utilities.hs 21.6 KB
Newer Older
Henrik Tramberend's avatar
Henrik Tramberend committed
1
module Utilities
2
3
4
5
6
7
8
9
       (cacheRemoteImages, calcProjectDirectory, spawn, terminate,
        threadDelay', wantRepeat, waitForModificationIn, defaultContext,
        runShakeInContext, watchFiles, waitForTwitch, dropSuffix,
        stopServer, startServer, runHttpServer, writeIndex, readMetaData,
        readMetaDataIO, substituteMetaData, markdownToHtmlDeck,
        markdownToHtmlHandout, markdownToPdfHandout, markdownToHtmlPage,
        markdownToPdfPage, writeExampleProject, metaValueAsString, (<++>),
        markNeeded, replaceSuffixWith, writeEmbeddedFiles,
Henrik Tramberend's avatar
Henrik Tramberend committed
10
        getRelativeSupportDir, collectIncludes, DeckerException(..))
Henrik Tramberend's avatar
Henrik Tramberend committed
11
12
13
14
15
16
17
18
       where

import Control.Monad.Loops
import Control.Monad
import Control.Concurrent
import Control.Exception
import Development.Shake
import Development.Shake.FilePath
19
import Data.Dynamic
Henrik Tramberend's avatar
Henrik Tramberend committed
20
21
22
23
24
25
26
27
28
29
30
import Data.List.Extra
import Data.Maybe
import Data.IORef
import qualified Data.Text as T
import Data.Time.Clock
import Data.Typeable
import qualified Data.Set as Set
import qualified Data.HashMap.Lazy as HashMap
import Text.Printf
import System.Process
import System.Process.Internals
31
import System.Directory as Dir
Henrik Tramberend's avatar
Henrik Tramberend committed
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
import System.Exit
import System.Posix.Signals
import System.FilePath
import qualified Data.Yaml as Y
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as L8
import Text.Pandoc
import Text.Pandoc.Walk
import Text.Pandoc.PDF
import Text.CSL.Pandoc
import Filter
import Debug.Trace
import Network.HTTP.Conduit
import Network.HTTP.Simple
import Network.URI
import Text.Highlighting.Kate.Styles
51
import Context
52
import Embed
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67

-- Find the project directory and change current directory to there. The project directory is the first upwards directory that contains a .git directory entry.
calcProjectDirectory :: IO FilePath
calcProjectDirectory =
  do cwd <- getCurrentDirectory
     pd <- searchGitRoot cwd
     return pd
  where searchGitRoot :: FilePath -> IO FilePath
        searchGitRoot path =
          do 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
68
69
70
71
72

-- Utility functions for shake based apps
spawn :: String -> Action ProcessHandle
spawn = liftIO . spawnCommand

73
-- Runs liveroladx on the given directory, if it is not already running. If
Henrik Tramberend's avatar
Henrik Tramberend committed
74
-- open is True a browser window is opended.
75
76
runHttpServer dir open =
  do process <- getServerHandle
Henrik Tramberend's avatar
Henrik Tramberend committed
77
78
     case process of
       Just handle -> return ()
79
       Nothing ->
Henrik Tramberend's avatar
Henrik Tramberend committed
80
         do putNormal "# livereloadx (on http://localhost:8888, see server.log)"
81
            handle <-
82
83
              spawn $
              "livereloadx -s -p 8888 -d 500 " ++ dir ++ " 2>&1 > server.log"
84
            setServerHandle $ Just handle
Henrik Tramberend's avatar
Henrik Tramberend committed
85
86
87
            threadDelay' 200000
            when open $ cmd "open http://localhost:8888/" :: Action ()

88
startServer id command =
Henrik Tramberend's avatar
Henrik Tramberend committed
89
90
91
  liftIO $
  do processHandle <- spawnCommand command
     withProcessHandle processHandle handleResult
92
  where handleResult ph =
Henrik Tramberend's avatar
Henrik Tramberend committed
93
          case ph of
