From 722499d8a9abee36e88bb7011ed25476523919cd Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 4 Jan 2025 21:45:23 +0100 Subject: [PATCH] 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 --- users/Profpatsch/my-prelude/default.nix | 1 + users/Profpatsch/my-prelude/my-prelude.cabal | 1 + users/Profpatsch/my-prelude/src/Debug.hs | 30 ++++++++++++ users/Profpatsch/my-prelude/src/Json.hs | 50 +++++++++++++++++++- users/Profpatsch/whatcd-resolver/src/Http.hs | 19 +++++--- 5 files changed, 94 insertions(+), 7 deletions(-) create mode 100644 users/Profpatsch/my-prelude/src/Debug.hs diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index 520ed6185..2bb9f7dad 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/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 diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal index 854390395..a01464857 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/users/Profpatsch/my-prelude/my-prelude.cabal @@ -62,6 +62,7 @@ library Arg AtLeast Comparison + Debug Json Json.Enc Test diff --git a/users/Profpatsch/my-prelude/src/Debug.hs b/users/Profpatsch/my-prelude/src/Debug.hs new file mode 100644 index 000000000..8e0af7395 --- /dev/null +++ b/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" "␉" diff --git a/users/Profpatsch/my-prelude/src/Json.hs b/users/Profpatsch/my-prelude/src/Json.hs index 3738ec6ad..1e0d14f05 100644 --- a/users/Profpatsch/my-prelude/src/Json.hs +++ b/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 diff --git a/users/Profpatsch/whatcd-resolver/src/Http.hs b/users/Profpatsch/whatcd-resolver/src/Http.hs index 14ce191d5..03b04d56b 100644 --- a/users/Profpatsch/whatcd-resolver/src/Http.hs +++ b/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) =>