diff options
Diffstat (limited to 'src/Hakyll/Core/Provider/Internal.hs')
| -rw-r--r-- | src/Hakyll/Core/Provider/Internal.hs | 202 |
1 files changed, 0 insertions, 202 deletions
diff --git a/src/Hakyll/Core/Provider/Internal.hs b/src/Hakyll/Core/Provider/Internal.hs deleted file mode 100644 index c298653..0000000 --- a/src/Hakyll/Core/Provider/Internal.hs +++ /dev/null @@ -1,202 +0,0 @@ --------------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Hakyll.Core.Provider.Internal - ( ResourceInfo (..) - , Provider (..) - , newProvider - - , resourceList - , resourceExists - - , resourceFilePath - , resourceString - , resourceLBS - - , resourceModified - , resourceModificationTime - ) where - - --------------------------------------------------------------------------------- -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.Set (Set) -import qualified Data.Set as S -import Data.Time (Day (..), UTCTime (..)) -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 (toRational dt) - - get = fmap BinaryTime $ UTCTime - <$> (ModifiedJulianDay <$> get) - <*> (fromRational <$> 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 - } deriving (Show) - - --------------------------------------------------------------------------------- --- | 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 || - resourceInfoMetadata n /= resourceInfoMetadata 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 |