forge/Vervis
1
0
Fork 0
Code Pull requests Activity

HTTP inbox POST delivery: Don't retry on 4xx responses

Browse source
This commit is contained in:
Pere Lev 2024-04-14 20:32:53 +03:00
parent 8024e993a2
commit 7dcb225aa8
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
1 changed files with 16 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
src/Web/Actor/Deliver.hs
View file

@ -45,9 +45,10 @@ import Data.Time.Clock
import Data.Time.Interval
import Data.Traversable
import Database.Persist.Sql
import Network.HTTP.Client (Manager)
import Network.HTTP.Client (Manager, HttpException (..), HttpExceptionContent (..), responseStatus)
import Network.HTTP.Types.Header (HeaderName)
import Network.HTTP.Types.URI (urlEncode, urlDecode)
import Network.HTTP.Types.Status
import System.FilePath ((</>))
import System.Directory
import Web.Hashids
@ -135,23 +136,31 @@ behavior manager postSignedHeaders micros (ObjURI h lu) = \case
uInbox <- getInbox
let mluFwd = if fwd then Just lu else Nothing
_resp <-
liftIO $ retry toException $
liftIO $ retry shouldRetry toException $
AP.deliver manager postSignedHeaders envelope mluFwd uInbox
done ()
MethodForwardRemote errand -> do
uInbox <- getInbox
_resp <-
liftIO $ retry toException $
liftIO $ retry shouldRetry toException $
AP.forward manager postSignedHeaders errand uInbox
done ()
where
retry :: (e -> SomeException) -> IO (Either e a) -> IO a
retry toE action = do
shouldRetry = \case
AP.APPostErrorHTTP (HttpExceptionRequest _ (StatusCodeException resp _))
| noRetry (responseStatus resp) -> False
_ -> True
where
noRetry s =
status200 <= s && s < status300 ||
status400 <= s && s < status500
retry :: (e -> Bool) -> (e -> SomeException) -> IO (Either e a) -> IO a
retry shouldRetry' toE action = do
errorOrResult <-
runExceptT $
retryOnError
(exponentialBackoff micros)
(\ _ _ -> pure True)
(\ _ e -> pure $ shouldRetry' e)
(const $ ExceptT action)
case errorOrResult of
Left e -> throwIO $ toE e
@ -165,6 +174,7 @@ behavior manager postSignedHeaders micros (ObjURI h lu) = \case
AP.Actor local _detail <-
liftIO $
retry
(const True)
(maybe (toException IdMismatch) toException)
(AP.fetchAPID' manager (AP.actorId . AP.actorLocal) h lu)
let luInb = AP.actorInbox local