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