Project.hs 8.82 KB
Newer Older
1
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
2
module Project
3
  ( findFile
Henrik Tramberend's avatar
Henrik Tramberend committed
4 5
  , readResource
  , provisionResource
6 7
  , copyResource
  , linkResource
8 9
  , relRefResource
  , absRefResource
10 11
  , removeCommonPrefix
  , isPrefix
12 13 14
  , makeRelativeTo
  , findProjectDirectory
  , projectDirectories
Henrik Tramberend's avatar
Henrik Tramberend committed
15 16
  , resolveLocally
  , provisioningFromMeta
17
  , provisioningFromClasses
18 19 20
  , Resource(..)
  , Provisioning(..)
  , ProjectDirs(..)
21 22
  ) where

23 24
import Common
import Control.Exception
Henrik Tramberend's avatar
Henrik Tramberend committed
25 26 27
import Control.Monad
import qualified Data.ByteString as B
import Data.List
28
import Data.Maybe
29
import Debug.Trace
Henrik Tramberend's avatar
Henrik Tramberend committed
30
import Embed
31
import Extra
32
import Network.URI
33
import qualified System.Directory as D
34
import System.FilePath
35
import System.Posix.Files
Henrik Tramberend's avatar
Henrik Tramberend committed
36 37
import Text.Pandoc.Definition
import Text.Pandoc.Shared
38 39

data Provisioning
40 41 42 43
  = Copy -- Copy to public and relative URL
  | SymLink -- Symbolic link to public and relative URL
  | Absolute -- Absolute local URL
  | Relative -- Relative local URL
Henrik Tramberend's avatar
Henrik Tramberend committed
44 45 46 47 48 49 50
  deriving (Eq, Show, Read)

provisioningFromMeta :: Meta -> Provisioning
provisioningFromMeta meta =
  case lookupMeta "provisioning" meta of
    Just (MetaString s) -> read s
    Just (MetaInlines i) -> read $ stringify i
51 52 53 54 55 56 57 58 59 60 61 62 63
    _ -> SymLink

provisioningClasses =
  [ ("copy", Copy)
  , ("symlink", SymLink)
  , ("absolute", Absolute)
  , ("relative", Relative)
  ]

provisioningFromClasses :: Provisioning -> [String] -> Provisioning
provisioningFromClasses defaultP cls =
  fromMaybe defaultP $
  listToMaybe $ map snd $ filter ((flip elem) cls . fst) provisioningClasses
64

65
data Resource = Resource
66 67 68
  { 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
69 70
  } deriving (Eq, Show)

71
copyResource :: Resource -> IO FilePath
72
copyResource resource
73
  -- TODO: Not working
74 75
  -- copyFileIfNewer (sourceFile resource) (publicFile resource)
 = do
76 77
  D.createDirectoryIfMissing True (takeDirectory (publicFile resource))
  D.copyFile (sourceFile resource) (publicFile resource)
78 79
  return (publicUrl resource)

80
linkResource :: Resource -> IO FilePath
81
linkResource resource = do
82 83 84
  whenM
    (D.doesFileExist (publicFile resource))
    (D.removeFile (publicFile resource))
85
  D.createDirectoryIfMissing True (takeDirectory (publicFile resource))
86 87 88
  createSymbolicLink (sourceFile resource) (publicFile resource)
  return (publicUrl resource)

89 90
absRefResource :: Resource -> IO FilePath
absRefResource resource = do
91 92
  return $ show $ URI "file" Nothing (sourceFile resource) "" ""

93 94 95 96 97
relRefResource :: FilePath -> Resource -> IO FilePath
relRefResource base resource = do
  let relPath = makeRelativeTo base (sourceFile resource)
  return $ show $ URI "file" Nothing relPath "" ""

98 99 100 101 102 103
data ProjectDirs = ProjectDirs
  { project :: FilePath
  , public :: FilePath
  , cache :: FilePath
  , support :: FilePath
  } deriving (Eq, Show)
104 105 106

-- Find the project directory.  
-- The project directory is the first upwards directory that contains a .git directory entry.
107 108
findProjectDirectory :: IO FilePath
findProjectDirectory = do
109
  cwd <- D.getCurrentDirectory
110 111 112 113 114
  searchGitRoot cwd
  where
    searchGitRoot :: FilePath -> IO FilePath
    searchGitRoot path =
      if isDrive path
115
        then D.makeAbsolute "."
116
        else do
117
          hasGit <- D.doesDirectoryExist (path </> ".git")
118
          if hasGit
119
            then D.makeAbsolute path
120 121
            else searchGitRoot $ takeDirectory path

122 123 124 125 126 127 128 129 130
-- 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)

