From aefafa32d1fe30bc5f49d178a5de6b0c48c56e6c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 12 Feb 2025 17:02:04 +0100 Subject: [PATCH] chore(firm): filter working on supervision discrepancy view --- .../uniworx/categories/firm/de-de-formal.msg | 7 +- messages/uniworx/categories/firm/en-eu.msg | 9 +- .../uniworx/categories/user/de-de-formal.msg | 4 +- messages/uniworx/categories/user/en-eu.msg | 4 +- .../utils/table_column/de-de-formal.msg | 4 +- messages/uniworx/utils/table_column/en-eu.msg | 2 +- src/Handler/Firm.hs | 125 +++++++++++------- src/Handler/Users.hs | 10 +- src/Handler/Utils/Avs.hs | 2 +- src/Handler/Utils/Table/Columns.hs | 107 ++++++++------- src/Utils/Company.hs | 10 +- test/Database/Fill.hs | 4 +- 12 files changed, 164 insertions(+), 124 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 0e57b9ead..cb58e7679 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -82,5 +82,10 @@ CompanyUserUseCompanyAddress: Verwendet Firmenkontaktaddresse CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterlegt ist 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: Betroffener ist nicht mit Firma #{fsh} aus Ansprechpartnerbeziehung assoziiert +CompanySuperviseeCompanyMissing fsh@CompanyShorthand: Klient ist nicht mit Firma #{fsh} aus Ansprechpartnerbeziehung assoziiert +SupervisionViolationChoice: Firmenassoziation fehlt für +SupervisionViolationEither: Egal +SupervisionViolationSupervisor: Ansprechpartner +SupervisionViolationClient: Klient +SupervisionViolationBoth: Beide ASChangeCompany: Firma ändern, welche Ansprechpartnerbeziehung begründet diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 5af785218..7126ef24d 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -15,7 +15,7 @@ FirmActionInfo: Affects alle company associates under your supervision. FirmActNotify: Send message FirmActResetSupervision: Reset supervisors for all company associates FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? -FirmActRemoveSupers: Terminate all company related supervisonships? +FirmActRemoveSupers: Terminate all company related supervisionships? FirmActResetMutualSupervision: Supervisors supervise each other FirmActResetSupersKeepAll: Keep all FirmActResetSupersRemoveAps: Remove default supervisors only @@ -82,5 +82,10 @@ CompanyUserUseCompanyAddress: Use company postal address CompanyUserUseCompanyAddressTip: if and only if the postal address of the user is empty 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 supervisonship reason +CompanySuperviseeCompanyMissing fsh: Supervisee is not associated with #{fsh} detailed as supervisionship reason +SupervisionViolationChoice: Company association missing for +SupervisionViolationEither: anyone +SupervisionViolationSupervisor: Supervisor +SupervisionViolationClient: Supervisee +SupervisionViolationBoth: both ASChangeCompany: Change company for supervisionship \ 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 b7cfebbe7..fc838e742 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 -UserRemoveSubordinates: Alle Ansprechpartnerbeziehungen zu Untergebenen beenden +UserRemoveClients: Alle Ansprechpartnerbeziehungen zu Untergebenen beenden UserIsSupervisor: Ist Ansprechpartner UserAvsSwitchCompany: Als Primärfirma verwenden UserAvsSwitchCompanyField: Primärfirma auswählen @@ -112,7 +112,7 @@ Name !ident-ok: Name UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt. UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden! UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht. -UsersRemoveSubordinates usr@Int: Alle Ansprechpartnerbeziehungen für #{tshow usr} #{pluralDE usr "ehemaligen" "ehemalige"} Ansprechpartner gelöscht. +UsersRemoveClients usr@Int: Alle Ansprechpartnerbeziehungen für #{tshow usr} #{pluralDE usr "ehemaligen" "ehemalige"} Ansprechpartner gelöscht. UserCompanyReason: Begründung der Firmenassoziation UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern. UserSupervisorReason: Begründung Ansprechpartner diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 5ca0bbf1c..a3d0ebf05 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -96,7 +96,7 @@ UserHijack: Hijack session UserAddSupervisor: Add supervisor UserSetSupervisor: Replace supervisors UserRemoveSupervisor: Set to unsupervised -UserRemoveSubordinates: Remove all subordinates +UserRemoveClients: Remove all clients UserIsSupervisor: Is supervisor UserAvsSwitchCompany: Use as primary company UserAvsSwitchCompanyField: Select primary company @@ -112,7 +112,7 @@ Name: Name UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{pluralENsN usr "user"} set. UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified! UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}. -UsersRemoveSubordinates usr: Removed all subordinates for #{pluralENsN usr "previous supervisor"}. +UsersRemoveClients usr: Removed all clients for #{pluralENsN usr "previous supervisor"}. UserCompanyReason: Reason for company association UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes. UserSupervisorReason: Reason for supervision diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 812aee1bc..e4c0fd753 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -103,7 +103,7 @@ TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige TableCompanyPinPassword: Pin Passwort für PDF Anhänge TableSupervisor: Ansprechpartner TableSupervisorActive: Aktiver Ansprechpartner -TableSupervisee: Ansprechpartner für +TableSupervisee: Klient TableReason: Begründung TableCreationTime: Erstellungszeit TableJob !ident-ok: Job @@ -118,7 +118,7 @@ TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrenn TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. TableFilterCommaPlusShort: Unterstützt mehrere Kriterien mit Komma-Plus, siehe oben. TableFilterCommaName: Mehrere Namen mit Komma trennen. -TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. +TableFilterCommaNameNr: Mehrere Namen oder exakte Nummern mit Komma trennen. TableUserEdit: Benutzer bearbeiten TableRows: Zeilen TableUserParkingToken day@Text: Parkmarke #{day} \ 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 62d534c38..19cc690b5 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -103,7 +103,7 @@ TableCompanyPostalPreference: Default notification preference TableCompanyPinPassword: Pin password for PDF attachments TableSupervisor: Supervisor TableSupervisorActive: Active supervisor -TableSupervisee: Supervisor for +TableSupervisee: Supervisee TableReason: Reason TableCreationTime: Creation TableJob !ident-ok: Job diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 414a62e4c..27d11dd7b 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -19,6 +19,7 @@ module Handler.Firm import Import -- import Jobs +import Utils.Company import Handler.Utils import Handler.Utils.Company import Handler.Utils.Communication @@ -1532,7 +1533,7 @@ handleFirmCommR ultDest cs = do ----------------------- -- Supervision Sanity -data ActSupervision = ASChangeCompany +data ActSupervision = ASChangeCompany -- | ASRemoveCompany | deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -1542,54 +1543,43 @@ 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) -mkSupervisonTable :: DB (FormResult (ActSupervisionData, Set UserSupervisorId), Widget) -mkSupervisonTable = over _1 postprocess <$> dbTable validator DBTable{..} +mkSupervisionTable :: DB (FormResult (ActSupervisionData, Set UserSupervisorId), Widget) +mkSupervisionTable = over _1 postprocess <$> dbTable validator DBTable{..} where dbtIdent = "sanity-super" :: Text - dbtStyle = def + 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) - querySubordinate :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User) - querySubordinate = $(E.sqlIJproj 3 3) + 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 - resultSubordinate :: Lens' TblSupervisionData (Entity User) - resultSubordinate = _dbrOutput . _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 - let usrHasNotCmp qUsr = E.notExists $ do - uc <- E.from $ E.table @UserCompany - E.where_ $ uc E.^. UserCompanyCompany E.=?. uus E.^. UserSupervisorCompany - E.&&. uc E.^. UserCompanyUser E.==. uus E.^. qUsr E.where_ $ E.isJust (uus E.^. UserSupervisorCompany) - E.&&. (usrHasNotCmp UserSupervisorSupervisor E.||. usrHasNotCmp UserSupervisorUser) - -- E.where_ $ E.isJust (uus E.^. UserSupervisorCompany) -- types, but yields incorrect result - -- E.&&. E.notExists (do - -- uc <- E.from ( - -- (do - -- uc <- E.from $ E.table @UserCompany - -- E.where_ $ uc E.^. UserCompanyCompany E.=?. uus E.^. UserSupervisorCompany - -- E.&&. uc E.^. UserCompanyUser E.==. uus E.^. UserSupervisorUser - -- pure uc - -- ) `E.unionAll_` (do - -- uc <- E.from $ E.table @UserCompany - -- E.where_ $ uc E.^. UserCompanyCompany E.=?. uus E.^. UserSupervisorCompany - -- E.&&. uc E.^. UserCompanyUser E.==. uus E.^. UserSupervisorSupervisor - -- pure uc - -- )) - -- E.where_ $ uc E.^. UserCompanyCompany E.=?. uus E.^. UserSupervisorCompany - -- ) return (uus, spr, sub) dbtRowKey = queryRelation >>> (E.^. UserSupervisorId) dbtProj = dbtProjId @@ -1597,36 +1587,69 @@ mkSupervisonTable = over _1 postprocess <$> dbTable validator DBTable{..} [ 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 "cshort") (i18nCell MsgUserSupervisorCompany) $ \(view $ resultRelation . _entityVal . _userSupervisorCompany -> c) -> maybeCell c companyIdCell\ - , sortable (Just "super") (i18nCell MsgTableSupervisor) $ \(view $ resultSupervisor -> u) -> cellHasUserModal ForProfileDataR u - , sortable (Just "super-com") (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" + , 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 "subordinate") (i18nCell MsgTableSupervisee) $ \(view $ resultSubordinate -> u) -> cellHasUserModal ForProfileDataR u - , sortable (Just "sub-company") (i18nCell MsgTableCompanies) $ \(view $ resultSubordinate . _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" + , 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 -- validator = def & defaultSorting [ SortAscBy "cshort" ] + validator = def & defaultSorting [SortAscBy "rel-comp", SortAscBy "supervisor", SortAscBy "client"] + & defaultFilter (singletonMap "violation" [toPathPiece SupervisionViolationEither]) dbtSorting = Map.fromList [ ("reason" , SortColumn $ queryRelation >>> (E.^. UserSupervisorReason)) - , ("cshort" , SortColumn $ queryRelation >>> (E.^. UserSupervisorCompany)) + , ("rel-comp" , SortColumn $ queryRelation >>> (E.^. UserSupervisorCompany)) , ("reroute" , SortColumn $ queryRelation >>> (E.^. UserSupervisorRerouteNotifications)) - , ("super" , SortColumn $ querySupervisor >>> (E.^. UserDisplayName)) - , ("subordinate" , SortColumn $ querySubordinate >>> (E.^. UserDisplayName)) + , ("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) )) - , ("user-company" , SortColumn (\row -> E.subSelect $ do + , ("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.==. querySubordinate row E.^. UserId + E.where_ $ usrCmp E.^. UserCompanyUser E.==. queryClient row E.^. UserId E.orderBy [E.asc $ cmp E.^. CompanyName] return (cmp E.^. CompanyName) )) ] - dbtFilter = mempty - dbtFilterUI = mempty + + 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 @@ -1657,7 +1680,7 @@ mkSupervisonTable = over _1 postprocess <$> dbTable validator DBTable{..} getFirmsSupervisionR, postFirmsSupervisionR :: Handler Html getFirmsSupervisionR = postFirmsSupervisionR postFirmsSupervisionR = do - (svRes, svTbl) <- runDB mkSupervisonTable + (svRes, svTbl) <- runDB mkSupervisionTable formResult svRes $ \case (ASChangeCompanyData, relations) -> do addMessage Info $ text2Html [st|Firmenwechsel Ansprechpartnerbeziehung noch nicht implementiert. #{Set.size relations} empfangen.|] diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 53cb00c0f..34b420fbc 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -61,7 +61,7 @@ instance HasEntity (DBRow (Entity User)) User where instance HasUser (DBRow (Entity User)) where hasUser = _dbrOutput . _entityVal -data UserAction = UserAvsSync | UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor | UserRemoveSubordinates +data UserAction = UserAvsSync | UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor | UserRemoveClients deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -74,7 +74,7 @@ data UserActionData = UserAvsSyncData | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } | UserRemoveSupervisorData - | UserRemoveSubordinatesData + | UserRemoveClientsData deriving (Eq, Ord, Read, Show, Generic) @@ -207,7 +207,7 @@ postUsersR = do <*> apopt boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) <*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData - , singletonMap UserRemoveSubordinates $ pure UserRemoveSubordinatesData + , singletonMap UserRemoveClients $ pure UserRemoveClientsData ] over _1 postprocess <$> dbTable psValidator DBTable @@ -400,9 +400,9 @@ postUsersR = do runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet redirectKeepGetParams UsersR - (UserRemoveSubordinatesData, userSet) -> do + (UserRemoveClientsData, userSet) -> do runDB $ deleteWhere [UserSupervisorSupervisor <-. Set.toList userSet] - addMessageI Success $ MsgUsersRemoveSubordinates $ Set.size userSet + addMessageI Success $ MsgUsersRemoveClients $ Set.size userSet redirectKeepGetParams UsersR (act, usersSet) | isActionSupervisor act -> do diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 20d9937bb..2468d842c 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -449,7 +449,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv -- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute -- delete ucidOld -- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds - -- -- adjust supervison + -- -- adjust supervision -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 0b4bc60a3..0c6220f94 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -275,10 +275,10 @@ colFileModificationWhen condition row2time = sortable (Just "time") (i18nCell Ms where conDTCell = ifCell condition dateTimeCell $ const mempty -sortFilePath :: (IsFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r') +sortFilePath :: (IsFileReference record) => (t -> E.SqlExpr (Entity record)) -> (SortingKey, SortColumn t r') sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. fileReferenceTitleField)) -sortFileModification :: (IsFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r') +sortFileModification :: (IsFileReference record) => (t -> E.SqlExpr (Entity record)) -> (SortingKey, SortColumn t r') sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. fileReferenceModifiedField)) defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x @@ -345,7 +345,7 @@ colUserNameModalHdrAdmin :: (IsDBTable m c, HasEntity a User, RenderMessage UniW colUserNameModalHdrAdmin colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModalAdmin userLink) -- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname -sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r') +sortUserName :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserName = ("user-name",) . sortUserNameBare sortUserNameBare :: (t -> E.SqlExpr (Entity User)) -> SortColumn t r' @@ -360,13 +360,13 @@ sortUserNameBareM queryUser = SortColumns $ queryUser >>> \user -> ] -- | Alias for sortUserName for consistency, since column comes in two variants -sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r') +sortUserNameLink :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserNameLink = sortUserName -sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r') +sortUserSurname :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserSurname queryUser = ("user-surname", SortColumn $ queryUser >>> (E.^. UserSurname)) -sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r') +sortUserDisplayName :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>> (E.^. UserDisplayName)) defaultSortingByName :: PSValidator m x -> PSValidator m x @@ -375,37 +375,37 @@ defaultSortingByName = defaultSorting [SortAscBy "user-name"] -- new way, working with single sorter -- | Alias for sortUserName for consistency -fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t fs) +fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) -> (FilterKey, FilterColumn t fs) fltrUserNameLink = fltrUserName -fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) +fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t fs) + -> (FilterKey, FilterColumn t fs) fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName ) where queryName = queryUser >>> (E.^. UserDisplayName) -fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) +fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t fs) + -> (FilterKey, FilterColumn t fs) fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName ) where queryName = queryUser >>> (E.^. UserDisplayName) -fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) +fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t fs) + -> (FilterKey, FilterColumn t fs) fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname)) -fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) +fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t fs) + -> (FilterKey, FilterColumn t fs) fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)) -- | Search all names, i.e. DisplayName, Surname, EMail -fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) +fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t fs) + -> (FilterKey, FilterColumn t fs) fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter [ mkContainsFilterWithCommaPlus id $ queryUser >>> (E.^. UserDisplayName) , mkContainsFilterWithCommaPlus id $ queryUser >>> (E.^. UserSurname) @@ -457,14 +457,12 @@ fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation" colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Bool -> Colonnade Sortable a (DBCell m c) colUserMatriclenr isAdmin = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) $ cellHasMatrikelnummerLinked isAdmin -sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') +sortUserMatriclenr :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer)) -fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) - , IsString d - ) +fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t fs) + -> (FilterKey, FilterColumn t fs) fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWithComma Just $ queryUser >>> (E.^. UserMatrikelnummer)) fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) @@ -479,14 +477,12 @@ fltrUserMatriclenrUI mPrev = colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) colUserEmail = sortable (Just "user-email") (i18nCell MsgTableEmail) cellHasEMail -sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') +sortUserEmail :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserDisplayEmail)) -fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool)) - , IsString d - ) +fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t fs) + -> (FilterKey, FilterColumn t fs) fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserDisplayEmail)) fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) @@ -498,7 +494,7 @@ fltrUserEmailUI mPrev = colUserLetterEmailPin :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) colUserLetterEmailPin = sortable (Just "user-mail-pref-pin") (i18nCell MsgPrefersPostal) cellMailPrefPin -sortUserLetterEmailPin :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') +sortUserLetterEmailPin :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserLetterEmailPin queryUser = ( "user-mail-pref-pin" , SortColumn (toSortVal . queryUser)) where toSortVal :: E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Int64) @@ -618,14 +614,12 @@ fltrStudyFeaturesSemesterUI mPrev = prismAForm (singletonFilter "features-semest colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c) colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgTableStudyFeatureAge) $ maybe mempty cellHasSemester . firstOf feature -sortFeaturesSemester :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (d, SortColumn t r') +sortFeaturesSemester :: (t -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (SortingKey, SortColumn t r') sortFeaturesSemester queryFeatures = ("features-semester", SortColumn $ queryFeatures >>> (E.?. StudyFeaturesSemester)) -fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value Bool)) - , IsString d - ) +fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Maybe (Entity StudyFeatures))) - -> (d, FilterColumn t fs) + -> (FilterKey, FilterColumn t fs) fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester)) fltrFeaturesSemesterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) @@ -636,14 +630,12 @@ fltrFeaturesSemesterUI mPrev = colField :: (IsDBTable m c, HasStudyTerms x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c) colField terms = sortable (Just "terms") (i18nCell MsgTableStudyTerm) $ maybe mempty cellHasField . firstOf terms -sortField :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (d, SortColumn t r') +sortField :: (t -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (SortingKey, SortColumn t r') sortField queryTerms = ("terms", SortColumn $ queryTerms >>> (E.?. StudyTermsName)) -fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) - , IsString d - ) +fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Maybe (Entity StudyTerms))) - -> (d, FilterColumn t fs) + -> (FilterKey, FilterColumn t fs) fltrField queryFeatures = ( "terms" , FilterColumn $ anyFilter [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsName) @@ -660,14 +652,12 @@ fltrFieldUI mPrev = colDegreeShort :: (IsDBTable m c, HasStudyDegree x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c) colDegreeShort terms = sortable (Just "degree-short") (i18nCell MsgTableDegreeShort) $ maybe mempty cellHasDegreeShort . firstOf terms -sortDegreeShort :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -> (d, SortColumn t r') +sortDegreeShort :: (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -> (SortingKey, SortColumn t r') sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand)) -fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) - , IsString d - ) +fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Maybe (Entity StudyDegree))) - -> (d, FilterColumn t fs) + -> (FilterKey, FilterColumn t fs) fltrDegree queryFeatures = ( "degree" , FilterColumn $ anyFilter [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName) @@ -785,7 +775,7 @@ colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \ icnSuper = text2markup " " <> icon IconSupervisor pure $ toWgt $ mconcat companies -sortUserCompany :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') +sortUserCompany :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserCompany queryUser = ( "user-company" , SortColumn $ queryUser >>> (\user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId @@ -795,9 +785,9 @@ sortUserCompany queryUser = ( "user-company" )) -- | Search companies by name or shorthand -fltrCompanyName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) +fltrCompanyName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity Company)) - -> (d, FilterColumn t fs) + -> (FilterKey, FilterColumn t fs) fltrCompanyName query = ( "company-name", FilterColumn $ anyFilter [ mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyName) , mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyShorthand) @@ -814,9 +804,9 @@ fltrCompanyNameHdrUI msg mPrev = -fltrCompanyNameNr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) +fltrCompanyNameNr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity Company)) - -> (d, FilterColumn t fs) + -> (FilterKey, FilterColumn t fs) fltrCompanyNameNr query = ("company-name-number", FilterColumn $ \needle (setFoldMap commaSeparatedText -> criterias) -> let numCrits = setMapMaybe readMay criterias fltrCName = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyName)) needle criterias @@ -838,13 +828,30 @@ fltrCompanyNameNrHdrUI msg mPrev = prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr) +fltrCompanyNameNrUsrHdrUI :: (RenderMessage UniWorX msg) => FilterKey -> msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrCompanyNameNrUsrHdrUI fk msg mPrev = + prismAForm (singletonFilter fk) mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr) + +fltrCompanyNameNrUsr :: (IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool))) + => (a -> E.SqlExpr (E.Value (Key User))) -> FilterColumn t fs + +fltrCompanyNameNrUsr 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.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) + testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId + testcrit = maybe testname testnumber $ readMay $ CI.original criterion + E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + E.where_ $ usrComp E.^. UserCompanyUser E.==. user E.&&. testcrit + + --------- -- AVS -- --------- -fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k) - => (a -> E.SqlExpr (Entity User)) -> (k, FilterColumn t fs) +fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool)))) + => (a -> E.SqlExpr (Entity User)) -> (FilterKey, FilterColumn t fs) fltrAVSCardNos queryUser = ("avs-card", fch) where fch = FilterColumnHandler $ \case diff --git a/src/Utils/Company.hs b/src/Utils/Company.hs index 4eb7eea05..57295701e 100644 --- a/src/Utils/Company.hs +++ b/src/Utils/Company.hs @@ -31,16 +31,16 @@ usrDoesNotBelong uid fsh = E.isJust fsh E.&&. E.notExists (do missingCompanySupervisor :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool) missingCompanySupervisor us = (us E.^. UserSupervisorSupervisor) `usrDoesNotBelong` (us E.^. UserSupervisorCompany) --- | given a supervisionship, true if subordinate is NOT associated with the supervisionship-company -missingCompanySubordinate :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool) -missingCompanySubordinate us = (us E.^. UserSupervisorUser) `usrDoesNotBelong` (us E.^. UserSupervisorCompany) +-- | given a supervisionship, true if client is NOT associated with the supervisionship-company +missingCompanyClient :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool) +missingCompanyClient us = (us E.^. UserSupervisorUser) `usrDoesNotBelong` (us E.^. UserSupervisorCompany) --- | once per day, check if there are supervisionships where supervisor or subordinate are not associated witht the supervisionship-company +-- | once per day, check if there are supervisionships where supervisor or client are not associated witht the supervisionship-company areThereInsaneCompanySupervisions :: HandlerFor UniWorX Bool areThereInsaneCompanySupervisions = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-company-supervision|] $ do res <- runDBRead $ E.selectExists $ do us <- E.from $ E.table @UserSupervisor E.where_ $ E.isJust (us E.^. UserSupervisorCompany) - E.&&. (missingCompanySupervisor us E.||. missingCompanySubordinate us) + E.&&. (missingCompanySupervisor us E.||. missingCompanyClient us) $logInfoS "sanity" [st|Are there insane company supervisions: #{tshow res}|] return res diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 22083cbc1..b1066eb93 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -688,16 +688,16 @@ fillDb = do -- void . insert' $ UserSupervisor svaupel gkleen False -- void . insert' $ UserSupervisor svaupel fhamann True -- void . insert' $ UserSupervisor sbarth tinaTester True - let supvs = [ UserSupervisor jost gkleen True (Just fraportAg) (Just $ tshow SupervisorReasonAvsSuperior) + let supvs = [ UserSupervisor jost gkleen True (Just fraGround) (Just $ tshow SupervisorReasonAvsSuperior) , UserSupervisor jost svaupel False (Just fraportAg) (Just $ tshow SupervisorReasonAvsSuperior) , UserSupervisor jost sbarth False (Just fraportAg) (Just "Staff") , UserSupervisor jost tinaTester True (Just fraportAg) (Just "Staff") , UserSupervisor jost jost True (Just fraportAg) (Just "Staff") + , UserSupervisor jost jost True (Just fraportAg) (Just "Staff") , UserSupervisor svaupel gkleen False (Just nice) (Just "Staff") , UserSupervisor svaupel fhamann True (Just nice) (Just "Staff") , UserSupervisor sbarth tinaTester True (Just fraportAg) (Just $ tshow SupervisorReasonAvsSuperior) , UserSupervisor gkleen fhamann False (Just fraGround) (Just "Staff") - , UserSupervisor gkleen gkleen True (Just fraGround) (Just "Staff") , UserSupervisor tinaTester tinaTester False Nothing (Just "Staff") ] ++ take 444 [ UserSupervisor fhamann uid True Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- matUsers, uid /= jost]