1 {-# LANGUAGE OverloadedStrings #-}
    2 module Databrary.View.Form
    3   ( FormHtml
    4   , field
    5   , inputText
    6   , inputTextarea
    7   , inputPassword
    8   , inputCheckbox
    9   , inputSelect
   10   , inputEnum
   11   , inputDate
   12   , inputFile
   13   , inputHidden
   14   , csrfForm
   15   , htmlForm
   16   ) where
   17 
   18 import Control.Applicative ((<|>))
   19 import Control.Monad (when)
   20 import Control.Monad.Reader (reader)
   21 import Control.Monad.Trans.Class (lift)
   22 import Control.Monad.Trans.Control (liftWith)
   23 import qualified Data.ByteString as BS
   24 import qualified Data.ByteString.Char8 as BSC
   25 import Data.Foldable (fold)
   26 import qualified Data.Text as T
   27 import Data.Time.Format (formatTime, defaultTimeLocale)
   28 import qualified Text.Blaze.Internal as M
   29 import qualified Text.Blaze.Html5 as H
   30 import qualified Text.Blaze.Html5.Attributes as HA
   31 
   32 import Databrary.Ops
   33 import Databrary.Has (view)
   34 import Databrary.Model.Enum
   35 import Databrary.Model.Time
   36 import Databrary.Model.Token
   37 import Databrary.Model.Identity
   38 import Databrary.Action
   39 import Databrary.HTTP.Form
   40 import Databrary.HTTP.Form.Errors
   41 import Databrary.HTTP.Form.View
   42 import Databrary.View.Html
   43 import Databrary.View.Template
   44 
   45 import {-# SOURCE #-} Databrary.Controller.Angular
   46 
   47 type FormHtmlM f = FormViewT f M.MarkupM
   48 type FormHtml f = FormHtmlM f ()
   49 
   50 pathId :: FormHtmlM f H.AttributeValue
   51 pathId = reader (byteStringValue . formPathBS)
   52 
   53 value :: FormHtmlM f (Maybe BS.ByteString)
   54 value = do
   55   val <- reader formDatum
   56   return $ case val of
   57     FormDatumNone -> Nothing
   58     FormDatumJSON _ -> Nothing -- that's weird
   59     FormDatumBS b -> (BS.null b) `unlessUse` b
   60     FormDatumFlag -> Nothing
   61 
   62 errorList :: [FormErrorMessage] -> H.Html
   63 errorList [] = mempty
   64 errorList err =
   65   H.ul H.! HA.class_ "error-list" $ mapM_
   66     ((H.li H.! HA.class_ "error") . H.toHtml) err
   67 
   68 errorLists :: [(FormPath, FormErrorMessage)] -> H.Html
   69 errorLists [] = mempty
   70 errorLists err =
   71   H.dl H.! HA.class_ "error-list" $ mapM_ (\(p,e) -> do
   72     H.dt $ H.toHtml (formPathText p)
   73     H.dd H.! HA.class_ "error" $ H.toHtml e) err
   74 
   75 _label :: H.AttributeValue -> H.Html -> H.Html
   76 _label ref = H.label
   77   H.! HA.for ref
   78 
   79 type Field = H.AttributeValue -> Maybe BS.ByteString -> H.Html
   80 
   81 field :: T.Text -> Field -> FormHtml f
   82 field k sub = k .:> do
   83   ref <- pathId
   84   err <- formViewErrors
   85   val <- value
   86   lift $ H.label $ do
   87     H.toHtml k
   88     sub ref val
   89     errorList err
   90     H.br
   91 
   92 inputText :: H.ToValue a => Maybe a -> Field
   93 inputText val ref dat = H.input
   94   H.! HA.type_ "text"
   95   H.! HA.id    ref
   96   H.! HA.name  ref
   97   !? (HA.value <$> (fmap byteStringValue dat <|> fmap H.toValue val))
   98 
   99 inputTextarea :: H.ToMarkup a => Maybe a -> Field
  100 inputTextarea val ref dat = H.textarea
  101   H.! HA.id    ref
  102   H.! HA.name  ref
  103   $ fold $ fmap byteStringHtml dat <|> fmap H.toHtml val
  104 
  105 inputPassword :: Field
  106 inputPassword ref _ = H.input
  107   H.! HA.type_ "password"
  108   H.! HA.id    ref
  109   H.! HA.name  ref
  110 
  111 inputCheckbox :: Bool -> Field
  112 inputCheckbox val ref dat = H.input
  113   H.! HA.type_ "checkbox"
  114   H.! HA.id    ref
  115   H.! HA.name  ref
  116   H.!? (maybe val (const True) dat, HA.checked "checked")
  117 
  118 inputSelect :: H.ToMarkup b => Maybe BS.ByteString -> [(BS.ByteString, b)] -> Field
  119 inputSelect val choices ref dat = H.select
  120   H.! HA.id   ref
  121   H.! HA.name ref
  122   $ mapM_ (\(v, c) -> H.option
  123     H.!  HA.value (byteStringValue v)
  124     H.!? (any (v ==) (dat <|> val), HA.selected "selected")
  125     $ H.toHtml c) choices
  126 
  127 inputEnum :: forall a . DBEnum a => Bool -> Maybe a -> Field
  128 inputEnum req val =
  129   inputSelect (bshow <$> val) $ (if req then id else (("", "") :)) $ map (\(x, v) -> (bshow (x :: a), v)) pgEnumValues
  130   where bshow = BSC.pack . show . fromEnum
  131 
  132 inputDate :: Maybe Date -> Field
  133 inputDate val ref dat = H.input
  134   H.! HA.type_ "date"
  135   H.! HA.id    ref
  136   H.! HA.name  ref
  137   !? (HA.value <$> (fmap byteStringValue dat <|> fmap (H.toValue . formatTime defaultTimeLocale "%F") val))
  138 
  139 inputFile :: Field
  140 inputFile ref _ = H.input
  141   H.! HA.type_ "file"
  142   H.! HA.id    ref
  143   H.! HA.name  ref
  144 
  145 inputHidden :: H.ToValue a => a -> Field
  146 inputHidden val ref dat = H.input
  147   H.! HA.type_ "hidden"
  148   H.! HA.id    ref
  149   H.! HA.name  ref
  150   H.! HA.value (maybe (H.toValue val) byteStringValue dat)
  151 
  152 csrfForm :: RequestContext -> FormHtml f
  153 csrfForm =
  154     lift . extractFromIdentifiedSessOrDefault mempty (\s -> inputHidden (byteStringValue $ sessionVerf s) "csverf" Nothing) . view
  155 
  156 htmlForm :: T.Text -> ActionRoute a -> a -> FormHtml f -> (JSOpt -> H.Html) -> RequestContext -> FormHtml f
  157 htmlForm title act arg form body req = liftWith $ \run -> do
  158   htmlTemplate req (Just title) $ \js -> do
  159     actionForm act arg js $ do
  160       (_, err) <- run $ when (actionMethod act arg /= GET) (csrfForm req) >> form
  161       errorLists $ allFormErrors err
  162       H.input
  163         H.! HA.type_ "submit"
  164     body js