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

chore(firm): filter working on supervision discrepancy view

Browse Source
This commit is contained in:
Steffen Jost 2025-02-12 17:02:04 +01:00 committed by Sarah Vaupel
parent 8e0eb401b5
commit aefafa32d1
12 changed files with 164 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -82,5 +82,10 @@ CompanyUserUseCompanyAddress: Verwendet Firmenkontaktaddresse
CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterlegt ist CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterlegt ist
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: 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 ASChangeCompany: Firma ändern, welche Ansprechpartnerbeziehung begründet

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

@ -15,7 +15,7 @@ FirmActionInfo: Affects alle company associates under your supervision.
FirmActNotify: Send message FirmActNotify: Send message
FirmActResetSupervision: Reset supervisors for all company associates FirmActResetSupervision: Reset supervisors for all company associates
FirmActResetSuperKeep: Additionally keep existing supervisors of 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 FirmActResetMutualSupervision: Supervisors supervise each other
FirmActResetSupersKeepAll: Keep all FirmActResetSupersKeepAll: Keep all
FirmActResetSupersRemoveAps: Remove default supervisors only 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 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! 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 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 ASChangeCompany: Change company for supervisionship

4
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
UserRemoveSubordinates: Alle Ansprechpartnerbeziehungen zu Untergebenen beenden UserRemoveClients: Alle Ansprechpartnerbeziehungen zu Untergebenen 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
@ -112,7 +112,7 @@ Name !ident-ok: Name
UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt. 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! 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. 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 UserCompanyReason: Begründung der Firmenassoziation
UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern. UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
UserSupervisorReason: Begründung Ansprechpartner UserSupervisorReason: Begründung Ansprechpartner

4
messages/uniworx/categories/user/en-eu.msg
View File

@ -96,7 +96,7 @@ UserHijack: Hijack session
UserAddSupervisor: Add supervisor UserAddSupervisor: Add supervisor
UserSetSupervisor: Replace supervisors UserSetSupervisor: Replace supervisors
UserRemoveSupervisor: Set to unsupervised UserRemoveSupervisor: Set to unsupervised
UserRemoveSubordinates: Remove all subordinates UserRemoveClients: Remove all clients
UserIsSupervisor: Is supervisor UserIsSupervisor: Is supervisor
UserAvsSwitchCompany: Use as primary company UserAvsSwitchCompany: Use as primary company
UserAvsSwitchCompanyField: Select primary company UserAvsSwitchCompanyField: Select primary company
@ -112,7 +112,7 @@ Name: Name
UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{pluralENsN usr "user"} set. 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! UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified!
UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}. 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 UserCompanyReason: Reason for company association
UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes. UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
UserSupervisorReason: Reason for supervision UserSupervisorReason: Reason for supervision

4
messages/uniworx/utils/table_column/de-de-formal.msg
View File

@ -103,7 +103,7 @@ TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
TableCompanyPinPassword: Pin Passwort für PDF Anhänge TableCompanyPinPassword: Pin Passwort für PDF Anhänge
TableSupervisor: Ansprechpartner TableSupervisor: Ansprechpartner
TableSupervisorActive: Aktiver Ansprechpartner TableSupervisorActive: Aktiver Ansprechpartner
TableSupervisee: Ansprechpartner für TableSupervisee: Klient
TableReason: Begründung TableReason: Begründung
TableCreationTime: Erstellungszeit TableCreationTime: Erstellungszeit
TableJob !ident-ok: Job 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. 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. TableFilterCommaPlusShort: Unterstützt mehrere Kriterien mit Komma-Plus, siehe oben.
TableFilterCommaName: Mehrere Namen mit Komma trennen. 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 TableUserEdit: Benutzer bearbeiten
TableRows: Zeilen TableRows: Zeilen
TableUserParkingToken day@Text: Parkmarke #{day} TableUserParkingToken day@Text: Parkmarke #{day}

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

@ -103,7 +103,7 @@ TableCompanyPostalPreference: Default notification preference
TableCompanyPinPassword: Pin password for PDF attachments TableCompanyPinPassword: Pin password for PDF attachments
TableSupervisor: Supervisor TableSupervisor: Supervisor
TableSupervisorActive: Active supervisor TableSupervisorActive: Active supervisor
TableSupervisee: Supervisor for TableSupervisee: Supervisee
TableReason: Reason TableReason: Reason
TableCreationTime: Creation TableCreationTime: Creation
TableJob !ident-ok: Job TableJob !ident-ok: Job

125
src/Handler/Firm.hs
View File

