From 95d362ab7ecbce743251f04f4ee8bc7624317e24 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Fri, 7 Apr 2017 17:51:46 +0200
Subject: [PATCH] miragesdk: clean error handling for Sdk.Ctl.Client

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
---
 .../src/dhcp-client/calf/unikernel.ml         |  4 +--
 projects/miragesdk/src/sdk/ctl.ml             |  3 ++
 projects/miragesdk/src/sdk/ctl.mli            | 12 ++++++--
 projects/miragesdk/src/test/test.ml           | 28 ++++++++++---------
 4 files changed, 29 insertions(+), 18 deletions(-)

diff --git a/projects/miragesdk/src/dhcp-client/calf/unikernel.ml b/projects/miragesdk/src/dhcp-client/calf/unikernel.ml
index b023a2970..da1c38b7b 100644
--- a/projects/miragesdk/src/dhcp-client/calf/unikernel.ml
+++ b/projects/miragesdk/src/dhcp-client/calf/unikernel.ml
@@ -178,8 +178,8 @@ module Dhcp_client = Dhcp_client_mirage.Make(Time)(Net)
 let set_ip ctl k ip =
   let str = Ipaddr.V4.to_string ip ^ "\n" in
   Sdk.Ctl.Client.write ctl k str >>= function
-  | Ok ()           -> Lwt.return_unit
-  | Error (`Msg e) -> failf "error while writing %s: %s" k e
+  | Ok ()   -> Lwt.return_unit
+  | Error e -> failf "error while writing %s: %a" k Sdk.Ctl.Client.pp_error e
 
 let set_ip_opt ctl k = function
   | None    -> Lwt.return_unit
diff --git a/projects/miragesdk/src/sdk/ctl.ml b/projects/miragesdk/src/sdk/ctl.ml
index 909ae8be0..9fb640828 100644
--- a/projects/miragesdk/src/sdk/ctl.ml
+++ b/projects/miragesdk/src/sdk/ctl.ml
@@ -257,6 +257,9 @@ module Client = struct
 
   let version = 0l
 
+  type error = [`Msg of string]
+  let pp_error ppf (`Msg s) = Fmt.string ppf s
+
   module K = struct
     type t = int32
     let equal = Int32.equal
diff --git a/projects/miragesdk/src/sdk/ctl.mli b/projects/miragesdk/src/sdk/ctl.mli
index 6974e211a..2d05551d0 100644
--- a/projects/miragesdk/src/sdk/ctl.mli
+++ b/projects/miragesdk/src/sdk/ctl.mli
@@ -92,21 +92,27 @@ module Client: sig
   type t
   (** The type for client state. *)
 
+  type error
+  (** The type for client errors. *)
+
+  val pp_error: error Fmt.t
+  (** [pp_error] is the pretty-printer for client errors. *)
+
   val v: IO.t -> t
   (** [v fd] is the client state using [fd] to send requests to the
       server. A client state also stores some state for all the
       incomplete client queries. *)
 
-  val read: t -> string -> (string option, [`Msg of string]) result Lwt.t
+  val read: t -> string -> (string option, error) result Lwt.t
   (** [read t k] is the value associated with the key [k] in the
       control plane state. Return [None] if no value is associated to
       [k]. *)
 
-  val write: t -> string -> string -> (unit, [`Msg of string]) result Lwt.t
+  val write: t -> string -> string -> (unit, error) result Lwt.t
   (** [write t p v] associates [v] to the key [k] in the control plane
       state. *)
 
-  val delete: t -> string -> (unit, [`Msg of string]) result Lwt.t
+  val delete: t -> string -> (unit, error) result Lwt.t
   (** [delete t k] remove [k]'s binding in the control plane state. *)
 
 end
diff --git a/projects/miragesdk/src/test/test.ml b/projects/miragesdk/src/test/test.ml
index b90fa511d..d6f93989f 100644
--- a/projects/miragesdk/src/test/test.ml
+++ b/projects/miragesdk/src/test/test.ml
@@ -154,23 +154,25 @@ let failf fmt = Fmt.kstrf Alcotest.fail fmt
 
 (* read ops *)
 
+let pp_error = Ctl.Client.pp_error
+
 let read_should_err t k =
   Ctl.Client.read t k >|= function
-  | Error (`Msg _) -> ()
-  | Ok None        -> failf "read(%s) -> got: none, expected: err" k
-  | Ok Some v      -> failf "read(%s) -> got: found:%S, expected: err" k v
+  | Error _   -> ()
+  | Ok None   -> failf "read(%s) -> got: none, expected: err" k
+  | Ok Some v -> failf "read(%s) -> got: found:%S, expected: err" k v
 
 let read_should_none t k =
   Ctl.Client.read t k >|= function
-  | Error (`Msg e) -> failf "read(%s) -> got: error:%s, expected none" k e
-  | Ok None        -> ()
-  | Ok Some v      -> failf "read(%s) -> got: found:%S, expected none" k v
+  | Error e   -> failf "read(%s) -> got: error:%a, expected none" k pp_error e
+  | Ok None   -> ()
+  | Ok Some v -> failf "read(%s) -> got: found:%S, expected none" k v
 
 let read_should_work t k v =
   Ctl.Client.read t k >|= function
-  | Error (`Msg e) -> failf "read(%s) -> got: error:%s, expected ok" k e
-  | Ok None        -> failf "read(%s) -> got: none, expected ok" k
-  | Ok Some v'     ->
+  | Error e    -> failf "read(%s) -> got: error:%a, expected ok" k pp_error e
+  | Ok None    -> failf "read(%s) -> got: none, expected ok" k
+  | Ok Some v' ->
     if v <> v' then failf "read(%s) -> got: ok:%S, expected: ok:%S" k v' v
 
 (* write ops *)
@@ -182,8 +184,8 @@ let write_should_err t k v =
 
 let write_should_work t k v =
   Ctl.Client.write t k v >|= function
-  | Ok ()          -> ()
-  | Error (`Msg e) -> failf "write(%s) -> error: %s" k e
+  | Ok ()   -> ()
+  | Error e -> failf "write(%s) -> error: %a" k pp_error e
 
 (* del ops *)
 
@@ -194,8 +196,8 @@ let delete_should_err t k =
 
 let delete_should_work t k =
   Ctl.Client.delete t k >|= function
-  | Ok ()          -> ()
-  | Error (`Msg e) -> failf "write(%s) -> error: %s" k e
+  | Ok ()   -> ()
+  | Error e -> failf "write(%s) -> error: %a" k pp_error e
 
 let test_ctl t () =
   let calf = calf Init.Pipe.(ctl t) in