project.hs 7.47 KB
Newer Older
Henrik Tramberend's avatar
Henrik Tramberend committed
1 2
{-- Author: Henrik Tramberend <henrik@tramberend.de> --} 

3
module Project
Henrik Tramberend's avatar
Henrik Tramberend committed
4 5 6
  ( findResource
  , readResource
  , provisionResource
7 8 9
  , copyResource
  , linkResource
  , refResource
10 11
  , removeCommonPrefix
  , isPrefix
12 13 14
  , makeRelativeTo
  , findProjectDirectory
  , projectDirectories
Henrik Tramberend's avatar
Henrik Tramberend committed
15 16
  , resolveLocally
  , provisioningFromMeta
17 18 19
  , Resource(..)
  , Provisioning(..)
  , ProjectDirs(..)
20 21
  ) where

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

data Provisioning
  = Copy -- Copy to public and relative link
  | SymbolicLink -- Link to public and relative link
  | Reference -- Absolute local link
Henrik Tramberend's avatar
Henrik Tramberend committed
44 45 46 47 48 49 50 51
  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
    _ -> Copy
52

53
data Resource = Resource
54 55 56
  { 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
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82
  } 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)
83 84 85

-- Find the project directory.  
-- The project directory is the first upwards directory that contains a .git directory entry.
86 87
findProjectDirectory :: IO FilePath
findProjectDirectory = do
88 89 90 91 92 93 94 95 96 97 98 99 100
  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

101 102 103 104 105 106 107 108 109
-- 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)

110 111
-- 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
112 113
resolveLocally :: FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
resolveLocally root base path = do
114
  let candidates =
115
        if isAbsolute path
Henrik Tramberend's avatar
Henrik Tramberend committed
116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
          then [root </> makeRelative "/" path, path]
          else [base </> path, root </> path]
  listToMaybe <$> filterM 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
     }

-- resolveUrl :: ProjectDirs -> FilePath -> FilePath -> IO (Maybe Resource)
-- resolveUrl dirs base url = do
--   case parseURI url >>= fileOrRelativeUrl of
--     Nothing -> return Nothing
--     Just path -> resourcePathes dirs base <$> resolve dirs base path
134 135 136 137 138 139
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 
Henrik Tramberend's avatar
Henrik Tramberend committed
140
-- are resolved against and copied or linked to public from 
141 142
--    1. the project root 
--    2. the local filesystem root 
Henrik Tramberend's avatar
Henrik Tramberend committed
143
-- Relative file URLs are resolved against and copied or linked to public from 
144 145
--    1. the directory path of the referencing file 
--    2. the project root
146 147 148
-- Copy and link operations target the public directory in the project root
-- and recreate the source directory structure.
provisionResource ::
149 150
     Provisioning -> ProjectDirs -> FilePath -> FilePath -> IO FilePath
provisionResource provisioning dirs base path = do
Henrik Tramberend's avatar
Henrik Tramberend committed
151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
  resource <- resourcePathes dirs base <$> findResource (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
  resolved <- resolveLocally root base path
  case resolved of
    Nothing ->
      throw $ ResourceException $ "Cannot find local resource: " ++ path
    Just resource -> return resource

readResource :: FilePath -> FilePath -> FilePath -> IO B.ByteString
readResource root base path = do
  resolved <- resolveLocally root base path
168
  case resolved of
Henrik Tramberend's avatar
Henrik Tramberend committed
169 170 171 172 173 174
    Just resource -> B.readFile resource
    Nothing ->
      case find (\(k, b) -> k == path) deckerTemplateDir of
        Nothing ->
          throw $ ResourceException $ "Cannot read local resource: " ++ path
        Just entry -> return $ snd entry
175

176 177 178 179
-- | 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
180 181 182 183 184 185 186 187
  newer <- fileIsNewer src dst
  if newer
    then do
      createDirectoryIfMissing True (takeDirectory dst)
      copyFile src dst
    else return ()

fileIsNewer a b = do
188 189 190 191 192 193 194 195 196 197
  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
198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228

-- | 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)