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

@@ -8,6 +8,7 @@ hash
 dhcp-client/bpf/.merlin
 dhcp-client/.merlin
 sdk/.merlin
+test/.merlin
 
 # Generated by `make dev`
 _build/

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:

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

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 ${<}))))

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;
+  ]