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. *)