From 7965bb61f56e1320eb53dfdaac8ccdd3684fb118 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= <antonin@tarides.com>
Date: Tue, 9 Jul 2024 16:21:44 +0200
Subject: [PATCH 01/10] http: support absolute-form URI for requests to proxies
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

> When making a request to a proxy, other than a CONNECT or
> server-wide OPTIONS request (as detailed below), a client MUST send
> the target URI in "absolute-form" as the request-target.

https://www.rfc-editor.org/rfc/rfc9112#name-absolute-form

See https://www.rfc-editor.org/rfc/rfc3986#appendix-A for the ABNF of
absolute-URI.

Signed-off-by: Antonin Décimo <antonin@tarides.com>
---
 cohttp/src/request.ml | 14 +++++++++-----
 cohttp/src/s.ml       |  2 ++
 2 files changed, 11 insertions(+), 5 deletions(-)

diff --git a/cohttp/src/request.ml b/cohttp/src/request.ml
index 05ea64541..7226d2467 100644
--- a/cohttp/src/request.ml
+++ b/cohttp/src/request.ml
@@ -42,7 +42,7 @@ let version t = t.version
 let encoding t = Header.get_transfer_encoding t.headers
 
 let make ?(meth = `GET) ?(version = `HTTP_1_1) ?encoding
-    ?(headers = Header.init ()) uri =
+    ?(headers = Header.init ()) ?(absolute_form = false) uri =
   let headers =
     Header.add_unless_exists headers "host"
       (match Uri.scheme uri with
@@ -66,7 +66,9 @@ let make ?(meth = `GET) ?(version = `HTTP_1_1) ?encoding
         Header.add_authorization headers auth
     | _, _, _ -> headers
   in
-  let resource = Uri.path_and_query uri in
+  let resource =
+    if absolute_form then Uri.to_string uri else Uri.path_and_query uri
+  in
   let headers =
     match encoding with
     | None -> headers
@@ -80,7 +82,7 @@ let is_keep_alive t = Http.Request.is_keep_alive t
    adding content headers if appropriate.
    @param chunked Forces chunked encoding
 *)
-let make_for_client ?headers ?chunked ?body_length meth uri =
+let make_for_client ?headers ?chunked ?body_length ?absolute_form meth uri =
   let encoding =
     match (chunked, body_length) with
     | Some true, None -> Transfer.Chunked
@@ -89,7 +91,7 @@ let make_for_client ?headers ?chunked ?body_length meth uri =
     | Some true, Some _ ->
         invalid_arg "cannot set both ?chunked and ?body_length:"
   in
-  make ~meth ~encoding ?headers uri
+  make ~meth ~encoding ?headers ?absolute_form uri
 
 let pp_hum ppf r =
   Format.fprintf ppf "%s" (r |> sexp_of_t |> Sexplib0.Sexp.to_string_hum)
@@ -181,7 +183,9 @@ module Make (IO : S.IO) = struct
     let fst_line =
       Printf.sprintf "%s %s %s\r\n"
         (Http.Method.to_string req.meth)
