unikernel/duniverse/paf-le-chien/test/clients.ml

@@ -0,0 +1,167 @@
+open Fiber
+
+let pr fmt = Format.printf fmt
+let epr fmt = Format.eprintf fmt
+
+external now : unit -> (int64[@unboxed]) = "b_mclock" "n_mclock" [@@noalloc]
+
+let reporter pid ppf =
+  let report src level ~over k msgf =
+    let k _ =
+      over () ;
+      k () in
+    let with_metadata header _tags k ppf fmt =
+      Format.kfprintf k ppf
+        ("[%06d]%a[%a]: " ^^ fmt ^^ "\n%!")
+        pid Logs_fmt.pp_header (level, header)
+        Fmt.(styled `Magenta string)
+        (Logs.Src.name src) in
+    msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in
+  { Logs.report }
+
+let run uri =
+  let open Lwt.Infix in
+  let t0 = now () in
+  Simple_client.run uri >>= fun _ ->
+  let t1 = now () in
+  Lwt.return (Int64.sub t1 t0)
+
+let run_client uri =
+  run_process (fun () ->
+      let () = Mirage_crypto_rng_unix.use_default () in
+      Lwt_main.run (run uri))
+
+let const x _ = x
+
+let clients ~n uri =
+  parallel_map (List.init n (const uri)) ~f:run_client >>| Array.of_list
+
+let count ~p arr =
+  let res = ref 0 in
+  Array.iter (fun x -> if p x then incr res) arr ;
+  !res
+
+let fold ~f a v = Array.fold_left f a v
+let map ~f a = Array.map f a
+let is_ok = function Ok _ -> true | _ -> false
+let is_error = function Error _ -> true | _ -> false
+let get_ok = function Ok v -> v | Error _ -> assert false
+
+let to_sec x =
+  let x = Int64.to_float x in
+  x /. 1e9
+
+let ( <.> ) f g x = f (g x)
+
+let histogram res =
+  let tbl = Hashtbl.create 0x100 in
+  Array.iter
+    (fun v ->
+      let v = Float.round (to_sec v *. 1e2) in
+      try
+        let n = Hashtbl.find tbl v in
+        Hashtbl.replace tbl v (succ n)
+      with _ -> Hashtbl.add tbl v 1)
+    res ;
+  let res = Hashtbl.fold (fun k v a -> (k *. 1e-2, v) :: a) tbl [] in
+  List.sort (fun (a, _) (b, _) -> Float.compare a b) res
+
+let utf8_chars =
+  (* Characters: space @ [0x258F .. 0x2589] *)
+  [| " "; "▏"; "▎"; "▍"; "▌"; "▋"; "▊"; "▉"; "█" |]
+
+let utf_num = Array.length utf8_chars - 1
+
+(* (c) CraigFe *)
+let show_bar width ppf proportion =
+  let bar_width =
+    let width = width () in
+    width - 2 in
+  let squaresf = Float.of_int bar_width *. proportion in
+  let squares = Float.to_int squaresf in
+  let filled = min squares bar_width in
+  let not_filled = bar_width - filled - 1 in
+  Format.pp_print_string ppf "│" ;
+  for _ = 1 to filled do
+    Format.pp_print_string ppf utf8_chars.(utf_num)
+  done ;
+  (if filled <> bar_width
+   then
+     let () =
+       let chunks = Float.to_int (squaresf *. Float.of_int utf_num) in
+       let index = chunks - (filled * utf_num) in
+       if index < utf_num then Format.pp_print_string ppf utf8_chars.(index)
+     in
+     for _ = 1 to not_filled do
+       Format.pp_print_string ppf utf8_chars.(0)
+     done) ;
+  Format.pp_print_string ppf "│"
+
+let exit_failure = 1
+let exit_success = 0
+
+let show res =
+  let er = count ~p:is_error res in
+  if er > 0
+  then (
+    pr "Got %d error(s).\n%!" er ;
+    exit exit_failure)
+  else
+    let res = map ~f:get_ok res in
+    let total = fold ~f:Int64.add 0L res in
+    let max = fold ~f:max 0L res in
+    let min = fold ~f:min max res in
+    let avg = Int64.div total (Int64.of_int (Array.length res)) in
+    pr "Total:   %2.03fs\n%!" (to_sec total) ;
+    pr "Slowest: %2.03fs\n%!" (to_sec max) ;
+    pr "Fastest: %2.03fs\n%!" (to_sec min) ;
+    pr "Average: %2.03fs\n%!" (to_sec avg) ;
+    let histogram = histogram res in
+    let width () = 40 in
+    let max =
+      Float.of_int (List.fold_left (fun a (_, v) -> v + a) 0 histogram) in
+    pr "\n%!" ;
+    pr "Response time histogram:\n%!" ;
+    List.iter
+      (fun (k, v) ->
+        let v = Int64.of_int v in
+        let p = Int64.to_float v /. max in
+        pr "%0.3f [%03Ld]\t%a\n%!" k v (show_bar width) p)
+      histogram ;
+    exit exit_success
+
+let concurrency = ref 50
+let number = ref 200
+let uri = ref None
+
+let anonymous_argument v =
+  match !uri with
+  | None -> (
+      try uri := Some (Uri.of_string v)
+      with _ ->
+        Format.eprintf "Invalid uri: %S.\n%!" v ;
+        exit exit_failure)
+  | Some _ -> ()
+
+let spec =
+  [
+    ( "-c",
+      Arg.Set_int concurrency,
+      "Number of workers to run concurrently. Total number of requests cannot \
+       be smaller than the concurrency level. Default is 50." );
+    ("-n", Arg.Set_int number, "Number of requests to run. Default is 200.");
+  ]
+
+let usage = Format.asprintf "%s [-c <number>] [-n <number>] uri" Sys.argv.(0)
+
+let () =
+  Arg.parse spec anonymous_argument usage ;
+  match !uri with
+  | Some uri ->
+      Fiber.set_concurrency !concurrency ;
+      (* Lwt_preemptive.init !concurrency !concurrency ignore ; *)
+      let res = Fiber.run (clients ~n:!number uri) in
+      show res
+  | None ->
+      Format.eprintf "%s\n%!" usage ;
+      exit exit_failure

unikernel/duniverse/paf-le-chien/test/dune

@@ -0,0 +1,66 @@
+(library
+ (name fiber)
+ (modules fiber)
+ (libraries fmt logs lwt.unix unix))
+
+(executable
+ (name simple_server)
+ (modules simple_server)
+ (libraries logs.fmt fmt.tty mirage-crypto-rng.unix tcpip.stack-socket
+   paf.mirage))
+
+(library
+ (name simple_client)
+ (modules simple_client)
+ (libraries lwt.unix logs.fmt fmt.tty uri mirage-crypto-rng.unix
+   tcpip.stack-socket paf.mirage))
+
+(executable
+ (name clients)
+ (modules clients)
+ (foreign_stubs
+  (language c)
+  (names mclock))
+ (libraries fiber simple_client))
+
+(executable
+ (name test)
+ (modules test)
+ (libraries uri unix))
+
+(executable
+ (name test_alpn)
+ (modules test_alpn)
+ (libraries fmt.tty logs.fmt alcotest-lwt tcpip.stack-socket paf.alpn
+   paf.mirage mirage-crypto-rng.unix))
+
+(executable
+ (name test_cohttp)
+ (modules test_cohttp)
+ (libraries fmt.tty logs.fmt alcotest-lwt tcpip.stack-socket cohttp-lwt
+   paf-cohttp paf.mirage mirage-crypto-rng.unix astring))
+
+(rule
+ (alias runtest)
+ (package paf)
+ (deps server.pem server.key %{exe:test_alpn.exe})
+ (enabled_if %{arch_sixtyfour})
+ (action
+  (run ./test_alpn.exe --color=always)))
+
+(rule
+ (alias runtest)
+ (package paf)
+ (locks m)
+ (deps server.pem server.key file.txt %{exe:clients.exe}
+   %{exe:simple_server.exe})
+ (action
+  (run ./test.exe -c 50 -n 200)))
+
+(rule
+ (alias runtest)
+ (locks m)
+ (package paf-cohttp)
+ (deps server.pem server.key %{exe:test_cohttp.exe})
+ (action
+  (run ./test_cohttp.exe --color=always)))

unikernel/duniverse/paf-le-chien/test/fiber.ml

@@ -0,0 +1,157 @@
+let src = Logs.Src.create "fiber"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+type 'a t = ('a -> unit) -> unit
+
+let return x k = k x
+let ( >>> ) a b k = a (fun () -> b k)
+let ( >>= ) t f k = t (fun x -> f x k)
+let ( >>| ) t f k = t (fun x -> k (f x))
+
+let both a b =
+  a >>= fun a ->
+  b >>= fun b -> return (a, b)
+
+module Ivar = struct
+  type 'a state = Full of 'a | Empty of ('a -> unit) Queue.t
+  type 'a t = { mutable state : 'a state }
+
+  let create () = { state = Empty (Queue.create ()) }
+
+  let fill t x =
+    match t.state with
+    | Full _ -> failwith "Ivar.fill"
+    | Empty q ->
+        t.state <- Full x ;
+        Queue.iter (fun f -> f x) q
+
+  let read t k = match t.state with Full x -> k x | Empty q -> Queue.push k q
+end
+
+type 'a ivar = 'a Ivar.t
+
+module Future = struct
+  let wait = Ivar.read
+end
+
+let fork f k =
+  let ivar = Ivar.create () in
+  f () (fun x -> Ivar.fill ivar x) ;
+  k ivar
+
+let fork_and_join f g =
+  fork f >>= fun a ->
+  fork g >>= fun b -> both (Future.wait a) (Future.wait b)
+
+let fork_and_join_unit f g =
+  fork f >>= fun a ->
+  fork g >>= fun b -> Future.wait a >>> Future.wait b
+
+let rec parallel_map l ~f =
+  match l with
+  | [] -> return []
+  | x :: l ->
+      fork (fun () -> f x) >>= fun future ->
+      parallel_map l ~f >>= fun l ->
+      Future.wait future >>= fun x -> return (x :: l)
+
+let rec parallel_iter l ~f =
+  match l with
+  | [] -> return ()
+  | x :: l ->
+      fork (fun () -> f x) >>= fun future ->
+      parallel_iter l ~f >>= fun () -> Future.wait future
+
+let safe_close fd = try Unix.close fd with Unix.Unix_error _ -> ()
+
+let create_process prgn =
+  let out0, out1 = Unix.pipe () in
+  (* XXX(dinosaure): to ~safely~ use [Lwt_main.run] , we must use [Lwt_unix.fork].
+   * However, this code is **really bad**! You should never start an [Lwt_main.run]
+   * inside a /fork/. [Lwt_unix.fork] ensures to properly clone() for a sub-lwt-process
+   * but this code can easily break. *)
+  Log.debug (fun m -> m "Create a new process.") ;
+  match Lwt_unix.fork () with
+  | 0 -> (
+      Unix.close out0 ;
+      let oc = Unix.out_channel_of_descr out1 in
+      try
+        Marshal.to_channel oc (prgn ()) [ Marshal.No_sharing ] ;
+        Log.debug (fun m ->
+            m "Transmit the result of the program to the parent.") ;
+        flush oc ;
+        Unix.close out1 ;
+        Log.debug (fun m -> m "Process ended.") ;
+        exit 0
+      with exn ->
+        Log.err (fun m ->
+            m "Process ended with an exception: %s." (Printexc.to_string exn)) ;
+        exit 127)
+  | pid ->
+      Log.debug (fun m -> m "%d created." pid) ;
+      Unix.close out1 ;
+      (out0, pid)
+
+let concurrency = ref 4
+let running = Hashtbl.create ~random:false !concurrency
+let waiting_for_slot = Queue.create ()
+let set_concurrency n = concurrency := n
+let get_concurrency () = !concurrency
+
+let throttle () =
+  if Hashtbl.length running >= !concurrency
+  then (
+    let ivar = Ivar.create () in
+    Queue.push ivar waiting_for_slot ;
+    Log.debug (fun m -> m "Waiting for a new slot.") ;
+    Ivar.read ivar)
+  else return ()
+
+let restart_throttle () =
+  while
+    Hashtbl.length running < !concurrency
+    && not (Queue.is_empty waiting_for_slot)
+  do
+    Ivar.fill (Queue.pop waiting_for_slot) ()
+  done
+
+let run_process prgn =
+  throttle () >>= fun () ->
+  let fd, pid = create_process prgn in
+  let ivar = Ivar.create () in
+  Hashtbl.add running pid ivar ;
+  Ivar.read ivar >>= fun status ->
+  Log.debug (fun m -> m "%d ended." pid) ;
+  let ic = Unix.in_channel_of_descr fd in
+  let res = Marshal.from_channel ic in
+  safe_close fd ;
+  match status with
+  | Unix.WEXITED 0 ->
+      Log.debug (fun m -> m "%d ended properly." pid) ;
+      return (Ok res)
+  | Unix.WEXITED n ->
+      Log.err (fun m -> m "%d got an error: %d." pid n) ;
+      return (Error n)
+  | Unix.WSIGNALED _ ->
+      Log.err (fun m -> m "%d received a signal." pid) ;
+      return (Error 255)
+  | Unix.WSTOPPED _ ->
+      Log.err (fun m -> m "%d was stopped." pid) ;
+      assert false
+
+let run fiber =
+  let result = ref None in
+  fiber (fun x -> result := Some x) ;
+  let rec loop () =
+    if Hashtbl.length running > 0
+    then (
+      Log.debug (fun m -> m "Waiting a process.") ;
+      let pid, status = Unix.wait () in
+      let ivar = Hashtbl.find running pid in
+      Hashtbl.remove running pid ;
+      Ivar.fill ivar status ;
+      restart_throttle () ;
+      loop ())
+    else match !result with Some x -> x | None -> failwith "fiber" in
+  loop ()

unikernel/duniverse/paf-le-chien/test/fiber.mli

@@ -0,0 +1,17 @@
+type 'a t
+type 'a ivar
+
+val return : 'a -> 'a t
+val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
+val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t
+val ( >>> ) : unit t -> unit t -> unit t
+val both : 'a t -> 'b t -> ('a * 'b) t
+val fork : (unit -> 'a t) -> 'a ivar t
+val fork_and_join : (unit -> 'a t) -> (unit -> 'b t) -> ('a * 'b) t
+val fork_and_join_unit : (unit -> unit t) -> (unit -> unit t) -> unit t
+val parallel_map : 'a list -> f:('a -> 'b t) -> 'b list t
+val parallel_iter : 'a list -> f:('a -> unit t) -> unit t
+val run_process : (unit -> 'a) -> ('a, int) result t
+val run : 'a t -> 'a
+val set_concurrency : int -> unit
+val get_concurrency : unit -> int

unikernel/duniverse/paf-le-chien/test/mclock.c

@@ -0,0 +1,38 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <time.h>
+#include <errno.h>
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+
+#ifndef __unused
+#define __unused(x) x __attribute((unused))
+#endif
+#define __unit() value __unused(unit)
+
+uint64_t
+n_mclock(__unit ())
+{
+  struct timespec ts;
+
+  clock_gettime(CLOCK_MONOTONIC, &ts);
+
+  return ((uint64_t) ts.tv_sec
+          * (uint64_t) 1000000000LL
+          + (uint64_t) ts.tv_nsec);
+}
+
+CAMLprim value
+b_mclock(__unit ())
+{
+  struct timespec ts;
+
+  clock_gettime(CLOCK_MONOTONIC, &ts);
+
+  return caml_copy_int64((uint64_t) ts.tv_sec
+                         * (uint64_t) 1000000000LL
+                         + (uint64_t) ts.tv_nsec);
+}

unikernel/duniverse/paf-le-chien/test/server.key

@@ -0,0 +1,15 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIICXQIBAAKBgQC2QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJv
+K+aOANKIsOOr9v4RiEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTRE
+BE/t1soVT3a/vVJWCLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQAB
+AoGAd/CShG8g/JBMh9Nz/8KAuKHRHc2BvysIM1C62cSosgaFmdRrazJfBrEv3Nlc
+2/0uc2dVYIxuvm8bIFqi2TWOdX9jWJf6oXwEPXCD0SaDbJTaoh0b+wjyHuaGlttY
+Ztvmf8mK1BOhyl3vNMxh/8Re0dGvGgPZHpn8zanaqfGVz+ECQQDngieUpwzxA0QZ
+GZKRYhHoLEaPiQzBaXphqWcCLLN7oAKxZlUCUckxRRe0tKINf0cB3Kr9gGQjPpm0
+YoqXo8mNAkEAyYgdd+JDi9FH3Cz6ijvPU0hYkriwTii0V09+Ar5DvYQNzNEIEJu8
+Q3Yte/TPRuK8zhnp97Bsy9v/Ji/LSWbtZQJBAJe9y8u3otfmWCBLjrIUIcCYJLe4
+ENBFHp4ctxPJ0Ora+mjkthuLF+BfdSZQr1dBcX1a8giuuvQO+Bgv7r9t75ECQC7F
+omEyaA7JEW5uGe9/Fgz0G2ph5rkdBU3GKy6jzcDsJu/EC6UfH8Bgawn7tSd0c/E5
+Xm2Xyog9lKfeK8XrV2kCQQCTico5lQPjfIwjhvn45ALc/0OrkaK0hQNpXgUNFJFQ
+tuX2WMD5flMyA5PCx5XBU8gEMHYa8Kr5d6uoixnbS0cZ
+-----END RSA PRIVATE KEY-----

unikernel/duniverse/paf-le-chien/test/server.pem

@@ -0,0 +1,15 @@
+-----BEGIN CERTIFICATE-----
+MIICYzCCAcwCCQDLbE6ES1ih1DANBgkqhkiG9w0BAQUFADB2MQswCQYDVQQGEwJB
+VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0
+cyBQdHkgTHRkMRUwEwYDVQQDDAxZT1VSIE5BTUUhISExGDAWBgkqhkiG9w0BCQEW
+CW1lQGJhci5kZTAeFw0xNDAyMTcyMjA4NDVaFw0xNTAyMTcyMjA4NDVaMHYxCzAJ
+BgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l
+dCBXaWRnaXRzIFB0eSBMdGQxFTATBgNVBAMMDFlPVVIgTkFNRSEhITEYMBYGCSqG
+SIb3DQEJARYJbWVAYmFyLmRlMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC2
+QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJvK+aOANKIsOOr9v4R
+iEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTREBE/t1soVT3a/vVJW
+CLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQABMA0GCSqGSIb3DQEB
+BQUAA4GBAIo4ZppIlp3JRyltRC1/AyCC0tsh5TdM3W7258wdoP3lEe08UlLwpnPc
+aJ/cX8rMG4Xf4it77yrbVrU3MumBEGN5TW4jn4+iZyFbp6TT3OUF55nsXDjNHBbu
+deDVpGuPTI6CZQVhU5qEMF3xmlokG+VV+HCDTglNQc+fdLM0LoNF
+-----END CERTIFICATE-----

unikernel/duniverse/paf-le-chien/test/simple_client.ml

@@ -0,0 +1,197 @@
+let reporter ppf =
+  let report src level ~over k msgf =
+    let k _ =
+      over () ;
+      k () in
+    let with_metadata header _tags k ppf fmt =
+      Format.kfprintf k ppf
+        ("[%a]%a[%a]: " ^^ fmt ^^ "\n%!")
+        Fmt.(styled `Blue int)
+        (Unix.getpid ()) Logs_fmt.pp_header (level, header)
+        Fmt.(styled `Magenta string)
+        (Logs.Src.name src) in
+    msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in
+  { Logs.report }
+
+(*
+let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ()
+let () = Logs.set_reporter (reporter Fmt.stderr)
+let () = Logs.set_level ~all:true (Some Logs.Debug)
+*)
+
+let failf fmt = Format.kasprintf failwith fmt
+let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt
+let src = Logs.Src.create "simple-client"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+module P = Paf_mirage.Make (Tcpip_stack_socket.V4V6.TCP)
+open Lwt.Infix
+
+let ( >>? ) x f =
+  x >>= function Ok x -> f x | Error err -> Lwt.return_error err
+
+let ( <.> ) f g x = f (g x)
+let apply v f = f v
+
+let response_handler : type reqd headers request response ro wo.
+    _ ->
+    f:(H1.Response.t -> string -> unit Lwt.t) ->
+    Mimic.flow ->
+    (Ipaddr.t * int) option ->
+    response ->
+    ro ->
+    (reqd, headers, request, response, ro, wo) Alpn.protocol ->
+    unit =
+ fun th_err ~f _flow _edn response body -> function
+  | Alpn.H2 (module Reqd) -> failf "Invalid protocol H2"
+  | Alpn.HTTP_1_1 (module Reqd) -> (
+      let buf = Buffer.create 0x100 in
+      let th, wk = Lwt.wait () in
+      let on_eof () =
+        H1.Body.Reader.close body ;
+        Lwt.wakeup_later wk () in
+      let rec on_read payload ~off ~len =
+        Buffer.add_string buf (Bigstringaf.substring payload ~off ~len) ;
+        H1.Body.Reader.schedule_read body ~on_eof ~on_read in
+      H1.Body.Reader.schedule_read body ~on_eof ~on_read ;
+      Lwt.async @@ fun () ->
+      Lwt.pick [ (th >|= fun () -> `Done); th_err ] >>= function
+      | `Done -> f response (Buffer.contents buf)
+      | _ ->
+          H1.Body.Reader.close body ;
+          Lwt.return_unit)
+
+let failf fmt = Format.kasprintf (fun err -> raise (Failure err)) fmt
+
+let error_handler wk _ _protocol err =
+  Lwt.wakeup_later wk (err :> [ `Body of string | `Done | Alpn.client_error ]) ;
+  match err with
+  | `Invalid_response_body_length_v1 _ | `Invalid_response_body_length_v2 _ ->
+      failf "Invalid response body-length"
+  | `Malformed_response _ -> failf "Malformed response"
+  | `Exn exn -> raise exn
+  | `Protocol_error (_error_code, _msg) -> failf "Protocol error"
+
+let client_handler th_err ~f wk =
+  {
+    Alpn.error = (fun edn protocol error -> error_handler wk edn protocol error);
+    Alpn.response =
+      (fun edn response body protocol ->
+        response_handler th_err ~f edn response body protocol);
+  }
+
+let anchors = []
+
+let null =
+  let authenticator ?ip:_ ~host:_ _ = Ok None in
+  Result.get_ok (Tls.Config.client ~authenticator ())
+
+let v =
+  Tcpip_stack_socket.V4V6.UDP.connect ~ipv4_only:false ~ipv6_only:false
+    Ipaddr.V4.Prefix.global None
+  >>= fun udpv4 ->
+  Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only:false ~ipv6_only:false
+    Ipaddr.V4.Prefix.global None
+  >>= fun tcpv4 -> Tcpip_stack_socket.V4V6.connect udpv4 tcpv4
+
+let stack = Mimic.make ~name:"stack"
+let ipaddr = Mimic.make ~name:"ipaddr"
+let port = Mimic.make ~name:"port"
+let domain_name = Mimic.make ~name:"domain-name"
+let scheme = Mimic.make ~name:"scheme"
+let tls = Mimic.make ~name:"tls"
+
+let tcp_connect scheme stack ipaddr port =
+  match scheme with
+  | `HTTP -> Lwt.return_some (stack, ipaddr, port)
+  | `HTTPS -> Lwt.return_none
+
+let dns_resolve domain_name =
+  match Unix.gethostbyname (Domain_name.to_string domain_name) with
+  | { Unix.h_addr_list; _ } ->
+      if Array.length h_addr_list > 0
+      then Lwt.return_some (Ipaddr_unix.of_inet_addr h_addr_list.(0))
+      else Lwt.return_none
+  | exception _ -> Lwt.return_none
+
+let tls_connect scheme domain_name cfg stack ipaddr port =
+  match scheme with
+  | `HTTPS -> Lwt.return_some (domain_name, cfg, stack, ipaddr, port)
+  | `HTTP -> Lwt.return_none
+
+let ctx =
+  Mimic.empty
+  |> Mimic.(
+       fold P.tcp_edn
+         Fun.[ req scheme; req stack; req ipaddr; dft port 80 ]
+         ~k:tcp_connect)
+  |> Mimic.(
+       fold P.tls_edn
+         Fun.
+           [
+             req scheme;
+             opt domain_name;
+             dft tls null;
+             req stack;
+             req ipaddr;
+             dft port 443;
+           ]
+         ~k:tls_connect)
+  |> Mimic.(fold ipaddr Fun.[ req domain_name ] ~k:dns_resolve)
+
+let run uri =
+  let th, wk = Lwt.wait () in
+  let f _ body =
+    Lwt.wakeup_later wk body ;
+    Lwt.return_unit in
+  let th_err, (wk_err : [ `Body of string | `Done | Alpn.client_error ] Lwt.u) =
+    Lwt.wait () in
+  let ctx =
+    match Uri.scheme uri with
+    | Some "http" -> Mimic.add scheme `HTTP ctx
+    | Some "https" -> Mimic.add scheme `HTTPS ctx
+    | _ -> ctx in
+  let ctx, hostname =
+    match Uri.host uri with
+    | None -> (ctx, None)
+    | Some host ->
+    match
+      ( Ipaddr.of_string host,
+        Result.bind (Domain_name.of_string host) Domain_name.host )
+    with
+    | Ok v0, Ok v1 ->
+        (ctx |> Mimic.add ipaddr v0 |> Mimic.add domain_name v1, Some host)
+    | Ok v, _ -> (ctx |> Mimic.add ipaddr v, Some host)
+    | _, Ok v -> (ctx |> Mimic.add domain_name v, Some host)
+    | _ -> (ctx, Some host) in
+  let ctx =
+    match Uri.port uri with Some v -> Mimic.add port v ctx | None -> ctx in
+  let headers =
+    Option.fold ~none:H1.Headers.empty
+      ~some:(fun hostname -> H1.Headers.of_list [ ("Host", hostname) ])
+      hostname in
+  let request = H1.Request.create ~headers `GET (Uri.path uri) in
+  v >>= fun v ->
+  let ctx = Mimic.add stack (Tcpip_stack_socket.V4V6.tcp v) ctx in
+  (* XXX(dinosaure): we don't fill the [ctx] with [Paf_mirage.paf_transmission]
+   * which is fine because we only want to send HTTP/1.1 requests and we don't
+   * need to proceed the ALPN challenge - so we don't need to inform [Paf_mirage.run]
+   * about the type of the connection and if we got the ALPN protocol _via_ the [ctx]
+   * and [paf_transmission] - in the default case, we proceed an HTTP/1.1 request.
+   *
+   * However, if we want to test an {i alpn} service, we must refactorize the code
+   * above to automatically add [paf_transmission] as a proceeded information into
+   * the [ctx] after a [Mimic.unfold]. *)
+  Paf_mirage.run ~ctx (client_handler th_err ~f wk_err) (`V1 request)
+  >>= function
+  | Error err ->
+      Log.err (fun m -> m "Got an error: %a." Mimic.pp_error err) ;
+      Lwt.return_error err
+  | Ok (Alpn.Response_H2 _) -> Lwt.return_error (`Msg "Invalid protocol (H2)")
+  | Ok (Alpn.Response_HTTP_1_1 (body, _)) -> (
+      H1.Body.Writer.close body ;
+      Lwt.pick [ (th >|= fun body -> `Body body); th_err ] >>= function
+      | `Body body -> Lwt.return_ok body
+      | _ ->
+          H1.Body.Writer.close body ;
+          Lwt.return_error (`Msg "Got an error while sending request"))

