From ec988eb93b992a49f4f38e15ac284b29c054ee6e Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 29 Mar 2017 12:36:31 +0200
Subject: [PATCH 1/7] miragesdk: fix `dev` target

Paths have changed since 47b9f08b16c07a24fb1ff46154ce15bb57b484ce

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
---
 projects/miragesdk/src/Makefile | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/projects/miragesdk/src/Makefile b/projects/miragesdk/src/Makefile
index 957d6d4cd..2d97abd86 100644
--- a/projects/miragesdk/src/Makefile
+++ b/projects/miragesdk/src/Makefile
@@ -66,8 +66,8 @@ clean::
 	(docker rmi -f $(IMAGE):dev || echo ok)
 
 dev:
-	cd calf && mirage configure && make
-	jbuilder build src/main.exe
+	cd dhcp-client/calf && mirage configure && make
+	jbuilder build dhcp-client/main.exe
 #	_build/default/src/main.exe -vv \
 #	  --cmd 'calf/_build/main.native -l debug --store 10 --net 12' \
 #	  --ethif eno1

From c06454273b7c91a3b4ffff0ce19796daac3638fc Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 29 Mar 2017 14:22:11 +0200
Subject: [PATCH 2/7] miragesdk: add a `dev-clean` target

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
---
 projects/miragesdk/src/Makefile | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/projects/miragesdk/src/Makefile b/projects/miragesdk/src/Makefile
index 2d97abd86..05bde5710 100644
--- a/projects/miragesdk/src/Makefile
+++ b/projects/miragesdk/src/Makefile
@@ -65,6 +65,9 @@ clean::
 	(docker rmi -f $(IMAGE):pkg || echo ok)
 	(docker rmi -f $(IMAGE):dev || echo ok)
 
+dev-clean:
+	rm -rf _build dhcp-client/calf/_build
+
 dev:
 	cd dhcp-client/calf && mirage configure && make
 	jbuilder build dhcp-client/main.exe

From df71c0f2996b3bfbd627a3f7dcf95e1779d34537 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 29 Mar 2017 15:41:23 +0200
Subject: [PATCH 3/7] miragesdk: add mimimal tests for the SDK

Very minimal so far, but the plan is to add much more of them.

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
---
 projects/miragesdk/src/.gitignore   |  1 +
 projects/miragesdk/src/Makefile     | 10 +++++---
 projects/miragesdk/src/sdk/init.ml  | 38 +++++++++++++++++++++++------
 projects/miragesdk/src/sdk/init.mli | 15 ++++++++++++
 projects/miragesdk/src/sdk/jbuild   |  3 ++-
 projects/miragesdk/src/test/jbuild  | 10 ++++++++
 projects/miragesdk/src/test/test.ml | 31 +++++++++++++++++++++++
 7 files changed, 96 insertions(+), 12 deletions(-)
 create mode 100644 projects/miragesdk/src/test/jbuild
 create mode 100644 projects/miragesdk/src/test/test.ml

diff --git a/projects/miragesdk/src/.gitignore b/projects/miragesdk/src/.gitignore
index 806fecf20..a1407950a 100644
--- a/projects/miragesdk/src/.gitignore
+++ b/projects/miragesdk/src/.gitignore
@@ -8,6 +8,7 @@ hash
 dhcp-client/bpf/.merlin
 dhcp-client/.merlin
 sdk/.merlin
+test/.merlin
 
 # Generated by `make dev`
 _build/
diff --git a/projects/miragesdk/src/Makefile b/projects/miragesdk/src/Makefile
index 05bde5710..bf42bb109 100644
--- a/projects/miragesdk/src/Makefile
+++ b/projects/miragesdk/src/Makefile
@@ -65,14 +65,18 @@ clean::
 	(docker rmi -f $(IMAGE):pkg || echo ok)
 	(docker rmi -f $(IMAGE):dev || echo ok)
 
+#### DEV
+
+.PHONY: test
+
+test:
+	jbuilder runtest
+
 dev-clean:
 	rm -rf _build dhcp-client/calf/_build
 
 dev:
 	cd dhcp-client/calf && mirage configure && make
 	jbuilder build dhcp-client/main.exe
-#	_build/default/src/main.exe -vv \
-#	  --cmd 'calf/_build/main.native -l debug --store 10 --net 12' \
-#	  --ethif eno1
 
 .DELETE_ON_ERROR:
