{-# LANGUAGE ExistentialQuantification #-}
module Web.JobsUi.Forms where
import Web.Spock
import Control.Monad.Trans
import Web.JobsUi.Internal.Types
import Data.Foldable
import Text.Digestive ((.:))
import Data.Traversable
import qualified Text.Digestive as D
import qualified Text.Digestive.Lucid.Html5 as D
import qualified Lucid as H
import qualified Data.Text as T
secureForm :: T.Text -> (D.View Html -> Html) -> D.View Html -> Action v Html
secureForm route formHtml view = do
csrfToken <- getCsrfToken
pure $ D.form view route $ do
H.input_ [ H.type_ "hidden", H.name_ "__csrf_token", H.value_ csrfToken ]
formHtml view
data EditJob
= forall info. EditJob
{ ejJobInfo :: JobInfo info
, ejPayload :: [(T.Text, T.Text)]
}
editJobForm :: Either (JobInfo info) EditJob -> D.Form Html (Action' ()) EditJob
editJobForm = \case
Left info ->
EditJob info <$> createPayload info
Right edit ->
pure edit
createPayload :: JobInfo info -> D.Form Html (Action' ()) [(T.Text, T.Text)]
createPayload info = D.monadic $ do
fmap sequenceA $ for (jiInputs info) $ \Param{..} ->
case paramInputType of
TextInput ->
pure $ (.:)
paramDesc
( D.validateM
( fmap (fmap (paramDesc,))
. fmap (D.resultMapError H.toHtml)
. liftIO . paramValidation
. trim
)
(D.text Nothing)
)
TextOptions opts -> do
opts' <- liftIO opts
pure $ (.:)
paramDesc
( D.choice
( map (\x -> ((paramDesc, x), H.toHtml x)) opts'
)
Nothing
)
editJobFormView :: JobInfo info -> D.View Html -> Html
editJobFormView info view = H.div_ $ do
H.table_ $ do
H.tr_ $ do
H.th_ [ H.scope_ "col" ] ""
H.th_ [ H.scope_ "col" ] ""
for_ (jiInputs info) $ \Param{..} ->
case paramInputType of
TextInput -> H.tr_ $ do
H.td_ $ D.label paramDesc view (H.toHtml paramDesc)
H.td_ $ do
D.inputText paramDesc view
D.errorList paramDesc view
TextOptions _ -> H.tr_ $ do
H.td_ $ D.label paramDesc view (H.toHtml paramDesc)
H.td_ $ do
D.inputSelect paramDesc view
D.errorList paramDesc view
D.inputSubmit "Create"
jobToEditJob :: Job -> EditJob
jobToEditJob job@Job{..} =
EditJob jobInfo (zip (paramDesc <$> jiInputs jobInfo) (getJobParams job))
trim :: T.Text -> T.Text
trim = T.filter (/='\r') . T.reverse . T.dropWhile (==' ') . T.reverse . T.dropWhile (==' ')