Merge pull request #1543 from samoht/mac

miragesdk: do not generate a random mac

projects/miragesdk/examples/mirage-dhcp.yml

@@ -2,10 +2,13 @@ kernel:
   image: "mobylinux/kernel:4.9.x"
   cmdline: "console=ttyS0 page_poison=1"
 init:
-  - "mobylinux/init:9d755f7e7d108d523448e4a503f1613b7d870389@sha256:9ccb16f2d8b3a09d12f5459106763f1836c064e420a13360e2e25599337960dc"
+  - mobylinux/init:286e9864b12beaff71b06809b6f0d832b6408eb5 # base init + strace + git
+  - mobylinux/runc:b0fb122e10dbb7e4e45115177a61a3f8d68c19a9
+  - mobylinux/containerd:18eaf72f3f4f9a9f29ca1951f66df701f873060b
+  - mobylinux/ca-certificates:eabc5a6e59f05aa91529d80e9a595b85b046f935
 onboot:
   - name: sysctl
-    image: "mobylinux/sysctl:2cf2f9d5b4d314ba1bfc22b2fe931924af666d8c"
+    image: mobylinux/sysctl:2cf2f9d5b4d314ba1bfc22b2fe931924af666d8c
     net: host
     pid: host
     ipc: host
@@ -13,19 +16,19 @@ onboot:
      - CAP_SYS_ADMIN
     readonly: true
   - name: binfmt
-    image: "mobylinux/binfmt:bdb754f25a5d851b4f5f8d185a43dfcbb3c22d01"
+    image: mobylinux/binfmt:bdb754f25a5d851b4f5f8d185a43dfcbb3c22d01
     binds:
      - /proc/sys/fs/binfmt_misc:/binfmt_misc
     readonly: true
 services:
   - name: rngd
-    image: "mobylinux/rngd:3dad6dd43270fa632ac031e99d1947f20b22eec9@sha256:1c93c1db7196f6f71f8e300bc1d15f0376dd18e8891c8789d77c8ff19f3a9a92"
+    image: mobylinux/rngd:3dad6dd43270fa632ac031e99d1947f20b22eec9
     capabilities:
      - CAP_SYS_ADMIN
     oomScoreAdj: -800
     readonly: true
   - name: dhcp-client
-    image: "mobylinux/dhcp-client:9e7009ae469ddd4d37f9cffaad2cf612114a3fb0@sha256:4421e05a0082b56c4ef83ca652e1da1a5af3a24e5baec61e7ba5b981f3b94a09"
+    image: mobylinux/dhcp-client:882ad65d1ef89a9a307b019c61f5f69301f59214
     net: host
     capabilities:
      - CAP_NET_ADMIN # to bring eth0 up

projects/miragesdk/pkg/init/Makefile

@@ -1,22 +1,8 @@
-CONTAINERD_IMAGE=mobylinux/containerd:a688df6aee1e3700eb8d54dbc81070361df397a2@sha256:59ee3da05fe4dad4fbecff582c86fc30ce75e19a225eeeb07e203c9cc36fe34f
-CONTAINERD_BINARIES=usr/bin/containerd usr/bin/containerd-shim usr/bin/ctr usr/bin/dist
-
-RUNC_IMAGE=mobylinux/runc:f225fb93dc3e6dda1cc9004962893015b29dc2d6@sha256:e75c4b274236bd3ad9f4db0a91a6f2174c8c77009c361ab5dd7a4169406675bc
-RUNC_BINARY=usr/bin/runc
-
 C_COMPILE=mobylinux/c-compile:81a6bd8ff45d769b60a2ee1acdaccda11ab835c8@sha256:eac250997a3b9784d3285a03c0c8311d4ca6fb63dc75164c987411ba93006487
 START_STOP_DAEMON=sbin/start-stop-daemon
 
 default: push
 
