{- | Defines the forms used in the app -} {-# 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 ----------- -- Utils -- ----------- -- | A form with hidden csrf token 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 ----------- -- Forms -- ----------- -- | Definition of an edit job data type data EditJob = forall info. EditJob { ejJobInfo :: JobInfo info , ejPayload :: [(T.Text, T.Text)] } -- | Definition of a form and it's validation editJobForm :: Either (JobInfo info) EditJob -> D.Form Html (Action' ()) EditJob editJobForm = \case Left info -> EditJob info <$> createPayload info Right edit -> -- not handling this correctly yet 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 ) -- | Defining the view for the edit event form 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 spaces from both sides trim :: T.Text -> T.Text trim = T.filter (/='\r') . T.reverse . T.dropWhile (==' ') . T.reverse . T.dropWhile (==' ')