-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros -- -- 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 , _userQualifications ) where import Import import Utils.Form import Handler.Utils import Handler.Utils.Course import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.PostgreSQL as E import Database.Esqueleto.Utils.TH import Handler.Course.Register (deregisterParticipant) import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.Vector as Vector import qualified Database.Esqueleto.Legacy as E 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] , 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 _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]) -> UserTableQualfications -> f UserTableQualifications _userQualifications :: Getter UserTableData [Entity Qualification] _userQualifications = _dbrOutput . _8 . to (fmap fst3) -- _userQualifications = _dbrOutput . _8 . each . _1 -- TODO: how to make this work _userCourseQualifications :: Lens' UserTableData UserTableQualifications _userCourseQualifications = _dbrOutput . _8 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) 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 , 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 , "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 , 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 , 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 , 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 ] [] 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 ] [] exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] [] 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) exams') 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) 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 ("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) -> flip (maybe E.true) criterion $ \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 . _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 . _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 , 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 runDB . forM_ selectedUsers $ void . insertUnique . TutorialParticipant registerTutorial addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers 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")