203 lines
7.8 KiB
Haskell
203 lines
7.8 KiB
Haskell
--------------------------------------------------------------------------------
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
module Hakyll.Core.Provider.Internal
|
|
( ResourceInfo (..)
|
|
, Provider (..)
|
|
, newProvider
|
|
|
|
, resourceList
|
|
, resourceExists
|
|
|
|
, resourceFilePath
|
|
, resourceString
|
|
, resourceLBS
|
|
|
|
, resourceModified
|
|
, resourceModificationTime
|
|
) where
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
import Control.Applicative ((<$>), (<*>))
|
|
import Control.DeepSeq (NFData (..), deepseq)
|
|
import Control.Monad (forM)
|
|
import Data.Binary (Binary (..))
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as M
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Monoid (mempty)
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as S
|
|
import Data.Time (Day (..), UTCTime (..),
|
|
secondsToDiffTime)
|
|
import Data.Typeable (Typeable)
|
|
import System.Directory (getModificationTime)
|
|
import System.FilePath (addExtension, (</>))
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
#if !MIN_VERSION_directory(1,2,0)
|
|
import Data.Time (readTime)
|
|
import System.Locale (defaultTimeLocale)
|
|
import System.Time (formatCalendarTime, toCalendarTime)
|
|
#endif
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
import Hakyll.Core.Identifier
|
|
import Hakyll.Core.Store (Store)
|
|
import qualified Hakyll.Core.Store as Store
|
|
import Hakyll.Core.Util.File
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Because UTCTime doesn't have a Binary instance...
|
|
newtype BinaryTime = BinaryTime {unBinaryTime :: UTCTime}
|
|
deriving (Eq, NFData, Ord, Show, Typeable)
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
instance Binary BinaryTime where
|
|
put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) =
|
|
put d >> put (floor dt :: Integer)
|
|
|
|
get = fmap BinaryTime $ UTCTime
|
|
<$> (ModifiedJulianDay <$> get)
|
|
<*> (secondsToDiffTime <$> get)
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
data ResourceInfo = ResourceInfo
|
|
{ resourceInfoModified :: BinaryTime
|
|
, resourceInfoMetadata :: Maybe Identifier
|
|
} deriving (Show, Typeable)
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
instance Binary ResourceInfo where
|
|
put (ResourceInfo mtime meta) = put mtime >> put meta
|
|
get = ResourceInfo <$> get <*> get
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
instance NFData ResourceInfo where
|
|
rnf (ResourceInfo mtime meta) = rnf mtime `seq` rnf meta `seq` ()
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Responsible for retrieving and listing resources
|
|
data Provider = Provider
|
|
{ -- Top of the provided directory
|
|
providerDirectory :: FilePath
|
|
, -- | A list of all files found
|
|
providerFiles :: Map Identifier ResourceInfo
|
|
, -- | A list of the files from the previous run
|
|
providerOldFiles :: Map Identifier ResourceInfo
|
|
, -- | Underlying persistent store for caching
|
|
providerStore :: Store
|
|
}
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Create a resource provider
|
|
newProvider :: Store -- ^ Store to use
|
|
-> (FilePath -> IO Bool) -- ^ Should we ignore this file?
|
|
-> FilePath -- ^ Search directory
|
|
-> IO Provider -- ^ Resulting provider
|
|
newProvider store ignore directory = do
|
|
list <- map fromFilePath <$> getRecursiveContents ignore directory
|
|
let universe = S.fromList list
|
|
files <- fmap (maxmtime . M.fromList) $ forM list $ \identifier -> do
|
|
rInfo <- getResourceInfo directory universe identifier
|
|
return (identifier, rInfo)
|
|
|
|
-- Get the old files from the store, and then immediately replace them by
|
|
-- the new files.
|
|
oldFiles <- fromMaybe mempty . Store.toMaybe <$> Store.get store oldKey
|
|
oldFiles `deepseq` Store.set store oldKey files
|
|
|
|
return $ Provider directory files oldFiles store
|
|
where
|
|
oldKey = ["Hakyll.Core.Provider.Internal.newProvider", "oldFiles"]
|
|
|
|
-- Update modified if metadata is modified
|
|
maxmtime files = flip M.map files $ \rInfo@(ResourceInfo mtime meta) ->
|
|
let metaMod = fmap resourceInfoModified $ meta >>= flip M.lookup files
|
|
in rInfo {resourceInfoModified = maybe mtime (max mtime) metaMod}
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
getResourceInfo :: FilePath -> Set Identifier -> Identifier -> IO ResourceInfo
|
|
getResourceInfo directory universe identifier = do
|
|
mtime <- fileModificationTime $ directory </> toFilePath identifier
|
|
return $ ResourceInfo (BinaryTime mtime) $
|
|
if mdRsc `S.member` universe then Just mdRsc else Nothing
|
|
where
|
|
mdRsc = fromFilePath $ flip addExtension "metadata" $ toFilePath identifier
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
resourceList :: Provider -> [Identifier]
|
|
resourceList = M.keys . providerFiles
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Check if a given resource exists
|
|
resourceExists :: Provider -> Identifier -> Bool
|
|
resourceExists provider =
|
|
(`M.member` providerFiles provider) . setVersion Nothing
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
resourceFilePath :: Provider -> Identifier -> FilePath
|
|
resourceFilePath p i = providerDirectory p </> toFilePath i
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Get the raw body of a resource as string
|
|
resourceString :: Provider -> Identifier -> IO String
|
|
resourceString p i = readFile $ resourceFilePath p i
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Get the raw body of a resource of a lazy bytestring
|
|
resourceLBS :: Provider -> Identifier -> IO BL.ByteString
|
|
resourceLBS p i = BL.readFile $ resourceFilePath p i
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | A resource is modified if it or its metadata has changed
|
|
resourceModified :: Provider -> Identifier -> Bool
|
|
resourceModified p r = case (ri, oldRi) of
|
|
(Nothing, _) -> False
|
|
(Just _, Nothing) -> True
|
|
(Just n, Just o) -> resourceInfoModified n > resourceInfoModified o
|
|
where
|
|
normal = setVersion Nothing r
|
|
ri = M.lookup normal (providerFiles p)
|
|
oldRi = M.lookup normal (providerOldFiles p)
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
resourceModificationTime :: Provider -> Identifier -> UTCTime
|
|
resourceModificationTime p i =
|
|
case M.lookup (setVersion Nothing i) (providerFiles p) of
|
|
Just ri -> unBinaryTime $ resourceInfoModified ri
|
|
Nothing -> error $
|
|
"Hakyll.Core.Provider.Internal.resourceModificationTime: " ++
|
|
"resource " ++ show i ++ " does not exist"
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
fileModificationTime :: FilePath -> IO UTCTime
|
|
fileModificationTime fp = do
|
|
#if MIN_VERSION_directory(1,2,0)
|
|
getModificationTime fp
|
|
#else
|
|
ct <- toCalendarTime =<< getModificationTime fp
|
|
let str = formatCalendarTime defaultTimeLocale "%s" ct
|
|
return $ readTime defaultTimeLocale "%s" str
|
|
#endif
|