{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-}
{-# LANGUAGE DefaultSignatures #-}
module Web.Simple.Templates
  ( HasTemplates(..), render, renderPlain, renderLayout, renderLayoutTmpl
  , defaultGetTemplate, defaultFunctionMap, defaultLayoutObject
  , H.fromList
  , Function(..), ToFunction(..), FunctionMap
  ) where

import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.Aeson.KeyMap as K
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import Data.Text.Encoding
import qualified Data.Vector as V
import Network.Mime
import System.FilePath
import Web.Simple.Controller.Trans (ControllerT, respond)
import Web.Simple.Responses (ok)
import Web.Simple.Templates.Language

class Monad m => HasTemplates m hs where
  -- | The layout to use by default. Layouts are just templates that embed
  -- views. They are rendered with the a global object containing the rendered
  -- view in the \"yield\" field, and the object the view was rendered with in
  -- the \"page\" field. By default, no template is used.
  defaultLayout :: ControllerT hs m (Maybe Template)
  defaultLayout = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

  -- | The directory to look for views passed to 'render'. This defaults to
  -- \"views\", so
  --
  -- @
  -- render \"index.html.tmpl\" ...
  -- @
  --
  -- will look for a view template in \"views/index.html.tmpl\".
  viewDirectory :: ControllerT hs m FilePath
  viewDirectory = forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"views"

  -- | A map of pure functions that can be called from within a template. See
  -- 'FunctionMap' and 'Function' for details.
  functionMap :: ControllerT hs m FunctionMap
  functionMap = forall (m :: * -> *) a. Monad m => a -> m a
return FunctionMap
defaultFunctionMap

  -- | Function to use to get a template. By default, it looks in the
  -- 'viewDirectory' for the given file name and compiles the file into a
  -- template. This can be overriden to, for example, cache compiled templates
  -- in memory.
  getTemplate :: FilePath -> ControllerT hs m Template
  default getTemplate :: MonadIO m => FilePath -> ControllerT hs m Template
  getTemplate = forall (m :: * -> *) hs.
(HasTemplates m hs, MonadIO m) =>
FilePath -> ControllerT hs m Template
defaultGetTemplate

  -- | The `Value` passed to a layout given the rendered view template and the
  -- value originally passed to the view template. By default, produces an
  -- `Object` with "yield", containing the rendered view, and "page", containing
  -- the value originally passed to the view.
  layoutObject :: (ToJSON pageContent, ToJSON pageVal)
               => pageContent -> pageVal -> ControllerT hs m Value
  layoutObject = forall (m :: * -> *) hs pageContent pageVal.
(HasTemplates m hs, ToJSON pageContent, ToJSON pageVal) =>
pageContent -> pageVal -> ControllerT hs m Value
defaultLayoutObject

defaultLayoutObject :: (HasTemplates m hs, ToJSON pageContent, ToJSON pageVal)
                    => pageContent -> pageVal -> ControllerT hs m Value
defaultLayoutObject :: forall (m :: * -> *) hs pageContent pageVal.
(HasTemplates m hs, ToJSON pageContent, ToJSON pageVal) =>
pageContent -> pageVal -> ControllerT hs m Value
defaultLayoutObject pageContent
pageContent pageVal
pageVal = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    [Pair] -> Value
object [Key
"yield" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= pageContent
pageContent, Key
"page" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= pageVal
pageVal]

-- | Render a view using the layout named by the first argument.
renderLayout :: (HasTemplates m hs, ToJSON a)
             => FilePath -> FilePath -> a -> ControllerT hs m ()
renderLayout :: forall (m :: * -> *) hs a.
(HasTemplates m hs, ToJSON a) =>
FilePath -> FilePath -> a -> ControllerT hs m ()
renderLayout FilePath
lfp FilePath
fp a
val  = do
  Template
layout <- forall (m :: * -> *) hs.
HasTemplates m hs =>
FilePath -> ControllerT hs m Template
getTemplate FilePath
lfp
  FilePath
viewDir <- forall (m :: * -> *) hs.
HasTemplates m hs =>
ControllerT hs m FilePath
viewDirectory
  Template
view <- forall (m :: * -> *) hs.
HasTemplates m hs =>
FilePath -> ControllerT hs m Template
getTemplate (FilePath
viewDir FilePath -> FilePath -> FilePath
</> FilePath
fp)
  let mime :: MimeType
mime = Identifier -> MimeType
defaultMimeLookup forall a b. (a -> b) -> a -> b
$ FilePath -> Identifier
T.pack forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
fp
  forall (m :: * -> *) hs a.
(HasTemplates m hs, ToJSON a) =>
Template -> Template -> a -> MimeType -> ControllerT hs m ()
renderLayoutTmpl Template
layout Template
view a
val MimeType
mime


-- | Same as 'renderLayout' but uses already compiled layouts.
renderLayoutTmpl :: (HasTemplates m hs, ToJSON a)
                 => Template -> Template -> a
                 -> S.ByteString -> ControllerT hs m ()
renderLayoutTmpl :: forall (m :: * -> *) hs a.
(HasTemplates m hs, ToJSON a) =>
Template -> Template -> a -> MimeType -> ControllerT hs m ()
renderLayoutTmpl Template
layout Template
view a
val MimeType
mime = do
  FunctionMap
fm <- forall (m :: * -> *) hs.
HasTemplates m hs =>
ControllerT hs m FunctionMap
functionMap
  let pageContent :: Identifier
pageContent = Template -> FunctionMap -> Value -> Identifier
renderTemplate Template
view FunctionMap
fm forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON a
val
  Value
value <- forall (m :: * -> *) hs pageContent pageVal.
(HasTemplates m hs, ToJSON pageContent, ToJSON pageVal) =>
pageContent -> pageVal -> ControllerT hs m Value
layoutObject Identifier
pageContent a
val
  let result :: Identifier
result = Template -> FunctionMap -> Value -> Identifier
renderTemplate Template
layout FunctionMap
fm Value
value
  forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond forall a b. (a -> b) -> a -> b
$ MimeType -> ByteString -> Response
ok MimeType
mime forall a b. (a -> b) -> a -> b
$ [MimeType] -> ByteString
L.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> MimeType
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Identifier
result

-- | Renders a view template with the default layout and a global used to
-- evaluate variables in the template.
render :: (HasTemplates m hs , Monad m, ToJSON a)
       => FilePath -- ^ Template to render
       -> a -- ^ Aeson `Value` to pass to the template
       -> ControllerT hs m ()
render :: forall (m :: * -> *) hs a.
(HasTemplates m hs, Monad m, ToJSON a) =>
FilePath -> a -> ControllerT hs m ()
render FilePath
fp a
val = do
  Maybe Template
mlayout <- forall (m :: * -> *) hs.
HasTemplates m hs =>
ControllerT hs m (Maybe Template)
defaultLayout
  case Maybe Template
mlayout of
    Maybe Template
Nothing -> forall (m :: * -> *) hs a.
(HasTemplates m hs, ToJSON a) =>
FilePath -> a -> ControllerT hs m ()
renderPlain FilePath
fp a
val
    Just Template
layout -> do
      FilePath
viewDir <- forall (m :: * -> *) hs.
HasTemplates m hs =>
ControllerT hs m FilePath
viewDirectory
      Template
view <- forall (m :: * -> *) hs.
HasTemplates m hs =>
FilePath -> ControllerT hs m Template
getTemplate (FilePath
viewDir FilePath -> FilePath -> FilePath
</> FilePath
fp)
      let mime :: MimeType
mime = Identifier -> MimeType
defaultMimeLookup forall a b. (a -> b) -> a -> b
$ FilePath -> Identifier
T.pack forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
fp
      forall (m :: * -> *) hs a.
(HasTemplates m hs, ToJSON a) =>
Template -> Template -> a -> MimeType -> ControllerT hs m ()
renderLayoutTmpl Template
layout Template
view a
val MimeType
mime

-- | Same as 'render' but without a template.
renderPlain :: (HasTemplates m hs, ToJSON a)
            => FilePath -- ^ Template to render
            -> a -- ^ Aeson `Value` to pass to the template
            -> ControllerT hs m ()
renderPlain :: forall (m :: * -> *) hs a.
(HasTemplates m hs, ToJSON a) =>
FilePath -> a -> ControllerT hs m ()
renderPlain FilePath
fp a
val = do
  FunctionMap
fm <- forall (m :: * -> *) hs.
HasTemplates m hs =>
ControllerT hs m FunctionMap
functionMap
  FilePath
dir <- forall (m :: * -> *) hs.
HasTemplates m hs =>
ControllerT hs m FilePath
viewDirectory
  Template
tmpl <- forall (m :: * -> *) hs.
HasTemplates m hs =>
FilePath -> ControllerT hs m Template
getTemplate (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
fp)
  let pageContent :: ByteString
pageContent =
        [MimeType] -> ByteString
L.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> MimeType
encodeUtf8 forall a b. (a -> b) -> a -> b
$
          Template -> FunctionMap -> Value -> Identifier
renderTemplate Template
tmpl FunctionMap
fm forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON a
val
  let mime :: MimeType
mime = Identifier -> MimeType
defaultMimeLookup forall a b. (a -> b) -> a -> b
$ FilePath -> Identifier
T.pack forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
fp
  forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond forall a b. (a -> b) -> a -> b
$ MimeType -> ByteString -> Response
ok MimeType
mime ByteString
pageContent

defaultGetTemplate :: (HasTemplates m hs, MonadIO m)
                   => FilePath -> ControllerT hs m Template
defaultGetTemplate :: forall (m :: * -> *) hs.
(HasTemplates m hs, MonadIO m) =>
FilePath -> ControllerT hs m Template
defaultGetTemplate FilePath
fp = do
  MimeType
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO MimeType
S.readFile FilePath
fp
  case Identifier -> Either FilePath Template
compileTemplate forall b c a. (b -> c) -> (a -> b) -> a -> c
. MimeType -> Identifier
decodeUtf8 forall a b. (a -> b) -> a -> b
$ MimeType
contents of
    Left FilePath
str -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
str
    Right Template
tmpl -> forall (m :: * -> *) a. Monad m => a -> m a
return Template
tmpl

defaultFunctionMap :: FunctionMap
defaultFunctionMap :: FunctionMap
defaultFunctionMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList
  [ (Identifier
"length", forall a. ToFunction a => a -> Function
toFunction Value -> Value
valueLength)
  , (Identifier
"null", forall a. ToFunction a => a -> Function
toFunction Value -> Value
valueNull)]

valueLength :: Value -> Value
valueLength :: Value -> Value
valueLength (Array Array
arr) = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int
V.length Array
arr
valueLength (Object Object
obj) = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> Int
K.size Object
obj
valueLength (String Identifier
str) = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ Identifier -> Int
T.length Identifier
str
valueLength Value
Null = forall a. ToJSON a => a -> Value
toJSON (Int
0 :: Int)
valueLength Value
_ = forall a. HasCallStack => FilePath -> a
error FilePath
"length only valid for arrays, objects and strings"

valueNull :: Value -> Value
valueNull :: Value -> Value
valueNull (Array Array
arr) = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Bool
V.null Array
arr
valueNull (Object Object
obj) = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> Bool
K.null Object
obj
valueNull (String Identifier
str) = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ Identifier -> Bool
T.null Identifier
str
valueNull Value
Null = forall a. ToJSON a => a -> Value
toJSON Bool
True
valueNull Value
_ = forall a. HasCallStack => FilePath -> a
error FilePath
"null only valid for arrays, objects and strings"