94
            ClosedHandle e ->
Henrik Tramberend's avatar
Henrik Tramberend committed
95
              print $ "Error starting server " ++ id ++ ": " ++ show e
96
            OpenHandle p ->
Henrik Tramberend's avatar
Henrik Tramberend committed
97
98
99
100
              do print $ "Server " ++ id ++ " running (" ++ show p ++ ")"
                 writeFile (id ++ ".pid")
                           (show p)

101
stopServer id =
Henrik Tramberend's avatar
Henrik Tramberend committed
102
103
104
105
106
  liftIO $
  do let pidFile = id ++ ".pid"
     result <- try $ readFile pidFile
     case result of
       Left (SomeException e) -> print $ "Unable to read file " ++ pidFile
107
       Right pid ->
Henrik Tramberend's avatar
Henrik Tramberend committed
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
         do exitCode <- system ("kill -9 " ++ pid)
            removeFile pidFile

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

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

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

waitForModificationIn :: [FilePath] -> Action ()
waitForModificationIn = liftIO . waitForTwitch

123
124
-- 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
125
126
127
128
129
130
data Context =
  Context [FilePath]
          (Maybe ProcessHandle)

defaultContext = Context [] Nothing

131
132
133
134
runShakeInContext :: ActionContext -> ShakeOptions -> Rules () -> IO ()
runShakeInContext context options rules =
  do opts <- setActionContext context options
     tid <- myThreadId
Henrik Tramberend's avatar
Henrik Tramberend committed
135
     installHandler keyboardSignal
136
                    (Catch (cleanup tid))
Henrik Tramberend's avatar
Henrik Tramberend committed
137
                    Nothing
138
139
140
141
142
143
144
     untilM_ (tryRunShake opts) nothingToWatch
     cleanup tid
  where tryRunShake opts =
          do catch (shakeArgs opts rules)
                   (\(SomeException e) -> return ())
        cleanup tid =
          do process <- readIORef $ ctxServerHandle context
Henrik Tramberend's avatar
Henrik Tramberend committed
145
146
147
148
             case process of
               Just handle -> terminateProcess handle
               Nothing -> return ()
             throwTo tid ExitSuccess
149
150
151
152
153
154
        nothingToWatch =
          do files <- readIORef $ ctxFilesToWatch context
             if null files
                then return True
                else do waitForTwitch files
                        return False
Henrik Tramberend's avatar
Henrik Tramberend committed
155

156
watchFiles files = setFilesToWatch files
Henrik Tramberend's avatar
Henrik Tramberend committed
157
158
159
160


-- | Actively waits for the first change to any member in the set of specified
-- | files and their parent directories, then returns.
161
waitForTwitch files =
Henrik Tramberend's avatar
Henrik Tramberend committed
162
163
164
165
166
  do startTime <- getCurrentTime
     let dirs = map takeDirectory files
     let filesAndDirs = Set.toList . Set.fromList $ files ++ dirs
     whileM_ (noModificationSince startTime filesAndDirs)
             (threadDelay 300000)
167
  where noModificationSince startTime pathes =
Henrik Tramberend's avatar
Henrik Tramberend committed
168
169
          do modified <- mapM (modifiedSince startTime) pathes
             return $ not (or modified)
170
        modifiedSince time path =
Henrik Tramberend's avatar
Henrik Tramberend committed
171
172
173
174
175
176
          handle (\(SomeException _) -> return False) $
          do modTime <- getModificationTime path
             return $ diffUTCTime modTime time > 0

-- | Monadic version of list concatenation.
(<++>) :: Monad m => m [a] -> m [a] -> m [a]
177
(<++>) = liftM2 (++)
Henrik Tramberend's avatar
Henrik Tramberend committed
178
179
180

-- | Mark files as need and return them
markNeeded :: [FilePath] -> Action [FilePath]
181
markNeeded files =
Henrik Tramberend's avatar
Henrik Tramberend committed
182
183
184
185
186
187
188
189
190
  do need files
     return files

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

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