unikernel/duniverse/paf-le-chien/test/simple_server.ml

@@ -0,0 +1,193 @@
+let reporter ppf =
+  let report src level ~over k msgf =
+    let k _ =
+      over () ;
+      k () in
+    let with_metadata header _tags k ppf fmt =
+      Format.kfprintf k ppf
+        ("%a[%a]: " ^^ fmt ^^ "\n%!")
+        Logs_fmt.pp_header (level, header)
+        Fmt.(styled `Magenta string)
+        (Logs.Src.name src) in
+    msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in
+  { Logs.report }
+
+let apply v f = f v
+let sigpipe = 13
+let () = Mirage_crypto_rng_unix.use_default ()
+let () = Printexc.record_backtrace true
+
+(*
+let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ()
+let () = Logs.set_reporter (reporter Fmt.stdout)
+let () = Logs.set_level ~all:true (Some Logs.Debug)
+*)
+
+let () = Sys.set_signal sigpipe Sys.Signal_ignore
+let src = Logs.Src.create "simple-server"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+module P = Paf_mirage.Make (Tcpip_stack_socket.V4V6.TCP)
+module Ke = Ke.Rke
+
+let getline queue =
+  let exists ~predicate queue =
+    let pos = ref 0 and res = ref (-1) in
+    Ke.iter
+      (fun chr ->
+        if predicate chr then res := !pos ;
+        incr pos)
+      queue ;
+    if !res = -1 then None else Some !res in
+  let blit src src_off dst dst_off len =
+    Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len in
+  match exists ~predicate:(( = ) '\n') queue with
+  | Some pos ->
+      let tmp = Bytes.create pos in
+      Ke.N.keep_exn queue ~blit ~length:Bytes.length ~off:0 ~len:pos tmp ;
+      Ke.N.shift_exn queue (pos + 1) ;
+      Some (Bytes.unsafe_to_string tmp)
+  | None -> None
+
+let http_large filename ?shutdown:_ (_ip, _port) ic oc =
+  let open H1 in
+  Body.Reader.close ic ;
+  let ic = open_in filename in
+  let tp = Bytes.create 0x1000 in
+  let rec go () =
+    match input ic tp 0 (Bytes.length tp) with
+    | 0 -> Body.Writer.close oc
+    | len ->
+        Body.Writer.write_string oc (Bytes.sub_string tp 0 len) ;
+        go ()
+    | exception End_of_file -> Body.Writer.close oc in
+  go () ;
+  close_in ic
+
+let http_ping_pong ?shutdown:_ (_ip, _port) ic oc =
+  let open H1 in
+  let open Lwt.Infix in
+  let closed = ref false and queue = Ke.create ~capacity:0x1000 Bigarray.char in
+
+  let blit src src_off dst dst_off len =
+    Bigstringaf.blit src ~src_off dst ~dst_off ~len in
+  let on_eof () = closed := true in
+  let rec on_read buf ~off ~len =
+    Ke.N.push queue ~blit ~length:Bigstringaf.length buf ~off ~len ;
+    Body.Reader.schedule_read ic ~on_eof ~on_read in
+  Body.Reader.schedule_read ic ~on_eof ~on_read ;
+  let rec go () =
+    match (!closed, getline queue) with
+    | false, None -> Lwt.pause () >>= go
+    | false, Some "ping" ->
+        Body.Writer.write_string oc "pong\n" ;
+        go ()
+    | false, Some "pong" ->
+        Body.Writer.write_string oc "ping\n" ;
+        go ()
+    | false, Some _line ->
+        Body.Writer.close oc ;
+        Lwt.return_unit
+    | true, _ ->
+        Body.Writer.close oc ;
+        Lwt.return_unit in
+  Lwt.async go
+
+let request_handler large ?shutdown _flow (ip, port) reqd =
+  let open H1 in
+  let request = Reqd.request reqd in
+  match request.Request.target with
+  | "/" ->
+      let headers = Headers.of_list [ ("transfer-encoding", "chunked") ] in
+      let response = Response.create ~headers `OK in
+      let oc = Reqd.respond_with_streaming reqd response in
+      http_ping_pong ?shutdown (ip, port) (Reqd.request_body reqd) oc
+  | "/ping" ->
+      let headers = Headers.of_list [ ("content-length", "4") ] in
+      let response = Response.create ~headers `OK in
+      Reqd.respond_with_string reqd response "pong" ;
+      Option.iter (apply ()) shutdown
+  | "/pong" ->
+      let headers = Headers.of_list [ ("content-length", "4") ] in
+      let response = Response.create ~headers `OK in
+      Reqd.respond_with_string reqd response "ping" ;
+      Option.iter (apply ()) shutdown
+  | "/large" ->
+      let headers = Headers.of_list [ ("transfer-encoding", "chunked") ] in
+      let response = Response.create ~headers `OK in
+      let oc = Reqd.respond_with_streaming reqd response in
+      http_large large ?shutdown (ip, port) (Reqd.request_body reqd) oc
+  | _ -> assert false
+
+let error_handler _ ?request:_ error _respond =
+  match error with
+  | `Exn _exn -> Printexc.print_backtrace stderr
+  | `Bad_gateway -> Fmt.epr "Got a bad gateway error.\n%!"
+  | `Bad_request -> Fmt.epr "Got a bad request error.\n%!"
+  | `Internal_server_error -> Fmt.epr "Got an internal server error.\n%!"
+
+let ( <.> ) f g x = f (g x)
+
+open Lwt.Infix
+
+let ( >>? ) x f =
+  x >>= function Ok x -> f x | Error _ as err -> Lwt.return err
+
+let fd_8080 = Unix.openfile "lock.8080" Unix.[ O_CREAT; O_RDWR ] 0o644
+let () = at_exit (fun () -> try Unix.close fd_8080 with _exn -> ())
+let fd_4343 = Unix.openfile "lock.4343" Unix.[ O_CREAT; O_RDWR ] 0o644
+let () = at_exit (fun () -> try Unix.close fd_4343 with _exn -> ())
+let unlock fd = Unix.lockf fd Unix.F_ULOCK 0
+
+let server_http large stack =
+  P.init ~port:8080 stack >>= fun service ->
+  let http = P.http_service ~error_handler (request_handler large) in
+  let (`Initialized th) = P.serve http service in
+  unlock fd_8080 ;
+  Log.debug (fun m -> m "HTTP server initialized.") ;
+  th
+
+let load_file filename =
+  let ic = open_in filename in
+  let ln = in_channel_length ic in
+  let rs = Bytes.create ln in
+  really_input ic rs 0 ln ;
+  close_in ic ;
+  Bytes.unsafe_to_string rs
+
+let server_https cert key large stack =
+  let cert = load_file cert in
+  let key = load_file key in
+  match
+    (X509.Certificate.decode_pem_multiple cert, X509.Private_key.decode_pem key)
+  with
+  | Ok certs, Ok (`RSA key) ->
+      let tls =
+        Result.get_ok
+          (Tls.Config.server ~certificates:(`Single (certs, `RSA key)) ()) in
+      P.init ~port:4343 stack >>= fun service ->
+      let https = P.https_service ~tls ~error_handler (request_handler large) in
+      let (`Initialized th) = P.serve https service in
+      unlock fd_4343 ;
+      th
+  | _ -> invalid_arg "Invalid certificate or key"
+
+let stack =
+  Tcpip_stack_socket.V4V6.UDP.connect ~ipv4_only:false ~ipv6_only:false
+    Ipaddr.V4.Prefix.global None
+  >>= fun udpv4 ->
+  Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only:false ~ipv6_only:false
+    Ipaddr.V4.Prefix.global None
+  >>= fun tcpv4 -> Tcpip_stack_socket.V4V6.connect udpv4 tcpv4
+
+let run_http large = stack >|= Tcpip_stack_socket.V4V6.tcp >>= server_http large
+
+let run_https cert key large =
+  stack >|= Tcpip_stack_socket.V4V6.tcp >>= server_https cert key large
+
+let () =
+  match Sys.argv with
+  | [| _; "--with-tls"; cert; key; large |] ->
+      Lwt_main.run (run_https cert key large)
+  | [| _; large |] -> Lwt_main.run (run_http large)
+  | _ -> Fmt.epr "%s [--with-tls cert key] large\n%!" Sys.argv.(0)

unikernel/duniverse/paf-le-chien/test/test.ml

@@ -0,0 +1,109 @@
+let null = Unix.openfile "/dev/null" Unix.[ O_CLOEXEC ] 0o644
+let () = at_exit (fun () -> try Unix.close null with _exn -> ())
+
+let create_lock filename =
+  let fd = Unix.openfile filename Unix.[ O_CREAT; O_RDWR ] 0o644 in
+  ignore (Unix.lseek fd 0 Unix.SEEK_SET) ;
+  fd
+
+let lock fd = Unix.lockf fd Unix.F_LOCK 0
+let unlock fd = Unix.lockf fd Unix.F_ULOCK 0
+
+(* XXX(dinosaure): this test wants to check with **true** parallelism
+ * that our server and our client works together (at least). The true
+ * parallelism is done by the clone()/fork() syscall - by this way,
+ * we are not constrained by the global GC lock.
+ *
+ * locks ([lock.8080]/[lock.4343]) permit to launch safely clients
+ * when, at least, servers are initialised. Then, we launch clients
+ * [N] times on some specific endpoints:
+ * - [/]
+ * - [/large]
+ * with TLS and without TLS. We see then (with a monotonic clock)
+ * the time spent by such request and generate an histogram. If
+ * one request fails, the test fails. Otherwise, we have a performance
+ * report about our implementation.
+ *
+ * The test does not want to provide metrics about performance. It
+ * gives this information but it's not real /benchmark/! *)
+
+let launch_server () =
+  let lock0 = create_lock "lock.4343" in
+  let lock1 = create_lock "lock.8080" in
+  let pid0 =
+    Unix.create_process_env "./simple_server.exe"
+      [|
+        "./simple_server.exe";
+        "--with-tls";
+        "server.pem";
+        "server.key";
+        "file.txt";
+      |]
+      [||] null Unix.stdout null in
+  let pid1 =
+    Unix.create_process_env "./simple_server.exe"
+      [| "./simple_server.exe"; "file.txt" |]
+      [||] null Unix.stdout null in
+  at_exit (fun () ->
+      try
+        Unix.close lock0 ;
+        Unix.unlink "lock.4343"
+      with _exn -> ()) ;
+  at_exit (fun () ->
+      try
+        Unix.close lock1 ;
+        Unix.unlink "lock.8080"
+      with _exn -> ()) ;
+  lock lock0 ;
+  lock lock1 ;
+  (lock0, lock1, pid0, pid1)
+
+let launch_clients c n uri =
+  Format.printf "===== -c %d -n %d %a =====\n%!" c n Uri.pp uri ;
+  let pid =
+    Unix.create_process_env "./clients.exe"
+      [|
+        "./clients.exe";
+        "-c";
+        string_of_int c;
+        "-n";
+        string_of_int n;
+        Uri.to_string uri;
+      |]
+      [||] Unix.stdin Unix.stdout Unix.stderr in
+  let _, _ = Unix.waitpid [] pid in
+  Format.printf "\n%!"
+
+let concurrency = ref 50
+let number = ref 200
+let anonymous_argument _ = ()
+
+let spec =
+  [
+    ( "-c",
+      Arg.Set_int concurrency,
+      "Number of workers to run concurrently. Total number of requests cannot \
+       be smaller than the concurrency level. Default is 50." );
+    ("-n", Arg.Set_int number, "Number of requests to run. Default is 200.");
+  ]
+
+let usage = Format.asprintf "%s [-c <number>] [-n <number>]" Sys.argv.(0)
+
+let () =
+  Arg.parse spec anonymous_argument usage ;
+  let lock0, lock1, pid0, pid1 = launch_server () in
+  lock lock0 ;
+  lock lock1 ;
+  Unix.sleep 2 ;
+  (* XXX(dinosaure): needed because [Paf.init/Stack.listen] does not ensure that
+   * we listen **after**. Lwt can schedule it in an other way... see mirage/mirage-tcpip#438 *)
+  launch_clients !concurrency !number (Uri.of_string "https://localhost:4343/") ;
+  launch_clients !concurrency !number
+    (Uri.of_string "https://localhost:4343/large") ;
+  launch_clients !concurrency !number (Uri.of_string "http://localhost:8080/") ;
+  launch_clients !concurrency !number
+    (Uri.of_string "http://localhost:8080/large") ;
+  Unix.kill pid0 Sys.sigint ;
+  Unix.kill pid1 Sys.sigint ;
+  unlock lock0 ;
+  unlock lock1

unikernel/duniverse/paf-le-chien/test/test_alpn.ml

@@ -0,0 +1,212 @@
+open Lwt.Infix
+
+let ( <.> ) f g x = f (g x)
+let ( >>? ) = Lwt_result.bind
+
+let reporter ppf =
+  let report src level ~over k msgf =
+    let k _ =
+      over () ;
+      k () in
+    let with_metadata header _tags k ppf fmt =
+      Format.kfprintf k ppf
+        ("%a[%a]: " ^^ fmt ^^ "\n%!")
+        Logs_fmt.pp_header (level, header)
+        Fmt.(styled `Magenta string)
+        (Logs.Src.name src) in
+    msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in
+  { Logs.report }
+
+let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ()
+let () = Logs.set_reporter (reporter Fmt.stderr)
+let () = Logs.set_level ~all:true (Some Logs.Debug)
+let () = Mirage_crypto_rng_unix.use_default ()
+
+module P = Paf_mirage.Make (Tcpip_stack_socket.V4V6.TCP)
+
+let unix_stack () =
+  Tcpip_stack_socket.V4V6.UDP.connect ~ipv4_only:false ~ipv6_only:false
+    Ipaddr.V4.Prefix.global None
+  >>= fun udpv4 ->
+  Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only:false ~ipv6_only:false
+    Ipaddr.V4.Prefix.global None
+  >>= fun tcpv4 -> Tcpip_stack_socket.V4V6.connect udpv4 tcpv4
+
+let load_file filename =
+  let ic = open_in filename in
+  let ln = in_channel_length ic in
+  let rs = Bytes.create ln in
+  really_input ic rs 0 ln ;
+  close_in ic ;
+  Bytes.unsafe_to_string rs
+
+let tls =
+  let cert = load_file "server.pem" in
+  let key = load_file "server.key" in
+  match
+    (X509.Certificate.decode_pem_multiple cert, X509.Private_key.decode_pem key)
+  with
+  | Ok certs, Ok (`RSA key) ->
+      Result.get_ok
+        (Tls.Config.server ~alpn_protocols:[ "http/1.1"; "h2" ]
+           ~certificates:(`Single (certs, `RSA key))
+           ())
+  | _ -> invalid_arg "Invalid certificate or key"
+
+let alpn_of_tls_connection (_, flow) =
+  match P.TLS.epoch flow with
+  | Ok { Tls.Core.alpn_protocol; _ } ->
+      Fmt.epr ">>> alpn_protocol (server side): %a.\n%!"
+        Fmt.(option string)
+        alpn_protocol ;
+      alpn_protocol
+  | Error _ -> None
+
+let peer_of_tls_connection ((ipaddr, port), _) =
+  Fmt.str "%a:%d" Ipaddr.pp ipaddr port
+
+let injection =
+  let module R = (val Mimic.repr P.tls_protocol) in
+  fun (_, flow) -> R.T flow
+
+let port =
+  let v = ref 9999 in
+  fun () ->
+    incr v ;
+    !v
+
+let service handler () =
+  let info =
+    {
+      Alpn.alpn = alpn_of_tls_connection;
+      Alpn.peer = peer_of_tls_connection;
+      Alpn.injection;
+    } in
+  let handshake flow =
+    let edn = P.TCP.dst flow in
+    P.TLS.server_of_flow tls flow >>= function
+    | Ok flow -> Lwt.return_ok (edn, flow)
+    | Error err ->
+        Lwt.return_error (`Msg (Fmt.str "%a" P.TLS.pp_write_error err))
+  and close = P.close in
+  Alpn.service info handler handshake P.accept close
+
+module R = (val Mimic.repr P.tls_protocol)
+
+type version = HTTP_1_1 | HTTP_2_0
+
+let error_handler _ _protocol ?request:_ _error _response = ()
+
+let request_handler : type reqd headers request response ro wo.
+    _ ->
+    _ ->
+    _ ->
+    _ ->
+    reqd ->
+    (reqd, headers, request, response, ro, wo) Alpn.protocol ->
+    unit =
+ fun wk_request wk _flow _edn _reqd -> function
+  | Alpn.HTTP_1_1 (module Reqd) ->
+      Lwt.wakeup_later wk_request HTTP_1_1 ;
+      Lwt.wakeup_later wk ()
+  | Alpn.H2 (module Reqd) ->
+      Lwt.wakeup_later wk_request HTTP_2_0 ;
+      Lwt.wakeup_later wk ()
+
+let server_handler wk_request wk =
+  {
+    Alpn.error = error_handler;
+    Alpn.request =
+      (fun flow edn reqd protocol ->
+        request_handler wk_request wk flow edn reqd protocol);
+  }
+
+let client ~ctx handler req =
+  Mimic.resolve ctx >>= function
+  | Error err -> Alcotest.failf "%a" Mimic.pp_error err
+  | Ok (R.T v as flow) -> (
+      let alpn =
+        match P.TLS.epoch v with
+        | Ok { Tls.Core.alpn_protocol; _ } -> alpn_protocol
+        | Error _ -> None in
+      Alpn.run ?alpn handler () req flow >>= function
+      | Ok body -> Lwt.return body
+      | Error err -> Alcotest.failf "%a" Mimic.pp_error err)
+  | Ok flow -> (
+      Alpn.run handler () req flow >>= function
+      | Ok body -> Lwt.return body
+      | Error err -> Alcotest.failf "%a" Mimic.pp_error err)
+
+let ctx_with_tls stack ~port tls =
+  let ipaddr = Ipaddr_unix.of_inet_addr Unix.inet_addr_loopback in
+  Mimic.add P.tls_edn (None, tls, stack, ipaddr, port) Mimic.empty
+
+let authenticator ?ip:_ ~host:_ _ = Ok None
+let apply v f = f v
+
+let fake_client_handler =
+  {
+    Alpn.error = (fun _ _protocol _error -> ());
+    Alpn.response = (fun _flow _edn _response _body _protocol -> ());
+  }
+
+let test01 =
+  Alcotest_lwt.test_case "http/1.1" `Quick @@ fun _sw () ->
+  let port = port () in
+  let stop = Lwt_switch.create () in
+  let th, wk = Lwt.wait () in
+  let request, wk_request = Lwt.wait () in
+  let service = service (server_handler wk_request wk) () in
+  let tls =
+    Result.get_ok
+      (Tls.Config.client ~authenticator ~alpn_protocols:[ "http/1.1" ] ()) in
+  let req = `V1 (H1.Request.create `GET "/") in
+  Lwt.both
+    ( unix_stack () >|= Tcpip_stack_socket.V4V6.tcp >>= fun stack ->
+      P.init ~port stack >>= fun t ->
+      P.serve ~stop service t |> fun (`Initialized th) ->
+      let ctx = ctx_with_tls stack ~port tls in
+      Lwt.both (client ~ctx fake_client_handler req) th )
+    (th >>= fun () -> Lwt_switch.turn_off stop)
+  >>= fun ((body, ()), ()) ->
+  request >>= fun request ->
+  match (request, body) with
+  | HTTP_1_1, Alpn.Response_HTTP_1_1 _ ->
+      Alcotest.(check pass) "http/1.1" () () ;
+      Lwt.return_unit
+  | _ -> Alcotest.failf "Unexpected version of HTTP"
+
+let close_body = function
+  | Alpn.Response_HTTP_1_1 _ as response -> response
+  | Alpn.Response_H2 (body, _) as response ->
+      H2.Body.Writer.close body ;
+      response
+
+let test02 =
+  Alcotest_lwt.test_case "h2" `Quick @@ fun _sw () ->
+  let port = port () in
+  let stop = Lwt_switch.create () in
+  let th, wk = Lwt.wait () in
+  let request, wk_request = Lwt.wait () in
+  let service = service (server_handler wk_request wk) () in
+  let tls =
+    Result.get_ok (Tls.Config.client ~authenticator ~alpn_protocols:[ "h2" ] ())
+  in
+  let req = `V2 (H2.Request.create ~scheme:"https" `GET "/") in
+  Lwt.both
+    ( unix_stack () >|= Tcpip_stack_socket.V4V6.tcp >>= fun stack ->
+      P.init ~port stack >>= fun t ->
+      P.serve ~stop service t |> fun (`Initialized th) ->
+      let ctx = ctx_with_tls stack ~port tls in
+      Lwt.both (client ~ctx fake_client_handler req >|= close_body) th )
+    (th >>= fun () -> Lwt_switch.turn_off stop)
+  >>= fun ((body, ()), ()) ->
+  request >>= fun request ->
+  match (request, body) with
+  | HTTP_2_0, Alpn.Response_H2 _ ->
+      Alcotest.(check pass) "h2" () () ;
+      Lwt.return_unit
+  | _ -> Alcotest.failf "Unexpected version of HTTP"
+
+let test () = Alcotest_lwt.run "alpn" [ ("alpn", [ test01; test02 ]) ]
+let () = Lwt_main.run (test ())

unikernel/duniverse/paf-le-chien/test/test_cohttp.ml

@@ -0,0 +1,260 @@
+open Lwt.Infix
+
+let ( <.> ) f g x = f (g x)
+let apply v f = f v
+
+let reporter ppf =
+  let report src level ~over k msgf =
+    let k _ =
+      over () ;
+      k () in
+    let with_metadata header _tags k ppf fmt =
+      Format.kfprintf k ppf
+        ("%a[%a]: " ^^ fmt ^^ "\n%!")
+        Logs_fmt.pp_header (level, header)
+        Fmt.(styled `Magenta string)
+        (Logs.Src.name src) in
+    msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in
+  { Logs.report }
+
+let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ()
+let () = Logs.set_reporter (reporter Fmt.stderr)
+let () = Logs.set_level ~all:true (Some Logs.Debug)
+let () = Mirage_crypto_rng_unix.use_default ()
+
+module P = Paf_mirage.Make (Tcpip_stack_socket.V4V6.TCP)
+
+let unix_stack () =
+  Tcpip_stack_socket.V4V6.UDP.connect ~ipv4_only:false ~ipv6_only:false
+    Ipaddr.V4.Prefix.global None
+  >>= fun udpv4 ->
+  Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only:false ~ipv6_only:false
+    Ipaddr.V4.Prefix.global None
+  >>= fun tcpv4 -> Tcpip_stack_socket.V4V6.connect udpv4 tcpv4
+
+let error_handler (_ip, _port) ?request:_ _error _respond = ()
+
+let load_file filename =
+  let ic = open_in filename in
+  let ln = in_channel_length ic in
+  let rs = Bytes.create ln in
+  really_input ic rs 0 ln ;
+  close_in ic ;
+  Bytes.unsafe_to_string rs
+
+let tls =
+  let cert = load_file "server.pem" in
+  let key = load_file "server.key" in
+  match
+    (X509.Certificate.decode_pem_multiple cert, X509.Private_key.decode_pem key)
+  with
+  | Ok certs, Ok (`RSA key) ->
+      Result.get_ok
+        (Tls.Config.server ~certificates:(`Single (certs, `RSA key)) ())
+  | _ -> invalid_arg "Invalid certificate or key"
+
+let sleep = Lwt_unix.sleep <.> Int64.to_float
+
+let run_http_and_https_server ~request_handler stop =
+  unix_stack () >|= Tcpip_stack_socket.V4V6.tcp >>= fun stack ->
+  P.init ~port:9090 stack >>= fun socket0 ->
+  P.init ~port:3434 stack >>= fun socket1 ->
+  let http = P.http_service ~error_handler (fun _flow -> request_handler) in
+  let https =
+    P.https_service ~tls ~error_handler (fun _flow -> request_handler) in
+  let (`Initialized fiber0) = P.serve ~stop http socket0 in
+  let (`Initialized fiber1) = P.serve ~stop https socket1 in
+  Logs.debug (fun m -> m "Server initialised.") ;
+  Lwt.async (fun () -> Lwt.join [ fiber0; fiber1 ]) ;
+  Lwt.return_unit
+
+let resolver domain_name =
+  match Unix.gethostbyname (Domain_name.to_string domain_name) with
+  | { Unix.h_addr_list; _ } ->
+      if Array.length h_addr_list > 0
+      then Lwt.return_some (Ipaddr_unix.of_inet_addr h_addr_list.(0))
+      else Lwt.return_none
+  | exception _ -> Lwt.return_none
+
+let tcp_connect scheme stack ipaddr port =
+  match scheme with
+  | `HTTP -> Lwt.return_some (stack, ipaddr, port)
+  | _ -> Lwt.return_none
+
+let tls_connect scheme domain_name cfg stack ipaddr port =
+  match scheme with
+  | `HTTPS -> Lwt.return_some (domain_name, cfg, stack, ipaddr, port)
+  | _ -> Lwt.return_none
+
+let null =
+  let authenticator ?ip:_ ~host:_ _ = Ok None in
+  Result.get_ok (Tls.Config.client ~authenticator ())
+
+module Client = Paf_cohttp
+
+let stack = Mimic.make ~name:"stack"
+
+let ctx =
+  let tls = Mimic.make ~name:"tls" in
+  Mimic.empty
+  |> Mimic.(
+       fold P.tcp_edn
+         Fun.
+           [
+             req Paf_cohttp.scheme;
+             req stack;
+             req Paf_cohttp.ipaddr;
+             dft Paf_cohttp.port 9090;
+           ]
+         ~k:tcp_connect)
+  |> Mimic.(
+       fold P.tls_edn
+         Fun.
+           [
+             req Paf_cohttp.scheme;
+             opt Paf_cohttp.domain_name;
+             dft tls null;
+             req stack;
+             req Paf_cohttp.ipaddr;
+             dft Paf_cohttp.port 3434;
+           ]
+         ~k:tls_connect)
+  |> Mimic.(
+       fold Paf_cohttp.ipaddr Fun.[ req Paf_cohttp.domain_name ] ~k:resolver)
+
+let body_to_string body =
+  let buf = Buffer.create 0x100 in
+  let th, wk = Lwt.wait () in
+  let on_eof () =
+    Lwt.wakeup_later wk (Buffer.contents buf) ;
+    H1.Body.Reader.close body in
+  let rec on_read str ~off ~len =
+    let str = Bigstringaf.substring str ~off ~len in
+    Logs.debug (fun m -> m "Received %S." str) ;
+    Buffer.add_string buf str ;
+    H1.Body.Reader.schedule_read body ~on_eof ~on_read in
+  Logs.debug (fun m -> m "Start to receive the body.") ;
+  H1.Body.Reader.schedule_read body ~on_eof ~on_read ;
+  th
+
+let query_to_assoc str =
+  let lst =
+    Astring.String.fields ~is_sep:(function '&' -> true | _ -> false) str in
+  let f str =
+    match Astring.String.cut ~sep:"=" str with
+    | Some (k, v) -> (k, v)
+    | None -> (str, "") in
+  List.map f lst
+
+let request_handler (ip, port) reqd =
+  let open H1 in
+  let req = Reqd.request reqd in
+  Logs.debug (fun m ->
+      m "Got a connection from %a:%d %s." Ipaddr.pp ip port req.Request.target) ;
+  let body = Reqd.request_body reqd in
+  match req.Request.target with
+  | "/" ->
+      let contents = "Hello World!" in
+      let headers =
+        Headers.of_list
+          [ ("content-length", string_of_int (String.length contents)) ] in
+      let resp = Response.create ~headers `OK in
+      Reqd.respond_with_string reqd resp contents ;
+      Lwt.async @@ fun () ->
+      body_to_string body >|= fun _ -> Logs.debug (fun m -> m "Body drained.")
+  | "/repeat" ->
+      Lwt.async @@ fun () ->
+      body_to_string body >|= fun str ->
+      let headers =
+        Headers.of_list
+          [ ("content-length", string_of_int (String.length str)) ] in
+      let resp = Response.create ~headers `OK in
+      Reqd.respond_with_string reqd resp str
+  | target ->
+  match Astring.String.cut ~sep:"?" target with
+  | Some ("/query", query) ->
+      let lst = query_to_assoc query in
+      let buf = Buffer.create 0x100 in
+      let ppf = Format.formatter_of_buffer buf in
+      Fmt.pf ppf "%a%!"
+        Fmt.(list ~sep:(any ";") (pair ~sep:(any "=") string string))
+        lst ;
+      let contents = Buffer.contents buf in
+      let headers =
+        Headers.of_list
+          [ ("content-length", string_of_int (String.length contents)) ] in
+      let resp = Response.create ~headers `OK in
+      Reqd.respond_with_string reqd resp contents ;
+      Lwt.async @@ fun () ->
+      body_to_string body >>= fun _ -> Lwt.return_unit
+  | _ ->
+      Reqd.report_exn reqd Not_found ;
+      let contents = "Invalid request." in
+      let headers =
+        Headers.of_list
+          [ ("content-length", string_of_int (String.length contents)) ] in
+      let resp = Response.create ~headers `Bad_request in
+      Reqd.respond_with_string reqd resp contents
+
+let test01 =
+  Alcotest_lwt.test_case "simple-http" `Quick @@ fun _sw () ->
+  unix_stack () >|= Tcpip_stack_socket.V4V6.tcp >>= fun v ->
+  let ctx = Mimic.add stack v ctx in
+  Client.get ~ctx (Uri.of_string "http://localhost:9090/")
+  >>= fun (_resp, body) ->
+  Cohttp_lwt.Body.to_string body >>= fun str ->
+  Alcotest.(check string) "contents" str "Hello World!" ;
+  Lwt.return_unit
+
+let test02 =
+  Alcotest_lwt.test_case "repeat" `Quick @@ fun _sw () ->
+  unix_stack () >|= Tcpip_stack_socket.V4V6.tcp >>= fun v ->
+  let ctx = Mimic.add stack v ctx in
+  let body = Cohttp_lwt.Body.of_string "Hello!" in
+  Client.post ~ctx ~body (Uri.of_string "http://localhost:9090/repeat")
+  >>= fun (_resp, body) ->
+  Cohttp_lwt.Body.to_string body >>= fun str ->
+  Alcotest.(check string) "contents" str "Hello!" ;
+  Lwt.return_unit
+
+let test03 =
+  Alcotest_lwt.test_case "simple-https" `Quick @@ fun _sw () ->
+  unix_stack () >|= Tcpip_stack_socket.V4V6.tcp >>= fun v ->
+  let ctx = Mimic.add stack v ctx in
+  Client.get ~ctx (Uri.of_string "https://localhost:3434/")
+  >>= fun (_resp, body) ->
+  Cohttp_lwt.Body.to_string body >>= fun str ->
+  Alcotest.(check string) "contents" str "Hello World!" ;
+  Lwt.return_unit
+
+let test04 =
+  Alcotest_lwt.test_case "repeat (https)" `Quick @@ fun _sw () ->
+  unix_stack () >|= Tcpip_stack_socket.V4V6.tcp >>= fun v ->
+  let ctx = Mimic.add stack v ctx in
+  let body = Cohttp_lwt.Body.of_string "Secret Hello!" in
+  Client.post ~ctx ~body (Uri.of_string "https://localhost:3434/repeat")
+  >>= fun (_resp, body) ->
+  Cohttp_lwt.Body.to_string body >>= fun str ->
+  Alcotest.(check string) "contents" str "Secret Hello!" ;
+  Lwt.return_unit
+
+let test05 =
+  Alcotest_lwt.test_case "queries" `Quick @@ fun _sw () ->
+  unix_stack () >|= Tcpip_stack_socket.V4V6.tcp >>= fun v ->
+  let ctx = Mimic.add stack v ctx in
+  Client.get ~ctx (Uri.of_string "https://localhost:3434/query?foo=a&bar=b")
+  >>= fun (_resp, body) ->
+  Cohttp_lwt.Body.to_string body >>= fun str ->
+  Alcotest.(check string) "contents" str "foo=a;bar=b" ;
+  Lwt.return_unit
+
+let test () =
+  Alcotest_lwt.run "smart"
+    [ ("cohttp", [ test01; test02; test03; test04; test05 ]) ]
+
+let () =
+  let fiber =
+    Lwt_switch.with_switch @@ fun stop ->
+    run_http_and_https_server ~request_handler stop >>= test >>= fun () ->
+    Lwt_switch.turn_off stop in
+  Lwt_main.run fiber