From d6b4afe975fd1df50ff19cdf7983bc3f4e08c270 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 11 Feb 2025 18:08:41 +0100 Subject: [PATCH] chore(firm): add working view for supervision discrepancy by firm show if a supervisionship-company is unrelated to either supervisor or supervisee --- .../uniworx/categories/firm/de-de-formal.msg | 1 + messages/uniworx/categories/firm/en-eu.msg | 5 +- .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 1 + src/Foundation/Navigation.hs | 7 + src/Handler/Firm.hs | 149 +++++++++++++++++- src/Handler/Profile.hs | 11 +- src/Handler/Users.hs | 2 +- src/Handler/Utils/Company.hs | 10 +- src/Handler/Utils/Widgets.hs | 7 +- 11 files changed, 179 insertions(+), 16 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index a182b3471..0e57b9ead 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -83,3 +83,4 @@ CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterle CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird! CompanySupervisorCompanyMissing fsh@CompanyShorthand: Empfänger ist nicht mit Firma #{fsh} aus Ansprechpartnerbeziehung assoziiert CompanySuperviseeCompanyMissing fsh@CompanyShorthand: Betroffener ist nicht mit Firma #{fsh} aus Ansprechpartnerbeziehung assoziiert +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 4b29c9734..5af785218 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -81,5 +81,6 @@ CompanyUserPriorityTip: Company priority is relative to other company associatio 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: Reciver is not associated with #{fsh} given as reroute reason -CompanySuperviseeCompanyMissing fsh: Supervisee is not associated with #{fsh} detailed as supervisonship reason \ No newline at end of file +CompanySupervisorCompanyMissing fsh: Receiver is not associated with #{fsh} given as reroute reason +CompanySuperviseeCompanyMissing fsh: Supervisee is not associated with #{fsh} detailed as supervisonship reason +ASChangeCompany: Change company for supervisionship \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index e34ad1d39..068c6b2d1 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -138,6 +138,7 @@ MenuFirms: Firmen MenuFirmUsers: Angehörige MenuFirmSupervisors: Ansprechpartner MenuFirmsComm: Mitteilung +MenuFirmsSupervision: Probleme Ansprechpartnerbeziehungen MenuInterfaces: Schnittstellen MenuSap: SAP Schnittstelle diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 0aaa3533f..608dd289e 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -138,6 +138,7 @@ MenuFirms: Companies MenuFirmUsers: Associates MenuFirmSupervisors: Supervisors MenuFirmsComm: Messaging +MenuFirmsSupervision: Problems supervisionship MenuInterfaces: Interfaces MenuSap: SAP Interface diff --git a/routes b/routes index 889f628ac..21b3dd7c0 100644 --- a/routes +++ b/routes @@ -126,6 +126,7 @@ /firms FirmAllR GET POST -- not yet !supervisor /firms/comm/+Companies FirmsCommR GET POST +/firms/supervision FirmsSupervisionR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST /firm/#CompanyShorthand FirmUsersR GET POST -- not yet !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST -- not yet !supervisor diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 951a31178..9448f70c3 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -127,6 +127,7 @@ breadcrumb ConfigInterfacesR = i18nCrumb MsgConfigInterfacesHeading $ Just breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR +breadcrumb FirmsSupervisionR= i18nCrumb MsgMenuFirmsSupervision $ Just FirmAllR breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh @@ -2457,6 +2458,12 @@ pageActions ApiDocsR = return , navChildren = [] } ] +pageActions FirmAllR = return + [ NavPageActionPrimary + { navLink = defNavLink MsgMenuFirmsSupervision FirmsSupervisionR + , navChildren = [] + } + ] pageActions (FirmUsersR fsh) = return [ NavPageActionPrimary { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 426e855b9..414a62e4c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -11,7 +11,8 @@ module Handler.Firm , getFirmUsersR , postFirmUsersR , getFirmSupersR, postFirmSupersR , getFirmCommR , postFirmCommR - , getFirmsCommR, postFirmsCommR + , getFirmsCommR , postFirmsCommR + , getFirmsSupervisionR , postFirmsSupervisionR ) where @@ -1526,3 +1527,149 @@ handleFirmCommR ultDest cs = do Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma Alle gewählten Personen, gruppiert nach deren Firma -} + + +----------------------- +-- Supervision Sanity + +data ActSupervision = ASChangeCompany + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''ActSupervision $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''ActSupervision id + +data ActSupervisionData = ASChangeCompanyData + deriving (Eq, Ord, Read, Show, Generic) + + +type TblSupervisionData = DBRow (Entity UserSupervisor, Entity User, Entity User) + +mkSupervisonTable :: DB (FormResult (ActSupervisionData, Set UserSupervisorId), Widget) +mkSupervisonTable = over _1 postprocess <$> dbTable validator DBTable{..} + where + dbtIdent = "sanity-super" :: Text + dbtStyle = def + + 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) + + resultRelation :: Lens' TblSupervisionData (Entity UserSupervisor) + resultRelation = _dbrOutput . _1 + resultSupervisor :: Lens' TblSupervisionData (Entity User) + resultSupervisor = _dbrOutput . _2 + resultSubordinate :: Lens' TblSupervisionData (Entity User) + resultSubordinate = _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 + dbtColonnade = formColonnade $ mconcat + [ dbSelect (applying _2) id (return . view (resultRelation . _entityKey)) + , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \(view $ resultRelation . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute + , sortable (Just "reason") (i18nCell MsgUserSupervisorReason) $ \(view $ resultRelation . _entityVal . _userSupervisorReason -> r) -> maybeCell r textCell + , sortable (Just "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" + 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" + maybeMonoid <$> wgtCompanies True uid + ] + validator = def -- validator = def & defaultSorting [ SortAscBy "cshort" ] + dbtSorting = Map.fromList + [ ("reason" , SortColumn $ queryRelation >>> (E.^. UserSupervisorReason)) + , ("cshort" , SortColumn $ queryRelation >>> (E.^. UserSupervisorCompany)) + , ("reroute" , SortColumn $ queryRelation >>> (E.^. UserSupervisorRerouteNotifications)) + , ("super" , SortColumn $ querySupervisor >>> (E.^. UserDisplayName)) + , ("subordinate" , SortColumn $ querySubordinate >>> (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 + (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.orderBy [E.asc $ cmp E.^. CompanyName] + return (cmp E.^. CompanyName) + )) + ] + dbtFilter = mempty + dbtFilterUI = mempty + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Nothing + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional = + let acts :: Map ActSupervision (AForm Handler ActSupervisionData) + acts = mconcat + [ singletonMap ASChangeCompany $ pure ASChangeCompanyData + ] + in renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + postprocess :: FormResult (First ActSupervisionData, DBFormResult UserSupervisorId Bool TblSupervisionData) + -> FormResult ( ActSupervisionData, Set UserSupervisorId) + postprocess inp = do + (First (Just act), jobMap) <- inp + let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap + return (act, jobSet) + + +getFirmsSupervisionR, postFirmsSupervisionR :: Handler Html +getFirmsSupervisionR = postFirmsSupervisionR +postFirmsSupervisionR = do + (svRes, svTbl) <- runDB mkSupervisonTable + formResult svRes $ \case + (ASChangeCompanyData, relations) -> do + addMessage Info $ text2Html [st|Firmenwechsel Ansprechpartnerbeziehung noch nicht implementiert. #{Set.size relations} empfangen.|] + reloadKeepGetParams FirmsSupervisionR + -- TODO: Bug Firmenwechsel: Bestehende Ansprechpartnerbeziehung - Firma ändern! + let heading = MsgMenuFirmsSupervision + siteLayoutMsg heading $ do + setTitleI heading + [whamlet|$newline never +

