Utilities.hs 27.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
  , threadDelay'
  , wantRepeat
  , defaultContext
  , runShakeInContext
  , watchFiles
  , dropSuffix
  , runHttpServer
  , writeIndex
  , readMetaDataForDir
  , substituteMetaData
  , markdownToHtmlDeck
  , markdownToHtmlHandout
  , markdownToPdfHandout
  , markdownToHtmlPage
  , markdownToPdfPage
  , writeExampleProject
  , metaValueAsString
  , (<++>)
  , replaceSuffixWith
  , writeEmbeddedFiles
  , getRelativeSupportDir
  , pandocMakePdf
  , isCacheableURI
  , adjustLocalUrl
  , cacheRemoteFile
  , cacheRemoteImages
  , fixMustacheMarkup
  , fixMustacheMarkupText
  , globA
33
  , toPandocMeta
34
  , reloadBrowsers
35
36
  , DeckerException(..)
  ) where
Henrik Tramberend's avatar
Henrik Tramberend committed
37

Henrik Tramberend's avatar
Henrik Tramberend committed
38
import Common
39
40
import Context
import Control.Arrow
Henrik Tramberend's avatar
Henrik Tramberend committed
41
42
import Control.Concurrent
import Control.Exception
43
import Control.Monad
44
import Control.Monad.IO.Class (MonadIO)
45
46
47
48
49
50
51
52
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
53
54
import Data.List as List
import Data.List.Extra as List
55
import qualified Data.Map.Lazy as Map
Henrik Tramberend's avatar
Henrik Tramberend committed
56
import Data.Maybe
57
import qualified Data.Set as Set
Henrik Tramberend's avatar
Henrik Tramberend committed
58
import qualified Data.Text as T
59
import qualified Data.Text.Encoding as E
60
61
62
63
64
65
66
67
68
69
import qualified Data.Vector as Vec
import qualified Data.Yaml as Y
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
70
import Project
71
import Server
72
import qualified System.Directory as Dir
73
import System.FilePath as SF
Henrik Tramberend's avatar
Henrik Tramberend committed
74
import System.FilePath.Glob
Henrik Tramberend's avatar
Henrik Tramberend committed
75
import System.IO as S
76
77
78
import System.Process
import System.Process.Internals
import Text.CSL.Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
79
80
81
82
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Text.Pandoc
import Text.Pandoc.PDF
83
import Text.Pandoc.Shared
84
import Text.Pandoc.Walk
85
import Watch
86

87
-- | Globs for files under the project dir in the Action monad. 
88
-- Returns absolute pathes.
89
globA :: FilePattern -> Action [FilePath]
90
globA pat = do
91
  dirs <- getProjectDirs
92
93
94
  liftIO $
    filter (not . isPrefixOf (public dirs)) <$>
    globDir1 (compile pat) (project dirs)
95

Henrik Tramberend's avatar
Henrik Tramberend committed
96
97
98
99
-- Utility functions for shake based apps
spawn :: String -> Action ProcessHandle
spawn = liftIO . spawnCommand

100
-- Runs liveroladx on the given directory, if it is not already running. If
Henrik Tramberend's avatar
Henrik Tramberend committed
101
-- open is True a browser window is opended.
102
103
104
105
runHttpServer :: ProjectDirs -> Bool -> Action ()
runHttpServer dirs open = do
  server <- getServerHandle
  case server of
106
    Just _ -> return ()
107
    Nothing -> do
108
109
110
111
112
113
114
115
116
117
118
      let port = 8888
      server <- liftIO $ startHttpServer dirs port
      setServerHandle $ Just server
      when open $ cmd ("open http://localhost:" ++ show port :: String) :: Action ()

reloadBrowsers :: Action ()
reloadBrowsers = do
  server <- getServerHandle
  case server of
    Just handle -> liftIO $ reloadClients handle
    Nothing -> return ()
