fix(avs): invalidate contact cache after licence writes
This commit is contained in:
parent
d578e80282
commit
c382be9325
@ -583,17 +583,20 @@ class SomeAvsQuery q where
|
||||
avsQuery = avsQueryNoCache
|
||||
-- | send query to AVS directly, never cached
|
||||
avsQueryNoCache :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
||||
avsQueryNoCache qry = do
|
||||
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
|
||||
@ -614,6 +617,8 @@ instance SomeAvsQuery AvsQuerySetLicences where
|
||||
type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences
|
||||
pickQuery = avsQuerySetLicences
|
||||
-- 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
|
||||
@ -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,23 +656,22 @@ 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
|
||||
procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = fmap maybeMonoid . 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 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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user