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