-$(RUNC_BINARY): Makefile
-	mkdir -p $(dir $@)
-	docker run --rm --net=none $(RUNC_IMAGE) tar cf - $@ | tar xf -
-
-$(CONTAINERD_BINARIES): Makefile
-	mkdir -p $(dir $@)
-	docker run --rm --net=none $(CONTAINERD_IMAGE) tar cf - $@ | tar xf -
-
 $(START_STOP_DAEMON): start-stop-daemon.c
 	mkdir -p $(dir $@)
 	tar cf - $^ | docker run --rm --net=none --log-driver=none -i $(C_COMPILE) -o $@ | tar xf -
@@ -28,7 +14,7 @@ IMAGE=init
 
 ETC=$(shell find etc -type f)
 
-hash: Dockerfile $(ETC) init $(RUNC_BINARY) $(CONTAINERD_BINARIES) $(START_STOP_DAEMON)
+hash: Dockerfile $(ETC) init $(START_STOP_DAEMON)
 	DOCKER_CONTENT_TRUST=1 docker pull $(BASE)
 	tar cf - $^ | docker build --no-cache -t $(IMAGE):build -
 	docker run --rm $(IMAGE):build sh -c 'cat $^ /lib/apk/db/installed | sha1sum' | sed 's/ .*//' > $@

projects/miragesdk/src/Dockerfile.build

@@ -1,12 +1,14 @@
 FROM ocaml/opam:alpine-3.5_ocaml-4.04.0
-RUN git -C /home/opam/opam-repository pull origin master && opam update -u
+RUN cd /home/opam/opam-repository && git pull && opam update -u
 
-RUN opam info mirage-net-fd
+# to be able to use cstruct.ppx + jbuilder
+RUN opam pin add cstruct 2.4.0 -n
+# to bring eth0 up
+RUN opam pin add tuntap 1.0.0 -n
+RUN opam pin add mirage-net-fd --dev -n
 
 RUN opam depext -iy mirage-net-unix logs-syslog irmin-unix cohttp decompress
-RUN opam depext -iy rawlink tuntap.1.0.0 jbuilder irmin-watcher inotify
+RUN opam depext -iy rawlink tuntap jbuilder irmin-watcher inotify rresult
-RUN opam install rresult
-RUN opam pin add tuntap 1.0.0
 
 # TMP: to compile the calf
 RUN opam pin add -n charrua-client https://github.com/yomimono/charrua-client.git#state-halfway
@@ -22,6 +24,8 @@ RUN sudo chown opam -R /src
 USER opam
 WORKDIR /src
 
+RUN opam list
+
 RUN opam config exec -- jbuilder build dhcp-client/main.exe
 RUN sudo cp /src/_build/default/dhcp-client/main.exe /dhcp-client
 

projects/miragesdk/src/Dockerfile.dev

@@ -1,23 +1,26 @@
-FROM mobylinux/mirage-compile:4e4686b60909d88a75f3f24c0429d0a8e415faa3
+FROM ocaml/opam:alpine-3.5_ocaml-4.04.0
 RUN cd /home/opam/opam-repository && git pull && opam update -u
 
-RUN opam pin -n add conduit https://github.com/samoht/ocaml-conduit.git#fd
+# to be able to use cstruct.ppx + jbuilder
-RUN opam pin -n add mirage-net-unix https://github.com/samoht/mirage-net-unix.git#fd
+RUN opam pin add cstruct 2.4.0 -n
+# to bring eth0 up
+RUN opam pin add tuntap 1.0.0 -n
+RUN opam pin add mirage-net-fd --dev -n
 
-RUN opam depext -iy mirage-net-unix logs-syslog cohttp decompress
+RUN opam depext -iy mirage-net-unix logs-syslog irmin-unix cohttp decompress
-RUN opam depext -iy rawlink tuntap.1.0.0 jbuilder
+RUN opam depext -iy rawlink tuntap jbuilder irmin-watcher inotify rresult
 
-RUN opam pin add tuntap 1.0.0
+# TMP: to compile the calf
+RUN opam pin add -n charrua-client https://github.com/yomimono/charrua-client.git#state-halfway
+RUN opam depext -uiy ocamlfind topkg-care ocamlbuild lwt mirage-types-lwt mirage
+RUN opam depext -uiy charrua-client cohttp conduit mirage-unix
+RUN opam depext -uiy mirage-net-fd ptime mirage-logs
 
 RUN sudo mkdir -p /src /bin
