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

2019-10-10 11:19:45 +02:00 · 2019-10-10 11:19:45 +02:00 · 1d5ddd102c
commit 1d5ddd102c
parent ec4b3a8f54
4 changed files with 98 additions and 55 deletions
--- 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)

--- 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
--- 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
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@ -208,6 +208,8 @@ makeLenses_ ''CourseUserExamOfficeOptOut
 makeLenses_ ''CourseNewsFile

 makeLenses_ ''AllocationCourse
+
+makeLenses_ ''Tutorial
  

 -- makeClassy_ ''Load