From 0ab1cd17be5a0ab4c0945cd15577c6843827507a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Oct 2023 13:23:05 +0200 Subject: [PATCH 1/5] chore(firm): add contact preference column and make firm nr filter exact --- .../utils/table_column/de-de-formal.msg | 4 ++- messages/uniworx/utils/table_column/en-eu.msg | 4 ++- src/Database/Esqueleto/Utils.hs | 13 +++++++- src/Handler/Firm.hs | 4 ++- src/Handler/Utils/Table/Columns.hs | 31 ++++++++++++++----- templates/i18n/firm-all/de-de-formal.hamlet | 3 +- templates/i18n/firm-all/en-eu.hamlet | 1 + 7 files changed, 47 insertions(+), 13 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index f2beb2c56..c08c769cd 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -90,6 +90,7 @@ TableCompanyNrSupersDefault: Standard Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner TableCompanyNrRerouteDefault: Standard Umleitungen TableCompanyNrRerouteActive: Aktive Umleitungen +TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige TableSupervisor: Ansprechpartner TableCreationTime: Erstellungszeit TableJob !ident-ok: Job @@ -100,4 +101,5 @@ TableJobCreationInstance: Ersteller ActJobDelete: Job entfernen TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrennt angegeben werden, wovon mindestens eines erfüllt werden muss. -TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. \ No newline at end of file +TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. +TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 1fc9066c0..dd7742a45 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -90,6 +90,7 @@ TableCompanyNrSupersDefault: Default supervisors TableCompanyNrForeignSupers: External Supervisors TableCompanyNrRerouteDefault: Default reroutes TableCompanyNrRerouteActive: Active reroutes +TableCompanyPostalPreference: Default notification preference TableSupervisor: Supervisor TableCreationTime: Creation TableJob !ident-ok: Job @@ -100,4 +101,5 @@ TableJobCreationInstance: Creator ActJobDelete: Delete job TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted TableFilterComma: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled. -TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. \ No newline at end of file +TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. +TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 2aced9b9f..060a4df98 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -18,7 +18,7 @@ module Database.Esqueleto.Utils , or, and , any, all , subSelectAnd, subSelectOr - , mkExactFilter, mkExactFilterWith + , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma , mkExactFilterLast, mkExactFilterLastWith , mkExactFilterMaybeLast, mkExactFilterMaybeLast' , mkContainsFilter, mkContainsFilterWith @@ -285,6 +285,17 @@ mkExactFilterWith cast lenslike row criterias | Set.null criterias = true | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias) +-- | like `mkExactFilterWith` but splits comma separared Texts into multiple criteria +mkExactFilterWithComma :: (PersistField b) + => (Text -> b) -- ^ type conversion + -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set Text -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkExactFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias) + | Set.null criterias = true + | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias) + -- | generic filter creation for dbTable -- Given a lens-like function, make filter for exact matches against last element of a collection mkExactFilterLast :: (PersistField a) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 48b7ac59e..1062ac2a5 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -276,11 +276,13 @@ mkFirmAllTable isAdmin uid = do , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr + , sortable (Just "postal-pref") (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconCell $ bool IconAt IconLetter b ] dbtSorting = mconcat [ singletonMap "name" $ SortColumn (E.^. CompanyName) , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) + , singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal) , singletonMap "users" $ SortColumn firmCountUsers , singletonMap "supervisors" $ SortColumn firmCountSupervisors , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised @@ -387,7 +389,7 @@ postFirmUsersR fsh = do

#{companyPostAddress}

