diff options
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Http.hs | 85 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/JsonLd.hs | 3 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Redacted.hs | 44 |
3 files changed, 70 insertions, 62 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/Http.hs b/users/Profpatsch/whatcd-resolver/src/Http.hs index 487d55c21d88..4376b721e80a 100644 --- a/users/Profpatsch/whatcd-resolver/src/Http.hs +++ b/users/Profpatsch/whatcd-resolver/src/Http.hs @@ -4,27 +4,35 @@ module Http ( doRequestJson, RequestOptions (..), mkRequestOptions, - setRequestMethod, - setRequestBodyLBS, - setRequestHeader, - getResponseStatus, - getResponseHeader, - getResponseBody, + httpJson, + Http.setRequestMethod, + Http.setRequestBodyLBS, + Http.setRequestHeader, + Http.getResponseStatus, + Http.getResponseHeader, + 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.Error.Tree import Data.List qualified as List import Data.Text qualified as 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 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 @@ -32,7 +40,7 @@ data RequestOptions = RequestOptions host :: Text, port :: Optional Int, path :: Optional [Text], - headers :: Optional [Header], + headers :: Optional [Http.Header], usePlainHttp :: Optional Bool } @@ -47,6 +55,47 @@ 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 [fmt|Server returned an non-200 error code, code {code}: {resp & showPretty}|] + ) + >>= assertM + span + ( \body -> + Json.parseStrict parser body + & first (Json.parseErrorTree "could not parse redacted response") + ) + doRequestJson :: (MonadOtel m) => RequestOptions -> @@ -56,16 +105,16 @@ doRequestJson opts val = inSpan' "HTTP Request (JSON)" $ \span -> do addAttribute span "request.xh" (requestToXhCommandLine opts val) resp <- defaultRequest {secure = not (opts & optsUsePlainHttp)} - & setRequestHost (opts & optsHost) - & setRequestPort (opts & optsPort) + & Http.setRequestHost (opts & optsHost) + & Http.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 - let code = resp & getResponseStatus & (.statusCode) - let msg = resp & getResponseStatus & (.statusMessage) & bytesToTextUtf8Lenient + & 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" @@ -87,7 +136,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) diff --git a/users/Profpatsch/whatcd-resolver/src/JsonLd.hs b/users/Profpatsch/whatcd-resolver/src/JsonLd.hs index 1a021b706c63..80d04f8e78a5 100644 --- a/users/Profpatsch/whatcd-resolver/src/JsonLd.hs +++ b/users/Profpatsch/whatcd-resolver/src/JsonLd.hs @@ -11,16 +11,15 @@ import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Set qualified as Set import Html qualified +import Http import IHP.HSX.QQ (hsx) import Json qualified import Label import MyPrelude import Network.HTTP.Client.Conduit qualified as Http -import Network.HTTP.Simple qualified as Http import Network.HTTP.Types.URI qualified as Url import Network.URI (URI) import Optional -import Redacted import Text.Blaze.Html (Html) import Prelude hiding (span) diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index 3427d9c940e6..0c9506e57e1e 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -15,6 +15,7 @@ import Database.PostgreSQL.Simple (Binary (Binary), Only (..)) import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.Types (PGArray (PGArray)) import FieldParser qualified as Field +import Http qualified import Json qualified import Label import MyPrelude @@ -522,47 +523,6 @@ httpTorrent span req = | code <- statusCode -> Left [fmt|Redacted returned an non-200 error code, code {code}: {resp & showPretty}|] ) -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 [fmt|Server returned an non-200 error code, code {code}: {resp & showPretty}|] - ) - >>= assertM - span - ( \body -> - Json.parseStrict parser body - & first (Json.parseErrorTree "could not parse redacted response") - ) - redactedApiRequestJson :: ( MonadThrow m, HasField "action" p ByteString, @@ -576,4 +536,4 @@ redactedApiRequestJson :: redactedApiRequestJson dat parser = do mkRedactedApiRequest dat - >>= httpJson defaults parser + >>= Http.httpJson defaults parser |