diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 3bfa3fce0..a33259d7f 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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] diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 57e8dbdd0..503ee3ee9 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -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) diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs index 52572d879..c0fc5758a 100644 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ b/src/Jobs/Handler/SynchroniseLdap.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index 1344a6455..3ac9fb955 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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