fn-extra-0.3.0.0: src/Web/Fn/Extra/Heist.hs
{-# LANGUAGE OverloadedStrings #-}
{-|
This module contains helpers to make Heist fit in more closely within
`Fn`'s stance against monad transformers and for regular functions.
In particular, it instantiates the Monad for HeistState to be a
StateT that contains our context, so that in the splices we can get
the context out (and modify it if needed).
Further, we add splice builders that work similar to our url
routing - splices are declared to have certain attributes of specific
types, and the splice that correspond is a function that takes those
as arguments (and takes the context and the node as well).
-}
module Web.Fn.Extra.Heist ( -- * Types
HeistContext(..)
, FnHeistState
, FnSplice
, FnCSplice
-- * Initializer
, heistInit
-- * Rendering templates
, heistServe
, render
, renderWithSplices
, cHeistServe
, cRender
-- * Building splices
, tag
, tag'
, FromAttribute(..)
, attr
, attrOpt
, (&=)
) where
import Blaze.ByteString.Builder
import Control.Applicative ((<$>), (<*>))
import Control.Arrow (first)
import Control.Lens
import Control.Monad.State
import Control.Monad.Trans.Either
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Text.Read (decimal, double)
import Heist
import qualified Heist.Compiled as C
import qualified Heist.Interpreted as I
import Network.HTTP.Types
import Network.Wai
import qualified Network.Wai.Util as W
import qualified Text.XmlHtml as X
import Web.Fn
-- | The type of our state. We need a StateT to be able to pass the
-- runtime context (which includes the current request) into the
-- splices.
type FnHeistState ctxt = HeistState (StateT ctxt IO)
-- | The type of our splice (interpreted version). We need a StateT to
-- be able to pass the runtime context (which includes the current
-- request) into the splice (and sometimes modify it).
type FnSplice ctxt = I.Splice (StateT ctxt IO)
-- | The type of our splice (compiled version). We need a StateT to
-- be able to pass the runtime context (which includes the current
-- request) into the splice (and sometimes modify it).
type FnCSplice ctxt = C.Splice (StateT ctxt IO)
-- | In order to have render be able to get the 'FnHeistState' out of
-- our context, we need this helper class.
class HeistContext ctxt where
getHeist :: ctxt -> FnHeistState ctxt
-- | Initialize heist. This takes a list of paths to template
-- directories, a set of interpreted splices, and a set of compiled
-- splices (you can pass @mempty@ as either)
heistInit :: HeistContext ctxt =>
[Text] ->
Splices (FnSplice ctxt) ->
Splices (FnCSplice ctxt) ->
IO (Either [String] (FnHeistState ctxt))
heistInit templateLocations isplices csplices =
do let ts = map (loadTemplates . T.unpack) templateLocations
runEitherT $ initHeist (emptyHeistConfig & hcTemplateLocations .~ ts
& hcInterpretedSplices .~ isplices
& hcLoadTimeSplices .~ defaultLoadTimeSplices
& hcCompiledSplices .~ csplices
& hcNamespace .~ "")
-- | Render interpreted templates according to the request path. Note
-- that if you have matched some parts of the path, those will not be
-- included in the path used to find the templates. For example, if
-- you have @foo\/bar.tpl@ in the directory where you loaded templates
-- from,
--
-- > path "foo" ==> heistServe
--
-- Will match @foo\/foo\/bar@, but not @foo\/bar@. To match that, you could:
--
-- > anything ==> heistServe
--
-- This will also try the path followed by "index" if the first
-- doesn't match, so if you have @foo\/index.tpl@, the path @foo@ will
-- be matched to it.
--
-- If no template is found, this will continue routing.
heistServe :: (RequestContext ctxt, HeistContext ctxt) =>
ctxt ->
IO (Maybe Response)
heistServe ctxt =
let p = pathInfo . fst $ getRequest ctxt in
mplus <$> render ctxt (T.intercalate "/" p)
<*> render ctxt (T.intercalate "/" (p ++ ["index"]))
-- | Render a single interpreted heist template by name.
render :: HeistContext ctxt =>
ctxt ->
Text ->
IO (Maybe Response)
render ctxt name = renderWithSplices ctxt name mempty
-- | Render a template, and add additional interpreted splices before
-- doing so.
renderWithSplices :: HeistContext ctxt =>
ctxt ->
Text ->
Splices (FnSplice ctxt) ->
IO (Maybe Response)
renderWithSplices ctxt name splices =
do (r,_) <- runStateT (I.renderTemplate (I.bindSplices splices (getHeist ctxt)) (T.encodeUtf8 name)) ctxt
case first toLazyByteString <$> r of
Nothing -> return Nothing
Just (h,m) -> Just <$> W.bytestring status200 [(hContentType, m)] h
-- | Render a single compiled heist template by name.
cRender :: HeistContext ctxt => ctxt -> Text -> IO (Maybe Response)
cRender ctxt tmpl =
let mr = C.renderTemplate (getHeist ctxt) (T.encodeUtf8 tmpl) in
case mr of
Nothing -> return Nothing
Just (rc, ct) ->
do (builder, _) <- runStateT rc ctxt
return $ Just $ responseBuilder status200 [(hContentType, ct)] builder
-- | Like 'heistServe', but for compiled templates.
cHeistServe :: (RequestContext ctxt, HeistContext ctxt) =>
ctxt ->
IO (Maybe Response)
cHeistServe ctxt =
do let p = pathInfo . fst $ getRequest ctxt
mplus <$> cRender ctxt (T.intercalate "/" p)
<*> cRender ctxt (T.intercalate "/" (p ++ ["index"]))
-- | In order to make splice definitions more functional, we declare
-- them and the attributes they need, along with deserialization (if
-- needed). The deserialization is facilitated be this class.
class FromAttribute a where
fromAttribute :: Text -> Maybe a
instance FromAttribute Text where
fromAttribute = Just
instance FromAttribute Int where
fromAttribute t = case decimal t of
Left _ -> Nothing
Right m | snd m /= "" ->
Nothing
Right (v, _) -> Just v
instance FromAttribute Double where
fromAttribute t = case double t of
Left _ -> Nothing
Right m | snd m /= "" ->
Nothing
Right (v, _) -> Just v
-- | This declares a new splice. Given a name, an attribute matcher,
-- and a handler function (which takes the context, the node, and the
-- specified attributes), it will pass the handler function the
-- provided attributes or return nothing, if the attributes are
-- missing / not deserializable.
--
-- Note that due to the dynamism (the handler function can have any
-- number of arguments, and the number / type of them is based on the
-- matcher), the types of this may be a little confusing (in
-- particular, the `k` contains a lot). This continuation-based style
-- lets us achieve this style, but the types suffer. It may be easier
-- to see via an example:
--
-- @
-- tag "posts" (attr "num" & attr "sort") $ \\ctxt node num sort -> ...
-- @
tag :: Text ->
(X.Node -> k -> Maybe (X.Node, FnSplice ctxt)) ->
(ctxt -> X.Node -> k) ->
Splices (FnSplice ctxt)
tag name match handle =
name ## do ctxt <- lift get
node <- getParamNode
case match node (handle ctxt node) of
Nothing -> do tellSpliceError $
"Invalid attributes for splice '" <>
name <> "'"
return []
Just (_, a) -> a
-- | A tag with no attributes.
tag' :: Text ->
(ctxt -> X.Node -> FnSplice ctxt) ->
Splices (FnSplice ctxt)
tag' name handle =
name ## do ctxt <- lift get
node <- getParamNode
handle ctxt node
-- | This combines two matchers together.
(&=) :: (X.Node -> k -> Maybe (X.Node, k')) ->
(X.Node -> k' -> Maybe (X.Node, a)) ->
X.Node ->
k -> Maybe (X.Node, a)
(&=) a1 a2 node k =
case a1 node k of
Nothing -> Nothing
Just (_, k') -> a2 node k'
-- | This specifies that an attribute should be present and
-- convertable to the type indicated by it's type.
attr :: FromAttribute a =>
Text ->
X.Node ->
(a -> t) ->
Maybe (X.Node, t)
attr name node k = case X.getAttribute name node >>= fromAttribute of
Nothing -> Nothing
Just a -> Just (node, k a)
-- | This specifies that an attribute is optional - if absent or not
-- convertable, 'Nothing' will be passed.
attrOpt :: FromAttribute a =>
Text ->
X.Node ->
(Maybe a -> t) ->
Maybe (X.Node, t)
attrOpt name node k =
Just (node, k (X.getAttribute name node >>= fromAttribute))