85 lines
3.1 KiB
Haskell
85 lines
3.1 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Hakyll.Web.Template.Context.Metadata
|
|
( includeContext
|
|
, metadataContext
|
|
, objectContext
|
|
, restoreMetadata
|
|
) where
|
|
|
|
import Control.Monad ((<=<))
|
|
import Data.Aeson (Object, Value(..))
|
|
import qualified Data.ByteString.Char8 as BS
|
|
import qualified Data.HashMap.Strict as H
|
|
import qualified Data.Text as T
|
|
import qualified Data.Vector as V
|
|
import Hakyll
|
|
import Text.Printf (printf)
|
|
import qualified Data.Yaml as Y
|
|
|
|
|
|
-- |Create a |Context| from the |Metadata| associated with an |Item|.
|
|
metadataContext
|
|
:: Context String -- ^ |Context| used when unfolding a JSON |Array| into a |ListField|.
|
|
-> Context String
|
|
metadataContext ctx = Context $ \k a i -> do
|
|
let identifier = itemIdentifier i
|
|
metadata <- getMetadata identifier
|
|
item <- makeItem metadata
|
|
unContext (objectContext ctx) k a item
|
|
|
|
-- |Create a |Context| from a JSON |Object| which loads data from files under "include" keys.
|
|
includeContext
|
|
:: Context String -- ^ |Context| used when unfolding a JSON |Array| into a |ListField|.
|
|
-> Context Object
|
|
includeContext ctx = Context $ \k a i -> do
|
|
let o = itemBody i
|
|
v <- lookupObject "include" o
|
|
identifier <- fromFilePath <$> toString v
|
|
unContext (ctx <> metadataContext ctx) k a =<< load identifier
|
|
|
|
-- |Create a |Context| from a JSON |Object|.
|
|
objectContext
|
|
:: Context String -- ^ |Context| used when unfolding a JSON |Array| into a |ListField|.
|
|
-> Context Object
|
|
objectContext ctx = Context $ \k _ i -> do
|
|
let o = itemBody i
|
|
decodeValue ctx =<< lookupObject k o
|
|
|
|
-- |Decode a JSON Value to a context field.
|
|
decodeValue :: Context String -> Value -> Compiler ContextField
|
|
decodeValue ctx (Array a) = do
|
|
objs <- mapM (makeItem <=< toObject) (V.toList a)
|
|
return $ ListField (includeContext ctx <> objectContext ctx) objs
|
|
decodeValue _ctx (String s) = return . StringField $ T.unpack s
|
|
decodeValue _ctx (Number n) = return . StringField $ show n
|
|
decodeValue _ctx (Bool b) = return . StringField $ show b
|
|
decodeValue _ctx v = fail $ printf "Unsupported value '%s'" (show v)
|
|
|
|
-- |Lookup the |Value| stored in an |Object| at the given key.
|
|
lookupObject :: MonadFail m => String -> Object -> m Value
|
|
lookupObject k o = maybe ifNotFound ifFound (H.lookup (T.pack k) o)
|
|
where
|
|
ifFound = return
|
|
ifNotFound = fail $ printf "Key '%s' undefined in context '%s'" k (show o)
|
|
|
|
-- |Convert a |Value| to an |Object|, or fail.
|
|
toObject :: MonadFail m => Value -> m Object
|
|
toObject (Object o) = return o
|
|
toObject v = fail $ printf "Not an object '%s'" (show v)
|
|
|
|
-- |Convert a |Value| to an |String|, or fail.
|
|
toString :: MonadFail m => Value -> m String
|
|
toString (String s) = return (T.unpack s)
|
|
toString v = fail $ printf "Not a string '%s'" (show v)
|
|
|
|
|
|
-- |Add the original |Metadata| block back to the file.
|
|
restoreMetadata :: Item String -> Compiler (Item String)
|
|
restoreMetadata item = do
|
|
metadata <- getMetadata (itemIdentifier item)
|
|
if H.null metadata then
|
|
return item
|
|
else do
|
|
let yaml = "---\n" <> BS.unpack (Y.encode metadata) <> "---\n\n"
|
|
withItemBody (\body -> return (yaml <> body)) item
|