Http errors with more info

Makefile

@@ -17,6 +17,9 @@ nri-http/nri-http.cabal: nri-http/package.yaml
 ghcid-nri-http: nri-http/nri-http.cabal
 	cd nri-http && ghcid
 
+ghcid-nri-http-test: nri-http/nri-http.cabal
+	cd nri-http && ghcid --command "cabal repl nri-http:test:spec" --test Main.main
+
 nri-kafka/nri-kafka.cabal: nri-kafka/package.yaml
 	hpack nri-kafka
 

cabal.project

@@ -8,3 +8,5 @@ packages:
   nri-http/nri-http.cabal
   nri-postgresql/nri-postgresql.cabal
   nri-kafka/nri-kafka.cabal
+
+tests: True

nri-http/nri-http.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           nri-http
-version:        0.7.0.0
+version:        0.8.0.0
 synopsis:       Make Elm style HTTP requests
 description:    Please see the README at <https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-http#readme>.
 category:       Web
@@ -98,7 +98,7 @@ test-suite spec
       TypeOperators
       ExtendedDefaultRules
       NumericUnderscores
-  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fplugin=NriPrelude.Plugin -fno-warn-type-defaults
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fplugin=NriPrelude.Plugin -threaded -fno-warn-type-defaults
   build-depends:
       aeson >=2.0 && <2.3
     , base >=4.18 && <4.22
@@ -110,10 +110,10 @@ test-suite spec
     , http-types ==0.12.*
     , mime-types >=0.1.0.0 && <0.2
     , network-uri >=2.6.0.0 && <2.8
-    , nri-observability >=0.1.0.0 && <0.4
+    , nri-observability >=0.1.0.0 && <0.5
     , nri-prelude >=0.1.0.0 && <0.7
     , safe-exceptions >=0.1.7.0 && <1.3
     , text >=1.2.3.1 && <2.2
     , wai >=3.2.0 && <3.3
-    , warp >=3.3.0 && <3.4
+    , warp >=3.3.0 && <3.5
   default-language: Haskell2010

nri-http/package.yaml

@@ -2,7 +2,7 @@ name: nri-http
 synopsis: Make Elm style HTTP requests
 description: Please see the README at <https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-http#readme>.
 author: NoRedInk
-version: 0.7.0.0
+version: 0.8.0.0
 maintainer: haskell-open-source@noredink.com
 copyright: 2024 NoRedInk Corp.
 github: NoRedInk/haskell-libraries/nri-http
@@ -39,7 +39,7 @@ tests:
       - base >= 4.18 && < 4.22
       - bytestring >= 0.10.8.2 && < 0.13
       - nri-prelude >= 0.1.0.0 && < 0.7
-      - nri-observability >= 0.1.0.0 && < 0.4
+      - nri-observability >= 0.1.0.0 && < 0.5
       - conduit >= 1.3.0 && < 1.4
       - case-insensitive >= 1.1 && < 2.0
       - http-client >= 0.6.0 && < 0.8
@@ -50,16 +50,16 @@ tests:
       - safe-exceptions >= 0.1.7.0 && < 1.3
       - text >= 1.2.3.1 && < 2.2
       - wai >= 3.2.0 && < 3.3
-      - warp >= 3.3.0 && < 3.4
+      - warp >= 3.3.0 && < 3.5
     main: Main.hs
     source-dirs:
       - src
       - test
-    # We intentionally do not add threaded ghc-options for tests. These would
-    # cause tests to run in parallel, which introduces flakiness in this test
-    # suite. The suite creates a number of web servers that are supposed to get
-    # unique ports, but if we start them in parallel this will not always work.
+    # Note: We used to intentionally not include -threaded here to avoid flakiness in the tests
+    # At some point tests stopped working completely without -threaded tho.
+    # See blame history for context.
     ghc-options:
+      - -threaded
       - -fno-warn-type-defaults
 default-extensions:
   - DataKinds

nri-http/src/Http.hs

@@ -19,6 +19,7 @@ module Http
     Internal.Request' (..),
     Internal.Request,
     Internal.Error (..),
+    Internal.BadBodyReason (..),
 
     -- * Header
     Internal.Header,
@@ -60,6 +61,7 @@ import qualified Data.CaseInsensitive as CI
 import qualified Data.Dynamic as Dynamic
 import Data.String (fromString)
 import qualified Data.Text.Encoding
