Utilities.hs 33.7 KB
Newer Older
1
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
Henrik Tramberend's avatar
Henrik Tramberend committed
2
module Utilities
3
  ( spawn
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
  , terminate
  , threadDelay'
  , wantRepeat
  , defaultContext
  , runShakeInContext
  , watchFiles
  , dropSuffix
  , stopServer
  , startServer
  , runHttpServer
  , writeIndex
  , readMetaDataForDir
  , substituteMetaData
  , markdownToHtmlDeck
  , markdownToHtmlHandout
  , markdownToPdfHandout
  , markdownToHtmlPage
  , markdownToPdfPage
  , writeExampleProject
  , metaValueAsString
  , (<++>)
  , replaceSuffixWith
  , writeEmbeddedFiles
  , getRelativeSupportDir
  , pandocMakePdf
  , isCacheableURI
  , adjustLocalUrl
  , cacheRemoteFile
  , cacheRemoteImages
  , makeRelativeTo
  , fixMustacheMarkup
  , fixMustacheMarkupText
  , globA
  , globRelA
38
  , toPandocMeta
39
40
  , DeckerException(..)
  ) where
Henrik Tramberend's avatar
Henrik Tramberend committed
41

Henrik Tramberend's avatar
Henrik Tramberend committed
42
import Common
43
44
import Context
import Control.Arrow
Henrik Tramberend's avatar
Henrik Tramberend committed
45
46
import Control.Concurrent
import Control.Exception
47
import Control.Monad
48
import Control.Monad.IO.Class (MonadIO)
49
50
51
52
53
54
55
56
import Control.Monad.Loops
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Digest.Pure.MD5
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.HashMap.Strict as H
import Data.IORef
57
import Data.List
Henrik Tramberend's avatar
Henrik Tramberend committed
58
import Data.List.Extra
59
import qualified Data.Map.Lazy as Map
Henrik Tramberend's avatar
Henrik Tramberend committed
60
import Data.Maybe
61
import qualified Data.Set as Set
Henrik Tramberend's avatar
Henrik Tramberend committed
62
import qualified Data.Text as T
63
import qualified Data.Text.Encoding as E
64
65
import qualified Data.Vector as Vec
import qualified Data.Yaml as Y
66
67

-- import Debug.Trace
68
69
70
71
72
73
74
75
import Development.Shake
import Development.Shake.FilePath as SFP
import Embed
import Filter
import Network.HTTP.Conduit
import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Network.URI
Henrik Tramberend's avatar
Henrik Tramberend committed
76
import Project
77
import qualified System.Directory as Dir
78
import System.FilePath as SF
Henrik Tramberend's avatar
Henrik Tramberend committed
79
import System.FilePath.Glob
Henrik Tramberend's avatar
Henrik Tramberend committed
80
import System.IO as S
81
82
83
import System.Process
import System.Process.Internals
import Text.CSL.Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
84
85
86
87
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Text.Pandoc
import Text.Pandoc.PDF
88
import Text.Pandoc.Shared
89
import Text.Pandoc.Walk
90
import Watch
91

92
93
-- Find the project directory and change current directory to there. 
-- The project directory is the first upwards directory that contains a .git directory entry.
94
calcProjectDirectory :: IO FilePath
95
calcProjectDirectory = do
96
  cwd <- Dir.getCurrentDirectory
97
98
99
100
101
  searchGitRoot cwd
  where
    searchGitRoot :: FilePath -> IO FilePath
    searchGitRoot path =
      if isDrive path
102
        then Dir.makeAbsolute "."
103
104
105
        else do
          hasGit <- Dir.doesDirectoryExist (path </> ".git")
          if hasGit
106
            then Dir.makeAbsolute path
107
            else searchGitRoot $ takeDirectory path
Henrik Tramberend's avatar
Henrik Tramberend committed
108

109
-- | Globs for files under the project dir in the Action monad. 
110
-- Returns absolute pathes.
111
globA :: FilePattern -> Action [FilePath]
112
globA pat = do
113
  dirs <- getProjectDirs
114
115
116
  liftIO $
    filter (not . isPrefixOf (public dirs)) <$>
    globDir1 (compile pat) (project dirs)
117
118
119
120

-- | Globs for files under the project dir in the Action monad. 
-- Returns pathes relative to the project directory. 
globRelA :: FilePattern -> Action [FilePath]
121
globRelA pat = do
122
  dirs <- getProjectDirs
123
  files <- globA pat
124
  return $ map (makeRelative (project dirs)) files
125

Henrik Tramberend's avatar
Henrik Tramberend committed
126
127
128
129
-- Utility functions for shake based apps
spawn :: String -> Action ProcessHandle
spawn = liftIO . spawnCommand

130
-- Runs liveroladx on the given directory, if it is not already running. If
Henrik Tramberend's avatar
Henrik Tramberend committed
131
-- open is True a browser window is opended.
132
133
134
runHttpServer dir open = do
  process <- getServerHandle
  case process of
135
    Just _ -> return ()
136
137
138
139
140
141
    Nothing -> do
      putNormal "# livereloadx (on http://localhost:8888, see server.log)"
      handle <-
        spawn $ "livereloadx -s -p 8888 -d 500 " ++ dir ++ " 2>&1 > server.log"
      setServerHandle $ Just handle
      threadDelay' 200000
142
      when open $ cmd ("open http://localhost:8888/" :: String) :: Action ()
Henrik Tramberend's avatar
Henrik Tramberend committed
143

Henrik Tramberend's avatar
Henrik Tramberend committed
144
startServer :: Control.Monad.IO.Class.MonadIO m => String -> String -> m ()
145
startServer id command =
146
147
148
  liftIO $ do
    processHandle <- spawnCommand command
    withProcessHandle processHandle handleResult
