chore(firm): finalize supervision discrepancy view
This commit is contained in:
parent
8a17c0e368
commit
cfbb489db4
@ -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.
|
||||
|
||||
@ -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
|
||||
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.
|
||||
@ -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
|
||||
|
||||
@ -41,4 +41,5 @@ Ambiguous: ist uneindeutig
|
||||
Action: Aktion
|
||||
For: für
|
||||
Address: Adresse
|
||||
NoContactAddress: Keinerlei Kontaktdaten bekannt!
|
||||
NoContactAddress: Keinerlei Kontaktdaten bekannt!
|
||||
StarKeepsEmptyDeletes: Stern zum Beibehalten, leer lassen zum Löschen
|
||||
@ -41,4 +41,5 @@ Ambiguous: is ambiguous
|
||||
Action: Action
|
||||
For: for
|
||||
Address: Address
|
||||
NoContactAddress: No contact details known!
|
||||
NoContactAddress: No contact details known!
|
||||
StarKeepsEmptyDeletes: A star to keep unchanged, blank removes
|
||||
@ -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}
|
||||
@ -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
|
||||
<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
234
src/Handler/Firm/Supervision.hs
Normal 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}
|
||||
|]
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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 --
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user