diff options
Diffstat (limited to 'src/Hakyll/Core/ResourceProvider')
| -rw-r--r-- | src/Hakyll/Core/ResourceProvider/Internal.hs | 86 | ||||
| -rw-r--r-- | src/Hakyll/Core/ResourceProvider/Metadata.hs | 119 | ||||
| -rw-r--r-- | src/Hakyll/Core/ResourceProvider/MetadataCache.hs | 62 | ||||
| -rw-r--r-- | src/Hakyll/Core/ResourceProvider/Modified.hs | 83 |
4 files changed, 350 insertions, 0 deletions
diff --git a/src/Hakyll/Core/ResourceProvider/Internal.hs b/src/Hakyll/Core/ResourceProvider/Internal.hs new file mode 100644 index 0000000..1f8f776 --- /dev/null +++ b/src/Hakyll/Core/ResourceProvider/Internal.hs @@ -0,0 +1,86 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.ResourceProvider.Internal + ( ResourceProvider (..) + , newResourceProvider + + , 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 ResourceProvider = ResourceProvider + { -- | A list of all files found + resourceSet :: Set (Identifier ()) + , -- | Cache keeping track of modified files + resourceModifiedCache :: IORef (Map (Identifier ()) Bool) + , -- | Underlying persistent store for caching + resourceStore :: Store + } + + +-------------------------------------------------------------------------------- +-- | Create a resource provider +newResourceProvider :: Store -- ^ Store to use + -> (FilePath -> Bool) -- ^ Should we ignore this file? + -> FilePath -- ^ Search directory + -> IO ResourceProvider -- ^ Resulting provider +newResourceProvider store ignore directory = do + list <- map parseIdentifier . filter (not . ignore) <$> + getRecursiveContents False directory + cache <- newIORef M.empty + return $ ResourceProvider (S.fromList list) cache store + + +-------------------------------------------------------------------------------- +resourceList :: ResourceProvider -> [Identifier ()] +resourceList = S.toList . resourceSet + + +-------------------------------------------------------------------------------- +-- | Check if a given resiyrce exists +resourceExists :: ResourceProvider -> Identifier a -> Bool +resourceExists provider = + (`S.member` resourceSet provider) . setGroup Nothing . castIdentifier + + +-------------------------------------------------------------------------------- +-- | Each resource may have an associated metadata resource (with a @.metadata@ +-- filename) +resourceMetadataResource :: Identifier a -> Identifier () +resourceMetadataResource = + parseIdentifier . flip addExtension "metadata" . toFilePath + + +-------------------------------------------------------------------------------- +-- | Get the raw body of a resource as string +resourceString :: Identifier a -> IO String +resourceString = readFile . toFilePath + + +-------------------------------------------------------------------------------- +-- | Get the raw body of a resource of a lazy bytestring +resourceLBS :: Identifier a -> IO BL.ByteString +resourceLBS = BL.readFile . toFilePath diff --git a/src/Hakyll/Core/ResourceProvider/Metadata.hs b/src/Hakyll/Core/ResourceProvider/Metadata.hs new file mode 100644 index 0000000..e297f2c --- /dev/null +++ b/src/Hakyll/Core/ResourceProvider/Metadata.hs @@ -0,0 +1,119 @@ +-------------------------------------------------------------------------------- +-- | Internal module to parse metadata +module Hakyll.Core.ResourceProvider.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.ResourceProvider.Internal +import Hakyll.Core.Util.String + + +-------------------------------------------------------------------------------- +loadMetadata :: ResourceProvider -> Identifier a -> 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 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 P.newline + trailing' <- P.many trailing + return (key, trim $ value ++ concat trailing') + where + trailing = (++) <$> P.many1 inlineSpace <*> P.manyTill P.anyChar P.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 <* P.newline + metadata' <- metadata + _ <- P.choice $ map (P.string . replicate (length open)) ['-', '.'] + P.skipMany inlineSpace + P.skipMany1 P.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/ResourceProvider/MetadataCache.hs b/src/Hakyll/Core/ResourceProvider/MetadataCache.hs new file mode 100644 index 0000000..85062a0 --- /dev/null +++ b/src/Hakyll/Core/ResourceProvider/MetadataCache.hs @@ -0,0 +1,62 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.ResourceProvider.MetadataCache + ( resourceMetadata + , resourceBody + , resourceInvalidateMetadataCache + ) where + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Identifier +import Hakyll.Core.Metadata +import Hakyll.Core.ResourceProvider.Internal +import Hakyll.Core.ResourceProvider.Metadata +import qualified Hakyll.Core.Store as Store + + +-------------------------------------------------------------------------------- +resourceMetadata :: ResourceProvider -> Identifier a -> IO Metadata +resourceMetadata rp r = do + load rp r + Store.Found md <- Store.get (resourceStore rp) + [name, toFilePath r, "metadata"] + return md + + +-------------------------------------------------------------------------------- +resourceBody :: ResourceProvider -> Identifier a -> IO String +resourceBody rp r = do + load rp r + Store.Found bd <- Store.get (resourceStore rp) + [name, toFilePath r, "body"] + maybe (resourceString r) return bd + + +-------------------------------------------------------------------------------- +resourceInvalidateMetadataCache :: ResourceProvider -> Identifier a -> IO () +resourceInvalidateMetadataCache rp r = do + Store.delete (resourceStore rp) [name, toFilePath r, "metadata"] + Store.delete (resourceStore rp) [name, toFilePath r, "body"] + + +-------------------------------------------------------------------------------- +load :: ResourceProvider -> Identifier a -> IO () +load rp 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 rp r + Store.set store mdk metadata + Store.set store bk body + where + store = resourceStore rp + mdk = [name, toFilePath r, "metadata"] + bk = [name, toFilePath r, "body"] + + +-------------------------------------------------------------------------------- +name :: String +name = "Hakyll.Core.Resource.Provider.MetadataCache" diff --git a/src/Hakyll/Core/ResourceProvider/Modified.hs b/src/Hakyll/Core/ResourceProvider/Modified.hs new file mode 100644 index 0000000..837bc8c --- /dev/null +++ b/src/Hakyll/Core/ResourceProvider/Modified.hs @@ -0,0 +1,83 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.ResourceProvider.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.ResourceProvider.Internal +import Hakyll.Core.ResourceProvider.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 :: ResourceProvider -> Identifier a -> 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 = castIdentifier $ setGroup Nothing r + exists = resourceExists rp r + store = resourceStore rp + cacheRef = resourceModifiedCache 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 a -> IO UTCTime +resourceModificationTime = getModificationTime . toFilePath |