+import qualified Data.Text.Encoding.Error
 import qualified Data.Text.Lazy
 import qualified Data.Text.Lazy.Encoding
 import Data.Version (showVersion)
@@ -261,7 +263,15 @@ handleResponse expect response =
        in case expect of
             Internal.ExpectJson ->
               case Aeson.eitherDecode bytes of
-                Left err -> Err (Internal.BadBody (Text.fromList err))
+                Left err ->
+                  Err
+                    ( Internal.BadBody <|
+                        Internal.BadBodyReason
+                          { Internal.decodingError = Text.fromList err,
+                            Internal.responseMetadata = mkMetadata okResponse,
+                            Internal.responseBody = Data.Text.Lazy.toStrict <| Data.Text.Lazy.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode bytes
+                          }
+                    )
                 Right x -> Ok x
             Internal.ExpectText -> Ok (Data.Text.Lazy.toStrict <| Data.Text.Lazy.Encoding.decodeUtf8 bytes)
             Internal.ExpectWhatever -> Ok ()
@@ -291,12 +301,18 @@ exceptionToError exception =
       Internal.BadUrl (Text.fromList message)
     HTTP.HttpExceptionRequest _ content ->
       case content of
-        HTTP.StatusCodeException res _ ->
-          res
-            |> HTTP.responseStatus
-            |> Status.statusCode
-            |> fromIntegral
-            |> Internal.BadStatus
+        HTTP.StatusCodeException res startOfBody ->
+          let body =
+                startOfBody
+                  |> Data.ByteString.Lazy.fromStrict
+                  |> Data.Text.Lazy.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode
+                  |> Data.Text.Lazy.toStrict
+              statusCode =
+                res
+                  |> HTTP.responseStatus
+                  |> Status.statusCode
+                  |> fromIntegral
+           in Internal.BadStatus statusCode body
         HTTP.ResponseTimeout ->
           Internal.Timeout
         HTTP.ConnectionTimeout ->

nri-http/src/Http/Internal.hs

@@ -66,20 +66,29 @@ data Expect' x a where
 -- - 'BadUrl' means you did not provide a valid URL.
 -- - 'Timeout' means it took too long to get a response.
 -- - 'NetworkError' means the user turned off their wifi, went in a cave, etc.
--- - 'BadStatus' means you got a response back, but the status code indicates failure.
--- - 'BadBody' means you got a response back with a nice status code, but the body of the response was something unexpected. The 'Text' in this cse is the debugging message that explains what went wrong with your JSONT decoder or whatever.
+-- - 'BadStatus' means you got a response back, but the status code indicates failure. Includes the status code and the beginning of the response body.
+-- - 'BadBody' means you got a response back with a nice status code, but the body of the response was something unexpected. The 'BadBodyReason' contains the decoding error, response metadata, and response body for debugging. These values may include sensitive information (for example, authentication headers or PII), so take care not to log or expose them without appropriate redaction or truncation.
 data Error
   = BadUrl Text
   | Timeout
   | NetworkError Text
-  | BadStatus Int
-  | BadBody Text
+  | BadStatus Int Text
+  | BadBody BadBodyReason
   deriving (Generic, Eq, Show)
 
 instance Exception.Exception Error
 
 instance Aeson.ToJSON Error
 
+data BadBodyReason = BadBodyReason
+  { decodingError :: Text,
+    responseMetadata :: Metadata,
+    responseBody :: Text
+  }
+  deriving (Generic, Eq, Show)
+
+instance Aeson.ToJSON BadBodyReason
+
 -- | A 'Response' can come back a couple different ways:
 --
 -- - 'BadUrl_' — you did not provide a valid URL.

nri-http/test/Main.hs

@@ -42,7 +42,7 @@ tests =
                 Http.get http url Http.expectWhatever
                   |> Expect.fails
               err
-                |> Expect.equal (Http.BadStatus 400)
+                |> Expect.equal (Http.BadStatus 400 "")
           ),
       test "Given a request made using `get` that expects a JSON response when the response includes the right JSON it is returned decoded" <| \() ->
         withServer
@@ -61,8 +61,17 @@ tests =
               err <-
                 Http.get http url (Http.expectJson :: Http.Expect Text)
                   |> Expect.fails