149
150
151
152
153
154
155
156
  where
    handleResult ph =
      case ph of
        ClosedHandle e ->
          print $ "Error starting server " ++ id ++ ": " ++ show e
        OpenHandle p -> do
          print $ "Server " ++ id ++ " running (" ++ show p ++ ")"
          writeFile (id ++ ".pid") (show p)
Henrik Tramberend's avatar
Henrik Tramberend committed
157

158
stopServer id =
159
160
161
162
163
164
165
  liftIO $ do
    let pidFile = id ++ ".pid"
    result <- try $ readFile pidFile
    case result of
      Left (SomeException e) -> print $ "Unable to read file " ++ pidFile
      Right pid -> do
        exitCode <- system ("kill -9 " ++ pid)
166
        Dir.removeFile pidFile
Henrik Tramberend's avatar
Henrik Tramberend committed
167
168
169
170
171
172
173
174
175
176

terminate :: ProcessHandle -> Action ()
terminate = liftIO . terminateProcess

threadDelay' :: Int -> Action ()
threadDelay' = liftIO . threadDelay

wantRepeat :: IORef Bool -> Action ()
wantRepeat justOnce = liftIO $ writeIORef justOnce False

177
178
-- The context of program invocation consists of a list of
-- files to watch and a possibly running local http server.
Henrik Tramberend's avatar
Henrik Tramberend committed
179
180
181
182
183
184
data Context =
  Context [FilePath]
          (Maybe ProcessHandle)

defaultContext = Context [] Nothing

185
runShakeInContext :: ActionContext -> ShakeOptions -> Rules () -> IO ()
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
runShakeInContext context options rules = do
  opts <- setActionContext context options
  catch
    (untilM_ (tryRunShake opts) nothingToWatch)
    (\(SomeException e) -> putStrLn $ "Terminated: " ++ show e)
  cleanup
  where
    tryRunShake opts =
      catch (shakeArgs opts rules) (\(SomeException e) -> return ())
    cleanup = do
      process <- readIORef $ ctxServerHandle context
      case process of
        Just handle -> terminateProcess handle
        Nothing -> return ()
    nothingToWatch = do
      files <- readIORef $ ctxFilesToWatch context
      if null files
        then return True
        else do
205
          waitForTwitchPassive files
206
          return False
Henrik Tramberend's avatar
Henrik Tramberend committed
207

208
watchFiles = setFilesToWatch
Henrik Tramberend's avatar
Henrik Tramberend committed
209
210

-- | Monadic version of list concatenation.
211
(<++>) :: Monad m => m [a] -> m [a] -> m [a]
212
(<++>) = liftM2 (++)
Henrik Tramberend's avatar
Henrik Tramberend committed
213
214
215
216
217

-- | Removes the last suffix from a filename
dropSuffix s t = fromMaybe t (stripSuffix s t)

-- | Monadic version of suffix replacement for easy binding.
218
replaceSuffixWith :: String -> String -> [FilePath] -> Action [FilePath]
219
replaceSuffixWith suffix with pathes =
Henrik Tramberend's avatar
Henrik Tramberend committed
220
221
  return [dropSuffix suffix d ++ with | d <- pathes]

222
-- | Monadic version of suffix replacement for easy binding.
223
224
calcTargetPath ::
     FilePath -> String -> String -> [FilePath] -> Action [FilePath]
225
226
227
228
calcTargetPath projectDir suffix with pathes =
  return [projectDir </> dropSuffix suffix d ++ with | d <- pathes]

-- | Generates an index.md file with links to all generated files of interest.
229
230
231
232
writeIndex out baseUrl decks handouts pages = do
  let decksLinks = map (makeRelative baseUrl) decks
  let handoutsLinks = map (makeRelative baseUrl) handouts
  let pagesLinks = map (makeRelative baseUrl) pages
233
  dirs <- getProjectDirs
234
235
236
237
238
  liftIO $
    writeFile out $
    unlines
      [ "---"
      , "title: Generated Index"
Henrik Tramberend's avatar
Henrik Tramberend committed
239
      , "subtitle: " ++ project dirs
240
241
242
243
244
245
246
247
248
249
250
      , "---"
      , "# Slide decks"
      , unlines $ map makeLink $ sort decksLinks
      , "# Handouts"
      , unlines $ map makeLink $ sort handoutsLinks
      , "# Supporting Documents"
      , unlines $ map makeLink $ sort pagesLinks
      ]
  where
    makeLink path = "-    [" ++ takeFileName path ++ "](" ++ path ++ ")"

251
252
253
254
255
256
joinMeta :: Y.Value -> Y.Value -> Y.Value
joinMeta (Y.Object old) (Y.Object new) = Y.Object (H.union new old)
joinMeta (Y.Object old) _ = Y.Object old
joinMeta _ (Y.Object new) = Y.Object new
joinMeta _ _ = throw $ YamlException "Can only join YAML objects."

257
readMetaDataForDir :: FilePath -> Action Y.Value
258
259
260
readMetaDataForDir dir = walkUpTo dir
  where
    walkUpTo dir = do
261
262
      dirs <- getProjectDirs
      if equalFilePath (project dirs) dir
263
264
265
266
267
        then collectMeta dir
        else do
          fromAbove <- walkUpTo (takeDirectory dir)
          fromHere <- collectMeta dir
          return $ joinMeta fromHere fromAbove
268
269
    --
    collectMeta dir = do
270
271
272
273
      files <- liftIO $ globDir1 (compile "*-meta.yaml") dir
      need files
      meta <- mapM decodeYaml files
      return $ foldl joinMeta (Y.object []) meta
274
275
    --
    decodeYaml yamlFile = do
276
277
278
279
280
281
282
      result <- liftIO $ Y.decodeFileEither yamlFile
      case result of
        Right object@(Y.Object _) -> return object
        Right _ ->
          throw $
          YamlException $ "Top-level meta value must be an object: " ++ dir
        Left exception -> throw exception