-        (if req.resource = "" then "/" else req.resource)
+        (if req.meth = `CONNECT then Option.get (Header.get req.headers "host")
+         else if req.resource = "" then "/"
+         else req.resource)
         (Http.Version.to_string req.version)
     in
     IO.write oc fst_line >>= fun _ -> Header_IO.write req.headers oc
diff --git a/cohttp/src/s.ml b/cohttp/src/s.ml
index 915433ff9..8daf31664 100644
--- a/cohttp/src/s.ml
+++ b/cohttp/src/s.ml
@@ -102,6 +102,7 @@ module type Request = sig
     ?version:Code.version ->
     ?encoding:Transfer.encoding ->
     ?headers:Header.t ->
+    ?absolute_form:bool ->
     Uri.t ->
     t
   (** [make ()] is a value of {!type:t}. The default values for the request, if
@@ -119,6 +120,7 @@ module type Request = sig
     ?headers:Header.t ->
     ?chunked:bool ->
     ?body_length:int64 ->
+    ?absolute_form:bool ->
     Code.meth ->
     Uri.t ->
     t

From 7cbcdde724ec42bd910547e78b125b83cab273b6 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= <antonin@tarides.com>
Date: Wed, 10 Jul 2024 17:31:17 +0200
Subject: [PATCH 02/10] cohttp-lwt: allow connections to use absolute-form URI
 for proxies
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Signed-off-by: Antonin Décimo <antonin@tarides.com>
---
 cohttp-lwt-unix/test/test_client.ml | 11 ++++++++---
 cohttp-lwt/src/connection.ml        | 12 ++++++++----
 cohttp-lwt/src/connection_cache.ml  | 11 +++++++----
 cohttp-lwt/src/s.ml                 |  1 +
 4 files changed, 24 insertions(+), 11 deletions(-)

diff --git a/cohttp-lwt-unix/test/test_client.ml b/cohttp-lwt-unix/test/test_client.ml
index 8ab5c34bd..47d7f6e24 100644
--- a/cohttp-lwt-unix/test/test_client.ml
+++ b/cohttp-lwt-unix/test/test_client.ml
@@ -114,7 +114,10 @@ let test_client uri =
   assert_equal ~printer:Fun.id "Spring" body;
 
   (* simple request function accepting custom requests. *)
-  let handler ?headers ?body meth uri = Client.call ?headers ?body meth uri in
+  let handler ?headers ?body ?absolute_form meth uri =
+    ignore absolute_form;
+    Client.call ?headers ?body meth uri
+  in
   tests handler uri
 
 (* The Client.{call, get, put, ...} functions by default use a new
@@ -143,7 +146,8 @@ let test_non_persistent uri =
   (* the resolved endpoint may be buffered to avoid stressing the resolver: *)
   Connection.Net.resolve ~ctx:(Lazy.force Connection.Net.default_ctx) uri
   >>= fun endp ->
-  let handler ?headers ?body meth uri =
+  let handler ?headers ?body ?absolute_form meth uri =
+    ignore absolute_form;
     Connection.connect ~persistent:false endp >>= fun connection ->
     Connection.call connection ?headers ?body meth uri
   in
@@ -159,7 +163,8 @@ let test_unknown uri =
   Connection.connect ~persistent:false endp >>= fun c ->
   let connection = ref c in
   (* reference to open connection *)
-  let rec handler ?headers ?body meth uri =
+  let rec handler ?headers ?body ?absolute_form meth uri =
+    ignore absolute_form;
     Lwt.catch
       (fun () -> Connection.call !connection ?headers ?body meth uri)
       (function
diff --git a/cohttp-lwt/src/connection.ml b/cohttp-lwt/src/connection.ml
index 879ed0810..300c75b0e 100644
--- a/cohttp-lwt/src/connection.ml
+++ b/cohttp-lwt/src/connection.ml
@@ -33,6 +33,7 @@ module Make (Net : S.Net) : S.Connection with module Net = Net = struct
   (* enable warning when https://github.com/mirage/ocaml-conduit/pull/319 is released *)
 
   type req_resr = {
+    absolute_form : bool;
     uri : Uri.t;
     meth : Cohttp.Code.meth;
     headers : Header.t;
@@ -164,12 +165,15 @@ module Make (Net : S.Net) : S.Connection with module Net = Net = struct
             queue_fail connection connection.in_flight e;
             Lwt.return_unit)
 
-  let call connection ?headers ?(body = `Empty) meth uri =
+  let call connection ?headers ?(body = `Empty) ?(absolute_form = false) meth
+      uri =
     let headers = match headers with Some h -> h | None -> Header.init () in
     match connection.state with
     | Connecting _ | Full _ ->
         let res, res_r = Lwt.wait () in
-        Queue.push { uri; meth; headers; body; res_r } connection.waiting;
+        Queue.push
+          { absolute_form; uri; meth; headers; body; res_r }
+          connection.waiting;
         Lwt_condition.broadcast connection.condition ();
         res
     | Closing _ | Half _ | Closed | Failed _ -> raise Retry
@@ -193,7 +197,7 @@ module Make (Net : S.Net) : S.Connection with module Net = Net = struct
       *)
         Lwt.return_unit
     | Full (ic, oc) | Closing (ic, oc) ->
-        let ({ uri; meth; headers; body; res_r } as work) =
+        let ({ absolute_form; uri; meth; headers; body; res_r } as work) =
           Queue.take connection.waiting
         in
 
@@ -222,7 +226,7 @@ module Make (Net : S.Net) : S.Connection with module Net = Net = struct
           else headers
         in
 
-        let req = Request.make ~encoding ~meth ~headers uri in
+        let req = Request.make ~encoding ~meth ~headers ~absolute_form uri in
 
         Queue.push work connection.in_flight;
 
diff --git a/cohttp-lwt/src/connection_cache.ml b/cohttp-lwt/src/connection_cache.ml
index 0dd46432d..21315284f 100644
--- a/cohttp-lwt/src/connection_cache.ml
+++ b/cohttp-lwt/src/connection_cache.ml
@@ -18,12 +18,15 @@ end = struct
 
   let call = Fun.id
 
-  let create ?(ctx = Lazy.force Net.default_ctx) () ?headers ?body meth uri =
+  let create ?(ctx = Lazy.force Net.default_ctx) () ?headers ?body
+      ?absolute_form meth uri =
     Net.resolve ~ctx uri
     (* TODO: Support chunked encoding without ~persistent:true ? *)
     >>= Connection.connect ~ctx ~persistent:true
     >>= fun connection ->
-    let res = Connection.call connection ?headers ?body meth uri in
+    let res =
+      Connection.call connection ?headers ?body ?absolute_form meth uri
+    in
     (* this can be simplified when https://github.com/mirage/ocaml-conduit/pull/319 is released. *)
     Lwt.dont_wait
       (fun () ->
@@ -152,12 +155,12 @@ end = struct
               (fun _ -> get_connection self endp)
               (fun _ -> get_connection self endp))
 
-  let call self ?headers ?body meth uri =
+  let call self ?headers ?body ?absolute_form meth uri =
     Net.resolve ~ctx:self.ctx uri >>= fun endp ->
     let rec request retry =
       get_connection self endp >>= fun conn ->
       Lwt.catch
-        (fun () -> Connection.call conn ?headers ?body meth uri)
+        (fun () -> Connection.call conn ?headers ?body ?absolute_form meth uri)
         (function
           | Retry -> (
               match body with
diff --git a/cohttp-lwt/src/s.ml b/cohttp-lwt/src/s.ml
index 18d8f7cab..57eaa8bbf 100644
--- a/cohttp-lwt/src/s.ml
+++ b/cohttp-lwt/src/s.ml
@@ -76,6 +76,7 @@ end
 type call =
   ?headers:Http.Header.t ->
   ?body:Body.t ->
+  ?absolute_form:bool ->
   Http.Method.t ->
   Uri.t ->
   (Cohttp.Response.t * Body.t) Lwt.t

From db5b5dc049c14cfd0d47730ea12078f987a3efef Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= <antonin@tarides.com>
Date: Tue, 16 Jul 2024 12:40:53 +0200
Subject: [PATCH 03/10] cohttp-lwt: add a Connection_cache module interface
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Signed-off-by: Antonin Décimo <antonin@tarides.com>
---
 cohttp-lwt/src/connection_cache.ml  | 44 ++---------------------------
 cohttp-lwt/src/connection_cache.mli | 43 ++++++++++++++++++++++++++++
 2 files changed, 45 insertions(+), 42 deletions(-)
 create mode 100644 cohttp-lwt/src/connection_cache.mli

diff --git a/cohttp-lwt/src/connection_cache.ml b/cohttp-lwt/src/connection_cache.ml
index 21315284f..ecd7199a1 100644
--- a/cohttp-lwt/src/connection_cache.ml
+++ b/cohttp-lwt/src/connection_cache.ml
@@ -1,15 +1,6 @@
 exception Retry = Connection.Retry
 
-(** This functor establishes a new connection for each request. *)
-module Make_no_cache (Connection : S.Connection) : sig
-  include S.Connection_cache
-
-  val create : ?ctx:Connection.Net.ctx -> unit -> t
-  (** [create ?ctx ()] creates a connection for handling a single request. The
-      connection accepts only a single request and will automatically be closed
-      as soon as possible.
-      @param ctx See {!Connection.Net.ctx} *)
-end = struct
+module Make_no_cache (Connection : S.Connection) = struct
   module Net = Connection.Net
   module IO = Net.IO
   open IO
@@ -41,38 +32,7 @@ end = struct
     res
 end
 
-(** This functor keeps a cache of connections for reuse. Connections are reused
-    based on their remote {!type:Conduit.endp} (effectively IP / port). *)
-module Make (Connection : S.Connection) (Sleep : S.Sleep) : sig
-  include S.Connection_cache
-
-  val create :
-    ?ctx:Connection.Net.ctx ->
-    ?keep:int64 ->
-    ?retry:int ->
-    ?parallel:int ->
-    ?depth:int ->
-    unit ->
-    t
-  (** Create a new connection cache
-
-      @param ctx Conduit context to use. See {!type:Connection.Net.ctx}.
-      @param keep Number of nanoseconds to keep an idle connection around.
-      @param retry
-        Number of times a {e gracefully} failed request is automatically
-        retried. {e graceful} means failed with {!exception:Connection.Retry}.
-        Requests with a [`Stream] {!module:Body} cannot be retried
-        automatically. Such requests will fail with
-        {!exception:Connection.Retry} and a new {!module:Body} will need to be
-        provided to retry.
-      @param parallel
-        maximum number of connections to establish to a single endpoint. Beware:
-        A single hostname may resolve to multiple endpoints. In such a case
-        connections may be created in excess to what was intended.
-      @param depth
-        maximum number of requests to queue and / or send on a single
-        connection. *)
-end = struct
+module Make (Connection : S.Connection) (Sleep : S.Sleep) = struct
   module Net = Connection.Net
   module IO = Net.IO
   open IO
