Utilities.hs 29.8 KB
Newer Older
1
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
Henrik Tramberend's avatar
Henrik Tramberend committed
2
module Utilities
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
  , (<++>)
  , 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

Henrik Tramberend's avatar
Henrik Tramberend committed
43
import Common
44 45
import Context
import Control.Arrow
Henrik Tramberend's avatar
Henrik Tramberend committed
46 47
import Control.Concurrent
import Control.Exception
48
import Control.Monad
49
import Control.Monad.IO.Class (MonadIO)
50 51 52 53 54 55 56 57
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
58
import Data.List
Henrik Tramberend's avatar
Henrik Tramberend committed
59
import Data.List.Extra
60
import qualified Data.Map.Lazy as Map
Henrik Tramberend's avatar
Henrik Tramberend committed
61
import Data.Maybe
62
import qualified Data.Set as Set
Henrik Tramberend's avatar
Henrik Tramberend committed
63
import qualified Data.Text as T
64
import qualified Data.Text.Encoding as E
65 66
import qualified Data.Vector as Vec
import qualified Data.Yaml as Y
67 68

-- import Debug.Trace
69 70 71 72 73 74 75 76
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
77
import Project
78
import qualified System.Directory as Dir
79
import System.FilePath as SF
Henrik Tramberend's avatar
Henrik Tramberend committed
80
import System.FilePath.Glob
Henrik Tramberend's avatar
Henrik Tramberend committed
81
import System.IO as S
82 83 84
import System.Process
import System.Process.Internals
import Text.CSL.Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
85 86 87 88
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Text.Pandoc
import Text.Pandoc.PDF
89
import Text.Pandoc.Shared
90
import Text.Pandoc.Walk
91
import Watch
92

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

110
-- | Globs for files under the project dir in the Action monad. 
111 112
-- Returns absolute pathes.
-- TODO: Remove matches under 'public', 'support', and 'cache'. 
113
globA :: FilePattern -> Action [FilePath]
114
globA pat = do
115 116
  dirs <- getProjectDirs
  liftIO $ globDir1 (compile pat) (project dirs)
117 118 119 120

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

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

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

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

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

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

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

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

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

defaultContext = Context [] Nothing

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Reads a markdownfile, expands the included files, and substitutes mustache
350 351
-- template variables and calls need.
readAndPreprocessMarkdown :: FilePath -> Action Pandoc
352
readAndPreprocessMarkdown markdownFile = do
353
  dirs <- getProjectDirs
354
  let baseDir = takeDirectory markdownFile
Henrik Tramberend's avatar
Henrik Tramberend committed
355 356
  readMetaMarkdown markdownFile >>= processIncludes (project dirs) baseDir >>=
    locateTemplates (project dirs) baseDir
357 358
  -- Disable automatic caching of remomte images for a while
  -- >>= populateCache
Henrik Tramberend's avatar
Henrik Tramberend committed
359 360

populateCache :: Pandoc -> Action Pandoc
361
populateCache pandoc = do
362 363
  dirs <- getProjectDirs
  liftIO $ walkM (cacheRemoteImages (cache dirs)) pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
364

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

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

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

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

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

483 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
-- | 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 []

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

pandocReaderOpts :: ReaderOptions
518
pandocReaderOpts = def {readerExtensions = deckerPandocExtensions}
519 520

pandocWriterOpts :: WriterOptions
521
pandocWriterOpts = def {writerExtensions = deckerPandocExtensions}
522

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

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

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

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

Henrik Tramberend's avatar
Henrik Tramberend committed
566 567 568 569
locateTemplates :: FilePath -> FilePath -> Pandoc -> Action Pandoc
locateTemplates root base (Pandoc meta blocks) = do
  return (Pandoc meta blocks)

570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 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 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642
-- TODO: Make this compile, then work
provisionResources :: ProjectDirs -> FilePath -> Pandoc -> Action Pandoc
provisionResources dirs base pandoc@(Pandoc meta blocks) = do
  let method = provisioningFromMeta meta
  liftIO $ do
    processedBlocks <-
      walkM (processInline dirs base method) blocks >>=
      walkM (processBlock dirs base method)
    processedMeta <- processMeta dirs base method meta
    return (Pandoc processedMeta processedBlocks)

elementAttributes =
  [ "src"
  , "data-src"
  , "data-markdown"
  , "data-background-video"
  , "data-background-image"
  , "data-background-iframe"
  ]

metaKeys = ["css", "bibliography", "csl", "citation-abbreviations"]

