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]

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)

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

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