git.iko.soy/hakyll
on 5c8eb2a help sign in
hakyll/src/Hakyll/Core/Provider/Metadata.hs
151 lines 5.8 kB history raw
1--------------------------------------------------------------------------------
2-- | Internal module to parse metadata
3{-# LANGUAGE BangPatterns #-}
4{-# LANGUAGE RecordWildCards #-}
5module Hakyll.Core.Provider.Metadata
6 ( loadMetadata
7 , parsePage
9 , MetadataException (..)
10 ) where
13--------------------------------------------------------------------------------
14import Control.Arrow (second)
15import Control.Exception (Exception, throwIO)
16import Control.Monad (guard)
17import qualified Data.ByteString as B
18import qualified Data.ByteString.Char8 as BC
19import Data.List.Extended (breakWhen)
20import qualified Data.Map as M
21import Data.Maybe (fromMaybe)
22import Data.Monoid ((<>))
23import qualified Data.Text as T
24import qualified Data.Text.Encoding as T
25import qualified Data.Yaml as Yaml
26import Hakyll.Core.Identifier
27import Hakyll.Core.Metadata
28import Hakyll.Core.Provider.Internal
29import System.IO as IO
32--------------------------------------------------------------------------------
33loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String)
34loadMetadata p identifier = do
35 hasHeader <- probablyHasMetadataHeader fp
36 (md, body) <- if hasHeader
37 then second Just <$> loadMetadataHeader fp
38 else return (mempty, Nothing)
40 emd <- case mi of
41 Nothing -> return mempty
42 Just mi' -> loadMetadataFile $ resourceFilePath p mi'
44 return (md <> emd, body)
45 where
46 normal = setVersion Nothing identifier
47 fp = resourceFilePath p identifier
48 mi = M.lookup normal (providerFiles p) >>= resourceInfoMetadata
51--------------------------------------------------------------------------------
52loadMetadataHeader :: FilePath -> IO (Metadata, String)
53loadMetadataHeader fp = do
54 fileContent <- readFile fp
55 case parsePage fileContent of
56 Right x -> return x
57 Left err -> throwIO $ MetadataException fp err
60--------------------------------------------------------------------------------
61loadMetadataFile :: FilePath -> IO Metadata
62loadMetadataFile fp = do
63 fileContent <- B.readFile fp
64 let errOrMeta = Yaml.decodeEither' fileContent
65 either (fail . show) return errOrMeta
68--------------------------------------------------------------------------------
69-- | Check if a file "probably" has a metadata header. The main goal of this is
70-- to exclude binary files (which are unlikely to start with "---").
71probablyHasMetadataHeader :: FilePath -> IO Bool
72probablyHasMetadataHeader fp = do
73 handle <- IO.openFile fp IO.ReadMode
74 bs <- BC.hGet handle 1024
75 IO.hClose handle
76 return $ isMetadataHeader bs
77 where
78 isMetadataHeader bs =
79 let pre = BC.takeWhile (\x -> x /= '\n' && x /= '\r') bs
80 in BC.length pre >= 3 && BC.all (== '-') pre
83--------------------------------------------------------------------------------
84-- | Parse the page metadata and body.
85splitMetadata :: String -> (Maybe String, String)
86splitMetadata str0 = fromMaybe (Nothing, str0) $ do
87 guard $ leading >= 3
88 let !str1 = drop leading str0
89 guard $ all isNewline (take 1 str1)
90 let !(!meta, !content0) = breakWhen isTrailing str1
91 guard $ not $ null content0
92 let !content1 = drop (leading + 1) content0
93 !content2 = dropWhile isNewline $ dropWhile isInlineSpace content1
94 -- Adding this newline fixes the line numbers reported by the YAML parser.
95 -- It's a bit ugly but it works.
96 return (Just ('\n' : meta), content2)
97 where
98 -- Parse the leading "---"
99 !leading = length $ takeWhile (== '-') str0
101 -- Predicate to recognize the trailing "---" or "..."
102 isTrailing [] = False
103 isTrailing (x : xs) =
104 isNewline x && length (takeWhile isDash xs) == leading
106 -- Characters
107 isNewline c = c == '\n' || c == '\r'
108 isDash c = c == '-' || c == '.'
109 isInlineSpace c = c == '\t' || c == ' '
112--------------------------------------------------------------------------------
113parseMetadata :: String -> Either Yaml.ParseException Metadata
114parseMetadata = Yaml.decodeEither' . T.encodeUtf8 . T.pack
117--------------------------------------------------------------------------------
118parsePage :: String -> Either Yaml.ParseException (Metadata, String)
119parsePage fileContent = case mbMetaBlock of
120 Nothing -> return (mempty, content)
121 Just metaBlock -> case parseMetadata metaBlock of
122 Left err -> Left err
123 Right meta -> return (meta, content)
124 where
125 !(!mbMetaBlock, !content) = splitMetadata fileContent
128--------------------------------------------------------------------------------
129-- | Thrown in the IO monad if things go wrong. Provides a nice-ish error
130-- message.
131data MetadataException = MetadataException FilePath Yaml.ParseException
134--------------------------------------------------------------------------------
135instance Exception MetadataException
138--------------------------------------------------------------------------------
139instance Show MetadataException where
140 show (MetadataException fp err) =
141 fp ++ ": " ++ Yaml.prettyPrintParseException err ++ hint
143 where
144 hint = case err of
145 Yaml.InvalidYaml (Just (Yaml.YamlParseException {..}))
146 | yamlProblem == problem -> "\n" ++
147 "Hint: if the metadata value contains characters such\n" ++
148 "as ':' or '-', try enclosing it in quotes."
149 _ -> ""
151 problem = "mapping values are not allowed in this context"