diff --git a/src/Web/Actor/Deliver.hs b/src/Web/Actor/Deliver.hs index 3128371..7659d64 100644 --- a/src/Web/Actor/Deliver.hs +++ b/src/Web/Actor/Deliver.hs @@ -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