From 8c8ffa5183ee5a72848d2aac3470eea861cc4ec8 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 12 Jul 2024 13:44:21 +0200 Subject: [PATCH] chore(avs): remove company superior, if there is none anymore --- src/Handler/Utils/Avs.hs | 149 ++++++++++++++++++++++----------------- 1 file changed, 84 insertions(+), 65 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index f4fec3cb9..50b70f784 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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