Commit dc6fcdca authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Fancy resource handling and image movies

parent f652a9ff
......@@ -8,7 +8,7 @@ A markdown based tool for slide deck creation.
Pick a [published release](https://cgmgit.beuth-hochschule.de/teaching/decker/tags), download and unpack:
```sh
``` {.sh}
gunzip decker.gz
chmod a+x decker
```
......@@ -103,4 +103,21 @@ chmod a+x decker
### Pull requests
Contributions are accepted via pull requests. Before working on a feature, please write up an issue and discuss it with me.
\ No newline at end of file
Contributions are accepted via pull requests. Before working on a feature, please write up an issue and discuss it with the other developers.
### CI build checks
The decker repository has a GitLab CI runner configured, that builds and runs all tests for each commit on every branch.
### Haskell source code formatting
Haskell soure code readability depends heavily on consistent formatting conventions. With decker, formatting is automated using the excellent [hindent]() tool. Formatting is checked for each commit that is uploaded to the GitLab repository.
### Compilation and running
``` {.sh}
> stack setup
> stack build
> stack test
> stack exec decker
```
......@@ -2,12 +2,12 @@
author: Henrik Tramberend
date: '15.5.2016'
history: True
signs: © €
subtitle: Tutorial and Examples
theme: 'htr-slides'
title: Decker Slide Tool
transition: linear
ümläüte: Ümläüte
signs: © €
---
# Overview
......@@ -55,15 +55,17 @@ signs: © €
## Include markdown files
The following text ist included from file `/resource/realtive.md`:
The following text is included from file `/resource/realtive.md`:
[\#include](include/relative.md)
[:include](include/relative.md)
# Multicolumn slides
## The author
![](img/htr-beuth.jpg)
![](img/htr-beuth.jpg){width="50%"}![](https://tramberend.beuth-hochschule.de/img/htr-beuth.jpg){width="50%"}
[Deck markdown source](example-deck.md)
###
......@@ -74,7 +76,7 @@ The following text ist included from file `/resource/realtive.md`:
## The author
![](img/htr-beuth.jpg)
![](img/htr-beuth.jpg){data-src="img/htr-beuth.jpg"}
###
......@@ -211,9 +213,7 @@ $e=mc^2$
# These are just notes {.notes}
Slides with headers that are have the `.notes` class attribute are not included
in the presentation. They are only visible in the handout and probably are
available as presenter notes during slide presentation.
Slides with headers that are have the `.notes` class attribute are not included in the presentation. They are only visible in the handout and probably are available as presenter notes during slide presentation.
# Cached Images
......@@ -221,8 +221,7 @@ available as presenter notes during slide presentation.
Remote images can be cached locally
Cache directory is named `img/cached` and is located in the directory of the
referencing document
Cache directory is named `img/cached` and is located in the directory of the referencing document
`decker cache` scans for and downloads all images
......@@ -230,12 +229,11 @@ referencing document
## Cached remote image
![Some piece of scene
graph](https://tramberend.beuth-hochschule.de/img/cg1-banner.png)
![Some piece of scene graph](https://tramberend.beuth-hochschule.de/img/cg1-banner.png)
## Not really!
- Caching is currently disabled
- Caching is currently disabled
# Meta Data
......@@ -271,17 +269,17 @@ Your total score is 42.
## UTF-8 encoding for everything
- Markdown source files are assumed to be UTF-8 encoded
- YAML metadata also
- Markdown source files are assumed to be UTF-8 encoded
- YAML metadata also
## German Umlaute
- ÄÖÜäöüßß
- ÄÖÜäöüßß
## Substituted meta data
- Umlaute: {{ümläüte}}
- Signs: {{signs}}
- Umlaute: {{ümläüte}}
- Signs: {{signs}}
# `decker` Tool {.section}
......@@ -320,8 +318,7 @@ Your total score is 42.
- `*-deck.html` a *reveal.js* based HTML slide deck
- `*-deck.pdf` a PDF version of that deck
- `*-handout.html` a HTML document containing only the speaker notes from the
deck
- `*-handout.html` a HTML document containing only the speaker notes from the deck
- `*-handout.pdf` a PDF version of that handout
## Generated from `*-page.md`
......
......@@ -7,4 +7,3 @@ structured:
- Third
date: 14.5.2016
resolver: 'Meta Data Test'
csl: chicago-author-date.csl
......@@ -9,14 +9,8 @@ module Embed
, deckTemplate
, pageTemplate
, pageLatexTemplate
, examLatexTemplate
, handoutTemplate
, handoutLatexTemplate
, testerMultipleChoiceTemplate
, testerMultipleAnswersTemplate
, testerFillTextTemplate
, testerFreeFormTemplate
, testLatexTemplate
, defaultTemplate
, defaultTemplateString
) where
......@@ -49,22 +43,6 @@ pageTemplate = fromJust $ defaultTemplateString "page.html"
pageLatexTemplate = fromJust $ defaultTemplateString "page.tex"
examLatexTemplate = fromJust $ defaultTemplateString "exam.tex"
handoutTemplate = fromJust $ defaultTemplateString "handout.html"
handoutLatexTemplate = fromJust $ defaultTemplateString "handout.tex"
testerMultipleChoiceTemplate =
fromJust $ defaultTemplate "mc-quest-catalog-template.md"
testerMultipleAnswersTemplate =
fromJust $ defaultTemplate "ma-quest-catalog-template.md"
testerFillTextTemplate =
fromJust $ defaultTemplate "ft-quest-catalog-template.md"
testerFreeFormTemplate =
fromJust $ defaultTemplate "ff-quest-catalog-template.md"
testLatexTemplate = fromJust $ defaultTemplate "test.tex"
......@@ -9,10 +9,10 @@ module Filter
, escapeToFilePath
, cachePandocImages
, extractLocalImagePathes
, renderImageVideo
, isMacro
) where
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Default ()
import Data.List.Split
......@@ -24,13 +24,16 @@ import Network.HTTP.Simple
import Network.URI
import System.Directory
import System.FilePath
import System.FilePath.Posix
import Text.Blaze (customAttribute)
import Text.Blaze.Html.Renderer.String
import Text.Blaze.Html5 as H ((!), div, figure, iframe, p, toValue)
import Text.Blaze.Html5 as H
((!), div, figure, iframe, p, source, stringTag, toValue, video)
import Text.Blaze.Html5.Attributes as A
(class_, height, src, style, width)
(alt, class_, height, id, src, style, title, width)
import Text.Pandoc.Definition ()
import Text.Pandoc.JSON
import Text.Pandoc.Shared
import Text.Pandoc.Walk
import Text.Printf
import Text.Read
......@@ -72,7 +75,7 @@ embedYoutubeHtml args attr (vid, _) =
src (toValue url) !
customAttribute "frameborder" "0" !
customAttribute "allowfullscreen" "" $
p ""
H.p ""
youtube :: MacroFunc
youtube args attr target (Format f) _
......@@ -126,6 +129,10 @@ parseMacro (pre:invocation)
| pre == ':' = Just (words invocation)
parseMacro _ = Nothing
isMacro :: String -> Bool
isMacro (pre:_) = pre == ':'
isMacro _ = False
onlyStrings :: [Inline] -> [String]
onlyStrings = reverse . foldl only []
where
......@@ -139,7 +146,7 @@ expand x _ _ = Just x
expand_ :: Attr -> [Inline] -> Target -> Format -> Meta -> Maybe Inline
expand_ attr text target format meta = do
name:args <- (parseMacro . unwords . onlyStrings) text
name:args <- parseMacro $ stringify text
func <- Map.lookup name macroMap
return (func args attr target format meta)
......@@ -193,7 +200,8 @@ splitColumns slide@(header:body) =
splitColumns [] = []
-- All fragment related classes from reveal.js have to be moved to the enclosing
-- DIV element. Otherwise to many fragments are produced.fragmentRelated :: [String]
-- DIV element. Otherwise to many fragments are produced.
fragmentRelated :: [String]
fragmentRelated =
[ "fragment"
, "grow"
......@@ -249,7 +257,7 @@ makeSlides (Just (Format "revealjs")) =
makeSlides (Just (Format "beamer")) =
walk (mapSlides splitColumns) .
walk (mapSlides wrapBoxes) . walk (mapSlides wrapNoteBeamer)
makeSlides _ = id
makeSlides _ = Prelude.id
-- Only consider slides that have the 'notes' class in their header. In all
-- others pick only the boxes that are tagged as notes.
......@@ -266,7 +274,7 @@ filterSlides _ = []
filterNotes :: Maybe Format -> Pandoc -> Pandoc
filterNotes (Just (Format _)) = walk (mapSlides filterSlides)
filterNotes _ = id
filterNotes _ = Prelude.id
escapeToFilePath :: String -> FilePath
escapeToFilePath = map repl
......@@ -309,7 +317,7 @@ cachePandocImages base img@(Image _ _ (url, _))
| otherwise = return img
cachePandocImages _ inline = return inline
-- | Download the image behind the URI and save it locally. Return the path of
-- | Downloads the image behind the URI and saves it locally. Returns the path of
-- the cached file relative to the base directory.
cacheImageIO :: String -> FilePath -> IO ()
cacheImageIO uri cacheDir = do
......@@ -319,3 +327,23 @@ cacheImageIO uri cacheDir = do
let cacheFile = cacheDir </> escapeToFilePath uri
createDirectoryIfMissing True cacheDir
L8.writeFile cacheFile body
-- File extensions that signify video content.
videoExtensions =
[".mp4", ".webm", ".ogg", ".avi", ".dv", ".mp2", ".mov", ".qt"]
-- Renders an image with a video reference to a video tag in raw HTML. Faithfully
-- transfers attributes to the video tag.
renderImageVideo :: Inline -> Inline
renderImageVideo image@(Image (ident, cls, values) inlines (url, tit)) =
if takeExtension url `elem` videoExtensions
then RawInline (Format "html") (renderHtml videoTag)
else image
where
appendAttr element (key, value) =
element ! customAttribute (stringTag key) (toValue value)
videoTag =
foldl appendAttr video values ! A.id (toValue ident) !
class_ (toValue $ unwords cls) !
alt (toValue $ stringify inlines) !
title (toValue tit) $ do source ! src (toValue url)
......@@ -5,7 +5,8 @@ module Project
, provisionResource
, copyResource
, linkResource
, refResource
, relRefResource
, absRefResource
, removeCommonPrefix
, isPrefix
, makeRelativeTo
......@@ -13,6 +14,7 @@ module Project
, projectDirectories
, resolveLocally
, provisioningFromMeta
, provisioningFromClasses
, Resource(..)
, Provisioning(..)
, ProjectDirs(..)
......@@ -21,8 +23,6 @@ module Project
import Common
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import qualified Data.ByteString as B
import Data.List
import Data.Maybe
......@@ -37,9 +37,10 @@ import Text.Pandoc.Definition
import Text.Pandoc.Shared
data Provisioning
= Copy -- Copy to public and relative path
| SymbolicLink -- Symbolic link to public and relative path
| Reference -- Absolute local path
= Copy -- Copy to public and relative URL
| SymLink -- Symbolic link to public and relative URL
| Absolute -- Absolute local URL
| Relative -- Relative local URL
deriving (Eq, Show, Read)
provisioningFromMeta :: Meta -> Provisioning
......@@ -47,7 +48,19 @@ provisioningFromMeta meta =
case lookupMeta "provisioning" meta of
Just (MetaString s) -> read s
Just (MetaInlines i) -> read $ stringify i
otherwise -> Copy
_ -> SymLink
provisioningClasses =
[ ("copy", Copy)
, ("symlink", SymLink)
, ("absolute", Absolute)
, ("relative", Relative)
]
provisioningFromClasses :: Provisioning -> [String] -> Provisioning
provisioningFromClasses defaultP cls =
fromMaybe defaultP $
listToMaybe $ map snd $ filter ((flip elem) cls . fst) provisioningClasses
data Resource = Resource
{ sourceFile :: FilePath -- Absolute Path to source file
......@@ -69,13 +82,19 @@ linkResource resource = do
whenM
(D.doesFileExist (publicFile resource))
(D.removeFile (publicFile resource))
D.createDirectoryIfMissing True (takeDirectory (publicFile resource))
createSymbolicLink (sourceFile resource) (publicFile resource)
return (publicUrl resource)
refResource :: Resource -> IO FilePath
refResource resource = do
absRefResource :: Resource -> IO FilePath
absRefResource resource = do
return $ show $ URI "file" Nothing (sourceFile resource) "" ""
relRefResource :: FilePath -> Resource -> IO FilePath
relRefResource base resource = do
let relPath = makeRelativeTo base (sourceFile resource)
return $ show $ URI "file" Nothing relPath "" ""
data ProjectDirs = ProjectDirs
{ project :: FilePath
, public :: FilePath
......@@ -129,15 +148,11 @@ resourcePathes dirs base absolute =
, publicUrl = makeRelativeTo base absolute
}
-- resolveUrl :: ProjectDirs -> FilePath -> FilePath -> IO (Maybe Resource)
-- resolveUrl dirs base url = do
-- case parseURI url >>= fileOrRelativeUrl of
-- Nothing -> return Nothing
-- Just path -> resourcePathes dirs base <$> resolve dirs base path
fileOrRelativeUrl :: URI -> Maybe FilePath
fileOrRelativeUrl (URI "file:" Nothing path _ _) = Just path
fileOrRelativeUrl (URI "" Nothing path _ _) = Just path
fileOrRelativeUrl _ = Nothing
isLocalURI :: String -> Bool
isLocalURI url = isNothing $ parseURI url
isRemoteURI :: String -> Bool
isRemoteURI = not . isLocalURI
-- | Determines if a URL can be resolved to a local file. Absolute file URLs
-- are resolved against and copied or linked to public from
......@@ -152,14 +167,18 @@ fileOrRelativeUrl _ = Nothing
provisionResource ::
Provisioning -> ProjectDirs -> FilePath -> FilePath -> IO FilePath
provisionResource provisioning dirs base path = do
resource <- resourcePathes dirs base <$> findFile (project dirs) base path
case provisioning of
Copy -> copyResource resource
SymbolicLink -> linkResource resource
Reference -> refResource resource
if path == "" || isRemoteURI path
then return path
else do
resource <- resourcePathes dirs base <$> findFile (project dirs) base path
case provisioning of
Copy -> copyResource resource
SymLink -> linkResource resource
Absolute -> absRefResource resource
Relative -> relRefResource base resource
-- Finds local file system files that sre needed at compile time.
-- Throws if the resource cannot be found. Use mainly for include files.
-- Throws if the resource cannot be found. Used mainly for include files.
findFile :: FilePath -> FilePath -> FilePath -> IO FilePath
findFile root base path = do
resolved <- resolveLocally root base path
......@@ -169,6 +188,15 @@ findFile root base path = do
ResourceException $ "Cannot find local file system resource: " ++ path
Just resource -> return resource
-- Finds local file system files that sre needed at compile time.
-- Returns the original path if the resource cannot be found.
maybeFindFile :: FilePath -> FilePath -> FilePath -> IO FilePath
maybeFindFile root base path = do
resolved <- resolveLocally root base path
case resolved of
Nothing -> return path
Just resource -> return resource
-- Finds and reads a resource at compile time. If the resource can not be found in the
-- file system, the built-in resource map is searched. If that fails, an error os thrown.
-- The resource is searched for in a directory name `template`.
......
......@@ -46,12 +46,12 @@ 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 Data.Dynamic
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.HashMap.Strict as H
import Data.IORef
......@@ -64,7 +64,8 @@ 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 Debug.Trace
-- import Debug.Trace
import Development.Shake
import Development.Shake.FilePath as SFP
import Embed
......@@ -85,6 +86,7 @@ import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Text.Pandoc
import Text.Pandoc.PDF
import Text.Pandoc.Shared
import Text.Pandoc.Walk
import Watch
......@@ -106,7 +108,8 @@ calcProjectDirectory = do
else searchGitRoot $ takeDirectory path
-- | Globs for files under the project dir in the Action monad.
-- Returns absolute pathes.
-- Returns absolute pathes.
-- TODO: Remove matches under 'public', 'support', and 'cache'.
globA :: FilePattern -> Action [FilePath]
globA pat = do
dirs <- getProjectDirs
......@@ -129,7 +132,7 @@ spawn = liftIO . spawnCommand
runHttpServer dir open = do
process <- getServerHandle
case process of
Just handle -> return ()
Just _ -> return ()
Nothing -> do
putNormal "# livereloadx (on http://localhost:8888, see server.log)"
handle <-
......@@ -138,6 +141,7 @@ runHttpServer dir open = do
threadDelay' 200000
when open $ cmd ("open http://localhost:8888/" :: String) :: Action ()
startServer :: Control.Monad.IO.Class.MonadIO m => [Char] -> String -> m ()
startServer id command =
liftIO $ do
processHandle <- spawnCommand command
......@@ -467,10 +471,9 @@ readMetaMarkdown markdownFile = do
-- adjust image urls
dirs <- getProjectDirs
-- TODO: This has to go
return $
walk (adjustImageUrls (project dirs) (takeDirectory markdownFile)) pandoc
-- return $ walk (adjustImageUrls (project dirs) (takeDirectory markdownFile)) pandoc
-- TODO: Make this work further down
-- provisionResources dirs (takeDirectory markdownFile) pandoc
provisionResources dirs (takeDirectory markdownFile) pandoc
where
readMarkdownOrThrow opts string =
case readMarkdown opts string of
......@@ -506,7 +509,7 @@ 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
-- the current include mechanism if slides have duplicate titles in separate
-- include files.
deckerPandocExtensions :: Set.Set Extension
deckerPandocExtensions = Set.delete Ext_auto_identifiers pandocExtensions
......@@ -564,17 +567,79 @@ locateTemplates :: FilePath -> FilePath -> Pandoc -> Action Pandoc
locateTemplates root base (Pandoc meta blocks) = do
return (Pandoc meta blocks)
-- TODO: Make this compile, than work
-- provisionResources :: ProjectDirs -> FilePath -> Pandoc -> Action Pandoc
-- provisionResources dirs base pandoc@(Pandoc meta blocks) = do
-- let provisioning = provisioningFromMeta meta
-- liftIO $ walkM (provision provisioning) pandoc
-- where
-- provision (Image attr inlines target) provisioning =
-- Image (provision_ attr provisioning) inlines target
-- provision anything _ = anything
-- provision_ (ident, klass, kvs) provisioning =
-- map (\(k, v) -> (k, provisionResource provisioning dirs base v))
-- 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)
-- Transitively splices all include files into the pandoc document.
processIncludes :: FilePath -> FilePath -> Pandoc -> Action Pandoc
processIncludes rootDir baseDir (Pandoc meta blocks) = do
......@@ -618,14 +683,13 @@ cacheRemoteFile cacheDir url
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 ()
-- 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
......@@ -752,7 +816,7 @@ writeEmbeddedFiles files dir = do
lookupValue :: String -> Y.Value -> Maybe Y.Value
lookupValue key (Y.Object hashTable) = HashMap.lookup (T.pack key) hashTable