processAttributes :: ProjectDirs -> FilePath -> Provisioning -> Attr -> IO Attr
processAttributes dirs base method (ident, classes, kv) = do
  processed <- mapM provisionAttrib kv
  return (ident, classes, processed)
  where
    provisionAttrib (key, value) = do
      if elem key metaKeys
        then do
          resource <- provisionResource method dirs base value
          print (key, resource)
          return (key, resource)
        else return (key, value)

processInline :: ProjectDirs -> FilePath -> Provisioning -> Inline -> IO Inline
processInline dirs base method img@(Image attr@(_, cls, _) inlines (url, title)) = do
  if not $ isMacro $ stringify inlines
    then do
      a <- processAttributes dirs base method attr
      u <- provisionResource (provisioningFromClasses method cls) dirs base url
      return $ renderImageVideo $ Image a inlines (u, title)
    else return img
processInline dirs base method lnk@(Link attr@(_, cls, _) inlines (url, title)) = do
  if not (isMacro $ stringify inlines) && "resource" `elem` cls
    then do
      a <- processAttributes dirs base method attr
      u <- provisionResource (provisioningFromClasses method cls) dirs base url
      return (Link a inlines (u, title))
    else return lnk
processInline dirs base method (Span attr inlines) = do
  processed <- processAttributes dirs base method attr
  return (Span processed inlines)
processInline dirs base method (Code attr string) = do
  processed <- processAttributes dirs base method attr
  return (Code processed string)
processInline _ _ _ inline = return inline

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

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

Henrik Tramberend's avatar
Henrik Tramberend committed
643
-- Transitively splices all include files into the pandoc document.
644
processIncludes :: FilePath -> FilePath -> Pandoc -> Action Pandoc
645
processIncludes rootDir baseDir (Pandoc meta blocks) = do
646 647
  included <- processBlocks baseDir blocks
  return $ Pandoc meta included
648 649 650
  where
    processBlocks :: FilePath -> [Block] -> Action [Block]
    processBlocks base blcks = do
651 652
      spliced <- foldM (include base) [] blcks
      return $ concat $ reverse spliced
653
    include :: FilePath -> [[Block]] -> Block -> Action [[Block]]
654
    include base result (Para [Link _ [Str "#include"] (url, _)]) = do
655
      filePath <- liftIO $ findFile rootDir base url
656 657 658
      Pandoc _ b <- readMetaMarkdown filePath
      included <- processBlocks (takeDirectory filePath) b
      return $ included : result
659
    include _ result block = return $ [block] : result
660

Henrik Tramberend's avatar
Henrik Tramberend committed
661
cacheRemoteImages :: FilePath -> Pandoc -> IO Pandoc
662
cacheRemoteImages cacheDir = walkM cacheRemoteImage
663
  where
664 665 666
    cacheRemoteImage (Image attr inlines (url, title)) = do
      cachedFile <- cacheRemoteFile cacheDir url
      return (Image attr inlines (cachedFile, title))
667
    cacheRemoteImage img = return img
Henrik Tramberend's avatar
Henrik Tramberend committed
668 669 670

cacheRemoteFile :: FilePath -> String -> IO FilePath
cacheRemoteFile cacheDir url
671
  | isCacheableURI url = do
672 673 674 675 676 677
    let cacheFile = cacheDir </> hashURI url
    exists <- Dir.doesFileExist cacheFile
    if exists
      then return cacheFile
      else catch
             (do content <- downloadUrl url
678
                 Dir.createDirectoryIfMissing True cacheDir
679 680 681 682 683
                 LB.writeFile cacheFile content
                 return cacheFile)
             (\e -> do
                putStrLn $ "Warning: " ++ show (e :: SomeException)
                return url)
Henrik Tramberend's avatar
Henrik Tramberend committed
684 685
cacheRemoteFile _ url = return url

686 687 688 689 690 691 692
-- 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
693
downloadUrl :: String -> IO LB.ByteString
694
downloadUrl url = do
695 696 697 698 699 700 701 702 703 704 705 706
  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
707 708

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

711
processPandocPage :: String -> Pandoc -> Action Pandoc
712
processPandocPage format pandoc = do
713
  let f = Just (Format format)
714
  dirs <- getProjectDirs
715
  processed <-
716 717
    liftIO $ processCites' pandoc >>= walkM (useCachedImages (cache dirs))
  --  processed <- liftIO $ walkM (useCachedImages (cache dirs)) pandoc
718 719 720 721 722
  return $ expandMacros f processed

processPandocDeck :: String -> Pandoc -> Action Pandoc
processPandocDeck format pandoc = do
  let f = Just (Format format)
723
  dirs <- getProjectDirs
724
  processed <-
725 726
    liftIO $ processCites' pandoc >>= walkM (useCachedImages (cache dirs))
  -- processed <- liftIO $ walkM (useCachedImages cacheD(cache dirs)ir) pandoc
