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. ...@@ -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: Pick a [published release](https://cgmgit.beuth-hochschule.de/teaching/decker/tags), download and unpack:
```sh ``` {.sh}
gunzip decker.gz gunzip decker.gz
chmod a+x decker chmod a+x decker
``` ```
...@@ -103,4 +103,21 @@ chmod a+x decker ...@@ -103,4 +103,21 @@ chmod a+x decker
### Pull requests ### Pull requests
Contributions are accepted via pull requests. Before working on a feature, please write up an issue and discuss it with me. Contributions are accepted via pull requests. Before working on a feature, please write up an issue and discuss it with the other developers.
\ No newline at end of file
### 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 @@ ...@@ -2,12 +2,12 @@
author: Henrik Tramberend author: Henrik Tramberend
date: '15.5.2016' date: '15.5.2016'
history: True history: True
signs: © €
subtitle: Tutorial and Examples subtitle: Tutorial and Examples
theme: 'htr-slides' theme: 'htr-slides'
title: Decker Slide Tool title: Decker Slide Tool
transition: linear transition: linear
ümläüte: Ümläüte ümläüte: Ümläüte
signs: © €
--- ---
# Overview # Overview
...@@ -55,15 +55,17 @@ signs: © € ...@@ -55,15 +55,17 @@ signs: © €
## Include markdown files ## 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 # Multicolumn slides
## The author ## 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`: ...@@ -74,7 +76,7 @@ The following text ist included from file `/resource/realtive.md`:
## The author ## The author
![](img/htr-beuth.jpg) ![](img/htr-beuth.jpg){data-src="img/htr-beuth.jpg"}
### ###
...@@ -211,9 +213,7 @@ $e=mc^2$ ...@@ -211,9 +213,7 @@ $e=mc^2$
# These are just notes {.notes} # These are just notes {.notes}
Slides with headers that are have the `.notes` class attribute are not included 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.
in the presentation. They are only visible in the handout and probably are
available as presenter notes during slide presentation.
# Cached Images # Cached Images
...@@ -221,8 +221,7 @@ available as presenter notes during slide presentation. ...@@ -221,8 +221,7 @@ available as presenter notes during slide presentation.
Remote images can be cached locally Remote images can be cached locally
Cache directory is named `img/cached` and is located in the directory of the Cache directory is named `img/cached` and is located in the directory of the referencing document
referencing document
`decker cache` scans for and downloads all images `decker cache` scans for and downloads all images
...@@ -230,8 +229,7 @@ referencing document ...@@ -230,8 +229,7 @@ referencing document
## Cached remote image ## Cached remote image
![Some piece of scene ![Some piece of scene graph](https://tramberend.beuth-hochschule.de/img/cg1-banner.png)
graph](https://tramberend.beuth-hochschule.de/img/cg1-banner.png)
## Not really! ## Not really!
...@@ -320,8 +318,7 @@ Your total score is 42. ...@@ -320,8 +318,7 @@ Your total score is 42.
- `*-deck.html` a *reveal.js* based HTML slide deck - `*-deck.html` a *reveal.js* based HTML slide deck
- `*-deck.pdf` a PDF version of that deck - `*-deck.pdf` a PDF version of that deck
- `*-handout.html` a HTML document containing only the speaker notes from the - `*-handout.html` a HTML document containing only the speaker notes from the deck
deck
- `*-handout.pdf` a PDF version of that handout - `*-handout.pdf` a PDF version of that handout
## Generated from `*-page.md` ## Generated from `*-page.md`
......
...@@ -7,4 +7,3 @@ structured: ...@@ -7,4 +7,3 @@ structured:
- Third - Third
date: 14.5.2016 date: 14.5.2016
resolver: 'Meta Data Test' resolver: 'Meta Data Test'
csl: chicago-author-date.csl
...@@ -9,14 +9,8 @@ module Embed ...@@ -9,14 +9,8 @@ module Embed
, deckTemplate , deckTemplate
, pageTemplate , pageTemplate
, pageLatexTemplate , pageLatexTemplate
, examLatexTemplate
, handoutTemplate , handoutTemplate
, handoutLatexTemplate , handoutLatexTemplate
, testerMultipleChoiceTemplate
, testerMultipleAnswersTemplate
, testerFillTextTemplate
, testerFreeFormTemplate
, testLatexTemplate
, defaultTemplate , defaultTemplate
, defaultTemplateString , defaultTemplateString
) where ) where
...@@ -49,22 +43,6 @@ pageTemplate = fromJust $ defaultTemplateString "page.html" ...@@ -49,22 +43,6 @@ pageTemplate = fromJust $ defaultTemplateString "page.html"
pageLatexTemplate = fromJust $ defaultTemplateString "page.tex" pageLatexTemplate = fromJust $ defaultTemplateString "page.tex"
examLatexTemplate = fromJust $ defaultTemplateString "exam.tex"
handoutTemplate = fromJust $ defaultTemplateString "handout.html" handoutTemplate = fromJust $ defaultTemplateString "handout.html"
handoutLatexTemplate = fromJust $ defaultTemplateString "handout.tex" 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 ...@@ -9,10 +9,10 @@ module Filter
, escapeToFilePath , escapeToFilePath
, cachePandocImages , cachePandocImages
, extractLocalImagePathes , extractLocalImagePathes
, renderImageVideo
, isMacro
) where ) where
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Default () import Data.Default ()
import Data.List.Split import Data.List.Split
...@@ -24,13 +24,16 @@ import Network.HTTP.Simple ...@@ -24,13 +24,16 @@ import Network.HTTP.Simple
import Network.URI import Network.URI
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import System.FilePath.Posix
import Text.Blaze (customAttribute) import Text.Blaze (customAttribute)
import Text.Blaze.Html.Renderer.String 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 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.Definition ()
import Text.Pandoc.JSON import Text.Pandoc.JSON
import Text.Pandoc.Shared
import Text.Pandoc.Walk import Text.Pandoc.Walk
import Text.Printf import Text.Printf
import Text.Read import Text.Read
...@@ -72,7 +75,7 @@ embedYoutubeHtml args attr (vid, _) = ...@@ -72,7 +75,7 @@ embedYoutubeHtml args attr (vid, _) =
src (toValue url) ! src (toValue url) !
customAttribute "frameborder" "0" ! customAttribute "frameborder" "0" !
customAttribute "allowfullscreen" "" $ customAttribute "allowfullscreen" "" $
p "" H.p ""
youtube :: MacroFunc youtube :: MacroFunc
youtube args attr target (Format f) _ youtube args attr target (Format f) _
...@@ -126,6 +129,10 @@ parseMacro (pre:invocation) ...@@ -126,6 +129,10 @@ parseMacro (pre:invocation)
| pre == ':' = Just (words invocation) | pre == ':' = Just (words invocation)
parseMacro _ = Nothing parseMacro _ = Nothing
isMacro :: String -> Bool
isMacro (pre:_) = pre == ':'
isMacro _ = False
onlyStrings :: [Inline] -> [String] onlyStrings :: [Inline] -> [String]
onlyStrings = reverse . foldl only [] onlyStrings = reverse . foldl only []
where where
...@@ -139,7 +146,7 @@ expand x _ _ = Just x ...@@ -139,7 +146,7 @@ expand x _ _ = Just x
expand_ :: Attr -> [Inline] -> Target -> Format -> Meta -> Maybe Inline expand_ :: Attr -> [Inline] -> Target -> Format -> Meta -> Maybe Inline
expand_ attr text target format meta = do expand_ attr text target format meta = do
name:args <- (parseMacro . unwords . onlyStrings) text name:args <- parseMacro $ stringify text
func <- Map.lookup name macroMap func <- Map.lookup name macroMap
return (func args attr target format meta) return (func args attr target format meta)
...@@ -193,7 +200,8 @@ splitColumns slide@(header:body) = ...@@ -193,7 +200,8 @@ splitColumns slide@(header:body) =
splitColumns [] = [] splitColumns [] = []
-- All fragment related classes from reveal.js have to be moved to the enclosing -- 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 = fragmentRelated =
[ "fragment" [ "fragment"
, "grow" , "grow"
...@@ -249,7 +257,7 @@ makeSlides (Just (Format "revealjs")) = ...@@ -249,7 +257,7 @@ makeSlides (Just (Format "revealjs")) =
makeSlides (Just (Format "beamer")) = makeSlides (Just (Format "beamer")) =
walk (mapSlides splitColumns) . walk (mapSlides splitColumns) .
walk (mapSlides wrapBoxes) . walk (mapSlides wrapNoteBeamer) walk (mapSlides wrapBoxes) . walk (mapSlides wrapNoteBeamer)
makeSlides _ = id makeSlides _ = Prelude.id
-- Only consider slides that have the 'notes' class in their header. In all -- Only consider slides that have the 'notes' class in their header. In all
-- others pick only the boxes that are tagged as notes. -- others pick only the boxes that are tagged as notes.
...@@ -266,7 +274,7 @@ filterSlides _ = [] ...@@ -266,7 +274,7 @@ filterSlides _ = []
filterNotes :: Maybe Format -> Pandoc -> Pandoc filterNotes :: Maybe Format -> Pandoc -> Pandoc
filterNotes (Just (Format _)) = walk (mapSlides filterSlides) filterNotes (Just (Format _)) = walk (mapSlides filterSlides)
filterNotes _ = id filterNotes _ = Prelude.id
escapeToFilePath :: String -> FilePath escapeToFilePath :: String -> FilePath
escapeToFilePath = map repl escapeToFilePath = map repl
...@@ -309,7 +317,7 @@ cachePandocImages base img@(Image _ _ (url, _)) ...@@ -309,7 +317,7 @@ cachePandocImages base img@(Image _ _ (url, _))
| otherwise = return img | otherwise = return img
cachePandocImages _ inline = return inline 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. -- the cached file relative to the base directory.
cacheImageIO :: String -> FilePath -> IO () cacheImageIO :: String -> FilePath -> IO ()
cacheImageIO uri cacheDir = do cacheImageIO uri cacheDir = do
...@@ -319,3 +327,23 @@ cacheImageIO uri cacheDir = do ...@@ -319,3 +327,23 @@ cacheImageIO uri cacheDir = do
let cacheFile = cacheDir </> escapeToFilePath uri let cacheFile = cacheDir </> escapeToFilePath uri
createDirectoryIfMissing True cacheDir createDirectoryIfMissing True cacheDir
L8.writeFile cacheFile body 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 ...@@ -5,7 +5,8 @@ module Project
, provisionResource , provisionResource
, copyResource , copyResource
, linkResource , linkResource
, refResource , relRefResource
, absRefResource
, removeCommonPrefix , removeCommonPrefix
, isPrefix , isPrefix
, makeRelativeTo , makeRelativeTo
...@@ -13,6 +14,7 @@ module Project ...@@ -13,6 +14,7 @@ module Project
, projectDirectories , projectDirectories
, resolveLocally , resolveLocally
, provisioningFromMeta , provisioningFromMeta
, provisioningFromClasses
, Resource(..) , Resource(..)
, Provisioning(..) , Provisioning(..)
, ProjectDirs(..) , ProjectDirs(..)
...@@ -21,8 +23,6 @@ module Project ...@@ -21,8 +23,6 @@ module Project
import Common import Common
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Data.List import Data.List
import Data.Maybe import Data.Maybe
...@@ -37,9 +37,10 @@ import Text.Pandoc.Definition ...@@ -37,9 +37,10 @@ import Text.Pandoc.Definition
import Text.Pandoc.Shared import Text.Pandoc.Shared
data Provisioning data Provisioning
= Copy -- Copy to public and relative path = Copy -- Copy to public and relative URL
| SymbolicLink -- Symbolic link to public and relative path | SymLink -- Symbolic link to public and relative URL
| Reference -- Absolute local path | Absolute -- Absolute local URL
| Relative -- Relative local URL
deriving (Eq, Show, Read) deriving (Eq, Show, Read)
provisioningFromMeta :: Meta -> Provisioning provisioningFromMeta :: Meta -> Provisioning
...@@ -47,7 +48,19 @@ provisioningFromMeta meta = ...@@ -47,7 +48,19 @@ provisioningFromMeta meta =
case lookupMeta "provisioning" meta of case lookupMeta "provisioning" meta of
Just (MetaString s) -> read s Just (MetaString s) -> read s
Just (MetaInlines i) -> read $ stringify i 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 data Resource = Resource
{ sourceFile :: FilePath -- Absolute Path to source file { sourceFile :: FilePath -- Absolute Path to source file
...@@ -69,13 +82,19 @@ linkResource resource = do ...@@ -69,13 +82,19 @@ linkResource resource = do
whenM whenM
(D.doesFileExist (publicFile resource)) (D.doesFileExist (publicFile resource))
(D.removeFile (publicFile resource)) (D.removeFile (publicFile resource))
D.createDirectoryIfMissing True (takeDirectory (publicFile resource))
createSymbolicLink (sourceFile resource) (publicFile resource) createSymbolicLink (sourceFile resource) (publicFile resource)
return (publicUrl resource) return (publicUrl resource)
refResource :: Resource -> IO FilePath absRefResource :: Resource -> IO FilePath
refResource resource = do absRefResource resource = do
return $ show $ URI "file" Nothing (sourceFile resource) "" "" 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 data ProjectDirs = ProjectDirs
{ project :: FilePath { project :: FilePath
, public :: FilePath , public :: FilePath
...@@ -129,15 +148,11 @@ resourcePathes dirs base absolute = ...@@ -129,15 +148,11 @@ resourcePathes dirs base absolute =
, publicUrl = makeRelativeTo base absolute , publicUrl = makeRelativeTo base absolute
} }
-- resolveUrl :: ProjectDirs -> FilePath -> FilePath -> IO (Maybe Resource) isLocalURI :: String -> Bool
-- resolveUrl dirs base url = do isLocalURI url = isNothing $ parseURI url
-- case parseURI url >>= fileOrRelativeUrl of
-- Nothing -> return Nothing isRemoteURI :: String -> Bool
-- Just path -> resourcePathes dirs base <$> resolve dirs base path isRemoteURI = not . isLocalURI
fileOrRelativeUrl :: URI -> Maybe FilePath
fileOrRelativeUrl (URI "file:" Nothing path _ _) = Just path
fileOrRelativeUrl (URI "" Nothing path _ _) = Just path
fileOrRelativeUrl _ = Nothing
-- | Determines if a URL can be resolved to a local file. Absolute file URLs -- | Determines if a URL can be resolved to a local file. Absolute file URLs
-- are resolved against and copied or linked to public from -- are resolved against and copied or linked to public from
...@@ -152,14 +167,18 @@ fileOrRelativeUrl _ = Nothing ...@@ -152,14 +167,18 @@ fileOrRelativeUrl _ = Nothing
provisionResource :: provisionResource ::
Provisioning -> ProjectDirs -> FilePath -> FilePath -> IO FilePath Provisioning -> ProjectDirs -> FilePath -> FilePath -> IO FilePath
provisionResource provisioning dirs base path = do provisionResource provisioning dirs base path = do
if path == "" || isRemoteURI path
then return path
else do
resource <- resourcePathes dirs base <$> findFile (project dirs) base path resource <- resourcePathes dirs base <$> findFile (project dirs) base path
case provisioning of case provisioning of
Copy -> copyResource resource Copy -> copyResource resource
SymbolicLink -> linkResource resource SymLink -> linkResource resource
Reference -> refResource resource Absolute -> absRefResource resource
Relative -> relRefResource base resource
-- Finds local file system files that sre needed at compile time. -- 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 :: FilePath -> FilePath -> FilePath -> IO FilePath
findFile root base path = do findFile root base path = do
resolved <- resolveLocally root base path resolved <- resolveLocally root base path
...@@ -169,6 +188,15 @@ findFile root base path = do ...@@ -169,6 +188,15 @@ findFile root base path = do
ResourceException $ "Cannot find local file system resource: " ++ path ResourceException $ "Cannot find local file system resource: " ++ path
Just resource -> return resource 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 -- 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. -- 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`. -- The resource is searched for in a directory name `template`.
......
...@@ -46,12 +46,12 @@ import Control.Arrow ...@@ -46,12 +46,12 @@ import Control.Arrow
import Control.Concurrent import Control.Concurrent
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Loops import Control.Monad.Loops
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Digest.Pure.MD5 import Data.Digest.Pure.MD5
import Data.Dynamic
import qualified Data.HashMap.Lazy as HashMap import qualified Data.HashMap.Lazy as HashMap
import qualified Data.HashMap.Strict as H import qualified Data.HashMap.Strict as H
import Data.IORef import Data.IORef
...@@ -64,7 +64,8 @@ import qualified Data.Text as T ...@@ -64,7 +64,8 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified Data.Vector as Vec import qualified Data.Vector as Vec
import qualified Data.Yaml as Y import qualified Data.Yaml as Y
import Debug.Trace
-- import Debug.Trace
import Development.Shake import Development.Shake
import Development.Shake.FilePath as SFP import Development.Shake.FilePath as SFP
import Embed import Embed
...@@ -85,6 +86,7 @@ import qualified Text.Mustache as M ...@@ -85,6 +86,7 @@ import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT import qualified Text.Mustache.Types as MT
import Text.Pandoc import Text.Pandoc
import Text.Pandoc.PDF import Text.Pandoc.PDF
import Text.Pandoc.Shared
import Text.Pandoc.Walk import Text.Pandoc.Walk
import Watch import Watch
...@@ -107,6 +109,7 @@ calcProjectDirectory = do ...@@ -107,6 +109,7 @@ calcProjectDirectory = do
-- | Globs for files under the project dir in the Action monad. -- | 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 :: FilePattern -> Action [FilePath]
globA pat = do globA pat = do
dirs <- getProjectDirs dirs <- getProjectDirs
...@@ -129,7 +132,7 @@ spawn = liftIO . spawnCommand ...@@ -129,7 +132,7 @@ spawn = liftIO . spawnCommand
runHttpServer dir open = do