diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 92a80ad..e7ef441 100644 --- a/src/Vervis/Federation.hs +++ b/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 diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs index 07a5f81..ae081b6 100644 --- a/src/Yesod/ActivityPub.hs +++ b/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