-              err
-                |> Expect.equal (Http.BadBody "Error in $: parsing Text failed, expected String, but encountered Number")
+              case err of
+                Http.BadBody reason -> do
+                  Http.decodingError reason
+                    |> Expect.equal "Error in $: parsing Text failed, expected String, but encountered Number"
+                  Http.responseBody reason
+                    |> Expect.equal "12"
+                  Http.responseMetadata reason
+                    |> Http.metadataStatusCode
+                    |> Expect.equal 200
+                other ->
+                  Expect.fail <| "Expected BadBody, got: " ++ (Text.fromList <| Prelude.show other)
           ),
       test "When a request is made using `get` to an invalid URL we fail with a BadUrl error" <| \() ->
         withServer
@@ -75,7 +84,7 @@ tests =
                 |> Expect.equal (Http.BadUrl "Invalid URL")
           ),
       test "When a request is made using `get` with a json body the `Content-Type` header is set to `application/json`" <| \() -> do
-        request <-
+        (request, _body) <-
           expectRequest
             ( \http url ->
                 Http.post http url (Http.jsonBody ()) Http.expectWhatever
@@ -85,15 +94,14 @@ tests =
           |> Data.List.lookup "content-type"
           |> Expect.equal (Just "application/json"),
       test "When a request is made using `get` with a json body the JSON is encoded correctly" <| \() -> do
-        request <-
+        (_request, body) <-
           expectRequest
             ( \http url ->
                 Http.post http url (Http.jsonBody [1, 2, 3 :: Int]) Http.expectWhatever
             )
-        body <- Expect.fromIO (Wai.strictRequestBody request)
         Expect.equal "[1,2,3]" body,
       test "When a request is made using `get` with a string body the `Content-Type` header is set to provided mime type" <| \() -> do
-        request <-
+        (request, _body) <-
           expectRequest
             ( \http url ->
                 Http.post http url (Http.stringBody "element/fire" "WOOSH") Http.expectWhatever
@@ -211,18 +219,20 @@ withServerIO log app run = do
 -- immediately returns that request so you can run expectations against it.
 --
 -- Useful if you want to check properties of requests you send.
-expectRequest :: (Show e) => (Http.Handler -> Text -> Task e a) -> Expect.Expectation' Wai.Request
+expectRequest :: (Show e) => (Http.Handler -> Text -> Task e a) -> Expect.Expectation' (Wai.Request, Data.ByteString.Lazy.ByteString)
 expectRequest run = do
-  let app req _respond = Exception.throwIO (FirstRequest req)
+  let app req _respond = do
+        body <- Wai.strictRequestBody req
+        Exception.throwIO (FirstRequest req body)
   log <- Expect.succeeds Platform.logHandler
   either <- Expect.fromIO <| Exception.try (withServerIO log app run)
   Expect.succeeds <|
     case either of
-      Prelude.Left (FirstRequest req) -> Task.succeed req
+      Prelude.Left (FirstRequest req body) -> Task.succeed (req, body)
       Prelude.Right (Ok _) -> Task.fail "Expected a request, but none was received."
       Prelude.Right (Err err) -> Task.fail (Debug.toString err)
 
-newtype FirstRequest = FirstRequest Wai.Request deriving (Show)
+data FirstRequest = FirstRequest Wai.Request Data.ByteString.Lazy.ByteString deriving (Show)
 
 instance Exception.Exception FirstRequest
 

nri-http/test/golden-results-9.8/expected-http-span

@@ -6,12 +6,12 @@ TracingSpan
       Just
         ( "rootTracingSpanIO"
         , SrcLoc
-            { srcLocPackage = "nri-http-0.6.0.0-inplace-spec"
+            { srcLocPackage = "nri-http-0.8.0.0-inplace-spec"
             , srcLocModule = "Main"
             , srcLocFile = "test/Main.hs"
-            , srcLocStartLine = 234
+            , srcLocStartLine = 244
             , srcLocStartCol = 7
-            , srcLocEndLine = 234
+            , srcLocEndLine = 244
             , srcLocEndCol = 33
             }
         )
@@ -29,12 +29,12 @@ TracingSpan
               Just
                 ( "tracingSpanIO"
                 , SrcLoc
-                    { srcLocPackage = "nri-http-0.6.0.0-inplace-spec"
+                    { srcLocPackage = "nri-http-0.8.0.0-inplace-spec"
                     , srcLocModule = "Http"
                     , srcLocFile = "src/Http.hs"
-                    , srcLocStartLine = 433
+                    , srcLocStartLine = 484
                     , srcLocStartCol = 11
-                    , srcLocEndLine = 433
+                    , srcLocEndLine = 484
                     , srcLocEndCol = 33
                     }
                 )