Merge pull request #196 from avsm/master

Resp and Reader/Writer changes to 0.12.0

CHANGES

@@ -2,9 +2,10 @@
 
 Compatibility breaking interface changes:
 
-* Rename `Cohttp.Auth.t` to `Cohttp.Auth.resp` to make it match the
-  existing `Cohttp.Auth.req` type.  Also expose an `Other` variant
-  to make it more extensible for unknown authentication types.
+* Rename `Cohttp.Auth.t` to `Cohttp.Auth.credential` and `Cohttp.Auth.req`
+  to `Cohttp.Auth.challenge`.  Also expose an `Other` variant
+  to make it more extensible for unknown authentication types. The
+  `Cohttp.Auth` functions using these types have also been renamed accordingly.
 * Rename `Cohttp.Transfer.encoding_to_string` to `string_of_encoding`
   for consistency with the rest of Cohttp's APIs.
 * The `has_body` function in the Request and Response modules now
@@ -14,6 +15,10 @@ Compatibility breaking interface changes:
  `resolve_local_file` in `Cohttp_async` and `Cohttp_lwt` now always
   percent-decode paths (#157)
 * Remove the `Cohttp_lwt.Server.server` type synonym to `t`.
+* When reading data from a HTTP body stream using the `Fixed` encoding,
+  we need to maintain state (bytes remaining) so we know when to finish.
+  The `Cohttp.Request` and `Cohttp.Response` interfaces now expose a
+  `reader` and `writer` types to track this safely.
 * Port module interfaces to the latest Conduit (0.6.0+) API.
 * Cohttp requires OCaml 4.01.0 or higher now.
 

async/cohttp_async.ml

@@ -113,14 +113,20 @@ module Body = struct
   let write body response wr =
     match body with
     | `Empty -> return ()
-    | `String s -> Response.write_body response wr s
+    | `String s ->
+      Response.write (fun writer ->
+        Response.write_body writer s
+      ) response wr
     | `Pipe p ->
       Pipe.iter p ~f:(fun buf ->
-          Response.write_body response wr buf
+        Response.write (fun writer ->
+          Response.write_body writer buf
           >>= fun () ->
           match Response.flush response with
           | true -> Writer.flushed wr
-          | false -> return ())
+          | false -> return ()
+        ) response wr
+      )
 
   let map t ~f =
     match t with
@@ -156,7 +162,10 @@ module Client = struct
     (* Write request down the wire *)
     Request.write_header req oc
     >>= fun () ->
-    Deferred.List.iter ~f:(fun b -> Request.write_body req oc b) body_bufs
+    Request.write (fun writer ->
+      Deferred.List.iter ~f:(fun b ->
+        Request.write_body writer b) body_bufs
+    ) req oc
     >>= fun () ->
     Request.write_footer req oc
     >>= fun () ->