Henrik Tramberend's avatar
Henrik Tramberend committed
119
120
121
122
123
124
125

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

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

126
127
-- 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
128
129
130
131
132
133
data Context =
  Context [FilePath]
          (Maybe ProcessHandle)

defaultContext = Context [] Nothing

134
runShakeInContext :: ActionContext -> ShakeOptions -> Rules () -> IO ()
135
136
137
138
139
140
141
142
runShakeInContext context options rules = do
  opts <- setActionContext context options
  catch
    (untilM_ (tryRunShake opts) nothingToWatch)
    (\(SomeException e) -> putStrLn $ "Terminated: " ++ show e)
  cleanup
  where
    tryRunShake opts =
143
      handle (\(SomeException e) -> return ()) (shakeArgs opts rules)
144
    cleanup = do
145
146
147
      server <- readIORef $ ctxServerHandle context
      case server of
        Just handle -> stopHttpServer handle
148
149
150
151
152
153
        Nothing -> return ()
    nothingToWatch = do
      files <- readIORef $ ctxFilesToWatch context
      if null files
        then return True
        else do
154
155
156
157
          server <- readIORef $ ctxServerHandle context
          case server of
            Just handle -> reloadClients handle
            Nothing -> return ()
158
          waitForTwitchPassive files
159
          return False
Henrik Tramberend's avatar
Henrik Tramberend committed
160

161
watchFiles = setFilesToWatch
Henrik Tramberend's avatar
Henrik Tramberend committed
162
163

-- | Monadic version of list concatenation.
164
(<++>) :: Monad m => m [a] -> m [a] -> m [a]
165
(<++>) = liftM2 (++)
Henrik Tramberend's avatar
Henrik Tramberend committed
166
167
168
169
170

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

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

175
-- | Monadic version of suffix replacement for easy binding.
176
177
calcTargetPath ::
     FilePath -> String -> String -> [FilePath] -> Action [FilePath]
178
179
180
181
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.
182
183
184
185
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
186
  dirs <- getProjectDirs
187
188
189
190
191
  liftIO $
    writeFile out $
    unlines
      [ "---"
      , "title: Generated Index"
Henrik Tramberend's avatar
Henrik Tramberend committed
192
      , "subtitle: " ++ project dirs
193
194
195
196
197
198
199
200
201
202
203
      , "---"
      , "# 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 ++ ")"

204
205
206
207
208
209
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."

210
readMetaDataForDir :: FilePath -> Action Y.Value
211
212
213
readMetaDataForDir dir = walkUpTo dir
  where
    walkUpTo dir = do
214
215
      dirs <- getProjectDirs
      if equalFilePath (project dirs) dir
216
217
218
219
220
        then collectMeta dir
        else do
          fromAbove <- walkUpTo (takeDirectory dir)
          fromHere <- collectMeta dir
          return $ joinMeta fromHere fromAbove
221
222
    --
    collectMeta dir = do
223
224
225
226
      files <- liftIO $ globDir1 (compile "*-meta.yaml") dir
      need files
      meta <- mapM decodeYaml files
      return $ foldl joinMeta (Y.object []) meta
227
228
    --
    decodeYaml yamlFile = do
229
230
231
232
233
234
235
      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
236

237
238
239
240
241
242
-- | 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
243
244
245
246
247
248
fixMustacheMarkupText content =
  T.replace
    (T.pack "{{\\#")
    (T.pack "{{#")
    (T.replace (T.pack "{{\\^") (T.pack "{{^") content)

249
250
251
252
253
254
255
256
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)

257
getRelativeSupportDir :: FilePath -> Action FilePath
258
getRelativeSupportDir from = do
259
  dirs <- getProjectDirs
260
  return $
261
262
    invertPath (makeRelative (public dirs) (takeDirectory from)) </>
    makeRelative (public dirs) (support dirs)
Henrik Tramberend's avatar
Henrik Tramberend committed
263
264

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

