From c382be9325fcc92e13cb5dc2ad7c20b198db26fc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 19 Feb 2024 17:28:40 +0100 Subject: [PATCH] fix(avs): invalidate contact cache after licence writes --- src/Handler/Utils/Avs.hs | 129 ++++++++++++++++++++------------------- src/Utils/Avs.hs | 9 +-- 2 files changed, 67 insertions(+), 71 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index c0ca02048..2c714abab 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -580,20 +580,23 @@ class SomeAvsQuery q where pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q)) -- | send query to AVS or maybe look it up within cache, depending on the type of the query avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) - avsQuery = avsQueryNoCache + avsQuery = avsQueryNoCache -- | send query to AVS directly, never cached avsQueryNoCache :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) - avsQueryNoCache qry = do - qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery) - throwLeftM $ qfun qry - + avsQueryNoCache = avsQueryNoCacheDefault + +avsQueryNoCacheDefault :: (SomeAvsQuery q + , MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) +avsQueryNoCacheDefault qry = do + qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery) + throwLeftM $ qfun qry + avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q), NFData (SomeAvsResponse q) , MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) -avsQueryCached = - (getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>=) . flip (\case - (Just t) | t > 1 -> \qry -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry - _ -> avsQueryNoCache - ) +avsQueryCached qry = + getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case + (Just t) | t > 1 -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry + _ -> avsQueryNoCache qry instance SomeAvsQuery AvsQueryPerson where type SomeAvsResponse AvsQueryPerson = AvsResponsePerson @@ -613,11 +616,13 @@ instance SomeAvsQuery AvsQueryContact where instance SomeAvsQuery AvsQuerySetLicences where type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences pickQuery = avsQuerySetLicences - -- NOTE: avsQuery = avsQueryCached -- should not and indeed does not compile + -- NOTE: avsQuery = avsQueryCached -- should not and indeed does not compile + avsQueryNoCache qry = avsQueryNoCacheDefault qry + <* memcachedInvalidate (Proxy @AvsResponseContact) -- invalidate all AvsResponseContact which may contain RampLicence info, since keys may comprise several ids instance SomeAvsQuery AvsQueryGetAllLicences where type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences - pickQuery = const . avsQueryGetAllLicences + pickQuery = const . avsQueryGetAllLicences @@ -635,9 +640,8 @@ queryAvsCardNo crd = do } --- A datatype for a specific heterogeneous list --- 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 +-- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens +data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) (Getting typ iavs typ) -- A persistent record field and fitting getting -- | 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 @@ -652,58 +656,57 @@ mkUpdate usr newapi oldapi (CheckAvsUpdate up la) mkUpdate _ _ _ _ = Nothing -updateAvsUserByIds :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) +-- | Update given AvsPersonId by querying AVS for each; update only, no insertion! +updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId)) updateAvsUserByIds apids = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids - res <- foldMapM procResp adcs + AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids + let requestedAnswers = Set.filter (view (_avsContactPersonID . to (`Set.member` apids))) adcs -- should not occur, neither should one apid occur multiple times within the response (if so, all responses processed here in random order) + res <- foldMapM procResp requestedAnswers let missing = Set.toList $ Set.difference apids $ Set.map fst res - unless (null missing) $ runDB $ do + unless (null missing) $ do now <- liftIO getCurrentTime updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] return res where - procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) - | 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 = fmap maybeMonoid . runDB . runMaybeT $ do - (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid - let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing here must not abort the entire synch, hence no hoistMaybe here - let oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing here must not abort the entire synch, hence no hoistMaybe here - let usrId = userAvsUser usravs - usr <- MaybeT $ get usrId - now <- liftIO getCurrentTime - let per_ups = maybeEmpty oldAvsPersonInfo $ \oldAvsPersonInfo' -> mapMaybe (mkUpdate usr newAvsPersonInfo 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 UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo - ] - eml_up = let -- Comm > Superior > Company > Personal; NOTE: Email update depends simultaneosuly on AvsFirmInfo and AvsPersonInfo - eml_old = (oldAvsFirmInfo ^. _Just . _avsFirmPrimaryEmail) <|> (oldAvsPersonInfo ^. _Just . _avsInfoPersonEMail) - eml_new = (newAvsFirmInfo ^. _avsFirmPrimaryEmail) <|> (newAvsPersonInfo ^. _avsInfoPersonEMail) - in mkUpdate usr eml_new eml_old $ - CheckAvsUpdate UserDisplayEmail $ to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo PROBLEM: Hängt auch von der FirmenEmail ab und muss daher im Verbund betrachtet werden. - frm_ups = maybeEmpty oldAvsFirmInfo $ \oldAvsFirmInfo' -> mapMaybe (mkUpdate usr newAvsFirmInfo oldAvsFirmInfo') - [ CheckAvsUpdate UserPostAddress $ _avsFirmAddress . to (Just . plaintextToStoredMarkup) - ] - usr_ups = mcons eml_up $ frm_ups <> per_ups - -- TODO: update Company - -- cmp_up = let - -- cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo) - -- cno_new = (oldAvsFirmInfo ^. _avsFirmFirmNo) - -- in - -- cmp_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirm ) - -- cmp_new = (oldAvsFirmInfo ^. _avsFirmFirm ) + procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = fmap maybeMonoid . runMaybeT $ do + (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid + let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here + let oldAvsFirmInfo = userAvsLastFirmInfo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here + let usrId = userAvsUser usravs + usr <- MaybeT $ get usrId + now <- liftIO getCurrentTime + let per_ups = maybeEmpty oldAvsPersonInfo $ \oldAvsPersonInfo' -> mapMaybe (mkUpdate usr newAvsPersonInfo 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 UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo + ] + eml_up = let -- Comm > Superior > Company > Personal; NOTE: Email update depends simultaneosuly on AvsFirmInfo and AvsPersonInfo + eml_old = (oldAvsFirmInfo ^. _Just . _avsFirmPrimaryEmail) <|> (oldAvsPersonInfo ^. _Just . _avsInfoPersonEMail) + eml_new = (newAvsFirmInfo ^. _avsFirmPrimaryEmail) <|> (newAvsPersonInfo ^. _avsInfoPersonEMail) + in mkUpdate usr eml_new eml_old $ + CheckAvsUpdate UserDisplayEmail $ to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo PROBLEM: Hängt auch von der FirmenEmail ab und muss daher im Verbund betrachtet werden. + frm_ups = maybeEmpty oldAvsFirmInfo $ \oldAvsFirmInfo' -> mapMaybe (mkUpdate usr newAvsFirmInfo oldAvsFirmInfo') + [ CheckAvsUpdate UserPostAddress $ _avsFirmAddress . to (Just . plaintextToStoredMarkup) + ] + usr_ups = mcons eml_up $ frm_ups <> per_ups + -- TODO: update Company + -- cmp_up = let + -- cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo) + -- cno_new = (oldAvsFirmInfo ^. _avsFirmFirmNo) + -- in + -- cmp_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirm ) + -- cmp_new = (oldAvsFirmInfo ^. _avsFirmFirm ) - avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` - [ UserAvsLastSynch =. now - , UserAvsLastSynchError =. Nothing - , UserAvsLastPersonInfo =. Just newAvsPersonInfo - , UserAvsLastFirmInfo =. Just newAvsFirmInfo - ] - lift $ update usrId usr_ups - lift $ update uaId avs_ups - return $ Set.singleton (apid, usrId) + avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` + [ UserAvsLastSynch =. now + , UserAvsLastSynchError =. Nothing + , UserAvsLastPersonInfo =. Just newAvsPersonInfo + , UserAvsLastFirmInfo =. Just newAvsFirmInfo + ] + lift $ update usrId usr_ups + lift $ update uaId avs_ups + return $ Set.singleton (apid, usrId) diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index e4546b36f..5b40bfbab 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -64,14 +64,7 @@ data AvsQuery = AvsQuery makeLenses_ ''AvsQuery --- AVS/VSM-Interface currently only allows to query ID 0, which means all licences --- instance SomeAvsQuery AvsQueryGetLicences where --- type SomeAvsResponse AvsQueryGetLicences = AvsResponseGetLicences --- pickQuery = avsQuerySetLicences --- type SomeAvsCachable AvsQueryGetLicences = () -- not cachable --- cacheable _ = Nothing - --- | To query all active licences, a special constant argument must be prepared +-- | AVS/VSM-interface currently only allows GetLicences with query argument ID 0, which means all licences; all other queries yield an empty response avsQueryAllLicences :: AvsQueryGetLicences avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero