Quick digestive-functors and heist tutorial

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE OverloadedStrings   #-}

module Main where

import           Blaze.ByteString.Builder   (toByteString)

import           Control.Applicative        (Applicative (..), (<$>), (<*>))
import           Control.Monad.IO.Class     (MonadIO)

import           Control.Monad.Trans.Either (EitherT, runEitherT)

import qualified Data.ByteString.Char8      as BS (putStrLn)

import           Data.Maybe                 (isJust)
import qualified Data.Text                  as T

import           Heist
import qualified Heist.Interpreted          as HI

import           Text.Digestive

import           Text.Digestive.Heist       (bindDigestiveSplices)

data User = User
    { uUsername :: T.Text
    , uEmail    :: T.Text
    , uKarma    :: Int
    } deriving (Show)

userForm :: Monad m => Form T.Text m User
userForm = User
    <$> "username"  .: text Nothing
    <*> "email"     .: check "invalid email" validateEmail (text Nothing)
    <*> pure 0
  where
    -- in our example, we don't need to use `m` monad for validation. if we
    -- were to need that, we could use `checkM` instead of `check`, and
    -- then use a validation function with type `T.Text -> m Bool` for same m.
    validateEmail :: T.Text -> Bool
    validateEmail = isJust . T.find (== '@')

initHeistState :: forall m. MonadIO m => IO (HeistState m)
initHeistState = do
    st <- runEitherT $ initHeist heistConfig
    case st of
      Left errors -> error $ unlines errors
      Right state -> return state
  where
    heistConfig :: HeistConfig m
    -- In HeistConfig, we need to specify what load-time, compile-time and
    -- run-time splices will be available. We also have options for
    -- attibute splices(QUESTION: why we don't have time distinction in
    -- attribute splices?) and locations of template files.
    heistConfig = HeistConfig
      {
      -- default interpreted splices consists of
      -- `apply`, `bind`, `ignore` and `markdown` splices
        hcInterpretedSplices = defaultInterpretedSplices
      -- this is same as default interpreted splices
      , hcLoadTimeSplices = defaultLoadTimeSplices
      -- I'm not using compiled splices because of the reason explained
      -- in first paragraphs
      , hcCompiledSplices = []
      -- .. also here.
      , hcAttributeSplices = []
      -- list of template locations. A template location is an
      -- IO action that either returns a list of error strings,
      -- or a map from template locations to template files.
      -- We're using `loadTemplates` from Heist package for loading
      -- templates from a folder. Subfolders are also traversed.
      , hcTemplateLocations = [loadTemplates "templates"]
      }

renderForm :: HeistState IO -> View T.Text -> IO ()
renderForm hs formView = do

    maybeBuilder <- HI.renderTemplate (bindDigestiveSplices formView hs) "user_form"
    case maybeBuilder of
      Nothing ->
        -- This happens when wrong template name is given to `renderTemplate`.
        error "template is not rendered"
      Just (builder, mimeType) -> do
        -- here `builder` has type `Blaze.ByteString.Builder.Builder` from
        -- `blaze-builder` package. It's used to efficiently build
        -- ByteStrings.
        BS.putStrLn (toByteString builder)
        print mimeType

main :: IO ()
main = do
    hs <- initHeistState

    -- we need to dynamically bind splices related with form generation
    -- while rendering `user_form` heist template. for that we need to use
    -- `Heist.Interpreter` functions to modify interpereted splices of our
    -- heist state.
    --
    -- To get form splices, we need to pass some POST or GET request as
    -- ByteString to `Text.Digestive.View.getForm` or `postForm`. Then we
    -- can use `Text.Digestive.Heist.digestiveSplices` to get required
    -- splices to render form.

    -- Here the type T.Text comes from first argument of userForm's return
    -- type
    (formView, maybeUser) <- postForm "userform" userForm (const $ return [])
                               :: IO (View T.Text, Maybe User)
    print maybeUser
    renderForm hs formView


    -- Case 2, POST request with invalid email address
    let env path = return $ case path of
                              ["userform", "username"] -> [TextInput "testuser"]
                              ["userform", "email"] -> [TextInput "invalidemail"]
                              _ -> []
    (formView', maybeUser') <- postForm "userform" userForm env
    print maybeUser'
    renderForm hs formView'

    -- Case 3, POST request with valid email address and username
    let env' path = return $ case path of
                               ["userform", "username"] -> [TextInput "testuser"]
                               ["userform", "email"] -> [TextInput "valid@email.com"]
                               _ -> []
    (formView'', maybeUser'') <- postForm "userform" userForm env'
    print maybeUser''
    renderForm hs formView''

<dfForm>
    <dfLabel ref="username">Username: </dfLabel>
    <dfInputText ref="username" />
    <dfErrorList ref="username" />

    <dfLabel ref="email">Email: </dfLabel>
    <dfInputText ref="email" />
    <dfErrorList ref="email" />

    <dfInputSubmit />
</dfForm>

Nothing

<form method='POST' enctype='application/x-www-form-urlencoded'>
    <label for='userform.username'>Username: </label>
    <input type='text' id='userform.username' name='userform.username' value />


    <label for='userform.email'>Email: </label>
    <input type='text' id='userform.email' name='userform.email' value />
    <ul><li>invalid email</li></ul>

    <input type='submit' />
</form>

Nothing

<form method='POST' enctype='application/x-www-form-urlencoded'>
    <label for='userform.username'>Username: </label>
    <input type='text' id='userform.username' name='userform.username' value='testuser' />


    <label for='userform.email'>Email: </label>
    <input type='text' id='userform.email' name='userform.email' value='invalidemail' />
    <ul><li>invalid email</li></ul>

    <input type='submit' />
</form>

Just (User {uUsername = "testuser", uEmail = "valid@email.com", uKarma = 0})

<form method='POST' enctype='application/x-www-form-urlencoded'>
    <label for='userform.username'>Username: </label>
    <input type='text' id='userform.username' name='userform.username' value='testuser' />


    <label for='userform.email'>Email: </label>
    <input type='text' id='userform.email' name='userform.email' value='valid@email.com' />


    <input type='submit' />
</form>