-- | Write a markdown file to a HTML file using the page template.
268
269
markdownToHtmlDeck :: FilePath -> FilePath -> Action ()
markdownToHtmlDeck markdownFile out = do
270
  putCurrentDocument out
271
272
273
  supportDir <- getRelativeSupportDir out
  let options =
        pandocWriterOpts
274
275
        { writerTemplate = Just deckTemplate
        -- , writerStandalone = True
276
        , writerHighlight = True
277
        -- , writerHighlightStyle = pygments
278
        , writerHTMLMathMethod =
279
280
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
281
282
283
284
        -- ,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
285
            [ ("revealjs-url", supportDir </> "reveal.js-3.5.0")
286
287
            , ("decker-support-dir", supportDir)
            ]
288
289
        , writerCiteMethod = Citeproc
        }
290
  pandoc <- readAndPreprocessMarkdown markdownFile Deck
291
292
  processed <- processPandocDeck "revealjs" pandoc
  writePandocString "revealjs" options out processed
293

Henrik Tramberend's avatar
Henrik Tramberend committed
294
295
296
297
298
299
300
301
302
-- | 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

303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
versionCheck :: Meta -> Action ()
versionCheck meta =
  case lookupMeta "decker-version" meta of
    Just (MetaInlines version) -> check $ stringify version
    Just (MetaString version) -> check version
    _ ->
      putNormal $
      "  - Document version unspecified. This is decker version " ++
      deckerVersion ++ "."
  where
    check version =
      when (List.trim version /= List.trim deckerVersion) $
      putNormal $
      "  - Document version " ++
      version ++
      ". This is decker version " ++ deckerVersion ++ ". Expect problems."

Henrik Tramberend's avatar
Henrik Tramberend committed
320
-- | Reads a markdownfile, expands the included files, and substitutes mustache
321
-- template variables and calls need.
322
323
readAndPreprocessMarkdown :: FilePath -> Disposition -> Action Pandoc
readAndPreprocessMarkdown markdownFile disposition = do
324
  dirs <- getProjectDirs
325
  let baseDir = takeDirectory markdownFile
326
  pandoc@(Pandoc meta _) <-
Henrik Tramberend's avatar
Henrik Tramberend committed
327
    readMetaMarkdown markdownFile >>= processIncludes dirs baseDir
328
  versionCheck meta
Henrik Tramberend's avatar
Henrik Tramberend committed
329
330
331
  let method = provisioningFromMeta meta
  liftIO $
    mapMetaResources (provisionMetaResource method dirs baseDir) pandoc >>=
Henrik Tramberend's avatar
Henrik Tramberend committed
332
    mapResources (provisionExistingResource method dirs baseDir) >>=
333
    walkM (renderImageVideo disposition)
Henrik Tramberend's avatar
Henrik Tramberend committed
334
335
    -- Disable automatic caching of remote images for a while
    -- >>= walkM (cacheRemoteImages (cache dirs))
Henrik Tramberend's avatar
Henrik Tramberend committed
336

337
338
339
340
341
342
lookupBool :: String -> Bool -> Meta -> Bool
lookupBool key def meta =
  case lookupMeta key meta of
    Just (MetaBool b) -> b
    _ -> def

Henrik Tramberend's avatar
Henrik Tramberend committed
343
344
345
346
347
348
349
350
351
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
352
  | key `elem` compiletimeMetaKeys = findLocalFile dirs base path
Henrik Tramberend's avatar
Henrik Tramberend committed
353
354
provisionMetaResource _ _ _ (key, path) = return path

355
356
357
358
359
putCurrentDocument out = do
  dirs <- getProjectDirs
  let rel = makeRelative (public dirs) out
  putNormal $ "# pandoc for (" ++ rel ++ ")"

