fix: don't send invalid HTTP/2 headers (#197)

also:
- refactor: don't send redundant arguments

lib/client.ml

@@ -35,7 +35,6 @@ module Connection_info = Connection.Info
 
 type t =
   { mutable conn : Connection.t
-  ; config : Config.t
   ; env : Eio_unix.Stdenv.base
   ; sw : Switch.t
   }
@@ -160,20 +159,18 @@ let shutdown_conn (Connection.Conn { impl; connection; info; fd; _ }) =
   Http_impl.shutdown (module (val impl)) ~fd connection
 
 let change_connection t (conn_info : Connection_info.t) =
-  let { sw; conn; env; _ } = t in
+  let { sw; conn = Connection.Conn { config; _ } as conn; env; _ } = t in
   Fiber.fork ~sw (fun () -> shutdown_conn conn);
-  let+! conn' =
-    open_connection ~sw ~config:t.config ~uri:conn_info.uri env conn_info
-  in
+  let+! conn' = open_connection ~sw ~config ~uri:conn_info.uri env conn_info in
   t.conn <- conn'
 
 let shutdown t = shutdown_conn t.conn
 
 (* returns true if it succeeding in reusing the connection, false otherwise. *)
 let reuse_or_set_up_new_connection
     ({ conn =
-         Connection.Conn ({ impl = (module Http); connection; info; _ } as conn)
-     ; config
+         Connection.Conn
+           ({ impl = (module Http); connection; config; info; _ } as conn)
      ; env
      ; _
      } as t)
@@ -247,7 +244,7 @@ type request_info =
   }
 
 let rec return_response
-    ({ conn; config; sw; _ } as t)
+    ({ conn; sw; _ } as t)
     ({ request; _ } as request_info)
     ({ Response.status; headers; version; body } as response)
   =
@@ -257,6 +254,7 @@ let rec return_response
         ; info = { Connection_info.scheme; _ } as conn_info
         ; uri
         ; fd
+        ; config
         ; _
         })
     =
@@ -313,7 +311,7 @@ let is_h2c_upgrade ~config ~version ~scheme =
   | _ -> false
 
 let make_request_info
-    { conn = Connection.Conn { version; info; _ }; config; _ }
+    { conn = Connection.Conn { version; info; config; _ }; _ }
     ?(remaining_redirects = config.max_redirects)
     ~meth
     ~headers
@@ -355,12 +353,11 @@ let make_request_info
 
 let rec send_request_and_handle_response
     t
-    ~body
     ({ remaining_redirects; request; headers; meth; _ } as request_info)
   =
-  let { conn = Conn ({ info; uri; _ } as conn); config; _ } = t in
+  let { conn = Conn ({ info; uri; config; _ } as conn); _ } = t in
 
