fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(firm): finalize supervision discrepancy view

Browse Source
This commit is contained in:
Steffen Jost 2025-02-13 13:03:48 +01:00
parent 8a17c0e368
commit cfbb489db4
13 changed files with 308 additions and 196 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
messages/uniworx/categories/firm/de-de-formal.msg
View File

@ -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 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 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. 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 FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen
FirmSetSupervisor: Existierende 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)} 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! CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird!
CompanySupervisorCompanyMissing fsh@CompanyShorthand: Empfänger ist nicht mit Firma #{fsh} aus Ansprechpartnerbeziehung assoziiert 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 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 SupervisionViolationChoice: Firmenassoziation fehlt für
SupervisionViolationEither: Egal SupervisionViolationEither: Egal
SupervisionViolationSupervisor: Ansprechpartner SupervisionViolationSupervisor: Ansprechpartner
SupervisionViolationClient: Klient SupervisionViolationClient: Klient
SupervisionViolationBoth: Beide 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.

10
messages/uniworx/categories/firm/en-eu.msg
View File

@ -25,7 +25,7 @@ FirmActAddAssociates: Associate users with company
FirmActAddSupersEmpty: No new supervisors added! 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. 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! 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. RemoveSupervisors ndef: #{ndef} default supervisors removed.
FirmActChangeContactUser: Change contact data for all company associates FirmActChangeContactUser: Change contact data for all company associates
FirmActChangeContactFirm: Change company contact data 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! 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 CompanySupervisorCompanyMissing fsh: Receiver is not associated with #{fsh} given as reroute reason
CompanySuperviseeCompanyMissing fsh: Supervisee is not associated with #{fsh} detailed as supervisionship 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 SupervisionViolationChoice: Company association missing for
SupervisionViolationEither: anyone SupervisionViolationEither: anyone
SupervisionViolationSupervisor: Supervisor SupervisionViolationSupervisor: Supervisor
SupervisionViolationClient: Supervisee SupervisionViolationClient: Supervisee
SupervisionViolationBoth: both SupervisionViolationBoth: both
ASChangeCompany: Change company for supervisionship 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.

2
messages/uniworx/categories/user/de-de-formal.msg
View File

@ -96,7 +96,7 @@ UserHijack: Sitzung übernehmen
UserAddSupervisor: Ansprechpartner hinzufügen UserAddSupervisor: Ansprechpartner hinzufügen
UserSetSupervisor: Ansprechpartner ersetzen UserSetSupervisor: Ansprechpartner ersetzen
UserRemoveSupervisor: Alle Ansprechpartner entfernen UserRemoveSupervisor: Alle Ansprechpartner entfernen
UserRemoveClients: Alle Ansprechpartnerbeziehungen zu Untergebenen beenden UserRemoveClients: Alle Ansprechpartnerbeziehungen zu Klienten beenden
UserIsSupervisor: Ist Ansprechpartner UserIsSupervisor: Ist Ansprechpartner
UserAvsSwitchCompany: Als Primärfirma verwenden UserAvsSwitchCompany: Als Primärfirma verwenden
UserAvsSwitchCompanyField: Primärfirma auswählen UserAvsSwitchCompanyField: Primärfirma auswählen

1
messages/uniworx/misc/de-de-formal.msg
View File

@ -42,3 +42,4 @@ Action: Aktion
For: für For: für
Address: Adresse Address: Adresse
NoContactAddress: Keinerlei Kontaktdaten bekannt! NoContactAddress: Keinerlei Kontaktdaten bekannt!
StarKeepsEmptyDeletes: Stern zum Beibehalten, leer lassen zum Löschen

1
messages/uniworx/misc/en-eu.msg
View File

@ -42,3 +42,4 @@ Action: Action
For: for For: for
Address: Address Address: Address
NoContactAddress: No contact details known! NoContactAddress: No contact details known!
StarKeepsEmptyDeletes: A star to keep unchanged, blank removes

2
messages/uniworx/utils/table_column/en-eu.msg
View File

