utilities.hs 18.3 KB
Newer Older
Henrik Tramberend's avatar
Henrik Tramberend committed
1
2
3
{-# LANGUAGE TemplateHaskell #-}

module Utilities
4
5
6
       (cacheRemoteImages, calcProjectDirectory, helpText, spawn,
        terminate, threadDelay', wantRepeat, waitForModificationIn,
        defaultContext, runShakeInContext, watchFiles,
Henrik Tramberend's avatar
Henrik Tramberend committed
7
8
9
10
        waitForTwitch, dropSuffix, stopServer, startServer, runHttpServer,
        writeIndex, readMetaData, readMetaDataIO, substituteMetaData,
        markdownToHtmlDeck, markdownToHtmlHandout, markdownToPdfHandout,
        markdownToHtmlPage, markdownToPdfPage, getBaseUrl,
11
12
        writeExampleProject, metaValueAsString, (<++>), markNeeded,
        replaceSuffixWith, DeckerException(..))
Henrik Tramberend's avatar
Henrik Tramberend committed
13
14
15
16
17
18
19
20
       where

import Control.Monad.Loops
import Control.Monad
import Control.Concurrent
import Control.Exception
import Development.Shake
import Development.Shake.FilePath
21
import Data.Dynamic
Henrik Tramberend's avatar
Henrik Tramberend committed
22
23
24
25
26
27
28
29
30
31
32
33
import Data.List.Extra
import Data.Maybe
import Data.FileEmbed
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
34
import System.Directory as Dir
Henrik Tramberend's avatar
Henrik Tramberend committed
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
import Context

-- 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
70
71
72
73
74
75
76

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

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

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

105
stopServer id =
Henrik Tramberend's avatar
Henrik Tramberend committed
106
107
108
109
110
  liftIO $
  do let pidFile = id ++ ".pid"
     result <- try $ readFile pidFile
     case result of
       Left (SomeException e) -> print $ "Unable to read file " ++ pidFile
111
       Right pid ->
Henrik Tramberend's avatar
Henrik Tramberend committed
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
         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

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

defaultContext = Context [] Nothing

135
136
137
138
runShakeInContext :: ActionContext -> ShakeOptions -> Rules () -> IO ()
runShakeInContext context options rules =
  do opts <- setActionContext context options
     tid <- myThreadId
Henrik Tramberend's avatar
Henrik Tramberend committed
139
     installHandler keyboardSignal
140
                    (Catch (cleanup tid))
Henrik Tramberend's avatar
Henrik Tramberend committed
141
                    Nothing
142
143
144
145
146
147
148
     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
149
150
151
152
             case process of
               Just handle -> terminateProcess handle
               Nothing -> return ()
             throwTo tid ExitSuccess
153
154
155
156
157
158
        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
159

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


-- | Actively waits for the first change to any member in the set of specified
-- | files and their parent directories, then returns.
165
waitForTwitch files =
Henrik Tramberend's avatar
Henrik Tramberend committed
166
167
168
169
170
  do startTime <- getCurrentTime
     let dirs = map takeDirectory files
     let filesAndDirs = Set.toList . Set.fromList $ files ++ dirs
     whileM_ (noModificationSince startTime filesAndDirs)
             (threadDelay 300000)
171
  where noModificationSince startTime pathes =
Henrik Tramberend's avatar
Henrik Tramberend committed
172
173
          do modified <- mapM (modifiedSince startTime) pathes
             return $ not (or modified)
174
        modifiedSince time path =
Henrik Tramberend's avatar
Henrik Tramberend committed
175
176
177
178
179
180
          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]
181
(<++>) = liftM2 (++)
Henrik Tramberend's avatar
Henrik Tramberend committed
182
183
184

-- | Mark files as need and return them
markNeeded :: [FilePath] -> Action [FilePath]
185
markNeeded files =
Henrik Tramberend's avatar
Henrik Tramberend committed
186
187
188
189
190
191
192
193
194
  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]
195
replaceSuffixWith suffix with pathes =
Henrik Tramberend's avatar
Henrik Tramberend committed
196
197
  return [dropSuffix suffix d ++ with | d <- pathes]

198
199
200
201
202
203
204
205
206
207
208
209
210
211
-- | 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.
writeIndex out baseUrl decks handouts pages plain =
  do let decksLinks = map (makeRelative baseUrl) decks
     let handoutsLinks = map (makeRelative baseUrl) handouts
     let pagesLinks = map (makeRelative baseUrl) pages
     let plainLinks = map (makeRelative baseUrl) plain
     liftIO $
       writeFile out $