194
195
196
197
198
199
200
-- | Monadic version of suffix replacement for easy binding.
calcTargetPath
  :: FilePath -> String -> String -> [FilePath] -> Action [FilePath]
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.
201
writeIndex out baseUrl decks handouts pages =
202
203
204
205
206
  do let decksLinks = map (makeRelative baseUrl) decks
     let handoutsLinks = map (makeRelative baseUrl) handouts
     let pagesLinks = map (makeRelative baseUrl) pages
     liftIO $
       writeFile out $
207
208
209
210
211
       unlines ["---"
               ,"title: Generated Index"
               , "subtitle: {{course}} ({{semester}})"
               ,"---"
               ,"# Slide decks"
212
               ,unlines $ map makeLink decksLinks
213
               ,"# Handouts"
214
               ,unlines $ map makeLink handoutsLinks
215
216
               ,"# Supporting Documents"
               ,unlines $ map makeLink pagesLinks]
Henrik Tramberend's avatar
Henrik Tramberend committed
217
218
219
220
221
  where makeLink path = "-    [" ++ takeFileName path ++ "](" ++ path ++ ")"

-- | Decodes an array of YAML files and combines the data into one object.
-- Key value pairs from later files overwrite those from early ones.
readMetaDataIO :: [FilePath] -> IO Y.Value
222
readMetaDataIO files =
Henrik Tramberend's avatar
Henrik Tramberend committed
223
  mapM decode files >>= foldM combine (Y.Object HashMap.empty)
224
  where decode file =
Henrik Tramberend's avatar
Henrik Tramberend committed
225
226
          do result <- Y.decodeFileEither file
             return (file,result)
227
        combine (Y.Object obj) (file,Right (Y.Object new)) =
Henrik Tramberend's avatar
Henrik Tramberend committed
228
          return (Y.Object (HashMap.union new obj))
229
        combine obj (file,Right _) =
Henrik Tramberend's avatar
Henrik Tramberend committed
230
231
232
233
          do throw $
               YamlException $
               file ++ ": top level metadata is not a YAML object."
             return obj
234
        combine obj (file,Left err) =
Henrik Tramberend's avatar
Henrik Tramberend committed
235
236
237
238
239
240
241
242
          do throw $
               YamlException $ file ++ ": " ++ Y.prettyPrintParseException err
             return obj

readMetaData files = liftIO $ readMetaDataIO files

-- | Substitutes meta data values in the provided file.
substituteMetaData
243
  :: FilePath -> MT.Value -> IO T.Text
244
substituteMetaData source metaData =
245
  do result <-  M.localAutomaticCompile source
Henrik Tramberend's avatar
Henrik Tramberend committed
246
247
248
249
     case result of
       Right template -> return $ M.substituteValue template metaData
       Left err -> throw $ MustacheException (show err)

250
251
252
253
254
255
256
257
258
259
getRelativeSupportDir :: FilePath -> Action FilePath
getRelativeSupportDir from =
  do supportDir <- getSupportDir
     publicDir <- getPublicDir
     return $
       invertPath
         (makeRelative publicDir
                       (takeDirectory from)) </>
       (makeRelative publicDir supportDir)
  where invertPath fp = joinPath $ map (\_ -> "..") $ filter ((/=) ".") $ splitPath fp
Henrik Tramberend's avatar
Henrik Tramberend committed
260
261
262

-- | Write a markdown file to a HTML file using the page template.
markdownToHtmlDeck
Henrik Tramberend's avatar
Henrik Tramberend committed
263
264
265
  :: FilePath -> MetaData -> FilePath -> Action ()
markdownToHtmlDeck markdownFile metaData out =
  do supportDir <- getRelativeSupportDir out
266
     let options =