@ -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. 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. TableFilterCommaPlusShort: Support multiple criteria with comma/plus, see above.
TableFilterCommaName: Separate names by comma. 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 TableUserEdit: Edit user
TableRows: Rows TableRows: Rows
TableUserParkingToken day: Parking token #{day} TableUserParkingToken day: Parking token #{day}

193
src/Handler/Firm.hs
View File

@ -19,7 +19,6 @@ module Handler.Firm
import Import import Import
-- import Jobs -- import Jobs
import Utils.Company
import Handler.Utils import Handler.Utils
import Handler.Utils.Company import Handler.Utils.Company
import Handler.Utils.Communication 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 qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
import Handler.Firm.Supervision
-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId -- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
-- decryptUser = decrypt -- decryptUser = decrypt
@ -233,10 +233,8 @@ firmActionHandler route isAdmin = flip formResult faHandler
addMessageI Warning MsgFirmActAddAssocsEmpty addMessageI Warning MsgFirmActAddAssocsEmpty
reloadKeepGetParams route reloadKeepGetParams route
runDB $ do runDB $ do
oks0 <- mapM insertUnique_ [UserCompany uid cid False False firmActAddAssociatePriority firmActAddUserUseCompanyAddress firmActAddAssociateReason | uid <- usersFound] oks <- mapM insertUnique_ [UserCompany uid cid False False firmActAddAssociatePriority firmActAddUserUseCompanyAddress firmActAddAssociateReason | uid <- usersFound]
let oks = length $ catMaybes oks0 addMessageOutOfI (const . MsgFirmActAddAssocs) (length $ catMaybes oks) (length usersFound)
allok = bool Warning Success $ oks == length usersFound
addMessageI allok $ MsgFirmActAddAssocs (fromIntegral oks)
redirect route redirect route
faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) = faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) =
@ -271,9 +269,8 @@ firmActionHandler route isAdmin = flip formResult faHandler
Just x -> updateWhereCount [UserCompanyCompany ==. cid] [UserCompanyUseCompanyAddress =. x] Just x -> updateWhereCount [UserCompanyCompany ==. cid] [UserCompanyUseCompanyAddress =. x]
Nothing -> return 0 Nothing -> return 0
nrCid <- count [UserCompanyCompany ==. cid] nrCid <- count [UserCompanyCompany ==. cid]
return (fromIntegral nrCid, max nrUsrChange nrUseComp) return (nrCid, max nrUsrChange nrUseComp)
let allok = bool Warning Success $ nrChanged == total addMessageOutOfI MsgFirmUserActChangeResult nrChanged total
addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
reloadKeepGetParams route -- reload to reflect changes reloadKeepGetParams route -- reload to reflect changes
faHandler _ = addMessageI Error MsgErrorUnknownFormAction faHandler _ = addMessageI Error MsgErrorUnknownFormAction
@ -1165,15 +1162,13 @@ postFirmUsersR fsh = do
nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
addMessageI Success $ MsgFirmActAddSupersSet nrUpd Nothing addMessageI Success $ MsgFirmActAddSupersSet nrUpd Nothing
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
(FirmUserActChangeDetailsData{..}, Set.toList -> uids) -> do (FirmUserActChangeDetailsData{..}, uids) -> do
let upReason = case canonical firmUserActDetailReason of let upReason = case canonical firmUserActDetailReason of
Nothing -> Nothing Nothing -> Nothing
Just "NULL" -> Just $ UserCompanyReason =. Nothing Just "NULL" -> Just $ UserCompanyReason =. Nothing
other -> Just $ UserCompanyReason =. other other -> Just $ UserCompanyReason =. other
nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority] nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. Set.toList uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority]
let total = fromIntegral $ length uids addMessageOutOfI MsgFirmUserActChangeDetailsResult nrUpd $ Set.size uids
allok = bool Warning Success $ nrUpd == total
addMessageI allok $ MsgFirmUserActChangeDetailsResult nrUpd total
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
(FirmUserActChangeContactData{..}, Set.toList -> uids) (FirmUserActChangeContactData{..}, Set.toList -> uids)
| firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr -> | firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr ->
@ -1191,9 +1186,7 @@ postFirmUsersR fsh = do
Just x -> updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanyUseCompanyAddress =. x] Just x -> updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanyUseCompanyAddress =. x]
Nothing -> return 0 Nothing -> return 0
return $ max nrUsrChange nrUseComp return $ max nrUsrChange nrUseComp
let total = fromIntegral $ length uids addMessageOutOfI MsgFirmUserActChangeResult nrChanged $ length uids
allok = bool Warning Success $ nrChanged == total
addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
(FirmUserActRemoveData{..}, Set.toList -> uids) -> do (FirmUserActRemoveData{..}, Set.toList -> uids) -> do
let optRemove = if firmUserActRemoveSupers then id else const $ return 0 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 Supervisor von gewählten Leuten, gruppiert nach deren Firma
Alle gewählten Personen, 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
<p>
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:
<p>
^{svTbl}
|]

