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

refactor(avs): using MaybeT

Browse Source
This commit is contained in:
Steffen Jost 2024-01-12 16:57:17 +01:00
parent b5340a18a2
commit cb807fce98
2 changed files with 27 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -572,13 +572,13 @@ updateReceivers uid = do
-- CR3 Functions
-- data CheckAvsUpdate record iavs = forall typ f. (Eq typ, PersistField typ, Functor f) => CheckAvsUpdate ((typ -> f typ) -> iavs -> f iavs) (EntityField record typ) -- A Lens and a User Field; does not work.
data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate ((typ -> Const typ typ) -> iavs -> Const typ iavs) (EntityField record typ) -- A Lens and a User Field
-- data CheckAvsUpdate record iavs = forall typ f. (Eq typ, PersistField typ, Functor f) => CheckAvsUpdate (EntityField record typ) ((typ -> f typ) -> iavs -> f iavs) -- An Record Field and fitting Lens
data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) ((typ -> Const typ typ) -> iavs -> Const typ iavs) -- An Record Field and fitting Lens
-- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value,
-- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query
mkUpdate :: PersistEntity record => record -> iavs -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
mkUpdate usr npi opi (CheckAvsUpdate la up)
mkUpdate usr npi opi (CheckAvsUpdate up la)
| let newval = npi ^. la
, let oldval = opi ^. la
, let usrval = getField up usr
@ -596,24 +596,23 @@ updateAvsUserByIds apids = do
where
procResp (AvsDataContact apid avsPersonInfo _avsFirmInfo)
| apid `Set.notMember` apids = return mempty -- should not occur, neither should one apid occur multiple times withtin the response (if so, all responses processed here in random order)
| otherwise = runDB $
getBy (UniqueUserAvsId apid) >>= foldMapM ( \(Entity _ usravs) ->
continueJust (userAvsLastPersonInfo usravs) ( \oldAvsPersonInfo ->
let usrId = userAvsUser usravs in
get usrId >>= foldMapM ( \usr -> do
let ups = mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo)
[ CheckAvsUpdate _avsInfoFirstName UserFirstName
, CheckAvsUpdate _avsInfoLastName UserSurname
, CheckAvsUpdate _avsInfoDisplayName UserDisplayName
, CheckAvsUpdate _avsInfoDateOfBirth UserBirthday
, CheckAvsUpdate _avsInfoPersonMobilePhoneNo UserMobile
, CheckAvsUpdate (_avsInfoPersonNo . re _Just) UserMatrikelnummer -- Maybe im User, aber nicht im AvsInfo
, CheckAvsUpdate (_avsInfoPersonEMail . to (fromMaybe mempty) . from _CI) UserDisplayEmail -- Maybe nicht im AvsInfo, aber im AvsInfo
, CheckAvsUpdate (_avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . to Just) UserCompanyPersonalNumber -- Maybe im User und im AvsInfo
]
update usrId ups
return $ Set.singleton usrId
)))
| otherwise = fmap maybeMonoid . runDB . runMaybeT $ do
(Entity _ usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid
oldAvsPersonInfo <- hoistMaybe $ userAvsLastPersonInfo usravs
let usrId = userAvsUser usravs
usr <- MaybeT $ get usrId
let ups = mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo)
[ CheckAvsUpdate UserFirstName _avsInfoFirstName
, CheckAvsUpdate UserSurname _avsInfoLastName
, CheckAvsUpdate UserDisplayName _avsInfoDisplayName
, CheckAvsUpdate UserBirthday _avsInfoDateOfBirth
, CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo
, CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just`
, CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo
, CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo
]
lift $ update usrId ups
return $ Set.singleton usrId
updateAvsUserById :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX )

8
src/Utils.hs
View File

@ -1214,11 +1214,17 @@ ofoldl1M _ _ = error "otoList of NonNull is empty"
foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
foldMapM f = foldrM (\x xs -> (<> xs) <$> f x) mempty
-- | convenient synonym for `flip foldMapM`
{- left as a remineder: if you need these, use MaybeT instead!
-- convenient synonym for `flip foldMapM`
continueJust :: (Applicative m, Monoid b) => Maybe a -> (a -> m b) -> m b
continueJust (Just x) f = f x
continueJust Nothing _ = pure mempty
maybeContinue :: (Monoid b, Monad m) => m (Maybe a) -> (a -> m b) -> m b
maybeContinue mx f = mx >>= \case
Nothing -> return mempty
Just x -> f x
-}
ifoldMapM :: (FoldableWithIndex i f, Monad m, Monoid b) => (i -> a -> m b) -> f a -> m b
ifoldMapM f = ifoldrM (\i x xs -> (<> xs) <$> f i x) mempty