unikernel/duniverse/paf-le-chien/.gitignore

@@ -0,0 +1,15 @@
+_build
+setup.data
+setup.log
+doc/*.html
+*.native
+*.byte
+*.so
+lib/decompress_conf.ml
+*.tar.gz
+_tests
+lib_test/files
+zpipe
+c/dpipe
+*.merlin
+*.install

unikernel/duniverse/paf-le-chien/.ocamlformat

@@ -0,0 +1,8 @@
+version = 0.27.0
+break-infix = fit-or-vertical
+parse-docstrings = true
+indicate-multiline-delimiters=no
+nested-match=align
+sequence-style=separator
+break-before-in=auto
+if-then-else=keyword-first

unikernel/duniverse/paf-le-chien/CHANGES.md

@@ -0,0 +1,110 @@
+### 0.8.0 (2025-02-17) Paris - France
+
+- Add `x-maintenance-intent` (@hannesm, #100)
+- Remove `mirage-time` dependency and upgrade to mirage-crypto.1.2.0 (@hannesm, #101)
+- Switch to `ocaml-h1` instead of `httpaf` (@dinosaure, #103)
+
+### 0.7.0 (2024-08-28) Paris - France
+
+- Upgrade to tls.1.0.0 and x509.1.0.0 (@hannesm, #96)
+
+### 0.6.0 (2024-05-07) Paris - France
+
+- Fix typographie on errors (@hannesm, #91)
+- Introduce and use the new `shutdown` function (@hannesm, @dinosaure, #92)
+- Update to ocamlformat.0.26.1 (@dinosaure, #94)
+
+### 0.5.0 (2023-21-03) Paris - France
+
+- Upgrade to `mirage-crypto-rng.0.11.0` (@hannesm, @dinosaure, #85)
+- Be able to specify ALPN protocols (@kit-ty-kate, @dinosaure, #86)
+  Also merged into `ocaml-letsencrypt` (see mmaker/ocaml-letsencrypt#33)
+- Set the default protocol used for the ALPN negotiation to "http/1.1" (@dinosaure, #87)
+  Also merged into `ocaml-letsencrypt` (see mmaker/ocaml-letsencrypt#33)
+- Upgrade `paf` to `h2.0.10.0` (@kit-ty-kate, @dinosaure, #83)
+- Replace `Cstruct.copy` (deprecated) by `Cstruct.to_string` (@dinosaure, #83)
+- Delete `paf-le` package (@dinosaure, @hannesm, #88)
+  Implementations are available via the new package `letsencrypt-mirage`
+
+### 0.4.0 (2023-01-10) Paris - France
+
+- Fix memory leak about functor application (@dinosaure, #78)
+- Add a new sub-package `le.mirage` to facilite obtaining a let's encrypt certificate
+  and expose few functions to handle Let's encrypt certificates (@kit-ty-kate, @dinosaure, @hannesm, #75)
+
+### 0.3.0 (2022-10-19) Paris - France
+
+- Fix a file-descriptor leak when we fail on the TLS handshake (#72, @TheLortex, @dinosaure, @hannesm)
+- Add `reneg` function into `Paf_mirage.Make.TLS` (#73, @dinosaure)
+
+### 0.2.0 (2022-09-29) Paris - France
+
+- Fix several issues about h2 protocols (@dinosaure, #70)
+- Delete the `Time` device (@dinosaure, @hannesm, #70)
+- Upgrade the distribution with the new interface of `Alpn` module and `Paf_mirage` (@dinosaure, #70)
+- Update unikernels (@dinosaure, #70)
+
+### 0.1.0 (2022-08-28) Paris - France
+
+- Fix the Let's encrypt support (@dinosaure, #65)
+- Update the codebase with `ocamlformat.0.23.0` (@dinosaure, #66)
+- Update the project with `h2.0.9.0` (@dinosaure, #67)
+
+### 0.0.9 (2022-04-11) Paris - France
+
+- Fix unikernels (@hannesm, #58)
+- Improve the API and documentation (@dinosaure, #59)
+- Add TCPV4V6 module to be able to provide a simple functoria device (@dinosaure, #59)
+- The HTTP server requires a TCP/IP implementation instead of a Stack implementation (@dinosaure, #59)
+- Extend the API by an _handshake_ function which handle the TLS handshake (@TheLortex, #59)
+
+### 0.0.8 (2022-04-01) Paris - France
+
+* Upgrade to `tcpip.7.0.0` (@dinosaure, #54)
+* Let the user to manipulate the incoming flow (@dinosaure, #55)
+
+### 0.0.7 (2021-10-12) Paris - France
+
+- Avoid `astring` dependency (@dinosaure, #45)
+- Remove `rresult` dependency (@hannesm, @dinosaure, #47)
+- Upgrade the code-base with `mirage-stack.3.0.0` (@dinosaure, #49)
+- Update ALPN module without GADT (@dinosaure, #50)
+
+### 0.0.6 (2021-10-11) Paris - France
+
+- Use `tls.0.15.0`, `x509.0.15.0` and `letsencrypt.0.4.0` (@hannesm, @dinosaure, #42)
+- Fix the documentation (@dinosaure, #43)
+
+### 0.0.5 (2021-03-08) Paris - France
+
+- Use `tls.0.14.0` (@hannesm, @dinosaure, #38)
+
+### 0.0.4 (2021-26-07) Paris - France
+
+- Don't use `disconnect` when the server terminates (@dinosaure, #28)
+- The main loop should not leave when it get an error from a client (@dinosaure, #28)
+- `Closed` error from TLS layer does not mean that the service is close,
+  wrap such error into a client's `write_error` (@dinosaure, #28)
+- Do the compression of the ring-buffer at any call of `read` (@dinosaure, #29)
+- Refactore the loop under a common implementation (@dinosaure, #30)
+- Add a simple accessor to the peer identity (@dinosaure, #31)
+- Cut package between `paf` & `paf-cohttp` (@dinosaure, @hannesm, #32)
+- Cut package between `paf` & `paf-le` (@dinosaure, @hannesm, #33)
+- Update unikernels with the package layout (@dinosaure, #34)
+
+### 0.0.3 (2021-26-04) Paris - France
+
+- Update to X509.0.13.0 (@hannesm, #26)
+
+### 0.0.2 (2021-20-04) Paris - France
+
+- Add simple unikernel as an example of `paf` (@dinosaure, #17)
+- Unfunctorize the client part of HTTP/AF (@dinosaure, #18)
+- Ensure to pass queries to the server handler (@dinosaure, #19)
+- Add the support of `h2` and ALPN (@dinosaure, #20)
+- Support `tls.0.13.0` (@dinosaure, @hannesm, #21)
+- Add tests about ALPN dispatcher (@dinosaure, #22)
+
+### 0.0.1 (2021-27-01) Paris - France
+
+- First release of paf

unikernel/duniverse/paf-le-chien/LICENSE.md

@@ -0,0 +1,20 @@
+The MIT License (MIT)
+
+Copyright (c) 2021 Romain Calascibetta
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
+the Software, and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

unikernel/duniverse/paf-le-chien/README.md

@@ -0,0 +1,192 @@
+## Paf le chien - A MirageOS compatible layer for [HTTP/AF][httpaf] and [H2][h2]
+
+This library wants to provide an easy way to use HTTP/AF & H2 into a unikernel.
+It implements the global /loop/ with a protocol implementation. The code, due to
+the compatibility with MirageOS, can work for `unix` too.
+
+The protocol implementation is given by [mimic][mimic] and should be the
+[mirage-tcpip][mirage-tcpip] implementation.
+
+It does the composition between the TLS encryption layer and the
+[StackV4V6][stackv4v6] implementation to provide a way to initiate a TLS
+server. Via `mimic`, it still keeps the abstraction of the underlying
+TCP/IP connection used.
+
+```ocaml
+module Make (Stack : Mirage_stack.V4V6) = struct
+  module Paf = Paf_mirage.Make (Stack.TCP)
+
+  let start stack =
+    let* t = Paf.init ~port:80 (Stack.tcp stack) in
+    let service = Paf.http_service ~error_handler request_handler in
+    let `Initialized th = Paf.serve service t in
+    th
+end
+
+(* For UNIX with mirage-time-unix & tcpip.stack-socket *)
+
+include Make (Tcpip_stack_socket.V4V6.TCP)
+
+let stack () =
+  let open Tcpip_stack_socket.V4V6 in
+  TCP.connect ~ipv4_only:false ~ipv6_only:false
+    Ipaddr.V4.Prefix.global None
+
+let () = Lwt_main.run ((Tcpip_stack_socket.V4V6.tcp stack) () >>= start)
+```
+
+It also provides a client-side with the logic of mimic and let the user to
+implement the resolution process to determine if the connection needs the TLS
+encryption (and how) layer or not.
+
+### Mimic
+
+Paf wants to provide an agnostic implementation of HTTP with the ability to
+launch a server or a client from an user-defined context: a `Mimic.ctx`. It
+does not exist one and unique way to use Paf because the context can be:
+- a MirageOS
+- a simple executable
+- something else like a JavaScript script (with `js_of_ocaml`)
+
+Mimic ensures the ability to gives a [Mirage_flow.S][mirage-flow] to Paf
+(client side). The underlying implementation of this /flow/ depends on what the
+user wants. It can be:
+- [ocaml-tls][ocaml-tls]
+- [lwt_ssl][lwt_ssl]
+- [mirage-tcpip][mirage-tcpip]
+- The host TCP/IP stack (see the `Unix` module)
+
+All of these choices **is not** done by Paf but must be defined by the user.
+Then, the CoHTTP layer trusts on [mirage-tcpip][mirage-tcpip] and
+[ocaml-tls][ocaml-tls] to easily communicate with a peer from a given `Uri.t`.
+Even if it seems to be the easy way to do HTTP requests (over TLS or not), the
+user is able to choose some others possibilities/paths.
+
+For example, the user is able to start a connection with an Unix domain socket:
+
+```ocaml
+module Unix_domain_socket : Mimic.Mirage_protocol.S
+  with type flow = Unix.file_descr
+   and type endpoint = Fpath.t
+
+let unix_domain_socket =
+  Mimic.register ~name:"unix-domain-socket" (module Unix_domain_socket)
+
+let ctx =
+  Mimic.add unix_domain_socket 
+    (Fpath.v "/var/my_domain.sock") Mimic.empty
+    
+let run =
+  Mimic.resolve ~ctx >>= function
+  | Error _ as err -> Lwt.return err
+  | Ok flow ->
+    let body, conn = Httpaf.Client_connection.request ?config:None req
+      ~error_handler ~response_handler in
+    Paf.run (module Httpaf.Client_connection) conn flow >>= fun () ->
+    Lwt.return_ok body
+```
+
+### CoHTTP layer
+
+Paf comes with a not-fully-implemented compatible layer with CoHTTP. From this
+sub-package and the [letsencrypt][letsencrypt] package, Paf provides a process
+to download a Let's encrypt TLS certificate ready to launch an HTTPS server.
+
+```ocaml
+let cfg =
+  { LE.email= Result.to_option (Emile.of_string "romain@x25519.net")
+  ; LE.account_seed= None
+  ; LE.account_key_type= `ED25519
+  ; LE.account_key_bits= None
+  ; LE.certificate_seed= None
+  ; LE.certificate_key_type= `ED25519
+  ; LE.certificate_key_bits= None
+  ; LE.hostname= Domain_name.(host_exn (of_string_exn "x25519.net")) }
+
+let ctx = ... (* see [mimic] *)
+
+module Paf = Paf_mirage.Make (Time) (Tcpip_stack_socket.V4V6)
+
+let get_tls_certificate stack =
+  Lwt_switch.with_switch @@ fun stop ->
+  let* t = Paf.init ~port:80 stack in
+  let service = Paf.http_service
+    ~error_handler
+    (fun _ -> LE.request_handler) in
+  let `Initialized th = Paf.serve ~stop service in
+  let fiber =
+    LE.provision_certificate ~production:false cfg
+      (LE.ctx ~gethostbyname ~authenticator) >>= fun res ->
+    Lwt_switch.turn_off stop >>= fun () -> Lwt.return res in
+  Lwt.both (th, fiber) >>= fun (_, tls) -> Lwt.return tls
+```
+
+### Application Layer Protocol Negotiation
+
+Paf provides the logic behind ALPN negotiation according a _certain_ TLS/SSL
+implementation. In other words, Paf is able to correctly dispatch which
+protocol the client wants without a requirement of [ocaml-tls][ocaml-tls] or
+[lwt_ssl][lwt_ssl]. The module `Alpn` is a HTTP service which handles:
+- HTTP/1.1
+- H2
+
+`Alpn` requires:
+- the `accept` and the `close` function
+- a way to extract the result of the Application Layer Protocol Negotiation
+- the Mimic's _injection_
+- `error_handler` and `request_handler` which handle HTTP/1.0, HTTP/1.1 and
+  H2 requests
+
+Here is an example with HTTP (without TLS):
+```ocaml
+let _, protocol
+  : Unix.sockaddr Mimic.value
+    * (Unix.sockaddr, Lwt_unix.file_descr) Mimic.protocol
+  = Mimic.register ~name:"lwt-tcp" (module TCP)
+
+let accept t =
+  Lwt.catch begin fun () ->
+    Lwt_unix.accept >>= fun (socket, _) ->
+    Lwt.return_ok socket
+  end @@ function
+  | Unix.Unix_error (err, f, v) ->
+    Lwt.return_error (`Unix (err, f, v))
+  | exn -> raise exn
+
+let info =
+  let module R = (val Mimic.register protocol) in
+  { Alpn.alpn= const None
+  ; Alpn.peer= (fun socket ->
+    sockaddr_to_string (Lwt_unix.getpeername socket))
+  ; Alpn.injection=
+    (fun socket -> R.T socket) }
+
+let service = Alpn.service info handler
+  accept Lwt_unix.close
+
+let fiber =
+  let t = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+  Lwt_unix.bind t (Unix.ADDR_INET (Unix.inet_addr_loopback, 8080))
+  >>= fun () ->
+  let `Initialized th = Paf.serve
+    service t in th
+
+let () = Lwt_main.run fiber
+```
+
+### Tests & Benchmark
+
+The distribution comes with a tool which launch several clients to communicate
+with a server. We record the time spent for each request and show as the result
+the histogram of them. It's not really a benchmark as is but it a good
+stress-test and we check that we don't have failure from the server.
+
+[httpaf]: https://github.com/inhabitedtype/httpaf
+[mimic]: https://github.com/mirage/ocaml-git
+[mirage-tcpip]: https://github.com/mirage/mirage-tcpip
+[letsencrypt]: https://github.com/mmaker/ocaml-letsencrypt
+[stackv4v6]: https://github.com/mirage/mirage-stack
+[ocaml-tls]: https://github.com/mirleft/ocaml-tls
+[lwt_ssl]: https://github.com/ocsigen/lwt_ssl
+[mirage-flow]: https://github.com/mirage/mirage-flow
+[h2]: https://github.com/anmonteiro/ocaml-h2

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

@@ -0,0 +1,3 @@
+(lang dune 2.0)
+(name paf)
+(version 0.8.0)

unikernel/duniverse/paf-le-chien/lib/alpn.ml

@@ -0,0 +1,277 @@
+let src = Logs.Src.create "paf-alpn"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module type REQD = sig
+  type t
+  type request
+  type response
+
+  module Body : sig
+    type ro
+    type wo
+  end
+
+  val request : t -> request
+  val request_body : t -> Body.ro
+  val response : t -> response option
+  val response_exn : t -> response
+  val respond_with_string : t -> response -> string -> unit
+  val respond_with_bigstring : t -> response -> Bigstringaf.t -> unit
+
+  val respond_with_streaming :
+    t -> ?flush_headers_immediately:bool -> response -> Body.wo
+
+  val report_exn : t -> exn -> unit
+  val try_with : t -> (unit -> unit) -> (unit, exn) result
+end
+
+type http_1_1_protocol =
+  (module REQD
+     with type t = H1.Reqd.t
+      and type request = H1.Request.t
+      and type response = H1.Response.t
+      and type Body.ro = H1.Body.Reader.t
+      and type Body.wo = H1.Body.Writer.t)
+
+type h2_protocol =
+  (module REQD
+     with type t = H2.Reqd.t
+      and type request = H2.Request.t
+      and type response = H2.Response.t
+      and type Body.ro = H2.Body.Reader.t
+      and type Body.wo = H2.Body.Writer.t)
+
+type ('reqd, 'headers, 'request, 'response, 'ro, 'wo) protocol =
+  | HTTP_1_1 :
+      http_1_1_protocol
+      -> ( H1.Reqd.t,
+           H1.Headers.t,
+           H1.Request.t,
+           H1.Response.t,
+           H1.Body.Reader.t,
+           H1.Body.Writer.t )
+         protocol
+  | H2 :
+      h2_protocol
+      -> ( H2.Reqd.t,
+           H2.Headers.t,
+           H2.Request.t,
+           H2.Response.t,
+           H2.Body.Reader.t,
+           H2.Body.Writer.t )
+         protocol
+
+let http_1_1 =
+  let module M = struct
+    include H1.Reqd
+
+    type request = H1.Request.t
+    type response = H1.Response.t
+
+    module Body = struct
+      type ro = H1.Body.Reader.t
+      type wo = H1.Body.Writer.t
+    end
+
+    let respond_with_streaming t ?flush_headers_immediately response =
+      respond_with_streaming t ?flush_headers_immediately response
+  end in
+  (module M : REQD
+    with type t = H1.Reqd.t
+     and type request = H1.Request.t
+     and type response = H1.Response.t
+     and type Body.ro = H1.Body.Reader.t
+     and type Body.wo = H1.Body.Writer.t)
+
+let h2 =
+  let module M = struct
+    include H2.Reqd
+
+    type request = H2.Request.t
+    type response = H2.Response.t
+
+    module Body = struct
+      type ro = H2.Body.Reader.t
+      type wo = H2.Body.Writer.t
+    end
+  end in
+  (module M : REQD
+    with type t = H2.Reqd.t
+     and type request = H2.Request.t
+     and type response = H2.Response.t
+     and type Body.ro = H2.Body.Reader.t
+     and type Body.wo = H2.Body.Writer.t)
+
+module H1_Client_connection = struct
+  include H1.Client_connection
+
+  let yield_reader _ = assert false
+
+  let next_read_operation t =
+    (next_read_operation t :> [ `Close | `Read | `Yield | `Upgrade ])
+
+  let next_write_operation t =
+    (next_write_operation t
+      :> [ `Close of int
+         | `Write of Bigstringaf.t H2.IOVec.t list
+         | `Yield
+         | `Upgrade ])
+end
+
+type ('flow, 'edn) info = {
+  alpn : 'flow -> string option;
+  peer : 'flow -> 'edn;
+  injection : 'flow -> Mimic.flow;
+}
+
+type server_error =
+  [ `Bad_gateway | `Bad_request | `Exn of exn | `Internal_server_error ]
+
+type ('flow, 'edn) server_handler = {
+  error :
+    'reqd 'headers 'request 'response 'ro 'wo.
+    'edn ->
+    ('reqd, 'headers, 'request, 'response, 'ro, 'wo) protocol ->
+    ?request:'request ->
+    server_error ->
+    ('headers -> 'wo) ->
+    unit;
+  request :
+    'reqd 'headers 'request 'response 'ro 'wo.
+    'flow ->
+    'edn ->
+    'reqd ->
+    ('reqd, 'headers, 'request, 'response, 'ro, 'wo) protocol ->
+    unit;
+}
+
+module H2_Server_connection = struct
+  include H2.Server_connection
+
+  let next_write_operation t =
+    (next_write_operation t
+      :> [ `Close of int
+         | `Write of Bigstringaf.t H2.IOVec.t list
+         | `Yield
+         | `Upgrade ])
+end
+
+let service :
+    ('flow, 'edn) info ->
+    (Mimic.flow, 'edn) server_handler ->
+    ('socket -> ('flow, ([> `Closed | `Msg of string ] as 'error)) result Lwt.t) ->
+    ('t -> ('socket, ([> `Closed | `Msg of string ] as 'error)) result Lwt.t) ->
+    ('t -> unit Lwt.t) ->
+    't Paf.service =
+ fun info handler connect accept close ->
+  let connection flow =
+    match info.alpn flow with
+    | Some "http/1.0" | Some "http/1.1" | None ->
+        let edn = info.peer flow in
+        let flow = info.injection flow in
+        let error_handler ?request error respond =
+          handler.error edn (HTTP_1_1 http_1_1) ?request
+            (error :> server_error)
+            respond in
+        let request_handler' reqd =
+          handler.request flow edn reqd (HTTP_1_1 http_1_1) in
+        let conn = H1.Server_connection.create ~error_handler request_handler' in
+        Lwt.return_ok (flow, Paf.Runtime ((module H1.Server_connection), conn))
+    | Some "h2" ->
+        let edn = info.peer flow in
+        let flow = info.injection flow in
+        let error_handler ?request error respond =
+          handler.error edn (H2 h2) ?request (error :> server_error) respond
+        in
+        let request_handler' reqd = handler.request flow edn reqd (H2 h2) in
+        let conn = H2.Server_connection.create ~error_handler request_handler' in
+        Lwt.return_ok (flow, Paf.Runtime ((module H2_Server_connection), conn))
+    | Some protocol ->
+        Lwt.return_error (`Msg (Fmt.str "Invalid protocol %S." protocol)) in
+  Paf.service connection connect accept close
+
+type client_error =
+  [ `Exn of exn
+  | `Malformed_response of string
+  | `Invalid_response_body_length_v1 of H1.Response.t
+  | `Invalid_response_body_length_v2 of H2.Response.t
+  | `Protocol_error of H2.Error_code.t * string ]
+
+type common_error = [ `Exn of exn | `Malformed_response of string ]
+
+let to_client_error_v1 = function
+  | `Invalid_response_body_length response ->
+      `Invalid_response_body_length_v1 response
+  | #common_error as err -> (err :> client_error)
+
+let to_client_error_v2 = function
+  | `Invalid_response_body_length response ->
+      `Invalid_response_body_length_v2 response
+  | (`Exn _ | `Malformed_response _ | `Protocol_error _) as err -> err
+
+type 'edn client_handler = {
+  error :
+    'reqd 'headers 'request 'response 'ro 'wo.
+    'edn ->
+    ('reqd, 'headers, 'request, 'response, 'ro, 'wo) protocol ->
+    client_error ->
+    unit;
+  response :
+    'reqd 'headers 'request 'response 'ro 'wo.
+    Mimic.flow ->
+    'edn ->
+    'response ->
+    'ro ->
+    ('reqd, 'headers, 'request, 'response, 'ro, 'wo) protocol ->
+    unit;
+}
+
+module H2_Client_connection = struct
+  include H2.Client_connection
+
+  let next_write_operation t =
+    (next_write_operation t
+      :> [ `Close of int
+         | `Write of Bigstringaf.t H2.IOVec.t list
+         | `Yield
+         | `Upgrade ])
+end
+
+type alpn_response =
+  | Response_HTTP_1_1 :
+      (H1.Body.Writer.t * H1.Client_connection.t)
+      -> alpn_response
+  | Response_H2 : H2.Body.Writer.t * H2.Client_connection.t -> alpn_response
+
+let run ?alpn handler edn request flow =
+  match (alpn, request) with
+  | (Some "h2" | None), `V2 request ->
+      let error_handler error =
+        handler.error edn (H2 h2) (to_client_error_v2 error) in
+      let response_handler response body =
+        handler.response flow edn response body (H2 h2) in
+      let conn =
+        H2.Client_connection.create ?config:None ?push_handler:None
+          ~error_handler () in
+      let body =
+        H2.Client_connection.request conn request ~error_handler
+          ~response_handler in
+      Lwt.async (fun () -> Paf.run (module H2_Client_connection) conn flow) ;
+      Lwt.return_ok (Response_H2 (body, conn))
+  | (Some "http/1.1" | None), `V1 request ->
+      let error_handler error =
+        handler.error edn (HTTP_1_1 http_1_1) (to_client_error_v1 error) in
+      let response_handler response body =
+        handler.response flow edn response body (HTTP_1_1 http_1_1) in
+      let body, conn =
+        H1.Client_connection.request request ~error_handler ~response_handler
+      in
+      Lwt.async (fun () -> Paf.run (module H1_Client_connection) conn flow) ;
+      Lwt.return_ok (Response_HTTP_1_1 (body, conn))
+  | Some protocol, _ ->
+      Lwt.return_error
+        (`Msg (Fmt.str "Invalid Application layer protocol: %S" protocol))
+
+let http_1_1 = HTTP_1_1 http_1_1
+let h2 = H2 h2

unikernel/duniverse/paf-le-chien/lib/alpn.mli

@@ -0,0 +1,298 @@
+(** ALPN support.
+
+    [Alpn] depend on [http/af] & [h2] and choose them because they share the
+    same {!Paf.RUNTIME} interface. [Alpn] does not require [ocaml-tls] so it's
+    possible to use OpenSSL. It requires, at least:
+
+    - Something to extract ALPN result from the TLS {i flow}
+    - Something to represent as the string the peer (useful for over-framework)
+    - An injection function (available from [mimic])
+
+    In other words, [Alpn] did the only choice to trust on [http/af] & [h2] to
+    handle HTTP/1.0, HTTP/1.1 and H2 protocols. *)
+
+module type REQD = sig
+  type t
+  type request
+  type response
+
+  module Body : sig
+    type ro
+    type wo
+  end
+
+  val request : t -> request
+  val request_body : t -> Body.ro
+  val response : t -> response option
+  val response_exn : t -> response
+  val respond_with_string : t -> response -> string -> unit
+  val respond_with_bigstring : t -> response -> Bigstringaf.t -> unit
+
+  val respond_with_streaming :
+    t -> ?flush_headers_immediately:bool -> response -> Body.wo
+
+  val report_exn : t -> exn -> unit
+  val try_with : t -> (unit -> unit) -> (unit, exn) result
+end
+
+type http_1_1_protocol =
+  (module REQD
+     with type t = H1.Reqd.t
+      and type request = H1.Request.t
+      and type response = H1.Response.t
+      and type Body.ro = H1.Body.Reader.t
+      and type Body.wo = H1.Body.Writer.t)
+
+type h2_protocol =
+  (module REQD
+     with type t = H2.Reqd.t
+      and type request = H2.Request.t
+      and type response = H2.Response.t
+      and type Body.ro = H2.Body.Reader.t
+      and type Body.wo = H2.Body.Writer.t)
+
+type ('reqd, 'headers, 'request, 'response, 'ro, 'wo) protocol =
+  | HTTP_1_1 :
+      http_1_1_protocol
+      -> ( H1.Reqd.t,
+           H1.Headers.t,
+           H1.Request.t,
+           H1.Response.t,
+           H1.Body.Reader.t,
+           H1.Body.Writer.t )
+         protocol
+  | H2 :
+      h2_protocol
+      -> ( H2.Reqd.t,
+           H2.Headers.t,
+           H2.Request.t,
+           H2.Response.t,
+           H2.Body.Reader.t,
+           H2.Body.Writer.t )
+         protocol
+
+val http_1_1 :
+  ( H1.Reqd.t,
+    H1.Headers.t,
+    H1.Request.t,
+    H1.Response.t,
+    H1.Body.Reader.t,
+    H1.Body.Writer.t )
+  protocol
+
+val h2 :
+  ( H2.Reqd.t,
+    H2.Headers.t,
+    H2.Request.t,
+    H2.Response.t,
+    H2.Body.Reader.t,
+    H2.Body.Writer.t )
+  protocol
+
+type server_error =
+  [ `Bad_gateway | `Bad_request | `Exn of exn | `Internal_server_error ]
+(** Type of server errors. *)
+
+type ('flow, 'edn) info = {
+  alpn : 'flow -> string option;
+  peer : 'flow -> 'edn;
+  injection : 'flow -> Mimic.flow;
+}
+(** The type of information from a ['flow]:
+
+    - [alpn] is a function which is able to extract the result of the
+      negotiation between the client & the server about which protocol we need
+      to use.
+    - [peer] returns a [string] representation of the given ['flow] to help to
+      print out some logs about this client.
+    - [injection] is the function which wraps the given ['flow] to a
+      [Mimic.flow].
+
+    For the last function, it can be done if you already registered the protocol
+    with [mimic]. In that case, the second value given by [Mimic.register] helps
+    you to {i inject} your flow as a [Mimic.flow]:
+
+    {[
+      let _, protocol = Mimic.register ~name:"my-protocol" (module My_protocol)
+
+      let injection (flow : My_protocol.flow) : Mimic.flow =
+        let module R = (val Mimic.repr protocol) in
+        R.T flow
+    ]} *)
+
+type ('flow, 'edn) server_handler = {
+  error :
+    'reqd 'headers 'request 'response 'ro 'wo.
+    'edn ->
+    ('reqd, 'headers, 'request, 'response, 'ro, 'wo) protocol ->
+    ?request:'request ->
+    server_error ->
+    ('headers -> 'wo) ->
+    unit;
+  request :
+    'reqd 'headers 'request 'response 'ro 'wo.
+    'flow ->
+    'edn ->
+    'reqd ->
+    ('reqd, 'headers, 'request, 'response, 'ro, 'wo) protocol ->
+    unit;
+}
+(** The type of handler. To be able to handle http/1.1 and h2 requests with the
+    same function, we have chosen to use record with universally quantified
+    types. Such design requires some constraints: 1) [error] and [request]
+    should be defined at top 2) if they requires extra informations (such as the
+    path of file, a value to connect to a database, etc.), they can be used into
+    handlers but the record must contains non-curried version of these handlers.
+    3) you must use type annotation due to the GADT {!type:protocol}
+
+    For instance, we have a value [db] is required by our request handler. You
+    can describe your handler by this way:
+
+    {[
+      let error_handler
+        : type reqd headers request response ro wo.
+          _ -> (reqd, headers, request, response, ro, wo) Alpn.protocol ->
+          ?request:request -> _ -> (headers -> wo) -> unit
+        = fun edn protocol ?request error respond ->
+          match protocol with
+          | Alpn.HTTP_1_1 _ ->
+            (* everything is specialized to the [H1] module. You can use
+               [?request] as an [H1.Request.t option] without type error. *)
+          | Alpn.H2 _ ->
+            (* everything is specialized to the [H2] module. *)
+
+      let request_handler
+        : type reqd headers request response ro wo.
+          Database.t -> _ -> _ -> reqd ->
+          (reqd, headers, request, response, ro, wo) Alpn.protocol -> unit
+        = fun db flow edn reqd -> function
+        | Alpn.HTTP_1_1 _ -> ...
+        | Alpn.H2 _ -> ...
+
+      let handler db =
+        { error= (fun edn protocol ?request error respond ->
+                error_handler edn protocol ?request error respond)
+        ; request= (fun flow edn reqd protocol ->
+                request_handler db flow end reqd protocol) }
+    ]} *)
+
+val service :
+  ('flow, 'edn) info ->
+  (Mimic.flow, 'edn) server_handler ->
+  ('socket -> ('flow, ([> `Closed | `Msg of string ] as 'error)) result Lwt.t) ->
+  ('t -> ('socket, ([> `Closed | `Msg of string ] as 'error)) result Lwt.t) ->
+  ('t -> unit Lwt.t) ->
+  't Paf.service
+(** [service info handler connect accept close] creates a new
+    {!type:Paf.service} over the {i socket} ['flow]. From the given
+    implementation of [accept] and [close], we are able to instantiate the
+    {i main loop}. Then, from the given [info], we extract informations such the
+    application layer protocol and choose which protocol we will use. Currently,
+    if [info.alpn] returns:
+
+    - [Some "http/1.0" | Some "http/1.1" | None], we launch an [http/af] service
+    - [Some "h2"], we launch an [h2] service
+
+    The user is able to identify which protocol we launched by
+    {!type:server_handler}. The returned service can be run with {!Paf.serve}.
+    Here is an example with [Lwt_unix.file_descr] and the TCP/IP transmission
+    protocol (without ALPN negotiation):
+
+    {[
+      let _, protocol
+        : Unix.sockaddr Mimic.value
+          * (Unix.sockaddr, Lwt_unix.file_descr) Mimic.protocol
+        = Mimic.register ~name:"lwt-tcp" (module TCP)
+
+      let accept t =
+        Lwt.catch begin fun () ->
+          Lwt_unix.accept >>= fun (socket, _) ->
+          Lwt.return_ok socket
+        end @@ function
+        | Unix.Unix_error (err, f, v) ->
+          Lwt.return_error (`Unix (err, f, v))
+        | exn -> raise exn
+
+      let info =
+        let module R = (val Mimic.register protocol) in
+        { Alpn.alpn= const None
+        ; Alpn.peer= (fun socket ->
+          sockaddr_to_string (Lwt_unix.getpeername socket))
+        ; Alpn.injection=
+          (fun socket -> R.T socket) }
+
+      let service = Alpn.service info handler
+        accept Lwt_unix.close
+
+      let fiber =
+        let t = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+        Lwt_unix.bind t (Unix.ADDR_INET (Unix.inet_addr_loopback, 8080))
+        >>= fun () ->
+        let `Initialized th = Paf.serve service t in th
+
+      let () = Lwt_main.run fiber
+    ]} *)
+
+type client_error =
+  [ `Exn of exn
+  | `Malformed_response of string
+  | `Invalid_response_body_length_v1 of H1.Response.t
+  | `Invalid_response_body_length_v2 of H2.Response.t
+  | `Protocol_error of H2.Error_code.t * string ]
+(** Type of client errors. *)
+
+type 'edn client_handler = {
+  error :
+    'reqd 'headers 'request 'response 'ro 'wo.
+    'edn ->
+    ('reqd, 'headers, 'request, 'response, 'ro, 'wo) protocol ->
+    client_error ->
+    unit;
+  response :
+    'reqd 'headers 'request 'response 'ro 'wo.
+    Mimic.flow ->
+    'edn ->
+    'response ->
+    'ro ->
+    ('reqd, 'headers, 'request, 'response, 'ro, 'wo) protocol ->
+    unit;
+}
+(** The type of client handler. As {!type:server_handler}, we have chosen to use
+    a record with universally quantified types. Please follow the explanation
+    given about {!type:server_handler} to understand how to use it. *)
+
+type alpn_response =
+  | Response_HTTP_1_1 :
+      (H1.Body.Writer.t * H1.Client_connection.t)
+      -> alpn_response
+  | Response_H2 : H2.Body.Writer.t * H2.Client_connection.t -> alpn_response
+
+val run :
+  ?alpn:string ->
+  'edn client_handler ->
+  'edn ->
+  [ `V1 of H1.Request.t | `V2 of H2.Request.t ] ->
+  Mimic.flow ->
+  (alpn_response, [> `Msg of string ]) result Lwt.t
+(** [run ?alpn ~client_handler edn req flow] tries communicate to [edn] via
+    [flow] with a certain protocol according to the given [alpn] value and the
+    given request. It returns the body of the request to allow the user to write
+    on it (and communicate then with the server).
+
+    [run] does only the ALPN dispatch. It does not instantiate the connection
+    and it does not try to upgrade the protocol. It just choose the right HTTP
+    protocol according to:
+
+    - the given [alpn] value
+    - the given [request] (if you want to communicate via HTTP/1.1 or H2)
+
+    Here is an example with [mimic]:
+
+    {[
+      let run uri request =
+        let ctx = ctx_of_uri uri in
+        (* See Mimic for more details. *)
+        Mimic.resolve ctx >>= function
+        | Error _ as err -> Lwt.return err
+        | Ok flow -> run ?alpn:None handler uri request flow
+    ]} *)

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

@@ -0,0 +1,23 @@
+(library
+ (name paf)
+ (public_name paf)
+ (modules paf)
+ (libraries faraday bigstringaf ke mimic))
+
+(library
+ (name alpn)
+ (public_name paf.alpn)
+ (modules alpn)
+ (libraries paf h1 h2))
+
+(library
+ (name paf_mirage)
+ (public_name paf.mirage)
+ (modules paf_mirage)
+ (libraries tcpip paf tls-mirage paf.alpn))
+
+(library
+ (name paf_cohttp)
+ (public_name paf-cohttp)
+ (modules paf_cohttp)
+ (libraries ipaddr domain-name paf h1 cohttp-lwt))

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

@@ -0,0 +1,403 @@
+module type RUNTIME = sig
+  type t
+
+  val next_read_operation : t -> [ `Read | `Yield | `Close | `Upgrade ]
+  (** [next_read_connection t] returns a value describing the next operation
+      that the caller should conduit on behalf of the connection. *)
+
+  val read : t -> Bigstringaf.t -> off:int -> len:int -> int
+  (** [read t bigstring ~off ~len] reads bytes of input from the provided range
+      of [bigstring] an returns the number of bytes consumed by the connection.
+      {!read} should be called after {!next_read_operation} returns a [`Read]
+      value an additional input is available for the connection to consume. *)
+
+  val read_eof : t -> Bigstringaf.t -> off:int -> len:int -> int
+  (** [read_eof t bigstring ~off ~len] reads bytes of input from the provided
+      range of [bigstring] and returns the number of bytes consumed by the
+      connection. {!read_eof} should be called after {!next_read_operation}
+      returns a [`Read] and an EOF has been received from the communication
+      channel. The connection will attempt to consume any buffered input and
+      then shutdown the HTTP parser for the connection. *)
+
+  val yield_reader : t -> (unit -> unit) -> unit
+  (** [yield_reader t continue] registers with the connection to call [continue]
+      when reading should resume. {!yield_reader} should be called after
+      {!next_read_operation} returns a [`Yield] value. *)
+
+  val next_write_operation :
+    t ->
+    [ `Write of Bigstringaf.t Faraday.iovec list
+    | `Yield
+    | `Close of int
+    | `Upgrade ]
+  (** [next_write_operation t] returns a value describing the next operation
+      that the caller should conduct on behalf the connection. *)
+
+  val report_write_result : t -> [ `Ok of int | `Closed ] -> unit
+  (** [report_write_result t result] reports the result of the latest write
+      attempt to the connection. {!report_write_result} should be called after a
+      call to {!next_write_operation} that returns a [`Write buffer] value.
+
+      - [`Ok n] indicates that the caller successfully wrote [n] bytes of output
+        from the buffer that the caller was provided by {!next_write_operation}
+        that returns a [`Write buffer] value.
+      - [`Closed] indicates that the output destination will no longer accept
+        bytes from the write processor. *)
+
+  val yield_writer : t -> (unit -> unit) -> unit
+  (** [yield_writer t continue] registers with the connection to call [continue]
+      when writing should resume. {!yield_writer} should be called after
+      {!next_write_operation} returns a [`Yield] value. *)
+
+  val report_exn : t -> exn -> unit
+  (** [report_exn t exn] reports that an error [exn] has been caught and that it
+      has been attributed to [t]. Calling this function will switch [t] into an
+      error state. Depending on the tate [t] is transitioning from, it may call
+      its error handler before terminating the connection. *)
+
+  val is_closed : t -> bool
+  (** [is_closed t] is [true] if both the read and write processors have been
+      shutdown. When this is the case {!next_read_operation} will return
+      [`Close _] and {!next_write_operation} will return a [`Write _] until all
+      buffered output has been flushed, at which point it will return [`Close].
+  *)
+
+  val shutdown : t -> unit
+  (** [shutdown t] asks to shutdown the connection. *)
+end
+
+type 'conn runtime = (module RUNTIME with type t = 'conn)
+
+exception Flow of string
+exception Flow_write of string
+
+let src = Logs.Src.create "paf-flow"
+
+module Log_flow = (val Logs.src_log src : Logs.LOG)
+
+module Make (Flow : Mirage_flow.S) = struct
+  type flow = {
+    flow : Flow.flow;
+    queue : (char, Bigarray.int8_unsigned_elt) Ke.Rke.t;
+    mutable rd_closed : bool;
+    mutable wr_closed : bool;
+  }
+
+  let create flow =
+    let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in
+    Lwt.return { flow; queue; rd_closed = false; wr_closed = false }
+
+  let safely_close flow =
+    if flow.rd_closed && flow.wr_closed
+    then (
+      Log_flow.debug (fun m -> m "Close the connection.") ;
+      Flow.close flow.flow)
+    else Lwt.return ()
+
+  let blit src src_off dst dst_off len =
+    let dst = Cstruct.of_bigarray ~off:dst_off ~len dst in
+    Cstruct.blit src src_off dst 0 len
+
+  open Lwt.Infix
+
+  type eof = [ `Eof ]
+
+  let recv flow ~report_error ~report_closed ~read ~read_eof =
+    Ke.Rke.compress flow.queue ;
+    Flow.read flow.flow >>= function
+    | (Error _ | Ok #eof) as v ->
+        flow.rd_closed <- true ;
+        safely_close flow >>= fun () ->
+        let _shift =
+          match
+            Ke.Rke.compress flow.queue ;
+            Ke.Rke.N.peek flow.queue
+          with
+          | [] -> read_eof Bigstringaf.empty ~off:0 ~len:0
+          | [ slice ] -> read_eof slice ~off:0 ~len:(Bigstringaf.length slice)
+          | _ -> assert false
+          (* XXX(dinosaure): impossible due to [compress]. *) in
+        (match v with
+        | Ok `Eof -> report_closed ()
+        | Error err -> report_error err) ;
+        Lwt.return `Closed
+    | Ok (`Data v) ->
+        let len = Cstruct.length v in
+        Ke.Rke.N.push flow.queue ~blit ~length:Cstruct.length ~off:0 ~len v ;
+        let[@warning "-8"] (slice :: _) = Ke.Rke.N.peek flow.queue in
+        let shift = read slice ~off:0 ~len:(Bigstringaf.length slice) in
+        Ke.Rke.N.shift_exn flow.queue shift ;
+        Lwt.return `Continue
+
+  let writev ~report_error flow iovecs =
+    let iovecs =
+      List.map
+        (fun { Faraday.buffer; off; len } ->
+          Cstruct.to_string (Cstruct.of_bigarray buffer ~off ~len) ~off:0 ~len)
+        iovecs in
+    let iovecs = List.map Cstruct.of_string iovecs in
+    (* XXX(dinosaure): the copy is needed:
+       1) [Mirage_flow.S] explicitly says that [write] takes the ownership on
+          the given [Cstruct.t]
+       2) [ocaml-h2] wants to keep the ownership on given [Faraday.iovec]s
+
+       To protect one from the other, copying is necessary. *)
+    Log_flow.debug (fun m ->
+        m "Start to write %d byte(s)."
+          (List.fold_left (fun acc cs -> Cstruct.length cs + acc) 0 iovecs)) ;
+    Flow.writev flow.flow iovecs >>= function
+    | Ok () ->
+        Lwt.return
+          (`Ok (List.fold_left (fun acc cs -> acc + Cstruct.length cs) 0 iovecs))
+    | Error err ->
+        Log_flow.err (fun m ->
+            m "Got an error when we wrote something: %a." Flow.pp_write_error
+              err) ;
+        report_error err ;
+        flow.wr_closed <- true ;
+        safely_close flow >>= fun () -> Lwt.return `Closed
+
+  let send ~report_error flow iovecs =
+    if flow.wr_closed
+    then safely_close flow >>= fun () -> Lwt.return `Closed
+    else writev ~report_error flow iovecs
+
+  let close flow =
+    match (flow.rd_closed, flow.wr_closed) with
+    | true, true -> Lwt.return_unit
+    | _ ->
+        flow.rd_closed <- true ;
+        flow.wr_closed <- true ;
+        Flow.close flow.flow
+end
+
+let src = Logs.Src.create "paf-server"
+
+module Log_server = (val Logs.src_log src : Logs.LOG)
+
+module Server (Flow : Mirage_flow.S) (Runtime : RUNTIME) : sig
+  val server : Runtime.t -> Flow.flow -> unit Lwt.t
+end = struct
+  module Easy_flow = Make (Flow)
+  open Lwt.Infix
+
+  let to_flow_exception err : exn = Flow (Fmt.str "%a" Flow.pp_error err)
+
+  let to_flow_write_exception err : exn =
+    Flow_write (Fmt.str "%a" Flow.pp_write_error err)
+
+  let server connection flow =
+    Easy_flow.create flow >>= fun flow ->
+    let rd_exit, notify_rd_exit = Lwt.wait () in
+    let wr_exit, notify_wr_exit = Lwt.wait () in
+
+    let rec rd_fiber () =
+      let report_error err =
+        Runtime.report_exn connection (to_flow_exception err) in
+      let rec go () =
+        Log_server.debug (fun m -> m "Compute next read operation.") ;
+        match Runtime.next_read_operation connection with
+        | `Upgrade -> failwith "Unimplemented"
+        | `Read ->
+            Log_server.debug (fun m -> m "next read operation: `read") ;
+            Easy_flow.recv flow ~report_error ~report_closed:ignore
+              ~read:(Runtime.read connection)
+              ~read_eof:(Runtime.read_eof connection)
+            >>= fun _ -> Lwt.pause () >>= go
+        | `Yield ->
+            Log_server.debug (fun m -> m "next read operation: `yield") ;
+            Runtime.yield_reader connection rd_fiber ;
+            Lwt.pause ()
+        | `Close ->
+            Log_server.debug (fun m -> m "next read operation: `close") ;
+            Lwt.wakeup_later notify_rd_exit () ;
+            Flow.shutdown flow.flow `read in
+      Lwt.async @@ fun () ->
+      Lwt.catch go (fun exn ->
+          Runtime.report_exn connection exn ;
+          Lwt.return_unit) in
+    let rec wr_fiber () =
+      let report_error err =
+        Runtime.report_exn connection (to_flow_write_exception err) in
+      let rec go () =
+        Log_server.debug (fun m -> m "Compute next write operation.") ;
+        match Runtime.next_write_operation connection with
+        | `Upgrade -> failwith "Unimplemented"
+        | `Write iovecs ->
+            Log_server.debug (fun m -> m "next write operation: `write") ;
+            Easy_flow.send ~report_error flow iovecs >>= fun res ->
+            Runtime.report_write_result connection res ;
+            Lwt.pause () >>= go
+        | `Yield ->
+            Log_server.debug (fun m -> m "next write operation: `yield") ;
+            Runtime.yield_writer connection wr_fiber ;
+            Lwt.pause ()
+        | `Close _ ->
+            Log_server.debug (fun m -> m "next write operation: `close") ;
+            Lwt.wakeup_later notify_wr_exit () ;
+            Flow.shutdown flow.flow `write in
+      Lwt.async @@ fun () ->
+      Lwt.catch go (fun exn ->
+          (* Runtime.report_write_result connection `Closed ; *)
+          Runtime.report_exn connection exn ;
+          Lwt.return_unit) in
+    rd_fiber () ;
+    wr_fiber () ;
+    Lwt.join [ rd_exit; wr_exit ] >>= fun () ->
+    Log_server.debug (fun m -> m "End of transmission.") ;
+    Easy_flow.close flow
+end
+
+let src = Logs.Src.create "paf-client"
+
+module Log_client = (val Logs.src_log src : Logs.LOG)
+
+module Client (Flow : Mirage_flow.S) (Runtime : RUNTIME) : sig
+  val run : Runtime.t -> Flow.flow -> unit Lwt.t
+end = struct
+  open Lwt.Infix
+  module Easy_flow = Make (Flow)
+
+  let to_flow_exception err : exn = Flow (Fmt.str "%a" Flow.pp_error err)
+
+  let to_flow_write_exception err : exn =
+    Flow_write (Fmt.str "%a" Flow.pp_write_error err)
+
+  let run connection flow =
+    Easy_flow.create flow >>= fun flow ->
+    let rd_exit, notify_rd_exit = Lwt.wait () in
+    let wr_exit, notify_wr_exit = Lwt.wait () in
+
+    let rec rd_fiber () =
+      let report_error err =
+        Runtime.report_exn connection (to_flow_exception err) in
+      let rec go () =
+        match Runtime.next_read_operation connection with
+        | `Upgrade -> failwith "Unimplemented"
+        | `Read ->
+            Log_client.debug (fun m -> m "next read operation: `read") ;
+            Easy_flow.recv flow ~report_error ~report_closed:ignore
+              ~read:(Runtime.read connection)
+              ~read_eof:(Runtime.read_eof connection)
+            >>= fun _ -> Lwt.pause () >>= go
+        | `Yield ->
+            Log_client.debug (fun m -> m "next read operation: `yield") ;
+            Runtime.yield_reader connection rd_fiber ;
+            Lwt.pause ()
+        | `Close ->
+            Log_client.debug (fun m -> m "next read operation: `close.") ;
+            Lwt.wakeup_later notify_rd_exit () ;
+            flow.Easy_flow.rd_closed <- true ;
+            Easy_flow.safely_close flow in
+      Lwt.async @@ fun () ->
+      Lwt.catch go (fun exn ->
+          Runtime.report_exn connection exn ;
+          Lwt.return_unit) in
+    let rec wr_fiber () =
+      let report_error err =
+        Runtime.report_exn connection (to_flow_write_exception err) in
+      let rec go () =
+        match Runtime.next_write_operation connection with
+        | `Upgrade -> failwith "Unimplemented"
+        | `Write iovecs ->
+            Log_client.debug (fun m -> m "next write operation: `write.") ;
+            Easy_flow.send ~report_error flow iovecs >>= fun res ->
+            Runtime.report_write_result connection res ;
+            Lwt.pause () >>= go
+        | `Yield ->
+            Log_client.debug (fun m -> m "next write operation: `yield.") ;
+            Runtime.yield_writer connection wr_fiber ;
+            Lwt.pause ()
+        | `Close _ ->
+            Log_client.debug (fun m -> m "next write operation: `close.") ;
+            Lwt.wakeup_later notify_wr_exit () ;
+            flow.Easy_flow.wr_closed <- true ;
+            Easy_flow.safely_close flow in
+      Lwt.async @@ fun () ->
+      Lwt.catch go (fun exn ->
+          Runtime.report_exn connection exn ;
+          Lwt.return ()) in
+    wr_fiber () ;
+    rd_fiber () ;
+    Lwt.join [ rd_exit; wr_exit ] >>= fun () ->
+    Log_client.debug (fun m -> m "End of transmission.") ;
+    Easy_flow.close flow
+end
+
+type impl = Runtime : 'conn runtime * 'conn -> impl
+
+type 't service =
+  | Service : {
+      accept : 't -> ('socket, ([> `Closed ] as 'error)) result Lwt.t;
+      handshake : 'socket -> ('flow, ([> `Closed ] as 'error)) result Lwt.t;
+      connection : 'flow -> (Mimic.flow * impl, 'error) result Lwt.t;
+      close : 't -> unit Lwt.t;
+    }
+      -> 't service
+
+and ('t, 'socket, 'flow, 'error) posix = {
+  accept : 't -> ('socket, 'error) result Lwt.t;
+  handshake : 'socket -> ('flow, 'error) result Lwt.t;
+  close : 't -> unit Lwt.t;
+}
+  constraint 'error = [> `Closed ]
+
+let service connection handshake accept close =
+  Service { accept; connection; handshake; close }
+
+open Lwt.Infix
+
+let serve_when_ready : type t socket flow.
+    (t, socket, flow, _) posix ->
+    ?stop:Lwt_switch.t ->
+    handler:(flow -> unit Lwt.t) ->
+    t ->
+    [ `Initialized of unit Lwt.t ] =
+ fun service ?stop ~handler t ->
+  let { accept; handshake; close } = service in
+  `Initialized
+    (let switched_off =
+       let t, u = Lwt.wait () in
+       Lwt_switch.add_hook stop (fun () ->
+           Lwt.wakeup_later u (Ok `Stopped) ;
+           Lwt.return_unit) ;
+       t in
+     let rec loop () =
+       accept t >>= function
+       | Ok socket ->
+           Lwt.async (fun () ->
+               handshake socket >>= function
+               | Ok flow -> handler flow
+               | Error `Closed ->
+                   Logs.info (fun m -> m "Connection closed by peer") ;
+                   Lwt.return ()
+               | Error _err ->
+                   Logs.err (fun m ->
+                       m "Got an error from a TCP/IP connection.") ;
+                   Lwt.return ()) ;
+           loop ()
+       | Error `Closed -> Lwt.return_error `Closed
+       | Error _ -> Lwt.pause () >>= loop in
+     let stop_result =
+       Lwt.pick [ switched_off; loop () ] >>= function
+       | Ok `Stopped -> close t >>= fun () -> Lwt.return_ok ()
+       | Error _ as err -> close t >>= fun () -> Lwt.return err in
+     stop_result >>= function Ok () | Error `Closed -> Lwt.return_unit)
+
+let server : type t. t runtime -> t -> Mimic.flow -> unit Lwt.t =
+ fun (module Runtime) conn flow ->
+  let module Server = Server (Mimic) (Runtime) in
+  Server.server conn flow
+
+let serve ?stop service t =
+  let (Service { accept; handshake; connection; close }) = service in
+  let handler flow =
+    connection flow >>= function
+    | Ok (flow, Runtime (runtime, conn)) -> server runtime conn flow
+    | Error _ -> Lwt.return_unit in
+  serve_when_ready ?stop ~handler { accept; handshake; close } t
+
+let run : type t. t runtime -> t -> Mimic.flow -> unit Lwt.t =
+ fun (module Runtime) conn flow ->
+  let module Client = Client (Mimic) (Runtime) in
+  Client.run conn flow

unikernel/duniverse/paf-le-chien/lib/paf.mli

@@ -0,0 +1,87 @@
+module type RUNTIME = sig
+  type t
+
+  val next_read_operation : t -> [ `Read | `Yield | `Close | `Upgrade ]
+  (** [next_read_connection t] returns a value describing the next operation
+      that the caller should conduit on behalf of the connection. *)
+
+  val read : t -> Bigstringaf.t -> off:int -> len:int -> int
+  (** [read t bigstring ~off ~len] reads bytes of input from the provided range
+      of [bigstring] an returns the number of bytes consumed by the connection.
+      {!read} should be called after {!next_read_operation} returns a [`Read]
+      value an additional input is available for the connection to consume. *)
+
+  val read_eof : t -> Bigstringaf.t -> off:int -> len:int -> int
+  (** [read_eof t bigstring ~off ~len] reads bytes of input from the provided
+      range of [bigstring] and returns the number of bytes consumed by the
+      connection. {!read_eof} should be called after {!next_read_operation}
+      returns a [`Read] and an EOF has been received from the communication
+      channel. The connection will attempt to consume any buffered input and
+      then shutdown the HTTP parser for the connection. *)
+
+  val yield_reader : t -> (unit -> unit) -> unit
+  (** [yield_reader t continue] registers with the connection to call [continue]
+      when reading should resume. {!yield_reader} should be called after
+      {!next_read_operation} returns a [`Yield] value. *)
+
+  val next_write_operation :
+    t ->
+    [ `Write of Bigstringaf.t Faraday.iovec list
+    | `Yield
+    | `Close of int
+    | `Upgrade ]
+  (** [next_write_operation t] returns a value describing the next operation
+      that the caller should conduct on behalf the connection. *)
+
+  val report_write_result : t -> [ `Ok of int | `Closed ] -> unit
+  (** [report_write_result t result] reports the result of the latest write
+      attempt to the connection. {!report_write_result} should be called after a
+      call to {!next_write_operation} that returns a [`Write buffer] value.
+
+      - [`Ok n] indicates that the caller successfully wrote [n] bytes of output
+        from the buffer that the caller was provided by {!next_write_operation}
+        that returns a [`Write buffer] value.
+      - [`Closed] indicates that the output destination will no longer accept
+        bytes from the write processor. *)
+
+  val yield_writer : t -> (unit -> unit) -> unit
+  (** [yield_writer t continue] registers with the connection to call [continue]
+      when writing should resume. {!yield_writer} should be called after
+      {!next_write_operation} returns a [`Yield] value. *)
+
+  val report_exn : t -> exn -> unit
+  (** [report_exn t exn] reports that an error [exn] has been caught and that it
+      has been attributed to [t]. Calling this function will switch [t] into an
+      error state. Depending on the tate [t] is transitioning from, it may call
+      its error handler before terminating the connection. *)
+
+  val is_closed : t -> bool
+  (** [is_closed t] is [true] if both the read and write processors have been
+      shutdown. When this is the case {!next_read_operation} will return
+      [`Close _] and {!next_write_operation} will return a [`Write _] until all
+      buffered output has been flushed, at which point it will return [`Close].
+  *)
+
+  val shutdown : t -> unit
+end
+
+type 'conn runtime = (module RUNTIME with type t = 'conn)
+type impl = Runtime : 'conn runtime * 'conn -> impl
+
+exception Flow of string
+exception Flow_write of string
+
+val server : 'conn runtime -> 'conn -> Mimic.flow -> unit Lwt.t
+val run : 'conn runtime -> 'conn -> Mimic.flow -> unit Lwt.t
+
+type 't service
+
+val service :
+  ('connected_flow -> (Mimic.flow * impl, 'error) result Lwt.t) ->
+  ('flow -> ('connected_flow, 'error) result Lwt.t) ->
+  ('t -> ('flow, ([> `Closed ] as 'error)) result Lwt.t) ->
+  ('t -> unit Lwt.t) ->
+  't service
+
+val serve :
+  ?stop:Lwt_switch.t -> 't service -> 't -> [ `Initialized of unit Lwt.t ]

unikernel/duniverse/paf-le-chien/lib/paf_cohttp.ml

@@ -0,0 +1,229 @@
+let ( <.> ) f g x = f (g x)
+let src = Logs.Src.create "paf-cohttp"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let scheme = Mimic.make ~name:"paf-scheme"
+let port = Mimic.make ~name:"paf-port"
+let domain_name = Mimic.make ~name:"paf-domain-name"
+let ipaddr = Mimic.make ~name:"paf-ipaddr"
+
+type ctx = Mimic.ctx
+
+let default_ctx = Mimic.empty
+let httpaf_config = Mimic.make ~name:"httpaf-config"
+let error_handler mvar err = Lwt.async @@ fun () -> Lwt_mvar.put mvar err
+
+let response_handler mvar pusher resp body =
+  let on_eof () = pusher None in
+  let rec on_read buf ~off ~len =
+    let str = Bigstringaf.substring buf ~off ~len in
+    pusher (Some str) ;
+    H1.Body.Reader.schedule_read ~on_eof ~on_read body in
+  H1.Body.Reader.schedule_read ~on_eof ~on_read body ;
+  Lwt.async @@ fun () -> Lwt_mvar.put mvar resp
+
+let rec unroll body stream =
+  let open Lwt.Infix in
+  Lwt_stream.get stream >>= function
+  | Some str ->
+      Log.debug (fun m -> m "Transmit to HTTP/AF: %S." str) ;
+      H1.Body.Writer.write_string body str ;
+      unroll body stream
+  | None ->
+      Log.debug (fun m -> m "Close the HTTP/AF writer.") ;
+      H1.Body.Writer.close body ;
+      Lwt.return_unit
+
+let transmit cohttp_body httpaf_body =
+  match cohttp_body with
+  | `Empty -> H1.Body.Writer.close httpaf_body
+  | `String str ->
+      H1.Body.Writer.write_string httpaf_body str ;
+      H1.Body.Writer.close httpaf_body
+  | `Strings sstr ->
+      List.iter (H1.Body.Writer.write_string httpaf_body) sstr ;
+      H1.Body.Writer.close httpaf_body
+  | `Stream stream -> Lwt.async @@ fun () -> unroll httpaf_body stream
+
+exception Internal_server_error
+exception Invalid_response_body_length of H1.Response.t
+exception Malformed_response of string
+
+let with_uri uri ctx =
+  let scheme_v =
+    match Uri.scheme uri with
+    | Some "http" -> Some `HTTP
+    | Some "https" -> Some `HTTPS
+    | _ -> None in
+  let port_v =
+    match (Uri.port uri, scheme_v) with
+    | Some port, _ -> Some port
+    | None, Some `HTTP -> Some 80
+    | None, Some `HTTPS -> Some 443
+    | _ -> None in
+  let domain_name_v, ipaddr_v =
+    match Uri.host uri with
+    | Some v -> (
+        match
+          ( Result.bind (Domain_name.of_string v) Domain_name.host,
+            Ipaddr.of_string v )
+        with
+        | _, Ok v -> (None, Some v)
+        | Ok v, _ -> (Some v, None)
+        | _ -> (None, None))
+    | _ -> (None, None) in
+  let ctx =
+    Option.fold ~none:ctx ~some:(fun v -> Mimic.add scheme v ctx) scheme_v in
+  let ctx = Option.fold ~none:ctx ~some:(fun v -> Mimic.add port v ctx) port_v in
+  let ctx =
+    Option.fold ~none:ctx ~some:(fun v -> Mimic.add ipaddr v ctx) ipaddr_v in
+  let ctx =
+    Option.fold ~none:ctx
+      ~some:(fun v -> Mimic.add domain_name v ctx)
+      domain_name_v in
+  ctx
+
+let with_host headers uri =
+  let hostname = Uri.host_with_default ~default:"localhost" uri in
+  let hostname =
+    match Uri.port uri with
+    | Some port -> Fmt.str "%s:%d" hostname port
+    | None -> hostname in
+  H1.Headers.add_unless_exists headers "host" hostname
+
+let with_transfer_encoding ~chunked (meth : Cohttp.Code.meth) body headers =
+  match (meth, chunked, body, H1.Headers.get headers "content-length") with
+  | `GET, _, _, _ -> headers
+  | _, (None | Some false), _, Some _ -> headers
+  | _, Some true, _, (Some _ | None) | _, None, `Stream _, None ->
+      (* XXX(dinosaure): I'm not sure that the [Some _] was right. *)
+      H1.Headers.add_unless_exists headers "transfer-encoding" "chunked"
+  | _, (None | Some false), `Empty, None ->
+      H1.Headers.add_unless_exists headers "content-length" "0"
+  | _, (None | Some false), `String str, None ->
+      H1.Headers.add_unless_exists headers "content-length"
+        (string_of_int (String.length str))
+  | _, (None | Some false), `Strings sstr, None ->
+      let len = List.fold_right (( + ) <.> String.length) sstr 0 in
+      H1.Headers.add_unless_exists headers "content-length" (string_of_int len)
+  | _, Some false, `Stream _, None ->
+      invalid_arg "Impossible to transfer a stream with a content-length value"
+
+module H1_Client_connection = struct
+  include H1.Client_connection
+
+  let yield_reader _ = assert false
+
+  let next_read_operation t =
+    (next_read_operation t :> [ `Close | `Read | `Yield | `Upgrade ])
+
+  let next_write_operation t =
+    (next_write_operation t
+      :> [ `Close of int
+         | `Write of Bigstringaf.t H1.IOVec.t list
+         | `Yield
+         | `Upgrade ])
+end
+
+let call ?(ctx = default_ctx) ?headers
+    ?body:(cohttp_body = Cohttp_lwt.Body.empty) ?chunked meth uri =
+  Log.debug (fun m -> m "Fill the context with %a." Uri.pp uri) ;
+  let ctx = with_uri uri ctx in
+  let config =
+    match Mimic.get httpaf_config ctx with
+    | Some config -> config
+    | None -> H1.Config.default in
+  let headers =
+    match headers with
+    | Some headers -> H1.Headers.of_list (Cohttp.Header.to_list headers)
+    | None -> H1.Headers.empty in
+  let headers = with_host headers uri in
+  let headers = with_transfer_encoding ~chunked meth cohttp_body headers in
+  let meth =
+    match meth with
+    | #H1.Method.t as meth -> meth
+    | #Cohttp.Code.meth as meth -> `Other (Cohttp.Code.string_of_method meth)
+  in
+  let req = H1.Request.create ~headers meth (Uri.path_and_query uri) in
+  let stream, pusher = Lwt_stream.create () in
+  let mvar_res = Lwt_mvar.create_empty () in
+  let mvar_err = Lwt_mvar.create_empty () in
+  let open Lwt.Infix in
+  Mimic.resolve ctx >>= function
+  | Error (#Mimic.error as err) ->
+      Lwt.fail (Failure (Fmt.str "%a" Mimic.pp_error err))
+  | Ok flow -> (
+      let error_handler = error_handler mvar_err in
+      let response_handler = response_handler mvar_res pusher in
+      let httpaf_body, conn =
+        H1.Client_connection.request ~config ~error_handler ~response_handler
+          req in
+      Lwt.async (fun () -> Paf.run (module H1_Client_connection) conn flow) ;
+      transmit cohttp_body httpaf_body ;
+      Log.debug (fun m -> m "Body transmitted.") ;
+      Lwt.pick
+        [
+          (Lwt_mvar.take mvar_res >|= fun res -> `Response res);
+          (Lwt_mvar.take mvar_err >|= fun err -> `Error err);
+        ]
+      >>= function
+      | `Error (`Exn exn) -> Mimic.close flow >>= fun () -> Lwt.fail exn
+      | `Error (`Invalid_response_body_length resp) ->
+          Mimic.close flow >>= fun () ->
+          Lwt.fail (Invalid_response_body_length resp)
+      | `Error (`Malformed_response err) ->
+          Mimic.close flow >>= fun () -> Lwt.fail (Malformed_response err)
+      | `Response resp ->
+          Log.debug (fun m -> m "Response received.") ;
+          let version =
+            match resp.H1.Response.version with
+            | { H1.Version.major = 1; minor = 0 } -> `HTTP_1_0
+            | { major = 1; minor = 1 } -> `HTTP_1_1
+            | { major; minor } -> `Other (Fmt.str "%d.%d" major minor) in
+          let status =
+            match
+              (resp.H1.Response.status :> [ Cohttp.Code.status | H1.Status.t ])
+            with
+            | #Cohttp.Code.status as status -> status
+            | #H1.Status.t as status -> `Code (H1.Status.to_code status) in
+          let encoding =
+            match meth with
+            | #H1.Method.standard as meth -> (
+                match H1.Response.body_length ~request_method:meth resp with
+                | `Chunked | `Close_delimited -> Cohttp.Transfer.Chunked
+                | `Error _err -> raise Internal_server_error
+                | `Fixed length -> Cohttp.Transfer.Fixed length)
+            | _ -> Cohttp.Transfer.Chunked in
+          let headers =
+            Cohttp.Header.of_list (H1.Headers.to_list resp.H1.Response.headers)
+          in
+          let resp =
+            Cohttp.Response.make ~version ~status ~encoding ~headers () in
+          Lwt.return (resp, `Stream stream))
+
+open Lwt.Infix
+
+let head ?ctx ?headers uri = call ?ctx ?headers `HEAD uri >|= fst
+let get ?ctx ?headers uri = call ?ctx ?headers `GET uri
+
+let delete ?ctx ?body ?chunked ?headers uri =
+  call ?ctx ?body ?chunked ?headers `DELETE uri
+
+let post ?ctx ?body ?chunked ?headers uri =
+  call ?ctx ?body ?chunked ?headers `POST uri
+
+let put ?ctx ?body ?chunked ?headers uri =
+  call ?ctx ?body ?chunked ?headers `PUT uri
+
+let patch ?ctx ?body ?chunked ?headers uri =
+  call ?ctx ?body ?chunked ?headers `PATCH uri
+
+let post_form ?ctx:_ ?headers:_ ~params:_ _uri = assert false (* TODO *)
+let callv ?ctx:_ _uri _stream = assert false (* TODO *)
+
+[@@@warning "-32"]
+
+let sexp_of_ctx _ctx = assert false
+
+[@@@warning "+32"]

unikernel/duniverse/paf-le-chien/lib/paf_cohttp.mli

@@ -0,0 +1,7 @@
+val scheme : [ `HTTP | `HTTPS ] Mimic.value
+val port : int Mimic.value
+val domain_name : [ `host ] Domain_name.t Mimic.value
+val ipaddr : Ipaddr.t Mimic.value
+val with_uri : Uri.t -> Mimic.ctx -> Mimic.ctx
+
+include Cohttp_lwt.S.Client with type ctx = Mimic.ctx

unikernel/duniverse/paf-le-chien/lib/paf_mirage.ml

@@ -0,0 +1,383 @@
+module type S = sig
+  type stack
+  type ipaddr
+
+  module TCP : sig
+    include Mirage_flow.S
+
+    val dst : flow -> ipaddr * int
+    val no_close : flow -> unit
+    val to_close : flow -> unit
+  end
+
+  module TLS : sig
+    type error =
+      [ `Tls_alert of Tls.Packet.alert_type
+      | `Tls_failure of Tls.Engine.failure
+      | `Read of TCP.error
+      | `Write of TCP.write_error ]
+
+    type write_error = [ `Closed | error ]
+
+    include
+      Mirage_flow.S with type error := error and type write_error := write_error
+
+    val no_close : flow -> unit
+    val to_close : flow -> unit
+    val epoch : flow -> (Tls.Core.epoch_data, unit) result
+
+    val reneg :
+      ?authenticator:X509.Authenticator.t ->
+      ?acceptable_cas:X509.Distinguished_name.t list ->
+      ?cert:Tls.Config.own_cert ->
+      ?drop:bool ->
+      flow ->
+      (unit, [ write_error | `Msg of string ]) result Lwt.t
+
+    val key_update :
+      ?request:bool ->
+      flow ->
+      (unit, [ write_error | `Msg of string ]) result Lwt.t
+
+    val server_of_flow :
+      Tls.Config.server -> TCP.flow -> (flow, write_error) result Lwt.t
+
+    val client_of_flow :
+      Tls.Config.client ->
+      ?host:[ `host ] Domain_name.t ->
+      TCP.flow ->
+      (flow, write_error) result Lwt.t
+  end
+
+  val tcp_protocol : (stack * ipaddr * int, TCP.flow) Mimic.protocol
+  val tcp_edn : (stack * ipaddr * int) Mimic.value
+
+  val tls_edn :
+    ([ `host ] Domain_name.t option * Tls.Config.client * stack * ipaddr * int)
+    Mimic.value
+
+  val tls_protocol :
+    ( [ `host ] Domain_name.t option * Tls.Config.client * stack * ipaddr * int,
+      TLS.flow )
+    Mimic.protocol
+
+  type t
+  type dst = ipaddr * int
+
+  val init : port:int -> stack -> t Lwt.t
+  val accept : t -> (TCP.flow, [> `Closed ]) result Lwt.t
+  val close : t -> unit Lwt.t
+
+  val http_service :
+    ?config:H1.Config.t ->
+    error_handler:(dst -> H1.Server_connection.error_handler) ->
+    (TCP.flow -> dst -> H1.Server_connection.request_handler) ->
+    t Paf.service
+
+  val https_service :
+    tls:Tls.Config.server ->
+    ?config:H1.Config.t ->
+    error_handler:(dst -> H1.Server_connection.error_handler) ->
+    (TLS.flow -> dst -> H1.Server_connection.request_handler) ->
+    t Paf.service
+
+  val alpn_service :
+    tls:Tls.Config.server ->
+    ?config:H1.Config.t * H2.Config.t ->
+    (TLS.flow, dst) Alpn.server_handler ->
+    t Paf.service
+
+  val serve :
+    ?stop:Lwt_switch.t -> 't Paf.service -> 't -> [ `Initialized of unit Lwt.t ]
+end
+
+module Make (Stack : Tcpip.Tcp.S) :
+  S with type stack = Stack.t and type ipaddr = Stack.ipaddr = struct
+  open Lwt.Infix
+
+  type ipaddr = Stack.ipaddr
+  type dst = ipaddr * int
+
+  module TCP = struct
+    let src = Logs.Src.create "paf-tcp"
+
+    module Log = (val Logs.src_log src : Logs.LOG)
+    include Stack
+
+    type nonrec flow = { flow : flow; mutable no_close : bool }
+    type endpoint = Stack.t * Stack.ipaddr * int
+
+    type nonrec write_error =
+      [ `Write of write_error | `Connect of error | `Closed ]
+
+    let pp_write_error ppf = function
+      | `Write err | (`Closed as err) -> pp_write_error ppf err
+      | `Connect err -> pp_error ppf err
+
+    let read flow = read flow.flow
+    let dst flow = dst flow.flow
+
+    let write flow cs =
+      write flow.flow cs >>= function
+      | Ok _ as v -> Lwt.return v
+      | Error err -> Lwt.return_error (`Write err)
+
+    let writev flow css =
+      writev flow.flow css >>= function
+      | Ok _ as v -> Lwt.return v
+      | Error err -> Lwt.return_error (`Write err)
+
+    let connect (stack, ipaddr, port) =
+      create_connection stack (ipaddr, port) >>= function
+      | Ok flow -> Lwt.return_ok { flow; no_close = false }
+      | Error err -> Lwt.return_error (`Connect err)
+
+    let no_close flow = flow.no_close <- true
+    let to_close flow = flow.no_close <- false
+
+    let close flow =
+      match flow.no_close with
+      | true ->
+          Log.debug (fun m -> m "Fakely close the connection.") ;
+          Lwt.return_unit
+      | false ->
+          Log.debug (fun m -> m "Really close the connection.") ;
+          close flow.flow
+
+    let shutdown flow = shutdown flow.flow
+  end
+
+  module TLS = struct
+    let src = Logs.Src.create "paf-tls"
+
+    module Log = (val Logs.src_log src : Logs.LOG)
+    include Tls_mirage.Make (TCP)
+
+    type endpoint =
+      [ `host ] Domain_name.t option
+      * Tls.Config.client
+      * Stack.t
+      * Stack.ipaddr
+      * int
+
+    type nonrec flow = TCP.flow * flow
+
+    let connect (host, cfg, stack, ipaddr, port) =
+      Stack.create_connection stack (ipaddr, port) >>= function
+      | Error err -> Lwt.return_error (`Read err)
+      | Ok flow ->
+          let open Lwt_result.Infix in
+          let tcp_flow = { TCP.flow; TCP.no_close = false } in
+          client_of_flow cfg ?host tcp_flow >>= fun tls_flow ->
+          Lwt.return_ok (tcp_flow, tls_flow)
+
+    let no_close (tcp_flow, _) = TCP.no_close tcp_flow
+    let to_close (tcp_flow, _) = TCP.to_close tcp_flow
+    let read (_, tls_flow) = read tls_flow
+    let write (_, tls_flow) = write tls_flow
+    let writev (_, tls_flow) = writev tls_flow
+    let shutdown (_, tls_flow) = shutdown tls_flow
+    let epoch (_, tls_flow) = epoch tls_flow
+
+    let reneg ?authenticator ?acceptable_cas ?cert ?drop (_, tls_flow) =
+      reneg ?authenticator ?acceptable_cas ?cert ?drop tls_flow
+
+    let key_update ?request (_, tls_flow) = key_update ?request tls_flow
+
+    let server_of_flow config tcp_flow =
+      Lwt_result.Infix.(
+        server_of_flow config tcp_flow >>= fun tls_flow ->
+        Lwt.return_ok (tcp_flow, tls_flow))
+
+    let client_of_flow config ?host tcp_flow =
+      Lwt_result.Infix.(
+        client_of_flow config ?host tcp_flow >>= fun tls_flow ->
+        Lwt.return_ok (tcp_flow, tls_flow))
+
+    let close (tcp_flow, tls_flow) =
+      match tcp_flow.TCP.no_close with
+      | true -> Lwt.return_unit
+      | false -> close tls_flow
+  end
+
+  let src = Logs.Src.create "paf-layer"
+
+  module Log = (val Logs.src_log src : Logs.LOG)
+
+  type stack = Stack.t
+
+  let tcp_edn, tcp_protocol = Mimic.register ~name:"tcp" (module TCP)
+
+  let tls_edn, tls_protocol =
+    Mimic.register ~priority:10 ~name:"tls" (module TLS)
+
+  type t = {
+    stack : Stack.t;
+    queue : Stack.flow Queue.t;
+    condition : unit Lwt_condition.t;
+    mutex : Lwt_mutex.t;
+    mutable closed : bool;
+  }
+
+  let init ~port stack =
+    let queue = Queue.create () in
+    let condition = Lwt_condition.create () in
+    let mutex = Lwt_mutex.create () in
+    let listener flow =
+      Lwt_mutex.lock mutex >>= fun () ->
+      Queue.push flow queue ;
+      Lwt_condition.signal condition () ;
+      Lwt_mutex.unlock mutex ;
+      Lwt.return () in
+    Stack.listen ~port stack listener ;
+    Lwt.return { stack; queue; condition; mutex; closed = false }
+
+  let rec accept ({ queue; condition; mutex; _ } as t) =
+    Lwt_mutex.lock mutex >>= fun () ->
+    let rec await () =
+      if Queue.is_empty queue && not t.closed
+      then Lwt_condition.wait condition ~mutex >>= await
+      else Lwt.return_unit in
+    await () >>= fun () ->
+    match Queue.pop queue with
+    | flow ->
+        Lwt_mutex.unlock mutex ;
+        Lwt.return_ok { TCP.flow; TCP.no_close = false }
+    | exception Queue.Empty ->
+        if t.closed
+        then (
+          Lwt_mutex.unlock mutex ;
+          Lwt.return_error `Closed)
+        else (
+          Lwt_mutex.unlock mutex ;
+          accept t)
+
+  let close ({ condition; _ } as t) =
+    t.closed <- true ;
+    (* Stack.disconnect stack >>= fun () -> *)
+    Lwt_condition.signal condition () ;
+    Lwt.return_unit
+
+  let http_service ?config ~error_handler request_handler =
+    let module R = (val Mimic.repr tcp_protocol) in
+    let connection flow =
+      let dst = TCP.dst flow in
+      let error_handler = error_handler dst in
+      let request_handler' reqd = request_handler flow dst reqd in
+      let conn =
+        H1.Server_connection.create ?config ~error_handler request_handler'
+      in
+      Lwt.return_ok (R.T flow, Paf.Runtime ((module H1.Server_connection), conn))
+    in
+    Paf.service connection Lwt.return_ok accept close
+
+  let https_service ~tls ?config ~error_handler request_handler =
+    let module R = (val Mimic.repr tls_protocol) in
+    let handshake tcp_flow =
+      let dst = TCP.dst tcp_flow in
+      TLS.server_of_flow tls tcp_flow >>= function
+      | Ok flow -> Lwt.return_ok (dst, flow)
+      | Error `Closed ->
+          (* XXX(dinosaure): be care! [`Closed] at this stage does not mean
+           * that the bound socket is closed but the socket with the peer is
+           * closed. *)
+          Log.err (fun m -> m "The connection was closed by peer.") ;
+          TCP.close tcp_flow >>= fun () -> Lwt.return_error `Closed
+      | Error err ->
+          Log.err (fun m -> m "Got a TLS error: %a." TLS.pp_write_error err) ;
+          TCP.close tcp_flow >>= fun () -> Lwt.return_error err in
+    let connection (dst, flow) =
+      let error_handler = error_handler dst in
+      let request_handler' reqd = request_handler flow dst reqd in
+      let conn =
+        H1.Server_connection.create ?config ~error_handler request_handler'
+      in
+      Lwt.return_ok (R.T flow, Paf.Runtime ((module H1.Server_connection), conn))
+    in
+    Paf.service connection handshake accept close
+
+  let alpn =
+    let module R = (val Mimic.repr tls_protocol) in
+    let alpn_of_tls_connection (_edn, flow) =
+      match TLS.epoch flow with
+      | Ok { Tls.Core.alpn_protocol; _ } -> alpn_protocol
+      | Error _ -> None in
+    let peer_of_tls_connection (edn, _flow) = edn in
+    (* XXX(dinosaure): [TLS]/[ocaml-tls] should let us to project the underlying
+     * [flow] and apply [TCP.dst] on it.
+     * Actually, we did it with the [TLS] module. *)
+    let injection (_edn, flow) = R.T flow in
+    {
+      Alpn.alpn = alpn_of_tls_connection;
+      Alpn.peer = peer_of_tls_connection;
+      Alpn.injection;
+    }
+
+  let alpn_service ~tls ?config:(_ = (H1.Config.default, H2.Config.default))
+      handler =
+    let handshake tcp_flow =
+      let dst = TCP.dst tcp_flow in
+      TLS.server_of_flow tls tcp_flow >>= function
+      | Ok flow -> Lwt.return_ok (dst, flow)
+      | Error `Closed ->
+          (* XXX(dinosaure): be care! [`Closed] at this stage does not mean
+           * that the bound socket is closed but the socket with the peer is
+           * closed. *)
+          Log.err (fun m -> m "The connection was closed by peer.") ;
+          Lwt.return_error (`Write `Closed)
+      | Error err ->
+          Log.err (fun m -> m "Got a TLS error: %a." TLS.pp_write_error err) ;
+          TCP.close tcp_flow >>= fun () ->
+          Lwt.return_error (err :> [ TLS.write_error | `Msg of string ]) in
+    let module R = (val Mimic.repr tls_protocol) in
+    let request flow edn reqd protocol =
+      match flow with
+      | R.T flow -> handler.Alpn.request flow edn reqd protocol
+      | _ -> assert false
+      (* XXX(dinosaure): this case should never occur. Indeed, the [injection]
+         given to [Alpn.service] only create a [tls_protocol] flow. We just
+         destruct it and give it to [request_handler]. *)
+    in
+    Alpn.service alpn { handler with request } handshake accept close
+
+  let serve ?stop service t = Paf.serve ?stop service t
+end
+
+type transmission = [ `Clear | `TLS of string option ]
+
+let paf_transmission : transmission Mimic.value =
+  Mimic.make ~name:"paf-transmission"
+
+let paf_endpoint : (Ipaddr.t * int) Mimic.value =
+  Mimic.make ~name:"paf-endpoint"
+
+open Lwt.Infix
+
+let rec kind_of_flow : Mimic.edn list -> transmission option = function
+  | Mimic.Edn (k, v) :: r -> (
+      match Mimic.equal k paf_transmission with
+      | Some Mimic.Refl -> Some v
+      | None -> kind_of_flow r)
+  | [] -> None
+
+let rec endpoint_of_flow : Mimic.edn list -> (Ipaddr.t * int) option = function
+  | Mimic.Edn (k, v) :: r -> (
+      match Mimic.equal k paf_endpoint with
+      | Some Mimic.Refl -> Some v
+      | None -> endpoint_of_flow r)
+  | [] -> None
+
+let ( >>? ) = Lwt_result.bind
+
+let run ~ctx handler request =
+  Mimic.unfold ctx >>? fun ress ->
+  Mimic.connect ress >>= fun res ->
+  match (res, kind_of_flow ress) with
+  | (Error _ as err), _ -> Lwt.return err
+  | Ok flow, (Some `Clear | None) ->
+      let edn = endpoint_of_flow ress in
+      let alpn = match request with `V1 _ -> "http/1.1" | `V2 _ -> "h2c" in
+      Alpn.run ~alpn handler edn request flow
+  | Ok flow, Some (`TLS alpn) ->
+      let edn = endpoint_of_flow ress in
+      Alpn.run ?alpn handler edn request flow

unikernel/duniverse/paf-le-chien/lib/paf_mirage.mli

@@ -0,0 +1,193 @@
+module type S = sig
+  type stack
+  (** The type of the TCP/IP stack. *)
+
+  type ipaddr
+  (** The type of the IP address. *)
+
+  (** {2 Protocols.}
+
+      From the given stack, [Paf_mirage] constructs protocols needed for HTTP:
+
+      - A simple TCP/IP protocol
+      - A TCP/IP protocol wrapped into TLS {i via} [ocaml-tls]
+
+      We expose these protocols in the sense of [mimic]. They are registered
+      globally with [mimic] and are usable {i via} [mimic] (see
+      {!Mimic.resolve}) as long as the given [ctx] contains {!val:tcp_edn}
+      and/or {!val:tls_edn}. Such way to instance {i something} which represents
+      these protocols and usable as a {!Mirage_flow.S} are useful for the
+      client-side, see {!val:run}.
+
+      We expose 2 new functions: [no_close]/[to_close]. In a specific context
+      such as the proxy, the handler should notify us to fakely close the
+      underlying connection. Indeed, [Paf] will try to close your connection as
+      soon as the HTTP transmission is finished. However, in the case of a
+      proxy, the connection must remains then. {!val:TCP.no_close} sets the
+      [flow] so that the next call to {!val:TCP.close} is ignored.
+      {!val:to_close} resets the [flow] to the basic behavior - we will really
+      close the given [flow]. *)
+
+  module TCP : sig
+    include Mirage_flow.S
+
+    val dst : flow -> ipaddr * int
+    val no_close : flow -> unit
+    val to_close : flow -> unit
+  end
+
+  module TLS : sig
+    type error =
+      [ `Tls_alert of Tls.Packet.alert_type
+      | `Tls_failure of Tls.Engine.failure
+      | `Read of TCP.error
+      | `Write of TCP.write_error ]
+
+    type write_error = [ `Closed | error ]
+
+    include
+      Mirage_flow.S with type error := error and type write_error := write_error
+
+    val no_close : flow -> unit
+    val to_close : flow -> unit
+    val epoch : flow -> (Tls.Core.epoch_data, unit) result
+
+    val reneg :
+      ?authenticator:X509.Authenticator.t ->
+      ?acceptable_cas:X509.Distinguished_name.t list ->
+      ?cert:Tls.Config.own_cert ->
+      ?drop:bool ->
+      flow ->
+      (unit, [ write_error | `Msg of string ]) result Lwt.t
+
+    val key_update :
+      ?request:bool ->
+      flow ->
+      (unit, [ write_error | `Msg of string ]) result Lwt.t
+
+    val server_of_flow :
+      Tls.Config.server -> TCP.flow -> (flow, write_error) result Lwt.t
+
+    val client_of_flow :
+      Tls.Config.client ->
+      ?host:[ `host ] Domain_name.t ->
+      TCP.flow ->
+      (flow, write_error) result Lwt.t
+  end
+
+  val tcp_protocol : (stack * ipaddr * int, TCP.flow) Mimic.protocol
+  val tcp_edn : (stack * ipaddr * int) Mimic.value
+
+  val tls_edn :
+    ([ `host ] Domain_name.t option * Tls.Config.client * stack * ipaddr * int)
+    Mimic.value
+
+  val tls_protocol :
+    ( [ `host ] Domain_name.t option * Tls.Config.client * stack * ipaddr * int,
+      TLS.flow )
+    Mimic.protocol
+
+  (** {2 Server implementation.} *)
+
+  type t
+  (** The type of the {i socket} bound on a specific port (via {!init}). *)
+
+  type dst = ipaddr * int
+
+  val init : port:int -> stack -> t Lwt.t
+  (** [init ~port stack] bounds the given [stack] to a specific port and return
+      the main socket {!t}. *)
+
+  val accept : t -> (TCP.flow, [> `Closed ]) result Lwt.t
+  (** [accept t] waits an incoming connection and return a {i socket} connected
+      to a peer. *)
+
+  val close : t -> unit Lwt.t
+  (** [close t] closes the main {e socket}. *)
+
+  (** {3 HTTP/1.1 servers.}
+
+      The user is able to launch a simple HTTP/1.1 server with TLS or not.
+      Below, you can see a simple example:
+
+      {[
+        let run ~error_handler ~request_handler =
+          Paf_mirage.init ~port:8080 stack >>= fun t ->
+          Paf_mirage.http_service ~error_handler request_handler
+          >>= fun service ->
+          let (`Initialized th) = Paf_mirage.serve service t in
+          th
+      ]} *)
+
+  val http_service :
+    ?config:H1.Config.t ->
+    error_handler:(dst -> H1.Server_connection.error_handler) ->
+    (TCP.flow -> dst -> H1.Server_connection.request_handler) ->
+    t Paf.service
+  (** [http_service ~error_handler request_handler] makes an HTTP/AF service
+      where any HTTP/1.1 requests are handled by [request_handler]. The returned
+      service is not yet launched (see {!serve}). *)
+
+  val https_service :
+    tls:Tls.Config.server ->
+    ?config:H1.Config.t ->
+    error_handler:(dst -> H1.Server_connection.error_handler) ->
+    (TLS.flow -> dst -> H1.Server_connection.request_handler) ->
+    t Paf.service
+  (** [https_service ~tls ~error_handler request_handler] makes an HTTP/AF
+      service over TLS (from the given TLS configuration). Then, HTTP/1.1
+      requests are handled by [request_handler]. The returned service is not yet
+      launched (see {!serve}). *)
+
+  (** {3 HTTP/1.1 & H2 over TLS server.}
+
+      It's possible to make am ALPN server. It's an HTTP server which can handle
+
+      - HTTP/1.1 requests
+      - and H2 requests
+
+      The choice is made by the ALPN challenge on the TLS layer where the client
+      can send which protocol he/she wants to use. Therefore, the server must
+      handle these two cases. *)
+
+  val alpn_service :
+    tls:Tls.Config.server ->
+    ?config:H1.Config.t * H2.Config.t ->
+    (TLS.flow, dst) Alpn.server_handler ->
+    t Paf.service
+  (** [alpn_service ~tls handler] makes an H2/HTTP/AF service over TLS (from the
+      given TLS configuration). An HTTP request (version 1.1 or 2) is handled
+      then by [handler]. The returned service is not yet launched (see
+      {!val:serve} to launch it). *)
+
+  val serve :
+    ?stop:Lwt_switch.t -> 't Paf.service -> 't -> [ `Initialized of unit Lwt.t ]
+  (** [serve ?stop service] returns an initialized promise of the given service
+      [service]. [stop] can be used to stop the service. *)
+end
+
+module Make (Stack : Tcpip.Tcp.S) :
+  S with type stack = Stack.t and type ipaddr = Stack.ipaddr
+
+(** {2 Client implementation.}
+
+    The client implementation of [Paf_mirage] does not strictly need a
+    {i functor}. Indeed, the client was made in the sense of [mimic]. The user
+    should provide a {!Mimic.ctx} which generate a {!paf_transmission}. By this
+    way, the {!run} function is able to introspect the used protocol (regardless
+    its implementation) and do the ALPN challenge with the server. *)
+
+type transmission = [ `Clear | `TLS of string option ]
+
+val paf_transmission : transmission Mimic.value
+
+val run :
+  ctx:Mimic.ctx ->
+  (Ipaddr.t * int) option Alpn.client_handler ->
+  [ `V1 of H1.Request.t | `V2 of H2.Request.t ] ->
+  (Alpn.alpn_response, [> Mimic.error ]) result Lwt.t
+(** [run ~ctx handler req] sends an HTTP request (H2 or HTTP/1.1) to a peer
+    which can be reached {i via} the given Mimic's [ctx]. If the connection is
+    recognized as a {!tls_protocol}, we proceed an ALPN challenge between what
+    the user chosen and what the peer can handle. Otherwise, we send a simple
+    HTTP/1.1 request or a [h2c] request. *)

unikernel/duniverse/paf-le-chien/paf-cohttp.opam

@@ -0,0 +1,32 @@
+version: "0.8.0"
+opam-version: "2.0"
+name: "paf"
+synopsis: "A CoHTTP client with its HTTP/AF implementation"
+description: "A compatible layer betweem CoHTTP and HTTP/AF."
+maintainer: "Romain Calascibetta <romain.calascibetta@gmail.com>"
+authors: "Romain Calascibetta <romain.calascibetta@gmail.com>"
+license: "MIT"
+homepage: "https://github.com/dinosaure/paf-le-chien"
+doc: "https://dinosaure.github.io/paf-le-chien/"
+bug-reports: "https://github.com/dinosaure/paf-le-chien/issues"
+depends: [
+  "ocaml" {>= "4.08.0"}
+  "dune" {>= "2.0.0"}
+  "paf" {= version}
+  "cohttp-lwt" {< "6.0.0~"}
+  "domain-name"
+  "h1"
+  "ipaddr"
+  "alcotest-lwt"      {with-test & >= "1.1.0"}
+  "fmt"               {with-test}
+  "logs"              {with-test}
+  "mirage-crypto-rng" {with-test & >= "0.11.0"}
+  "tcpip"             {with-test & >= "6.0.0"}
+  "uri"               {with-test}
+  "lwt"               {with-test}
+  "astring"           {with-test}
+]
+build: ["dune" "build" "-p" name "-j" jobs]
+run-test: ["dune" "runtest" "-p" name "-j" jobs] {os != "macos"}
+dev-repo: "git+https://github.com/dinosaure/paf-le-chien.git"
+x-maintenance-intent: [ "(latest)" ]

unikernel/duniverse/paf-le-chien/paf.opam

@@ -0,0 +1,38 @@
+version: "0.8.0"
+opam-version: "2.0"
+name: "paf"
+synopsis: "HTTP/AF and MirageOS"
+description: "A compatible layer for HTTP/AF and MirageOS."
+maintainer: "Romain Calascibetta <romain.calascibetta@gmail.com>"
+authors: "Romain Calascibetta <romain.calascibetta@gmail.com>"
+license: "MIT"
+homepage: "https://github.com/dinosaure/paf-le-chien"
+doc: "https://dinosaure.github.io/paf-le-chien/"
+bug-reports: "https://github.com/dinosaure/paf-le-chien/issues"
+depends: [
+  "ocaml" {>= "4.08.0"}
+  "dune" {>= "2.0.0"}
+  "tcpip" {>= "8.0.1"}
+  "tls-mirage" {>= "0.17.4"}
+  "mimic" {>= "0.0.7"}
+  "ke" {>= "0.4"}
+  "lwt" {with-test}
+  "base-unix" {with-test}
+  "logs" {with-test}
+  "fmt" {with-test}
+  "mirage-crypto-rng" {with-test & >= "1.2.0"}
+  "ptime" {with-test}
+  "uri" {with-test}
+  "alcotest-lwt" {with-test}
+  "x509" {with-test & > "1.0.0"}
+  "bigstringaf" {>= "0.7.0"}
+  "h1"
+  "h2" {>= "0.10.0"}
+  "faraday" {>= "0.7.2"}
+  "tls" {>= "1.0.0"}
+  "cstruct" {>= "6.0.0"}
+]
+build: ["dune" "build" "-p" name "-j" jobs]
+run-test: ["dune" "runtest" "-p" name "-j" jobs] {os != "macos"}
+dev-repo: "git+https://github.com/dinosaure/paf-le-chien.git"
+x-maintenance-intent: [ "(latest)" ]

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

unikernel/duniverse/paf-le-chien/unikernel/.ocamlformat

@@ -0,0 +1 @@
+disable=true

unikernel/duniverse/paf-le-chien/unikernel/client/README.md

@@ -0,0 +1,28 @@
+## A MirageOS with Paf
+
+This simple unikernel shows how to use `paf` and MirageOS **as a client**. We
+describe a new _device_ `http_client` which is a composition of several modules
+such as [happy-eyeballs][happy-eyeballs] (to be able to resolve domain name)
+and [ca-certs][ca-certs] to introduce an _authenticator_.
+
+The usage of this unikernel is simple:
+```sh
+$ opam pin add -y https://github.com/dinosaure/paf-le-chien
+$ git clone https://github.com/dinosaure/paf-le-chien
+$ cp -r paf-le-chien/unikernel/client/* paf-unikernel/
+$ cd paf-unikernel
+$ mirage configure -t unix
+$ make depends
+$ mirage build
+$ ./dist/minipaf -u https://www.google.com/
+```
+
+This unikernel is able to talk via http/1.1 and h2 (as `paf` can do). It prints
+out the response and the body (in hexadecimal format, thanks to [hxd][hxd]).
+The API of `Http_mirage_client` comes from the great project
+[http-lwt-client][http-lwt-client] which does the same but specially for the
+`unix` platform.
+
+[happy-eyeballs]: https://github.com/roburio/happy-eyeballs
+[ca-certs]: https://github.com/mirage/ca-certs
+[http-lwt-client]: https://github.com/roburio/http-lwt-client

unikernel/duniverse/paf-le-chien/unikernel/client/config.ml

@@ -0,0 +1,36 @@
+open Mirage
+
+let uri =
+  let doc = Key.Arg.info ~doc:"URI to fetch." [ "uri" ] in
+  Key.(create "uri" Arg.(required string doc))
+
+type http_client = HTTP_client
+let http_client = typ HTTP_client
+
+let minipaf =
+  foreign "Unikernel.Make"
+    ~keys:[ Key.v uri; ]
+    ~packages:[ package "paf"
+              ; package "h2"
+              ; package "hxd" ~sublibs:[ "core"; "string" ]
+              ; package "httpaf" ]
+    (console @-> time @-> http_client @-> job)
+
+let stack = generic_stackv4v6 default_network
+let dns = generic_dns_client stack
+let tcp = tcpv4v6_of_stackv4v6 stack
+
+let http_client =
+  let connect _ modname = function
+    | [ _pclock; _tcpv4v6; ctx ] ->
+      Fmt.str {ocaml|%s.connect %s|ocaml} modname ctx
+    | _ -> assert false in
+  impl ~connect "Http_mirage_client.Make"
+    (pclock @-> tcpv4v6 @-> git_client @-> http_client)
+
+let http_client =
+  let happy_eyeballs = git_happy_eyeballs stack dns (generic_happy_eyeballs stack dns) in
+  http_client $ default_posix_clock $ tcp $ happy_eyeballs
+
+let () = register "minipaf"
+    [ minipaf $ default_console $ default_time $ http_client ]

unikernel/duniverse/paf-le-chien/unikernel/client/http_mirage_client.ml

@@ -0,0 +1,337 @@
+let http_scheme = Mimic.make ~name:"http-scheme"
+let http_port = Mimic.make ~name:"http-port"
+let http_hostname = Mimic.make ~name:"http-hostname"
+let tls_config = Mimic.make ~name:"tls-config"
+
+open Lwt.Infix
+
+module type S = sig
+  val connect : Mimic.ctx -> Mimic.ctx Lwt.t
+  val alpn_protocol : Mimic.flow -> string option
+  val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result
+end
+
+module Make
+  (Pclock : Mirage_clock.PCLOCK)
+  (TCP : Tcpip.Tcp.S)
+  (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = struct
+  module TCP = struct
+    include TCP
+    type endpoint = Happy_eyeballs.t * string * int
+    type nonrec write_error =
+      [ `Write of write_error | `Connect of string | `Closed ]
+    let pp_write_error ppf = function
+      | `Connect err -> Fmt.string ppf err
+      | `Write err -> pp_write_error ppf err
+      | `Closed as err -> pp_write_error ppf err
+
+    let write flow cs =
+      let open Lwt.Infix in
+      write flow cs >>= function
+      | Ok _ as v -> Lwt.return v
+      | Error err -> Lwt.return_error (`Write err)
+
+    let writev flow css =
+      writev flow css >>= function
+      | Ok _ as v -> Lwt.return v
+      | Error err -> Lwt.return_error (`Write err)
+
+    let connect (happy_eyeballs, hostname, port) =
+      Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function
+      | Error (`Msg err) -> Lwt.return_error (`Connect err)
+      | Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow
+  end
+
+  let tcp_edn, _tcp_protocol = Mimic.register ~name:"tcp" (module TCP)
+
+  module TLS = struct
+    type endpoint = Happy_eyeballs.t * Tls.Config.client * string * int
+
+    include Tls_mirage.Make (TCP)
+
+    let connect (happy_eyeballs, cfg, hostname, port) =
+      let peer_name =
+        Result.(to_option (bind (Domain_name.of_string hostname) Domain_name.host)) in
+      Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function
+      | Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow
+      | Error (`Msg err) -> Lwt.return_error (`Write (`Connect err))
+  end
+
+  let tls_edn, tls_protocol =
+    Mimic.register ~name:"tls" (module TLS)
+
+  let connect ctx =
+    let k0 happy_eyeballs http_scheme http_hostname http_port = match http_scheme with
+      | "http" -> Lwt.return_some (happy_eyeballs, http_hostname, http_port)
+      | _      -> Lwt.return_none in
+    let k1 happy_eyeballs http_scheme http_hostname http_port tls_config = match http_scheme with
+      | "https" -> Lwt.return_some (happy_eyeballs, tls_config, http_hostname, http_port)
+      | _       -> Lwt.return_none in
+    let ctx = Mimic.fold tcp_edn
+      Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs
+                ; req http_scheme; req http_hostname; dft http_port 80 ]
+      ~k:k0 ctx in
+    let ctx = Mimic.fold tls_edn
+      Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs
+                ; req http_scheme; req http_hostname; dft http_port 443
+                ; req tls_config ]
+      ~k:k1 ctx in
+    Lwt.return ctx
+
+  let alpn_protocol flow =
+    let module M = (val (Mimic.repr tls_protocol)) in
+    match flow with
+    | M.T flow ->
+      ( match TLS.epoch flow with
+      | Ok { Tls.Core.alpn_protocol; _ } -> alpn_protocol
+      | Error _ -> None )
+    | _ -> None
+
+  let authenticator =
+    let module V = Ca_certs_nss.Make (Pclock) in
+    V.authenticator ()
+end
+
+module Version = Httpaf.Version
+module Status = H2.Status
+module Headers = H2.Headers
+
+type response =
+  { version : Version.t
+  ; status  : Status.t
+  ; reason  : string
+  ; headers : Headers.t }
+
+module HTTP_1_1 = struct
+  include Httpaf.Client_connection
+  let yield_reader _ = assert false
+  let next_read_operation t =
+    (next_read_operation t :> [ `Close | `Read | `Yield ])
+end
+
+let add_authentication ~add headers = function
+  | None -> headers
+  | Some (user, pass) ->
+    let data = Base64.encode_string (user ^ ":" ^ pass) in
+    add headers "authorization" ("Basic " ^ data)
+
+let prepare_http_1_1_headers headers host user_pass body_length =
+  let headers = Httpaf.Headers.of_list headers in
+  let add = Httpaf.Headers.add_unless_exists in
+  let headers = add headers "user-agent" ("http-mirage-client/0.8.0") in
+  let headers = add headers "host" host in
+  let headers = add headers "connection" "close" in
+  let headers = match body_length with
+    | None -> headers
+    | Some v -> add headers "content-length" (string_of_int v) in
+  add_authentication ~add headers user_pass
+
+let single_http_1_1_request ?config flow user_pass host meth path headers body =
+  let body_length = Option.map String.length body in
+  let headers = prepare_http_1_1_headers headers host user_pass body_length in
+  let req = Httpaf.Request.create ~headers meth path in
+  let finished, notify_finished = Lwt.wait () in
+  let wakeup = let w = ref false in
+    fun v -> if not !w then Lwt.wakeup_later notify_finished v ; w := true in
+  let response_handler response body =
+    let buf = Buffer.create 0x100 in
+    let rec on_eof () =
+      let response =
+        { version= response.Httpaf.Response.version
+        ; status = (response.Httpaf.Response.status :> H2.Status.t)
+        ; reason = response.Httpaf.Response.reason
+        ; headers= H2.Headers.of_list (Httpaf.Headers.to_list response.Httpaf.Response.headers) } in
+      wakeup (Ok (response, Some (Buffer.contents buf)))
+    and on_read ba ~off ~len =
+      Buffer.add_string buf (Bigstringaf.substring ~off ~len ba) ;
+      Httpaf.Body.schedule_read body ~on_read ~on_eof in
+    let on_eof () =
+      let response =
+        { version= response.Httpaf.Response.version
+        ; status = (response.Httpaf.Response.status :> H2.Status.t)
+        ; reason = response.Httpaf.Response.reason
+        ; headers= H2.Headers.of_list (Httpaf.Headers.to_list response.Httpaf.Response.headers) } in
+      wakeup (Ok (response, None)) in
+    Httpaf.Body.schedule_read body ~on_read ~on_eof in
+  let error_handler e =
+    let err = match e with
+      | `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x))
+      | `Invalid_response_body_length _ -> Error (`Msg ("Invalid response body length"))
+      | `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in
+    wakeup err in
+  let request_body, conn = Httpaf.Client_connection.request ?config req ~error_handler
+    ~response_handler in
+  Lwt.async (fun () -> Paf.run (module HTTP_1_1) conn flow) ;
+  Option.iter (Httpaf.Body.write_string request_body) body ;
+  Httpaf.Body.close_writer request_body ;
+  finished
+
+let prepare_h2_headers headers host user_pass body_length =
+  let headers = H2.Headers.of_list headers in
+  let add hdr = H2.Headers.add_unless_exists hdr ?sensitive:None in
+  let headers = add headers ":authority" host in
+  let headers = add headers "content-length" (string_of_int (Option.value ~default:0 body_length)) in
+  add_authentication ~add headers user_pass
+
+let single_h2_request ?config ~scheme flow user_pass host meth path headers body =
+  let body_length = Option.map String.length body in
+  let headers = prepare_h2_headers headers host user_pass body_length in
+  let req = H2.Request.create ~scheme ~headers meth path in
+  let finished, notify_finished = Lwt.wait () in
+  let wakeup = let w = ref false in
+    fun v -> if not !w then Lwt.wakeup_later notify_finished v ; w := true in
+  let response_handler response response_body =
+    let buf = Buffer.create 0x100 in
+    let rec on_eof () =
+      let response =
+        { version= { major= 2; minor= 0; }
+        ; status = response.H2.Response.status
+        ; reason = ""
+        ; headers= response.H2.Response.headers } in
+      wakeup (Ok (response, Some (Buffer.contents buf)))
+    and on_read ba ~off ~len =
+      Buffer.add_string buf (Bigstringaf.substring ~off ~len ba) ;
+      H2.Body.Reader.schedule_read response_body
+        ~on_read ~on_eof in
+    let on_eof () =
+      let response =
+        { version= { major= 2; minor= 0; }
+        ; status = response.H2.Response.status
+        ; reason = ""
+        ; headers= response.H2.Response.headers } in
+      wakeup (Ok (response, None)) in
+    H2.Body.Reader.schedule_read response_body
+      ~on_read ~on_eof in
+  let error_handler e =
+    let err = match e with
+      | `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x))
+      | `Invalid_response_body_length _ -> Error (`Msg "Invalid response body length")
+      | `Protocol_error (err, msg) ->
+        let kerr _ = Error (`Msg (Format.flush_str_formatter ())) in
+        Format.kfprintf kerr Format.str_formatter "%a: %s" H2.Error_code.pp_hum err msg
+      | `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in
+    wakeup err in
+  let conn = H2.Client_connection.create ?config ?push_handler:None
+    ~error_handler in
+  let request_body = H2.Client_connection.request conn req ~error_handler ~response_handler in
+  Lwt.async (fun () -> Paf.run (module H2.Client_connection) conn flow) ;
+  Option.iter (H2.Body.Writer.write_string request_body) body ;
+  H2.Body.Writer.close request_body ;
+  finished >|= fun v ->
+  H2.Client_connection.shutdown conn ; v
+
+let decode_uri ~ctx uri =
+  let ( >>= ) = Result.bind in
+  match String.split_on_char '/' uri with
+  | proto :: "" :: user_pass_host_port :: path ->
+    ( if String.equal proto "http:"
+      then Ok ("http", Mimic.add http_scheme "http" ctx)
+      else if String.equal proto "https:"
+      then Ok ("https", Mimic.add http_scheme "https" ctx)
+      else Error (`Msg "Couldn't decode user and password") ) >>= fun (scheme, ctx) ->
+    let decode_user_pass up = match String.split_on_char ':' up with
+      | [ user; pass; ] -> Ok (user, pass)
+      | _ -> Error (`Msg "Couldn't decode user and password") in
+    ( match String.split_on_char '@' user_pass_host_port with
+    | [ host_port ] -> Ok (None, host_port)
+    | [ user_pass; host_port ] ->
+      decode_user_pass user_pass >>= fun up ->
+      Ok (Some up, host_port)
+    | _ -> Error (`Msg "Couldn't decode URI") ) >>= fun (user_pass, host_port) ->
+    ( match String.split_on_char ':' host_port with
+    | [] -> Error (`Msg "Empty host & port")
+    | [ hostname ] -> Ok (hostname, Mimic.add http_hostname hostname ctx)
+    | hd :: tl ->
+      let port, hostname = match List.rev (hd :: tl) with
+        | hd :: tl -> hd, String.concat ":" (List.rev tl)
+        | _ -> assert false in
+      ( try Ok (hostname, Mimic.add http_hostname hostname (Mimic.add http_port (int_of_string port) ctx))
+        with Failure _ -> Error (`Msg "Couldn't decode port") ) ) >>= fun (hostname, ctx) ->
+    Ok (ctx, scheme, hostname, user_pass, "/" ^ String.concat "/" path)
+  | _ -> Error (`Msg "Couldn't decode URI on top")
+
+let ( >>? ) = Lwt_result.bind
+
+let alpn_protocol_of_string = function
+  | "http/1.1" -> Some `HTTP_1_1
+  | "h2" -> Some `H2
+  | _ -> None
+
+let single_request ~ctx ~alpn_protocol ?config cfg ~meth ~headers ?body uri =
+  Lwt.return (decode_uri ~ctx uri) >>? fun (ctx, scheme, host, user_pass, path) ->
+  let ctx = match Lazy.force cfg with
+    | Ok (`Custom cfg) -> Mimic.add tls_config cfg ctx
+    | Ok (`Default cfg) ->
+      ( match Result.bind (Domain_name.of_string host) Domain_name.host with
+      | Ok peer -> Mimic.add tls_config (Tls.Config.peer cfg peer) ctx
+      | Error _ -> Mimic.add tls_config cfg ctx )
+    | Error _ -> ctx in
+  Mimic.resolve ctx >>? fun flow ->
+  match Option.bind (alpn_protocol flow) alpn_protocol_of_string, config with
+  | (Some `HTTP_1_1 | None), Some (`HTTP_1_1 config) ->
+    single_http_1_1_request ~config flow user_pass host meth path headers body
+  | (Some `HTTP_1_1 | None), None ->
+    single_http_1_1_request flow user_pass host meth path headers body
+  | (Some `H2 | None), Some (`H2 config) ->
+    single_h2_request ~config ~scheme flow user_pass host meth path headers body
+  | Some `H2, None ->
+    single_h2_request ~scheme flow user_pass host meth path headers body
+  | Some `H2, (Some (`HTTP_1_1 _)) ->
+    single_h2_request ~scheme flow user_pass host meth path headers body
+  | Some `HTTP_1_1, Some (`H2 _) ->
+    single_http_1_1_request flow user_pass host meth path headers body
+
+let tls_config ?tls_config ?config authenticator =
+  lazy ( match tls_config with
+  | Some cfg -> Ok (`Custom cfg)
+  | None ->
+    let alpn_protocols = match config with
+      | None -> [ "h2"; "http/1.1" ]
+      | Some (`H2 _) -> [ "h2" ]
+      | Some (`HTTP_1_1 _) -> [ "http/1.1" ] in
+    Result.map (fun authenticator -> `Default (Tls.Config.client ~alpn_protocols ~authenticator ())) authenticator )
+
+let resolve_location ~uri ~location =
+  match String.split_on_char '/' location with
+  | "http:" :: "" :: _ -> Ok location
+  | "https:" :: "" :: _ -> Ok location
+  | "" :: "" :: _ ->
+    let schema = String.sub uri 0 (String.index uri '/') in
+    Ok (schema ^ location)
+  | "" :: _ ->
+    (match String.split_on_char '/' uri with
+     | schema :: "" :: user_pass_host_port :: _ ->
+       Ok (String.concat "/" [schema ; "" ; user_pass_host_port ^ location])
+     | _ -> Error (`Msg ("expected an absolute uri, got: " ^ uri)))
+  | _ -> Error (`Msg ("unknown location (relative path): " ^ location))
+
+let one_request
+  ?config
+  ?tls_config:cfg
+  ~ctx
+  ~alpn_protocol
+  ~authenticator
+  ?(meth= `GET)
+  ?(headers= [])
+  ?body
+  ?(max_redirect= 5)
+  ?(follow_redirect= true) uri =
+  let tls_config = tls_config ?tls_config:cfg ?config authenticator in
+  if not follow_redirect
+  then single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri
+  else
+    let rec follow_redirect count uri =
+      if count = 0 then Lwt.return_error (`Msg "Redirect limit exceeded")
+      else
+        single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri
+        >>? fun (resp, body) ->
+        if Status.is_redirection resp.status then
+          ( match Headers.get resp.headers "location" with
+          | Some location ->
+            Lwt.return (resolve_location ~uri ~location) >>? fun uri ->
+            follow_redirect (pred count) uri
+          | None ->
+            Lwt.return_ok (resp, body) )
+        else
+          Lwt.return_ok (resp, body) in
+    follow_redirect max_redirect uri

unikernel/duniverse/paf-le-chien/unikernel/client/http_mirage_client.mli

@@ -0,0 +1,34 @@
+module type S = sig
+  val connect : Mimic.ctx -> Mimic.ctx Lwt.t
+  val alpn_protocol : Mimic.flow -> string option
+  val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result
+end
+
+module Make
+  (Pclock : Mirage_clock.PCLOCK)
+  (TCP : Tcpip.Tcp.S)
+  (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S
+
+module Version = Httpaf.Version
+module Status = H2.Status
+module Headers = H2.Headers
+
+type response =
+  { version : Version.t
+  ; status  : Status.t
+  ; reason  : string
+  ; headers : Headers.t }
+
+val one_request :
+  ?config:[ `H2 of H2.Config.t | `HTTP_1_1 of Httpaf.Config.t ] ->
+  ?tls_config:Tls.Config.client ->
+  ctx:Mimic.ctx ->
+  alpn_protocol:(Mimic.flow -> string option) ->
+  authenticator:(X509.Authenticator.t, [> `Msg of string ]) result ->
+  ?meth:Httpaf.Method.t ->
+  ?headers:(string * string) list ->
+  ?body:string ->
+  ?max_redirect:int ->
+  ?follow_redirect:bool ->
+  string ->
+  (response * string option, [> Mimic.error ]) result Lwt.t

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

@@ -0,0 +1,43 @@
+open Lwt.Infix
+
+module Make
+  (Console : Mirage_console.S)
+  (Time : Mirage_time.S)
+  (HTTP_Client : Http_mirage_client.S) = struct
+  let one_request =
+    Http_mirage_client.one_request
+      ~alpn_protocol:HTTP_Client.alpn_protocol
+      ~authenticator:HTTP_Client.authenticator
+
+  let log console fmt = Fmt.kstr (Console.log console) fmt
+
+  let print_response console uri response =
+    let ( let* ) = Lwt.bind in
+    let* () = log console ">> %S" uri in
+    let* () = log console "> Version: %a" Httpaf.Version.pp_hum response.Http_mirage_client.version in
+    let* () = log console "> Status: %a" H2.Status.pp_hum response.Http_mirage_client.status in
+    let headers = H2.Headers.to_list response.Http_mirage_client.headers in
+    let headers =
+      let tbl = Hashtbl.create 0x100 in
+      List.iter (fun (k, v) -> Hashtbl.add tbl k v) headers ; tbl in
+    let* () = log console "> Headers: @[<hov>%a@]"
+      Fmt.(Dump.hashtbl string string) headers in
+    let* () = log console ">" in
+    Lwt.return_unit
+
+  let print_body console = function
+    | None -> Lwt.return_unit
+    | Some body ->
+      log console "@[<hov>%a@]" (Hxd_string.pp Hxd.default) body
+
+  let start console _time ctx =
+    one_request ~ctx (Key_gen.uri ()) >>= fun res ->
+    (* XXX(dinosaure): let 5s for the underlying fiber executed into a
+       [Lwt.async] to properly finish the job. *)
+    Time.sleep_ns 5_000_000_000L >>= fun () -> match res with
+    | Ok (response, body) ->
+      print_response console (Key_gen.uri ()) response >>= fun () ->
+      print_body console body
+    | Error err ->
+      log console "ERROR: %a" Mimic.pp_error err
+end

unikernel/duniverse/paf-le-chien/unikernel/server/README.md

@@ -0,0 +1,62 @@
+# A MirageOS with Paf
+
+This simple unikernel shows how to use `paf` and MirageOS **as a server**. It
+launches a simple server with several endpoints and TLS. You must create a key
+and a certificate to be able to run `minipaf` with `--tls=true`:
+```sh
+$ ./gen.sh foo
+```
+
+The server has 4 endpoints:
+- `http{,s}://localhost/` which emits a simple `text/plain` page
+- `http{,s}://localhost/random` which requires a `x-length` value and an
+  optionally `x-seed` (base64 encoded) seed to generate a Base64 page of
+  random bytes
+- `http{,s}://localhost/hash` requires `x-length` & `x-seed` and it calcultates
+  the hash of "random" bytes as the `random` page generated (if you used the
+  same seed)
+- `http{,s}://localhost/transmit` which copy what you sent
+
+For instance, this is some example of how to use this server:
+```sh
+$ curl -H x-length:15000 -H x-seed:Vau9IWDa4Jg= --insecure --http1.1 \
+  https://localhost:4343/random | base64 -di - | sha256sum > hash.result
+$ curl -H x-length:15000 -H x-seed:Vau9IWDa4Jg= --insecure --http2 \
+  https://localhost:4343/hash -w "  -\n" > hash.expected
+$ diff hash.result hash.expected
+$ curl -H x-length:15000 -H x-seed:w3CJxsQ+deQ= https://localhost:4343/random \
+  --insecure --http2 > file.txt
+$ cat file.txt | curl https://localhost:4343/transmit --http1.1 -d @- \
+  --insecure | base64 -d - | sha256sum > hash.0
+$ curl -H x-length:15000 -H x-seed:w3CJxsQ+deQ= --insecure \
+  https://localhost:4343/hash -w "  -\n" > hash.1
+$ cat file.txt | base64 -di - | sha256sum > hash.2
+$ diff hash.0 hash.1
+$ diff hash.0 hash.2
+```
+
+Finally, the server implements a proxy which can be used in this way:
+```sh
+$ curl --proxy http://localhost:8080/ https://www.google.com/
+...
+```
+
+### How to build and use it?
+
+As any MirageOS projects:
+```sh
+$ mirage configure -t unix
+$ make depends
+$ ./gen.sh foo
+$ mirage build
+$ ./dist/minipaf --tls
+...
+```
+
+### Disclamer
+
+This example wants to show a simple HTTP server with MirageOS without offering
+a high level API. Indeed, below an HTTP server, several elements exist
+(including the TLS layer). Paf exists to assemble all these elements in the
+**most transparent** way possible. Then, there can be a framework on top of
+that.

unikernel/duniverse/paf-le-chien/unikernel/server/certificates/foo

@@ -0,0 +1,29 @@
+-----BEGIN CERTIFICATE-----
+MIIFCTCCAvGgAwIBAgIUbGe8xVkM+g29lqiZmzqF6aO+qU8wDQYJKoZIhvcNAQEL
+BQAwFDESMBAGA1UEAwwJbG9jYWxob3N0MB4XDTIyMTAyMDE1MTE0N1oXDTIzMTAy
+MDE1MTE0N1owFDESMBAGA1UEAwwJbG9jYWxob3N0MIICIjANBgkqhkiG9w0BAQEF
+AAOCAg8AMIICCgKCAgEA9PAthwgcS/2zQBM+/VuO7hYCAeOZ+zXUygih62EnPupX
+twuaLpE0/3x4rcjL0uLxWifUVwOwBLYtJITfkBl4WyST7y9d2jwQDdUOrCOxACH9
+besublS/wKKUQJ04E2nlfuGRnqCfegTXVl+lexDvfZooVS/Ws/1kmouVzPQ0G1Ov
+TWIDpCx664v2uVbXthBHZjc3rUVeGc/w2iQ4ANlpT4Inty4lhpgFqgY8xC8d+odL
+oT+xTOlDbTleGWDDn00P3+Fe3IoUXN72wizqDG9r/3ja4dO6nRinBNpAHsPQ/gEv
+ZQoLImL1nt7t2GBfBVvMrflMdg33aYrb7qh+aXDb3AqBTMqwivPA78vlgMt8fV6v
+qgByFsvltQSCJX9smIAlOHuYE2GPwwv1JTfsXW1M89ytWCiUfEx+c9682l1t2i9I
+PZP96gaHK8qAHipi7CCJzPCd9Tgy69lZCetz0pAg2EXdlOL/TFka59k7V1PFwbO5
+UPbdugWueYrOHjhLllH/fS0k9d3vWU6bORk1Pf1zjVQBn3KWD8VF8l9nBqLgIj25
+W5tjdZRZSM+bLQ/IXWa8LGRxDA0P8eGaogwzZeaQbBET/voFSoThQbwpm8SQcbvO
+Z7/RO5E37mtGseMS5ywCyZV2TIUDoUWVQmWMIMTMNCvH0I3ZF2lnGN2vDYuU9CcC
+AwEAAaNTMFEwHQYDVR0OBBYEFBVPw8/7X/n3qzB/GG1nl6Zx0ThHMB8GA1UdIwQY
+MBaAFBVPw8/7X/n3qzB/GG1nl6Zx0ThHMA8GA1UdEwEB/wQFMAMBAf8wDQYJKoZI
+hvcNAQELBQADggIBAF/olgakqPM5lhoWliio+2yqzXJH1M7y4I1nO0ADcS7+GXHu
+/uf1sQ23iPZhUBgoZpyy1w6F0bTc8v/0YFawjSOnE+xM7eUEGvP3E+38FSwsASGg
+pnrumJp9+fDXMLrKeR+Xz1L3P02HQmKe2Mqn53i47aY2FZFbJWGoUZHD9ZgYxqmp
+tbd64tihepkSkkE26sBZtLlILz3mjvam29m3gtQJj3OZkP36MzXn+OTBLMDCqAiu
+AiGtvRJok7Ya1zpTY2axG65cA0NSCVW5XOnWS2Y5f8AXyvOnxv9Y2w0Z3ecyU1fQ
+oT6usjYyayP3rq05T1QrjIpE2t9J0pSxaoJlSuRmmE+IGBHLeR+TvJIvhfFM8kTb
+VoXIWWoDuZbeuNospLzH1fjLArDTFvd1Fhnuhv/3iXXVSti25mzQcQzVF8UVr175
+1pa/eyhPpf6exoQKsHdLm3g5rxgDW2sjo1aV0KDfDXVy0s6WUvgw9DK1CLFk9Pus
+fuVeOShv2cEY/owM516Up6R2LgqgDZld81xwUnhP6jqg/ugYkh4FhLrFiluPeK81
+4F4d20DER4ebQPWYLqwbPABJ6UxYFJ4etFD3IYQCI9qzn0PTCLx1W8mK1rHvjpKy
+kXCZmNNYRXzfpm4LYoMxpd8xXobiXTCTd2IisVplVzVRLfg4UuexWglwt5nU
+-----END CERTIFICATE-----

unikernel/duniverse/paf-le-chien/unikernel/server/config.ml

@@ -0,0 +1,56 @@
+open Mirage
+
+let port =
+  let doc = Key.Arg.info ~doc:"Port of HTTP service." [ "p"; "port" ] in
+  Key.(create "ports" Arg.(opt int 8080 doc))
+
+let tls =
+  let doc = Key.Arg.info ~doc:"Start an HTTP server with a TLS certificate." [ "tls" ] in
+  Key.(create "tls" Arg.(flag doc))
+
+let tls_port =
+  let doc = Key.Arg.info ~doc:"Port of HTTPS service." [ "tls-port" ] in
+  Key.(create "tls-port" Arg.(opt int 4343 doc))
+
+let alpn =
+  let doc = Key.Arg.info ~doc:"Protocols handled by the HTTP server." [ "alpn" ] in
+  Key.(create "alpn" Arg.(opt (some string) None doc))
+
+type conn = Connect
+let conn = typ Connect
+
+let minipaf =
+  foreign "Unikernel.Make"
+    ~packages:[ package "digestif"
+              ; package "mimic-happy-eyeballs"
+              ; package "rresult"
+              ; package "hxd" ~sublibs:[ "core"; "string" ]
+              ; package "base64" ~sublibs:[ "rfc2045" ] ]
+    ~keys:[ Key.v tls_port
+          ; Key.v tls
+          ; Key.v alpn ]
+    (random @-> kv_ro @-> kv_ro @-> tcpv4v6 @-> conn @-> http_server @-> job)
+
+let conn =
+  let connect _ modname = function
+    | [ _pclock; _tcpv4v6; ctx ] ->
+      Fmt.str {ocaml|%s.connect %s|ocaml} modname ctx
+    | _ -> assert false in
+  impl ~connect "Connect.Make"
+    (pclock @-> tcpv4v6 @-> git_client @-> conn)
+
+let stackv4v6 = generic_stackv4v6 default_network
+let tcpv4v6 = tcpv4v6_of_stackv4v6 stackv4v6
+let dns = generic_dns_client stackv4v6
+let certificates = crunch "certificates"
+let keys = crunch "keys"
+
+let conn =
+  let happy_eyeballs = git_happy_eyeballs stackv4v6 dns
+    (generic_happy_eyeballs stackv4v6 dns) in
+  conn $ default_posix_clock $ tcpv4v6 $ happy_eyeballs
+
+let http_server = paf_server ~port tcpv4v6
+
+let () = register "minipaf"
+  [ minipaf $ default_random $ certificates $ keys $ tcpv4v6 $ conn $ http_server ]

unikernel/duniverse/paf-le-chien/unikernel/server/connect.ml

@@ -0,0 +1,128 @@
+module type S = sig
+  val connect : Mimic.ctx -> Mimic.ctx Lwt.t
+  val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result
+end
+
+open Lwt.Infix
+
+let connect_scheme = Mimic.make ~name:"connect-scheme"
+let connect_port = Mimic.make ~name:"connect-port"
+let connect_hostname = Mimic.make ~name:"connect-hostname"
+let connect_tls_config = Mimic.make ~name:"connect-tls-config"
+
+module Make
+  (Pclock : Mirage_clock.PCLOCK)
+  (TCP : Tcpip.Tcp.S)
+  (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = struct
+  module TCP = struct
+    include TCP
+    type endpoint = Happy_eyeballs.t * string * int
+    type nonrec write_error =
+      [ `Write of write_error | `Connect of string | `Closed ]
+    let pp_write_error ppf = function
+      | `Connect err -> Fmt.string ppf err
+      | `Write err -> pp_write_error ppf err
+      | `Closed as err -> pp_write_error ppf err
+
+    let write flow cs =
+      let open Lwt.Infix in
+      write flow cs >>= function
+      | Ok _ as v -> Lwt.return v
+      | Error err -> Lwt.return_error (`Write err)
+
+    let writev flow css =
+      writev flow css >>= function
+      | Ok _ as v -> Lwt.return v
+      | Error err -> Lwt.return_error (`Write err)
+
+    let connect (happy_eyeballs, hostname, port) =
+      Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function
+      | Error (`Msg err) -> Lwt.return_error (`Connect err)
+      | Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow
+  end
+
+  let tcp_edn, _tcp_protocol = Mimic.register ~name:"tcp" (module TCP)
+
+  module TLS = struct
+    type endpoint = Happy_eyeballs.t * Tls.Config.client * string * int
+
+    include Tls_mirage.Make (TCP)
+
+    let connect (happy_eyeballs, cfg, hostname, port) =
+      let peer_name =
+        Result.(to_option (bind (Domain_name.of_string hostname) Domain_name.host)) in
+      Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function
+      | Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow
+      | Error (`Msg err) -> Lwt.return_error (`Write (`Connect err))
+  end
+
+  let tls_edn, _tls_protocol =
+    Mimic.register ~name:"tls" (module TLS)
+
+  let connect ctx =
+    let k0 happy_eyeballs connect_scheme connect_hostname connect_port = match connect_scheme with
+      | "http" -> Lwt.return_some (happy_eyeballs, connect_hostname, connect_port)
+      | _      -> Lwt.return_none in
+    let k1 happy_eyeballs connect_scheme connect_hostname connect_port tls_config = match connect_scheme with
+      | "https" -> Lwt.return_some (happy_eyeballs, tls_config, connect_hostname, connect_port)
+      | _       -> Lwt.return_none in
+    let ctx = Mimic.fold tcp_edn
+      Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs
+                ; req connect_scheme; req connect_hostname; dft connect_port 80 ]
+      ~k:k0 ctx in
+    let ctx = Mimic.fold tls_edn
+      Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs
+                ; req connect_scheme; req connect_hostname; dft connect_port 443
+                ; req connect_tls_config ]
+      ~k:k1 ctx in
+    Lwt.return ctx
+
+  let authenticator =
+    let module V = Ca_certs_nss.Make (Pclock) in
+    V.authenticator ()
+end
+
+let decode_uri ~ctx uri =
+  let ( >>= ) = Result.bind in
+  match String.split_on_char '/' uri with
+  | proto :: "" :: user_pass_host_port :: _path ->
+    ( if String.equal proto "http:"
+      then Ok ("http", Mimic.add connect_scheme "http" ctx)
+      else if String.equal proto "https:"
+      then Ok ("https", Mimic.add connect_scheme "https" ctx)
+      else Error (`Msg "Couldn't decode user and password") ) >>= fun (_scheme, ctx) ->
+    ( match String.split_on_char '@' user_pass_host_port with
+    | [ host_port ] -> Ok (None, host_port)
+    | [ _user_pass; host_port ] -> Ok (None, host_port)
+    | _ -> Error (`Msg "Couldn't decode URI") ) >>= fun (_user_pass, host_port) ->
+    ( match String.split_on_char ':' host_port with
+    | [] -> Error (`Msg "Empty host & port")
+    | [ hostname ] -> Ok (hostname, Mimic.add connect_hostname hostname ctx)
+    | hd :: tl ->
+      let port, hostname = match List.rev (hd :: tl) with
+        | hd :: tl -> hd, String.concat ":" (List.rev tl)
+        | _ -> assert false in
+      ( try Ok (hostname, Mimic.add connect_hostname hostname (Mimic.add connect_port (int_of_string port) ctx))
+        with Failure _ -> Error (`Msg "Couldn't decode port") ) ) >>= fun (hostname, ctx) ->
+    Ok (ctx, hostname)
+  | _ -> Error (`Msg "Couldn't decode URI on top")
+
+let tls_config ?tls_config authenticator =
+  lazy ( match tls_config with
+  | Some cfg -> Ok (`Custom cfg)
+  | None ->
+    let alpn_protocols = [ "h2"; "http/1.1" ] in
+    Result.map (fun authenticator -> `Default (Tls.Config.client ~alpn_protocols ~authenticator ())) authenticator )
+
+let create_connection ?tls_config:cfg ~ctx ~authenticator uri =
+  let tls_config = tls_config ?tls_config:cfg authenticator in
+  let open Lwt_result.Infix in
+  Lwt.return (decode_uri ~ctx uri) >>= fun (ctx, host) ->
+  let ctx = match Lazy.force tls_config with
+    | Ok (`Custom cfg) -> Mimic.add connect_tls_config cfg ctx
+    | Ok (`Default cfg) ->
+      ( match Result.bind (Domain_name.of_string host) Domain_name.host with
+      | Ok peer -> Mimic.add connect_tls_config (Tls.Config.peer cfg peer) ctx
+      | Error _ -> Mimic.add connect_tls_config cfg ctx )
+    | Error _ -> ctx in
+  Mimic.resolve ctx

unikernel/duniverse/paf-le-chien/unikernel/server/gen.sh

@@ -0,0 +1,5 @@
+#!/bin/sh
+
+hostname="${2:-localhost}"
+
+openssl req -x509 -newkey rsa:4096 -keyout keys/$1 -out certificates/$1 -sha256 -days 365 -subj "/CN=$hostname" -nodes

unikernel/duniverse/paf-le-chien/unikernel/server/keys/foo

@@ -0,0 +1,52 @@
+-----BEGIN PRIVATE KEY-----
+MIIJQgIBADANBgkqhkiG9w0BAQEFAASCCSwwggkoAgEAAoICAQD08C2HCBxL/bNA
+Ez79W47uFgIB45n7NdTKCKHrYSc+6le3C5oukTT/fHityMvS4vFaJ9RXA7AEti0k
+hN+QGXhbJJPvL13aPBAN1Q6sI7EAIf1t6y5uVL/AopRAnTgTaeV+4ZGeoJ96BNdW
+X6V7EO99mihVL9az/WSai5XM9DQbU69NYgOkLHrri/a5Vte2EEdmNzetRV4Zz/Da
+JDgA2WlPgie3LiWGmAWqBjzELx36h0uhP7FM6UNtOV4ZYMOfTQ/f4V7cihRc3vbC
+LOoMb2v/eNrh07qdGKcE2kAew9D+AS9lCgsiYvWe3u3YYF8FW8yt+Ux2Dfdpitvu
+qH5pcNvcCoFMyrCK88Dvy+WAy3x9Xq+qAHIWy+W1BIIlf2yYgCU4e5gTYY/DC/Ul
+N+xdbUzz3K1YKJR8TH5z3rzaXW3aL0g9k/3qBocryoAeKmLsIInM8J31ODLr2VkJ
+63PSkCDYRd2U4v9MWRrn2TtXU8XBs7lQ9t26Ba55is4eOEuWUf99LST13e9ZTps5
+GTU9/XONVAGfcpYPxUXyX2cGouAiPblbm2N1lFlIz5stD8hdZrwsZHEMDQ/x4Zqi
+DDNl5pBsERP++gVKhOFBvCmbxJBxu85nv9E7kTfua0ax4xLnLALJlXZMhQOhRZVC
+ZYwgxMw0K8fQjdkXaWcY3a8Ni5T0JwIDAQABAoICAAVvoSsKiIo9NrG426CG3Cy3
+i1LcaMn0/2R+fY16SgMw80JqPQFEkr8K1ajRuIhVJhMgqCtINytbmbPiSQ3rKssn
+DCt2SyhxRc/wxxMV9bMxjezXF+A1/E17rjui4aA4rPG8ct1o5jEwk1Dk7YjGLvKE
+Ldn6JlM3T/jIGUqDrvZeTJk0kC0gGZhJsm+ZmE7/nH4NwqwTSovbHBbTT/Tg3l/3
+3QbJPOb4T8PewJGAFDO/tfN9tOMmmCr/53E7vwu1i6El4NOXMu1+u05C7ezZujVg
+ysbRSqZ66hYG+/5SzTwd7Z3Z87ZPKPFeNDwlo2Y8i9Xenw5NsAyFGu14itmvOgnk
+ifrDnDD4CQvMPj3JRi1wBSZVqhEp9g783BsGwmLtvRqS8t1gxHeYemOgdrVRVInc
+dbhVXmMZiVg/lFaD7j3E6csZ9Pj/6TCYAEwMmeKvJ8n+tcgnFoGLyAe5ouvu1lBx
+0uO0SUF0IjgzAoAl1kYs2dOra6iUrl70PdZsEuYX3y/v7aWtnkl3X/WbNw9oGFWc
+eBl30n0IRsPQ/N/XEXETdB8kCeaFaxifam9/6clsey+2HEhoWDH3TVJ4mjiF8ftL
+1N6j1UpU9n/xmRnJ47/CRNLurC5zO3tULezrMbV2LTqLiIW7EVOgiKKsyS8oONfe
+40sQXhtBjQoPyNZV+nhxAoIBAQD2eP44jWq8C38NXlPVmuQx2T3AdysuSgkLVPJG
+nte9CESilbPZ/CGRpjwWYmgpytELIRjqLUv7kiSRAzmbe8P2SfD2uptiyzhuC4Sc
+xFyDcExGCAQhdeqi9H1VkOS9ij75wwix3Nziy9xRq0nScTcuIPoLBToh68VR3Fw8
+S0JEsttaH4K6MfcIUarIVU4C9CrZDFOMKgy5FuE4UQDmu2ao7w98tDacLkwgOORk
+4MQCobtxFkxrCmlAQpSOYCjACmX0twH9Vcneko/NYVpcSPc1Wcn4yFHiGlfvqIt1
+UhmIZmoTBRjw7c5Fw4bC4fYwpF7BbsfyIQAtn1mXIBk33ak3AoIBAQD+aAAlBYsD
+WC/V14RYL8unaPkWSL66sqZEfZEOfV+VyTT14ovynYLcyTdNqET8x4lXj820YD34
+UGgiPI8yocsKhFMro2nw4RZDvvQJtvm835IAx5l2BHB8QOgqwuI/qw3J44p9LQqh
+Zk6ioeO7g4hMvrSDPZ1Pkort6ikjok/eQapXGTtMlEWOo3+AMODnGDWLpEHLJhNI
+D7jA4Zphtw5SfUdAYeGK2QycioQYl/xCSnTyTKo5zurXgL/5b2vwUB+qG0FUWTsV
+OHJgpmT2TxvUw25uv383RI/xO5Hb6P48nTbOYG86fQRktlPOVr/vlyQMmJSBHL5/
+wSCMtuLvVsSRAoIBAB7Ux8g/OGjJb102vXns5DqwGB9pSMeDj1oRiDT5Tbdhv2Qv
+Ic5U0cYsazvJl4oSys9/lmREwkp334ccRiqC8uJuIWxbr3BOR4LMggwyK/htJb1k
+509gNrenqb34YASttG79zKqjHCZqpea5bISckPB+Q4j5YGo52fcBf7AzIdkCHppJ
+csrj0SkDPj/NG/MWo/1+ozzXTbwhdo7a4yf5rT/Yl7FbwbELwY4OT9Omoh5KKO5e
+gbSqGrxlF7wvnylWo6ZW9jLAdn4XC1H/qZP9tJ7B2pf6RvPno7Rg+wD0Aimj1gUH
+EDWjKbhkWwkpxugSx5+ewfgx1JngYw6af00Tt0UCggEBANz3wiBl1x95ilrnjXj3
+UqE+6RL07kzE/OuCUOrP9KTqFYj4U+vP6akRUGqwG/Oe8GjQa7Ae49R5KmmKRiqJ
+Iw0ocAD4N/1T0/3Vrqt9dR8a5PquY1mBc55I1h7GFLOORDS14UTmSVR0wxo5GM92
+6H0YKzvO2YMS2n7ZIxBjW5HFYUmzjbDvHBdPZWAXlFDE00VNzyO/F4JAvY0ypt/2
+mocFb0y5d6gc6/pPyXp/EEkX2MnX0wbQ9WNm3deucodRYJ9kevLjahD9bUMLY6gY
+gCjl8lZZGAsODyRNRFxI3AIT31WTpyibC6TaRKJ08NMOaO5T3LDkIYZfXYE7HJMb
+vzECggEATzoSzz/NWwuUmcfJG43yS1TZq7wiMDRIeGxUr4pYsb3BWHSFEYhRDMi+
+1XMFA0W1usOAeOLIJOVNPLOC8w3j15xmd+rCqOddOKP0ko1MMdPg8E8O/rlehwLX
+eg6VBA8LYwlTswoKN8YcwG5Mrr6vbIZNrP0HNWUrUbDoOk6cVd4qrvh5eyzF29aZ
+Au0QwJrcrTmS7mBdmHm6UJGUrw3ZahmWjDeLjiPodojjtDZGJr8aIvXO7M5x2Bp4
+4l9qhsaKXIkxiSUn6aL6JHI4Y6LKrmLHOqev8nWEap8GOERB+JHf1gP1y6HlO97z
+4wOoFDBqO9Cmwrs/vzlrraEWjMEjRw==
+-----END PRIVATE KEY-----

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

@@ -0,0 +1,484 @@
+let src = Logs.Src.create "server"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let is_digit = function
+  | '0' .. '9' -> true | _ -> false
+
+let root =
+  {plain|Hello fellows!
+
+This unikernel is a simple example of a website that supports HTTP/1.1, H2 and
+the TLS security layer. This is an example of how to make a website with
+MirageOS.
+
+The website has several endpoints:
+- `http{,s}://$hostname/` the page you are about to read.
+- `http{,s}://$hostname/transmit` a page that copies what is sent (no matter
+  how big it is)
+- `http{,s}://$hostname/hash` calculates a hash from a random content
+  generated by a seed `x-seed`
+- `http{,s}://$hostname/random` a page that waits in the request for a size
+  (`x-length`) and generates a random (optionally seeded by `x-seed`) content
+  encoded in base64
+
+These different endpoints allow performance tests of what MirageOS can offer.
+Have fun, and hack it!
+|plain}
+
+let random_cstruct ~g buf len =
+  for i = 0 to Cstruct.length buf - 1 do
+    let v = Random.State.bits g land 0xff in
+    Cstruct.set_uint8 buf i v
+  done ; Cstruct.sub buf 0 len
+
+let random_state_of_seed str =
+  match Base64.decode str with
+  | Error _ -> None
+  | Ok seed ->
+    let res = Array.make (String.length seed / 2) 0 in
+    for i = 0 to (String.length seed / 2) - 1
+    do res.(i) <- (Char.code seed.[i * 2] lsl 8) lor (Char.code seed.[i * 2 + 1]) done ;
+    Some (Random.State.make res)
+
+let transmit_random ~write_string ~flush ~close_writer ?(g= Random.State.make_self_init ()) length body =
+  let tmp = Bytes.create (0x1000 * 4) in
+  let rnd = Cstruct.create 0x1000 in
+  let ctx = Digestif.SHA256.empty in
+
+  let encoder = Base64_rfc2045.encoder `Manual in
+
+  let rec go ctx length cs = function
+    | `Ok when Cstruct.length cs = 0 -> encode ctx length
+    | `Ok ->
+      go ctx length (Cstruct.shift cs 1)
+        (Base64_rfc2045.encode encoder (`Char (Cstruct.get_char cs 0)))
+    | `Partial ->
+      let len = Bytes.length tmp - Base64_rfc2045.dst_rem encoder in
+      write_string body (Bytes.sub_string tmp 0 len) ;
+      Base64_rfc2045.dst encoder tmp 0 (Bytes.length tmp) ;
+      let next () = go ctx length cs (Base64_rfc2045.encode encoder `Await) in
+      flush body next
+  and encode ctx = function
+    | 0L -> finalize ctx (Base64_rfc2045.encode encoder `End)
+    | length ->
+      let len = min (Int64.of_int (Cstruct.length rnd)) length in
+      let { Cstruct.buffer; off; len= buffer_len; } as rnd = random_cstruct ~g rnd (Int64.to_int len) in
+      Log.debug (fun m -> m "@[<hov>%a@]"
+        (Hxd_string.pp Hxd.default) (Bigstringaf.substring buffer ~off ~len:buffer_len)) ;
+      let ctx = Digestif.SHA256.feed_bigstring ctx ~off ~len:buffer_len buffer in
+      go ctx (Int64.sub length len) rnd `Ok
+  and finalize ctx = function
+    | `Partial ->
+      let len = Bytes.length tmp - Base64_rfc2045.dst_rem encoder in
+      write_string body (Bytes.sub_string tmp 0 len) ;
+      Base64_rfc2045.dst encoder tmp 0 (Bytes.length tmp) ;
+      let next () = finalize ctx (Base64_rfc2045.encode encoder `Await) in
+      flush body next
+    | `Ok ->
+      Logs.debug (fun m -> m "%a" Digestif.SHA256.pp (Digestif.SHA256.get ctx)) ;
+      close_writer body in
+
+  Base64_rfc2045.dst encoder tmp 0 (Bytes.length tmp) ;
+  encode ctx length
+
+let hash ~version ~create ?seed length =
+  let rec go g rnd ctx = function
+    | 0L ->
+      let headers =
+        [ "content-length", string_of_int (Digestif.SHA256.digest_size * 2)
+        ; "content-type", "text/plain" ] in
+      (* XXX(dinosaure): Connection: Close header is only true for http/1.1.
+         For h2, curl complains and abruptely closes the connection. The most
+         important seems Content-Length which closes properly the connection
+         on both sides. *)
+      let headers = match version with
+        | `HTTP_1_1 -> ("connection", "close") :: headers
+        | `HTTP_2_0 -> headers in
+      let response = create headers `OK in
+      response, Digestif.SHA256.(to_hex (get ctx))
+    | length ->
+      let len = min (Int64.of_int (Cstruct.length rnd)) length in
+      let { Cstruct.buffer; off; len= buffer_len; } = random_cstruct ~g rnd (Int64.to_int len) in
+      Log.debug (fun m -> m "@[<hov>%a@]"
+        (Hxd_string.pp Hxd.default) (Bigstringaf.substring buffer ~off ~len:buffer_len)) ;
+      let ctx = Digestif.SHA256.feed_bigstring ctx ~off ~len:buffer_len buffer in
+      go g rnd ctx (Int64.sub length len) in
+  match Option.bind seed random_state_of_seed,
+        Option.bind length Int64.of_string_opt with
+  | Some g, Some length -> go g (Cstruct.create 0x1000) Digestif.SHA256.empty length
+  | _ ->
+    let contents = "Invalid seed." in
+    let headers =
+      [ "content-length", string_of_int (String.length contents)
+      ; "content-type", "text/plain" ] in
+    let headers = match version with
+      | `HTTP_1_1 -> ("connection", "close") :: headers
+      | `HTTP_2_0 -> headers in
+    let response = create headers `Bad_request in
+    response, contents
+
+module Cache = Ephemeron.K1.Make
+  (struct type t = string option * string option let equal = (=) let hash = Hashtbl.hash end)
+
+module type S = sig
+  type response
+  type request
+
+  val version : [ `HTTP_1_1 | `HTTP_2_0 ]
+  val create : (string * string) list -> H2.Status.t -> response
+  val with_etag : string -> response -> response
+  val with_status : H2.Status.t -> response -> response
+  val get : request -> string -> string option
+end
+
+let hash_of_seed
+  :  type response request.
+     (module S with type response = response and type request = request)
+  -> respond:(response -> string -> unit)
+  -> request
+  -> unit
+  = fun (module S) -> (); let tbl = Cache.create 0x100 in
+    fun ~respond request ->
+    let seed = S.get request "x-seed" and length = S.get request "x-length" in
+
+    match Cache.find_opt tbl (seed, length),
+          S.get request "if-none-match" with
+    | None, _ | Some _, None ->
+      let response, contents = hash ~version:S.version ~create:S.create ?seed length in
+      Cache.add tbl (seed, length) (response, contents) ;
+      respond response contents
+    | Some (response, contents),
+      Some etags ->
+      let hash = Digestif.SHA256.digest_string contents in
+      let hash = Digestif.SHA256.to_hex hash in
+
+      if List.mem hash (String.split_on_char ',' etags)
+      then let response = S.with_etag hash (S.with_status `Not_modified response) in
+           respond response String.empty
+      else respond response contents
+
+let transmit_over_http
+  : to_close:_ -> Mimic.flow -> Mimic.flow -> unit Lwt.t
+  = fun ~to_close src dst ->
+    let open Lwt.Infix in
+    let closed = Lwt_mvar.create_empty () in
+    let rec loop ~src ~dst () =
+      Lwt.pick [ Lwt_result.Infix.(Mimic.read src >|= fun v -> (v :> [ `Closed | _ Mirage_flow.or_eof ]))
+               ; (Lwt_mvar.take closed >|= fun v -> Ok v) ] >>= function
+      | Error err ->
+        Log.err (fun m -> m "Got an error while we reading the source \
+                             (CONNECT): %a."
+          Mimic.pp_error err) ;
+        if Lwt_mvar.is_empty closed
+        then Lwt_mvar.put closed `Closed
+        else Lwt.return_unit
+      | Ok `Closed -> Lwt.return_unit
+      | Ok `Eof ->
+        if Lwt_mvar.is_empty closed
+        then Lwt_mvar.put closed `Closed
+        else Lwt.return_unit
+      | Ok (`Data cs) ->
+        Log.debug (fun m -> m "Transfer over HTTP:") ;
+        Log.debug (fun m -> m "@[<hov>%a@]."
+          (Hxd_string.pp Hxd.default) (Cstruct.to_string cs)) ;
+        Mimic.write dst cs >>= function
+        | Ok () -> Lwt.pause () >>= loop ~src ~dst
+        | Error err ->
+          Log.err (fun m -> m "Got an error while we writing into \
+                               the destination (CONNECT): %a."
+            Mimic.pp_write_error err) ;
+          if Lwt_mvar.is_empty closed
+          then Lwt_mvar.put closed `Closed
+          else Lwt.return_unit in
+    Lwt.join
+      [ loop ~src:src ~dst:dst ()
+      ; loop ~src:dst ~dst:src () ] >>= fun () ->
+    to_close src ;
+    Lwt.join [ Mimic.close src; Mimic.close dst ] >>= fun () ->
+    Log.debug (fun m -> m "Connection closed properly on both side.") ;
+    Lwt.return_unit
+
+(***** HTTP/1.1 *****)
+
+module S_HTTP_1_1 = struct
+  type request = Httpaf.Request.t
+  type response = Httpaf.Response.t
+
+  let version = `HTTP_1_1
+  let get request name = Httpaf.Headers.get request.Httpaf.Request.headers name
+  let create headers = function
+    | #Httpaf.Status.t as status -> Httpaf.Response.create ~headers:(Httpaf.Headers.of_list headers) status
+    | _ -> assert false
+  let with_etag etag response =
+    let headers = response.Httpaf.Response.headers in
+    { response with Httpaf.Response.headers= Httpaf.Headers.add headers "etag" etag }
+  let with_status (status : H2.Status.t) response = match status with
+    | #Httpaf.Status.t as status -> { response with Httpaf.Response.status }
+    | _ -> assert false
+end
+
+let transmit src dst =
+  let rec on_eof () =
+    Httpaf.Body.close_reader src ;
+    Httpaf.Body.close_writer dst
+  and on_read buf ~off ~len =
+    Httpaf.Body.write_bigstring dst ~off ~len buf ;
+    Httpaf.Body.schedule_read src ~on_eof ~on_read in
+  Httpaf.Body.schedule_read src ~on_eof ~on_read
+
+let connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd =
+  let request = Httpaf.Reqd.request reqd in
+  ( match Httpaf.Headers.get request.Httpaf.Request.headers "host" with
+  | Some uri ->
+    let uri = "http://" ^ uri in
+    let open Lwt.Infix in
+    Lwt.async (fun () -> Connect.create_connection ~ctx ~authenticator uri >>= function
+    | Ok dst ->
+      let headers = Httpaf.Headers.of_list
+        [ "connection", "close" ] in
+      let response = Httpaf.Response.create ~reason:"CONNECT" ~headers `OK in
+      Httpaf.Reqd.respond_with_string reqd response "" ;
+      Httpaf.Body.close_reader (Httpaf.Reqd.request_body reqd) ;
+      transmit_over_http ~to_close flow dst
+    | Error err ->
+      Log.err (fun m -> m "Got an error while connection to %S: %a." uri Mimic.pp_error err) ;
+      let contents = Fmt.str "Invalid URI: %S" uri in
+      let headers = Httpaf.Headers.of_list
+        [ "content-length", string_of_int (String.length contents)
+        ; "connection", "close"
+        ; "content-type", "text/plain" ] in
+      let response = Httpaf.Response.create ~reason:"CONNECT" ~headers `Bad_request in
+      Httpaf.Reqd.respond_with_string reqd response contents ;
+      Lwt.return_unit )
+  | None ->
+    let contents = "Missing Host field." in
+    let headers = Httpaf.Headers.of_list
+      [ "content-length", string_of_int (String.length contents)
+      ; "connection", "close"
+      ; "content-type", "text/plain" ] in
+    let response = Httpaf.Response.create ~reason:"CONNECT" ~headers `Bad_request in
+    Httpaf.Reqd.respond_with_string reqd response contents )
+
+let http_1_1_request_handler ~ctx ~authenticator ~to_close =
+  let hash_of_seed = hash_of_seed (module S_HTTP_1_1) in
+  fun flow reqd ->
+  let request = Httpaf.Reqd.request reqd in
+  Log.debug (fun m -> m "(HTTP/1.1) request-handler: %S" request.Httpaf.Request.target) ;
+  match request.Httpaf.Request.meth with
+  | `CONNECT ->
+    Log.debug (fun m -> m "Start to transmit data over HTTP/1.1.") ;
+    connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd
+  | _meth ->
+    match String.split_on_char '/' request.Httpaf.Request.target with
+    | [ ""; "" ] ->
+      let headers = Httpaf.Headers.of_list
+        [ "content-length", string_of_int (String.length root)
+        ; "connection", "close"
+        ; "content-type", "text/plain" ] in
+      let response = Httpaf.Response.create ~reason:"root" ~headers `OK in
+      Httpaf.Reqd.respond_with_string reqd response root
+    | [ ""; "transmit" ] ->
+      let content_type = Httpaf.Headers.get request.Httpaf.Request.headers "content-type" in
+      let content_type = Option.value ~default:"application/octet-stream" content_type in
+      let headers = Httpaf.Headers.of_list
+        [ "transfer-encoding", "chunked"
+        ; "content-type", content_type ] in     
+      let response = Httpaf.Response.create ~reason:"transmit" ~headers `OK in
+      let src = Httpaf.Reqd.request_body reqd in
+      let dst = Httpaf.Reqd.respond_with_streaming reqd response in
+      transmit src dst
+    | [ ""; "hash" ] ->
+      let respond response contents = Httpaf.Reqd.respond_with_string reqd response contents in
+      hash_of_seed ~respond request
+    | [ ""; "random" ] ->
+      ( match Httpaf.Headers.get request.Httpaf.Request.headers "x-length" with
+      | Some v when String.for_all is_digit v ->
+        let length = Int64.of_string v in
+        let g = Option.bind (Httpaf.Headers.get request.Httpaf.Request.headers "x-seed") random_state_of_seed in
+        let headers = Httpaf.Headers.of_list
+          [ "content-type", "text/plain"
+          ; "transfer-encoding", "chunked" ] in
+        let response = Httpaf.Response.create ~reason:"random" ~headers `OK in
+        let body = Httpaf.Reqd.respond_with_streaming reqd response in
+        transmit_random
+          ~write_string:(fun body str -> Httpaf.Body.write_string body str)
+          ~flush:Httpaf.Body.flush
+          ~close_writer:Httpaf.Body.close_writer
+          ?g length body
+      | _ ->
+        let contents = "Invalid length." in
+        let headers = Httpaf.Headers.of_list
+          [ "content-length", string_of_int (String.length contents)
+          ; "connection", "close"
+          ; "content-type", "text/plain" ] in
+        let response = Httpaf.Response.create ~reason:"random" ~headers `Bad_request in
+        Httpaf.Reqd.respond_with_string reqd response contents )
+    | _ ->
+      let contents = "Not found." in
+      let headers = Httpaf.Headers.of_list
+        [ "content-type", "text/plain"
+        ; "connection", "close"
+        ; "content-length", string_of_int (String.length contents) ] in
+      let response = Httpaf.Response.create ~reason:"not-found" ~headers `Not_found in
+      Httpaf.Reqd.respond_with_string reqd response contents
+
+(***** H2 *****)
+
+module S_HTTP_2_0 = struct
+  type request = H2.Request.t
+  type response = H2.Response.t
+
+  let version = `HTTP_2_0
+  let get request name = H2.Headers.get request.H2.Request.headers name
+  let create headers status = H2.Response.create ~headers:(H2.Headers.of_list headers) status
+  let with_etag etag response =
+    let headers = response.H2.Response.headers in
+    { response with H2.Response.headers= H2.Headers.add headers "etag" etag }
+  let with_status status response = { response with H2.Response.status }
+end
+
+let transmit src dst =
+  let rec on_eof () =
+    H2.Body.Reader.close src ;
+    H2.Body.Writer.close dst
+  and on_read buf ~off ~len =
+    H2.Body.Writer.write_bigstring dst ~off ~len buf ;
+    H2.Body.Reader.schedule_read src ~on_eof ~on_read in
+  H2.Body.Reader.schedule_read src ~on_eof ~on_read
+
+let connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd =
+  let request = H2.Reqd.request reqd in
+  ( match H2.Headers.get request.H2.Request.headers "host" with
+  | Some uri ->
+    let uri = "http://" ^ uri in
+    let open Lwt.Infix in
+    Lwt.async (fun () -> Connect.create_connection ~ctx ~authenticator uri >>= function
+    | Ok dst ->
+      let response = H2.Response.create `OK in
+      H2.Reqd.respond_with_string reqd response "" ;
+      H2.Body.Reader.close (H2.Reqd.request_body reqd) ;
+      transmit_over_http ~to_close flow dst
+    | Error err ->
+      Log.err (fun m -> m "Got an error while connection to %S: %a." uri Mimic.pp_error err) ;
+      let contents = Fmt.str "Invalid URI: %S" uri in
+      let headers = H2.Headers.of_list
+        [ "content-length", string_of_int (String.length contents)
+        ; "content-type", "text/plain" ] in
+      let response = H2.Response.create ~headers `Bad_request in
+      H2.Reqd.respond_with_string reqd response contents ;
+      Lwt.return_unit )
+  | None ->
+    let contents = "Missing Host field." in
+    let headers = H2.Headers.of_list
+      [ "content-length", string_of_int (String.length contents)
+      ; "content-type", "text/plain" ] in
+    let response = H2.Response.create ~headers `Bad_request in
+    H2.Reqd.respond_with_string reqd response contents )
+
+let http_2_0_request_handler ~ctx ~authenticator ~to_close =
+  let hash_of_seed = hash_of_seed (module S_HTTP_2_0) in
+  fun flow reqd ->
+  let request = H2.Reqd.request reqd in
+  Log.debug (fun m -> m "(H2) request-handler: %S" request.H2.Request.target) ;
+  match request.H2.Request.meth with
+  | `CONNECT ->
+    Log.debug (fun m -> m "Start to transmit data over H2.") ;
+    connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd
+  | _meth -> match String.split_on_char '/' request.H2.Request.target with
+    | [ ""; "" ] ->
+      let headers = H2.Headers.of_list
+        [ "content-length", string_of_int (String.length root)
+        ; "content-type", "text/plain" ] in
+      let response = H2.Response.create ~headers `OK in
+      H2.Reqd.respond_with_string reqd response root
+    | [ ""; "transmit" ] ->
+      let content_type = H2.Headers.get request.H2.Request.headers "content-type" in
+      let content_type = Option.value ~default:"application/octet-stream" content_type in
+      let headers = H2.Headers.of_list
+        [ "content-type", content_type ] in     
+      let response = H2.Response.create ~headers `OK in
+      let src = H2.Reqd.request_body reqd in
+      let dst = H2.Reqd.respond_with_streaming reqd response in
+      transmit src dst
+    | [ ""; "hash" ] ->
+      let respond response contents = H2.Reqd.respond_with_string reqd response contents in
+      hash_of_seed ~respond request
+    | [ ""; "random" ] ->
+      ( match H2.Headers.get request.H2.Request.headers "x-length" with
+      | Some v when String.for_all is_digit v ->
+        let length = Int64.of_string v in
+        let g = Option.bind (H2.Headers.get request.H2.Request.headers "x-seed") random_state_of_seed in
+        let headers = H2.Headers.of_list
+          [ "content-type", "text/plain" ] in
+        let response = H2.Response.create ~headers `OK in
+        let body = H2.Reqd.respond_with_streaming reqd response in
+        transmit_random
+          ~write_string:(fun body str -> H2.Body.Writer.write_string body str)
+          ~flush:H2.Body.Writer.flush
+          ~close_writer:H2.Body.Writer.close
+          ?g length body
+      | _ ->
+        let contents = "Invalid length." in
+        let headers = H2.Headers.of_list
+          [ "content-length", string_of_int (String.length contents)
+          ; "content-type", "text/plain" ] in
+        let response = H2.Response.create ~headers `Bad_request in
+        H2.Reqd.respond_with_string reqd response contents )
+    | _ ->
+      let contents = "Not found." in
+      let headers = H2.Headers.of_list
+        [ "content-type", "text/plain"
+        ; "content-length", string_of_int (String.length contents) ] in
+      let response = H2.Response.create ~headers `Not_found in
+      H2.Reqd.respond_with_string reqd response contents
+
+let alpn_request_handler
+  : type reqd headers request response ro wo.
+    ctx:_ -> authenticator:_ -> to_close:_ -> ?shutdown:_ -> _ -> _ -> reqd -> (reqd, headers, request, response, ro, wo) Alpn.protocol -> unit
+  = fun ~ctx ~authenticator ~to_close ?shutdown:_ flow _edn reqd -> function
+  | Alpn.HTTP_1_1 _ -> http_1_1_request_handler ~ctx ~authenticator ~to_close flow reqd
+  | Alpn.H2 _ -> http_2_0_request_handler ~ctx ~authenticator ~to_close flow reqd
+
+let headers_of_list
+  : type reqd headers request response ro wo.
+    (reqd, headers, request, response, ro, wo) Alpn.protocol -> (string * string) list -> headers
+  = fun protocol lst -> match protocol with
+  | Alpn.HTTP_1_1 _ -> Httpaf.Headers.of_list lst
+  | Alpn.H2 _ -> H2.Headers.of_list lst
+
+let respond_with_string
+  : type reqd headers request response ro wo.
+    (reqd, headers, request, response, ro, wo) Alpn.protocol -> 
+    headers:headers -> respond:(headers -> wo) -> string -> unit
+  = fun protocol ~headers ~respond str ->
+  let body = respond headers in
+  match protocol with
+  | Alpn.HTTP_1_1 _ ->
+    Httpaf.Body.write_string body str ;
+    Httpaf.Body.close_writer body
+  | Alpn.H2 _ ->
+    H2.Body.Writer.write_string body str ;
+    H2.Body.Writer.close body
+
+let alpn_error_handler
+  : type reqd headers request response ro wo.
+    _ -> (reqd, headers, request, response, ro, wo) Alpn.protocol -> ?request:_ -> _ -> (headers -> wo) -> unit
+  = fun _edn protocol ?request:_ error respond ->
+  let contents = match error with
+    | `Bad_gateway -> {plain|Bad gateway.|plain}
+    | `Bad_request -> {plain|Bad request.|plain}
+    | `Exn (Paf.Flow err) | `Exn (Paf.Flow_write err) -> Fmt.str {plain|I/O error: %s.|plain} err
+    | `Exn exn -> Fmt.str {plain|Unknown error: %S.|plain} (Printexc.to_string exn)
+    | `Internal_server_error -> {plain|Internal server error.|plain} in
+  let headers = headers_of_list protocol
+    [ "content-type", "text/plain"
+    ; "content-length", string_of_int (String.length contents) ] in
+  respond_with_string protocol ~respond ~headers contents
+
+let http_1_1_error_handler edn ?request error respond =
+  alpn_error_handler edn ?request Alpn.http_1_1
+    (error :> Alpn.server_error) respond
+
+let http_2_0_error_handler edn ?request error respond =
+  alpn_error_handler edn ?request Alpn.h2
+    (error :> Alpn.server_error) respond

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

@@ -0,0 +1,106 @@
+open Rresult
+open Lwt.Infix
+
+let ( <.> ) f g = fun x -> f (g x)
+let always x = fun _ -> x
+
+module Make
+  (Random : Mirage_random.S)
+  (Certificate : Mirage_kv.RO)
+  (Key : Mirage_kv.RO)
+  (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t)
+  (Connect : Connect.S)
+  (HTTP_Server : Paf_mirage.S) = struct
+
+  let tls key_ro certificate_ro =
+    let open Lwt_result.Infix in
+    Lwt.Infix.(Key.list key_ro Mirage_kv.Key.empty
+    >|= R.reword_error (R.msgf "%a" Key.pp_error)) >>= fun keys ->
+    let keys, _ = List.partition (fun (_, t) -> t = `Value) keys in
+    Lwt.Infix.(Certificate.list certificate_ro Mirage_kv.Key.empty
+    >|= R.reword_error (R.msgf "%a" Certificate.pp_error)) >>= fun certificates ->
+    let certificates, _ = List.partition (fun (_, t) -> t = `Value) certificates in
+    let fold acc (name, _) = match name with
+      | ".gitkeep" -> Lwt.return acc
+      | _ ->
+        let open Lwt_result.Infix in
+        Lwt.Infix.(Certificate.get certificate_ro
+          Mirage_kv.Key.(empty / name) >|= R.reword_error (R.msgf "%a" Certificate.pp_error))
+        >|= Cstruct.of_string
+        >>= (Lwt.return <.> X509.Certificate.decode_pem_multiple)
+        >>= fun certificates -> Lwt.return acc >>= fun acc ->
+        Lwt.return_ok ((name, certificates) :: acc) in
+    Lwt_list.fold_left_s fold (Ok []) certificates >>= fun certificates ->
+    let fold acc (name, _) = match name with
+      | ".gitkeep" -> Lwt.return acc
+      | _ ->
+        let open Lwt_result.Infix in
+        Lwt.Infix.(Key.get key_ro 
+          Mirage_kv.Key.(empty / name) >|= R.reword_error (R.msgf "%a" Key.pp_error))
+        >|= Cstruct.of_string
+        >>= (Lwt.return <.> X509.Private_key.decode_pem)
+        >>= fun key -> Lwt.return acc
+        >>= fun acc -> Lwt.return_ok ((name, key) :: acc) in
+    Lwt_list.fold_left_s fold (Ok []) keys >>= fun keys ->
+    let tbl = Hashtbl.create 0x10 in
+    List.iter (fun (name, certificates) -> match List.assoc_opt name keys with
+      | Some key -> Hashtbl.add tbl name (certificates, key)
+      | None -> ()) certificates ;
+    match Hashtbl.fold (fun _ certchain acc -> certchain :: acc) tbl [] with
+    | [] -> Lwt.return_ok `None
+    | [ certchain ] -> Lwt.return_ok (`Single certchain)
+    | certchains -> Lwt.return_ok (`Multiple certchains)
+
+  let http_1_1_request_handler ~ctx ~authenticator flow _edn =
+    let module R = (val (Mimic.repr HTTP_Server.tcp_protocol)) in
+    fun reqd ->
+      match (Httpaf.Reqd.request reqd).Httpaf.Request.meth with
+      | `CONNECT ->
+        HTTP_Server.TCP.no_close flow ;
+        let to_close = function
+          | R.T flow -> HTTP_Server.TCP.to_close flow
+          | _ -> () in
+        Server.http_1_1_request_handler ~ctx ~authenticator ~to_close (R.T flow) reqd
+      | _ ->
+        Server.http_1_1_request_handler ~ctx ~authenticator ~to_close:(always ()) (R.T flow) reqd
+
+  let alpn_handler ~ctx ~authenticator =
+    let module R = (val (Mimic.repr HTTP_Server.tls_protocol)) in
+    let to_close = function
+      | R.T flow -> HTTP_Server.TLS.to_close flow
+      | _ -> () in
+    { Alpn.error= Server.alpn_error_handler
+    ; Alpn.request= (fun flow edn reqd protocol ->
+      Server.alpn_request_handler ~ctx ~authenticator ~to_close (R.T flow) edn reqd protocol) }
+
+  let run_with_tls ~ctx ~authenticator ~tls tcpv4v6 http_server =
+    let alpn_service = HTTP_Server.alpn_service ~tls (alpn_handler ~ctx ~authenticator) in
+    let http_1_1_service =
+      HTTP_Server.http_service ~error_handler:Server.http_1_1_error_handler
+        (http_1_1_request_handler ~ctx ~authenticator) in
+    HTTP_Server.init ~port:(Key_gen.tls_port ()) tcpv4v6 >>= fun tls_server ->
+    let `Initialized th0 = HTTP_Server.serve alpn_service tls_server in
+    let `Initialized th1 = HTTP_Server.serve http_1_1_service http_server in
+    Lwt.both th0 th1 >>= fun ((), ()) -> Lwt.return_unit
+
+  let run ~ctx ~authenticator http_server =
+    let http_1_1_service =
+      HTTP_Server.http_service ~error_handler:Server.http_1_1_error_handler
+        (http_1_1_request_handler ~ctx ~authenticator) in
+    let `Initialized th = HTTP_Server.serve http_1_1_service http_server in th
+
+  let start _random certificate_ro key_ro tcpv4v6 ctx http_server =
+    let open Lwt.Infix in
+    let authenticator = Connect.authenticator in
+    tls key_ro certificate_ro >>= fun tls ->
+    match Key_gen.tls (), tls, Key_gen.alpn () with
+    | true, Ok certificates, None ->
+      run_with_tls ~ctx ~authenticator ~tls:(Tls.Config.server ~certificates ~alpn_protocols:[ "h2"; "http/1.1" ] ())
+        tcpv4v6 http_server
+    | true, Ok certificates, Some (("http/1.1" | "h2") as alpn_protocol) ->
+      run_with_tls ~ctx ~authenticator ~tls:(Tls.Config.server ~certificates ~alpn_protocols:[ alpn_protocol ] ())
+        tcpv4v6 http_server
+    | false, _, _ -> run ~ctx ~authenticator http_server
+    | _, _, Some protocol -> Fmt.failwith "Invalid protocol %S" protocol
+    | true, Error _, _ -> Fmt.failwith "A TLS server requires, at least, one certificate and one private key."
+end