Delete cohttp dependency and split packages

.ocamlformat

@@ -1,4 +1,4 @@
-version = 0.17.0
+version = 0.18.0
 break-infix = fit-or-vertical
 parse-docstrings = true
 indicate-multiline-delimiters=no

lib/dune

@@ -18,7 +18,7 @@
 
 (library
  (name paf_cohttp)
- (public_name paf.cohttp)
+ (public_name paf-cohttp)
  (modules paf_cohttp)
  (libraries ipaddr domain-name paf httpaf cohttp-lwt))
 
@@ -27,11 +27,5 @@
  (wrapped false)
  (public_name paf.le)
  (modules lE)
- (libraries mirage-time mirage-stack paf.cohttp duration tls-mirage emile
+ (libraries httpaf paf mirage-time mirage-stack duration tls-mirage emile
    letsencrypt))
-
-; (library
-;  (name mirage_paf)
-;  (public_name paf.mirage)
-;  (modules mirage_paf)
-;  (libraries mirage))

lib/lE.ml

@@ -1,12 +1,222 @@
 (* (c) Hannes Menhert *)
 
+let ( <.> ) f g x = f (g x)
+
 type configuration = {
   email : Emile.mailbox option;
   seed : string option;
   certificate_seed : string option;
   hostname : [ `host ] Domain_name.t;
 }
 
+let scheme = Mimic.make ~name:"paf-le-scheme"
+
+let port = Mimic.make ~name:"paf-le-port"
+
+let domain_name = Mimic.make ~name:"paf-le-domain-name"
+
+let ipaddr = Mimic.make ~name:"paf-le-ipaddr"
+
+let sleep = Mimic.make ~name:"paf-le-sleep"
+
+module Httpaf_Client_connection = struct
+  include Httpaf.Client_connection
+
+  let yield_reader _ = assert false
+
+  let next_read_operation t =
+    (next_read_operation t :> [ `Close | `Read | `Yield ])
+end
+
+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
+          (Rresult.(Domain_name.(of_string v >>= 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
+  Httpaf.Headers.add_unless_exists headers "host" hostname
+
+let with_transfer_encoding ~chunked (meth : [ `GET | `HEAD | `POST ]) body
+    headers =
+  match (meth, chunked, body, Httpaf.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. *)
+      Httpaf.Headers.add_unless_exists headers "transfer-encoding" "chunked"
+  | _, (None | Some false), `Empty, None ->
+      Httpaf.Headers.add_unless_exists headers "content-length" "0"
+  | _, (None | Some false), `String str, None ->
+      Httpaf.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
+      Httpaf.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 HTTP : Letsencrypt__HTTP_client.S with type ctx = Mimic.ctx (* FIXME *) =
+struct
+  type ctx = Mimic.ctx
+
+  module Headers = struct
+    include Httpaf.Headers
+
+    let init_with field value = of_list [ (field, value) ]
+
+    let get_location hdrs = Option.map Uri.of_string (get hdrs "location")
+  end
+
+  module Body = struct
+    type t =
+      [ `Stream of string Lwt_stream.t
+      | `Empty
+      | `String of string
+      | `Strings of string list ]
+
+    let of_string str = `String str
+
+    let to_string = function
+      | `Stream t ->
+          let open Lwt.Infix in
+          Lwt_stream.to_list t >|= String.concat ""
+      | `String str -> Lwt.return str
+      | `Empty -> Lwt.return ""
+      | `Strings sstr -> Lwt.return (String.concat "" sstr)
+  end
+
+  module Response = struct
+    include Httpaf.Response
+
+    let status resp = Httpaf.Status.to_code resp.Httpaf.Response.status
+
+    let headers resp = resp.Httpaf.Response.headers
+  end
+
+  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) ;
+      Httpaf.Body.schedule_read ~on_eof ~on_read body in
+    Httpaf.Body.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 ->
+        Httpaf.Body.write_string body str ;
+        unroll body stream
+    | None ->
+        Httpaf.Body.close_writer body ;
+        Lwt.return_unit
+
+  let transmit cohttp_body httpaf_body =
+    match cohttp_body with
+    | `Empty -> Httpaf.Body.close_writer httpaf_body
+    | `String str ->
+        Httpaf.Body.write_string httpaf_body str ;
+        Httpaf.Body.close_writer httpaf_body
+    | `Strings sstr ->
+        List.iter (Httpaf.Body.write_string httpaf_body) sstr ;
+        Httpaf.Body.close_writer httpaf_body
+    | `Stream stream -> Lwt.async @@ fun () -> unroll httpaf_body stream
+
+  exception Invalid_response_body_length of Httpaf.Response.t
+
+  exception Malformed_response of string
+
+  let call ?(ctx = Mimic.empty) ?(headers = Httpaf.Headers.empty)
+      ?(body = `Empty) ?chunked (meth : [ `GET | `HEAD | `POST ]) uri =
+    let ctx = with_uri uri ctx in
+    let sleep =
+      match Mimic.get sleep ctx with
+      | Some sleep -> sleep
+      | None -> fun _ -> Lwt.return_unit
+      (* TODO *) in
+    let headers = with_host headers uri in
+    let headers = with_transfer_encoding ~chunked meth body headers in
+    let req =
+      Httpaf.Request.create ~headers
+        (meth :> Httpaf.Method.t)
+        (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 =
+          Httpaf.Client_connection.request ~error_handler ~response_handler req
+        in
+        Lwt.async (fun () ->
+            Paf.run ~sleep (module Httpaf_Client_connection) conn flow) ;
+        transmit body httpaf_body ;
+        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 -> 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 post ?ctx ?body ?chunked ?headers uri =
+    call ?ctx ?body ?chunked ?headers `POST uri
+end
+
 module Make (Time : Mirage_time.S) (Stack : Mirage_stack.V4V6) = struct
   type nonrec configuration = configuration = {
     email : Emile.mailbox option;
@@ -15,7 +225,7 @@ module Make (Time : Mirage_time.S) (Stack : Mirage_stack.V4V6) = struct
     hostname : [ `host ] Domain_name.t;
   }
 
-  module Acme = Letsencrypt.Client.Make (Paf_cohttp)
+  module Acme = Letsencrypt.Client.Make (HTTP)
 
   module Log = (val let src = Logs.Src.create "letsencrypt" in
                     Logs.src_log src : Logs.LOG)
@@ -136,8 +346,6 @@ module Make (Time : Mirage_time.S) (Stack : Mirage_stack.V4V6) = struct
       | Ok flow -> client_of_flow ?host cfg flow
   end
 
-  include Paf_cohttp
-
   let ctx ~gethostbyname ~authenticator dns stackv4v6 =
     let tcp_edn, _tcp_protocol =
       Mimic.register ~name:"letsencrypt-tcp" (module TCP) in
@@ -178,4 +386,6 @@ module Make (Time : Mirage_time.S) (Stack : Mirage_stack.V4V6) = struct
            ]
          ~k:k1
     |> Mimic.fold ipaddr Fun.[ req domain_name ] ~k:k2
+
+  let with_uri = with_uri
 end

paf-cohttp.opam

@@ -0,0 +1,30 @@
+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"
+  "cohttp-lwt"
+  "domain-name"
+  "httpaf"
+  "ipaddr"
+  "alcotest-lwt"      {with-test}
+  "fmt"               {with-test}
+  "logs"              {with-test}
+  "mirage-crypto-rng" {with-test}
+  "mirage-time-unix"  {with-test}
+  "tcpip"             {with-test}
+  "uri"               {with-test}
+  "lwt"               {with-test}
+]
+build: ["dune" "build" "-p" name "-j" jobs]
+run-test: ["dune" "runtest" "-p" name "-j" jobs]
+dev-repo: "git+https://github.com/dinosaure/paf-le-chien.git"

test/dune

@@ -38,7 +38,7 @@
  (name test_cohttp)
  (modules test_cohttp)
  (libraries mirage-time-unix fmt.tty logs.fmt alcotest-lwt tcpip.stack-socket
-   cohttp-lwt paf.cohttp paf.mirage mirage-crypto-rng.unix))
+   cohttp-lwt paf-cohttp paf.mirage mirage-crypto-rng.unix))
 
 (rule
  (alias runtest)
@@ -58,6 +58,7 @@
 (rule
  (alias runtest)
  (locks m)
+ (package paf-cohttp)
  (deps server.pem server.key %{exe:test_cohttp.exe})
  (action
   (run ./test_cohttp.exe --color=always)))