Henrik Tramberend's avatar
Henrik Tramberend committed
267
           def {writerStandalone = True
Henrik Tramberend's avatar
Henrik Tramberend committed
268
269
270
               ,writerTemplate = deckTemplate
               ,writerHighlight = True
               ,writerHighlightStyle = pygments
271
               ,writerHTMLMathMethod =
272
273
274
275
                  KaTeX (supportDir </> "katex/katex.min.js")
                        (supportDir </> "katex/katex.min.css")
               ,writerVariables =
                  [("revealjs-url",supportDir </> "reveal.js")]
Henrik Tramberend's avatar
Henrik Tramberend committed
276
               ,writerCiteMethod = Citeproc}
Henrik Tramberend's avatar
Henrik Tramberend committed
277
278
     pandoc <- readAndPreprocessMarkdown metaData markdownFile
     processed <- processPandocDeck "revealjs" pandoc
279
280
     let images = extractLocalImagePathes processed
     copyLocalImages images markdownFile out
Henrik Tramberend's avatar
Henrik Tramberend committed
281
     writePandocString "revealjs" options out processed
282
283
284
285
286
287
288
289
290
291
292

copyLocalImages :: [FilePath] -> FilePath  -> FilePath -> Action ()
copyLocalImages imageFiles inFile outFile =
  do let inDir = takeDirectory inFile
     let outDir = takeDirectory outFile
     mapM_ (copyImageFile inDir outDir) imageFiles
  where copyImageFile inDir outDir imageFile =
          do let from = inDir </> imageFile
             let to = outDir </> imageFile
             liftIO $ createDirectoryIfMissing True (takeDirectory to)
             copyFileChanged from to
Henrik Tramberend's avatar
Henrik Tramberend committed
293

Henrik Tramberend's avatar
Henrik Tramberend committed
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
type MetaData = Y.Value

-- | 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
-- template variables.
readAndPreprocessMarkdown :: MetaData -> FilePath -> Action Pandoc
readAndPreprocessMarkdown metaData markdownFile =
  do -- let writer = getPandocWriter format
     projectDir <- getProjectDir
     let baseDir = takeDirectory markdownFile
     includes <- collectIncludes markdownFile
     pandoc <- readMetaMarkdown markdownFile metaData
     need (markdownFile : includes)
     liftIO $ processIncludes projectDir baseDir metaData pandoc

Henrik Tramberend's avatar
Henrik Tramberend committed
317
318
-- | Write a markdown file to a HTML file using the page template.
markdownToHtmlPage
Henrik Tramberend's avatar
Henrik Tramberend committed
319
320
  :: FilePath -> MetaData -> FilePath -> Action ()
markdownToHtmlPage markdownFile metaData out =
321
  do supportDir <- getRelativeSupportDir out
322
     let options =
Henrik Tramberend's avatar
Henrik Tramberend committed
323
324
325
326
327
           def {writerHtml5 = True
               ,writerStandalone = True
               ,writerTemplate = pageTemplate
               ,writerHighlight = True
               ,writerHighlightStyle = pygments
328
               ,writerHTMLMathMethod =
329
330
331
332
                  KaTeX (supportDir </> "katex/katex.min.js")
                        (supportDir </> "katex/katex.min.css")
               ,writerVariables =
                  [("css",supportDir </> "readable/bootstrap.min.css")]
Henrik Tramberend's avatar
Henrik Tramberend committed
333
               ,writerCiteMethod = Citeproc}
Henrik Tramberend's avatar
Henrik Tramberend committed
334
335
336
337
338
     pandoc <- readAndPreprocessMarkdown metaData markdownFile
     processed <- processPandocPage "html5" pandoc
     let images = extractLocalImagePathes processed
     copyLocalImages images markdownFile out
     writePandocString "html5" options out processed
Henrik Tramberend's avatar
Henrik Tramberend committed
339
340
341

-- | Write a markdown file to a PDF file using the handout template.
markdownToPdfPage
Henrik Tramberend's avatar
Henrik Tramberend committed
342
343
344
  :: FilePath -> MetaData -> FilePath -> Action ()
markdownToPdfPage markdownFile metaData out =
  do let options =