Henrik Tramberend's avatar
Henrik Tramberend committed
283

284
285
286
287
288
289
-- | Fixes pandoc escaped # markup in mustache template {{}} markup.
fixMustacheMarkup :: B.ByteString -> T.Text
fixMustacheMarkup content = fixMustacheMarkupText $ E.decodeUtf8 content

-- | Fixes pandoc escaped # markup in mustache template {{}} markup.
fixMustacheMarkupText :: T.Text -> T.Text
290
291
292
293
294
295
fixMustacheMarkupText content =
  T.replace
    (T.pack "{{\\#")
    (T.pack "{{#")
    (T.replace (T.pack "{{\\^") (T.pack "{{^") content)

296
297
298
299
300
301
302
303
substituteMetaData :: T.Text -> MT.Value -> T.Text
substituteMetaData text metaData = do
  let fixed = fixMustacheMarkupText text
  let result = M.compileTemplate "internal" fixed
  case result of
    Right template -> M.substituteValue template metaData
    Left err -> throw $ MustacheException (show err)

304
getRelativeSupportDir :: FilePath -> Action FilePath
305
getRelativeSupportDir from = do
306
  dirs <- getProjectDirs
307
  return $
308
309
    invertPath (makeRelative (public dirs) (takeDirectory from)) </>
    makeRelative (public dirs) (support dirs)
Henrik Tramberend's avatar
Henrik Tramberend committed
310
311

invertPath :: FilePath -> FilePath
312
invertPath fp = joinPath $ map (const "..") $ filter ("." /=) $ splitPath fp
Henrik Tramberend's avatar
Henrik Tramberend committed
313
314

-- | Write a markdown file to a HTML file using the page template.
315
316
317
318
319
markdownToHtmlDeck :: FilePath -> FilePath -> Action ()
markdownToHtmlDeck markdownFile out = do
  supportDir <- getRelativeSupportDir out
  let options =
        pandocWriterOpts
320
321
        { writerTemplate = Just deckTemplate
        -- , writerStandalone = True
322
        , writerHighlight = True
323
        -- , writerHighlightStyle = pygments
324
        , writerHTMLMathMethod =
325
326
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
327
328
329
330
        -- ,writerHTMLMathMethod =
        --    KaTeX (supportDir </> "katex-0.6.0/katex.min.js")
        --          (supportDir </> "katex-0.6.0/katex.min.css")
        , writerVariables =
Henrik Tramberend's avatar
Henrik Tramberend committed
331
            [ ("revealjs-url", supportDir </> "reveal.js-3.5.0")
332
333
            , ("decker-support-dir", supportDir)
            ]
334
335
336
337
338
        , writerCiteMethod = Citeproc
        }
  pandoc <- readAndPreprocessMarkdown markdownFile
  processed <- processPandocDeck "revealjs" pandoc
  writePandocString "revealjs" options out processed
339

Henrik Tramberend's avatar
Henrik Tramberend committed
340
341
342
343
344
345
346
347
348
349
-- | Selects a matching pandoc string writer for the format string, or throws an
-- exception.
getPandocWriter :: String -> StringWriter
getPandocWriter format =
  case getWriter format of
    Right (PureStringWriter w) -> w
    Left e -> throw $ PandocException e
    _ -> throw $ PandocException $ "No writer for format: " ++ format

-- | Reads a markdownfile, expands the included files, and substitutes mustache
350
351
-- template variables and calls need.
readAndPreprocessMarkdown :: FilePath -> Action Pandoc
352
readAndPreprocessMarkdown markdownFile = do
Henrik Tramberend's avatar
Henrik Tramberend committed
353
  putLoud $ "reading: " ++ markdownFile
354
  dirs <- getProjectDirs
355
  let baseDir = takeDirectory markdownFile
Henrik Tramberend's avatar
Henrik Tramberend committed
356
  pandoc@(Pandoc meta bocks) <-
Henrik Tramberend's avatar
Henrik Tramberend committed
357
    readMetaMarkdown markdownFile >>= processIncludes dirs baseDir
Henrik Tramberend's avatar
Henrik Tramberend committed
358
359
360
  let method = provisioningFromMeta meta
  liftIO $
    mapMetaResources (provisionMetaResource method dirs baseDir) pandoc >>=
Henrik Tramberend's avatar
Henrik Tramberend committed
361
362
363
    mapResources (provisionExistingResource method dirs baseDir) >>=
    walkM renderImageVideo
      -- Disable automatic caching of remote images for a while
364
  -- >>= populateCache
Henrik Tramberend's avatar
Henrik Tramberend committed
365

Henrik Tramberend's avatar
Henrik Tramberend committed
366
367
368
369
370
371
372
373
374
provisionMetaResource ::
     Provisioning
  -> ProjectDirs
  -> FilePath
  -> (String, FilePath)
  -> IO FilePath
provisionMetaResource method dirs base (key, path)
  | key `elem` runtimeMetaKeys = provisionResource method dirs base path
provisionMetaResource method dirs base (key, path)
Henrik Tramberend's avatar
Henrik Tramberend committed
375
  | key `elem` compiletimeMetaKeys = findLocalFile dirs base path
Henrik Tramberend's avatar
Henrik Tramberend committed
376
377
provisionMetaResource _ _ _ (key, path) = return path

Henrik Tramberend's avatar
Henrik Tramberend committed
378
populateCache :: Pandoc -> Action Pandoc
379
populateCache pandoc = do
380
381
  dirs <- getProjectDirs
  liftIO $ walkM (cacheRemoteImages (cache dirs)) pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
382

