diff --git a/git-paf.opam b/git-paf.opam index 78677d301..2b11d6f43 100644 --- a/git-paf.opam +++ b/git-paf.opam @@ -13,8 +13,6 @@ depends: [ "mimic" {>= "0.0.3"} "paf" {>= "0.0.2"} "ca-certs-nss" - "cohttp" - "cohttp-lwt" "fmt" "ipaddr" "logs" @@ -26,6 +24,12 @@ depends: [ "rresult" "tls" {>= "0.13.0"} "uri" + "bigarray-compat" + "bigstringaf" + "domain-name" + "httpaf" + "mirage-flow" + "tls-mirage" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/git-paf/dune b/src/git-paf/dune index 4a6a04641..4aa584d67 100644 --- a/src/git-paf/dune +++ b/src/git-paf/dune @@ -1,16 +1,17 @@ (library (name git_paf) (public_name git-paf) - (optional) (libraries logs uri mirage-time mirage-clock mirage-stack + mirage-flow + domain-name + bigstringaf + bigarray-compat result - cohttp - cohttp-lwt lwt fmt git.nss.git @@ -19,5 +20,6 @@ ca-certs-nss ipaddr mimic - paf.mirage - paf.cohttp)) + paf + tls-mirage + httpaf)) diff --git a/src/git-paf/git_paf.ml b/src/git-paf/git_paf.ml index 1a3828ecb..fa6586723 100644 --- a/src/git-paf/git_paf.ml +++ b/src/git-paf/git_paf.ml @@ -4,6 +4,75 @@ let src = Logs.Src.create "git.paf" module Log = (val Logs.src_log src : Logs.LOG) +let scheme = Mimic.make ~name:"git-scheme" +let port = Mimic.make ~name:"git-port" +let domain_name = Mimic.make ~name:"git-domain-name" +let ipaddr = Mimic.make ~name:"git-ipaddr" +let sleep = Mimic.make ~name:"git-sleep" + +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 | `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, Some _, None -> + (* XXX(dinosaure): I'm not sure that the [Some _] was right. *) + Httpaf.Headers.add_unless_exists headers "transfer-encoding" "chunked" + | _, (None | Some false), None, None -> + Httpaf.Headers.add_unless_exists headers "content-length" "0" + | _, _, Some str, None -> + Httpaf.Headers.add_unless_exists headers "content-length" + (string_of_int (String.length str)) + type error = | let pp_error : error Fmt.t = fun _ppf -> function _ -> . @@ -13,10 +82,13 @@ let with_redirects ?(max = 10) ~f uri = let tbl = Hashtbl.create 0x10 in let rec go max uri = f uri >>= fun (resp, body) -> - let status_code = Cohttp.(Response.status resp |> Code.code_of_status) in - if Cohttp.Code.is_redirection status_code then ( + let status_code = Httpaf.Status.to_code resp.Httpaf.Response.status in + if status_code = 300 then ( Log.debug (fun m -> m "The request must be redirected."); - match Cohttp.(Response.headers resp |> Header.get_location) with + match + Option.map Uri.of_string + Httpaf.(Headers.get resp.Response.headers "location") + with | Some uri' when Hashtbl.mem tbl uri' || max = 0 -> Log.warn (fun m -> m @@ -27,7 +99,7 @@ let with_redirects ?(max = 10) ~f uri = | Some uri' -> Log.debug (fun m -> m "Redirection to %a." Uri.pp uri'); Hashtbl.add tbl uri' (); - Cohttp_lwt.Body.drain_body body >>= fun () -> go (pred max) uri' + (* Cohttp_lwt.Body.drain_body body >>= fun () -> *) go (pred max) uri' | None -> Log.debug (fun m -> m "The request did not give to us the location."); Lwt.return (resp, body)) @@ -35,40 +107,157 @@ let with_redirects ?(max = 10) ~f uri = in go max uri +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 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 body = function + | None -> Httpaf.Body.close_writer body + | Some str -> + Httpaf.Body.write_string body str; + Httpaf.Body.close_writer body + +exception Invalid_response_body_length of Httpaf.Response.t +exception Malformed_response of string + +let call ?(ctx = Mimic.empty) ?(headers = Httpaf.Headers.empty) ?body ?chunked + (meth : [ `GET | `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 httpaf_body 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)) + +let body_to_string stream = Lwt_stream.to_list stream >|= String.concat "" +let http_get ?ctx ?headers uri = call ?ctx ?headers `GET uri + +let http_post ?ctx ?body ?chunked ?headers uri = + call ?ctx ?body ?chunked ?headers `POST uri + let get ~ctx ?(headers = []) uri : (_, error) result Lwt.t = - let headers = Cohttp.Header.of_list headers in + let headers = Httpaf.Headers.of_list headers in let f uri = let edn = Smart_git.Endpoint.of_string (Uri.to_string uri) in let edn = Rresult.R.get_ok edn in let ctx = Smart_git.Endpoint.to_ctx edn ctx in - Paf_cohttp.get ~ctx ~headers uri + http_get ~ctx ~headers uri in with_redirects ~f uri >>= fun (_resp, body) -> - Cohttp_lwt.Body.to_string body >>= fun body -> Lwt.return_ok ((), body) + body_to_string body >>= fun body -> Lwt.return_ok ((), body) let post ~ctx ?(headers = []) uri body : (_, error) result Lwt.t = - let headers = Cohttp.Header.of_list headers in - let body = Cohttp_lwt.Body.of_string body in + let headers = Httpaf.Headers.of_list headers in let f uri = let edn = Smart_git.Endpoint.of_string (Uri.to_string uri) in let edn = Rresult.R.get_ok edn in let ctx = Smart_git.Endpoint.to_ctx edn ctx in - Paf_cohttp.post ~ctx ~headers ~chunked:false ~body uri + http_post ~ctx ~headers ~chunked:false ~body uri in with_redirects ~f uri >>= fun (_resp, body) -> - Cohttp_lwt.Body.to_string body >>= fun body -> Lwt.return_ok ((), body) + body_to_string body >>= fun body -> Lwt.return_ok ((), body) module Make (Time : Mirage_time.S) (Pclock : Mirage_clock.PCLOCK) - (Stack : Mirage_stack.V4V6) - (Paf : Paf_mirage.S with type stack = Stack.t) (TCP : sig + (Stack : Mirage_stack.V4V6) (TCP' : sig + val tcp_endpoint : (Stack.t * Ipaddr.t * int) Mimic.value val tcp_stack : Stack.t Mimic.value val tcp_ipaddr : Ipaddr.t Mimic.value end) = struct module Nss = Ca_certs_nss.Make (Pclock) + module TLS = struct + module Log = (val Logs.src_log src : Logs.LOG) + include Tls_mirage.Make (Stack.TCP) + + type endpoint = + [ `host ] Domain_name.t option + * Tls.Config.client + * Stack.t + * Ipaddr.t + * int + + let connect (domain_name, cfg, stack, ipaddr, port) = + let t = Stack.tcp stack in + Stack.TCP.create_connection t (ipaddr, port) >>= function + | Error err -> Lwt.return_error (`Read err) + | Ok flow -> + client_of_flow cfg + ?host:(Option.map Domain_name.to_string domain_name) + flow + end + + let tls_edn, _tls_protocol = + Mimic.register ~priority:10 ~name:"tls" (module TLS) + let authenticator = Rresult.R.failwith_error_msg (Nss.authenticator ()) let default_tls_cfg = Tls.Config.client ~authenticator () let tls = Mimic.make ~name:"git-paf-tls" @@ -87,21 +276,21 @@ struct | _ -> Lwt.return_none in Mimic.empty - |> Mimic.add Paf_cohttp.sleep Time.sleep_ns + |> Mimic.add sleep Time.sleep_ns |> Mimic.( - fold Paf.tcp_edn + fold TCP'.tcp_endpoint Fun. [ - req Smart_git.git_scheme; req TCP.tcp_stack; req TCP.tcp_ipaddr; - dft Smart_git.git_port 80; + req Smart_git.git_scheme; req TCP'.tcp_stack; + req TCP'.tcp_ipaddr; dft Smart_git.git_port 80; ] ~k:k0) |> Mimic.( - fold Paf.tls_edn + fold tls_edn Fun. [ req Smart_git.git_scheme; req Smart_git.git_host; - dft tls default_tls_cfg; req TCP.tcp_stack; req TCP.tcp_ipaddr; + dft tls default_tls_cfg; req TCP'.tcp_stack; req TCP'.tcp_ipaddr; dft Smart_git.git_port 443; ] ~k:k1) diff --git a/src/git-paf/git_paf.mli b/src/git-paf/git_paf.mli index 668c06b5d..90f622854 100644 --- a/src/git-paf/git_paf.mli +++ b/src/git-paf/git_paf.mli @@ -3,8 +3,7 @@ include Smart_git.HTTP module Make (Time : Mirage_time.S) (Pclock : Mirage_clock.PCLOCK) - (Stack : Mirage_stack.V4V6) - (Paf : Paf_mirage.S with type stack = Stack.t) (TCP : sig + (Stack : Mirage_stack.V4V6) (TCP : sig val tcp_endpoint : (Stack.t * Ipaddr.t * int) Mimic.value val tcp_stack : Stack.t Mimic.value val tcp_ipaddr : Ipaddr.t Mimic.value diff --git a/unikernel/empty-commit/config.ml b/unikernel/empty-commit/config.ml index f55241b18..1cc071385 100644 --- a/unikernel/empty-commit/config.ml +++ b/unikernel/empty-commit/config.ml @@ -155,31 +155,16 @@ let git_conf ?path () = let git_impl ?path hash = git_conf ?path () $ hash -type paf = Paf -let paf = typ Paf - -let paf_conf () = - let packages = [ package "paf" ~sublibs:[ "mirage" ] ] in - impl @@ object - inherit base_configurable - method ty = time @-> stackv4v6 @-> paf - method module_name = "Paf_mirage.Make" - method! packages = Key.pure packages - method name = "paf" - end - -let paf_impl time stackv4v6 = paf_conf () $ time $ stackv4v6 - let mimic_paf_conf () = let packages = [ package "git-paf" ] in impl @@ object inherit base_configurable - method ty = time @-> pclock @-> stackv4v6 @-> paf @-> mimic @-> mimic + method ty = time @-> pclock @-> stackv4v6 @-> mimic @-> mimic method module_name = "Git_paf.Make" method! packages = Key.pure packages method name = "paf_ctx" method! connect _ modname = function - | [ _; _; _; _; tcp_ctx; ] -> + | [ _; _; _; tcp_ctx; ] -> Fmt.str {ocaml|let paf_ctx00 = Mimic.merge %s %s.ctx in Lwt.return paf_ctx00|ocaml} @@ -187,12 +172,11 @@ let mimic_paf_conf () = | _ -> assert false end -let mimic_paf_impl time pclock stackv4v6 paf mimic_tcp = +let mimic_paf_impl time pclock stackv4v6 mimic_tcp = mimic_paf_conf () $ time $ pclock $ stackv4v6 - $ paf $ mimic_tcp (* User space *) @@ -221,11 +205,11 @@ let minigit = ~keys:[ Key.abstract remote; Key.abstract ssh_seed; Key.abstract ssh_auth; Key.abstract branch ] (git @-> mimic @-> job) -let mimic ~kind ~seed ~auth stackv4v6 random mclock pclock time paf = +let mimic ~kind ~seed ~auth stackv4v6 random mclock pclock time = let mtcp = mimic_tcp_impl stackv4v6 in let mdns = mimic_dns_impl random mclock time stackv4v6 mtcp in let mssh = mimic_ssh_impl ~kind ~seed ~auth stackv4v6 mtcp mclock in - let mpaf = mimic_paf_impl time pclock stackv4v6 paf mtcp in + let mpaf = mimic_paf_impl time pclock stackv4v6 mtcp in merge mpaf (merge mssh mdns) let stackv4v6 = generic_stackv4v6 default_network @@ -234,12 +218,10 @@ let pclock = default_posix_clock let time = default_time let random = default_random let git = git_impl sha1 -let paf = paf_impl time stackv4v6 let mimic = mimic ~kind:`Rsa ~seed:ssh_seed ~auth:ssh_auth -let mimic = mimic stackv4v6 random mclock pclock time paf +let mimic = mimic stackv4v6 random mclock pclock time let () = register "minigit" ~packages:[ package "ptime" - ; package "paf" ~sublibs:[ "cohttp" ] ; package "git-paf" ] [ minigit $ git $ mimic ] diff --git a/unikernel/simple-store/config.ml b/unikernel/simple-store/config.ml index dbed6ac12..47092396f 100644 --- a/unikernel/simple-store/config.ml +++ b/unikernel/simple-store/config.ml @@ -155,31 +155,16 @@ let git_conf ?path () = let git_impl ?path hash = git_conf ?path () $ hash -type paf = Paf -let paf = typ Paf - -let paf_conf () = - let packages = [ package "paf" ~sublibs:[ "mirage" ] ] in - impl @@ object - inherit base_configurable - method ty = time @-> stackv4v6 @-> paf - method module_name = "Paf_mirage.Make" - method! packages = Key.pure packages - method name = "paf" - end - -let paf_impl time stackv4v6 = paf_conf () $ time $ stackv4v6 - let mimic_paf_conf () = let packages = [ package "git-paf" ] in impl @@ object inherit base_configurable - method ty = time @-> pclock @-> stackv4v6 @-> paf @-> mimic @-> mimic + method ty = time @-> pclock @-> stackv4v6 @-> mimic @-> mimic method module_name = "Git_paf.Make" method! packages = Key.pure packages method name = "paf_ctx" method! connect _ modname = function - | [ _; _; _; _; tcp_ctx; ] -> + | [ _; _; _; tcp_ctx; ] -> Fmt.str {ocaml|let paf_ctx00 = Mimic.merge %s %s.ctx in Lwt.return paf_ctx00|ocaml} @@ -187,12 +172,11 @@ let mimic_paf_conf () = | _ -> assert false end -let mimic_paf_impl time pclock stackv4v6 paf mimic_tcp = +let mimic_paf_impl time pclock stackv4v6 mimic_tcp = mimic_paf_conf () $ time $ pclock $ stackv4v6 - $ paf $ mimic_tcp (* User space *) @@ -229,11 +213,11 @@ let minigit = ; Key.abstract port ] (console @-> stackv4v6 @-> git @-> mimic @-> job) -let mimic ~kind ~seed ~auth stackv4v6 random mclock pclock time paf = +let mimic ~kind ~seed ~auth stackv4v6 random mclock pclock time = let mtcp = mimic_tcp_impl stackv4v6 in let mdns = mimic_dns_impl random mclock time stackv4v6 mtcp in let mssh = mimic_ssh_impl ~kind ~seed ~auth stackv4v6 mtcp mclock in - let mpaf = mimic_paf_impl time pclock stackv4v6 paf mtcp in + let mpaf = mimic_paf_impl time pclock stackv4v6 mtcp in merge mpaf (merge mssh mdns) let console = default_console @@ -243,13 +227,11 @@ let pclock = default_posix_clock let time = default_time let random = default_random let git = git_impl sha1 -let paf = paf_impl time stackv4v6 let mimic = mimic ~kind:`Rsa ~seed:ssh_seed ~auth:ssh_auth -let mimic = mimic stackv4v6 random mclock pclock time paf +let mimic = mimic stackv4v6 random mclock pclock time let () = register "minigit" ~packages:[ package "ptime" - ; package "paf" ~sublibs:[ "cohttp" ] ; package "hxd" ~sublibs:[ "core"; "string" ] ; package "git-paf" ] [ minigit $ console $ stackv4v6 $ git $ mimic ]