diff --git a/cohttp-lwt/src/connection_cache.mli b/cohttp-lwt/src/connection_cache.mli
new file mode 100644
index 000000000..c51b97f01
--- /dev/null
+++ b/cohttp-lwt/src/connection_cache.mli
@@ -0,0 +1,43 @@
+(** This functor establishes a new connection for each request. *)
+module Make_no_cache (Connection : S.Connection) : sig
+  include S.Connection_cache
+
+  val create : ?ctx:Connection.Net.ctx -> unit -> t
+  (** [create ?ctx ()] creates a connection for handling a single request. The
+      connection accepts only a single request and will automatically be closed
+      as soon as possible.
+      @param ctx See {!Connection.Net.ctx} *)
+end
+
+(** This functor keeps a cache of connections for reuse. Connections are reused
+    based on their remote {!type:Conduit.endp} (effectively IP / port). *)
+module Make (Connection : S.Connection) (Sleep : S.Sleep) : sig
+  include S.Connection_cache
+
+  val create :
+    ?ctx:Connection.Net.ctx ->
+    ?keep:int64 ->
+    ?retry:int ->
+    ?parallel:int ->
+    ?depth:int ->
+    unit ->
+    t
+  (** Create a new connection cache
+
+      @param ctx Conduit context to use. See {!type:Connection.Net.ctx}.
+      @param keep Number of nanoseconds to keep an idle connection around.
+      @param retry
+        Number of times a {e gracefully} failed request is automatically
+        retried. {e graceful} means failed with {!exception:Connection.Retry}.
+        Requests with a [`Stream] {!module:Body} cannot be retried
+        automatically. Such requests will fail with
+        {!exception:Connection.Retry} and a new {!module:Body} will need to be
+        provided to retry.
+      @param parallel
+        maximum number of connections to establish to a single endpoint. Beware:
+        A single hostname may resolve to multiple endpoints. In such a case
+        connections may be created in excess to what was intended.
+      @param depth
+        maximum number of requests to queue and / or send on a single
+        connection. *)
+end

From 05dced4b899e1152d5ce1ae0774e613ec3f47f09 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= <antonin@tarides.com>
Date: Tue, 16 Jul 2024 12:28:21 +0200
Subject: [PATCH 04/10] cohttp-lwt: support client using direct proxies
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Signed-off-by: Antonin Décimo <antonin@tarides.com>
---
 cohttp-lwt/src/connection_cache.ml  | 27 ++++++++++++++++++++++++---
 cohttp-lwt/src/connection_cache.mli |  4 +++-
 2 files changed, 27 insertions(+), 4 deletions(-)

diff --git a/cohttp-lwt/src/connection_cache.ml b/cohttp-lwt/src/connection_cache.ml
index ecd7199a1..936a07c9a 100644
--- a/cohttp-lwt/src/connection_cache.ml
+++ b/cohttp-lwt/src/connection_cache.ml
@@ -46,10 +46,11 @@ module Make (Connection : S.Connection) (Sleep : S.Sleep) = struct
     retry : int;
     parallel : int;
     depth : int;
+    proxy : Uri.t option;
   }
 
   let create ?(ctx = Lazy.force Net.default_ctx) ?(keep = 60_000_000_000L)
-      ?(retry = 2) ?(parallel = 4) ?(depth = 100) () =
+      ?(retry = 2) ?(parallel = 4) ?(depth = 100) ?proxy () =
     {
       cache = Hashtbl.create ~random:true 10;
       ctx;
@@ -57,6 +58,7 @@ module Make (Connection : S.Connection) (Sleep : S.Sleep) = struct
       retry;
       parallel;
       depth;
+      proxy;
     }
 
   let rec get_connection self endp =
@@ -115,12 +117,31 @@ module Make (Connection : S.Connection) (Sleep : S.Sleep) = struct
               (fun _ -> get_connection self endp)
               (fun _ -> get_connection self endp))
 
+  let prepare self ?headers ?absolute_form meth uri =
+    match self.proxy with
+    | None ->
+        let absolute_form = Option.value ~default:false absolute_form in
+        Net.resolve ~ctx:self.ctx uri >>= fun endp ->
+        Lwt.return (endp, absolute_form, headers)
+    | Some proxy_uri ->
+        let absolute_form =
+          Option.value
+            ~default:
+              (not
+                 (meth = `CONNECT
+                 || (meth = `OPTIONS && Uri.path_and_query uri = "*")))
+            absolute_form
+        in
+        Net.resolve ~ctx:self.ctx proxy_uri >>= fun endp ->
+        Lwt.return (endp, absolute_form, headers)
+
   let call self ?headers ?body ?absolute_form meth uri =
-    Net.resolve ~ctx:self.ctx uri >>= fun endp ->
+    prepare self ?headers ?absolute_form meth uri
+    >>= fun (endp, absolute_form, headers) ->
     let rec request retry =
       get_connection self endp >>= fun conn ->
       Lwt.catch
-        (fun () -> Connection.call conn ?headers ?body ?absolute_form meth uri)
+        (fun () -> Connection.call conn ?headers ?body ~absolute_form meth uri)
         (function
           | Retry -> (
               match body with
diff --git a/cohttp-lwt/src/connection_cache.mli b/cohttp-lwt/src/connection_cache.mli
index c51b97f01..8044606ef 100644
--- a/cohttp-lwt/src/connection_cache.mli
+++ b/cohttp-lwt/src/connection_cache.mli
@@ -20,6 +20,7 @@ module Make (Connection : S.Connection) (Sleep : S.Sleep) : sig
     ?retry:int ->
     ?parallel:int ->
     ?depth:int ->
+    ?proxy:Uri.t ->
     unit ->
     t
   (** Create a new connection cache
@@ -39,5 +40,6 @@ module Make (Connection : S.Connection) (Sleep : S.Sleep) : sig
         connections may be created in excess to what was intended.
       @param depth
         maximum number of requests to queue and / or send on a single
-        connection. *)
+        connection.
+      @param proxy A direct (non-tunneling) proxy to use. *)
 end

From d9116465afaad4ea1c3aee0376d0555f36c74d16 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= <antonin@tarides.com>
Date: Wed, 10 Jul 2024 17:16:55 +0200
Subject: [PATCH 05/10] cohttp-lwt: dispatch requests through direct and
 tunneling proxies
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

To ensure end-to-end security it's possible to use a tunneling
proxy. The proxy in the middle blindly forwards data.

This is needed if the remote server is available via HTTPS. First, a
CONNECT request is made to the proxy with the remote server as
target. If it succeeds, a new connection can be made to the remote
server, tunneled via the connection made to the proxy.

See also RFC 9110 § 9.3.6. CONNECT.
https://www.rfc-editor.org/rfc/rfc9110#name-connect

We consider that it's a sane default to always tunnel connections to
HTTPS remote server. We provide the Connection_proxy module that
automatically opens connections to a direct proxy or a tunneling
proxy, based on the remote sheme used.

We show how to respect curl's [scheme]_proxy, ALL_PROXY, and NO_PROXY
environment variables.
https://curl.se/libcurl/c/libcurl-env.html

Signed-off-by: Antonin Décimo <antonin@tarides.com>
---
 cohttp-lwt-unix/src/cohttp_lwt_unix.ml |   8 +
 cohttp-lwt-unix/src/net.ml             |  10 +-
 cohttp-lwt-unix/src/net.mli            |   1 +
 cohttp-lwt/src/connection.ml           |  28 +++
 cohttp-lwt/src/connection_cache.ml     | 310 ++++++++++++++++++++++++-
 cohttp-lwt/src/connection_cache.mli    |  49 ++++
 cohttp-lwt/src/dune                    |   2 +-
 cohttp-lwt/src/s.ml                    |   7 +
 cohttp-mirage/src/net.ml               |   3 +
 cohttp/src/dune                        |   3 +-
 cohttp/src/request.ml                  |  26 ++-
 11 files changed, 434 insertions(+), 13 deletions(-)

diff --git a/cohttp-lwt-unix/src/cohttp_lwt_unix.ml b/cohttp-lwt-unix/src/cohttp_lwt_unix.ml
index 120202039..db8239124 100644
--- a/cohttp-lwt-unix/src/cohttp_lwt_unix.ml
+++ b/cohttp-lwt-unix/src/cohttp_lwt_unix.ml
@@ -38,6 +38,14 @@ module Connection_cache =
       let sleep_ns ns = Lwt_unix.sleep (Int64.to_float ns /. 1_000_000_000.)
     end)
 
+module Connection_proxy =
+  Cohttp_lwt.Connection_cache.Make_proxy
+    (Connection)
+    (struct
+      (* : Mirage_time.S *)
+      let sleep_ns ns = Lwt_unix.sleep (Int64.to_float ns /. 1_000_000_000.)
+    end)
+
 module Client : sig
   (** The [Client] module implements the full UNIX HTTP client interface,
       including the UNIX-specific functions defined in {!C}. *)
diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml
index cd0edefab..6a49c8ed3 100644
--- a/cohttp-lwt-unix/src/net.ml
+++ b/cohttp-lwt-unix/src/net.ml
@@ -35,15 +35,21 @@ let default_ctx =
     }
 
 type endp = Conduit.endp
+type client = Conduit_lwt_unix.client
 
 let resolve ~ctx uri = Resolver_lwt.resolve_uri ~uri ctx.resolver
 
-let connect_endp ~ctx:{ ctx; _ } endp =
-  Conduit_lwt_unix.endp_to_client ~ctx endp >>= fun client ->
+let tunnel hostname (channels : IO.ic * IO.oc) : client =
+  `TLS_tunnel (`Hostname hostname, (fst channels).chan, snd channels)
+
+let connect_client ~ctx:{ ctx; _ } client =
   Conduit_lwt_unix.connect ~ctx client >|= fun (flow, ic, oc) ->
   let ic = Input_channel.create ic in
   (flow, ic, oc)
 
+let connect_endp ~ctx endp =
+  Conduit_lwt_unix.endp_to_client ~ctx:ctx.ctx endp >>= connect_client ~ctx
+
 let connect_uri ~ctx uri = resolve ~ctx uri >>= connect_endp ~ctx
 
 let close c =
diff --git a/cohttp-lwt-unix/src/net.mli b/cohttp-lwt-unix/src/net.mli
index c3f216b7e..42c09fd7e 100644
--- a/cohttp-lwt-unix/src/net.mli
+++ b/cohttp-lwt-unix/src/net.mli
@@ -24,6 +24,7 @@ include
     with module IO = Io
      and type ctx := ctx
      and type endp = Conduit.endp
+     and type client = Conduit_lwt_unix.client
 
 val init : ?ctx:Conduit_lwt_unix.ctx -> ?resolver:Resolver_lwt.t -> unit -> ctx
 (** [init ?ctx ?resolver ()] is a network context that is the same as the
diff --git a/cohttp-lwt/src/connection.ml b/cohttp-lwt/src/connection.ml
index 300c75b0e..0c454a724 100644
--- a/cohttp-lwt/src/connection.ml
+++ b/cohttp-lwt/src/connection.ml
@@ -297,6 +297,34 @@ module Make (Net : S.Net) : S.Connection with module Net = Net = struct
       on_failure;
     connection
 
+  let create_tunnel ?(finalise = fun _ -> Lwt.return_unit)
+      ?(ctx = Lazy.force Net.default_ctx) proxy remote_host =
+    match proxy.state with
+    | Full (ic, oc) ->
+        let client = Net.tunnel remote_host (ic, oc) in
+        let channels =
+          Net.connect_client ~ctx client >>= fun (_, ic, oc) -> return (ic, oc)
+        in
+        let connection =
+          {
+            finalise;
+            in_flight = Queue.create ();
+            waiting = Queue.create ();
+            state = Connecting channels;
+            condition = Lwt_condition.create ();
+            persistent = `True;
+          }
+        in
+        let on_failure e = connection.state <- Failed e in
+        Lwt.on_any channels
+          (fun channels ->
+            connection.state <- Full channels;
+            Lwt.dont_wait (fun () -> reader connection) on_failure;
+            Lwt.dont_wait (fun () -> writer connection) on_failure)
+          on_failure;
+        connection
+    | _ -> failwith "Proxy connection wasn't in right state."
+
   let connect ?finalise ?persistent ?ctx uri =
     let connection = create ?finalise ?persistent ?ctx uri in
     match connection.state with
diff --git a/cohttp-lwt/src/connection_cache.ml b/cohttp-lwt/src/connection_cache.ml
index 936a07c9a..695c52033 100644
--- a/cohttp-lwt/src/connection_cache.ml
+++ b/cohttp-lwt/src/connection_cache.ml
@@ -74,7 +74,8 @@ module Make (Connection : S.Connection) (Sleep : S.Sleep) = struct
       Lwt.return_unit
     in
     let create () =
-      let connection = Connection.create ~finalise ~ctx:self.ctx endp
+      let connection =
+        Connection.create ~persistent:true ~finalise ~ctx:self.ctx endp
       and timeout = ref Lwt.return_unit in
       let rec busy () =
         Lwt.cancel !timeout;
@@ -152,3 +153,310 @@ module Make (Connection : S.Connection) (Sleep : S.Sleep) = struct
     in
     request self.retry
 end
+
+module Make_tunnel (Connection : S.Connection) (Sleep : S.Sleep) : sig
+  include S.Connection_cache
+
+  val create :
+    ?ctx:Connection.Net.ctx ->
+    ?keep:int64 ->
+    ?retry:int ->
+    ?parallel:int ->
+    ?depth:int ->
+    ?proxy_headers:Http.Header.t ->
+    Uri.t ->
+    unit ->
+    t
+end = struct
+  module Net = Connection.Net
+  module IO = Net.IO
+  open IO
+
+  type ctx = Net.ctx
+  type tunnel = { proxy : Connection.t; remote : Connection.t }
+
+  type t = {
+    cache : (string, tunnel) Hashtbl.t; (* remote host * tunnel *)
+    proxy_uri : Uri.t;
+    mutable proxy_endp : Net.endp option;
+    proxy_headers : Http.Header.t;
+    ctx : ctx;
+    keep : int64;
+    retry : int;
+    parallel : int;
+    depth : int;
+  }
+
+  let proxy_default_scheme uri =
+    match Uri.scheme uri with
+    | None -> Uri.with_scheme uri (Some "http")
+    | _ -> uri
+
+  let create ?(ctx = Lazy.force Net.default_ctx) ?(keep = 60_000_000_000L)
+      ?(retry = 2) ?(parallel = 4) ?(depth = 100)
+      ?(proxy_headers = Http.Header.init ()) proxy_uri () =
+    if Uri.host proxy_uri = None then
+      Printf.ksprintf invalid_arg "No host was provided in URI %s."
+        (Uri.to_string proxy_uri);
+    {
+      cache = Hashtbl.create ~random:true 10;
+      proxy_uri = proxy_default_scheme proxy_uri;
+      proxy_endp = None;
+      proxy_headers;
+      ctx;
+      keep;
+      retry;
+      parallel;
+      depth;
+    }
+
+  let rec request conn ?headers ?body ?absolute_form meth uri retry =
+    Lwt.catch
+      (fun () -> Connection.call conn ?headers ?body ?absolute_form meth uri)
+      (function
+        | Retry -> (
+            match body with
+            | Some (`Stream _) -> Lwt.fail Retry
+            | None | Some `Empty | Some (`String _) | Some (`Strings _) ->
+                if retry <= 0 then Lwt.fail Retry
+                else
+                  request conn ?headers ?body ?absolute_form meth uri (retry - 1)
+            )
+        | e -> Lwt.fail e)
+
+  let rec get_connection self ~proxy_endp ~remote ~remote_host ~remote_uri =
+    let finalise connection =
+      let rec remove keep =
+        let current = Hashtbl.find self.cache remote in
+        Hashtbl.remove self.cache remote;
+        if current.proxy == connection || current.remote == connection then
+          List.iter (Hashtbl.add self.cache remote) keep
+        else remove (current :: keep)
+      in
+      remove [];
+      Lwt.return_unit
+    in
+    let create () =
+      let proxy =
+        Connection.create ~persistent:true ~finalise ~ctx:self.ctx proxy_endp
+      in
+      request proxy ~headers:self.proxy_headers `CONNECT remote_uri self.retry
+      >>= fun (resp, _body) ->
+      let code = resp |> Http.Response.status |> Cohttp.Code.code_of_status in
+      if not (Cohttp.Code.is_success code) then
+        Printf.ksprintf failwith "Could not setup tunnel. Response code: %d\n"
+          code;
+      let remote =
+        Connection.create_tunnel ~finalise ~ctx:self.ctx proxy remote_host
+      and timeout = ref Lwt.return_unit in
+      let rec busy () =
+        Lwt.cancel !timeout;
+        if Connection.length remote = 0 then (
+          timeout :=
+            Sleep.sleep_ns self.keep >>= fun () ->
+            Connection.close remote;
+            Connection.close proxy;
+            (* failure is ignored *)
+            Lwt.return_unit);
+        Lwt.on_termination (Connection.notify remote) busy
+      in
+      busy ();
+      Lwt.return { proxy; remote }
+    in
+    match Hashtbl.find_all self.cache remote with
+    | [] ->
+        create () >>= fun tunnel ->
+        Hashtbl.add self.cache remote tunnel;
+        Lwt.return tunnel
+    | tunnels -> (
+        let rec search length = function
+          | [ a ] -> (a, length + 1)
+          | a :: b :: tl
+            when Connection.length a.remote < Connection.length b.remote ->
+              search (length + 1) (a :: tl)
+          | _ :: tl -> search (length + 1) tl
+          | [] -> assert false
+        in
+        match search 0 tunnels with
+        | shallowest, _ when Connection.length shallowest.remote = 0 ->
+            Lwt.return shallowest
+        | _, length when length < self.parallel ->
+            create () >>= fun tunnel ->
+            Hashtbl.add self.cache remote tunnel;
+            Lwt.return tunnel
+        | shallowest, _ when Connection.length shallowest.remote < self.depth ->
+            Lwt.return shallowest
+        | _ ->
+            Lwt.try_bind
+              (fun () ->
+                Lwt.choose
+                  (List.map
+                     (fun { remote; _ } -> Connection.notify remote)
+                     tunnels))
+              (fun _ ->
+                get_connection self ~proxy_endp ~remote ~remote_host ~remote_uri)
+              (fun _ ->
+                get_connection self ~proxy_endp ~remote ~remote_host ~remote_uri)
+        )
+
+  let call self ?headers ?body ?absolute_form meth uri =
+    (match self.proxy_endp with
+    | None ->
+        Net.resolve ~ctx:self.ctx self.proxy_uri >>= fun proxy_endp ->
+        self.proxy_endp <- Some proxy_endp;
+        Lwt.return proxy_endp
+    | Some proxy_endp -> Lwt.return proxy_endp)
+    >>= fun proxy_endp ->
+    let remote_port =
+      match Uri_services.tcp_port_of_uri uri with
+      | Some p -> p
+      | None -> failwith "A port is required for the CONNECT method."
+    in
+    let remote_host = Option.get (Uri.host uri) in
+    let remote = remote_host ^ ":" ^ string_of_int remote_port
+    and remote_uri = Uri.with_port uri (Some remote_port) in
+    get_connection self ~proxy_endp ~remote ~remote_host ~remote_uri
+    >>= fun tunnel ->
+    request tunnel.remote ?headers ?body ?absolute_form meth uri self.retry
+end
+
+type no_proxy_pattern = Name of string | Ipaddr_prefix of Ipaddr.Prefix.t
+type no_proxy = Wildcard | Patterns of no_proxy_pattern list
+
+let trim_dots ~first_leading s =
+  let len = String.length s in
+  let i = ref 0 in
+  if first_leading && !i < len && String.unsafe_get s !i = '.' then incr i;
+  let j = ref (len - 1) in
+  while !j >= !i && String.unsafe_get s !j = '.' do
+    decr j
+  done;
+  if !j >= !i then String.sub s !i (!j - !i + 1) else ""
+
+let strncasecompare a b n =
+  let a = String.(sub a 0 (min (length a) n) |> lowercase_ascii)
+  and b = String.(sub b 0 (min (length b) n) |> lowercase_ascii) in
+  String.compare a b = 0
+
+let no_proxy_from_env no_proxy =
+  if no_proxy = "*" then Wildcard
+  else
+    let patterns =
+      no_proxy
+      |> String.split_on_char ','
+      |> List.filter_map (fun pattern ->
+             if pattern = "" then None else Some (String.trim pattern))
+      |> List.map (fun pattern ->
+             match Ipaddr.of_string pattern with
+             | Ok addr -> Ipaddr_prefix (Ipaddr.Prefix.of_addr addr)
+             | Error _ -> (
+                 match Ipaddr.Prefix.of_string pattern with
+                 | Ok prefix -> Ipaddr_prefix prefix
+                 | Error _ -> Name (trim_dots ~first_leading:true pattern)))
+    in
+    Patterns patterns
+
+let check_no_proxy_patterns host = function
+  | Wildcard -> true
+  | _ when String.length host = 0 -> true
+  | Patterns patterns -> (
+      match Ipaddr.of_string host with
+      | Ok hostip ->
+          List.exists
+            (function
+              | Name _ -> false
+              | Ipaddr_prefix network -> Ipaddr.Prefix.mem hostip network)
+            patterns
+      | Error _ ->
+          let name = trim_dots ~first_leading:false host in
+          List.exists
+            (function
+              | Ipaddr_prefix _ -> false
+              | Name pattern ->
+                  let patternlen = String.length pattern
+                  and namelen = String.length name in
+                  if patternlen = namelen then
+                    strncasecompare pattern name namelen
+                  else if patternlen < namelen then
+                    name.[namelen - patternlen - 1] = '.'
+                    && strncasecompare pattern
+                         (String.sub name (namelen - patternlen)
+                            (patternlen - namelen - patternlen))
+                         patternlen
+                  else false)
+            patterns)
+
+let tunnel_schemes = [ "https" ]
+
+module Make_proxy (Connection : S.Connection) (Sleep : S.Sleep) = struct
+  module Connection_cache = Make (Connection) (Sleep)
+  module Connection_tunnel = Make_tunnel (Connection) (Sleep)
+
+  type proxy = Direct of Connection_cache.t | Tunnel of Connection_tunnel.t
+
+  type t = {
+    proxies : (string * proxy) list;
+    direct : proxy option;
+    tunnel : proxy option;
+    no_proxy : Connection_cache.t;
+    no_proxy_patterns : no_proxy;
+  }
+
+  let create ?ctx ?keep ?retry ?parallel ?depth ?(scheme_proxy = []) ?all_proxy
+      ?no_proxy ?proxy_headers () =
+    let create_default () =
+      Connection_cache.create ?ctx ?keep ?retry ?parallel ?depth ()
+    and create_direct proxy =
+      Connection_cache.create ?ctx ?keep ?retry ?parallel ?depth ~proxy ()
+    and create_tunnel proxy_uri =
+      Connection_tunnel.create ?ctx ?keep ?retry ?parallel ?depth ?proxy_headers
+        proxy_uri ()
+    in
+    let no_proxy_patterns =
+      match no_proxy with
+      | None -> Patterns []
+      | Some no_proxy -> no_proxy_from_env no_proxy
+    in
+    let no_proxy = create_default () in
+    let proxies =
+      List.map
+        (fun (scheme, uri) ->
+          let proxy =
+            if List.mem scheme tunnel_schemes then Tunnel (create_tunnel uri)
+            else Direct (create_direct uri)
+          in
+          (scheme, proxy))
+        scheme_proxy
+    in
+    let direct, tunnel =
+      match all_proxy with
+      | Some uri ->
+          (Some (Direct (create_direct uri)), Some (Tunnel (create_tunnel uri)))
+      | None -> (None, None)
+    in
+    { no_proxy; direct; tunnel; proxies; no_proxy_patterns }
+
+  let call self ?headers ?body ?absolute_form meth uri =
+    let proxy =
+      if
+        check_no_proxy_patterns
+          (Uri.host_with_default ~default:"" uri)
+          self.no_proxy_patterns
+      then None
+        (* Connection_cache.call self.no_proxy ?headers ?body ?absolute_form meth uri *)
+      else
+        let scheme = Option.value ~default:"" (Uri.scheme uri) in
+        match List.assoc scheme self.proxies with
+        | proxy -> Some proxy
+        | exception Not_found ->
+            if List.mem scheme tunnel_schemes then self.tunnel else self.direct
+    in
+    match proxy with
+    | None ->
+        Connection_cache.call self.no_proxy ?headers ?body ?absolute_form meth
+          uri
+    | Some (Tunnel proxy) ->
+        Connection_tunnel.call proxy ?headers ?body ?absolute_form meth uri
+    | Some (Direct proxy) ->
+        Connection_cache.call proxy ?headers ?body ?absolute_form meth uri
+end
diff --git a/cohttp-lwt/src/connection_cache.mli b/cohttp-lwt/src/connection_cache.mli
index 8044606ef..1fc271d27 100644
--- a/cohttp-lwt/src/connection_cache.mli
+++ b/cohttp-lwt/src/connection_cache.mli
@@ -43,3 +43,52 @@ module Make (Connection : S.Connection) (Sleep : S.Sleep) : sig
         connection.
       @param proxy A direct (non-tunneling) proxy to use. *)
 end
+
+(** This functor keeps a cache of connections for reuse. Connections are reused
+    based on their remote {!type:Conduit.endp} (effectively IP / port). It also
+    supports automatically connecting and reconnecting to direct and tunneling
+    proxies, based on the remote URI scheme (HTTP will select direct proxies,
+    HTTPS tunneling proxies). *)
+module Make_proxy (Connection : S.Connection) (Sleep : S.Sleep) : sig
+  include S.Connection_cache
+
+  val create :
+    ?ctx:Connection.Net.ctx ->
+    ?keep:int64 ->
+    ?retry:int ->
+    ?parallel:int ->
+    ?depth:int ->
+    ?scheme_proxy:(string * Uri.t) list ->
+    ?all_proxy:Uri.t ->
+    ?no_proxy:string ->
+    ?proxy_headers:Http.Header.t ->
+    unit ->
+    t
+  (** Create a new connection cache. The outer connections to the proxy and the
+      inner connections share the same parameters.
+
+      @param ctx Conduit context to use. See {!type:Connection.Net.ctx}.
+      @param keep Number of nanoseconds to keep an idle connection around.
+      @param retry
+        Number of times a {e gracefully} failed request is automatically
+        retried. {e graceful} means failed with {!exception:Connection.Retry}.
+        Requests with a [`Stream] {!module:Body} cannot be retried
+        automatically. Such requests will fail with
+        {!exception:Connection.Retry} and a new {!module:Body} will need to be
+        provided to retry.
+      @param parallel
+        maximum number of connections to establish to a single endpoint. Beware:
+        A single hostname may resolve to multiple endpoints. In such a case
+        connections may be created in excess to what was intended.
+      @param depth
+        maximum number of requests to queue and / or send on a single
+        connection.
+      @param scheme_proxy The proxy URI associated to each (remote) scheme.
+      @param all_proxy
+        The default proxy to use. Proxy for specific schemes have precedence
+        over this.
+      @param no_proxy
+        Disable proxies for specific hosts, specified as curl's [NO_PROXY].
+      @see <https://everything.curl.dev/usingcurl/proxies/env.html#no-proxy>
+      @param proxy_headers Headers to pass to the proxy. *)
+end
diff --git a/cohttp-lwt/src/dune b/cohttp-lwt/src/dune
index 12c5df290..d2d062103 100644
--- a/cohttp-lwt/src/dune
+++ b/cohttp-lwt/src/dune
@@ -4,4 +4,4 @@
  (synopsis "Lwt backend")
  (preprocess
   (pps ppx_sexp_conv))
- (libraries lwt uri http_bytebuffer cohttp logs logs.lwt))
+ (libraries lwt uri uri.services http_bytebuffer cohttp logs logs.lwt ipaddr))
diff --git a/cohttp-lwt/src/s.ml b/cohttp-lwt/src/s.ml
index 57eaa8bbf..c9af878cd 100644
--- a/cohttp-lwt/src/s.ml
+++ b/cohttp-lwt/src/s.ml
@@ -20,6 +20,7 @@ end
 module type Net = sig
   module IO : IO
 
