feature: remove [scheme] from requests (#1086)

This makes it so that [Request.make ~uri |> Request.uri] will no longer
return the same URI as [uri]. Also, this property was never preserved
with respect to other URI fields.

Signed-off-by: Rudi Grinberg <[email protected]>

CHANGES.md

@@ -1,5 +1,8 @@
 ## Unreleased
 
+- http, cohttp: remove the scheme field from requests. This means that
+  [Request.uri] no longer returns the same URI as was to create the request
+  with [Request.make] (@rgrinberg 1086)
 - cohttp-eio: Remove unused `Client_intf` module (talex5 #1081)
 - cohttp-eio: Make server response type abstract and allow streaming in cohttp-eio (talex5 #1024)
 - cohttp-{lwt,eio}: server: add connection header to response if not present (ushitora-anqou #1025)

cohttp/src/request.ml

@@ -19,29 +19,24 @@ open Sexplib0.Sexp_conv
 type t = Http.Request.t = {
   headers : Header.t;
   meth : Code.meth;
-  scheme : string option;
   resource : string;
   version : Code.version;
 }
 [@@deriving sexp]
 
-let compare { headers; meth; scheme; resource; version } y =
+let compare { headers; meth; resource; version } y =
   match Header.compare headers y.headers with
   | 0 -> (
       match Code.compare_method meth y.meth with
       | 0 -> (
-          match Option.compare String.compare scheme y.scheme with
-          | 0 -> (
-              match String.compare resource y.resource with
-              | 0 -> Code.compare_version version y.version
-              | i -> i)
+          match String.compare resource y.resource with
+          | 0 -> Code.compare_version version y.version
           | i -> i)
       | i -> i)
   | i -> i
 
 let headers t = t.headers
 let meth t = t.meth
-let scheme t = t.scheme
 let resource t = t.resource
 let version t = t.version
 let encoding t = Header.get_transfer_encoding t.headers
@@ -71,14 +66,13 @@ let make ?(meth = `GET) ?(version = `HTTP_1_1) ?encoding
         Header.add_authorization headers auth
     | _, _, _ -> headers
   in
-  let scheme = Uri.scheme uri in
   let resource = Uri.path_and_query uri in
   let headers =
     match encoding with
     | None -> headers
     | Some encoding -> Header.add_transfer_encoding headers encoding
   in
-  { headers; meth; scheme; resource; version }
+  { headers; meth; resource; version }
 
 let is_keep_alive t = Http.Request.is_keep_alive t
 
@@ -110,49 +104,42 @@ let is_valid_uri path meth =
   | Some _ -> true
   | None -> not (String.length path > 0 && path.[0] <> '/')
 
-let uri { scheme; resource; headers; meth; _ } =
-  let uri =
-    match resource with
-    | "*" -> (
-        match Header.get headers "host" with
-        | None -> Uri.of_string ""
-        | Some host ->
-            let host_uri = Uri.of_string ("//" ^ host) in
-            Uri.(make ?host:(host host_uri) ?port:(port host_uri) ()))
-    | authority when meth = `CONNECT -> Uri.of_string ("//" ^ authority)
-    | path -> (
-        let uri = Uri.of_string path in
-        match Uri.scheme uri with
-        | Some _ -> (
-            Uri.(
-              (* we have an absoluteURI *)
-              match path uri with "" -> with_path uri "/" | _ -> uri))
-        | None ->
-            let empty = Uri.of_string "" in
-            let empty_base = Uri.of_string "///" in
-            let pqs =
-              match Stringext.split ~max:2 path ~on:'?' with
-              | [] -> empty_base
-              | [ path ] ->
+let uri { resource; headers; meth; _ } =
+  match resource with
+  | "*" -> (
+      match Header.get headers "host" with
+      | None -> Uri.of_string ""
+      | Some host ->
+          let host_uri = Uri.of_string ("//" ^ host) in
+          Uri.(make ?host:(host host_uri) ?port:(port host_uri) ()))
+  | authority when meth = `CONNECT -> Uri.of_string ("//" ^ authority)
+  | path -> (
+      let uri = Uri.of_string path in
+      match Uri.scheme uri with
+      | Some _ -> (
+          Uri.(
+            (* we have an absoluteURI *)
+            match path uri with "" -> with_path uri "/" | _ -> uri))
+      | None -> (
+          let empty = Uri.of_string "" in
+          let empty_base = Uri.of_string "///" in
+          let pqs =
+            match Stringext.split ~max:2 path ~on:'?' with
+            | [] -> empty_base
+            | [ path ] ->
+                Uri.resolve "http" empty_base (Uri.with_path empty path)
+            | path :: qs :: _ ->
+                let path_base =
                   Uri.resolve "http" empty_base (Uri.with_path empty path)
-              | path :: qs :: _ ->
-                  let path_base =
-                    Uri.resolve "http" empty_base (Uri.with_path empty path)
-                  in
-                  Uri.with_query path_base (Uri.query_of_encoded qs)
-            in
-            let uri =
-              match Header.get headers "host" with
-              | None -> Uri.(with_scheme (with_host pqs None) None)
-              | Some host ->
-                  let host_uri = Uri.of_string ("//" ^ host) in
-                  let uri = Uri.with_host pqs (Uri.host host_uri) in
-                  Uri.with_port uri (Uri.port host_uri)
-            in
-            uri)
-  in
-  (* Only set the scheme if it's not already part of the URI *)
-  match Uri.scheme uri with Some _ -> uri | None -> Uri.with_scheme uri scheme
+                in
+                Uri.with_query path_base (Uri.query_of_encoded qs)
+          in
+          match Header.get headers "host" with
+          | None -> Uri.(with_scheme (with_host pqs None) None)
+          | Some host ->
+              let host_uri = Uri.of_string ("//" ^ host) in
+              let uri = Uri.with_host pqs (Uri.host host_uri) in
+              Uri.with_port uri (Uri.port host_uri)))
 
 type tt = t
 

cohttp/src/s.ml

@@ -85,15 +85,13 @@ module type Request = sig
   type t = {
     headers : Header.t;  (** HTTP request headers *)
     meth : Code.meth;  (** HTTP request method *)
-    scheme : string option;  (** URI scheme (http or https) *)
     resource : string;  (** Request path and query *)
     version : Code.version;  (** HTTP version, usually 1.1 *)
   }
   [@@deriving sexp]
 
   val headers : t -> Header.t
   val meth : t -> Code.meth
-  val scheme : t -> string option
   val resource : t -> string
   val version : t -> Code.version
   val encoding : t -> Transfer.encoding

cohttp/test/test_request.ml

@@ -249,8 +249,16 @@ let parse_request_uri_host_traversal _ =
   parse_request_uri_ r uri "parse_request_uri_host_traversal"
 
 let uri_round_trip _ =
-  let expected_uri = Uri.of_string "https://www.example.com/test" in
-  let actual_uri = Request.make expected_uri |> Request.uri in
+  let expected_uri =
+    let uri = Uri.of_string "https://www.example.com/test" in
+    Uri.with_userinfo uri (Some "foo")
+  in
+  let actual_uri =
+    let uri = Request.make expected_uri |> Request.uri in
+    (* These are the fields that aren't preserved: *)
+    let uri = Uri.with_scheme uri (Uri.scheme expected_uri) in
+    Uri.with_userinfo uri (Uri.userinfo expected_uri)
+  in
   Alcotest.check uri_testable "Request.make uri round-trip" actual_uri
     expected_uri
 

http/src/http.ml

@@ -739,27 +739,22 @@ module Request = struct
   type t = {
     headers : Header.t;  (** HTTP request headers *)
     meth : Method.t;  (** HTTP request method *)
-    scheme : string option;  (** URI scheme (http or https) *)
     resource : string;  (** Request path and query *)
     version : Version.t;  (** HTTP version, usually 1.1 *)
   }
 
   let headers t = t.headers
   let meth t = t.meth
-  let scheme t = t.scheme
   let resource t = t.resource
   let version t = t.version
 
-  let compare { headers; meth; scheme; resource; version } y =
+  let compare { headers; meth; resource; version } y =
     match Header.compare headers y.headers with
     | 0 -> (
         match Method.compare meth y.meth with
         | 0 -> (
-            match Option.compare String.compare scheme y.scheme with
-            | 0 -> (
-                match String.compare resource y.resource with
-                | 0 -> Version.compare version y.version
-                | i -> i)
+            match String.compare resource y.resource with
+            | 0 -> Version.compare version y.version
             | i -> i)
         | i -> i)
     | i -> i
@@ -786,8 +781,8 @@ module Request = struct
     else `No
 
   let make ?(meth = `GET) ?(version = `HTTP_1_1) ?(headers = Header.empty)
-      ?scheme resource =
-    { headers; meth; scheme; resource; version }
+      resource =
+    { headers; meth; resource; version }
 
   let pp fmt t =
     let open Format in
@@ -1133,7 +1128,7 @@ module Parser = struct
     let path = token source in
     let version = version source in
     let headers = headers source in
-    { Request.headers; meth; scheme = None; resource = path; version }
+    { Request.headers; meth; resource = path; version }
 
   type error = Partial | Msg of string
 

http/src/http.mli

@@ -385,15 +385,13 @@ module Request : sig
   type t = {
     headers : Header.t;  (** HTTP request headers *)
     meth : Method.t;  (** HTTP request method *)
-    scheme : string option;  (** URI scheme (http or https) *)
     resource : string;  (** Request path and query *)
     version : Version.t;  (** HTTP version, usually 1.1 *)
   }
 
   val has_body : t -> [ `No | `Unknown | `Yes ]
   val headers : t -> Header.t
   val meth : t -> Method.t
-  val scheme : t -> string option
   val resource : t -> string
   val version : t -> Version.t
   val compare : t -> t -> int
@@ -428,17 +426,11 @@ module Request : sig
       that a user-agent can handle HTTP chunked trailers headers. *)
 
   val make :
-    ?meth:Method.t ->
-    ?version:Version.t ->
-    ?headers:Header.t ->
-    ?scheme:string ->
-    string ->
-    t
+    ?meth:Method.t -> ?version:Version.t -> ?headers:Header.t -> string -> t
   (** [make resource] is a value of {!type:t}. The default values for the
       response, if not specified, are as follows: [meth] is [`GET], [version] is
-      [`HTTP_1_1], [headers] is [Header.empty] and [scheme] is [None]. The
-      request encoding value is determined via the
-      [Header.get_transfer_encoding] function.*)
+      [`HTTP_1_1], [headers] is [Header.empty]. The request encoding value is
+      determined via the [Header.get_transfer_encoding] function.*)
 
   val pp : Format.formatter -> t -> unit
 end

http/test/test_parser.ml

@@ -38,7 +38,7 @@ let assert_req_success ~here ~expected_req ~expected_consumed ?pos ?len buf =
   [%test_result: int] ~here ~expect:expected_consumed consumed
 
 let[@warning "-3"] make_req ~headers meth resource =
-  { Http.Request.headers; meth; resource; scheme = None; version = `HTTP_1_1 }
+  { Http.Request.headers; meth; resource; version = `HTTP_1_1 }
 
 let req_expected =
   make_req