diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5d11a24d7..514420c38 100644 --- a/messages/uniworx/de.msg +++ b/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. \ No newline at end of file diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 91bfdf0c3..7fce82abf 100644 --- a/src/Handler/Course/Users.hs +++ b/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 - , csvUserDegree :: Maybe Text - , csvUserSemester :: Maybe Int + , csvUserStudyFeatures :: Either (Maybe UserTableCsvStudyFeature) (Set UserTableCsvStudyFeature) , csvUserRegistration :: UTCTime , csvUserNote :: Maybe Html - } - deriving (Generic) + } deriving (Eq, Ord, Read, Show, Generic, Typeable) makeLenses_ ''UserTableCsv -userTableCsvOptions :: Csv.Options -userTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 } instance Csv.ToNamedRecord UserTableCsv where - toNamedRecord = Csv.genericToNamedRecord userTableCsvOptions -instance Csv.DefaultOrdered UserTableCsv where - headerOrder = Csv.genericHeaderOrder userTableCsvOptions -instance CsvColumnsExplained UserTableCsv where - csvColumnsExplanations = genericCsvColumnsExplanations userTableCsvOptions $ mconcat - [ singletonMap 'csvUserName MsgCsvColumnUserName - , singletonMap 'csvUserMatriculation MsgCsvColumnUserMatriculation - , singletonMap 'csvUserEmail MsgCsvColumnUserEmail - , singletonMap 'csvUserField MsgCsvColumnUserField - , singletonMap 'csvUserDegree MsgCsvColumnUserDegree - , singletonMap 'csvUserSemester MsgCsvColumnUserSemester - , singletonMap 'csvUserRegistration MsgCsvColumnUserRegistration - , singletonMap 'csvUserNote MsgCsvColumnUserNote + toNamedRecord UserTableCsv{..} = Csv.namedRecord $ + [ "name" Csv..= csvUserName + , "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 + ] + ++ + [ "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 - <$> view (hasUser . _userDisplayName) - <*> view (hasUser . _userMatrikelnummer) - <*> view (hasUser . _userEmail) - <*> preview ( _userTableFeatures . _3 . _Just . _studyTermsName . _Just - <> _userTableFeatures . _3 . _Just . _studyTermsKey . to tshow - ) - <*> preview ( _userTableFeatures . _2 . _Just . _studyDegreeName . _Just - <> _userTableFeatures . _2 . _Just . _studyDegreeKey . to tshow - ) - <*> preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester) - <*> view _userTableRegistration - <*> userNote + 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{..}) -> + 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