Form Missing eliminated for GET request

This commit is contained in:
SJost 2018-06-12 11:47:26 +02:00
parent af6d97454d
commit a5428bfc30
4 changed files with 48 additions and 14 deletions

View File

@ -5,6 +5,8 @@ Page n@Int64: #{tshow n}
TermEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert.
TermNewTitle: Semester editiere/anlegen.
InvalidInput: Eingaben bitte korrigieren.
Term: Semester
TermPlaceholder: W/S + vierstellige Jahreszahl
CourseNewOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt.
CourseEditOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich geändert.
@ -55,3 +57,4 @@ TermsHeading: Semesterübersicht
NumCourses n@Int64: #{tshow n} Kurse
CloseAlert: Schliessen

View File

@ -127,24 +127,26 @@ postCShowR tid csh = do
getCourseNewR :: Handler Html
getCourseNewR = do
-- TODO: Defaults für Semester hier ermitteln und übergeben
courseEditHandler Nothing
courseEditHandler True Nothing
postCourseNewR :: Handler Html
postCourseNewR = courseEditHandler Nothing
postCourseNewR = courseEditHandler False Nothing
getCEditR :: TermId -> Text -> Handler Html
getCEditR tid csh = do
course <- runDB $ getBy $ CourseTermShort tid csh
courseEditHandler course
courseEditHandler True course
postCEditR :: TermId -> Text -> Handler Html
postCEditR = getCEditR
postCEditR tid csh = do
course <- runDB $ getBy $ CourseTermShort tid csh
courseEditHandler False course
getCourseEditIDR :: CryptoUUIDCourse -> Handler Html
getCourseEditIDR cID = do
cIDKey <- getsYesod appCryptoIDKey
courseID <- UUID.decrypt cIDKey cID
courseEditHandler =<< runDB (getEntity courseID)
courseEditHandler True =<< runDB (getEntity courseID)
courseDeleteHandler :: Handler Html -- not called anywhere yet
@ -158,8 +160,8 @@ courseDeleteHandler = undefined
redirect $ TermCourseListR $ cfTerm res
-}
courseEditHandler :: Maybe (Entity Course) -> Handler Html
courseEditHandler course = do
courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html
courseEditHandler isGet course = do
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course
case result of
@ -250,6 +252,7 @@ courseEditHandler course = do
-- else addMessageI "danger" $ MsgCourseEditDupShort tident csh
(FormFailure _) -> addMessageI "warning" MsgInvalidInput
(FormMissing) | isGet -> return ()
other -> addMessage "error" $ [shamlet| Error: #{show other}|]
let formTitle = "Kurs editieren/anlegen" :: Text
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute

View File

@ -133,13 +133,14 @@ termEditHandler term = do
newTermForm :: Maybe Term -> Form Term
newTermForm template html = do
renderMessage <- getMessageRender
(result, widget) <- flip (renderAForm FormStandard) html $ Term
<$> areq termNewField (bfs ("Semester" :: Text)) (termName <$> template)
<*> areq dayField (bfs ("Erster Tag" :: Text)) (termStart <$> template)
<*> areq dayField (bfs ("Letzer Tag" :: Text)) (termEnd <$> template)
<$> areq termNewField (fslpI MsgTerm (renderMessage MsgTermPlaceholder)) (termName <$> template)
<*> areq dayField (fsl ("Erster Tag" :: Text)) (termStart <$> template)
<*> areq dayField (fsl ("Letzer Tag" :: Text)) (termEnd <$> template)
<*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined
<*> areq dayField (bfs ("Beginn Vorlesungen" :: Text)) (termLectureStart <$> template)
<*> areq dayField (bfs ("Ende Vorlesungen" :: Text)) (termLectureEnd <$> template)
<*> areq dayField (fsl "Beginn Vorlesungen") (termLectureStart <$> template)
<*> areq dayField (fsl ("Ende Vorlesungen" :: Text)) (termLectureEnd <$> template)
<*> areq checkBoxField (bfs ("Aktiv" :: Text)) (termActive <$> template)
<* submitButton
return $ case result of

View File

@ -378,12 +378,39 @@ utcTimeField = Field
showTime = fromString . (formatTime germanTimeLocale fieldTimeFormat)
fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX
fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
fsm = bfs -- TODO: get rid of Bootstrap
fsb :: Text -> FieldSettings site
fsb :: Text -> FieldSettings site -- DEPRECATED
fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
fsl :: Text -> FieldSettings UniWorX
fsl label =
FieldSettings { fsLabel = (SomeMessage label)
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = []
}
fslp :: Text -> Text -> FieldSettings UniWorX
fslp label placeholder =
FieldSettings { fsLabel = (SomeMessage label)
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = [("placeholder", placeholder)]
}
fslpI :: RenderMessage UniWorX msg => msg -> Text -> FieldSettings UniWorX
fslpI label placeholder =
FieldSettings { fsLabel = (SomeMessage label)
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = [("placeholder", placeholder)]
}
addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
where