From 26463c60329b6cc04b6eb54ab61f40e20ee3fdbb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Apr 2023 15:36:23 +0000 Subject: [PATCH] chore(csv): export company in csv --- .../categories/qualification/de-de-formal.msg | 1 + .../categories/qualification/en-eu.msg | 1 + src/Handler/Qualification.hs | 81 ++++++++++++------- 3 files changed, 53 insertions(+), 30 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 47aa7455b..1d76ad70f 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -25,6 +25,7 @@ TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend au TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen? TableQualificationNoRenewal: Auslaufend TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein. +QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte? QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus QualificationUserNone: Für diese Person sind keine Qualifikationen registriert. QualificationBlockReason: Entzugsbegründung diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 149b12f41..25de10365 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -25,6 +25,7 @@ TableQualificationBlockedTooltip: Why and when was this qualification temporaril TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons? TableQualificationNoRenewal: Discontinued TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. +QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon? QualificationUserNoRenewal: Expires without further notification QualificationUserNone: No registered qualifications for this person. QualificationBlockReason: Reason for revoking diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 70658679c..cfc4ae0da 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -151,26 +151,30 @@ mkQualificationAllTable = do -- postQualificationEditR = error "TODO" data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. - { qtcDisplayName :: UserDisplayName - , qtcEmail :: UserEmail - , qtcValidUntil :: Day - , qtcLastRefresh :: Day - , qtcBlocked :: Maybe Day - , qtcLmsStatusTxt :: Maybe Text - , qtcLmsStatusDay :: Maybe Day + { qtcDisplayName :: UserDisplayName + , qtcEmail :: UserEmail + , qtcCompany :: Maybe Text + , qtcValidUntil :: Day + , qtcLastRefresh :: Day + , qtcBlocked :: Maybe Day + , qtcScheduleRenewal:: Bool + , qtcLmsStatusTxt :: Maybe Text + , qtcLmsStatusDay :: Maybe Day } deriving Generic makeLenses_ ''QualificationTableCsv qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv - { qtcDisplayName = "Max Mustermann" - , qtcEmail = "m.mustermann@example.com" - , qtcValidUntil = compDay - , qtcLastRefresh = compDay - , qtcBlocked = Nothing - , qtcLmsStatusTxt = Just "Success" - , qtcLmsStatusDay = Just compDay + { qtcDisplayName = "Max Mustermann" + , qtcEmail = "m.mustermann@example.com" + , qtcCompany = Just "Example Brothers LLC" + , qtcValidUntil = compDay + , qtcLastRefresh = compDay + , qtcBlocked = Nothing + , qtcScheduleRenewal= True + , qtcLmsStatusTxt = Just "Success" + , qtcLmsStatusDay = Just compDay } where compTime :: UTCTime @@ -185,7 +189,7 @@ qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } renameLtc other = replaceLtc $ camelToPathPiece' 1 other replaceLtc ('l':'m':'s':'-':t) = prefixLms t replaceLtc other = other - prefixLms = ("e-learn-" <>) + prefixLms = ("elearn-" <>) instance Csv.ToNamedRecord QualificationTableCsv where toNamedRecord = Csv.genericToNamedRecord qtcOptions @@ -195,30 +199,37 @@ instance Csv.DefaultOrdered QualificationTableCsv where instance CsvColumnsExplained QualificationTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList - [ ('qtcDisplayName, MsgLmsUser) - , ('qtcEmail , MsgTableLmsEmail) - , ('qtcValidUntil , MsgLmsQualificationValidUntil) - , ('qtcLastRefresh, MsgTableQualificationLastRefresh) - , ('qtcLmsStatusTxt, MsgTableLmsStatus) - , ('qtcLmsStatusDay, MsgTableLmsStatusDay) + [ ('qtcDisplayName , SomeMessage MsgLmsUser) + , ('qtcEmail , SomeMessage MsgTableLmsEmail) + , ('qtcCompany , SomeMessage MsgTableCompany) + , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) + , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) + , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) + , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus) + , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) ] -type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) - `E.InnerJoin` E.SqlExpr (Entity User) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) +type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) + `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity UserCompany)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity Company))) queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) -queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) +queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) -queryLmsUser = $(sqlLOJproj 2 2) +queryLmsUser = $(sqlLOJproj 3 2) + +queryCompany :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity Company)) +queryCompany = $(sqlIJproj 2 2) . $(sqlLOJproj 3 3) -type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser)) +type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity Company)) resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -229,6 +240,9 @@ resultUser = _dbrOutput . _2 resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just +resultCompany :: Traversal' QualificationTableData (Entity Company) +resultCompany = _dbrOutput . _4 . _Just + instance HasEntity QualificationTableData User where hasEntity = resultUser @@ -273,13 +287,16 @@ qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) , E.SqlExpr (Maybe (Entity LmsUser)) + , E.SqlExpr (Maybe (Entity Company)) ) -qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do +qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` (usrComp `E.InnerJoin` company)) = do + E.on $ usrComp E.?. UserCompanyCompany E.==. company E.?. CompanyId + E.on $ usrComp E.?. UserCompanyUser E.?=. user E.^. UserId E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) - return (qualUser, user, lmsUser) + return (qualUser, user, lmsUser, company) mkQualificationTable :: @@ -324,6 +341,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) ) + , single ( "company", SortColumn $ queryCompany >>> (E.?. CompanyName)) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser @@ -372,9 +390,11 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = QualificationTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) + <*> preview (resultCompany . _entityVal . _companyName . _CI) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) + <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt <*> getStatusPlusDay getStatusPlusTxt = @@ -450,6 +470,7 @@ postQualificationR sid qsh = do (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' icnSuper = text2markup " " <> icon IconSupervisor pure $ toWgt $ mconcat companies + , sortable (Just "company") (i18nCell MsgTableCompany) $ \( preview $ resultCompany . _entityVal . _companyName . _CI -> cn) -> cellMaybe textCell cn , guardMonoid isAdmin colUserMatriclenr , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d