--------------------------------------------------------------------------------
-- | 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           Data.Monoid                   ((<>))
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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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
yamlProblemMark :: YamlException -> YamlMark
yamlProblem :: YamlException -> String
yamlContext :: YamlException -> String
yamlProblemMark :: YamlMark
yamlContext :: String
yamlProblem :: String
..}))
                | String
yamlProblem String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
problem -> 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."
            ParseException
_ -> String
""

        problem :: String
problem = String
"mapping values are not allowed in this context"