Start provider rewrite

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

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

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
+    , Internal.resourceList
-    , resourceExists
+    , Internal.resourceExists
-    , resourceModified
+    , Internal.resourceModified
-    , resourceModificationTime
+    , Internal.resourceModificationTime
 
       -- * Access to raw resource content
-    , resourceString
+    , Internal.resourceString
-    , resourceLBS
+    , Internal.resourceLBS
 
       -- * Access to metadata and body content
-    , resourceMetadata
+    , Internal.resourceMetadata
-    , resourceBody
+    , Internal.resourceBody
     ) where
 
 
 --------------------------------------------------------------------------------
-import           Hakyll.Core.Identifier
+import           Control.Monad                      (forM_)
-import           Hakyll.Core.Metadata
+import qualified Hakyll.Core.Provider.Internal      as Internal
-import           Hakyll.Core.Provider.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
+-- | Create a resource provider
-resourceMetadata :: Provider -> Identifier -> IO Metadata
+newProvider :: Store                 -- ^ Store to use
-resourceMetadata rp r = do
+            -> (FilePath -> Bool)    -- ^ Should we ignore this file?
-    _ <- resourceModified rp r
+            -> FilePath              -- ^ Search directory
-    Internal.resourceMetadata rp r
+            -> IO Internal.Provider  -- ^ Resulting provider
-
+newProvider store ignore directory = do
-
+    -- Delete metadata cache where necessary
---------------------------------------------------------------------------------
+    provider <- Internal.newProvider store ignore directory
--- | Wrapper to ensure metadata cache is invalidated if necessary
+    forM_ (Internal.resourceList provider) $ \identifier ->
-resourceBody :: Provider -> Identifier -> IO String
+        if Internal.resourceModified provider identifier
-resourceBody rp r = do
+            then Internal.resourceInvalidateMetadataCache provider identifier
-    _ <- resourceModified rp r
+            else return ()
-    Internal.resourceBody rp r
+    return provider

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
+      providerFiles     :: Map Identifier ResourceInfo
-    , -- | Cache keeping track of modified files
+    , -- | A list of the files from the previous run
-      providerModifiedCache :: IORef (Map Identifier Bool)
+      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
+    list <- map fromFilePath <$> getRecursiveContents ignore directory
-    cache <- newIORef M.empty
+    let universe = S.fromList list
-    return $ Provider directory (S.fromList list) cache store
+    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
+    (`M.member` providerFiles provider) . setVersion Nothing
-
-
---------------------------------------------------------------------------------
--- | Each resource may have an associated metadata resource (with a @.metadata@
--- filename)
-resourceMetadataResource :: Identifier -> Identifier
-resourceMetadataResource =
-    fromFilePath . flip addExtension "metadata" . toFilePath
 
 
 --------------------------------------------------------------------------------
@@ -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

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
+    mi  = M.lookup identifier (providerFiles p) >>= resourceInfoMetadata
-    mfp = resourceFilePath p mi
 
 
 --------------------------------------------------------------------------------

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"]

src/Hakyll/Core/Provider/Modified.hs

@@ -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)

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 $
+        modified    = S.fromList $ flip filter identifiers $
-        liftIO . resourceModified provider
+            resourceModified provider
+
     let (ood, facts', msgs) = outOfDate identifiers modified facts
         todo'               = M.filterWithKey
             (\id' _ -> id' `S.member` ood) universe

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 $
+    let mtime = resourceModificationTime provider $ itemIdentifier i
-        resourceModificationTime provider $ itemIdentifier i
     return $ formatTime locale fmt mtime
 
 

tests/Hakyll/Core/Provider/Tests.hs

@@ -37,3 +37,4 @@ case01 = do
 
     doesntExist <- resourceMetadata provider "doesntexist.md"
     M.empty @=? doesntExist
+    cleanTestEnv

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 =

tests/Hakyll/Core/Store/Tests.hs

@@ -67,3 +67,4 @@ wrongType = do
             e == typeOf (undefined :: Int) &&
             t == typeOf (undefined :: String)
         _                   -> False
+    cleanTestEnv

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"