{-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Course.Users ( queryUser , makeCourseUserTable , postCUsersR, getCUsersR , colUserDegreeShort, colUserField, colUserSemester, colUserSex' ) 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 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 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) 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 StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)) ) `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 4 1) queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant) queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1) queryUserNote :: UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote)) queryUserNote = $(sqlLOJproj 4 2) queryFeaturesStudy :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) queryFeaturesStudy = $(sqlIJproj 3 1) . $(sqlLOJproj 4 3) queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 4 3) queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) queryFeaturesField = $(sqlIJproj 3 3) . $(sqlLOJproj 4 3) querySubmissionGroup :: UserTableExpr -> E.SqlExpr (Maybe (Entity SubmissionGroup)) querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 4 4) userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User) , E.SqlExpr (Entity CourseParticipant) , E.SqlExpr (E.Value (Maybe (Key CourseUserNote))) , StudyFeaturesDescription' , E.SqlExpr (Maybe (Entity SubmissionGroup)) ) userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures `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) features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures 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, features, subGroup) type UserTableData = DBRow ( Entity User , Entity CourseParticipant , Maybe CourseUserNoteId , (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms) , ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial))) , [Entity Exam] , Maybe (Entity SubmissionGroup) ) 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 _userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms) _userTableFeatures = _dbrOutput . _4 _rowUserSemester :: Traversal' UserTableData Int _rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester _userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial))) _userTutorials = _dbrOutput . _5 _userExams :: Lens' UserTableData [Entity Exam] _userExams = _dbrOutput . _6 _userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup) _userSubmissionGroup = _dbrOutput . _7 . _Just colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserComment tid ssh csh = sortable (Just "note") (i18nCell MsgCourseUserNote) $ \DBRow{ dbrOutput=(Entity 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) colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $ foldMap numCell . preview _rowUserSemester colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $ foldMap i18nCell . view (_userTableFeatures . _3) -- colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) -- colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $ -- foldMap (i18nCell . ShortStudyTerms) . view (_userTableFeatures . _3) -- colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) -- colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $ -- foldMap i18nCell . preview (_userTableFeatures . _2 . _Just) colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $ foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just) 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 MsgSubmissionGroup) $ foldMap (cell . toWidget) . preview (_userSubmissionGroup . _entityVal . _submissionGroupName) data UserTableCsvStudyFeature = UserTableCsvStudyFeature { csvUserField :: Text , csvUserDegree :: Text , csvUserSemester :: Int , csvUserType :: StudyFieldType } deriving (Eq, Ord, Read, Show, Generic, Typeable) makeLenses_ ''UserTableCsvStudyFeature data UserTableCsv = UserTableCsv { csvUserName :: Text , csvUserSex :: Maybe Sex , csvUserMatriculation :: Maybe Text , csvUserEmail :: CI Email , csvUserStudyFeatures :: Either (Maybe UserTableCsvStudyFeature) (Set UserTableCsvStudyFeature) , csvUserSubmissionGroup :: Maybe SubmissionGroupName , csvUserRegistration :: UTCTime , csvUserNote :: Maybe Html , csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName)) , csvUserExams :: [ExamName] } deriving (Eq, Ord, Read, Show, Generic, Typeable) makeLenses_ ''UserTableCsv instance Csv.ToNamedRecord UserTableCsv where toNamedRecord UserTableCsv{..} = Csv.namedRecord $ [ "name" Csv..= csvUserName , "sex" Csv..= csvUserSex , "matriculation" Csv..= csvUserMatriculation , "email" Csv..= csvUserEmail ] ++ case csvUserStudyFeatures of Left feats -> [ "field" Csv..= (csvUserField <$> feats) , "degree" Csv..= (csvUserDegree <$> feats) , "semester" Csv..= (csvUserSemester <$> feats) ] Right feats -> let featsStr = Text.intercalate "; " . flip map (Set.toList feats) $ \UserTableCsvStudyFeature{..} -> let csvUserType' = renderMessage (error "no foundation needed" :: UniWorX) [] $ ShortStudyFieldType csvUserType in [st|#{csvUserField} #{csvUserDegree} (#{csvUserType'} #{tshow csvUserSemester})|] in [ "study-features" Csv..= featsStr ] ++ [ "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 , "note" Csv..= csvUserNote ] instance CsvColumnsExplained UserTableCsv where csvColumnsExplanations _ = mconcat [ single "name" MsgCsvColumnUserName , single "sex" MsgCsvColumnUserSex , single "matriculation" MsgCsvColumnUserMatriculation , single "email" MsgCsvColumnUserEmail , single "study-features" MsgCsvColumnUserStudyFeatures , single "field" MsgCsvColumnUserField , single "degree" MsgCsvColumnUserDegree , single "semester" MsgCsvColumnUserSemester , 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 { csvUserSimplifiedFeaturesOfStudy :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Default UserCsvExportData where def = UserCsvExportData True userTableCsvHeader :: Bool -> UserCsvExportData -> [Entity Tutorial] -> Csv.Header userTableCsvHeader showSex UserCsvExportData{..} tuts = Csv.header $ [ "name" ] ++ [ "sex" | showSex ] ++ [ "matriculation", "email" ] ++ bool (pure "study-features") ["field", "degree", "semester"] csvUserSimplifiedFeaturesOfStudy ++ [ "tutorial" | hasEmptyRegGroup ] ++ map (encodeUtf8 . CI.foldedCase) regGroups ++ [ "exams", "registration", "note" ] where hasEmptyRegGroup = has (folded . _entityVal . _tutorialRegGroup . _Nothing) tuts regGroups = Set.toList $ setOf (folded . _entityVal . _tutorialRegGroup . _Just) tuts data CourseUserAction = CourseUserSendMail | CourseUserDeregister | CourseUserRegisterTutorial | CourseUserRegisterExam | CourseUserSetSubmissionGroup | CourseUserReRegister 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 deriving (Eq, Ord, Read, Show, Generic, Typeable) makeCourseUserTable :: forall h act act'. ( Functor h, ToSortable h , Ord act, PathPiece act, RenderMessage UniWorX act ) => CourseId -> Map act (AForm Handler act') -> (UserTableExpr -> E.SqlExpr (E.Value Bool)) -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))) -> 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 csvName <- getMessageRender <*> pure (MsgCourseUserCsvName courseTerm courseSchool courseShorthand) tutorials <- selectList [ TutorialCourse ==. cid ] [] exams <- selectList [ ExamCourse ==. cid ] [] -- -- 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 = traverse $ \(user, participant, E.Value userNoteId, (feature,degree,terms), subGroup) -> do tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] [] exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] [] 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 return (user, participant, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts, exs, subGroup) 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 $ ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) , single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) , single $ ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) , single $ ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) , single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) , 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)) ] 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 $ ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)) , single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) , single $ ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey)) , single $ ("field" , FilterColumn $ E.anyFilter [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName) , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand) , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey) ] ) , single $ ("degree" , FilterColumn $ E.anyFilter [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName) , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand) , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) ] ) , single $ ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) , 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)) ] where single = uncurry Map.singleton dbtFilterUI mPrev = mconcat $ [ prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt (courseParticipantStateIsActiveField . Just $ SomeMessage MsgNoFilter) (fslI MsgCourseParticipantStateIsActiveFilter) , fltrUserNameEmailUI mPrev , fltrUserMatriclenrUI mPrev ] ++ [ fltrUserSexUI mPrev | showSex ] ++ [ prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree) , prismAForm (singletonFilter "field") mPrev $ aopt textField (fslI MsgCourseStudyFeature) , prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup) , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial) , prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } dbtCsvEncode = do csvColumns' <- csvColumns return $ DBTCsvEncode { dbtCsvExportForm = UserCsvExportData <$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def) , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ UserTableCsv <$> view (hasUser . _userDisplayName) <*> view (hasUser . _userSex) <*> view (hasUser . _userMatrikelnummer) <*> view (hasUser . _userEmail) <*> if | csvUserSimplifiedFeaturesOfStudy -> fmap Left . runMaybeT $ UserTableCsvStudyFeature <$> MaybeT (preview $ _userTableFeatures . _3 . _Just . _studyTermsName . _Just <> _userTableFeatures . _3 . _Just . _studyTermsKey . to tshow ) <*> MaybeT (preview $ _userTableFeatures . _2 . _Just . _studyDegreeName . _Just <> _userTableFeatures . _2 . _Just . _studyDegreeKey . to tshow ) <*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesSemester) <*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesType) | otherwise -> Right <$> do feats <- lift . E.select . E.from $ \(feat `E.InnerJoin` terms `E.InnerJoin` degree) -> do E.on $ degree E.^. StudyDegreeId E.==. feat E.^. StudyFeaturesDegree E.on $ terms E.^. StudyTermsId E.==. feat E.^. StudyFeaturesField let registered = E.exists . E.from $ \participant -> E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid E.&&. participant E.^. CourseParticipantUser E.==. E.val uid E.&&. participant E.^. CourseParticipantField E.==. E.just (feat E.^. StudyFeaturesId) E.where_ $ registered E.||. feat E.^. StudyFeaturesValid E.where_ $ feat E.^. StudyFeaturesUser E.==. E.val uid return (terms, degree, feat) return . Set.fromList . flip map feats $ \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableCsvStudyFeature { csvUserField = fromMaybe (tshow studyTermsKey) studyTermsName , csvUserDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName , csvUserSemester = studyFeaturesSemester , csvUserType = studyFeaturesType } <*> 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) , dbtCsvName = unpack csvName , dbtCsvNoExportData = Nothing , dbtCsvHeader = return . Vector.filter csvColumns' . flip (userTableCsvHeader showSex) tutorials . fromMaybe def , dbtCsvExampleData = Nothing } where userNote = runMaybeT $ do noteId <- MaybeT . preview $ _userTableNote . _Just CourseUserNote{..} <- lift . lift $ getJust noteId return courseUserNoteNote dbtCsvDecode = Nothing 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 (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 let exams = nubOn entityKey $ examOccurrencesPerExam ^.. folded . _1 let colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) , guardOn showSex $ colUserSex' , pure $ colUserEmail , pure $ colUserMatriclenr , pure $ colUserDegreeShort , pure $ colUserField , pure $ colUserSemester , guardOn hasSubmissionGroups colUserSubmissionGroup , guardOn hasTutorials $ colUserTutorials tid ssh csh , guardOn hasExams $ colUserExams tid ssh csh , pure $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (maybe mempty dateCell . preview (_Just . _userTableRegistration) . assertM' (has $ _userTableParticipant . _entityVal . _courseParticipantState . _CourseParticipantActive)) , pure $ sortable (Just "state") (i18nCell MsgCourseUserState) (i18nCell . view (_userTableParticipant . _entityVal . _courseParticipantState)) , pure $ 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 MsgExamOccurrence) (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 = 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 MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing , guardOn mayRegister . singletonMap CourseUserDeregister $ courseUserDeregisterForm cid , guardOn mayRegister . singletonMap CourseUserReRegister $ pure CourseUserReRegisterData ] 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 lift $ deregisterParticipant courseParticipantUser courseParticipantCourse 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 let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|] headingShort = prependCourseTitle tid ssh csh MsgCourseMembers siteLayout headingLong $ do setTitleI headingShort $(widgetFile "course-participants")