-
-COPY calf /src/calf
-RUN sudo chown opam -R /src
-RUN cd /src/calf && opam config exec -- mirage configure && make depend
-
 COPY . /src
 COPY init-dev.sh /home/opam/init-dev.sh
 
 USER opam
 WORKDIR /src
+
 ENTRYPOINT ["/bin/sh", "/home/opam/init-dev.sh"]

projects/miragesdk/src/dhcp-client/calf/unikernel.ml

@@ -178,15 +178,22 @@ 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
+  | Ok ()   -> Lwt.return_unit
-  | Error (`Msg e) -> failf "error while writing %s: %s" k e
+  | 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
   | Some ip -> set_ip ctl k ip
 
+let get_mac ctl =
+  Sdk.Ctl.Client.read ctl "/mac" >>= function
+  | Ok None   -> Lwt.return None
+  | Ok Some s -> Lwt.return @@ Macaddr.of_string (String.trim s)
+  | Error e   -> failf "get_mac: %a" Sdk.Ctl.Client.pp_error e
+
 let start () dhcp_codes net ctl =
-  Netif_fd.connect net >>= fun net ->
+  get_mac ctl >>= fun mac ->
+  Netif_fd.connect ?mac net >>= fun net ->
   let requests = match dhcp_codes with
     | [] -> default_options
     | l  ->

projects/miragesdk/src/dhcp-client/main.ml

@@ -5,15 +5,6 @@ open Astring
 let src = Logs.Src.create "dhcp-client" ~doc:"DHCP client"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-let failf fmt = Fmt.kstrf Lwt.fail_with fmt
-
-let run fmt =
-  Fmt.kstrf (fun str ->
-      match Sys.command str with
-      | 0 -> Lwt.return ()
-      | i -> Fmt.kstrf Lwt.fail_with "%S exited with code %d" str i
-    ) fmt
-
 module Handlers = struct
 
   (* System handlers *)
@@ -23,27 +14,27 @@ module Handlers = struct
     | `Updated (_, (_, `Contents (v, _))) -> Some v
     | _ -> None
 
+  let with_ip str f =
+    match Ipaddr.V4.of_string (String.trim str) with
+    | Some ip ->
+      Log.info (fun l -> l "SET IP to %a" Ipaddr.V4.pp_hum ip);
+      f ip
+    | None ->
+      Log.err (fun l -> l "%s is not a valid IP" str);
+      Lwt.return_unit
+
   let ip ~ethif t =
     Ctl.KV.watch_key t ["ip"] (fun diff ->
         match contents_of_diff diff with
         | None    -> Lwt.return_unit
-        | Some ip ->
+        | Some ip -> with_ip ip (fun ip -> Net.set_ip ethif ip)
-          let ip = String.trim ip in
-          Log.info (fun l -> l "SET IP to %s" ip);
-          (* FIXME: use language bindings to netlink instead *)
-          run "ifconfig %s %s netmask 255.255.255.0" ethif ip
-          (* run "ip addr add %s/24 dev %s" ip ethif *)
       )
 
   let gateway t =
     Ctl.KV.watch_key t ["gateway"] (fun diff ->
         match contents_of_diff diff with
         | None    -> Lwt.return_unit
-        | Some gw ->
+        | Some gw -> with_ip gw (fun gw -> Net.set_gateway gw)
-          let gw = String.trim gw in
-          Log.info (fun l -> l "SET GATEWAY to %s" gw);
-          (* FIXME: use language bindings to netlink instead *)
-          run "ip route add default via %s" gw
       )
 
   let handlers ~ethif = [
@@ -52,7 +43,7 @@ module Handlers = struct
   ]
 
   let watch ~ethif db =
-    Lwt_list.map_p (fun f -> f db) (handlers ethif) >>= fun _ ->
+    Lwt_list.map_p (fun f -> f db) (handlers ~ethif) >>= fun _ ->
     let t, _ = Lwt.task () in
     t
 
@@ -80,24 +71,30 @@ let read_cmd file =
   else
     failwith ("Cannot read " ^ file)
 
- let run () cmd ethif path =
+let infof fmt =
+  Fmt.kstrf (fun msg () ->
+      let date = Int64.of_float (Unix.gettimeofday ()) in
+      Irmin.Info.v ~date ~author:"priv" msg
+    ) fmt
+
+let run () cmd ethif path =
   let cmd = match cmd with
     | None   -> default_cmd
     | Some f -> read_cmd f
   in
   Lwt_main.run (
     let routes = [
-      "/ip";
+      "/ip"     , [`Write];
-      "/gateway";
+      "/mac"    , [`Read ];
-      "/domain";
+      "/gateway", [`Write];
-      "/search";
-      "/mtu";
-      "/nameservers/*"
     ] in
     Ctl.v path >>= fun db ->
     let ctl fd = Ctl.Server.listen ~routes db fd in
     let handlers () = Handlers.watch ~ethif db in
     let net = Init.rawlink ~filter:(dhcp_filter ()) ethif in
+    Net.mac ethif >>= fun mac ->
+    let mac = Macaddr.to_string mac ^ "\n" in
+    Ctl.KV.set db ~info:(infof "Add mac") ["mac"] mac >>= fun () ->
     Init.run t ~net ~ctl ~handlers cmd
   )
 