Henrik Tramberend's avatar
Henrik Tramberend committed
360
-- | Write a markdown file to a HTML file using the page template.
361
362
markdownToHtmlPage :: FilePath -> FilePath -> Action ()
markdownToHtmlPage markdownFile out = do
363
  putCurrentDocument out
364
365
366
367
  supportDir <- getRelativeSupportDir out
  let options =
        pandocWriterOpts
        { writerHtml5 = True
368
369
        -- , writerStandalone = True
        , writerTemplate = Just pageTemplate
370
        , writerHighlight = True
371
        -- , writerHighlightStyle = pygments
372
        , writerHTMLMathMethod =
373
374
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
375
376
377
378
379
380
        -- ,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
        }
381
  pandoc <- readAndPreprocessMarkdown markdownFile Page
382
383
  processed <- processPandocPage "html5" pandoc
  writePandocString "html5" options out processed
Henrik Tramberend's avatar
Henrik Tramberend committed
384
385

-- | Write a markdown file to a PDF file using the handout template.
386
387
markdownToPdfPage :: FilePath -> FilePath -> Action ()
markdownToPdfPage markdownFile out = do
388
  putCurrentDocument out
389
390
  let options =
        pandocWriterOpts
391
392
        { writerTemplate = Just pageLatexTemplate
        -- , writerStandalone = True
393
        , writerHighlight = True
394
        -- , writerHighlightStyle = pygments
395
396
        , writerCiteMethod = Citeproc
        }
397
  pandoc <- readAndPreprocessMarkdown markdownFile Page
398
399
400
401
402
403
404
405
406
  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
407
408

-- | Write a markdown file to a HTML file using the handout template.
409
410
markdownToHtmlHandout :: FilePath -> FilePath -> Action ()
markdownToHtmlHandout markdownFile out = do
411
  putCurrentDocument out
412
  pandoc <- readAndPreprocessMarkdown markdownFile Handout
413
414
415
416
417
  processed <- processPandocHandout "html" pandoc
  supportDir <- getRelativeSupportDir out
  let options =
        pandocWriterOpts
        { writerHtml5 = True
418
        , writerTemplate = Just handoutTemplate
419
420
        , writerHighlight = True
        , writerHTMLMathMethod =
421
422
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
423
424
425
426
        , writerVariables = [("decker-support-dir", supportDir)]
        , writerCiteMethod = Citeproc
        }
  writePandocString "html5" options out processed
Henrik Tramberend's avatar
Henrik Tramberend committed
427
428

-- | Write a markdown file to a PDF file using the handout template.
429
markdownToPdfHandout :: FilePath -> FilePath -> Action ()
430
markdownToPdfHandout markdownFile out = do
431
  putCurrentDocument out
432
  pandoc <- readAndPreprocessMarkdown markdownFile Handout
433
434
435
  processed <- processPandocHandout "latex" pandoc
  let options =
        pandocWriterOpts
436
        { writerTemplate = Just handoutLatexTemplate
437
438
439
440
441
        , writerHighlight = True
        , writerCiteMethod = Citeproc
        }
  putNormal $ "# pandoc (for " ++ out ++ ")"
  pandocMakePdf options processed out
442

443
-- | Reads a markdown file and returns a pandoc document. 
444
readMetaMarkdown :: FilePath -> Action Pandoc
445
446
readMetaMarkdown markdownFile = do
  need [markdownFile]
447
  -- read external meta data for this directory
Henrik Tramberend's avatar
Henrik Tramberend committed
448
  externalMeta <- readMetaDataForDir (takeDirectory markdownFile)
449
  -- extract embedded meta data from the document
Henrik Tramberend's avatar
Henrik Tramberend committed
450
451
452
  markdown <- liftIO $ S.readFile markdownFile
  let Pandoc meta _ = readMarkdownOrThrow pandocReaderOpts markdown
  let documentMeta = MetaMap $ unMeta meta
453
  -- combine the meta data with preference on the embedded data
