diff --git a/projects/miragesdk/src/sdk/ctl.ml b/projects/miragesdk/src/sdk/ctl.ml index 2d18f23f9..909ae8be0 100644 --- a/projects/miragesdk/src/sdk/ctl.ml +++ b/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 () diff --git a/projects/miragesdk/src/sdk/ctl.mli b/projects/miragesdk/src/sdk/ctl.mli index 2472e9897..6974e211a 100644 --- a/projects/miragesdk/src/sdk/ctl.mli +++ b/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 diff --git a/projects/miragesdk/src/test/test.ml b/projects/miragesdk/src/test/test.ml index fe86ea480..b90fa511d 100644 --- a/projects/miragesdk/src/test/test.ml +++ b/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) + | Ok m' -> Alcotest.(check message) "write/read" m m' + | 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