From a74d86fe4ee9ae7bddab7a7b8e3f32dd2e24dbd1 Mon Sep 17 00:00:00 2001 From: Ali Caglayan Date: Thu, 17 Aug 2023 01:58:36 +0100 Subject: [PATCH] test: serialize and deserialize RPC error messages We demonstrate a bug with how error messages are serialized. Currently there are two "Error:" prefixes after serializing and deserializing. This is because the prefix hasn't been stripped in the initial serialization. We should strip the prefix since the severity information is recorded elsewhere in the diagnostic data. Signed-off-by: Ali Caglayan --- otherlibs/stdune/src/stdune.ml | 26 ++ otherlibs/stdune/src/user_message.ml | 17 ++ otherlibs/stdune/src/user_message.mli | 1 + src/dune_engine/build_system.ml | 8 + src/dune_engine/build_system.mli | 15 + src/dune_rpc_impl/dune_rpc_impl.ml | 6 + test/expect-tests/dune_rpc_impl/dune | 27 ++ .../dune_rpc_impl/dune_rpc_impl_tests.ml | 259 ++++++++++++++++++ 8 files changed, 359 insertions(+) create mode 100644 test/expect-tests/dune_rpc_impl/dune create mode 100644 test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml diff --git a/otherlibs/stdune/src/stdune.ml b/otherlibs/stdune/src/stdune.ml index 8228003bf741..6ae63cd37e3e 100644 --- a/otherlibs/stdune/src/stdune.ml +++ b/otherlibs/stdune/src/stdune.ml @@ -30,6 +30,32 @@ module Pp = struct let compare ~compare x y = Ordering.of_int (Pp.compare (fun a b -> Ordering.to_int (compare a b)) x y) ;; + + let to_dyn tag_to_dyn t = + match Pp.to_ast t with + | Error _ -> Dyn.variant "Contains Format" [ Dyn.opaque "" ] + | Ok t -> + let open Dyn in + let rec to_dyn t = + match (t : _ Pp.Ast.t) with + | Nop -> variant "Nop" [] + | Seq (x, y) -> variant "Seq" [ to_dyn x; to_dyn y ] + | Concat (x, y) -> variant "Concat" [ to_dyn x; list to_dyn y ] + | Box (i, t) -> variant "Box" [ int i; to_dyn t ] + | Vbox (i, t) -> variant "Vbox" [ int i; to_dyn t ] + | Hbox t -> variant "Hbox" [ to_dyn t ] + | Hvbox (i, t) -> variant "Hvbox" [ int i; to_dyn t ] + | Hovbox (i, t) -> variant "Hovbox" [ int i; to_dyn t ] + | Verbatim s -> variant "Verbatim" [ string s ] + | Char c -> variant "Char" [ char c ] + | Break (x, y) -> + variant "Break" [ triple string int string x; triple string int string y ] + | Newline -> variant "Newline" [] + | Text s -> variant "Text" [ string s ] + | Tag (s, t) -> variant "Tag" [ tag_to_dyn s; to_dyn t ] + in + to_dyn t + ;; end module Result = Result diff --git a/otherlibs/stdune/src/user_message.ml b/otherlibs/stdune/src/user_message.ml index c6ed4cd92486..f72e31973bf9 100644 --- a/otherlibs/stdune/src/user_message.ml +++ b/otherlibs/stdune/src/user_message.ml @@ -13,6 +13,23 @@ module Style = struct | Success | Ansi_styles of Ansi_color.Style.t list + let to_dyn = + let open Dyn in + function + | Loc -> variant "Loc" [] + | Error -> variant "Error" [] + | Warning -> variant "Warning" [] + | Kwd -> variant "Kwd" [] + | Id -> variant "Id" [] + | Prompt -> variant "Prompt" [] + | Hint -> variant "Hint" [] + | Details -> variant "Details" [] + | Ok -> variant "Ok" [] + | Debug -> variant "Debug" [] + | Success -> variant "Success" [] + | Ansi_styles l -> variant "Ansi_styles" [ list Ansi_color.Style.to_dyn l ] + ;; + let compare t1 t2 : Ordering.t = match t1, t2 with | Loc, Loc -> Eq diff --git a/otherlibs/stdune/src/user_message.mli b/otherlibs/stdune/src/user_message.mli index 64ba91b2dd92..c618d801e24b 100644 --- a/otherlibs/stdune/src/user_message.mli +++ b/otherlibs/stdune/src/user_message.mli @@ -22,6 +22,7 @@ module Style : sig | Success | Ansi_styles of Ansi_color.Style.t list + val to_dyn : t -> Dyn.t val compare : t -> t -> Ordering.t end diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 8b59841ee042..512b57b488ce 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -92,6 +92,14 @@ module Error = struct | Diagnostic d -> `Diagnostic d.diagnostic ;; + module For_tests = struct + let make ~id ~description ~dir ~promotion () = + match description with + | `Exn exn -> Exn { id; exn } + | `Diagnostic diagnostic -> Diagnostic { id; diagnostic; dir; promotion } + ;; + end + module Set : sig type error := t diff --git a/src/dune_engine/build_system.mli b/src/dune_engine/build_system.mli index c86e939d053a..7fdcce78c653 100644 --- a/src/dune_engine/build_system.mli +++ b/src/dune_engine/build_system.mli @@ -88,6 +88,7 @@ module Error : sig module Map : Map.S with type key = t + val gen : unit -> t val compare : t -> t -> Ordering.t val to_int : t -> int val to_dyn : t -> Dyn.t @@ -126,6 +127,20 @@ module Error : sig val current : t -> error Id.Map.t val empty : t end + + module For_tests : sig + (** Internal helpers for testing purposes. Do not use. *) + + (** Construct an [Error.t] *) + val make + : id:Id.t + -> description: + [ `Exn of Exn_with_backtrace.t | `Diagnostic of Compound_user_error.t ] + -> dir:Path.t option + -> promotion:Diff_promotion.Annot.t option + -> unit + -> t + end end (** The current set of active errors. *) diff --git a/src/dune_rpc_impl/dune_rpc_impl.ml b/src/dune_rpc_impl/dune_rpc_impl.ml index a6eb06bdde2a..c685ca918576 100644 --- a/src/dune_rpc_impl/dune_rpc_impl.ml +++ b/src/dune_rpc_impl/dune_rpc_impl.ml @@ -6,6 +6,12 @@ module Private = Dune_rpc_client.Private module Watch_mode_config = Watch_mode_config module Where = Dune_rpc_client.Where +module Diagnostics = struct + module For_tests = struct + let diagnostic_of_error = Diagnostics.diagnostic_of_error + end +end + module Poll_active = Dune_rpc_private.Registry.Poll (Fiber) diff --git a/test/expect-tests/dune_rpc_impl/dune b/test/expect-tests/dune_rpc_impl/dune new file mode 100644 index 000000000000..ff44cc6e4d8d --- /dev/null +++ b/test/expect-tests/dune_rpc_impl/dune @@ -0,0 +1,27 @@ +(library + (name dune_rpc_impl_tests) + (modules dune_rpc_impl_tests) + (inline_tests) + (libraries + ocaml_config + dune_util + dune_console + dune_rpc_private + dune_rpc_server + dune_rpc_impl + dune_rpc_client + dune_engine + dune_re + stdune + test_scheduler + csexp + fiber + ;; This is because of the (implicit_transitive_deps false) + ;; in dune-project + ppx_expect.config + ppx_expect.config_types + ppx_expect.common + base + ppx_inline_test.config) + (preprocess + (pps ppx_expect))) diff --git a/test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml b/test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml new file mode 100644 index 000000000000..a9b8bd7ceb0a --- /dev/null +++ b/test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml @@ -0,0 +1,259 @@ +open! Stdune +open! Fiber.O +module Dune_rpc = Dune_rpc_private +module Re = Dune_re + +let () = + Stdune.Path.set_root (Stdune.Path.External.of_filename_relative_to_initial_cwd "."); + Stdune.Path.Build.set_build_dir (Stdune.Path.Outside_build_dir.of_string "_build") +;; + +let test ~dir ~f main = + let id = Dune_engine.Build_system.Error.Id.gen () in + let description = + `Diagnostic (Dune_engine.Compound_user_error.make ~main ~related:[]) + in + Dune_console.printf "---- Original ----"; + f main; + Dune_console.printf "------- RPC ------"; + Dune_engine.Build_system.Error.For_tests.make ~id ~description ~dir ~promotion:None () + |> Dune_rpc_impl.Diagnostics.For_tests.diagnostic_of_error + |> Dune_rpc_private.Diagnostic.to_user_message + |> f +;; + +let test_plain ~dir main = test main ~dir ~f:Dune_console.print_user_message + +let test_dyn ~dir main = + test main ~dir ~f:(fun x -> + Stdune.User_message.pp x + |> Pp.to_dyn Stdune.User_message.Style.to_dyn + |> Dyn.to_string + |> print_endline) +;; + +let scrub output = + Re.replace_string + (Re.compile (Re.str Stdune.Path.(to_absolute_filename root))) + ~by:"TEST" + output + |> print_endline +;; + +let%expect_test "serialize and deserialize error message" = + let dir = None in + let message = User_error.make [ Pp.verbatim "Oh no!" ] in + test_plain ~dir message; + test_dyn ~dir message; + [%expect + {| + ---- Original ---- + Error: Oh no! + ------- RPC ------ + Error: Error: Oh no! + ---- Original ---- + Vbox + 0,Seq + Box + 0,Concat + Break ("", 1, ""),("", 0, ""),[ Seq + Tag Error,Verbatim "Error", + Char + : + ; Verbatim "Oh no!" + ],Break ("", 0, ""),("", 0, "") + ------- RPC ------ + Vbox + 0,Seq + Box + 0,Concat + Break ("", 1, ""),("", 0, ""),[ Tag Error,Text "Error:" + ; Concat + Break ("", 1, ""),("", 0, ""), + [ Seq + Tag + Details,Verbatim "Error", + Char + : + ; Verbatim "Oh no!" + ] + ],Break ("", 0, ""),("", 0, "") |}] +;; + +let%expect_test "serialize and deserialize error message with location" = + let loc = Stdune.Loc.of_pos ("Bar", 1, 2, 3) in + let dir = Some (Stdune.Path.of_string "/Foo") in + let message = User_error.make ~loc [ Pp.verbatim "An error with location!" ] in + test_plain ~dir message; + test_dyn ~dir message; + [%expect + {| + ---- Original ---- + File "Bar", line 1, characters 2-3: + Error: An error with location! + ------- RPC ------ + Error: (In directory /Foo) + File "/Foo/Bar", line 1, characters 2-3: + + Error: An error with location! + ---- Original ---- + Vbox + 0,Concat + Nop,[ Seq + Box 0,Tag Loc,Text "File \"Bar\", line 1, characters 2-3:", + Break + ("", 0, ""),("", 0, "") + ; Seq + Box + 0,Concat + Break ("", 1, ""),("", 0, ""),[ Seq + Tag + Error,Verbatim + "Error", + Char + : + ; Verbatim + "An error with location!" + ],Break + ("", 0, ""),("", 0, "") + ] + ------- RPC ------ + Vbox + 0,Concat + Nop,[ Seq + Box + 0,Concat + Break ("", 1, ""),("", 0, ""),[ Tag Error,Text "Error:" + ; Tag + Loc,Text + "(In directory /Foo)" + ],Break + ("", 0, ""),("", 0, "") + ; Seq + Box + 0,Seq + Seq + Tag + Loc,Verbatim + "File \"/Foo/Bar\", line 1, characters 2-3:",Newline,Nop, + Break + ("", 0, ""),("", 0, "") + ; Seq + Box + 0,Concat + Break ("", 1, ""),("", 0, ""),[ Seq + Tag + Details,Verbatim + "Error", + Char + : + ; Verbatim + "An error with location!" + ],Break + ("", 0, ""),("", 0, "") + ] |}] +;; + +let%expect_test "serialize and deserialize error with location exerpt and hint" = + Io.String_path.write_file "foo.ml" "let x = 1\nlet y = 2\nlet z = 3\n"; + let loc = Stdune.Loc.of_pos ("foo.ml", 1, 2, 3) in + let dir = Some (Stdune.Path.of_string ".") in + let hints = [ Pp.verbatim "Hint 1"; Pp.verbatim "Hint 2" ] in + let message = User_error.make ~loc ~hints [ Pp.verbatim "An error with location!" ] in + test_plain ~dir message; + test_dyn ~dir message; + scrub [%expect.output]; + [%expect + {| + ---- Original ---- + File "foo.ml", line 1, characters 2-3: + 1 | let x = 1 + ^ + Error: An error with location! + Hint: Hint 1 + Hint: Hint 2 + ------- RPC ------ + Error: (In directory + TEST) + File "TEST/foo.ml", line 1, characters 2-3: + 1 | let x = 1 + ^ + + Error: An error with location! + ---- Original ---- + Vbox + 0,Concat + Nop,[ Seq + Box 0,Tag Loc,Text "File \"foo.ml\", line 1, characters 2-3:", + Break + ("", 0, ""),("", 0, "") + ; Seq + Box + 0,Concat + Break ("", 1, ""),("", 0, ""),[ Seq + Tag + Error,Verbatim + "Error", + Char + : + ; Verbatim + "An error with location!" + ],Break + ("", 0, ""),("", 0, "") + ; Seq + Box + 0,Seq + Seq + Tag Hint,Verbatim "Hint:",Break ("", 1, ""),("", 0, ""), + Verbatim + "Hint 1",Break ("", 0, ""),("", 0, "") + ; Seq + Box + 0,Seq + Seq + Tag Hint,Verbatim "Hint:",Break ("", 1, ""),("", 0, ""), + Verbatim + "Hint 2",Break ("", 0, ""),("", 0, "") + ] + ------- RPC ------ + Vbox + 0,Concat + Nop,[ Seq + Box + 0,Concat + Break ("", 1, ""),("", 0, ""),[ Tag Error,Text "Error:" + ; Tag + Loc,Text + "(In directory TEST)" + ],Break + ("", 0, ""),("", 0, "") + ; Seq + Box + 0,Seq + Seq + Tag + Loc,Verbatim + "File \"TEST/foo.ml\", line 1, characters 2-3:",Newline, + Seq + Seq + Seq + Seq + Seq Verbatim "1",Verbatim " | ",Verbatim + "let x = 1",Newline, + Verbatim + " ^",Newline,Break ("", 0, ""),("", 0, "") + ; Seq + Box + 0,Concat + Break ("", 1, ""),("", 0, ""),[ Seq + Tag + Details,Verbatim + "Error", + Char + : + ; Verbatim + "An error with location!" + ],Break + ("", 0, ""),("", 0, "") + ] |}] +;;