maurice/snix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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>
This commit is contained in:
Profpatsch 2025-01-05 21:20:47 +01:00
parent 08131be8e0
commit cabb8cd3d0
1 changed files with 52 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

42
users/Profpatsch/whatcd-resolver/src/Http.hs
View file

@ -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,10 +74,9 @@ httpJson ::
m b
httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do
let opts' = opts.withDefault (label @"contentType" "application/json")
let go =
Http.httpBS req
>>= assertM
span
( \resp -> do
>>= ( \resp -> do
let statusCode = resp & Http.responseStatus & (.statusCode)
contentType =
resp
@ -85,15 +88,36 @@ httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do
| statusCode == 200,
Just ct <- contentType,
ct == opts'.contentType ->
Right $ (resp & Http.responseBody)
pure $ Right $ (resp & Http.responseBody)
| statusCode == 200,
Just otherType <- contentType ->
Left [fmt|Server returned a non-json body, with content-type "{otherType}"|]
pure $ 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]
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 ->