CourseForm works without redirect only
This commit is contained in:
SJost
parent
075872dbbe
commit
40cf5ec858
@ -9,3 +9,11 @@
|
||||
|
||||
- Handler.Utils.Form.FormIdentifier: Still needed?
|
||||
- Verification of Ownership during Edit?
|
||||
- Versionen für Studenten/Korrektoren/Lecturers/Admins?!
|
||||
|
||||
- Sheets: Multiple Files
|
||||
|
||||
** Page pageActions
|
||||
- i18n der Links?
|
||||
- Berechtigungen prüfen?
|
||||
=> Eigener Constructor statt NavbarLeft/Right?!
|
||||
|
||||
2
models
2
models
@ -96,9 +96,11 @@ Sheet
|
||||
name Text
|
||||
description Html Maybe
|
||||
type SheetType
|
||||
grouping SheetGroup
|
||||
markingText Html Maybe
|
||||
activeFrom UTCTime
|
||||
activeTo UTCTime
|
||||
visibleFrom UTCTime Maybe
|
||||
hintFrom UTCTime Maybe
|
||||
solutionFrom UTCTime Maybe
|
||||
created UTCTime
|
||||
|
||||
@ -200,7 +200,10 @@ isAuthorizedDB TermEditR _ = adminAccess Nothing
|
||||
isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing
|
||||
isAuthorizedDB CourseNewR _ = lecturerAccess Nothing
|
||||
isAuthorizedDB (CourseEditR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (SheetNewR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (SheetListR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (SheetNewR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (SheetEditR t c s) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (SheetDelR t c s) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseEditIDR cID) _ = do
|
||||
courseId <- decrypt cID
|
||||
courseLecturerAccess courseId
|
||||
|
||||
@ -198,7 +198,7 @@ courseEditHandler course = do
|
||||
})) -> do -- edit existing course
|
||||
let tident = unTermKey tid
|
||||
actTime <- liftIO getCurrentTime
|
||||
addMessage "debug" [shamlet| #{show res}|]
|
||||
-- addMessage "debug" [shamlet| #{show res}|]
|
||||
runDB $ do
|
||||
old <- get cid
|
||||
case old of
|
||||
@ -208,7 +208,7 @@ courseEditHandler course = do
|
||||
-- if ((entityKey <$> existing) /= Just cid)
|
||||
-- then addMessageI "danger" $ MsgCourseEditDupShort tident csh
|
||||
-- else do
|
||||
addMessage "debug" $ fromMaybe [shamlet|No description given.|] $ cfDesc res
|
||||
-- addMessage "debug" $ fromMaybe [shamlet|No description given.|] $ cfDesc res
|
||||
-- update cid
|
||||
-- [ CourseName =. cfName res
|
||||
-- , CourseDescription =. cfDesc res
|
||||
@ -242,7 +242,7 @@ courseEditHandler course = do
|
||||
-- if (isNothing updOkay)
|
||||
-- then do
|
||||
addMessageI "info" $ MsgCourseEditOk tident csh
|
||||
redirect $ CourseListTermR tid
|
||||
-- redirect $ CourseListTermR tid
|
||||
-- else addMessageI "danger" $ MsgCourseEditDupShort tident csh
|
||||
|
||||
(FormFailure _) -> addMessageI "warning" MsgInvalidInput
|
||||
|
||||
@ -38,7 +38,9 @@ data SheetForm = SheetForm
|
||||
{ sfName :: Text
|
||||
, sfComment :: Maybe Html
|
||||
, sfType :: SheetType
|
||||
, sfGroup :: SheetGroup
|
||||
, sfMarkingText :: Maybe Html
|
||||
, sfVisibleFrom :: Maybe UTCTime
|
||||
, sfActiveFrom :: UTCTime
|
||||
, sfActiveTo :: UTCTime
|
||||
, sfSheetF :: Maybe FileInfo
|
||||
@ -46,6 +48,7 @@ data SheetForm = SheetForm
|
||||
, sfHintF :: Maybe FileInfo
|
||||
, sfSolutionFrom :: Maybe UTCTime
|
||||
, sfSolutionF :: Maybe FileInfo
|
||||
, sfSheetId :: Maybe SheetId
|
||||
}
|
||||
|
||||
|
||||
@ -54,18 +57,21 @@ makeSheetForm cid template = identForm FIDsheet $ \html -> do
|
||||
-- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :(
|
||||
-- Erstmal nur mit ZIP arbeiten
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
|
||||
<$> areq textField (fsb "Name") (sfName <$> template)
|
||||
<*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfMarkingText <$> template)
|
||||
<*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template)
|
||||
<$> areq textField (fsb "Name") (sfName <$> template)
|
||||
<*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfMarkingText <$> template)
|
||||
<*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGroup <$> template)
|
||||
--TODO: SICHTBARKEIT hinzunehmen
|
||||
<*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
|
||||
<*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template)
|
||||
<*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template)
|
||||
<*> fileAFormOpt (fsb "Aufgaben")
|
||||
<*> aopt utcTimeField (fsb "Hinweis ab") (sfHintFrom <$> template)
|
||||
<*> fileAFormOpt (fsb "Hinweis")
|
||||
<*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template)
|
||||
<*> fileAFormOpt (fsb "Lösung")
|
||||
<*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
|
||||
<*> aopt utcTimeField (fsb "Sichtbar ab") (sfVisibleFrom <$> template)
|
||||
<*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template)
|
||||
<*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template)
|
||||
<*> fileAFormOpt (fsb "Aufgabenstellung")
|
||||
<*> aopt utcTimeField (fsb "Hinweis ab") (sfHintFrom <$> template)
|
||||
<*> fileAFormOpt (fsb "Hinweis")
|
||||
<*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template)
|
||||
<*> fileAFormOpt (fsb "Lösung")
|
||||
<*> aopt hiddenField "EditSheetId" (sfSheetId <$> template)
|
||||
return $ case result of
|
||||
FormSuccess sheetResult
|
||||
| errorMsgs <- validateSheet sheetResult
|
||||
@ -82,7 +88,18 @@ makeSheetForm cid template = identForm FIDsheet $ \html -> do
|
||||
)
|
||||
_ -> (result, widget)
|
||||
where
|
||||
validateSheet _ = [] -- TODO
|
||||
validateSheet :: SheetForm -> [Text]
|
||||
validateSheet (SheetForm{..}) =
|
||||
[ msg | (False, msg) <-
|
||||
[ ( maybe True (sfActiveFrom >=) sfVisibleFrom
|
||||
, "Sichtbarkeit muss vor Beginn der Abgabefrist liegen."
|
||||
)
|
||||
, ( sfActiveTo >= sfActiveFrom
|
||||
, "Ende der Abgabefrist muss nach deren Beginn liegen."
|
||||
)
|
||||
-- TODO: continue here!!!
|
||||
] ]
|
||||
|
||||
|
||||
|
||||
fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
|
||||
@ -115,16 +132,23 @@ getSheetList courseEnt = do
|
||||
rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
|
||||
return (sid, sheet, (submissions, rated))
|
||||
let colSheets = mconcat
|
||||
[ headed "Blatt" $ toWgt . sheetName . snd3
|
||||
, headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
|
||||
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
|
||||
, headed "Bewertung" $ toWgt . show . sheetType . snd3
|
||||
, headed "Korrigiert" $ toWgt . snd . trd3
|
||||
, headed "Eingereicht" $ toWgt . fst . trd3
|
||||
-- TODO: only show edit button for allowed course assistants
|
||||
, headed "" $ \s -> linkButton "Edit" BCLink $ SheetEditR tid csh $ fst3 s
|
||||
]
|
||||
defaultLayout $ do
|
||||
[ headed "Blatt" $ toWgt . sheetName . snd3
|
||||
, headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
|
||||
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
|
||||
, headed "Bewertung" $ toWgt . show . sheetType . snd3
|
||||
, headed "Korrigiert" $ toWgt . snd . trd3
|
||||
, headed "Eingereicht" $ toWgt . fst . trd3
|
||||
-- TODO: only show edit button for allowed course assistants
|
||||
, headed "" $ \s -> linkButton "Edit" BCLink $ SheetEditR tid csh $ fst3 s
|
||||
]
|
||||
let pageActions =
|
||||
[ NavbarLeft $ MenuItem
|
||||
{ menuItemLabel = "Neues Übungsblatt"
|
||||
, menuItemRoute = SheetNewR tid csh
|
||||
, menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseNewR False
|
||||
}
|
||||
]
|
||||
defaultLinkLayout pageActions $ do
|
||||
setTitle $ toHtml $ T.append "Übungsblätter " csh
|
||||
if null sheets
|
||||
then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
|
||||
|
||||
@ -53,6 +53,8 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
||||
whenIsJust (Just x) f = f x
|
||||
whenIsJust Nothing _ = return ()
|
||||
|
||||
|
||||
|
||||
----------
|
||||
-- Maps --
|
||||
----------
|
||||
|
||||
@ -274,6 +274,14 @@ sheetTypeAFormReq d (Just (Normal p)) =
|
||||
-- TODO, offer options to choose between Normal/Bonus/Pass
|
||||
(Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p)
|
||||
|
||||
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
|
||||
sheetGroupAFormReq d (Just (Arbitrary n)) | n >= 1 =
|
||||
-- TODO, offer options to choose between Arbitrary/Registered/NoGroups
|
||||
Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just n)
|
||||
sheetGroupAFormReq d _other = -- TODO
|
||||
-- TODO, offer options to choose between Arbitrary/Registered/NoGroups
|
||||
Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1)
|
||||
|
||||
utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime
|
||||
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
|
||||
-- TODO: Verify whether this is UTC or local time from Browser
|
||||
|
||||
@ -54,6 +54,15 @@ data SheetType
|
||||
deriveJSON defaultOptions ''SheetType
|
||||
derivePersistFieldJSON "SheetType"
|
||||
|
||||
data SheetGroup
|
||||
= Arbitrary { maxParticipants :: Int }
|
||||
| RegisteredGroups
|
||||
| NoGroups
|
||||
deriving (Show, Read, Eq)
|
||||
deriveJSON defaultOptions ''SheetGroup
|
||||
derivePersistFieldJSON "SheetGroup"
|
||||
|
||||
|
||||
data ExamStatus = Attended | NoShow | Voided
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded)
|
||||
derivePersistField "ExamStatus"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user