Henrik Tramberend's avatar
Henrik Tramberend committed
383
-- | Write a markdown file to a HTML file using the page template.
384
385
386
387
388
389
markdownToHtmlPage :: FilePath -> FilePath -> Action ()
markdownToHtmlPage markdownFile out = do
  supportDir <- getRelativeSupportDir out
  let options =
        pandocWriterOpts
        { writerHtml5 = True
390
391
        -- , writerStandalone = True
        , writerTemplate = Just pageTemplate
392
        , writerHighlight = True
393
        -- , writerHighlightStyle = pygments
394
        , writerHTMLMathMethod =
395
396
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
397
398
399
400
401
402
403
404
405
        -- ,writerHTMLMathMethod =
        --    KaTeX (supportDir </> "katex-0.6.0/katex.min.js")
        --          (supportDir </> "katex-0.6.0/katex.min.css")
        , writerVariables = [("decker-support-dir", supportDir)]
        , writerCiteMethod = Citeproc
        }
  pandoc <- readAndPreprocessMarkdown markdownFile
  processed <- processPandocPage "html5" pandoc
  writePandocString "html5" options out processed
Henrik Tramberend's avatar
Henrik Tramberend committed
406
407

-- | Write a markdown file to a PDF file using the handout template.
408
409
410
411
markdownToPdfPage :: FilePath -> FilePath -> Action ()
markdownToPdfPage markdownFile out = do
  let options =
        pandocWriterOpts
412
413
        { writerTemplate = Just pageLatexTemplate
        -- , writerStandalone = True
414
        , writerHighlight = True
415
        -- , writerHighlightStyle = pygments
416
417
418
419
420
421
422
423
424
425
426
427
        , writerCiteMethod = Citeproc
        }
  pandoc <- readAndPreprocessMarkdown markdownFile
  processed <- processPandocPage "latex" pandoc
  putNormal $ "# pandoc (for " ++ out ++ ")"
  pandocMakePdf options processed out

pandocMakePdf options processed out = do
  result <- liftIO $ makePDF "pdflatex" writeLaTeX options processed
  case result of
    Left err -> throw $ PandocException (show err)
    Right pdf -> liftIO $ LB.writeFile out pdf
Henrik Tramberend's avatar
Henrik Tramberend committed
428
429

-- | Write a markdown file to a HTML file using the handout template.
430
431
432
433
434
435
436
437
markdownToHtmlHandout :: FilePath -> FilePath -> Action ()
markdownToHtmlHandout markdownFile out = do
  pandoc <- readAndPreprocessMarkdown markdownFile
  processed <- processPandocHandout "html" pandoc
  supportDir <- getRelativeSupportDir out
  let options =
        pandocWriterOpts
        { writerHtml5 = True
438
        , writerTemplate = Just handoutTemplate
439
        , writerHighlight = True
440
        -- , writerHighlightStyle = pygments
441
        , writerHTMLMathMethod =
442
443
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
444
445
446
447
        , writerVariables = [("decker-support-dir", supportDir)]
        , writerCiteMethod = Citeproc
        }
  writePandocString "html5" options out processed
Henrik Tramberend's avatar
Henrik Tramberend committed
448
449

-- | Write a markdown file to a PDF file using the handout template.
450
markdownToPdfHandout :: FilePath -> FilePath -> Action ()
451
markdownToPdfHandout markdownFile out = do
452
453
454
455
  pandoc <- readAndPreprocessMarkdown markdownFile
  processed <- processPandocHandout "latex" pandoc
  let options =
        pandocWriterOpts
456
457
        { writerTemplate = Just handoutLatexTemplate
        -- , writerStandalone = True
458
        , writerHighlight = True
459
        -- , writerHighlightStyle = pygments
460
461
462
463
        , writerCiteMethod = Citeproc
        }
  putNormal $ "# pandoc (for " ++ out ++ ")"
  pandocMakePdf options processed out
464

465
-- | Reads a markdown file and returns a pandoc document. 
466
readMetaMarkdown :: FilePath -> Action Pandoc
467
468
readMetaMarkdown markdownFile = do
  need [markdownFile]
469
  -- read external meta data for this directory
Henrik Tramberend's avatar
Henrik Tramberend committed
470
  externalMeta <- readMetaDataForDir (takeDirectory markdownFile)
471
  -- extract embedded meta data from the document
Henrik Tramberend's avatar
Henrik Tramberend committed
472
473
474
  markdown <- liftIO $ S.readFile markdownFile
  let Pandoc meta _ = readMarkdownOrThrow pandocReaderOpts markdown
  let documentMeta = MetaMap $ unMeta meta
475
  -- combine the meta data with preference on the embedded data
Henrik Tramberend's avatar
Henrik Tramberend committed
476
477
478
479
480
481
482
483
484
  let combinedMeta = mergePandocMeta documentMeta (toPandocMeta externalMeta)
  let mustacheMeta = toMustacheMeta combinedMeta
   -- use mustache to substitute
  let substituted = substituteMetaData (T.pack markdown) mustacheMeta
  -- read markdown with substitutions again
  let Pandoc _ blocks =
        readMarkdownOrThrow pandocReaderOpts $ T.unpack substituted
  let (MetaMap m) = combinedMeta
  let pandoc = Pandoc (Meta m) blocks
485
  -- adjust image urls
486
  dirs <- getProjectDirs
Henrik Tramberend's avatar
Henrik Tramberend committed
487
  -- TODO: This has to go
488
  -- return $ walk (adjustImageUrls (project dirs) (takeDirectory markdownFile)) pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
489
  -- TODO: Make this work further down
490
  -- provisionResources dirs (takeDirectory markdownFile) pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
491
  liftIO $ mapResources (findLocalFile dirs (takeDirectory markdownFile)) pandoc
492
493
494
495
496
497