diff --git a/projects/miragesdk/src/sdk/init.ml b/projects/miragesdk/src/sdk/init.ml
index 301f19804..6bd657361 100644
--- a/projects/miragesdk/src/sdk/init.ml
+++ b/projects/miragesdk/src/sdk/init.ml
@@ -5,6 +5,35 @@ module Log = (val Logs.src_log src : Logs.LOG)
 
 let failf fmt = Fmt.kstrf Lwt.fail_with fmt
 
+module IO = struct
+
+  let rec really_write fd buf off len =
+    match len with
+    | 0   -> Lwt.return_unit
+    | len ->
+      Lwt_unix.write fd buf off len >>= fun n ->
+      really_write fd buf (off+n) (len-n)
+
+  let rec really_read fd buf off len =
+    match len with
+    | 0   -> Lwt.return_unit
+    | len ->
+      Lwt_unix.read fd buf off len >>= fun n ->
+      really_write fd buf (off+n) (len-n)
+
+  let read_all fd =
+    let len = 16 * 1024 in
+    let buf = Bytes.create len in
+    let rec loop acc =
+      Lwt_unix.read fd buf 0 len >>= fun len ->
+      let res = String.sub buf 0 len in
+      loop (res :: acc)
+    in
+    loop [] >|= fun bufs ->
+    String.concat "" (List.rev bufs)
+
+end
+
 module Fd = struct
 
   type t = {
@@ -72,13 +101,6 @@ module Fd = struct
       listen_socket ();
     ]
 
-  let rec really_write dst buf off len =
-    match len with
-    | 0   -> Lwt.return_unit
-    | len ->
-      Lwt_unix.write dst.fd buf off len >>= fun n ->
-      really_write dst buf (off+n) (len-n)
-
   let forward ~src ~dst =
     Log.debug (fun l -> l "forward %a => %a" pp src pp dst);
     let len = 16 * 1024 in
@@ -92,7 +114,7 @@ module Fd = struct
         Log.debug (fun l ->
             l "FORWARD[%a => %a]: %S (%d)"
               pp src pp dst (Bytes.sub buf 0 len) len);
-        really_write dst buf 0 len >>= fun () ->
+        IO.really_write dst.fd buf 0 len >>= fun () ->
         loop ()
       )
     in
diff --git a/projects/miragesdk/src/sdk/init.mli b/projects/miragesdk/src/sdk/init.mli
index 3fb6abb68..3cc3108cc 100644
--- a/projects/miragesdk/src/sdk/init.mli
+++ b/projects/miragesdk/src/sdk/init.mli
@@ -15,6 +15,21 @@
     }*)
 
 
+module IO: sig
+
+  (** {IO helpers} *)
+
+  val really_write: Lwt_unix.file_descr -> string -> int -> int -> unit Lwt.t
+  (** [really_write fd buf off len] writes exactly [len] bytes. *)
+
+  val really_read: Lwt_unix.file_descr -> string -> int -> int -> unit Lwt.t
+  (** [really_read fd buf off len] reads exactly [len] bytes. *)
+
+  val read_all: Lwt_unix.file_descr -> string Lwt.t
+  (** [read_all fd] reads all the contents of [fd] bytes. *)
+
+end
+
 module Fd: sig
 
   type t