Henrik Tramberend's avatar
Henrik Tramberend committed
345
346
347
348
349
           def {writerStandalone = True
               ,writerTemplate = pageLatexTemplate
               ,writerHighlight = True
               ,writerHighlightStyle = pygments
               ,writerCiteMethod = Citeproc}
Henrik Tramberend's avatar
Henrik Tramberend committed
350
351
     pandoc <- readAndPreprocessMarkdown metaData markdownFile
     processed <- processPandocPage "latex" pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
352
353
354
     putNormal $ "# pandoc (for " ++ out ++ ")"
     pandocMakePdf options processed out

355
pandocMakePdf options processed out =
Henrik Tramberend's avatar
Henrik Tramberend committed
356
357
358
359
360
361
362
363
  do result <- liftIO $ makePDF "pdflatex" writeLaTeX options processed
     case result of
       Left err -> throw $ PandocException (show err)
       Right pdf -> liftIO $ LB.writeFile out pdf

-- | Write a markdown file to a HTML file using the handout template.
markdownToHtmlHandout
  :: FilePath -> [FilePath] -> FilePath -> Action ()
364
markdownToHtmlHandout markdownFile metaFiles out =
Henrik Tramberend's avatar
Henrik Tramberend committed
365
  do need $ markdownFile : metaFiles
366
367
     metaData <- readMetaData metaFiles
     pandoc <- readMetaMarkdown markdownFile metaData
Henrik Tramberend's avatar
Henrik Tramberend committed
368
     processed <- processPandocHandout "html" pandoc
369
     supportDir <- getRelativeSupportDir out
370
     let options =
Henrik Tramberend's avatar
Henrik Tramberend committed
371
372
373
374
375
           def {writerHtml5 = True
               ,writerStandalone = True
               ,writerTemplate = handoutTemplate
               ,writerHighlight = True
               ,writerHighlightStyle = pygments
376
               ,writerHTMLMathMethod =
377
378
379
380
                  KaTeX (supportDir </> "katex/katex.min.js")
                        (supportDir </> "katex/katex.min.css")
               ,writerVariables =
                  [("css",supportDir </> "readable/bootstrap.min.css")]
Henrik Tramberend's avatar
Henrik Tramberend committed
381
               ,writerCiteMethod = Citeproc}
Henrik Tramberend's avatar
Henrik Tramberend committed
382
     writePandocString "html5" options out processed
Henrik Tramberend's avatar
Henrik Tramberend committed
383
384
385
386
387
388

-- | Write a markdown file to a PDF file using the handout template.
markdownToPdfHandout
  :: FilePath -> [FilePath] -> FilePath -> Action ()
markdownToPdfHandout markdownFile metaFiles out =
  do need $ markdownFile : metaFiles
389
390
     metaData <- readMetaData metaFiles
     pandoc <- readMetaMarkdown markdownFile metaData
Henrik Tramberend's avatar
Henrik Tramberend committed
391
     processed <- processPandocHandout "latex" pandoc
392
     let options =
Henrik Tramberend's avatar
Henrik Tramberend committed
393
394
395
396
397
398
399
400
401
           def {writerStandalone = True
               ,writerTemplate = handoutLatexTemplate
               ,writerHighlight = True
               ,writerHighlightStyle = pygments
               ,writerCiteMethod = Citeproc}
     putNormal $ "# pandoc (for " ++ out ++ ")"
     pandocMakePdf options processed out

readMetaMarkdown
402
403
404
405
406
407
408
  :: FilePath -> Y.Value -> Action Pandoc
readMetaMarkdown markdownFile metaData = liftIO $ readMetaMarkdownIO markdownFile metaData

readMetaMarkdownIO
  :: FilePath -> Y.Value -> IO Pandoc
readMetaMarkdownIO markdownFile metaData =
  do text <-
Henrik Tramberend's avatar
Henrik Tramberend committed
409
410
411
412
413
414
       substituteMetaData markdownFile
                          (MT.mFromJSON metaData)
     case readMarkdown def $ T.unpack text of
       Right pandoc -> return pandoc
       Left err -> throw $ PandocException (show err)

