From 1c5ca24dc582d384018f46bf1d95d651b8dd982d Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 20 Mar 2024 18:06:45 +0100 Subject: [PATCH] chore(avs): WIP keep supervision if company keeps email or address --- src/Handler/Utils/Avs.hs | 83 ++++++++++++++++++++-------------------- src/Utils.hs | 3 ++ src/Utils/Persist.hs | 4 +- 3 files changed, 47 insertions(+), 43 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 30011ae98..4d12acf70 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -351,8 +351,8 @@ avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeabl , MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) avsQueryCached qry = getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case - (Just t) | t > 1 -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry - _ -> avsQueryNoCache qry + Just t | t > 1 -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry + _ -> avsQueryNoCache qry instance SomeAvsQuery AvsQueryPerson where type SomeAvsResponse AvsQueryPerson = AvsResponsePerson @@ -497,8 +497,8 @@ updateAvsUserByIds apids = do CheckAvsUpdate UserDisplayEmail $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI eml_up = em_p_up <|> em_f_up -- ensure that only one email update is produced; there is no Eq instance for the Update type frm_up = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users, - CheckAvsUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead - usr_ups = eml_up `mcons` (frm_up `mcons` per_ups) + CheckAvsUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead + usr_up0 = eml_up `mcons` (frm_up `mcons` per_ups) avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` [ UserAvsLastSynch =. now , UserAvsLastSynchError =. Nothing @@ -507,47 +507,46 @@ updateAvsUserByIds apids = do ] -- -- TODO: Update UserCompany too - -- TODO #124 Add an old default supervisor to an Admin TODO-List + -- DONE #124 Add an old default supervisor to an Admin TODO-List -- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen -- TODO #36 "company postal preference" -- lift $ do -- no more maybeT neeed from here - update usrId usr_ups -- update company association & supervision - oldCompanyMb <- join <$> (getAvsCompany `traverse` oldAvsFirmInfo) - let oldCompanyId = entityKey <$> oldCompanyMb - newCompanyId <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo - newCompanyMb <- get newCompanyId - - -- TODO: possibly change postal preferences - let _prefPostal = maybe True companyPrefersPostal newCompanyMb - -- _primaryCompanyIdMb <- getUserPrimaryCompany usrId (pure . companyShorthand) - -- possibly add to usr_ups! - - -- case (oldAvsFirmInfo, oldCompanyMb, newCompanyMb) of - case oldAvsFirmInfo of + Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo + oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo + let oldCompanyId = entityKey <$> oldCompanyEnt + oldCompanyMb = entityVal <$> oldCompanyEnt + pst_up = mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference TODO: only if needed + superReasonComDef = tshow SupervisorReasonCompanyDefault + + usr_ups <- case oldAvsFirmInfo of _ | oldCompanyId == Just newCompanyId -- company unchanged entirely - -> return () - -- (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged - -- -> return () - -- (Just oafi) | ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged - -- -> return () + -> return usr_up0 -- => do nothing + (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged OR + || ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged + -> do -- => just update user company association, keeping supervision privileges + void $ upsertBy (UniqueUserCompany usrId newCompanyId) + (UserCompany usrId newCompanyId False False 1 True) + [UserCompanyCompany =. newCompanyId] + whenIsJust oldCompanyId $ \ocid -> + updateWhere [UserSupervisorSupervisor ==. usrId, UserSupervisorCompany ==. Just ocid, UserSupervisorReason ==. Just superReasonComDef] + [UserSupervisorCompany =. Just newCompanyId] + return usr_up0 _ -- company changed completely -> do -- switch company - (join <$> ((getBy . UniqueUserCompany usrId) `traverse` oldCompanyId)) >>= (\case - Nothing -> do - void $ insertUnique $ UserCompany usrId newCompanyId False False 1 True - (Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}}) -> do - when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute - delete ucidOld - void $ insertUnique $ UserCompany usrId newCompanyId False False userCompanyPriority True - ) - + (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case + Nothing -> do + void $ insertUnique $ UserCompany usrId newCompanyId False False 1 True + Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do + when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute + delete ucidOld + void $ insertUnique $ UserCompany usrId newCompanyId False False userCompanyPriority True + -- forMM_ (get newCompanyId) $ \Company{} -> -- void $ upsertBy (UniqueUserCompany usrId newCompanyId) (UserCompany usrId newCompanyId False False 0 True) [error "continue here"] -- TODO: better defaults - let superReasonComDef = tshow SupervisorReasonCompanyDefault - superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.) + let superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.) _oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [superCompanyFilter oldCompanyId, UserSupervisorReason ~=. superReasonComDef] E.insertSelectWithConflict UniqueUserSupervisor @@ -570,7 +569,7 @@ updateAvsUserByIds apids = do _newAPs <- count $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~=. newCompanyId, UserSupervisorReason ~=. superReasonComDef] -- when (oldAPs > 0 && newAPs <= 0) $ -- TODO: notify admins -- TODO continue here - return () + return $ pst_up `mcons` usr_up0 -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors whenIsJust (newAvsFirmInfo ^. _avsFirmEMailSuperior) $ \supemail -> forMM_ (altM (guessUserByEmail $ supemail ^. from _CI) @@ -580,6 +579,7 @@ updateAvsUserByIds apids = do deleteWhere [UserSupervisorUser ==.usrId, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior] void $ insertUnique $ UserSupervisor supid usrId False (Just newCompanyId) reasonSuperior -- update stored avsinfo + update usrId usr_ups update uaId avs_ups return $ Set.singleton (apid, usrId) @@ -598,7 +598,8 @@ getAvsCompany afi = , getBy $ UniqueCompanyName compName ] -upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB CompanyId +-- | insert a company from AVS firm info or update an existing one based on previous values +upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company) upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do mbFirmEnt <- getAvsCompany newAvsFirmInfo case (mbFirmEnt, mbOldAvsFirmInfo) of @@ -612,14 +613,14 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do , companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress , companyEmail = newAvsFirmInfo ^. _avsFirmPrimaryEmail . _Just . from _CI . re _Just } - newId <- insert $ foldl' upd dmy firmInfo2company - reportAdminProblem $ AdminProblemNewCompany newId - return newId + newCmp <- insertEntity $ foldl' upd dmy firmInfo2company + reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp + return newCmp (Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred let cmp_ups = mapMaybe (mkUpdate firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company - update firmid cmp_ups - return firmid + Entity firmid <$> updateGet firmid cmp_ups + where firmInfo2company = [ CheckAvsUpdate CompanyName $ _avsFirmFirm . from _CI diff --git a/src/Utils.hs b/src/Utils.hs index 09f4140ad..ce5f00f0e 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -946,6 +946,9 @@ positiveSum = maybePositive . getSum maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM dft act mb = mb >>= maybe dft act +traverseJoin :: (Applicative m, Traversable maybe, Monad maybe) => (a -> m (maybe b)) -> maybe a -> m (maybe b) +traverseJoin f x = join <$> (f `traverse` x) + maybeT :: Monad m => m a -> MaybeT m a -> m a maybeT x m = runMaybeT m >>= maybe x return diff --git a/src/Utils/Persist.hs b/src/Utils/Persist.hs index 3a03ac19b..199a3659a 100644 --- a/src/Utils/Persist.hs +++ b/src/Utils/Persist.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -41,6 +41,6 @@ fromPersistValueErrorSql _ = fromPersistValueError (tshow $ typeRep @a) (tshow $ infix 4 ~=. --- | is Equal or Nothing +-- | is Equal or Nothing, do not confuse with Database.Esqueleto.Utils(~=.) which does the same for proper Esqueleto queries (~=.) :: PersistField a => EntityField v (Maybe a) -> a -> [Filter v] (~=.) f v = [f ==. Just v] ||. [f ==. Nothing] \ No newline at end of file