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/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

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

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))))
  ))