fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Multi-Field Form Validation added.

Browse Source
This commit is contained in:
SJost 2017-10-08 17:04:43 +02:00
parent b472f2ca27
commit 99edd912dc
2 changed files with 54 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
src/Handler/Term.hs
View File

@ -35,8 +35,13 @@ getShowTermsR = do
<li>
<a href=@{EditTermExistR $ termName term}>
#{termToText $ termName term}
von #{formatTimeGerWD $ termStart term}
bis #{formatTimeGerWD $ termEnd term}
#{formatTimeGerWD $ termStart term}
bis #{formatTimeGerWD $ termEnd term}.
<h4>
Vorlesungszeit:
#{formatTimeGerWD $ termLectureStart term}
bis #{formatTimeGerWD $ termLectureEnd term}.
$if termActive term
(Semester ist aktiv)
$with holidays <- termHolidays term
@ -87,29 +92,15 @@ postEditTermR = do
runDB $ repsert (TermKey $ termName res) res
let tid = termToText $ termName res
let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."
let okay = termStart res `withinTerm` termName res
let order = termStart res <= termEnd res
setMessage [shamlet| #{msg}
$if not okay
<p .bg-warning>
Bezeichner des Semesters und Datum des Starts stimmen nicht überein!
$if not order
<p .bg-danger>
Ende des Semesters liegt vor dem Start!
|]
setMessage [shamlet| #{msg} |]
redirect ShowTermsR
| otherwise -> redirect ShowTermsR
(FormMissing,_) -> do
setMessage "Keine Formulardaten erhalten."
wdgtTermForm formWidget formEnctype
(FormFailure errorMsgs,_) -> do
setMessage [shamlet|
<p .bg-danger>Fehler:
<ul>
$forall errmsg <- errorMsgs
<li> #{errmsg}
|]
(FormFailure _,_) -> do
setMessage "Bitte Eingabe korrigieren."
wdgtTermForm formWidget formEnctype
wdgtTermForm :: (ToWidget UniWorX a) => a -> Enctype -> Handler Html
@ -122,8 +113,8 @@ wdgtTermForm formWidget formEnctype = do
$(widgetFile "generic_form")
newTermForm :: Maybe Term -> Form Term
newTermForm template =
renderBootstrap3 bsHorizontalDefault $ Term
newTermForm template html = do
(result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ Term
<$> areq termNewField (bfs ("Semester" :: Text)) (termName <$> template)
<*> areq dayField (bfs ("Erster Tag" :: Text)) (termStart <$> template)
<*> areq dayField (set "Letzer Tag") (termEnd <$> template)
@ -131,7 +122,22 @@ newTermForm template =
<*> areq dayField (bfs ("Beginn Vorlesungen" :: Text)) (termLectureStart <$> template)
<*> areq dayField (set "Ende Vorlesungen") (termLectureEnd <$> template)
<*> areq checkBoxField (set "Aktiv") (termActive <$> template)
-- <* bootstrapSubmit (bsSubmit "Semester bearbeiten")
-- <* bootstrapSubmit (bsSubmit "Semester bearbeiten")
return $ case result of
FormSuccess termResult
| errorMsgs <- validateTerm termResult
, not $ null errorMsgs ->
(FormFailure errorMsgs,
[whamlet|
<div class="alert alert-danger">
<h4> Fehler:
<ul>
$forall errmsg <- errorMsgs
<li> #{errmsg}
^{widget}
|]
)
_ -> (result, widget)
where set txt = FieldSettings
{ fsLabel = txt
, fsTooltip = Nothing

26
src/Handler/Utils/Term.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
@ -35,3 +36,28 @@ termField mustexist = checkMMap checkTerm termToText textField
return $ if mustexist && isNothing term
then Left $ errTextFreigabe ti
else res
validateTerm :: Term -> [Text]
validateTerm (Term{..}) =
[ msg | (False, msg) <-
[ --startOk
( termStart `withinTerm` termName
, "Jahreszahl im Namenskürzel stimmt nicht mit Semesterbeginn überein."
)
, -- endOk
( termStart < termEnd
, "Semester darf nicht enden, bevor es begann."
)
, -- startOk
( termLectureStart < termLectureEnd
, "Vorlesungszeit muss vor ihrem Ende anfgangen."
)
, -- lecStartOk
( termStart <= termLectureStart
, "Semester muss vor der Vorlesungszeit beginnen."
)
, -- lecEndOk
( termEnd >= termLectureEnd
, "Vorlesungszeit muss vor dem Semester enden."
)
] ]