@ -19,6 +19,7 @@ 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
@ -1532,7 +1533,7 @@ handleFirmCommR ultDest cs = do
----------------------- -----------------------
-- Supervision Sanity -- Supervision Sanity
data ActSupervision = ASChangeCompany data ActSupervision = ASChangeCompany -- | ASRemoveCompany |
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite)
@ -1542,54 +1543,43 @@ embedRenderMessage ''UniWorX ''ActSupervision id
data ActSupervisionData = ASChangeCompanyData data ActSupervisionData = ASChangeCompanyData
deriving (Eq, Ord, Read, Show, Generic) 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) type TblSupervisionData = DBRow (Entity UserSupervisor, Entity User, Entity User)
mkSupervisonTable :: DB (FormResult (ActSupervisionData, Set UserSupervisorId), Widget) mkSupervisionTable :: DB (FormResult (ActSupervisionData, Set UserSupervisorId), Widget)
mkSupervisonTable = over _1 postprocess <$> dbTable validator DBTable{..} mkSupervisionTable = over _1 postprocess <$> dbTable validator DBTable{..}
where where
dbtIdent = "sanity-super" :: Text 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.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserSupervisor)
queryRelation = $(E.sqlIJproj 3 1) 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.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
querySupervisor = $(E.sqlIJproj 3 2) 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) queryClient :: (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) queryClient = $(E.sqlIJproj 3 3)
resultRelation :: Lens' TblSupervisionData (Entity UserSupervisor) resultRelation :: Lens' TblSupervisionData (Entity UserSupervisor)
resultRelation = _dbrOutput . _1 resultRelation = _dbrOutput . _1
resultSupervisor :: Lens' TblSupervisionData (Entity User) resultSupervisor :: Lens' TblSupervisionData (Entity User)
resultSupervisor = _dbrOutput . _2 resultSupervisor = _dbrOutput . _2
resultSubordinate :: Lens' TblSupervisionData (Entity User) resultClient :: Lens' TblSupervisionData (Entity User)
resultSubordinate = _dbrOutput . _3 resultClient = _dbrOutput . _3
dbtSQLQuery (uus `E.InnerJoin` spr `E.InnerJoin` sub) = do dbtSQLQuery (uus `E.InnerJoin` spr `E.InnerJoin` sub) = do
EL.on $ uus E.^. UserSupervisorSupervisor E.==. spr E.^. UserId EL.on $ uus E.^. UserSupervisorSupervisor E.==. spr E.^. UserId
EL.on $ uus E.^. UserSupervisorUser E.==. sub 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.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) return (uus, spr, sub)
dbtRowKey = queryRelation >>> (E.^. UserSupervisorId) dbtRowKey = queryRelation >>> (E.^. UserSupervisorId)
dbtProj = dbtProjId dbtProj = dbtProjId
@ -1597,36 +1587,69 @@ mkSupervisonTable = over _1 postprocess <$> dbTable validator DBTable{..}
[ dbSelect (applying _2) id (return . view (resultRelation . _entityKey)) [ dbSelect (applying _2) id (return . view (resultRelation . _entityKey))
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \(view $ resultRelation . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute , 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 "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 "rel-comp") (i18nCell MsgUserSupervisorCompany) $ \(view $ resultRelation . _entityVal . _userSupervisorCompany -> c) -> maybeCell c companyIdCell\
, sortable (Just "super") (i18nCell MsgTableSupervisor) $ \(view $ resultSupervisor -> u) -> cellHasUserModal ForProfileDataR u , sortable (Just "supervisor") (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 "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 maybeMonoid <$> wgtCompanies True uid
, sortable (Just "subordinate") (i18nCell MsgTableSupervisee) $ \(view $ resultSubordinate -> u) -> cellHasUserModal ForProfileDataR u , sortable (Just "client") (i18nCell MsgTableSupervisee) $ \(view $ resultClient -> 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-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 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 dbtSorting = Map.fromList
[ ("reason" , SortColumn $ queryRelation >>> (E.^. UserSupervisorReason)) [ ("reason" , SortColumn $ queryRelation >>> (E.^. UserSupervisorReason))
, ("cshort" , SortColumn $ queryRelation >>> (E.^. UserSupervisorCompany)) , ("rel-comp" , SortColumn $ queryRelation >>> (E.^. UserSupervisorCompany))
, ("reroute" , SortColumn $ queryRelation >>> (E.^. UserSupervisorRerouteNotifications)) , ("reroute" , SortColumn $ queryRelation >>> (E.^. UserSupervisorRerouteNotifications))
, ("super" , SortColumn $ querySupervisor >>> (E.^. UserDisplayName)) , ("supervisor" , SortColumn $ querySupervisor >>> (E.^. UserDisplayName))
, ("subordinate" , SortColumn $ querySubordinate >>> (E.^. UserDisplayName)) , ("client" , SortColumn $ queryClient >>> (E.^. UserDisplayName))
, ("super-comp" , SortColumn (\row -> E.subSelect $ do , ("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) (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.where_ $ usrCmp E.^. UserCompanyUser E.==. querySupervisor row E.^. UserId
E.orderBy [E.asc $ cmp E.^. CompanyName] E.orderBy [E.asc $ cmp E.^. CompanyName]
return (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) (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] E.orderBy [E.asc $ cmp E.^. CompanyName]
return (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 dbtParams = DBParamsForm
{ dbParamsFormMethod = POST { dbParamsFormMethod = POST
, dbParamsFormAction = Nothing , dbParamsFormAction = Nothing
@ -1657,7 +1680,7 @@ mkSupervisonTable = over _1 postprocess <$> dbTable validator DBTable{..}
getFirmsSupervisionR, postFirmsSupervisionR :: Handler Html getFirmsSupervisionR, postFirmsSupervisionR :: Handler Html
getFirmsSupervisionR = postFirmsSupervisionR getFirmsSupervisionR = postFirmsSupervisionR
postFirmsSupervisionR = do postFirmsSupervisionR = do
(svRes, svTbl) <- runDB mkSupervisonTable (svRes, svTbl) <- runDB mkSupervisionTable
formResult svRes $ \case formResult svRes $ \case
(ASChangeCompanyData, relations) -> do (ASChangeCompanyData, relations) -> do
addMessage Info $ text2Html [st|Firmenwechsel Ansprechpartnerbeziehung noch nicht implementiert. #{Set.size relations} empfangen.|] addMessage Info $ text2Html [st|Firmenwechsel Ansprechpartnerbeziehung noch nicht implementiert. #{Set.size relations} empfangen.|]

10
src/Handler/Users.hs
View File

@ -61,7 +61,7 @@ instance HasEntity (DBRow (Entity User)) User where
instance HasUser (DBRow (Entity User)) where instance HasUser (DBRow (Entity User)) where
hasUser = _dbrOutput . _entityVal 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 (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite)
@ -74,7 +74,7 @@ data UserActionData = UserAvsSyncData
| UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
| UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
| UserRemoveSupervisorData | UserRemoveSupervisorData
| UserRemoveSubordinatesData | UserRemoveClientsData
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
@ -207,7 +207,7 @@ postUsersR = do
<*> apopt boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) <*> apopt boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing <*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
, singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
, singletonMap UserRemoveSubordinates $ pure UserRemoveSubordinatesData , singletonMap UserRemoveClients $ pure UserRemoveClientsData
] ]
over _1 postprocess <$> dbTable psValidator DBTable over _1 postprocess <$> dbTable psValidator DBTable
@ -400,9 +400,9 @@ postUsersR = do
runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet
redirectKeepGetParams UsersR redirectKeepGetParams UsersR
(UserRemoveSubordinatesData, userSet) -> do (UserRemoveClientsData, userSet) -> do
runDB $ deleteWhere [UserSupervisorSupervisor <-. Set.toList userSet] runDB $ deleteWhere [UserSupervisorSupervisor <-. Set.toList userSet]
addMessageI Success $ MsgUsersRemoveSubordinates $ Set.size userSet addMessageI Success $ MsgUsersRemoveClients $ Set.size userSet
redirectKeepGetParams UsersR redirectKeepGetParams UsersR
(act, usersSet) (act, usersSet)
| isActionSupervisor act -> do | isActionSupervisor act -> do

2
src/Handler/Utils/Avs.hs
View File

@ -449,7 +449,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
-- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute -- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
-- delete ucidOld -- delete ucidOld
-- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds -- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
-- -- adjust supervison -- -- adjust supervision
-- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
-- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
-- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr

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

@ -275,10 +275,10 @@ colFileModificationWhen condition row2time = sortable (Just "time") (i18nCell Ms
where conDTCell = ifCell condition dateTimeCell $ const mempty 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)) 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)) sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. fileReferenceModifiedField))
defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x 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) colUserNameModalHdrAdmin colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModalAdmin userLink)
-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname -- | 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 sortUserName = ("user-name",) . sortUserNameBare
sortUserNameBare :: (t -> E.SqlExpr (Entity User)) -> SortColumn t r' 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 -- | 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 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)) 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)) sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>> (E.^. UserDisplayName))
defaultSortingByName :: PSValidator m x -> PSValidator m x defaultSortingByName :: PSValidator m x -> PSValidator m x
@ -375,37 +375,37 @@ defaultSortingByName =
defaultSorting [SortAscBy "user-name"] -- new way, working with single sorter defaultSorting [SortAscBy "user-name"] -- new way, working with single sorter
-- | Alias for sortUserName for consistency -- | 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 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)) => (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t fs) -> (FilterKey, FilterColumn t fs)
fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName ) fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName )
where where
queryName = queryUser >>> (E.^. UserDisplayName) 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)) => (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t fs) -> (FilterKey, FilterColumn t fs)
fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName ) fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName )
where where
queryName = queryUser >>> (E.^. UserDisplayName) 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)) => (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t fs) -> (FilterKey, FilterColumn t fs)
fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname)) 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)) => (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t fs) -> (FilterKey, FilterColumn t fs)
fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)) fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName))
-- | Search all names, i.e. DisplayName, Surname, EMail -- | 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)) => (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t fs) -> (FilterKey, FilterColumn t fs)
fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter
[ mkContainsFilterWithCommaPlus id $ queryUser >>> (E.^. UserDisplayName) [ mkContainsFilterWithCommaPlus id $ queryUser >>> (E.^. UserDisplayName)
, mkContainsFilterWithCommaPlus id $ queryUser >>> (E.^. UserSurname) , 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 :: (IsDBTable m c, HasEntity a User) => Bool -> Colonnade Sortable a (DBCell m c)
colUserMatriclenr isAdmin = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) $ cellHasMatrikelnummerLinked isAdmin 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)) sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))
fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)))
, IsString d
)
=> (a -> E.SqlExpr (Entity User)) => (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t fs) -> (FilterKey, FilterColumn t fs)
fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWithComma Just $ queryUser >>> (E.^. UserMatrikelnummer)) fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWithComma Just $ queryUser >>> (E.^. UserMatrikelnummer))
fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) 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 :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
colUserEmail = sortable (Just "user-email") (i18nCell MsgTableEmail) cellHasEMail 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)) sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserDisplayEmail))
fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool)) fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool)))
, IsString d
)
=> (a -> E.SqlExpr (Entity User)) => (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t fs) -> (FilterKey, FilterColumn t fs)
fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserDisplayEmail)) fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserDisplayEmail))
fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) 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 :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c)
colUserLetterEmailPin = sortable (Just "user-mail-pref-pin") (i18nCell MsgPrefersPostal) cellMailPrefPin 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)) sortUserLetterEmailPin queryUser = ( "user-mail-pref-pin" , SortColumn (toSortVal . queryUser))
where where
toSortVal :: E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Int64) 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 :: (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 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)) sortFeaturesSemester queryFeatures = ("features-semester", SortColumn $ queryFeatures >>> (E.?. StudyFeaturesSemester))
fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value Bool)) fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value Bool)))
, IsString d
)
=> (a -> E.SqlExpr (Maybe (Entity StudyFeatures))) => (a -> E.SqlExpr (Maybe (Entity StudyFeatures)))
-> (d, FilterColumn t fs) -> (FilterKey, FilterColumn t fs)
fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester)) fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester))
fltrFeaturesSemesterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) 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 :: (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 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)) sortField queryTerms = ("terms", SortColumn $ queryTerms >>> (E.?. StudyTermsName))
fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)))
, IsString d
)
=> (a -> E.SqlExpr (Maybe (Entity StudyTerms))) => (a -> E.SqlExpr (Maybe (Entity StudyTerms)))
-> (d, FilterColumn t fs) -> (FilterKey, FilterColumn t fs)
fltrField queryFeatures = ( "terms" fltrField queryFeatures = ( "terms"
, FilterColumn $ anyFilter , FilterColumn $ anyFilter
[ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsName) [ 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 :: (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 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)) sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand))
fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)))
, IsString d
)
=> (a -> E.SqlExpr (Maybe (Entity StudyDegree))) => (a -> E.SqlExpr (Maybe (Entity StudyDegree)))
-> (d, FilterColumn t fs) -> (FilterKey, FilterColumn t fs)
fltrDegree queryFeatures = ( "degree" fltrDegree queryFeatures = ( "degree"
, FilterColumn $ anyFilter , FilterColumn $ anyFilter
[ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName) [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName)
@ -785,7 +775,7 @@ colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \
icnSuper = text2markup " " <> icon IconSupervisor icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies 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" sortUserCompany queryUser = ( "user-company"
, SortColumn $ queryUser >>> (\user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do , SortColumn $ queryUser >>> (\user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
@ -795,9 +785,9 @@ sortUserCompany queryUser = ( "user-company"
)) ))
-- | Search companies by name or shorthand -- | 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)) => (a -> E.SqlExpr (Entity Company))
-> (d, FilterColumn t fs) -> (FilterKey, FilterColumn t fs)
fltrCompanyName query = ( "company-name", FilterColumn $ anyFilter fltrCompanyName query = ( "company-name", FilterColumn $ anyFilter
[ mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyName) [ mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyName)
, mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyShorthand) , 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)) => (a -> E.SqlExpr (Entity Company))
-> (d, FilterColumn t fs) -> (FilterKey, FilterColumn t fs)
fltrCompanyNameNr query = ("company-name-number", FilterColumn $ \needle (setFoldMap commaSeparatedText -> criterias) -> fltrCompanyNameNr query = ("company-name-number", FilterColumn $ \needle (setFoldMap commaSeparatedText -> criterias) ->
let numCrits = setMapMaybe readMay criterias let numCrits = setMapMaybe readMay criterias
fltrCName = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyName)) needle 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) 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 -- -- AVS --
--------- ---------
fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k) fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))))
=> (a -> E.SqlExpr (Entity User)) -> (k, FilterColumn t fs) => (a -> E.SqlExpr (Entity User)) -> (FilterKey, FilterColumn t fs)
fltrAVSCardNos queryUser = ("avs-card", fch) fltrAVSCardNos queryUser = ("avs-card", fch)
where where
fch = FilterColumnHandler $ \case fch = FilterColumnHandler $ \case

