diff options
Diffstat (limited to 'src/Hakyll/Core')
| -rw-r--r-- | src/Hakyll/Core/Compiler.hs | 2 | ||||
| -rw-r--r-- | src/Hakyll/Core/Configuration.hs | 2 | ||||
| -rw-r--r-- | src/Hakyll/Core/Provider.hs | 48 | ||||
| -rw-r--r-- | src/Hakyll/Core/Provider/Internal.hs | 157 | ||||
| -rw-r--r-- | src/Hakyll/Core/Provider/Metadata.hs | 7 | ||||
| -rw-r--r-- | src/Hakyll/Core/Provider/MetadataCache.hs | 1 | ||||
| -rw-r--r-- | src/Hakyll/Core/Provider/Modified.hs | 101 | ||||
| -rw-r--r-- | src/Hakyll/Core/Rules/Internal.hs | 20 | ||||
| -rw-r--r-- | src/Hakyll/Core/Runtime.hs | 7 | ||||
| -rw-r--r-- | src/Hakyll/Core/Store.hs | 8 | ||||
| -rw-r--r-- | src/Hakyll/Core/UnixFilter.hs | 2 | ||||
| -rw-r--r-- | src/Hakyll/Core/Util/File.hs | 11 |
12 files changed, 194 insertions, 172 deletions
diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index ae83fc4..b711719 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -136,7 +136,7 @@ cached name compiler = do id' <- compilerUnderlying <$> compilerAsk store <- compilerStore <$> compilerAsk provider <- compilerProvider <$> compilerAsk - modified <- compilerUnsafeIO $ resourceModified provider id' + let modified = resourceModified provider id' if modified then do x <- compiler diff --git a/src/Hakyll/Core/Configuration.hs b/src/Hakyll/Core/Configuration.hs index 47de700..fdca879 100644 --- a/src/Hakyll/Core/Configuration.hs +++ b/src/Hakyll/Core/Configuration.hs @@ -37,7 +37,7 @@ data Configuration = Configuration -- -- Note that the files in 'destinationDirectory' and 'storeDirectory' will -- also be ignored. Note that this is the configuration parameter, if you - -- want to use the test, you should use 'shouldIgnoreFile'. + -- want to use the test, you should use 'shouldIgnoreFile'. -- ignoreFile :: FilePath -> Bool , -- | Here, you can plug in a system command to upload/deploy your site. diff --git a/src/Hakyll/Core/Provider.hs b/src/Hakyll/Core/Provider.hs index 64b3786..00b694d 100644 --- a/src/Hakyll/Core/Provider.hs +++ b/src/Hakyll/Core/Provider.hs @@ -3,44 +3,40 @@ -- caching. module Hakyll.Core.Provider ( -- * Constructing resource providers - Provider + Internal.Provider , newProvider -- * Querying resource properties - , resourceList - , resourceExists - , resourceModified - , resourceModificationTime + , Internal.resourceList + , Internal.resourceExists + , Internal.resourceModified + , Internal.resourceModificationTime -- * Access to raw resource content - , resourceString - , resourceLBS + , Internal.resourceString + , Internal.resourceLBS -- * Access to metadata and body content - , resourceMetadata - , resourceBody + , Internal.resourceMetadata + , Internal.resourceBody ) where -------------------------------------------------------------------------------- -import Hakyll.Core.Identifier -import Hakyll.Core.Metadata -import Hakyll.Core.Provider.Internal +import qualified Hakyll.Core.Provider.Internal as Internal import qualified Hakyll.Core.Provider.MetadataCache as Internal -import Hakyll.Core.Provider.Modified +import Hakyll.Core.Store (Store) -------------------------------------------------------------------------------- --- | Wrapper to ensure metadata cache is invalidated if necessary -resourceMetadata :: Provider -> Identifier -> IO Metadata -resourceMetadata rp r = do - _ <- resourceModified rp r - Internal.resourceMetadata rp r - - --------------------------------------------------------------------------------- --- | Wrapper to ensure metadata cache is invalidated if necessary -resourceBody :: Provider -> Identifier -> IO String -resourceBody rp r = do - _ <- resourceModified rp r - Internal.resourceBody rp r +-- | Create a resource provider +newProvider :: Store -- ^ Store to use + -> (FilePath -> Bool) -- ^ Should we ignore this file? + -> FilePath -- ^ Search directory + -> IO Internal.Provider -- ^ Resulting provider +newProvider store ignore directory = do + -- Delete metadata cache where necessary + p <- Internal.newProvider store ignore directory + mapM_ (Internal.resourceInvalidateMetadataCache p) $ + filter (Internal.resourceModified p) $ Internal.resourceList p + return p diff --git a/src/Hakyll/Core/Provider/Internal.hs b/src/Hakyll/Core/Provider/Internal.hs index 1360ef5..5c3d07e 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,30 +108,47 @@ newProvider :: Store -- ^ Store to use -> FilePath -- ^ Search directory -> IO Provider -- ^ Resulting provider newProvider store ignore directory = do - list <- map fromFilePath . filter (not . ignore) <$> - getRecursiveContents 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 -------------------------------------------------------------------------------- @@ -92,3 +166,38 @@ 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 diff --git a/src/Hakyll/Core/Provider/Metadata.hs b/src/Hakyll/Core/Provider/Metadata.hs index 52c07cb..276483b 100644 --- a/src/Hakyll/Core/Provider/Metadata.hs +++ b/src/Hakyll/Core/Provider/Metadata.hs @@ -31,13 +31,14 @@ loadMetadata p identifier = do then second Just <$> loadMetadataHeader fp else return (M.empty, Nothing) - emd <- if resourceExists p mi then loadMetadataFile mfp else return M.empty + emd <- case mi of + Nothing -> return M.empty + Just mi' -> loadMetadataFile $ resourceFilePath p mi' return (M.union md emd, body) where fp = resourceFilePath p identifier - mi = resourceMetadataResource identifier - mfp = resourceFilePath p mi + mi = M.lookup identifier (providerFiles p) >>= resourceInfoMetadata -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Core/Provider/MetadataCache.hs b/src/Hakyll/Core/Provider/MetadataCache.hs index b813303..2c97baa 100644 --- a/src/Hakyll/Core/Provider/MetadataCache.hs +++ b/src/Hakyll/Core/Provider/MetadataCache.hs @@ -23,6 +23,7 @@ resourceMetadata :: Provider -> Identifier -> IO Metadata resourceMetadata p r | not (resourceExists p r) = return M.empty | otherwise = do + -- TODO keep time in md cache load p r Store.Found md <- Store.get (providerStore p) [name, toFilePath r, "metadata"] diff --git a/src/Hakyll/Core/Provider/Modified.hs b/src/Hakyll/Core/Provider/Modified.hs deleted file mode 100644 index 8fad96a..0000000 --- a/src/Hakyll/Core/Provider/Modified.hs +++ /dev/null @@ -1,101 +0,0 @@ --------------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} -module Hakyll.Core.Provider.Modified - ( resourceModified - , resourceModificationTime - ) where - - --------------------------------------------------------------------------------- -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (when) -import qualified Crypto.Hash.MD5 as MD5 -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.IORef -import qualified Data.Map as M -import Data.Time (UTCTime) -import System.Directory (getModificationTime) - - --------------------------------------------------------------------------------- -#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.Provider.Internal -import Hakyll.Core.Provider.MetadataCache -import Hakyll.Core.Store (Store) -import qualified Hakyll.Core.Store as Store - - --------------------------------------------------------------------------------- --- | A resource is modified if it or its metadata has changed -resourceModified :: Provider -> Identifier -> IO Bool -resourceModified p r - | not exists = return False - | otherwise = do - cache <- readIORef cacheRef - case M.lookup normalized cache of - Just m -> return m - Nothing -> do - -- Check if the actual file was modified, and do a recursive - -- call to check if the metadata file was modified - m <- (||) - <$> fileDigestModified store filePath - <*> resourceModified p (resourceMetadataResource r) - modifyIORef cacheRef (M.insert normalized m) - - -- Important! (But ugly) - when m $ resourceInvalidateMetadataCache p r - - return m - where - normalized = setVersion Nothing r - exists = resourceExists p r - store = providerStore p - cacheRef = providerModifiedCache p - filePath = resourceFilePath p r - - --------------------------------------------------------------------------------- --- | Utility: Check if a the digest of a file was modified -fileDigestModified :: Store -> FilePath -> IO Bool -fileDigestModified store fp = do - -- Get the latest seen digest from the store, and calculate the current - -- digest for the - lastDigest <- Store.get store key - newDigest <- fileDigest fp - if Store.Found newDigest == lastDigest - -- All is fine, not modified - then return False - -- Resource modified; store new digest - else do - Store.set store key newDigest - return True - where - key = ["Hakyll.Core.Resource.Provider.fileModified", fp] - - --------------------------------------------------------------------------------- --- | Utility: Retrieve a digest for a given file -fileDigest :: FilePath -> IO B.ByteString -fileDigest = fmap MD5.hashlazy . BL.readFile - - --------------------------------------------------------------------------------- -resourceModificationTime :: Provider -> Identifier -> IO UTCTime -resourceModificationTime p i = do -#if MIN_VERSION_directory(1,2,0) - getModificationTime $ resourceFilePath p i -#else - ct <- toCalendarTime =<< getModificationTime (resourceFilePath p i) - let str = formatCalendarTime defaultTimeLocale "%s" ct - return $ readTime defaultTimeLocale "%s" str -#endif diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs index 10ca919..09d9b1e 100644 --- a/src/Hakyll/Core/Rules/Internal.hs +++ b/src/Hakyll/Core/Rules/Internal.hs @@ -16,9 +16,9 @@ import Control.Applicative (Applicative, (<$>)) import Control.Monad.Reader (ask) import Control.Monad.RWS (RWST, runRWST) import Control.Monad.Trans (liftIO) -import qualified Data.Map as M import Data.Monoid (Monoid, mappend, mempty) import Data.Set (Set) +import qualified Data.Set as S -------------------------------------------------------------------------------- @@ -92,7 +92,12 @@ instance MonadMetadata Rules where runRules :: Rules a -> Provider -> IO RuleSet runRules rules provider = do (_, _, ruleSet) <- runRWST (unRules rules) env emptyRulesState - return $ nubCompilers ruleSet + case findDuplicate (map fst $ rulesCompilers ruleSet) of + Nothing -> return ruleSet + Just id' -> error $ + "Hakyll.Core.Rules.Internal: two different rules for " ++ + show id' ++ " exist, bailing out" + where env = RulesRead { rulesProvider = provider @@ -102,9 +107,10 @@ runRules rules provider = do -------------------------------------------------------------------------------- --- | Remove duplicate compilers from the 'RuleSet'. When two compilers match an --- item, we prefer the first one -nubCompilers :: RuleSet -> RuleSet -nubCompilers set = set {rulesCompilers = nubCompilers' (rulesCompilers set)} +findDuplicate :: Ord a => [a] -> Maybe a +findDuplicate = go S.empty where - nubCompilers' = M.toList . M.fromListWith (flip const) + go _ [] = Nothing + go s (x : xs) + | x `S.member` s = Just x + | otherwise = go (S.insert x s) xs diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs index f166b3c..9f27969 100644 --- a/src/Hakyll/Core/Runtime.hs +++ b/src/Hakyll/Core/Runtime.hs @@ -6,7 +6,7 @@ module Hakyll.Core.Runtime -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) -import Control.Monad (filterM, unless) +import Control.Monad (unless) import Control.Monad.Error (ErrorT, runErrorT, throwError) import Control.Monad.Reader (ask) import Control.Monad.RWS (RWST, runRWST) @@ -140,8 +140,9 @@ scheduleOutOfDate = do todo <- runtimeTodo <$> get let identifiers = M.keys universe - modified <- fmap S.fromList $ flip filterM identifiers $ - liftIO . resourceModified provider + modified = S.fromList $ flip filter identifiers $ + resourceModified provider + let (ood, facts', msgs) = outOfDate identifiers modified facts todo' = M.filterWithKey (\id' _ -> id' `S.member` ood) universe diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs index 63dd64c..e3bcce3 100644 --- a/src/Hakyll/Core/Store.hs +++ b/src/Hakyll/Core/Store.hs @@ -5,6 +5,7 @@ module Hakyll.Core.Store ( Store , Result (..) + , toMaybe , new , set , get @@ -54,6 +55,13 @@ data Result a -------------------------------------------------------------------------------- +-- | Convert result to 'Maybe' +toMaybe :: Result a -> Maybe a +toMaybe (Found x) = Just x +toMaybe _ = Nothing + + +-------------------------------------------------------------------------------- -- | Initialize the store new :: Bool -- ^ Use in-memory caching -> FilePath -- ^ Directory to use for hard disk storage diff --git a/src/Hakyll/Core/UnixFilter.hs b/src/Hakyll/Core/UnixFilter.hs index 2a2f394..261613d 100644 --- a/src/Hakyll/Core/UnixFilter.hs +++ b/src/Hakyll/Core/UnixFilter.hs @@ -57,7 +57,7 @@ unixFilter = unixFilterWith writer reader -- -- > match "music.wav" $ do -- > route $ setExtension "ogg" --- > compile $ getResourceLBS >>= withItemBody (unixFilter "oggenc" ["-"]) +-- > compile $ getResourceLBS >>= withItemBody (unixFilterLBS "oggenc" ["-"]) unixFilterLBS :: String -- ^ Program name -> [String] -- ^ Program args -> ByteString -- ^ Program input diff --git a/src/Hakyll/Core/Util/File.hs b/src/Hakyll/Core/Util/File.hs index 0e34d7c..20cfbbc 100644 --- a/src/Hakyll/Core/Util/File.hs +++ b/src/Hakyll/Core/Util/File.hs @@ -25,12 +25,13 @@ makeDirectories = createDirectoryIfMissing True . takeDirectory -------------------------------------------------------------------------------- -- | Get all contents of a directory. -getRecursiveContents :: FilePath -- ^ Directory to search - -> IO [FilePath] -- ^ List of files found -getRecursiveContents top = go "" +getRecursiveContents :: (FilePath -> Bool) -- ^ Ignore this file/directory + -> FilePath -- ^ Directory to search + -> IO [FilePath] -- ^ List of files found +getRecursiveContents ignore top = go "" where - isProper = (`notElem` [".", ".."]) - go dir = do + isProper x = notElem x [".", ".."] && not (ignore x) + go dir = do dirExists <- doesDirectoryExist (top </> dir) if not dirExists then return [] |