Henrik Tramberend's avatar
Henrik Tramberend committed
212
213
       unlines ["# Index"
               ,"## Slide decks"
214
               ,unlines $ map makeLink decksLinks
Henrik Tramberend's avatar
Henrik Tramberend committed
215
               ,"## Handouts"
216
               ,unlines $ map makeLink handoutsLinks
Henrik Tramberend's avatar
Henrik Tramberend committed
217
               ,"## Supporting Documents"
218
               ,unlines $ map makeLink pagesLinks
Henrik Tramberend's avatar
Henrik Tramberend committed
219
               ,"## Everything else"
220
               ,unlines $ map makeLink plainLinks]
Henrik Tramberend's avatar
Henrik Tramberend committed
221
222
223
224
225
  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
226
readMetaDataIO files =
Henrik Tramberend's avatar
Henrik Tramberend committed
227
  mapM decode files >>= foldM combine (Y.Object HashMap.empty)
228
  where decode file =
Henrik Tramberend's avatar
Henrik Tramberend committed
229
230
          do result <- Y.decodeFileEither file
             return (file,result)
231
        combine (Y.Object obj) (file,Right (Y.Object new)) =
Henrik Tramberend's avatar
Henrik Tramberend committed
232
          return (Y.Object (HashMap.union new obj))
233
        combine obj (file,Right _) =
Henrik Tramberend's avatar
Henrik Tramberend committed
234
235
236
237
          do throw $
               YamlException $
               file ++ ": top level metadata is not a YAML object."
             return obj
238
        combine obj (file,Left err) =
Henrik Tramberend's avatar
Henrik Tramberend committed
239
240
241
242
243
244
245
246
247
          do throw $
               YamlException $ file ++ ": " ++ Y.prettyPrintParseException err
             return obj

readMetaData files = liftIO $ readMetaDataIO files

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

254
getBaseUrl =
Henrik Tramberend's avatar
Henrik Tramberend committed
255
256
  getEnvWithDefault "https://tramberend.beuth-hochschule.de/cdn/" "DECKER_RESOURCE_BASE_URL"

257
258
259
260
-- | The help page
helpText :: B.ByteString
helpText = $(makeRelativeToProject "resource/help-page.md" >>= embedFile)

Henrik Tramberend's avatar
Henrik Tramberend committed
261
deckTemplate :: String
262
deckTemplate =
Henrik Tramberend's avatar
Henrik Tramberend committed
263
264
265
266
267
268
269
270
271
  B.unpack $(makeRelativeToProject "resource/deck.html" >>= embedFile)

-- | Write a markdown file to a HTML file using the page template.
markdownToHtmlDeck
  :: FilePath -> [FilePath] -> FilePath -> Action ()
markdownToHtmlDeck markdownFile metaFiles out =
  do need $ markdownFile : metaFiles
     pandoc <- readMetaMarkdown markdownFile metaFiles
     processed <- processPandocDeck "revealjs" pandoc
272
273
     let images = extractLocalImagePathes pandoc
     putNormal $ "images: " ++ show images
Henrik Tramberend's avatar
Henrik Tramberend committed
274
     baseUrl <- getBaseUrl
275
     let options =
Henrik Tramberend's avatar
Henrik Tramberend committed
276
277
278
279
280
281
           def {writerHtml5 = True
               ,writerStandalone = True
               ,writerTemplate = deckTemplate
               ,writerSlideVariant = RevealJsSlides
               ,writerHighlight = True
               ,writerHighlightStyle = pygments
282
               ,writerHTMLMathMethod =
Henrik Tramberend's avatar
Henrik Tramberend committed
283
284
285
286
287
288
289
                  KaTeX (baseUrl ++ "katex-0.6.0/katex.min.js")
                        (baseUrl ++ "katex-0.6.0/katex.min.css")
               ,writerVariables = [("revealjs-url",baseUrl ++ "reveal.js")]
               ,writerCiteMethod = Citeproc}
     writePandocString writeHtmlString options out processed

pageTemplate :: String
290
pageTemplate =
Henrik Tramberend's avatar
Henrik Tramberend committed
291
292
293
  B.unpack $(makeRelativeToProject "resource/page.html" >>= embedFile)

pageLatexTemplate :: String
294
pageLatexTemplate =
Henrik Tramberend's avatar
Henrik Tramberend committed
295
296
297
298
299
300
301
302
303
304
  B.unpack $(makeRelativeToProject "resource/page.tex" >>= embedFile)

-- | Write a markdown file to a HTML file using the page template.
markdownToHtmlPage
  :: FilePath -> [FilePath] -> FilePath -> Action ()
