fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(avs): remove company superior, if there is none anymore

Browse Source
This commit is contained in:
Steffen Jost 2024-07-12 13:44:21 +02:00
parent fee14edf36
commit 8c8ffa5183
1 changed files with 84 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -643,71 +643,90 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
-- upsert company supervisor from AvsFirmEMailSuperior -- upsert company supervisor from AvsFirmEMailSuperior
upsertCompanySuperior :: (Maybe CompanyId, AvsFirmInfo) -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId)) upsertCompanySuperior :: (Maybe CompanyId, AvsFirmInfo) -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId))
upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do upsertCompanySuperior (mbCid, newAfi) mbOldAfi
supemail <- MaybeT . pure $ newAfi ^. _avsFirmEMailSuperior | Just supemail <- newAfi ^. _avsFirmEMailSuperior -- superior given
cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi) = runMaybeT $ do
supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail) cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi)
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail) supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
lift $ do (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior lift $ do
oldChanges <- runMaybeT $ do -- remove old superior, if any oldChanges <- runMaybeT $ do -- remove old superior, if any
oldAfi <- MaybeT $ pure mbOldAfi oldAfi <- MaybeT $ pure mbOldAfi
oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
oldCid <- MaybeT $ getAvsCompanyId oldAfi oldCid <- MaybeT $ getAvsCompanyId oldAfi
oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml
let supChange = oldSup /= supid let supChange = oldSup /= supid
when (supChange && oldCid == cid) $ lift $ do when (supChange && oldCid == cid) $ lift $ do
-- deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company NOTE: we leave this to the oldSuperior's AVS update -- deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company NOTE: we leave this to the oldSuperior's AVS update
-- switch supervison -- switch supervison
-- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness -- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness
E.update $ \usuper -> do E.update $ \usuper -> do
E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ] E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ]
E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup
E.&&. usuper E.^. UserSupervisorCompany E.==. E.justVal cid E.&&. usuper E.^. UserSupervisorCompany E.==. E.justVal cid
E.&&. usuper E.^. UserSupervisorReason E.==. E.val reasonSuperior E.&&. usuper E.^. UserSupervisorReason E.==. E.val reasonSuperior
E.&&. E.notExists (do E.&&. E.notExists (do
newSuper <- E.from $ E.table @UserSupervisor newSuper <- E.from $ E.table @UserSupervisor
E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid
E.&&. newSuper E.^. UserSupervisorUser E.==. newSuper E.^. UserSupervisorUser E.&&. newSuper E.^. UserSupervisorUser E.==. newSuper E.^. UserSupervisorUser
) )
deleteWhere [UserSupervisorSupervisor ==. oldSup, UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior] -- remove un-updateable remainders, if any deleteOldSuperior oldSup cid -- remove un-updateable remainders, if any
return (supChange, oldSup) return (supChange, oldSup)
let supChange = fst <$> oldChanges let supChange = fst <$> oldChanges
oldSup = snd <$> oldChanges oldSup = snd <$> oldChanges
unless (supChange == Just False) $ do unless (supChange == Just False) $ do
-- upsert new superior company supervisor -- upsert new superior company supervisor
mbMaxPrio <- E.selectOne $ do mbMaxPrio <- E.selectOne $ do
usrCmp <- E.from $ E.table @UserCompany usrCmp <- E.from $ E.table @UserCompany
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid
return . E.max_ $ usrCmp E.^. UserCompanyPriority return . E.max_ $ usrCmp E.^. UserCompanyPriority
let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
suprEnt <- upsertBy (UniqueUserCompany supid cid) suprEnt <- upsertBy (UniqueUserCompany supid cid)
(UserCompany supid cid True False maxPrio True reasonSuperior) (UserCompany supid cid True False maxPrio True reasonSuperior)
[UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior] [UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior]
E.insertSelectWithConflict UniqueUserSupervisor E.insertSelectWithConflict UniqueUserSupervisor
(do (do
usr <- E.from $ E.table @UserCompany usr <- E.from $ E.table @UserCompany
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
-- E.&&. E.notExists (do -- restrict to primary company only -- E.&&. E.notExists (do -- restrict to primary company only
-- othr <- E.from $ E.table @UserCompany -- othr <- E.from $ E.table @UserCompany
-- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority -- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
-- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser -- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving -- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
-- ) -- )
return $ UserSupervisor return $ UserSupervisor
E.<# E.val supid E.<# E.val supid
E.<&> (usr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser)
E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute) E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute)
E.<&> E.justVal cid E.<&> E.justVal cid
E.<&> E.val reasonSuperior E.<&> E.val reasonSuperior
) )
(\old new -> (\_old new ->
[ UserSupervisorCompany E.=. E.coalesce [old E.^. UserSupervisorCompany, new E.^. UserSupervisorCompany] [ -- UserSupervisorSupervisor E.=. new E.^. UserSupervisorSupervisor -- this is already given in case of conflict
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason , new E.^. UserSupervisorReason ] UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
] , UserSupervisorReason E.=. new E.^. UserSupervisorReason
) ]
reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup )
return (cid,supid) reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup
return (cid,supid)
| Just oldSupeEmail <- mbOldAfi ^? _Just . _avsFirmEMailSuperior . _Just -- no more superior, delete old one
= do
void $ runMaybeT $ do
oldAfi <- MaybeT $ pure mbOldAfi
oldCid <- MaybeT $ getAvsCompanyId oldAfi
oldSup <- MaybeT $ guessUserByEmail $ stripCI oldSupeEmail
lift $ deleteOldSuperior oldSup oldCid
return Nothing
| otherwise -- neither new nor old superior
= return Nothing
where
reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
deleteOldSuperior oldSup oldCid =
deleteWhere [ UserSupervisorSupervisor ==. oldSup
, UserSupervisorCompany ==. Just oldCid
, UserSupervisorReason ==. reasonSuperior
]
queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64 queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64