Add Item abstraction

4 files changed, 356 insertions, 0 deletions

diff --git a/src/Hakyll/Core/Provider/Internal.hs b/src/Hakyll/Core/Provider/Internal.hs
new file mode 100644
index 0000000..54332a9
--- /dev/null
+++ b/src/Hakyll/Core/Provider/Internal.hs
@@ -0,0 +1,86 @@
+--------------------------------------------------------------------------------
+module Hakyll.Core.Provider.Internal
+    ( Provider (..)
+    , newProvider
+
+    , resourceList
+    , resourceExists
+    , resourceMetadataResource
+
+    , resourceString
+    , resourceLBS
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Control.Applicative   ((<$>))
+import qualified Data.ByteString.Lazy  as BL
+import           Data.IORef
+import           Data.Map              (Map)
+import qualified Data.Map              as M
+import           Data.Set              (Set)
+import qualified Data.Set              as S
+import           System.FilePath       (addExtension)
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.Store
+import           Hakyll.Core.Util.File
+import           Hakyll.Core.Identifier
+
+
+--------------------------------------------------------------------------------
+-- | Responsible for retrieving and listing resources
+data Provider = Provider
+    { -- | A list of all files found
+      providerSet           :: Set Identifier
+    , -- | Cache keeping track of modified files
+      providerModifiedCache :: IORef (Map Identifier Bool)
+    , -- | Underlying persistent store for caching
+      providerStore         :: Store
+    }
+
+
+--------------------------------------------------------------------------------
+-- | Create a resource provider
+newProvider :: Store               -- ^ Store to use
+            -> (FilePath -> Bool)  -- ^ Should we ignore this file?
+            -> FilePath            -- ^ Search directory
+            -> IO Provider         -- ^ Resulting provider
+newProvider store ignore directory = do
+    list  <- map fromFilePath . filter (not . ignore) <$>
+        getRecursiveContents False directory
+    cache <- newIORef M.empty
+    return $ Provider (S.fromList list) cache store
+
+
+--------------------------------------------------------------------------------
+resourceList :: Provider -> [Identifier]
+resourceList = S.toList . providerSet
+
+
+--------------------------------------------------------------------------------
+-- | 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
+
+
+--------------------------------------------------------------------------------
+-- | Get the raw body of a resource as string
+resourceString :: Identifier -> IO String
+resourceString = readFile . toFilePath
+
+
+--------------------------------------------------------------------------------
+-- | Get the raw body of a resource of a lazy bytestring
+resourceLBS :: Identifier -> IO BL.ByteString
+resourceLBS = BL.readFile . toFilePath
diff --git a/src/Hakyll/Core/Provider/Metadata.hs b/src/Hakyll/Core/Provider/Metadata.hs
new file mode 100644
index 0000000..18536f4
--- /dev/null
+++ b/src/Hakyll/Core/Provider/Metadata.hs
@@ -0,0 +1,125 @@
+--------------------------------------------------------------------------------
+-- | Internal module to parse metadata
+module Hakyll.Core.Provider.Metadata
+    ( loadMetadata
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Control.Applicative
+import           Control.Arrow                 (second)
+import qualified Data.ByteString.Char8         as BC
+import qualified Data.Map                      as M
+import           System.IO                     as IO
+import           Text.Parsec                   ((<?>))
+import qualified Text.Parsec                   as P
+import           Text.Parsec.String            (Parser)
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.Identifier
+import           Hakyll.Core.Metadata
+import           Hakyll.Core.Provider.Internal
+import           Hakyll.Core.Util.String
+
+
+--------------------------------------------------------------------------------
+loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String)
+loadMetadata rp identifier = do
+    hasHeader  <- probablyHasMetadataHeader fp
+    (md, body) <- if hasHeader
+        then second Just <$> loadMetadataHeader fp
+        else return (M.empty, Nothing)
+
+    emd <- if resourceExists rp mi then loadMetadataFile mfp else return M.empty
+
+    return (M.union md emd, body)
+  where
+    fp  = toFilePath identifier
+    mi  = resourceMetadataResource identifier
+    mfp = toFilePath mi
+
+
+--------------------------------------------------------------------------------
+loadMetadataHeader :: FilePath -> IO (Metadata, String)
+loadMetadataHeader fp = do
+    contents <- readFile fp
+    case P.parse page fp contents of
+        Left err      -> error (show err)
+        Right (md, b) -> return (M.fromList md, b)
+
+
+--------------------------------------------------------------------------------
+loadMetadataFile :: FilePath -> IO Metadata
+loadMetadataFile fp = do
+    contents <- readFile fp
+    case P.parse metadata fp contents of
+        Left err  -> error (show err)
+        Right md  -> return $ M.fromList md
+
+
+--------------------------------------------------------------------------------
+-- | Check if a file "probably" has a metadata header. The main goal of this is
+-- to exclude binary files (which are unlikely to start with "---").
+probablyHasMetadataHeader :: FilePath -> IO Bool
+probablyHasMetadataHeader fp = do
+    handle <- IO.openFile fp IO.ReadMode
+    bs     <- BC.hGet handle 1024
+    IO.hClose handle
+    return $ isMetadataHeader bs
+  where
+    isMetadataHeader bs =
+        let pre = BC.takeWhile (\x -> x /= '\n' && x /= '\r') bs
+        in  BC.length pre >= 3 && BC.all (== '-') pre
+
+
+--------------------------------------------------------------------------------
+-- | Space or tab, no newline
+inlineSpace :: Parser Char
+inlineSpace = P.oneOf ['\t', ' '] <?> "space"
+
+
+--------------------------------------------------------------------------------
+-- | Parse Windows newlines as well (i.e. "\n" or "\r\n")
+newline :: Parser String
+newline = P.string "\n" <|> P.string "\r\n"
+
+
+--------------------------------------------------------------------------------
+-- | Parse a single metadata field
+metadataField :: Parser (String, String)
+metadataField = do
+    key <- P.manyTill P.alphaNum $ P.char ':'
+    P.skipMany1 inlineSpace <?> "space followed by metadata for: " ++ key
+    value     <- P.manyTill P.anyChar newline
+    trailing' <- P.many trailing
+    return (key, trim $ value ++ concat trailing')
+  where
+    trailing = (++) <$> P.many1 inlineSpace <*> P.manyTill P.anyChar newline
+
+
+--------------------------------------------------------------------------------
+-- | Parse a metadata block
+metadata :: Parser [(String, String)]
+metadata = P.many metadataField
+
+
+--------------------------------------------------------------------------------
+-- | Parse a metadata block, including delimiters and trailing newlines
+metadataBlock :: Parser [(String, String)]
+metadataBlock = do
+    open      <- P.many1 (P.char '-') <* P.many inlineSpace <* newline
+    metadata' <- metadata
+    _         <- P.choice $ map (P.string . replicate (length open)) ['-', '.']
+    P.skipMany inlineSpace
+    P.skipMany1 newline
+    return metadata'
+
+
+--------------------------------------------------------------------------------
+-- | Parse a page consisting of a metadata header and a body
+page :: Parser ([(String, String)], String)
+page = do
+    metadata' <- P.option [] metadataBlock
+    body      <- P.many P.anyChar
+    return (metadata', body)
diff --git a/src/Hakyll/Core/Provider/MetadataCache.hs b/src/Hakyll/Core/Provider/MetadataCache.hs
new file mode 100644
index 0000000..cd67370
--- /dev/null
+++ b/src/Hakyll/Core/Provider/MetadataCache.hs
@@ -0,0 +1,62 @@
+--------------------------------------------------------------------------------
+module Hakyll.Core.Provider.MetadataCache
+    ( resourceMetadata
+    , resourceBody
+    , resourceInvalidateMetadataCache
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.Identifier
+import           Hakyll.Core.Metadata
+import           Hakyll.Core.Provider.Internal
+import           Hakyll.Core.Provider.Metadata
+import qualified Hakyll.Core.Store             as Store
+
+
+--------------------------------------------------------------------------------
+resourceMetadata :: Provider -> Identifier -> IO Metadata
+resourceMetadata p r = do
+    load p r
+    Store.Found md <- Store.get (providerStore p)
+        [name, toFilePath r, "metadata"]
+    return md
+
+
+--------------------------------------------------------------------------------
+resourceBody :: Provider -> Identifier -> IO String
+resourceBody p r = do
+    load p r
+    Store.Found bd <- Store.get (providerStore p)
+        [name, toFilePath r, "body"]
+    maybe (resourceString r) return bd
+
+
+--------------------------------------------------------------------------------
+resourceInvalidateMetadataCache :: Provider -> Identifier -> IO ()
+resourceInvalidateMetadataCache p r = do
+    Store.delete (providerStore p) [name, toFilePath r, "metadata"]
+    Store.delete (providerStore p) [name, toFilePath r, "body"]
+
+
+--------------------------------------------------------------------------------
+load :: Provider -> Identifier -> IO ()
+load p r = do
+    mmd <- Store.get store mdk :: IO (Store.Result Metadata)
+    case mmd of
+        -- Already loaded
+        Store.Found _  -> return ()
+        -- Not yet loaded
+        _ -> do
+            (metadata, body) <- loadMetadata p r
+            Store.set store mdk metadata
+            Store.set store bk  body
+  where
+    store = providerStore p
+    mdk   = [name, toFilePath r, "metadata"]
+    bk    = [name, toFilePath r, "body"]
+
+
+--------------------------------------------------------------------------------
+name :: String
+name = "Hakyll.Core.Resource.Provider.MetadataCache"
diff --git a/src/Hakyll/Core/Provider/Modified.hs b/src/Hakyll/Core/Provider/Modified.hs
new file mode 100644
index 0000000..166019d
--- /dev/null
+++ b/src/Hakyll/Core/Provider/Modified.hs
@@ -0,0 +1,83 @@
+--------------------------------------------------------------------------------
+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)
+
+
+--------------------------------------------------------------------------------
+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 rp 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 (toFilePath r)
+                    <*> resourceModified rp (resourceMetadataResource r)
+                modifyIORef cacheRef (M.insert normalized m)
+
+                -- Important! (But ugly)
+                when m $ resourceInvalidateMetadataCache rp r
+
+                return m
+  where
+    normalized = setVersion Nothing r
+    exists     = resourceExists rp r
+    store      = providerStore rp
+    cacheRef   = providerModifiedCache rp
+
+
+--------------------------------------------------------------------------------
+-- | 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 :: Identifier -> IO UTCTime
+resourceModificationTime = getModificationTime . toFilePath