markdownToHtmlPage markdownFile metaFiles out =
  do need $ markdownFile : metaFiles
     pandoc <- readMetaMarkdown markdownFile metaFiles
     processed <- processPandocDeck "html" pandoc
     baseUrl <- getBaseUrl
305
     let options =
Henrik Tramberend's avatar
Henrik Tramberend committed
306
307
308
309
310
           def {writerHtml5 = True
               ,writerStandalone = True
               ,writerTemplate = pageTemplate
               ,writerHighlight = True
               ,writerHighlightStyle = pygments
311
               ,writerHTMLMathMethod =
Henrik Tramberend's avatar
Henrik Tramberend committed
312
313
314
315
316
317
318
319
                  KaTeX (baseUrl ++ "katex-0.6.0/katex.min.js")
                        (baseUrl ++ "katex-0.6.0/katex.min.css")
               ,writerCiteMethod = Citeproc}
     writePandocString writeHtmlString options out processed

-- | Write a markdown file to a PDF file using the handout template.
markdownToPdfPage
  :: FilePath -> [FilePath] -> FilePath -> Action ()
320
markdownToPdfPage markdownFile metaFiles out =
Henrik Tramberend's avatar
Henrik Tramberend committed
321
322
323
324
  do need $ markdownFile : metaFiles
     pandoc <- readMetaMarkdown markdownFile metaFiles
     processed <- processPandoc "latex" pandoc
     baseUrl <- getBaseUrl
325
     let options =
Henrik Tramberend's avatar
Henrik Tramberend committed
326
327
328
329
330
331
332
333
           def {writerStandalone = True
               ,writerTemplate = pageLatexTemplate
               ,writerHighlight = True
               ,writerHighlightStyle = pygments
               ,writerCiteMethod = Citeproc}
     putNormal $ "# pandoc (for " ++ out ++ ")"
     pandocMakePdf options processed out

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

handoutTemplate :: String
341
handoutTemplate =
Henrik Tramberend's avatar
Henrik Tramberend committed
342
343
344
  B.unpack $(makeRelativeToProject "resource/handout.html" >>= embedFile)

handoutLatexTemplate :: String
345
handoutLatexTemplate =
Henrik Tramberend's avatar
Henrik Tramberend committed
346
347
348
349
350
  B.unpack $(makeRelativeToProject "resource/handout.tex" >>= embedFile)

-- | Write a markdown file to a HTML file using the handout template.
markdownToHtmlHandout
  :: FilePath -> [FilePath] -> FilePath -> Action ()
351
markdownToHtmlHandout markdownFile metaFiles out =
Henrik Tramberend's avatar
Henrik Tramberend committed
352
353
354
355
  do need $ markdownFile : metaFiles
     pandoc <- readMetaMarkdown markdownFile metaFiles
     processed <- processPandocHandout "html" pandoc
     baseUrl <- getBaseUrl
356
     let options =
Henrik Tramberend's avatar
Henrik Tramberend committed
357
358
359
360
361
           def {writerHtml5 = True
               ,writerStandalone = True
               ,writerTemplate = handoutTemplate
               ,writerHighlight = True
               ,writerHighlightStyle = pygments
362
               ,writerHTMLMathMethod =
Henrik Tramberend's avatar
Henrik Tramberend committed
363
364
365
366
367
368
369
370
371
372
373
374
375
                  KaTeX (baseUrl ++ "katex-0.6.0/katex.min.js")
                        (baseUrl ++ "katex-0.6.0/katex.min.css")
               ,writerCiteMethod = Citeproc}
     writePandocString writeHtmlString options out processed

-- | 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
     pandoc <- readMetaMarkdown markdownFile metaFiles
     processed <- processPandocHandout "latex" pandoc
     baseUrl <- getBaseUrl
376
     let options =
Henrik Tramberend's avatar
Henrik Tramberend committed
377
378
379
380
381
382
383
384
385
386
           def {writerStandalone = True
               ,writerTemplate = handoutLatexTemplate
               ,writerHighlight = True
               ,writerHighlightStyle = pygments
               ,writerCiteMethod = Citeproc}
     putNormal $ "# pandoc (for " ++ out ++ ")"
     pandocMakePdf options processed out

readMetaMarkdown
  :: FilePath -> [FilePath] -> Action Pandoc
387
readMetaMarkdown markdownFile metaFiles =
Henrik Tramberend's avatar
Henrik Tramberend committed
388
  do metaData <- readMetaData metaFiles
389
     text <-
Henrik Tramberend's avatar
Henrik Tramberend committed
390
391
392
393
394
395
       substituteMetaData markdownFile
                          (MT.mFromJSON metaData)
     case readMarkdown def $ T.unpack text of
       Right pandoc -> return pandoc
       Left err -> throw $ PandocException (show err)

