utilities.hs 27.2 KB
Newer Older
Henrik Tramberend's avatar
Henrik Tramberend committed
1
module Utilities
2
3
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
38
  ( calcProjectDirectory
  , spawn
  , terminate
  , threadDelay'
  , wantRepeat
  , defaultContext
  , runShakeInContext
  , watchFiles
  , dropSuffix
  , stopServer
  , startServer
  , runHttpServer
  , writeIndex
  , readMetaDataForDir
  , substituteMetaData
  , markdownToHtmlDeck
  , markdownToHtmlHandout
  , markdownToPdfHandout
  , markdownToHtmlPage
  , markdownToPdfPage
  , writeExampleProject
  , metaValueAsString
  , (<++>)
  , markNeeded
  , replaceSuffixWith
  , writeEmbeddedFiles
  , getRelativeSupportDir
  , pandocMakePdf
  , isCacheableURI
  , adjustLocalUrl
  , cacheRemoteFile
  , cacheRemoteImages
  , makeRelativeTo
  , fixMustacheMarkup
  , fixMustacheMarkupText
  , globA
  , globRelA
39
  , toPandocMeta
40
41
  , DeckerException(..)
  ) where
Henrik Tramberend's avatar
Henrik Tramberend committed
42

43
44
import Context
import Control.Arrow
Henrik Tramberend's avatar
Henrik Tramberend committed
45
46
import Control.Concurrent
import Control.Exception
47
48
49
50
51
52
import Control.Monad
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
53
import Data.Dynamic
54
55
56
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
66
67
68
69
70
71
72
73
74
import qualified Data.Vector as Vec
import qualified Data.Yaml as Y
import Debug.Trace
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
75
import System.Directory as Dir
76
import System.FilePath as SF
Henrik Tramberend's avatar
Henrik Tramberend committed
77
import System.FilePath.Glob
Henrik Tramberend's avatar
Henrik Tramberend committed
78
import System.IO as S
79
80
81
import System.Process
import System.Process.Internals
import Text.CSL.Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
82
83
84
85
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Text.Pandoc
import Text.Pandoc.PDF
86
import Text.Pandoc.Walk
87
import Watch
88

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

106
107
108
-- | Globs for files under the project dir in the Action monad. 
-- Returns absolute pathes. 
globA :: FilePattern -> Action [FilePath]
109
globA pat = do
110
  projectDir <- getProjectDir
111
  liftIO $ globDir1 (compile pat) projectDir
112
113
114
115

-- | Globs for files under the project dir in the Action monad. 
-- Returns pathes relative to the project directory. 
globRelA :: FilePattern -> Action [FilePath]
116
globRelA pat = do
117
  projectDir <- getProjectDir
118
  files <- globA pat
119
  return $ map (makeRelative projectDir) files
120

Henrik Tramberend's avatar
Henrik Tramberend committed
121
122
123
124
-- Utility functions for shake based apps
spawn :: String -> Action ProcessHandle
spawn = liftIO . spawnCommand

125
-- Runs liveroladx on the given directory, if it is not already running. If
Henrik Tramberend's avatar
Henrik Tramberend committed
126
-- open is True a browser window is opended.
127
128
129
130
131
132
133
134
135
136
runHttpServer dir open = do
  process <- getServerHandle
  case process of
    Just handle -> return ()
    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
137
      when open $ cmd ("open http://localhost:8888/" :: String) :: Action ()
Henrik Tramberend's avatar
Henrik Tramberend committed
138

139
startServer id command =
140
141
142
  liftIO $ do
    processHandle <- spawnCommand command
    withProcessHandle processHandle handleResult
143
144
145
146
147
148
149
150
  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
151

152
stopServer id =
153
154
155
156
157
158
159
160
  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)
        removeFile pidFile
Henrik Tramberend's avatar
Henrik Tramberend committed
161
162
163
164
165
166
167
168
169
170

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

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

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

171
172
-- 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
173
174
175
176
177
178
data Context =
  Context [FilePath]
          (Maybe ProcessHandle)