415
416
417
418
cacheRemoteImages :: FilePath -> [FilePath] -> [FilePath] -> Action ()
cacheRemoteImages cacheDir metaFiles markdownFiles =
  do mapM_ cacheImages markdownFiles
  where cacheImages markdownFile =
419
420
          do metaData <- readMetaData metaFiles
             pandoc <- readMetaMarkdown markdownFile metaData
Henrik Tramberend's avatar
Henrik Tramberend committed
421
             _ <- liftIO $ walkM (cachePandocImages cacheDir) pandoc
422
             putNormal $ "# pandoc (cached images for " ++ markdownFile ++ ")"
Henrik Tramberend's avatar
Henrik Tramberend committed
423

Henrik Tramberend's avatar
Henrik Tramberend committed
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
absoluteIncludePath root base path =
  if isAbsolute path
     then root </> makeRelative "/" path
     else base </> path

-- Transitively collects all include files for the given markdown file. The returned pathes
-- are absolute an can be passed directly to `need`.
collectIncludes ::  FilePath -> Action [FilePath]
collectIncludes markdownFile =
  do projectDir <- getProjectDir
     liftIO $ collectIncludesIO projectDir markdownFile

collectIncludesIO :: FilePath -> FilePath -> IO [FilePath]
collectIncludesIO rootDir markdownFile =
  do markdown <- readFile markdownFile
     let pandoc =
           case readMarkdown def markdown of
             Right p -> p
             Left e -> throw $ PandocException (show e)
     let baseDir = takeDirectory markdownFile
     let direct = map (absoluteIncludePath rootDir baseDir) (Text.Pandoc.Walk.query include pandoc)
     transitive <- mapM (collectIncludesIO rootDir) direct
     return $ direct ++ concat transitive
  where include :: Block -> [FilePath]
        include (Para [Image _ [Str "#include"] (url,_)]) = [url]
        include _ = []

-- Transitively splices all include files into the pandoc document.
processIncludes :: FilePath -> FilePath -> Y.Value -> Pandoc -> IO Pandoc
processIncludes rootDir baseDir metaData (Pandoc meta blocks) =
  do included <- processBlocks baseDir blocks
     return $ Pandoc meta included
  where processBlocks
          :: FilePath -> [Block] -> IO [Block]
        processBlocks base blcks =
          do spliced <- foldM (include base) [] blcks
             return $ concat $ reverse spliced
        include
          :: FilePath -> [[Block]] -> Block -> IO [[Block]]
        include base result (Para [Image _ [Str "#include"] (url,_)]) =
          do let filePath = absoluteIncludePath rootDir base url
             Pandoc _ b <- readMetaMarkdownIO filePath metaData
466
             included <-
Henrik Tramberend's avatar
Henrik Tramberend committed
467
468
469
470
               processBlocks (takeDirectory filePath)
                             b
             return $ included : result
        include _ result block = return $ [block] : result
471
472

processPandocPage
Henrik Tramberend's avatar
Henrik Tramberend committed
473
  :: String -> Pandoc -> Action Pandoc
474
processPandocPage format pandoc =
Henrik Tramberend's avatar
Henrik Tramberend committed
475
  do let f = Just (Format format)
476
477
478
     -- processed <- liftIO $ processCites' pandoc >>= walkM (useCachedImages cacheDir)
     cacheDir <- getCacheDir
     processed <- liftIO $ walkM (useCachedImages cacheDir) pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
479
480
481
482
     return $ expandMacros f processed

processPandocDeck
  :: String -> Pandoc -> Action Pandoc
483
processPandocDeck format pandoc =
Henrik Tramberend's avatar
Henrik Tramberend committed
484
  do let f = Just (Format format)
485
486
487
     -- processed <- liftIO $ processCites' pandoc >>= walkM (useCachedImages cacheDir)
     cacheDir <- getCacheDir
     processed <- liftIO $ walkM (useCachedImages cacheDir) pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
