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/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/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index f2beb2c56..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 @@ -90,6 +91,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 +102,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..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 @@ -90,6 +91,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 +102,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/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/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/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 diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 48b7ac59e..4fcad5788 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
- #{companyPostAddress} -
- Für neue Firmangehörige ist Benachrichtigungs-Voreinstellung: - $if companyPrefersPostal - #{icon IconLetter} Briefversand - $else - #{icon IconAt} Email -
- AVS Nummer #{companyAvsId} - -
- Table showing all company associated users
+
+ #{companyPostAddress}
+
+ Benachrichtigungs-Voreinstellung für neue Firmangehörige: #
+ $if companyPrefersPostal
+ #{icon IconLetter} Briefversand
+ $else
+ #{icon IconAt} Email
+
+ ^{fusrTable}
|]
@@ -412,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/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) ->
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/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/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/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
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.
+
+ Company associated users, excluding foreign supervisors
+