396
397
398
399
400
401
402
cacheRemoteImages :: FilePath -> [FilePath] -> [FilePath] -> Action ()
cacheRemoteImages cacheDir metaFiles markdownFiles =
  do mapM_ cacheImages markdownFiles
  where cacheImages markdownFile =
          do pandoc <- readMetaMarkdown markdownFile metaFiles
             liftIO $ walkM (cachePandocImages cacheDir) pandoc
             putNormal $ "# pandoc (cached images for " ++ markdownFile ++ ")"
Henrik Tramberend's avatar
Henrik Tramberend committed
403
404
405

processPandoc
  :: String -> Pandoc -> Action Pandoc
406
processPandoc format pandoc =
Henrik Tramberend's avatar
Henrik Tramberend committed
407
  do let f = Just (Format format)
408
409
410
     -- processed <- liftIO $ processCites' pandoc >>= walkM (useCachedImages cacheDir)
     cacheDir <- getCacheDir
     processed <- liftIO $ walkM (useCachedImages cacheDir) pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
411
412
413
414
     return $ expandMacros f processed

processPandocDeck
  :: String -> Pandoc -> Action Pandoc
415
processPandocDeck format pandoc =
Henrik Tramberend's avatar
Henrik Tramberend committed
416
  do let f = Just (Format format)
417
418
419
     -- processed <- liftIO $ processCites' pandoc >>= walkM (useCachedImages cacheDir)
     cacheDir <- getCacheDir
     processed <- liftIO $ walkM (useCachedImages cacheDir) pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
420
421
422
423
     return $ (makeSlides f . expandMacros f) processed

processPandocHandout
  :: String -> Pandoc -> Action Pandoc
424
processPandocHandout format pandoc =
Henrik Tramberend's avatar
Henrik Tramberend committed
425
  do let f = Just (Format format)
426
427
428
     -- processed <- liftIO $ processCites' pandoc >>= walkM (useCachedImages cacheDir)
     cacheDir <- getCacheDir
     processed <- liftIO $ walkM (useCachedImages cacheDir) pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
429
430
431
432
433
434
435
436
437
     return $ (expandMacros f . filterNotes f) processed

type StringWriter = WriterOptions -> Pandoc -> String

writePandocString :: StringWriter
                  -> WriterOptions
                  -> FilePath
                  -> Pandoc
                  -> Action ()
438
writePandocString writer options out pandoc =
Henrik Tramberend's avatar
Henrik Tramberend committed
439
440
441
442
443
444
  do writeFile' out
                (writer options pandoc)
     putNormal $ "# pandoc for (" ++ out ++ ")"

writeExampleProject :: Action ()
writeExampleProject = mapM_ writeOne deckerExampleFiles
445
  where deckerExampleFiles =
Henrik Tramberend's avatar
Henrik Tramberend committed
446
447
448
449
450
451
452
453
454
          [("example-deck.md"
           ,B.unpack $(makeRelativeToProject "resource/example/example-deck.md" >>=
                       embedFile))
          ,("example-meta.yaml"
           ,B.unpack $(makeRelativeToProject "resource/example/example-meta.yaml" >>=
                       embedFile))
          ,("example-page.md"
           ,B.unpack $(makeRelativeToProject "resource/example/example-page.md" >>=
                       embedFile))]
455
        writeOne (path,contents) =
Henrik Tramberend's avatar
Henrik Tramberend committed
456
457
458
459
460
461
          do exists <- Development.Shake.doesFileExist path
             unless exists $
               do writeFile' path contents
                  putNormal $ "# create (for " ++ path ++ ")"

lookupValue :: String -> Y.Value -> Maybe Y.Value
462
lookupValue key (Y.Object hashTable) =
Henrik Tramberend's avatar
Henrik Tramberend committed
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
  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
486
  | RsyncUrlException
Henrik Tramberend's avatar
Henrik Tramberend committed
487
488
489
490
491
492
493
494
495
  | DecktapeException String
  deriving (((Typeable)))

instance Exception DeckerException

instance Show DeckerException where
  show (MustacheException e) = e
  show (PandocException e) = e
  show (YamlException e) = e
496
  show (DecktapeException cdn) =
Henrik Tramberend's avatar
Henrik Tramberend committed
497
498
    "decktape.sh failed. Is environment varible 'DECKER_RESOURCE_BASE_URL' set correctly (currently " ++
    cdn ++ ")?"
499
  show RsyncUrlException =
Henrik Tramberend's avatar
Henrik Tramberend committed
500
    "attributes 'destinationRsyncHost' or 'destinationRsyncPath' not defined in meta data"