From eab6b6363ded16136a5f0ddec1f1638098a6ff7a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 12 Dec 2024 18:28:15 +0100 Subject: [PATCH] chore(exam): show exam occurrences in participants views for tutorial and course --- .../courses/courses/de-de-formal.msg | 1 + .../categories/courses/courses/en-eu.msg | 1 + src/Handler/Course/Users.hs | 27 +++-- src/Handler/Sheet/Form.hs | 10 +- src/Handler/Tutorial/Users.hs | 12 +++ src/Handler/Utils/Form.hs | 98 ++++++++++++------- src/Utils.hs | 3 + src/Utils/DB.hs | 1 + 8 files changed, 107 insertions(+), 46 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index e0c589aba..c92b235e4 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -135,6 +135,7 @@ CourseUserTutorialsDeregistered count@Int64: Teilnehmer:in von #{show count} #{p CourseUserNoTutorialsDeregistered: Teilnehmer:in ist zu keinem der gewählten Kurse angemeldet CourseUserTutorials: Angemeldete Kurse CourseUserExams: Angemeldete Prüfungen +CourseUserExamOccurrences: Termine/Räume CourseUserSheets: Übungsblätter CsvColumnUserName: Voller Name des/der Teilnehmers/Teilnehmerin CsvColumnUserMatriculation: AVS Nummer des/der Teilnehmers/Teilnehmerin diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index d71d9178a..47123b096 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -135,6 +135,7 @@ CourseUserTutorialsDeregistered count: Sucessfully deregistered participant from CourseUserNoTutorialsDeregistered: Participant is not registered for any of the selected courses CourseUserTutorials: Registered courses CourseUserExams: Registered exams +CourseUserExamOccurrences: Occurrences/rooms CourseUserSheets: Exercise sheets CsvColumnUserName: Participant's full name CsvColumnUserMatriculation: Participant's AVS number diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index b5fe6ca51..f2742212f 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -10,6 +10,7 @@ module Handler.Course.Users , postCUsersR, getCUsersR , colUserSex' , colUserQualifications, colUserQualificationBlocked + , colUserExamOccurrences , _userQualifications ) where @@ -95,7 +96,7 @@ type UserTableData = DBRow ( Entity User , Entity CourseParticipant , Maybe CourseUserNoteId , ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial))) - , [Entity Exam] + , ([Entity Exam], [Entity ExamOccurrence]) , Maybe (Entity SubmissionGroup) , Map SheetName (SheetType SqlBackendKey, Maybe Points) , UserTableQualifications @@ -120,7 +121,10 @@ _userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe ( _userTutorials = _dbrOutput . _4 _userExams :: Lens' UserTableData [Entity Exam] -_userExams = _dbrOutput . _5 +_userExams = _dbrOutput . _5 . _1 + +_userExamOccurrences :: Lens' UserTableData [Entity ExamOccurrence] +_userExamOccurrences = _dbrOutput . _5 . _2 _userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup) _userSubmissionGroup = _dbrOutput . _6 . _Just @@ -165,6 +169,13 @@ colUserExams tid ssh csh = sortable (Just "exams") (i18nCell MsgCourseUserExams) (\(Entity _ Exam{..}) -> CExamR tid ssh csh examName EUsersR) (examName . entityVal) +colUserExamOccurrences :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) +colUserExamOccurrences _tid _ssh _csh = sortable (Just "exams") (i18nCell MsgCourseUserExamOccurrences) + $ \(view _userExamOccurrences -> exams') -> + let exams = sortOn (examOccurrenceName . entityVal) exams' + in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) $ listCell exams + (\(Entity _ ExamOccurrence{..}) -> wgtCell [whamlet|#{examOccurrenceName}:^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}|]) + colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserSex' = colUserSex $ hasUser . _userSex @@ -389,8 +400,9 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do courseQualis <- getCourseQualifications cid let cqids = entityKey <$> courseQualis tutorials <- selectList [ TutorialCourse ==. cid ] [] - exams <- selectList [ ExamCourse ==. cid ] [] - sheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] + exams <- selectList [ ExamCourse ==. cid ] [] + exOccs <- selectList [ ExamOccurrenceExam <-. fmap entityKey exams] [ Asc ExamOccurrenceId ] <&> Map.fromAscList . fmap (\ent -> (entityKey ent, ent)) + sheets <- selectList [ SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] personalisedSheets <- E.select . E.from $ \sheet -> do let hasPersonalised = E.exists . E.from $ \psFile -> E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId @@ -432,9 +444,11 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts' - exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams + exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams + -- ocs = filter (\(Entity oId _) -> any ((== Just oId) . examRegistrationOccurrence . entityVal) exams') exOccs + ocs = catMaybes [ Map.lookup oId exOccs | Entity{entityVal=ExamRegistration{examRegistrationOccurrence = Just oId}} <- exams' ] subs = Map.fromList $ map (over (_2 . _2) (views _entityVal submissionRatingPoints <=< assertM (views _entityVal submissionRatingDone)) . over _1 E.unValue . over (_2 . _1) E.unValue) subs' - return (user, participant, userNoteId, tuts, exs, subGroup, subs, qualis) + return (user, participant, userNoteId, tuts, (exs,ocs), subGroup, subs, qualis) dbtColonnade = colChoices dbtSorting = mconcat [ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header @@ -666,6 +680,7 @@ postCUsersR tid ssh csh = do , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh , guardOn hasExams . cap' $ colUserExams tid ssh csh + , guardOn hasExams . cap' $ colUserExamOccurrences tid ssh csh , pure . cap' $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (maybe mempty dateCell . preview (_Just . _userTableRegistration) . assertM' (has $ _userTableParticipant . _entityVal . _courseParticipantState . _CourseParticipantActive)) , pure . cap' $ sortable (Just "state") (i18nCell MsgCourseUserState) (i18nCell . view (_userTableParticipant . _entityVal . _courseParticipantState)) , guardOn (not $ null sheetList) . colUserSheets $ map (sheetName . entityVal) sheetList diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index ee01d5d4e..4bc636607 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -60,7 +60,7 @@ data SheetPersonalisedFilesForm = SheetPersonalisedFilesForm , spffAllowNonPersonalisedSubmission :: Bool } - + getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference) getFtIdMap sId = do allSheetFiles <- E.select . E.from $ \sheetFile -> do @@ -84,7 +84,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS return ((school, mSchoolAuthorshipStatement), course) sheetPersonalisedFilesForm <- makeSheetPersonalisedFilesForm $ template >>= sfPersonalF - let mkSheetForm + let mkSheetForm sfName sfDescription sfRequireExamRegistration @@ -130,7 +130,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS if | isn't _SchoolAuthorshipStatementModeNone schoolSheetAuthorshipStatementMode -> do wformSection MsgSheetAuthorshipStatementSection - let + let reqContentField :: AForm Handler I18nStoredMarkup reqContentField = formResultUnOpt mr' MsgSheetAuthorshipStatementContent `fmapAForm` i18nFieldA htmlField True (\_ -> Nothing) ("authorship-statement" :: Text) @@ -143,7 +143,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS if | not schoolSheetAuthorshipStatementAllowOther -> (pure SheetAuthorshipStatementModeEnabled, pure sfAuthorshipStatementExam', ) - <$> (fmap (traverse $ fmap authorshipStatementDefinitionContent) . traverse forcedContentField $ entityVal <$> mSchoolAuthorshipStatement) + <$> fmap (traverse $ fmap authorshipStatementDefinitionContent) (traverse (forcedContentField . entityVal) mSchoolAuthorshipStatement) | otherwise -> do examOpts <- let examFieldQuery = E.from $ \exam -> do @@ -205,7 +205,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS #{iconFileZip} \ _{MsgSheetPersonalisedFilesDownload} |] - listRoute <- for mbSheet $ \(sheetName -> shn) -> toTextUrl + listRoute <- for mbSheet $ \(sheetName -> shn) -> toTextUrl ( CourseR courseTerm courseSchool courseShorthand CUsersR , [ ("courseUsers-has-personalised-sheet-files" , toPathPiece shn diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 1f068722e..b7dbad725 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -75,6 +75,7 @@ postTUsersR tid ssh csh tutn = do , pure $ colUserMatriclenr isAdmin , pure $ colUserQualifications nowaday , pure $ colUserQualificationBlocked isAdmin nowaday + , pure $ colUserExamOccurrences tid ssh csh ] psValidator = def & defaultSortingByName @@ -87,6 +88,17 @@ postTUsersR tid ssh csh tutn = do csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"] qualOptions = qualificationsOptionList qualifications + -- pick earliest still open associated exam + _mbExam <- selectFirst + (-- ([ExamRegisterTo >=. Just now] ||. [ExamRegisterTo ==. Nothing]) ++ -- Reconsider: only allow exams with open registration? + ([ExamEnd >=. Just now] ||. [ExamEnd ==. Nothing]) ++ + [ ExamStart <=. Just now -- , ExamRegisterFrom <=. Just now + , ExamCourse ==. cid, ExamClosed ==. Nothing, ExamFinished ==. Nothing -- Reconsider: ExamFinished prevents publication of results - do we want this? + ]) [Asc ExamRegisterFrom, Asc ExamStart, Asc ExamRegisterTo, Asc ExamName] -- earliest still open exam + -- pick exam occurrences and tutors + -- TODO: !!!continue here!!! + + -- multiActionAOpts or similar, see FirmAction for another example let acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData) acts = Map.fromList $ diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 0f3e65c0b..73568b24e 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1886,27 +1886,46 @@ userField onlySuggested suggestions = Field{..}