- Für neue Firmangehörige ist Benachrichtigungs-Voreinstellung: + Benachrichtigungs-Voreinstellung für neue Firmangehörige: # $if companyPrefersPostal #{icon IconLetter} Briefversand $else diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index e42451442..ce4147b03 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -754,23 +754,38 @@ sortUserCompany queryUser = ( "user-company" )) -- | Search companies by name, shorthand oder AVS nr +-- fltrCompanyNameNr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) +-- => (a -> E.SqlExpr (Entity Company)) +-- -> (d, FilterColumn t fs) +-- fltrCompanyNameNr query = ( "company-name-number", FilterColumn $ anyFilter +-- [ mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyName) +-- , mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyShorthand) +-- , mkExactFilterWithComma id $ query >>> (E.num2text . (E.^. CompanyAvsId)) +-- ] +-- ) + fltrCompanyNameNr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity Company)) -> (d, FilterColumn t fs) -fltrCompanyNameNr query = ( "company-name-number", FilterColumn $ anyFilter - [ mkContainsFilterWithCommaPlus CI.mk $ query >>> (E.^. CompanyName) - , mkContainsFilterWithCommaPlus CI.mk $ query >>> (E.^. CompanyShorthand) - , mkContainsFilterWithCommaPlus id $ query >>> (E.num2text . (E.^. CompanyAvsId)) - ] - ) - +fltrCompanyNameNr query = ("company-name-number", FilterColumn $ \needle (setFoldMap commaSeparatedText -> criterias) -> + let numCrits = setMapMaybe readMay criterias + fltrCName = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyName)) needle criterias + fltrCShort = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyShorthand)) needle criterias + fltrCno = mkExactFilter (query >>> (E.^. CompanyAvsId)) needle numCrits + in if null numCrits + then fltrCName E.||. fltrCShort + else fltrCName E.||. fltrCShort E.||. fltrCno + ) + where + setFoldMap :: (Text -> Set.Set Text) -> Set.Set Text -> Set.Set Text + setFoldMap = foldMap fltrCompanyNameNrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrCompanyNameNrUI = fltrCompanyNameNrHdrUI MsgTableCompanyFilter fltrCompanyNameNrHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrCompanyNameNrHdrUI msg mPrev = - prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaPlus) + prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr) ---------------------------- diff --git a/templates/i18n/firm-all/de-de-formal.hamlet b/templates/i18n/firm-all/de-de-formal.hamlet index e4e59fc3e..49ab8a1d5 100644 --- a/templates/i18n/firm-all/de-de-formal.hamlet +++ b/templates/i18n/firm-all/de-de-formal.hamlet @@ -32,11 +32,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Ob ein Ansprechpartner Email oder Briefpost wünscht ist eine individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner.

  • Anzahl der firmenfremden Ansprechpartner, welche mindestens einen Firmenangehörigen betreuen. Bei manchen Firmen ist es normal, dass die Ansprechpartner einer anderen Firma angehören, aber oft ist nur ein Fehler durch Firmenwechsel.
  • Anzahl der Ansprechpartner mit derzeit aktiver Benachrichtigungsumleitung, egal ob Brief oder Email. -
  • Gesamtzahl der Brief und Emails, welche bei Benachrichtigung aller Firmenangehörigen derzeit verschickt würden. +
  • Gesamtzahl der Brief und Emails, welche bei Benachrichtigung aller Firmenangehörigen derzeit verschickt würden.

    Dies ist also die Gesamtzahl aller derzeit aktiven Benachrichtigungsumleitungen.

    Beispiel: Für eine Firma mit 2 Angehörigen, für die ein Mitarbeiter 1 Ansprechpartner mit aktiver Umleitung und einen Mitarbeiter mit 3 Ansprechpartnern mit aktiver Umleitung hätte, # würde hier die Zahl 4 stehen, da bei einer Benachrichtigung an beide Mitarbeiter insgesamt 4 Briefe oder Emails versendet würden. +

  • Voreinstellung der persönlichen Benachrichtigungspreferenz für Firmenangehörige welche neu aus dem AVS importiert werden (erst mit Umsetzung CR3 effektiv). diff --git a/templates/i18n/firm-all/en-eu.hamlet b/templates/i18n/firm-all/en-eu.hamlet index d1a659458..e8a2ccfb0 100644 --- a/templates/i18n/firm-all/en-eu.hamlet +++ b/templates/i18n/firm-all/en-eu.hamlet @@ -40,4 +40,5 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Beispiel: Für eine Firma mit 2 Angehörigen, für die ein Mitarbeiter 1 Ansprechpartner mit aktiver Umleitung und einen Mitarbeiter mit 3 Ansprechpartnern mit aktiver Umleitung hätte, # würde hier die Zahl 4 stehen, da bei einer Benachrichtigung an beide Mitarbeiter insgesamt 4 Briefe oder Emails versendet würden. +
  • Voreinstellung der persönlichen Benachrichtigungspreferenz für Firmenangehörige welche neu aus dem AVS importiert werden (erst mit Umsetzung CR3 effektiv). From 230ca0c40f3a7cc334fd4b3a9a8435aab189ac74 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Oct 2023 17:26:10 +0200 Subject: [PATCH 2/5] chore(auth): add firm routes to superviser auth tag --- .../categories/authorization/de-de-formal.msg | 2 ++ .../uniworx/categories/authorization/en-eu.msg | 2 ++ routes | 6 +++--- src/Foundation/Authorization.hs | 17 +++++++++++++++-- 4 files changed, 22 insertions(+), 5 deletions(-) diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index 0c8732515..f9a26de23 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -20,6 +20,8 @@ UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Re UnauthorizedTokenInvalidImpersonation: Ihr Authorisierungs-Token enthält die Anweisung sich als ein Nutzer:in auszugeben, dies ist jedoch nicht allen Benutzer:innen, auf deren Rechten ihr Authorisierungs-Token basiert, erlaubt. UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden. UnauthorizedSupervisor: Sie sind kein Ansprechpartner:in für diesen Benutzer:in. +UnauthorizedAnySupervisor: Sie sind kein Ansprechpartner:in. +UnauthorizedCompanySupervisor fsh@CompanyShorthand: Sie sind kein Standard Ansprechpartner:in für Firma #{fsh}. UnauthorizedSiteAdmin: Sie sind nicht System-weiter Administrator:in. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator:in für diesen Bereich eingetragen. UnauthorizedAdminEscalation: Sie sind nicht Administrator:in für alle Bereiche, für die dieser Nutzer/diese Nutzerin Administrator:in oder Veranstalter:in ist. diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index 87f044580..b539efbf1 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -20,6 +20,8 @@ UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which UnauthorizedTokenInvalidImpersonation: Your authorisation-token contains an instruction to impersonate an user. Not all users on whose rights your token is based however are permitted to do so. UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages. UnauthorizedSupervisor: You are not a supervisor for the requested user. +UnauthorizedAnySupervisor: You are not a supervisor. +UnauthorizedCompanySupervisor fsh: You are not a default supervisor for company #{fsh}. UnauthorizedSiteAdmin: You are no system-wide administrator. UnauthorizedSchoolAdmin: You are no administrator for this department. UnauthorizedAdminEscalation: You aren't an administrator for all departments for which this user is an administrator. diff --git a/routes b/routes index b77b24c70..6b89c13f6 100644 --- a/routes +++ b/routes @@ -113,10 +113,10 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET POST +/firm FirmAllR GET POST !supervisor /firm/#CompanyShorthand FirmR GET POST -/firm/#CompanyShorthand/users FirmUsersR GET POST -/firm/#CompanyShorthand/supers FirmSupersR GET POST +/firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor +/firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 832cf62a7..7ca298622 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -539,8 +539,11 @@ tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right d return Authorized tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of - ForProfileR cID -> checkSupervisor (mAuthId, cID) - ForProfileDataR cID -> checkSupervisor (mAuthId, cID) + ForProfileR cID -> checkSupervisor (mAuthId, cID) + ForProfileDataR cID -> checkSupervisor (mAuthId, cID) + FirmAllR -> checkAnySupervisor mAuthId + FirmUsersR fsh -> checkCompanySupervisor (mAuthId, fsh) + FirmSupersR fsh -> checkCompanySupervisor (mAuthId, fsh) r -> $unsupportedAuthPredicate AuthSupervisor r where checkSupervisor sup@(mAuthId, cID) = $cachedHereBinary sup . exceptT return return $ do @@ -549,6 +552,16 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of isSupervisor <- lift . existsBy $ UniqueUserSupervisor authId uid guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedSupervisor) return Authorized + checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh + guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh) + return Authorized + checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isSupervisor <- lift $ exists [UserSupervisorSupervisor ==. authId] + guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedAnySupervisor) + return Authorized tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if | maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if From ff176faa12906087b18921a059cd7f0b2c68b362 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Oct 2023 17:28:00 +0200 Subject: [PATCH 3/5] chore(users): remove duplicated link from company personal number --- src/Handler/Users.hs | 9 +++++---- src/Handler/Utils/Table/Cells.hs | 1 + src/Utils.hs | 4 ++-- src/Utils/Icon.hs | 2 +- 4 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index ca93e58c7..1133c56d8 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -111,10 +111,11 @@ postUsersR = do companies = (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' pure $ intercalate (text2widget "; ") companies - , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM - (AdminUserR <$> encrypt uid) - (toWgt userCompanyPersonalNumber) - , sortable (Just "company-department") (i18nCell MsgCompanyDepartment) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment + -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM + -- (AdminUserR <$> encrypt uid) + -- (toWgt userCompanyPersonalNumber) + , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyPersonalNumber + , sortable (Just "company-department") (i18nCell MsgCompanyDepartment) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment -- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- (AdminUserR <$> encrypt uid) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index e19be03aa..bdc1cc611 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -91,6 +91,7 @@ guardAuthCell mkParams = over cellContents $ \act -> do --------------------- -- Icon cells +-- to be used with icons directly, for results of `icon`, use either `wgtCell` or `iconFixedCell` iconCell :: IsDBTable m a => Icon -> DBCell m a iconCell = cell . toWidget . icon diff --git a/src/Utils.hs b/src/Utils.hs index e91f92015..44b863ae9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -846,8 +846,8 @@ _MapUnit = iso Map.keysSet $ Map.fromSet (const ()) -- | Just @flip (.)@ for convenient formatting in some cases, -- Deprecated in favor of Control.Arrow.(>>>) -compose :: (a -> b) -> (b -> c) -> (a -> c) -compose = flip (.) +-- compose :: (a -> b) -> (b -> c) -> (a -> c) +-- compose = flip (.) ----------- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 645e89e73..982d19b5f 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later From 90703f4921f98e77d3923817127754167297c8d3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Oct 2023 17:30:46 +0200 Subject: [PATCH 4/5] chore(firm): implement firm-users dbTable --- .../utils/table_column/de-de-formal.msg | 1 + messages/uniworx/utils/table_column/en-eu.msg | 1 + src/Handler/Firm.hs | 172 +++++++++++++++--- src/Handler/LMS.hs | 2 +- 4 files changed, 147 insertions(+), 29 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index c08c769cd..579e8ddf0 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -80,6 +80,7 @@ TableCompanyShort: Firmenkürzel TableCompanies: Firmen TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern +TableCompanyUser: Firmenangehöriger TableCompanyNrUsers: Firmenangehörige TableCompanyNrSupers: Ansprechpartner TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index dd7742a45..b441ea783 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -80,6 +80,7 @@ TableCompanyShort: Company shorthand TableCompanies: Companies TableCompanyNo: Company number TableCompanyNos: Company numbers +TableCompanyUser: Associate TableCompanyNrUsers: Associates TableCompanyNrSupers: Supervisors TableCompanyNrEmpSupervised: Supervsied employees diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 1062ac2a5..46b08a864 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -28,7 +28,7 @@ import qualified Data.CaseInsensitive as CI -- import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma --- import qualified Database.Esqueleto.Legacy as EL +import qualified Database.Esqueleto.Legacy as EL (from, on) -- import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -77,7 +77,7 @@ postFirmR fsh = do
      $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr, E.Value prefPost) <- cactSuper
    • #{nr} Employees supervised by ^{nameWidget dn sn} # - #{icon (bool IconAt IconLetter prefPost)} # + #{iconLetterOrEmail prefPost} # $maybe csh <- mbCsh $if csh /= fshId from foreign company #{unCompanyKey csh} @@ -112,8 +112,8 @@ data FirmAllActionData = FirmAllActNotifyData -- just in case for future extensions type AllCompanyTableExpr = E.SqlExpr (Entity Company) -queryCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) -queryCompany = id +queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) +queryAllCompany = id type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64) resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company) @@ -255,10 +255,8 @@ mkFirmAllTable isAdmin uid = do ) dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId - dbtColonnade = formColonnade $ - mconcat - [ if not isAdmin then mempty else -- guardOnM idAdmin $ - dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) + dbtColonnade = formColonnade $ mconcat + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> @@ -276,7 +274,7 @@ mkFirmAllTable isAdmin uid = do , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr - , sortable (Just "postal-pref") (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconCell $ bool IconAt IconLetter b + , sortable (Just "postal-pref") (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b ] dbtSorting = mconcat [ singletonMap "name" $ SortColumn (E.^. CompanyName) @@ -294,12 +292,12 @@ mkFirmAllTable isAdmin uid = do , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' ] dbtFilter = mconcat - [ single $ fltrCompanyNameNr queryCompany + [ single $ fltrCompanyNameNr queryAllCompany , single ("is-supervisor", FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) - E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryCompany row E.^. CompanyId + E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId E.&&. ( (usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) @@ -376,31 +374,149 @@ data FirmUserActionData = FirmUserActNotifyData | FirmUserActMkSuperData deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) + +queryUserUser :: UserCompanyTableExpr -> E.SqlExpr (Entity User) +queryUserUser = $(sqlIJproj 2 1) + +queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany) +queryUserUserCompany = $(sqlIJproj 2 2) + +type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) + +resultUserUser :: Lens' UserCompanyTableData (Entity User) +resultUserUser = _dbrOutput . _1 + +resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany) +resultUserUserCompany = _dbrOutput . _2 + +resultUserCompanySupervisors :: Lens' UserCompanyTableData Word64 +resultUserCompanySupervisors = _dbrOutput . _3 . _unValue + +resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64 +resultUserCompanyReroutes = _dbrOutput . _4 . _unValue + +instance HasEntity UserCompanyTableData User where + hasEntity = resultUserUser + +instance HasUser UserCompanyTableData where + hasUser = resultUserUser . _entityVal + + +firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) +firmCountUserSupervisors usrCmp = E.subSelectCount $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + +firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) +firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + E.&&. usrSpr E.^. UserSupervisorRerouteNotifications + +mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) +mkFirmUserTable isAdmin cid = do + let + resultDBTable = DBTable{..} + where + dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do + EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser + E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid + return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp) + dbtRowKey = queryUserUser >>> (E.^. UserId) + dbtProj = dbtProjId + dbtColonnade = formColonnade $ mconcat + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR + , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr + , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr + , sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , colUserEmail + ] + dbtSorting = mconcat + [ single $ sortUserNameLink queryUserUser + , single $ sortUserEmail queryUserUser + , singletonMap "postal-pref" $ SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal) + , singletonMap "matriculation" $ SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer) + , singletonMap "personal-number" $ SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber) + , singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors + , singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute + ] + dbtFilter = mconcat + [ single $ fltrUserNameEmail queryUserUser + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + acts :: Map FirmUserAction (AForm Handler FirmUserActionData) + acts = mconcat + [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData + , singletonMap FirmUserActMkSuper $ pure FirmUserActMkSuperData + ] + 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 + } + dbtIdent :: Text + dbtIdent = "firm-users" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + postprocess :: FormResult (First FirmUserActionData, DBFormResult UserId Bool UserCompanyTableData) + -> FormResult ( FirmUserActionData, Set UserId) + postprocess inp = do + (First (Just act), m) <- inp + let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m + return (act, s) + + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + resultDBTableValidator = def + & defaultSorting [SortAscBy "user-name"] + over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable + + getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do + isAdmin <- hasReadAccessTo AdminR let fshId = CompanyKey fsh - Company{..} <- runDB $ get404 fshId + (Company{..}, (fusrRes, fusrTable)) <- runDB $ (,) + <$> get404 fshId + <*> mkFirmUserTable isAdmin fshId + formResult fusrRes $ \case + (FirmUserActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " employees. TODO" + (FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO" siteLayout (citext2widget companyName) $ do - setTitle $ citext2Html companyShorthand + setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")" [whamlet| -

      - #{companyPostAddress} -

      - Benachrichtigungs-Voreinstellung für neue Firmangehörige: # - $if companyPrefersPostal - #{icon IconLetter} Briefversand - $else - #{icon IconAt} Email -

      - AVS Nummer #{companyAvsId} - -

      - !!!STUB!!!TO DO!!! -

      - Table showing all company associated users +

      +

      + #{companyPostAddress} +

      + Benachrichtigungs-Voreinstellung für neue Firmangehörige: # + $if companyPrefersPostal + #{icon IconLetter} Briefversand + $else + #{icon IconAt} Email +

      +

      + Company associated users, excluding foreign supervisors +

      + ^{fusrTable} |] diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index c0e32c3f4..682e0c7f4 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -631,7 +631,7 @@ postLmsR sid qsh = do <* aformMessage msgRestartWarning ] colChoices cmpMap = mconcat - [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey)) + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> From 647964fc355665109fe9400e4c8cddf6e353ec0d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Oct 2023 18:23:39 +0200 Subject: [PATCH 5/5] 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