+  type client
   type endp
 
   type ctx [@@deriving sexp_of]
@@ -40,6 +41,8 @@ module type Net = sig
   (** [resolve ~ctx uri] resolves [uri] into an endpoint description. This is
       [Resolver_lwt.resolve_uri ~uri ctx.resolver]. *)
 
+  val tunnel : string -> IO.ic * IO.oc -> client
+
   val connect_uri : ctx:ctx -> Uri.t -> (IO.conn * IO.ic * IO.oc) IO.t
   (** [connect_uri ~ctx uri] starts a {i flow} on the given [uri]. The choice of
       the protocol (with or without encryption) is done by the {i scheme} of the
@@ -62,6 +65,7 @@ module type Net = sig
   (** [connect_endp ~ctx endp] starts a {i flow} to the given [endp]. [endp]
       describes address and protocol of the endpoint to connect to. *)
 
+  val connect_client : ctx:ctx -> client -> (IO.conn * IO.ic * IO.oc) IO.t
   val close_in : IO.ic -> unit
   val close_out : IO.oc -> unit
   val close : IO.ic -> IO.oc -> unit
@@ -139,6 +143,9 @@ module type Connection = sig
       @param ctx See [Net.ctx]
       @param endp The remote address, port and protocol to connect to. *)
 
+  val create_tunnel :
+    ?finalise:(t -> unit Net.IO.t) -> ?ctx:Net.ctx -> t -> string -> t
+
   val connect :
     ?finalise:(t -> unit Net.IO.t) ->
     ?persistent:bool ->