projects/miragesdk/src/sdk/IO.ml

@@ -35,7 +35,7 @@ let pp ppf (Flow (name, _, _)) = Fmt.string ppf name
 
 type t = flow
 
-let forward ~src ~dst =
+let forward ?(verbose=false) ~src ~dst =
   let rec loop () =
     read src >>= function
     | Ok `Eof ->
@@ -45,8 +45,12 @@ let forward ~src ~dst =
       Log.err (fun l -> l "forward[%a => %a] %a" pp src pp dst pp_error e);
       Lwt.return_unit
     | Ok (`Data buf) ->
-      Log.debug (fun l -> l "forward[%a => %a] %a"
+      Log.debug (fun l ->
-                    pp src pp dst Cstruct.hexdump_pp buf);
+          let payload =
+            if verbose then Fmt.strf "[%S]" @@ Cstruct.to_string buf
+            else Fmt.strf "%d bytes" (Cstruct.len buf)
+          in
+          l "forward[%a => %a] %s" pp src pp dst payload);
       write dst buf >>= function
       | Ok ()   -> loop ()
       | Error e ->
@@ -56,8 +60,8 @@ let forward ~src ~dst =
   in
   loop ()
 
-let proxy f1 f2 =
+let proxy ?verbose f1 f2 =
   Lwt.join [
-    forward ~src:f1 ~dst:f2;
+    forward ?verbose ~src:f1 ~dst:f2;
-    forward ~src:f2 ~dst:f1;
+    forward ?verbose ~src:f2 ~dst:f1;
   ]

projects/miragesdk/src/sdk/IO.mli

