Skip to content

Commit

Permalink
Merge pull request #879 from bikallem/eio-client
Browse files Browse the repository at this point in the history
cohttp-eio Client module
  • Loading branch information
mseri authored Aug 27, 2022
2 parents 3086be9 + a4df4ae commit ce5f271
Show file tree
Hide file tree
Showing 26 changed files with 842 additions and 343 deletions.
1 change: 0 additions & 1 deletion .ocamlformat
Original file line number Diff line number Diff line change
@@ -1,4 +1,3 @@
version=0.21.0
profile=conventional
break-infix=fit-or-vertical
parse-docstrings=true
1 change: 1 addition & 0 deletions CHANGES.md
Original file line number Diff line number Diff line change
@@ -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)
Expand Down
5 changes: 1 addition & 4 deletions cohttp-eio.opam
Original file line number Diff line number Diff line change
Expand Up @@ -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}
]
Expand Down
13 changes: 13 additions & 0 deletions cohttp-eio/examples/client1.ml
Original file line number Diff line number Diff line change
@@ -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
19 changes: 19 additions & 0 deletions cohttp-eio/examples/client_timeout.ml
Original file line number Diff line number Diff line change
@@ -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"
20 changes: 20 additions & 0 deletions cohttp-eio/examples/docker_client.ml
Original file line number Diff line number Diff line change
@@ -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)
6 changes: 3 additions & 3 deletions cohttp-eio/examples/dune
Original file line number Diff line number Diff line change
@@ -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)
Expand Down
100 changes: 44 additions & 56 deletions cohttp-eio/src/body.ml
Original file line number Diff line number Diff line change
@@ -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 = {
Expand Down Expand Up @@ -44,29 +45,17 @@ 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
| 'A' .. 'F' -> true
| _ -> 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)
Expand All @@ -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);
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 =
Expand All @@ -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 -> ()
Loading

0 comments on commit ce5f271

Please sign in to comment.