131 132
-- Resolves a file path to a concrete verified file system path, or
-- returns Nothing if no file can be found.
Henrik Tramberend's avatar
Henrik Tramberend committed
133 134
resolveLocally :: FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
resolveLocally root base path = do
135 136
  absRoot <- D.makeAbsolute root
  absBase <- D.makeAbsolute base
137
  let candidates =
138
        if isAbsolute path
139 140 141
          then [absRoot </> makeRelative "/" path, path]
          else [absBase </> path, absRoot </> path]
  listToMaybe <$> filterM D.doesFileExist candidates
Henrik Tramberend's avatar
Henrik Tramberend committed
142 143 144

resourcePathes :: ProjectDirs -> FilePath -> FilePath -> Resource
resourcePathes dirs base absolute =
145 146 147 148 149
  Resource
  { sourceFile = absolute
  , publicFile = (public dirs) </> makeRelativeTo (project dirs) absolute
  , publicUrl = makeRelativeTo base absolute
  }
Henrik Tramberend's avatar
Henrik Tramberend committed
150

151 152 153 154 155
isLocalURI :: String -> Bool
isLocalURI url = isNothing $ parseURI url

isRemoteURI :: String -> Bool
isRemoteURI = not . isLocalURI
156 157

-- | Determines if a URL can be resolved to a local file. Absolute file URLs 
Henrik Tramberend's avatar
Henrik Tramberend committed
158
-- are resolved against and copied or linked to public from 
159 160
--    1. the project root 
--    2. the local filesystem root 
Henrik Tramberend's avatar
Henrik Tramberend committed
161
-- Relative file URLs are resolved against and copied or linked to public from 
162 163
--    1. the directory path of the referencing file 
--    2. the project root
164 165
-- Copy and link operations target the public directory in the project root
-- and recreate the source directory structure.
166
-- This function is used to provision resources that are used at presentation time.
167 168
provisionResource ::
     Provisioning -> ProjectDirs -> FilePath -> FilePath -> IO FilePath
169
provisionResource provisioning dirs base path = do
170 171 172 173 174 175 176 177 178
  if path == "" || isRemoteURI path
    then return path
    else do
      resource <- resourcePathes dirs base <$> findFile (project dirs) base path
      case provisioning of
        Copy -> copyResource resource
        SymLink -> linkResource resource
        Absolute -> absRefResource resource
        Relative -> relRefResource base resource
Henrik Tramberend's avatar
Henrik Tramberend committed
179

180
-- Finds local file system files that sre needed at compile time. 
181
-- Throws if the resource cannot be found. Used mainly for include files.
182 183
findFile :: FilePath -> FilePath -> FilePath -> IO FilePath
findFile root base path = do
Henrik Tramberend's avatar
Henrik Tramberend committed
184 185 186
  resolved <- resolveLocally root base path
  case resolved of
    Nothing ->
187 188
      throw $
      ResourceException $ "Cannot find local file system resource: " ++ path
Henrik Tramberend's avatar
Henrik Tramberend committed
189 190
    Just resource -> return resource

191 192 193 194 195 196 197 198 199
-- Finds local file system files that sre needed at compile time. 
-- Returns the original path if the resource cannot be found.
maybeFindFile :: FilePath -> FilePath -> FilePath -> IO FilePath
maybeFindFile root base path = do
  resolved <- resolveLocally root base path
  case resolved of
    Nothing -> return path
    Just resource -> return resource

200 201 202
-- 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`.
Henrik Tramberend's avatar
Henrik Tramberend committed
203 204
readResource :: FilePath -> FilePath -> FilePath -> IO B.ByteString
readResource root base path = do
205
  let searchPath = "template" </> path
Henrik Tramberend's avatar
Henrik Tramberend committed
206
  resolved <- resolveLocally root base path
207
  case resolved of
Henrik Tramberend's avatar
Henrik Tramberend committed
208 209 210 211
    Just resource -> B.readFile resource
    Nothing ->
      case find (\(k, b) -> k == path) deckerTemplateDir of
        Nothing ->
212
          throw $ ResourceException $ "Cannot find built-in resource: " ++ path
Henrik Tramberend's avatar
Henrik Tramberend committed
213
        Just entry -> return $ snd entry
214

215 216 217 218
-- | 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
219 220 221
  newer <- fileIsNewer src dst
  if newer
    then do
222 223
      D.createDirectoryIfMissing True (takeDirectory dst)
      D.copyFile src dst
224 225 226
    else return ()

fileIsNewer a b = do
227 228
  aexists <- D.doesFileExist a
  bexists <- D.doesFileExist b
229 230 231
  if bexists
    then if aexists
           then do
232 233
             at <- D.getModificationTime a
             bt <- D.getModificationTime b
234 235 236
             return ((traceShowId at) > (traceShowId bt))
           else return True
    else return False
237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259

-- | 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
260
    isPrefix_ :: Eq a => [a] -> [a] -> Bool
261 262 263 264 265 266 267
    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)