{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-redundant-constraints #-} module Handler.Course.Users ( queryUser , makeCourseUserTable , postCUsersR, getCUsersR , colUserSex', _userStudyFeatures ) where import Import import Utils.Form import Handler.Utils import Handler.Utils.Course import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Handler.Course.Register (deregisterParticipant) import Handler.Utils.StudyFeatures 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 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) , UserTableStudyFeatures ) 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 _userStudyFeatures :: Lens' UserTableData UserTableStudyFeatures _userStudyFeatures = _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 data UserTableCsv = UserTableCsv { csvUserSurname :: UserSurname , csvUserFirstName :: UserFirstName , csvUserName :: UserDisplayName , csvUserSex :: Maybe Sex , csvUserMatriculation :: Maybe UserMatriculation , csvUserEmail :: UserEmail , csvUserStudyFeatures :: UserTableStudyFeatures , 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, Typeable) makeLenses_ ''UserTableCsv instance Csv.ToNamedRecord UserTableCsv where toNamedRecord UserTableCsv{..} = Csv.namedRecord $ [ "surname" Csv..= csvUserSurname , "first-name" Csv..= csvUserFirstName , "name" Csv..= csvUserName , "sex" Csv..= csvUserSex , "matriculation" Csv..= csvUserMatriculation , "email" Csv..= csvUserEmail , "study-features" Csv..= csvUserStudyFeatures , "submission-group" Csv..= csvUserSubmissionGroup ] ++ [ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1 in "tutorial" Csv..= tutsStr ] ++ [ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut) | (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2 ] ++ [ let examsStr = Text.intercalate "; " $ map CI.original csvUserExams in "exams" Csv..= examsStr ] ++ [ "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 "matriculation" MsgCsvColumnUserMatriculation , single "email" MsgCsvColumnUserEmail , single "study-features" MsgCsvColumnUserCourseStudyFeatures , 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, Typeable) 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", "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 , jsonUserStudyFeatures :: UserTableStudyFeatures , 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, Typeable) data UserTableJsonSheetResult = UserTableJsonSheetResult { jsonSheetType :: SheetType UserTableJsonSheetTypeExamPartRef , jsonPoints :: Maybe Points } deriving (Generic, Typeable) data UserTableJsonSheetTypeExamPartRef = UserTableJsonSheetTypeExamPartRef { jsonExam :: ExamName , jsonExamPart :: ExamPartNumber } deriving (Generic, Typeable) 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 , ("study-features" JSON..=) <$> assertM' (views _Wrapped $ not . onull) jsonUserStudyFeatures , ("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, Typeable) 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, Typeable) 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 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 ) ) feats <- courseUserStudyFeatures (participant ^. _entityVal . _courseParticipantCourse) (participant ^. _entityVal . _courseParticipantUser) 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, feats) 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 . _userMatrikelnummer) <*> view (hasUser . _userEmail) <*> view _userStudyFeatures <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) <*> view _userTableRegistration <*> userNote <*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials) -- <*> (over (_2.traverse._Just) (examName . entityVal) . over (_1.traverse) (examName . entityVal) <$> view _userExams) <*> (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 _userStudyFeatures <*> 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 $ do allocated <- liftHandler . runDB . E.selectExists . E.from $ \participant -> E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid E.&&. E.not_ (E.isNothing $ participant E.^. CourseParticipantAllocated) E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive if | allocated -> do wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip let selfImposedForm = (,) <$> apreq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing <*> apopt checkBoxField (fslI MsgCourseDeregistrationAllocationNoShow & setTooltip MsgCourseDeregistrationAllocationNoShowTip) Nothing fmap CourseUserDeregisterData <$> optionalActionW selfImposedForm (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True) | otherwise -> pure . pure $ CourseUserDeregisterData Nothing getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR = postCUsersR postCUsersR tid ssh csh = do 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 = nubOn 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 , pure . cap' $ colStudyFeatures _userStudyFeatures , 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 now <- liftIO getCurrentTime 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 case deregisterSelfImposed of Just (reason, noShow) | is _Just courseParticipantAllocated -> lift $ do insert_ $ AllocationDeregister uid (Just cid) now (Just reason) updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ] let recordNoShow eId = do didRecord <- is _Just <$> insertUnique ExamResult { examResultExam = eId , examResultUser = uid , examResultResult = ExamNoShow , examResultLastChanged = now } when didRecord $ audit $ TransactionExamResultEdit eId uid when noShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow _other -> return () 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 ] now <- liftIO getCurrentTime 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 now <- liftIO getCurrentTime Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do didUpdate <- lift $ updateWhereCount [ CourseParticipantUser ==. uid , CourseParticipantCourse ==. cid , CourseParticipantState !=. CourseParticipantActive ] [ CourseParticipantState =. CourseParticipantActive , CourseParticipantRegistration =. now , CourseParticipantAllocated =. Nothing ] guard $ didUpdate > 0 lift $ deleteWhere [ AllocationDeregisterCourse ==. Just cid, AllocationDeregisterUser ==. uid ] 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")