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>
This commit is contained in:
Thomas Gazagnaire 2017-03-29 15:41:23 +02:00
parent c06454273b
commit df71c0f299
7 changed files with 96 additions and 12 deletions

View File

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

View File

@ -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:

View File

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

View File

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

View File

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

View File

@ -0,0 +1,10 @@
(jbuild_version 1)
(executables
((names (test))
(libraries (sdk alcotest))))
(alias
((name runtest)
(deps (test.exe))
(action (run ${<}))))

View File

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