Merge pull request #879 from bikallem/eio-client

cohttp-eio Client module

.ocamlformat

@@ -1,4 +1,3 @@
-version=0.21.0
 profile=conventional
 break-infix=fit-or-vertical
 parse-docstrings=true

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)

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}
 ]

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

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"

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)

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)

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,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)
@@ -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 -> ()