From cabb8cd3d03e93b36173534e4e2bde0caf4be418 Mon Sep 17 00:00:00 2001
From: Profpatsch <mail@profpatsch.de>
Date: Sun, 5 Jan 2025 21:20:47 +0100
Subject: [PATCH] fix(users/Profpatsch/whatcd-resolver): handle redacted too
 many req
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

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 | 76 +++++++++++++-------
 1 file changed, 52 insertions(+), 24 deletions(-)

diff --git a/users/Profpatsch/whatcd-resolver/src/Http.hs b/users/Profpatsch/whatcd-resolver/src/Http.hs
index 03b04d56b..a9aa23495 100644
--- a/users/Profpatsch/whatcd-resolver/src/Http.hs
+++ b/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
-    >>= assertM
-      span
-      ( \resp -> do
-          let statusCode = resp & Http.responseStatus & (.statusCode)
-              contentType =
-                resp
-                  & Http.responseHeaders
-                  & List.lookup "content-type"
-                  <&> Wai.parseContentType
-                  <&> (\(ct, _mimeAttributes) -> ct)
-          if
-            | statusCode == 200,
-              Just ct <- contentType,
-              ct == opts'.contentType ->
-                Right $ (resp & Http.responseBody)
-            | statusCode == 200,
-              Just otherType <- contentType ->
-                Left [fmt|Server returned a non-json body, with content-type "{otherType}"|]
-            | statusCode == 200,
-              Nothing <- contentType ->
-                Left [fmt|Server returned a body with unspecified content type|]
-            | code <- statusCode -> Left $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp]
-      )
+  let go =
+        Http.httpBS req
+          >>= ( \resp -> do
+                  let statusCode = resp & Http.responseStatus & (.statusCode)
+                      contentType =
+                        resp
+                          & Http.responseHeaders
+                          & List.lookup "content-type"
+                          <&> Wai.parseContentType
+                          <&> (\(ct, _mimeAttributes) -> ct)
+                  if
+                    | statusCode == 200,
+                      Just ct <- contentType,
+                      ct == opts'.contentType ->
+                        pure $ Right $ (resp & Http.responseBody)
+                    | statusCode == 200,
+                      Just otherType <- contentType ->
+                        pure $ Left [fmt|Server returned a non-json body, with content-type "{otherType}"|]
+                    | statusCode == 200,
+                      Nothing <- contentType ->
+                        pure $ Left [fmt|Server returned a body with unspecified content type|]
+                    | statusCode == 429 -> do
+                        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 ->