488
489
490
491
     return $ (makeSlides f . expandMacros f) processed

processPandocHandout
  :: String -> Pandoc -> Action Pandoc
492
processPandocHandout format pandoc =
Henrik Tramberend's avatar
Henrik Tramberend committed
493
  do let f = Just (Format format)
494
495
496
     -- processed <- liftIO $ processCites' pandoc >>= walkM (useCachedImages cacheDir)
     cacheDir <- getCacheDir
     processed <- liftIO $ walkM (useCachedImages cacheDir) pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
497
498
499
500
     return $ (expandMacros f . filterNotes f) processed

type StringWriter = WriterOptions -> Pandoc -> String

Henrik Tramberend's avatar
Henrik Tramberend committed
501
writePandocString :: String
Henrik Tramberend's avatar
Henrik Tramberend committed
502
503
504
505
                  -> WriterOptions
                  -> FilePath
                  -> Pandoc
                  -> Action ()
Henrik Tramberend's avatar
Henrik Tramberend committed
506
507
508
writePandocString format options out pandoc =
  do let writer = getPandocWriter format
     writeFile' out
Henrik Tramberend's avatar
Henrik Tramberend committed
509
510
511
512
                (writer options pandoc)
     putNormal $ "# pandoc for (" ++ out ++ ")"

writeExampleProject :: Action ()
513
514
writeExampleProject = mapM_ writeOne deckerExampleDir
  where writeOne (path,contents) =
Henrik Tramberend's avatar
Henrik Tramberend committed
515
516
          do exists <- Development.Shake.doesFileExist path
             unless exists $
517
518
               do liftIO $ createDirectoryIfMissing True (takeDirectory path)
                  liftIO $ B.writeFile path contents
Henrik Tramberend's avatar
Henrik Tramberend committed
519
520
                  putNormal $ "# create (for " ++ path ++ ")"

521
522
523
524
525
526
527
528
529
530
531
writeEmbeddedFiles :: [(FilePath, B.ByteString)] -> FilePath -> Action ()
writeEmbeddedFiles files dir =
  do let absolute = map (\(path,contents) -> (dir </> path,contents)) files
     mapM_ write absolute
  where write (path,contents) =
          do liftIO $
               Dir.createDirectoryIfMissing True
                                            (takeDirectory path)
             exists <- liftIO $ Dir.doesFileExist path
             when (not exists) $ liftIO $ B.writeFile path contents

Henrik Tramberend's avatar
Henrik Tramberend committed
532
lookupValue :: String -> Y.Value -> Maybe Y.Value
533
lookupValue key (Y.Object hashTable) =
Henrik Tramberend's avatar
Henrik Tramberend committed
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
  HashMap.lookup (T.pack key)
                 hashTable
lookupValue key _ = Nothing

metaValueAsString
  :: String -> Y.Value -> Maybe String
metaValueAsString key meta =
  case splitOn "." key of
    [] -> Nothing
    k:ks -> lookup' ks (lookupValue k meta)
  where lookup'
          :: [String] -> Maybe Y.Value -> Maybe String
        lookup' [] (Just (Y.String text)) = Just (T.unpack text)
        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

-- | Tool specific exceptions
data DeckerException
  = MustacheException String
  | PandocException String
  | YamlException String
557
  | RsyncUrlException
Henrik Tramberend's avatar
Henrik Tramberend committed
558
559
560
561
562
563
564
565
566
  | DecktapeException String
  deriving (((Typeable)))

instance Exception DeckerException

instance Show DeckerException where
  show (MustacheException e) = e
  show (PandocException e) = e
  show (YamlException e) = e
567
568
  show (DecktapeException e) =
    "decktape.sh failed for reason: " ++ e
569
  show RsyncUrlException =
Henrik Tramberend's avatar
Henrik Tramberend committed
570
    "attributes 'destinationRsyncHost' or 'destinationRsyncPath' not defined in meta data"