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

chore(exam): show exam occurrences in participants views for tutorial and course

Browse Source
This commit is contained in:
Steffen Jost 2024-12-12 18:28:15 +01:00
parent 6d172c8259
commit eab6b6363d
8 changed files with 107 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/courses/courses/de-de-formal.msg
View File

@ -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

1
messages/uniworx/categories/courses/courses/en-eu.msg
View File

@ -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

27
src/Handler/Course/Users.hs
View File

@ -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

10
src/Handler/Sheet/Form.hs
View File

@ -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

12
src/Handler/Tutorial/Users.hs
View File

@ -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 $

98
src/Handler/Utils/Form.hs
View File

@ -1886,27 +1886,46 @@ userField onlySuggested suggestions = Field{..}
<option value=#{email}>
#{email} (#{dName})
|]
fieldParse (filter (not . Text.null) -> t : _) _ = runExceptT . fmap Just $ do
email <- either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . CI.mk . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
case lookupExpr of
Nothing -> return $ Left email
Just lookupExpr' -> do
dbRes <- fmap (setOf $ folded . _Value). liftHandler . runDB . E.select $ do
fieldParse (filter (not . Text.null) . fmap T.strip -> t : _) _ = runExceptT . fmap Just $
case Email.validate (encodeUtf8 t) of
Right (CI.mk . decodeUtf8 . Email.toByteString -> email) -> case lookupExpr of
Nothing -> return $ Left email
Just lookupExpr' -> do
dbRes <- fmap (setOf $ folded . _Value). liftHandler . runDBRead . E.select $ do
user <- lookupExpr'
E.where_ $ user E.^. UserIdent `E.ciEq` E.val email
E.||. ( user E.^. UserDisplayEmail `E.ciEq` E.val email
E.&&. unique UserDisplayEmail user
)
E.||. ( user E.^. UserEmail `E.ciEq` E.val email
E.&&. unique UserEmail user
)
return $ user E.^. UserId
if | Set.null dbRes
-> return $ Left email
| [uid] <- Set.toList dbRes
-> return $ Right uid
| otherwise
-> throwE $ SomeMessage MsgAmbiguousEmail
Left notAnEmail
| Just lookupExpr' <- lookupExpr -> do -- allow known user entry by avs-nr or corporate-id for convenience
dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
user <- lookupExpr'
E.where_ $ user E.^. UserIdent `E.ciEq` E.val email
E.||. ( user E.^. UserDisplayEmail `E.ciEq` E.val email
E.&&. unique UserDisplayEmail user
)
E.||. ( user E.^. UserEmail `E.ciEq` E.val email
E.&&. unique UserEmail user
)
E.where_ $ ( E.justVal t E.==. user E.^. UserCompanyPersonalNumber
E.&&. uniqueTX user UserCompanyPersonalNumber
)
E.||. ( E.justVal t E.==. user E.^. UserMatrikelnummer
E.&&. uniqueTX user UserMatrikelnummer
)
E.limit 3 -- we need a single answer only, so we optimize the query to stop at multiple answers
return $ user E.^. UserId
if | Set.null dbRes
-> return $ Left email
| [uid] <- Set.toList dbRes
-> return $ Right uid
| otherwise
-> throwE $ SomeMessage MsgAmbiguousEmail
let errMsg m = SomeMessage $ SomeMessages [SomeMessage MsgAvsPersonNo, text2message "/", SomeMessage MsgCompanyPersonalNumber, text2message t, m]
case dbRes of
[uid] -> return $ Right $ E.unValue uid
_ | Text.any Char.isAlpha t -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{notAnEmail})|]
[] -> throwE $ errMsg $ SomeMessage $ bool MsgUnknown MsgUnknownOrNotAllowed onlySuggested
_ -> throwE $ errMsg $ SomeMessage MsgAmbiguous
| otherwise -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{notAnEmail})|]
fieldParse _ _ = return $ Right Nothing
unique field user = case lookupExpr of
@ -1919,6 +1938,14 @@ userField onlySuggested suggestions = Field{..}
)
Nothing -> E.true
uniqueTX user field | Just lookupExpr' <- lookupExpr = E.not_ . E.exists $ do
user' <- lookupExpr'
E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
E.&&. ( user' E.^. UserMatrikelnummer E.==. user E.^. field
E.||. user' E.^. UserCompanyPersonalNumber E.==. user E.^. field
)
uniqueTX _ _ = E.true
knownUserField :: forall m.
( MonadHandler m
@ -1976,23 +2003,24 @@ knownUserField onlySuggested suggestions = Field{..}
#{email} (#{dName})
|]
fieldParse (filter (not . Text.null) . fmap T.strip -> t : _) _
| Just lookupExpr' <- lookupExpr = case Email.validate (encodeUtf8 t) of
| Text.any Char.isAlpha t, Just lookupExpr' <- lookupExpr
= case Email.validate (encodeUtf8 t) of
Left notAnEmail -> return $ Left $ SomeMessage $ MsgInvalidEmail [st|#{t} (#{notAnEmail})|]
Right (CI.mk . decodeUtf8 . Email.toByteString -> email) -> do
dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
user <- lookupExpr'
E.where_ $ E.val email `E.ciEq` user E.^. UserIdent -- UserIdent is unique
E.||. E.val email `E.ciEq` user E.^. UserEmail -- UserEmail is unique
E.||. ( E.val email `E.ciEq` user E.^. UserDisplayEmail
E.&&. uniqueCI user UserDisplayEmail -- ensure uniqueness
)
E.limit 3 -- we need a single answer only, so we optimize the query to stop at multiple answers
return $ user E.^. UserId
case dbRes of
[uid] -> return $ Right $ Just $ E.unValue uid
[] -> return $ Left $ SomeMessage MsgUnknownEmail
_ -> return $ Left $ SomeMessage MsgAmbiguousEmail
Left _notAnEmail -> do -- allow known user entry by avs-nr or corporate-id for convenience
dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
user <- lookupExpr'
E.where_ $ E.val email `E.ciEq` user E.^. UserIdent -- UserIdent is unique
E.||. E.val email `E.ciEq` user E.^. UserEmail -- UserEmail is unique
E.||. ( E.val email `E.ciEq` user E.^. UserDisplayEmail
E.&&. uniqueCI user UserDisplayEmail -- ensure uniqueness
)
E.limit 3 -- we need a single answer only, so we optimize the query to stop at multiple answers
return $ user E.^. UserId
case dbRes of
[uid] -> return $ Right $ Just $ E.unValue uid
[] -> return $ Left $ SomeMessage MsgUnknownEmail
_ -> return $ Left $ SomeMessage MsgAmbiguousEmail
| Just lookupExpr' <- lookupExpr = do -- allow known user entry by avs-nr or corporate-id for convenience
dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
user <- lookupExpr'
E.where_ $ ( E.justVal t E.==. user E.^. UserCompanyPersonalNumber

3
src/Utils.hs
View File

@ -332,6 +332,9 @@ text2AlphaNumPlus =
let aNumPlus = Set.fromList oks <> alphaNum
in Text.filter (`Set.member` aNumPlus)
-- hasAlpha :: Text -> Bool
-- hasAlpha = Text.any Char.isAlpha
-- | Convert or remove all non-ascii characters, e.g. for filenames
text2asciiAlphaNum :: Text -> Text
text2asciiAlphaNum = text2AlphaNumPlus ['-','_']

1
src/Utils/DB.hs
View File

@ -245,6 +245,7 @@ put v = do
forM_ (persistUniqueKeys v) deleteBy
insert v
-- | Deprecated, use selectFirst instead.
selectMaybe :: forall record backend m.
( MonadIO m
, PersistQueryRead backend