Do some debug logging during delivery in outbox POST handler

This commit is contained in:
fr33domlover 2019-05-10 20:38:55 +00:00
parent 770983e829
commit f88dcef0d7
2 changed files with 57 additions and 6 deletions

View file

@ -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

View file

@ -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)
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
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