    --------------------------------------------------------------------------------
    -- | Internal module to parse metadata
    {-# LANGUAGE BangPatterns    #-}
    {-# LANGUAGE RecordWildCards #-}
    module Hakyll.Core.Provider.Metadata
        ( loadMetadata
        , parsePage

        , MetadataException (..)
        ) where

    --------------------------------------------------------------------------------
    import           Control.Arrow                 (second)
    import           Control.Exception             (Exception, throwIO)
    import           Control.Monad                 (guard)
    import qualified Data.ByteString               as B
    import qualified Data.ByteString.Char8         as BC
    import           Data.List.Extended            (breakWhen)
    import qualified Data.Map                      as M
    import           Data.Maybe                    (fromMaybe)
    import qualified Data.Text                     as T
    import qualified Data.Text.Encoding            as T
    import qualified Data.Yaml                     as Yaml
    import           Hakyll.Core.Identifier
    import           Hakyll.Core.Metadata
    import           Hakyll.Core.Provider.Internal
    import           System.IO                     as IO
    import           System.IO.Error               (modifyIOError, ioeSetLocation)

    --------------------------------------------------------------------------------
    loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String)
    loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String)
    loadMetadata Provider
    p Identifier
    identifier = do
        Bool
    hasHeader  <- String -> IO Bool
    probablyHasMetadataHeader String
    fp
        (Metadata
    md, Maybe String
    body) <- if Bool
    hasHeader
            then (String -> Maybe String)
    -> (Metadata, String) -> (Metadata, Maybe String)
    forall b c d. (b -> c) -> (d, b) -> (d, c)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (d, b) (d, c)
    second String -> Maybe String
    forall a. a -> Maybe a
    Just ((Metadata, String) -> (Metadata, Maybe String))
    -> IO (Metadata, String) -> IO (Metadata, Maybe String)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> IO (Metadata, String)
    loadMetadataHeader String
    fp
            else (Metadata, Maybe String) -> IO (Metadata, Maybe String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Metadata
    forall a. Monoid a => a
    mempty, Maybe String
    forall a. Maybe a
    Nothing)

        Metadata
    emd <- case Maybe Identifier
    mi of
            Maybe Identifier
    Nothing  -> Metadata -> IO Metadata
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Metadata
    forall a. Monoid a => a
    mempty
            Just Identifier
    mi' -> String -> IO Metadata
    loadMetadataFile (String -> IO Metadata) -> String -> IO Metadata
    forall a b. (a -> b) -> a -> b
    $ Provider -> Identifier -> String
    resourceFilePath Provider
    p Identifier
    mi'

        (Metadata, Maybe String) -> IO (Metadata, Maybe String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Metadata
    md Metadata -> Metadata -> Metadata
    forall a. Semigroup a => a -> a -> a
    <> Metadata
    emd, Maybe String
    body)
      where
        normal :: Identifier
    normal = Maybe String -> Identifier -> Identifier
    setVersion Maybe String
    forall a. Maybe a
    Nothing Identifier
    identifier
        fp :: String
    fp     = Provider -> Identifier -> String
    resourceFilePath Provider
    p Identifier
    identifier
        mi :: Maybe Identifier
    mi     = Identifier -> Map Identifier ResourceInfo -> Maybe ResourceInfo
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup Identifier
    normal (Provider -> Map Identifier ResourceInfo
    providerFiles Provider
    p) Maybe ResourceInfo
    -> (ResourceInfo -> Maybe Identifier) -> Maybe Identifier
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= ResourceInfo -> Maybe Identifier
    resourceInfoMetadata

    --------------------------------------------------------------------------------
    loadMetadataHeader :: FilePath -> IO (Metadata, String)
    loadMetadataHeader :: String -> IO (Metadata, String)
    loadMetadataHeader String
    fp = do
        String
    fileContent <- (IOError -> IOError) -> IO String -> IO String
    forall a. (IOError -> IOError) -> IO a -> IO a
    modifyIOError (IOError -> String -> IOError
    `ioeSetLocation` String
    "loadMetadataHeader") (IO String -> IO String) -> IO String -> IO String
    forall a b. (a -> b) -> a -> b
    $ String -> IO String
    readFile String
    fp
        case String -> Either ParseException (Metadata, String)
    parsePage String
    fileContent of
            Right (Metadata, String)
    x   -> (Metadata, String) -> IO (Metadata, String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Metadata, String)
    x
            Left  ParseException
    err -> MetadataException -> IO (Metadata, String)
    forall e a. Exception e => e -> IO a
    throwIO (MetadataException -> IO (Metadata, String))
    -> MetadataException -> IO (Metadata, String)
    forall a b. (a -> b) -> a -> b
    $ String -> ParseException -> MetadataException
    MetadataException String
    fp ParseException
    err

    --------------------------------------------------------------------------------
    loadMetadataFile :: FilePath -> IO Metadata
    loadMetadataFile :: String -> IO Metadata
    loadMetadataFile String
    fp = do
        ByteString
    fileContent <- (IOError -> IOError) -> IO ByteString -> IO ByteString
    forall a. (IOError -> IOError) -> IO a -> IO a
    modifyIOError (IOError -> String -> IOError
    `ioeSetLocation` String
    "loadMetadataFile") (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ String -> IO ByteString
    B.readFile String
    fp
        let errOrMeta :: Either ParseException Metadata
    errOrMeta = ByteString -> Either ParseException Metadata
    forall a. FromJSON a => ByteString -> Either ParseException a
    Yaml.decodeEither' ByteString
    fileContent
        (ParseException -> IO Metadata)
    -> (Metadata -> IO Metadata)
    -> Either ParseException Metadata
    -> IO Metadata
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either (String -> IO Metadata
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> IO Metadata)
    -> (ParseException -> String) -> ParseException -> IO Metadata
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ParseException -> String
    forall a. Show a => a -> String
    show) Metadata -> IO Metadata
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Either ParseException Metadata
    errOrMeta

    --------------------------------------------------------------------------------
    -- | 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 :: String -> IO Bool
    probablyHasMetadataHeader String
    fp = do
        Handle
    handle <- String -> IOMode -> IO Handle
    IO.openFile String
    fp IOMode
    IO.ReadMode
        ByteString
    bs     <- Handle -> Int -> IO ByteString
    BC.hGet Handle
    handle Int
    1024
        Handle -> IO ()
    IO.hClose Handle
    handle
        Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> IO Bool) -> Bool -> IO Bool
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Bool
    isMetadataHeader ByteString
    bs
      where
        isMetadataHeader :: ByteString -> Bool
    isMetadataHeader ByteString
    bs =
            let pre :: ByteString
    pre = (Char -> Bool) -> ByteString -> ByteString
    BC.takeWhile (\Char
    x -> Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\n' Bool -> Bool -> Bool
    && Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\r') ByteString
    bs
            in  ByteString -> Int
    BC.length ByteString
    pre Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    3 Bool -> Bool -> Bool
    && (Char -> Bool) -> ByteString -> Bool
    BC.all (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '-') ByteString
    pre

    --------------------------------------------------------------------------------
    -- | Parse the page metadata and body.
    splitMetadata :: String -> (Maybe String, String)
    splitMetadata :: String -> (Maybe String, String)
    splitMetadata String
    str0 = (Maybe String, String)
    -> Maybe (Maybe String, String) -> (Maybe String, String)
    forall a. a -> Maybe a -> a
    fromMaybe (Maybe String
    forall a. Maybe a
    Nothing, String
    str0) (Maybe (Maybe String, String) -> (Maybe String, String))
    -> Maybe (Maybe String, String) -> (Maybe String, String)
    forall a b. (a -> b) -> a -> b
    $ do
        Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Bool -> Maybe ()) -> Bool -> Maybe ()
    forall a b. (a -> b) -> a -> b
    $ Int
    leading Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    3
        let !str1 :: String
    str1 = Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop Int
    leading String
    str0
        Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Bool -> Maybe ()) -> Bool -> Maybe ()
    forall a b. (a -> b) -> a -> b
    $ (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Char -> Bool
    isNewline (Int -> String -> String
    forall a. Int -> [a] -> [a]
    take Int
    1 String
    str1)
        let !(!String
    meta, !String
    content0) = (String -> Bool) -> String -> (String, String)
    forall a. ([a] -> Bool) -> [a] -> ([a], [a])
    breakWhen String -> Bool
    isTrailing String
    str1
        Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Bool -> Maybe ()) -> Bool -> Maybe ()
    forall a b. (a -> b) -> a -> b
    $ Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    content0
        let !content1 :: String
    content1 = Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop (Int
    leading Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) String
    content0
            !content2 :: String
    content2 = (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isNewline (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isInlineSpace String
    content1
        -- Adding this newline fixes the line numbers reported by the YAML parser.
        -- It's a bit ugly but it works.
        (Maybe String, String) -> Maybe (Maybe String, String)
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> Maybe String
    forall a. a -> Maybe a
    Just (Char
    '\n' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    meta), String
    content2)
      where
        -- Parse the leading "---"
        !leading :: Int
    leading = String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (String -> Int) -> String -> Int
    forall a b. (a -> b) -> a -> b
    $ (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '-') String
    str0

        -- Predicate to recognize the trailing "---" or "..."
        isTrailing :: String -> Bool
    isTrailing []       = Bool
    False
        isTrailing (Char
    x : String
    xs) =
            Char -> Bool
    isNewline Char
    x Bool -> Bool -> Bool
    && String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile Char -> Bool
    isDash String
    xs) Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    leading

        -- Characters
        isNewline :: Char -> Bool
    isNewline     Char
    c = Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\n' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\r'
        isDash :: Char -> Bool
    isDash        Char
    c = Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '-'  Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '.'
        isInlineSpace :: Char -> Bool
    isInlineSpace Char
    c = Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\t' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ' '

    --------------------------------------------------------------------------------
    parseMetadata :: String -> Either Yaml.ParseException Metadata
    parseMetadata :: String -> Either ParseException Metadata
    parseMetadata = ByteString -> Either ParseException Metadata
    forall a. FromJSON a => ByteString -> Either ParseException a
    Yaml.decodeEither' (ByteString -> Either ParseException Metadata)
    -> (String -> ByteString)
    -> String
    -> Either ParseException Metadata
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> ByteString
    T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    T.pack

    --------------------------------------------------------------------------------
    parsePage :: String -> Either Yaml.ParseException (Metadata, String)
    parsePage :: String -> Either ParseException (Metadata, String)
    parsePage String
    fileContent = case Maybe String
    mbMetaBlock of
        Maybe String
    Nothing        -> (Metadata, String) -> Either ParseException (Metadata, String)
    forall a. a -> Either ParseException a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Metadata
    forall a. Monoid a => a
    mempty, String
    content)
        Just String
    metaBlock -> case String -> Either ParseException Metadata
    parseMetadata String
    metaBlock of
            Left  ParseException
    err  -> ParseException -> Either ParseException (Metadata, String)
    forall a b. a -> Either a b
    Left   ParseException
    err
            Right Metadata
    meta -> (Metadata, String) -> Either ParseException (Metadata, String)
    forall a. a -> Either ParseException a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Metadata
    meta, String
    content)
      where
        !(!Maybe String
    mbMetaBlock, !String
    content) = String -> (Maybe String, String)
    splitMetadata String
    fileContent

    --------------------------------------------------------------------------------
    -- | Thrown in the IO monad if things go wrong. Provides a nice-ish error
    -- message.
    data MetadataException = MetadataException FilePath Yaml.ParseException

    --------------------------------------------------------------------------------
    instance Exception MetadataException

    --------------------------------------------------------------------------------
    instance Show MetadataException where
        show :: MetadataException -> String
    show (MetadataException String
    fp ParseException
    err) =
            String
    fp String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ": " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ParseException -> String
    Yaml.prettyPrintParseException ParseException
    err String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    hint

          where
            hint :: String
    hint = case ParseException
    err of
                Yaml.InvalidYaml (Just (Yaml.YamlParseException {String
    YamlMark
    yamlProblem :: String
    yamlContext :: String
    yamlProblemMark :: YamlMark
    yamlProblem :: YamlException -> String
    yamlContext :: YamlException -> String
    yamlProblemMark :: YamlException -> YamlMark
    ..}))
                    | String
    yamlProblem String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    ==  String
    "mapping values are not allowed in this context" -> String
    "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                        String
    "Hint: if the metadata value contains characters such\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                        String
    "as ':' or '-', try enclosing it in quotes."
                Yaml.AesonException String
    "Error in $: parsing HashMap ~Text failed, expected Object, but encountered String"
                    -> String
    "\nHint: in metadata, keys and values are separated by a colon *and* a space."
                ParseException
    _ -> String
    ""