From 7dcb225aa88c33f7439b2768b192533f545a4b2a Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Sun, 14 Apr 2024 20:32:53 +0300
Subject: [PATCH] HTTP inbox POST delivery: Don't retry on 4xx responses

---
 src/Web/Actor/Deliver.hs | 22 ++++++++++++++++------
 1 file changed, 16 insertions(+), 6 deletions(-)

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