summaryrefslogtreecommitdiff
path: root/src/Hakyll/Core/ResourceProvider/Metadata.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Hakyll/Core/ResourceProvider/Metadata.hs')
-rw-r--r--src/Hakyll/Core/ResourceProvider/Metadata.hs119
1 files changed, 119 insertions, 0 deletions
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)