+ In folgenden Ansprechpartnerbeziehungen gehören entweder der Ansprechpartner oder der Angesprochene # + nicht mehr der Firma an, welche als Begründung für die Beziehung eingetragen ist: +

+ ^{svTbl} + |] diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 94cf19cba..5c690fd29 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -652,7 +652,7 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do EL.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid return (studyfeat, studydegree, studyterms) - companies <- wgtCompanies uid + companies <- wgtCompanies False uid -- supervisors' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do -- EL.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId -- E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid @@ -1234,7 +1234,8 @@ mkReceiversTable uid usrCmps receivers = dbTableDB' validator DBTable{..} E.&&. spr E.?. UserSupervisorUser E.?=. E.val uid E.where_ $ usr E.^. UserId `E.in_` E.vals (entityKey <$> receivers) return (usr, spr) - dbtRowKey (usr `E.LeftOuterJoin` _) = usr E.^. UserId + -- dbtRowKey (usr `E.LeftOuterJoin` _) = usr E.^. UserId + dbtRowKey = (E.^. UserId) . queryReceiver dbtProj = dbtProjId dbtColonnade = mconcat @@ -1265,7 +1266,7 @@ mkReceiversTable uid usrCmps receivers = dbTableDB' validator DBTable{..} rcmp = row ^? resultReceiverSupervisor . _entityVal . _userSupervisorCompany . _Just . to unCompanyKey errWgt fsh = let emsg = MsgCompanySupervisorCompanyMissing fsh in [whamlet|^{messageTooltip =<< messageI Warning emsg} _{emsg}|] - cmps <- wgtCompanies' ruid + cmps <- wgtCompanies' True ruid return $ case (cmps, rcmp) of (Just (cwgt, cmpsData), Just svcsh) | svcsh `notElem` (cmpsData ^.. traverse . _1) -> @@ -1290,7 +1291,7 @@ mkReceiversTable uid usrCmps receivers = dbTableDB' validator DBTable{..} , sfsh `notElem` usrCmps -> companyIdCell sfid <> wgtCell (errWgt sfsh) | otherwise -> companyIdCell sfid ] - validator = def -- & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ] + validator = def & defaultSorting [ SortAscBy "user-name" ] dbtSorting = Map.fromList [ sortUserNameLink queryReceiver -- , sortUserLetterEmailPin queryReceiver @@ -1474,7 +1475,7 @@ getUserRecipientsR uuid = do [] -> return Nothing -- no receivers [_] | usrReceives -> return Nothing -- only user receives for themself _ -> runDB $ do - usrCmps <- wgtCompanies' uid + usrCmps <- wgtCompanies' True uid let fshs :: [CompanyShorthand] = usrCmps ^.. _Just . _2 . traverse . _1 rtbl <- mkReceiversTable uid fshs receivers return $ Just (rtbl, fst <$> usrCmps) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index aafdacd02..53cb00c0f 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -110,7 +110,7 @@ postUsersR = do (nameWidget userDisplayName userSurname) , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity 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 uid + maybeMonoid <$> wgtCompanies False uid -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- redundant -- (AdminUserR <$> encrypt uid) -- (toWgt userCompanyPersonalNumber) diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 99ed65a7a..27e554164 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -38,15 +38,15 @@ instance E.SqlString (Key Company) company2msg :: CompanyId -> SomeMessage UniWorX company2msg = text2message . ciOriginal . unCompanyKey -wgtCompanies :: UserId -> DB (Maybe Widget) -wgtCompanies = (wrapUL . fst <<$>>) . wgtCompanies' +wgtCompanies :: Bool -> UserId -> DB (Maybe Widget) +wgtCompanies useShort = (wrapUL . fst <<$>>) . wgtCompanies' useShort where wrapUL wgt = [whamlet|