diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index ae9b53f2d..b8cb5a610 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -329,6 +329,8 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv let usrId = userAvsUser usravs usr <- MaybeT $ get usrId lift $ do -- maybeT no longer needed from here onwards + uuid :: CryptoUUIDUser <- encrypt usrId + $logInfoS "AVS" [st|updateAvsUserByADC: #{tshow uuid}|] let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here oldAvsCardNo = userAvsLastCardNo usravs & fmap Just @@ -380,72 +382,73 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv , UserAvsLastCardNo =. newAvsCardNo ] - -- update company association & supervision - newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo - oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo - primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId - let oldCompanyId = entityKey <$> oldCompanyEnt - -- oldCompanyMb = entityVal <$> oldCompanyEnt - -- pst_up = if - -- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines - -- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) - -- | isNothing oldCompanyMb - -- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) - -- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line - -- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference - -- | otherwise - -- -> Nothing - superReasonComDef = tshow SupervisorReasonCompanyDefault - newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done + usr_up2 <- guardMonoidM (oldAvsFirmInfo /= Just newAvsFirmInfo) $ do + -- update company association & supervision + newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo + upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId -- ensure firmInfo superior is supervisor for this user + oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo + primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId + let oldCompanyId = entityKey <$> oldCompanyEnt + -- oldCompanyMb = entityVal <$> oldCompanyEnt + -- pst_up = if + -- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines + -- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) + -- | isNothing oldCompanyMb + -- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) + -- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line + -- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference + -- | otherwise + -- -> Nothing + superReasonComDef = tshow SupervisorReasonCompanyDefault + newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done - usr_up2 <- case oldAvsFirmInfo of - _ | Just newCompanyId == oldCompanyId -- company unchanged entirely - -> return mempty -- => do nothing - (Just oafi) | isJust (view _avsFirmPostAddressSimple oafi) - && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR - || isJust (view _avsFirmPrimaryEmail oafi) - && ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged - -> do -- => just update user company association, keeping supervision privileges - case oldCompanyId of - Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists - Just ocid -> do - void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings - void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions - , UserSupervisorCompany ==. Just ocid -- to new company, regardless of - , UserSupervisorReason ==. Just superReasonComDef] -- user - [ UserSupervisorCompany =. Just newCompanyId] - return mempty - _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company - -> do - whenIsJust oldCompanyId $ \oldCid -> do - deleteBy $ UniqueUserCompany usrId oldCid - deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) - return mempty - _ -- company changed completely - -> do - (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId - mapM_ reportAdminProblem problems - -- Following line does not type, hence additional parameter needed - -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates) - return pst_up - -- SPECIALISED CODE, PROBABLY DEPRECATED - -- switch user company, keeping old priority - -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case - -- Nothing -> - -- void $ insertUnique newUserComp - -- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do - -- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute - -- delete ucidOld - -- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds - -- -- adjust supervison - -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] - -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr - -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr - -- addDefaultSupervisors' newCompanyId $ singleton usrId - -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) - -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId - -- return pst_up - upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId -- ensure firmInfo superior is supervisor for this user + case oldAvsFirmInfo of + _ | Just newCompanyId == oldCompanyId -- company unchanged entirely + -> return mempty -- => do nothing + (Just oafi) | isJust (view _avsFirmPostAddressSimple oafi) + && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR + || isJust (view _avsFirmPrimaryEmail oafi) + && ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged + -> do -- => just update user company association, keeping supervision privileges + case oldCompanyId of + Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists + Just ocid -> do + void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings + void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions + , UserSupervisorCompany ==. Just ocid -- to new company, regardless of + , UserSupervisorReason ==. Just superReasonComDef] -- user + [ UserSupervisorCompany =. Just newCompanyId] + return mempty + _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company + -> do + whenIsJust oldCompanyId $ \oldCid -> do + deleteBy $ UniqueUserCompany usrId oldCid + deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) + return mempty + _ -- company changed completely + -> do + (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId + mapM_ reportAdminProblem problems + -- Following line does not type, hence additional parameter needed + -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates) + return pst_up + -- SPECIALISED CODE, PROBABLY DEPRECATED + -- switch user company, keeping old priority + -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case + -- Nothing -> + -- void $ insertUnique newUserComp + -- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do + -- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute + -- delete ucidOld + -- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds + -- -- adjust supervison + -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] + -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr + -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr + -- addDefaultSupervisors' newCompanyId $ singleton usrId + -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) + -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId + -- return pst_up update usrId usr_up2 -- update user by company switch first (due to possible conflicts with usr_up2) update usrId usr_up1 -- update user eventually update uaId avs_ups -- update stored avsinfo for future updates @@ -585,8 +588,8 @@ getAvsCompany afi = -- | 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 (Just oldAvsFirmInfo) - | newAvsFirmInfo == oldAvsFirmInfo = maybeM (upsertAvsCompany newAvsFirmInfo Nothing) pure $ getAvsCompany newAvsFirmInfo -- firmInfo unchanged, shortcircuit +-- upsertAvsCompany newAvsFirmInfo (Just oldAvsFirmInfo) +-- | newAvsFirmInfo == oldAvsFirmInfo = maybeM (upsertAvsCompany newAvsFirmInfo Nothing) pure $ getAvsCompany newAvsFirmInfo -- firmInfo unchanged, shortcircuit; SHORTCIRCUIT no longer needed, checked at call-site due to result not being wrapped in Maybe upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do mbFirmEnt <- getAvsCompany newAvsFirmInfo -- primarily by AvsId, then Shorthand, then name $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbOldAvsFirmInfo} new #{tshow newAvsFirmInfo} ent-new #{tshow mbFirmEnt}|]