From df71c0f2996b3bfbd627a3f7dcf95e1779d34537 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Wed, 29 Mar 2017 15:41:23 +0200 Subject: [PATCH] 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 --- 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; + ]