From 64ff002ffbe45da84b4e9f11f575a7c055cbf254 Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 29 Aug 2024 14:34:37 +0200 Subject: [PATCH] chore(firm): provide more filters for supervisors also fix build #175 --- .../uniworx/categories/firm/de-de-formal.msg | 1 + messages/uniworx/categories/firm/en-eu.msg | 1 + src/Handler/Firm.hs | 42 ++++++++++++------- test/Database/Fill.hs | 12 +++--- 4 files changed, 36 insertions(+), 20 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 8ea0ee728..70d351f25 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -51,6 +51,7 @@ FilterSupervisor: Hat aktiven Ansprechpartner FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört FilterForeignSupervisor: Hat firmenfremde Ansprechpartner +FilterIsForeignSupervisee: Ist Ansprechpartner für Firmenfremde FilterFirmExtern: Externe Firma FilterFirmExternTooltip: Hat die Firma eine Postanschrift im AVS? FilterFirmPrimary: Ist primäre Firma in FRADrive diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 4f7ce71fc..b1fb27b3f 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -51,6 +51,7 @@ FilterSupervisor: Has active supervisor FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} FilterForeignSupervisor: Has company-external supervisors +FilterIsForeignSupervisee: Supervisor for company external users FilterFirmExtern: External company FilterFirmExternTooltip: i.e. is a postal address registered within AVS? FilterFirmPrimary: Is primary company in FRADrive diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index f360b0072..b0086c847 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1204,21 +1204,22 @@ mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Se mkFirmSuperTable isAdmin cid = do msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo let - reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior + reasonSuperior = tshow SupervisorReasonAvsSuperior -- fsh = unCompanyKey cid resultDBTable = DBTable{..} where dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid - E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) - E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) + E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) + -- let uc_reason = E.joinV (usrCmp E.?. UserCompanyReason) return ( usr , usr & firmCountForSupervisor cid Nothing , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) , usrCmp E.?. UserCompanySupervisor , usrCmp E.?. UserCompanySupervisorReroute - , (usrCmp E.?. UserCompanyReason E.?=. E.val reasonSuperior) E.||. - E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.val reasonSuperior)) usr) + -- , (E.isJust uc_reason E.&&. uc_reason E.==. E.justVal reasonSuperior) -- NOTE: this is problematic, as obvious approaches caused errors such as: Failed to parse Haskell type bool, received PersistNull, since the SQL comparison with NULL returns NULL + , (E.coalesceDefault [E.joinV (usrCmp E.?. UserCompanyReason)] (E.val mempty) E.==. E.val reasonSuperior) -- works as well + E.||. E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.justVal reasonSuperior)) usr) ) dbtRowKey = querySuperUser >>> (E.^. UserId) dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute, isSuperior) -> do @@ -1239,18 +1240,11 @@ mkFirmSuperTable isAdmin cid = do , colUserEmail , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr - -- , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell } , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ view resultSuperCompanyDefaultSuper >>> \case Nothing -> iconCell IconSupervisorForeign (Just True ) -> iconCell IconSupervisor (Just False) -> iconSpacerCell - , sortable Nothing (i18nCell MsgTableSuperior) $ \row -> - let mb = row ^. resultSuperCompanyDefaultSuper - sp = row ^. resultSuperCompanySuperior - in case (mb,sp) of - (_ , False) -> iconSpacerCell - (Nothing , True ) -> iconCell IconSuperior <> iconCell IconSupervisorForeign - (Just _ , True ) -> iconCell IconSuperior + , sortable Nothing (i18nCell MsgTableSuperior) $ view resultSuperCompanySuperior >>> flip ifIconCell IconSuperior , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True) , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr ] @@ -1273,9 +1267,29 @@ mkFirmSuperTable isAdmin cid = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail querySuperUser + , singletonMap "is-foreign-supervisor" $ FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) -> + case criterion of + Nothing -> E.true + Just True -> E.isNothing $ suc E.?. UserCompanyUser + Just False -> E.isJust $ suc E.?. UserCompanyUser + , singletonMap "super-relation-foreign" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId + E.&&. E.exists (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.!=. E.val cid + E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + ) + in case criterion of + Nothing -> E.true + Just True -> E.exists checkSuper + Just False -> E.notExists checkSuper ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev + , prismAForm (singletonFilter "is-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperForeign) + , prismAForm (singletonFilter "super-relation-foreign" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterIsForeignSupervisee) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) @@ -1362,7 +1376,7 @@ postFirmSupersR fsh = do formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm] - siteLayout (citext2widget fsh) $ do + siteLayout (citext2widget companyName) $ do setTitle $ citext2Html $ fsh <> " Supers" let firmContactInfo = $(widgetFile "firm-contact-info") $(i18nWidgetFile "firm-supervisors") diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8cf77fdef..268c56c97 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -655,14 +655,14 @@ fillDb = do , let rcName = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n) , let rcShort = CI.mk $ "RC" <> tshow n ] - void . insert' $ UserCompany jost fraportAg True True 0 False $ Just "Vorgesetzter" - void . insert' $ UserCompany svaupel nice True False 2 False $ Just "Vorgesetzter" + void . insert' $ UserCompany jost fraportAg True True 0 False $ Just $ tshow SupervisorReasonAvsSuperior + void . insert' $ UserCompany svaupel nice True False 2 False $ Just $ tshow SupervisorReasonAvsSuperior void . insert' $ UserCompany svaupel ffacil False False 1 False $ Just "Irgendwas" void . insert' $ UserCompany svaupel bpol True False 2 False $ Just "Irgendwas" void . insert' $ UserCompany svaupel fraGround True False 1 False $ Just "Irgendwas" void . insert' $ UserCompany gkleen nice False False 1 True $ Just "Winterdienst" void . insert' $ UserCompany gkleen fraGround False True 2 False $ Just "Irgendwas" - void . insert' $ UserCompany gkleen bpol False True 1 False $ Just "Irgendwas" + void . insert' $ UserCompany gkleen bpol False True 1 False $ Just $ tshow SupervisorReasonAvsSuperior void . insert' $ UserCompany fhamann bpol False False 1 True $ Just "Irgendwas" void . insert' $ UserCompany fhamann ffacil True True 2 True $ Just "Irgendwas" void . insert' $ UserCompany fhamann nice False False 3 False $ Just "Winterdienst" @@ -687,14 +687,14 @@ 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 "Staff") - , UserSupervisor jost svaupel False (Just fraportAg) (Just "Staff") + let supvs = [ UserSupervisor jost gkleen True (Just fraportAg) (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 svaupel gkleen False (Just nice) (Just "Staff") , UserSupervisor svaupel fhamann True (Just nice) (Just "Staff") - , UserSupervisor sbarth tinaTester True (Just nice) (Just "Staff") + , UserSupervisor sbarth tinaTester True (Just nice) (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")