From 1d5ddd102ce49c83ab0b45cf2be590f76ca0f0d0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 10 Oct 2019 11:19:45 +0200 Subject: [PATCH] feat(course-users): include tutorial in csv-export --- messages/uniworx/de.msg | 1 + src/Handler/Course/Users.hs | 147 +++++++++++++++++++++------------- src/Handler/Tutorial/Users.hs | 3 +- src/Utils/Lens.hs | 2 + 4 files changed, 98 insertions(+), 55 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 514420c38..7ae0ce831 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1559,6 +1559,7 @@ CsvColumnUserDegree: Abschluss, den der Teilnehmer im assoziierten Studienfach a CsvColumnUserSemester: Fachsemester des Teilnehmers im assoziierten Studienfach CsvColumnUserRegistration: Zeitpunkt der Anmeldung zum Kurs (ISO 8601) CsvColumnUserNote: Notizen zum Teilnehmer +CsvColumnUserTutorial: Tutorien zu denen der Teilnehmer angemeldet ist, als Semikolon (;) separierte Liste. Für Registrierungs-Gruppen unter den Tutorien gibt es jeweils eine weitere Spalte. Die Registrierungs-Gruppen-Spalten enthalten jeweils maximal ein Tutorium pro Teilnehmer. Sind alle Tutorien in Registrierungs-Gruppen, so gibt es keine Spalte "tutorial". CsvColumnExamOfficeExamUserOccurrenceStart: Prüfungstermin (ISO 8601) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 7fce82abf..bd1f80e12 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -19,6 +19,7 @@ import Data.Function ((&)) 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 @@ -26,11 +27,17 @@ import qualified Data.Csv as Csv import qualified Data.Conduit.List as C +import qualified Data.CaseInsensitive as CI -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))) + +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)) + ) -- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a) -- forceUserTableType = id @@ -70,7 +77,12 @@ userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.L return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features) -type UserTableData = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)) +type UserTableData = DBRow ( Entity User + , UTCTime + , Maybe CourseUserNoteId + , (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms) + , ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial))) + ) instance HasEntity UserTableData User where hasEntity = _dbrOutput . _1 @@ -91,11 +103,14 @@ _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 + 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,_) } -> + $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey, _, _) } -> maybeEmpty mbNoteKey $ const $ anchorCellM (courseLink <$> encrypt uid) (hasComment True) where @@ -137,6 +152,7 @@ data UserTableCsv = UserTableCsv , csvUserStudyFeatures :: Either (Maybe UserTableCsvStudyFeature) (Set UserTableCsvStudyFeature) , csvUserRegistration :: UTCTime , csvUserNote :: Maybe Html + , csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName)) } deriving (Eq, Ord, Read, Show, Generic, Typeable) makeLenses_ ''UserTableCsv @@ -158,6 +174,12 @@ instance Csv.ToNamedRecord UserTableCsv where in [ "study-features" Csv..= featsStr ] ++ + [ 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 + ] ++ [ "registration" Csv..= csvUserRegistration , "note" Csv..= csvUserNote ] @@ -170,6 +192,7 @@ instance CsvColumnsExplained UserTableCsv where , single "field" MsgCsvColumnUserField , single "degree" MsgCsvColumnUserDegree , single "semester" MsgCsvColumnUserSemester + , single "tutorial" MsgCsvColumnUserTutorial , single "registration" MsgCsvColumnUserRegistration , single "note" MsgCsvColumnUserNote ] @@ -183,12 +206,17 @@ newtype UserCsvExportData = UserCsvExportData instance Default UserCsvExportData where def = UserCsvExportData True -userTableCsvHeader :: UserCsvExportData -> Csv.Header -userTableCsvHeader UserCsvExportData{..} = Csv.header $ +userTableCsvHeader :: UserCsvExportData -> [Entity Tutorial] -> Csv.Header +userTableCsvHeader UserCsvExportData{..} tuts = Csv.header $ [ "name", "matriculation", "email" ] ++ bool (pure "study-features") ["field", "degree", "semester"] csvUserSimplifiedFeaturesOfStudy ++ + [ "tutorial" | hasEmptyRegGroup ] ++ + map (encodeUtf8 . CI.foldedCase) regGroups ++ [ "registration", "note" ] + where + hasEmptyRegGroup = has (folded . _entityVal . _tutorialRegGroup . _Nothing) tuts + regGroups = Set.toList $ setOf (folded . _entityVal . _tutorialRegGroup . _Just) tuts data CourseUserAction = CourseUserSendMail | CourseUserDeregister @@ -215,17 +243,25 @@ makeCourseUserTable :: forall h act 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 = do +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 ] [] -- -- psValidator has default sorting and filtering let dbtIdent = "courseUsers" :: Text dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q) dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms)) + dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> do + tuts'' <- lift $ selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] [] + 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) regGroups) tuts' + return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts) dbtColonnade = colChoices dbtSorting = Map.fromList [ sortUserNameLink queryUser -- slower sorting through clicking name column header @@ -294,50 +330,53 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do , dbParamsFormResult = id , dbParamsFormIdent = def } - dbtCsvEncode = Just 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 . _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{..}) -> + 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 . _userMatrikelnummer) + <*> view (hasUser . _userEmail) + <*> if + | csvUserSimplifiedFeaturesOfStudy -> fmap Left . runMaybeT $ UserTableCsvStudyFeature - { csvUserField = fromMaybe (tshow studyTermsKey) studyTermsName - , csvUserDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName - , csvUserSemester = studyFeaturesSemester - , csvUserType = studyFeaturesType - } - <*> view _userTableRegistration - <*> userNote - , dbtCsvName = unpack csvName - , dbtCsvNoExportData = Nothing - , dbtCsvHeader = return . userTableCsvHeader . fromMaybe def - } + <$> 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 + } + <*> view _userTableRegistration + <*> userNote + <*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials) + , dbtCsvName = unpack csvName + , dbtCsvNoExportData = Nothing + , dbtCsvHeader = return . Vector.filter csvColumns' . flip userTableCsvHeader tutorials . fromMaybe def + } where userNote = runMaybeT $ do noteId <- MaybeT . preview $ _userTableNote . _Just @@ -389,7 +428,7 @@ postCUsersR tid ssh csh = do -> mempty ] numParticipants <- count [CourseParticipantCourse ==. cid] - table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator + table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator (Just $ const True) return (ent, numParticipants, table) formResult participantRes $ \case (CourseUserSendMailData, selectedUsers) -> do diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 4c33dd1ee..ddd9893bb 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -50,9 +50,10 @@ postTUsersR tid ssh csh tutn = do isInTut q = E.exists . E.from $ \tutorialParticipant -> E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid + csvColChoices = flip elem ["name", "matriculation", "email", "field", "degree", "semester", "study-features"] cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - table <- makeCourseUserTable cid (Map.fromList $ map (id &&& pure) universeF) isInTut colChoices psValidator + table <- makeCourseUserTable cid (Map.fromList $ map (id &&& pure) universeF) isInTut colChoices psValidator (Just csvColChoices) return (tut, table) formResult participantRes $ \case diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 234ab1075..4ed056e10 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -208,6 +208,8 @@ makeLenses_ ''CourseUserExamOfficeOptOut makeLenses_ ''CourseNewsFile makeLenses_ ''AllocationCourse + +makeLenses_ ''Tutorial -- makeClassy_ ''Load