727 728 729 730 731
  return $ (makeSlides f . expandMacros f) processed

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

type StringWriter = WriterOptions -> Pandoc -> String

740
writePandocString :: String -> WriterOptions -> FilePath -> Pandoc -> Action ()
741 742 743 744 745
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
746

Henrik Tramberend's avatar
Henrik Tramberend committed
747
copyImages :: FilePath -> Pandoc -> Action Pandoc
748
copyImages baseDir pandoc = do
749 750 751
  dirs <- getProjectDirs
  walkM (copyAndLinkInline (project dirs) (public dirs)) pandoc >>=
    walkM (copyAndLinkBlock (project dirs) (public dirs))
752
  where
753 754 755
    copyAndLinkInline project public (Image attr inlines (url, title)) = do
      relUrl <- copyAndLinkFile project public baseDir url
      return (Image attr inlines (relUrl, title))
756 757
    copyAndLinkInline _ _ inline = return inline
    copyAndLinkBlock project public (Header 1 attr inlines) = do
758 759
      relAttr <- copyBgImageUrl project public attr
      return (Header 1 relAttr inlines)
760
    copyAndLinkBlock _ _ block = return block
761 762 763 764
    copyBgImageUrl project public (i, cs, kvs) = do
      relKvs <-
        mapM
          (\(k, v) ->
765 766 767 768 769
             if k == "data-background-image"
               then do
                 relUrl <- copyAndLinkFile project public baseDir v
                 return (k, relUrl)
               else return (k, v))
770 771 772
          kvs
      return (i, cs, relKvs)

773 774
copyAndLinkFile ::
     FilePath -> FilePath -> FilePath -> FilePath -> Action FilePath
775
copyAndLinkFile project public base url = do
776 777 778 779 780
  let rel = makeRelative project url
  if rel == url
    then return url
    else do
      let pub = public </> rel
781
      liftIO $ Dir.createDirectoryIfMissing True (takeDirectory pub)
782
      copyFileChanged url pub
Henrik Tramberend's avatar
Henrik Tramberend committed
783
      return $ makeRelativeTo base pub
784 785 786

-- | Express the second path argument as relative to the first. 
-- Both arguments are expected to be absolute pathes. 
787 788 789 790 791 792 793 794 795 796
-- makeRelativeTo :: FilePath -> FilePath -> FilePath
-- makeRelativeTo dir file =
--   let (d, f) = removeCommonPrefix (splitDirectories dir) (splitDirectories file)
--   in normalise $ invertPath (joinPath d) </> joinPath f
-- removeCommonPrefix :: [FilePath] -> [FilePath] -> ([FilePath], [FilePath])
-- removeCommonPrefix al@(a:as) bl@(b:bs)
--  | a == b = removeCommonPrefix as bs
--  | otherwise = (al, bl)
-- removeCommonPrefix a [] = (a, [])
-- removeCommonPrefix [] b = ([], b)
Henrik Tramberend's avatar
Henrik Tramberend committed
797
writeExampleProject :: Action ()
798
writeExampleProject = mapM_ writeOne deckerExampleDir
799
  where
800 801
    writeOne (path, contents) = do
      exists <- Development.Shake.doesFileExist path
802
      unless exists $ do
803
        liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
804 805
        liftIO $ B.writeFile path contents
        putNormal $ "# create (for " ++ path ++ ")"
Henrik Tramberend's avatar
Henrik Tramberend committed
806

807
writeEmbeddedFiles :: [(FilePath, B.ByteString)] -> FilePath -> Action ()
808
writeEmbeddedFiles files dir = do
809 810
  let absolute = map (\(path, contents) -> (dir </> path, contents)) files
  mapM_ write absolute
811
  where
812 813 814 815
    write (path, contents) = do
      liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
      exists <- liftIO $ Dir.doesFileExist path
      unless exists $ liftIO $ B.writeFile path contents
816

Henrik Tramberend's avatar
Henrik Tramberend committed
817
lookupValue :: String -> Y.Value -> Maybe Y.Value
818
lookupValue key (Y.Object hashTable) = HashMap.lookup (T.pack key) hashTable
819
lookupValue _ _ = Nothing
Henrik Tramberend's avatar
Henrik Tramberend committed
820

821
metaValueAsString :: String -> Y.Value -> Maybe String
Henrik Tramberend's avatar
Henrik Tramberend committed
822
metaValueAsString key meta =
823 824 825
  case splitOn "." key of
    [] -> Nothing
    k:ks -> lookup' ks (lookupValue k meta)
826 827
  where
    lookup' :: [String] -> Maybe Y.Value -> Maybe String
828
    lookup' [] (Just (Y.String text)) = Just (T.unpack text)
829 830 831 832
    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