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

refactor(avs): add more logging to AVS synch ops

Browse Source
This commit is contained in:
Steffen Jost 2024-04-26 16:04:28 +02:00
parent 13a648de18
commit a5dfd5e10f
4 changed files with 58 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -92,19 +92,47 @@ embedRenderMessage ''UniWorX ''AvsException id -- display as feedback for user
-}
-- | Catch AVS exceptions and display them as messages
-- catchAVS2message :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
catchAVS2message :: Handler (Maybe a) -> Handler (Maybe a)
catchAVS2message act = act `catches` handlers
catchAVS2message :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
-- catchAVS2message :: Handler (Maybe a) -> Handler (Maybe a)
catchAVS2message = catchAVShandler False False True Nothing
-- | Catch AVS exceptions and ignore them, but display them as messages
catchAVS2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
catchAVS2log = catchAVShandler False True False Nothing
catchAll2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m a -> m ()
catchAll2log = voidMaybe $ catchAVShandler True True False Nothing
-- catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException, Monoid a) => m a -> m ()
-- catchAll2log' = voidMaybe $ catchAVShandler True True False mempty
catchAVShandler :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => Bool -> Bool -> Bool -> a -> m a -> m a
catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHandlers)
where
handlers =
[ Catch.Handler (\(exc::AvsException) -> addMessageI Warning exc >> return Nothing)
, Catch.Handler (\(exc::ClientError ) -> do
let msg = "AVS fatal communicaton failure: " <> tshow exc
$logErrorS "AVS" msg
addMessage Warning $ toHtml msg
return Nothing
avsHandlers =
[ Catch.Handler (\(exc::AvsException) -> liftHandler $ do
let txt = "AVS exception ignored: " <> tshow exc
when toLog $ $logErrorS "AVS" txt
when toMsg $ addMessageI Warning exc
return dft
)
, Catch.Handler (\(exc::ClientError ) -> liftHandler $ do
let txt = "AVS fatal communicaton failure: " <> tshow exc
when toLog $ $logErrorS "AVS" txt
when toMsg $ addMessage Warning $ toHtml txt
return dft
)
]
allHandlers = guardMonoid allEx
[ Catch.Handler (\(exc::SomeException) -> liftHandler $ do
let txt = "AVS fatal unknown failure: " <> tshow exc
when toLog $ $logErrorS "AVS" txt
when toMsg $ addMessage Error $ toHtml txt
return dft
)
]
------------------
@ -140,7 +168,7 @@ updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool)
updateReceivers uid = do
-- First perform AVS update for receiver
runDB (getBy (UniqueUserAvsUser uid)) >>= \case
Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> void . maybeCatchAll $ Just <$> upsertAvsUserById apid
Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ upsertAvsUserById apid
Nothing -> return ()
-- Retrieve updated user and supervisors now
(underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
@ -158,7 +186,7 @@ updateReceivers uid = do
receiverIDs :: [UserId] = E.unValue <$> superVs
toUpdate = Set.fromList $ mapMaybe E.unValue avsIds
directResult = return (underling, pure underling, True) -- already contains updated address
forM_ toUpdate (void . maybeCatchAll . fmap Just . upsertAvsUserById) -- attempt to update postaddress from AVS
forM_ toUpdate (catchAll2log . upsertAvsUserById) -- attempt to update postaddress from AVS
if null receiverIDs
then directResult
else do
@ -240,7 +268,7 @@ queryAvsCardNo crd = do
-- | Queries AVS Status to retrieve primary card (heursitic)
queryAvsPrimaryCard :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsDataPersonCard)
queryAvsPrimaryCard api = runMaybeT $ do
AvsResponseStatus res <- MaybeT . maybeCatchAll . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api
AvsResponseStatus res <- MaybeT . catchAVS2log . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api
pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res
hoistMaybe $ Set.lookupMax $ avsStatusPersonCardStatus pstatus
@ -325,9 +353,13 @@ updateAvsUserById apid = do
let res = Set.filter ((== apid) . avsContactPersonID) adcs
snd <<$>> traverseJoin updateAvsUserByADC (Set.lookupMax res)
-- | Update given AvsPersonIds by querying AVS for each; update only, no insertion! Uses batch mechanism abd should not throw. Each user dealt within own runDB, i.e. own DB transaction
-- | Variant of `updateAvsUserByIds'` that catches and logs all exceptions
updateAvsUserByIds :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId))
updateAvsUserByIds apids = do
updateAvsUserByIds = catchAVShandler True True False mempty . updateAvsUserByIds'
-- | Update given AvsPersonIds by querying AVS for each; update only, no insertion! Uses batch mechanism and should not throw. Each user dealt within own runDB, i.e. own DB transaction
updateAvsUserByIds' :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId))
updateAvsUserByIds' apids = do
-- apids <- Set.fromList <$> E.filterExists UserAvsPersonId apids0 --not needed anymore, we expect the set to be linked
AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids -- automatically batched
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)
@ -466,7 +498,7 @@ linktoAvsUserByUIDs uids = do
return (uid, ipn)
mapM_ procUsr ips
where
procUsr (E.Value uid, E.Value (Just ipn)) = void $ maybeCatchAll $ fmap Just $ linktoAvsUserByUID uid $ mkAvsInternalPersonalNo ipn
procUsr (E.Value uid, E.Value (Just ipn)) = catchAll2log $ linktoAvsUserByUID uid $ mkAvsInternalPersonalNo ipn
procUsr _ = return ()
-- | similar to 'upsertAvsUserByCard', but accounts for the known UserId
@ -568,7 +600,7 @@ repsertSuperiorSupervisor :: Maybe CompanyId -> AvsFirmInfo -> UserId -> DB ()
repsertSuperiorSupervisor cid afi uid =
whenIsJust (afi ^. _avsFirmEMailSuperior) $ \supemail -> forMM_
(altM (guessUserByEmail $ stripCI supemail)
(maybeCatchAll $ Just . entityKey <$> ldapLookupAndUpsert supemail)
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
) $ \supid -> do
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
deleteWhere [UserSupervisorUser ==. uid, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior]

