module Hakyll.Web.Template.Context
( ContextField (..)
, Context (..)
, field
, constField
, listField
, mapContext
, defaultContext
, bodyField
, metadataField
, urlField
, pathField
, titleField
, dateField
, dateFieldWith
, getItemUTC
, modificationTimeField
, modificationTimeFieldWith
, teaserField
, missingField
) where
import Control.Applicative (Alternative (..), (<$>))
import Control.Monad (msum)
import Data.List (intercalate)
import qualified Data.Map as M
import Data.Monoid (Monoid (..))
import Data.Time.Clock (UTCTime (..))
import Data.Time.Format (formatTime, parseTime)
import System.FilePath (takeBaseName, takeFileName)
import System.Locale (TimeLocale, defaultTimeLocale)
import Hakyll.Core.Compiler
import Hakyll.Core.Compiler.Internal
import Hakyll.Core.Identifier
import Hakyll.Core.Item
import Hakyll.Core.Metadata
import Hakyll.Core.Provider
import Hakyll.Core.Util.String (splitAll, needlePrefix)
import Hakyll.Web.Html
data ContextField
= StringField String
| forall a. ListField (Context a) [Item a]
newtype Context a = Context
{ unContext :: String -> Item a -> Compiler ContextField
}
instance Monoid (Context a) where
mempty = missingField
mappend (Context f) (Context g) = Context $ \k i -> f k i <|> g k i
field' :: String -> (Item a -> Compiler ContextField) -> Context a
field' key value = Context $ \k i -> if k == key then value i else empty
field :: String -> (Item a -> Compiler String) -> Context a
field key value = field' key (fmap StringField . value)
constField :: String -> String -> Context a
constField key = field key . const . return
listField :: String -> Context a -> Compiler [Item a] -> Context b
listField key c xs = field' key $ \_ -> fmap (ListField c) xs
mapContext :: (String -> String) -> Context a -> Context a
mapContext f (Context c) = Context $ \k i -> do
fld <- c k i
return $ case fld of
StringField str -> StringField (f str)
ListField ctx is -> ListField ctx is
defaultContext :: Context String
defaultContext =
bodyField "body" `mappend`
metadataField `mappend`
urlField "url" `mappend`
pathField "path" `mappend`
titleField "title" `mappend`
missingField
teaserSeparator :: String
teaserSeparator = "<!--more-->"
bodyField :: String -> Context String
bodyField key = field key $ return . itemBody
metadataField :: Context String
metadataField = Context $ \k i -> do
value <- getMetadataField (itemIdentifier i) k
maybe empty (return . StringField) value
urlField :: String -> Context a
urlField key = field key $
fmap (maybe empty toUrl) . getRoute . itemIdentifier
pathField :: String -> Context a
pathField key = field key $ return . toFilePath . itemIdentifier
titleField :: String -> Context a
titleField = mapContext takeBaseName . pathField
dateField :: String
-> String
-> Context a
dateField = dateFieldWith defaultTimeLocale
dateFieldWith :: TimeLocale
-> String
-> String
-> Context a
dateFieldWith locale key format = field key $ \i -> do
time <- getItemUTC locale $ itemIdentifier i
return $ formatTime locale format time
getItemUTC :: MonadMetadata m
=> TimeLocale
-> Identifier
-> m UTCTime
getItemUTC locale id' = do
metadata <- getMetadata id'
let tryField k fmt = M.lookup k metadata >>= parseTime' fmt
fn = takeFileName $ toFilePath id'
maybe empty' return $ msum $
[tryField "published" fmt | fmt <- formats] ++
[tryField "date" fmt | fmt <- formats] ++
[parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fn]
where
empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++
"could not parse time for " ++ show id'
parseTime' = parseTime locale
formats =
[ "%a, %d %b %Y %H:%M:%S %Z"
, "%Y-%m-%dT%H:%M:%S%Z"
, "%Y-%m-%d %H:%M:%S%Z"
, "%Y-%m-%d"
, "%B %e, %Y %l:%M %p"
, "%B %e, %Y"
, "%b %d, %Y"
]
modificationTimeField :: String
-> String
-> Context a
modificationTimeField = modificationTimeFieldWith defaultTimeLocale
modificationTimeFieldWith :: TimeLocale
-> String
-> String
-> Context a
modificationTimeFieldWith locale key fmt = field key $ \i -> do
provider <- compilerProvider <$> compilerAsk
let mtime = resourceModificationTime provider $ itemIdentifier i
return $ formatTime locale fmt mtime
teaserField :: String
-> Snapshot
-> Context String
teaserField key snapshot = field key $ \item -> do
body <- itemBody <$> loadSnapshot (itemIdentifier item) snapshot
case needlePrefix teaserSeparator body of
Nothing -> fail $
"Hakyll.Web.Template.Context: no teaser defined for " ++
show (itemIdentifier item)
Just t -> return t
missingField :: Context a
missingField = Context $ \k i -> fail $
"Missing field $" ++ k ++ "$ in context for item " ++
show (itemIdentifier i)