defaultContext = Context [] Nothing

179
runShakeInContext :: ActionContext -> ShakeOptions -> Rules () -> IO ()
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
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
199
          waitForTwitchPassive files
200
          return False
Henrik Tramberend's avatar
Henrik Tramberend committed
201

202
watchFiles = setFilesToWatch
Henrik Tramberend's avatar
Henrik Tramberend committed
203
204

-- | Monadic version of list concatenation.
205
206
207
(<++>)
  :: Monad m
  => m [a] -> m [a] -> m [a]
208
(<++>) = liftM2 (++)
Henrik Tramberend's avatar
Henrik Tramberend committed
209
210
211

-- | Mark files as need and return them
markNeeded :: [FilePath] -> Action [FilePath]
212
213
214
markNeeded files = do
  need files
  return files
Henrik Tramberend's avatar
Henrik Tramberend committed
215
216
217
218
219

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

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

224
-- | Monadic version of suffix replacement for easy binding.
225
226
227
228
229
calcTargetPath :: FilePath
               -> String
               -> String
               -> [FilePath]
               -> Action [FilePath]
230
231
232
233
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.
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
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
  projectDir <- getProjectDir
  liftIO $
    writeFile out $
    unlines
      [ "---"
      , "title: Generated Index"
      , "subtitle: " ++ projectDir
      , "---"
      , "# 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 ++ ")"

256
257
258
259
260
261
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."

262
readMetaDataForDir :: FilePath -> Action Y.Value
263
264
265
readMetaDataForDir dir = walkUpTo dir
  where
    walkUpTo dir = do
266
267
268
269
270
271
272
      projectDir <- getProjectDir
      if equalFilePath projectDir dir
        then collectMeta dir
        else do
          fromAbove <- walkUpTo (takeDirectory dir)
          fromHere <- collectMeta dir
          return $ joinMeta fromHere fromAbove
273
274
    --
    collectMeta dir = do
275
276
277
278
      files <- liftIO $ globDir1 (compile "*-meta.yaml") dir
      need files
      meta <- mapM decodeYaml files
      return $ foldl joinMeta (Y.object []) meta
279
280
    --
    decodeYaml yamlFile = do
281
282
283
284
285
286
287
      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
288

289
290
291
292
293
294
-- | 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
295
296
297
298
299
300
fixMustacheMarkupText content =
  T.replace
    (T.pack "{{\\#")
    (T.pack "{{#")
    (T.replace (T.pack "{{\\^") (T.pack "{{^") content)

301
302
303
304
305
306
307
308
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)

309
getRelativeSupportDir :: FilePath -> Action FilePath
310
311
312
313
314
315
getRelativeSupportDir from = do
  supportDir <- getSupportDir
  publicDir <- getPublicDir
  return $
    invertPath (makeRelative publicDir (takeDirectory from)) </>
    makeRelative publicDir supportDir
Henrik Tramberend's avatar
Henrik Tramberend committed
316
317

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

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

Henrik Tramberend's avatar
Henrik Tramberend committed
346
347
348
349
350
351
352
353
354
355
-- | 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
356
357
-- template variables and calls need.
readAndPreprocessMarkdown :: FilePath -> Action Pandoc
358
359
360
readAndPreprocessMarkdown markdownFile = do
  projectDir <- getProjectDir
  let baseDir = takeDirectory markdownFile
361
362
363
  readMetaMarkdown markdownFile >>= processIncludes projectDir baseDir
  -- Disable automatic caching of remomte images for a while
  -- >>= populateCache
Henrik Tramberend's avatar
Henrik Tramberend committed
364
365

populateCache :: Pandoc -> Action Pandoc
366
367
368
populateCache pandoc = do
  cacheDir <- getCacheDir
  liftIO $ walkM (cacheRemoteImages cacheDir) pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
369

