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

chore(avs): WIP keep supervision if company keeps email or address

Browse Source
This commit is contained in:
Steffen Jost 2024-03-20 18:06:45 +01:00
parent 4a51f94a8f
commit 1c5ca24dc5
3 changed files with 47 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -351,8 +351,8 @@ avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeabl
, MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) , MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
avsQueryCached qry = avsQueryCached qry =
getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case
(Just t) | t > 1 -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry Just t | t > 1 -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry
_ -> avsQueryNoCache qry _ -> avsQueryNoCache qry
instance SomeAvsQuery AvsQueryPerson where instance SomeAvsQuery AvsQueryPerson where
type SomeAvsResponse AvsQueryPerson = AvsResponsePerson type SomeAvsResponse AvsQueryPerson = AvsResponsePerson
@ -498,7 +498,7 @@ updateAvsUserByIds apids = do
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 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, 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 CheckAvsUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead
usr_ups = eml_up `mcons` (frm_up `mcons` per_ups) usr_up0 = eml_up `mcons` (frm_up `mcons` per_ups)
avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
[ UserAvsLastSynch =. now [ UserAvsLastSynch =. now
, UserAvsLastSynchError =. Nothing , UserAvsLastSynchError =. Nothing
@ -507,47 +507,46 @@ updateAvsUserByIds apids = do
] ]
-- --
-- TODO: Update UserCompany too -- 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 #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen
-- TODO #36 "company postal preference" -- TODO #36 "company postal preference"
-- --
lift $ do -- no more maybeT neeed from here lift $ do -- no more maybeT neeed from here
update usrId usr_ups
-- update company association & supervision -- update company association & supervision
oldCompanyMb <- join <$> (getAvsCompany `traverse` oldAvsFirmInfo) Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
let oldCompanyId = entityKey <$> oldCompanyMb oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
newCompanyId <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo let oldCompanyId = entityKey <$> oldCompanyEnt
newCompanyMb <- get newCompanyId oldCompanyMb = entityVal <$> oldCompanyEnt
pst_up = mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference TODO: only if needed
superReasonComDef = tshow SupervisorReasonCompanyDefault
-- TODO: possibly change postal preferences usr_ups <- case oldAvsFirmInfo of
let _prefPostal = maybe True companyPrefersPostal newCompanyMb
-- _primaryCompanyIdMb <- getUserPrimaryCompany usrId (pure . companyShorthand)
-- possibly add to usr_ups!
-- case (oldAvsFirmInfo, oldCompanyMb, newCompanyMb) of
case oldAvsFirmInfo of
_ | oldCompanyId == Just newCompanyId -- company unchanged entirely _ | oldCompanyId == Just newCompanyId -- company unchanged entirely
-> return () -> return usr_up0 -- => do nothing
-- (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged OR
-- -> return () || ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged
-- (Just oafi) | ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged -> do -- => just update user company association, keeping supervision privileges
-- -> return () 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 _ -- company changed completely
-> do -- switch company -> do -- switch company
(join <$> ((getBy . UniqueUserCompany usrId) `traverse` oldCompanyId)) >>= (\case (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
Nothing -> do Nothing -> do
void $ insertUnique $ UserCompany usrId newCompanyId False False 1 True void $ insertUnique $ UserCompany usrId newCompanyId False False 1 True
(Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}}) -> do Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
delete ucidOld delete ucidOld
void $ insertUnique $ UserCompany usrId newCompanyId False False userCompanyPriority True void $ insertUnique $ UserCompany usrId newCompanyId False False userCompanyPriority True
)
-- forMM_ (get newCompanyId) $ \Company{} -> -- forMM_ (get newCompanyId) $ \Company{} ->
-- void $ upsertBy (UniqueUserCompany usrId newCompanyId) (UserCompany usrId newCompanyId False False 0 True) [error "continue here"] -- TODO: better defaults -- void $ upsertBy (UniqueUserCompany usrId newCompanyId) (UserCompany usrId newCompanyId False False 0 True) [error "continue here"] -- TODO: better defaults
let superReasonComDef = tshow SupervisorReasonCompanyDefault let superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.)
superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.)
_oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [superCompanyFilter oldCompanyId, UserSupervisorReason ~=. superReasonComDef] _oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [superCompanyFilter oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
E.insertSelectWithConflict E.insertSelectWithConflict
UniqueUserSupervisor UniqueUserSupervisor
@ -570,7 +569,7 @@ updateAvsUserByIds apids = do
_newAPs <- count $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~=. newCompanyId, UserSupervisorReason ~=. superReasonComDef] _newAPs <- count $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~=. newCompanyId, UserSupervisorReason ~=. superReasonComDef]
-- when (oldAPs > 0 && newAPs <= 0) $ -- TODO: notify admins -- when (oldAPs > 0 && newAPs <= 0) $ -- TODO: notify admins
-- TODO continue here -- 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 -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors
whenIsJust (newAvsFirmInfo ^. _avsFirmEMailSuperior) $ \supemail -> forMM_ whenIsJust (newAvsFirmInfo ^. _avsFirmEMailSuperior) $ \supemail -> forMM_
(altM (guessUserByEmail $ supemail ^. from _CI) (altM (guessUserByEmail $ supemail ^. from _CI)
@ -580,6 +579,7 @@ updateAvsUserByIds apids = do
deleteWhere [UserSupervisorUser ==.usrId, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior] deleteWhere [UserSupervisorUser ==.usrId, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior]
void $ insertUnique $ UserSupervisor supid usrId False (Just newCompanyId) reasonSuperior void $ insertUnique $ UserSupervisor supid usrId False (Just newCompanyId) reasonSuperior
-- update stored avsinfo -- update stored avsinfo
update usrId usr_ups
update uaId avs_ups update uaId avs_ups
return $ Set.singleton (apid, usrId) return $ Set.singleton (apid, usrId)
@ -598,7 +598,8 @@ getAvsCompany afi =
, getBy $ UniqueCompanyName compName , 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 upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
mbFirmEnt <- getAvsCompany newAvsFirmInfo mbFirmEnt <- getAvsCompany newAvsFirmInfo
case (mbFirmEnt, mbOldAvsFirmInfo) of case (mbFirmEnt, mbOldAvsFirmInfo) of
@ -612,14 +613,14 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
, companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress , companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress
, companyEmail = newAvsFirmInfo ^. _avsFirmPrimaryEmail . _Just . from _CI . re _Just , companyEmail = newAvsFirmInfo ^. _avsFirmPrimaryEmail . _Just . from _CI . re _Just
} }
newId <- insert $ foldl' upd dmy firmInfo2company newCmp <- insertEntity $ foldl' upd dmy firmInfo2company
reportAdminProblem $ AdminProblemNewCompany newId reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
return newId return newCmp
(Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred (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 let cmp_ups = mapMaybe (mkUpdate firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
update firmid cmp_ups Entity firmid <$> updateGet firmid cmp_ups
return firmid
where where
firmInfo2company = firmInfo2company =
[ CheckAvsUpdate CompanyName $ _avsFirmFirm . from _CI [ CheckAvsUpdate CompanyName $ _avsFirmFirm . from _CI

3
src/Utils.hs
View File

@ -946,6 +946,9 @@ positiveSum = maybePositive . getSum
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM dft act mb = mb >>= maybe dft act 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 :: Monad m => m a -> MaybeT m a -> m a
maybeT x m = runMaybeT m >>= maybe x return maybeT x m = runMaybeT m >>= maybe x return

4
src/Utils/Persist.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de> -- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -41,6 +41,6 @@ fromPersistValueErrorSql _ = fromPersistValueError (tshow $ typeRep @a) (tshow $
infix 4 ~=. 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] (~=.) :: PersistField a => EntityField v (Maybe a) -> a -> [Filter v]
(~=.) f v = [f ==. Just v] ||. [f ==. Nothing] (~=.) f v = [f ==. Just v] ||. [f ==. Nothing]