Henrik Tramberend's avatar
Henrik Tramberend committed
454
455
456
457
458
459
460
461
462
  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
463
  -- adjust image urls
464
  dirs <- getProjectDirs
Henrik Tramberend's avatar
Henrik Tramberend committed
465
  liftIO $ mapResources (findLocalFile dirs (takeDirectory markdownFile)) pandoc
466
467
468
469
470
471

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

Henrik Tramberend's avatar
Henrik Tramberend committed
473
474
-- | Converts pandoc meta data to mustache meta data. Inlines and blocks are
-- rendered to markdown strings with default options.
475
476
477
478
479
480
481
482
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
483
  T.pack $ writeMarkdown def (Pandoc (Meta Map.empty) [Plain inlines])
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
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
499
toPandocMeta Y.Null = MetaList []
500

501
-- Remove automatic identifier creation for headers. It does not work well with
502
-- the current include mechanism if slides have duplicate titles in separate
503
504
505
506
507
-- include files.
deckerPandocExtensions :: Set.Set Extension
deckerPandocExtensions = Set.delete Ext_auto_identifiers pandocExtensions

pandocReaderOpts :: ReaderOptions
508
pandocReaderOpts = def {readerExtensions = deckerPandocExtensions}
509
510

pandocWriterOpts :: WriterOptions
511
pandocWriterOpts = def {writerExtensions = deckerPandocExtensions}
512

513
514
515
516
517
518
519
520
521
isLocalURI :: String -> Bool
isLocalURI url = isNothing $ parseURI url

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

isCacheableURI :: String -> Bool
isCacheableURI url =
  case parseURI url of
522
    Just uri -> uriScheme uri `elem` ["http:", "https:"]
523
524
525
526
527
528
529
    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
530
adjustImageUrls projectDir baseDir = walk adjustBlock . walk adjustInline
531
  where
532
533
    adjustInline (Image attr inlines (url, title)) =
      Image attr inlines (adjustLocalUrl projectDir baseDir url, title)
534
535
    adjustInline other = other
    adjustBlock (Header 1 attr inlines) =
536
      Header 1 (adjustBgImageUrl attr) inlines
537
    adjustBlock other = other
538
539
540
541
542
    adjustBgImageUrl (i, cs, kvs) =
      ( i
      , cs
      , map
          (\(k, v) ->
543
544
545
             if k == "data-background-image" || k == "data-background-video"
               then (k, adjustLocalUrl projectDir baseDir v)
               else (k, v))
546
          kvs)
547
548
549
550

adjustLocalUrl :: FilePath -> FilePath -> FilePath -> FilePath
adjustLocalUrl root base url
  | isLocalURI url =
551
552
553
    if isAbsolute url
      then root </> makeRelative "/" url
      else base </> url
554
555
adjustLocalUrl _ _ url = url

Henrik Tramberend's avatar
Henrik Tramberend committed
556
557
-- TODO: Move the map* functions into the Action monad so that need can be
-- called for the resources.
558
559
560
561
562
563
564
565
566
567
568
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
569
570
    mapAttr kv@(key, value) =
      if key `elem` elementAttributes
571
572
573
574
575
576
        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
577
mapInline transform img@(Image attr@(_, cls, _) inlines (url, title)) =
578
579
580
581
  if not $ isMacro $ stringify inlines
    then do
      a <- mapAttributes transform attr
      u <- transform url
Henrik Tramberend's avatar
Henrik Tramberend committed
582
      return $ Image a inlines (u, title)
583
    else return img
Henrik Tramberend's avatar
Henrik Tramberend committed
584
585
mapInline transform lnk@(Link attr@(_, cls, _) inlines (url, title)) =
  if not (isMacro $ stringify inlines) && "resource" `elem` cls
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
    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
611
mapMetaResources :: ((String, FilePath) -> IO FilePath) -> Pandoc -> IO Pandoc
612
613
614
615
616
617
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
618
        transformed <- transform (k, v)
