miragesdk: cleaner errors

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>

projects/miragesdk/src/sdk/ctl.ml

@@ -65,6 +65,9 @@ module Query = struct
     } [@@little_endian]
   ]
 
+  type error = [ `Eof | `Msg of string ]
+  let pp_error ppf t = Fmt.string ppf (match t with `Eof -> "EOF" | `Msg s -> s)
+
   (* to avoid warning 32 *)
   let _ = hexdump_msg
   let _ = string_to_operation
@@ -114,7 +117,7 @@ module Query = struct
     buf
 
   let err e = Lwt.return (Error (`Msg (Fmt.to_to_string C.pp_error e)))
-  let err_eof = Lwt.return (Error (`Msg "EOF"))
+  let err_eof = Lwt.return (Error `Eof)
 
   let read fd =
     let fd = C.create fd in
@@ -171,6 +174,9 @@ module Reply = struct
     } [@@little_endian]
   ]
 
+  type error = [ `Eof | `Msg of string ]
+  let pp_error ppf t = Fmt.string ppf (match t with `Eof -> "EOF" | `Msg s -> s)
+
   (* to avoid warning 32 *)
   let _ = hexdump_msg
   let _ = string_to_status
@@ -208,7 +214,7 @@ module Reply = struct
     buf
 
   let err e = Lwt.return (Result.Error (`Msg (Fmt.to_to_string C.pp_error e)))
-  let err_eof = Lwt.return (Result.Error (`Msg "EOF"))
+  let err_eof = Lwt.return (Result.Error `Eof)
 
   let read fd =
     let fd = C.create fd in
@@ -275,8 +281,9 @@ module Client = struct
         Lwt.return r
       with Not_found ->
         Reply.read t.fd >>= function
-        | Error (`Msg e) ->
-          Log.err (fun l -> l "Got %s while waiting for a reply to %ld" e id);
+        | Error e ->
+          Log.err (fun l -> l "Got %a while waiting for a reply to %ld"
+                      Query.pp_error e id);
           loop ()
         | Ok r ->
           if r.id = id then Lwt.return r
@@ -361,6 +368,7 @@ module Server = struct
     let cond = Lwt_condition.create () in
     let rec listen () =
       Query.read fd >>= function
+      | Error `Eof     -> Lwt.return_unit
       | Error (`Msg e) ->
         Log.err (fun l -> l "received invalid message: %s" e);
         listen ()

projects/miragesdk/src/sdk/ctl.mli

@@ -18,6 +18,12 @@ module Query: sig
     payload  : string;                                 (** Arbitrary payload. *)
   }
 
+  type error = [ `Eof | `Msg of string ]
+  (** The type of errors. *)
+
+  val pp_error: error Fmt.t
+  (** [pp_error] is the pretty-printer for query errors. *)
+
   val pp: t Fmt.t
   (** [pp] is the pretty-printer for queries. *)
 
@@ -31,7 +37,7 @@ module Query: sig
   val write: IO.flow -> t -> unit Lwt.t
   (** [write fd t] writes a query message. *)
 
-  val read: IO.flow -> (t, [`Msg of string]) result Lwt.t
+  val read: IO.flow -> (t, error) result Lwt.t
   (** [read fd] reads a query message. *)
 
 end
@@ -60,10 +66,16 @@ module Reply: sig
   val to_cstruct: t -> Cstruct.t
   (** [to_cstruct t] is the serialization of [t]. *)
 
+  type error = [`Eof | `Msg of string ]
+  (** The type for reply errors. *)
+
+  val pp_error: error Fmt.t
+  (** [pp_error] is the pretty-printer for errors. *)
+
   val write: IO.flow -> t -> unit Lwt.t
   (** [write fd t] writes a reply message. *)
 
-  val read: IO.flow -> (t, [`Msg of string]) result Lwt.t
+  val read: IO.flow -> (t, error) result Lwt.t
   (** [read fd] reads a reply message. *)
 
 end

projects/miragesdk/src/test/test.ml

@@ -123,14 +123,14 @@ let test_serialization to_cstruct of_cstruct message messages =
   in
   List.iter test messages
 
-let test_send t write read message messages =
+let test_send t write read message pp_error messages =
   let calf = calf Init.Pipe.(ctl t) in
   let priv = priv Init.Pipe.(ctl t) in
   let test m =
     write calf m >>= fun () ->
     read priv >|= function
     | Ok m'   -> Alcotest.(check message) "write/read" m m'
-    | Error (`Msg e) -> Alcotest.fail ("Message.read: " ^ e)
+    | Error e -> Fmt.kstrf Alcotest.fail "Message.read: %a" pp_error e
   in
   Lwt_list.iter_s test messages
 
@@ -144,11 +144,11 @@ let test_reply_serialization () =
 
 let test_query_send t () =
   let open Ctl.Query in
-  test_send t write read query queries
+  test_send t write read query pp_error queries
 
 let test_reply_send t () =
   let open Ctl.Reply in
-  test_send t write read reply replies
+  test_send t write read reply pp_error replies
 
 let failf fmt = Fmt.kstrf Alcotest.fail fmt