chore(avs): remove company superior, if there is none anymore
This commit is contained in:
parent
fee14edf36
commit
8c8ffa5183
@ -643,71 +643,90 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
||||
|
||||
-- upsert company supervisor from AvsFirmEMailSuperior
|
||||
upsertCompanySuperior :: (Maybe CompanyId, AvsFirmInfo) -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId))
|
||||
upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do
|
||||
supemail <- MaybeT . pure $ newAfi ^. _avsFirmEMailSuperior
|
||||
cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi)
|
||||
supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
|
||||
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
|
||||
lift $ do
|
||||
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
||||
oldChanges <- runMaybeT $ do -- remove old superior, if any
|
||||
oldAfi <- MaybeT $ pure mbOldAfi
|
||||
oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
|
||||
oldCid <- MaybeT $ getAvsCompanyId oldAfi
|
||||
oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml
|
||||
let supChange = oldSup /= supid
|
||||
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
|
||||
-- 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 [UserSupervisorSupervisor ==. oldSup, UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior] -- remove un-updateable remainders, if any
|
||||
return (supChange, oldSup)
|
||||
let supChange = fst <$> oldChanges
|
||||
oldSup = snd <$> oldChanges
|
||||
unless (supChange == Just False) $ do
|
||||
-- upsert new superior company supervisor
|
||||
mbMaxPrio <- E.selectOne $ do
|
||||
usrCmp <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid
|
||||
return . E.max_ $ usrCmp E.^. UserCompanyPriority
|
||||
let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
|
||||
suprEnt <- upsertBy (UniqueUserCompany supid cid)
|
||||
(UserCompany supid cid True False maxPrio True reasonSuperior)
|
||||
[UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior]
|
||||
E.insertSelectWithConflict UniqueUserSupervisor
|
||||
(do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
|
||||
-- E.&&. E.notExists (do -- restrict to primary company only
|
||||
-- othr <- E.from $ E.table @UserCompany
|
||||
-- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
|
||||
-- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
|
||||
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
|
||||
-- )
|
||||
return $ UserSupervisor
|
||||
E.<# E.val supid
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute)
|
||||
E.<&> E.justVal cid
|
||||
E.<&> E.val reasonSuperior
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorCompany E.=. E.coalesce [old E.^. UserSupervisorCompany, new E.^. UserSupervisorCompany]
|
||||
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason , new E.^. UserSupervisorReason ]
|
||||
]
|
||||
)
|
||||
reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup
|
||||
return (cid,supid)
|
||||
upsertCompanySuperior (mbCid, newAfi) mbOldAfi
|
||||
| Just supemail <- newAfi ^. _avsFirmEMailSuperior -- superior given
|
||||
= runMaybeT $ do
|
||||
cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi)
|
||||
supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
|
||||
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
|
||||
lift $ do
|
||||
oldChanges <- runMaybeT $ do -- remove old superior, if any
|
||||
oldAfi <- MaybeT $ pure mbOldAfi
|
||||
oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
|
||||
oldCid <- MaybeT $ getAvsCompanyId oldAfi
|
||||
oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml
|
||||
let supChange = oldSup /= supid
|
||||
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
|
||||
-- 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
|
||||
)
|
||||
deleteOldSuperior oldSup cid -- remove un-updateable remainders, if any
|
||||
return (supChange, oldSup)
|
||||
let supChange = fst <$> oldChanges
|
||||
oldSup = snd <$> oldChanges
|
||||
unless (supChange == Just False) $ do
|
||||
-- upsert new superior company supervisor
|
||||
mbMaxPrio <- E.selectOne $ do
|
||||
usrCmp <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid
|
||||
return . E.max_ $ usrCmp E.^. UserCompanyPriority
|
||||
let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
|
||||
suprEnt <- upsertBy (UniqueUserCompany supid cid)
|
||||
(UserCompany supid cid True False maxPrio True reasonSuperior)
|
||||
[UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior]
|
||||
E.insertSelectWithConflict UniqueUserSupervisor
|
||||
(do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
|
||||
-- E.&&. E.notExists (do -- restrict to primary company only
|
||||
-- othr <- E.from $ E.table @UserCompany
|
||||
-- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
|
||||
-- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
|
||||
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
|
||||
-- )
|
||||
return $ UserSupervisor
|
||||
E.<# E.val supid
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute)
|
||||
E.<&> E.justVal cid
|
||||
E.<&> E.val reasonSuperior
|
||||
)
|
||||
(\_old new ->
|
||||
[ -- UserSupervisorSupervisor E.=. new E.^. UserSupervisorSupervisor -- this is already given in case of conflict
|
||||
UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
, UserSupervisorReason E.=. new E.^. UserSupervisorReason
|
||||
]
|
||||
)
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user