-- SPDX-FileCopyrightText: 2022-25 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-redundant-constraints #-} module Handler.Course.Users ( queryUser , makeCourseUserTable , postCUsersR, getCUsersR , colUserSex' , colUserQualifications, colUserQualificationBlocked , colUserExams, colUserExamOccurrences, colUserExamOccurrencesCheck, colUserExamOccurrencesCheckDB , _userQualifications ) where import Import import Utils.Form import Handler.Utils import Handler.Utils.Course import Handler.Utils.Company import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Experimental as X (from,on,table,innerJoin,leftJoin) import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Utils.TH import Handler.Course.Register (deregisterParticipant) import qualified Data.Set as Set import qualified Data.Map as Map import Data.Map ((!?)) import qualified Data.Text as Text import qualified Data.Vector as Vector import qualified Data.Csv as Csv import qualified Data.Conduit.List as C import qualified Data.CaseInsensitive as CI import Database.Persist.Sql (updateWhereCount) import Handler.Sheet.PersonalisedFiles import qualified Data.Text.Lazy as Lazy (Text) import qualified Data.Aeson as JSON type UserTableExpr = ( E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity SubmissionGroup)) `E.InnerJoin` E.SqlExpr (Maybe (Entity SubmissionGroupUser)) ) -- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a) -- forceUserTableType = id -- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions) -- This ought to ease refactoring the query queryUser :: UserTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant) queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryUserNote :: UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote)) queryUserNote = $(sqlLOJproj 3 2) querySubmissionGroup :: UserTableExpr -> E.SqlExpr (Maybe (Entity SubmissionGroup)) querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 3 3) userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User) , E.SqlExpr (Entity CourseParticipant) , E.SqlExpr (E.Value (Maybe (Key CourseUserNote))) , E.SqlExpr (Maybe (Entity SubmissionGroup)) ) userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` (subGroup `E.InnerJoin` subGroupUser)) = do -- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis E.on $ subGroup E.?. SubmissionGroupId E.==. subGroupUser E.?. SubmissionGroupUserSubmissionGroup E.on $ subGroupUser E.?. SubmissionGroupUserUser E.==. E.just (user E.^. UserId) E.&&. subGroup E.?. SubmissionGroupCourse E.==. E.just (E.val cid) E.on $ (note E.?. CourseUserNoteUser E.==. E.just (participant E.^. CourseParticipantUser)) E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid)) E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid return (user, participant, note E.?. CourseUserNoteId, subGroup) type UserTableQualifications = [(Entity Qualification, Entity QualificationUser, Maybe (Entity QualificationUserBlock))] type UserTableData = DBRow ( Entity User , Entity CourseParticipant , Maybe CourseUserNoteId , ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial))) , ([Entity Exam], [(Entity ExamOccurrence, Maybe UserDisplayName)]) -- Paired with ExamOccurrence is an examiner name, iff user is registered for another ExamOccurrence with this examiner, regardless of CourseId and time , Maybe (Entity SubmissionGroup) , Map SheetName (SheetType SqlBackendKey, Maybe Points) , UserTableQualifications ) instance HasEntity UserTableData User where hasEntity = _dbrOutput . _1 instance HasUser UserTableData where hasUser = _dbrOutput . _1 . _entityVal _userTableParticipant :: Lens' UserTableData (Entity CourseParticipant) _userTableParticipant = _dbrOutput . _2 _userTableRegistration :: Lens' UserTableData UTCTime _userTableRegistration = _userTableParticipant . _entityVal . _courseParticipantRegistration _userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId) _userTableNote = _dbrOutput . _3 _userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial))) _userTutorials = _dbrOutput . _4 _userExams :: Lens' UserTableData [Entity Exam] _userExams = _dbrOutput . _5 . _1 _userExamOccsDblExaminers :: Lens' UserTableData [(Entity ExamOccurrence, Maybe UserDisplayName)] _userExamOccsDblExaminers = _dbrOutput . _5 . _2 _userExamOccurrences :: Getter UserTableData [Entity ExamOccurrence] _userExamOccurrences = _userExamOccsDblExaminers . to (map fst) _userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup) _userSubmissionGroup = _dbrOutput . _6 . _Just _userSheets :: Lens' UserTableData (Map SheetName (SheetType SqlBackendKey, Maybe Points)) _userSheets = _dbrOutput . _7 -- _userQualifications :: Traversal' UserTableData [Entity Qualification] -- _userQualifications = _dbrOutput . _8 . (traverse _1) -- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualifications -> f UserTableQualifications _userCourseQualifications :: Lens' UserTableData UserTableQualifications _userCourseQualifications = _dbrOutput . _8 _userQualifications :: Getter UserTableData [Entity Qualification] _userQualifications = _userCourseQualifications . to (map fst3) colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserComment tid ssh csh = sortable (Just "note") (i18nCell MsgCourseUserNote) $ views (_dbrOutput . $(multifocusG 2) (_1 . _entityKey) _3) $ \(uid, mbNoteKey) -> maybeEmpty mbNoteKey $ const $ anchorCellM (courseLink <$> encrypt uid) (hasComment True) where courseLink = CourseR tid ssh csh . CUserR colUserTutorials :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserTutorials tid ssh csh = sortable (Just "tutorials") (i18nCell MsgCourseUserTutorials) $ \(view _userTutorials -> tuts') -> let tuts = sortOn (tutorialName . entityVal) $ (tuts' ^. _1) ++ (tuts' ^.. _2 . folded . _Just) in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell tuts $ anchorCell' (\(Entity _ Tutorial{..}) -> CTutorialR tid ssh csh tutorialName TUsersR) (tutorialName . entityVal) colUserExams :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserExams tid ssh csh = sortable (Just "exams") (i18nCell MsgCourseUserExams) $ \(view _userExams -> exams') -> let exams = sortOn (examName . entityVal) exams' in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell exams $ anchorCell' (\(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 "exam-occurrences") (i18nCell MsgCourseUserExamOccurrences) $ \(view _userExamOccurrences -> exams') -> let exams = sortOn (examOccurrenceName . entityVal) exams' in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) $ listCell exams examOccurrenceCell colUserExamOccurrencesCheck :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserExamOccurrencesCheck _tid _ssh _csh = sortable (Just "exam-occurrences") (i18nCell MsgCourseUserExamOccurrences) $ \(view _userExamOccsDblExaminers -> exams') -> let exams = sortOn (examOccurrenceName . entityVal .fst) exams' in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) $ listCell exams (\(exOcc, dblExmnr) -> let warnExaminer :: Widget = foldMapM (messageTooltip <=< messageI Warning . MsgExaminerReocurrence) dblExmnr in wgtCell warnExaminer <> examOccurrenceCell exOcc ) colUserExamOccurrencesCheckDB :: (IsDBTable (MForm Handler) c, MonadHandler (DBCell (MForm Handler)), HandlerSite (DBCell (MForm Handler)) ~ UniWorX) -- this type seems to be unusable+ => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell (MForm Handler) c) colUserExamOccurrencesCheckDB _tid _ssh _csh = sortable (Just "exam-occurrences") (i18nCell MsgCourseUserExamOccurrences) $ \row -> do let exams = sortOn (examOccurrenceName . entityVal) (row ^. _userExamOccurrences) uid = row ^. hasEntity . _entityKey (Map.fromAscList . map $(E.unValueN 2) -> dblExaminers) <- liftHandler . runDB $ E.select $ do (reg :& occ :& usr) <- X.from $ X.table @ExamRegistration `X.innerJoin` X.table @ExamOccurrence `X.on` (\(reg :& occ) -> occ E.^. ExamOccurrenceExam E.==. reg E.^. ExamRegistrationExam) `X.innerJoin` X.table @User `X.on` (\(_ :& occ :& usr) -> occ E.^. ExamOccurrenceExaminer E.?=. usr E.^. UserId) E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid E.&&. E.isJust (occ E.^. ExamOccurrenceExaminer) E.&&. occ E.^. ExamOccurrenceId `E.notIn` E.valList (entityKey <$> exams) E.&&. occ E.^. ExamOccurrenceExaminer `E.in_` E.valList (exams ^.. traverse . _entityVal . _examOccurrenceExaminer) E.orderBy [E.asc $ usr E.^. UserId] E.distinct $ pure (usr E.^. UserId, usr E.^. UserDisplayName) (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) $ listCell exams (\(Entity _ eo@ExamOccurrence{..}) -> wgtCell $ do $logDebugS "ExOccWarning" [st|Problems: #{tshow dblExaminers}. ExamOccurrence: #{tshow eo}|] warnExaminer <- case (dblExaminers !?) =<< examOccurrenceExaminer of Nothing -> pure mempty (Just exname) -> messageTooltip <$> messageI Warning (MsgExaminerReocurrence exname) [whamlet|^{warnExaminer}#{examOccurrenceName}:^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}|] ) colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserSex' = colUserSex $ hasUser . _userSex colUserSubmissionGroup :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserSubmissionGroup = sortable (Just "submission-group") (i18nCell MsgTableSubmissionGroup) $ foldMap (cell . toWidget) . preview (_userSubmissionGroup . _entityVal . _submissionGroupName) colUserSheets :: forall m c. IsDBTable m c => [SheetName] -> Cornice Sortable ('Cap 'Base) UserTableData (DBCell m c) colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns where caption = i18nCell MsgCourseUserSheets & cellAttrs <>~ [ ("uw-hide-column-header", "sheets") , ("uw-hide-column-default-hidden", "") ] userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c) userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) $ \dat -> flip (views $ _userSheets . at shn) dat $ \case Just (preview _grading -> Just Points{..}, Just points) -> i18nCell $ MsgTableAchievedOf points maxPoints Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgTableNotPassed MsgTablePassed $ Just True == gradingPassed grading' points _other -> mempty colUserQualifications :: forall m c. IsDBTable m c => Day -> Colonnade Sortable UserTableData (DBCell m c) colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $ let qualNamedValidCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidUntilCell cutoff qb qu in \(view _userCourseQualifications -> qualis) -> (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedValidCell colUserQualificationBlocked :: forall m c. IsDBTable m c => Bool -> Day -> Colonnade Sortable UserTableData (DBCell m c) colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ let qualNamedReasonCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidReasonCell' Nothing isAdmin cutoff qb qu in \(view _userCourseQualifications -> qualis) -> (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedReasonCell data UserTableCsv = UserTableCsv { csvUserSurname :: UserSurname , csvUserFirstName :: UserFirstName , csvUserName :: UserDisplayName , csvUserSex :: Maybe Sex , csvUserBirthday :: Maybe Day , csvUserMatriculation :: Maybe UserMatriculation , csvUserEPPN :: Maybe UserEduPersonPrincipalName , csvUserEmail :: UserEmail , csvUserQualifications :: [QualificationName] , csvUserSubmissionGroup :: Maybe SubmissionGroupName , csvUserRegistration :: UTCTime , csvUserNote :: Maybe StoredMarkup , csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName)) , csvUserExams :: [ExamName] , csvUserSheets :: Map SheetName (SheetType (), Maybe Points) } deriving (Eq, Ord, Read, Show, Generic) makeLenses_ ''UserTableCsv instance Csv.ToNamedRecord UserTableCsv where toNamedRecord UserTableCsv{..} = Csv.namedRecord $ [ "surname" Csv..= csvUserSurname , "first-name" Csv..= csvUserFirstName , "name" Csv..= csvUserName , "sex" Csv..= csvUserSex , "birthday" Csv..= csvUserBirthday , "matriculation" Csv..= csvUserMatriculation , "eduPersonPrincipalName" Csv..= csvUserEPPN , "email" Csv..= csvUserEmail , "qualifications" Csv..= CsvSemicolonList csvUserQualifications , "submission-group" Csv..= csvUserSubmissionGroup , "tutorial" Csv..= CsvSemicolonList (csvUserTutorials ^. _1) ] ++ [ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut) | (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2 ] ++ [ "exams" Csv..= CsvSemicolonList csvUserExams , "registration" Csv..= csvUserRegistration ] ++ [ encodeUtf8 (CI.foldedCase shn) Csv..= res | (shn, res) <- Map.toList csvUserSheets ] ++ [ "note" Csv..= csvUserNote ] instance CsvColumnsExplained UserTableCsv where csvColumnsExplanations _ = mconcat [ single "surname" MsgCsvColumnUserSurname , single "first-name" MsgCsvColumnUserFirstName , single "name" MsgCsvColumnUserName , single "sex" MsgCsvColumnUserSex , single "birthday" MsgCsvColumnUserBirthday , single "matriculation" MsgCsvColumnUserMatriculation , single "email" MsgCsvColumnUserEmail , single "submission-group" MsgCsvColumnUserSubmissionGroup , single "tutorial" MsgCsvColumnUserTutorial , single "exams" MsgCsvColumnUserExam , single "registration" MsgCsvColumnUserRegistration , single "note" MsgCsvColumnUserNote ] where single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget single k v = singletonMap k [whamlet|_{v}|] newtype UserCsvExportData = UserCsvExportData { csvUserIncludeSheets :: Bool } deriving (Eq, Ord, Read, Show, Generic) instance Default UserCsvExportData where def = UserCsvExportData False userTableCsvHeader :: Bool -> [Entity Tutorial] -> [Entity Sheet] -> UserCsvExportData -> Csv.Header userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $ [ "surname", "first-name", "name" ] ++ [ "sex" | showSex ] ++ [ "matriculation", "eduPersonPrincipalName", "email", "study-features"] ++ [ "tutorial" | hasEmptyRegGroup ] ++ map (encodeUtf8 . CI.foldedCase) regGroups ++ [ "exams", "registration" ] ++ guardOnM csvUserIncludeSheets [ encodeUtf8 $ CI.foldedCase sheetName | Entity _ Sheet{..} <- sheets ] ++ [ "note" ] where hasEmptyRegGroup = has (folded . _entityVal . _tutorialRegGroup . _Nothing) tuts regGroups = Set.toList $ setOf (folded . _entityVal . _tutorialRegGroup . _Just) tuts data UserTableJson = UserTableJson { jsonUserSurname :: UserSurname , jsonUserFirstName :: UserFirstName , jsonUserName :: UserDisplayName , jsonUserSex :: Maybe (Maybe Sex) , jsonUserMatriculation :: Maybe UserMatriculation , jsonUserEPPN :: Maybe UserEduPersonPrincipalName , jsonUserEmail :: UserEmail , jsonUserQualifications :: Set QualificationName , jsonUserSubmissionGroup :: Maybe SubmissionGroupName , jsonUserRegistration :: UTCTime , jsonUserNote :: Maybe Lazy.Text , jsonUserTutorials :: Set TutorialName , jsonUserTutorialGroups :: Map (CI Text) (Maybe TutorialName) , jsonUserExams :: Set ExamName , jsonUserSheets :: Map SheetName UserTableJsonSheetResult } deriving (Generic) data UserTableJsonSheetResult = UserTableJsonSheetResult { jsonSheetType :: SheetType UserTableJsonSheetTypeExamPartRef , jsonPoints :: Maybe Points } deriving (Generic) data UserTableJsonSheetTypeExamPartRef = UserTableJsonSheetTypeExamPartRef { jsonExam :: ExamName , jsonExamPart :: ExamPartNumber } deriving (Generic) deriveToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } ''UserTableJsonSheetTypeExamPartRef deriveToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } ''UserTableJsonSheetResult instance ToJSON UserTableJson where toJSON UserTableJson{..} = JSON.object $ catMaybes [ pure $ "surname" JSON..= jsonUserSurname , pure $ "first-name" JSON..= jsonUserFirstName , pure $ "name" JSON..= jsonUserName , ("sex" JSON..=) <$> jsonUserSex , ("matriculation" JSON..=) <$> jsonUserMatriculation , ("eduPersonPrincipalName" JSON..=) <$> jsonUserEPPN , pure $ "email" JSON..= jsonUserEmail , ("qualifications" JSON..=) <$> assertM' (not . onull) jsonUserQualifications , ("submission-group" JSON..=) <$> jsonUserSubmissionGroup , pure $ "registration" JSON..= jsonUserRegistration , ("note" JSON..=) <$> jsonUserNote , ("tutorials" JSON..=) <$> assertM' (not . onull) jsonUserTutorials , ("tutorial-groups" JSON..=) <$> assertM' (any $ is _Just) jsonUserTutorialGroups , ("exams" JSON..=) <$> assertM' (not . onull) jsonUserExams , ("sheets" JSON..=) <$> assertM' (any $ has (to jsonPoints . _Just)) jsonUserSheets ] data CourseUserAction = CourseUserSendMail | CourseUserRegisterTutorial | CourseUserRegisterExam | CourseUserSetSubmissionGroup | CourseUserReRegister | CourseUserDeregister | CourseUserDownloadPersonalisedSheetFiles deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe CourseUserAction instance Finite CourseUserAction nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''CourseUserAction id data CourseUserActionData = CourseUserSendMailData | CourseUserDeregisterData { deregisterSelfImposed :: Maybe (Text, Bool {- no-show -}) } | CourseUserRegisterTutorialData { registerTutorial :: TutorialId } | CourseUserRegisterExamData { registerExam :: (ExamId, Maybe ExamOccurrenceId) } | CourseUserSetSubmissionGroupData { setSubmissionGroup :: Maybe SubmissionGroupName } | CourseUserReRegisterData | CourseUserDownloadPersonalisedSheetFilesData { downloadPersonalisedFilesForSheet :: SheetName , downloadPersonalisedFilesAnonMode :: PersonalisedSheetFilesDownloadAnonymous } deriving (Eq, Ord, Read, Show, Generic) makeCourseUserTable :: forall h p cols act act'. ( Functor h, ToSortable h, Ord act, PathPiece act, RenderMessage UniWorX act -- , HandlerSite (DBCell (MForm Handler)) ~ UniWorX, MonadHandler (DBCell (MForm Handler)) -- for colUserExamOccurrencesCheckDB, but this does not work at all , AsCornice h p UserTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))) cols ) => CourseId -> Map act (AForm Handler act') -> (UserTableExpr -> E.SqlExpr (E.Value Bool)) -> cols -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData)) -> Maybe (Csv.Name -> Bool) -> DB (FormResult (act', Set UserId), Widget) makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute Course{..} <- getJust cid courseQualis <- getCourseQualifications cid let cqids = entityKey <$> courseQualis tutorials <- selectList [ TutorialCourse ==. cid ] [] 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 E.where_ $ E.not_ (sheet E.^. SheetAllowNonPersonalisedSubmission) E.||. hasPersonalised E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.orderBy [ E.desc $ sheet E.^. SheetActiveTo , E.desc $ sheet E.^. SheetActiveFrom ] return $ sheet E.^. SheetName -- -- psValidator has default sorting and filtering showSex <- getShowSex let dbtIdent = "courseUsers" :: Text dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q) dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjSimple $ \(user, participant, E.Value userNoteId, subGroup) -> do tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] [] usrExams :: [(Entity ExamRegistration, E.Value (Maybe UserId), E.Value (Maybe UserDisplayName))] <- E.select $ do (reg :& _occ :& usr) <- X.from $ X.table @ExamRegistration `X.leftJoin` X.table @ExamOccurrence `X.on` (\(reg :& occ) -> occ E.?. ExamOccurrenceId E.==. reg E.^. ExamRegistrationOccurrence) `X.leftJoin` X.table @User `X.on` (\(_ :& occ :& usr) -> E.joinV (occ E.?. ExamOccurrenceExaminer) E.==. usr E.?. UserId) E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val (entityKey user) pure (reg, usr E.?. UserId, usr E.?. UserDisplayName) subs' <- E.select . E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do E.on $ submissionUser E.?. SubmissionUserSubmission E.==. submission E.?. SubmissionId E.on $ E.just (sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet E.&&. submissionUser E.?. SubmissionUserUser E.==. E.just (E.val $ entityKey user) E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return ( sheet E.^. SheetName , ( sheet E.^. SheetType , submission ) ) qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser `E.LeftOuterJoin` qualificationBlock) -> do E.on $ qualificationUser E.^. QualificationUserId E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser E.&&. qualificationBlock `isLatestBlockBefore` E.now_ E.on $ qualificationUser E.^. QualificationUserQualification E.==. qualification E.^. QualificationId E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val (entityKey user) E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids E.orderBy [E.asc $ qualification E.^. QualificationShorthand] -- we should sort by CourseQualificationSortOrder instead, but since we have not seen a course with multiple qualifications yet, we take a shortcut here return (qualification, qualificationUser, qualificationBlock) let 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 . fst3) usrExams) exams usrDblExaminer :: Map UserId (Set ExamRegistrationId) usrDblExaminer = Map.filter ((1 <) . Set.size) $ Map.fromListWith (<>) [(examiner, Set.singleton reg) | (Entity{entityKey=reg}, E.Value (Just examiner), _) <- usrExams] checkUsrDbl :: Maybe UserId -> Maybe UserDisplayName -> Maybe UserDisplayName checkUsrDbl (Just exid) exnm | isJust (usrDblExaminer !? exid) = exnm checkUsrDbl _ _ = Nothing ocs = [ (occ, checkUsrDbl exUsrId exUsrName) | (Entity{entityVal=ExamRegistration{examRegistrationOccurrence = Just _oId@((exOccs !?) -> Just occ)}}, E.Value exUsrId, E.Value exUsrName) <- usrExams] 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,ocs), subGroup, subs, qualis) dbtColonnade = colChoices dbtSorting = mconcat [ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header , single $ sortUserSurname queryUser -- needed for initial sorting , single $ sortUserDisplayName queryUser -- needed for initial sorting , single $ sortUserEmail queryUser , single $ sortUserMatriclenr queryUser , sortUserSex (to queryUser . to (E.^. UserSex)) , single ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) , single ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date E.subSelectMaybe . E.from $ \edit -> do E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) return . E.max_ $ edit E.^. CourseUserNoteEditTime ) , single ("tutorials" , SortColumn $ queryUser >>> \user -> E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial E.&&. tutorial E.^. TutorialCourse E.==. E.val cid E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId return . E.min_ $ tutorial E.^. TutorialName ) , single ("exams" , SortColumn $ queryUser >>> \user -> E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam E.&&. exam E.^. ExamCourse E.==. E.val cid E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId return . E.min_ $ exam E.^. ExamName ) , single ("exam-occurrences", SortColumn $ queryUser >>> \user -> E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do E.on $ examOccurrence E.^. ExamOccurrenceId E.=?. examRegistration E.^. ExamRegistrationOccurrence E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam E.&&. exam E.^. ExamCourse E.==. E.val cid E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.&&. E.isJust (examRegistration E.^. ExamRegistrationOccurrence) return $ E.arrayAggWith E.AggModeDistinct (examOccurrence E.^. ExamOccurrenceName) [E.asc $ examOccurrence E.^. ExamOccurrenceName] ) , single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) , single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState)) , mconcat [ single ( SortingKey $ "sheet-" <> sheetName , SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.where_ $ submission E.^. SubmissionSheet E.==. E.val shId return $ submission E.^. SubmissionRatingPoints ) | Entity shId Sheet{..} <- sheets ] ] where single = uncurry Map.singleton dbtFilter = mconcat [ single $ fltrUserNameLink queryUser , single $ fltrUserEmail queryUser , single $ fltrUserMatriclenr queryUser , single $ fltrUserNameEmail queryUser , fltrUserSex (to queryUser . to (E.^. UserSex)) , single ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion -> E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId ) , single ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion -> E.from $ \(exam `E.InnerJoin` examRegistration) -> do E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam E.where_ $ exam E.^. ExamCourse E.==. E.val cid E.&&. E.hasInfix (exam E.^. ExamName) (E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.&&. examRegistration E.^. ExamRegistrationUser E.==.queryUser row E.^. UserId ) -- , ("course-registration", error "TODO") -- TODO -- , ("course-user-note", error "TODO") -- TODO , single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) , single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState)) , single ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> ifNothing criterion E.true $ \shn -> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.&&. sheet E.^. SheetName E.==. E.val shn ) --, fltrRelevantStudyFeaturesTerms (to $ -- \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) -- , queryUser t E.^. UserId -- )) --, fltrRelevantStudyFeaturesDegree (to $ -- \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) -- , queryUser t E.^. UserId -- )) --, fltrRelevantStudyFeaturesSemester (to $ -- \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) -- , queryUser t E.^. UserId -- )) ] where single = uncurry Map.singleton dbtFilterUI mPrev = mconcat $ [ prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt (courseParticipantStateIsActiveField . Just $ SomeMessage MsgTableNoFilter) (fslI MsgCourseParticipantStateIsActiveFilter) , fltrUserNameEmailUI mPrev , fltrUserMatriclenrUI mPrev ] ++ [ fltrUserSexUI mPrev | showSex ] ++ [ prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgTableSubmissionGroup) , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial) , prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam) --, fltrRelevantStudyFeaturesDegreeUI mPrev --, fltrRelevantStudyFeaturesTermsUI mPrev --, fltrRelevantStudyFeaturesSemesterUI mPrev ] ++ [ prismAForm (singletonFilter "has-personalised-sheet-files". maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) . optionsF $ map E.unValue personalisedSheets) (fslI MsgCourseUserHasPersonalisedSheetFilesFilter) | not $ null personalisedSheets ] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } dbtCsvName = MsgCourseUserCsvName courseTerm courseSchool courseShorthand dbtCsvSheetName = MsgCourseUserCsvSheetName courseTerm courseSchool courseShorthand dbtCsvEncode = do csvColumns' <- csvColumns return $ DBTCsvEncode { dbtCsvExportForm = UserCsvExportData <$> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def) , dbtCsvDoEncode = \UserCsvExportData{} -> C.mapM $ \(_, row) -> flip runReaderT row $ UserTableCsv <$> view (hasUser . _userSurname) <*> view (hasUser . _userFirstName) <*> view (hasUser . _userDisplayName) <*> view (hasUser . _userSex) <*> view (hasUser . _userBirthday) <*> view (hasUser . _userMatrikelnummer) <*> view (hasUser . _userLdapPrimaryKey) <*> view (hasUser . _userEmail) <*> (over traverse (qualificationName . entityVal) <$> view _userQualifications) <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) <*> view _userTableRegistration <*> userNote <*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials) <*> (over traverse (examName . entityVal) <$> view _userExams) <*> views _userSheets (set (mapped . _1 . mapped) ()) , dbtCsvName, dbtCsvSheetName , dbtCsvNoExportData = Nothing , dbtCsvHeader = return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def , dbtCsvExampleData = Nothing } userNote = runMaybeT $ do noteId <- MaybeT . preview $ _userTableNote . _Just CourseUserNote{..} <- lift . lift $ getJust noteId return courseUserNoteNote dbtCsvDecode = Nothing dbtExtraReps = withCsvExtraRep dbtCsvSheetName (UserCsvExportData True) dbtCsvEncode [ DBTExtraRep $ toPrettyJSON <$> repUserJson, DBTExtraRep $ toYAML <$> repUserJson ] repUserJson :: ConduitT (E.Value UserId, UserTableData) Void DB (Map CryptoUUIDUser UserTableJson) repUserJson = C.foldMapM $ \(E.Value uid, res) -> Map.singleton <$> encrypt uid <*> mkUserTableJson res where mkUserTableJson res' = flip runReaderT res' $ UserTableJson <$> view (hasUser . _userSurname) <*> view (hasUser . _userFirstName) <*> view (hasUser . _userDisplayName) <*> views (hasUser . _userSex) (guardOn showSex) <*> view (hasUser . _userMatrikelnummer) <*> view (hasUser . _userLdapPrimaryKey) <*> view (hasUser . _userEmail) <*> view (_userQualifications . folded . to (Set.singleton . qualificationName . entityVal)) <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) <*> view _userTableRegistration <*> (fmap markupInput <$> userNote) <*> view (_userTutorials . _1 . folded . to (Set.singleton . tutorialName . entityVal)) <*> views (_userTutorials . _2) (over (traverse . _Just) $ tutorialName . entityVal) <*> view (_userExams . folded . to (Set.singleton . examName . entityVal)) <*> (fmap (fmap $ uncurry UserTableJsonSheetResult) . traverseOf (traverse . _1) (lift . resolveSheetType') =<< view _userSheets) resolveSheetType' sType = do sType' <- resolveSheetType cid sType for sType' $ \(Entity _ ExamPart{..}) -> do Exam{..} <- getJust examPartExam return $ UserTableJsonSheetTypeExamPartRef examName examPartNumber over _1 postprocess <$> dbTable psValidator DBTable{..} where postprocess :: FormResult (First act', DBFormResult UserId Bool UserTableData) -> FormResult (act', Set UserId) postprocess inp = do (First (Just act), usrMap) <- inp let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap return (act, usrSet) courseUserDeregisterForm :: CourseId -> AForm Handler CourseUserActionData courseUserDeregisterForm _cid = wFormToAForm . pure . pure $ CourseUserDeregisterData Nothing getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR = postCUsersR postCUsersR tid ssh csh = do now <- liftIO getCurrentTime let nowaday = utctDay now showSex <- getShowSex (course@(Entity cid Course{..}), numParticipants, (participantRes,participantTable)) <- runDB $ do mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh hasTutorials <- exists [TutorialCourse ==. cid] examOccurrencesPerExam <- E.select . E.from $ \(exam `E.LeftOuterJoin` examOccurrence) -> do E.on $ E.just (exam E.^. ExamId) E.==. examOccurrence E.?. ExamOccurrenceExam E.where_ $ exam E.^. ExamCourse E.==. E.val cid return (exam, examOccurrence) hasSubmissionGroups <- E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` courseParticipant) -> do E.on $ courseParticipant E.^. CourseParticipantUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser E.&&. courseParticipant E.^. CourseParticipantCourse E.==. submissionGroup E.^. SubmissionGroupCourse E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid sheetList <- 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 E.where_ $ E.not_ (sheet E.^. SheetAllowNonPersonalisedSubmission) E.||. hasPersonalised E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.orderBy [ E.desc $ sheet E.^. SheetActiveTo , E.desc $ sheet E.^. SheetActiveFrom ] return $ sheet E.^. SheetName let exams = nubOrdOn entityKey $ examOccurrencesPerExam ^.. folded . _1 let colChoices = mconcat $ catMaybes [ pure . cap' $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR) , guardOn showSex . cap' $ colUserSex' , pure . cap' $ colUserEmail , pure . cap' $ colUserMatriclenr False , pure . cap' $ colUserQualifications nowaday , 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 , pure . cap' $ colUserComment tid ssh csh ] psValidator = def & defaultSortingByName & defaultFilter (singletonMap "active" [toPathPiece True]) hasExams = not $ null exams examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId)) examOccActs = examOccurrencesPerExam & map (bimap entityKey hoistMaybe) & Map.fromListWith (<>) & imap (\k v -> case v of [] -> pure (k, Nothing) _ -> (k,) <$> aopt (selectField' (Just $ SomeMessage MsgExamNoOccurrence) $ examOccOpts v) (fslI MsgTableExamOccurrence) (Just Nothing) ) where examOccOpts :: [Entity ExamOccurrence] -> Handler (OptionList ExamOccurrenceId) examOccOpts examOccs = fmap mkOptionList . forM examOccs $ \Entity{..} -> do optionExternalValue' <- encrypt entityKey :: Handler CryptoUUIDExamOccurrence let optionExternalValue = toPathPiece optionExternalValue' optionInternalValue = entityKey optionDisplay = CI.original $ examOccurrenceName entityVal return Option{..} examActs :: Handler (OptionList ExamId) examActs = fmap mkOptionList . forM exams $ \Entity{..} -> do optionExternalValue' <- encrypt entityKey :: Handler CryptoUUIDExam let optionExternalValue = toPathPiece optionExternalValue' optionInternalValue = entityKey optionDisplay = CI.original $ examName entityVal return Option{..} submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal) acts :: Map CourseUserAction (AForm Handler CourseUserActionData) acts = mconcat $ catMaybes [ pure . singletonMap CourseUserSendMail $ pure CourseUserSendMailData , pure . singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData <$> apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName) (fslI MsgCourseTutorial) Nothing , pure . singletonMap CourseUserRegisterExam $ CourseUserRegisterExamData <$> multiActionAOpts examOccActs examActs (fslI MsgCourseExam) Nothing , pure . singletonMap CourseUserSetSubmissionGroup $ CourseUserSetSubmissionGroupData . assertM (not . Text.null . CI.original) <$> aopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgTableSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing , guardOn mayRegister . singletonMap CourseUserDeregister $ courseUserDeregisterForm cid , guardOn mayRegister . singletonMap CourseUserReRegister $ pure CourseUserReRegisterData , guardOn (not $ null personalisedSheets) . singletonMap CourseUserDownloadPersonalisedSheetFiles $ CourseUserDownloadPersonalisedSheetFilesData <$> apopt (selectField' Nothing . optionsF $ map E.unValue personalisedSheets) (fslI MsgExerciseSheet) Nothing <*> apopt (selectField optionsFinite) (fslI MsgPersonalisedSheetFilesDownloadAnonymousField) (Just PersonalisedSheetFilesDownloadAnonymous) ] numParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive] table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator (Just $ const True) return (ent, numParticipants, table) formResult participantRes $ \case (CourseUserSendMailData, selectedUsers) -> do cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) (CourseUserDeregisterData{}, selectedUsers) -> do Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do Entity _ CourseParticipant{..} <- MaybeT . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid unless (courseParticipantCourse == cid) $ error "courseParticipantCourse does not match cid" lift $ deregisterParticipant courseParticipantUser course return 1 addMessageI Success $ MsgCourseUsersDeregistered nrDel redirect $ CourseR tid ssh csh CUsersR (CourseUserRegisterTutorialData{..}, selectedUsers) -> do Sum nrOk <- runDB $ flip foldMapM selectedUsers $ \uid -> do fsh <- selectCompanyUserPrime' uid mbKey <- insertUnique $ TutorialParticipant registerTutorial uid fsh Nothing Nothing Nothing return $ Sum $ length mbKey let mStatus = bool Success Warning $ nrOk < Set.size selectedUsers addMessageI mStatus $ MsgCourseUsersTutorialRegistered $ fromIntegral nrOk redirect $ CourseR tid ssh csh CUsersR (CourseUserRegisterExamData{..}, selectedUsers) -> do Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] let (exam, mOccurrence) = registerExam mExamReg <- lift $ insertUnique ExamRegistration { examRegistrationExam = exam , examRegistrationUser = uid , examRegistrationOccurrence = mOccurrence , examRegistrationTime = now } case mExamReg of Just _ -> do lift . audit $ TransactionExamRegister exam uid return 1 Nothing -> return mempty addMessageI Success $ MsgCourseUsersExamRegistered nrReg redirect $ CourseR tid ssh csh CUsersR (CourseUserSetSubmissionGroupData{..}, selectedUsers) -> do nrSet <- runDB $ setUsersSubmissionGroup cid selectedUsers setSubmissionGroup case setSubmissionGroup of Nothing -> addMessageI Success $ MsgCourseUsersSubmissionGroupUnset nrSet Just _ -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet redirect $ CourseR tid ssh csh CUsersR (CourseUserReRegisterData, selectedUsers) -> do Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do didUpdate <- lift $ updateWhereCount [ CourseParticipantUser ==. uid , CourseParticipantCourse ==. cid , CourseParticipantState !=. CourseParticipantActive ] [ CourseParticipantState =. CourseParticipantActive , CourseParticipantRegistration =. now ] guard $ didUpdate > 0 lift . audit $ TransactionCourseParticipantEdit cid uid return $ Sum didUpdate addMessageI Success $ MsgCourseUsersStateSet nrSet redirect $ CourseR tid ssh csh CUsersR (CourseUserDownloadPersonalisedSheetFilesData shn anonMode, selectedUsers) -> do shId <- runDB . getKeyBy404 $ CourseSheet cid shn archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgPersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand shn sendResponse <=< serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cid (Just shId) (Just selectedUsers) anonMode Set.empty let headingLong = [whamlet|_{MsgHeadingCourseMembers} #{courseName} #{tid}|] headingShort = prependCourseTitle tid ssh csh MsgHeadingCourseMembers siteLayout headingLong $ do setTitleI headingShort $(widgetFile "course-participants")