Commit cb68693d authored by Kristof Korwisi's avatar Kristof Korwisi
Browse files

Merge remote-tracking branch 'origin/beuth-master'

parents 337e78c2 a79ef676
......@@ -9,16 +9,13 @@ import Data.IORef ()
import Data.List
import Data.Maybe
import Data.String ()
import Debug.Trace
import Development.Shake
import Development.Shake.FilePath
import External
import GHC.Conc (numCapabilities)
import Project
import Resources
import System.Directory
(copyFile, createDirectoryIfMissing, doesDirectoryExist,
removeFile)
import System.Directory (createDirectoryIfMissing, removeFile)
import System.FilePath ()
import System.Posix.Files
import Text.Groom
......
......@@ -39,7 +39,7 @@ executable decker
, Render
, External
, Paths_decker
ghc-options: -threaded -rtsopts -with-rtsopts=-N
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
build-depends: base
, Glob
, HTTP
......@@ -90,6 +90,16 @@ executable decker
, websockets-snap
, yaml
default-language: Haskell2010
default-extensions: EmptyCase
, FlexibleContexts
, FlexibleInstances
, InstanceSigs
, MultiParamTypeClasses
, OverloadedStrings
, TupleSections
, DeriveDataTypeable
, TemplateHaskell
, MultiWayIf
source-repository head
type: git
......
......@@ -2,9 +2,15 @@ decker := $(shell stack path | grep local-install-root | sed "s/local-install-ro
zip := $(shell mktemp -u)
build:
stack build
stack build -j 8 --fast
@(cd resource; zip -qr $(zip) example support template; cat $(zip) >> $(decker); rm $(zip))
watch:
stack test -j 8 --fast --file-watch
docs: build
stack hoogle -- generate --local
clean:
stack clean
......@@ -18,4 +24,4 @@ info:
@echo "decker: $(decker)"
@echo "zip: $(zip)"
.PHONY: build clean install dist
.PHONY: build clean install dist docs
provisioning: Copy
\ No newline at end of file
provisioning: SymLink
\ No newline at end of file
[![build
status](https://cgmgit.beuth-hochschule.de/teaching/decker/badges/master/build.svg)](https://cgmgit.beuth-hochschule.de/teaching/decker/commits/master)
# decker
A markdown based tool for slide deck creation.
......@@ -8,7 +5,7 @@ A markdown based tool for slide deck creation.
## Installation
Pick a [published
release](https://cgmgit.beuth-hochschule.de/teaching/decker/tags), download and
release](../../releases), download and
unpack:
``` {.sh}
......
......@@ -18,7 +18,6 @@ module Action
import Common
import Context
import Control.Exception
import Control.Monad
import Data.IORef
import Data.List as List
import Data.List (isInfixOf)
......@@ -48,37 +47,32 @@ 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.
-- running.
runHttpServer :: Int -> ProjectDirs -> Maybe String -> Action ()
runHttpServer port dirs url = do
server <- getServerHandle
case server of
Just _ -> return ()
Nothing -> do
server <- liftIO $ startHttpServer dirs port
setServerHandle $ Just server
case url of
Just url -> openBrowser url
httpServer <- liftIO $ startHttpServer dirs port
setServerHandle $ Just httpServer
case url of
Just u -> openBrowser u
Nothing -> return ()
openBrowser :: String -> Action ()
openBrowser url = do
case os of
osid
| any (`isInfixOf` osid) ["linux", "bsd"] ->
liftIO $ callProcess "xdg-open" [url]
osid
| "darwin" `isInfixOf` osid -> liftIO $ callProcess "open" [url]
osid
| otherwise ->
putNormal $ "Unable to open browser on this platform for url: " ++ url
if | any (`isInfixOf` os) ["linux", "bsd"] ->
liftIO $ callProcess "xdg-open" [url]
| "darwin" `isInfixOf` os -> liftIO $ callProcess "open" [url]
| otherwise ->
putNormal $ "Unable to open browser on this platform for url: " ++ url
reloadBrowsers :: Action ()
reloadBrowsers = do
server <- getServerHandle
case server of
Just handle -> liftIO $ reloadClients handle
Just serv -> liftIO $ reloadClients serv
Nothing -> return ()
wantRepeat :: IORef Bool -> Action ()
......@@ -106,8 +100,10 @@ calcSource targetSuffix srcSuffix target = do
return src
-- | Removes the last suffix from a filename
dropSuffix :: String -> String -> String
dropSuffix s t = fromMaybe t (stripSuffix s t)
replaceSuffix :: String -> String -> String -> String
replaceSuffix srcSuffix targetSuffix filename =
dropSuffix srcSuffix filename ++ targetSuffix
......@@ -117,7 +113,7 @@ replaceSuffixWith suffix with pathes =
return [dropSuffix suffix d ++ with | d <- pathes]
readMetaDataForDir :: FilePath -> Action Y.Value
readMetaDataForDir dir = walkUpTo dir
readMetaDataForDir directory = walkUpTo directory
where
walkUpTo dir = do
dirs <- getProjectDirs
......@@ -140,5 +136,5 @@ readMetaDataForDir dir = walkUpTo dir
Right object@(Y.Object _) -> return object
Right _ ->
throw $
YamlException $ "Top-level meta value must be an object: " ++ dir
YamlException $ "Top-level meta value must be an object: " ++ directory
Left exception -> throw exception
{-# LANGUAGE Safe #-}
-- {-# LANGUAGE Safe #-}
{- arch-tag: GZIP CRC32 implementation in pure Haskell
Copyright (c) 2004-2011 John Goerzen <jgoerzen@complete.org>
......@@ -27,7 +27,6 @@ module CRC32 where
import Data.Array
import Data.Bits
import Data.Word
import Data.List
import Data.Char
update_crc :: Word32 -> Char -> Word32
......
......@@ -24,7 +24,7 @@ import Data.Version (showVersion, versionBranch)
import Development.Shake (Action, need)
import Network.URI as U
import Paths_decker (version)
import System.FilePath.Posix
-- import System.FilePath.Posix
-- | The version from the cabal file
deckerVersion :: String
......@@ -71,7 +71,7 @@ doIO :: IO a -> Decker a
doIO = lift . liftIO
needFile :: FilePath -> Decker ()
needFile path = lift $ need [path]
needFile file = lift $ need [file]
needFiles :: [FilePath] -> Decker ()
needFiles pathes = lift $ need pathes
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Context
( ActionContext(..)
......@@ -15,11 +15,10 @@ module Context
, getPublicResource
, withShakeLock
, getRelativeSupportDir
) where
import Control.Monad ()
import Common
import Control.Monad ()
import Data.Dynamic
import qualified Data.HashMap.Lazy as HashMap
import Data.IORef
......@@ -29,7 +28,6 @@ import Development.Shake as Shake
import Project
import Server
import System.FilePath.Posix
import Text.Printf
data ActionContext = ActionContext
{ ctxFilesToWatch :: IORef [FilePath]
......@@ -106,12 +104,12 @@ getPublicResource = do
return $ ctxPublicResource ctx
withShakeLock :: Action a -> Action a
withShakeLock action = do
withShakeLock perform = do
publicResource <- getPublicResource
withResource publicResource 1 action
withResource publicResource 1 perform
getRelativeSupportDir :: FilePath -> Action FilePath
getRelativeSupportDir from = do
dir <- public <$> getProjectDirs
let support = dir </> ("support" ++ "-" ++ deckerVersion)
return $ makeRelativeTo from support
pub <- public <$> getProjectDirs
let sup = pub </> ("support" ++ "-" ++ deckerVersion)
return $ makeRelativeTo from sup
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE TemplateHaskell #-}
module Embed
( deckerHelpText
......
......@@ -28,6 +28,7 @@ data ExternalProgram = ExternalProgram
, help :: String
}
programs :: [(String, ExternalProgram)]
programs =
[ ( "ssh"
, ExternalProgram
......@@ -156,9 +157,9 @@ makeProgram name =
checkProgram :: String -> Action Bool
checkProgram name = do
liftIO $
handle (\(SomeException e) -> return False) $ do
handle (\(SomeException _) -> return False) $ do
let external = fromJust $ lookup name programs
(code, out, err) <-
(code, _, _) <-
readProcessWithExitCode (path external) (testArgs external) ""
case code of
ExitFailure status
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE OverloadedStrings, TupleSections #-}
module Filter
( Layout(..)
, OutputFormat(..)
......@@ -24,18 +22,13 @@ 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
......@@ -45,21 +38,23 @@ 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)
((!), audio, iframe, iframe, img, stringTag, toValue, video)
import Text.Blaze.Html5.Attributes as A (alt, class_, id, title)
import Text.Pandoc
import Text.Pandoc.Definition ()
import Text.Pandoc.Shared
import Text.Pandoc.Walk
import Text.Printf
import Text.Read
processPandoc ::
(Pandoc -> Decker Pandoc) -> FilePath -> Disposition -> Provisioning -> Pandoc -> Action Pandoc
processPandoc transformation basePath disposition provisioning pandoc =
evalStateT (transformation pandoc) (DeckerState basePath disposition provisioning 0 [] [])
(Pandoc -> Decker Pandoc)
-> FilePath
-> Disposition
-> Provisioning
-> Pandoc
-> Action Pandoc
processPandoc transform base disp prov pandoc =
evalStateT (transform pandoc) (DeckerState base disp prov 0 [] [])
isSlideHeader :: Block -> Bool
isSlideHeader (Header 1 _ _) = True
......@@ -77,7 +72,7 @@ hasAnyClass :: [String] -> Block -> Bool
hasAnyClass which = isJust . firstClass which
firstClass :: [String] -> Block -> Maybe String
firstClass which block = listToMaybe $ filter ((flip hasClass) block) which
firstClass which block = listToMaybe $ filter (`hasClass` block) which
-- | Slide layouts are rows of one ore more columns.
data RowLayout = RowLayout
......@@ -95,6 +90,7 @@ type Area = [Block]
type AreaMap = [(String, Area)]
rowLayouts :: [RowLayout]
rowLayouts =
[ RowLayout
"columns"
......@@ -104,38 +100,35 @@ rowLayouts =
]
]
rowAreas :: Row -> [String]
rowAreas (SingleColumn area) = [area]
rowAreas (MultiColumn areas) = areas
layoutAreas layout = concatMap rowAreas $ rows layout
layoutAreas :: RowLayout -> [String]
layoutAreas l = concatMap rowAreas $ rows l
hasRowLayout :: Block -> Maybe RowLayout
hasRowLayout block =
hasAttrib "layout" block >>=
(\layout -> find ((==) layout . lname) rowLayouts)
hasAttrib "layout" block >>= (\l -> find ((==) l . lname) rowLayouts)
renderRow :: AreaMap -> Row -> Maybe Block
renderRow areaMap (SingleColumn rowArea) =
lookup rowArea areaMap >>= Just . Div ("", ["single-column-row"], [])
renderRow areaMap (MultiColumn rowAreas) =
renderRow areaMap (SingleColumn area) =
lookup area areaMap >>= Just . Div ("", ["single-column-row"], [])
renderRow areaMap (MultiColumn areas) =
Just $
Div
( ""
, ["multi-column-row", "multi-column-row-" ++ show (length rowAreas)]
, []) $
mapMaybe renderArea (zip [1 ..] rowAreas)
Div ("", ["multi-column-row", "multi-column-row-" ++ show (length areas)], []) $
mapMaybe renderArea (zip [1 ..] areas)
where
renderArea (i, area) = lookup area areaMap >>= Just . renderColumn . (i, )
renderColumn :: (Int, [Block]) -> Block
renderColumn (i, blocks) =
let grow =
maybe (1 :: Int) Prelude.id $
lookup "grow" (blockKeyvals blocks) >>= readMaybe
fromMaybe (1 :: Int) $ lookup "grow" (blockKeyvals blocks) >>= readMaybe
in Div
( ""
, ["grow-" ++ show grow, "column", "column-" ++ show i]
, (blockKeyvals blocks))
, blockKeyvals blocks)
blocks
blockKeyvals :: [Block] -> [(String, String)]
......@@ -145,7 +138,7 @@ blockKeyvals (first:_) =
blockKeyvals [] = []
renderLayout :: AreaMap -> RowLayout -> [Block]
renderLayout areaMap layout = catMaybes $ map (renderRow areaMap) (rows layout)
renderLayout areaMap l = mapMaybe (renderRow areaMap) (rows l)
slideAreas :: [String] -> [Block] -> AreaMap
slideAreas names blocks =
......@@ -155,10 +148,10 @@ slideAreas names blocks =
layoutSlides :: Slide -> Slide
layoutSlides slide@(header, body) =
case hasRowLayout header of
Just layout ->
let names = layoutAreas layout
Just l ->
let names = layoutAreas l
areas = slideAreas names body
in (header, renderLayout areas layout)
in (header, renderLayout areas l)
Nothing -> slide
hasAttrib :: String -> Block -> Maybe String
......@@ -184,9 +177,10 @@ blockAttribs _ = ("", [], [])
-- | Split join columns with CSS3. Must be performed after `wrapBoxes`.
splitJoinColumns :: Slide -> Slide
splitJoinColumns (header, body) = (header, concatMap wrapRow rows)
splitJoinColumns (header, body) = (header, concatMap wrapRow rowBlocks)
where
rows = split (keepDelimsL $ whenElt (hasAnyClass ["split", "join"])) body
rowBlocks =
split (keepDelimsL $ whenElt (hasAnyClass ["split", "join"])) body
wrapRow row@(first:_)
| hasClass "split" first = [Div ("", ["css-columns"], []) row]
wrapRow row = row
......@@ -211,27 +205,19 @@ fragmentRelated =
deFragment :: [String] -> [String]
deFragment = filter (`notElem` fragmentRelated)
deconstructSlide :: [Block] -> (Maybe Inline, Maybe Block, [Block])
deconstructSlide (header:body) =
case header of
Header 1 attribs inlines ->
( listToMaybe $ query allImages inlines
, Just $ Header 1 attribs (map zapImages inlines)
, body)
deconstructSlide blocks = (Nothing, Nothing, blocks)
allImages :: Inline -> [Inline]
allImages image@Image {} = [image]
allImages _ = []
zapImages :: Inline -> Inline
zapImages Image {} = Space
zapImages inline = inline
-- Transform inline image or video elements within the header line with
-- background attributes of the respective section.
setSlideBackground :: Slide -> Slide
setSlideBackground slide@((Header 1 (headerId, headerClasses, headerAttributes) inlines), slideBody) =
setSlideBackground slide@(Header 1 (headerId, headerClasses, headerAttributes) inlines, slideBody) =
case query allImages inlines of
[] -> slide
Image (_, imageClasses, imageAttributes) _ (imageSrc, _):_ ->
( Header
1
......@@ -241,6 +227,7 @@ setSlideBackground slide@((Header 1 (headerId, headerClasses, headerAttributes)
headerAttributes ++ map transform imageAttributes)
(walk zapImages inlines)
, slideBody)
_ -> slide
where
transform ("size", value) = ("data-background-size", value)
transform ("position", value) = ("data-background-position", value)
......@@ -274,28 +261,12 @@ wrapBoxes (header, body) = (header, concatMap wrap boxes)
-- | Wrap H1 headers with class notes into a DIV and promote all header
-- attributes to the DIV.
wrapNoteRevealjs :: Slide -> Slide
wrapNoteRevealjs slide@(header@(Header 1 (id_, cls, kvs) _), body)
wrapNoteRevealjs (header@(Header 1 (id_, cls, kvs) _), body)
| "notes" `elem` cls = (Div (id_, cls, kvs) (header : body), [])
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
......@@ -304,12 +275,12 @@ mapSlides func (Pandoc meta blocks) =
where
slideBlocks = split (keepDelimsL $ whenElt isSlideHeader) blocks
slides = map extractHeader $ filter (not . null) slideBlocks
extractHeader (header@(Header 1 _ _):blocks) = (header, blocks)
extractHeader (rule@(HorizontalRule):blocks) = (rule, blocks)
extractHeader (header@(Header 1 _ _):bs) = (header, bs)
extractHeader (rule@HorizontalRule:bs) = (rule, bs)
extractHeader slide =
throw $
PandocException $ "Error extracting slide header: \n" ++ show slide
prependHeader (header, blocks) = header : blocks
prependHeader (header, bs) = header : bs
makeSlides :: Pandoc -> Decker Pandoc
makeSlides pandoc = do
......@@ -326,11 +297,11 @@ makeSlides pandoc = do
walk (mapSlides layoutSlides) $
walk (mapSlides splitJoinColumns) $
walk (mapSlides setSlideBackground) $ walk (mapSlides wrapBoxes) pandoc
Disposition _ _ ->
return $
walk (mapSlides splitJoinColumns) $
Disposition _ _ -> return pandoc
-- TODO: Do this for pages
-- walk (mapSlides splitJoinColumns) $
-- walk (mapSlides setSlideBackground) $
walk (mapSlides wrapBoxes) pandoc
-- walk (mapSlides wrapBoxes) pandoc
makeBoxes :: Pandoc -> Pandoc
makeBoxes = walk (mapSlides wrapBoxes)
......@@ -344,12 +315,13 @@ escapeToFilePath = map repl
else c
useCachedImages :: FilePath -> Inline -> IO Inline
useCachedImages cacheDir img@(Image (ident, cls, values) inlines (url, title)) = do
useCachedImages cacheDir image@(Image (ident, cls, values) inlines (url, imgTitle)) = do
let cached = cacheDir </> escapeToFilePath url
exists <- doesFileExist cached
if exists
then return (Image (ident, "cached" : cls, values) inlines (cached, title))
else return img
then return
(Image (ident, "cached" : cls, values) inlines (cached, imgTitle))
else return image
useCachedImages _ inline = return inline
localImagePath :: Inline -> [FilePath]
......@@ -369,11 +341,11 @@ isHttpUri url =
Nothing -> False
cachePandocImages :: FilePath -> Inline -> IO Inline
cachePandocImages base img@(Image _ _ (url, _))
cachePandocImages base image@(Image _ _ (url, _))
| isHttpUri url = do
cacheImageIO url base
return img
| otherwise = return img
return image
| otherwise = return image
cachePandocImages _ inline = return inline
-- | Downloads the image behind the URI and saves it locally. Returns the path of
......@@ -406,9 +378,9 @@ iframeExtensions :: [String]
iframeExtensions = [".html", ".html", ".pdf"]
uriPathExtension :: String -> String
uriPathExtension path =
case U.parseRelativeReference path of
Nothing -> takeExtension path
uriPathExtension reference =
case U.parseRelativeReference reference of
Nothing -> takeExtension reference
Just uri -> takeExtension (U.uriPath uri)
classifyFilePath :: FilePath -> MediaType
......@@ -425,15 +397,18 @@ classifyFilePath name =
-- Renders an image with a video reference to a video tag in raw HTML. Faithfully
-- transfers attributes to the video tag.
renderImageAudioVideoTag :: Disposition -> Inline -> Inline
renderImageAudioVideoTag disposition (Image (ident, cls, values) inlines (url, tit)) =
renderImageAudioVideoTag disp (Image (ident, cls, values) inlines (url, tit)) =
RawInline (Format "html") (renderHtml imageVideoTag)
where
imageVideoTag =
case classifyFilePath url of
VideoMedia -> mediaTag (video "Browser does not support video.")
AudioMedia -> mediaTag (audio "Browser does not support audio.")
IframeMedia -> mediaTag (iframe "Browser does not support iframe.")
ImageMedia -> mediaTag img
if "iframe" `elem` cls
then mediaTag (iframe "Browser does not support iframe.")
else case classifyFilePath url of
VideoMedia -> mediaTag (video "Browser does not support video.")
AudioMedia -> mediaTag (audio "Browser does not support audio.")
IframeMedia ->
mediaTag (iframe "Browser does not support iframe.")
ImageMedia -> mediaTag img
appendAttr element (key, value) =
element ! customAttribute (stringTag key) (toValue value)
mediaTag tag =
......@@ -446,7 +421,7 @@ renderImageAudioVideoTag disposition (Image (ident, cls, values) inlines (url, t
then element
else element ! attr (toValue value)
srcAttr =
if disposition == Disposition Deck Html
if disp == Disposition Deck Html
then "data-src"
else "src"
transformedValues = (lazyLoad . transformImageSize) values
......@@ -464,10 +439,10 @@ transformImageSize attributes =
split (dropDelims $ oneOf ";") $
fromMaybe "" $ snd <$> find (\(k, _) -> k == "style") attributes
unstyled :: [(String, String)]
unstyled = filter (\(k, v) -> k /= "style") attributes
unstyled = filter (\(k, _) -> k /= "style") attributes
unsized =
filter (\(k, v) -> k /= "width") $
filter (\(k, v) -> k /= "height") unstyled
filter (\(k, _) -> k /= "width") $
filter (\(k, _) -> k /= "height") unstyled
size =
( snd <$> find (\(k, _) -> k == "width") unstyled
, snd <$> find (\(k, _) -> k == "height") unstyled)
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE OverloadedStrings, TupleSections #-}
module Macro
( expandDeckerMacros
) where
......@@ -10,14 +8,12 @@ import Control.Monad.State
import Data.List.Split
import qualified Data.Map as Map (Map, fromList, lookup)
import Data.Maybe