readMarkdownOrThrow :: ReaderOptions -> String -> Pandoc
readMarkdownOrThrow opts string =
  case readMarkdown opts string of
    Right pandoc -> pandoc
    Left err -> throw $ PandocException (show err)
498

Henrik Tramberend's avatar
Henrik Tramberend committed
499
500
-- | Converts pandoc meta data to mustache meta data. Inlines and blocks are
-- rendered to markdown strings with default options.
501
502
503
504
505
506
507
508
toMustacheMeta :: MetaValue -> MT.Value
toMustacheMeta (MetaMap mmap) =
  MT.Object $ H.fromList $ map (T.pack *** toMustacheMeta) $ Map.toList mmap
toMustacheMeta (MetaList a) = MT.Array $ Vec.fromList $ map toMustacheMeta a
toMustacheMeta (MetaBool bool) = MT.Bool bool
toMustacheMeta (MetaString string) = MT.String $ T.pack string
toMustacheMeta (MetaInlines inlines) =
  MT.String $
Henrik Tramberend's avatar
Henrik Tramberend committed
509
  T.pack $ writeMarkdown def (Pandoc (Meta Map.empty) [Plain inlines])
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
toMustacheMeta (MetaBlocks blocks) =
  MT.String $ T.pack $ writeMarkdown def (Pandoc (Meta Map.empty) blocks)

mergePandocMeta :: MetaValue -> MetaValue -> MetaValue
mergePandocMeta (MetaMap left) (MetaMap right) = MetaMap $ Map.union left right
mergePandocMeta left _ = left

-- | Converts YAML meta data to pandoc meta data.
toPandocMeta :: Y.Value -> MetaValue
toPandocMeta (Y.Object m) =
  MetaMap $ Map.fromList $ map (T.unpack *** toPandocMeta) $ H.toList m
toPandocMeta (Y.Array vector) = MetaList $ map toPandocMeta $ Vec.toList vector
toPandocMeta (Y.String text) = MetaString $ T.unpack text
toPandocMeta (Y.Number scientific) = MetaString $ show scientific
toPandocMeta (Y.Bool bool) = MetaBool bool
Henrik Tramberend's avatar
Henrik Tramberend committed
525
toPandocMeta Y.Null = MetaList []
526

527
-- Remove automatic identifier creation for headers. It does not work well with
528
-- the current include mechanism if slides have duplicate titles in separate
529
530
531
532
533
-- include files.
deckerPandocExtensions :: Set.Set Extension
deckerPandocExtensions = Set.delete Ext_auto_identifiers pandocExtensions

pandocReaderOpts :: ReaderOptions
534
pandocReaderOpts = def {readerExtensions = deckerPandocExtensions}
535
536

pandocWriterOpts :: WriterOptions
537
pandocWriterOpts = def {writerExtensions = deckerPandocExtensions}
538

539
540
541
542
543
544
545
546
547
isLocalURI :: String -> Bool
isLocalURI url = isNothing $ parseURI url

isRemoteURI :: String -> Bool
isRemoteURI = not . isLocalURI

isCacheableURI :: String -> Bool
isCacheableURI url =
  case parseURI url of
548
    Just uri -> uriScheme uri `elem` ["http:", "https:"]
549
550
551
552
553
554
555
    Nothing -> False

-- | Walks over all images in a Pandoc document and transforms image URLs like
-- this: 1. Remote URLs are not transformed. 2. Absolute URLs are intepreted
-- relative to the project root directory. 3. Relative URLs are intepreted
-- relative to the containing document.
adjustImageUrls :: FilePath -> FilePath -> Pandoc -> Pandoc
556
adjustImageUrls projectDir baseDir = walk adjustBlock . walk adjustInline
557
  where
558
559
    adjustInline (Image attr inlines (url, title)) =
      Image attr inlines (adjustLocalUrl projectDir baseDir url, title)
560
561
    adjustInline other = other
    adjustBlock (Header 1 attr inlines) =
562
      Header 1 (adjustBgImageUrl attr) inlines
563
    adjustBlock other = other
564
565
566
567
568
    adjustBgImageUrl (i, cs, kvs) =
      ( i
      , cs
      , map
          (\(k, v) ->
569
570
571
             if k == "data-background-image" || k == "data-background-video"
               then (k, adjustLocalUrl projectDir baseDir v)
               else (k, v))
572
          kvs)
573
574
575
576

adjustLocalUrl :: FilePath -> FilePath -> FilePath -> FilePath
adjustLocalUrl root base url
  | isLocalURI url =
577
578
579
    if isAbsolute url
      then root </> makeRelative "/" url
      else base </> url
580
581
adjustLocalUrl _ _ url = url

Henrik Tramberend's avatar
Henrik Tramberend committed
582
locateTemplates :: FilePath -> FilePath -> Pandoc -> Action Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
583
locateTemplates root base (Pandoc meta blocks) = return (Pandoc meta blocks)
Henrik Tramberend's avatar
Henrik Tramberend committed
584

585
586
587
588
589
590
591
592
593
594
595
mapResources :: (FilePath -> IO FilePath) -> Pandoc -> IO Pandoc
mapResources transform pandoc@(Pandoc meta blocks) = do
  processedBlocks <-
    walkM (mapInline transform) blocks >>= walkM (mapBlock transform)
  return (Pandoc meta processedBlocks)

mapAttributes :: (FilePath -> IO FilePath) -> Attr -> IO Attr
mapAttributes transform (ident, classes, kv) = do
  processed <- mapM mapAttr kv
  return (ident, classes, processed)
  where
Henrik Tramberend's avatar
Henrik Tramberend committed
596
597
    mapAttr kv@(key, value) =
      if key `elem` elementAttributes
598
599
600
601
602
603
        then do
          transformed <- transform value
          return (key, transformed)
        else return kv

