Commit 92314851 authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

More tests for project related functions

parent 217d1acb
name: decker
version: 1.0.0.0
version: 0.3.0
synopsis: All inclusive slide deck creation with pandoc.
description: Please see README.md
homepage: https://tramberend.beuth-hochschule.de/decker
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Project
( findResource
( findFile
, readResource
, provisionResource
, copyResource
......@@ -31,16 +30,16 @@ import Debug.Trace
import Embed
import Extra
import Network.URI
import System.Directory
import qualified System.Directory as D
import System.FilePath
import System.Posix.Files
import Text.Pandoc.Definition
import Text.Pandoc.Shared
data Provisioning
= Copy -- Copy to public and relative link
| SymbolicLink -- Link to public and relative link
| Reference -- Absolute local link
= Copy -- Copy to public and relative path
| SymbolicLink -- Symbolic link to public and relative path
| Reference -- Absolute local path
deriving (Eq, Show, Read)
provisioningFromMeta :: Meta -> Provisioning
......@@ -48,7 +47,7 @@ provisioningFromMeta meta =
case lookupMeta "provisioning" meta of
Just (MetaString s) -> read s
Just (MetaInlines i) -> read $ stringify i
_ -> Copy
otherwise -> Copy
data Resource = Resource
{ sourceFile :: FilePath -- Absolute Path to source file
......@@ -56,21 +55,22 @@ data Resource = Resource
, publicUrl :: FilePath -- Relative URL to served file from base
} deriving (Eq, Show)
copyResource :: Resource -> IO (FilePath)
copyResource :: Resource -> IO FilePath
copyResource resource
-- TODO: Not working
-- copyFileIfNewer (sourceFile resource) (publicFile resource)
= do
createDirectoryIfMissing True (takeDirectory (publicFile resource))
copyFile (sourceFile resource) (publicFile resource)
D.createDirectoryIfMissing True (takeDirectory (publicFile resource))
D.copyFile (sourceFile resource) (publicFile resource)
return (publicUrl resource)
linkResource :: Resource -> IO (FilePath)
linkResource :: Resource -> IO FilePath
linkResource resource = do
whenM (doesFileExist (publicFile resource)) (removeFile (publicFile resource))
whenM (D.doesFileExist (publicFile resource)) (D.removeFile (publicFile resource))
createSymbolicLink (sourceFile resource) (publicFile resource)
return (publicUrl resource)
refResource :: Resource -> IO (FilePath)
refResource :: Resource -> IO FilePath
refResource resource = do
return $ show $ URI "file" Nothing (sourceFile resource) "" ""
......@@ -85,17 +85,17 @@ data ProjectDirs = ProjectDirs
-- The project directory is the first upwards directory that contains a .git directory entry.
findProjectDirectory :: IO FilePath
findProjectDirectory = do
cwd <- getCurrentDirectory
cwd <- D.getCurrentDirectory
searchGitRoot cwd
where
searchGitRoot :: FilePath -> IO FilePath
searchGitRoot path =
if isDrive path
then makeAbsolute "."
then D.makeAbsolute "."
else do
hasGit <- doesDirectoryExist (path </> ".git")
hasGit <- D.doesDirectoryExist (path </> ".git")
if hasGit
then makeAbsolute path
then D.makeAbsolute path
else searchGitRoot $ takeDirectory path
-- Calculate important absolute project directory pathes
......@@ -111,20 +111,21 @@ projectDirectories = do
-- returns Nothing if no file can be found.
resolveLocally :: FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
resolveLocally root base path = do
absRoot <- D.makeAbsolute root
absBase <- D.makeAbsolute base
let candidates =
if isAbsolute path
then [root </> makeRelative "/" path, path]
else [base </> path, root </> path]
listToMaybe <$> filterM doesFileExist candidates
then [absRoot </> makeRelative "/" path, path]
else [absBase </> path, absRoot </> path]
listToMaybe <$> filterM D.doesFileExist candidates
resourcePathes :: ProjectDirs -> FilePath -> FilePath -> Resource
resourcePathes dirs base absolute =
let relative = makeRelativeTo (project dirs) absolute
in Resource
{ sourceFile = absolute
, publicFile = (public dirs) </> makeRelativeTo (project dirs) absolute
, publicUrl = makeRelativeTo base absolute
}
Resource
{ sourceFile = absolute
, publicFile = (public dirs) </> makeRelativeTo (project dirs) absolute
, publicUrl = makeRelativeTo base absolute
}
-- resolveUrl :: ProjectDirs -> FilePath -> FilePath -> IO (Maybe Resource)
-- resolveUrl dirs base url = do
......@@ -145,32 +146,39 @@ fileOrRelativeUrl _ = Nothing
-- 2. the project root
-- Copy and link operations target the public directory in the project root
-- and recreate the source directory structure.
-- This function is used to provision resources that are used at presentation time.
provisionResource ::
Provisioning -> ProjectDirs -> FilePath -> FilePath -> IO FilePath
provisionResource provisioning dirs base path = do
resource <- resourcePathes dirs base <$> findResource (project dirs) base path
resource <- resourcePathes dirs base <$> findFile (project dirs) base path
case provisioning of
Copy -> copyResource resource
SymbolicLink -> linkResource resource
Reference -> refResource resource
findResource :: FilePath -> FilePath -> FilePath -> IO FilePath
findResource root base path = do
-- Finds local file system files that sre needed at compile time.
-- Throws if the resource cannot be found. Use mainly for include files.
findFile :: FilePath -> FilePath -> FilePath -> IO FilePath
findFile root base path = do
resolved <- resolveLocally root base path
case resolved of
Nothing ->
throw $ ResourceException $ "Cannot find local resource: " ++ path
throw $ ResourceException $ "Cannot find local file system resource: " ++ path
Just resource -> return resource
-- Finds and reads a resource at compile time. If the resource can not be found in the
-- file system, the built-in resource map is searched. If that fails, an error os thrown.
-- The resource is searched for in a directory name `template`.
readResource :: FilePath -> FilePath -> FilePath -> IO B.ByteString
readResource root base path = do
let searchPath = "template" </> path
resolved <- resolveLocally root base path
case resolved of
Just resource -> B.readFile resource
Nothing ->
case find (\(k, b) -> k == path) deckerTemplateDir of
Nothing ->
throw $ ResourceException $ "Cannot read local resource: " ++ path
throw $ ResourceException $ "Cannot find built-in resource: " ++ path
Just entry -> return $ snd entry
-- | Copies the src to dst if src is newer or dst does not exist.
......@@ -180,18 +188,18 @@ copyFileIfNewer src dst = do
newer <- fileIsNewer src dst
if newer
then do
createDirectoryIfMissing True (takeDirectory dst)
copyFile src dst
D.createDirectoryIfMissing True (takeDirectory dst)
D.copyFile src dst
else return ()
fileIsNewer a b = do
aexists <- doesFileExist a
bexists <- doesFileExist b
aexists <- D.doesFileExist a
bexists <- D.doesFileExist b
if bexists
then if aexists
then do
at <- getModificationTime a
bt <- getModificationTime b
at <- D.getModificationTime a
bt <- D.getModificationTime b
return ((traceShowId at) > (traceShowId bt))
else return True
else return False
......
......@@ -76,7 +76,7 @@ import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Network.URI
import Project
import System.Directory as Dir
import qualified System.Directory as Dir
import System.FilePath as SF
import System.FilePath.Glob
import System.IO as S
......@@ -94,17 +94,17 @@ import Watch
-- The project directory is the first upwards directory that contains a .git directory entry.
calcProjectDirectory :: IO FilePath
calcProjectDirectory = do
cwd <- getCurrentDirectory
cwd <- Dir.getCurrentDirectory
searchGitRoot cwd
where
searchGitRoot :: FilePath -> IO FilePath
searchGitRoot path =
if isDrive path
then makeAbsolute "."
then Dir.makeAbsolute "."
else do
hasGit <- Dir.doesDirectoryExist (path </> ".git")
if hasGit
then makeAbsolute path
then Dir.makeAbsolute path
else searchGitRoot $ takeDirectory path
-- | Globs for files under the project dir in the Action monad.
......@@ -161,7 +161,7 @@ stopServer id =
Left (SomeException e) -> print $ "Unable to read file " ++ pidFile
Right pid -> do
exitCode <- system ("kill -9 " ++ pid)
removeFile pidFile
Dir.removeFile pidFile
terminate :: ProcessHandle -> Action ()
terminate = liftIO . terminateProcess
......@@ -595,7 +595,7 @@ processIncludes rootDir baseDir (Pandoc meta blocks) = do
return $ concat $ reverse spliced
include :: FilePath -> [[Block]] -> Block -> Action [[Block]]
include base result (Para [Link _ [Str "#include"] (url, _)]) = do
filePath <- liftIO $ findResource rootDir base url
filePath <- liftIO $ findFile rootDir base url
Pandoc _ b <- readMetaMarkdown filePath
included <- processBlocks (takeDirectory filePath) b
return $ included : result
......@@ -618,7 +618,7 @@ cacheRemoteFile cacheDir url
then return cacheFile
else catch
(do content <- downloadUrl url
createDirectoryIfMissing True cacheDir
Dir.createDirectoryIfMissing True cacheDir
LB.writeFile cacheFile content
return cacheFile)
(\e -> do
......@@ -631,7 +631,7 @@ clearCachedFile cacheDir url
| isCacheableURI url = do
let cacheFile = cacheDir </> hashURI url
exists <- Dir.doesFileExist cacheFile
when exists $ removeFile cacheFile
when exists $ Dir.removeFile cacheFile
clearCachedFile _ _ = return ()
downloadUrl :: String -> IO LB.ByteString
......@@ -722,7 +722,7 @@ copyAndLinkFile project public base url = do
then return url
else do
let pub = public </> rel
liftIO $ createDirectoryIfMissing True (takeDirectory pub)
liftIO $ Dir.createDirectoryIfMissing True (takeDirectory pub)
copyFileChanged url pub
return $ makeRelativeTo base pub
......@@ -744,7 +744,7 @@ writeExampleProject = mapM_ writeOne deckerExampleDir
writeOne (path, contents) = do
exists <- Development.Shake.doesFileExist path
unless exists $ do
liftIO $ createDirectoryIfMissing True (takeDirectory path)
liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
liftIO $ B.writeFile path contents
putNormal $ "# create (for " ++ path ++ ")"
......
......@@ -11,7 +11,7 @@ import Data.Text.Encoding
import qualified Data.Yaml as Y
import Project as P
import Project
import System.Directory
import qualified System.Directory as Dir
import System.FilePath
import System.FilePath.Glob
import System.FilePath.Posix
......@@ -21,6 +21,8 @@ import Utilities
main = do
dirs <- projectDirectories
--
deckTemplate <- B.readFile ((project dirs) </> "resource/template/deck.html")
--
metaFiles <- globDir1 (compile "**/*-meta.yaml") (project dirs)
print metaFiles
--
......@@ -91,7 +93,7 @@ main = do
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`
Dir.doesFileExist ((project dirs) </> "resource/example/img/06-metal.png") `shouldReturn`
True
copyResource
(Resource
......@@ -99,13 +101,13 @@ main = do
((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`
Dir.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`
"Links an existing resource to the public dir and returns the public URL." $ do
Dir.doesFileExist ((project dirs) </> "resource/example/img/06-metal.png") `shouldReturn`
True
linkResource
(Resource
......@@ -113,20 +115,62 @@ main = do
((public dirs) </> "resource/example/img/06-metal.png")
"img/06-metal.png") `shouldReturn`
"img/06-metal.png"
pathIsSymbolicLink
Dir.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
describe "provisionResource" $ do
it "Copies a presentation time resource into the public dir." $ do
provisionResource
Copy
dirs
((project dirs) </> "resource/example")
"img/06-metal.png" `shouldReturn`
"img/06-metal.png"
Dir.doesFileExist ((public dirs) </> "resource/example/img/06-metal.png") `shouldReturn`
True
it "Links a presentation time resource into the public dir." $ 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`
Dir.doesFileExist ((public dirs) </> "resource/example/img/06-metal.png") `shouldReturn`
True
Dir.pathIsSymbolicLink
((public dirs) </> "resource/example/img/06-metal.png") `shouldReturn`
True
it "Throws, if the resource can not be found." $ do
provisionResource
Copy
dirs
((project dirs) </> "resource/example")
"img/does-not-exist.png" `shouldThrow`
anyException
--
describe "findFile" $ do
it "Finds local file system resources that sre needed at compile time." $ do
findFile (project dirs) (project dirs) "resource/template/deck.html" `shouldReturn`
(project dirs) </>
"resource/template/deck.html"
it "Throws, if the resource can not be found." $ do
findFile (project dirs) (project dirs) "deck.html" `shouldThrow`
anyException
--
describe "readResource" $ do
it
"Finds local file system or built-in resources that sre needed at compile time." $ do
readResource
(project dirs)
((project dirs) </> "resource/template")
"deck.html" `shouldReturn`
deckTemplate
readResource (project dirs) (project dirs) "deck.html" `shouldReturn`
deckTemplate
it "Throws, if the resource can not be read." $ do
readResource (project dirs) (project dirs) "dreck.html" `shouldThrow`
anyException
--
describe "cacheRemoteFile" $
it
......
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