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

chore(avs): proper company superiors as company wide default APs (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2024-06-26 17:18:41 +02:00
parent 2559346d96
commit 975bf13d9c
2 changed files with 46 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/users.model
View File

@ -91,7 +91,7 @@ UserCompany
company CompanyId OnDeleteCascade OnUpdateCascade
supervisor Bool default=false -- should this user be made supervisor for all _new_ users associated with this company?
supervisorReroute Bool default=false -- if supervisor is true, should this supervisor receive email for _new_ company users?
priority Int default=0 -- higher number, higher priority
priority Int default=0 -- higher number, higher priority; default=1 for Haskell-Code
useCompanyAddress Bool default=true -- if true, CompanyPostalAddress and CompanyEmail are used if UserPostalAddress/UserDisplayEmail are Nothing, respects priority
UniqueUserCompany user company -- a user may belong to multiple companies, but to each one only once
deriving Generic Show

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

@ -444,7 +444,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
-- return pst_up
repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors
repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is supervisor, must be executed after updating company default supervisors
update usrId $ usr_up2 <> usr_up1 -- update user eventually
update uaId avs_ups -- update stored avsinfo for future updates
return (apid, usrId)
@ -570,9 +570,50 @@ repsertSuperiorSupervisor cid afi uid =
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
) $ \supid -> do
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
deleteWhere [UserSupervisorUser ==. uid, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior]
void $ insertUnique $ UserSupervisor supid uid False cid reasonSuperior
newSupervisor = UserSupervisor supid uid False cid reasonSuperior
deleteWhere [UserSupervisorUser ==. uid, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior] -- delete previous superiors, if any
-- void $ upsertBy (UniqueUserSupervisor supid uid) newSupervisor [company =. cid, reason =. reasonSuperior] -- always update supervisor reason
void $ insertUnique $ UserSupervisor supid uid False cid reasonSuperior -- do not change existing supervisor relationship
-- TODO: CR3: user upsertCompanySuperior instead of repsertSuperiorSupervisor
-- upsert company supervisor from AvsFirmEMailSuperior
upsertCompanySuperior :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId))
upsertCompanySuperior newAfi mbOldAfi = runMaybeT $ do
supemail <- MaybeT . pure $ newAfi ^. _avsFirmEMailSuperior
supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
cid <- MaybeT $ getAvsCompanyId newAfi
lift $ do
void $ runMaybeT $ do -- remove old superior, if any
oldAfi <- MaybeT $ pure mbOldAfi
oldSeml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
oldSup <- MaybeT $ guessUserByEmail $ stripCI oldSeml
oldCid <- MaybeT $ getAvsCompanyId oldAfi
when (oldCid == cid && oldSup /= supid) $ lift $ do
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company
-- switch supervison
-- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness
E.update $ \usuper -> do
E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ]
E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup
E.&&. usuper E.^. UserSupervisorCompany E.==. E.justVal cid
E.&&. usuper E.^. UserSupervisorReason E.==. E.val reasonSuperior
E.&&. E.notExists (do
newSuper <- E.from $ E.table @UserSupervisor
E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid
E.&&. newSuper E.^. UserSupervisorUser E.==. newSuper E.^. UserSupervisorUser
)
deleteWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] -- remove un-updateable remainders, if any
-- upsert new superior company supervisor
void $ upsertBy (UniqueUserCompany supid cid)
(UserCompany supid cid True False 1 True)
[UserCompanySupervisor =. True]
return (cid,supid)
getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo
getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
@ -612,7 +653,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
}
cmp = foldl' upd dmy $ firmInfo2key : firmInfo2companyNo : firmInfo2company
$logInfoS "AVS" $ "Insert new company: " <> tshow cmp
newCmp <- insertEntity cmp
newCmp <- insertEntity cmp
reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
$logInfoS "AVS" "Insert new company completed."
return newCmp