diff --git a/cohttp-mirage/src/net.ml b/cohttp-mirage/src/net.ml
index 72964fccb..00d2636f3 100644
--- a/cohttp-mirage/src/net.ml
+++ b/cohttp-mirage/src/net.ml
@@ -21,7 +21,10 @@ struct
     lazy { resolver = R.localhost; conduit = None; authenticator = None }
 
   type endp = Conduit.endp
+  type client
 
+  let tunnel = failwith "Unimplemented"
+  let connect_client = failwith "Unimplemented"
   let resolve ~ctx uri = R.resolve_uri ~uri ctx.resolver
 
   let connect_endp ~ctx endp =
diff --git a/cohttp/src/dune b/cohttp/src/dune
index bdc14c034..34636e5a1 100644
--- a/cohttp/src/dune
+++ b/cohttp/src/dune
@@ -17,7 +17,8 @@
   sexplib0
   stringext
   uri
-  uri-sexp))
+  uri-sexp
+  uri.services))
 
 (ocamllex accept_lexer)
 
diff --git a/cohttp/src/request.ml b/cohttp/src/request.ml
index 7226d2467..78746771b 100644
--- a/cohttp/src/request.ml
+++ b/cohttp/src/request.ml
@@ -43,15 +43,25 @@ let encoding t = Header.get_transfer_encoding t.headers
 
 let make ?(meth = `GET) ?(version = `HTTP_1_1) ?encoding
     ?(headers = Header.init ()) ?(absolute_form = false) uri =
