Commit 337e78c2 authored by Kristof Korwisi's avatar Kristof Korwisi
Browse files

Merge remote-tracking branch 'beuth-master/decker-monad' into HEAD

parents 21c5470f e542071b
......@@ -6,6 +6,7 @@ public/
cache/
log/
generated/
code/
*-deck.html
*-handout.html
*-page.html
......
before_script:
- stack --version
- stack setup
build:
script:
- stack build
formatting:
script:
bin/check-formatting.sh
\ No newline at end of file
......@@ -58,7 +58,7 @@ main = do
let indexA = return [index] :: Action [FilePath]
let everythingA = decksA <++> handoutsA <++> pagesA
let everythingPdfA = decksPdfA <++> handoutsPdfA <++> pagesPdfA
let cruft = ["index.md.generated", "log", "//.shake", "generated"]
let cruft = ["index.md.generated", "log", "//.shake", "generated", "code"]
context <- makeActionContext dirs
runShakeInContext context (options projectDir) $
--
......@@ -75,7 +75,7 @@ main = do
need ["support"]
everythingA <++> indexA >>= need
--
-- phony "pdf" $ pagesPdfA <++> handoutsPdfA <++> indexA >>= need
phony "pdf" $ pagesPdfA <++> handoutsPdfA <++> indexA >>= need
--
-- phony "pdf-decks" $ decksPdfA <++> indexA >>= need
--
......
......@@ -25,6 +25,7 @@ executable decker
other-modules: Action
, Cache
, CRC32
, Macro
, Meta
, Watch
, Embed
......@@ -56,18 +57,19 @@ executable decker
, file-embed
, filepath
, fsnotify
, groom
, hashable
, highlighting-kate
, http-conduit
, http-types
, monad-loops
, mtl
, multimap
, mustache
, network-uri
, pandoc
, pandoc-citeproc
, pandoc-types
, groom
, process
, pureMD5
, random
......
rsync-destination:
host: tramberend@tramberend.beuth-hochschule.de
path: /var/www/html/tramberend/decker
This source diff could not be displayed because it is too large. You can view the blob instead.
This diff is collapsed.
......@@ -82,7 +82,7 @@ decker [options] [target]
using `pandoc`:
``` {.sh}
decker help | pandoc -s -t html > ~/tmp/decker-help.html
decker help | pandoc -s -t html > decker-help.html
```
`decker check`
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Common
( DeckerException(..)
, DeckerState(..)
, Layout(..)
, OutputFormat(..)
, Disposition(..)
, MediaType(..)
, Provisioning(..)
, Script(..)
, Decker
, doIO
, needFile
, needFiles
, deckerVersion
, isDevelopmentVersion
, addScript
) where
import Control.Exception
import Control.Monad.State
import Data.Typeable
import Data.Version (showVersion, versionBranch)
import Development.Shake (Action, need)
import Network.URI as U
import Paths_decker (version)
import System.FilePath.Posix
-- | The version from the cabal file
deckerVersion :: String
......@@ -48,3 +64,63 @@ instance Show DeckerException where
show (DecktapeException e) = "decktape.sh failed for reason: " ++ e
show (ExternalException e) = e
show (SassException e) = e
type Decker = StateT DeckerState Action
doIO :: IO a -> Decker a
doIO = lift . liftIO
needFile :: FilePath -> Decker ()
needFile path = lift $ need [path]
needFiles :: [FilePath] -> Decker ()
needFiles pathes = lift $ need pathes
addScript :: Script -> Decker ()
addScript script = do
modify (\s -> s {scripts = scripts s ++ [script]})
data DeckerState = DeckerState
{ basePath :: String
, disposition :: Disposition
, provisioning :: Provisioning
, slideCount :: Int
, externalReferences :: [U.URI]
, scripts :: [Script]
} deriving (Eq, Show)
data Script
= ScriptURI { scriptLang :: String
, scriptUri :: String }
| ScriptSource { scriptLang :: String
, scriptSource :: String }
deriving (Eq, Show, Ord)
data Layout
= Deck
| Page
| Handout
deriving (Eq, Show)
data OutputFormat
= Html
| Pdf
deriving (Eq, Show)
data Disposition = Disposition
{ layout :: Layout
, format :: OutputFormat
} deriving (Eq, Show)
data MediaType
= ImageMedia
| AudioMedia
| VideoMedia
| IframeMedia
data Provisioning
= 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)
......@@ -13,9 +13,13 @@ module Context
, actionContextKey
, getActionContext
, getPublicResource
, withShakeLock
, getRelativeSupportDir
) where
import Control.Monad ()
import Common
import Data.Dynamic
import qualified Data.HashMap.Lazy as HashMap
import Data.IORef
......@@ -24,6 +28,8 @@ import Data.Typeable ()
import Development.Shake as Shake
import Project
import Server
import System.FilePath.Posix
import Text.Printf
data ActionContext = ActionContext
{ ctxFilesToWatch :: IORef [FilePath]
......@@ -98,3 +104,14 @@ getPublicResource :: Action Shake.Resource
getPublicResource = do
ctx <- getActionContext
return $ ctxPublicResource ctx
withShakeLock :: Action a -> Action a
withShakeLock action = do
publicResource <- getPublicResource
withResource publicResource 1 action
getRelativeSupportDir :: FilePath -> Action FilePath
getRelativeSupportDir from = do
dir <- public <$> getProjectDirs
let support = dir </> ("support" ++ "-" ++ deckerVersion)
return $ makeRelativeTo from support
......@@ -2,11 +2,12 @@
{-# LANGUAGE OverloadedStrings, TupleSections #-}
module Filter
( Disposition(..)
( Layout(..)
, OutputFormat(..)
, Disposition(..)
, processPandoc
, hasAttrib
, hasLayout
, blockClasses
, expandMacros
, makeSlides
, makeBoxes
, useCachedImages
......@@ -16,7 +17,6 @@ module Filter
, renderMediaTags
, transformImageSize
, lazyLoadImage
, isMacro
, iframeExtensions
, audioExtensions
, videoExtensions
......@@ -25,13 +25,17 @@ module Filter
import Common
import Control.Exception
import Control.Monad
import Control.Monad.State
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Default ()
import Data.List
import Data.List.Split
import qualified Data.Map as Map (Map, fromList, lookup)
import Data.Maybe
import Data.Maybe
import Debug.Trace
import Development.Shake (Action)
import Macro
import Network.HTTP.Conduit
import Network.HTTP.Simple
import qualified Network.URI as U
......@@ -52,125 +56,10 @@ import Text.Pandoc.Walk
import Text.Printf
import Text.Read
type MacroFunc = [String] -> Attr -> Target -> Format -> Meta -> Inline
-- iframe resizing, see:
-- https://css-tricks.com/NetMag/FluidWidthVideo/Article-FluidWidthVideo.php
-- YouTube links: iv_load_policy=3 disables annotations, rel=0 disables related
-- videos. See:
-- https://developers.google.com/youtube/player_parameters?hl=de#IFrame_Player_API
embedYoutubeHtml :: [String] -> Attr -> Target -> Inline
embedYoutubeHtml args attr (vid, _) =
RawInline (Format "html") (renderHtml html)
where
url =
printf
"https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=1&rel=0&modestbranding=1&autohide=1"
vid :: String
vidWidthStr = macroArg 0 args "560"
vidHeightStr = macroArg 1 args "315"
vidWidth = readDefault 560.0 vidWidthStr :: Float
vidHeight = readDefault 315.0 vidHeightStr :: Float
wrapperStyle =
printf
"position:relative;padding-top:25px;padding-bottom:%f%%;height:0;"
(vidHeight / vidWidth * 100.0) :: String
iframeStyle =
"position:absolute;top:0;left:0;width:100%;height:100%;" :: String
figureStyle (_, _, kv) =
foldl (\s (k, v) -> s ++ printf "%s:%s;" k v :: String) "" kv
figureClass (_, cls, _) = unwords cls
html =
H.figure ! class_ (toValue (figureClass attr)) !
style (toValue (figureStyle attr)) $
H.div ! style (toValue wrapperStyle) $
iframe ! style (toValue iframeStyle) ! width (toValue vidWidthStr) !
height (toValue vidHeightStr) !
src (toValue url) !
customAttribute "frameborder" "0" !
customAttribute "allowfullscreen" "" $
H.p ""
youtube :: MacroFunc
youtube args attr target (Format f) _
| f `elem` ["html", "html5", "revealjs"] = embedYoutubeHtml args attr target
youtube _ attr (vid, _) _ _ =
Link nullAttr [Image attr [Str text] (imageUrl, "")] (videoUrl, "")
where
videoUrl =
printf
"https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=0&rel=0&modestbranding=1&autohide=1"
vid :: String
imageUrl =
printf "http://img.youtube.com/vi/%s/maxresdefault.jpg" vid :: String
text = printf "YouTube: %s" vid :: String
fontAwesome :: MacroFunc
fontAwesome _ _ (iconName, _) (Format f) _
| f `elem` ["html", "html5", "revealjs"] =
RawInline (Format "html") $ "<i class=\"fa fa-" ++ iconName ++ "\"></i>"
fontAwesome _ _ (iconName, _) _ _ = Str $ "[" ++ iconName ++ "]"
metaValue :: MacroFunc
metaValue _ _ (key, _) _ meta =
case splitOn "." key of
[] -> Str key
k:ks -> lookup' ks (lookupMeta k meta)
where
lookup' :: [String] -> Maybe MetaValue -> Inline
lookup' [] (Just (MetaString s)) = Str s
lookup' [] (Just (MetaInlines i)) = Span nullAttr i
lookup' (k:ks) (Just (MetaMap metaMap)) = lookup' ks (Map.lookup k metaMap)
lookup' _ _ = Strikeout [Str key]
type MacroMap = Map.Map String MacroFunc
macroMap :: MacroMap
macroMap =
Map.fromList [("meta", metaValue), ("youtube", youtube), ("fa", fontAwesome)]
readDefault :: Read a => a -> String -> a
readDefault default_ string = fromMaybe default_ (readMaybe string)
macroArg :: Int -> [String] -> String -> String
macroArg n args default_ =
if length args > n
then args !! n
else default_
parseMacro :: String -> Maybe [String]
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
only ss (Str s) = s : ss
only ss _ = ss
expand :: Inline -> Format -> Meta -> Maybe Inline
expand (Link attr text target) format meta =
expand_ attr text target format meta
expand x _ _ = Just x
expand_ :: Attr -> [Inline] -> Target -> Format -> Meta -> Maybe Inline
expand_ attr text target format meta = do
name:args <- parseMacro $ stringify text
func <- Map.lookup name macroMap
return (func args attr target format meta)
expandInlineMacros :: Format -> Meta -> Inline -> Inline
expandInlineMacros format meta inline =
fromMaybe inline (expand inline format meta)
expandMacros :: Format -> Pandoc -> Pandoc
expandMacros format doc@(Pandoc meta _) =
walk (expandInlineMacros format meta) doc
processPandoc ::
(Pandoc -> Decker Pandoc) -> FilePath -> Disposition -> Provisioning -> Pandoc -> Action Pandoc
processPandoc transformation basePath disposition provisioning pandoc =
evalStateT (transformation pandoc) (DeckerState basePath disposition provisioning 0 [] [])
isSlideHeader :: Block -> Bool
isSlideHeader (Header 1 _ _) = True
......@@ -190,12 +79,6 @@ hasAnyClass which = isJust . firstClass which
firstClass :: [String] -> Block -> Maybe String
firstClass which block = listToMaybe $ filter ((flip hasClass) block) which
-- | Slide layouts
data Layout = Layout
{ name :: String
, areas :: [String]
} deriving (Show)
-- | Slide layouts are rows of one ore more columns.
data RowLayout = RowLayout
{ lname :: String
......@@ -278,15 +161,6 @@ layoutSlides slide@(header, body) =
in (header, renderLayout areas layout)
Nothing -> slide
masters :: [(String, Layout)]
masters =
[ ("default", Layout "default" [])
, ("columns", Layout "columns" ["left", "right"])
, ("top2columns", Layout "top2columns" ["top", "left", "right"])
, ("bottom2columns", Layout "bottom2columns" ["left", "right", "bottom"])
, ("centeredoverlay", Layout "centeredoverlay" ["back", "front"])
]
hasAttrib :: String -> Block -> Maybe String
hasAttrib which (Div (_, _, keyvals) _) = lookup which keyvals
hasAttrib which (Header 1 (_, _, keyvals) _) = lookup which keyvals
......@@ -294,9 +168,6 @@ hasAttrib which (CodeBlock (_, _, keyvals) _) = lookup which keyvals
hasAttrib which (Para [Image (_, _, keyvals) _ _]) = lookup which keyvals
hasAttrib _ _ = Nothing
hasLayout :: Block -> Maybe Layout
hasLayout block = hasAttrib "layout" block >>= (flip lookup) masters
blockClasses :: Block -> [String]
blockClasses (Div (_, classes, _) _) = classes
blockClasses (Header 1 (_, classes, _) _) = classes
......@@ -311,31 +182,6 @@ blockAttribs (CodeBlock attribs _) = attribs
blockAttribs (Para [Image attribs _ _]) = attribs
blockAttribs _ = ("", [], [])
-- | Fit slide to layout
fitLayout :: [Block] -> [Block]
fitLayout slide@(header:body) =
case hasLayout header of
Just layout ->
let wrapArea blocks@(first:_) =
case whichArea first of
Just area ->
let (_, _, attribs) = blockAttribs first
in [Div ("", [(name layout), area], attribs) blocks]
Nothing -> blocks
wrapArea block = block
whichArea block =
listToMaybe $ intersect (blockClasses block) (areas layout)
slideAreas =
split (keepDelimsL $ whenElt (hasAnyClass (areas layout))) body
orderedAreas =
catMaybes $
map
(\a -> find (maybe False (hasClass a) . listToMaybe) slideAreas)
(areas layout)
in header : concatMap wrapArea orderedAreas
Nothing -> slide
fitLayout [] = []
-- | Split join columns with CSS3. Must be performed after `wrapBoxes`.
splitJoinColumns :: Slide -> Slide
splitJoinColumns (header, body) = (header, concatMap wrapRow rows)
......@@ -434,6 +280,22 @@ wrapNoteRevealjs slide = slide
type Slide = (Block, [Block])
splitSlides :: [Block] -> [Slide]
splitSlides blocks =
map extractHeader $
filter (not . null) $ split (keepDelimsL $ whenElt isSlideHeader) blocks
where
extractHeader (header@(Header 1 _ _):blocks) = (header, blocks)
extractHeader (rule@(HorizontalRule):blocks) = (rule, blocks)
extractHeader slide =
throw $
PandocException $ "Error extracting slide header: \n" ++ show slide
joinSlides :: [Slide] -> [Block]
joinSlides slides = concatMap prependHeader slides
where
prependHeader (header, blocks) = header : blocks
-- | Map over all slides in a deck. A slide has always a header followed by zero
-- or more blocks.
mapSlides :: (Slide -> Slide) -> Pandoc -> Pandoc
......@@ -446,16 +308,29 @@ mapSlides func (Pandoc meta blocks) =
extractHeader (rule@(HorizontalRule):blocks) = (rule, blocks)
extractHeader slide =
throw $
PandocException $ "Error extracting slide header: \n" ++ show slide -- never happens
PandocException $ "Error extracting slide header: \n" ++ show slide
prependHeader (header, blocks) = header : blocks
makeSlides :: Format -> Pandoc -> Pandoc
makeSlides (Format "revealjs") =
walk (mapSlides layoutSlides) .
walk (mapSlides splitJoinColumns) .
walk (mapSlides setSlideBackground) .
walk (mapSlides wrapBoxes) . walk (mapSlides wrapNoteRevealjs)
makeSlides _ = Prelude.id
makeSlides :: Pandoc -> Decker Pandoc
makeSlides pandoc = do
disp <- gets disposition
case disp of
Disposition Deck Html ->
return $
walk (mapSlides layoutSlides) $
walk (mapSlides splitJoinColumns) $
walk (mapSlides setSlideBackground) $
walk (mapSlides wrapBoxes) $ walk (mapSlides wrapNoteRevealjs) pandoc
Disposition Deck Pdf ->
return $
walk (mapSlides layoutSlides) $
walk (mapSlides splitJoinColumns) $
walk (mapSlides setSlideBackground) $ walk (mapSlides wrapBoxes) pandoc
Disposition _ _ ->
return $
walk (mapSlides splitJoinColumns) $
-- walk (mapSlides setSlideBackground) $
walk (mapSlides wrapBoxes) pandoc
makeBoxes :: Pandoc -> Pandoc
makeBoxes = walk (mapSlides wrapBoxes)
......@@ -512,8 +387,10 @@ cacheImageIO uri cacheDir = do
createDirectoryIfMissing True cacheDir
L8.writeFile cacheFile body
renderMediaTags :: Disposition -> Pandoc -> Pandoc
renderMediaTags disposition = walk (renderImageAudioVideoTag disposition)
renderMediaTags :: Pandoc -> Decker Pandoc
renderMediaTags pandoc = do
disp <- gets disposition
return $ walk (renderImageAudioVideoTag disp) pandoc
-- | File extensions that signify video content.
videoExtensions :: [String]
......@@ -528,18 +405,6 @@ audioExtensions = [".m4a", ".mp3", ".ogg", ".wav"]
iframeExtensions :: [String]
iframeExtensions = [".html", ".html", ".pdf"]
data Disposition
= Deck
| Page
| Handout
deriving (Eq)
data MediaType
= ImageMedia
| AudioMedia
| VideoMedia
| IframeMedia
uriPathExtension :: String -> String
uriPathExtension path =
case U.parseRelativeReference path of
......@@ -581,7 +446,7 @@ renderImageAudioVideoTag disposition (Image (ident, cls, values) inlines (url, t
then element
else element ! attr (toValue value)
srcAttr =
if disposition == Deck
if disposition == Disposition Deck Html
then "data-src"
else "src"
transformedValues = (lazyLoad . transformImageSize) values
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE OverloadedStrings, TupleSections #-}
module Macro
( expandDeckerMacros
) where
import Common
import Control.Monad.State
import Data.List.Split
import qualified Data.Map as Map (Map, fromList, lookup)
import Data.Maybe
import System.FilePath
import Text.Blaze (customAttribute)
import Text.Blaze.Html.Renderer.String
import Text.Blaze.Html5 as H
((!), audio, div, figure, iframe, iframe, img, p, stringTag,
toValue, video)
import Text.Blaze.Html5.Attributes as A
(alt, class_, height, id, src, style, title, width)
import Text.Pandoc
import Text.Pandoc.Definition ()
import Text.Pandoc.Shared
import Text.Pandoc.Walk
import Text.Printf
import Text.Read
type MacroAction = [String] -> Attr -> Target -> Meta -> Decker Inline
-- iframe resizing, see:
-- https://css-tricks.com/NetMag/FluidWidthVideo/Article-FluidWidthVideo.php
-- YouTube links: iv_load_policy=3 disables annotations, rel=0 disables related
-- videos. See:
-- https://developers.google.com/youtube/player_parameters?hl=de#IFrame_Player_API
embedYoutubeHtml :: [String] -> Attr -> Target -> Inline
embedYoutubeHtml args attr (vid, _) =
RawInline (Format "html") (renderHtml html)
where
url =
printf
"https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=1&rel=0&modestbranding=1&autohide=1"
vid :: String
vidWidthStr = macroArg 0 args "560"
vidHeightStr = macroArg 1 args "315"
vidWidth = readDefault 560.0 vidWidthStr :: Float
vidHeight = readDefault 315.0 vidHeightStr :: Float
wrapperStyle =
printf
"position:relative;padding-top:25px;padding-bottom:%f%%;height:0;"
(vidHeight / vidWidth * 100.0) :: String
iframeStyle =
"position:absolute;top:0;left:0;width:100%;height:100%;" :: String
figureStyle (_, _, kv) =
foldl (\s (k, v) -> s ++ printf "%s:%s;" k v :: String) "" kv
figureClass (_, cls, _) = unwords cls
html =
H.figure ! class_ (toValue (figureClass attr)) !
style (toValue (figureStyle attr)) $
H.div ! style (toValue wrapperStyle) $
iframe ! style (toValue iframeStyle) ! width (toValue vidWidthStr) !
height (toValue vidHeightStr) !
src (toValue url) !
customAttribute "frameborder" "0" !
customAttribute "allowfullscreen" "" $
H.p ""
embedYoutubePdf :: [String] -> Attr -> Target -> Inline