-  match Http_impl.send_request ~sw:t.sw t.conn ~config ~body request with
+  match Http_impl.send_request ~sw:t.sw t.conn request with
   | Error (#Error.client as err) -> Error err
   | Ok response ->
     if conn.persistent
@@ -427,40 +424,42 @@ let rec send_request_and_handle_response
             ~remaining_redirects:(remaining_redirects - 1)
             ~meth:meth'
             ~headers
-            ~body
+            ~body:request.body
             target
         in
-        send_request_and_handle_response t ~body request_info')
+        send_request_and_handle_response t request_info')
     (* Either not a redirect, or we shouldn't follow redirects. *)
     | false, _, _, _ | _, false, _, _ | true, true, _, None ->
       return_response t request_info response)
 
 let create ?(config = Config.default) ~sw env uri =
   let*! conn_info = Connection_info.of_uri env ~config uri in
   match open_connection ~config ~sw ~uri:conn_info.uri env conn_info with
-  | Ok conn -> Ok { conn; config; env; sw }
+  | Ok conn -> Ok { conn; env; sw }
   | Error (#Error.client as err) -> Error err
 
 let call t ~meth ?(headers = []) ?(body = Body.empty) target =
   (* Need to try to reconnect to the base host on every call, if redirects are
    * enabled, because the connection manager could have tried to follow a
    * temporary redirect. We remember permanent redirects. *)
-  let (Connection.Conn { impl = (module Http); connection; uri; _ }) = t.conn in
+  let (Connection.Conn { impl = (module Http); connection; config; uri; _ }) =
+    t.conn
+  in
   let reused =
-    if t.config.follow_redirects || Http_impl.is_closed (module Http) connection
+    if config.follow_redirects || Http_impl.is_closed (module Http) connection
     then reuse_or_set_up_new_connection t uri
     else Ok true
   in
   match reused with
   | Error #Error.client as err -> err
   | Ok _ ->
     let request_info =
-      let headers = t.config.default_headers @ headers in
+      let headers = config.default_headers @ headers in
       make_request_info t ~meth ~headers ~body target
     in
     let (Connection.Conn conn) = t.conn in
     conn.persistent <- Request.persistent_connection request_info.request;
-    send_request_and_handle_response t ~body request_info
+    send_request_and_handle_response t request_info
 
 let request t ?headers ?body ~meth target = call t ?headers ?body ~meth target
 
@@ -523,12 +522,10 @@ module Oneshot = struct
       create ~config ~sw env uri
     in
     let target = Uri.path_and_query conn.uri in
-    let headers = t.config.default_headers @ headers in
+    let headers = conn.config.default_headers @ headers in
     let request_info = make_request_info t ~meth ~headers ~body target in
     conn.persistent <- Request.persistent_connection request_info.request;
-    let response_result =
-      send_request_and_handle_response t ~body request_info
-    in
+    let response_result = send_request_and_handle_response t request_info in
     Fiber.fork ~sw (fun () ->
       (match response_result with
       | Ok { Response.body; _ } ->

lib/connection.ml

@@ -209,6 +209,7 @@ type t =
   | Conn :
       { impl : (module Http_intf.HTTPCommon with type Client.t = 'a)
       ; connection : 'a
+      ; config : Config.t
       ; fd : Eio_unix.Net.stream_socket_ty Eio.Net.stream_socket
       ; mutable info : Info.t
       ; mutable uri : Uri.t

lib/headers.ml

@@ -54,18 +54,28 @@ module Well_known = struct
   end
 end
 
-let add_length_related_headers ~body_length headers =
+let add_length_related_headers ~version ~body_length headers =
   (* TODO: check `Httpaf.Response.body_length` because we may have to issue a
    * 0-length response body. *)
   (* Don't step over an explicit `content-length` header. *)
   match body_length with
   | `Fixed n ->
     add_unless_exists headers Well_known.content_length (Int64.to_string n)
   | `Chunked ->
-    add_unless_exists
-      headers
-      Well_known.transfer_encoding
-      Well_known.Values.chunked
+    (* From RFC9113§8.2.2:
+     *   An endpoint MUST NOT generate an HTTP/2 message containing
+     *   connection-specific header fields. This includes the Connection header
+     *   field and those listed as having connection-specific semantics in
+     *   Section 7.6.1 of [HTTP] (that is, Proxy-Connection, Keep-Alive,
+     *   Transfer-Encoding, and Upgrade).
+     *)
+    (match version with
+    | Versions.HTTP.HTTP_2 -> headers
+    | HTTP_1_0 | HTTP_1_1 ->
+      add_unless_exists
+        headers
+        Well_known.transfer_encoding
+        Well_known.Values.chunked)
   | `Close_delimited ->
     add_unless_exists headers Well_known.connection Well_known.Values.close
   | `Error _ | `Unknown -> headers
@@ -83,7 +93,7 @@ let canonicalize_headers ~body_length ~host ~version headers =
     | HTTP_1_0 | HTTP_1_1 ->
       add_unless_exists (of_list headers) Well_known.HTTP1.host host
   in
-  add_length_related_headers ~body_length headers
+  add_length_related_headers ~version ~body_length headers
 
 let host t ~version =
   match version with

lib/http1.ml

@@ -165,6 +165,13 @@ module MakeHTTP1 (Runtime_scheme : Scheme.Runtime.SCHEME) :
         (module HttpServer)
         ~fd
         ~scheme:Runtime_scheme.scheme
+        ~version:
+          (Option.value
+             ~default:HTTP_1_1
+             (Option.map
+                (fun (request : Httpaf.Request.t) ->
+                   Versions.HTTP.Raw.to_version_exn request.version)
+                request))
         ~error_handler
         ~start_response
         client_addr
@@ -194,7 +201,7 @@ module MakeHTTP1 (Runtime_scheme : Scheme.Runtime.SCHEME) :
         { Server_intf.Handler.ctx =
             { Request_info.client_address = client_addr
             ; scheme = Runtime_scheme.scheme
-            ; version = HTTP_1_1
+            ; version = Versions.HTTP.Raw.to_version_exn request.version
             ; sw
             }
         ; request = request_of_http1 ~body:request_body request

lib/http2.ml

@@ -171,6 +171,7 @@ end = struct
       ?request:(Option.map Request.of_h2 request)
       (module HttpServer)
       ~scheme:Runtime_scheme.scheme
+      ~version:HTTP_2
       ~fd
       ~error_handler
       ~start_response

lib/http_impl.ml

@@ -65,6 +65,7 @@ let create_connection
     in
     Connection.Conn
       { impl = (module Http_impl)
+      ; config
       ; connection
       ; fd
       ; info = conn_info
@@ -112,8 +113,8 @@ let handle_response :
     Fiber.fork ~sw (fun () ->
       match
         Fiber.any
-          [ (fun () -> Error (Promise.await response_error_p :> Error.t))
-          ; (fun () -> Error (Promise.await connection_error_p :> Error.t))
+          [ (ptoerr response_error_p :> unit -> (_, Error.t) result)
+          ; (ptoerr connection_error_p :> unit -> (_, Error.t) result)
           ; (fun () -> Body.closed response.body)
           ]
       with
@@ -128,14 +129,18 @@ let handle_response :
 let send_request :
      sw:Switch.t
     -> Connection.t
-    -> config:Config.t
-    -> body:Body.t
     -> Request.t
     -> (Response.t, Error.client) result
   =
- fun ~sw conn ~config ~body request ->
+ fun ~sw conn request ->
   let (Connection.Conn
-        { impl = (module Http); connection; fd; connection_error_received; _ })
+        { impl = (module Http)
+        ; connection
+        ; config
+        ; fd
+        ; connection_error_received
+        ; _
+        })
     =
     conn
   in
@@ -152,7 +157,7 @@ let send_request :
         Promise.resolve notify_response response
       in
       let flush_headers_immediately =
-        match body.contents with
+        match request.body.contents with
         | `Sendfile _ -> true
         | _ -> config.flush_headers_immediately
       in
@@ -163,7 +168,7 @@ let send_request :
         ~response_handler
         request
     in
-    match body.contents with
+    match request.body.contents with
     | `Empty _ -> Bodyw.close request_body
     | `String s ->
       Bodyw.write_string request_body s;
@@ -287,6 +292,7 @@ let create_h2c_connection
         let connection =
           Connection.Conn
             { impl = (module Http2)
+            ; config
             ; fd
             ; connection
             ; info = conn_info

lib/http_server_impl.ml

@@ -97,7 +97,9 @@ let handle_request :
   =
  fun (module Http) ~config ?upgrade ~fd ~handler ~arg reqd ->
   let report_exn = report_exn (module Http) reqd in
-  let { Server_intf.Handler.ctx = { Request_info.sw; scheme; _ }; _ } = arg in
+  let { Server_intf.Handler.ctx = { Request_info.sw; scheme; version; _ }; _ } =
+    arg
+  in
   Fiber.fork ~sw (fun () ->
     try
       let ({ Response.headers; body; _ } as response) = handler arg in
@@ -118,8 +120,10 @@ let handle_request :
       | None ->
         let response =
           { response with
-            headers =
+            version
+          ; headers =
               Headers.add_length_related_headers
+                ~version
                 ~body_length:(Piaf_body.length body)
                 headers
           }
@@ -182,6 +186,7 @@ let handle_error :
     -> start_response:(Headers.t -> writer)
     -> error_handler:Server_intf.error_handler
     -> scheme:Scheme.t
+    -> version:Versions.HTTP.t
     -> fd:Eio_unix.Net.stream_socket_ty Eio.Net.stream_socket
     -> Eio.Net.Sockaddr.stream
     -> Error.server
@@ -192,6 +197,7 @@ let handle_error :
    ~start_response
    ~error_handler
    ~scheme
+   ~version
    ~fd
    client_address
    error ->
@@ -200,6 +206,7 @@ let handle_error :
   let respond ~headers body =
     let headers =
       Headers.add_length_related_headers
+        ~version
         ~body_length:(Piaf_body.length body)
         headers
     in

lib/server_config.ml

@@ -44,7 +44,10 @@ type t =
       - the highest HTTP version that ALPN will negotiate with the remote peer
       - the version to listen on the insecure server:
       - max_http_version == HTTP/2 && h2c_upgrade => HTTP/1.1 + H2c upgrade
-      - max_http_version == HTTP/2 => HTTP/2 server *)
+      - max_http_version == HTTP/2 => HTTP/2 server.
+
+      TODO(anmonteiro): doesn't make it possible to create a http/https server
+      where https is listening on http/2 and http on http1.1 *)
   ; https : HTTPS.t option
   ; h2c_upgrade : bool
   (** Send an upgrade to `h2c` (HTTP/2 over TCP) request to the server.