Commit 95c2ea54 authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Working on URL resolution and meta data handling

parent 53cbe533
#!/usr/bin/env runhaskell
{-# LANGUAGE OverloadedStrings #-}
-- gnuplot.hs
-- gnuplot.hs
module Main where
import Text.Pandoc.JSON
import System.Process
import System.IO
import System.Exit
import System.Directory
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Digest.Pure.MD5
import Data.List
import Data.List.Split
import qualified Data.ByteString.Base64 as B64
import System.Directory
import System.Exit
import System.IO
import System.Process
import Text.Pandoc.JSON
-- Compiles an external Gnuplot file to an external PDF file. Returns the name of
-- the PDF file or an error message.
compileExternal :: String -> String -> IO (Either String String)
compileExternal cmd infile = do
let outfile = (Prelude.head (splitOn "." infile)) ++ ".pdf"
let prelude = "set terminal pdfcairo; set output '" ++ outfile ++ "';"
(exitCode, _, err) <- readProcessWithExitCode "gnuplot" ["-d", "-e", prelude, infile] ""
(exitCode, _, err) <-
readProcessWithExitCode "gnuplot" ["-d", "-e", prelude, infile] ""
if exitCode == ExitSuccess
then return (Right outfile)
else return (Left err)
then return (Right outfile)
else return (Left err)
genUniqueFilename :: String -> String -> String -> FilePath
genUniqueFilename prefix contents extension =
prefix ++ "-" ++ (take 8 $ show $ md5 $ L.pack contents) ++ "." ++ extension
prefix ++ "-" ++ (take 8 $ show $ md5 $ L.pack contents) ++ "." ++ extension
-- Compiles an embedded Gnuplot description to an external PDF file with a generated filename.
-- Returns the name of the PDF file or an error message.
compileInternal :: String -> String -> IO (Either String String)
compileInternal cmd contents = do
let outfile = genUniqueFilename cmd contents "pdf"
exists <- doesFileExist outfile
if exists
then return (Right outfile)
else do
then return (Right outfile)
else do
let prelude = "set terminal pdfcairo; set output '" ++ outfile ++ "';"
(exitCode, _, err) <- readProcessWithExitCode "gnuplot" ["-d"] (prelude ++ contents)
(exitCode, _, err) <-
readProcessWithExitCode "gnuplot" ["-d"] (prelude ++ contents)
if exitCode == ExitSuccess
then return (Right outfile)
else return (Left err)
then return (Right outfile)
else return (Left err)
-- Creates a Pandoc Image block from the filename or communicates an inline error message.
generateBlock :: (Either String String) -> IO Block
generateBlock (Right filename) = do
return (Para [Image nullAttr [] (filename, "Generated from code block")])
generateBlock (Left error) = do
hPutStrLn stderr msg
return (Para [Str msg])
where msg = "Error in filter 'gnuplot': " ++ error
-- Compiles gnuplot code from a code block to an image block
compileGnuplot :: Maybe Format -> Block -> IO Block
where
msg = "Error in filter 'gnuplot': " ++ error
thrd (_, _, x) = x
-- Compiles gnuplot code from a code block to an image block
compileGnuplot :: Maybe Format -> Block -> IO Block
compileGnuplot (Just (Format "latex")) cb@(CodeBlock attribs contents) =
case lookup "gnuplot" (thrd attribs) of
Just "" -> compileInternal "gnuplot" contents >>= generateBlock
Just infile -> compileExternal "gnuplot" infile >>= generateBlock
Nothing -> return cb
compileGnuplot (Just (Format "revealjs")) cb@(CodeBlock (id, classes, namevals) contents) =
case lookup "gnuplot" (thrd attribs) of
Just "block" -> compileInternal "gnuplot" contents >>= generateBlock
Just infile -> compileExternal "gnuplot" infile >>= generateBlock
Nothing -> return cb
compileGnuplot (Just (Format "revealjs")) cb@(CodeBlock (id, classes, namevals) contents)
-- Examine 'dot' attribute.
case lookup "dot" namevals of
=
case lookup "dot" namevals
-- Empty file name means 'read from code block'.
Just "" -> do
of
Just ""
-- Pipe content to dot, include result via data
-- url on an image tag. Otherwise it is difficult to control
-- the size if the resulting SVG element with CSS.
(exitCode, svg, err) <- readProcessWithExitCode "dot" ["-Tsvg"] contents
if exitCode == ExitSuccess
then return (Para [Image nullAttr [] (svgDataUrl svg, "Generated from code block")])
-> do
(exitCode, svg, err) <- readProcessWithExitCode "dot" ["-Tsvg"] contents
if exitCode == ExitSuccess
then return
(Para
[ Image
nullAttr
[]
(svgDataUrl svg, "Generated from code block")
])
else return (Para [Str $ "Error running 'dot': " ++ err])
-- Read from file
Just file -> do
(exitCode, svg, err) <- readProcessWithExitCode "dot" ["-Tsvg", file] ""
if exitCode == ExitSuccess
then return (Para [Image nullAttr [] (svgDataUrl svg, "Generated from file " ++ file)])
Just file -> do
(exitCode, svg, err) <- readProcessWithExitCode "dot" ["-Tsvg", file] ""
if exitCode == ExitSuccess
then return
(Para
[ Image
nullAttr
[]
(svgDataUrl svg, "Generated from file " ++ file)
])
else return (Para [Str $ "Error running 'dot': " ++ err])
-- Do nothing
Nothing -> return cb
Nothing -> return cb
compileGnuplot _ cb = return cb
main :: IO ()
......@@ -100,4 +109,5 @@ main = toJSONFilter compileGnuplot
-- | Encode a svg snippet into a data url for an image element
svgDataUrl :: String -> String
svgDataUrl svg = "data:image/svg+xml;base64," ++ (B.unpack (B64.encode (B.pack svg)))
svgDataUrl svg =
"data:image/svg+xml;base64," ++ (B.unpack (B64.encode (B.pack svg)))
......@@ -15,7 +15,7 @@ cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Watch, Test, Embed, Context, Utilities, Filter, Student, Shuffle
exposed-modules: Watch, Test, Embed, Context, Utilities, Filter, Student, Shuffle, Project
build-depends: base
, aeson
, random
......@@ -52,6 +52,7 @@ library
, fsnotify
, vector
, scientific
, transformers
default-language: Haskell2010
executable decker
......@@ -119,22 +120,22 @@ executable examiner
-- , pureMD5
-- default-language: Haskell2010
-- executable gnuplot-pandoc-filter
-- hs-source-dirs: app
-- main-is: Gnuplot.hs
-- ghc-options: -threaded -rtsopts -with-rtsopts=-N
-- build-depends: base
-- , slides
-- , pandoc-types
-- , base64-bytestring
-- , bytestring
-- , process
-- , blaze-markup
-- , blaze-html
-- , split
-- , pureMD5
-- , directory
-- default-language: Haskell2010
executable gnuplot-pandoc-filter
hs-source-dirs: app
main-is: Gnuplot.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base
, slides
, pandoc-types
, base64-bytestring
, bytestring
, process
, blaze-markup
, blaze-html
, split
, pureMD5
, directory
default-language: Haskell2010
-- executable macros-pandoc-filter
-- hs-source-dirs: app
......
module Project
( provisionResource
, removeCommonPrefix
, isPrefix
) where
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.Maybe
import Network.URI
import System.Directory
import System.FilePath
data Provisioning
= Copy -- Copy to public and relative link
| SymbolicLink -- Link to public and relative link
| Reference -- Absolute local link
data ResolvedUrl = ResolvedUrl
{ sourceFile :: FilePath -- Absolute Path to source file
, publicFile :: FilePath -- Absolute path to file in public folder
, publicUrl :: FilePath -- Relative URL to served file from base
}
-- Find the project directory.
-- The project directory is the first upwards directory that contains a .git directory entry.
calcProjectDirectory :: IO FilePath
calcProjectDirectory = do
cwd <- getCurrentDirectory
searchGitRoot cwd
where
searchGitRoot :: FilePath -> IO FilePath
searchGitRoot path =
if isDrive path
then makeAbsolute "."
else do
hasGit <- doesDirectoryExist (path </> ".git")
if hasGit
then makeAbsolute path
else searchGitRoot $ takeDirectory path
-- Resolves a file path to a concrete verified file system path, or
-- returns Nothing if no file can be found.
resolve :: FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
resolve project base path = do
let pathes =
if isAbsolute path
then [project </> makeRelative "/" path, path]
else [base </> path, project </> path]
listToMaybe <$> filterM doesFileExist pathes
resolveUrl :: FilePath -> FilePath -> FilePath -> IO (Maybe ResolvedUrl)
resolveUrl project base url = do
case parseURI url >>= fileOrRelativeUrl of
Nothing -> return Nothing
Just path -> do
file <- resolve project base path
case file of
Nothing -> return Nothing
Just file -> return $ Just $ ResolvedUrl file "" ""
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
-- are resolved against and copied or linked from
-- - the project root
-- - the local filesystem root
-- Relative file URLs are resolved against and copied or linked from
-- - the directory path of the referencing file
-- - the project root
-- Copy and link operations target the public directory in the project root
-- and recreate the source directory structure.
provisionResource ::
Provisioning -> FilePath -> FilePath -> FilePath -> IO FilePath
provisionResource provisioning project base path = do
let pathes =
if isAbsolute path
then [project </> makeRelative "/" path, path]
else [base </> path, project </> path]
resource <- listToMaybe <$> filterM doesFileExist pathes
case resource of
Nothing -> return path
Just resolved -> do
case provisioning of
Copy -> return resolved
SymbolicLink -> return resolved
Reference -> return resolved
copyFileChanged :: FilePath -> FilePath -> IO ()
copyFileChanged src dst = do
newer <- fileIsNewer src dst
if newer
then do
createDirectoryIfMissing True (takeDirectory dst)
copyFile src dst
else return ()
fileIsNewer a b = do
exists <- doesFileExist b
if exists
then do
at <- getModificationTime a
bt <- getModificationTime b
return (at > bt)
else return True
-- | Express the second path argument as relative to the first.
-- Both arguments are expected to be absolute pathes.
makeRelativeTo :: FilePath -> FilePath -> FilePath
makeRelativeTo dir file =
let (d, f) = removeCommonPrefix (dir, file)
in normalise $ invertPath d </> f
invertPath :: FilePath -> FilePath
invertPath fp = joinPath $ map (const "..") $ filter ("." /=) $ splitPath fp
removeCommonPrefix :: (FilePath, FilePath) -> (FilePath, FilePath)
removeCommonPrefix =
mapTuple joinPath . removeCommonPrefix_ . mapTuple splitDirectories
where
removeCommonPrefix_ :: ([FilePath], [FilePath]) -> ([FilePath], [FilePath])
removeCommonPrefix_ (al@(a:as), bl@(b:bs))
| a == b = removeCommonPrefix_ (as, bs)
| otherwise = (al, bl)
removeCommonPrefix_ pathes = pathes
isPrefix a b = isPrefix_ (splitPath a) (splitPath b)
where
isPrefix_ :: Eq a => [a] -> [a] -> Bool
isPrefix_ al@(a:as) bl@(b:bs)
| a == b = isPrefix_ as bs
| otherwise = False
isPrefix_ [] _ = True
isPrefix_ _ _ = False
mapTuple f (a, b) = (f a, f b)
......@@ -723,6 +723,7 @@ removeCommonPrefix :: [FilePath] -> [FilePath] -> ([FilePath], [FilePath])
removeCommonPrefix al@(a:as) bl@(b:bs)
| a == b = removeCommonPrefix as bs
| otherwise = (al, bl)
removeCommonPrefix a [] = (a, [])
removeCommonPrefix [] b = ([], b)
writeExampleProject :: Action ()
......
......@@ -10,6 +10,7 @@ import Data.Text
import Data.Text.Encoding
import qualified Data.Yaml as Y
import NeatInterpolation
import Project as P
import Student
import System.FilePath
import System.FilePath.Glob
......@@ -35,7 +36,7 @@ main = do
it "returns True if URL has http: or https: protocol" $ do
isCacheableURI "http://heise.de" `shouldBe` True
isCacheableURI "ftp://heise.de" `shouldBe` False
--
--
describe "adjustLocalUrl" $
it
"adjusts URL to be relative to the project root or the provided base directory" $ do
......@@ -60,7 +61,15 @@ main = do
"/Users/henrik/tmp/decker-demo/public"
"/Users/henrik/tmp/decker-demo/public/cache/b48cadafb942dc1426316772321dd0c7.png" `shouldBe`
"cache/b48cadafb942dc1426316772321dd0c7.png"
--
--
describe "removeCommonPrefix" $
it "Removes the common prefix from two pathes." $ do
P.removeCommonPrefix ("", "") `shouldBe` ("", "")
P.removeCommonPrefix ("fasel/bla", "fasel/bla/lall") `shouldBe` ("", "lall")
P.removeCommonPrefix ("lurgel/hopp", "fasel/bla/lall") `shouldBe` ("lurgel/hopp", "fasel/bla/lall")
P.removeCommonPrefix ("/lurgel/hopp", "fasel/bla/lall") `shouldBe` ("/lurgel/hopp", "fasel/bla/lall")
P.removeCommonPrefix ("/lurgel/hopp", "/fasel/bla/lall") `shouldBe` ("lurgel/hopp", "fasel/bla/lall")
--
describe "cacheRemoteFile" $
it
"Stores the data behind a URL locally, if possible. Return the local path to the cached file." $ do
......@@ -106,89 +115,68 @@ main = do
describe "parseStudentData" $
it "Parses student data in YAML format into a nifty data structure." $
parseStudentData projectDir `shouldReturn` Just realData
--
describe "splitMarkdown" $
it "Splits markdown into text und meta data." $ do
splitMarkdown "" `shouldBe` ("", Y.Object $ H.fromList [])
splitMarkdown "Hällö" `shouldBe` ("Hällö", Y.Object $ H.fromList [])
splitMarkdown "---\ntext: Hällö\n---" `shouldBe`
("", Y.Object $ H.fromList [("text", "Hällö")])
splitMarkdown "---\ntext: Hallo Wach\n---\nSome more text." `shouldBe`
("Some more text.", Y.Object $ H.fromList [("text", "Hallo Wach")])
splitMarkdown
"---\ntext: Hallo Wach\n---\nSome more text.\n---\ntoast: Cheese\n---\nSandwich" `shouldBe`
( "Some more text.\n\nSandwich"
, Y.Object $ H.fromList [("text", "Hallo Wach"), ("toast", "Cheese")])
--
describe "toMeta" $
it "Converts YAML.Value data to Pandoc.Meta data" $ do
toMeta (Y.Object $ H.fromList []) `shouldBe` MetaMap M.empty
toMeta (Y.Object $ H.fromList [("test", "Hallo")]) `shouldBe`
MetaMap (M.fromList [("test", MetaString "Hallo")])
mockData :: Students
mockData =
Students $
H.fromList
[ ( "888888"
, Student "mock" "mock" "mock" "mock" "mock" "mock" "mock" "mock" 1)
, ( "888889"
, Student "mock" "mock" "mock" "mock" "mock" "mock" "mock" "mock" 1)
]
Students
{ stds_course = "Mock"
, stds_semester = "Mock 1234"
, stds_students =
H.fromList
[ ("888888", Student "mock" "mock" "mock" "mock" "mock" "mock" 1)
, ("888889", Student "mock" "mock" "mock" "mock" "mock" "mock" 1)
]
}
realData :: Students
realData =
Students
(H.fromList
[ ( "836381"
, Student
{ std_uid = "s64386"
, std_department = "FB6"
, std_displayName = "Justen, David Alexander"
, std_employeeNumber = "836381"
, std_givenName = "David Alexander"
, std_mail = "s64386@beuth-hochschule.de"
, std_sAMAccountName = "s64386"
, std_sn = "Justen"
, std_track = 1
})
, ( "798101"
, Student
{ std_uid = "s53445"
, std_department = "FB6"
, std_displayName = "Mahmoud, Hassan"
, std_employeeNumber = "798101"
, std_givenName = "Hassan"
, std_mail = "s53445@beuth-hochschule.de"
, std_sAMAccountName = "s53445"
, std_sn = "Mahmoud"
, std_track = 1
})
, ( "814510"
, Student
{ std_uid = "s57637"
, std_department = "FB6"
, std_displayName = "Sahli, Hanen"
, std_employeeNumber = "814510"
, std_givenName = "Hanen"
, std_mail = "s57637@beuth-hochschule.de"
, std_sAMAccountName = "s57637"
, std_sn = "Sahli"
, std_track = 1
})
, ( "832701"
, Student
{ std_uid = "s61660"
, std_department = "FB6"
, std_displayName = "Naci Aydogan"
, std_employeeNumber = "832701"
, std_givenName = "Naci"
, std_mail = "s61660@beuth-hochschule.de"
, std_sAMAccountName = "s61660"
, std_sn = "Aydogan"
, std_track = 1
})
])
{ stds_course = "Mock"
, stds_semester = "Mock 1234"
, stds_students =
(H.fromList
[ ( "836381"
, Student
{ std_displayName = "Justen, David Alexander"
, std_employeeNumber = "836381"
, std_givenName = "David Alexander"
, std_mail = "s64386@beuth-hochschule.de"
, std_sAMAccountName = "s64386"
, std_sn = "Justen"
, std_track = 1
})
, ( "798101"
, Student
{ std_displayName = "Mahmoud, Hassan"
, std_employeeNumber = "798101"
, std_givenName = "Hassan"
, std_mail = "s53445@beuth-hochschule.de"
, std_sAMAccountName = "s53445"
, std_sn = "Mahmoud"
, std_track = 1
})
, ( "814510"
, Student
{ std_displayName = "Sahli, Hanen"
, std_employeeNumber = "814510"
, std_givenName = "Hanen"
, std_mail = "s57637@beuth-hochschule.de"
, std_sAMAccountName = "s57637"
, std_sn = "Sahli"
, std_track = 1
})
, ( "832701"
, Student
{ std_displayName = "Naci Aydogan"
, std_employeeNumber = "832701"
, std_givenName = "Naci"
, std_mail = "s61660@beuth-hochschule.de"
, std_sAMAccountName = "s61660"
, std_sn = "Aydogan"
, std_track = 1
})
])
}
genStudentData :: FilePath -> IO ()
genStudentData dir =
......
888888:
department: mock
givenName: mock
track: 1
uid: mock
sAMAccountName: mock
displayName: mock
sn: mock
employeeNumber: mock
mail: mock
888889:
department: mock
givenName: mock
track: 1
uid: mock
sAMAccountName: mock
displayName: mock
sn: mock
employeeNumber: mock
mail: mock
semester: Mock 1234
students:
888888:
givenName: mock
track: 1
sAMAccountName: mock
displayName: mock
sn: mock
employeeNumber: mock
mail: mock
888889:
givenName: mock
track: 1
sAMAccountName: mock
displayName: mock
sn: mock
employeeNumber: mock
mail: mock
course: Mock
{
"798101": {
"department": "FB6",
"displayName": "Mahmoud, Hassan",
"employeeNumber": "798101",
"givenName": "Hassan",
"mail": "s53445@beuth-hochschule.de",
"sAMAccountName": "s53445",
"sn": "Mahmoud",
"uid": "s53445",
"track": 1
},
"814510": {
"department": "FB6",
"displayName": "Sahli, Hanen",
"employeeNumber": "814510",
"givenName": "Hanen",
"mail": "s57637@beuth-hochschule.de",
"sAMAccountName": "s57637",
"sn": "Sahli",
"uid": "s57637",
"track": 1
},
"832701": {
"department": "FB6",
"displayName": "Naci Aydogan",
"employeeNumber": "832701",
"givenName": "Naci",
"mail": "s61660@beuth-hochschule.de",
"sAMAccountName": "s61660",
"sn": "Aydogan",
"uid": "s61660",
"track": 1
},
"836381": {
"department": "FB6",
"displayName": "Justen, David Alexander",
"employeeNumber": "836381",
"givenName": "David Alexander",
"mail": "s64386@beuth-hochschule.de",
"sAMAccountName": "s64386",
"sn": "Justen",
"uid": "s64386",