mapInline :: (FilePath -> IO FilePath) -> Inline -> IO Inline
Henrik Tramberend's avatar
Henrik Tramberend committed
604
mapInline transform img@(Image attr@(_, cls, _) inlines (url, title)) =
605
606
607
608
  if not $ isMacro $ stringify inlines
    then do
      a <- mapAttributes transform attr
      u <- transform url
Henrik Tramberend's avatar
Henrik Tramberend committed
609
      return $ Image a inlines (u, title)
610
    else return img
Henrik Tramberend's avatar
Henrik Tramberend committed
611
612
mapInline transform lnk@(Link attr@(_, cls, _) inlines (url, title)) =
  if not (isMacro $ stringify inlines) && "resource" `elem` cls
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
    then do
      a <- mapAttributes transform attr
      u <- transform url
      return (Link a inlines (u, title))
    else return lnk
mapInline transform (Span attr inlines) = do
  attribs <- mapAttributes transform attr
  return (Span attribs inlines)
mapInline transform (Code attr string) = do
  attribs <- mapAttributes transform attr
  return (Code attribs string)
mapInline _ inline = return inline

mapBlock :: (FilePath -> IO FilePath) -> Block -> IO Block
mapBlock transform (CodeBlock attr string) = do
  attribs <- mapAttributes transform attr
  return (CodeBlock attribs string)
mapBlock transform (Header n attr inlines) = do
  attribs <- mapAttributes transform attr
  return (Header n attribs inlines)
mapBlock transform (Div attr blocks) = do
  attribs <- mapAttributes transform attr
  return (Div attribs blocks)
mapBlock _ block = return block

Henrik Tramberend's avatar
Henrik Tramberend committed
638
mapMetaResources :: ((String, FilePath) -> IO FilePath) -> Pandoc -> IO Pandoc
639
640
641
642
643
644
mapMetaResources transform (Pandoc (Meta kvmap) blocks) = do
  mapped <- mapM mapMeta $ Map.toList kvmap
  return $ Pandoc (Meta $ Map.fromList mapped) blocks
  where
    mapMeta (k, MetaString v)
      | k `elem` metaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
645
        transformed <- transform (k, v)
646
647
648
        return (k, MetaString transformed)
    mapMeta (k, MetaInlines inlines)
      | k `elem` metaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
649
        transformed <- transform (k, stringify inlines)
650
651
652
        return (k, MetaString transformed)
    mapMeta (k, MetaList l)
      | k `elem` metaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
653
        transformed <- mapM (mapMetaList k) l
654
655
        return (k, MetaList transformed)
    mapMeta kv = return kv
Henrik Tramberend's avatar
Henrik Tramberend committed
656
657
658
659
    mapMetaList k (MetaString v) = MetaString <$> transform (k, v)
    mapMetaList k (MetaInlines inlines) =
      MetaString <$> transform (k, stringify inlines)
    mapMetaList _ v = return v
660

661
662
663
664
665
666
667
668
669
670
provisionResources :: ProjectDirs -> FilePath -> Pandoc -> Action Pandoc
provisionResources dirs base pandoc@(Pandoc meta blocks) = do
  let method = provisioningFromMeta meta
  liftIO $ do
    processedBlocks <-
      walkM (processInline dirs base method) blocks >>=
      walkM (processBlock dirs base method)
    processedMeta <- processMeta dirs base method meta
    return (Pandoc processedMeta processedBlocks)

Henrik Tramberend's avatar
Henrik Tramberend committed
671
672
673
-- | These resources are needed at runtime. If they are specified as local URLs,
-- the resource must exists at compile time. Remote URLs are passed through
-- unchanged.
674
675
676
677
678
679
680
681
682
elementAttributes =
  [ "src"
  , "data-src"
  , "data-markdown"
  , "data-background-video"
  , "data-background-image"
  , "data-background-iframe"
  ]

Henrik Tramberend's avatar
Henrik Tramberend committed
683
684
685
686
687
688
689
-- | Resources in meta data that are needed at compile time. They have to be
-- specified as local URLs and must exist.
runtimeMetaKeys = ["css"]

compiletimeMetaKeys = ["bibliography", "csl", "citation-abbreviations"]

metaKeys = runtimeMetaKeys ++ compiletimeMetaKeys
690
691
692
693
694
695

processAttributes :: ProjectDirs -> FilePath -> Provisioning -> Attr -> IO Attr
processAttributes dirs base method (ident, classes, kv) = do
  processed <- mapM provisionAttrib kv
  return (ident, classes, processed)
  where
Henrik Tramberend's avatar
Henrik Tramberend committed
696
697
698
699
700
701
    provisionAttrib (key, path)
      | key `elem` runtimeMetaKeys = do
        resource <- provisionResource method dirs base path
        return (key, resource)
    provisionAttrib (key, path)
      | key `elem` compiletimeMetaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
702
        local <- findLocalFile dirs base path
Henrik Tramberend's avatar
Henrik Tramberend committed
703
704
        return (key, local)
    provisionAttrib (key, path) = return (key, path)
705
706

processInline :: ProjectDirs -> FilePath -> Provisioning -> Inline -> IO Inline
Henrik Tramberend's avatar
Henrik Tramberend committed
707
processInline dirs base method img@(Image attr@(_, cls, _) inlines (url, title)) =
708
709
710
711
  if not $ isMacro $ stringify inlines
    then do
      a <- processAttributes dirs base method attr
      u <- provisionResource (provisioningFromClasses method cls) dirs base url
Henrik Tramberend's avatar
Henrik Tramberend committed
712
      return $ Image a inlines (u, title)
713
    else return img
Henrik Tramberend's avatar
Henrik Tramberend committed
714
processInline dirs base method lnk@(Link attr@(_, cls, _) inlines (url, title)) =
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
  if not (isMacro $ stringify inlines) && "resource" `elem` cls
    then do
      a <- processAttributes dirs base method attr
      u <- provisionResource (provisioningFromClasses method cls) dirs base url
      return (Link a inlines (u, title))
    else return lnk
