diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg
index cb58e7679..f6af62a89 100644
--- a/messages/uniworx/categories/firm/de-de-formal.msg
+++ b/messages/uniworx/categories/firm/de-de-formal.msg
@@ -41,7 +41,7 @@ FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
FirmUserActChangeDetailsResult n@Int64 t@Int64: Firmenassoziation von #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden aktualisiert
FirmUserActChangeResult n@Int64 t@Int64: Benachrichtigungseinstellung für #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden geändert
FirmUserActRemoveResult uc@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt.
-FirmRemoveSupervision sup@Int64 sub@Int64: #{noneMoreDE sup "" (tshow sup <> " Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöscht. ")} #{noneOneMoreDE sub "Keine Ansprechpartnerbeziehung" "Eine Ansprechpartnerbeziehung" (tshow sup <> " Ansprechpartnerbeziehungen")} wegen entferntem Angesprochenem gelöscht.
+FirmRemoveSupervision sup@Int64 sub@Int64: #{noneMoreDE sup "" (tshow sup <> " Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöscht. ")} #{noneOneMoreDE sub "Keine Ansprechpartnerbeziehung" "Eine Ansprechpartnerbeziehung" (tshow sup <> " Ansprechpartnerbeziehungen")} wegen entferntem Klienten gelöscht.
FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen
FirmSetSupervisor: Existierende Ansprechpartner hinzufügen
FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)}
@@ -83,9 +83,15 @@ CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterle
CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird!
CompanySupervisorCompanyMissing fsh@CompanyShorthand: Empfänger ist nicht mit Firma #{fsh} aus Ansprechpartnerbeziehung assoziiert
CompanySuperviseeCompanyMissing fsh@CompanyShorthand: Klient ist nicht mit Firma #{fsh} aus Ansprechpartnerbeziehung assoziiert
+FirmSupervisionRInfo: In folgenden Ansprechpartnerbeziehungen gehören entweder der Ansprechpartner oder der Klient nicht mehr der Firma an, welche als Begründung für die Beziehung eingetragen ist.
SupervisionViolationChoice: Firmenassoziation fehlt für
SupervisionViolationEither: Egal
SupervisionViolationSupervisor: Ansprechpartner
SupervisionViolationClient: Klient
SupervisionViolationBoth: Beide
-ASChangeCompany: Firma ändern, welche Ansprechpartnerbeziehung begründet
+SupervisionsRemoved n@Int64 m@Int64: #{n}/#{m} #{pluralDE n "Ansprechpartnerbeziehung" "Ansprechpartnerbeziehungen"} entfernt.
+SupervisionsEdited n@Int64 m@Int64: #{n}/#{m} #{pluralDE n "Ansprechpartnerbeziehung" "Ansprechpartnerbeziehungen"} geändert.
+ASChangeCompany: Begründungen für Ansprechpartnerbeziehung abändern
+ASRemoveAssociation: Ansprechpartnerbeziehung löschen
+FirmNameNotFound: Keine Firma mit diesen Namen/Kürzel/AVS-Nr gefunden.
+FirmNameAmbiguous: Firmenname/-kürzel oder AVS-Nr ist nicht eindeutig.
diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg
index 7126ef24d..d918c3809 100644
--- a/messages/uniworx/categories/firm/en-eu.msg
+++ b/messages/uniworx/categories/firm/en-eu.msg
@@ -25,7 +25,7 @@ FirmActAddAssociates: Associate users with company
FirmActAddSupersEmpty: No new supervisors added!
FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
FirmActAddAssocsEmpty: No new company associated users added!
-FirmActAddAssocs n@Int64: #{pluralENsN n "company associated user"} added.
+FirmActAddAssocs n: #{pluralENsN n "company associated user"} added.
RemoveSupervisors ndef: #{ndef} default supervisors removed.
FirmActChangeContactUser: Change contact data for all company associates
FirmActChangeContactFirm: Change company contact data
@@ -83,9 +83,15 @@ CompanyUserUseCompanyAddressTip: if and only if the postal address of the user i
CompanyUserUseCompanyPostalError: Individual postal address must left empty for the company address to be used!
CompanySupervisorCompanyMissing fsh: Receiver is not associated with #{fsh} given as reroute reason
CompanySuperviseeCompanyMissing fsh: Supervisee is not associated with #{fsh} detailed as supervisionship reason
+FirmSupervisionRInfo: Shown are supervisionships where either supervisor or supervisee no longer belong to the company associated with the supervisionship.
SupervisionViolationChoice: Company association missing for
SupervisionViolationEither: anyone
SupervisionViolationSupervisor: Supervisor
SupervisionViolationClient: Supervisee
SupervisionViolationBoth: both
-ASChangeCompany: Change company for supervisionship
\ No newline at end of file
+SupervisionsRemoved n m: #{n}/#{m} #{pluralENs n "Supervisionship"} removed.
+SupervisionsEdited n m: #{n}/#{m} #{pluralENs n "Supervisionship"} edited.
+ASChangeCompany: Change supervisionship annotations
+ASRemoveAssociation: Delete supervisionship
+FirmNameNotFound: No company found with this name/shorthand or AVS number.
+FirmNameAmbiguous: Company name/shorthand or AVS number is amiguous.
\ No newline at end of file
diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg
index fc838e742..1f3b163c1 100644
--- a/messages/uniworx/categories/user/de-de-formal.msg
+++ b/messages/uniworx/categories/user/de-de-formal.msg
@@ -96,7 +96,7 @@ UserHijack: Sitzung übernehmen
UserAddSupervisor: Ansprechpartner hinzufügen
UserSetSupervisor: Ansprechpartner ersetzen
UserRemoveSupervisor: Alle Ansprechpartner entfernen
-UserRemoveClients: Alle Ansprechpartnerbeziehungen zu Untergebenen beenden
+UserRemoveClients: Alle Ansprechpartnerbeziehungen zu Klienten beenden
UserIsSupervisor: Ist Ansprechpartner
UserAvsSwitchCompany: Als Primärfirma verwenden
UserAvsSwitchCompanyField: Primärfirma auswählen
diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg
index e4bc92fa3..c34f39545 100644
--- a/messages/uniworx/misc/de-de-formal.msg
+++ b/messages/uniworx/misc/de-de-formal.msg
@@ -41,4 +41,5 @@ Ambiguous: ist uneindeutig
Action: Aktion
For: für
Address: Adresse
-NoContactAddress: Keinerlei Kontaktdaten bekannt!
\ No newline at end of file
+NoContactAddress: Keinerlei Kontaktdaten bekannt!
+StarKeepsEmptyDeletes: Stern zum Beibehalten, leer lassen zum Löschen
\ No newline at end of file
diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg
index 3d13cc994..6a94c7370 100644
--- a/messages/uniworx/misc/en-eu.msg
+++ b/messages/uniworx/misc/en-eu.msg
@@ -41,4 +41,5 @@ Ambiguous: is ambiguous
Action: Action
For: for
Address: Address
-NoContactAddress: No contact details known!
\ No newline at end of file
+NoContactAddress: No contact details known!
+StarKeepsEmptyDeletes: A star to keep unchanged, blank removes
\ 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 19cc690b5..4aa554108 100644
--- a/messages/uniworx/utils/table_column/en-eu.msg
+++ b/messages/uniworx/utils/table_column/en-eu.msg
@@ -118,7 +118,7 @@ TableFilterComma: Separate multiple alternative filter criteria by comma, at lea
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.
TableFilterCommaPlusShort: Support multiple criteria with comma/plus, see above.
TableFilterCommaName: Separate names by comma.
-TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact.
+TableFilterCommaNameNr: Separate names and exact numbers by comma.
TableUserEdit: Edit user
TableRows: Rows
TableUserParkingToken day: Parking token #{day}
\ No newline at end of file
diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs
index bb90df48d..ba64f041e 100644
--- a/src/Handler/Firm.hs
+++ b/src/Handler/Firm.hs
@@ -19,7 +19,6 @@ module Handler.Firm
import Import
-- import Jobs
-import Utils.Company
import Handler.Utils
import Handler.Utils.Company
import Handler.Utils.Communication
@@ -40,6 +39,7 @@ import qualified Database.Esqueleto.Legacy as EL (on) -- needed for legacy join
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
+import Handler.Firm.Supervision
-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
-- decryptUser = decrypt
@@ -233,10 +233,8 @@ firmActionHandler route isAdmin = flip formResult faHandler
addMessageI Warning MsgFirmActAddAssocsEmpty
reloadKeepGetParams route
runDB $ do
- oks0 <- mapM insertUnique_ [UserCompany uid cid False False firmActAddAssociatePriority firmActAddUserUseCompanyAddress firmActAddAssociateReason | uid <- usersFound]
- let oks = length $ catMaybes oks0
- allok = bool Warning Success $ oks == length usersFound
- addMessageI allok $ MsgFirmActAddAssocs (fromIntegral oks)
+ oks <- mapM insertUnique_ [UserCompany uid cid False False firmActAddAssociatePriority firmActAddUserUseCompanyAddress firmActAddAssociateReason | uid <- usersFound]
+ addMessageOutOfI (const . MsgFirmActAddAssocs) (length $ catMaybes oks) (length usersFound)
redirect route
faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) =
@@ -271,9 +269,8 @@ firmActionHandler route isAdmin = flip formResult faHandler
Just x -> updateWhereCount [UserCompanyCompany ==. cid] [UserCompanyUseCompanyAddress =. x]
Nothing -> return 0
nrCid <- count [UserCompanyCompany ==. cid]
- return (fromIntegral nrCid, max nrUsrChange nrUseComp)
- let allok = bool Warning Success $ nrChanged == total
- addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
+ return (nrCid, max nrUsrChange nrUseComp)
+ addMessageOutOfI MsgFirmUserActChangeResult nrChanged total
reloadKeepGetParams route -- reload to reflect changes
faHandler _ = addMessageI Error MsgErrorUnknownFormAction
@@ -1165,15 +1162,13 @@ postFirmUsersR fsh = do
nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
addMessageI Success $ MsgFirmActAddSupersSet nrUpd Nothing
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
- (FirmUserActChangeDetailsData{..}, Set.toList -> uids) -> do
+ (FirmUserActChangeDetailsData{..}, uids) -> do
let upReason = case canonical firmUserActDetailReason of
Nothing -> Nothing
Just "NULL" -> Just $ UserCompanyReason =. Nothing
other -> Just $ UserCompanyReason =. other
- nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority]
- let total = fromIntegral $ length uids
- allok = bool Warning Success $ nrUpd == total
- addMessageI allok $ MsgFirmUserActChangeDetailsResult nrUpd total
+ nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. Set.toList uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority]
+ addMessageOutOfI MsgFirmUserActChangeDetailsResult nrUpd $ Set.size uids
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
(FirmUserActChangeContactData{..}, Set.toList -> uids)
| firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr ->
@@ -1191,9 +1186,7 @@ postFirmUsersR fsh = do
Just x -> updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanyUseCompanyAddress =. x]
Nothing -> return 0
return $ max nrUsrChange nrUseComp
- let total = fromIntegral $ length uids
- allok = bool Warning Success $ nrChanged == total
- addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
+ addMessageOutOfI MsgFirmUserActChangeResult nrChanged $ length uids
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
(FirmUserActRemoveData{..}, Set.toList -> uids) -> do
let optRemove = if firmUserActRemoveSupers then id else const $ return 0
@@ -1528,171 +1521,3 @@ handleFirmCommR ultDest cs = do
Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma
Alle gewählten Personen, gruppiert nach deren Firma
-}
-
-
------------------------
--- Supervision Sanity
-
-data ActSupervision = ASChangeCompany -- | ASRemoveCompany |
- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
- deriving anyclass (Universe, Finite)
-
-nullaryPathPiece ''ActSupervision $ camelToPathPiece' 2
-embedRenderMessage ''UniWorX ''ActSupervision id
-
-data ActSupervisionData = ASChangeCompanyData
- deriving (Eq, Ord, Read, Show, Generic)
-
-data SupervisionViolation = SupervisionViolationEither | SupervisionViolationClient | SupervisionViolationSupervisor | SupervisionViolationBoth
- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
- deriving anyclass (Universe, Finite)
-
-nullaryPathPiece ''SupervisionViolation $ camelToPathPiece' 1
-embedRenderMessage ''UniWorX ''SupervisionViolation id
-
-supervisionViolationField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m SupervisionViolation
--- supervisionViolationField = radioGroupField (Just $ SomeMessage MsgSupervisionViolationEither) $ optionsFinite
-supervisionViolationField = radioGroupField Nothing $ optionsFinite
-
-type TblSupervisionData = DBRow (Entity UserSupervisor, Entity User, Entity User)
-
-mkSupervisionTable :: DB (FormResult (ActSupervisionData, Set UserSupervisorId), Widget)
-mkSupervisionTable = over _1 postprocess <$> dbTable validator DBTable{..}
- where
- dbtIdent = "sanity-super" :: Text
- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
-
- queryRelation :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserSupervisor)
- queryRelation = $(E.sqlIJproj 3 1)
- querySupervisor :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
- querySupervisor = $(E.sqlIJproj 3 2)
- queryClient :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
- queryClient = $(E.sqlIJproj 3 3)
-
- resultRelation :: Lens' TblSupervisionData (Entity UserSupervisor)
- resultRelation = _dbrOutput . _1
- resultSupervisor :: Lens' TblSupervisionData (Entity User)
- resultSupervisor = _dbrOutput . _2
- resultClient :: Lens' TblSupervisionData (Entity User)
- resultClient = _dbrOutput . _3
-
- dbtSQLQuery (uus `E.InnerJoin` spr `E.InnerJoin` sub) = do
- EL.on $ uus E.^. UserSupervisorSupervisor E.==. spr E.^. UserId
- EL.on $ uus E.^. UserSupervisorUser E.==. sub E.^. UserId
- E.where_ $ E.isJust (uus E.^. UserSupervisorCompany)
- return (uus, spr, sub)
- dbtRowKey = queryRelation >>> (E.^. UserSupervisorId)
- dbtProj = dbtProjId
- dbtColonnade = formColonnade $ mconcat
- [ dbSelect (applying _2) id (return . view (resultRelation . _entityKey))
- , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \(view $ resultRelation . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
- , sortable (Just "reason") (i18nCell MsgUserSupervisorReason) $ \(view $ resultRelation . _entityVal . _userSupervisorReason -> r) -> maybeCell r textCell
- , sortable (Just "rel-comp") (i18nCell MsgUserSupervisorCompany) $ \(view $ resultRelation . _entityVal . _userSupervisorCompany -> c) -> maybeCell c companyIdCell\
- , sortable (Just "supervisor") (i18nCell MsgTableSupervisor) $ \(view $ resultSupervisor -> u) -> cellHasUserModal ForProfileDataR u
- , sortable (Just "super-comp") (i18nCell MsgTableCompanies) $ \(view $ resultSupervisor . _entityKey -> uid) -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
- maybeMonoid <$> wgtCompanies True uid
- , sortable (Just "client") (i18nCell MsgTableSupervisee) $ \(view $ resultClient -> u) -> cellHasUserModal ForProfileDataR u
- , sortable (Just "client-comp") (i18nCell MsgTableCompanies) $ \(view $ resultClient . _entityKey -> uid) -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
- maybeMonoid <$> wgtCompanies True uid
- ]
- validator = def & defaultSorting [SortAscBy "rel-comp", SortAscBy "supervisor", SortAscBy "client"]
- & defaultFilter (singletonMap "violation" [toPathPiece SupervisionViolationEither])
- dbtSorting = Map.fromList
- [ ("reason" , SortColumn $ queryRelation >>> (E.^. UserSupervisorReason))
- , ("rel-comp" , SortColumn $ queryRelation >>> (E.^. UserSupervisorCompany))
- , ("reroute" , SortColumn $ queryRelation >>> (E.^. UserSupervisorRerouteNotifications))
- , ("supervisor" , SortColumn $ querySupervisor >>> (E.^. UserDisplayName))
- , ("client" , SortColumn $ queryClient >>> (E.^. UserDisplayName))
- , ("super-comp" , SortColumn (\row -> E.subSelect $ do
- (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
- E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySupervisor row E.^. UserId
- E.orderBy [E.asc $ cmp E.^. CompanyName]
- return (cmp E.^. CompanyName)
- ))
- , ("client-comp" , SortColumn (\row -> E.subSelect $ do
- (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
- E.where_ $ usrCmp E.^. UserCompanyUser E.==. queryClient row E.^. UserId
- E.orderBy [E.asc $ cmp E.^. CompanyName]
- return (cmp E.^. CompanyName)
- ))
- ]
-
- dbtFilter = Map.fromList
- [ ("violation", FilterColumn $ \(queryRelation -> us) (getLast -> criterion) -> case criterion of
- Just SupervisionViolationSupervisor -> missingCompanySupervisor us
- Just SupervisionViolationClient -> missingCompanyClient us
- Just SupervisionViolationBoth -> missingCompanySupervisor us E.&&. missingCompanyClient us
- _ -> missingCompanySupervisor us E.||. missingCompanyClient us
- )
- , ("rel-company", FilterColumn $ E.mkExistsFilter $ \(queryRelation -> us) (commaSeparatedText -> criteria) -> do
- let numCrits = setMapMaybe readMay criteria
- cmp <- E.from $ E.table @Company
- E.where_ $ cmp E.^. CompanyId E.=?. us E.^. UserSupervisorCompany
- E.&&. E.or (
- bcons (notNull numCrits)
- (E.mkExactFilter (E.^. CompanyAvsId) cmp numCrits)
- [E.mkContainsFilterWith CI.mk (E.^. CompanyName) cmp criteria
- ,E.mkContainsFilterWith CI.mk (E.^. CompanyShorthand) cmp criteria
- ]
- )
- )
- , ("supervisor-company", fltrCompanyNameNrUsr (querySupervisor >>> (E.^. UserId)))
- , ("client-company" , fltrCompanyNameNrUsr (queryClient >>> (E.^. UserId)))
- , ("supervisor", FilterColumn . E.mkContainsFilter $ querySupervisor >>> (E.^. UserDisplayName))
- , ("client" , FilterColumn . E.mkContainsFilter $ queryClient >>> (E.^. UserDisplayName))
- ]
- dbtFilterUI mPrev = mconcat -- Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text])
- [ prismAForm (singletonFilter "violation" . maybePrism _PathPiece) mPrev $ aopt supervisionViolationField (fslI MsgSupervisionViolationChoice)
- , prismAForm (singletonFilter "rel-company") mPrev $ aopt textField (fslI MsgUserSupervisorCompany & setTooltip MsgTableFilterCommaNameNr)
- , prismAForm (singletonFilter "supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
- , fltrCompanyNameNrUsrHdrUI "supervisor-company" (someMessages [MsgTableSupervisor, MsgTableCompany]) mPrev
- , prismAForm (singletonFilter "client") mPrev $ aopt textField (fslI MsgTableSupervisee)
- , fltrCompanyNameNrUsrHdrUI "client-company" (someMessages [MsgTableSupervisee, MsgTableCompany]) mPrev
- ]
-
- dbtParams = DBParamsForm
- { dbParamsFormMethod = POST
- , dbParamsFormAction = Nothing
- , dbParamsFormAttrs = []
- , dbParamsFormSubmit = FormSubmit
- , dbParamsFormAdditional =
- let acts :: Map ActSupervision (AForm Handler ActSupervisionData)
- acts = mconcat
- [ singletonMap ASChangeCompany $ pure ASChangeCompanyData
- ]
- in renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing
- , dbParamsFormEvaluate = liftHandler . runFormPost
- , dbParamsFormResult = id
- , dbParamsFormIdent = def
- }
- dbtCsvEncode = noCsvEncode
- dbtCsvDecode = Nothing
- dbtExtraReps = []
-
- postprocess :: FormResult (First ActSupervisionData, DBFormResult UserSupervisorId Bool TblSupervisionData)
- -> FormResult ( ActSupervisionData, Set UserSupervisorId)
- postprocess inp = do
- (First (Just act), jobMap) <- inp
- let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
- return (act, jobSet)
-
-
-getFirmsSupervisionR, postFirmsSupervisionR :: Handler Html
-getFirmsSupervisionR = postFirmsSupervisionR
-postFirmsSupervisionR = do
- (svRes, svTbl) <- runDB mkSupervisionTable
- formResult svRes $ \case
- (ASChangeCompanyData, relations) -> do
- addMessage Info $ text2Html [st|Firmenwechsel Ansprechpartnerbeziehung noch nicht implementiert. #{Set.size relations} empfangen.|]
- reloadKeepGetParams FirmsSupervisionR
- -- TODO: Bug Firmenwechsel: Bestehende Ansprechpartnerbeziehung - Firma ändern!
- let heading = MsgMenuFirmsSupervision
- siteLayoutMsg heading $ do
- setTitleI heading
- [whamlet|$newline never
-
- In folgenden Ansprechpartnerbeziehungen gehören entweder der Ansprechpartner oder der Angesprochene #
- nicht mehr der Firma an, welche als Begründung für die Beziehung eingetragen ist:
-
- ^{svTbl}
- |]
diff --git a/src/Handler/Firm/Supervision.hs b/src/Handler/Firm/Supervision.hs
new file mode 100644
index 000000000..fe5c6721e
--- /dev/null
+++ b/src/Handler/Firm/Supervision.hs
@@ -0,0 +1,234 @@
+-- SPDX-FileCopyrightText: 2023-25 Steffen Jost
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# LANGUAGE TypeApplications #-}
+
+module Handler.Firm.Supervision
+ ( getFirmsSupervisionR , postFirmsSupervisionR
+ )
+ where
+
+import Import
+
+-- import Jobs
+import Utils.Company
+import Handler.Utils
+import Handler.Utils.Company
+
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+-- import qualified Data.Csv as Csv
+-- import qualified Data.Text as T
+import qualified Data.CaseInsensitive as CI
+-- import qualified Data.Conduit.List as C
+-- import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
+import Database.Persist.Postgresql
+import Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Legacy as EL (on) -- needed for legacy join expected by dbTable
+-- import qualified Database.Esqueleto.PostgreSQL as E
+import qualified Database.Esqueleto.Utils as E
+-- import Database.Esqueleto.Utils.TH
+
+
+-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
+-- decryptUser = decrypt
+
+-- encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser
+-- encryptUser = encrypt
+
+
+-----------------------
+-- Supervision Sanity
+
+data ActSupervision = ASChangeCompany | ASRemoveAssociation
+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+ deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''ActSupervision $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''ActSupervision id
+
+data ActSupervisionData
+ = ASChangeCompanyData { asTblCompany :: Maybe CompanyShorthand, asTblReason :: Maybe Text }
+ | ASRemoveAssociationData
+ deriving (Eq, Ord, Read, Show, Generic)
+
+data SupervisionViolation = SupervisionViolationEither | SupervisionViolationClient | SupervisionViolationSupervisor | SupervisionViolationBoth
+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+ deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''SupervisionViolation $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''SupervisionViolation id
+
+supervisionViolationField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m SupervisionViolation
+-- supervisionViolationField = radioGroupField (Just $ SomeMessage MsgSupervisionViolationEither) $ optionsFinite
+supervisionViolationField = radioGroupField Nothing $ optionsFinite
+
+type TblSupervisionData = DBRow (Entity UserSupervisor, Entity User, Entity User)
+
+mkSupervisionTable :: DB (FormResult (ActSupervisionData, Set UserSupervisorId), Widget)
+mkSupervisionTable = over _1 postprocess <$> dbTable validator DBTable{..}
+ where
+ dbtIdent = "sanity-super" :: Text
+ dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
+
+ queryRelation :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserSupervisor)
+ queryRelation = $(E.sqlIJproj 3 1)
+ querySupervisor :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
+ querySupervisor = $(E.sqlIJproj 3 2)
+ queryClient :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
+ queryClient = $(E.sqlIJproj 3 3)
+
+ resultRelation :: Lens' TblSupervisionData (Entity UserSupervisor)
+ resultRelation = _dbrOutput . _1
+ resultSupervisor :: Lens' TblSupervisionData (Entity User)
+ resultSupervisor = _dbrOutput . _2
+ resultClient :: Lens' TblSupervisionData (Entity User)
+ resultClient = _dbrOutput . _3
+
+ dbtSQLQuery (uus `E.InnerJoin` spr `E.InnerJoin` sub) = do
+ EL.on $ uus E.^. UserSupervisorSupervisor E.==. spr E.^. UserId
+ EL.on $ uus E.^. UserSupervisorUser E.==. sub E.^. UserId
+ E.where_ $ E.isJust (uus E.^. UserSupervisorCompany)
+ return (uus, spr, sub)
+ dbtRowKey = queryRelation >>> (E.^. UserSupervisorId)
+ dbtProj = dbtProjId
+ dbtColonnade = formColonnade $ mconcat
+ [ dbSelect (applying _2) id (return . view (resultRelation . _entityKey))
+ , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \(view $ resultRelation . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
+ , sortable (Just "reason") (i18nCell MsgUserSupervisorReason) $ \(view $ resultRelation . _entityVal . _userSupervisorReason -> r) -> maybeCell r textCell
+ , sortable (Just "rel-comp") (i18nCell MsgUserSupervisorCompany) $ \(view $ resultRelation . _entityVal . _userSupervisorCompany -> c) -> maybeCell c companyIdCell\
+ , sortable (Just "supervisor") (i18nCell MsgTableSupervisor) $ \(view $ resultSupervisor -> u) -> cellHasUserModal ForProfileDataR u
+ , sortable (Just "super-comp") (i18nCell MsgTableCompanies) $ \(view $ resultSupervisor . _entityKey -> uid) -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
+ maybeMonoid <$> wgtCompanies True uid
+ , sortable (Just "client") (i18nCell MsgTableSupervisee) $ \(view $ resultClient -> u) -> cellHasUserModal ForProfileDataR u
+ , sortable (Just "client-comp") (i18nCell MsgTableCompanies) $ \(view $ resultClient . _entityKey -> uid) -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
+ maybeMonoid <$> wgtCompanies True uid
+ ]
+ validator = def & defaultSorting [SortAscBy "rel-comp", SortAscBy "supervisor", SortAscBy "client"]
+ & defaultFilter (singletonMap "violation" [toPathPiece SupervisionViolationEither])
+ dbtSorting = Map.fromList
+ [ ("reason" , SortColumn $ queryRelation >>> (E.^. UserSupervisorReason))
+ , ("rel-comp" , SortColumn $ queryRelation >>> (E.^. UserSupervisorCompany))
+ , ("reroute" , SortColumn $ queryRelation >>> (E.^. UserSupervisorRerouteNotifications))
+ , ("supervisor" , SortColumn $ querySupervisor >>> (E.^. UserDisplayName))
+ , ("client" , SortColumn $ queryClient >>> (E.^. UserDisplayName))
+ , ("super-comp" , SortColumn (\row -> E.subSelect $ do
+ (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
+ E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySupervisor row E.^. UserId
+ E.orderBy [E.asc $ cmp E.^. CompanyName]
+ return (cmp E.^. CompanyName)
+ ))
+ , ("client-comp" , SortColumn (\row -> E.subSelect $ do
+ (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
+ E.where_ $ usrCmp E.^. UserCompanyUser E.==. queryClient row E.^. UserId
+ E.orderBy [E.asc $ cmp E.^. CompanyName]
+ return (cmp E.^. CompanyName)
+ ))
+ ]
+
+ dbtFilter = Map.fromList
+ [ ("violation", FilterColumn $ \(queryRelation -> us) (getLast -> criterion) -> case criterion of
+ Just SupervisionViolationSupervisor -> missingCompanySupervisor us
+ Just SupervisionViolationClient -> missingCompanyClient us
+ Just SupervisionViolationBoth -> missingCompanySupervisor us E.&&. missingCompanyClient us
+ _ -> missingCompanySupervisor us E.||. missingCompanyClient us
+ )
+ , ("rel-company", FilterColumn $ E.mkExistsFilter $ \(queryRelation -> us) (commaSeparatedText -> criteria) -> do
+ let numCrits = setMapMaybe readMay criteria
+ cmp <- E.from $ E.table @Company
+ E.where_ $ cmp E.^. CompanyId E.=?. us E.^. UserSupervisorCompany
+ E.&&. E.or (
+ bcons (notNull numCrits)
+ (E.mkExactFilter (E.^. CompanyAvsId) cmp numCrits)
+ [E.mkContainsFilterWith CI.mk (E.^. CompanyName) cmp criteria
+ ,E.mkContainsFilterWith CI.mk (E.^. CompanyShorthand) cmp criteria
+ ]
+ )
+ )
+ , ("supervisor-company", fltrCompanyShortNrUsr (querySupervisor >>> (E.^. UserId)))
+ , ("client-company" , fltrCompanyShortNrUsr (queryClient >>> (E.^. UserId)))
+ , ("supervisor", FilterColumn . E.mkContainsFilter $ querySupervisor >>> (E.^. UserDisplayName))
+ , ("client" , FilterColumn . E.mkContainsFilter $ queryClient >>> (E.^. UserDisplayName))
+ ]
+ dbtFilterUI mPrev = mconcat -- Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text])
+ [ prismAForm (singletonFilter "violation" . maybePrism _PathPiece) mPrev $ aopt supervisionViolationField (fslI MsgSupervisionViolationChoice)
+ , prismAForm (singletonFilter "rel-company") mPrev $ aopt textField (fslI MsgUserSupervisorCompany & setTooltip MsgTableFilterCommaNameNr)
+ , prismAForm (singletonFilter "supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
+ , fltrCompanyNameNrUsrHdrUI "supervisor-company" (someMessages [MsgTableSupervisor, MsgTableCompanyShort]) mPrev
+ , prismAForm (singletonFilter "client") mPrev $ aopt textField (fslI MsgTableSupervisee)
+ , fltrCompanyNameNrUsrHdrUI "client-company" (someMessages [MsgTableSupervisee, MsgTableCompanyShort]) mPrev
+ ]
+
+ suggestionSupervision :: Handler (OptionList Text)
+ suggestionSupervision = mkOptionListText <$> runDB
+ (E.select $ do
+ us <- E.from $ E.table @UserSupervisor
+ let reason = us E.^. UserSupervisorReason
+ countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
+ E.where_ $ E.isJust reason
+ E.groupBy reason
+ E.orderBy [E.desc countRows']
+ E.limit 9
+ pure $ E.coalesceDefault [reason] (E.val "")
+ )
+ dbtParams = DBParamsForm
+ { dbParamsFormMethod = POST
+ , dbParamsFormAction = Nothing
+ , dbParamsFormAttrs = []
+ , dbParamsFormSubmit = FormSubmit
+ , dbParamsFormAdditional =
+ let acts :: Map ActSupervision (AForm Handler ActSupervisionData)
+ acts = mconcat
+ [ singletonMap ASChangeCompany $ ASChangeCompanyData
+ <$> aopt companyField (fslI MsgUserSupervisorCompany) Nothing
+ <*> aopt (textField & cfStrip & addDatalist suggestionSupervision) (fslI MsgUserSupervisorReason & setTooltip MsgStarKeepsEmptyDeletes) (Just $ Just "*")
+ , singletonMap ASRemoveAssociation $ pure ASRemoveAssociationData
+ ]
+ in renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing
+ , dbParamsFormEvaluate = liftHandler . runFormPost
+ , dbParamsFormResult = id
+ , dbParamsFormIdent = def
+ }
+ dbtCsvEncode = noCsvEncode
+ dbtCsvDecode = Nothing
+ dbtExtraReps = []
+
+ postprocess :: FormResult (First ActSupervisionData, DBFormResult UserSupervisorId Bool TblSupervisionData)
+ -> FormResult ( ActSupervisionData, Set UserSupervisorId)
+ postprocess inp = do
+ (First (Just act), jobMap) <- inp
+ let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
+ return (act, jobSet)
+
+
+getFirmsSupervisionR, postFirmsSupervisionR :: Handler Html
+getFirmsSupervisionR = postFirmsSupervisionR
+postFirmsSupervisionR = do
+ (svRes, svTbl) <- runDB mkSupervisionTable
+ formResult svRes $ \case
+ (ASRemoveAssociationData, relations) -> do
+ nrDel <- runDB $ deleteWhereCount [UserSupervisorId <-. Set.toList relations]
+ addMessageOutOfI MsgSupervisionsRemoved nrDel $ Set.size relations
+ reloadKeepGetParams FirmsSupervisionR
+ (ASChangeCompanyData{..}, relations) -> do
+ let rsnChg = case asTblReason of
+ Just "*" -> Nothing
+ _ -> Just $ UserSupervisorReason =. asTblReason
+ chgs = mcons rsnChg [UserSupervisorCompany =. CompanyKey <$> canonical asTblCompany]
+ nrChg <- runDB $ updateWhereCount [UserSupervisorId <-. Set.toList relations] chgs
+ addMessageOutOfI MsgSupervisionsEdited nrChg $ Set.size relations
+ reloadKeepGetParams FirmsSupervisionR
+ -- TODO: Bug Firmenwechsel: Bestehende Ansprechpartnerbeziehung - Firma ändern!
+ let heading = MsgMenuFirmsSupervision
+ siteLayoutMsg heading $ do
+ setTitleI heading
+ [whamlet|$newline never
+
+ _{MsgFirmSupervisionRInfo} In folgenden Ansprechpartnerbeziehungen gehören entweder der Ansprechpartner oder der Angesprochene #
+ nicht mehr der Firma an, welche als Begründung für die Beziehung eingetragen ist:
+
+ ^{svTbl}
+ |]
diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs
index 372338394..eb35c85ec 100644
--- a/src/Handler/PrintCenter.hs
+++ b/src/Handler/PrintCenter.hs
@@ -315,8 +315,7 @@ postPrintCenterR = do
oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF (fromMaybe False ignoreReroute)
let nr_oks = getSum $ mconcat oks
nr_tot = length pjIds
- mstat = bool Warning Success $ nr_oks == nr_tot
- addMessageI mstat $ MsgPrintJobReprint nr_oks nr_tot
+ addMessageOutOfI MsgPrintJobReprint nr_oks nr_tot
reloadKeepGetParams PrintCenterR
siteConf <- getYesod
let lprConf = siteConf ^. _appLprConf
diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs
index 10989ea5c..a5aeb2c30 100644
--- a/src/Handler/Qualification.hs
+++ b/src/Handler/Qualification.hs
@@ -634,7 +634,7 @@ postQualificationR sid qsh = do
jobs <- forM validQualHolders $ queueJob . JobLmsEnqueueUser qid
let nrTodo = length selectedUsers
nrEnqueued = length $ catMaybes jobs
- addMessageI (bool Warning Success $ nrEnqueued > 0 && nrEnqueued == nrTodo) $ MsgQualificationActStartELearningStatus qsh nrEnqueued nrTodo
+ addMessageOutOfI (MsgQualificationActStartELearningStatus qsh) nrEnqueued nrTodo
-- transaction audit identical to automatic start, performed by JobLmsEnqueueUser
reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isExpiryAct action -> do
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 68a44dfe0..041a317b6 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -3,6 +3,7 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE TypeApplications #-}
module Handler.Utils.Form
( module Handler.Utils.Form
@@ -40,6 +41,7 @@ import qualified Data.Conduit.List as C (mapMaybe, mapMaybeM)
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect)
+import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import Database.Persist.Sql.Raw.QQ
import qualified Data.Set as Set
@@ -2643,3 +2645,21 @@ i18nFieldW :: forall a ident handler.
-> Maybe (Maybe (I18n a))
-> WForm handler (FormResult (Maybe (I18n a)))
i18nFieldW strField onlyAppLanguages miButtonAction miIdent fSettings fRequired mPrev' = aFormToWForm $ i18nFieldA strField onlyAppLanguages miButtonAction miIdent fSettings fRequired mPrev'
+
+
+companyField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m CompanyShorthand
+companyField = checkMMap findCompany CI.original textField
+ where
+ -- findCompany :: Text -> m (Either msg CompanyShorthand)
+ findCompany tc = do
+ cmps <- liftHandler $ runDBRead $ Ex.select $ do
+ cmp <- Ex.from $ Ex.table @Company
+ let numFltr n = cmp E.^.CompanyAvsId E.==. E.val n
+ namFltr = E.mkContainsFilterWith CI.mk (E.^. CompanyName) cmp (Set.singleton tc)
+ E.||. E.mkContainsFilterWith CI.mk (E.^. CompanyShorthand) cmp (Set.singleton tc)
+ Ex.where_ $ maybe namFltr numFltr $ readMay tc
+ return $ cmp E.^. CompanyShorthand
+ return $ case cmps of
+ [E.Value fsh] -> Right fsh
+ [] -> Left MsgFirmNameNotFound
+ _ -> Left MsgFirmNameAmbiguous
\ No newline at end of file
diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs
index 4f9d9df03..91605cbb5 100644
--- a/src/Handler/Utils/Table/Columns.hs
+++ b/src/Handler/Utils/Table/Columns.hs
@@ -844,6 +844,18 @@ fltrCompanyNameNrUsr query = FilterColumn . E.mkExistsFilter $ \(query -> user)
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. user E.&&. testcrit
+fltrCompanyShortNrUsr :: (IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool)))
+ => (a -> E.SqlExpr (E.Value (Key User))) -> FilterColumn t fs
+
+fltrCompanyShortNrUsr query = FilterColumn . E.mkExistsFilter $ \(query -> user) 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.^. CompanyShorthand) :: 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.==. user E.&&. testcrit
+
---------
-- AVS --
diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs
index 372bf0401..394ec653d 100644
--- a/src/Utils/Message.hs
+++ b/src/Utils/Message.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost
+-- SPDX-FileCopyrightText: 2022-25 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@@ -12,6 +12,7 @@ module Utils.Message
, Message(..)
, messageIconI, messageIconIHamlet, messageIconFile, messageIconWidget
, messageI, messageIHamlet, messageFile, messageWidget, messageTooltip
+ , addMessageOutOfI
) where
import Data.Universe
@@ -137,6 +138,13 @@ addMessage mc = ClassyPrelude.Yesod.addMessage $ encodeMessageStatus mc
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m ()
addMessageI mc = ClassyPrelude.Yesod.addMessageI $ encodeMessageStatus mc
+-- | For messages of type n-success out of m-total; Success if n==m, Warning otherwise
+addMessageOutOfI :: (MonadHandler m, RenderMessage (HandlerSite m) msg, Integral ia, Integral ib, Num n, Ord n)
+ => (n -> n -> msg) -> ia -> ib -> m ()
+addMessageOutOfI msg (fromIntegral -> nr) (fromIntegral -> total) = addMessageI allok $ msg nr total
+ where
+ allok = bool Utils.Message.Warning Utils.Message.Success $ total > 0 && total == nr
+
messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m Message
messageI messageStatus msg = do
messageContent <- toHtml . ($ msg) <$> getMessageRender