Commit 51733dd7 authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Gardening.

parent 3d87b35f
......@@ -21,6 +21,7 @@ import qualified Text.Mustache as M ()
import Text.Pandoc ()
import Text.Printf ()
import Utilities
import Action
main :: IO ()
main = do
......@@ -173,26 +174,3 @@ main = do
-- | Some constants that might need tweaking
options = shakeOptions {shakeFiles = ".shake"}
replaceSuffix srcSuffix targetSuffix filename =
dropSuffix srcSuffix filename ++ targetSuffix
-- | Calculates the target pathes from a list of source files.
calcTargets :: String -> String -> [FilePath] -> Action [FilePath]
calcTargets srcSuffix targetSuffix sources = do
dirs <- getProjectDirs
return $
map
(replaceSuffix srcSuffix targetSuffix .
combine (public dirs) . makeRelative (project dirs))
sources
-- | Calculate the source file from the target path. Calls need.
calcSource :: String -> String -> FilePath -> Action FilePath
calcSource targetSuffix srcSuffix target = do
dirs <- getProjectDirs
let src =
(replaceSuffix targetSuffix srcSuffix .
combine (project dirs) . makeRelative (public dirs))
target
need [src]
return src
......@@ -14,7 +14,7 @@ cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Watch, Embed, Context, Utilities, Filter, Project, Common, Server
exposed-modules: Action, Cache, Meta, Watch, Embed, Context, Utilities, Filter, Project, Common, Server
build-depends: base
, aeson
, random
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Action
( spawn
, wantRepeat
, dropSuffix
, runHttpServer
, replaceSuffix
, replaceSuffixWith
, globA
, reloadBrowsers
, calcTargets
, calcSource
, readMetaDataForDir
, DeckerException(..)
) where
import Common
import Context
import Control.Exception
import Control.Monad
import Data.IORef
import Data.List as List
import Data.List.Extra as List
import Data.Maybe
import qualified Data.Yaml as Y
import Development.Shake
import Development.Shake.FilePath as SFP
import Project
import Server
import System.FilePath.Glob
import System.Process
import Meta
-- | Globs for files under the project dir in the Action monad.
-- Returns absolute pathes.
globA :: FilePattern -> Action [FilePath]
globA pat = do
dirs <- getProjectDirs
liftIO $
filter (not . isPrefixOf (public dirs)) <$>
globDir1 (compile pat) (project dirs)
-- Utility functions for shake based apps
spawn :: String -> Action ProcessHandle
spawn = liftIO . spawnCommand
-- Runs the built-in server on the given directory, if it is not already
-- running. If open is True a browser window is opended.
runHttpServer :: ProjectDirs -> Bool -> Action ()
runHttpServer dirs open = do
server <- getServerHandle
case server of
Just _ -> return ()
Nothing -> do
let port = 8888
server <- liftIO $ startHttpServer dirs port
setServerHandle $ Just server
when open $ cmd ("open http://localhost:" ++ show port :: String) :: Action ()
reloadBrowsers :: Action ()
reloadBrowsers = do
server <- getServerHandle
case server of
Just handle -> liftIO $ reloadClients handle
Nothing -> return ()
wantRepeat :: IORef Bool -> Action ()
wantRepeat justOnce = liftIO $ writeIORef justOnce False
-- | Calculates the target pathes from a list of source files.
calcTargets :: String -> String -> [FilePath] -> Action [FilePath]
calcTargets srcSuffix targetSuffix sources = do
dirs <- getProjectDirs
return $
map
(replaceSuffix srcSuffix targetSuffix .
combine (public dirs) . makeRelative (project dirs))
sources
-- | Calculate the source file from the target path. Calls need.
calcSource :: String -> String -> FilePath -> Action FilePath
calcSource targetSuffix srcSuffix target = do
dirs <- getProjectDirs
let src =
(replaceSuffix targetSuffix srcSuffix .
combine (project dirs) . makeRelative (public dirs))
target
need [src]
return src
-- | Removes the last suffix from a filename
dropSuffix s t = fromMaybe t (stripSuffix s t)
replaceSuffix srcSuffix targetSuffix filename =
dropSuffix srcSuffix filename ++ targetSuffix
-- | Monadic version of suffix replacement for easy binding.
replaceSuffixWith :: String -> String -> [FilePath] -> Action [FilePath]
replaceSuffixWith suffix with pathes =
return [dropSuffix suffix d ++ with | d <- pathes]
readMetaDataForDir :: FilePath -> Action Y.Value
readMetaDataForDir dir = walkUpTo dir
where
walkUpTo dir = do
dirs <- getProjectDirs
if equalFilePath (project dirs) dir
then collectMeta dir
else do
fromAbove <- walkUpTo (takeDirectory dir)
fromHere <- collectMeta dir
return $ joinMeta fromHere fromAbove
--
collectMeta dir = do
files <- liftIO $ globDir1 (compile "*-meta.yaml") dir
need files
meta <- mapM decodeYaml files
return $ foldl joinMeta (Y.object []) meta
--
decodeYaml yamlFile = do
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
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Cache
( isCacheableURI
, cacheRemoteFile
, cacheRemoteImages
) where
import Common
import Control.Exception
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 Development.Shake.FilePath as SFP
import Network.HTTP.Conduit
import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Network.URI
import qualified System.Directory as Dir
import System.FilePath as SF
import Text.Pandoc
import Text.Pandoc.Walk
cacheRemoteImages :: FilePath -> Pandoc -> IO Pandoc
cacheRemoteImages cacheDir = walkM cacheRemoteImage
where
cacheRemoteImage (Image attr inlines (url, title)) = do
cachedFile <- cacheRemoteFile cacheDir url
return (Image attr inlines (cachedFile, title))
cacheRemoteImage img = return img
cacheRemoteFile :: FilePath -> String -> IO FilePath
cacheRemoteFile cacheDir url
| isCacheableURI url = do
let cacheFile = cacheDir </> hashURI url
exists <- Dir.doesFileExist cacheFile
if exists
then return cacheFile
else catch
(do content <- downloadUrl url
Dir.createDirectoryIfMissing True cacheDir
LB.writeFile cacheFile content
return cacheFile)
(\e -> do
putStrLn $ "Warning: " ++ show (e :: SomeException)
return url)
cacheRemoteFile _ url = return url
-- 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 ()
downloadUrl :: String -> IO LB.ByteString
downloadUrl url = do
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) ++ ")"
isCacheableURI :: String -> Bool
isCacheableURI url =
case parseURI url of
Just uri -> uriScheme uri `elem` ["http:", "https:"]
Nothing -> False
hashURI :: String -> String
hashURI uri = show (md5 $ L8.pack uri) SF.<.> SF.takeExtension uri
......@@ -30,3 +30,4 @@ instance Show DeckerException where
show (DecktapeException e) = "decktape.sh failed for reason: " ++ e
show RsyncUrlException =
"attributes 'destinationRsyncHost' or 'destinationRsyncPath' not defined in meta data"
......@@ -22,7 +22,6 @@ import Data.Maybe (fromMaybe)
import Data.Typeable ()
import Development.Shake
import Project
import System.Process
import Server
data ActionContext = ActionContext
......
......@@ -36,7 +36,7 @@ import Text.Blaze.Html5 as H
((!), audio, div, figure, iframe, img, p, source, stringTag,
toValue, video)
import Text.Blaze.Html5.Attributes as A
(alt, class_, height, id, src, style, title, width)
(alt, class_, height, id, preload, src, style, title, width)
import Text.Pandoc.Definition ()
import Text.Pandoc.JSON
import Text.Pandoc.Shared
......@@ -352,13 +352,17 @@ data Disposition
-- Renders an image with a video reference to a video tag in raw HTML. Faithfully
-- transfers attributes to the video tag.
renderImageVideo :: Disposition -> Inline -> IO Inline
renderImageVideo disposition image@(Image (ident, cls, values) inlines (url, tit)) =
renderImageVideo disposition (Image (ident, cls, values) inlines (url, tit)) =
return $ RawInline (Format "html") (renderHtml $ mediaTag which)
where
which =
case takeExtension url of
ext | ext `elem` videoExtensions -> video "Browser does not support video."
ext | ext `elem` audioExtensions -> audio "Browser does not support audio."
ext
| ext `elem` videoExtensions ->
video "Browser does not support video."
ext
| ext `elem` audioExtensions ->
audio "Browser does not support audio."
_ -> img
appendAttr element (key, value) =
element ! customAttribute (stringTag key) (toValue value)
......@@ -366,7 +370,8 @@ renderImageVideo disposition image@(Image (ident, cls, values) inlines (url, tit
ifNotEmpty A.id ident $
ifNotEmpty class_ (unwords cls) $
ifNotEmpty alt (stringify inlines) $
ifNotEmpty title tit $ foldl appendAttr tag transformedValues
ifNotEmpty title tit $
foldl appendAttr tag transformedValues
ifNotEmpty attr value element =
if value == ""
then element
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Meta
( toPandocMeta
, toMustacheMeta
, mergePandocMeta
, joinMeta
, DeckerException(..)
) where
import Common
import Control.Arrow
import Control.Exception
import qualified Data.HashMap.Strict as H
import qualified Data.Map.Lazy as Map
import qualified Data.Text as T
import qualified Data.Vector as Vec
import qualified Data.Yaml as Y
import qualified Text.Mustache.Types as MT
import Text.Pandoc
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."
-- | 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 []
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Utilities
( spawn
, threadDelay'
, wantRepeat
, defaultContext
, runShakeInContext
( runShakeInContext
, watchFiles
, dropSuffix
, runHttpServer
, writeIndex
, readMetaDataForDir
, substituteMetaData
......@@ -19,36 +13,24 @@ module Utilities
, writeExampleProject
, metaValueAsString
, (<++>)
, replaceSuffixWith
, writeEmbeddedFiles
, getRelativeSupportDir
, pandocMakePdf
, isCacheableURI
, adjustLocalUrl
, cacheRemoteFile
, cacheRemoteImages
, fixMustacheMarkup
, fixMustacheMarkupText
, globA
, toPandocMeta
, reloadBrowsers
, DeckerException(..)
) where
import Common
import Context
import Control.Arrow
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (MonadIO)
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
import Data.List as List
import Data.List.Extra as List
......@@ -57,24 +39,16 @@ import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Vector as Vec
import qualified Data.Yaml as Y
import Development.Shake
import Development.Shake.FilePath as SFP
import Embed
import Filter
import Network.HTTP.Conduit
import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Network.URI
import Project
import Server
import qualified System.Directory as Dir
import System.FilePath as SF
import System.FilePath.Glob
import System.IO as S
import System.Process
import System.Process.Internals
import Text.CSL.Pandoc
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
......@@ -83,53 +57,8 @@ import Text.Pandoc.PDF
import Text.Pandoc.Shared
import Text.Pandoc.Walk
import Watch
-- | Globs for files under the project dir in the Action monad.
-- Returns absolute pathes.
globA :: FilePattern -> Action [FilePath]
globA pat = do
dirs <- getProjectDirs
liftIO $
filter (not . isPrefixOf (public dirs)) <$>
globDir1 (compile pat) (project dirs)
-- Utility functions for shake based apps
spawn :: String -> Action ProcessHandle
spawn = liftIO . spawnCommand
-- Runs liveroladx on the given directory, if it is not already running. If
-- open is True a browser window is opended.
runHttpServer :: ProjectDirs -> Bool -> Action ()
runHttpServer dirs open = do
server <- getServerHandle
case server of
Just _ -> return ()
Nothing -> do
let port = 8888
server <- liftIO $ startHttpServer dirs port
setServerHandle $ Just server
when open $ cmd ("open http://localhost:" ++ show port :: String) :: Action ()
reloadBrowsers :: Action ()
reloadBrowsers = do
server <- getServerHandle
case server of
Just handle -> liftIO $ reloadClients handle
Nothing -> return ()
threadDelay' :: Int -> Action ()
threadDelay' = liftIO . threadDelay
wantRepeat :: IORef Bool -> Action ()
wantRepeat justOnce = liftIO $ writeIORef justOnce False
-- The context of program invocation consists of a list of
-- files to watch and a possibly running local http server.
data Context =
Context [FilePath]
(Maybe ProcessHandle)
defaultContext = Context [] Nothing
import Action
import Meta
runShakeInContext :: ActionContext -> ShakeOptions -> Rules () -> IO ()
runShakeInContext context options rules = do
......@@ -164,20 +93,6 @@ watchFiles = setFilesToWatch
(<++>) :: Monad m => m [a] -> m [a] -> m [a]
(<++>) = liftM2 (++)
-- | 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]
replaceSuffixWith suffix with pathes =
return [dropSuffix suffix d ++ with | d <- pathes]
-- | 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 = do
let decksLinks = map (makeRelative baseUrl) decks
......@@ -201,38 +116,6 @@ writeIndex out baseUrl decks handouts pages = do
where
makeLink path = "- [" ++ takeFileName path ++ "](" ++ path ++ ")"
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."
readMetaDataForDir :: FilePath -> Action Y.Value
readMetaDataForDir dir = walkUpTo dir
where
walkUpTo dir = do
dirs <- getProjectDirs
if equalFilePath (project dirs) dir
then collectMeta dir
else do
fromAbove <- walkUpTo (takeDirectory dir)
fromHere <- collectMeta dir
return $ joinMeta fromHere fromAbove
--
collectMeta dir = do
files <- liftIO $ globDir1 (compile "*-meta.yaml") dir
need files
meta <- mapM decodeYaml files
return $ foldl joinMeta (Y.object []) meta
--
decodeYaml yamlFile = do
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
-- | Fixes pandoc escaped # markup in mustache template {{}} markup.
fixMustacheMarkup :: B.ByteString -> T.Text
......@@ -470,33 +353,6 @@ readMarkdownOrThrow opts string =
Right pandoc -> pandoc
Left err -> throw $ PandocException (show err)
-- | 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 []
-- Remove automatic identifier creation for headers. It does not work well with
-- the current include mechanism if slides have duplicate titles in separate
......@@ -516,44 +372,7 @@ isLocalURI url = isNothing $ parseURI url
isRemoteURI :: String -> Bool
isRemoteURI = not . isLocalURI
isCacheableURI :: String -> Bool
isCacheableURI url =
case parseURI url of
Just uri -> uriScheme uri `elem` ["http:", "https:"]
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
adjustImageUrls projectDir baseDir = walk adjustBlock . walk adjustInline
where
adjustInline (Image attr inlines (url, title)) =
Image attr inlines (adjustLocalUrl projectDir baseDir url, title)
adjustInline other = other
adjustBlock (Header 1 attr inlines) =
Header 1 (adjustBgImageUrl attr) inlines
adjustBlock other = other
adjustBgImageUrl (i, cs, kvs) =
( i
, cs
, map
(\(k, v) ->
if k == "data-background-image" || k == "data-background-video"
then (k, adjustLocalUrl projectDir baseDir v)
else (k, v))
kvs)
adjustLocalUrl :: FilePath -> FilePath -> FilePath -> FilePath
adjustLocalUrl root base url
| isLocalURI url =
if isAbsolute url
then root </> makeRelative "/" url
else base </> url