Do some debug logging during delivery in outbox POST handler

src/Vervis/Federation.hs

@@ -59,7 +59,7 @@ import Network.HTTP.Types.Header
 import Network.HTTP.Types.URI
 import Network.TLS hiding (SHA256)
 import UnliftIO.Exception (try)
-import Yesod.Core hiding (logError, logWarn, logInfo)
+import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
 import Yesod.Persist.Core
 
 import qualified Data.ByteString.Lazy as BL
@@ -1548,16 +1548,33 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
            )
         -> Worker ()
     deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
+        logDebug' "Starting"
         let deliver fwd h inbox = do
                 let fwd' = if h == hContext then Just fwd else Nothing
                 (isJust fwd',) <$> deliverHttp doc fwd' h inbox
         now <- liftIO getCurrentTime
+        logDebug' $
+            "Launching fetched " <> T.pack (show $ map (snd . fst) fetched)
         traverse_ (fork . deliverFetched deliver now) fetched
+        logDebug' $
+            "Launching unfetched " <> T.pack (show $ map (snd . fst) unfetched)
         traverse_ (fork . deliverUnfetched deliver now) unfetched
+        logDebug' $
+            "Launching unknown " <> T.pack (show $ map (snd . fst) unknown)
         traverse_ (fork . deliverUnfetched deliver now) unknown
+        logDebug' "Done (async delivery may still be running)"
         where
+        logDebug' t = logDebug $ prefix <> t
+            where
+            prefix =
+                T.concat
+                    [ "Outbox POST handler: deliverRemoteHttp obid#"
+                    , T.pack $ show obid
+                    , ": "
+                    ]
         fork = forkWorker "Outbox POST handler: HTTP delivery"
         deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
+            logDebug'' "Starting"
             let (raid, luActor, luInbox, dlid) = r
             (_, e) <- deliver luActor h luInbox
             e' <- case e of
@@ -1598,7 +1615,10 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                                         updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                         update dlid [DeliveryRunning =. False]
                                     Right _resp -> delete dlid
+            where
+            logDebug'' t = logDebug' $ T.concat ["deliverFetched ", h, t]
         deliverUnfetched deliver now ((iid, h), recips@(r :| rs)) = do
+            logDebug'' "Starting"
             let (uraid, luActor, udlid) = r
             e <- fetchRemoteActor iid h luActor
             let e' = case e of
@@ -1643,6 +1663,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                                         delete udlid
                                         insert_ $ Delivery raid obid fwd False
                                     Right _ -> delete udlid
+            where
+            logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", h, t]
 
 retryOutboxDelivery :: Worker ()
 retryOutboxDelivery = do

src/Yesod/ActivityPub.hs

@@ -22,16 +22,19 @@ where
 
 import Prelude
 
+import Control.Exception
+import Control.Monad.Logger.CallStack
 import Data.ByteString (ByteString)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
-import Yesod.Core
+import Network.HTTP.Client
+import Network.HTTP.Types.Header
+import Yesod.Core hiding (logError, logDebug)
 
 import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
 
-import Network.HTTP.Client
 import Network.HTTP.Signature
-import Network.HTTP.Types.Header
 
 import Network.FedURI
 import Web.ActivityPub
@@ -62,7 +65,20 @@ deliverActivity inbox mfwd doc@(Doc hAct activity) = do
     headers <- asksSite sitePostSignedHeaders
     (keyid, sign) <- siteGetHttpSign
     let sender = renderFedURI $ l2f hAct (activityActor activity)
-    httpPostAP manager inbox headers keyid sign sender (Left <$> mfwd) doc
+    result <-
+        httpPostAP manager inbox headers keyid sign sender (Left <$> mfwd) doc
+    case result of
+        Left err ->
+            logError $ T.concat
+                [ "deliverActivity to inbox <", renderFedURI inbox
+                , "> error: ", T.pack $ displayException err
+                ]
+        Right resp ->
+            logDebug $ T.concat
+                [ "deliverActivity to inbox <", renderFedURI inbox
+                , "> success: ", T.pack $ show $ responseStatus resp
+                ]
+    return result
 
 forwardActivity
     :: ( MonadSite m
@@ -81,4 +97,17 @@ forwardActivity inbox sig rSender body = do
     (keyid, sign) <- siteGetHttpSign
     renderUrl <- askUrlRender
     let sender = renderUrl rSender
-    httpPostAPBytes manager inbox headers keyid sign sender (Just $ Right sig) body
+    result <-
+        httpPostAPBytes manager inbox headers keyid sign sender (Just $ Right sig) body
+    case result of
+        Left err ->
+            logError $ T.concat
+                [ "forwardActivity to inbox <", renderFedURI inbox
+                , "> error: ", T.pack $ displayException err
+                ]
+        Right resp ->
+            logDebug $ T.concat
+                [ "forwardActivity to inbox <", renderFedURI inbox
+                , "> success: ", T.pack $ show $ responseStatus resp
+                ]
+    return result