@@ -12,10 +12,14 @@ val create: (module Mirage_flow_lwt.S with type flow = 'a) -> 'a -> string -> fl
 val pp: flow Fmt.t
 (** [pp] is the pretty-printer for IO flows. *)
 
-val forward: src:t -> dst:t -> unit Lwt.t
+val forward: ?verbose:bool -> src:t -> dst:t -> unit Lwt.t
-(** [forward ~src ~dst] forwards writes from [src] to [dst]. Block
+(** [forward ?verbose ~src ~dst] forwards writes from [src] to
-    until either [src] or [dst] is closed. *)
+    [dst]. Block until either [src] or [dst] is closed. If [verbose]
+    is set (by default it is not), show the raw flow in debug mode,
+    otherwise just show the lenght. *)
 
-val proxy: t -> t -> unit Lwt.t
+val proxy: ?verbose:bool -> t -> t -> unit Lwt.t
-(** [proxy x y] is the same as [forward x y <*> forward y x]. Block
+(** [proxy ?verbose x y] is the same as [forward x y <*> forward y
-    until both flows are closed. *)
+    x]. Block until both flows are closed. If [verbose] is set (by
+    default it is not), show the raw flow in debug mode, otherwise
+    just show the lenght. *)

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
@@ -327,6 +330,8 @@ end
 
 module Server = struct
 
+  type op = [ `Read | `Write | `Delete ]
+
   let ok q payload =
     { Reply.id = q.Query.id; status = Reply.Ok; payload }
 
@@ -345,21 +350,29 @@ module Server = struct
         Irmin.Info.v ~date ~author:"calf" msg
       ) fmt
 
-  let dispatch db q =
+  let not_allowed q =
+    let path = q.Query.path in
+    let err = Fmt.strf "%s is not an allowed path" path in
+    Log.err (fun l -> l "%ld: %s" q.Query.id path);
+    error q err
+
+  let dispatch db op q =
     with_key q (fun key ->
+        let can x = List.mem x op in
         match q.Query.operation with
-        | Write ->
+        | Write when can `Write ->
           let info = infof "Updating %a" KV.Key.pp key in
           KV.set db ~info key q.payload >|= fun () ->
           ok q ""
-        | Delete ->
+        | Delete when can `Delete ->
           let info = infof "Removing %a" KV.Key.pp key in
           KV.remove db ~info key >|= fun () ->
           ok q ""
-        | Read ->
+        | Read when can `Read ->
-          KV.find db key >|= function
+          (KV.find db key >|= function
           | None   -> error q err_not_found
-          | Some v -> ok q v
+          | Some v -> ok q v)
+        | _ -> Lwt.return (not_allowed q)
       )
 
   let listen ~routes db fd =
@@ -381,13 +394,12 @@ module Server = struct
       Lwt_condition.wait cond >>= fun () ->
       let q = Queue.pop queries in
       let path = q.Query.path in
-      (if List.mem path routes then (
+      (if List.mem_assoc path routes then (
-          dispatch db q >>= fun r ->
+          let op = List.assoc path routes in
+          dispatch db op q >>= fun r ->
           Reply.write fd r
         ) else (
-         let err = Fmt.strf "%s is not an allowed path" path in
+         Reply.write fd (not_allowed q)
-         Log.err (fun l -> l "%ld: %s" q.Query.id path);
-         Reply.write fd (error q err)
        )) >>= fun () ->
       process ()
     in

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
@@ -120,7 +126,10 @@ val v: string -> KV.t Lwt.t
 
 module Server: sig
 
-  val listen: routes:string list -> KV.t -> IO.t -> unit Lwt.t
+  type op = [ `Read | `Write | `Delete ]
+  (** The type for operations to perform on routes. *)
+
+  val listen: routes:(string * op list) list -> KV.t -> IO.t -> unit Lwt.t
   (** [listen ~routes kv fd] is the thread exposing the KV store [kv],
       holding control plane state, running inside the privileged
       container. [routes] are the routes exposed by the server to the

projects/miragesdk/src/sdk/init.ml

@@ -291,11 +291,11 @@ let exec_and_forward ?(handlers=block_for_ever) ~pid ~cmd ~net ~ctl t =
   Lwt.pick ([
       wait ();
       (* data *)
-      IO.proxy net priv_net;
+      IO.proxy ~verbose:true net priv_net;
 
       (* redirect the calf stdout to the shim stdout *)
-      IO.forward ~src:priv_stdout ~dst:Fd.(flow stdout);
+      IO.forward ~verbose:false ~src:priv_stdout ~dst:Fd.(flow stdout);
-      IO.forward ~src:priv_stderr ~dst:Fd.(flow stderr);
+      IO.forward ~verbose:false ~src:priv_stderr ~dst:Fd.(flow stderr);
       (* TODO: Init.Fd.forward ~src:Init.Pipe.(priv metrics)
          ~dst:Init.Fd.metric; *)
       ctl priv_ctl;

projects/miragesdk/src/sdk/jbuild

@@ -5,6 +5,6 @@
   (libraries (threads cstruct.lwt cmdliner fmt.cli logs.fmt logs.cli fmt.tty
               decompress irmin irmin-git lwt.unix rawlink tuntap dispatch
               irmin-watcher inotify astring rresult mirage-flow-lwt
-              mirage-channel-lwt io-page.unix))
+              mirage-channel-lwt io-page.unix ipaddr))
   (preprocess (per_file ((pps (cstruct.ppx)) (ctl))))
  ))

projects/miragesdk/src/sdk/net.ml

@@ -0,0 +1,28 @@
+(* This file is a big hack and should be replaced ASAP with proper bindings *)
+
+open Lwt.Infix
+
+let run fmt =
+  Fmt.kstrf (fun str ->
+      match Sys.command str with
+      | 0 -> Lwt.return ()
+      | i -> Fmt.kstrf Lwt.fail_with "%S exited with code %d" str i
+    ) fmt
+
+let read fmt =
+  Fmt.kstrf (fun str ->
+      Lwt_process.pread ("/bin/sh", [|"/bin/sh"; "-c";  str|])
+    ) fmt
+
+let mac ethif =
+  read "ifconfig -a %s | grep -o -E '([[:xdigit:]]{1,2}:){5}[[:xdigit:]]{1,2}'"
+    ethif >|= fun mac ->
+  Macaddr.of_string_exn (String.trim mac)
+
+let set_ip ethif ip =
+  (* FIXME: use language bindings to netlink instead *)
+  (* run "ip addr add %s/24 dev %s" ip ethif *)
+  run "ifconfig %s %a netmask 255.255.255.0" ethif Ipaddr.V4.pp_hum ip
+
+let set_gateway gw =
+  run "ip route add default via %a" Ipaddr.V4.pp_hum gw

projects/miragesdk/src/sdk/net.mli

@@ -0,0 +1,10 @@
+(** [Net] exposes low-level system functions related to network. *)
+
+val mac: string -> Macaddr.t Lwt.t
+(** [mac e] is the MAC address of the interface [e]. *)
+
+val set_ip: string -> Ipaddr.V4.t -> unit Lwt.t
+(** [set_ip e ip] sets [e]'s IP address to [ip]. *)
+
+val set_gateway: Ipaddr.V4.t -> unit Lwt.t
+(** [set_gateway ip] set the default host gateway to [ip]. *)

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 _) -> ()
+  | Error _   -> ()
-  | Ok None        -> failf "read(%s) -> got: none, expected: err" k
+  | Ok None   -> failf "read(%s) -> got: none, expected: err" k
-  | Ok Some v      -> failf "read(%s) -> got: found:%S, expected: err" k v
+  | 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
+  | Error e   -> failf "read(%s) -> got: error:%a, expected none" k pp_error e
-  | Ok None        -> ()
+  | Ok None   -> ()
-  | Ok Some v      -> failf "read(%s) -> got: found:%S, expected none" k v
+  | 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
+  | 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 None    -> failf "read(%s) -> got: none, expected ok" k
-  | Ok Some v'     ->
+  | 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 ()          -> ()
+  | Ok ()   -> ()
-  | Error (`Msg e) -> failf "write(%s) -> error: %s" k e
+  | 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 ()          -> ()
+  | Ok ()   -> ()
-  | Error (`Msg e) -> failf "write(%s) -> error: %s" k e
+  | Error e -> failf "write(%s) -> error: %a" k pp_error e
 
 let test_ctl t () =
   let calf = calf Init.Pipe.(ctl t) in
@@ -204,7 +206,8 @@ let test_ctl t () =
   let k2 = "a" in
   let k3 = "b/c" in
   let k4 = "xxxxxx" in
-  let routes = [k1; k2; k3] in
+  let all = [`Read; `Write; `Delete] in
+  let routes = [k1,all; k2,all; k3,all ] in
   let git_root = "/tmp/sdk/ctl" in
   let _ = Sys.command (Fmt.strf "rm -rf %s" git_root) in
   Ctl.v git_root >>= fun ctl ->