From 647964fc355665109fe9400e4c8cddf6e353ec0d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Oct 2023 18:23:39 +0200 Subject: [PATCH] chore(firm): add users filter for (foreign) supervisors --- .../uniworx/categories/firm/de-de-formal.msg | 4 +- messages/uniworx/categories/firm/en-eu.msg | 4 +- .../categories/settings/de-de-formal.msg | 3 +- .../uniworx/categories/settings/en-eu.msg | 3 +- src/Handler/Firm.hs | 538 +----------------- src/Handler/Profile.hs | 2 +- templates/profileData.hamlet | 2 +- 7 files changed, 37 insertions(+), 519 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 3758bc790..786e57dd6 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -5,4 +5,6 @@ FirmAllActNotify: Mitteilung versenden FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmUserActNotify: Mitteilung versenden -FirmUserActMkSuper: Zum Firmenansprechparnter ernennen +FirmUserActMkSuper: Zum Firmenansprechpartner ernennen +FilterSupervisor: Hat aktiven Ansprechpartner +FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 34ede15a2..a9e105cc3 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -5,4 +5,6 @@ FirmAllActNotify: Send message FirmAllActResetSupervision: Reset supervisors for all company associates FirmUserActNotify: Send message -FirmUserActMkSuper: Mark as company supervisor \ No newline at end of file +FirmUserActMkSuper: Mark as company supervisor +FilterSupervisor: Has active supervisor +FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} \ No newline at end of file diff --git a/messages/uniworx/categories/settings/de-de-formal.msg b/messages/uniworx/categories/settings/de-de-formal.msg index 028c2085f..302c38b84 100644 --- a/messages/uniworx/categories/settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/de-de-formal.msg @@ -37,7 +37,8 @@ PDFPassword: Passwort zur Verschlüsselung von PDF Anhängen an Email Benachrich PDFPasswordTip: Achtung, dieses Passwort ist für FRADrive Administratoren einsehbar und wird unverschlüsselt gespeichert! PDFPasswordInvalid c@Char: Bitte ein nicht-triviales Passwort für PDF Email Anhänge eintragen! Ungültiges Zeichen: #{char2Text c} PDFPasswordTooShort n@Int: Bitte ein PDF Passwort mit mindestens #{show n} Zeichen wählen oder Post-Versand aktivieren -PrefersPostal: Sollen Benachrichtigung möglichst per Post versendet werden anstatt per Email? +PrefersPostal: Bevorzugte Benachrichtigung +PrefersPostalExp: Sollen Benachrichtigung möglichst per Post versendet werden anstatt per Email? PostalTip: Postversand kann in Rechnung gestellt werden und ist derzeit nur für Benachrichtigungen über Erneuerung und Ablauf von Qualifikation, wie z.B. Führerscheine, verfügbar. PostAddress: Postalische Adresse PostAddressTip: Mindestens eine Zeile mit Straße und Hausnummer und eine Zeile mit Postleitzahl und Ort. Kein Empfängername, denn dieser wird später automatisch hinzugefügt. diff --git a/messages/uniworx/categories/settings/en-eu.msg b/messages/uniworx/categories/settings/en-eu.msg index 5fa8840f5..1a4790f5e 100644 --- a/messages/uniworx/categories/settings/en-eu.msg +++ b/messages/uniworx/categories/settings/en-eu.msg @@ -37,7 +37,8 @@ PDFPassword: Password to lock PDF email attachments PDFPasswordTip: Please note that this password is displayed to FRADrive admins and is saved unencrypted PDFPasswordInvalid c: Please supply a sensible password for encrypting PDF email attachments! Invalid character #{char2Text c} PDFPasswordTooShort n: Please provide a password with at least #{show n} characters or choose postal mail -PrefersPostal: Should notifications preferably send by post instead of email? +PrefersPostal: Notification preference +PrefersPostalExp: Should notifications preferably send by post instead of email? PostalTip: Mailing may incur a fee and is currently only avaulable for qualification expiry notifications, such as driving lincence renewal. PostAddress: Postal address PostAddressTip: Should contain at least one line with street and house number and another line featuring zip code and town. Omit a recipient name, since it will be added later. diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 46b08a864..4fcad5788 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -417,6 +417,7 @@ firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) mkFirmUserTable isAdmin cid = do let + fsh = unCompanyKey cid resultDBTable = DBTable{..} where dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do @@ -445,10 +446,33 @@ mkFirmUserTable isAdmin cid = do , singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute ] dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUserUser + [ single $ fltrUserNameEmail queryUserUser + , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + in case criterion of + Nothing -> E.true + Just True -> E.exists checkSuper + Just False -> E.notExists checkSuper + , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. E.exists (do + spr <- E.from $ E.table @UserCompany + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + ) + in case criterion of + Nothing -> E.true + Just True -> E.exists checkSuper + Just False -> E.notExists checkSuper ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev + , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) + , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmUserAction (AForm Handler FirmUserActionData) @@ -487,8 +511,6 @@ mkFirmUserTable isAdmin cid = do over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable - - getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do @@ -530,513 +552,3 @@ postFirmSupersR fsh = do siteLayout (citext2widget fsh) $ do setTitle $ citext2Html fsh [whamlet|!!!STUB!!!TO DO!!!|] - - --- data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. --- { qtcDisplayName :: UserDisplayName --- , qtcEmail :: UserEmail --- , qtcCompany :: Maybe Text --- , qtcCompanyNumbers :: CsvSemicolonList Int --- , qtcValidUntil :: Day --- , qtcLastRefresh :: Day --- , qtcBlockStatus :: Maybe Bool --- , qtcBlockFrom :: Maybe UTCTime --- , qtcScheduleRenewal:: Bool --- , qtcLmsStatusTxt :: Maybe Text --- , qtcLmsStatusDay :: Maybe UTCTime --- } --- deriving Generic --- makeLenses_ ''QualificationTableCsv - --- qtcExample :: QualificationTableCsv --- qtcExample = QualificationTableCsv --- { qtcDisplayName = "Max Mustermann" --- , qtcEmail = "m.mustermann@example.com" --- , qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" --- , qtcCompanyNumbers = CsvSemicolonList [27,69] --- , qtcValidUntil = compDay --- , qtcLastRefresh = compDay --- , qtcBlockStatus = Nothing --- , qtcBlockFrom = Nothing --- , qtcScheduleRenewal= True --- , qtcLmsStatusTxt = Just "Success" --- , qtcLmsStatusDay = Just compTime --- } --- where --- compTime :: UTCTime --- compTime = $compileTime --- compDay :: Day --- compDay = utctDay compTime - --- qtcOptions :: Csv.Options --- qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } --- where --- renameLtc "qtcDisplayName" = "licensee" --- renameLtc other = replaceLtc $ camelToPathPiece' 1 other --- replaceLtc ('l':'m':'s':'-':t) = prefixLms t --- replaceLtc other = other --- prefixLms = ("elearn-" <>) - --- instance Csv.ToNamedRecord QualificationTableCsv where --- toNamedRecord = Csv.genericToNamedRecord qtcOptions - --- instance Csv.DefaultOrdered QualificationTableCsv where --- headerOrder = Csv.genericHeaderOrder qtcOptions - --- instance CsvColumnsExplained QualificationTableCsv where --- csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList --- [ ('qtcDisplayName , SomeMessage MsgLmsUser) --- , ('qtcEmail , SomeMessage MsgTableLmsEmail) --- , ('qtcCompany , SomeMessage MsgTableCompanies) --- , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) --- , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) --- , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) --- , ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus) --- , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) --- , ('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)) --- `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) - --- queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) --- queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) - --- queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User) --- queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) - --- queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) --- queryLmsUser = $(sqlLOJproj 3 2) - --- queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) --- queryQualBlock = $(sqlLOJproj 3 3) - --- type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany]) - --- resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) --- resultQualUser = _dbrOutput . _1 - --- resultUser :: Lens' QualificationTableData (Entity User) --- resultUser = _dbrOutput . _2 - --- resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) --- resultLmsUser = _dbrOutput . _3 . _Just - --- resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock) --- resultQualBlock = _dbrOutput . _4 . _Just - --- resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] --- resultCompanyUser = _dbrOutput . _5 - - --- instance HasEntity QualificationTableData User where --- hasEntity = resultUser - --- instance HasUser QualificationTableData where --- hasUser = resultUser . _entityVal - --- instance HasEntity QualificationTableData QualificationUser where --- hasEntity = resultQualUser - --- instance HasQualificationUser QualificationTableData where --- hasQualificationUser = resultQualUser . _entityVal - --- -- instance HasEntity QualificationUserBlock where --- -- hasQualificationUserBlock = resultQualBlock - - --- data QualificationTableAction --- = QualificationActExpire --- | QualificationActUnexpire --- | QualificationActBlockSupervisor --- | QualificationActBlock --- | QualificationActUnblock --- | QualificationActRenew --- | QualificationActGrant --- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) - --- instance Universe QualificationTableAction --- instance Finite QualificationTableAction --- nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2 --- embedRenderMessage ''UniWorX ''QualificationTableAction id - --- {- --- isAdminAct :: QualificationTableAction -> Bool --- isAdminAct QualificationActExpire = False --- isAdminAct QualificationActUnexpire = False --- isAdminAct QualificationActBlockSupervisor = False --- isAdminAct _ = True --- -} - --- data QualificationTableActionData --- = QualificationActExpireData --- | QualificationActUnexpireData --- | QualificationActBlockSupervisorData --- | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } --- | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool} --- | QualificationActRenewData --- | QualificationActGrantData { qualTableActGrantUntil :: Day } --- deriving (Eq, Ord, Show, Generic) - --- isExpiryAct :: QualificationTableActionData -> Bool --- isExpiryAct QualificationActExpireData = True --- isExpiryAct QualificationActUnexpireData = True --- isExpiryAct _ = False - --- isBlockAct :: QualificationTableActionData -> Bool --- isBlockAct QualificationActBlockSupervisorData = True --- isBlockAct QualificationActBlockData{} = True --- isBlockAct QualificationActUnblockData{} = True --- isBlockAct _ = False - --- blockActRemoveSupervisors :: QualificationTableActionData -> Bool --- blockActRemoveSupervisors QualificationActBlockSupervisorData = True --- blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res --- blockActRemoveSupervisors _ = False - --- -- qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr --- -- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) --- -- , E.SqlExpr (Entity User) --- -- , E.SqlExpr (Maybe (Entity LmsUser)) --- -- ) --- -- qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUse) = 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) - --- qualificationTableQuery :: UTCTime -> 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 QualificationUserBlock)) --- ) --- qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do --- -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps --- -- --- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId --- E.&&. qualBlock `isLatestBlockBefore` E.val now --- 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, qualBlock) - - --- mkQualificationTable :: --- ( Functor h, ToSortable h --- , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols --- ) --- => Bool --- -> Entity Qualification --- -> Map QualificationTableAction (AForm Handler QualificationTableActionData) --- -> (Map CompanyId 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 --- svs <- getSupervisees --- now <- liftIO getCurrentTime --- -- lookup all companies --- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do --- cmps <- selectList [] [] -- [Asc CompanyShorthand] --- return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps --- let --- nowaday = utctDay now --- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday --- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) --- dbtIdent :: Text --- dbtIdent = "qualification" --- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `E.in_` E.vals svs --- dbtSQLQuery = qualificationTableQuery now qid fltrSvs --- dbtRowKey = queryUser >>> (E.^. UserId) --- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> 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, qUsrBlock, cmpUsr) --- dbtColonnade = cols cmpMap --- dbtSorting = mconcat --- [ single $ sortUserNameLink queryUser --- , single $ sortUserEmail queryUser --- , single $ sortUserMatriclenr queryUser --- , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) --- , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) --- , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) --- , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) --- , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) --- , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) --- , E.joinV (queryLmsUser row E.?. LmsUserNotified) --- , queryLmsUser row E.?. LmsUserStarted]) --- , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) --- , 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 --- E.orderBy [E.asc (comp E.^. CompanyName)] --- return (comp E.^. CompanyName) --- ) --- -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now) --- ] --- dbtFilter = mconcat --- [ single $ fltrUserNameEmail queryUser --- , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> --- E.from $ \usrAvs -> -- 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 ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of --- Nothing -> E.false --- Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do --- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId --- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId --- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) --- ) --- , 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 ("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 ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) --- , 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 ("tobe-notified", FilterColumn $ \row criterion -> --- if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row) --- | otherwise -> E.true --- ) --- , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) --- ] --- dbtFilterUI mPrev = mconcat --- [ 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) --- , if isNothing mbRenewal then mempty --- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) --- , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue) --- , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) --- ] --- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } --- dbtCsvEncode = Just DBTCsvEncode --- { dbtCsvExportForm = pure () --- , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) --- , dbtCsvName = csvName --- , dbtCsvSheetName = csvName --- , dbtCsvNoExportData = Just id --- , dbtCsvHeader = const $ return $ Csv.headerOrder qtcExample --- , dbtCsvExampleData = Just [qtcExample] --- } --- where --- doEncode' :: QualificationTableData -> QualificationTableCsv --- doEncode' = QualificationTableCsv --- <$> view (resultUser . _entityVal . _userDisplayName) --- <*> view (resultUser . _entityVal . _userDisplayEmail) --- <*> (view resultCompanyUser >>= getCompanies) --- <*> (view resultCompanyUser >>= getCompanyNos) --- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) --- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) --- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not) --- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) --- <*> 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 (_companyName . _CI)) somecmps --- getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) - --- getStatusPlusTxt = --- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case --- Just LmsBlocked{} -> return $ Just "Failed" --- Just LmsExpired{} -> return $ Just "Expired" --- Just LmsSuccess{} -> return $ Just "Success" --- Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $ --- preview (resultLmsUser . _entityVal . _lmsUserStarted) --- getStatusPlusDay = --- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case --- lsd@(Just _) -> return lsd --- Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted) - --- dbtCsvDecode = Nothing --- dbtExtraReps = [] --- dbtParams = DBParamsForm --- { dbParamsFormMethod = POST --- , dbParamsFormAction = Nothing --- , dbParamsFormAttrs = [] --- , dbParamsFormSubmit = FormSubmit --- , dbParamsFormAdditional --- = renderAForm FormStandard --- $ (, mempty) . First . Just --- <$> multiActionA acts (fslI MsgTableAction) Nothing --- , dbParamsFormEvaluate = liftHandler . runFormPost --- , dbParamsFormResult = id --- , dbParamsFormIdent = def --- } - --- postprocess :: FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData) --- -> FormResult ( QualificationTableActionData, Set UserId) --- postprocess inp = do --- (First (Just act), usrMap) <- inp --- let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap --- return (act, usrSet) - --- -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableActionData)) --- -- resultDBTableValidator = def --- -- & defaultSorting [SortAscBy csvLmsIdent] --- over _1 postprocess <$> dbTable psValidator DBTable{..} - --- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html --- getQualificationR = postQualificationR --- postQualificationR sid qsh = do --- isAdmin <- hasReadAccessTo AdminR --- msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning --- msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning --- now <- liftIO getCurrentTime --- let nowaday = utctDay now --- ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do --- qent@Entity{ --- entityKey=qid --- , entityVal=Qualification{ --- qualificationAuditDuration=auditMonths --- , qualificationValidDuration=validMonths --- }} <- getBy404 $ SchoolQualificationShort sid qsh - --- -- Block copied to Handler/Qualifications TODO: refactor --- let getBlockReasons unblk = E.select $ do --- (quser :& qblock) <- E.from $ E.table @QualificationUser --- `E.innerJoin` E.table @QualificationUserBlock --- `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser) --- E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid --- E.&&. unblk (qblock E.^. QualificationUserBlockUnblock) --- E.groupBy (qblock E.^. QualificationUserBlockReason) --- let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows --- E.orderBy [E.desc countRows'] --- E.limit 7 --- pure (qblock E.^. QualificationUserBlockReason) --- mkOption :: E.Value Text -> Option Text --- mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } --- suggestionsBlock :: HandlerFor UniWorX (OptionList Text) --- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_) --- suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) --- dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths --- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) --- acts = mconcat $ --- [ singletonMap QualificationActExpire $ pure QualificationActExpireData --- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData --- <$ aformMessage msgUnexpire --- ] ++ bool --- -- nonAdmin actions, ie. Supervisor --- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] --- -- Admin-only actions --- [ singletonMap QualificationActUnblock $ QualificationActUnblockData --- <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing --- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) --- , singletonMap QualificationActBlock $ QualificationActBlockData --- <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing --- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) --- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) --- , singletonMap QualificationActRenew $ pure QualificationActRenewData --- , singletonMap QualificationActGrant $ QualificationActGrantData --- <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry --- <* aformMessage msgGrantWarning --- ] isAdmin --- linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh) --- linkUserName = bool ForProfileR ForProfileDataR isAdmin --- colChoices cmpMap = mconcat --- [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) --- , colUserNameModalHdr MsgLmsUser linkUserName --- , 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 --- , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap --- ] --- companies = intercalate (text2markup ", ") $ --- (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs --- in wgtCell companies --- , guardMonoid isAdmin colUserMatriclenr --- -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) --- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d --- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d --- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) --- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> --- qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row --- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip --- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification --- , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) --- $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu --- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d --- ] --- psValidator = def & defaultSorting [SortDescBy "last-refresh"] --- tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator --- return (tbl, qent) - --- formResult lmsRes $ \case --- (QualificationActRenewData, selectedUsers) | isAdmin -> do --- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers --- addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks --- reloadKeepGetParams $ QualificationR sid qsh --- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do --- runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing --- addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers --- reloadKeepGetParams $ QualificationR sid qsh --- (action, selectedUsers) | isExpiryAct action -> do --- let isUnexpire = action == QualificationActUnexpireData --- upd <- runDB $ updateWhereCount --- [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers] --- [QualificationUserScheduleRenewal =. isUnexpire] --- let msgKind = if upd > 0 then Success else Warning --- msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire --- addMessageI msgKind msgVal --- reloadKeepGetParams $ QualificationR sid qsh --- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do --- let selUserIds = Set.toList selectedUsers --- (unblock, reason) = case action of --- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) --- QualificationActBlockData{..} -> (False, Left qualTableActBlockReason) --- QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason) --- _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks --- notify = case action of --- QualificationActBlockData{qualTableActNotify} -> qualTableActNotify --- _ -> False - --- oks <- runDB $ do --- when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] --- qualificationUserBlocking qid selUserIds unblock Nothing reason notify --- let nrq = length selectedUsers --- warnLevel = if --- | oks < 0 -> Error --- | oks == nrq -> Success --- | otherwise -> Warning --- fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock --- addMessageI warnLevel $ fbmsg qsh oks nrq --- reloadKeepGetParams $ QualificationR sid qsh --- _ -> addMessageI Error MsgInvalidFormAction - --- let heading = citext2widget $ qualificationName quali --- siteLayout heading $ do --- setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh --- $(widgetFile "qualification") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 3dde9b54d..e0a12e0b1 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -130,7 +130,7 @@ makeSettingForm template html = do <* aformSection MsgFormNotifications <*> aopt (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template) - <*> apopt checkBoxField (fslI MsgPrefersPostal & setTooltip MsgPostalTip) (stgPrefersPostal <$> template) + <*> apopt checkBoxField (fslI MsgPrefersPostalExp & setTooltip MsgPostalTip) (stgPrefersPostal <$> template) <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) <*> examOfficeForm (stgExamOfficeSettings <$> template) diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 91f194fed..9eb2817af 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -49,7 +49,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
^{formatTimeW SelFormatDate bday}
- _{MsgPrefersPostal} + _{MsgPrefersPostalExp}
#{iconLetterOrEmail userPrefersPostal} $maybe addr <- userPostAddress