summaryrefslogtreecommitdiff
path: root/lib/Hakyll/Core/Provider
diff options
context:
space:
mode:
authorJasper Van der Jeugt <m@jaspervdj.be>2017-06-19 11:57:23 +0200
committerJasper Van der Jeugt <m@jaspervdj.be>2017-06-19 11:57:23 +0200
commit67ecff7ad383640bc73d64edc2506c7cc648a134 (patch)
tree6d328e43c3ab86c29a2d775fabaa23618c16fb51 /lib/Hakyll/Core/Provider
parent2df3209bafa08e6b77ee4a8598fc503269513527 (diff)
downloadhakyll-67ecff7ad383640bc73d64edc2506c7cc648a134.tar.gz
Move src/ to lib/, put Init.hs in src/
Diffstat (limited to 'lib/Hakyll/Core/Provider')
-rw-r--r--lib/Hakyll/Core/Provider/Internal.hs202
-rw-r--r--lib/Hakyll/Core/Provider/Metadata.hs151
-rw-r--r--lib/Hakyll/Core/Provider/MetadataCache.hs62
3 files changed, 415 insertions, 0 deletions
diff --git a/lib/Hakyll/Core/Provider/Internal.hs b/lib/Hakyll/Core/Provider/Internal.hs
new file mode 100644
index 0000000..c298653
--- /dev/null
+++ b/lib/Hakyll/Core/Provider/Internal.hs
@@ -0,0 +1,202 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Hakyll.Core.Provider.Internal
+ ( ResourceInfo (..)
+ , Provider (..)
+ , newProvider
+
+ , resourceList
+ , resourceExists
+
+ , resourceFilePath
+ , resourceString
+ , resourceLBS
+
+ , resourceModified
+ , resourceModificationTime
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.DeepSeq (NFData (..), deepseq)
+import Control.Monad (forM)
+import Data.Binary (Binary (..))
+import qualified Data.ByteString.Lazy as BL
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Time (Day (..), UTCTime (..))
+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 (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 (toRational dt)
+
+ get = fmap BinaryTime $ UTCTime
+ <$> (ModifiedJulianDay <$> get)
+ <*> (fromRational <$> 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
+ , -- | A list of all files found
+ providerFiles :: Map Identifier ResourceInfo
+ , -- | A list of the files from the previous run
+ providerOldFiles :: Map Identifier ResourceInfo
+ , -- | Underlying persistent store for caching
+ providerStore :: Store
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+-- | Create a resource provider
+newProvider :: Store -- ^ Store to use
+ -> (FilePath -> IO Bool) -- ^ Should we ignore this file?
+ -> FilePath -- ^ Search directory
+ -> IO Provider -- ^ Resulting provider
+newProvider store ignore directory = do
+ 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 = M.keys . providerFiles
+
+
+--------------------------------------------------------------------------------
+-- | Check if a given resource exists
+resourceExists :: Provider -> Identifier -> Bool
+resourceExists provider =
+ (`M.member` providerFiles provider) . setVersion Nothing
+
+
+--------------------------------------------------------------------------------
+resourceFilePath :: Provider -> Identifier -> FilePath
+resourceFilePath p i = providerDirectory p </> toFilePath i
+
+
+--------------------------------------------------------------------------------
+-- | Get the raw body of a resource as string
+resourceString :: Provider -> Identifier -> IO String
+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, _) -> False
+ (Just _, Nothing) -> True
+ (Just n, Just o) ->
+ resourceInfoModified n > resourceInfoModified o ||
+ resourceInfoMetadata n /= resourceInfoMetadata o
+ where
+ normal = setVersion Nothing r
+ ri = M.lookup normal (providerFiles p)
+ oldRi = M.lookup normal (providerOldFiles 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/lib/Hakyll/Core/Provider/Metadata.hs b/lib/Hakyll/Core/Provider/Metadata.hs
new file mode 100644
index 0000000..6285ce1
--- /dev/null
+++ b/lib/Hakyll/Core/Provider/Metadata.hs
@@ -0,0 +1,151 @@
+--------------------------------------------------------------------------------
+-- | Internal module to parse metadata
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+module Hakyll.Core.Provider.Metadata
+ ( loadMetadata
+ , parsePage
+
+ , MetadataException (..)
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Arrow (second)
+import Control.Exception (Exception, throwIO)
+import Control.Monad (guard)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import Data.List.Extended (breakWhen)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Monoid ((<>))
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Yaml as Yaml
+import Hakyll.Core.Identifier
+import Hakyll.Core.Metadata
+import Hakyll.Core.Provider.Internal
+import System.IO as IO
+
+
+--------------------------------------------------------------------------------
+loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String)
+loadMetadata p identifier = do
+ hasHeader <- probablyHasMetadataHeader fp
+ (md, body) <- if hasHeader
+ then second Just <$> loadMetadataHeader fp
+ else return (mempty, Nothing)
+
+ emd <- case mi of
+ Nothing -> return mempty
+ Just mi' -> loadMetadataFile $ resourceFilePath p mi'
+
+ return (md <> emd, body)
+ where
+ normal = setVersion Nothing identifier
+ fp = resourceFilePath p identifier
+ mi = M.lookup normal (providerFiles p) >>= resourceInfoMetadata
+
+
+--------------------------------------------------------------------------------
+loadMetadataHeader :: FilePath -> IO (Metadata, String)
+loadMetadataHeader fp = do
+ fileContent <- readFile fp
+ case parsePage fileContent of
+ Right x -> return x
+ Left err -> throwIO $ MetadataException fp err
+
+
+--------------------------------------------------------------------------------
+loadMetadataFile :: FilePath -> IO Metadata
+loadMetadataFile fp = do
+ fileContent <- B.readFile fp
+ let errOrMeta = Yaml.decodeEither' fileContent
+ either (fail . show) return errOrMeta
+
+
+--------------------------------------------------------------------------------
+-- | 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
+
+
+--------------------------------------------------------------------------------
+-- | Parse the page metadata and body.
+splitMetadata :: String -> (Maybe String, String)
+splitMetadata str0 = fromMaybe (Nothing, str0) $ do
+ guard $ leading >= 3
+ let !str1 = drop leading str0
+ guard $ all isNewline (take 1 str1)
+ let !(!meta, !content0) = breakWhen isTrailing str1
+ guard $ not $ null content0
+ let !content1 = drop (leading + 1) content0
+ !content2 = dropWhile isNewline $ dropWhile isInlineSpace content1
+ -- Adding this newline fixes the line numbers reported by the YAML parser.
+ -- It's a bit ugly but it works.
+ return (Just ('\n' : meta), content2)
+ where
+ -- Parse the leading "---"
+ !leading = length $ takeWhile (== '-') str0
+
+ -- Predicate to recognize the trailing "---" or "..."
+ isTrailing [] = False
+ isTrailing (x : xs) =
+ isNewline x && length (takeWhile isDash xs) == leading
+
+ -- Characters
+ isNewline c = c == '\n' || c == '\r'
+ isDash c = c == '-' || c == '.'
+ isInlineSpace c = c == '\t' || c == ' '
+
+
+--------------------------------------------------------------------------------
+parseMetadata :: String -> Either Yaml.ParseException Metadata
+parseMetadata = Yaml.decodeEither' . T.encodeUtf8 . T.pack
+
+
+--------------------------------------------------------------------------------
+parsePage :: String -> Either Yaml.ParseException (Metadata, String)
+parsePage fileContent = case mbMetaBlock of
+ Nothing -> return (mempty, content)
+ Just metaBlock -> case parseMetadata metaBlock of
+ Left err -> Left err
+ Right meta -> return (meta, content)
+ where
+ !(!mbMetaBlock, !content) = splitMetadata fileContent
+
+
+--------------------------------------------------------------------------------
+-- | Thrown in the IO monad if things go wrong. Provides a nice-ish error
+-- message.
+data MetadataException = MetadataException FilePath Yaml.ParseException
+
+
+--------------------------------------------------------------------------------
+instance Exception MetadataException
+
+
+--------------------------------------------------------------------------------
+instance Show MetadataException where
+ show (MetadataException fp err) =
+ fp ++ ": " ++ Yaml.prettyPrintParseException err ++ hint
+
+ where
+ hint = case err of
+ Yaml.InvalidYaml (Just (Yaml.YamlParseException {..}))
+ | yamlProblem == problem -> "\n" ++
+ "Hint: if the metadata value contains characters such\n" ++
+ "as ':' or '-', try enclosing it in quotes."
+ _ -> ""
+
+ problem = "mapping values are not allowed in this context"
diff --git a/lib/Hakyll/Core/Provider/MetadataCache.hs b/lib/Hakyll/Core/Provider/MetadataCache.hs
new file mode 100644
index 0000000..46dbf3e
--- /dev/null
+++ b/lib/Hakyll/Core/Provider/MetadataCache.hs
@@ -0,0 +1,62 @@
+--------------------------------------------------------------------------------
+module Hakyll.Core.Provider.MetadataCache
+ ( resourceMetadata
+ , resourceBody
+ , resourceInvalidateMetadataCache
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Monad (unless)
+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
+ | not (resourceExists p r) = return mempty
+ | otherwise = do
+ -- TODO keep time in md cache
+ load p r
+ Store.Found (BinaryMetadata 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 p 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
+ mmof <- Store.isMember store mdk
+ unless mmof $ do
+ (md, body) <- loadMetadata p r
+ Store.set store mdk (BinaryMetadata md)
+ 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"