feat(users/Profpatsch/whatcd-resolver): show json val on parse err

The json parsing library gives us an error path where the parse
failed, which means we can index into the path to show the json value
that failed us.

This can be quite expensive (and large!) of course, but the error
message clarity is worth it methinks.

Change-Id: Icacbd799254aaecd4a939ca13e6070d68a78138d
Reviewed-on: https://cl.tvl.fyi/c/depot/+/12952
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>

users/Profpatsch/my-prelude/default.nix

@@ -8,6 +8,7 @@ pkgs.haskellPackages.mkDerivation {
     ./my-prelude.cabal
     ./src/Aeson.hs
     ./src/Comparison.hs
+    ./src/Debug.hs
     ./src/Json.hs
     ./src/Json/Enc.hs
     ./src/Arg.hs

users/Profpatsch/my-prelude/my-prelude.cabal

@@ -62,6 +62,7 @@ library
       Arg
       AtLeast
       Comparison
+      Debug
       Json
       Json.Enc
       Test

users/Profpatsch/my-prelude/src/Debug.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Debug where
+
+import Data.Text qualified as Text
+import Data.Text.IO qualified as Text.IO
+import Debug.Trace as Debug
+import PossehlAnalyticsPrelude
+import Pretty qualified
+
+-- | 'Debug.trace' a showable value when (and only if!) it is evaluated, and pretty print it.
+traceShowPretty :: (Show a) => a -> a
+traceShowPretty a = Debug.trace (textToString $ Pretty.showPretty a) a
+
+-- | 'Debug.trace' a showable value when (and only if!) it is evaluated, and pretty print it. In addition, the given prefix is put before the value for easier recognition.
+traceShowPrettyPrefix :: (Show a) => Text -> a -> a
+traceShowPrettyPrefix prefix a = Debug.trace ([fmt|{prefix}: {Pretty.showPretty a}|]) a
+
+-- | Display non-printable characters as their unicode Control Pictures
+-- https://en.wikipedia.org/wiki/Unicode_control_characters#Control_pictures
+--
+-- Not all implemented.
+putStrLnShowNPr :: Text -> IO ()
+putStrLnShowNPr t =
+  Text.IO.putStrLn $
+    -- newlines will actually print a newline for convenience
+    t
+      & Text.replace "\n" "␤\n"
+      & Text.replace "\r\n" "␤\n"
+      & Text.replace "\t" "␉"

users/Profpatsch/my-prelude/src/Json.hs

@@ -6,6 +6,8 @@ module Json where
 import Data.Aeson (FromJSON (parseJSON), ToJSON (toEncoding, toJSON), Value (..), withObject)
 import Data.Aeson qualified as Json
 import Data.Aeson.BetterErrors qualified as Json
+import Data.Aeson.Key qualified as Key
+import Data.Aeson.KeyMap qualified as KeyMap
 import Data.Aeson.Types qualified
 import Data.Error.Tree
 import Data.Map.Strict qualified as Map
@@ -18,7 +20,8 @@ import Data.Vector qualified as Vector
 import FieldParser (FieldParser)
 import FieldParser qualified as Field
 import Label
-import PossehlAnalyticsPrelude
+import MyPrelude
+import Pretty
 
 -- | Use a "Data.Aeson.BetterErrors" parser to implement 'FromJSON'’s 'parseJSON' method.
 --
@@ -68,6 +71,51 @@ parseErrorTree contextMsg errs =
     & singleError
     & nestedError contextMsg
 
+-- | Convert a 'Json.ParseError' to a corresponding 'ErrorTree'
+--
+-- This version shows some of the value at the path where the error occurred.
+parseErrorTreeValCtx :: Error -> Json.Value -> Json.ParseError ErrorTree -> ErrorTree
+parseErrorTreeValCtx contextMsg origValue errs = do
+  let ctxPath = case errs of
+        Json.BadSchema path _spec -> Just path
+        _ -> Nothing
+  let getSubset (Json.Object o) (Json.ObjectKey k) = o & KeyMap.lookup (Key.fromText k)
+      getSubset (Json.Array a) (Json.ArrayIndex k) = a Vector.!? k
+      getSubset _ _ = Nothing
+  let go v = \case
+        IsEmpty -> v
+        IsNonEmpty (p :| path) -> case getSubset v p of
+          Nothing -> v
+          Just v' -> go v' path
+
+  ( ( errs
+        & Json.displayError prettyErrorTree
+        & Text.intercalate "\n"
+        & newError
+    )
+      :| ( maybe
+             []
+             ( \ctx ->
+                 [ go origValue ctx
+                     & Pretty.showPrettyJson
+                     & newError
+                 ]
+             )
+             ctxPath
+         )
+    )
+    -- We nest this here because the json errors is multiline, so the result looks like
+    --
+    -- @
+    -- contextMsg
+    -- \|
+    -- `- At the path: ["foo"]["bar"]
+    --   Type mismatch:
+    --   Expected a value of type object
+    --   Got: true
+    -- @
+    & errorTree contextMsg
+
 -- | Lift the parser error to an error tree
 asErrorTree :: (Functor m) => Json.ParseT Error m a -> Json.ParseT ErrorTree m a
 asErrorTree = Json.mapError singleError

users/Profpatsch/whatcd-resolver/src/Http.hs

@@ -19,6 +19,7 @@ module Http
 where
 
 import AppT
+import Data.Aeson qualified as Json
 import Data.Aeson.BetterErrors qualified as Json
 import Data.CaseInsensitive (CI (original))
 import Data.Char qualified as Char
@@ -93,12 +94,18 @@ httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do
                 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")
-      )
+    >>= \body -> do
+      val <-
+        Json.eitherDecodeStrict body
+          & first (\err -> AppExceptionTree $ nestedError "HTTP response was not valid JSON" (err & stringToText & newError & singleError))
+          & orAppThrow span
+
+      let res = Json.parseValue parser val
+      case res of
+        Left e -> do
+          let prettyErr = Json.parseErrorTreeValCtx "could not parse HTTP response" val e
+          appThrow span (AppExceptionTree prettyErr)
+        Right a -> pure a
 
 doRequestJson ::
   (MonadOtel m) =>