Henrik Tramberend's avatar
Henrik Tramberend committed
370
-- | Write a markdown file to a HTML file using the page template.
371
372
373
374
375
376
markdownToHtmlPage :: FilePath -> FilePath -> Action ()
markdownToHtmlPage markdownFile out = do
  supportDir <- getRelativeSupportDir out
  let options =
        pandocWriterOpts
        { writerHtml5 = True
377
378
        -- , writerStandalone = True
        , writerTemplate = Just pageTemplate
379
        , writerHighlight = True
380
        -- , writerHighlightStyle = pygments
381
        , writerHTMLMathMethod =
382
383
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
384
385
386
387
388
389
390
391
392
        -- ,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
393
394

-- | Write a markdown file to a PDF file using the handout template.
395
396
397
398
markdownToPdfPage :: FilePath -> FilePath -> Action ()
markdownToPdfPage markdownFile out = do
  let options =
        pandocWriterOpts
399
400
        { writerTemplate = Just pageLatexTemplate
        -- , writerStandalone = True
401
        , writerHighlight = True
402
        -- , writerHighlightStyle = pygments
403
404
405
406
407
408
409
410
411
412
413
414
        , 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
415
416

-- | Write a markdown file to a HTML file using the handout template.
417
418
419
420
421
422
423
424
markdownToHtmlHandout :: FilePath -> FilePath -> Action ()
markdownToHtmlHandout markdownFile out = do
  pandoc <- readAndPreprocessMarkdown markdownFile
  processed <- processPandocHandout "html" pandoc
  supportDir <- getRelativeSupportDir out
  let options =
        pandocWriterOpts
        { writerHtml5 = True
425
426
        -- , writerStandalone = True
        , writerTemplate = Just handoutTemplate
427
        , writerHighlight = True
428
        -- , writerHighlightStyle = pygments
429
        , writerHTMLMathMethod =
430
431
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
432
433
434
435
436
437
438
        -- ,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
        }
  writePandocString "html5" options out processed
Henrik Tramberend's avatar
Henrik Tramberend committed
439
440

-- | Write a markdown file to a PDF file using the handout template.
441
markdownToPdfHandout :: FilePath -> FilePath -> Action ()
442
markdownToPdfHandout markdownFile out = do
443
444
445
446
  pandoc <- readAndPreprocessMarkdown markdownFile
  processed <- processPandocHandout "latex" pandoc
  let options =
        pandocWriterOpts
447
448
        { writerTemplate = Just handoutLatexTemplate
        -- , writerStandalone = True
449
        , writerHighlight = True
450
        -- , writerHighlightStyle = pygments
451
452
453
454
        , writerCiteMethod = Citeproc
        }
  putNormal $ "# pandoc (for " ++ out ++ ")"
  pandocMakePdf options processed out
455

456
-- | Reads a markdown file and returns a pandoc document. 
457
readMetaMarkdown :: FilePath -> Action Pandoc
458
459
readMetaMarkdown markdownFile = do
  need [markdownFile]
460
  -- read external meta data for this directory
Henrik Tramberend's avatar
Henrik Tramberend committed
461
  externalMeta <- readMetaDataForDir (takeDirectory markdownFile)
462
  -- extract embedded meta data from the document
Henrik Tramberend's avatar
Henrik Tramberend committed
463
464
465
  markdown <- liftIO $ S.readFile markdownFile
  let Pandoc meta _ = readMarkdownOrThrow pandocReaderOpts markdown
  let documentMeta = MetaMap $ unMeta meta
466
  -- combine the meta data with preference on the embedded data
Henrik Tramberend's avatar
Henrik Tramberend committed
467
468
469
470
471
472
473
474
475
  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
476
  -- adjust image urls
477
478
  projectDir <- getProjectDir
  return $ walk (adjustImageUrls projectDir (takeDirectory markdownFile)) pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
479
480
481
482
483
  where
    readMarkdownOrThrow opts string =
      case readMarkdown opts string of
        Right pandoc -> pandoc
        Left err -> throw $ PandocException (show err)
484

485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
-- | Converts pandoc meta data to mustache meta data. Inlines and blocks are rendered to 
-- markdown strings with default options.
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 $
  T.pack $ writeMarkdown def (Pandoc (Meta Map.empty) [(Plain inlines)])
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
toPandocMeta (Y.Null) = MetaList []

513
514
515
516
517
518
519
-- Remove automatic identifier creation for headers. It does not work well with
-- the current include mechanism, if slides have duplicate titles in separate
-- include files.
deckerPandocExtensions :: Set.Set Extension
deckerPandocExtensions = Set.delete Ext_auto_identifiers pandocExtensions

pandocReaderOpts :: ReaderOptions
520
pandocReaderOpts = def {readerExtensions = deckerPandocExtensions}
521
522

pandocWriterOpts :: WriterOptions
523
pandocWriterOpts = def {writerExtensions = deckerPandocExtensions}
524

525
526
527
528
529
530
531
532
533
isLocalURI :: String -> Bool
isLocalURI url = isNothing $ parseURI url

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

isCacheableURI :: String -> Bool
isCacheableURI url =
  case parseURI url of
534
    Just uri -> uriScheme uri `elem` ["http:", "https:"]
535
536
537
538
539
540
541
    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
542
adjustImageUrls projectDir baseDir = walk adjustBlock . walk adjustInline
543
  where
544
545
    adjustInline (Image attr inlines (url, title)) =
      Image attr inlines (adjustLocalUrl projectDir baseDir url, title)
546
547
    adjustInline other = other
    adjustBlock (Header 1 attr inlines) =
548
      Header 1 (adjustBgImageUrl attr) inlines
549
    adjustBlock other = other
550
551
552
553
554
    adjustBgImageUrl (i, cs, kvs) =
      ( i
      , cs
      , map
          (\(k, v) ->
555
556
557
             if k == "data-background-image" || k == "data-background-video"
               then (k, adjustLocalUrl projectDir baseDir v)
               else (k, v))
558
          kvs)
559
560
561
562

adjustLocalUrl :: FilePath -> FilePath -> FilePath -> FilePath
adjustLocalUrl root base url
  | isLocalURI url =
563
564
565
    if isAbsolute url
      then root </> makeRelative "/" url
      else base </> url
566
567
adjustLocalUrl _ _ url = url

Henrik Tramberend's avatar
Henrik Tramberend committed
568
-- Transitively splices all include files into the pandoc document.
569
processIncludes :: FilePath -> FilePath -> Pandoc -> Action Pandoc
570
processIncludes rootDir baseDir (Pandoc meta blocks) = do
571
572
  included <- processBlocks baseDir blocks
  return $ Pandoc meta included
573
574
575
  where
    processBlocks :: FilePath -> [Block] -> Action [Block]
    processBlocks base blcks = do
576
577
      spliced <- foldM (include base) [] blcks
      return $ concat $ reverse spliced
578
    include :: FilePath -> [[Block]] -> Block -> Action [[Block]]
579
580
581
582
583
    include base result (Para [Link _ [Str "#include"] (url, _)]) = do
      let filePath = adjustLocalUrl rootDir base url
      Pandoc _ b <- readMetaMarkdown filePath
      included <- processBlocks (takeDirectory filePath) b
      return $ included : result
584
    include _ result block = return $ [block] : result
585

Henrik Tramberend's avatar
Henrik Tramberend committed
586
cacheRemoteImages :: FilePath -> Pandoc -> IO Pandoc
587
cacheRemoteImages cacheDir = walkM cacheRemoteImage
588
  where
589
590
591
    cacheRemoteImage (Image attr inlines (url, title)) = do
      cachedFile <- cacheRemoteFile cacheDir url
      return (Image attr inlines (cachedFile, title))
592
    cacheRemoteImage img = return img
Henrik Tramberend's avatar
Henrik Tramberend committed
593
594
595

cacheRemoteFile :: FilePath -> String -> IO FilePath
cacheRemoteFile cacheDir url
596
  | isCacheableURI url = do
597
598
599
600
601
602
603
604
605
606
607
608
    let cacheFile = cacheDir </> hashURI url
    exists <- Dir.doesFileExist cacheFile
    if exists
      then return cacheFile
      else catch
             (do content <- downloadUrl url
                 createDirectoryIfMissing True cacheDir
                 LB.writeFile cacheFile content
                 return cacheFile)
             (\e -> do
                putStrLn $ "Warning: " ++ show (e :: SomeException)
                return url)
Henrik Tramberend's avatar
Henrik Tramberend committed
609
610
611
612
cacheRemoteFile _ url = return url

clearCachedFile :: FilePath -> String -> IO ()
clearCachedFile cacheDir url
613
  | isCacheableURI url = do
614
615
616
    let cacheFile = cacheDir </> hashURI url
    exists <- Dir.doesFileExist cacheFile
    when exists $ removeFile cacheFile
Henrik Tramberend's avatar
Henrik Tramberend committed
617
618
619
clearCachedFile _ _ = return ()

downloadUrl :: String -> IO LB.ByteString
620
downloadUrl url = do
621
622
623
624
625
626
627
628
629
630
631
632
  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
633
634

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

637
processPandocPage :: String -> Pandoc -> Action Pandoc
638
processPandocPage format pandoc = do
639
640
  let f = Just (Format format)
  cacheDir <- getCacheDir
641
642
643
  processed <-
    liftIO $ processCites' pandoc >>= walkM (useCachedImages cacheDir)
  --  processed <- liftIO $ walkM (useCachedImages cacheDir) pandoc
644
645
646
647
648
649
  return $ expandMacros f processed

processPandocDeck :: String -> Pandoc -> Action Pandoc
processPandocDeck format pandoc = do
  let f = Just (Format format)
  cacheDir <- getCacheDir
650
651
652
  processed <-
    liftIO $ processCites' pandoc >>= walkM (useCachedImages cacheDir)
  -- processed <- liftIO $ walkM (useCachedImages cacheDir) pandoc
653
654
655
656
657
658
  return $ (makeSlides f . expandMacros f) processed

processPandocHandout :: String -> Pandoc -> Action Pandoc
processPandocHandout format pandoc = do
  let f = Just (Format format)
  cacheDir <- getCacheDir
659
660
661
  processed <-
    liftIO $ processCites' pandoc >>= walkM (useCachedImages cacheDir)
  -- processed <- liftIO $ walkM (useCachedImages cacheDir) pandoc
662
  return $ (expandMacros f . filterNotes f) processed
Henrik Tramberend's avatar
Henrik Tramberend committed
663
664
665

type StringWriter = WriterOptions -> Pandoc -> String

666
writePandocString :: String -> WriterOptions -> FilePath -> Pandoc -> Action ()
667
668
669
670
671
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
672

Henrik Tramberend's avatar
Henrik Tramberend committed
673
copyImages :: FilePath -> Pandoc -> Action Pandoc
674
copyImages baseDir pandoc = do
675
676
677
678
  projectDir <- getProjectDir
  publicDir <- getPublicDir
  walkM (copyAndLinkInline projectDir publicDir) pandoc >>=
    walkM (copyAndLinkBlock projectDir publicDir)
679
  where
680
681
682
    copyAndLinkInline project public (Image attr inlines (url, title)) = do
      relUrl <- copyAndLinkFile project public baseDir url
      return (Image attr inlines (relUrl, title))
683
684
    copyAndLinkInline _ _ inline = return inline
    copyAndLinkBlock project public (Header 1 attr inlines) = do
685
686
      relAttr <- copyBgImageUrl project public attr
      return (Header 1 relAttr inlines)
687
    copyAndLinkBlock _ _ block = return block
688
689
690
691
    copyBgImageUrl project public (i, cs, kvs) = do
      relKvs <-
        mapM
          (\(k, v) ->
692
693
694
695
696
             if k == "data-background-image"
               then do
                 relUrl <- copyAndLinkFile project public baseDir v
                 return (k, relUrl)
               else return (k, v))
697
698
699
700
701
702
703
704
          kvs
      return (i, cs, relKvs)

copyAndLinkFile :: FilePath
                -> FilePath
                -> FilePath
                -> FilePath
                -> Action FilePath
705
copyAndLinkFile project public base url = do
706
707
708
709
710
711
712
  let rel = makeRelative project url
  if rel == url
    then return url
    else do
      let pub = public </> rel
      liftIO $ createDirectoryIfMissing True (takeDirectory pub)
      copyFileChanged url pub
Henrik Tramberend's avatar
Henrik Tramberend committed
713
      return $ makeRelativeTo base pub
714
715
716

-- | Express the second path argument as relative to the first. 
-- Both arguments are expected to be absolute pathes. 
Henrik Tramberend's avatar
Henrik Tramberend committed
717
718
makeRelativeTo :: FilePath -> FilePath -> FilePath
makeRelativeTo dir file =
719
720
721
722
723
724
725
  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)
726
removeCommonPrefix a [] = (a, [])
727
removeCommonPrefix [] b = ([], b)
Henrik Tramberend's avatar
Henrik Tramberend committed
728

Henrik Tramberend's avatar
Henrik Tramberend committed
729
writeExampleProject :: Action ()
730
writeExampleProject = mapM_ writeOne deckerExampleDir
731
  where
732
733
    writeOne (path, contents) = do
      exists <- Development.Shake.doesFileExist path
734
735
736
737
      unless exists $ do
        liftIO $ createDirectoryIfMissing True (takeDirectory path)
        liftIO $ B.writeFile path contents
        putNormal $ "# create (for " ++ path ++ ")"
Henrik Tramberend's avatar
Henrik Tramberend committed
738

739
writeEmbeddedFiles :: [(FilePath, B.ByteString)] -> FilePath -> Action ()
740
writeEmbeddedFiles files dir = do
741
742
  let absolute = map (\(path, contents) -> (dir </> path, contents)) files
  mapM_ write absolute
743
  where
744
745
746
747
    write (path, contents) = do
      liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
      exists <- liftIO $ Dir.doesFileExist path
      unless exists $ liftIO $ B.writeFile path contents
748

Henrik Tramberend's avatar
Henrik Tramberend committed
749
lookupValue :: String -> Y.Value -> Maybe Y.Value
750
lookupValue key (Y.Object hashTable) = HashMap.lookup (T.pack key) hashTable
Henrik Tramberend's avatar
Henrik Tramberend committed
751
752
lookupValue key _ = Nothing

753
metaValueAsString :: String -> Y.Value -> Maybe String
Henrik Tramberend's avatar
Henrik Tramberend committed
754
metaValueAsString key meta =
755
756
757
  case splitOn "." key of
    [] -> Nothing
    k:ks -> lookup' ks (lookupValue k meta)
758
759
  where
    lookup' :: [String] -> Maybe Y.Value -> Maybe String
760
    lookup' [] (Just (Y.String text)) = Just (T.unpack text)
761
762
763
764
    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
Henrik Tramberend's avatar
Henrik Tramberend committed
765
766
767

-- | Tool specific exceptions
data DeckerException
768
  = MustacheException String
769
  | GitException String
770
771
772
773
774
775
  | PandocException String
  | YamlException String
  | HttpException String
  | RsyncUrlException
  | DecktapeException String
  deriving (Typeable)
Henrik Tramberend's avatar
Henrik Tramberend committed
776
777
778
779

instance Exception DeckerException

instance Show DeckerException where
780
  show (MustacheException e) = e
781
  show (GitException e) = e
782
783
784
785
786
787
  show (HttpException e) = e
  show (PandocException e) = e
  show (YamlException e) = e
  show (DecktapeException e) = "decktape.sh failed for reason: " ++ e
  show RsyncUrlException =
    "attributes 'destinationRsyncHost' or 'destinationRsyncPath' not defined in meta data"