diff options
Diffstat (limited to 'src/Hakyll/Core/Provider/Internal.hs')
| -rw-r--r-- | src/Hakyll/Core/Provider/Internal.hs | 155 |
1 files changed, 132 insertions, 23 deletions
diff --git a/src/Hakyll/Core/Provider/Internal.hs b/src/Hakyll/Core/Provider/Internal.hs index 301c25c..64b19c8 100644 --- a/src/Hakyll/Core/Provider/Internal.hs +++ b/src/Hakyll/Core/Provider/Internal.hs @@ -1,46 +1,103 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Provider.Internal - ( Provider (..) + ( ResourceInfo (..) + , Provider (..) , newProvider , resourceList , resourceExists - , resourceMetadataResource , resourceFilePath , resourceString , resourceLBS + + , resourceModified + , resourceModificationTime ) where -------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) +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.IORef 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 +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 + providerDirectory :: FilePath , -- | A list of all files found - providerSet :: Set Identifier - , -- | Cache keeping track of modified files - providerModifiedCache :: IORef (Map Identifier Bool) + providerFiles :: Map Identifier ResourceInfo + , -- | A list of the files from the previous run + providerOldFiles :: Map Identifier ResourceInfo , -- | Underlying persistent store for caching - providerStore :: Store + providerStore :: Store } @@ -51,29 +108,47 @@ newProvider :: Store -- ^ Store to use -> FilePath -- ^ Search directory -> IO Provider -- ^ Resulting provider newProvider store ignore directory = do - list <- map fromFilePath <$> getRecursiveContents ignore directory - cache <- newIORef M.empty - return $ Provider directory (S.fromList list) cache store + 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 = S.toList . providerSet +resourceList = M.keys . providerFiles -------------------------------------------------------------------------------- -- | Check if a given resource exists resourceExists :: Provider -> Identifier -> Bool resourceExists provider = - (`S.member` providerSet provider) . setVersion Nothing - - --------------------------------------------------------------------------------- --- | Each resource may have an associated metadata resource (with a @.metadata@ --- filename) -resourceMetadataResource :: Identifier -> Identifier -resourceMetadataResource = - fromFilePath . flip addExtension "metadata" . toFilePath + (`M.member` providerFiles provider) . setVersion Nothing -------------------------------------------------------------------------------- @@ -91,3 +166,37 @@ 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, _) -> True + (Just _, Nothing) -> True + (Just n, Just o) -> resourceInfoModified n > resourceInfoModified o + where + ri = M.lookup (setVersion Nothing r) (providerFiles p) + oldRi = ri >>= resourceInfoMetadata >>= flip M.lookup (providerFiles 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 |