Move src/ to lib/, put Init.hs in src/

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"