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))
|
||||
-- | 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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user