Support proxying client requests through direct and tunneling HTTP/HTTPS proxies

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)
 

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"}

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 ())

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))

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}. *)

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 =

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

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

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;
 
@@ -293,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