From 5f3615debc05453a5b9d1577cbaa45cbd8f9210b Mon Sep 17 00:00:00 2001
From: Alain Mebsout <alain.mebsout@functori.com>
Date: Mon, 23 May 2022 21:10:21 +0200
Subject: [PATCH 1/2] RPC: Pretty print conflicts at registration time

---
 src/lib_rpc/RPC_directory.ml | 64 ++++++++++++++++++++++++++++++++++++
 1 file changed, 64 insertions(+)

diff --git a/src/lib_rpc/RPC_directory.ml b/src/lib_rpc/RPC_directory.ml
index b8232a933231..faa4aff09836 100644
--- a/src/lib_rpc/RPC_directory.ml
+++ b/src/lib_rpc/RPC_directory.ml
@@ -26,6 +26,70 @@
 open Error_monad
 include Resto_directory.Make (RPC_encoding)
 
+let string_of_step = function
+  | Static s -> s
+  | Dynamic arg -> Format.sprintf "<%s>" arg.name
+  | DynamicTail arg -> Format.sprintf "<%s...>" arg.name
+
+let pp_confict_kind ppf = function
+  | CDir -> Format.pp_print_string ppf "Dir conflict"
+  | CBuilder -> Format.pp_print_string ppf "Builder conflict"
+  | CTail -> Format.pp_print_string ppf "Tail conflict"
+  | CService meth ->
+      Format.fprintf ppf "Method conflict for %s" (Resto.string_of_meth meth)
+  | CTypes (arg1, arg2) ->
+      Format.fprintf
+        ppf
+        "Type conflict for argument %s with argument %s"
+        arg1.name
+        arg2.name
+  | CType (arg, names) ->
+      Format.fprintf
+        ppf
+        "Type conflict for %s with argument %s"
+        (String.concat ", " names)
+        arg.name
+
+let pp_conflict ppf (steps, kind) =
+  Format.fprintf
+    ppf
+    "%a in /%s"
+    pp_confict_kind
+    kind
+    (String.concat "/" @@ List.map string_of_step steps)
+
+let rec pp_path :
+    type a b. Format.formatter -> (a, b) Resto.Internal.path -> unit =
+ fun ppf -> function
+  | Root -> ()
+  | Static (p, s) -> Format.fprintf ppf "%a/%s" pp_path p s
+  | Dynamic (p, arg) -> Format.fprintf ppf "%a/<%s>" pp_path p arg.descr.name
+  | DynamicTail (p, arg) ->
+      Format.fprintf ppf "%a/<%s...>" pp_path p arg.descr.name
+
+(* TODO: https://gitlab.com/nomadic-labs/resto/-/issues/3
+   Use printing from Resto when available.*)
+let pp_service ppf service =
+  let iservice = Service.Internal.to_service service in
+  Format.fprintf
+    ppf
+    "%s %a (%s)"
+    (Resto.string_of_meth iservice.meth)
+    pp_path
+    iservice.path
+    (Option.value ~default:"" iservice.description)
+
+let register dir service handler =
+  try register dir service handler
+  with Conflict (steps, conflict) as e ->
+    Format.eprintf
+      "@[<v 2>Error in registration of service %a:@ %a@]@."
+      pp_service
+      service
+      pp_conflict
+      (steps, conflict) ;
+    raise e
+
 let gen_register dir service handler =
   register dir service (fun p q i ->
       Lwt.catch
-- 
GitLab


From 4bfd53b4b3754ecbb231bd230aaf816687ba7d17 Mon Sep 17 00:00:00 2001
From: Alain Mebsout <alain.mebsout@functori.com>
Date: Wed, 1 Jun 2022 10:47:32 +0200
Subject: [PATCH 2/2] fixup! RPC: Pretty print conflicts at registration time

---
 src/lib_rpc/RPC_directory.ml | 24 ++++++++++++++++--------
 1 file changed, 16 insertions(+), 8 deletions(-)

diff --git a/src/lib_rpc/RPC_directory.ml b/src/lib_rpc/RPC_directory.ml
index faa4aff09836..0d594e6bfe15 100644
--- a/src/lib_rpc/RPC_directory.ml
+++ b/src/lib_rpc/RPC_directory.ml
@@ -79,16 +79,24 @@ let pp_service ppf service =
     iservice.path
     (Option.value ~default:"" iservice.description)
 
+exception Directory_conflict of string * step list * conflict
+
+let () =
+  Printexc.register_printer @@ function
+  | Directory_conflict (service, steps, conflict) ->
+      Format.kasprintf
+        Option.some
+        "Conflict in registration of service %s:\n%a"
+        service
+        pp_conflict
+        (steps, conflict)
+  | _ -> None
+
 let register dir service handler =
   try register dir service handler
-  with Conflict (steps, conflict) as e ->
-    Format.eprintf
-      "@[<v 2>Error in registration of service %a:@ %a@]@."
-      pp_service
-      service
-      pp_conflict
-      (steps, conflict) ;
-    raise e
+  with Conflict (steps, conflict) ->
+    let service_str = Format.asprintf "%a" pp_service service in
+    raise (Directory_conflict (service_str, steps, conflict))
 
 let gen_register dir service handler =
   register dir service (fun p q i ->
-- 
GitLab