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

chore(avs): add debug log info after not finding an error in company supervision switching after avs update

Browse Source
This commit is contained in:
Steffen Jost 2025-02-13 17:26:10 +01:00
parent 38baa395e2
commit b4f3171257
3 changed files with 35 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -411,26 +411,29 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
base_up :: [Update User]
base_up = guardMonoid (newCompanyEnt ^. _entityVal . _companyPinPassword) (maybeToList pin_up0)
case oldAvsFirmInfo of
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely
-> return base_up -- => do nothing
-> do -- => do nothing
$logInfoS "Supervision" [st|updateAvsUserByADC for #{tshow usrId} to new company #{unCompanyKey newCompanyId} from old company #{oldCompanyId} having primary company #{primaryCompanyId}. Company id unchanged.|]
return base_up
(Just oafi) | isJust (view _avsFirmPostAddressSimple oafi)
&& ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR
|| isJust (view _avsFirmPrimaryEmail oafi)
&& ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged
-> do -- => just update user company association, keeping supervision privileges
$logInfoS "Supervision" [st|updateAvsUserByADC for #{tshow usrId} to new company #{unCompanyKey newCompanyId} from old company #{oldCompanyId} having primary company #{primaryCompanyId}. Company address unchanged, just updating.|]
case oldCompanyId of
Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
Just ocid -> do
void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings
void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
, UserSupervisorReason ==. Just superReasonComDef] -- user
[ UserSupervisorCompany =. Just newCompanyId]
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
, UserSupervisorReason ==. Just superReasonComDef] -- user
[ UserSupervisorCompany =. Just newCompanyId]
return base_up
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
-> do
$logInfoS "Supervision" [st|updateAvsUserByADC for #{tshow usrId} to new company #{unCompanyKey newCompanyId} from old company #{oldCompanyId} having primary company #{primaryCompanyId}. Primary company unchanged.|]
whenIsJust oldCompanyId $ \oldCid -> do
deleteBy $ UniqueUserCompany usrId oldCid
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
@ -438,6 +441,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
_ -- company changed completely
-> do
(pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
$logInfoS "Supervision" [st|updateAvsUserByADC for #{tshow usrId} to new company #{unCompanyKey newCompanyId} from old company #{oldCompanyId} having primary company #{primaryCompanyId}. Company switched. #{length pst_up} updates. #{length problems} problems.|]
mapM_ reportAdminProblem problems
-- Following line does not type, hence additional parameter needed
-- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
@ -715,11 +719,11 @@ upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi u
E.<&> E.justVal cid
E.<&> E.val reasonSuperior
)
(\_old _new -> [] -- do not change exisitng supervision
-- [ UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason
-- , UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-- ]
(\_old new ->
[ UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
, UserSupervisorReason E.=. new E.^. UserSupervisorReason
, UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
]
)
when (unchangedCompany && changedSuperior) $ do
oldSupId <- getOldId

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

@ -38,6 +38,11 @@ instance E.SqlString (Key Company)
company2msg :: CompanyId -> SomeMessage UniWorX
company2msg = text2message . ciOriginal . unCompanyKey
-- for convenience in debugging
instance ToText (Maybe CompanyId) where
toText Nothing = toText ("-None-"::Text)
toText (Just fsh) = toText $ unCompanyKey fsh
wgtCompanies :: Bool -> UserId -> DB (Maybe Widget)
wgtCompanies useShort = (wrapUL . fst <<$>>) . wgtCompanies' useShort
where
@ -104,7 +109,8 @@ addDefaultSupervisors reason cid employees = do
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
, UserSupervisorCompany E.=. E.justVal cid
, UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
])
]
)
-- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
@ -164,7 +170,7 @@ addDefaultSupervisorsAll reason mutualSupervision cids = do
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
] )
-- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet
-- | removes user supervisorship on switch. WARNING: problems are only returned, but not yet written to DB via reportProblem
switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do
usrRec <- get404 uid
@ -193,14 +199,16 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
case mbUsrComp of
Nothing -> do -- create company user
void $ insertUnique newUserComp
void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
newAPs <- addDefaultSupervisors' newCompanyId $ singleton uid
$logInfoS "Supervision" [st|switchAvsUserCompany for #{tshow uid} to #{unCompanyKey newCompanyId}. #{newAPs} default company supervisors upserted.|]
return (usrUpdate, mempty)
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
| newCompanyId == oldCompanyId -> return mempty -- nothing to do
| otherwise -> do -- switch company
when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = succ oldPrio}
[UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
let newPrio = succ oldPrio
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = newPrio}
[UserCompanyPriority =. newPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
-- supervised by uid
supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
usrSup <- E.from $ E.table @UserSupervisor
@ -220,17 +228,19 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
return $ [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute
| (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True) <- supervisees ]
-- supervisors of uid
let superDeftFltr = (UserSupervisorUser ==. uid) : (UserSupervisorReason ~=. superReasonComDef)
oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr
let superDeftFltr = (UserSupervisorUser ==. uid) : (UserSupervisorReason ~=. superReasonComDef) -- default or no reason
oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr -- old company or no company
oldAPs <- if keepOldCompanySupervs
then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
else deleteWhereCount oldSubFltr
void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
nrDefSups <- addDefaultSupervisors' newCompanyId $ singleton uid -- CHECK HERE WITH LINES ABOVE
newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
problems = bcons oldSuper (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
$ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
newlyUnsupervised
delupd = bool "deleted" "updated" keepOldCompanySupervs :: Text
$logInfoS "Supervision" [st|switchAvsUserCompany for #{tshow uid} from #{unCompanyKey oldCompanyId} to #{unCompanyKey newCompanyId}. #{oldAPs} old APs #{delupd}. #{nrDefSups} default company supervisors upserted. #{newAPs} new company supervisors counted now.|]
return (usrUpdate ,problems)
defaultSupervisorReasonFilter :: [Filter UserSupervisor]

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

@ -78,10 +78,9 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
assemble = Text.intercalate "."
-- Note: Entity can be recovered, since CompanyShort is also the key
-- getUserPrimaryCompany :: UserId -> DBRead (Maybe UserCompany)
-- getUserPrimaryCompany :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) =>
-- UserId -> ReaderT backend m (Maybe UserCompany)
-- | Retrieve primary company association for user.
-- Warning: if there are multiple associations witht the same priority, one with rerouting and supervision are preferred, them alphabetically
-- Note that Entity Company can be retrieved, since CompanyShorthand is the DB key.
getUserPrimaryCompany :: UserId -> DBRead' (Maybe UserCompany)
getUserPrimaryCompany uid = entityVal <<$>>
selectFirst [UserCompanyUser ==. uid]