summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--hakyll.cabal1
-rw-r--r--src/Hakyll/Core/Compiler.hs2
-rw-r--r--src/Hakyll/Core/Provider.hs51
-rw-r--r--src/Hakyll/Core/Provider/Internal.hs155
-rw-r--r--src/Hakyll/Core/Provider/Metadata.hs7
-rw-r--r--src/Hakyll/Core/Provider/MetadataCache.hs1
-rw-r--r--src/Hakyll/Core/Provider/Modified.hs115
-rw-r--r--src/Hakyll/Core/Runtime.hs7
-rw-r--r--src/Hakyll/Web/Template/Context.hs3
-rw-r--r--tests/Hakyll/Core/Provider/Tests.hs1
-rw-r--r--tests/Hakyll/Core/Rules/Tests.hs1
-rw-r--r--tests/Hakyll/Core/Store/Tests.hs1
-rw-r--r--tests/Hakyll/Web/Template/Tests.hs2
13 files changed, 173 insertions, 174 deletions
diff --git a/hakyll.cabal b/hakyll.cabal
index 2d0a47d..c143929 100644
--- a/hakyll.cabal
+++ b/hakyll.cabal
@@ -151,7 +151,6 @@ Library
Hakyll.Core.Provider.Internal
Hakyll.Core.Provider.Metadata
Hakyll.Core.Provider.MetadataCache
- Hakyll.Core.Provider.Modified
Hakyll.Core.Rules.Internal
Hakyll.Core.Runtime
Hakyll.Core.Store
diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index dcaf2f0..b23b69b 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -131,7 +131,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/Provider.hs b/src/Hakyll/Core/Provider.hs
index 64b3786..4dd8288 100644
--- a/src/Hakyll/Core/Provider.hs
+++ b/src/Hakyll/Core/Provider.hs
@@ -3,44 +3,43 @@
-- 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 Control.Monad (forM_)
+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
+ provider <- Internal.newProvider store ignore directory
+ forM_ (Internal.resourceList provider) $ \identifier ->
+ if Internal.resourceModified provider identifier
+ then Internal.resourceInvalidateMetadataCache provider identifier
+ else return ()
+ return provider
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
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 4c3bdc5..0000000
--- a/src/Hakyll/Core/Provider/Modified.hs
+++ /dev/null
@@ -1,115 +0,0 @@
---------------------------------------------------------------------------------
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-module Hakyll.Core.Provider.Modified
- ( resourceModified
- , resourceModificationTime
- ) where
-
-
---------------------------------------------------------------------------------
-import Control.Applicative ((<$>), (<*>))
-import Control.Monad (when)
-import Data.Binary (Binary (..))
-import Data.IORef
-import qualified Data.Map as M
-import Data.Time (Day (..), UTCTime (..),
- secondsToDiffTime)
-import Data.Typeable (Typeable)
-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 <- (||)
- <$> fileModified 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 file was modified recently
-fileModified :: Store -> FilePath -> IO Bool
-fileModified store fp = do
- lastModified <- Store.get store key
- newModified <- BinaryTime <$> fileModificationTime fp
- if maybe False (>= newModified) (Store.toMaybe lastModified)
- -- All is fine, not modified
- then return False
- -- Resource modified; store new digest
- else do
- Store.set store key newModified
- return True
- where
- key = ["Hakyll.Core.Resource.Provider.fileModified", fp]
-
-
---------------------------------------------------------------------------------
-resourceModificationTime :: Provider -> Identifier -> IO UTCTime
-resourceModificationTime p i = fileModificationTime $ resourceFilePath p i
-
-
---------------------------------------------------------------------------------
-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
-
-
---------------------------------------------------------------------------------
--- | Because UTCTime doesn't have a Binary instance...
-newtype BinaryTime = BinaryTime UTCTime
- deriving (Eq, Ord, 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)
diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs
index b7dc4e8..150cc60 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/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs
index fcb527a..8aab989 100644
--- a/src/Hakyll/Web/Template/Context.hs
+++ b/src/Hakyll/Web/Template/Context.hs
@@ -207,8 +207,7 @@ modificationTimeFieldWith :: TimeLocale -- ^ Time output locale
-> Context a -- ^ Resulting context
modificationTimeFieldWith locale key fmt = field key $ \i -> do
provider <- compilerProvider <$> compilerAsk
- mtime <- compilerUnsafeIO $
- resourceModificationTime provider $ itemIdentifier i
+ let mtime = resourceModificationTime provider $ itemIdentifier i
return $ formatTime locale fmt mtime
diff --git a/tests/Hakyll/Core/Provider/Tests.hs b/tests/Hakyll/Core/Provider/Tests.hs
index 5fd9c0d..abe5c1d 100644
--- a/tests/Hakyll/Core/Provider/Tests.hs
+++ b/tests/Hakyll/Core/Provider/Tests.hs
@@ -37,3 +37,4 @@ case01 = do
doesntExist <- resourceMetadata provider "doesntexist.md"
M.empty @=? doesntExist
+ cleanTestEnv
diff --git a/tests/Hakyll/Core/Rules/Tests.hs b/tests/Hakyll/Core/Rules/Tests.hs
index d43772d..ee12010 100644
--- a/tests/Hakyll/Core/Rules/Tests.hs
+++ b/tests/Hakyll/Core/Rules/Tests.hs
@@ -51,6 +51,7 @@ rulesTest = do
Just "example.mv1" @=? runRoutes routes (sv "mv1" "example.md")
Just "example.mv2" @=? runRoutes routes (sv "mv2" "example.md")
readIORef ioref >>= assert
+ cleanTestEnv
where
sv g = setVersion (Just g)
expected =
diff --git a/tests/Hakyll/Core/Store/Tests.hs b/tests/Hakyll/Core/Store/Tests.hs
index 19b268b..95140e3 100644
--- a/tests/Hakyll/Core/Store/Tests.hs
+++ b/tests/Hakyll/Core/Store/Tests.hs
@@ -67,3 +67,4 @@ wrongType = do
e == typeOf (undefined :: Int) &&
t == typeOf (undefined :: String)
_ -> False
+ cleanTestEnv
diff --git a/tests/Hakyll/Web/Template/Tests.hs b/tests/Hakyll/Web/Template/Tests.hs
index 6fb5233..b96cfa5 100644
--- a/tests/Hakyll/Web/Template/Tests.hs
+++ b/tests/Hakyll/Web/Template/Tests.hs
@@ -44,6 +44,7 @@ case01 = do
pandocCompiler >>= applyTemplate (itemBody tpl) testContext
out @=? itemBody item
+ cleanTestEnv
--------------------------------------------------------------------------------
@@ -63,6 +64,7 @@ testApplyJoinTemplateList = do
applyJoinTemplateList ", " tpl defaultContext [i1, i2]
str @?= "<b>Hello</b>, <b>World</b>"
+ cleanTestEnv
where
i1 = Item "item1" "Hello"
i2 = Item "item2" "World"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-16 06:58:53 +0000