From 26463c60329b6cc04b6eb54ab61f40e20ee3fdbb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Apr 2023 15:36:23 +0000 Subject: [PATCH 01/10] 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 From 797729a248e681d0af6aaf4d3809a0a38883673a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 27 Apr 2023 16:48:43 +0000 Subject: [PATCH 02/10] refactor(qualifications): towards using dbtProj for companies (WIP) --- src/Handler/Qualification.hs | 70 +++++++++++++++++++++-------------- src/Handler/Utils/DateTime.hs | 15 +++++++- 2 files changed, 56 insertions(+), 29 deletions(-) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index cfc4ae0da..e3d83f076 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -153,7 +153,7 @@ mkQualificationAllTable = do data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. { qtcDisplayName :: UserDisplayName , qtcEmail :: UserEmail - , qtcCompany :: Maybe Text + , qtcCompany :: [Text] , qtcValidUntil :: Day , qtcLastRefresh :: Day , qtcBlocked :: Maybe Day @@ -168,7 +168,7 @@ qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv { qtcDisplayName = "Max Mustermann" , qtcEmail = "m.mustermann@example.com" - , qtcCompany = Just "Example Brothers LLC" + , qtcCompany = ["Example Brothers LLC"] , qtcValidUntil = compDay , qtcLastRefresh = compDay , qtcBlocked = Nothing @@ -212,24 +212,19 @@ instance CsvColumnsExplained QualificationTableCsv where 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))) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) -queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) +queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) -queryLmsUser = $(sqlLOJproj 3 2) - -queryCompany :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity Company)) -queryCompany = $(sqlIJproj 2 2) . $(sqlLOJproj 3 3) +queryLmsUser = $(sqlLOJproj 2 2) -type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity Company)) +type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany]) resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -240,8 +235,8 @@ resultUser = _dbrOutput . _2 resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just -resultCompany :: Traversal' QualificationTableData (Entity Company) -resultCompany = _dbrOutput . _4 . _Just +resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] +resultCompanyUser = _dbrOutput . _4 instance HasEntity QualificationTableData User where @@ -286,17 +281,14 @@ isBlockAct _ = False qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) - , E.SqlExpr (Maybe (Entity LmsUser)) - , E.SqlExpr (Maybe (Entity Company)) + , E.SqlExpr (Maybe (Entity LmsUser)) ) -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 +qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do 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, company) + return (qualUser, user, lmsUser) mkQualificationTable :: @@ -306,7 +298,7 @@ mkQualificationTable :: => Bool -> Entity Qualification -> Map QualificationTableAction (AForm Handler QualificationTableActionData) - -> cols + -> (Map CompanyId (Entity Company) -> cols) -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do @@ -314,6 +306,12 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do now <- liftIO getCurrentTime let nowaday = utctDay now + companyStamp = "CompanyMap" <> tshow (roundDownToMinutes 5 now) + -- lookup all companies + cmpMap <- $cachedHereBinary companyStamp $ do + cmps <- selectList [] [Asc CompanyId] + return $ Map.fromAscList $ fmap (\c -> (entityKey c, c)) cmps + let mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text @@ -321,8 +319,15 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs dbtSQLQuery = qualificationTableQuery qid fltrSvs dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjId -- FilteredPostId - dbtColonnade = cols + dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr) -> do + -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do + -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + -- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr) + -- E.orderBy [E.asc (comp E.^. CompanyName)] + -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor) + cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] + return (qualUsr, usr, lmsUsr, cmpUsr) + dbtColonnade = cols cmpMap dbtSorting = mconcat [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser @@ -340,8 +345,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) - ) - , single ( "company", SortColumn $ queryCompany >>> (E.?. CompanyName)) + ) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser @@ -390,7 +394,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = QualificationTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) - <*> preview (resultCompany . _entityVal . _companyName . _CI) + <*> pure ["TODO: companies not yet exported"] <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) @@ -456,7 +460,7 @@ postQualificationR sid qsh = do linkLmsUser = toMaybe isAdmin LmsUserR linkUserName = bool ForProfileR ForProfileDataR isAdmin blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin - colChoices = mconcat + colChoices cmpMap = mconcat [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail @@ -470,7 +474,17 @@ 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 + , sortable (Just "company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) -> do + let icnSuper = text2markup " " <> icon IconSupervisor + cs = [ (cmpName, cmpSpr) + | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps + , let cmpEnt = Map.lookup cmpId cmpMap + , isJust cmpEnt + , let Just (Entity _ Company{companyName = cmpName}) = cmpEnt + ] + companies = intersperse (text2markup ", ") $ + (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs + pure $ toWgt $ mconcat companies , 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 diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index a29ff5f6b..80669b061 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -8,7 +8,8 @@ module Handler.Utils.DateTime ( utcToLocalTime, utcToZonedTime , localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple , toTimeOfDay - , toMidnight, beforeMidnight, toMidday, toMorning, addHours + , toMidnight, beforeMidnight, toMidday, toMorning + , toFullHour, roundDownToMinutes, addHours , formatDiffDays, formatCalendarDiffDays , formatTime' , formatTime, formatTimeUser, formatTimeW, formatTimeMail @@ -68,6 +69,18 @@ toMidnight = toTimeOfDay 0 0 0 toMidday :: Day -> UTCTime toMidday = toTimeOfDay 12 0 0 +-- | Round up to next full hour +toFullHour :: UTCTime -> UTCTime +toFullHour t = t{utctDayTime=rounded} + where + rounded = fromInteger $ 3600 * (1 + (truncate (utctDayTime t) `div` 3600)) + +roundDownToMinutes :: Integer -> UTCTime -> UTCTime +roundDownToMinutes f t = t{utctDayTime=rounded} + where + rounded = fromInteger $ factor * (truncate (utctDayTime t) `div` factor) + factor = 60 * f + -- | One second before the end of day beforeMidnight :: Day -> UTCTime beforeMidnight = toTimeOfDay 23 59 59 From f1ec4d0b7b4b83d16be6ba94ae8766eff753d9ea Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Apr 2023 08:59:37 +0000 Subject: [PATCH 03/10] refactor(qualifications): towards using dbtProj for companies working --- src/Handler/Qualification.hs | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index e3d83f076..9150ab903 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -153,7 +153,7 @@ mkQualificationAllTable = do data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. { qtcDisplayName :: UserDisplayName , qtcEmail :: UserEmail - , qtcCompany :: [Text] + , qtcCompany :: Maybe Text , qtcValidUntil :: Day , qtcLastRefresh :: Day , qtcBlocked :: Maybe Day @@ -168,7 +168,7 @@ qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv { qtcDisplayName = "Max Mustermann" , qtcEmail = "m.mustermann@example.com" - , qtcCompany = ["Example Brothers LLC"] + , qtcCompany = Just "Example Brothers LLC, SecondayJobs Inc" , qtcValidUntil = compDay , qtcLastRefresh = compDay , qtcBlocked = Nothing @@ -281,7 +281,7 @@ isBlockAct _ = False qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) - , E.SqlExpr (Maybe (Entity LmsUser)) + , E.SqlExpr (Maybe (Entity LmsUser)) ) qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser @@ -345,7 +345,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) - ) + ) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser @@ -394,7 +394,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = QualificationTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) - <*> pure ["TODO: companies not yet exported"] + <*> pure (Just "TODO: companies not yet exported") <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) @@ -444,7 +444,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html getQualificationR = postQualificationR postQualificationR sid qsh = do - isAdmin <- hasReadAccessTo AdminR + isAdmin <- hasReadAccessTo AdminR ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) @@ -461,7 +461,7 @@ postQualificationR sid qsh = do linkUserName = bool ForProfileR ForProfileDataR isAdmin blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin colChoices cmpMap = mconcat - [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) + [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" @@ -470,21 +470,20 @@ postQualificationR sid qsh = do E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ + let companies = intercalate (text2markup ", ") $ (\(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) $ \( view resultCompanyUser -> cmps) -> do + pure $ toWgt companies + , sortable (Just "company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) -> let icnSuper = text2markup " " <> icon IconSupervisor cs = [ (cmpName, cmpSpr) | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps , let cmpEnt = Map.lookup cmpId cmpMap - , isJust cmpEnt - , let Just (Entity _ Company{companyName = cmpName}) = cmpEnt + , Just (Entity _ Company{companyName = cmpName}) <- [cmpEnt] ] - companies = intersperse (text2markup ", ") $ + companies = intercalate (text2markup ", ") $ (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs - pure $ toWgt $ mconcat companies + in wgtCell companies , 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 From fcc2c1b3ab5ca914841fd93bbb8bedeeaa14ee11 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Apr 2023 11:15:26 +0000 Subject: [PATCH 04/10] refactor(qualifications): towards using dbtProj for companies working (2) --- .../utils/table_column/de-de-formal.msg | 2 ++ messages/uniworx/utils/table_column/en-eu.msg | 2 ++ src/Handler/Admin/Avs.hs | 2 +- src/Handler/LMS.hs | 2 +- src/Handler/Qualification.hs | 19 ++++++++++++++----- src/Handler/Users.hs | 2 +- src/Handler/Utils/Table/Columns.hs | 4 ++-- 7 files changed, 23 insertions(+), 10 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index f0ce25d50..c3247ecf5 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -74,4 +74,6 @@ TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelPriority: Label-Priorität TableQualifications: Qualifikationen TableCompany: Firma +TableCompanies: Firmen +TableCompanyNos: Firmennummern TableSupervisor: Ansprechpartner diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 6eeed21d1..5ff701e6a 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -74,4 +74,6 @@ TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelPriority: Label priority TableQualifications: Qualifications TableCompany: Company +TableCompanies: Companies +TableCompanyNos: Company numbers TableSupervisor: Supervisor diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 7d101e786..88b490be6 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -538,7 +538,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do , colUserNameLink AdminUserR , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a -- , colUserCompany - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index c88cfb9ba..58c87494f 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -517,7 +517,7 @@ postLmsR sid qsh = do [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 9150ab903..9dc345872 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -154,6 +154,7 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. { qtcDisplayName :: UserDisplayName , qtcEmail :: UserEmail , qtcCompany :: Maybe Text + , qtcCompanyNumbers :: CsvSemicolonList Int , qtcValidUntil :: Day , qtcLastRefresh :: Day , qtcBlocked :: Maybe Day @@ -168,7 +169,8 @@ qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv { qtcDisplayName = "Max Mustermann" , qtcEmail = "m.mustermann@example.com" - , qtcCompany = Just "Example Brothers LLC, SecondayJobs Inc" + , qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" + , qtcCompanyNumbers = CsvSemicolonList [27,69] , qtcValidUntil = compDay , qtcLastRefresh = compDay , qtcBlocked = Nothing @@ -201,7 +203,8 @@ instance CsvColumnsExplained QualificationTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList [ ('qtcDisplayName , SomeMessage MsgLmsUser) , ('qtcEmail , SomeMessage MsgTableLmsEmail) - , ('qtcCompany , SomeMessage MsgTableCompany) + , ('qtcCompany , SomeMessage MsgTableCompanies) + , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) @@ -394,13 +397,19 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = QualificationTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) - <*> pure (Just "TODO: companies not yet exported") + <*> (view resultCompanyUser >>= getCompanies) + <*> (view resultCompanyUser >>= getCompanyNos) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt <*> getStatusPlusDay + getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of + [] -> pure Nothing + somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_entityVal . _companyName . _CI)) somecmps + getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _entityVal . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) + getStatusPlusTxt = (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case Just LmsBlocked{} -> return $ Just "Failed" @@ -464,7 +473,7 @@ postQualificationR sid qsh = do [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid @@ -474,7 +483,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 companies - , sortable (Just "company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) -> + , sortable (Just "company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> let icnSuper = text2markup " " <> icon IconSupervisor cs = [ (cmpName, cmpSpr) | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 67e3ac395..0bc4e434a 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -100,7 +100,7 @@ postUsersR = do (AdminUserR <$> encrypt uid) (nameWidget userDisplayName userSurname) , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 473b3c484..07a122af2 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -718,7 +718,7 @@ fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI {- -- colUserCompany :: (HandlerSite (DBCell m) ~ UniWorX, IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) -colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu -> do +colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> do let uid = heu ^. hasEntity . _entityKey companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid @@ -732,7 +732,7 @@ colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \he -- PROBLEM: how to type sqlCell compatible with dbTable that as actions, i.e. MForm instead of YesodDB? colUserCompany :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c) -colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu -> +colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> let uid = heu ^. hasEntity . _entityKey in sqlCell $ do companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do From eba437de33ba463574abf3ea7a2a14993e0854fb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Apr 2023 11:15:51 +0000 Subject: [PATCH 05/10] refactor(csv): change new user default to xlsx working now --- src/Handler/LMS/Users.hs | 3 ++- src/Handler/SAP.hs | 3 ++- src/Handler/Utils/LMS.hs | 3 ++- src/Model/Types/Csv.hs | 2 +- src/Utils/Users.hs | 2 +- 5 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 5af247638..9a0eb8e96 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -177,7 +177,8 @@ getLmsUsersDirectR sid qsh = do --csvRenderedHeader = lmsUserTableCsvHeader --cvsRendered = CsvRendered {..} csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users - fmtOpts = def { csvIncludeHeader = lmsDownloadHeader + fmtOpts = (review csvPreset CsvPresetRFC) + { csvIncludeHeader = lmsDownloadHeader , csvDelimiter = lmsDownloadDelimiter , csvUseCrLf = lmsDownloadCrLf } diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 5365b00fd..79e69d222 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -97,7 +97,8 @@ getQualificationSAPDirectR = do , qual Ex.^. QualificationSapId ) let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers - fmtOpts = def { csvIncludeHeader = True + fmtOpts = (review csvPreset CsvPresetRFC) + { csvIncludeHeader = True , csvDelimiter = ',' , csvUseCrLf = True } diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 8d05b5618..680a75b40 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -45,7 +45,8 @@ getLmsCsvDecoder :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, From getLmsCsvDecoder = do LmsConf{..} <- getsYesod $ view _appLmsConf if | Just upDelim <- lmsUploadDelimiter -> do - let fmtOpts = def { csvDelimiter = upDelim + let fmtOpts = (review csvPreset CsvPresetRFC) + { csvDelimiter = upDelim , csvIncludeHeader = lmsUploadHeader } csvOpts = def { csvFormat = fmtOpts } diff --git a/src/Model/Types/Csv.hs b/src/Model/Types/Csv.hs index b859ab0ee..62ac641e1 100644 --- a/src/Model/Types/Csv.hs +++ b/src/Model/Types/Csv.hs @@ -85,7 +85,7 @@ instance Default CsvOptions where } instance Default CsvFormatOptions where - def = CsvXlsxFormatOptions -- csvPreset # CsvPresetRFC + def = csvPreset # CsvPresetRFC -- changing the default here to CsvPresetXlsx will cause internal server errors to to partial record selectors failing data CsvPreset = CsvPresetRFC | CsvPresetXlsx diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs index 36721dd7c..2339fbed5 100644 --- a/src/Utils/Users.hs +++ b/src/Utils/Users.hs @@ -73,7 +73,7 @@ addNewUser AddUserData{..} = do , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels , userNotificationSettings = def , userLanguages = Nothing - , userCsvOptions = def + , userCsvOptions = def { csvFormat = review csvPreset CsvPresetXlsx } , userTokensIssuedAfter = Nothing , userCreated = now , userLastLdapSynchronisation = Nothing From bb2c0858d1ee8d28d73757f20508a8f0b045533d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Apr 2023 12:58:20 +0000 Subject: [PATCH 06/10] docs(dbtable): clarify usage of dbtProj --- src/Handler/Admin.hs | 2 +- src/Handler/Admin/Avs.hs | 3 +-- src/Handler/LMS.hs | 2 +- src/Handler/LMS/Result.hs | 2 +- src/Handler/LMS/Userlist.hs | 2 +- src/Handler/LMS/Users.hs | 2 +- src/Handler/PrintCenter.hs | 2 +- src/Handler/Qualification.hs | 5 ++--- src/Handler/Utils/Table/Pagination.hs | 5 +++++ src/Model/Types/Csv.hs | 3 ++- 10 files changed, 16 insertions(+), 12 deletions(-) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 59614fd5a..25c26d110 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -137,7 +137,7 @@ mkUnreachableUsersTable = do E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") pure user dbtRowKey = (E.^. UserId) - dbtProj = dbtProjFilteredPostId -- TODO: still don't understand the choices here + dbtProj = dbtProjId dbtColonnade = -} diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 88b490be6..4c0a76b7d 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -530,8 +530,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do return (usrAvs, user, qualUser, qual) dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR? -- Not sure what changes here: - dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) - -- dbtProj = dbtProjFilteredPostId + dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) dbtColonnade = mconcat [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId) -- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 58c87494f..ef8f77347 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -124,7 +124,7 @@ mkLmsAllTable isAdmin = do -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem return (quali, cactive, cusers) dbtRowKey = (Ex.^. QualificationId) - dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference? + dbtProj = dbtProjId adminable = if isAdmin then sortable else \_ _ _ -> mempty dbtColonnade = dbColonnade $ mconcat [ colSchool $ resultAllQualification . _qualificationSchool diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index c9bec0c04..6662d7574 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -96,7 +96,7 @@ mkResultTable sid qsh qid = do E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid return lmsresult dbtRowKey = (E.^. LmsResultId) - dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index a9ccbf942..407c7436e 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -94,7 +94,7 @@ mkUserlistTable sid qsh qid = do E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid return lmslist dbtRowKey = (E.^. LmsUserlistId) - dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent , sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 9a0eb8e96..97ab76850 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -95,7 +95,7 @@ mkUserTable _sid qsh qid = do E.&&. E.isNothing (lmsuser E.^. LmsUserEnded) return lmsuser dbtRowKey = (E.^. LmsUserId) - dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index cd3beeec1..4a1911e5a 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -161,7 +161,7 @@ mkPJTable = do let dbtSQLQuery = pjTableQuery dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) - dbtProj = dbtProjFilteredPostId + dbtProj = dbtProjId dbtColonnade = mconcat [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) , sortable (Just "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 9dc345872..141cc9357 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -3,7 +3,6 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances -{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only {-# LANGUAGE TypeApplications #-} module Handler.Qualification @@ -46,7 +45,7 @@ getQualificationSchoolR :: SchoolId -> Handler Html getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) getQualificationAllR :: Handler Html -getQualificationAllR = do -- TODO just a stub +getQualificationAllR = do qualiTable <- runDB $ do view _2 <$> mkQualificationAllTable siteLayoutMsg MsgMenuQualifications $ do @@ -88,7 +87,7 @@ mkQualificationAllTable = do Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser return (quali, cactive, cusers) dbtRowKey = (Ex.^. QualificationId) - dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference? + dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ colSchool $ resultAllQualification . _qualificationSchool , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 076b1ac29..d3852d2eb 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -716,6 +716,7 @@ dbtProjId' :: forall fs r r'. => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' dbtProjId' = view _dbtProjRow +-- | Reicht das Ergebnis der SQL-Abfrage direkt durch an colonnade und csv dbtProjId :: forall fs r r'. ( fs ~ (), DBRow r ~ r' ) => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' @@ -727,6 +728,7 @@ dbtProjSimple' :: forall fs r r' r''. -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' dbtProjSimple' cont = (views _dbtProjRow . set _dbrOutput) <=< (hoist lift . magnify (_dbtProjRow . _dbrOutput)) $ lift . cont =<< ask +-- | Transformation des SQL Ergbnistyp vor dem Weiterreichen an colonnade oder csv durch eine einfache monadische Funktion dbtProjSimple :: forall fs r r' r''. ( fs ~ (), DBRow r'' ~ r' ) => (r -> DB r'') @@ -743,11 +745,14 @@ withFilteredPost proj = do guardM . lift . lift $ p r' return r' +-- | Wie `dbtProjId` plus zusätzliches Filtern der SQL-Abfrage in Haskell +-- Nur zu Verwenden, wenn Filter mit mkFilterProjectedPost verwendet werden; ein Typfehler weist daraufhin, wenn dies nötig ist! dbtProjFilteredPostId :: forall fs r r'. ( fs ~ DBTProjFilterPost r', DBRow r ~ r' ) => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' dbtProjFilteredPostId = withFilteredPost dbtProjId' +-- | Kombination aus `dbtProjFilteredPostId` und `dbtProjSimple`, d.h. Ergeniszeilen in Haskell transformieren und filtern dbtProjFilteredPostSimple :: forall fs r r' r''. ( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' ) => (r -> DB r'') diff --git a/src/Model/Types/Csv.hs b/src/Model/Types/Csv.hs index 62ac641e1..159339062 100644 --- a/src/Model/Types/Csv.hs +++ b/src/Model/Types/Csv.hs @@ -85,7 +85,8 @@ instance Default CsvOptions where } instance Default CsvFormatOptions where - def = csvPreset # CsvPresetRFC -- changing the default here to CsvPresetXlsx will cause internal server errors to to partial record selectors failing + def = csvPreset # CsvPresetRFC -- DO NOT CHANGE! + -- Changing the default to CsvPresetXlsx will cause internal server errors due to partial record selectors failing, like `csvIncludeHeader` data CsvPreset = CsvPresetRFC | CsvPresetXlsx From 4df024374d387fc85a833b3faffe1b6ef8edc7d9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Apr 2023 14:52:02 +0000 Subject: [PATCH 07/10] feat(qualfications): renewal actions and filtering by card and personal number --- .../categories/qualification/de-de-formal.msg | 1 + .../categories/qualification/en-eu.msg | 1 + src/Handler/Qualification.hs | 68 +++++++++++-------- test/Database/Fill.hs | 6 +- 4 files changed, 45 insertions(+), 31 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 1d76ad70f..6267eff82 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -86,6 +86,7 @@ QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung un QualificationActBlockSupervisor: Dauerhaft entziehen und Ansprechpartner entfernen, mit sofortiger Wirkung QualificationActBlock: Entziehen QualificationActUnblock: Entzug löschen +QualificationActRenew: Qualifikation regulär verlängern QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach. diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 25de10365..6880fa3ee 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -86,6 +86,7 @@ QualificationSetUnexpire n: Expiry notification and e‑learning activated for # QualificationActBlockSupervisor: Waive permanently and remove all supervisiors, effective immediately QualificationActBlock: Revoke QualificationActUnblock: Clear revocation +QualificationActRenew: Renew Qualification QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter. diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 141cc9357..8d693c17f 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -253,21 +253,30 @@ data QualificationTableAction | QualificationActBlockSupervisor | QualificationActBlock | QualificationActUnblock - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + | QualificationActRenew + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe QualificationTableAction instance Finite QualificationTableAction nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''QualificationTableAction id --- Not yet needed, since there is no additional data for now: +{- +isAdminAct :: QualificationTableAction -> Bool +isAdminAct QualificationActExpire = False +isAdminAct QualificationActUnexpire = False +isAdminAct QualificationActBlockSupervisor = False +isAdminAct _ = True +-} + data QualificationTableActionData = QualificationActExpireData | QualificationActUnexpireData | QualificationActBlockSupervisorData - | QualificationActBlockData { qualTableActBlockReason :: Text} + | QualificationActBlockData { qualTableActBlockReason :: Text} | QualificationActUnblockData - deriving (Eq, Ord, Read, Show, Generic) + | QualificationActRenewData + deriving (Eq, Ord, Read, Show, Generic) isExpiryAct :: QualificationTableActionData -> Bool isExpiryAct QualificationActExpireData = True @@ -356,15 +365,17 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) - , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> - E.from $ \(usrComp `E.InnerJoin` comp) -> do - let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` - (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) - testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId - testcrit = maybe testname testnumber $ readMay $ CI.original criterion - E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId - E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit - ) + , single ("avs-card" , FilterColumn . E.mkExistsFilter $ \row criterion -> + E.from $ \(usrAvs `E.InnerJoin` avsCard) -> do + E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId + E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId + E.&&. ((E.explicitUnsafeCoerceSqlExprValue "citext" (avsCard E.^. UserAvsCardCardNo) :: E.SqlExpr (E.Value (CI Text))) + `E.hasInfix` (E.val criterion :: E.SqlExpr (E.Value (CI Text)))) + ) + , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if + | Set.null criteria -> E.true + | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria + ) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> if | Just renewal <- mbRenewal @@ -375,8 +386,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev - , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) - , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) + , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) + , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) + , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) + , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) @@ -460,10 +473,11 @@ postQualificationR sid qsh = do [ singletonMap QualificationActExpire $ pure QualificationActExpireData , singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData ] ++ bool - [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin Supervisor - [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData + [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin actions, ie. Supervisor + [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData -- Admin-only actions , singletonMap QualificationActBlock $ QualificationActBlockData <$> apreq textField (fslI MsgQualificationBlockReason) Nothing + , singletonMap QualificationActRenew $ pure QualificationActRenewData ] isAdmin linkLmsUser = toMaybe isAdmin LmsUserR linkUserName = bool ForProfileR ForProfileDataR isAdmin @@ -471,18 +485,8 @@ postQualificationR sid qsh = do colChoices cmpMap = mconcat [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName - , colUserEmail - , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" - companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do - E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId - E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid - E.orderBy [E.asc (comp E.^. CompanyName)] - return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intercalate (text2markup ", ") $ - (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' - icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt companies - , sortable (Just "company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> + , colUserEmail + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> let icnSuper = text2markup " " <> icon IconSupervisor cs = [ (cmpName, cmpSpr) | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps @@ -509,7 +513,11 @@ postQualificationR sid qsh = do tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator return (tbl, qent) - formResult lmsRes $ \case + formResult lmsRes $ \case + (QualificationActRenewData, selectedUsers) | isAdmin -> do + noks <- runDB $ renewValidQualificationUsers qid $ Set.toList selectedUsers + addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks + reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isExpiryAct action -> do let isUnexpire = action == QualificationActUnexpireData upd <- runDB $ updateWhereCount diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 13c67c30c..8d34c713b 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -163,7 +163,7 @@ fillDb = do , userAuthentication = pwSimple , userLastAuthentication = Nothing , userTokensIssuedAfter = Nothing - , userMatrikelnummer = Just "94094094094" + , userMatrikelnummer = Just "12345678" , userEmail = "S.Jost@Fraport.de" , userDisplayEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" @@ -680,6 +680,10 @@ fillDb = do void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 + void . insert' $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now + void . insert' $ UserAvsCard (AvsPersonId 2) (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now + void . insert' $ UserAvsCard (AvsPersonId 3) (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now + void . insert' $ UserAvsCard (AvsPersonId 4) (AvsFullCardNo (AvsCardNo "9999") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "9999") "4") now let f_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] let r_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] From 2093cf501827ab2305f26ab5cf742f2b0be4a7de Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Apr 2023 15:56:12 +0000 Subject: [PATCH 08/10] fix(cvs): export company in e-learning view --- src/Handler/LMS.hs | 226 +++++++++++++++++++---------------- src/Handler/Qualification.hs | 2 +- 2 files changed, 124 insertions(+), 104 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index ef8f77347..d902aed38 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -195,38 +195,42 @@ postLmsEditR = error "TODO: STUB" data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. - { ltcDisplayName :: UserDisplayName - , ltcEmail :: UserEmail - , ltcValidUntil :: Day - , ltcLastRefresh :: Day - , ltcFirstHeld :: Day - , ltcBlockedDue :: Maybe QualificationBlocked - , ltcLmsIdent :: Maybe LmsIdent - , ltcLmsStatus :: Maybe LmsStatus - , ltcLmsStarted :: Maybe UTCTime - , ltcLmsDatePin :: Maybe UTCTime - , ltcLmsReceived :: Maybe UTCTime - , ltcLmsNotified :: Maybe UTCTime - , ltcLmsEnded :: Maybe UTCTime + { ltcDisplayName :: UserDisplayName + , ltcEmail :: UserEmail + , ltcCompany :: Maybe Text + , ltcCompanyNumbers :: CsvSemicolonList Int + , ltcValidUntil :: Day + , ltcLastRefresh :: Day + , ltcFirstHeld :: Day + , ltcBlockedDue :: Maybe QualificationBlocked + , ltcLmsIdent :: Maybe LmsIdent + , ltcLmsStatus :: Maybe LmsStatus + , ltcLmsStarted :: Maybe UTCTime + , ltcLmsDatePin :: Maybe UTCTime + , ltcLmsReceived :: Maybe UTCTime + , ltcLmsNotified :: Maybe UTCTime + , ltcLmsEnded :: Maybe UTCTime } deriving Generic makeLenses_ ''LmsTableCsv ltcExample :: LmsTableCsv ltcExample = LmsTableCsv - { ltcDisplayName = "Max Mustermann" - , ltcEmail = "m.mustermann@example.com" - , ltcValidUntil = compDay - , ltcLastRefresh = compDay - , ltcFirstHeld = compDay - , ltcBlockedDue = Nothing - , ltcLmsIdent = Nothing - , ltcLmsStatus = Nothing - , ltcLmsStarted = Just compTime - , ltcLmsDatePin = Nothing - , ltcLmsReceived = Nothing - , ltcLmsNotified = Nothing - , ltcLmsEnded = Nothing + { ltcDisplayName = "Max Mustermann" + , ltcEmail = "m.mustermann@example.com" + , ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" + , ltcCompanyNumbers = CsvSemicolonList [27,69] + , ltcValidUntil = compDay + , ltcLastRefresh = compDay + , ltcFirstHeld = compDay + , ltcBlockedDue = Nothing + , ltcLmsIdent = Nothing + , ltcLmsStatus = Nothing + , ltcLmsStarted = Just compTime + , ltcLmsDatePin = Nothing + , ltcLmsReceived = Nothing + , ltcLmsNotified = Nothing + , ltcLmsEnded = Nothing } where compTime :: UTCTime @@ -253,35 +257,37 @@ instance Csv.DefaultOrdered LmsTableCsv where instance CsvColumnsExplained LmsTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList - [ ('ltcDisplayName, MsgLmsUser) - , ('ltcEmail , MsgTableLmsEmail) - , ('ltcValidUntil , MsgLmsQualificationValidUntil) - , ('ltcLastRefresh, MsgTableQualificationLastRefresh) - , ('ltcFirstHeld , MsgTableQualificationFirstHeld) - , ('ltcLmsIdent , MsgTableLmsIdent) - , ('ltcLmsStatus , MsgTableLmsStatus) - , ('ltcLmsStarted , MsgTableLmsStarted) - , ('ltcLmsDatePin , MsgTableLmsDatePin) - , ('ltcLmsReceived, MsgTableLmsReceived) - , ('ltcLmsEnded , MsgTableLmsEnded) + [ ('ltcDisplayName , SomeMessage MsgLmsUser) + , ('ltcEmail , SomeMessage MsgTableLmsEmail) + , ('ltcCompany , SomeMessage MsgTableCompanies) + , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos) + , ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil) + , ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) + , ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld) + , ('ltcLmsIdent , SomeMessage MsgTableLmsIdent) + , ('ltcLmsStatus , SomeMessage MsgTableLmsStatus) + , ('ltcLmsStarted , SomeMessage MsgTableLmsStarted) + , ('ltcLmsDatePin , SomeMessage MsgTableLmsDatePin) + , ('ltcLmsReceived , SomeMessage MsgTableLmsReceived) + , ('ltcLmsEnded , SomeMessage MsgTableLmsEnded) ] -type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) - `E.InnerJoin` E.SqlExpr (Entity User) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) +type LmsTableExpr = E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + `E.InnerJoin` E.SqlExpr (Entity LmsUser) queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) -queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) +queryQualUser = $(sqlIJproj 3 1) queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) +queryUser = $(sqlIJproj 3 2) -queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) -queryLmsUser = $(sqlLOJproj 2 2) +queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser) +queryLmsUser = $(sqlIJproj 3 3) -type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), E.Value (Maybe [Maybe UTCTime])) +type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany]) resultQualUser :: Lens' LmsTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -289,12 +295,15 @@ resultQualUser = _dbrOutput . _1 resultUser :: Lens' LmsTableData (Entity User) resultUser = _dbrOutput . _2 -resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) -resultLmsUser = _dbrOutput . _3 . _Just +resultLmsUser :: Lens' LmsTableData (Entity LmsUser) +resultLmsUser = _dbrOutput . _3 resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] resultPrintAck = _dbrOutput . _4 . _unValue . _Just +resultCompanyUser :: Lens' LmsTableData [Entity UserCompany] +resultCompanyUser = _dbrOutput . _5 + instance HasEntity LmsTableData User where hasEntity = resultUser @@ -330,53 +339,58 @@ isRenewPinAct LmsActRenewPinData = True lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) - , E.SqlExpr (Maybe (Entity LmsUser)) + , E.SqlExpr (Entity LmsUser) , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs ) -lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do +lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do -- RECALL: another outer join on PrintJob did not work out well, since -- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; -- - using noExsists on printJob join condition works, but only deliver single value; -- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest - 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.==. 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_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other! -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) - E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser)) + E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser)) let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder return (qualUser, user, lmsUser, printAcknowledged) -mkLmsTable :: forall h p cols act act'. - ( Functor h, ToSortable h - , Ord act, PathPiece act, RenderMessage UniWorX act - , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols +mkLmsTable :: ( Functor h, ToSortable h + , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))) cols ) => Bool -> Entity Qualification - -> Map act (AForm Handler act') - -> cols - -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) - -> DB (FormResult (act', Set UserId), Widget) + -> Map LmsTableAction (AForm Handler LmsTableActionData) + -> (Map CompanyId (Entity Company) -> cols) + -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData)) + -> DB (FormResult (LmsTableActionData, Set UserId), Widget) mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do - now <- liftIO getCurrentTime - let + now <- liftIO getCurrentTime + let nowaday = utctDay now + companyStamp = "CompanyMap" <> tshow (roundDownToMinutes 5 now) + -- lookup all companies + cmpMap <- $cachedHereBinary companyStamp $ do + cmps <- selectList [] [Asc CompanyId] + return $ Map.fromAscList $ fmap (\c -> (entityKey c, c)) cmps + let mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "qualification" dbtSQLQuery = lmsTableQuery qid dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjId - - dbtColonnade = cols + dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, printAcks) -> do + cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] + return (qualUsr, usr, lmsUsr, printAcks, cmpUsr) + dbtColonnade = cols cmpMap dbtSorting = mconcat [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser @@ -386,14 +400,14 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) - , single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserIdent)) - , single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserPin)) - , single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.?. LmsUserStatus)) - , single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserStarted)) - , single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserDatePin)) - , single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived)) - , single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date - , single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserEnded)) + , single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) + , single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) + , single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus)) + , single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) + , single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) + , single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) + , single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date + , single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId @@ -403,7 +417,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser - , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) + , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) -- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) @@ -413,7 +427,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | otherwise -> E.true ) - , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified))) + , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId @@ -455,6 +469,8 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = LmsTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) + <*> (view resultCompanyUser >>= getCompanies) + <*> (view resultCompanyUser >>= getCompanyNos) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) @@ -466,6 +482,11 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) + getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of + [] -> pure Nothing + somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_entityVal . _companyName . _CI)) somecmps + getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _entityVal . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) + dbtCsvDecode = Nothing dbtExtraReps = [] dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else @@ -513,20 +534,20 @@ postLmsR sid qsh = do -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData ] -- lmsStatusLink = toMaybe isAdmin LmsUserR - colChoices = mconcat + colChoices cmpMap = mconcat [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail - , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" - companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do - E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId - E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid - E.orderBy [E.asc (comp E.^. CompanyName)] - return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ - (\(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 "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> + let icnSuper = text2markup " " <> icon IconSupervisor + cs = [ (cmpName, cmpSpr) + | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps + , let cmpEnt = Map.lookup cmpId cmpMap + , Just (Entity _ Company{companyName = cmpName}) <- [cmpEnt] + ] + companies = intercalate (text2markup ", ") $ + (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs + in wgtCell companies , 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 @@ -535,22 +556,22 @@ postLmsR sid qsh = do ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification - , sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid + , sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid , sortable (Just "lms-pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] - ) $ \(preview $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> foldMap textCell pin - , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status - , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d - , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d - , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d - --, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d - , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row -> + ) $ \(view $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> textCell pin + , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(view $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell status + , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> dateTimeCell d + , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> dateTimeCell d + , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d + --, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(view $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d + , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row -> -- 4 Cases: -- - No notification: LmsUserNotified == Nothing -- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing -- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _ -- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _ - let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified - lmsident = row ^? resultLmsUser . _entityVal . _lmsUserIdent + let notifyDate = row ^. resultLmsUser . _entityVal . _lmsUserNotified + lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent recipient = row ^. hasUser letterDates = row ^? resultPrintAck lastLetterDate = headDef Nothing =<< letterDates @@ -560,7 +581,7 @@ postLmsR sid qsh = do cDate = if | not letterSent -> foldMap dateTimeCell notifyDate | Just d <- lastLetterDate -> dateTimeCell d | otherwise -> i18nCell MsgPrintJobUnacknowledged - lprLink :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)])) + lprLink :: Route UniWorX = lmsident & (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)])) cAckDates = case letterDates of Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|

@@ -572,11 +593,10 @@ postLmsR sid qsh = do $maybe ackdate <- mbackdate ^{formatTimeW SelFormatDateTime ackdate} $nothing - _{MsgPrintJobUnacknowledged} - $maybe lu <- lprLink -

- - _{MsgPrintJobs} + _{MsgPrintJobUnacknowledged} +

+ + _{MsgPrintJobs} |] -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)]) _ -> mempty @@ -585,7 +605,7 @@ postLmsR sid qsh = do then mempty else cIcon <> spacerCell <> cDate <> cAckDates -- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d) - , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d + , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(view $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell d ] where -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 8d693c17f..fc0a0c46e 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -304,7 +304,7 @@ qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` mkQualificationTable :: ( Functor h, ToSortable h - , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols + , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols ) => Bool -> Entity Qualification From 484cac208f85be8dd8e4fa2845a78c87154023f8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Apr 2023 16:00:08 +0000 Subject: [PATCH 09/10] chore(lms): add filter for personnel- and card numbers --- src/Handler/LMS.hs | 41 +++++++++++++++++++++++++++-------------- 1 file changed, 27 insertions(+), 14 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index d902aed38..1f4821a54 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -381,7 +381,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do cmps <- selectList [] [Asc CompanyId] return $ Map.fromAscList $ fmap (\c -> (entityKey c, c)) cmps let - mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday + -- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "qualification" @@ -421,12 +421,12 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do -- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) - , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> - if | Just renewal <- mbRenewal - , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal - E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday - | otherwise -> E.true - ) + -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> + -- if | Just renewal <- mbRenewal + -- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal + -- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday + -- | otherwise -> E.true + -- ) , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do @@ -441,18 +441,31 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do testcrit = maybe testname testnumber $ readMay $ CI.original criterion E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit - ) + ) + , single ("avs-card" , FilterColumn . E.mkExistsFilter $ \row criterion -> + E.from $ \(usrAvs `E.InnerJoin` avsCard) -> do + E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId + E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId + E.&&. ((E.explicitUnsafeCoerceSqlExprValue "citext" (avsCard E.^. UserAvsCardCardNo) :: E.SqlExpr (E.Value (CI Text))) + `E.hasInfix` (E.val criterion :: E.SqlExpr (E.Value (CI Text)))) + ) + , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if + | Set.null criteria -> E.true + | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria + ) ] dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailHdrUI MsgLmsUser mPrev - , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) - , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) + [ prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) + , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) + , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) + , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) - , if isNothing mbRenewal then mempty - else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) + -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) + -- , if isNothing mbRenewal then mempty + -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtCsvEncode = Just DBTCsvEncode From 33a847baa3310e6e261409f2cda9d964cf5a821d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Apr 2023 16:22:48 +0000 Subject: [PATCH 10/10] fix(qualifications): counts for lms/quals correct now --- src/Handler/LMS.hs | 23 +++++++++++------------ src/Handler/Qualification.hs | 17 ++++++----------- src/Handler/Utils/Users.hs | 8 ++++++++ 3 files changed, 25 insertions(+), 23 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 1f4821a54..ebefebe94 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -25,7 +25,7 @@ import Import import Jobs import Handler.Utils --- import Handler.Utils.Csv +import Handler.Utils.Users import Handler.Utils.LMS @@ -47,7 +47,6 @@ import Handler.LMS.Userlist as Handler.LMS import Handler.LMS.Result as Handler.LMS import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production! --- import Handler.Utils.Qualification (validQualification) -- avoids repetition of local definitions single :: (k,a) -> Map k a @@ -105,22 +104,22 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 resultAllQualificationTotal = _dbrOutput . _3 . _unValue - + mkLmsAllTable :: Bool -> DB (Any, Widget) mkLmsAllTable isAdmin = do - now <- liftIO getCurrentTime - + svs <- getSupervisees let resultDBTable = DBTable{..} where dbtSQLQuery quali = do - let cusers = Ex.subSelectCount $ do - quser <- Ex.from $ Ex.table @QualificationUser - Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId - cactive = Ex.subSelectCount $ do - quser <- Ex.from $ Ex.table @QualificationUser - Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId - Ex.&&. validQualification (utctDay now) quser + let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId + Ex.&&. (E.val isAdmin E.||. luser Ex.^. LmsUserUser `Ex.in_` E.vals svs) + cusers = Ex.subSelectCount $ do + luser <- Ex.from $ Ex.table @LmsUser + Ex.where_ $ filterSvs luser + cactive = Ex.subSelectCount $ do + luser <- Ex.from $ Ex.table @LmsUser + Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser E.^. LmsUserStatus) -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem return (quali, cactive, cusers) dbtRowKey = (Ex.^. QualificationId) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index fc0a0c46e..b312a83d5 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -16,7 +16,7 @@ import Import -- import Jobs import Handler.Utils --- import Handler.Utils.Csv +import Handler.Utils.Users import Handler.Utils.LMS @@ -46,8 +46,9 @@ getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-over getQualificationAllR :: Handler Html getQualificationAllR = do + isAdmin <- hasReadAccessTo AdminR qualiTable <- runDB $ do - view _2 <$> mkQualificationAllTable + view _2 <$> mkQualificationAllTable isAdmin siteLayoutMsg MsgMenuQualifications $ do setTitleI MsgMenuQualifications $(widgetFile "qualification-all") @@ -62,15 +63,9 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 resultAllQualificationTotal = _dbrOutput . _3 . _unValue -getSupervisees :: DB (Set UserId) -getSupervisees = do - uid <- requireAuthId - svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser] - return $ Set.insert uid $ Set.fromAscList svs - -mkQualificationAllTable :: DB (Any, Widget) -mkQualificationAllTable = do +mkQualificationAllTable :: Bool -> DB (Any, Widget) +mkQualificationAllTable isAdmin = do svs <- getSupervisees now <- liftIO getCurrentTime let @@ -78,7 +73,7 @@ mkQualificationAllTable = do where dbtSQLQuery quali = do let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId - Ex.&&. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs + Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs) cusers = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser Ex.where_ $ filterSvs quser diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index b5948021e..f583e65b1 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -18,6 +18,7 @@ module Handler.Utils.Users , getPostalAddress, getPostalPreferenceAndAddress , abbrvName , getReceivers + , getSupervisees ) where import Import @@ -110,6 +111,13 @@ getReceivers uid = do then directResult else return (underling, receivers, uid `elem` (entityKey <$> receivers)) +-- | return underlings for currently logged in user +getSupervisees :: DB (Set UserId) +getSupervisees = do + uid <- requireAuthId + svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser] + return $ Set.insert uid $ Set.fromAscList svs + computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256 computeUserAuthenticationDigest = hashlazy . JSON.encode