From b6389b7e45da1c302d6dee2cf8493ed9362ee3c8 Mon Sep 17 00:00:00 2001 From: Gabriel Moise Date: Thu, 6 Jun 2024 13:56:25 +0100 Subject: [PATCH 1/4] Expose closefn function --- cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml | 3 +++ cohttp-lwt/src/client.ml | 10 +++++++--- cohttp-lwt/src/s.ml | 16 +++++++++++++++- 3 files changed, 25 insertions(+), 4 deletions(-) diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml index a638de23f9..07fbfa9a97 100644 --- a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml @@ -180,6 +180,9 @@ struct let callv ?ctx:_ _uri _reqs = Lwt.fail Cohttp_lwt_xhr_callv_not_implemented + let call_with_closefn ?ctx:_ ?headers:_ ?body:_ ?chunked:_ _meth _uri = + assert false + (* ??? *) end diff --git a/cohttp-lwt/src/client.ml b/cohttp-lwt/src/client.ml index 533da1df07..78a30642a7 100644 --- a/cohttp-lwt/src/client.ml +++ b/cohttp-lwt/src/client.ml @@ -46,8 +46,8 @@ module Make (IO : S.IO) (Net : S.Net with module IO = IO) = struct | `DELETE -> false | _ -> true - let call ?(ctx = Net.default_ctx) ?headers ?(body = `Empty) ?chunked meth uri - = + let call_with_closefn ?(ctx = Net.default_ctx) ?headers ?(body = `Empty) + ?chunked meth uri = let headers = match headers with None -> Header.init () | Some h -> h in Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) -> let closefn () = Net.close ic oc in @@ -88,7 +88,11 @@ module Make (IO : S.IO) (Net : S.Net with module IO = IO) = struct |> fun t -> Lwt.on_cancel t closefn; Lwt.on_failure t (fun _exn -> closefn ()); - t + Lwt.return (t, closefn) + + let call ?(ctx = Net.default_ctx) ?headers ?(body = `Empty) ?chunked meth uri + = + call_with_closefn ~ctx ?headers ~body ?chunked meth uri >>= fun (t, _) -> t (* The HEAD should not have a response body *) let head ?ctx ?headers uri = call ?ctx ?headers `HEAD uri >|= fst diff --git a/cohttp-lwt/src/s.ml b/cohttp-lwt/src/s.ml index fe5b33d2cb..2e70419499 100644 --- a/cohttp-lwt/src/s.ml +++ b/cohttp-lwt/src/s.ml @@ -74,7 +74,21 @@ module type Client = sig (using [ocaml-tls]) or SSL (using [ocaml-ssl]), on [*:443] or on the specified port by the user. If neitehr [ocaml-tls] or [ocaml-ssl] are installed on the system, [cohttp]/[conduit] tries the usual ([*:80]) or - the specified port by the user in a non-secured way. *) + the specified port by the user in a non-secured way. + + The function returns response and body. *) + + val call_with_closefn : + ?ctx:ctx -> + ?headers:Cohttp.Header.t -> + ?body:Body.t -> + ?chunked:bool -> + Cohttp.Code.meth -> + Uri.t -> + ((Cohttp.Response.t * Body.t) Lwt.t * (unit -> unit)) Lwt.t + (** [call_with_closefn ?ctx ?headers ?body ?chunked meth uri] is the same as + [call] but returns response, body and [close_fn] which force releases the + connection. *) val head : ?ctx:ctx -> ?headers:Cohttp.Header.t -> Uri.t -> Cohttp.Response.t Lwt.t From 84fbaff117864122f496aa6ba9dc90e8d9dc7384 Mon Sep 17 00:00:00 2001 From: Gabriel Moise Date: Fri, 4 Oct 2024 11:21:19 +0100 Subject: [PATCH 2/4] Fix CI --- cohttp-async/src/server.ml | 12 ++++++------ cohttp-async/test/test_async_integration.ml | 3 ++- cohttp-lwt-unix/bin/dune | 12 ++---------- examples/async/dune | 3 ++- examples/async/s3_cp.ml | 1 - 5 files changed, 12 insertions(+), 19 deletions(-) diff --git a/cohttp-async/src/server.ml b/cohttp-async/src/server.ml index d269641c95..c3c1fa209f 100644 --- a/cohttp-async/src/server.ml +++ b/cohttp-async/src/server.ml @@ -87,14 +87,14 @@ let handle_client handle_request sock rd wr = Body.drain body >>| fun () -> Ivar.fill_if_empty finished () | `Response (req, body, (res, res_body)) -> (* There are scenarios if a client leaves before consuming the full response, - we might have a reference to an async Pipe that doesn't get drained. + we might have a reference to an async Pipe that doesn't get drained. - Not draining or closing a pipe can lead to issues if its holding a resource like - a file handle as those resources will never be closed, leading to a leak. + Not draining or closing a pipe can lead to issues if its holding a resource like + a file handle as those resources will never be closed, leading to a leak. - Async writers have a promise that's fulfilled whenever they are closed, - so we can use it to schedule a close operation on the stream to ensure that we - don't leave a stream open if the underlying channels are closed. *) + Async writers have a promise that's fulfilled whenever they are closed, + so we can use it to schedule a close operation on the stream to ensure that we + don't leave a stream open if the underlying channels are closed. *) (match res_body with | `Empty | `String _ | `Strings _ -> () | `Pipe stream -> diff --git a/cohttp-async/test/test_async_integration.ml b/cohttp-async/test/test_async_integration.ml index 32a2a6aa79..767d925c64 100644 --- a/cohttp-async/test/test_async_integration.ml +++ b/cohttp-async/test/test_async_integration.ml @@ -111,7 +111,8 @@ let ts = ("Pipe with empty strings", Pipe.of_list [ ""; ""; "" ], true); ] in - Deferred.List.iter ~how:`Sequential tests ~f:(fun (msg, pipe, expected) -> + Deferred.List.iter ~how:`Sequential tests + ~f:(fun (msg, pipe, expected) -> is_empty (`Pipe pipe) >>| fun real -> assert_equal ~msg expected real) >>= fun () -> diff --git a/cohttp-lwt-unix/bin/dune b/cohttp-lwt-unix/bin/dune index b8ae61a03e..63e95e9032 100644 --- a/cohttp-lwt-unix/bin/dune +++ b/cohttp-lwt-unix/bin/dune @@ -1,14 +1,6 @@ (executables (names cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt) - (libraries - cohttp-lwt-unix - cohttp_server - logs - logs.lwt - logs.fmt - logs.cli - cmdliner - conduit-lwt - fmt.tty) + (libraries cohttp-lwt-unix cohttp_server logs logs.lwt logs.fmt logs.cli + cmdliner conduit-lwt fmt.tty) (package cohttp-lwt-unix) (public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt)) diff --git a/examples/async/dune b/examples/async/dune index 8d875ddcbd..109a31026d 100644 --- a/examples/async/dune +++ b/examples/async/dune @@ -1,6 +1,7 @@ (executables (names hello_world receive_post s3_cp) - (libraries mirage-crypto cohttp-async base async_kernel core_unix.command_unix)) + (libraries mirage-crypto cohttp-async base async_kernel + core_unix.command_unix)) (alias (name runtest) diff --git a/examples/async/s3_cp.ml b/examples/async/s3_cp.ml index 48a6f6482a..735dcafb44 100644 --- a/examples/async/s3_cp.ml +++ b/examples/async/s3_cp.ml @@ -44,7 +44,6 @@ open Core open Async open Cohttp open Cohttp_async - module Time = Time_float let ksrt (k, _) (k', _) = String.compare k k' From ea2403d6bcf0f64510fa8af5565c57fcadf788e3 Mon Sep 17 00:00:00 2001 From: Gabriel Moise Date: Fri, 4 Oct 2024 11:31:12 +0100 Subject: [PATCH 3/4] Add cstruct to dependencies in dune --- cohttp-mirage/src/dune | 2 +- examples/async/dune | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cohttp-mirage/src/dune b/cohttp-mirage/src/dune index cc00817565..03cabcd36a 100644 --- a/cohttp-mirage/src/dune +++ b/cohttp-mirage/src/dune @@ -5,4 +5,4 @@ (preprocess (pps ppx_sexp_conv)) (libraries conduit-mirage cohttp-lwt mirage-channel mirage-kv mirage-flow - magic-mime astring)) + magic-mime astring cstruct)) diff --git a/examples/async/dune b/examples/async/dune index 109a31026d..e495b7388e 100644 --- a/examples/async/dune +++ b/examples/async/dune @@ -1,7 +1,7 @@ (executables (names hello_world receive_post s3_cp) (libraries mirage-crypto cohttp-async base async_kernel - core_unix.command_unix)) + core_unix.command_unix cstruct)) (alias (name runtest) From 1ceb38f71decc4fa71d8e988d70f6752f21a571b Mon Sep 17 00:00:00 2001 From: Gabriel Moise Date: Fri, 11 Oct 2024 10:59:58 +0100 Subject: [PATCH 4/4] Fix mirage-crypto --- cohttp-async.opam | 2 +- cohttp-async/test/test_async_integration.ml | 4 ++-- examples/async/dune | 4 ++-- examples/async/s3_cp.ml | 17 +++++------------ 4 files changed, 10 insertions(+), 17 deletions(-) diff --git a/cohttp-async.opam b/cohttp-async.opam index 99e950b4ed..1f0d88e1a7 100644 --- a/cohttp-async.opam +++ b/cohttp-async.opam @@ -34,7 +34,7 @@ depends: [ "cohttp" {= version} "conduit-async" {>= "1.2.0"} "magic-mime" - "mirage-crypto" {with-test} + "digestif" {with-test} "logs" "fmt" {>= "0.8.2"} "sexplib0" diff --git a/cohttp-async/test/test_async_integration.ml b/cohttp-async/test/test_async_integration.ml index 767d925c64..8780017409 100644 --- a/cohttp-async/test/test_async_integration.ml +++ b/cohttp-async/test/test_async_integration.ml @@ -111,8 +111,8 @@ let ts = ("Pipe with empty strings", Pipe.of_list [ ""; ""; "" ], true); ] in - Deferred.List.iter ~how:`Sequential tests - ~f:(fun (msg, pipe, expected) -> + Deferred.List.iter ~how:`Sequential tests + ~f:(fun (msg, pipe, expected) -> is_empty (`Pipe pipe) >>| fun real -> assert_equal ~msg expected real) >>= fun () -> diff --git a/examples/async/dune b/examples/async/dune index e495b7388e..ff688d21f8 100644 --- a/examples/async/dune +++ b/examples/async/dune @@ -1,7 +1,7 @@ (executables (names hello_world receive_post s3_cp) - (libraries mirage-crypto cohttp-async base async_kernel - core_unix.command_unix cstruct)) + (libraries digestif.c cohttp-async base async_kernel core_unix.command_unix + cstruct)) (alias (name runtest) diff --git a/examples/async/s3_cp.ml b/examples/async/s3_cp.ml index 735dcafb44..755e1816fe 100644 --- a/examples/async/s3_cp.ml +++ b/examples/async/s3_cp.ml @@ -169,8 +169,7 @@ module Auth = struct let digest s = (* string -> sha256 as a hex string *) - Mirage_crypto.Hash.(digest `SHA256 (Cstruct.of_string s)) - |> Compat.cstruct_to_hex_string + Digestif.SHA256.(digest_string s |> to_hex) let make_amz_headers ?body time = (* Return x-amz-date and x-amz-sha256 headers *) @@ -238,16 +237,12 @@ module Auth = struct Printf.sprintf "AWS4-HMAC-SHA256\n%s\n%s\n%s" time_str scope_str hashed_req let make_signing_key ?date ~region ~service ~secret_access_key () = - let mac k v = - Mirage_crypto.Hash.(mac `SHA256 ~key:k (Cstruct.of_string v)) - in + let mac k v = Digestif.SHA256.(hmac_string ~key:k v |> to_raw_string) in let date' = match date with None -> Date.today ~zone:Time.Zone.utc | Some d -> d in let date_str = Date.to_string_iso8601_basic date' in - let date_key = - mac (Cstruct.of_string ("AWS4" ^ secret_access_key)) date_str - in + let date_key = mac ("AWS4" ^ secret_access_key) date_str in let date_region_key = mac date_key (string_of_region region) in let date_region_service_key = mac date_region_key (string_of_service service) @@ -277,14 +272,12 @@ module Auth = struct (string_of_service service) in let signature = - Mirage_crypto.Hash.( - mac `SHA256 ~key:signing_key (Cstruct.of_string string_to_sign)) + Digestif.SHA256.(hmac_string ~key:signing_key string_to_sign |> to_hex) in let auth_header = Printf.sprintf "AWS4-HMAC-SHA256 Credential=%s,SignedHeaders=%s,Signature=%s" creds - signed_headers - (Compat.cstruct_to_hex_string signature) + signed_headers signature in [ ("Authorization", auth_header) ] end