From 0d712d586e1dc0a924bdec347a29c9f5c8e1a82f Mon Sep 17 00:00:00 2001 From: Bikal Lem Date: Sat, 11 Feb 2023 11:48:14 +0000 Subject: [PATCH] cohttp-eio: remove redundant type from Body. Remove redundant files from tests. Remove Rwer module Update Body.mli --- CHANGES.md | 1 + cohttp-eio/src/body.ml | 270 ----------------------------- cohttp-eio/src/body.mli | 63 ++----- cohttp-eio/src/rwer.ml | 62 ------- cohttp-eio/tests/chunks.txt | 3 - cohttp-eio/tests/dune | 1 - cohttp-eio/tests/server_chunks.txt | 3 - 7 files changed, 20 insertions(+), 383 deletions(-) delete mode 100644 cohttp-eio/src/rwer.ml delete mode 100644 cohttp-eio/tests/chunks.txt delete mode 100644 cohttp-eio/tests/server_chunks.txt diff --git a/CHANGES.md b/CHANGES.md index ed6017f872..4599598bdf 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -7,6 +7,7 @@ - cohttp-eio: generate Date header in responses (bikallem #955) - cohttp-eio: further improve Cohttp_eio.Client ergonomics (bikallem #?) - cohttp-eio: server api improvements (bikallem #962) +- cohttp-eio: renovate Client/Server API (bikallem #969) ## v6.0.0~alpha0 (2022-10-24) - cohttp-eio: ensure "Host" header is the first header in http client requests (bikallem #939) diff --git a/cohttp-eio/src/body.ml b/cohttp-eio/src/body.ml index 8af56c6600..b9562fdd2a 100644 --- a/cohttp-eio/src/body.ml +++ b/cohttp-eio/src/body.ml @@ -1,273 +1,3 @@ -module Buf_read = Eio.Buf_read -module Buf_write = Eio.Buf_write - -type t = - | Fixed of string - | Chunked of chunk_writer - | Custom of (Buf_write.t -> unit) - | Empty - -and chunk_writer = { - body_writer : (chunk -> unit) -> unit; - trailer_writer : (Http.Header.t -> unit) -> unit; -} - -and chunk = Chunk of chunk_body | Last_chunk of chunk_extension list - -and chunk_body = { - size : int; - data : string; - extensions : chunk_extension list; -} - -and chunk_extension = { name : string; value : string option } - -let pp_chunk_extension fmt = - Fmt.( - vbox - @@ list ~sep:Fmt.semi - @@ record - [ - Fmt.field "name" (fun ext -> ext.name) Fmt.string; - Fmt.field "value" (fun ext -> ext.value) Fmt.(option string); - ]) - fmt - -let pp_chunk fmt = function - | Chunk chunk -> - Fmt.( - record - [ - Fmt.field "size" (fun t -> t.size) Fmt.int; - Fmt.field "data" (fun t -> t.data) Fmt.string; - Fmt.field "extensions" (fun t -> t.extensions) pp_chunk_extension; - ]) - fmt chunk - | Last_chunk extensions -> pp_chunk_extension fmt extensions - -(* Chunked encoding parser *) - -let hex_digit = function - | '0' .. '9' -> true - | 'a' .. 'f' -> true - | 'A' .. 'F' -> true - | _ -> false - -let quoted_char = - let open Buf_read.Syntax in - let+ c = Buf_read.any_char in - match c with - | ' ' | '\t' | '\x21' .. '\x7E' -> c - | c -> failwith (Printf.sprintf "Invalid escape \\%C" c) - -(*-- qdtext = HTAB / SP /%x21 / %x23-5B / %x5D-7E / obs-text -- *) -let qdtext = function - | ('\t' | ' ' | '\x21' | '\x23' .. '\x5B' | '\x5D' .. '\x7E') as c -> c - | c -> failwith (Printf.sprintf "Invalid quoted character %C" c) - -(*-- quoted-string = DQUOTE *( qdtext / quoted-pair ) DQUOTE --*) -let quoted_string r = - Buf_read.char '"' r; - let buf = Buffer.create 100 in - let rec aux () = - match Buf_read.any_char r with - | '"' -> Buffer.contents buf - | '\\' -> - Buffer.add_char buf (quoted_char r); - aux () - | c -> - Buffer.add_char buf (qdtext c); - aux () - in - aux () - -let optional c x r = - let c2 = Buf_read.peek_char r in - if Some c = c2 then ( - Buf_read.consume r 1; - Some (x r)) - else None - -(*-- https://datatracker.ietf.org/doc/html/rfc7230#section-4.1 --*) -let chunk_ext_val = - let open Buf_read.Syntax in - let* c = Buf_read.peek_char in - match c with Some '"' -> quoted_string | _ -> Rwer.token - -let rec chunk_exts r = - let c = Buf_read.peek_char r in - match c with - | Some ';' -> - Buf_read.consume r 1; - let name = Rwer.token r in - let value = optional '=' chunk_ext_val r in - { name; value } :: chunk_exts r - | _ -> [] - -let chunk_size = - let open Buf_read.Syntax in - let* sz = Rwer.take_while1 hex_digit in - try Buf_read.return (Format.sprintf "0x%s" sz |> int_of_string) - with _ -> failwith (Format.sprintf "Invalid chunk_size: %s" sz) - -(* Be strict about headers allowed in trailer headers to minimize security - issues, eg. request smuggling attack - - https://portswigger.net/web-security/request-smuggling - Allowed headers are defined in 2nd paragraph of - https://datatracker.ietf.org/doc/html/rfc7230#section-4.1.2 *) -let is_trailer_header_allowed h = - match String.lowercase_ascii h with - | "transfer-encoding" | "content-length" | "host" - (* Request control headers are not allowed. *) - | "cache-control" | "expect" | "max-forwards" | "pragma" | "range" | "te" - (* Authentication headers are not allowed. *) - | "www-authenticate" | "authorization" | "proxy-authenticate" - | "proxy-authorization" - (* Cookie headers are not allowed. *) - | "cookie" | "set-cookie" - (* Response control data headers are not allowed. *) - | "age" | "expires" | "date" | "location" | "retry-after" | "vary" | "warning" - (* Headers to process the payload are not allowed. *) - | "content-encoding" | "content-type" | "content-range" | "trailer" -> - false - | _ -> true - -(* Request indiates which headers will be sent in chunk trailer part by - specifying the headers in comma separated value in 'Trailer' header. *) -let request_trailer_headers headers = - match Http.Header.get headers "Trailer" with - | Some v -> List.map String.trim @@ String.split_on_char ',' v - | None -> [] - -(* Chunk decoding algorithm is explained at - https://datatracker.ietf.org/doc/html/rfc7230#section-4.1.3 *) -let chunk (total_read : int) (headers : Http.Header.t) = - let open Buf_read.Syntax in - let* sz = chunk_size in - match sz with - | sz when sz > 0 -> - let* extensions = chunk_exts <* Rwer.crlf in - let* data = Buf_read.take sz <* Rwer.crlf in - Buf_read.return @@ `Chunk (sz, data, extensions) - | 0 -> - let* extensions = chunk_exts <* Rwer.crlf in - (* Read trailer headers if any and append those to request headers. - Only headers names appearing in 'Trailer' request headers and "allowed" trailer - headers are appended to request. - The spec at https://datatracker.ietf.org/doc/html/rfc7230#section-4.1.3 - specifies that 'Content-Length' and 'Transfer-Encoding' headers must be - updated. *) - let* trailer_headers = Rwer.http_headers in - let request_trailer_headers = request_trailer_headers headers in - let trailer_headers = - List.filter - (fun (name, _) -> - List.mem name request_trailer_headers - && is_trailer_header_allowed name) - (Http.Header.to_list trailer_headers) - in - let request_headers = - List.fold_left - (fun h (key, v) -> Http.Header.add h key v) - headers trailer_headers - in - (* Remove either just the 'chunked' from Transfer-Encoding header value or - remove the header entirely if value is empty. *) - let te_header = "Transfer-Encoding" in - let request_headers = - match Http.Header.get request_headers te_header with - | Some header_value -> - let new_header_value = - String.split_on_char ',' header_value - |> List.map String.trim - |> List.filter (fun v -> - let v = String.lowercase_ascii v in - not (String.equal v "chunked")) - |> String.concat "," - in - if String.length new_header_value > 0 then - Http.Header.replace request_headers te_header new_header_value - else Http.Header.remove request_headers te_header - | None -> assert false - in - (* Remove 'Trailer' from request headers. *) - let headers = Http.Header.remove request_headers "Trailer" in - (* Add Content-Length header *) - let headers = - Http.Header.add headers "Content-Length" (string_of_int total_read) - in - Buf_read.return @@ `Last_chunk (extensions, headers) - | sz -> failwith (Format.sprintf "Invalid chunk size: %d" sz) - -let read_chunked reader headers f = - match Http.Header.get_transfer_encoding headers with - | Http.Transfer.Chunked -> - let total_read = ref 0 in - let rec chunk_loop f = - let chunk = chunk !total_read headers reader in - match chunk with - | `Chunk (size, data, extensions) -> - f (Chunk { size; data; extensions }); - total_read := !total_read + size; - (chunk_loop [@tailcall]) f - | `Last_chunk (extensions, headers) -> - f (Last_chunk extensions); - Some headers - in - chunk_loop f - | _ -> None - -(* https://datatracker.ietf.org/doc/html/rfc7230#section-4.1 *) -let write_chunked ?(write_chunked_trailers = false) writer chunk_writer = - let write_extensions exts = - List.iter - (fun { name; value } -> - let v = - match value with None -> "" | Some v -> Printf.sprintf "=%s" v - in - Buf_write.string writer (Printf.sprintf ";%s%s" name v)) - exts - in - let write_body = function - | Chunk { size; data; extensions = exts } -> - Buf_write.string writer (Printf.sprintf "%X" size); - write_extensions exts; - Buf_write.string writer "\r\n"; - Buf_write.string writer data; - Buf_write.string writer "\r\n" - | Last_chunk exts -> - Buf_write.string writer "0"; - write_extensions exts; - Buf_write.string writer "\r\n" - in - chunk_writer.body_writer write_body; - if write_chunked_trailers then - chunk_writer.trailer_writer (Rwer.write_headers writer); - Buf_write.string writer "\r\n" - -let write_body ?write_chunked_trailers writer body = - match body with - | Fixed s -> Buf_write.string writer s - | Chunked chunk_writer -> - write_chunked ?write_chunked_trailers writer chunk_writer - | Custom f -> f writer - | Empty -> () - -let add_content_length requires_content_length headers body : Http.Header.t = - let content_length_hdr = "Content-Length" in - if requires_content_length && not (Http.Header.mem headers content_length_hdr) - then - match body with - | Fixed s -> - String.length s - |> string_of_int - |> Http.Header.add headers content_length_hdr - | Empty -> Http.Header.add headers content_length_hdr "0" - | _ -> headers - else headers - -(* New body *) - class virtual writer = object method virtual write_body : Eio.Buf_write.t -> unit diff --git a/cohttp-eio/src/body.mli b/cohttp-eio/src/body.mli index d9d46dff34..260a1f7e6a 100644 --- a/cohttp-eio/src/body.mli +++ b/cohttp-eio/src/body.mli @@ -1,37 +1,5 @@ (** [Body] is HTTP request or response body. *) -type t = - | Fixed of string - | Chunked of chunk_writer - | Custom of (Eio.Buf_write.t -> unit) - | Empty - -and chunk_writer = { - body_writer : (chunk -> unit) -> unit; - trailer_writer : (Http.Header.t -> unit) -> unit; -} - -(** [Chunk] encapsulates HTTP/1.1 chunk transfer encoding data structures. - https://datatracker.ietf.org/doc/html/rfc7230#section-4.1 *) -and chunk = Chunk of chunk_body | Last_chunk of chunk_extension list - -and chunk_body = { - size : int; - data : string; - extensions : chunk_extension list; -} - -and chunk_extension = { name : string; value : string option } - -val pp_chunk_extension : Format.formatter -> chunk_extension list -> unit -val pp_chunk : Format.formatter -> chunk -> unit -val add_content_length : bool -> Http.Header.t -> t -> Http.Header.t - -val read_chunked : - Buf_read.t -> Http.Header.t -> (chunk -> unit) -> Http.Header.t option - -val write_body : ?write_chunked_trailers:bool -> Buf_write.t -> t -> unit - (** {1 Writer} *) (** [writer] is a body that can be written. *) @@ -44,8 +12,9 @@ class virtual writer : (** {2 none} *) (** [none] is a special type of reader and writer that represents the absence of - HTTP request or response body. It is a no-op. See {!type:Method.t} and - {!class:Request.server_request}. *) + HTTP request or response body. It is a no-op. + + See {!type:Method.t} and {!class:Request.server_request}. *) class virtual none : object inherit writer @@ -67,10 +36,13 @@ val form_values_writer : (string * string list) list -> writer (** {1 Reader} *) -(** [reader] is a body that can be read. {!class:Request.server_request} and - {!class:Response.client_response} are both [reader] body types. As such both - of them can be used with functions that accept [#reader] instances. See - {!val:read_content} and {!val:read_form_values}. *) +(** [reader] is a body that can be read. + + {!class:Request.server_request} and {!class:Response.client_response} are + both [reader] body types. As such both of them can be used with functions + that accept [#reader] instances. + + See {!val:read_content} and {!val:read_form_values}. *) class virtual reader : object method virtual headers : Http.Header.t @@ -81,13 +53,16 @@ class virtual reader : val read_content : #reader -> string option (** [read_content reader] is [Some content], where [content] is of length [n] if - "Content-Length" header is a valid integer value [n] in [reader]. If - ["Content-Length"] header is missing or is an invalid value in [reader] then - [None] is returned. *) + "Content-Length" header is a valid integer value [n] in [reader]. + + If ["Content-Length"] header is missing or is an invalid value in [reader] + then [None] is returned. *) val read_form_values : #reader -> (string * string list) list (** [read_form_values reader] is [form_values] if [reader] body [Content-Type] is ["application/x-www-form-urlencoded"] and [Content-Length] is a valid - integer value. [form_values] is a list of tuple of form [(name, values)] - where [name] is the name of the form field and [values] is a list of values - corresponding to the [name]. *) + integer value. + + [form_values] is a list of tuple of form [(name, values)] where [name] is + the name of the form field and [values] is a list of values corresponding to + the [name]. *) diff --git a/cohttp-eio/src/rwer.ml b/cohttp-eio/src/rwer.ml deleted file mode 100644 index ac3d56ddc5..0000000000 --- a/cohttp-eio/src/rwer.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* This modules encapsulates refactored - common - readers and writers - used by the Client and Server modules. - - rwer.ml => (R)eader (W)riter + er -*) - -module Buf_read = Eio.Buf_read -module Buf_write = Eio.Buf_write - -let take_while1 p r = - match Buf_read.take_while p r with "" -> raise End_of_file | x -> x - -let token = - take_while1 (function - | '0' .. '9' - | 'a' .. 'z' - | 'A' .. 'Z' - | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '^' | '_' - | '`' | '|' | '~' -> - true - | _ -> false) - -let ows = Buf_read.skip_while (function ' ' | '\t' -> true | _ -> false) -let crlf = Buf_read.string "\r\n" -let not_cr = function '\r' -> false | _ -> true -let space = Buf_read.char '\x20' - -let version = - let open Eio.Buf_read.Syntax in - let* v = Buf_read.string "HTTP/1." *> Buf_read.any_char in - match v with - | '1' -> Buf_read.return `HTTP_1_1 - | '0' -> Buf_read.return `HTTP_1_0 - | v -> failwith (Format.sprintf "Invalid HTTP version: %C" v) - -let header = - let open Eio.Buf_read.Syntax in - let+ key = token <* Buf_read.char ':' <* ows - and+ value = Buf_read.take_while not_cr <* crlf in - (key, value) - -let http_headers r = - let[@tail_mod_cons] rec aux () = - match Buf_read.peek_char r with - | Some '\r' -> - crlf r; - [] - | _ -> - let h = header r in - h :: aux () - in - Http.Header.of_list (aux ()) - -let write_headers writer headers = - let headers = Http.Header.clean_dup headers in - Http.Header.iter - (fun k v -> - Buf_write.string writer k; - Buf_write.string writer ": "; - Buf_write.string writer v; - Buf_write.string writer "\r\n") - headers diff --git a/cohttp-eio/tests/chunks.txt b/cohttp-eio/tests/chunks.txt deleted file mode 100644 index 94edd3e041..0000000000 --- a/cohttp-eio/tests/chunks.txt +++ /dev/null @@ -1,3 +0,0 @@ -Mozilla -Developer -Network diff --git a/cohttp-eio/tests/dune b/cohttp-eio/tests/dune index 6c9ff06a11..8cd00acbd4 100644 --- a/cohttp-eio/tests/dune +++ b/cohttp-eio/tests/dune @@ -1,4 +1,3 @@ (mdx (package cohttp-eio) - (deps server_chunks.txt chunks.txt) (libraries eio eio.core eio.mock eio_main cohttp-eio http fmt)) diff --git a/cohttp-eio/tests/server_chunks.txt b/cohttp-eio/tests/server_chunks.txt deleted file mode 100644 index 94edd3e041..0000000000 --- a/cohttp-eio/tests/server_chunks.txt +++ /dev/null @@ -1,3 +0,0 @@ -Mozilla -Developer -Network