cohttp-eio(client): Ensure "Host" header is the first header in requests

.github/workflows/workflow.yml

@@ -66,7 +66,7 @@ jobs:
           - ubuntu-latest
           - macos-latest
         ocaml-compiler:
-          - ocaml-variants.5.0.0+trunk
+          - ocaml-variants.5.0.0~beta1+options
         local-packages:
           - |
             http.opam

CHANGES.md

@@ -1,4 +1,5 @@
 ## Unreleased
+- cohttp-eio: ensure "Host" header is the first header in http client requests (bikallem #939)
 - cohttp-eio: add TE header in client. Check TE header is server (bikallem #941)
 - cohttp-eio: add User-Agent header to request from Client (bikallem #940)
 - cohttp-eio: add Content-Length header to request/response (bikallem #929)

Makefile

@@ -26,4 +26,4 @@ eio-test:
 	dune runtest cohttp-eio
 
 eio-shell: # nix-shell for eio dev
-	nix-shell -p gmp libev nmap 
+	nix-shell -p gmp libev nmap curl

cohttp-eio.opam

@@ -21,7 +21,7 @@ bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
 depends: [
   "dune" {>= "2.9"}
   "base-domains"
-  "eio" {>= "0.4"}
+  "eio" {>= "0.6"}
   "eio_main" {with-test}
   "mdx" {with-test}
   "uri" {with-test}

cohttp-eio/src/client.ml

@@ -32,6 +32,8 @@ let write_request request writer body =
       (Http.Request.headers request)
       body
   in
+  let headers = Http.Header.clean_dup headers in
+  let headers = Http.Header.Private.move_to_front headers "Host" in
   let meth = Http.Method.to_string @@ Http.Request.meth request in
   let version = Http.Version.to_string @@ Http.Request.version request in
   Buf_write.string writer meth;

cohttp-eio/tests/test_client.t

@@ -8,9 +8,8 @@ Test Client.get
   resource: /get
   version: HTTP/1.1
   headers: Header {
-   Accept = "application/json"; Host = "localhost:8082";
-   User-Agent = "cohttp-eio"; TE = "trailers"; Connection = "TE" }
-
+   Accept = "application/json"; User-Agent = "cohttp-eio"; TE = "trailers";
+   Connection = "TE"; Host = "localhost:8082" }
   $ kill ${running_pid}
 
 Test Client.post
@@ -23,11 +22,11 @@ Test Client.post
   resource: /post
   version: HTTP/1.1
   headers: Header {
-   Accept = "application/json"; Content-Length = "12"; Host = "localhost:8082";
-   User-Agent = "cohttp-eio"; TE = "trailers"; Connection = "TE" }
+   Accept = "application/json"; Content-Length = "12";
+   User-Agent = "cohttp-eio"; TE = "trailers"; Connection = "TE";
+   Host = "localhost:8082" }
 
   hello world!
-
   $ kill ${running_pid}
 
 
@@ -41,8 +40,8 @@ Test posting "chunked" data
   version: HTTP/1.1
   headers: Header {
    Content-Length = "23"; Header1 = "Header1 value text";
-   Content-Type = "text/plain"; Host = "localhost:8082";
-   User-Agent = "cohttp-eio"; TE = "trailers"; Connection = "TE" }
+   Content-Type = "text/plain"; User-Agent = "cohttp-eio"; TE = "trailers";
+   Connection = "TE"; Host = "localhost:8082" }
 
   size: 7
    data: Mozilla

dune-project

@@ -339,7 +339,7 @@ should also be fine under Windows too.
   "A CoHTTP server and client implementation based on `eio` library. `cohttp-eio`features a multicore capable HTTP 1.1 server. The library promotes and is built with direct style of coding as opposed to a monadic.")
  (depends
   base-domains
-  (eio (>= 0.4))
+  (eio (>= 0.6))
   (eio_main :with-test)
   (mdx :with-test)
   (uri :with-test)

http/src/http.ml

@@ -14,56 +14,51 @@ module Transfer = struct
 end
 
 module Header = struct
-  module Private = struct
-    external string_unsafe_get64 : string -> int -> int64
-      = "%caml_string_get64u"
+  external string_unsafe_get64 : string -> int -> int64 = "%caml_string_get64u"
 
-    (* [caseless_equal a b] must be equivalent to
-       [String.equal (String.lowercase_ascii a) (String.lowercase_ascii b)]. *)
-    let caseless_equal a b =
-      if a == b then true
-      else
-        let len = String.length a in
-        len = String.length b
-        (* Note: at this point we konw that [a] and [b] have the same length. *)
-        &&
-        (* [word_loop a b i len] compares strings [a] and [b] from
-           offsets [i] (included) to [len] (excluded), one word at a time.
-           [i] is a world-aligned index into the strings.
-        *)
-        let rec word_loop a b i len =
-          if i = len then true
+  (* [caseless_equal a b] must be equivalent to
+     [String.equal (String.lowercase_ascii a) (String.lowercase_ascii b)]. *)
+  let caseless_equal a b =
+    if a == b then true
+    else
+      let len = String.length a in
+      len = String.length b
+      (* Note: at this point we konw that [a] and [b] have the same length. *)
+      &&
+      (* [word_loop a b i len] compares strings [a] and [b] from
+         offsets [i] (included) to [len] (excluded), one word at a time.
+         [i] is a world-aligned index into the strings.
+      *)
+      let rec word_loop a b i len =
+        if i = len then true
+        else
+          let i' = i + 8 in
+          (* If [i' > len], what remains to be compared is strictly
+             less than a word long, use byte-per-byte comparison. *)
+          if i' > len then byte_loop a b i len
+          else if string_unsafe_get64 a i = string_unsafe_get64 b i then
+            word_loop a b i' len
           else
-            let i' = i + 8 in
-            (* If [i' > len], what remains to be compared is strictly
-               less than a word long, use byte-per-byte comparison. *)
-            if i' > len then byte_loop a b i len
-            else if string_unsafe_get64 a i = string_unsafe_get64 b i then
-              word_loop a b i' len
-            else
-              (* If the words at [i] differ, it may due to a case
-                 difference; we check the individual bytes of this
-                 work, and then we continue checking the other
-                 words. *)
-              byte_loop a b i i' && word_loop a b i' len
-        (* [byte_loop a b i len] compares the strings [a] and [b] from
-           offsets [i] (included) to [len] (excluded), one byte at
-           a time.
-
-           This function assumes that [i < len] holds -- its only called
-           by [word_loop] when this is known to hold. *)
-        and byte_loop a b i len =
-          let c1 = String.unsafe_get a i in
-          let c2 = String.unsafe_get b i in
-          Char.lowercase_ascii c1 = Char.lowercase_ascii c2
-          &&
-          let i' = i + 1 in
-          i' = len || byte_loop a b i' len
-        in
-        word_loop a b 0 len
-  end
-
-  let caseless_equal = Private.caseless_equal
+            (* If the words at [i] differ, it may due to a case
+               difference; we check the individual bytes of this
+               work, and then we continue checking the other
+               words. *)
+            byte_loop a b i i' && word_loop a b i' len
+      (* [byte_loop a b i len] compares the strings [a] and [b] from
+         offsets [i] (included) to [len] (excluded), one byte at
+         a time.
+
+         This function assumes that [i < len] holds -- its only called
+         by [word_loop] when this is known to hold. *)
+      and byte_loop a b i len =
+        let c1 = String.unsafe_get a i in
+        let c2 = String.unsafe_get b i in
+        Char.lowercase_ascii c1 = Char.lowercase_ascii c2
+        &&
+        let i' = i + 1 in
+        i' = len || byte_loop a b i' len
+      in
+      word_loop a b 0 len
 
   type t = (string * string) list
 
@@ -108,6 +103,8 @@ module Header = struct
     in
     loop h
 
+  let first t = match t with [] -> None | (k, v) :: _ -> Some (k, v)
+
   let get_multi (h : t) (k : string) =
     let rec loop h acc =
       match h with
@@ -164,6 +161,16 @@ module Header = struct
         let h = remove h k in
         add_multi h k xs
 
+  let move_to_front t hdr_name =
+    match t with
+    | (k, _) :: _ when caseless_equal k hdr_name -> t
+    | _ -> (
+        match get t hdr_name with
+        | Some v ->
+            let headers = remove t hdr_name in
+            add headers hdr_name v
+        | None -> t)
+
   let map (f : string -> string -> string) (h : t) : t =
     List.map
       (fun (k, v) ->
@@ -339,6 +346,12 @@ module Header = struct
     | Some v when v = "close" -> Some `Close
     | Some x -> Some (`Unknown x)
     | _ -> None
+
+  module Private = struct
+    let caseless_equal = caseless_equal
+    let first = first
+    let move_to_front = move_to_front
+  end
 end
 
 module Status = struct

http/src/http.mli

@@ -202,8 +202,8 @@ module Header : sig
       name [k] and value [v]. *)
 
   val add : t -> string -> string -> t
-  (** [add h k v] adds the header name [k] and it associated value [v] at the
-      end of header list [h]. *)
+  (** [add h k v] adds the header name [k] and its associated value [v] at the
+      front of header list [h]. *)
 
   val add_list : t -> (string * string) list -> t
   (** [add_list h l] adds in order all header pairs contained in [l] to the
@@ -366,6 +366,15 @@ module Header : sig
     val caseless_equal : string -> string -> bool
     (** [caseless_equal a b] must be equivalent to
         [String.equal (String.lowercase_ascii a) (String.lowercase_ascii b)]. *)
+
+    val first : t -> (string * string) option
+    (** [first t] is [Some (hdr_name, hdr_value)], which represents the first
+        header in headers list [t]. It is [None] if [t] is empty. *)
+
+    val move_to_front : t -> string -> t
+    (** [move_to_front t hdr_name] is [t] with header name [hdr_name] moved to
+        the front of the headers list [t]. If the header doesn't exist in [t] or
+        the header is already at the front, then [t] is unchanged. *)
   end
 end
 

http/test/test_header.ml

@@ -167,6 +167,24 @@ let replace_tests () =
     ]
     H.(to_list (replace prebuilt "accept" "text/*"))
 
+let move_to_front_tests () =
+  let headers1 = [ ("accept", "text/*"); ("Host", "www.example.com") ] in
+  let headers2 =
+    [
+      ("content-length", "23"); ("Host", "www.example.com"); ("accept", "text/*");
+    ]
+  in
+  aeso {|move_to_front h "Host"|} (Some "Host")
+    (H.(Private.move_to_front (H.of_list headers1) "Host" |> Private.first)
+     |> function
+     | Some (k, _) -> Some k
+     | None -> Some "");
+  aeso {|move_to_front h "Host"|} (Some "Host")
+    (H.(Private.move_to_front (H.of_list headers2) "Host" |> Private.first)
+     |> function
+     | Some (k, _) -> Some k
+     | None -> Some "")
+
 let h =
   H.init () |> fun h ->
   H.add h "first" "1" |> fun h ->
@@ -380,6 +398,7 @@ let tests =
       ("Header.iter", `Quick, iter_tests);
       ("Header.update", `Quick, update_tests);
       ("Header.update_all", `Quick, update_all_tests);
+      ("Header.move_to_front", `Quick, move_to_front_tests);
       ("many headers", `Slow, many_headers);
       ("transfer encoding is in correct order", `Quick, transfer_encoding_tests);
     ]