diff --git a/FragenSJ.txt b/FragenSJ.txt index 3f8319750..c9ecfa3d6 100644 --- a/FragenSJ.txt +++ b/FragenSJ.txt @@ -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?! diff --git a/models b/models index d36a1e4c2..a2a86d9f0 100644 --- a/models +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index dff753a63..a060fdc93 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 742abd7b1..f0da6d33d 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 06a7d8fb1..9016e2a09 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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.|] diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index e8143d998..ca0a66bc0 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -53,6 +53,8 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () + + ---------- -- Maps -- ---------- diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 0bd3ec14c..46242770b 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index d5966efdf..85ae9f2ee 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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"