diff options
Diffstat (limited to 'lib/Hakyll/Core/Provider/Internal.hs')
| -rw-r--r-- | lib/Hakyll/Core/Provider/Internal.hs | 202 |
1 files changed, 202 insertions, 0 deletions
diff --git a/lib/Hakyll/Core/Provider/Internal.hs b/lib/Hakyll/Core/Provider/Internal.hs new file mode 100644 index 0000000..c298653 --- /dev/null +++ b/lib/Hakyll/Core/Provider/Internal.hs @@ -0,0 +1,202 @@ +-------------------------------------------------------------------------------- +{-# 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 |