1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
--------------------------------------------------------------------------------
-- | 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 -> 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 Windows newlines as well (i.e. "\n" or "\r\n")
newline :: Parser String
newline = P.string "\n" <|> P.string "\r\n"
--------------------------------------------------------------------------------
-- | 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 newline
trailing' <- P.many trailing
return (key, trim $ value ++ concat trailing')
where
trailing = (++) <$> P.many1 inlineSpace <*> P.manyTill P.anyChar 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 <* newline
metadata' <- metadata
_ <- P.choice $ map (P.string . replicate (length open)) ['-', '.']
P.skipMany inlineSpace
P.skipMany1 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)
|