-  let headers =
-    Header.add_unless_exists headers "host"
-      (match Uri.scheme uri with
-      | Some "httpunix" -> ""
-      | _ -> (
-          Uri.host_with_default ~default:"localhost" uri
-          ^
-          match Uri.port uri with Some p -> ":" ^ string_of_int p | None -> ""))
+  let port () =
+    match Uri.port uri with
+    | Some p -> ":" ^ string_of_int p
+    | None when meth = `CONNECT -> (
+        match Uri_services.tcp_port_of_uri uri with
+        | None -> failwith "A port is required for the CONNECT method."
+        | Some p -> ":" ^ string_of_int p)
+    | None -> ""
+  in
+  let host =
+    match Header.get headers "host" with
+    | None -> (
+        match Uri.scheme uri with
+        | Some "httpunix" -> ""
+        | _ -> Uri.host_with_default ~default:"localhost" uri ^ port ())
+    | Some host -> if String.contains host ':' then host else host ^ port ()
   in
+
+  let headers = Header.replace headers "host" host in
   let headers =
     Header.add_unless_exists headers "user-agent" Header.user_agent
   in

From 49280a2b84c13596ff4c3f8179810980de451a66 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= <antonin@tarides.com>
Date: Thu, 18 Jul 2024 17:16:55 +0200
Subject: [PATCH 06/10] cohttp-lwt-unix: example client supporting proxies
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Signed-off-by: Antonin Décimo <antonin@tarides.com>
---
 cohttp-lwt-unix/examples/client_lwt_proxy.ml | 145 +++++++++++++++++++
 cohttp-lwt-unix/examples/dune                |  11 +-
 2 files changed, 153 insertions(+), 3 deletions(-)
 create mode 100644 cohttp-lwt-unix/examples/client_lwt_proxy.ml

diff --git a/cohttp-lwt-unix/examples/client_lwt_proxy.ml b/cohttp-lwt-unix/examples/client_lwt_proxy.ml
new file mode 100644
index 000000000..0293003de
--- /dev/null
+++ b/cohttp-lwt-unix/examples/client_lwt_proxy.ml
@@ -0,0 +1,145 @@
+open Lwt
+open Cohttp
+open Cohttp_lwt_unix
+
+let () =
+  if not @@ Debug.debug_active () then (
+    Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ();
+    Logs.set_level ~all:true (Some Logs.Debug);
+    Logs.set_reporter Debug.default_reporter)
+
+let proxy_uri = ref None
+let uri = ref []
+let proxy_authorization = ref None
+let set_proxy_uri uri = proxy_uri := Some (Uri.of_string uri)
+
+let set_proxy_authorization auth =
+  proxy_authorization :=
+    Some (Cohttp.Auth.credential_of_string ("Basic " ^ Base64.encode_exn auth))
+
+let usage_msg =
+  {|Usage: test_client_proxy -proxy <uri> <resource>
+Examples:
+$ test_client_proxy -proxy http://localhost:8080 http://example.com
+$ test_client_proxy -proxy https://localhost:8080 https://example.com
+Options:|}
+
+let anon_fun args = uri := !uri @ [ args ]
+
+let speclist =
+  [
+    ("-proxy", Arg.String set_proxy_uri, "<uri>  Proxy uri");
+    ("-proxyauth", Arg.String set_proxy_authorization, " Proxy authorization");
+  ]
+
+(* Boilerplate code to handle redirects *)
+
+let rec http_get_and_follow ~max_redirects ?headers uri =
+  let open Lwt.Syntax in
+  let* ans = Cohttp_lwt_unix.Client.get ?headers uri in
+  follow_redirect ~max_redirects ?headers uri ans
+
+and follow_redirect ~max_redirects ?headers request_uri (response, body) =
+  let open Lwt.Syntax in
+  let status = Http.Response.status response in
+  (* The unconsumed body would otherwise leak memory *)
+  let* () =
+    if status <> `OK then Cohttp_lwt.Body.drain_body body else Lwt.return_unit
+  in
+  match status with
+  | `OK -> Lwt.return (response, body)
+  | `Permanent_redirect | `Moved_permanently ->
+      handle_redirect ~permanent:true ~max_redirects ?headers request_uri
+        response
+  | `Found | `Temporary_redirect ->
+      handle_redirect ~permanent:false ~max_redirects ?headers request_uri
+        response
+  | `Not_found | `Gone -> failwith "Not found"
+  | status ->
+      Printf.ksprintf failwith "Unhandled status: %s"
+        (Cohttp.Code.string_of_status status)
+
+and handle_redirect ~permanent ~max_redirects ?headers request_uri response =
+  if max_redirects <= 0 then failwith "Too many redirects"
+  else
+    let headers' = Http.Response.headers response in
+    let location = Http.Header.get headers' "location" in
+    match location with
+    | None -> failwith "Redirection without Location header"
+    | Some url ->
+        let open Lwt.Syntax in
+        let uri = Uri.of_string url in
+        let* () =
+          if permanent then
+            Logs_lwt.warn (fun m ->
+                m "Permanent redirection from %s to %s"
+                  (Uri.to_string request_uri)
+                  url)
+          else Lwt.return_unit
+        in
+        http_get_and_follow ?headers uri ~max_redirects:(max_redirects - 1)
+
+(* Interesting stuff *)
+
+let getenv_opt k =
+  match Sys.getenv_opt k with
+  | Some v -> Some (k, Uri.of_string v)
+  | None -> None
+
+let getenv_opt_case k =
+  match getenv_opt (String.lowercase_ascii k) with
+  | None -> getenv_opt (String.uppercase_ascii k)
+  | v -> v
+
+let main ~proxy ~uri ~credential () =
+  let all_proxy, no_proxy, scheme_proxy =
+    match proxy with
+    | None ->
+        ( Option.map Uri.of_string (Sys.getenv_opt "ALL_PROXY"),
+          Sys.getenv_opt "NO_PROXY",
+          [
+            getenv_opt_case "httpunix_proxy";
+            getenv_opt_case "https_proxy";
+            getenv_opt "http_proxy";
+          ]
+          |> List.filter_map (function
+               | Some (k, v) -> Some (String.(sub k 0 (rindex k '_')), v)
+               | n -> n) )
+    | v -> (v, None, [])
+  in
+
+  let proxy_headers =
+    Option.map
+      (fun credential ->
+        Http.Header.init_with "Proxy-Authorization"
+          (Cohttp.Auth.string_of_credential credential))
+      credential
+  in
+
+  let module Cache = Cohttp_lwt_unix.Connection_proxy in
+  let cache =
+    Cache.create ?all_proxy ~scheme_proxy ?no_proxy ?proxy_headers ()
+  in
+  Client.set_cache (Cache.call cache);
+
+  http_get_and_follow ~max_redirects:2 (Uri.of_string uri)
+  >>= fun (resp, body) ->
+  let code = resp |> Response.status |> Code.code_of_status in
+  Printf.printf "Response code: %d\n" code;
+  Printf.printf "Headers: %s\n" (resp |> Response.headers |> Header.to_string);
+  body |> Cohttp_lwt.Body.to_string >|= fun body ->
+  Printf.printf "Body of length: %d\n" (String.length body);
+  print_endline ("Received body\n" ^ body)
+
+(* Argument parsing *)
+
+let () =
+  Arg.parse speclist anon_fun usage_msg;
+  if List.length !uri <> 1 then (
+    prerr_endline "Expected a single resource uri.";
+    prerr_endline usage_msg;
+    exit 1);
+  let proxy = !proxy_uri
+  and uri = List.hd !uri
+  and credential = !proxy_authorization in
+  Lwt_main.run (main ~proxy ~uri ~credential ())
diff --git a/cohttp-lwt-unix/examples/dune b/cohttp-lwt-unix/examples/dune
index c323e76d5..b596cd6b3 100644
--- a/cohttp-lwt-unix/examples/dune
+++ b/cohttp-lwt-unix/examples/dune
@@ -1,8 +1,13 @@
 (executables
- (names client_lwt client_lwt_timeout docker_lwt server_lwt)
- (libraries cohttp-lwt-unix))
+ (names client_lwt client_lwt_timeout docker_lwt server_lwt client_lwt_proxy)
+ (libraries cohttp-lwt-unix fmt.tty))
 
 (alias
  (name runtest)
  (package cohttp-lwt-unix)
- (deps client_lwt.exe client_lwt_timeout.exe docker_lwt.exe server_lwt.exe))
+ (deps
+  client_lwt.exe
+  client_lwt_timeout.exe
+  docker_lwt.exe
+  server_lwt.exe
+  client_lwt_proxy.exe))

From e2723483130c4f628c10b88ca4235a4ebac5e823 Mon Sep 17 00:00:00 2001
From: ArthurW <arthur@tarides.com>
Date: Thu, 29 Aug 2024 14:44:25 +0200
Subject: [PATCH 07/10] update changelog

---
 CHANGES.md | 1 +
 1 file changed, 1 insertion(+)

diff --git a/CHANGES.md b/CHANGES.md
index b0baa2b89..5ad685a58 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -17,6 +17,7 @@
   `~chunked:true` and `~body_length`.
 - cohttp-lwt-unix: Don't blow up when certificates are not available and no-network requests are made. (akuhlens #1027)
   + Makes `cohttp-lwt.S.default_ctx` lazy. 
+- cohttp-lwt-unix: Add http/https proxy support for client requests (MisterDA #1080)
 
 ## v6.0.0~beta2 (2024-01-05)
 

From d133a858cb96c4deb07cce261c19874afc3fc31c Mon Sep 17 00:00:00 2001
From: ArthurW <arthur@tarides.com>
Date: Thu, 5 Dec 2024 13:02:16 +0100
Subject: [PATCH 08/10] unused functor param

---
 cohttp-lwt/src/connection_cache.mli | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/cohttp-lwt/src/connection_cache.mli b/cohttp-lwt/src/connection_cache.mli
index 1fc271d27..60708dfd6 100644
--- a/cohttp-lwt/src/connection_cache.mli
+++ b/cohttp-lwt/src/connection_cache.mli
@@ -43,6 +43,7 @@ module Make (Connection : S.Connection) (Sleep : S.Sleep) : sig
         connection.
       @param proxy A direct (non-tunneling) proxy to use. *)
 end
+[@@warning "-unused-functor-parameter"]
 
 (** This functor keeps a cache of connections for reuse. Connections are reused
     based on their remote {!type:Conduit.endp} (effectively IP / port). It also
@@ -92,3 +93,4 @@ module Make_proxy (Connection : S.Connection) (Sleep : S.Sleep) : sig
       @see <https://everything.curl.dev/usingcurl/proxies/env.html#no-proxy>
       @param proxy_headers Headers to pass to the proxy. *)
 end
+[@@warning "-unused-functor-parameter"]

From c877c41c975ba5cafc344765452a374af05edd8d Mon Sep 17 00:00:00 2001
From: ArthurW <arthur@tarides.com>
Date: Thu, 5 Dec 2024 13:21:20 +0100
Subject: [PATCH 09/10] fix opam dep

---
 cohttp-lwt-unix.opam | 4 ++--
 dune-project         | 4 ++--
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/cohttp-lwt-unix.opam b/cohttp-lwt-unix.opam
index ed7574317..c31bcc5f2 100644
--- a/cohttp-lwt-unix.opam
+++ b/cohttp-lwt-unix.opam
@@ -34,8 +34,8 @@ depends: [
   "cohttp-lwt" {= version}
   "cmdliner" {>= "1.1.0"}
   "lwt" {>= "3.0.0"}
-  "conduit-lwt" {>= "5.0.0"}
-  "conduit-lwt-unix" {>= "5.0.0"}
+  "conduit-lwt" {>= "7.1.0"}
+  "conduit-lwt-unix" {>= "7.1.0"}
   "fmt" {>= "0.8.2"}
   "base-unix"
   "ppx_sexp_conv" {>= "v0.13.0"}
diff --git a/dune-project b/dune-project
index 052162ce0..8fdc73942 100644
--- a/dune-project
+++ b/dune-project
@@ -103,9 +103,9 @@
   (lwt
    (>= 3.0.0))
   (conduit-lwt
-   (>= 5.0.0))
+   (>= 7.1.0))
   (conduit-lwt-unix
-   (>= 5.0.0))
+   (>= 7.1.0))
   (fmt
    (>= 0.8.2))
   base-unix

From 811f790d84c5b2d383fa574b103f09aed52a298b Mon Sep 17 00:00:00 2001
From: ArthurW <arthur@tarides.com>
Date: Thu, 5 Dec 2024 16:51:37 +0100
Subject: [PATCH 10/10] update nix

---
 flake.lock | 48 +++++++-----------------------------------------
 1 file changed, 7 insertions(+), 41 deletions(-)

diff --git a/flake.lock b/flake.lock
index 95e638b1d..c8fbb52e7 100644
--- a/flake.lock
+++ b/flake.lock
@@ -18,35 +18,16 @@
         "type": "github"
       }
     },
-    "flake-utils_2": {
-      "inputs": {
-        "systems": "systems_2"
-      },
-      "locked": {
-        "lastModified": 1710146030,
-        "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=",
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a",
-        "type": "github"
-      },
-      "original": {
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "type": "github"
-      }
-    },
     "nixpkgs": {
       "inputs": {
-        "flake-utils": "flake-utils_2",
         "nixpkgs": "nixpkgs_2"
       },
       "locked": {
-        "lastModified": 1725916231,
-        "narHash": "sha256-kaU41Z43Uv2As0Sor8FPACJfWjkbUsWnZMtbCgqicvU=",
+        "lastModified": 1733352979,
+        "narHash": "sha256-QQhZgADZ2IYXjl9BiCWajOB0KXKzhhS4zrlgu71tqBU=",
         "owner": "nix-ocaml",
         "repo": "nix-overlays",
-        "rev": "d63aa7b62251c70bbf0a28a67c30555077a2b758",
+        "rev": "2680def9838fc1bdc36540f3db2ad666e70fb016",
         "type": "github"
       },
       "original": {
@@ -57,17 +38,17 @@
     },
     "nixpkgs_2": {
       "locked": {
-        "lastModified": 1725857262,
-        "narHash": "sha256-m9n0PncgZepVgmjOO1rfVXMgUACDOwZbhjSRjJ/NUpM=",
+        "lastModified": 1733335574,
+        "narHash": "sha256-F2lOx7b5kTO088Eq2wnb8UZo+S/RGpegObyhf1dEhD0=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "5af6aefbcc55670e36663fd1f8a796e1e323001a",
+        "rev": "f1a18363305d2314cd9994d22fc13497916aced7",
         "type": "github"
       },
       "original": {
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "5af6aefbcc55670e36663fd1f8a796e1e323001a",
+        "rev": "f1a18363305d2314cd9994d22fc13497916aced7",
         "type": "github"
       }
     },
@@ -91,21 +72,6 @@
         "repo": "default",
         "type": "github"
       }
-    },
-    "systems_2": {
-      "locked": {
-        "lastModified": 1681028828,
-        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
-        "owner": "nix-systems",
-        "repo": "default",
-        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
-        "type": "github"
-      },
-      "original": {
-        "owner": "nix-systems",
-        "repo": "default",
-        "type": "github"
-      }
     }
   },
   "root": "root",