5
src/Jobs/Handler/SynchroniseAvs.hs
View File

@ -31,6 +31,7 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
now <- liftIO getCurrentTime
todos <- runConduit $ readUsers .| filterIteration now .| sinkList
putMany todos
$logInfoS "SynchronisAvs" [st|AVS synch summary for #{tshow numIterations}/#{tshow epoch}/#{tshow iteration}: #{length todos}|]
void $ queueJob JobSynchroniseAvsQueue
where
readUsers :: ConduitT () UserId _ ()
@ -42,7 +43,7 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
userIteration, currentIteration :: Integer
userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
currentIteration = toInteger iteration `mod` toInteger numIterations
-- $logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
$logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: AVS sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
guard $ userIteration == currentIteration
return $ AvsSync userId now pause
@ -116,8 +117,10 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
return jobs
let (unlinked, linked) = foldl' discernJob mempty jobs
$logInfoS "SynchronisAvs" [st|AVS synch performing for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
void $ updateAvsUserByIds linked
void $ linktoAvsUserByUIDs unlinked
$logInfoS "SynchronisAvs" [st|AVS synch performed for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
-- we do not reschedule failed synchs here in order to avoid a loop
where
discernJob (accUid, accApi) ( _ , E.Value (Just api)) = ( accUid, Set.insert api accApi)

2
src/Jobs/Handler/SynchroniseLdap.hs
View File

@ -37,7 +37,7 @@ dispatchJobSynchroniseLdap numIterations epoch iteration
userIteration, currentIteration :: Integer
userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
currentIteration = toInteger iteration `mod` toInteger numIterations
$logDebugS "SynchroniseLdap" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
$logDebugS "SynchroniseLdap" [st|User ##{tshow (fromSqlKey userId)}: LDAP sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
guard $ userIteration == currentIteration
return $ JobSynchroniseLdapUser userId

5
src/Utils.hs
View File

@ -1196,6 +1196,10 @@ infixl 4 <<$>>
(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
(<<$>>) f x = fmap f <$> x
-- useful for using `maybeCatchall`
voidMaybe :: Functor f => (f (Maybe a) -> f (Maybe a)) -> f a -> f ()
voidMaybe trf = void . trf . fmap Just
------------
-- Monads --
@ -1208,7 +1212,6 @@ shortCircuitM sc binOp mx my = do
| sc x -> return x
| otherwise -> binOp x <$> my
guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f