Start provider rewrite

4 files changed, 137 insertions, 141 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
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)