fix(users/Profpatsch/whatcd-resolver): handle redacted too many req

We can’t do more than like 5 requests right next to each other, so
let’s handle the timeout they request.

This kinda destroys search speeds for large search results,
so we might have to filter out collections somehow, or do something
smarter like schedule things out and show a preliminary result at one
point.

Change-Id: If916379eb6e19cf8e960cf7553965b338645e560
Reviewed-on: https://cl.tvl.fyi/c/depot/+/12958
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>

users/Profpatsch/whatcd-resolver/src/Http.hs

@@ -25,8 +25,11 @@ import Data.CaseInsensitive (CI (original))
 import Data.Char qualified as Char
 import Data.Error.Tree
 import Data.List qualified as List
+import Data.List.NonEmpty qualified as NonEmpty
+import Data.Ord (clamp)
 import Data.Text qualified as Text
 import Data.Text.Punycode qualified as Punycode
+import FieldParser qualified as Field
 import Json qualified
 import Json.Enc qualified as Enc
 import Label
@@ -38,6 +41,7 @@ import Network.HTTP.Types.Status (Status (..))
 import Network.Wai.Parse qualified as Wai
 import Optional
 import Pretty
+import UnliftIO.Concurrent (threadDelay)
 import Prelude hiding (span)
 
 data RequestOptions = RequestOptions
@@ -70,30 +74,50 @@ httpJson ::
   m b
 httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do
   let opts' = opts.withDefault (label @"contentType" "application/json")
-  Http.httpBS req
+  let go =
-    >>= assertM
+        Http.httpBS req
-      span
+          >>= ( \resp -> do
-      ( \resp -> do
+                  let statusCode = resp & Http.responseStatus & (.statusCode)
-          let statusCode = resp & Http.responseStatus & (.statusCode)
+                      contentType =
-              contentType =
+                        resp
-                resp
+                          & Http.responseHeaders
-                  & Http.responseHeaders
+                          & List.lookup "content-type"
-                  & List.lookup "content-type"
+                          <&> Wai.parseContentType
-                  <&> Wai.parseContentType
+                          <&> (\(ct, _mimeAttributes) -> ct)
-                  <&> (\(ct, _mimeAttributes) -> ct)
+                  if
-          if
+                    | statusCode == 200,
-            | statusCode == 200,
+                      Just ct <- contentType,
-              Just ct <- contentType,
+                      ct == opts'.contentType ->
-              ct == opts'.contentType ->
+                        pure $ Right $ (resp & Http.responseBody)
-                Right $ (resp & Http.responseBody)
+                    | statusCode == 200,
-            | statusCode == 200,
+                      Just otherType <- contentType ->
-              Just otherType <- contentType ->
+                        pure $ Left [fmt|Server returned a non-json body, with content-type "{otherType}"|]
-                Left [fmt|Server returned a non-json body, with content-type "{otherType}"|]
+                    | statusCode == 200,
-            | statusCode == 200,
+                      Nothing <- contentType ->
-              Nothing <- contentType ->
+                        pure $ Left [fmt|Server returned a body with unspecified content type|]
-                Left [fmt|Server returned a body with unspecified content type|]
+                    | statusCode == 429 -> do
-            | code <- statusCode -> Left $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp]
+                        let retryAfter =
-      )
+                              resp
+                                & Http.getResponseHeader "Retry-After"
+                                & nonEmpty
+                                >>= ( NonEmpty.head
+                                        >>> Field.runFieldParser
+                                          ( Field.utf8
+                                              >>> (Field.decimalNatural <&> toInteger)
+                                              >>> (Field.bounded @Int "Int" <&> clamp @Int (0, 10))
+                                          )
+                                        >>> hush
+                                    )
+                                  & fromMaybe 2
+                        inSpan' "HTTP Request (JSON) - Rate Limited" $ \span' -> do
+                          addAttribute span' "request.response.status" statusCode
+                          addAttribute span' "request.response.retry-after" retryAfter
+                          threadDelay (retryAfter * 1_000_000)
+                          go
+                    | code <- statusCode -> pure $ Left $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp]
+              )
+  go
+    >>= orAppThrow span
     >>= \body -> do
       val <-
         Json.eitherDecodeStrict body
@@ -107,6 +131,10 @@ httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do
           appThrow span (AppExceptionTree prettyErr)
         Right a -> pure a
 
+hush :: Either e a -> Maybe a
+hush (Right a) = Just a
+hush _ = Nothing
+
 doRequestJson ::
   (MonadOtel m) =>
   RequestOptions ->