10
src/Utils/Company.hs
View File

@ -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 :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)
missingCompanySupervisor us = (us E.^. UserSupervisorSupervisor) `usrDoesNotBelong` (us E.^. UserSupervisorCompany) missingCompanySupervisor us = (us E.^. UserSupervisorSupervisor) `usrDoesNotBelong` (us E.^. UserSupervisorCompany)
-- | given a supervisionship, true if subordinate is NOT associated with the supervisionship-company -- | given a supervisionship, true if client is NOT associated with the supervisionship-company
missingCompanySubordinate :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool) missingCompanyClient :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)
missingCompanySubordinate us = (us E.^. UserSupervisorUser) `usrDoesNotBelong` (us E.^. UserSupervisorCompany) 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 :: HandlerFor UniWorX Bool
areThereInsaneCompanySupervisions = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-company-supervision|] $ do areThereInsaneCompanySupervisions = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-company-supervision|] $ do
res <- runDBRead $ E.selectExists $ do res <- runDBRead $ E.selectExists $ do
us <- E.from $ E.table @UserSupervisor us <- E.from $ E.table @UserSupervisor
E.where_ $ E.isJust (us E.^. UserSupervisorCompany) 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}|] $logInfoS "sanity" [st|Are there insane company supervisions: #{tshow res}|]
return res return res

4
test/Database/Fill.hs
View File

@ -688,16 +688,16 @@ fillDb = do
-- void . insert' $ UserSupervisor svaupel gkleen False -- void . insert' $ UserSupervisor svaupel gkleen False
-- void . insert' $ UserSupervisor svaupel fhamann True -- void . insert' $ UserSupervisor svaupel fhamann True
-- void . insert' $ UserSupervisor sbarth tinaTester 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 svaupel False (Just fraportAg) (Just $ tshow SupervisorReasonAvsSuperior)
, UserSupervisor jost sbarth False (Just fraportAg) (Just "Staff") , UserSupervisor jost sbarth False (Just fraportAg) (Just "Staff")
, UserSupervisor jost tinaTester True (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 jost jost True (Just fraportAg) (Just "Staff")
, UserSupervisor svaupel gkleen False (Just nice) (Just "Staff") , UserSupervisor svaupel gkleen False (Just nice) (Just "Staff")
, UserSupervisor svaupel fhamann True (Just nice) (Just "Staff") , UserSupervisor svaupel fhamann True (Just nice) (Just "Staff")
, UserSupervisor sbarth tinaTester True (Just fraportAg) (Just $ tshow SupervisorReasonAvsSuperior) , UserSupervisor sbarth tinaTester True (Just fraportAg) (Just $ tshow SupervisorReasonAvsSuperior)
, UserSupervisor gkleen fhamann False (Just fraGround) (Just "Staff") , UserSupervisor gkleen fhamann False (Just fraGround) (Just "Staff")
, UserSupervisor gkleen gkleen True (Just fraGround) (Just "Staff")
, UserSupervisor tinaTester tinaTester False Nothing (Just "Staff") , UserSupervisor tinaTester tinaTester False Nothing (Just "Staff")
] ]
++ take 444 [ UserSupervisor fhamann uid True Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- matUsers, uid /= jost] ++ take 444 [ UserSupervisor fhamann uid True Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- matUsers, uid /= jost]