diff --git a/.ocamlformat b/.ocamlformat index ae37eff..2abd4d9 100644 --- a/.ocamlformat +++ b/.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 diff --git a/lib/dune b/lib/dune index 74df529..9e147d1 100644 --- a/lib/dune +++ b/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)) diff --git a/lib/lE.ml b/lib/lE.ml index 50e75ee..ac9b799 100644 --- a/lib/lE.ml +++ b/lib/lE.ml @@ -1,5 +1,7 @@ (* (c) Hannes Menhert *) +let ( <.> ) f g x = f (g x) + type configuration = { email : Emile.mailbox option; seed : string option; @@ -7,6 +9,214 @@ type configuration = { 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 diff --git a/paf-cohttp.opam b/paf-cohttp.opam new file mode 100644 index 0000000..a6da84b --- /dev/null +++ b/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 " +authors: "Romain Calascibetta " +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" diff --git a/test/dune b/test/dune index 7badee9..8f15866 100644 --- a/test/dune +++ b/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)))