feat(course-users): include tutorial in csv-export

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)
 

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))
+type UserTableExpr   = (               E.SqlExpr (Entity User)
-        `E.LeftOuterJoin`
+                         `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)
-        (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 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 -> [Entity Tutorial] -> Csv.Header
-userTableCsvHeader UserCsvExportData{..} = 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
+        dbtCsvEncode = do
-          { dbtCsvExportForm = UserCsvExportData
+          csvColumns' <- csvColumns
-              <$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def)
+          return $ DBTCsvEncode
-          , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ 
+            { dbtCsvExportForm = UserCsvExportData
-              UserTableCsv
+                <$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def)
-                <$> view (hasUser . _userDisplayName)
+            , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ 
-                <*> view (hasUser . _userMatrikelnummer)
+                UserTableCsv
-                <*> view (hasUser . _userEmail)
+                  <$> view (hasUser . _userDisplayName)
-                <*> if
+                  <*> view (hasUser . _userMatrikelnummer)
-                      | csvUserSimplifiedFeaturesOfStudy -> fmap Left . runMaybeT $
+                  <*> view (hasUser . _userEmail)
-                          UserTableCsvStudyFeature
+                  <*> if
-                            <$> MaybeT (preview $   _userTableFeatures . _3 . _Just . _studyTermsName . _Just
+                        | csvUserSimplifiedFeaturesOfStudy -> fmap Left . runMaybeT $
-                                                 <> _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
+                              <$> MaybeT (preview $   _userTableFeatures . _3 . _Just . _studyTermsName . _Just
-                              , csvUserDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
+                                                   <> _userTableFeatures . _3 . _Just . _studyTermsKey . to tshow
-                              , csvUserSemester = studyFeaturesSemester
+                                         )
-                              , csvUserType = studyFeaturesType
+                              <*> MaybeT (preview $   _userTableFeatures . _2 . _Just . _studyDegreeName . _Just
-                              }
+                                                   <> _userTableFeatures . _2 . _Just . _studyDegreeKey . to tshow
-                <*> view _userTableRegistration
+                                         )
-                <*> userNote
+                              <*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesSemester)
-          , dbtCsvName = unpack csvName
+                              <*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesType)
-          , dbtCsvNoExportData = Nothing
+                        | otherwise -> Right <$> do
-          , dbtCsvHeader = return . userTableCsvHeader . fromMaybe def
+                            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

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

src/Utils/Lens.hs

@@ -208,6 +208,8 @@ makeLenses_ ''CourseUserExamOfficeOptOut
 makeLenses_ ''CourseNewsFile
 
 makeLenses_ ''AllocationCourse
+
+makeLenses_ ''Tutorial
   
 
 -- makeClassy_ ''Load