619
620
621
        return (k, MetaString transformed)
    mapMeta (k, MetaInlines inlines)
      | k `elem` metaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
622
        transformed <- transform (k, stringify inlines)
623
624
625
        return (k, MetaString transformed)
    mapMeta (k, MetaList l)
      | k `elem` metaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
626
        transformed <- mapM (mapMetaList k) l
627
628
        return (k, MetaList transformed)
    mapMeta kv = return kv
Henrik Tramberend's avatar
Henrik Tramberend committed
629
630
631
632
    mapMetaList k (MetaString v) = MetaString <$> transform (k, v)
    mapMetaList k (MetaInlines inlines) =
      MetaString <$> transform (k, stringify inlines)
    mapMetaList _ v = return v
633

Henrik Tramberend's avatar
Henrik Tramberend committed
634
635
636
-- | 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.
637
638
639
640
641
642
643
644
645
elementAttributes =
  [ "src"
  , "data-src"
  , "data-markdown"
  , "data-background-video"
  , "data-background-image"
  , "data-background-iframe"
  ]

Henrik Tramberend's avatar
Henrik Tramberend committed
646
647
648
649
650
651
652
-- | 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
653

Henrik Tramberend's avatar
Henrik Tramberend committed
654
-- Transitively splices all include files into the pandoc document.
Henrik Tramberend's avatar
Henrik Tramberend committed
655
656
processIncludes :: ProjectDirs -> FilePath -> Pandoc -> Action Pandoc
processIncludes dirs baseDir (Pandoc meta blocks) = do
657
658
  included <- processBlocks baseDir blocks
  return $ Pandoc meta included
659
660
661
  where
    processBlocks :: FilePath -> [Block] -> Action [Block]
    processBlocks base blcks = do
662
663
      spliced <- foldM (include base) [] blcks
      return $ concat $ reverse spliced
664
    include :: FilePath -> [[Block]] -> Block -> Action [[Block]]
665
    include base result (Para [Link _ [Str ":include"] (url, _)]) = do
Henrik Tramberend's avatar
Henrik Tramberend committed
666
      filePath <- liftIO $ findFile dirs base url
667
668
669
      Pandoc _ b <- readMetaMarkdown filePath
      included <- processBlocks (takeDirectory filePath) b
      return $ included : result
670
    include _ result block = return $ [block] : result
671

Henrik Tramberend's avatar
Henrik Tramberend committed
672
cacheRemoteImages :: FilePath -> Pandoc -> IO Pandoc
673
cacheRemoteImages cacheDir = walkM cacheRemoteImage
674
  where
675
676
677
    cacheRemoteImage (Image attr inlines (url, title)) = do
      cachedFile <- cacheRemoteFile cacheDir url
      return (Image attr inlines (cachedFile, title))
678
    cacheRemoteImage img = return img
Henrik Tramberend's avatar
Henrik Tramberend committed
679
680
681

cacheRemoteFile :: FilePath -> String -> IO FilePath
cacheRemoteFile cacheDir url
682
  | isCacheableURI url = do
683
684
685
686
687
688
    let cacheFile = cacheDir </> hashURI url
    exists <- Dir.doesFileExist cacheFile
    if exists
      then return cacheFile
      else catch
             (do content <- downloadUrl url
689
                 Dir.createDirectoryIfMissing True cacheDir
690
691
692
693
694
                 LB.writeFile cacheFile content
                 return cacheFile)
             (\e -> do
                putStrLn $ "Warning: " ++ show (e :: SomeException)
                return url)
Henrik Tramberend's avatar
Henrik Tramberend committed
695
696
cacheRemoteFile _ url = return url

697
698
699
700
701
702
703
-- 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
704
downloadUrl :: String -> IO LB.ByteString
705
downloadUrl url = do
706
707
708
709
710
711
712
713
714
715
716
717
  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