234
src/Handler/Firm/Supervision.hs Normal file
View File

@ -0,0 +1,234 @@
-- SPDX-FileCopyrightText: 2023-25 Steffen Jost <S.Jost@fraport.de>
--
-- 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
<p>
_{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:
<p>
^{svTbl}
|]

3
src/Handler/PrintCenter.hs
View File

@ -315,8 +315,7 @@ postPrintCenterR = do
oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF (fromMaybe False ignoreReroute) oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF (fromMaybe False ignoreReroute)
let nr_oks = getSum $ mconcat oks let nr_oks = getSum $ mconcat oks
nr_tot = length pjIds nr_tot = length pjIds
mstat = bool Warning Success $ nr_oks == nr_tot addMessageOutOfI MsgPrintJobReprint nr_oks nr_tot
addMessageI mstat $ MsgPrintJobReprint nr_oks nr_tot
reloadKeepGetParams PrintCenterR reloadKeepGetParams PrintCenterR
siteConf <- getYesod siteConf <- getYesod
let lprConf = siteConf ^. _appLprConf let lprConf = siteConf ^. _appLprConf

2
src/Handler/Qualification.hs
View File

@ -634,7 +634,7 @@ postQualificationR sid qsh = do
jobs <- forM validQualHolders $ queueJob . JobLmsEnqueueUser qid jobs <- forM validQualHolders $ queueJob . JobLmsEnqueueUser qid
let nrTodo = length selectedUsers let nrTodo = length selectedUsers
nrEnqueued = length $ catMaybes jobs 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 -- transaction audit identical to automatic start, performed by JobLmsEnqueueUser
reloadKeepGetParams $ QualificationR sid qsh reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isExpiryAct action -> do (action, selectedUsers) | isExpiryAct action -> do

20
src/Handler/Utils/Form.hs
View File

@ -3,6 +3,7 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE TypeApplications #-}
module Handler.Utils.Form module Handler.Utils.Form
( 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.Legacy as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect) 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 Database.Persist.Sql.Raw.QQ
import qualified Data.Set as Set import qualified Data.Set as Set
@ -2643,3 +2645,21 @@ i18nFieldW :: forall a ident handler.
-> Maybe (Maybe (I18n a)) -> Maybe (Maybe (I18n a))
-> WForm handler (FormResult (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' 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

12
src/Handler/Utils/Table/Columns.hs
View File

@ -844,6 +844,18 @@ fltrCompanyNameNrUsr query = FilterColumn . E.mkExistsFilter $ \(query -> user)
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. user E.&&. testcrit 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 -- -- AVS --

10
src/Utils/Message.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2022-25 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <sjost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -12,6 +12,7 @@ module Utils.Message
, Message(..) , Message(..)
, messageIconI, messageIconIHamlet, messageIconFile, messageIconWidget , messageIconI, messageIconIHamlet, messageIconFile, messageIconWidget
, messageI, messageIHamlet, messageFile, messageWidget, messageTooltip , messageI, messageIHamlet, messageFile, messageWidget, messageTooltip
, addMessageOutOfI
) where ) where
import Data.Universe 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 :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m ()
addMessageI mc = ClassyPrelude.Yesod.addMessageI $ encodeMessageStatus mc 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 :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m Message
messageI messageStatus msg = do messageI messageStatus msg = do
messageContent <- toHtml . ($ msg) <$> getMessageRender messageContent <- toHtml . ($ msg) <$> getMessageRender