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