diff options
Diffstat (limited to 'users/Profpatsch/whatcd-resolver/src/Http.hs')
-rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Http.hs | 105 |
1 files changed, 80 insertions, 25 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/Http.hs b/users/Profpatsch/whatcd-resolver/src/Http.hs index 4fdbb306ad18..14ce191d520e 100644 --- a/users/Profpatsch/whatcd-resolver/src/Http.hs +++ b/users/Profpatsch/whatcd-resolver/src/Http.hs @@ -4,29 +4,39 @@ module Http ( doRequestJson, RequestOptions (..), mkRequestOptions, - setRequestMethod, - setRequestBodyLBS, - setRequestHeader, - getResponseStatus, - getResponseHeader, - getResponseBody, + httpJson, + Http.httpBS, + Http.Request, + Http.setRequestMethod, + Http.setQueryString, + Http.setRequestBodyLBS, + Http.setRequestHeader, + Http.getResponseStatus, + Http.getResponseHeader, + Http.getResponseHeaders, + Http.getResponseBody, ) where import AppT +import Data.Aeson.BetterErrors qualified as Json import Data.CaseInsensitive (CI (original)) import Data.Char qualified as Char -import Data.Int (Int64) +import Data.Error.Tree import Data.List qualified as List import Data.Text qualified as Text -import Data.Text.Lazy qualified as Lazy.Text import Data.Text.Punycode qualified as Punycode +import Json qualified import Json.Enc qualified as Enc +import Label import MyPrelude import Network.HTTP.Client -import Network.HTTP.Simple -import OpenTelemetry.Attributes qualified as Otel +import Network.HTTP.Client qualified as Http +import Network.HTTP.Simple qualified as Http +import Network.HTTP.Types.Status (Status (..)) +import Network.Wai.Parse qualified as Wai import Optional +import Pretty import Prelude hiding (span) data RequestOptions = RequestOptions @@ -34,7 +44,7 @@ data RequestOptions = RequestOptions host :: Text, port :: Optional Int, path :: Optional [Text], - headers :: Optional [Header], + headers :: Optional [Http.Header], usePlainHttp :: Optional Bool } @@ -49,26 +59,71 @@ mkRequestOptions opts = usePlainHttp = defaults } +httpJson :: + ( MonadThrow m, + MonadOtel m + ) => + (Optional (Label "contentType" ByteString)) -> + Json.Parse ErrorTree b -> + Http.Request -> + 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] + ) + >>= assertM + span + ( \body -> + Json.parseStrict parser body + & first (AppExceptionTree . Json.parseErrorTree "could not parse HTTP response") + ) + doRequestJson :: (MonadOtel m) => RequestOptions -> Enc.Enc -> m (Response ByteString) doRequestJson opts val = inSpan' "HTTP Request (JSON)" $ \span -> do - let x = requestToXhCommandLine opts val - let attrs = [100, 200 .. fromIntegral @Int @Int64 (x & Text.length)] - for_ attrs $ \n -> do - addAttribute span [fmt|request.xh.{n}|] (Lazy.Text.repeat 'x' & Lazy.Text.take n & toStrict & Otel.TextAttribute) addAttribute span "request.xh" (requestToXhCommandLine opts val) - defaultRequest {secure = not (opts & optsUsePlainHttp)} - & setRequestHost (opts & optsHost) - & setRequestPort (opts & optsPort) - -- TODO: is this automatically escaped by the library? - & setRequestPath (opts & optsPath) - & setRequestHeaders (opts & optsHeaders) - & setRequestMethod opts.method - & setRequestBodyLBS (Enc.encToBytesUtf8Lazy val) - & httpBS + resp <- + defaultRequest {secure = not (opts & optsUsePlainHttp)} + & Http.setRequestHost (opts & optsHost) + & Http.setRequestPort (opts & optsPort) + -- TODO: is this automatically escaped by the library? + & Http.setRequestPath (opts & optsPath) + & Http.setRequestHeaders (opts & optsHeaders) + & Http.setRequestMethod opts.method + & Http.setRequestBodyLBS (Enc.encToBytesUtf8Lazy val) + & Http.httpBS + let code = resp & Http.getResponseStatus & (.statusCode) + let msg = resp & Http.getResponseStatus & (.statusMessage) & bytesToTextUtf8Lenient + addAttribute + span + "request.response.status" + ([fmt|{code} {msg}|] :: Text) + pure resp optsHost :: RequestOptions -> ByteString optsHost opts = @@ -85,7 +140,7 @@ optsPort opts = opts.port.withDefault (if opts & optsUsePlainHttp then 80 else 4 optsPath :: RequestOptions -> ByteString optsPath opts = opts.path.withDefault [] & Text.intercalate "/" & ("/" <>) & textToBytesUtf8 -optsHeaders :: RequestOptions -> [Header] +optsHeaders :: RequestOptions -> [Http.Header] optsHeaders opts = opts.headers.withDefault [] -- | Create a string that can be pasted on the command line to invoke the same HTTP request via the `xh` tool (curl but nicer syntax) |