diff --git a/projects/miragesdk/src/sdk/jbuild b/projects/miragesdk/src/sdk/jbuild
index b1a693f2c..a6e199b3a 100644
--- a/projects/miragesdk/src/sdk/jbuild
+++ b/projects/miragesdk/src/sdk/jbuild
@@ -2,8 +2,9 @@
 
 (library
  ((name sdk)
-  (libraries (logs-syslog.lwt threads cohttp.lwt cstruct.lwt
+  (libraries (threads cohttp.lwt cstruct.lwt
               cmdliner fmt.cli logs.fmt logs.cli fmt.tty decompress
               irmin irmin-git irmin-http lwt.unix rawlink tuntap
               irmin-watcher inotify))
+  (preprocess (per_file ((pps (cstruct.ppx)) (ctl))))
  ))
diff --git a/projects/miragesdk/src/test/jbuild b/projects/miragesdk/src/test/jbuild
new file mode 100644
index 000000000..eec286f2f
--- /dev/null
+++ b/projects/miragesdk/src/test/jbuild
@@ -0,0 +1,10 @@
+(jbuild_version 1)
+
+(executables
+  ((names (test))
+   (libraries (sdk alcotest))))
+
+(alias
+ ((name    runtest)
+  (deps    (test.exe))
+  (action  (run ${<}))))
\ No newline at end of file
diff --git a/projects/miragesdk/src/test/test.ml b/projects/miragesdk/src/test/test.ml
new file mode 100644
index 000000000..2887f802e
--- /dev/null
+++ b/projects/miragesdk/src/test/test.ml
@@ -0,0 +1,31 @@
+open Lwt.Infix
+open Sdk
+
+let random_string n = Bytes.create n
+
+let test_pipe pipe () =
+  let ic = Init.Fd.fd @@ Init.Pipe.(calf pipe) in
+  let oc = Init.Fd.fd @@ Init.Pipe.(priv pipe) in
+  let test str =
+    Init.IO.really_write oc str 0 (String.length str) >>= fun () ->
+    Init.IO.read_all ic >|= fun buf ->
+    Alcotest.(check string) "stdout" str buf
+  in
+  test (random_string 10241) >>= fun () ->
+  test (random_string 100) >>= fun () ->
+  test (random_string 1)
+
+let run f () =
+  try Lwt_main.run (f ())
+  with e -> Fmt.epr "ERROR: %a" Fmt.exn e
+
+let test_stderr () = ()
+
+let test = [
+  "stdout", `Quick, run (test_pipe Init.Pipe.stdout);
+  "stdout", `Quick, run (test_pipe Init.Pipe.stderr);
+  ]
+
+let () = Alcotest.run "sdk" [
+    "init", test;
+  ]

From b5a3d4b2aa9dc0774bdd958b9b0351c15662e031 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 29 Mar 2017 19:25:37 +0200
Subject: [PATCH 4/7] miragesdk: rework the control plane protocol

Previously, the control plane was using HTTP client/server, that various people
found way too complex to run in a privileged container (for very good reasons).

So switching to a simpler binary protocol, using c-like structures. Will
probably switch to an other serialization protocol later (eg. protobuf
or cap-n-proto).

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
---
 projects/miragesdk/src/sdk/IO.ml    |  46 +++++++
 projects/miragesdk/src/sdk/IO.mli   |  13 ++
 projects/miragesdk/src/sdk/ctl.ml   | 192 ++++++++++++++++------------
 projects/miragesdk/src/sdk/ctl.mli  |  23 ++++
 projects/miragesdk/src/sdk/init.ml  |  37 +-----
 projects/miragesdk/src/sdk/init.mli |  16 ---
 projects/miragesdk/src/sdk/jbuild   |   5 +-
 7 files changed, 194 insertions(+), 138 deletions(-)
 create mode 100644 projects/miragesdk/src/sdk/IO.ml
 create mode 100644 projects/miragesdk/src/sdk/IO.mli

diff --git a/projects/miragesdk/src/sdk/IO.ml b/projects/miragesdk/src/sdk/IO.ml
new file mode 100644
index 000000000..2d9345729
--- /dev/null
+++ b/projects/miragesdk/src/sdk/IO.ml
@@ -0,0 +1,46 @@
+open Lwt.Infix
+
+let src = Logs.Src.create "IO" ~doc:"IO helpers"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let rec really_write fd buf off len =
+  Log.debug (fun l -> l "really_write");
+  match len with
+  | 0   -> Lwt.return_unit
+  | len ->
+    Lwt_unix.write fd buf off len >>= fun n ->
+    really_write fd buf (off+n) (len-n)
+
+let rec really_read fd buf off len =
+  Log.debug (fun l -> l "really_read");
+  match len with
+  | 0   -> Lwt.return_unit
+  | len ->
+    Lwt_unix.read fd buf off len >>= fun n ->
+    really_read fd buf (off+n) (len-n)
+
+let read_all fd =
+  Log.debug (fun l -> l "read_all");
+  let len = 16 * 1024 in
+  let buf = Bytes.create len in
+  let rec loop acc =
+    Lwt_unix.read fd buf 0 len >>= fun n ->
+    let acc = String.sub buf 0 n :: acc in
+    if n <= len then Lwt.return (List.rev acc)
+    else loop acc
+  in
+  loop [] >|= fun bufs ->
+  String.concat "" bufs
+
+let read_n fd len =
+  Log.debug (fun l -> l "read_n");
+  let buf = Bytes.create len in
+  let rec loop acc len =
+    Lwt_unix.read fd buf 0 len >>= fun n ->
+    let acc = String.sub buf 0 n :: acc in
+    match len - n with
+    | 0 -> Lwt.return (List.rev acc)
+    | r -> loop acc r
+  in
+  loop [] len >|= fun bufs ->
+  String.concat "" bufs
diff --git a/projects/miragesdk/src/sdk/IO.mli b/projects/miragesdk/src/sdk/IO.mli
new file mode 100644
index 000000000..121ba33c7
--- /dev/null
+++ b/projects/miragesdk/src/sdk/IO.mli
@@ -0,0 +1,13 @@
+(** IO helpers *)
+
+val really_write: Lwt_unix.file_descr -> string -> int -> int -> unit Lwt.t
+(** [really_write fd buf off len] writes exactly [len] bytes to [fd]. *)
+
+val really_read: Lwt_unix.file_descr -> string -> int -> int -> unit Lwt.t
+(** [really_read fd buf off len] reads exactly [len] bytes from [fd]. *)
+
+val read_all: Lwt_unix.file_descr -> string Lwt.t
+(** [read_all fd] reads as much data as it is available in [fd]. *)
+
+val read_n: Lwt_unix.file_descr -> int -> string Lwt.t
+(** [read_n fd n] reads exactly [n] bytes from [fd]. *)
diff --git a/projects/miragesdk/src/sdk/ctl.ml b/projects/miragesdk/src/sdk/ctl.ml
index feadedf35..d561e067b 100644
--- a/projects/miragesdk/src/sdk/ctl.ml
+++ b/projects/miragesdk/src/sdk/ctl.ml
@@ -4,7 +4,7 @@ let src = Logs.Src.create "init" ~doc:"Init steps"
 module Log = (val Logs.src_log src : Logs.LOG)
 
 (* FIXME: to avoid linking with gmp *)
-module IO = struct
+module No_IO = struct
   type ic = unit
   type oc = unit
   type ctx = unit
@@ -17,7 +17,7 @@ module IO = struct
 end
 
 (* FIXME: we don't use Irmin_unix.Git.FS.KV to avoid linking with gmp *)
-module Store = Irmin_git.FS.KV(IO)(Inflator)(Io_fs)
+module Store = Irmin_git.FS.KV(No_IO)(Inflator)(Io_fs)
 module KV = Store(Irmin.Contents.String)
 
 let v path =
@@ -28,17 +28,84 @@ let v path =
 let () =
   Irmin.Private.Watch.set_listen_dir_hook Irmin_watcher.hook
 
+module Message = struct
+
+  [%%cenum
+    type operation =
+      | Write
+      | Read
+      | Delete
+    [@@uint8_t]
+  ]
+
+  type t = {
+    operation: operation;
+    path     : string;
+    payload  : string option;
+  }
+
+  [%%cstruct type message = {
+      operation : uint8_t; (* = type operation *)
+      path      : uint16_t;
+      payload   : uint16_t;
+    } [@@little_endian]
+  ]
+
+  (* to avoid warning 32 *)
+  let _ = hexdump_message
+  let _ = operation_to_string
+  let _ = string_to_operation
+
+  let read_message fd =
+    IO.read_n fd 4 >>= fun buf ->
+    let len =
+      Cstruct.LE.get_uint32 (Cstruct.of_string buf) 0
+      |> Int32.to_int
+    in
+    IO.read_n fd len >>= fun buf ->
+    let buf = Cstruct.of_string buf in
+    let operation = match int_to_operation (get_message_operation buf) with
+      | None   -> failwith "invalid operation"
+      | Some o -> o
+    in
+    let path_len = get_message_path buf in
+    let payload_len = get_message_payload buf in
+    IO.read_n fd path_len >>= fun path ->
+    (match payload_len with
+     | 0 -> Lwt.return None
+     | n -> IO.read_n fd n >|= fun x -> Some x)
+    >|= fun payload ->
+    { operation; path; payload }
+
+  let write_message fd msg =
+    let operation = operation_to_int msg.operation in
+    let path = String.length msg.path in
+    let payload = match msg.payload with
+      | None   -> 0
+      | Some x -> String.length x
+    in
+    let len = sizeof_message + path + payload in
+    let buf = Cstruct.create len in
+    set_message_operation buf operation;
+    set_message_path buf path;
+    set_message_payload buf path;
+    Cstruct.blit_from_bytes msg.path 0 buf sizeof_message path;
+    let () = match msg.payload with
+      | None   -> ()
+      | Some x -> Cstruct.blit_from_bytes x 0 buf (sizeof_message+path) payload
+    in
+    IO.really_write fd (Cstruct.to_string buf) 0 len
+
+end
+
 module Dispatch = struct
 
-  module Wm = struct
-    module Rd = Webmachine.Rd
-    include Webmachine.Make(Cohttp_lwt_unix.Server.IO)
-  end
+  open Message
 
-  let with_key rd f =
-    match KV.Key.of_string rd.Wm.Rd.dispatch_path with
-    | Ok x    -> f x
-    | Error _ -> Wm.respond 404 rd
+  let with_key msg f =
+    match KV.Key.of_string msg.path with
+    | Ok x           -> f x
+    | Error (`Msg e) -> Fmt.kstrf Lwt.fail_with "invalid key: %s" e
 
   let infof fmt =
     Fmt.kstrf (fun msg () ->
@@ -46,91 +113,50 @@ module Dispatch = struct
         Irmin.Info.v ~date ~author:"calf" msg
       ) fmt
 
-  let ok = "{\"status\": \"ok\"}"
-
-  class item db = object(self)
-
-    inherit [Cohttp_lwt_body.t] Wm.resource
-
-    method private of_string rd =
-      Cohttp_lwt_body.to_string rd.Wm.Rd.req_body >>= fun value ->
-      with_key rd (fun key ->
+  let dispatch db msg =
+    with_key msg (fun key ->
+        match msg.operation with
+        | Write ->
           let info = infof "Updating %a" KV.Key.pp key in
-          KV.set db ~info key value >>= fun () ->
-          let resp_body = `String ok in
-          let rd = { rd with Wm.Rd.resp_body } in
-          Wm.continue true rd
-        )
+          (match msg.payload with
+           | None   -> Fmt.kstrf Lwt.fail_with "dispatch: missing payload"
+           | Some v -> KV.set db ~info key v)
+        | _ -> failwith "TODO"
+      )
 
-    method private to_string rd =
-      with_key rd (fun key ->
-          KV.find db key >>= function
-          | Some value -> Wm.continue (`String value) rd
-          | None       -> assert false
-        )
-
-    method resource_exists rd =
-      with_key rd (fun key ->
-          KV.mem db key >>= fun mem ->
-          Wm.continue mem rd
-        )
-
-    method allowed_methods rd =
-      Wm.continue [`GET; `HEAD; `PUT; `DELETE] rd
-
-    method content_types_provided rd =
-      Wm.continue [
-        "plain", self#to_string
-      ] rd
-
-    method content_types_accepted rd =
-      Wm.continue [
-        "plain", self#of_string
-      ] rd
-
-    method delete_resource rd =
-      with_key rd (fun key ->
-          let info = infof "Deleting %a" KV.Key.pp key in
-          KV.remove db ~info key >>= fun () ->
-          let resp_body = `String ok in
-          Wm.continue true { rd with Wm.Rd.resp_body }
-        )
-  end
-
-  let v db routes =
-    let routes = List.map (fun r -> r, fun () -> new item db) routes in
-    let callback (_ch, _conn) request body =
-      let open Cohttp in
-      (Wm.dispatch' routes ~body ~request >|= function
-        | None        -> (`Not_found, Header.init (), `String "Not found", [])
-        | Some result -> result)
-      >>= fun (status, headers, body, path) ->
-      Log.info (fun l ->
-          l "%d - %s %s"
-            (Code.code_of_status status)
-            (Code.string_of_method (Request.meth request))
-            (Uri.path (Request.uri request)));
-      Log.debug (fun l -> l "path=%a" Fmt.(Dump.list string) path);
-      (* Finally, send the response to the client *)
-      Cohttp_lwt_unix.Server.respond ~headers ~body ~status ()
+  let serve fd db ~routes =
+    let msgs = Queue.create () in
+    let cond = Lwt_condition.create () in
+    let rec listen () =
+      read_message fd >>= fun msg ->
+      Queue.add msg msgs;
+      Lwt_condition.signal cond ();
+      listen ()
     in
-    (* create the server and handle requests with the function defined above *)
-    let conn_closed (_, conn) =
-      Log.info (fun l ->
-          l "connection %s closed\n%!" (Cohttp.Connection.to_string conn))
+    let rec process () =
+      Lwt_condition.wait cond >>= fun () ->
+      let msg = Queue.pop msgs in
+      (if List.mem msg.path routes then dispatch db msg
+       else (
+         Log.err (fun l -> l "%s is not an allowed path" msg.path);
+         Lwt.return_unit;
+       )) >>= fun () ->
+      process ()
     in
-    Cohttp_lwt_unix.Server.make ~callback ~conn_closed ()
+    Lwt.pick [
+      listen ();
+      process ();
+    ]
+
 end
 
 let int_of_fd (t:Lwt_unix.file_descr) =
   (Obj.magic (Lwt_unix.unix_file_descr t): int)
 
 let serve ~routes db fd =
-  let http = Dispatch.v db routes in
-  let on_exn e = Log.err (fun l -> l "ERROR: %a" Fmt.exn e) in
   Lwt_unix.blocking fd >>= fun blocking ->
   Log.debug (fun l ->
       l "Serving the control state over fd:%d (blocking=%b)"
         (int_of_fd fd) blocking
     );
-  Cohttp_lwt_unix.Server.create ~on_exn ~mode:(`Fd fd) http
+  Dispatch.serve fd db ~routes
diff --git a/projects/miragesdk/src/sdk/ctl.mli b/projects/miragesdk/src/sdk/ctl.mli
index b88e4a7cf..5af101be8 100644
--- a/projects/miragesdk/src/sdk/ctl.mli
+++ b/projects/miragesdk/src/sdk/ctl.mli
@@ -3,6 +3,29 @@
 
 module KV: Irmin.KV with type contents = string
 
+module Message: sig
+
+  (** The type for operations. *)
+  type operation =
+    | Write
+    | Read
+    | Delete
+
+  (** The type for control messages. *)
+  type t = {
+    operation: operation;
+    path     : string;
+    payload  : string option;
+  }
+
+  val write_message: Lwt_unix.file_descr -> t -> unit Lwt.t
+  (** [write_message fd t] writes a control message. *)
+
+  val read_message: Lwt_unix.file_descr -> t Lwt.t
+  (** [read_message fd] reads a control message. *)
+
+end
+
 val v: string -> KV.t Lwt.t
 (** [v p] is the KV store storing the control state, located at path
     [p] in the filesystem of the privileged container. *)
diff --git a/projects/miragesdk/src/sdk/init.ml b/projects/miragesdk/src/sdk/init.ml
index 6bd657361..b9e2cd7be 100644
--- a/projects/miragesdk/src/sdk/init.ml
+++ b/projects/miragesdk/src/sdk/init.ml
@@ -5,35 +5,6 @@ module Log = (val Logs.src_log src : Logs.LOG)
 
 let failf fmt = Fmt.kstrf Lwt.fail_with fmt
 
-module IO = struct
-
-  let rec really_write fd buf off len =
-    match len with
-    | 0   -> Lwt.return_unit
-    | len ->
-      Lwt_unix.write fd buf off len >>= fun n ->
-      really_write fd buf (off+n) (len-n)
-
-  let rec really_read fd buf off len =
-    match len with
-    | 0   -> Lwt.return_unit
-    | len ->
-      Lwt_unix.read fd buf off len >>= fun n ->
-      really_write fd buf (off+n) (len-n)
-
-  let read_all fd =
-    let len = 16 * 1024 in
-    let buf = Bytes.create len in
-    let rec loop acc =
-      Lwt_unix.read fd buf 0 len >>= fun len ->
-      let res = String.sub buf 0 len in
-      loop (res :: acc)
-    in
-    loop [] >|= fun bufs ->
-    String.concat "" (List.rev bufs)
-
-end
-
 module Fd = struct
 
   type t = {
@@ -120,12 +91,6 @@ module Fd = struct
     in
     loop ()
 
-  let proxy x y =
-    Lwt.pick [
-      forward ~src:x ~dst:y;
-      forward ~src:y ~dst:x;
-    ]
-
 end
 
 module Pipe = struct
@@ -229,7 +194,7 @@ let exec_priv ~pid ~cmd ~net ~ctl ~handlers =
       Fd.forward ~src:Pipe.(priv stderr)  ~dst:Fd.stderr;
       (* TODO: Init.Fd.forward ~src:Init.Pipe.(priv metrics) ~dst:Init.Fd.metric; *)
       ctl ();
-(*      handlers (); *)
+      handlers ();
     ])
 
 let run ~net ~ctl ~handlers cmd =
diff --git a/projects/miragesdk/src/sdk/init.mli b/projects/miragesdk/src/sdk/init.mli
index 3cc3108cc..fc50863cd 100644
--- a/projects/miragesdk/src/sdk/init.mli
+++ b/projects/miragesdk/src/sdk/init.mli
@@ -14,22 +14,6 @@
        data, e.g. the IP address once a DHCP lease is obtained.}
     }*)
 
-
-module IO: sig
-
-  (** {IO helpers} *)
-
-  val really_write: Lwt_unix.file_descr -> string -> int -> int -> unit Lwt.t
-  (** [really_write fd buf off len] writes exactly [len] bytes. *)
-
-  val really_read: Lwt_unix.file_descr -> string -> int -> int -> unit Lwt.t
-  (** [really_read fd buf off len] reads exactly [len] bytes. *)
-
-  val read_all: Lwt_unix.file_descr -> string Lwt.t
-  (** [read_all fd] reads all the contents of [fd] bytes. *)
-
-end
-
 module Fd: sig
 
   type t
diff --git a/projects/miragesdk/src/sdk/jbuild b/projects/miragesdk/src/sdk/jbuild
index a6e199b3a..53403e2ad 100644
--- a/projects/miragesdk/src/sdk/jbuild
+++ b/projects/miragesdk/src/sdk/jbuild
@@ -2,9 +2,8 @@
 
 (library
  ((name sdk)
-  (libraries (threads cohttp.lwt cstruct.lwt
-              cmdliner fmt.cli logs.fmt logs.cli fmt.tty decompress
-              irmin irmin-git irmin-http lwt.unix rawlink tuntap
+  (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))
   (preprocess (per_file ((pps (cstruct.ppx)) (ctl))))
  ))

From 9db898ceaf3f202895a942a29f31658898af1f93 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 29 Mar 2017 19:28:42 +0200
Subject: [PATCH 5/7] miragesdk: enable all warnings when compiling the
 projects

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
---
 projects/miragesdk/src/Makefile | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/projects/miragesdk/src/Makefile b/projects/miragesdk/src/Makefile
index bf42bb109..88a8bc1c2 100644
--- a/projects/miragesdk/src/Makefile
+++ b/projects/miragesdk/src/Makefile
@@ -70,13 +70,13 @@ clean::
 .PHONY: test
 
 test:
-	jbuilder runtest
+	jbuilder runtest --dev
 
 dev-clean:
 	rm -rf _build dhcp-client/calf/_build
 
 dev:
 	cd dhcp-client/calf && mirage configure && make
-	jbuilder build dhcp-client/main.exe
+	jbuilder build dhcp-client/main.exe --dev
 
 .DELETE_ON_ERROR:

From 2b48442fee7655473ffb7e9ed749310b009d61a1 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 29 Mar 2017 19:29:22 +0200
Subject: [PATCH 6/7] miragesdk: update .gitignore

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
---
 projects/miragesdk/src/.gitignore | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/projects/miragesdk/src/.gitignore b/projects/miragesdk/src/.gitignore
index a1407950a..21a037422 100644
--- a/projects/miragesdk/src/.gitignore
+++ b/projects/miragesdk/src/.gitignore
@@ -13,7 +13,7 @@ test/.merlin
 # Generated by `make dev`
 _build/
 main.native
-calf/dhcp_client
+dhcp-client/calf/dhcp_client
 src/bpf/.merlin
 
 # Generated by the mirage tool

From c582aafe45062bd246127638b4aa179663914556 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 29 Mar 2017 19:29:40 +0200
Subject: [PATCH 7/7] miragesdk: add tests for stdout/stderr pipes

And the tests pass!

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
---
 projects/miragesdk/src/test/jbuild  |  2 +-
 projects/miragesdk/src/test/test.ml | 63 ++++++++++++++++++++++++-----
 2 files changed, 54 insertions(+), 11 deletions(-)

diff --git a/projects/miragesdk/src/test/jbuild b/projects/miragesdk/src/test/jbuild
index eec286f2f..ef137b2c4 100644
--- a/projects/miragesdk/src/test/jbuild
+++ b/projects/miragesdk/src/test/jbuild
@@ -2,7 +2,7 @@
 
 (executables
   ((names (test))
-   (libraries (sdk alcotest))))
+   (libraries (sdk alcotest astring mtime.os))))
 
 (alias
  ((name    runtest)
diff --git a/projects/miragesdk/src/test/test.ml b/projects/miragesdk/src/test/test.ml
index 2887f802e..0aa18877a 100644
--- a/projects/miragesdk/src/test/test.ml
+++ b/projects/miragesdk/src/test/test.ml
@@ -1,31 +1,74 @@
+open Astring
 open Lwt.Infix
 open Sdk
 
 let random_string n = Bytes.create n
 
 let test_pipe pipe () =
-  let ic = Init.Fd.fd @@ Init.Pipe.(calf pipe) in
-  let oc = Init.Fd.fd @@ Init.Pipe.(priv pipe) in
+  let calf = Init.Fd.fd @@ Init.Pipe.(calf pipe) in
+  let priv = Init.Fd.fd @@ Init.Pipe.(priv pipe) in
   let test str =
-    Init.IO.really_write oc str 0 (String.length str) >>= fun () ->
-    Init.IO.read_all ic >|= fun buf ->
-    Alcotest.(check string) "stdout" str buf
+    (* check the the pipe is unidirectional *)
+    IO.really_write calf str 0 (String.length str) >>= fun () ->
+    IO.read_all priv >>= fun buf ->
+    Alcotest.(check string) "stdout"
+      (String.Ascii.escape str) (String.Ascii.escape buf);
+    Lwt.catch (fun () ->
+        IO.really_write priv str 0 (String.length str) >|= fun () ->
+        Alcotest.fail "priv side is writable!"
+      ) (fun _ -> Lwt.return_unit)
+    >>= fun () ->
+    Lwt.catch (fun () ->
+        IO.read_all calf >|= fun _ ->
+        Alcotest.fail "calf sid is readable!"
+      ) (fun _ -> Lwt.return_unit)
+    >>= fun () ->
+    Lwt.return_unit
   in
-  test (random_string 10241) >>= fun () ->
+  test (random_string 1) >>= fun () ->
   test (random_string 100) >>= fun () ->
-  test (random_string 1)
+  test (random_string 10241) >>= fun () ->
+
+  Lwt.return_unit
 
 let run f () =
   try Lwt_main.run (f ())
-  with e -> Fmt.epr "ERROR: %a" Fmt.exn e
+  with e ->
+    Fmt.epr "ERROR: %a" Fmt.exn e;
+    raise e
 
 let test_stderr () = ()
 
 let test = [
-  "stdout", `Quick, run (test_pipe Init.Pipe.stdout);
-  "stdout", `Quick, run (test_pipe Init.Pipe.stderr);
+  "stdout" , `Quick, run (test_pipe Init.Pipe.stdout);
+  "stdout" , `Quick, run (test_pipe Init.Pipe.stderr);
   ]
 
+let reporter ?(prefix="") () =
+  let pad n x =
+    if String.length x > n then x
+    else x ^ String.v ~len:(n - String.length x) (fun _ -> ' ')
+  in
+  let report src level ~over k msgf =
+    let k _ = over (); k () in
+    let ppf = match level with Logs.App -> Fmt.stdout | _ -> Fmt.stderr in
+    let with_stamp h _tags k fmt =
+      let dt = Mtime.to_us (Mtime.elapsed ()) in
+      Fmt.kpf k ppf ("%s%+04.0fus %a %a @[" ^^ fmt ^^ "@]@.")
+        prefix
+        dt
+        Fmt.(styled `Magenta string) (pad 10 @@ Logs.Src.name src)
+        Logs_fmt.pp_header (level, h)
+    in
+    msgf @@ fun ?header ?tags fmt ->
+    with_stamp header tags k fmt
+  in
+  { Logs.report = report }
+
+let () =
+  Logs.set_level (Some Logs.Debug);
+  Logs.set_reporter (reporter ())
+
 let () = Alcotest.run "sdk" [
     "init", test;
   ]