diff --git a/.ocamlformat b/.ocamlformat index ccb7749a80..ad45d296ad 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,3 @@ -version=0.21.0 profile=conventional break-infix=fit-or-vertical parse-docstrings=true diff --git a/CHANGES.md b/CHANGES.md index 6827e5ae8c..8121e51522 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,5 @@ ## Unreleased +- cohttp-eio: add cohttp-eio client api - Cohttp_eio.Client (bikallem #879) - cohttp-eio: use Eio.Buf_write and improve server API (talex5 #887) - cohttp-eio: update to Eio 0.3 (talex5 #886) - cohttp-eio: convert to Eio.Buf_read (talex5 #882) diff --git a/cohttp-eio.opam b/cohttp-eio.opam index fa6e487aa1..e50deadfdd 100644 --- a/cohttp-eio.opam +++ b/cohttp-eio.opam @@ -23,12 +23,9 @@ depends: [ "base-domains" "eio" {>= "0.4"} "eio_main" {with-test} + "mdx" {with-test} "uri" {with-test} - "cstruct" - "bigstringaf" "fmt" - "mdx" {with-test} - "eio_main" {with-test} "http" {= version} "odoc" {with-doc} ] diff --git a/cohttp-eio/examples/client1.ml b/cohttp-eio/examples/client1.ml new file mode 100644 index 0000000000..749f0065bc --- /dev/null +++ b/cohttp-eio/examples/client1.ml @@ -0,0 +1,13 @@ +open Eio +open Cohttp_eio + +let () = + Eio_main.run @@ fun env -> + Switch.run @@ fun sw -> + let hostname, port = ("www.example.org", 80) in + let he = Unix.gethostbyname hostname in + let addr = `Tcp (Eio_unix.Ipaddr.of_unix he.h_addr_list.(0), port) in + let conn = Net.connect ~sw env#net addr in + let host = (hostname, Some port) in + let res = Client.get ~conn host "/" in + print_string @@ Client.read_fixed res diff --git a/cohttp-eio/examples/client_timeout.ml b/cohttp-eio/examples/client_timeout.ml new file mode 100644 index 0000000000..397a04d9d6 --- /dev/null +++ b/cohttp-eio/examples/client_timeout.ml @@ -0,0 +1,19 @@ +open Eio +open Cohttp_eio + +let () = + Eio_main.run @@ fun env -> + Switch.run @@ fun sw -> + (* Increment/decrement this value to see success/failure. *) + let timeout_s = 0.01 in + Eio.Time.with_timeout env#clock timeout_s (fun () -> + let hostname, port = ("www.example.org", 80) in + let he = Unix.gethostbyname hostname in + let addr = `Tcp (Eio_unix.Ipaddr.of_unix he.h_addr_list.(0), port) in + let conn = Net.connect ~sw env#net addr in + let host = (hostname, Some port) in + let res = Client.get ~conn host "/" in + Client.read_fixed res |> Result.ok) + |> function + | Ok s -> print_string s + | Error `Timeout -> print_string "Connection timed out" diff --git a/cohttp-eio/examples/docker_client.ml b/cohttp-eio/examples/docker_client.ml new file mode 100644 index 0000000000..8dee798eea --- /dev/null +++ b/cohttp-eio/examples/docker_client.ml @@ -0,0 +1,20 @@ +module Switch = Eio.Switch +module Net = Eio.Net +module Stdenv = Eio.Stdenv +module Client = Cohttp_eio.Client +module Response = Http.Response +module Status = Http.Status + +let () = + Eio_main.run @@ fun env -> + Switch.run @@ fun sw -> + let addr = `Unix "/var/run/docker.sock" in + let conn = Net.connect ~sw env#net addr in + let res = Client.get ~conn ("docker", None) "/version" in + let code = fst res |> Response.status |> Status.to_int in + Printf.printf "Response code: %d\n" code; + Printf.printf "Headers: %s\n" + (fst res |> Response.headers |> Http.Header.to_string); + let body = Client.read_fixed res in + Printf.printf "Body of length: %d\n" (String.length body); + print_endline ("Received body\n" ^ body) diff --git a/cohttp-eio/examples/dune b/cohttp-eio/examples/dune index fe4a214e41..0127c08042 100644 --- a/cohttp-eio/examples/dune +++ b/cohttp-eio/examples/dune @@ -1,6 +1,6 @@ -(executable - (name server1) - (libraries cohttp-eio uri eio_main)) +(executables + (names server1 client1 docker_client client_timeout) + (libraries cohttp-eio eio_main eio.unix unix)) (alias (name runtest) diff --git a/cohttp-eio/src/body.ml b/cohttp-eio/src/body.ml index ef2f571f69..5bf53fc322 100644 --- a/cohttp-eio/src/body.ml +++ b/cohttp-eio/src/body.ml @@ -1,9 +1,10 @@ -module Write = Eio.Buf_write +module Buf_read = Eio.Buf_read +module Buf_write = Eio.Buf_write type t = | Fixed of string | Chunked of chunk_writer - | Custom of (Write.t -> unit) + | Custom of (Buf_write.t -> unit) | Empty and chunk_writer = { @@ -44,21 +45,8 @@ let pp_chunk fmt = function fmt chunk | Last_chunk extensions -> pp_chunk_extension fmt extensions -open Reader -open Eio.Buf_read - -let read_fixed t headers = - match Http.Header.get headers "Content-length" with - | Some v -> - let content_length = int_of_string v in - let content = take content_length t in - content - | None -> raise @@ Invalid_argument "Request is not a fixed content body" - (* Chunked encoding parser *) -open Eio.Buf_read.Syntax - let hex_digit = function | '0' .. '9' -> true | 'a' .. 'f' -> true @@ -66,7 +54,8 @@ let hex_digit = function | _ -> false let quoted_char = - let+ c = any_char in + 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) @@ -78,10 +67,10 @@ let qdtext = function (*-- quoted-string = DQUOTE *( qdtext / quoted-pair ) DQUOTE --*) let quoted_string r = - char '"' r; + Buf_read.char '"' r; let buf = Buffer.create 100 in let rec aux () = - match any_char r with + match Buf_read.any_char r with | '"' -> Buffer.contents buf | '\\' -> Buffer.add_char buf (quoted_char r); @@ -93,30 +82,32 @@ let quoted_string r = aux () let optional c x r = - let c2 = peek_char r in + let c2 = Buf_read.peek_char r in if Some c = c2 then ( - consume r 1; + 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* c = peek_char in - match c with Some '"' -> quoted_string | _ -> token + 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 = peek_char r in + let c = Buf_read.peek_char r in match c with | Some ';' -> - consume r 1; - let name = token r in + 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* sz = take_while1 hex_digit in - try return (Format.sprintf "0x%s" sz |> int_of_string) + 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 @@ -151,21 +142,22 @@ let request_trailer_headers headers = (* 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 <* crlf in - let* data = take sz <* crlf in - return @@ `Chunk (sz, data, extensions) + 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 <* crlf in + 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 = http_headers in + let* trailer_headers = Rwer.http_headers in let request_trailer_headers = request_trailer_headers headers in let trailer_headers = List.filter @@ -204,7 +196,7 @@ let chunk (total_read : int) (headers : Http.Header.t) = let headers = Http.Header.add headers "Content-Length" (string_of_int total_read) in - return @@ `Last_chunk (extensions, headers) + Buf_read.return @@ `Last_chunk (extensions, headers) | sz -> failwith (Format.sprintf "Invalid chunk size: %d" sz) let read_chunked reader headers f = @@ -220,45 +212,41 @@ let read_chunked reader headers f = (chunk_loop [@tailcall]) f | `Last_chunk (extensions, headers) -> f (Last_chunk extensions); - headers + Some headers in chunk_loop f - | _ -> raise @@ Invalid_argument "Request is not a chunked request" - -(* Writes *) - -let write_headers t headers = - Http.Header.iter - (fun k v -> - Write.string t k; - Write.string t ": "; - Write.string t v; - Write.string t "\r\n") - headers + | _ -> None (* https://datatracker.ietf.org/doc/html/rfc7230#section-4.1 *) -let write_chunked t chunk_writer = +let write_chunked 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 - Write.string t (Printf.sprintf ";%s%s" name v)) + Buf_write.string writer (Printf.sprintf ";%s%s" name v)) exts in let write_body = function | Chunk { size; data; extensions = exts } -> - Write.string t (Printf.sprintf "%X" size); + Buf_write.string writer (Printf.sprintf "%X" size); write_extensions exts; - Write.string t "\r\n"; - Write.string t data; - Write.string t "\r\n" + Buf_write.string writer "\r\n"; + Buf_write.string writer data; + Buf_write.string writer "\r\n" | Last_chunk exts -> - Write.string t "0"; + Buf_write.string writer "0"; write_extensions exts; - Write.string t "\r\n" + Buf_write.string writer "\r\n" in chunk_writer.body_writer write_body; - chunk_writer.trailer_writer (write_headers t); - Write.string t "\r\n" + chunk_writer.trailer_writer (Rwer.write_headers writer); + Buf_write.string writer "\r\n" + +let write_body writer body = + match body with + | Fixed s -> Buf_write.string writer s + | Chunked chunk_writer -> write_chunked writer chunk_writer + | Custom f -> f writer + | Empty -> () diff --git a/cohttp-eio/src/client.ml b/cohttp-eio/src/client.ml new file mode 100644 index 0000000000..75d2bd8c1f --- /dev/null +++ b/cohttp-eio/src/client.ml @@ -0,0 +1,115 @@ +module Buf_read = Eio.Buf_read +module Buf_write = Eio.Buf_write + +type response = Http.Response.t * Buf_read.t +type host = string * int option +type resource_path = string + +type 'a body_disallowed_call = + ?version:Http.Version.t -> + ?headers:Http.Header.t -> + conn:(#Eio.Flow.two_way as 'a) -> + host -> + resource_path -> + response +(** [body_disallowed_call] denotes HTTP client calls where a request is not + allowed to have a request body. *) + +type 'a body_allowed_call = + ?version:Http.Version.t -> + ?headers:Http.Header.t -> + ?body:Body.t -> + conn:(#Eio.Flow.two_way as 'a) -> + host -> + resource_path -> + response + +(* Request line https://datatracker.ietf.org/doc/html/rfc7230#section-3.1.1 *) +let write_request writer (meth, version, headers, resource_path, body) = + Buf_write.string writer (Http.Method.to_string meth); + Buf_write.char writer ' '; + Buf_write.string writer resource_path; + Buf_write.char writer ' '; + Buf_write.string writer (Http.Version.to_string version); + Buf_write.string writer "\r\n"; + Rwer.write_headers writer headers; + Buf_write.string writer "\r\n"; + Body.write_body writer body + +(* response parser *) + +let is_digit = function '0' .. '9' -> true | _ -> false + +let status_code = + let open Rwer in + let open Buf_read.Syntax in + let+ status = take_while1 is_digit in + Http.Status.of_int (int_of_string status) + +let reason_phrase = + Buf_read.take_while (function + | '\x21' .. '\x7E' | '\t' | ' ' -> true + | _ -> false) + +(* https://datatracker.ietf.org/doc/html/rfc7230#section-3.1.2 *) +let response buf_read = + let open Buf_read.Syntax in + let version = Rwer.(version <* space) buf_read in + let status = Rwer.(status_code <* space) buf_read in + let () = Rwer.(reason_phrase *> crlf *> Buf_read.return ()) buf_read in + let headers = Rwer.http_headers buf_read in + Http.Response.make ~version ~status ~headers () + +(* Generic HTTP call *) + +let call ?(meth = `GET) ?(version = `HTTP_1_1) ?(headers = Http.Header.init ()) + ?(body = Body.Empty) ~conn host resource_path = + let host = + match host with + | host, Some port -> host ^ ":" ^ string_of_int port + | host, None -> host + in + Buf_write.with_flow ~initial_size:0x1000 conn (fun writer -> + let headers = Http.Header.add_unless_exists headers "Host" host in + write_request writer (meth, version, headers, resource_path, body); + let reader = + Eio.Buf_read.of_flow ~initial_size:0x1000 ~max_size:max_int conn + in + let response = response reader in + (response, reader)) + +(* HTTP Calls with Body Disallowed *) + +let get ?version ?headers ~conn host resource_path = + call ~meth:`GET ?version ?headers ~conn host resource_path + +let head ?version ?headers ~conn host resource_path = + call ~meth:`HEAD ?version ?headers ~conn host resource_path + +let delete ?version ?headers ~conn host resource_path = + call ~meth:`DELETE ?version ?headers ~conn host resource_path + +(* HTTP Calls with Body Allowed *) + +let post ?version ?headers ?body ~conn host resource_path = + call ~meth:`POST ?version ?headers ?body ~conn host resource_path + +let put ?version ?headers ?body ~conn host resource_path = + call ~meth:`PUT ?version ?headers ?body ~conn host resource_path + +let patch ?version ?headers ?body ~conn host resource_path = + call ~meth:`PATCH ?version ?headers ?body ~conn host resource_path + +(* Response Body *) + +let read_fixed ((response, reader) : Http.Response.t * Buf_read.t) = + match + Http.Header.get response.headers "Content-Length" + |> Option.get + |> int_of_string + with + | content_length -> Buf_read.take content_length reader + | exception _ -> Buf_read.take_all reader + +let read_chunked : response -> (Body.chunk -> unit) -> Http.Header.t option = + fun (response, reader) f -> Body.read_chunked reader response.headers f diff --git a/cohttp-eio/src/cohttp_eio.ml b/cohttp-eio/src/cohttp_eio.ml index 8a0f06127d..284353ff92 100644 --- a/cohttp-eio/src/cohttp_eio.ml +++ b/cohttp-eio/src/cohttp_eio.ml @@ -1,2 +1,3 @@ module Body = Body module Server = Server +module Client = Client diff --git a/cohttp-eio/src/cohttp_eio.mli b/cohttp-eio/src/cohttp_eio.mli index 737d1b8068..3dcea73d84 100644 --- a/cohttp-eio/src/cohttp_eio.mli +++ b/cohttp-eio/src/cohttp_eio.mli @@ -35,28 +35,32 @@ module Server : sig type response = Http.Response.t * Body.t type handler = request -> response - (** {1 Request} *) + (** {1 Request Body} *) - val read_fixed : Http.Request.t -> Eio.Buf_read.t -> string - (** [read_fixed request body] reads a string of length [n] if "Content-Length" - header is a valid integer value [n] in [request]. + val read_fixed : Http.Request.t -> Eio.Buf_read.t -> string option + (** [read_fixed (request, buf_read)] is [Some content], where [content] is of + length [n] if "Content-Length" header is a valid integer value [n] in + [request]. - @raise Invalid_argument - if ["Content-Length"] header is missing or is an invalid value in - [headers] OR if the request http method is not one of [POST], [PUT] or - [PATCH]. *) + [buf_read] is updated to reflect that [n] bytes was read. - val read_chunked : - Http.Request.t -> Eio.Buf_read.t -> (Body.chunk -> unit) -> Http.Header.t - (** [read_chunked request body chunk_handler] is [updated_headers] if - "Transfer-Encoding" header value is "chunked" in [headers] and all chunks - in [reader] are read successfully. [updated_headers] is the updated - headers as specified by the chunked encoding algorithm in - https://datatracker.ietf.org/doc/html/rfc7230#section-4.1.3. Otherwise it - is [Error err] where [err] is the error text. + If ["Content-Length"] header is missing or is an invalid value in + [request] OR if the request http method is not one of [POST], [PUT] or + [PATCH], then [None] is returned. *) - @raise Invalid_argument - if [Transfer-Encoding] header in [headers] is not specified as "chunked" *) + val read_chunked : + Http.Request.t -> + Eio.Buf_read.t -> + (Body.chunk -> unit) -> + Http.Header.t option + (** [read_chunked request buf_read chunk_handler] is [Some updated_headers] if + "Transfer-Encoding" header value is "chunked" in [request] and all chunks + in [buf_read] are read successfully. [updated_headers] is the updated + headers as specified by the chunked encoding algorithm in https: + //datatracker.ietf.org/doc/html/rfc7230#section-4.1.3. + + [buf_read] is updated to reflect the number of bytes read. Returns [None] + if [Transfer-Encoding] header in [headers] is not specified as "chunked" *) (** {1 Response} *) @@ -96,3 +100,81 @@ module Server : sig val not_found_handler : handler end + +(** [Client] is a HTTP/1.1 client. *) +module Client : sig + type response = Http.Response.t * Eio.Buf_read.t + + type host = string * int option + (** Represents a server host - as ip address or domain name - and an optional + port value, e.g. www.example.org:8080, www.reddit.com *) + + type resource_path = string + (** Represents HTTP request resource path, e.g. "/shop/purchase", + "/shop/items", "/shop/categories/" etc. *) + + type 'a body_disallowed_call = + ?version:Http.Version.t -> + ?headers:Http.Header.t -> + conn:(#Eio.Flow.two_way as 'a) -> + host -> + resource_path -> + response + (** [body_disallowed_call] denotes HTTP client calls where a request is not + allowed to have a request body. *) + + type 'a body_allowed_call = + ?version:Http.Version.t -> + ?headers:Http.Header.t -> + ?body:Body.t -> + conn:(#Eio.Flow.two_way as 'a) -> + host -> + resource_path -> + response + (** [body_allowed_call] denotes HTTP client calls where a request can + optionally have a request body. *) + + (** {1 Generic HTTP call} *) + + val call : + ?meth:Http.Method.t -> + ?version:Http.Version.t -> + ?headers:Http.Header.t -> + ?body:Body.t -> + conn:#Eio.Flow.two_way -> + host -> + resource_path -> + response + + (** {1 HTTP Calls with Body Disallowed} *) + + val get : 'a body_disallowed_call + val head : 'a body_disallowed_call + val delete : 'a body_disallowed_call + + (** {1 HTTP Calls with Body Allowed} *) + + val post : 'a body_allowed_call + val put : 'a body_allowed_call + val patch : 'a body_allowed_call + + (** {1 Response Body} *) + + val read_fixed : response -> string + (** [read_fixed (response,reader)] is [body_content], where [body_content] is + of length [n] if "Content-Length" header exists and is a valid integer + value [n] in [response]. Otherwise [body_content] holds all bytes until + eof. *) + + val read_chunked : response -> (Body.chunk -> unit) -> Http.Header.t option + (** [read_chunked response chunk_handler] is [Some updated_headers] if + "Transfer-Encoding" header value is "chunked" in [response] and all chunks + in [reader] are read successfully. [updated_headers] is the updated + headers as specified by the chunked encoding algorithm in https: + //datatracker.ietf.org/doc/html/rfc7230#section-4.1.3. + + [reader] is updated to reflect the number of bytes read. + + Returns [None] if [Transfer-Encoding] header in [headers] is not specified + as "chunked" *) +end diff --git a/cohttp-eio/src/dune b/cohttp-eio/src/dune index cab99284c3..e8cea3850e 100644 --- a/cohttp-eio/src/dune +++ b/cohttp-eio/src/dune @@ -1,4 +1,4 @@ (library (name cohttp_eio) (public_name cohttp-eio) - (libraries eio cstruct http bigstringaf fmt)) + (libraries eio http fmt)) diff --git a/cohttp-eio/src/reader.ml b/cohttp-eio/src/reader.ml deleted file mode 100644 index e7c0809419..0000000000 --- a/cohttp-eio/src/reader.ml +++ /dev/null @@ -1,63 +0,0 @@ -open Eio.Buf_read -open Eio.Buf_read.Syntax - -let return v _ = v - -let take_while1 p r = - match take_while p r with - | "" -> failwith "[take_while1] count is less than 1" - | x -> x - -let token = - take_while1 (function - | '0' .. '9' - | 'a' .. 'z' - | 'A' .. 'Z' - | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '^' | '_' - | '`' | '|' | '~' -> - true - | _ -> false) - -let ows = skip_while (function ' ' | '\t' -> true | _ -> false) -let crlf = string "\r\n" -let not_cr = function '\r' -> false | _ -> true -let space = char '\x20' - -let p_meth = - let+ meth = token <* space in - Http.Method.of_string meth - -let p_resource = take_while1 (fun c -> c != ' ') <* space - -let p_version = - let* v = string "HTTP/1." *> any_char <* crlf in - match v with - | '1' -> return `HTTP_1_1 - | '0' -> return `HTTP_1_0 - | v -> failwith (Format.sprintf "Invalid HTTP version: %C" v) - -let header = - let+ key = token <* char ':' <* ows and+ value = take_while not_cr <* crlf in - (key, value) - -let http_headers r = - let rec aux () = - match peek_char r with - | Some '\r' -> - crlf r; - [] - | _ -> - let h = header r in - h :: aux () - in - Http.Header.of_list (aux ()) - -let[@warning "-3"] http_request t = - match at_end_of_input t with - | true -> Stdlib.raise_notrace End_of_file - | false -> - let meth = p_meth t in - let resource = p_resource t in - let version = p_version t in - let headers = http_headers t in - Http.Request.make ~meth ~version ~headers resource diff --git a/cohttp-eio/src/rwer.ml b/cohttp-eio/src/rwer.ml new file mode 100644 index 0000000000..8484282260 --- /dev/null +++ b/cohttp-eio/src/rwer.ml @@ -0,0 +1,61 @@ +(* 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 = + 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/src/server.ml b/cohttp-eio/src/server.ml index adb971aacd..f7fa2b011b 100644 --- a/cohttp-eio/src/server.ml +++ b/cohttp-eio/src/server.ml @@ -1,5 +1,6 @@ -open Eio.Std -module Write = Eio.Buf_write +module Buf_read = Eio.Buf_read +module Buf_write = Eio.Buf_write +module Switch = Eio.Switch type middleware = handler -> handler and handler = request -> response @@ -15,14 +16,13 @@ let domain_count = let read_fixed request reader = match Http.Request.meth request with - | `POST | `PUT | `PATCH -> Body.read_fixed reader request.headers - | _ -> - let err = - Printf.sprintf - "Request with HTTP method '%s' doesn't support request body" - (Http.Method.to_string request.meth) - in - raise @@ Invalid_argument err + | `POST | `PUT | `PATCH -> + let ( let* ) o f = Option.bind o f in + let ( let+ ) o f = Option.map f o in + let* v = Http.Header.get request.headers "Content-Length" in + let+ content_length = int_of_string_opt v in + Buf_read.take content_length reader + | _ -> None let read_chunked request reader f = Body.read_chunked reader (Http.Request.headers request) f @@ -65,26 +65,41 @@ let internal_server_error_response = let bad_request_response = (Http.Response.make ~status:`Bad_request (), Body.Empty) -let write_response (writer : Write.t) - ((response, body) : Http.Response.t * Body.t) = +let write_response writer ((response, body) : Http.Response.t * Body.t) = let version = Http.Version.to_string response.version in let status = Http.Status.to_string response.status in - Write.string writer version; - Write.string writer " "; - Write.string writer status; - Write.string writer "\r\n"; - Body.write_headers writer response.headers; - Write.string writer "\r\n"; - match body with - | Fixed s -> Write.string writer s - | Chunked chunk_writer -> Body.write_chunked writer chunk_writer - | Custom f -> f writer - | Empty -> () + Buf_write.string writer version; + Buf_write.char writer ' '; + Buf_write.string writer status; + Buf_write.string writer "\r\n"; + Rwer.write_headers writer response.headers; + Buf_write.string writer "\r\n"; + Body.write_body writer body + +(* request parsers *) + +let meth = + let open Eio.Buf_read.Syntax in + let+ meth = Rwer.(token <* space) in + Http.Method.of_string meth + +let resource = + let open Eio.Buf_read.Syntax in + Rwer.(take_while1 (fun c -> c != ' ') <* space) + +let[@warning "-3"] http_request t = + let open Eio.Buf_read.Syntax in + let meth = meth t in + let resource = resource t in + let version = Rwer.(version <* crlf) t in + let headers = Rwer.http_headers t in + let encoding = Http.Header.get_transfer_encoding headers in + { Http.Request.meth; resource; version; headers; scheme = None; encoding } (* main *) let rec handle_request client_addr reader writer flow handler = - match Reader.http_request reader with + match http_request reader with | request -> let response, body = handler (request, reader, client_addr) in write_response writer (response, body); @@ -99,10 +114,8 @@ let rec handle_request client_addr reader writer flow handler = raise ex let connection_handler (handler : handler) flow client_addr = - let reader = - Eio.Buf_read.of_flow ~initial_size:0x1000 ~max_size:max_int flow - in - Write.with_flow flow (fun writer -> + let reader = Buf_read.of_flow ~initial_size:0x1000 ~max_size:max_int flow in + Buf_write.with_flow flow (fun writer -> handle_request client_addr reader writer flow handler) let run_domain ssock handler = diff --git a/cohttp-eio/tests/chunks.txt b/cohttp-eio/tests/chunks.txt new file mode 100644 index 0000000000..94edd3e041 --- /dev/null +++ b/cohttp-eio/tests/chunks.txt @@ -0,0 +1,3 @@ +Mozilla +Developer +Network diff --git a/cohttp-eio/tests/dune b/cohttp-eio/tests/dune index c7dfde49c0..697349fea1 100644 --- a/cohttp-eio/tests/dune +++ b/cohttp-eio/tests/dune @@ -1,17 +1,6 @@ -(executable - (name test_server) - (modules test_server) - (libraries cohttp_eio eio_main fmt)) - -(executable - (name test_chunk_server) - (modules test_chunk_server) - (libraries cohttp_eio eio_main fmt)) - -(executable - (name crlf) - (modules crlf) - (libraries unix)) +(executables + (names test_server test_client crlf) + (libraries cohttp_eio eio_main fmt uri)) (mdx (package cohttp-eio) @@ -22,7 +11,12 @@ (binaries (test_server.exe as test-server) crlf.exe - (test_chunk_server.exe as test-chunk-server)))) + (test_client.exe as test-client)))) (cram - (deps %{bin:test-server} %{bin:test-chunk-server} %{bin:crlf})) + (deps + %{bin:test-server} + %{bin:crlf} + %{bin:test-client} + chunks.txt + server_chunks.txt)) diff --git a/cohttp-eio/tests/server_chunks.txt b/cohttp-eio/tests/server_chunks.txt new file mode 100644 index 0000000000..94edd3e041 --- /dev/null +++ b/cohttp-eio/tests/server_chunks.txt @@ -0,0 +1,3 @@ +Mozilla +Developer +Network diff --git a/cohttp-eio/tests/test_chunk.t b/cohttp-eio/tests/test_chunk.t deleted file mode 100644 index a0bc7c2197..0000000000 --- a/cohttp-eio/tests/test_chunk.t +++ /dev/null @@ -1,54 +0,0 @@ -Test chunk request processing. -1. Test chunks -2. Test chunk extension parsing -3. Test chunk trailer header processing. Specifically, the in the test sample below - - $ port=8081 - $ test-chunk-server -p ${port} & - $ running_pid=$! - $ crlf << EOF | ncat localhost ${port} - > POST / HTTP/1.1 - > Content-Type: text/plain - > Transfer-Encoding: chunked - > Trailer: Expires, Header1 - > - > 7;ext1=ext1_v;ext2=ext2_v;ext3 - > Mozilla - > 9 - > Developer - > 7 - > Network - > 0 - > Expires: Wed, 21 Oct 2015 07:28:00 GMT - > Header1: Header1 value text - > Header2: Header2 value text - > - > EOF - HTTP/1.1 200 OK - content-length: 342 - content-type: text/plain; charset=UTF-8 - - meth: POST - resource: / - version: HTTP/1.1 - headers: Header { - Content-Length = "23"; Header1 = "Header1 value text"; - Content-Type = "text/plain" } - - size: 7 - data: Mozilla - extensions: - name: ext1 - value: ext1_v; - name: ext2 - value: ext2_v; - name: ext3 - value: - size: 9 - data: Developer - extensions: - size: 7 - data: Network - extensions: - - $ kill ${running_pid} diff --git a/cohttp-eio/tests/test_chunk_server.ml b/cohttp-eio/tests/test_chunk_server.ml deleted file mode 100644 index 72e9c8c7e1..0000000000 --- a/cohttp-eio/tests/test_chunk_server.ml +++ /dev/null @@ -1,27 +0,0 @@ -open Cohttp_eio -open Cohttp_eio.Server - -let dump_chunk buf chunk = - let s = Format.asprintf "\n%a" Body.pp_chunk chunk in - Buffer.add_string buf s - -let app (req, reader, _client_addr) = - match Http.Request.resource req with - | "/" -> ( - let chunk_buf = Buffer.create 0 in - match Server.read_chunked req reader (dump_chunk chunk_buf) with - | headers -> - let req = { req with headers } in - Buffer.contents chunk_buf - |> Format.asprintf "%a@ %s%!" Http.Request.pp req - |> Server.text_response - | exception Invalid_argument _ -> Server.bad_request_response) - | _ -> Server.not_found_response - -let () = - let port = ref 8080 in - Arg.parse - [ ("-p", Arg.Set_int port, " Listening port number(8080 by default)") ] - ignore "An HTTP/1.1 server"; - - Eio_main.run @@ fun env -> run ~port:!port env app diff --git a/cohttp-eio/tests/test_client.ml b/cohttp-eio/tests/test_client.ml new file mode 100644 index 0000000000..766e470ddb --- /dev/null +++ b/cohttp-eio/tests/test_client.ml @@ -0,0 +1,119 @@ +module Net = Eio.Net +module Stdenv = Eio.Stdenv +module Switch = Eio.Switch +open Cohttp_eio + +let get conn host = + let res = + Client.get + ~headers:(Http.Header.of_list [ ("Accept", "application/json") ]) + ~conn host "/get" + in + print_string @@ Client.read_fixed res + +let post conn host = + let content = "hello world!" in + let content_length = String.length content |> string_of_int in + let res = + Client.post + ~headers: + (Http.Header.of_list + [ + ("Accept", "application/json"); ("Content-Length", content_length); + ]) + ~body:(Body.Fixed content) ~conn host "/post" + in + print_string @@ Client.read_fixed res + +(** Write chunk test. + + Read from text file "chunks.txt" and write each line as a chunk. We add some + chunk extensions to the first chunk. This is purely for demonstrative effect + and for testing purposes rather than for any such specific requirement. *) +let post_chunk conn host = + let rec body_writer chan chunks f = + match In_channel.input_line chan with + | Some data -> + let extensions = + if chunks = 0 then + [ + Body.{ name = "ext1"; value = Some "ext1_v" }; + { name = "ext2"; value = Some "ext2_v" }; + { name = "ext3"; value = None }; + ] + else [] + in + let chunk = + Body.Chunk { size = String.length data; data; extensions } + in + f chunk; + body_writer chan (chunks + 1) f + | None -> + let last_chunk = Body.Last_chunk [] in + f last_chunk + in + let trailer_writer f = + let trailer_headers = + Http.Header.of_list + [ + ("Expires", "Wed, 21 Oct 2015 07:28:00 GMT"); + ("Header1", "Header1 value text"); + ("Header2", "Header2 value text"); + ] + in + f trailer_headers + in + In_channel.with_open_text "chunks.txt" (fun chan -> + Client.post + ~headers: + (Http.Header.of_list + [ + ("Transfer-Encoding", "chunked"); + ("Content-Type", "text/plain"); + ("Trailer", "Expires, Header1"); + ]) + ~body: + (Body.Chunked { body_writer = body_writer chan 0; trailer_writer }) + ~conn host "/handle_chunk") + |> Client.read_fixed + |> print_string + +(* Read chunk and dump to a "client_chunks2.txt" *) +let get_chunk env conn host = + let write_chunk_to_file flow chunk = + let data = Format.asprintf "%a\n\n" Body.pp_chunk chunk in + Eio.Flow.copy_string data flow + in + let res = Client.get ~conn host "/get_chunk" in + let path = Eio.Path.(Stdenv.cwd env / "client_chunks2.txt") in + Eio.Path.with_open_out ~append:false ~create:(`Or_truncate 0o666) path + (fun flow -> + Client.read_chunked res (write_chunk_to_file flow) |> function + | Some headers -> + let s = Format.asprintf "%a%!" Http.Header.pp_hum headers in + Eio.Flow.copy_string s flow + | None -> ()) + +let () = + let port = ref 8080 in + let t = ref "invalid_uri" in + Arg.parse + [ + ("-p", Arg.Set_int port, " Server listening port number(8080 default)"); + ( "-t", + Arg.Set_string t, + "Specify test case to execute,('invalid_uri' default)" ); + ] + ignore "An HTTP/1.1 server"; + + Eio_main.run @@ fun env -> + Switch.run @@ fun sw -> + let addr = `Tcp (Net.Ipaddr.V4.loopback, !port) in + let conn = Net.connect ~sw env#net addr in + let host = ("localhost", Some !port) in + match !t with + | "get" -> get conn host + | "post" -> post conn host + | "post_chunk" -> post_chunk conn host + | "get_chunk" -> get_chunk env conn host + | _ -> print_string "Usage: test-client [get|post]" diff --git a/cohttp-eio/tests/test_client.t b/cohttp-eio/tests/test_client.t new file mode 100644 index 0000000000..2699a68ef8 --- /dev/null +++ b/cohttp-eio/tests/test_client.t @@ -0,0 +1,92 @@ +Test Client.get + + $ port=8082 + $ test-server -p ${port} & + $ running_pid=$! + $ test-client -p ${port} -t get + meth: GET + resource: /get + version: HTTP/1.1 + headers: Header { Accept = "application/json"; Host = "localhost:8082" } + + $ kill ${running_pid} + +Test Client.post + + $ port=8082 + $ test-server -p ${port} & + $ running_pid=$! + $ test-client -p ${port} -t post + meth: POST + resource: /post + version: HTTP/1.1 + headers: Header { + Accept = "application/json"; Content-Length = "12"; Host = "localhost:8082" + } + + hello world! + + $ kill ${running_pid} + + +Test posting "chunked" data + $ port=8082 + $ test-server -p ${port} & + $ running_pid=$! + $ test-client -p ${port} -t post_chunk + meth: POST + resource: /handle_chunk + version: HTTP/1.1 + headers: Header { + Content-Length = "23"; Header1 = "Header1 value text"; + Content-Type = "text/plain"; Host = "localhost:8082" } + + size: 7 + data: Mozilla + extensions: + name: ext1 + value: ext1_v; + name: ext2 + value: ext2_v; + name: ext3 + value: + size: 9 + data: Developer + extensions: + size: 7 + data: Network + extensions: + + $ kill ${running_pid} + +Test "chunked" response in client and "chunked" response writing in server. + $ port=8082 + $ test-server -p ${port} & + $ running_pid=$! + $ test-client -p ${port} -t get_chunk + $ kill ${running_pid} + $ cat client_chunks2.txt + size: 7 + data: Mozilla + extensions: + name: ext1 + value: ext1_v; + name: ext2 + value: ext2_v; + name: ext3 + value: + + size: 9 + data: Developer + extensions: + + size: 7 + data: Network + extensions: + + + + Header { + Content-Length = "23"; Header1 = "Header1 value text"; + Content-Type = "text/plain" + } diff --git a/cohttp-eio/tests/test_get_post.t b/cohttp-eio/tests/test_get_post.t deleted file mode 100644 index 71f0947670..0000000000 --- a/cohttp-eio/tests/test_get_post.t +++ /dev/null @@ -1,57 +0,0 @@ -Test GET success. - - $ test-server & - $ running_pid=$! - $ crlf << EOF | ncat localhost 8080 - > GET /get HTTP/1.1 - > - > EOF - HTTP/1.1 200 OK - content-length: 63 - content-type: text/plain; charset=UTF-8 - - meth: GET - resource: /get - version: HTTP/1.1 - headers: Header { } - $ kill ${running_pid} - -Test GET error. -The test should respond with error message since we are trying to read request body. HTTP 1.1 doesn't support request bodies in GET. - - $ test-server & - $ running_pid=$! - $ crlf << EOF | ncat localhost 8080 - > GET /get_error HTTP/1.1 - > - > EOF - HTTP/1.1 200 OK - content-length: 59 - content-type: text/plain; charset=UTF-8 - - Request with HTTP method 'GET' doesn't support request body - $ kill ${running_pid} - -Test POST - - $ test-server & - $ running_pid=$! - $ crlf << EOF | ncat localhost 8080 - > POST /post HTTP/1.0 - > Content-Length:12 - > - > hello world! - > EOF - HTTP/1.1 200 OK - content-length: 100 - content-type: text/plain; charset=UTF-8 - - meth: POST - resource: /post - version: HTTP/1.0 - headers: Header { Content-Length = "12" } - - hello world! - $ kill ${running_pid} - - diff --git a/cohttp-eio/tests/test_server.ml b/cohttp-eio/tests/test_server.ml index 1a35b19848..64bbebd520 100644 --- a/cohttp-eio/tests/test_server.ml +++ b/cohttp-eio/tests/test_server.ml @@ -1,18 +1,88 @@ open Cohttp_eio -let read_body req reader = - let body = Server.read_fixed req reader in - Server.text_response @@ Fmt.str "%a\n\n%s" Http.Request.pp req body - -let app (req, reader, _client_addr) = +let app (req, reader, _) = match Http.Request.resource req with | "/get" -> Server.text_response (Fmt.to_to_string Http.Request.pp req) | "/get_error" -> ( - try - let _ = Server.read_fixed req reader in - assert false - with Invalid_argument e -> Server.text_response e) - | "/post" -> read_body req reader + match Server.read_fixed req reader with + | Some _ -> Server.text_response "FAIL" + | None -> Server.text_response "PASS") + | "/post" -> + let body = Server.read_fixed req reader |> Option.get in + let buf = Buffer.create 0 in + let fmt = Format.formatter_of_buffer buf in + Http.Request.pp fmt req; + Format.fprintf fmt "\n\n%s%!" body; + Server.text_response (Buffer.contents buf) + | "/handle_chunk" -> ( + let dump_chunk buf chunk = + let s = Format.asprintf "\n%a" Body.pp_chunk chunk in + Buffer.add_string buf s + in + let chunk_buf = Buffer.create 0 in + match Server.read_chunked req reader (dump_chunk chunk_buf) with + | Some headers -> + let req = { req with headers } in + Buffer.contents chunk_buf + |> Format.asprintf "%a@ %s%!" Http.Request.pp req + |> Server.text_response + | None -> Server.bad_request_response) + | "/get_chunk" -> + let rec body_writer chan chunks f = + match In_channel.input_line chan with + | Some data -> + let extensions = + if chunks = 0 then + [ + Body.{ name = "ext1"; value = Some "ext1_v" }; + { name = "ext2"; value = Some "ext2_v" }; + { name = "ext3"; value = None }; + ] + else [] + in + let chunk = + Body.Chunk { size = String.length data; data; extensions } + in + f chunk; + body_writer chan (chunks + 1) f + | None -> + let last_chunk = Body.Last_chunk [] in + In_channel.close chan; + f last_chunk + in + let trailer_writer f = + let trailer_headers = + Http.Header.of_list + [ + ("Expires", "Wed, 21 Oct 2015 07:28:00 GMT"); + ("Header1", "Header1 value text"); + ("Header2", "Header2 value text"); + ] + in + f trailer_headers + in + let chan = + In_channel.open_gen [ Open_text; Open_rdonly ] 0 "server_chunks.txt" + in + let headers = + Http.Header.of_list + [ + ("Transfer-Encoding", "chunked"); + ("Content-Type", "text/plain"); + ("Trailer", "Expires, Header1"); + ] + in + let response = Http.Response.make ~status:`OK ~headers () in + let body = + Body.Chunked { body_writer = body_writer chan 0; trailer_writer } + in + (response, body) | _ -> Server.bad_request_response -let () = Eio_main.run @@ fun env -> Server.run ~port:8080 env app +let () = + let port = ref 8080 in + Arg.parse + [ ("-p", Arg.Set_int port, " Listening port number(8080 by default)") ] + ignore "An HTTP/1.1 server"; + + Eio_main.run @@ fun env -> Server.run ~port:!port env app diff --git a/cohttp-eio/tests/test_server.t b/cohttp-eio/tests/test_server.t new file mode 100644 index 0000000000..d993d7ef97 --- /dev/null +++ b/cohttp-eio/tests/test_server.t @@ -0,0 +1,113 @@ +Test GET success. + + $ port=8080 + $ test-server -p ${port} & + $ running_pid=$! + $ crlf << EOF | ncat localhost ${port} + > GET /get HTTP/1.1 + > + > EOF + HTTP/1.1 200 OK + content-length: 63 + content-type: text/plain; charset=UTF-8 + + meth: GET + resource: /get + version: HTTP/1.1 + headers: Header { } + $ kill ${running_pid} + +Test GET error. +The test should respond with error message since we are trying to read request body. HTTP 1.1 doesn't support request bodies in GET. + + $ port=8081 + $ test-server -p ${port} & + $ running_pid=$! + $ crlf << EOF | ncat localhost ${port} + > GET /get_error HTTP/1.1 + > + > EOF + HTTP/1.1 200 OK + content-length: 4 + content-type: text/plain; charset=UTF-8 + + PASS + $ kill ${running_pid} + +Test POST + + $ port=8082 + $ test-server -p ${port} & + $ running_pid=$! + $ crlf << EOF | ncat localhost ${port} + > POST /post HTTP/1.0 + > Content-Length:12 + > + > hello world! + > EOF + HTTP/1.1 200 OK + content-length: 100 + content-type: text/plain; charset=UTF-8 + + meth: POST + resource: /post + version: HTTP/1.0 + headers: Header { Content-Length = "12" } + + hello world! + $ kill ${running_pid} + +Test chunk request processing: +1. Test chunks +2. Test chunk extension parsing +3. Test chunk trailer header processing + + $ port=8083 + $ test-server -p ${port} & + $ running_pid=$! + $ crlf << EOF | ncat localhost ${port} + > POST /handle_chunk HTTP/1.1 + > Content-Type: text/plain + > Transfer-Encoding: chunked + > Trailer: Expires, Header1 + > + > 7;ext1=ext1_v;ext2=ext2_v;ext3 + > Mozilla + > 9 + > Developer + > 7 + > Network + > 0 + > Expires: Wed, 21 Oct 2015 07:28:00 GMT + > Header1: Header1 value text + > Header2: Header2 value text + > + > EOF + HTTP/1.1 200 OK + content-length: 354 + content-type: text/plain; charset=UTF-8 + + meth: POST + resource: /handle_chunk + version: HTTP/1.1 + headers: Header { + Content-Length = "23"; Header1 = "Header1 value text"; + Content-Type = "text/plain" } + + size: 7 + data: Mozilla + extensions: + name: ext1 + value: ext1_v; + name: ext2 + value: ext2_v; + name: ext3 + value: + size: 9 + data: Developer + extensions: + size: 7 + data: Network + extensions: + + $ kill ${running_pid} diff --git a/dune-project b/dune-project index dff414491c..525a36803a 100644 --- a/dune-project +++ b/dune-project @@ -341,11 +341,8 @@ should also be fine under Windows too. base-domains (eio (>= 0.4)) (eio_main :with-test) + (mdx :with-test) (uri :with-test) - cstruct - bigstringaf fmt - (mdx :with-test) - (eio_main :with-test) (http (= :version))))