From 33c932e23c083a42a46f5b2a04dfd265818b2945 Mon Sep 17 00:00:00 2001
From: Henrik Tramberend <henrik@tramberend.de>
Date: Sat, 17 Jun 2017 07:13:18 +0200
Subject: [PATCH] Working on resource resolution
---
.vscode/launch.json | 21 +++++++
.vscode/phoityne.log | 16 +++++
app/decker.hs | 25 ++++----
app/examiner.hs | 10 +--
slides.cabal | 4 +-
src/common.hs | 31 ++++++++++
src/context.hs | 52 +++++-----------
src/project.hs | 141 ++++++++++++++++++++++++++++++-------------
src/utilities.hs | 106 +++++++++++++-------------------
test/Spec.hs | 102 ++++++++++++++++++++++++-------
10 files changed, 323 insertions(+), 185 deletions(-)
create mode 100644 .vscode/launch.json
create mode 100644 .vscode/phoityne.log
create mode 100644 src/common.hs
diff --git a/.vscode/launch.json b/.vscode/launch.json
new file mode 100644
index 0000000..50d43ca
--- /dev/null
+++ b/.vscode/launch.json
@@ -0,0 +1,21 @@
+{
+ "version": "0.2.0",
+ "configurations": [
+ {
+ "type": "ghc",
+ "name": "ghci debug viewer Phoityne",
+ "request": "launch",
+ "internalConsoleOptions": "openOnSessionStart",
+ "workspace": "${workspaceRoot}",
+ "startup": "${workspaceRoot}/test/Spec.hs",
+ "logFile": "${workspaceRoot}/.vscode/phoityne.log",
+ "logLevel": "WARNING",
+ "ghciPrompt": "H>>= ",
+ "ghciCmd": "stack ghci --test --no-load --no-build --main-is TARGET",
+ "ghciEnv": {},
+ "stopOnEntry": true,
+ "hackageVersion": "0.0.14.0",
+ "mainArgs": ""
+ }
+ ]
+}
\ No newline at end of file
diff --git a/.vscode/phoityne.log b/.vscode/phoityne.log
new file mode 100644
index 0000000..50416a3
--- /dev/null
+++ b/.vscode/phoityne.log
@@ -0,0 +1,16 @@
+2017-06-16 14:34:18 [ThreadId 11] ERROR phoityne - [deleteBreakPointOnGHCi] invalid delete break point. BreakPointData {nameBreakPointData = "Spec", srcPosBreakPointData = SourcePosition {filePathSourcePosition = "/Users/henrik/workspace/decker/test/Spec.hs", startLineNoSourcePosition = 97, startColNoSourcePosition = -1, endLineNoSourcePosition = -1, endColNoSourcePosition = -1}, breakNoBreakPointData = Nothing, conditionBreakPointData = Nothing, hitConditionBreakPointData = Nothing, hitCountBreakPointData = 0}
+2017-06-16 14:34:49 [ThreadId 16] ERROR phoityne - load file fail.[/Users/henrik/workspace/decker/test/Spec.hs] file load error. '/Users/henrik/workspace/decker/test/Spec.hs'
+2017-06-16 14:36:15 [ThreadId 11] ERROR phoityne - "error: Ambiguous occurrence \8216doesFileExist\8217 It could refer to either \8216Development.Shake.doesFileExist\8217, imported from \8216Development.Shake\8217 at /Users/henrik/workspace/decker/src/Context.hs:10:1-24 (and originally defined in \8216shake-0.15.11:Development.Shake.Rules.Directory\8217) or \8216System.Directory.doesFileExist\8217, imported from \8216System.Directory\8217 at /Users/henrik/workspace/decker/src/Filter.hs:23:1-23"
+2017-06-16 14:38:28 [ThreadId 11] ERROR phoityne - "\"extractSourcePosition\" (line 26, column 6):\nunexpected end of input\nexpecting \"Stopped at \" or \"Stopped in \" [INPUT] Resolves a file path to a concrete verified file system path. FAILED [2]\ncacheRemoteFile\n Stores the data behind a URL locally, if possible. Return the local path to the cached file.\ncacheRemoteImages\n Replaces all remote images in the pandoc document with locally caches copies.\nparseStudentData\n Parses student data in YAML format into a nifty data structure.\n\nFailures:\n\n /Users/henrik/workspace/decker/test/Spec.hs:107: \n 1) copyResource Copies an existing resource to the public dir and returns the public URL.\n expected: True\n but got: False\n\n /Users/henrik/workspace/decker/test/Spec.hs:112: \n 2) provisionResource Resolves a file path to a concrete verified file system path.\n expected: True\n but got: False\n\nRandomized with seed 1732182263\n\nFinished in 107.8106 seconds\n10 examples, 2 failures\n*** Exception: ExitFailure 1\nH>>= "
+2017-06-16 14:39:38 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: aexists"
+2017-06-16 14:39:44 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: aexists"
+2017-06-16 14:39:58 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: aexists"
+2017-06-16 14:40:20 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: b"
+2017-06-16 14:40:23 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: a"
+2017-06-16 14:40:32 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: a"
+2017-06-16 14:40:32 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: b"
+2017-06-16 14:41:01 [ThreadId 11] ERROR phoityne - "error: Ambiguous occurrence \8216doesFileExist\8217 It could refer to either \8216Development.Shake.doesFileExist\8217, imported from \8216Development.Shake\8217 at /Users/henrik/workspace/decker/src/Context.hs:10:1-24 (and originally defined in \8216shake-0.15.11:Development.Shake.Rules.Directory\8217) or \8216System.Directory.doesFileExist\8217, imported from \8216System.Directory\8217 at /Users/henrik/workspace/decker/src/Filter.hs:23:1-23"
+2017-06-16 15:24:07 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: a"
+2017-06-16 15:24:07 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: b"
+2017-06-16 15:26:22 [ThreadId 11] ERROR phoityne - "error: parse error on input \8216then\8217"
+2017-06-16 15:26:23 [ThreadId 11] ERROR phoityne - "error: \8226 Variable not in scope: bt \8226 Perhaps you meant one of these: \8216Ghci6.b\8217 (imported from Ghci6), \8216Ghci7.b\8217 (imported from Ghci7), \8216b\8217 (<no location info>)"
diff --git a/app/decker.hs b/app/decker.hs
index 0aaed11..3527dfe 100644
--- a/app/decker.hs
+++ b/app/decker.hs
@@ -18,15 +18,16 @@ import qualified Text.Mustache as M ()
import Text.Pandoc ()
import Text.Printf ()
import Utilities
+import Project
version = "0.1.0"
main :: IO ()
main = do
- projectDir <- calcProjectDirectory
- let publicDir = projectDir </> "public"
- let cacheDir = projectDir </> "cache"
- let supportDir = publicDir </> "support"
+ dirs <- projectDirectories
+ let projectDir = (project dirs)
+ let publicDir = (public dirs)
+ let supportDir = (support dirs)
-- Find sources. These are formulated as actions in the Action mondad, such
-- that each new iteration rescans all possible source files.
let deckSourcesA = globA "**/*-deck.md"
@@ -42,16 +43,16 @@ main = do
let handoutsPdfA = deckSourcesA >>= calcTargets "-deck.md" "-handout.pdf"
let pagesA = pageSourcesA >>= calcTargets ".md" ".html"
let pagesPdfA = pageSourcesA >>= calcTargets ".md" ".pdf"
- let indexSource = projectDir </> "index.md"
+ let indexSource = (project dirs) </> "index.md"
let index = publicDir </> "index.html"
let indexA = return [index] :: Action [FilePath]
let everythingA = decksA <++> handoutsA <++> pagesA
let everythingPdfA = decksPdfA <++> handoutsPdfA <++> pagesPdfA
let cruft =
map
- (combine projectDir)
+ (combine (project dirs))
["index.md.generated", "server.log", "//.shake"]
- context <- makeActionContext projectDir publicDir cacheDir supportDir
+ context <- makeActionContext dirs
runShakeInContext context options $
--
do
@@ -185,22 +186,20 @@ replaceSuffix srcSuffix targetSuffix filename =
-- | Calculates the target pathes from a list of source files.
calcTargets :: String -> String -> [FilePath] -> Action [FilePath]
calcTargets srcSuffix targetSuffix sources = do
- projectDir <- getProjectDir
- publicDir <- getPublicDir
+ dirs <- getProjectDirs
return $
map
(replaceSuffix srcSuffix targetSuffix .
- combine publicDir . makeRelative projectDir)
+ combine (public dirs) . makeRelative (project dirs))
sources
-- | Calculate the source file from the target path. Calls need.
calcSource :: String -> String -> FilePath -> Action FilePath
calcSource targetSuffix srcSuffix target = do
- projectDir <- getProjectDir
- publicDir <- getPublicDir
+ dirs <- getProjectDirs
let src =
(replaceSuffix targetSuffix srcSuffix .
- combine projectDir . makeRelative publicDir)
+ combine (project dirs) . makeRelative (public dirs))
target
need [src]
return src
diff --git a/app/examiner.hs b/app/examiner.hs
index 078eaf4..d5f54c5 100644
--- a/app/examiner.hs
+++ b/app/examiner.hs
@@ -36,13 +36,15 @@ import Text.Pandoc
import Text.Pandoc.PDF
import Text.Pandoc.Walk
import Utilities
+import Project
replaceSuffix srcSuffix targetSuffix filename =
dropSuffix srcSuffix filename ++ targetSuffix
main :: IO ()
main = do
- projectDir <- calcProjectDirectory
+ dirs <- projectDirectories
+ let projectDir = (project dirs)
let privateDir = projectDir </> "private"
-- Find questions
questionSources <- glob "**/*-quest.yaml"
@@ -65,7 +67,7 @@ main = do
-- Prepare Mustache templates
let templates = compileTesterTemplates
---
- context <- makeActionContext projectDir privateDir "" ""
+ context <- makeActionContext (ProjectDirs projectDir privateDir "" "")
runShakeInContext context shakeOptions $ do
want ["catalog"]
--
@@ -205,8 +207,8 @@ compileTemplates disposition = do
compileProjectTemplate :: FilePath -> FilePath -> Action MT.Template
compileProjectTemplate disposition name = do
- projectDir <- getProjectDir
- let filename = projectDir </> "exams" </> "templates" </> disposition </> name
+ dirs <- getProjectDirs
+ let filename = (project dirs) </> "exams" </> "templates" </> disposition </> name
need [filename]
text <- liftIO $ T.readFile filename
let result = M.compileTemplate name (fixMustacheMarkupText text)
diff --git a/slides.cabal b/slides.cabal
index ff7e077..eac9957 100644
--- a/slides.cabal
+++ b/slides.cabal
@@ -15,7 +15,7 @@ cabal-version: >=1.10
library
hs-source-dirs: src
- exposed-modules: Watch, Test, Embed, Context, Utilities, Filter, Student, Shuffle, Project
+ exposed-modules: Watch, Test, Embed, Context, Utilities, Filter, Student, Shuffle, Project, Common
build-depends: base
, aeson
, random
@@ -53,6 +53,7 @@ library
, vector
, scientific
, transformers
+ , unix
default-language: Haskell2010
executable decker
@@ -191,6 +192,7 @@ test-suite slides-test
, text
, neat-interpolation
, bytestring
+ , directory
ghc-options: -threaded -rtsopts -with-rtsopts=-N
default-language: Haskell2010
diff --git a/src/common.hs b/src/common.hs
new file mode 100644
index 0000000..114e086
--- /dev/null
+++ b/src/common.hs
@@ -0,0 +1,31 @@
+module Common
+ ( DeckerException(..)
+ ) where
+
+import Control.Exception
+import Data.Typeable
+
+-- | Tool specific exceptions
+data DeckerException
+ = MustacheException String
+ | ResourceException String
+ | GitException String
+ | PandocException String
+ | YamlException String
+ | HttpException String
+ | RsyncUrlException
+ | DecktapeException String
+ deriving (Typeable)
+
+instance Exception DeckerException
+
+instance Show DeckerException where
+ show (MustacheException e) = e
+ show (ResourceException e) = e
+ show (GitException e) = e
+ show (HttpException e) = e
+ show (PandocException e) = e
+ show (YamlException e) = e
+ show (DecktapeException e) = "decktape.sh failed for reason: " ++ e
+ show RsyncUrlException =
+ "attributes 'destinationRsyncHost' or 'destinationRsyncPath' not defined in meta data"
diff --git a/src/context.hs b/src/context.hs
index 44f2a11..7640499 100644
--- a/src/context.hs
+++ b/src/context.hs
@@ -2,8 +2,8 @@
module Context
(ActionContext(..), makeActionContext, setActionContext, getFilesToWatch,
- setFilesToWatch, getServerHandle, setServerHandle, getProjectDir,
- getPublicDir, getCacheDir, getSupportDir, actionContextKey, getActionContext)
+ setFilesToWatch, getServerHandle, setServerHandle, getProjectDirs,
+ actionContextKey, getActionContext)
where
import Control.Monad ()
@@ -15,43 +15,33 @@ import Data.Typeable ()
import qualified Data.HashMap.Lazy as HashMap
import System.Process
import Text.Printf
+import Project
data ActionContext =
ActionContext {ctxFilesToWatch :: IORef [FilePath]
,ctxServerHandle :: IORef (Maybe ProcessHandle)
- ,ctxProjectDir :: FilePath
- ,ctxPublicDir :: FilePath
- ,ctxCacheDir :: FilePath
- ,ctxSupportDir :: FilePath}
- deriving (Typeable)
+ ,ctxDirs :: ProjectDirs}
+ deriving (Typeable, Show)
-instance Show ActionContext where
- show ctx =
- printf "ActionContext {ctxProjectDir = '%s', ctxPublicDir = '%s', ctxCacheDir = '%s', ctxSupportDir = '%s'}"
- (ctxProjectDir ctx)
- (ctxPublicDir ctx)
- (ctxCacheDir ctx)
- (ctxSupportDir ctx)
+instance Show (IORef a) where
+ show _ = "IORef"
defaultActionContext :: IO ActionContext
defaultActionContext = do
files <- newIORef []
server <- newIORef Nothing
- return $ ActionContext files server "" "" "" ""
+ return $ ActionContext files server (ProjectDirs "" "" "" "")
actionContextKey :: IO TypeRep
actionContextKey = do
ctx <- liftIO $ defaultActionContext
return $ typeOf ctx
-makeActionContext :: FilePath -> FilePath -> FilePath -> FilePath-> IO ActionContext
-makeActionContext projectDir publicDir cacheDir supportDir =
+makeActionContext :: ProjectDirs -> IO ActionContext
+makeActionContext dirs =
do ctx <- defaultActionContext
return $
- ctx {ctxProjectDir = projectDir
- ,ctxPublicDir = publicDir
- ,ctxCacheDir = cacheDir
- ,ctxSupportDir = supportDir}
+ ctx { ctxDirs = dirs }
setActionContext :: ActionContext -> ShakeOptions -> IO ShakeOptions
setActionContext ctx options =
@@ -91,22 +81,8 @@ setServerHandle handle = do
ctx <- getActionContext
liftIO $ writeIORef (ctxServerHandle ctx) handle
-getProjectDir :: Action FilePath
-getProjectDir =
+getProjectDirs :: Action ProjectDirs
+getProjectDirs =
do ctx <- getActionContext
- return $ ctxProjectDir ctx
+ return $ ctxDirs ctx
-getPublicDir :: Action FilePath
-getPublicDir =
- do ctx <- getActionContext
- return $ ctxPublicDir ctx
-
-getCacheDir :: Action FilePath
-getCacheDir =
- do ctx <- getActionContext
- return $ ctxCacheDir ctx
-
-getSupportDir :: Action FilePath
-getSupportDir =
- do ctx <- getActionContext
- return $ ctxSupportDir ctx
diff --git a/src/project.hs b/src/project.hs
index a787cd4..7e73368 100644
--- a/src/project.hs
+++ b/src/project.hs
@@ -1,32 +1,73 @@
module Project
( provisionResource
+ , copyResource
+ , linkResource
+ , refResource
, removeCommonPrefix
, isPrefix
+ , makeRelativeTo
+ , findProjectDirectory
+ , projectDirectories
+ , resolve
+ , Resource(..)
+ , Provisioning(..)
+ , ProjectDirs(..)
) where
+import Common
import Control.Monad
+import Control.Exception
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.Maybe
+import Debug.Trace
+import Extra
import Network.URI
import System.Directory
import System.FilePath
+import System.Posix.Files
data Provisioning
= Copy -- Copy to public and relative link
| SymbolicLink -- Link to public and relative link
| Reference -- Absolute local link
+ deriving (Eq, Show)
-data ResolvedUrl = ResolvedUrl
+data Resource = Resource
{ 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
- }
+ } deriving (Eq, Show)
+
+copyResource :: Resource -> IO (FilePath)
+copyResource resource
+ -- copyFileIfNewer (sourceFile resource) (publicFile resource)
+ = do
+ createDirectoryIfMissing True (takeDirectory (publicFile resource))
+ copyFile (sourceFile resource) (publicFile resource)
+ return (publicUrl resource)
+
+linkResource :: Resource -> IO (FilePath)
+linkResource resource = do
+ whenM (doesFileExist (publicFile resource)) (removeFile (publicFile resource))
+ createSymbolicLink (sourceFile resource) (publicFile resource)
+ return (publicUrl resource)
+
+refResource :: Resource -> IO (FilePath)
+refResource resource = do
+ return $ show $ URI "file" Nothing (sourceFile resource) "" ""
+
+data ProjectDirs = ProjectDirs
+ { project :: FilePath
+ , public :: FilePath
+ , cache :: FilePath
+ , support :: FilePath
+ } deriving (Eq, Show)
-- Find the project directory.
-- The project directory is the first upwards directory that contains a .git directory entry.
-calcProjectDirectory :: IO FilePath
-calcProjectDirectory = do
+findProjectDirectory :: IO FilePath
+findProjectDirectory = do
cwd <- getCurrentDirectory
searchGitRoot cwd
where
@@ -40,25 +81,38 @@ calcProjectDirectory = do
then makeAbsolute path
else searchGitRoot $ takeDirectory path
+-- Calculate important absolute project directory pathes
+projectDirectories :: IO ProjectDirs
+projectDirectories = do
+ projectDir <- findProjectDirectory
+ let publicDir = projectDir </> "public"
+ let cacheDir = publicDir </> "cache"
+ let supportDir = publicDir </> "support"
+ return (ProjectDirs projectDir publicDir cacheDir supportDir)
+
-- 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 =
+resolve :: ProjectDirs -> FilePath -> FilePath -> IO (Maybe Resource)
+resolve dirs base path = do
+ let candidates =
if isAbsolute path
- then [project </> makeRelative "/" path, path]
- else [base </> path, project </> path]
- listToMaybe <$> filterM doesFileExist pathes
+ then [(project dirs) </> makeRelative "/" path, path]
+ else [base </> path, (project dirs) </> path]
+ (listToMaybe . map resolveResource) <$> filterM doesFileExist candidates
+ where
+ resolveResource absolute =
+ let relative = makeRelativeTo (project dirs) absolute
+ in Resource
+ { sourceFile = absolute
+ , publicFile = (public dirs) </> makeRelativeTo (project dirs) absolute
+ , publicUrl = makeRelativeTo base absolute
+ }
-resolveUrl :: FilePath -> FilePath -> FilePath -> IO (Maybe ResolvedUrl)
-resolveUrl project base url = do
+resolveUrl :: ProjectDirs -> FilePath -> FilePath -> IO (Maybe Resource)
+resolveUrl dirs 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 "" ""
+ Just path -> resolve dirs base path
fileOrRelativeUrl :: URI -> Maybe FilePath
fileOrRelativeUrl (URI "file:" Nothing path _ _) = Just path
@@ -67,31 +121,29 @@ 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
+-- 1. the project root
+-- 2. 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
+-- 1. the directory path of the referencing file
+-- 2. 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
+ Provisioning -> ProjectDirs -> FilePath -> FilePath -> IO FilePath
+provisionResource provisioning dirs base path = do
+ resolved <- resolve dirs base path
+ case resolved of
+ Nothing -> throw $ ResourceException $ "Cannot find local resource: " ++ path
+ Just resource -> do
case provisioning of
- Copy -> return resolved
- SymbolicLink -> return resolved
- Reference -> return resolved
+ Copy -> copyResource resource
+ SymbolicLink -> linkResource resource
+ Reference -> refResource resource
-copyFileChanged :: FilePath -> FilePath -> IO ()
-copyFileChanged src dst = do
+-- | Copies the src to dst if src is newer or dst does not exist.
+-- Creates missing directories while doing so.
+copyFileIfNewer :: FilePath -> FilePath -> IO ()
+copyFileIfNewer src dst = do
newer <- fileIsNewer src dst
if newer
then do
@@ -100,13 +152,16 @@ copyFileChanged src dst = do
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
+ aexists <- doesFileExist a
+ bexists <- doesFileExist b
+ if bexists
+ then if aexists
+ then do
+ at <- getModificationTime a
+ bt <- getModificationTime b
+ return ((traceShowId at) > (traceShowId bt))
+ else return True
+ else return False
-- | Express the second path argument as relative to the first.
-- Both arguments are expected to be absolute pathes.
diff --git a/src/utilities.hs b/src/utilities.hs
index b03a26b..e02144d 100644
--- a/src/utilities.hs
+++ b/src/utilities.hs
@@ -85,6 +85,8 @@ import Text.Pandoc
import Text.Pandoc.PDF
import Text.Pandoc.Walk
import Watch
+import Project
+import Common
-- Find the project directory and change current directory to there.
-- The project directory is the first upwards directory that contains a .git directory entry.
@@ -107,16 +109,16 @@ calcProjectDirectory = do
-- Returns absolute pathes.
globA :: FilePattern -> Action [FilePath]
globA pat = do
- projectDir <- getProjectDir
- liftIO $ globDir1 (compile pat) projectDir
+ dirs <- getProjectDirs
+ liftIO $ globDir1 (compile pat) (project dirs)
-- | Globs for files under the project dir in the Action monad.
-- Returns pathes relative to the project directory.
globRelA :: FilePattern -> Action [FilePath]
globRelA pat = do
- projectDir <- getProjectDir
+ dirs <- getProjectDirs
files <- globA pat
- return $ map (makeRelative projectDir) files
+ return $ map (makeRelative (project dirs)) files
-- Utility functions for shake based apps
spawn :: String -> Action ProcessHandle
@@ -235,13 +237,13 @@ writeIndex out baseUrl decks handouts pages = do
let decksLinks = map (makeRelative baseUrl) decks
let handoutsLinks = map (makeRelative baseUrl) handouts
let pagesLinks = map (makeRelative baseUrl) pages
- projectDir <- getProjectDir
+ dirs <- getProjectDirs
liftIO $
writeFile out $
unlines
[ "---"
, "title: Generated Index"
- , "subtitle: " ++ projectDir
+ , "subtitle: " ++ (project dirs)
, "---"
, "# Slide decks"
, unlines $ map makeLink $ sort decksLinks
@@ -263,8 +265,8 @@ readMetaDataForDir :: FilePath -> Action Y.Value
readMetaDataForDir dir = walkUpTo dir
where
walkUpTo dir = do
- projectDir <- getProjectDir
- if equalFilePath projectDir dir
+ dirs <- getProjectDirs
+ if equalFilePath (project dirs) dir
then collectMeta dir
else do
fromAbove <- walkUpTo (takeDirectory dir)
@@ -308,11 +310,10 @@ substituteMetaData text metaData = do
getRelativeSupportDir :: FilePath -> Action FilePath
getRelativeSupportDir from = do
- supportDir <- getSupportDir
- publicDir <- getPublicDir
+ dirs <- getProjectDirs
return $
- invertPath (makeRelative publicDir (takeDirectory from)) </>
- makeRelative publicDir supportDir
+ invertPath (makeRelative (public dirs) (takeDirectory from)) </>
+ makeRelative (public dirs) (support dirs)
invertPath :: FilePath -> FilePath
invertPath fp = joinPath $ map (const "..") $ filter ("." /=) $ splitPath fp
@@ -356,16 +357,16 @@ getPandocWriter format =
-- template variables and calls need.
readAndPreprocessMarkdown :: FilePath -> Action Pandoc
readAndPreprocessMarkdown markdownFile = do
- projectDir <- getProjectDir
+ dirs <- getProjectDirs
let baseDir = takeDirectory markdownFile
- readMetaMarkdown markdownFile >>= processIncludes projectDir baseDir
+ readMetaMarkdown markdownFile >>= processIncludes (project dirs) baseDir
-- Disable automatic caching of remomte images for a while
-- >>= populateCache
populateCache :: Pandoc -> Action Pandoc
populateCache pandoc = do
- cacheDir <- getCacheDir
- liftIO $ walkM (cacheRemoteImages cacheDir) pandoc
+ dirs <- getProjectDirs
+ liftIO $ walkM (cacheRemoteImages (cache dirs)) pandoc
-- | Write a markdown file to a HTML file using the page template.
markdownToHtmlPage :: FilePath -> FilePath -> Action ()
@@ -474,8 +475,8 @@ readMetaMarkdown markdownFile = do
let (MetaMap m) = combinedMeta
let pandoc = Pandoc (Meta m) blocks
-- adjust image urls
- projectDir <- getProjectDir
- return $ walk (adjustImageUrls projectDir (takeDirectory markdownFile)) pandoc
+ dirs <- getProjectDirs
+ return $ walk (adjustImageUrls (project dirs) (takeDirectory markdownFile)) pandoc
where
readMarkdownOrThrow opts string =
case readMarkdown opts string of
@@ -637,28 +638,28 @@ hashURI uri = show (md5 $ L8.pack uri) SF.<.> SF.takeExtension uri
processPandocPage :: String -> Pandoc -> Action Pandoc
processPandocPage format pandoc = do
let f = Just (Format format)
- cacheDir <- getCacheDir
+ dirs <- getProjectDirs
processed <-
- liftIO $ processCites' pandoc >>= walkM (useCachedImages cacheDir)
- -- processed <- liftIO $ walkM (useCachedImages cacheDir) pandoc
+ liftIO $ processCites' pandoc >>= walkM (useCachedImages (cache dirs))
+ -- processed <- liftIO $ walkM (useCachedImages (cache dirs)) pandoc
return $ expandMacros f processed
processPandocDeck :: String -> Pandoc -> Action Pandoc
processPandocDeck format pandoc = do
let f = Just (Format format)
- cacheDir <- getCacheDir
+ dirs <- getProjectDirs
processed <-
- liftIO $ processCites' pandoc >>= walkM (useCachedImages cacheDir)
- -- processed <- liftIO $ walkM (useCachedImages cacheDir) pandoc
+ liftIO $ processCites' pandoc >>= walkM (useCachedImages (cache dirs))
+ -- processed <- liftIO $ walkM (useCachedImages cacheD(cache dirs)ir) pandoc
return $ (makeSlides f . expandMacros f) processed
processPandocHandout :: String -> Pandoc -> Action Pandoc
processPandocHandout format pandoc = do
let f = Just (Format format)
- cacheDir <- getCacheDir
+ dirs <- getProjectDirs
processed <-
- liftIO $ processCites' pandoc >>= walkM (useCachedImages cacheDir)
- -- processed <- liftIO $ walkM (useCachedImages cacheDir) pandoc
+ liftIO $ processCites' pandoc >>= walkM (useCachedImages (cache dirs))
+ -- processed <- liftIO $ walkM (useCachedImages (cache dirs)) pandoc
return $ (expandMacros f . filterNotes f) processed
type StringWriter = WriterOptions -> Pandoc -> String
@@ -672,10 +673,9 @@ writePandocString format options out pandoc = do
copyImages :: FilePath -> Pandoc -> Action Pandoc
copyImages baseDir pandoc = do
- projectDir <- getProjectDir
- publicDir <- getPublicDir
- walkM (copyAndLinkInline projectDir publicDir) pandoc >>=
- walkM (copyAndLinkBlock projectDir publicDir)
+ dirs <- getProjectDirs
+ walkM (copyAndLinkInline (project dirs) (public dirs)) pandoc >>=
+ walkM (copyAndLinkBlock (project dirs) (public dirs))
where
copyAndLinkInline project public (Image attr inlines (url, title)) = do
relUrl <- copyAndLinkFile project public baseDir url
@@ -714,17 +714,17 @@ copyAndLinkFile project public base url = do
-- | 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 (splitDirectories dir) (splitDirectories file)
- in normalise $ invertPath (joinPath d) </> joinPath f
-
-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)
+-- makeRelativeTo :: FilePath -> FilePath -> FilePath
+-- makeRelativeTo dir file =
+-- let (d, f) = removeCommonPrefix (splitDirectories dir) (splitDirectories file)
+-- in normalise $ invertPath (joinPath d) </> joinPath f
+
+-- 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 ()
writeExampleProject = mapM_ writeOne deckerExampleDir
@@ -763,25 +763,3 @@ metaValueAsString key meta =
lookup' (k:ks) (Just obj@(Y.Object _)) = lookup' ks (lookupValue k obj)
lookup' _ _ = Nothing
--- | Tool specific exceptions
-data DeckerException
- = MustacheException String
- | GitException String
- | PandocException String
- | YamlException String
- | HttpException String
- | RsyncUrlException
- | DecktapeException String
- deriving (Typeable)
-
-instance Exception DeckerException
-
-instance Show DeckerException where
- show (MustacheException e) = e
- show (GitException e) = e
- show (HttpException e) = e
- show (PandocException e) = e
- show (YamlException e) = e
- show (DecktapeException e) = "decktape.sh failed for reason: " ++ e
- show RsyncUrlException =
- "attributes 'destinationRsyncHost' or 'destinationRsyncPath' not defined in meta data"
diff --git a/test/Spec.hs b/test/Spec.hs
index 187896e..18082a8 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -11,7 +11,9 @@ import Data.Text.Encoding
import qualified Data.Yaml as Y
import NeatInterpolation
import Project as P
+import Project
import Student
+import System.Directory
import System.FilePath
import System.FilePath.Glob
import System.FilePath.Posix
@@ -19,15 +21,11 @@ import Text.Pandoc
import Utilities
main = do
- projectDir <- calcProjectDirectory
+ dirs <- projectDirectories
--
- let publicDir = projectDir </> "public"
- let cacheDir = publicDir </> "cache"
- let supportDir = publicDir </> "support"
- --
- metaFiles <- globDir1 (compile "**/*-meta.yaml") projectDir
+ metaFiles <- globDir1 (compile "**/*-meta.yaml") (project dirs)
print metaFiles
- genStudentData projectDir
+ genStudentData (project dirs)
--
hspec $
--
@@ -40,13 +38,14 @@ main = do
describe "adjustLocalUrl" $
it
"adjusts URL to be relative to the project root or the provided base directory" $ do
- adjustLocalUrl projectDir "base" "http://heise.de" `shouldBe`
+ adjustLocalUrl (project dirs) "base" "http://heise.de" `shouldBe`
"http://heise.de"
--
- adjustLocalUrl projectDir "base" "/some/where" `shouldBe` projectDir </>
+ adjustLocalUrl (project dirs) "base" "/some/where" `shouldBe`
+ (project dirs) </>
"some/where"
--
- adjustLocalUrl projectDir "base" "some/where" `shouldBe`
+ adjustLocalUrl (project dirs) "base" "some/where" `shouldBe`
"base/some/where"
--
describe "makeRelativeTo" $
@@ -65,33 +64,92 @@ main = do
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")
+ 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 "resolve" $
+ it "Resolves a file path to a concrete verified file system path." $ do
+ resolve dirs ((project dirs) </> "resource/example") "img/06-metal.png" `shouldReturn`
+ Just
+ (Resource
+ ((project dirs) </> "resource/example/img/06-metal.png")
+ ((public dirs) </> "resource/example/img/06-metal.png")
+ "img/06-metal.png")
+ resolve dirs ((project dirs) </> "resource/example") "img/06-metal.png" `shouldReturn`
+ Just
+ (Resource
+ ((project dirs) </> "resource/example/img/06-metal.png")
+ ((public dirs) </> "resource/example/img/06-metal.png")
+ "img/06-metal.png")
+ --
+ describe "copyResource" $
+ it
+ "Copies an existing resource to the public dir and returns the public URL." $ do
+ doesFileExist ((project dirs) </> "resource/example/img/06-metal.png") `shouldReturn`
+ True
+ copyResource
+ (Resource
+ ((project dirs) </> "resource/example/img/06-metal.png")
+ ((public dirs) </> "resource/example/img/06-metal.png")
+ "img/06-metal.png") `shouldReturn`
+ "img/06-metal.png"
+ doesFileExist ((public dirs) </> "resource/example/img/06-metal.png") `shouldReturn`
+ True
+ --
+ describe "linkResource" $
+ it
+ "Copies an existing resource to the public dir and returns the public URL." $ do
+ doesFileExist ((project dirs) </> "resource/example/img/06-metal.png") `shouldReturn`
+ True
+ linkResource
+ (Resource
+ ((project dirs) </> "resource/example/img/06-metal.png")
+ ((public dirs) </> "resource/example/img/06-metal.png")
+ "img/06-metal.png") `shouldReturn`
+ "img/06-metal.png"
+ pathIsSymbolicLink
+ ((public dirs) </> "resource/example/img/06-metal.png") `shouldReturn`
+ True
+ --
+ describe "provisionResource" $
+ it "Resolves a file path to a verified file system path." $ do
+ provisionResource
+ SymbolicLink
+ dirs
+ ((project dirs) </> "resource/example")
+ "img/06-metal.png" `shouldReturn`
+ "img/06-metal.png"
+ doesFileExist ((public dirs) </> "resource/example/img/06-metal.png") `shouldReturn`
+ True
--
describe "cacheRemoteFile" $
it
"Stores the data behind a URL locally, if possible. Return the local path to the cached file." $ do
cacheRemoteFile
- cacheDir
+ (cache dirs)
"https://tramberend.beuth-hochschule.de/img/htr-beuth.jpg" `shouldReturn`
- cacheDir </>
+ (cache dirs) </>
"bc137c359488beadbb61589f7fe9e208.jpg"
cacheRemoteFile
- cacheDir
+ (cache dirs)
"ftp://tramberend.beuth-hochschule.de/img/htr-beuth.jpg" `shouldReturn`
"ftp://tramberend.beuth-hochschule.de/img/htr-beuth.jpg"
- cacheRemoteFile cacheDir "/img/htr-beuth.jpg" `shouldReturn`
+ cacheRemoteFile (cache dirs) "/img/htr-beuth.jpg" `shouldReturn`
"/img/htr-beuth.jpg"
- cacheRemoteFile cacheDir "img/htr-beuth.jpg" `shouldReturn`
+ cacheRemoteFile (cache dirs) "img/htr-beuth.jpg" `shouldReturn`
"img/htr-beuth.jpg"
--
describe "cacheRemoteImages" $
it
"Replaces all remote images in the pandoc document with locally caches copies." $
cacheRemoteImages
- cacheDir
+ (cache dirs)
(Pandoc
nullMeta
[ Para
@@ -108,13 +166,13 @@ main = do
[ Image
nullAttr
[]
- (cacheDir </> "bc137c359488beadbb61589f7fe9e208.jpg", "")
+ ((cache dirs) </> "bc137c359488beadbb61589f7fe9e208.jpg", "")
]
]
--
describe "parseStudentData" $
it "Parses student data in YAML format into a nifty data structure." $
- parseStudentData projectDir `shouldReturn` Just realData
+ parseStudentData (project dirs) `shouldReturn` Just realData
mockData :: Students
mockData =
--
GitLab