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

chore(firm): add working view for supervision discrepancy by firm

Browse Source 
show if a supervisionship-company is unrelated to either supervisor or supervisee
This commit is contained in:
Steffen Jost 2025-02-11 18:08:41 +01:00
parent a56a5e148e
commit 396bcf6e13
11 changed files with 179 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

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

@ -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
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

1
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -141,6 +141,7 @@ MenuFirms: Firmen
MenuFirmUsers: Angehörige
MenuFirmSupervisors: Ansprechpartner
MenuFirmsComm: Mitteilung
MenuFirmsSupervision: Probleme Ansprechpartnerbeziehungen
MenuInterfaces: Schnittstellen
MenuSap: SAP Schnittstelle

1
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -141,6 +141,7 @@ MenuFirms: Companies
MenuFirmUsers: Associates
MenuFirmSupervisors: Supervisors
MenuFirmsComm: Messaging
MenuFirmsSupervision: Problems supervisionship
MenuInterfaces: Interfaces
MenuSap: SAP Interface

1
routes
View File

@ -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

7
src/Foundation/Navigation.hs
View File

@ -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
@ -2480,6 +2481,12 @@ pageActions ApiDocsR = return
, navChildren = []
}
]
pageActions FirmAllR = return
[ NavPageActionPrimary
{ navLink = defNavLink MsgMenuFirmsSupervision FirmsSupervisionR
, navChildren = []
}
]
pageActions (FirmUsersR fsh) = return
[ NavPageActionPrimary
{ navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh

149
src/Handler/Firm.hs
View File

@ -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
<p>
In folgenden Ansprechpartnerbeziehungen gehören entweder der Ansprechpartner oder der Angesprochene #
nicht mehr der Firma an, welche als Begründung für die Beziehung eingetragen ist:
<p>
^{svTbl}
|]

11
src/Handler/Profile.hs
View File

@ -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)

2
src/Handler/Users.hs
View File

@ -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)

10
src/Handler/Utils/Company.hs
View File

@ -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|<ul .list--iconless>^{wgt}|]
-- | Given a UserId, create widget showing top-companies (with internal link) and associated companies (unlinked)
-- NOTE: The widget must be wrapped with <ul>
wgtCompanies' :: UserId -> DB (Maybe (Widget, [(CompanyShorthand,CompanyName,Bool,Int)]))
wgtCompanies' uid = do
wgtCompanies' :: Bool -> UserId -> DB (Maybe (Widget, [(CompanyShorthand,CompanyName,Bool,Int)]))
wgtCompanies' useShort uid = do
companies <- $(E.unValueN 4) <<$>> E.select do
(usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company
`E.on` (\(usrComp :& comp) -> usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId)
@ -68,7 +68,7 @@ wgtCompanies' uid = do
procCmp _ [] = (0, [], [])
procCmp maxPri ((cmpSh, cmpName, cmpSpr, cmpPrio) : cs) =
let isTop = cmpPrio >= maxPri
cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr)
cmpWgt = companyWidget' useShort isTop (cmpSh, cmpName, cmpSpr)
(accPri,accTop,accRem) = procCmp maxPri cs
in ( max cmpPrio accPri
, bool accTop (cmpWgt : accTop) isTop -- lazy evaluation after repmin example, don't factor out the bool!

7
src/Handler/Utils/Widgets.hs
View File

@ -160,14 +160,17 @@ modalAccess wdgtNo wdgtYes writeAccess route = do
-- also see Handler.Utils.Table.Cells.companyCell
companyWidget :: Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
companyWidget isPrimary (csh, cname, isSupervisor)
companyWidget = companyWidget' False
companyWidget' :: Bool -> Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
companyWidget' useShort isPrimary (csh, cname, isSupervisor)
| isPrimary, isSupervisor = simpleLink (toWgt $ name <> iconSupervisor) curl
| isPrimary = simpleLink (toWgt name ) curl
| isSupervisor = toWgt name <> simpleLink (toWgt iconSupervisor) curl
| otherwise = toWgt name
where
curl = FirmUsersR csh
corg = ciOriginal cname
corg = ciOriginal $ bool cname csh useShort
name
| isSupervisor = text2markup (corg <> " ")
| otherwise = text2markup corg