Commit 254e4604 authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

First working version

parent 3e7cf8f6
......@@ -29,7 +29,7 @@ main = do
-- Calculate some directories
projectDir <- calcProjectDirectory
let publicDir = projectDir </> "public"
let cacheDir = publicDir </> "cache"
let cacheDir = projectDir </> "cache"
let supportDir = publicDir </> "support"
-- Find sources. These are formulated as actions in the Action mondad, such
......@@ -37,6 +37,8 @@ main = do
let deckSourcesA = globA "**/*-deck.md"
let pageSourcesA = globA "**/*-page.md"
let allSourcesA = deckSourcesA <++> pageSourcesA
let allMarkdownA = globA "**/*.md"
let allImagesA = globA "**/*.png" <++> globA "**/*.jpg"
let metaA = globA "**/*-meta.yaml"
......@@ -82,10 +84,10 @@ main = do
phony "watch" $ do
need ["html"]
allSourcesA <++> metaA >>= watchFiles
allMarkdownA <++> metaA <++> allImagesA >>= watchFiles
phony "server" $ do
need ["watch"]
need ["watch", "support"]
runHttpServer publicDir True
phony "example" writeExampleProject
......@@ -154,9 +156,11 @@ main = do
liftIO $ B.putStr $ encodePretty defConfig metaData
phony "support" $ do
putNormal $ "# write embedded files for (" ++ supportDir ++ ")"
writeEmbeddedFiles deckerSupportDir supportDir
phony "publish" $ do
need ["support"]
everythingA <++> indexA >>= need
metaData <- readMetaDataFor projectDir
let host = metaValueAsString "rsync-destination.host" metaData
......@@ -167,15 +171,6 @@ main = do
cmd "rsync -a" publicDir $ intercalate ":" [fromJust host, fromJust path] :: Action ()
else throw RsyncUrlException
phony "cache" $ do
meta <- metaA
sources <- allSourcesA
cacheRemoteImages cacheDir meta sources
phony "clean-cache" $ do
need ["clean"]
removeFilesAfter "." ["**/cached"]
-- | Some constants that might need tweaking
options = shakeOptions{shakeFiles=".shake"}
......
......@@ -229,7 +229,7 @@ the referencing document
## Cached remote image
![Some piece of scene
graph](http://mmi-rtr.dev/slides/02-jet-engine/img/cube-scene-graph.png)
graph](https://tramberend.beuth-hochschule.de/img/cg1-banner.png)
# Meta Data
......
......@@ -7,7 +7,7 @@ date: 15.5.2016
# Introduction
![#include](/resource/relative.md)
[#include](/resource/relative.md)
This is just a simple run-of-the-mill document. Use it for exercises and
everything else. This document also has access to the meta data in surrounding
......
......@@ -28,7 +28,7 @@ $for(css)$
<link rel="stylesheet" href="$css$">
$endfor$
$else$
<link rel="stylesheet" href="https://bootswatch.com/sandstone/bootstrap.min.css">
<link rel="stylesheet" href="$decker-css$">
$endif$
<style type="text/css">
.container {
......
......@@ -28,7 +28,7 @@ $for(css)$
<link rel="stylesheet" href="$css$">
$endfor$
$else$
<link rel="stylesheet" href="https://bootswatch.com/sandstone/bootstrap.min.css">
<link rel="stylesheet" href="$decker-css$">
$endif$
<style type="text/css">
.container {
......
-- | Generally useful functions on pansoc data structures. Some in the IO monad.
module Pandoc
(isCacheableURI, cacheRemoteFile,
Pandoc.cacheRemoteImages, Pandoc.readMetaData)
(isCacheableURI, Pandoc.readMetaData)
where
import Control.Exception
......@@ -29,47 +28,6 @@ import Utilities
import Context
import Debug.Trace
cacheRemoteImages :: FilePath -> Pandoc -> IO Pandoc
cacheRemoteImages cacheDir pandoc = walkM cacheRemoteImage pandoc
where cacheRemoteImage (Image attr inlines (url,title)) =
do cachedFile <- cacheRemoteFile cacheDir url
return (Image attr inlines (cachedFile,title))
cacheRemoteImage img = return img
cacheRemoteFile :: FilePath -> String -> IO FilePath
cacheRemoteFile cacheDir url
| isCacheableURI url =
do let cacheFile = cacheDir </> hashURI url
exists <- fileExist cacheFile
if exists
then return cacheFile
else do content <- downloadUrl url
createDirectoryIfMissing True cacheDir
L.writeFile cacheFile content
return cacheFile
cacheRemoteFile _ url = return url
clearCachedFile :: FilePath -> String -> IO ()
clearCachedFile cacheDir url
| isCacheableURI url =
do let cacheFile = cacheDir </> hashURI url
exists <- fileExist cacheFile
when exists $ removeFile cacheFile
clearCachedFile _ _ = return ()
downloadUrl :: String -> IO L.ByteString
downloadUrl url =
do request <- parseRequest url
result <- httpLBS request
let status = getResponseStatus result
if status == ok200
then return $ getResponseBody result
else throw $
HttpException $
"Cannot download " ++ url ++ ": status: " ++ show status
hashURI :: String -> String
hashURI uri = (show $ md5 $ L.pack uri) <.> takeExtension uri
type MetaData = M.Map FilePath Y.Value
......
module Utilities
(cacheRemoteImages, calcProjectDirectory, spawn, terminate,
threadDelay', wantRepeat, waitForModificationIn, defaultContext,
runShakeInContext, watchFiles, waitForTwitch, dropSuffix,
stopServer, startServer, runHttpServer, writeIndex, readMetaData,
readMetaDataFor, readMetaDataIO, substituteMetaData,
markdownToHtmlDeck, markdownToHtmlHandout, markdownToPdfHandout,
markdownToHtmlPage, markdownToPdfPage, writeExampleProject,
metaValueAsString, (<++>), markNeeded, replaceSuffixWith,
writeEmbeddedFiles, getRelativeSupportDir,
pandocMakePdf, isCacheableURI, adjustLocalUrl, DeckerException(..))
(calcProjectDirectory, spawn, terminate, threadDelay', wantRepeat,
waitForModificationIn, defaultContext, runShakeInContext,
watchFiles, waitForTwitch, dropSuffix, stopServer, startServer,
runHttpServer, writeIndex, readMetaData, readMetaDataFor,
readMetaDataIO, substituteMetaData, markdownToHtmlDeck,
markdownToHtmlHandout, markdownToPdfHandout, markdownToHtmlPage,
markdownToPdfPage, writeExampleProject, metaValueAsString, (<++>),
markNeeded, replaceSuffixWith, writeEmbeddedFiles,
getRelativeSupportDir, pandocMakePdf, isCacheableURI,
adjustLocalUrl, cacheRemoteFile, cacheRemoteImages, makeRelativeTo,
DeckerException(..))
where
import Control.Monad.Loops
......@@ -33,6 +34,7 @@ import System.Process.Internals
import System.Directory as Dir
import System.Exit
import System.Posix.Signals
import System.Posix.Files
import System.FilePath
import System.FilePath.Glob
import qualified Data.Yaml as Y
......@@ -41,6 +43,7 @@ import qualified Text.Mustache.Types as MT
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 Text.Pandoc
import Text.Pandoc.Walk
import Text.Pandoc.PDF
......@@ -49,6 +52,7 @@ import Filter
import Debug.Trace
import Network.HTTP.Conduit
import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Network.URI
import Text.Highlighting.Kate.Styles
import Context
......@@ -295,7 +299,9 @@ getRelativeSupportDir from =
(makeRelative publicDir
(takeDirectory from)) </>
(makeRelative publicDir supportDir)
where invertPath fp = joinPath $ map (\_ -> "..") $ filter ((/=) ".") $ splitPath fp
invertPath :: FilePath -> FilePath
invertPath fp = joinPath $ map (\_ -> "..") $ filter ((/=) ".") $ splitPath fp
-- | Write a markdown file to a HTML file using the page template.
markdownToHtmlDeck
......@@ -315,21 +321,8 @@ markdownToHtmlDeck markdownFile out =
,writerCiteMethod = Citeproc}
pandoc <- readAndPreprocessMarkdown markdownFile
processed <- processPandocDeck "revealjs" pandoc
let images = extractLocalImagePathes processed
copyLocalImages images markdownFile out
writePandocString "revealjs" options out processed
copyLocalImages :: [FilePath] -> FilePath -> FilePath -> Action ()
copyLocalImages imageFiles inFile outFile =
do let inDir = takeDirectory inFile
let outDir = takeDirectory outFile
mapM_ (copyImageFile inDir outDir) imageFiles
where copyImageFile inDir outDir imageFile =
do let from = inDir </> imageFile
let to = outDir </> imageFile
liftIO $ createDirectoryIfMissing True (takeDirectory to)
copyFileChanged from to
type MetaData = Y.Value
-- | Selects a matching pandoc string writer for the format string, or throws an
......@@ -347,8 +340,13 @@ readAndPreprocessMarkdown :: FilePath -> Action Pandoc
readAndPreprocessMarkdown markdownFile =
do projectDir <- getProjectDir
let baseDir = takeDirectory markdownFile
pandoc <- readMetaMarkdown markdownFile
processIncludes projectDir baseDir pandoc
readMetaMarkdown markdownFile >>= processIncludes projectDir baseDir >>=
populateCache
populateCache :: Pandoc -> Action Pandoc
populateCache pandoc =
do cacheDir <- getCacheDir
liftIO $ walkM (cacheRemoteImages cacheDir) pandoc
-- | Write a markdown file to a HTML file using the page template.
markdownToHtmlPage
......@@ -365,12 +363,10 @@ markdownToHtmlPage markdownFile out =
KaTeX (supportDir </> "katex/katex.min.js")
(supportDir </> "katex/katex.min.css")
,writerVariables =
[("css",supportDir </> "sandstone/bootstrap.min.css")]
[("decker-css",supportDir </> "sandstone/bootstrap.min.css")]
,writerCiteMethod = Citeproc}
pandoc <- readAndPreprocessMarkdown markdownFile
processed <- processPandocPage "html5" pandoc
let images = extractLocalImagePathes processed
copyLocalImages images markdownFile out
writePandocString "html5" options out processed
-- | Write a markdown file to a PDF file using the handout template.
......@@ -411,7 +407,7 @@ markdownToHtmlHandout markdownFile out =
KaTeX (supportDir </> "katex/katex.min.js")
(supportDir </> "katex/katex.min.css")
,writerVariables =
[("css",supportDir </> "sandstone/bootstrap.min.css")]
[("decker-css",supportDir </> "sandstone/bootstrap.min.css")]
,writerCiteMethod = Citeproc}
writePandocString "html5" options out processed
......@@ -482,13 +478,13 @@ adjustLocalUrl root base url
else base </> url
adjustLocalUrl _ _ url = url
cacheRemoteImages :: FilePath -> [FilePath] -> [FilePath] -> Action ()
cacheRemoteImages cacheDir metaFiles markdownFiles =
do mapM_ cacheImages markdownFiles
where cacheImages markdownFile =
do pandoc <- readMetaMarkdown markdownFile
_ <- liftIO $ walkM (cachePandocImages cacheDir) pandoc
putNormal $ "# pandoc (cached images for " ++ markdownFile ++ ")"
-- cacheRemoteImages :: FilePath -> [FilePath] -> [FilePath] -> Action ()
-- cacheRemoteImages cacheDir metaFiles markdownFiles =
-- do mapM_ cacheImages markdownFiles
-- where cacheImages markdownFile =
-- do pandoc <- readMetaMarkdown markdownFile
-- _ <- liftIO $ walkM (cachePandocImages cacheDir) pandoc
-- putNormal $ "# pandoc (cached images for " ++ markdownFile ++ ")"
-- Transitively splices all include files into the pandoc document.
processIncludes :: FilePath -> FilePath -> Pandoc -> Action Pandoc
......@@ -511,6 +507,54 @@ processIncludes rootDir baseDir (Pandoc meta blocks) =
return $ included : result
include _ result block = return $ [block] : result
cacheRemoteImages :: FilePath -> Pandoc -> IO Pandoc
cacheRemoteImages cacheDir pandoc = walkM cacheRemoteImage pandoc
where cacheRemoteImage (Image attr inlines (url,title)) =
do cachedFile <- cacheRemoteFile cacheDir url
return (Image attr inlines (cachedFile,title))
cacheRemoteImage img = return img
cacheRemoteFile :: FilePath -> String -> IO FilePath
cacheRemoteFile cacheDir url
| isCacheableURI url =
do let cacheFile = cacheDir </> hashURI url
exists <- fileExist cacheFile
if exists
then return cacheFile
else catch (do content <- downloadUrl url
createDirectoryIfMissing True cacheDir
LB.writeFile cacheFile content
return cacheFile)
(\e ->
do putStrLn $ "Warning: " ++ show (e :: SomeException)
return url)
cacheRemoteFile _ url = return url
clearCachedFile :: FilePath -> String -> IO ()
clearCachedFile cacheDir url
| isCacheableURI url =
do let cacheFile = cacheDir </> hashURI url
exists <- fileExist cacheFile
when exists $ removeFile cacheFile
clearCachedFile _ _ = return ()
downloadUrl :: String -> IO LB.ByteString
downloadUrl url =
do request <- parseRequest url
result <- httpLBS request
let status = getResponseStatus result
if status == ok200
then return $ getResponseBody result
else throw $
HttpException $
"Cannot download " ++
url ++
" (" ++
show (statusCode status) ++ " " ++ B.unpack (statusMessage status) ++ ")"
hashURI :: String -> String
hashURI uri = (show $ md5 $ L8.pack uri) <.> takeExtension uri
processPandocPage
:: String -> Pandoc -> Action Pandoc
processPandocPage format pandoc =
......@@ -547,10 +591,38 @@ writePandocString :: String
-> Action ()
writePandocString format options out pandoc =
do let writer = getPandocWriter format
final <- copyImages (takeDirectory out) pandoc
writeFile' out
(writer options pandoc)
(writer options final)
putNormal $ "# pandoc for (" ++ out ++ ")"
copyImages :: FilePath -> Pandoc -> Action Pandoc
copyImages baseDir pandoc =
do projectDir <- getProjectDir
publicDir <- getPublicDir
walkM (copyAndLink baseDir projectDir publicDir) pandoc
where copyAndLink base project public image@(Image attr inlines (url,title)) =
do let rel = makeRelative project url
if rel == url
then return image
else do let pub = public </> rel
liftIO $ createDirectoryIfMissing True (takeDirectory pub)
copyFileChanged url pub
return (Image attr inlines (makeRelativeTo baseDir pub,title))
copyAndLink _ _ _ inline = return inline
makeRelativeTo :: FilePath -> FilePath -> FilePath
makeRelativeTo dir file =
let (d,fd) =
removeCommonPrefix (splitPath dir)
(splitPath (takeDirectory file))
in normalise $ invertPath (joinPath d) </> (joinPath fd) </> (takeFileName file)
where removeCommonPrefix al@(a:as) bl@(b:bs) =
if a == b
then removeCommonPrefix as bs
else (al,bl)
removeCommonPrefix a b = (a,b)
writeExampleProject :: Action ()
writeExampleProject = mapM_ writeOne deckerExampleDir
where writeOne (path,contents) =
......@@ -605,6 +677,7 @@ instance Exception DeckerException
instance Show DeckerException where
show (MustacheException e) = e
show (HttpException e) = e
show (PandocException e) = e
show (YamlException e) = e
show (DecktapeException e) =
......
......@@ -4,7 +4,6 @@ import Test.Hspec
import Data.Maybe
import Data.Text
import Pandoc
import Text.Pandoc
import Utilities
import System.FilePath
......@@ -43,6 +42,16 @@ main =
adjustLocalUrl projectDir "base" "some/where" `shouldBe`
"base/some/where"
--
describe "makeRelativeTo" $
do it "calculates the path of file relative to dir. Inlcudes '..'" $
do makeRelativeTo "" "img.png" `shouldBe` "img.png"
makeRelativeTo "/one/two" "/one/two/img.png" `shouldBe`
"img.png"
makeRelativeTo "/one/two/three" "/one/two/four/img.png" `shouldBe`
"../four/img.png"
makeRelativeTo "/some/where/else" "/one/two/four/img.png" `shouldBe`
"../../../one/two/four/img.png"
--
describe "cacheRemoteFile" $
it "Stores the data behind a URL locally, if possible. Return the local path to the cached file." $
do cacheRemoteFile cacheDir "https://tramberend.beuth-hochschule.de/img/htr-beuth.jpg" `shouldReturn`
......@@ -54,13 +63,10 @@ main =
"/img/htr-beuth.jpg"
cacheRemoteFile cacheDir "img/htr-beuth.jpg" `shouldReturn`
"img/htr-beuth.jpg"
cacheRemoteFile cacheDir
"https://tramberend.beuth-hochschule.de/img/htr-beuth.jpg.wurst" `shouldThrow`
anyException
--
describe "cacheRemoteImages" $
it "Replaces all remote images in the pandoc document with locally caches copies." $
do Pandoc.cacheRemoteImages
do cacheRemoteImages
cacheDir
(Pandoc nullMeta
[(Para [Image nullAttr
......@@ -73,28 +79,3 @@ main =
(cacheDir </>
"bc137c359488beadbb61589f7fe9e208.jpg"
,"")])])
Pandoc.cacheRemoteImages
cacheDir
(Pandoc nullMeta
[(Para [Image nullAttr
[]
("https://tramberend.beuth-hochschule.de/img/htr-beuth.jpg.wurst"
,"")])]) `shouldThrow`
anyException
--
describe "readMetaData" $
it "Collects the projects meta data from all .yaml files. Combines the data hierarchically for each directory." $
do Pandoc.readMetaData metaFiles `shouldReturn`
M.fromList
[("/Users/henrik/workspace/decker/resource/example"
,Y.Object (HM.fromList
[("semester",Y.String "Winter 2016")
,("structured"
,Y.array [Y.String "First"
,Y.String "Second"
,Y.String "Third"])
,("date",Y.String "14.5.2016")
,("csl",Y.String "chicago-author-date.csl")
,("course",Y.String "Real-Time Rendering")
,("resolver",Y.String "Meta Data Test")
,("sometext",Y.String "Some random text.")]))]
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment