Add new exception HttpClientTimeout

src/Monocle/Effects.hs

@@ -67,6 +67,7 @@ import Monocle.Config qualified
 import Network.HTTP.Client (HttpException (..))
 import Network.HTTP.Client qualified as HTTP
 
+import Control.Exception qualified
 import Effectful as E
 import Effectful.Dispatch.Static (SideEffects (..), StaticRep, evalStaticRep, getStaticRep, localStaticRep)
 import Effectful.Dispatch.Static.Primitive qualified as EffStatic
@@ -545,17 +546,21 @@ httpRequestWithTimeout request = do
   resp <- Effectful.Timeout.timeout 75_000_000 $ httpRequest request
   case resp of
     Just x -> pure x
-    Nothing -> error "The HTTP request hung for more than 75 seconds"
+    Nothing -> unsafeEff_ $ Control.Exception.throwIO HttpClientTimeout
 
 -------------------------------------------------------------------------------
 -- A network retry system
 
 retryLimit :: Int
 retryLimit = 7
 
+data HttpClientTimeout = HttpClientTimeout HTTP.Request
+  deriving (Show)
+instance Exception HttpClientTimeout
+
 -- | Retry HTTP network action, doubling backoff each time
 httpRetry :: (HasCallStack, PrometheusEffect :> es, Retry :> es, LoggerEffect :> es) => Text -> Eff es a -> Eff es a
-httpRetry urlLabel baseAction = Retry.recovering policy [httpHandler] (const action)
+httpRetry urlLabel baseAction = Retry.recovering policy [httpHandler, httpHandler2] (const action)
  where
   modName = case getCallStack callStack of
     ((_, srcLoc) : _) -> from (srcLocModule srcLoc)
@@ -577,6 +582,8 @@ httpRetry urlLabel baseAction = Retry.recovering policy [httpHandler] (const act
       promIncrCounter httpFailureCounter label
       pure True
     InvalidUrlException _ _ -> pure False
+  httpHandler2 (RetryStatus _ _ _) = Handler $ \case
+    HttpClientTimeout _ -> pure True
 
 ------------------------------------------------------------------
 --