--------------------------------------------------------------------------------
-- | 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 forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Metadata, String)
loadMetadataHeader String
fp
        else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, forall a. Maybe a
Nothing)

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

    forall (m :: * -> *) a. Monad m => a -> m a
return (Metadata
md forall a. Semigroup a => a -> a -> a
<> Metadata
emd, Maybe String
body)
  where
    normal :: Identifier
normal = Maybe String -> Identifier -> Identifier
setVersion forall a. Maybe a
Nothing Identifier
identifier
    fp :: String
fp     = Provider -> Identifier -> String
resourceFilePath Provider
p Identifier
identifier
    mi :: Maybe Identifier
mi     = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
normal (Provider -> Map Identifier ResourceInfo
providerFiles Provider
p) 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 <- forall a. (IOError -> IOError) -> IO a -> IO a
modifyIOError (IOError -> String -> IOError
`ioeSetLocation` String
"loadMetadataHeader") 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   -> forall (m :: * -> *) a. Monad m => a -> m a
return (Metadata, String)
x
        Left  ParseException
err -> forall e a. Exception e => e -> IO a
throwIO 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 <- forall a. (IOError -> IOError) -> IO a -> IO a
modifyIOError (IOError -> String -> IOError
`ioeSetLocation` String
"loadMetadataFile") forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
fp
    let errOrMeta :: Either ParseException Metadata
errOrMeta = forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' ByteString
fileContent
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) 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
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char
x forall a. Eq a => a -> a -> Bool
/= Char
'\r') ByteString
bs
        in  ByteString -> Int
BC.length ByteString
pre forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> Bool
&& (Char -> Bool) -> ByteString -> Bool
BC.all (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 = forall a. a -> Maybe a -> a
fromMaybe (forall a. Maybe a
Nothing, String
str0) forall a b. (a -> b) -> a -> b
$ do
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
leading forall a. Ord a => a -> a -> Bool
>= Int
3
    let !str1 :: String
str1 = forall a. Int -> [a] -> [a]
drop Int
leading String
str0
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isNewline (forall a. Int -> [a] -> [a]
take Int
1 String
str1)
    let !(!String
meta, !String
content0) = forall a. ([a] -> Bool) -> [a] -> ([a], [a])
breakWhen String -> Bool
isTrailing String
str1
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
content0
    let !content1 :: String
content1 = forall a. Int -> [a] -> [a]
drop (Int
leading forall a. Num a => a -> a -> a
+ Int
1) String
content0
        !content2 :: String
content2 = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isNewline forall a b. (a -> b) -> a -> b
$ 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.
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Char
'\n' forall a. a -> [a] -> [a]
: String
meta), String
content2)
  where
    -- Parse the leading "---"
    !leading :: Int
leading = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (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
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDash String
xs) forall a. Eq a => a -> a -> Bool
== Int
leading

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


--------------------------------------------------------------------------------
parseMetadata :: String -> Either Yaml.ParseException Metadata
parseMetadata :: String -> Either ParseException Metadata
parseMetadata = forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 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        -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, String
content)
    Just String
metaBlock -> case String -> Either ParseException Metadata
parseMetadata String
metaBlock of
        Left  ParseException
err  -> forall a b. a -> Either a b
Left   ParseException
err
        Right Metadata
meta -> 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 forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ ParseException -> String
Yaml.prettyPrintParseException ParseException
err forall a. [a] -> [a] -> [a]
++ String
hint

      where
        hint :: String
hint = case ParseException
err of
            Yaml.InvalidYaml (Just (Yaml.YamlParseException {String
YamlMark
yamlProblem :: YamlException -> String
yamlContext :: YamlException -> String
yamlProblemMark :: YamlException -> YamlMark
yamlProblemMark :: YamlMark
yamlContext :: String
yamlProblem :: String
..}))
                | String
yamlProblem forall a. Eq a => a -> a -> Bool
==  String
"mapping values are not allowed in this context" -> String
"\n" forall a. [a] -> [a] -> [a]
++
                    String
"Hint: if the metadata value contains characters such\n" 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
""