feat(course): allow csv-export of all features-of-study

messages/uniworx/de.msg

@@ -1553,6 +1553,7 @@ CsvColumnExamUserCourseNote: Notizen zum Teilnehmer
 CsvColumnUserName: Voller Name des Teilnehmers
 CsvColumnUserMatriculation: Matrikelnummer des Teilnehmers
 CsvColumnUserEmail: E-Mail Addresse des Teilnehmers
+CsvColumnUserStudyFeatures: Alle aktiven Studiendaten des Teilnehmers als Semikolon (;) separierte Liste
 CsvColumnUserField: Studienfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat
 CsvColumnUserDegree: Abschluss, den der Teilnehmer im assoziierten Studienfach anstrebt
 CsvColumnUserSemester: Fachsemester des Teilnehmers im assoziierten Studienfach
@@ -1934,3 +1935,6 @@ CourseEventCreated: Kurstermin erfolgreich angelegt
 CourseEventEdited: Kurstermin erfolgreich editiert
 CourseEventDeleteQuestion: Wollen Sie den unten aufgeführten Termin wirklich löschen?
 CourseEventDeleted: Kurstermin erfolgreich gelöscht
+
+UserSimplifiedFeaturesOfStudyCsv: Vereinfachte Studiengangsdaten
+UserSimplifiedFeaturesOfStudyCsvTip: Sollen Abschluss, Studiengang und Semester zur einfacheren Verarbeitung als separate Spalten exportiert werden? Es wird dann nur jeweils das Fach exportiert, dass der Student bei der Anmeldung ausgewählt hat.

src/Handler/Course/Users.hs

@@ -18,11 +18,14 @@ import Data.Function ((&))
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map
+import qualified Data.Text as Text
 
 import qualified Database.Esqueleto as E
 
 import qualified Data.Csv as Csv
 
+import qualified Data.Conduit.List as C
+
 
 type UserTableExpr   = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant))
         `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
@@ -119,36 +122,73 @@ colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDeg
     foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
 
 
+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
   , csvUserMatriculation :: Maybe Text
   , csvUserEmail :: CI Email
-  , csvUserField :: Maybe Text
+  , csvUserStudyFeatures :: Either (Maybe UserTableCsvStudyFeature) (Set UserTableCsvStudyFeature)
-  , csvUserDegree :: Maybe Text
-  , csvUserSemester :: Maybe Int
   , csvUserRegistration :: UTCTime
   , csvUserNote :: Maybe Html
-  }
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
-  deriving (Generic)
 makeLenses_ ''UserTableCsv
 
-userTableCsvOptions :: Csv.Options
-userTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 }
 instance Csv.ToNamedRecord UserTableCsv where
-  toNamedRecord = Csv.genericToNamedRecord userTableCsvOptions
+  toNamedRecord UserTableCsv{..} = Csv.namedRecord $
-instance Csv.DefaultOrdered UserTableCsv where
+    [ "name" Csv..= csvUserName
-  headerOrder = Csv.genericHeaderOrder userTableCsvOptions
+    , "matriculation" Csv..= csvUserMatriculation
-instance CsvColumnsExplained UserTableCsv where
+    , "email" Csv..= csvUserEmail
-  csvColumnsExplanations = genericCsvColumnsExplanations userTableCsvOptions $ mconcat
+    ] ++ case csvUserStudyFeatures of
-    [ singletonMap 'csvUserName          MsgCsvColumnUserName
+           Left feats
-    , singletonMap 'csvUserMatriculation MsgCsvColumnUserMatriculation
+             -> [ "field"    Csv..= (csvUserField    <$> feats)
-    , singletonMap 'csvUserEmail         MsgCsvColumnUserEmail
+                , "degree"   Csv..= (csvUserDegree   <$> feats)
-    , singletonMap 'csvUserField         MsgCsvColumnUserField
+                , "semester" Csv..= (csvUserSemester <$> feats)
-    , singletonMap 'csvUserDegree        MsgCsvColumnUserDegree
+                ]
-    , singletonMap 'csvUserSemester      MsgCsvColumnUserSemester
+           Right feats
-    , singletonMap 'csvUserRegistration  MsgCsvColumnUserRegistration
+             -> let featsStr = Text.intercalate "; " . flip map (Set.toList feats) $ \UserTableCsvStudyFeature{..}
-    , singletonMap 'csvUserNote          MsgCsvColumnUserNote
+                      -> let csvUserType' = renderMessage (error "no foundation needed" :: UniWorX) [] $ ShortStudyFieldType csvUserType
+                          in [st|#{csvUserField} #{csvUserDegree} (#{csvUserType'} #{tshow csvUserSemester})|]
+                 in [ "study-features" Csv..= featsStr
+                    ]
+      ++
+    [ "registration" Csv..= csvUserRegistration
+    , "note" Csv..= csvUserNote
     ]
+instance CsvColumnsExplained UserTableCsv where
+  csvColumnsExplanations _ = mconcat
+    [ single "name"                MsgCsvColumnUserName
+    , single "matriculation"       MsgCsvColumnUserMatriculation
+    , single "email"               MsgCsvColumnUserEmail
+    , single "study-features"      MsgCsvColumnUserStudyFeatures
+    , single "field"               MsgCsvColumnUserField
+    , single "degree"              MsgCsvColumnUserDegree
+    , single "semester"            MsgCsvColumnUserSemester
+    , 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 :: UserCsvExportData -> Csv.Header
+userTableCsvHeader UserCsvExportData{..} = Csv.header $
+  [ "name", "matriculation", "email"
+  ] ++ bool (pure "study-features") ["field", "degree", "semester"] csvUserSimplifiedFeaturesOfStudy ++
+  [ "registration", "note"
+  ]
 
 
 data CourseUserAction = CourseUserSendMail | CourseUserDeregister
@@ -254,19 +294,50 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do
           , dbParamsFormResult   = id
           , dbParamsFormIdent    = def
           }
-        dbtCsvEncode = simpleCsvEncodeM csvName $ UserTableCsv
+        dbtCsvEncode = Just DBTCsvEncode
-          <$> view (hasUser . _userDisplayName)
+          { dbtCsvExportForm = UserCsvExportData
-          <*> view (hasUser . _userMatrikelnummer)
+              <$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def)
-          <*> view (hasUser . _userEmail)
+          , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ 
-          <*> preview (   _userTableFeatures . _3 . _Just . _studyTermsName . _Just
+              UserTableCsv
-                       <> _userTableFeatures . _3 . _Just . _studyTermsKey . to tshow
+                <$> view (hasUser . _userDisplayName)
-                      )
+                <*> view (hasUser . _userMatrikelnummer)
-          <*> preview (   _userTableFeatures . _2 . _Just . _studyDegreeName . _Just
+                <*> view (hasUser . _userEmail)
-                       <> _userTableFeatures . _2 . _Just . _studyDegreeKey . to tshow
+                <*> if
-                      )
+                      | csvUserSimplifiedFeaturesOfStudy -> fmap Left . runMaybeT $
-          <*> preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester)
+                          UserTableCsvStudyFeature
-          <*> view _userTableRegistration
+                            <$> MaybeT (preview $   _userTableFeatures . _3 . _Just . _studyTermsName . _Just
-          <*> userNote
+                                                 <> _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
+          , dbtCsvName = unpack csvName
+          , dbtCsvNoExportData = Nothing
+          , dbtCsvHeader = return . userTableCsvHeader . fromMaybe def
+          }
           where
             userNote = runMaybeT $ do
               noteId <- MaybeT . preview $ _userTableNote . _Just