fix(avs): invalidate contact cache after licence writes
This commit is contained in:
parent
d578e80282
commit
c382be9325
@ -580,20 +580,23 @@ class SomeAvsQuery q where
|
|||||||
pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q))
|
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
|
-- | 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 :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
||||||
avsQuery = avsQueryNoCache
|
avsQuery = avsQueryNoCache
|
||||||
-- | send query to AVS directly, never cached
|
-- | send query to AVS directly, never cached
|
||||||
avsQueryNoCache :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
avsQueryNoCache :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
||||||
avsQueryNoCache qry = do
|
avsQueryNoCache = avsQueryNoCacheDefault
|
||||||
qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
|
|
||||||
throwLeftM $ qfun qry
|
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)
|
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)
|
, MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
||||||
avsQueryCached =
|
avsQueryCached qry =
|
||||||
(getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>=) . flip (\case
|
getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case
|
||||||
(Just t) | t > 1 -> \qry -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry
|
(Just t) | t > 1 -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry
|
||||||
_ -> avsQueryNoCache
|
_ -> avsQueryNoCache qry
|
||||||
)
|
|
||||||
|
|
||||||
instance SomeAvsQuery AvsQueryPerson where
|
instance SomeAvsQuery AvsQueryPerson where
|
||||||
type SomeAvsResponse AvsQueryPerson = AvsResponsePerson
|
type SomeAvsResponse AvsQueryPerson = AvsResponsePerson
|
||||||
@ -613,11 +616,13 @@ instance SomeAvsQuery AvsQueryContact where
|
|||||||
instance SomeAvsQuery AvsQuerySetLicences where
|
instance SomeAvsQuery AvsQuerySetLicences where
|
||||||
type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences
|
type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences
|
||||||
pickQuery = avsQuerySetLicences
|
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
|
instance SomeAvsQuery AvsQueryGetAllLicences where
|
||||||
type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences
|
type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences
|
||||||
pickQuery = const . avsQueryGetAllLicences
|
pickQuery = const . avsQueryGetAllLicences
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -635,9 +640,8 @@ queryAvsCardNo crd = do
|
|||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
-- A datatype for a specific heterogeneous list
|
-- 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 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) (Getting typ iavs typ) -- A persistent record field and fitting getting
|
||||||
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,
|
-- | 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
|
-- 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
|
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
|
updateAvsUserByIds apids = do
|
||||||
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids
|
||||||
AvsResponseContact adcs <- throwLeftM . avsQueryContact $ 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 adcs
|
res <- foldMapM procResp requestedAnswers
|
||||||
let missing = Set.toList $ Set.difference apids $ Set.map fst res
|
let missing = Set.toList $ Set.difference apids $ Set.map fst res
|
||||||
unless (null missing) $ runDB $ do
|
unless (null missing) $ do
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"]
|
updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"]
|
||||||
return res
|
return res
|
||||||
where
|
where
|
||||||
procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo)
|
procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = fmap maybeMonoid . runMaybeT $ do
|
||||||
| 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)
|
(Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid
|
||||||
| otherwise = fmap maybeMonoid . runDB . runMaybeT $ do
|
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here
|
||||||
(Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid
|
let oldAvsFirmInfo = userAvsLastFirmInfo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here
|
||||||
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing here must not abort the entire synch, hence no hoistMaybe here
|
let usrId = userAvsUser usravs
|
||||||
let oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing here must not abort the entire synch, hence no hoistMaybe here
|
usr <- MaybeT $ get usrId
|
||||||
let usrId = userAvsUser usravs
|
now <- liftIO getCurrentTime
|
||||||
usr <- MaybeT $ get usrId
|
let per_ups = maybeEmpty oldAvsPersonInfo $ \oldAvsPersonInfo' -> mapMaybe (mkUpdate usr newAvsPersonInfo oldAvsPersonInfo')
|
||||||
now <- liftIO getCurrentTime
|
[ CheckAvsUpdate UserFirstName _avsInfoFirstName
|
||||||
let per_ups = maybeEmpty oldAvsPersonInfo $ \oldAvsPersonInfo' -> mapMaybe (mkUpdate usr newAvsPersonInfo oldAvsPersonInfo')
|
, CheckAvsUpdate UserSurname _avsInfoLastName
|
||||||
[ CheckAvsUpdate UserFirstName _avsInfoFirstName
|
, CheckAvsUpdate UserDisplayName _avsInfoDisplayName
|
||||||
, CheckAvsUpdate UserSurname _avsInfoLastName
|
, CheckAvsUpdate UserBirthday _avsInfoDateOfBirth
|
||||||
, CheckAvsUpdate UserDisplayName _avsInfoDisplayName
|
, CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo
|
||||||
, CheckAvsUpdate UserBirthday _avsInfoDateOfBirth
|
, CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just`
|
||||||
, CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo
|
, CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo
|
||||||
, 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_up = let -- Comm > Superior > Company > Personal; NOTE: Email update depends simultaneosuly on AvsFirmInfo and AvsPersonInfo
|
eml_new = (newAvsFirmInfo ^. _avsFirmPrimaryEmail) <|> (newAvsPersonInfo ^. _avsInfoPersonEMail)
|
||||||
eml_old = (oldAvsFirmInfo ^. _Just . _avsFirmPrimaryEmail) <|> (oldAvsPersonInfo ^. _Just . _avsInfoPersonEMail)
|
in mkUpdate usr eml_new eml_old $
|
||||||
eml_new = (newAvsFirmInfo ^. _avsFirmPrimaryEmail) <|> (newAvsPersonInfo ^. _avsInfoPersonEMail)
|
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.
|
||||||
in mkUpdate usr eml_new eml_old $
|
frm_ups = maybeEmpty oldAvsFirmInfo $ \oldAvsFirmInfo' -> mapMaybe (mkUpdate usr newAvsFirmInfo oldAvsFirmInfo')
|
||||||
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.
|
[ CheckAvsUpdate UserPostAddress $ _avsFirmAddress . to (Just . plaintextToStoredMarkup)
|
||||||
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
|
||||||
usr_ups = mcons eml_up $ frm_ups <> per_ups
|
-- cmp_up = let
|
||||||
-- TODO: update Company
|
-- cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo)
|
||||||
-- cmp_up = let
|
-- cno_new = (oldAvsFirmInfo ^. _avsFirmFirmNo)
|
||||||
-- cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo)
|
-- in
|
||||||
-- cno_new = (oldAvsFirmInfo ^. _avsFirmFirmNo)
|
-- cmp_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirm )
|
||||||
-- in
|
-- cmp_new = (oldAvsFirmInfo ^. _avsFirmFirm )
|
||||||
-- cmp_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirm )
|
|
||||||
-- cmp_new = (oldAvsFirmInfo ^. _avsFirmFirm )
|
|
||||||
|
|
||||||
avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
|
avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
|
||||||
[ UserAvsLastSynch =. now
|
[ UserAvsLastSynch =. now
|
||||||
, UserAvsLastSynchError =. Nothing
|
, UserAvsLastSynchError =. Nothing
|
||||||
, UserAvsLastPersonInfo =. Just newAvsPersonInfo
|
, UserAvsLastPersonInfo =. Just newAvsPersonInfo
|
||||||
, UserAvsLastFirmInfo =. Just newAvsFirmInfo
|
, UserAvsLastFirmInfo =. Just newAvsFirmInfo
|
||||||
]
|
]
|
||||||
lift $ update usrId usr_ups
|
lift $ update usrId usr_ups
|
||||||
lift $ update uaId avs_ups
|
lift $ update uaId avs_ups
|
||||||
return $ Set.singleton (apid, usrId)
|
return $ Set.singleton (apid, usrId)
|
||||||
|
|||||||
@ -64,14 +64,7 @@ data AvsQuery = AvsQuery
|
|||||||
makeLenses_ ''AvsQuery
|
makeLenses_ ''AvsQuery
|
||||||
|
|
||||||
|
|
||||||
-- AVS/VSM-Interface currently only allows to query ID 0, which means all licences
|
-- | AVS/VSM-interface currently only allows GetLicences with query argument ID 0, which means all licences; all other queries yield an empty response
|
||||||
-- 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
|
|
||||||
avsQueryAllLicences :: AvsQueryGetLicences
|
avsQueryAllLicences :: AvsQueryGetLicences
|
||||||
avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
|
avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user