@@ -165,13 +174,14 @@ module Client = struct
     | `Eof -> raise (Failure "Connection closed by remote host")
     | `Invalid reason -> raise (Failure reason)
     | `Ok res ->
-      (* Build a response pipe for the body *)
-      let rd = pipe_of_body (Response.read_body_chunk res) ic oc in
-      don't_wait_for (
-        Pipe.closed rd >>= fun () ->
-        Deferred.all_ignore [Reader.close ic; Writer.close oc]
-      );
-      return (res, `Pipe rd)
+        (* Build a response pipe for the body *)
+        let reader = Response.make_body_reader res ic in
+        let rd = pipe_of_body (fun ic -> Response.read_body_chunk reader) ic oc in
+        don't_wait_for (
+          Pipe.closed rd >>= fun () ->
+          Deferred.all_ignore [Reader.close ic; Writer.close oc]
+        );
+        return (res, `Pipe rd)
 
   let get ?interrupt ?headers uri =
     call ?interrupt ?headers ~chunked:false `GET uri
@@ -215,8 +225,9 @@ module Server = struct
     (* TODO maybe attempt to read body *)
     | `No | `Unknown -> `Empty
     | `Yes -> (* Create a Pipe for the body *)
-      let read_chunk = Request.read_body_chunk req in
-      `Pipe (pipe_of_body read_chunk rd wr)
+      let reader = Request.make_body_reader req rd in
+      `Pipe (pipe_of_body (fun ic ->
+        Request.read_body_chunk reader) rd wr)
 
   let drain_body = function
     | `Empty | `String _ -> return ()

cohttp/auth.ml

@@ -18,29 +18,29 @@
 open Sexplib.Std
 open Printf
 
-type req = [
+type challenge = [
  | `Basic of string (* realm *)
 ] with sexp
 
-type resp = [
+type credential = [
  | `Basic of string * string (* username, password *)
  | `Other of string
 ]  with sexp
 
-let string_of_resp (resp:resp) =
-  match resp with
+let string_of_credential (cred:credential) =
+  match cred with
   | `Basic (user, pass) ->
     "Basic " ^ (Base64.encode (sprintf "%s:%s" user pass))
   | `Other buf -> buf
 
-let resp_of_string (buf:string) : resp =
+let credential_of_string (buf:string) : credential =
   try
     let b64 = Scanf.sscanf buf "Basic %s" (fun b -> b) in
     match Stringext.split ~on:':' (Base64.decode b64) ~max:2 with
     |[user;pass] -> `Basic (user,pass)
     |_ -> `Other buf
   with _ -> `Other buf
 
-let string_of_req (ty:req) =
+let string_of_challenge (ty:challenge) =
   match ty with
   |`Basic realm -> sprintf "Basic realm=\"%s\"" realm

cohttp/auth.mli

@@ -15,34 +15,37 @@
  *
  *)
 
-(** HTTP Authentication header parsing and generation *)
+(** HTTP Authentication and Authorization header parsing and generation *)
 
-(** HTTP authentication request types *)
-type req = [
- | `Basic of string (* Basic authorization with a realm *)
+(** HTTP authentication challenge types *)
+type challenge = [
+ | `Basic of string (** Basic authentication within a realm *)
 ] with sexp
 
-(** HTTP authentication response types *)
-type resp = [
-  | `Basic of string * string (** Basic authorization with a username and password *)
-  | `Other of string (* An unknown response header that will be passed straight through to the HTTP layer *)
+(** HTTP authorization credential types *)
+type credential = [
+  | `Basic of string * string
+  (** Basic authorization with a username and password *)
+  | `Other of string
+  (** An unknown credential type that will be passed straight through
+      to the application layer *)
 ] with sexp
 
-(** [string_of_resp] converts the {!resp} to a string compatible
-    with the HTTP/1.1 wire format for responses *)
-val string_of_resp : resp -> string
+(** [string_of_credential] converts the {!credential} to a string compatible
+    with the HTTP/1.1 wire format for authorization credentials ("responses") *)
+val string_of_credential : credential -> string
 
-(** [resp_of_string resp] converts a HTTP response to an authorization
-    request into a {!resp}.  If the response is not recognized, [None]
-    is returned. *)
-val resp_of_string : string -> resp
+(** [credential_of_string cred_s] converts an HTTP response to an
+    authentication challenge into a {!credential}.  If the credential is not
+    recognized, [`Other cred_s] is returned. *)
+val credential_of_string : string -> credential
 
-(** [string_of_req req] converts the {!req} to a string compatible with
-    the HTTP/1.1 wire format for authorization requests.
+(** [string_of_challenge challenge] converts the {!challenge} to a string
+    compatible with the HTTP/1.1 wire format for authentication challenges.
 
-    For example, a {!Basic} request with realm ["foo"] will be 
+    For example, a [`Basic] challenge with realm ["foo"] will be
     marshalled to ["Basic realm=foo"], which can then be combined
     with a [www-authenticate] HTTP header and sent back to the
     client.  There is a helper function {!Header.add_authorization_req}
     that does just this. *)
-val string_of_req : req -> string
+val string_of_challenge : challenge -> string

cohttp/header.ml

@@ -177,16 +177,16 @@ let add_transfer_encoding headers enc =
   |Unknown, Fixed len -> add headers "content-length" (Int64.to_string len)
   |Unknown, Unknown -> headers
 
-let add_authorization_req headers req =
-  add headers "www-authenticate" (Auth.string_of_req req)
+let add_authorization_req headers challenge =
+  add headers "www-authenticate" (Auth.string_of_challenge challenge)
 
-let add_authorization headers auth =
-  add headers "authorization" (Auth.string_of_resp auth)
+let add_authorization headers cred =
+  add headers "authorization" (Auth.string_of_credential cred)
 
 let get_authorization headers =
   match get headers "authorization" with
   |None -> None
-  |Some v -> Some (Auth.resp_of_string v)
+  |Some v -> Some (Auth.credential_of_string v)
 
 let is_form headers =
   get_media_type headers = (Some "application/x-www-form-urlencoded")

cohttp/header.mli

@@ -68,9 +68,9 @@ val get_acceptable_encodings : t -> Accept.encoding Accept.qlist
 val get_acceptable_languages : t -> Accept.language Accept.qlist
 val get_transfer_encoding : t -> Transfer.encoding
 val add_transfer_encoding : t -> Transfer.encoding -> t
-val add_authorization : t -> Auth.resp -> t
-val get_authorization : t -> Auth.resp option
-val add_authorization_req : t -> Auth.req -> t
+val add_authorization : t -> Auth.credential -> t
+val get_authorization : t -> Auth.credential option
+val add_authorization_req : t -> Auth.challenge -> t
 val is_form : t -> bool
 
 val user_agent : string

cohttp/header_io.ml

@@ -44,6 +44,7 @@ module Make(IO : S.IO) = struct
   let parse_form headers ic =
     (* If the form is query-encoded, then extract those parameters also *)
     let encoding = Header.get_transfer_encoding headers in
-    Transfer_IO.to_string encoding ic >>= fun body ->
+    let reader = Transfer_IO.make_reader encoding ic in
+    Transfer_IO.to_string reader >>= fun body ->
     return (Uri.query_of_encoded body)
 end

cohttp/request.ml

@@ -66,6 +66,8 @@ module Make(IO : S.IO) = struct
   module IO = IO
   module Header_IO = Header_io.Make(IO)
   module Transfer_IO = Transfer_io.Make(IO)
+  type reader = Transfer_IO.reader
+  type writer = Transfer_IO.writer
 
   open IO
 
@@ -101,7 +103,9 @@ module Make(IO : S.IO) = struct
       return (`Ok { headers; meth; uri; version; encoding })
 
   let has_body req = Transfer.has_body req.encoding
-  let read_body_chunk req = Transfer_IO.read req.encoding
+
+  let make_body_reader req ic = Transfer_IO.make_reader req.encoding ic
+  let read_body_chunk = Transfer_IO.read
 
   let write_header req oc =
    let fst_line = Printf.sprintf "%s %s %s\r\n" (Code.string_of_method req.meth)
@@ -117,8 +121,8 @@ module Make(IO : S.IO) = struct
     iter (IO.write oc) (Header.to_lines headers) >>= fun _ ->
     IO.write oc "\r\n"
 
-  let write_body req oc buf =
-    Transfer_IO.write req.encoding oc buf
+  let make_body_writer req oc = Transfer_IO.make_writer req.encoding oc
+  let write_body = Transfer_IO.write
 
   let write_footer req oc =
     match req.encoding with
@@ -129,7 +133,8 @@ module Make(IO : S.IO) = struct
 
   let write write_body req oc =
     write_header req oc >>= fun () ->
-    write_body req oc >>= fun () ->
+    let writer = make_body_writer req oc in
+    write_body writer >>= fun () ->
     write_footer req oc
 
   let is_form req = Header.is_form req.headers

cohttp/response.ml

@@ -35,6 +35,8 @@ module Make(IO : S.IO) = struct
   module IO = IO
   module Header_IO = Header_io.Make(IO)
   module Transfer_IO = Transfer_io.Make(IO)
+  type reader = Transfer_IO.reader
+  type writer = Transfer_IO.writer
 
   open IO
 
@@ -63,7 +65,8 @@ module Make(IO : S.IO) = struct
        return (`Ok { encoding; headers; version; status; flush })
 
   let has_body {encoding} = Transfer.has_body encoding
-  let read_body_chunk {encoding} ic = Transfer_IO.read encoding ic
+  let make_body_reader {encoding} ic = Transfer_IO.make_reader encoding ic
+  let read_body_chunk = Transfer_IO.read
 
   let write_header res oc =
     write oc (Printf.sprintf "%s %s\r\n" (Code.string_of_version res.version) 
@@ -72,8 +75,8 @@ module Make(IO : S.IO) = struct
     iter (IO.write oc) (Header.to_lines headers) >>= fun () ->
     IO.write oc "\r\n"
 
-  let write_body {encoding} oc buf =
-    Transfer_IO.write encoding oc buf
+  let make_body_writer {encoding} oc = Transfer_IO.make_writer encoding oc
+  let write_body = Transfer_IO.write
 
   let write_footer {encoding} oc =
     match encoding with
@@ -84,7 +87,8 @@ module Make(IO : S.IO) = struct
 
   let write fn req oc =
     write_header req oc >>= fun () ->
-    fn req oc >>= fun () ->
+    let writer = make_body_writer req oc in
+    fn writer >>= fun () ->
     write_footer req oc
 
   let is_form req = Header.is_form req.headers

cohttp/s.mli

@@ -36,19 +36,23 @@ end
 
 module type Http_io = sig
   type t
+  type reader
+  type writer
   module IO : IO
 
   val read : IO.ic -> [ `Eof | `Invalid of string | `Ok of t ] IO.t
   val has_body : t -> [ `No | `Unknown | `Yes ]
-  val read_body_chunk : t -> IO.ic -> Transfer.chunk IO.t
+  val make_body_reader : t -> IO.ic -> reader
+  val read_body_chunk : reader -> Transfer.chunk IO.t
 
   val is_form: t -> bool
   val read_form : t -> IO.ic -> (string * string list) list IO.t
 
   val write_header : t -> IO.oc -> unit IO.t
-  val write_body : t -> IO.oc -> string -> unit IO.t
+  val make_body_writer : t -> IO.oc -> writer
+  val write_body : writer -> string -> unit IO.t
   val write_footer : t -> IO.oc -> unit IO.t
-  val write : (t -> IO.oc -> unit IO.t) -> t -> IO.oc -> unit IO.t
+  val write : (writer -> unit IO.t) -> t -> IO.oc -> unit IO.t
 end
 
 module type Request = sig

cohttp/transfer_io.ml

@@ -19,9 +19,11 @@ open Transfer
 
 module Make(IO : S.IO) = struct
   open IO
+  type reader = unit -> Transfer.chunk IO.t
+  type writer = string -> unit IO.t
 
   module Chunked = struct
-    let read ic =
+    let read ic () =
       (* Read chunk size *)
       read_line ic >>= function
       |Some chunk_size_hex -> begin
@@ -53,7 +55,7 @@ module Make(IO : S.IO) = struct
   end
 
   module Fixed = struct
-    let read ~remaining ic =
+    let read ~remaining ic () =
       (* TODO functorise string to a bigbuffer *)
       match !remaining with
       |0L -> return Done
@@ -74,29 +76,32 @@ module Make(IO : S.IO) = struct
   module Unknown = struct
     (* If we have no idea, then read one chunk and return it.
      * TODO should this be a read with an explicit timeout? *)
-    let read ic =
+    let read ic () =
       read ic 16384 >>= fun buf -> return (Final_chunk buf)
 
     let write oc buf =
       write oc buf
   end
 
-  let read =
+  let make_reader =
     function
     | Chunked -> Chunked.read
     | Fixed len -> Fixed.read ~remaining:(ref len)
     | Unknown -> Unknown.read
 
-  let write =
+  let make_writer =
     function
     | Chunked -> Chunked.write
     | Fixed len -> Fixed.write
     | Unknown -> Unknown.write
 
-  let to_string encoding ic =
+  let read reader = reader ()
+  let write writer buf = writer buf
+
+  let to_string reader =
     let buf = Buffer.create 256 in
     let rec loop () =
-      read encoding ic >>= function
+      read reader >>= function
       |Chunk c ->
         Buffer.add_string buf c;
         loop ()