718
719

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

722
processPandocPage :: String -> Pandoc -> Action Pandoc
723
processPandocPage format pandoc = do
724
  let f = Just (Format format)
725
  dirs <- getProjectDirs
Henrik Tramberend's avatar
Henrik Tramberend committed
726
  processed <- liftIO $ processCites' pandoc
727
  --  processed <- liftIO $ walkM (useCachedImages (cache dirs)) pandoc
728
729
730
731
732
  return $ expandMacros f processed

processPandocDeck :: String -> Pandoc -> Action Pandoc
processPandocDeck format pandoc = do
  let f = Just (Format format)
733
  dirs <- getProjectDirs
Henrik Tramberend's avatar
Henrik Tramberend committed
734
  processed <- liftIO $ processCites' pandoc
735
  -- processed <- liftIO $ walkM (useCachedImages cacheD(cache dirs)ir) pandoc
736
737
738
739
740
  return $ (makeSlides f . expandMacros f) processed

processPandocHandout :: String -> Pandoc -> Action Pandoc
processPandocHandout format pandoc = do
  let f = Just (Format format)
741
  dirs <- getProjectDirs
Henrik Tramberend's avatar
Henrik Tramberend committed
742
  processed <- liftIO $ processCites' (makeBoxes pandoc)
743
  -- processed <- liftIO $ walkM (useCachedImages (cache dirs)) pandoc
744
745
  -- return $ (expandMacros f . filterNotes f) processed
  return $ expandMacros f processed
Henrik Tramberend's avatar
Henrik Tramberend committed
746
747
748

type StringWriter = WriterOptions -> Pandoc -> String

749
writePandocString :: String -> WriterOptions -> FilePath -> Pandoc -> Action ()
750
751
writePandocString format options out pandoc = do
  let writer = getPandocWriter format
Henrik Tramberend's avatar
Henrik Tramberend committed
752
  writeFile' out (writer options pandoc)
Henrik Tramberend's avatar
Henrik Tramberend committed
753
754

writeExampleProject :: Action ()
755
writeExampleProject = mapM_ writeOne deckerExampleDir
756
  where
757
758
    writeOne (path, contents) = do
      exists <- Development.Shake.doesFileExist path
759
      unless exists $ do
760
        liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
761
762
        liftIO $ B.writeFile path contents
        putNormal $ "# create (for " ++ path ++ ")"
Henrik Tramberend's avatar
Henrik Tramberend committed
763

764
writeEmbeddedFiles :: [(FilePath, B.ByteString)] -> FilePath -> Action ()
Henrik Tramberend's avatar
Henrik Tramberend committed
765
766
767
768
writeEmbeddedFiles files dir
  -- let absolute = map (\(path, contents) -> (dir </> path, contents)) files
 = do
  let absolute = map (first (dir </>)) files
769
  mapM_ write absolute
770
  where
771
772
773
774
    write (path, contents) = do
      liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
      exists <- liftIO $ Dir.doesFileExist path
      unless exists $ liftIO $ B.writeFile path contents
775

Henrik Tramberend's avatar
Henrik Tramberend committed
776
lookupValue :: String -> Y.Value -> Maybe Y.Value
777
lookupValue key (Y.Object hashTable) = HashMap.lookup (T.pack key) hashTable
778
lookupValue _ _ = Nothing
Henrik Tramberend's avatar
Henrik Tramberend committed
779

780
metaValueAsString :: String -> Y.Value -> Maybe String
Henrik Tramberend's avatar
Henrik Tramberend committed
781
metaValueAsString key meta =
782
783
784
  case splitOn "." key of
    [] -> Nothing
    k:ks -> lookup' ks (lookupValue k meta)
785
786
  where
    lookup' :: [String] -> Maybe Y.Value -> Maybe String
787
    lookup' [] (Just (Y.String text)) = Just (T.unpack text)
788
789
790
791
    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