Skip to content
GitLab
Commit 10e5e168 authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Better path handling and cleanup

parent e8781e10
Hide whitespace changes
Inline Side-by-side
app/decker.hs
View file @ 10e5e168
......@@ -17,80 +17,82 @@ import Text.Mustache.Types (mFromJSON)
import Text.Pandoc
import Text.Printf
import Utilities
import Context
-- | All observable source files that are considered. These are specified in
-- the Action monad, such that they are revealuated on each iteration of the *watch* target.
getDeckSources = globRelative "**/*-deck.md"
getPageSources = globRelative "**/*-page.md"
getAllSources = globRelative "**/*.md"
-- | Calculates all plain markdown files ending just in `*.md`.
getPlainSources =
do all <- getAllSources
decks <- getDeckSources
pages <- getPageSources
return $ all \\ (decks ++ pages)
-- | Returns all YAML files.
getMeta = globRelative "**/*.yaml"
-- | Actions that generate lists of target files from the source list actions
getDecks = getDeckSources >>= replaceSuffixWith ".md" ".html"
getDecksPdf = getDeckSources >>= replaceSuffixWith ".md" ".pdf"
getHandouts = getDeckSources >>= replaceSuffixWith "-deck.md" "-handout.html"
getHandoutsPdf = getDeckSources >>= replaceSuffixWith "-deck.md" "-handout.pdf"
getPages = getPageSources >>= replaceSuffixWith ".md" ".html"
getPagesPdf = getPageSources >>= replaceSuffixWith ".md" ".pdf"
getPlain = getPlainSources >>= replaceSuffixWith ".md" ".html"
getPlainPdf = getPlainSources >>= replaceSuffixWith ".md" ".pdf"
getEverything = getDecks <++> getHandouts <++> getPages <++> getPlain
getEverythingPdf = getDecksPdf <++> getHandoutsPdf <++> getPagesPdf <++> getPlain
-- | Stuff that will be deleted by the clean target
getCruft = return ["index.md.generated", "index.html", "server.log"]
main :: IO ()
main = do
contextRef <- newIORef defaultContext
runShakeInContext contextRef options $ do
-- Calculate some directories
projectDir <- calcProjectDirectory
let publicDir = projectDir </> publicDirName
let cacheDir = publicDir </> "cache"
-- Find sources
deckSources <- glob "**/*-deck.md"
pageSources <- glob "**/*-page.md"
allSources <- glob "**/*.md"
meta <- glob "**/*.yaml"
let plainSources = allSources \\ (deckSources ++ pageSources)
-- Calculate targets
let decks = targetPathes deckSources projectDir ".md" ".html"
let decksPdf = targetPathes deckSources projectDir ".md" ".pdf"
let handouts = targetPathes deckSources projectDir "-deck.md" "-handout.html"
let handoutsPdf = targetPathes deckSources projectDir "-deck.md" "-handout.pdf"
let pages = targetPathes pageSources projectDir ".md" ".html"
let pagesPdf = targetPathes pageSources projectDir ".md" ".pdf"
let plain = targetPathes plainSources projectDir ".md" ".html"
let plainPdf = targetPathes pageSources projectDir ".md" ".pdf"
let indexSource = projectDir </> "index.md"
let index = publicDir </> "index.html"
let everything = decks ++ handouts ++ pages ++ plain ++ [index]
let everythingPdf = decksPdf ++ handoutsPdf ++ pagesPdf ++ plainPdf
let cruft = [ "index.md.generated"
, "server.log"
, "//.shake"
]
context <- makeActionContext projectDir publicDir cacheDir
runShakeInContext context options $ do
want ["html"]
phony "decks" $ do
need decks
phony "html" $ do
need ["index.html"]
getDecks <++> getHandouts <++> getPages <++> getPlain >>= need
need $ everything ++ [index]
-- getDecks <++> getHandouts <++> getPages <++> getPlain >>= need
phony "pdf" $ do
need ["index.html"]
getPagesPdf <++> getHandoutsPdf <++> getPlainPdf >>= need
need $ pagesPdf ++ handoutsPdf ++ plainPdf ++ [index]
-- getPagesPdf <++> getHandoutsPdf <++> getPlainPdf >>= need
phony "pdf-decks" $ do
need ["index.html"]
getDecksPdf >>= need
need $ decksPdf ++ [index]
-- getDecksPdf >>= need
phony "watch" $ do
need ["html"]
getDecks <++> getHandouts <++> getPages <++> getPlain >>= markNeeded
sources <- getAllSources
meta <- getMeta
watchFiles (sources ++ meta) contextRef
watchFiles $ allSources ++ meta
phony "server" $ do
need ["watch"]
runHttpServer contextRef True
runHttpServer True
phony "example" writeExampleProject
priority 2 $ "//*-deck.html" %> \out -> do
let src = out -<.> "md"
meta <- getMeta
let src = sourcePath out projectDir ".html" ".md"
markdownToHtmlDeck src meta out
priority 2 $ "//*-deck.pdf" %> \out -> do
let src = out -<.> "html"
let src = sourcePath out projectDir ".pdf" ".html"
need [src]
runHttpServer contextRef False
runHttpServer False
code <- cmd "decktape.sh reveal" ("http://localhost:8888/" ++ src) out
case code of
ExitFailure _ -> do
......@@ -100,71 +102,60 @@ main = do
return ()
priority 2 $ "//*-handout.html" %> \out -> do
let src = dropSuffix "-handout.html" out ++ "-deck.md"
meta <- getMeta
let src = sourcePath out projectDir "-handout.html" "-deck.md"
markdownToHtmlHandout src meta out
priority 2 $ "//*-handout.pdf" %> \out -> do
let src = dropSuffix "-handout.pdf" out ++ "-deck.md"
meta <- getMeta
let src = sourcePath out projectDir "-handout.pdf" "-deck.md"
markdownToPdfHandout src meta out
priority 2 $ "//*-page.html" %> \out -> do
let src = dropSuffix "-page.html" out ++ "-page.md"
meta <- getMeta
let src = sourcePath out projectDir "-page.html" "-page.md"
markdownToHtmlPage src meta out
priority 2 $ "//*-page.pdf" %> \out -> do
let src = dropSuffix "-page.pdf" out ++ "-page.md"
meta <- getMeta
let src = sourcePath out projectDir "-page.pdf" "-page.md"
markdownToPdfPage src meta out
priority 2 $ "index.html" %> \out -> do
exists <- Development.Shake.doesFileExist "index.md"
let src = if exists then "index.md" else "index.md.generated"
meta <- getMeta
priority 2 $ index %> \out -> do
exists <- Development.Shake.doesFileExist indexSource
let src = if exists then indexSource else indexSource <.> "generated"
markdownToHtmlPage src meta out
"index.md.generated" %> \out -> do
decks <-getDecks
handouts <- getHandouts
pages <- getPages
plain <- getPlain
indexSource <.> "generated" %> \out -> do
need $ decks ++ handouts ++ pages ++ plain
writeIndex out decks handouts pages plain
writeIndex out (takeDirectory index) decks handouts pages plain
"//*.html" %> \out -> do
let src = out -<.> "md"
meta <- getMeta
markdownToHtmlPage src meta out
"//*.pdf" %> \out -> do
let src = out -<.> "md"
meta <- getMeta
markdownToPdfPage src meta out
phony "clean" $
getEverything <++> getEverythingPdf <++> getCruft >>= removeFilesAfter "."
phony "clean" $ do
removeFilesAfter publicDir ["//"]
removeFilesAfter projectDir cruft
phony "help" $
liftIO $ B.putStr helpText
phony "source" $ do
source <- getAllSources
meta <- getMeta
liftIO $ mapM_ putStrLn $ source ++ meta
phony "plan" $ do
putNormal $ "project directory: " ++ projectDir
putNormal "sources:"
mapM_ putNormal $ allSources ++ meta
putNormal "targets:"
mapM_ putNormal $ everything ++ everythingPdf
phony "meta" $ do
meta <- getMeta
value <- readMetaData meta
liftIO $ B.putStr $ encodePretty defConfig value
phony "publish" $ do
everything <- getEverything
need everything
need $ everything ++ ["index.html"]
hasResource <- Development.Shake.doesDirectoryExist resourceDir
let source = if hasResource then resourceDir : everything else everything
meta <- getMeta
metaData <- readMetaData meta
let host = metaValueAsString "rsync-destination.host" metaData
let path = metaValueAsString "rsync-destination.path" metaData
......@@ -174,16 +165,42 @@ main = do
cmd "rsync -a" source $ intercalate ":" [fromJust host, fromJust path] :: Action ()
else throw RsyncUrlException
phony "cache" $ getAllSources >>= mapM_ cacheImages
phony "cache" $
cacheRemoteImages cacheDir meta allSources
phony "clean-cache" $ do
need ["clean"]
removeFilesAfter "." ["**/cached"]
phony "self-test" $ do
ctx <- getActionContext
putNormal $ show ctx
-- | Glob for pathes below and relative to the current directory.
globRelative :: String -> Action [FilePath]
globRelative pat = liftIO $ glob pat >>= mapM makeRelativeToCurrentDirectory
-- | Glob for pathes below and relative to the current directory.
globRelativeIO :: String -> IO [FilePath]
globRelativeIO pat = glob pat >>= mapM makeRelativeToCurrentDirectory
-- | Some constants that might need tweaking
resourceDir = "img"
options = shakeOptions{shakeFiles=".shake"}
publicDirName :: String
publicDirName = "public"
targetPath :: FilePath -> FilePath -> String -> String -> FilePath
targetPath source projectDir srcSuffix targetSuffix =
let target = projectDir </> publicDirName </> (makeRelative projectDir source)
in dropSuffix srcSuffix target ++ targetSuffix
targetPathes :: [FilePath] -> FilePath -> String -> String -> [FilePath]
targetPathes sources projectDir srcSuffix targetSuffix =
[targetPath s projectDir srcSuffix targetSuffix | s <- sources]
sourcePath :: FilePath -> FilePath -> String -> String -> FilePath
sourcePath out projectDir targetSuffix srcSuffix =
let source = projectDir </> (makeRelative (projectDir </> publicDirName) out)
in dropSuffix targetSuffix source ++ srcSuffix
resource/example/example-deck.md
View file @ 10e5e168
......@@ -52,13 +52,13 @@ subtitle: Tutorial and Examples
## The author
![](img/htr-beuth.jpg)
![](https://tramberend.beuth-hochschule.de/img/htr-beuth.jpg)
###
## Slide source
``` {.markdown}
``` {.markdown}
# Multicolumn slides
## The author
......@@ -283,7 +283,7 @@ Your total score is 42.
## Generated from `*-deck.md`
- `*-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
- `*-handout.html` a HTML document containing only the speaker notes from the
deck
......
resource/example/example-meta.yaml
View file @ 10e5e168
---
rsync-destination:
rsync-destination:
host: tramberend@tramberend.beuth-hochschule.de
path: /var/www/html/internal/lehre/16-ws/bmi-cgg
sometext: Some random text.
course: Real-Time Rendering
semester: Winter 2016
structured:
structured:
- First
- Second
- Third
- Fourth
date: 14.5.2016
csl: chicago-author-date.csl
...
resource/example/index.md.generated deleted 100644 → 0
View file @ e8781e10
# Index
## Slide decks
- [example-deck.html](example-deck.html)
## Handouts
- [example-handout.html](example-handout.html)
## Supporting Documents
- [example-page.html](example-page.html)
## Everything else
resource/support/reveal.js/plugin/markdown/example.html deleted 100644 → 0
View file @ e8781e10
<!doctype html>
<html lang="en">
<head>
<meta charset="utf-8">
<title>reveal.js - Markdown Demo</title>
<link rel="stylesheet" href="../../css/reveal.css">
<link rel="stylesheet" href="../../css/theme/white.css" id="theme">
<link rel="stylesheet" href="../../lib/css/zenburn.css">
</head>
<body>
<div class="reveal">
<div class="slides">
<!-- Use external markdown resource, separate slides by three newlines; vertical slides by two newlines -->
<section data-markdown="example.md" data-separator="^\n\n\n" data-separator-vertical="^\n\n"></section>
<!-- Slides are separated by three dashes (quick 'n dirty regular expression) -->
<section data-markdown data-separator="---">
<script type="text/template">
## Demo 1
Slide 1
---
## Demo 1
Slide 2
---
## Demo 1
Slide 3
</script>
</section>
<!-- Slides are separated by newline + three dashes + newline, vertical slides identical but two dashes -->
<section data-markdown data-separator="^\n---\n$" data-separator-vertical="^\n--\n$">
<script type="text/template">
## Demo 2
Slide 1.1
--
## Demo 2
Slide 1.2
---
## Demo 2
Slide 2
</script>
</section>
<!-- No "extra" slides, since there are no separators defined (so they'll become horizontal rulers) -->
<section data-markdown>
<script type="text/template">
A
---
B
---
C
</script>
</section>
<!-- Slide attributes -->
<section data-markdown>
<script type="text/template">
<!-- .slide: data-background="#000000" -->
## Slide attributes
</script>
</section>
<!-- Element attributes -->
<section data-markdown>
<script type="text/template">
## Element attributes
- Item 1 <!-- .element: class="fragment" data-fragment-index="2" -->
- Item 2 <!-- .element: class="fragment" data-fragment-index="1" -->
</script>
</section>
<!-- Code -->
<section data-markdown>
<script type="text/template">
```php
public function foo()
{
$foo = array(
'bar' => 'bar'
)
}
```
</script>
</section>
</div>
</div>
<script src="../../lib/js/head.min.js"></script>
<script src="../../js/reveal.js"></script>
<script>
Reveal.initialize({
controls: true,
progress: true,
history: true,
center: true,
// Optional libraries used to extend on reveal.js
dependencies: [
{ src: '../../lib/js/classList.js', condition: function() { return !document.body.classList; } },
{ src: 'marked.js', condition: function() { return !!document.querySelector( '[data-markdown]' ); } },
{ src: 'markdown.js', condition: function() { return !!document.querySelector( '[data-markdown]' ); } },
{ src: '../highlight/highlight.js', async: true, callback: function() { hljs.initHighlightingOnLoad(); } },
{ src: '../notes/notes.js' }
]
});
</script>
</body>
</html>
resource/support/reveal.js/plugin/markdown/example.md deleted 100644 → 0
View file @ e8781e10
# Markdown Demo
## External 1.1
Content 1.1
Note: This will only appear in the speaker notes window.
## External 1.2
Content 1.2
## External 2
Content 2.1
## External 3.1
Content 3.1
## External 3.2
Content 3.2
slides.cabal
View file @ 10e5e168
......@@ -15,7 +15,7 @@ cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Utilities, Filter
exposed-modules: Context, Utilities, Filter
build-depends: base
, pandoc-types
, pandoc-citeproc
......@@ -61,6 +61,7 @@ executable decker
, pandoc
, yaml
, mustache
, io-memoize
default-language: Haskell2010
executable include-pandoc-filter
......
src/context.hs 0 → 100644
View file @ 10e5e168
{-# LANGUAGE DeriveDataTypeable #-}
module Context
(ActionContext(..), makeActionContext, setActionContext, getFilesToWatch,
setFilesToWatch, getServerHandle, setServerHandle, getProjectDir,
getPublicDir, getCacheDir, actionContextKey, getActionContext)
where
import Control.Monad()
import Development.Shake
import Data.Dynamic
import Data.Maybe
import Data.IORef
import Data.Typeable()
import qualified Data.HashMap.Lazy as HashMap
import System.Process
import Text.Printf
data ActionContext =
ActionContext {ctxFilesToWatch :: IORef [FilePath]
,ctxServerHandle :: IORef (Maybe ProcessHandle)
,ctxProjectDir :: FilePath
,ctxPublicDir :: FilePath
,ctxCacheDir :: FilePath}
deriving (Typeable)
instance Show ActionContext where
show ctx =
printf "ActionContext {ctxProjectDir = %s, ctxPublicDir = %s, ctxCacheDir = %s}"
(ctxProjectDir ctx)
(ctxPublicDir ctx)
(ctxCacheDir ctx)
defaultActionContext :: IO ActionContext
defaultActionContext = do
files <- newIORef []
server <- newIORef Nothing
return $ ActionContext files server "" "" ""
actionContextKey :: IO TypeRep
actionContextKey = do
ctx <- liftIO $ defaultActionContext
return $ typeOf ctx
makeActionContext :: FilePath -> FilePath -> FilePath -> IO ActionContext
makeActionContext projectDir publicDir cacheDir =
do ctx <- defaultActionContext
return $
ctx {ctxProjectDir = projectDir
,ctxPublicDir = publicDir
,ctxCacheDir = cacheDir}
setActionContext :: ActionContext -> ShakeOptions -> IO ShakeOptions
setActionContext ctx options =
do key <- liftIO $ actionContextKey
let extra = HashMap.insert key (toDyn ctx) $ HashMap.empty
return options {shakeExtra = extra}
getActionContext :: Action ActionContext
getActionContext = do
options <- getShakeOptions
key <- liftIO $ actionContextKey
let extra = shakeExtra options
let dyn = case HashMap.lookup key extra of
Just d -> d
Nothing -> error "Error looking up action context"
return $ case fromDynamic dyn of
Just d -> d
Nothing -> error "Error upcasting action context"
getFilesToWatch :: Action [FilePath]
getFilesToWatch = do
ctx <- getActionContext
liftIO $ readIORef $ ctxFilesToWatch ctx
setFilesToWatch :: [FilePath] -> Action ()
setFilesToWatch files = do
ctx <- getActionContext
liftIO $ writeIORef (ctxFilesToWatch ctx) files
getServerHandle :: Action (Maybe ProcessHandle)
getServerHandle = do
ctx <- getActionContext
liftIO $ readIORef $ ctxServerHandle ctx
setServerHandle :: Maybe ProcessHandle -> Action ()
setServerHandle handle = do
ctx <- getActionContext
liftIO $ writeIORef (ctxServerHandle ctx) handle
getProjectDir :: Action FilePath
getProjectDir =
do ctx <- getActionContext
return $ ctxProjectDir ctx
getPublicDir :: Action FilePath
getPublicDir =
do ctx <- getActionContext
return $ ctxPublicDir ctx
getCacheDir :: Action FilePath
getCacheDir =
do ctx <- getActionContext
return $ ctxCacheDir ctx
src/filter.hs
View file @ 10e5e168
......@@ -2,7 +2,7 @@
module Filter