processInline dirs base method (Span attr inlines) = do
  processed <- processAttributes dirs base method attr
  return (Span processed inlines)
processInline dirs base method (Code attr string) = do
  processed <- processAttributes dirs base method attr
  return (Code processed string)
processInline _ _ _ inline = return inline

processBlock :: ProjectDirs -> FilePath -> Provisioning -> Block -> IO Block
processBlock dirs base method (CodeBlock attr string) = do
  processed <- processAttributes dirs base method attr
  return (CodeBlock attr string)
processBlock dirs base method (Header n attr inlines) = do
  processed <- processAttributes dirs base method attr
  return (Header n attr inlines)
processBlock dirs base method (Div attr blocks) = do
  processed <- processAttributes dirs base method attr
  return (Div attr blocks)
processBlock _ _ _ block = return block

processMeta :: ProjectDirs -> FilePath -> Provisioning -> Meta -> IO Meta
processMeta dirs base method (Meta kvmap) = return (Meta kvmap)

Henrik Tramberend's avatar
Henrik Tramberend committed
744
-- Transitively splices all include files into the pandoc document.
Henrik Tramberend's avatar
Henrik Tramberend committed
745
746
processIncludes :: ProjectDirs -> FilePath -> Pandoc -> Action Pandoc
processIncludes dirs baseDir (Pandoc meta blocks) = do
747
748
  included <- processBlocks baseDir blocks
  return $ Pandoc meta included
749
750
751
  where
    processBlocks :: FilePath -> [Block] -> Action [Block]
    processBlocks base blcks = do
752
753
      spliced <- foldM (include base) [] blcks
      return $ concat $ reverse spliced
754
    include :: FilePath -> [[Block]] -> Block -> Action [[Block]]
755
    include base result (Para [Link _ [Str ":include"] (url, _)]) = do
Henrik Tramberend's avatar
Henrik Tramberend committed
756
      filePath <- liftIO $ findFile dirs base url
757
758
759
      Pandoc _ b <- readMetaMarkdown filePath
      included <- processBlocks (takeDirectory filePath) b
      return $ included : result
760
    include _ result block = return $ [block] : result
761

Henrik Tramberend's avatar
Henrik Tramberend committed
762
cacheRemoteImages :: FilePath -> Pandoc -> IO Pandoc
763
cacheRemoteImages cacheDir = walkM cacheRemoteImage
764
  where
765
766
767
    cacheRemoteImage (Image attr inlines (url, title)) = do
      cachedFile <- cacheRemoteFile cacheDir url
      return (Image attr inlines (cachedFile, title))
768
    cacheRemoteImage img = return img
Henrik Tramberend's avatar
Henrik Tramberend committed
769
770
771

cacheRemoteFile :: FilePath -> String -> IO FilePath
cacheRemoteFile cacheDir url
772
  | isCacheableURI url = do
773
774
775
776
777
778
    let cacheFile = cacheDir </> hashURI url
    exists <- Dir.doesFileExist cacheFile
    if exists
      then return cacheFile
      else catch
             (do content <- downloadUrl url
779
                 Dir.createDirectoryIfMissing True cacheDir
780
781
782
783
784
                 LB.writeFile cacheFile content
                 return cacheFile)
             (\e -> do
                putStrLn $ "Warning: " ++ show (e :: SomeException)
                return url)
Henrik Tramberend's avatar
Henrik Tramberend committed
785
786
cacheRemoteFile _ url = return url

787
788
789
790
791
792
793
-- clearCachedFile :: FilePath -> String -> IO ()
-- clearCachedFile cacheDir url
--   | isCacheableURI url = do
--     let cacheFile = cacheDir </> hashURI url
--     exists <- Dir.doesFileExist cacheFile
--     when exists $ Dir.removeFile cacheFile
-- clearCachedFile _ _ = return ()
Henrik Tramberend's avatar
Henrik Tramberend committed
794
downloadUrl :: String -> IO LB.ByteString
795
downloadUrl url = do
796
797
798
799
800
801
802
803
804
805
806
807
  request <- parseRequest url
  result <- httpLBS request
  let status = getResponseStatus result
  if status == ok200
    then return $ getResponseBody result
    else throw $
         HttpException $
         "Cannot download " ++
         url ++
         " (" ++
         show (statusCode status) ++
         " " ++ B.unpack (statusMessage status) ++ ")"
Henrik Tramberend's avatar
Henrik Tramberend committed
808
809

hashURI :: String -> String
810
hashURI uri = show (md5 $ L8.pack uri) SF.<.> SF.takeExtension uri
Henrik Tramberend's avatar
Henrik Tramberend committed
811

812
processPandocPage :: String -> Pandoc -> Action Pandoc
813
processPandocPage format pandoc = do
814
  let f = Just (Format format)
815
  dirs <- getProjectDirs
816
  processed <-
817
818
    liftIO $ processCites' pandoc >>= walkM (useCachedImages (cache dirs))
  --  processed <- liftIO $ walkM (useCachedImages (cache dirs)) pandoc
819
820
821
822
823
  return $ expandMacros f processed

processPandocDeck :: String -> Pandoc -> Action Pandoc
processPandocDeck format pandoc = do
  let f = Just (Format format)
824
  dirs <- getProjectDirs
825
  processed <-
826
827
    liftIO $ processCites' pandoc >>= walkM (useCachedImages (cache dirs))
  -- processed <- liftIO $ walkM (useCachedImages cacheD(cache dirs)ir) pandoc
828
829
830
831
832
  return $ (makeSlides f . expandMacros f) processed

processPandocHandout :: String -> Pandoc -> Action Pandoc
processPandocHandout format pandoc = do
  let f = Just (Format format)
