{-# 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.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 = Maybe Template -> ControllerT hs m (Maybe Template)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Template
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 = FilePath -> ControllerT hs m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return "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 = FunctionMap -> ControllerT hs m 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 = FilePath -> ControllerT hs m Template
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 = pageContent -> pageVal -> ControllerT hs m Value
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 :: pageContent -> pageVal -> ControllerT hs m Value
defaultLayoutObject pageContent :: pageContent
pageContent pageVal :: pageVal
pageVal = Value -> ControllerT hs m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ControllerT hs m Value)
-> Value -> ControllerT hs m Value
forall a b. (a -> b) -> a -> b
$
    [Pair] -> Value
object ["yield" Text -> pageContent -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= pageContent
pageContent, "page" Text -> pageVal -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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 :: FilePath -> FilePath -> a -> ControllerT hs m ()
renderLayout lfp :: FilePath
lfp fp :: FilePath
fp val :: a
val  = do
  Template
layout <- FilePath -> ControllerT hs m Template
forall (m :: * -> *) hs.
HasTemplates m hs =>
FilePath -> ControllerT hs m Template
getTemplate FilePath
lfp
  FilePath
viewDir <- ControllerT hs m FilePath
forall (m :: * -> *) hs.
HasTemplates m hs =>
ControllerT hs m FilePath
viewDirectory
  Template
view <- FilePath -> ControllerT hs m Template
forall (m :: * -> *) hs.
HasTemplates m hs =>
FilePath -> ControllerT hs m Template
getTemplate (FilePath
viewDir FilePath -> FilePath -> FilePath
</> FilePath
fp)
  let mime :: MimeType
mime = Text -> MimeType
defaultMimeLookup (Text -> MimeType) -> Text -> MimeType
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
fp
  Template -> Template -> a -> MimeType -> ControllerT hs m ()
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 :: Template -> Template -> a -> MimeType -> ControllerT hs m ()
renderLayoutTmpl layout :: Template
layout view :: Template
view val :: a
val mime :: MimeType
mime = do
  FunctionMap
fm <- ControllerT hs m FunctionMap
forall (m :: * -> *) hs.
HasTemplates m hs =>
ControllerT hs m FunctionMap
functionMap
  let pageContent :: Text
pageContent = Template -> FunctionMap -> Value -> Text
renderTemplate Template
view FunctionMap
fm (Value -> Text) -> Value -> Text
forall a b. (a -> b) -> a -> b
$ a -> Value
forall a. ToJSON a => a -> Value
toJSON a
val
  Value
value <- Text -> a -> ControllerT hs m Value
forall (m :: * -> *) hs pageContent pageVal.
(HasTemplates m hs, ToJSON pageContent, ToJSON pageVal) =>
pageContent -> pageVal -> ControllerT hs m Value
layoutObject Text
pageContent a
val
  let result :: Text
result = Template -> FunctionMap -> Value -> Text
renderTemplate Template
layout FunctionMap
fm Value
value
  Response -> ControllerT hs m ()
forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond (Response -> ControllerT hs m ())
-> Response -> ControllerT hs m ()
forall a b. (a -> b) -> a -> b
$ MimeType -> ByteString -> Response
ok MimeType
mime (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ [MimeType] -> ByteString
L.fromChunks ([MimeType] -> ByteString)
-> (Text -> [MimeType]) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MimeType -> [MimeType] -> [MimeType]
forall a. a -> [a] -> [a]
:[]) (MimeType -> [MimeType])
-> (Text -> MimeType) -> Text -> [MimeType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MimeType
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
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 :: FilePath -> a -> ControllerT hs m ()
render fp :: FilePath
fp val :: a
val = do
  Maybe Template
mlayout <- ControllerT hs m (Maybe Template)
forall (m :: * -> *) hs.
HasTemplates m hs =>
ControllerT hs m (Maybe Template)
defaultLayout
  case Maybe Template
mlayout of
    Nothing -> FilePath -> a -> ControllerT hs m ()
forall (m :: * -> *) hs a.
(HasTemplates m hs, ToJSON a) =>
FilePath -> a -> ControllerT hs m ()
renderPlain FilePath
fp a
val
    Just layout :: Template
layout -> do
      FilePath
viewDir <- ControllerT hs m FilePath
forall (m :: * -> *) hs.
HasTemplates m hs =>
ControllerT hs m FilePath
viewDirectory
      Template
view <- FilePath -> ControllerT hs m Template
forall (m :: * -> *) hs.
HasTemplates m hs =>
FilePath -> ControllerT hs m Template
getTemplate (FilePath
viewDir FilePath -> FilePath -> FilePath
</> FilePath
fp)
      let mime :: MimeType
mime = Text -> MimeType
defaultMimeLookup (Text -> MimeType) -> Text -> MimeType
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
fp
      Template -> Template -> a -> MimeType -> ControllerT hs m ()
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 :: FilePath -> a -> ControllerT hs m ()
renderPlain fp :: FilePath
fp val :: a
val = do
  FunctionMap
fm <- ControllerT hs m FunctionMap
forall (m :: * -> *) hs.
HasTemplates m hs =>
ControllerT hs m FunctionMap
functionMap
  FilePath
dir <- ControllerT hs m FilePath
forall (m :: * -> *) hs.
HasTemplates m hs =>
ControllerT hs m FilePath
viewDirectory
  Template
tmpl <- FilePath -> ControllerT hs m Template
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 ([MimeType] -> ByteString)
-> (Text -> [MimeType]) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MimeType -> [MimeType] -> [MimeType]
forall a. a -> [a] -> [a]
:[]) (MimeType -> [MimeType])
-> (Text -> MimeType) -> Text -> [MimeType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MimeType
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$
          Template -> FunctionMap -> Value -> Text
renderTemplate Template
tmpl FunctionMap
fm (Value -> Text) -> Value -> Text
forall a b. (a -> b) -> a -> b
$ a -> Value
forall a. ToJSON a => a -> Value
toJSON a
val
  let mime :: MimeType
mime = Text -> MimeType
defaultMimeLookup (Text -> MimeType) -> Text -> MimeType
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
fp
  Response -> ControllerT hs m ()
forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond (Response -> ControllerT hs m ())
-> Response -> ControllerT hs m ()
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 :: FilePath -> ControllerT hs m Template
defaultGetTemplate fp :: FilePath
fp = do
  MimeType
contents <- IO MimeType -> ControllerT hs m MimeType
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MimeType -> ControllerT hs m MimeType)
-> IO MimeType -> ControllerT hs m MimeType
forall a b. (a -> b) -> a -> b
$ FilePath -> IO MimeType
S.readFile FilePath
fp
  case Text -> Either FilePath Template
compileTemplate (Text -> Either FilePath Template)
-> (MimeType -> Text) -> MimeType -> Either FilePath Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MimeType -> Text
decodeUtf8 (MimeType -> Either FilePath Template)
-> MimeType -> Either FilePath Template
forall a b. (a -> b) -> a -> b
$ MimeType
contents of
    Left str :: FilePath
str -> FilePath -> ControllerT hs m Template
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
str
    Right tmpl :: Template
tmpl -> Template -> ControllerT hs m Template
forall (m :: * -> *) a. Monad m => a -> m a
return Template
tmpl

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

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

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