git.iko.soy/hakyll
on 712ffa3 help sign in
hakyll/src/Hakyll/Core/Provider/Metadata.hs
166 lines 6.2 kB history raw
1--------------------------------------------------------------------------------
2-- | Internal module to parse metadata
3module Hakyll.Core.Provider.Metadata
4 ( loadMetadata
5 , metadata
6 , page
8 -- This parser can be reused in some places
9 , metadataKey
10 ) where
13--------------------------------------------------------------------------------
14import Control.Applicative
15import Control.Arrow (second)
16import qualified Data.ByteString.Char8 as BC
17import Data.List (intercalate)
18import qualified Data.Map as M
19import System.IO as IO
20import Text.Parsec ((<?>))
21import qualified Text.Parsec as P
22import Text.Parsec.String (Parser)
23import System.FilePath.Posix
24import Control.Monad (liftM)
27--------------------------------------------------------------------------------
28import Hakyll.Core.Identifier
29import Hakyll.Core.Metadata
30import Hakyll.Core.Provider.Internal
31import Hakyll.Core.Util.Parser
32import Hakyll.Core.Util.String
33import Hakyll.Core.Identifier.Pattern
35--------------------------------------------------------------------------------
36loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String)
37loadMetadata p identifier = do
38 hasHeader <- probablyHasMetadataHeader fp
39 (md, body) <- if hasHeader
40 then second Just <$> loadMetadataHeader fp
41 else return (M.empty, Nothing)
43 emd <- case mi of
44 Nothing -> return M.empty
45 Just mi' -> loadMetadataFile $ resourceFilePath p mi'
47 gmd <- loadGlobalMetadata p identifier
49 return (M.unions [md, emd, gmd], body)
50 where
51 normal = setVersion Nothing identifier
52 fp = resourceFilePath p identifier
53 mi = M.lookup normal (providerFiles p) >>= resourceInfoMetadata
56--------------------------------------------------------------------------------
57loadMetadataHeader :: FilePath -> IO (Metadata, String)
58loadMetadataHeader fp = do
59 contents <- readFile fp
60 case P.parse page fp contents of
61 Left err -> error (show err)
62 Right (md, b) -> return (M.fromList md, b)
65--------------------------------------------------------------------------------
66loadMetadataFile :: FilePath -> IO Metadata
67loadMetadataFile fp = do
68 contents <- readFile fp
69 case P.parse metadata fp contents of
70 Left err -> error (show err)
71 Right md -> return $ M.fromList md
74--------------------------------------------------------------------------------
75-- | Check if a file "probably" has a metadata header. The main goal of this is
76-- to exclude binary files (which are unlikely to start with "---").
77probablyHasMetadataHeader :: FilePath -> IO Bool
78probablyHasMetadataHeader fp = do
79 handle <- IO.openFile fp IO.ReadMode
80 bs <- BC.hGet handle 1024
81 IO.hClose handle
82 return $ isMetadataHeader bs
83 where
84 isMetadataHeader bs =
85 let pre = BC.takeWhile (\x -> x /= '\n' && x /= '\r') bs
86 in BC.length pre >= 3 && BC.all (== '-') pre
89--------------------------------------------------------------------------------
90-- | Space or tab, no newline
91inlineSpace :: Parser Char
92inlineSpace = P.oneOf ['\t', ' '] <?> "space"
95--------------------------------------------------------------------------------
96-- | Parse Windows newlines as well (i.e. "\n" or "\r\n")
97newline :: Parser String
98newline = P.string "\n" <|> P.string "\r\n"
101--------------------------------------------------------------------------------
102-- | Parse a single metadata field
103metadataField :: Parser (String, String)
104metadataField = do
105 key <- metadataKey
106 _ <- P.char ':'
107 P.skipMany1 inlineSpace <?> "space followed by metadata for: " ++ key
108 value <- P.manyTill P.anyChar newline
109 trailing' <- P.many trailing
110 return (key, trim $ intercalate " " $ value : trailing')
111 where
112 trailing = P.many1 inlineSpace *> P.manyTill P.anyChar newline
115--------------------------------------------------------------------------------
116-- | Parse a metadata block
117metadata :: Parser [(String, String)]
118metadata = P.many metadataField
121--------------------------------------------------------------------------------
122-- | Parse a metadata block, including delimiters and trailing newlines
123metadataBlock :: Parser [(String, String)]
124metadataBlock = do
125 open <- P.many1 (P.char '-') <* P.many inlineSpace <* newline
126 metadata' <- metadata
127 _ <- P.choice $ map (P.string . replicate (length open)) ['-', '.']
128 P.skipMany inlineSpace
129 P.skipMany1 newline
130 return metadata'
133--------------------------------------------------------------------------------
134-- | Parse a page consisting of a metadata header and a body
135page :: Parser ([(String, String)], String)
136page = do
137 metadata' <- P.option [] metadataBlock
138 body <- P.many P.anyChar
139 return (metadata', body)
142--------------------------------------------------------------------------------
143-- | Load directory-wise metadata
144loadGlobalMetadata :: Provider -> Identifier -> IO Metadata
145loadGlobalMetadata p fp = liftM M.fromList $ loadgm fp where
146 loadgm :: Identifier -> IO [(String, String)]
147 loadgm = liftM concat . mapM loadOne . reverse . filter (resourceExists p) . metadataFiles
148 loadOne mfp =
149 let path = resourceFilePath p mfp
150 dir = takeDirectory $ toFilePath mfp
151 -- TODO: It might be better to print warning and continue
152 in either (error.show) (findMetadata dir) . P.parse namedMetadata path <$> readFile path
153 findMetadata dir =
154 concatMap snd . filter (flip matches fp . fromGlob . combine dir . fst)
156namedMetadata :: Parser [(String, [(String, String)])]
157namedMetadata = P.many namedMetadataBlock
159namedMetadataBlock :: Parser (String, [(String, String)])
160namedMetadataBlock = do
161 name <- P.many1 (P.char '-') *> P.many inlineSpace *> P.manyTill P.anyChar newline
162 metadata' <- metadata
163 P.skipMany P.space
164 return (name, metadata')