833
  dirs <- getProjectDirs
834
  processed <-
835
    liftIO $ processCites' (makeBoxes pandoc) >>= walkM (useCachedImages (cache dirs))
836
  -- processed <- liftIO $ walkM (useCachedImages (cache dirs)) pandoc
837
838
  -- return $ (expandMacros f . filterNotes f) processed
  return $ expandMacros f processed
Henrik Tramberend's avatar
Henrik Tramberend committed
839
840
841

type StringWriter = WriterOptions -> Pandoc -> String

842
writePandocString :: String -> WriterOptions -> FilePath -> Pandoc -> Action ()
843
844
845
846
847
writePandocString format options out pandoc = do
  let writer = getPandocWriter format
  final <- copyImages (takeDirectory out) pandoc
  writeFile' out (writer options final)
  putNormal $ "# pandoc for (" ++ out ++ ")"
Henrik Tramberend's avatar
Henrik Tramberend committed
848

Henrik Tramberend's avatar
Henrik Tramberend committed
849
copyImages :: FilePath -> Pandoc -> Action Pandoc
850
copyImages baseDir pandoc = do
851
852
853
  dirs <- getProjectDirs
  walkM (copyAndLinkInline (project dirs) (public dirs)) pandoc >>=
    walkM (copyAndLinkBlock (project dirs) (public dirs))
854
  where
855
856
857
    copyAndLinkInline project public (Image attr inlines (url, title)) = do
      relUrl <- copyAndLinkFile project public baseDir url
      return (Image attr inlines (relUrl, title))
858
859
    copyAndLinkInline _ _ inline = return inline
    copyAndLinkBlock project public (Header 1 attr inlines) = do
860
861
      relAttr <- copyBgImageUrl project public attr
      return (Header 1 relAttr inlines)
862
    copyAndLinkBlock _ _ block = return block
863
864
865
866
    copyBgImageUrl project public (i, cs, kvs) = do
      relKvs <-
        mapM
          (\(k, v) ->
867
868
869
870
871
             if k == "data-background-image"
               then do
                 relUrl <- copyAndLinkFile project public baseDir v
                 return (k, relUrl)
               else return (k, v))
872
873
874
          kvs
      return (i, cs, relKvs)

875
876
copyAndLinkFile ::
     FilePath -> FilePath -> FilePath -> FilePath -> Action FilePath
877
copyAndLinkFile project public base url = do
878
879
880
881
882
  let rel = makeRelative project url
  if rel == url
    then return url
    else do
      let pub = public </> rel
883
      liftIO $ Dir.createDirectoryIfMissing True (takeDirectory pub)
884
      copyFileChanged url pub
Henrik Tramberend's avatar
Henrik Tramberend committed
885
      return $ makeRelativeTo base pub
886
887
888

-- | Express the second path argument as relative to the first. 
-- Both arguments are expected to be absolute pathes. 
889
890
891
892
893
894
895
896
897
898
-- makeRelativeTo :: FilePath -> FilePath -> FilePath
-- makeRelativeTo dir file =
--   let (d, f) = removeCommonPrefix (splitDirectories dir) (splitDirectories file)
--   in normalise $ invertPath (joinPath d) </> joinPath f
-- removeCommonPrefix :: [FilePath] -> [FilePath] -> ([FilePath], [FilePath])
-- removeCommonPrefix al@(a:as) bl@(b:bs)
--  | a == b = removeCommonPrefix as bs
--  | otherwise = (al, bl)
-- removeCommonPrefix a [] = (a, [])
-- removeCommonPrefix [] b = ([], b)
Henrik Tramberend's avatar
Henrik Tramberend committed
899
writeExampleProject :: Action ()
900
writeExampleProject = mapM_ writeOne deckerExampleDir
901
  where
902
903
    writeOne (path, contents) = do
      exists <- Development.Shake.doesFileExist path
904
      unless exists $ do
905
        liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
906
907
        liftIO $ B.writeFile path contents
        putNormal $ "# create (for " ++ path ++ ")"
Henrik Tramberend's avatar
Henrik Tramberend committed
908

909
writeEmbeddedFiles :: [(FilePath, B.ByteString)] -> FilePath -> Action ()
Henrik Tramberend's avatar
Henrik Tramberend committed
910
911
912
913
writeEmbeddedFiles files dir
  -- let absolute = map (\(path, contents) -> (dir </> path, contents)) files
 = do
  let absolute = map (first (dir </>)) files
914
  mapM_ write absolute
915
  where
916
917
918
919
    write (path, contents) = do
      liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
      exists <- liftIO $ Dir.doesFileExist path
      unless exists $ liftIO $ B.writeFile path contents
920

Henrik Tramberend's avatar
Henrik Tramberend committed
921
lookupValue :: String -> Y.Value -> Maybe Y.Value
922
lookupValue key (Y.Object hashTable) = HashMap.lookup (T.pack key) hashTable
923
lookupValue _ _ = Nothing
Henrik Tramberend's avatar
Henrik Tramberend committed
924

925
metaValueAsString :: String -> Y.Value -> Maybe String
Henrik Tramberend's avatar
Henrik Tramberend committed
926
metaValueAsString key meta =
927
928
929
  case splitOn "." key of
    [] -> Nothing
    k:ks -> lookup' ks (lookupValue k meta)
930
931
  where
    lookup' :: [String] -> Maybe Y.Value -> Maybe String
932
    lookup' [] (Just (Y.String text)) = Just (T.unpack text)
933
934
935
936
    lookup' [] (Just (Y.Number n)) = Just (show n)
    lookup' [] (Just (Y.Bool b)) = Just (show b)
    lookup' (k:ks) (Just obj@(Y.Object _)) = lookup' ks (lookupValue k obj)
    lookup' _ _ = Nothing