Permalink
Browse files

bring async interface up to compilation status

  • Loading branch information...
1 parent f1d57a1 commit 2fc41705dc4c3c339e4ce796d925b1a2ed6202c0 @avsm committed Jan 30, 2013
Showing with 80 additions and 36 deletions.
  1. +52 −1 async/cohttp_async.ml
  2. +2 −2 cohttp.obuild
  3. +3 −3 cohttp/body.ml
  4. +14 −16 cohttp/client.ml
  5. +1 −1 cohttp/client.mli
  6. +2 −2 cohttp/make.ml
  7. +1 −1 cohttp/request.mli
  8. +1 −1 cohttp/response.mli
  9. +4 −9 lib_test/test_net_async.ml
View
53 async/cohttp_async.ml
@@ -52,14 +52,65 @@ module IO = struct
let write oc buf =
Writer.write oc buf;
+Printf.printf "%s%!" buf;
return ()
let write_line oc buf =
Writer.write oc buf;
Writer.write oc "\r\n";
+Printf.printf "%s\n%!" buf;
return ()
end
module Request = Cohttp.Request.Make(IO)
module Response = Cohttp.Response.Make(IO)
-module Client = Cohttp.Client.Make(IO)(Request)(Response)
+module Client = struct
+ include Cohttp.Client.Make(IO)(Request)(Response)
+
+ let call ?headers ?(chunked=false) ?body meth uri =
+ let host = Option.value (Uri.host uri) ~default:"localhost" in
+ match Uri_services.tcp_port_of_uri ~default:"http" uri with
+ |None -> return None
+ |Some port ->
+ let ivar = Ivar.create () in
+ let state = ref `Waiting_for_response in
+ let signal_handler s =
+ match !state,s with
+ |`Waiting_for_response, `Response resp ->
+ let rd,wr = Pipe.create () in
+ state := `Getting_body wr;
+ Ivar.fill ivar (resp, rd);
+ return ()
+ |`Getting_body wr, `Body buf ->
+ Pipe.write_when_ready wr ~f:(fun wrfn -> wrfn buf)
+ >>= (function
+ |`Closed -> (* Junk rest of the body *)
+ state := `Junking_body;
+ return ()
+ |`Ok _ -> return ())
+ |`Getting_body wr, `Body_end ->
+ state := `Complete;
+ Pipe.close wr;
+ return ()
+ |`Junking_body, `Body _ -> return ()
+ |`Junking_body, `Body_end ->
+ state := `Complete;
+ return ()
+ |`Waiting_for_response, `Body _
+ |`Waiting_for_response, `Body_end
+ |_, `Failure
+ |`Junking_body, `Response _
+ |`Getting_body _, `Response _ ->
+ (* TODO warning and non-fatal *)
+ assert false
+ |`Complete, _ -> return ()
+ in
+ Tcp.with_connection (Tcp.to_host_and_port host port)
+ (fun ic oc ->
+ (* Establish the remote HTTP connection *)
+ call ?headers ~chunked ?body meth uri signal_handler ic oc
+ >>= fun () ->
+ Ivar.read ivar >>= fun x ->
+ return (Some x)
+ )
+end
View
4 cohttp.obuild
@@ -28,7 +28,7 @@ Library cohttp
Library lwt
Path: lwt
Buildable: $lwt
- BuildDepends: lwt.unix, lwt, uri, cohttp, lwt.ssl, lwt.syntax
+ BuildDepends: lwt.unix, lwt, uri, cohttp, lwt.syntax
pp: camlp4o
Modules: Cohttp_lwt_unix, Cohttp_lwt, Cohttp_lwt_net, Cohttp_lwt_body, Cohttp_lwt_make
@@ -43,7 +43,7 @@ Library cohttp
Path: async
Buildable: $async
BuildDepends: uri, cohttp, async_core >= 108.07.00, async_unix, threads, async
- Modules: Cohttp_async_raw, Cohttp_async
+ Modules: Cohttp_async
Test parser
Path: lib_test
View
6 cohttp/body.ml
@@ -26,9 +26,9 @@ module Make (IO:Make.IO) = struct
let rec aux () =
TIO.read encoding ic
>>= function
- |Transfer.Done -> fn None; return ()
- |Transfer.Final_chunk b -> fn (Some b); fn None; return ()
- |Transfer.Chunk b -> fn (Some b); aux ()
+ |Transfer.Done -> fn None
+ |Transfer.Final_chunk b -> fn (Some b) >>= fun () -> fn None
+ |Transfer.Chunk b -> fn (Some b) >>= fun () -> aux ()
in aux ()
let write fn encoding oc =
View
30 cohttp/client.ml
@@ -35,26 +35,25 @@ module Make
Response.read ic
>>= function
|None ->
- signal `Failure;
- return ()
+ signal `Failure
|Some res -> begin
- signal (`Response res);
+ signal (`Response res) >>= fun () ->
match Response.has_body res with
|false ->
- signal `Body_end;
- return ()
+ signal `Body_end
|true ->
Response.read_body res
- (function
- |None -> signal `Body_end
- |Some b -> signal (`Body b)
- ) ic
+ (function
+ |None -> signal `Body_end
+ |Some b -> signal (`Body b)
+ ) ic
end
- let call ?headers ?(chunked=false) ?body meth uri signal ic oc =
+ let call ?headers ?(chunked=false) ?body meth uri (signal:signal_handler) ic oc =
match body with
|None ->
- let req = Request.make ~meth ?headers ~body uri in
+ let encoding = Transfer.Fixed 0 in
+ let req = Request.make ~meth ~encoding ?headers ~body uri in
Request.write req (fun _ -> None) oc >>= fun () ->
read_response signal ic
|Some body -> begin
@@ -65,17 +64,16 @@ module Make
read_response signal ic
|false ->
(* If chunked is not allowed, then call [body_fn] once insert length header *)
- let headers = match headers with |None -> Header.init () |Some h -> h in
match body () with
|None ->
- let headers = Header.add_transfer_encoding headers (Transfer.Fixed 0) in
- let req = Request.make ~meth ~headers ~body uri in
+ let encoding = Transfer.Fixed 0 in
+ let req = Request.make ~meth ~encoding ?headers ~body uri in
Request.write req body oc >>= fun () ->
read_response signal ic
|Some buf ->
let clen = String.length buf in
- let headers = Header.add_transfer_encoding headers (Transfer.Fixed clen) in
- let req = Request.make ~meth ~headers ~body uri in
+ let encoding = Transfer.Fixed clen in
+ let req = Request.make ~meth ~encoding ?headers ~body uri in
Request.write req body oc >>= fun () ->
read_response signal ic
end
View
2 cohttp/client.mli
@@ -28,7 +28,7 @@ module Make
| `Body_end
]
- type signal_handler = (input_signal -> unit)
+ type signal_handler = (input_signal -> unit IO.t)
val call :
?headers:Header.t ->
View
4 cohttp/make.ml
@@ -59,7 +59,7 @@ module type REQUEST = sig
val read : ic -> t option io
val has_body : t -> bool
- val read_body : t -> (string option -> unit) -> ic -> unit io
+ val read_body : t -> (string option -> unit io) -> ic -> unit io
val write : t -> (unit -> string option) -> oc -> unit io
end
@@ -79,7 +79,7 @@ module type RESPONSE = sig
val read : ic -> t option io
val has_body : t -> bool
- val read_body : t -> (string option -> unit) -> ic -> unit io
+ val read_body : t -> (string option -> unit io) -> ic -> unit io
val write : t -> (unit -> string option) -> oc -> unit io
end
View
2 cohttp/request.mli
@@ -40,7 +40,7 @@ module Make(IO:Make.IO) : sig
val read : ic -> t option io
val has_body : t -> bool
- val read_body : t -> (string option -> unit) -> ic -> unit io
+ val read_body : t -> (string option -> unit io) -> ic -> unit io
val write : t -> (unit -> string option) -> oc -> unit io
end
View
2 cohttp/response.mli
@@ -30,7 +30,7 @@ module Make(IO:Make.IO) : sig
val read: ic -> t option io
val has_body : t -> bool
- val read_body: t -> (string option -> unit) -> ic -> unit io
+ val read_body: t -> (string option -> unit io) -> ic -> unit io
val write : t -> (unit -> string option) -> oc -> unit io
end
View
13 lib_test/test_net_async.ml
@@ -24,26 +24,21 @@ let show_headers h =
let make_net_req () =
let headers = Cohttp.Header.of_list ["connection","close"] in
- let uri = Uri.of_string "http://anil.recoil.org/" in
- let res_fn b =
- match b with
- |None -> Printf.printf "end\n%!";
- |Some b -> Printf.printf "res: %s\n%!" b
- in
+ let uri = Uri.of_string "http://anil.recoil.org/index.html" in
let host = Option.value (Uri.host uri) ~default:"localhost" in
match Uri_services.tcp_port_of_uri ~default:"http" uri with
|None -> failwith "unable to resolve"
|Some port ->
Tcp.with_connection (Tcp.to_host_and_port host port)
(fun ic oc ->
- Client.call ~headers `GET uri res_fn ic oc
+ Client.call ~headers `GET uri
>>= function
|None ->
prerr_endline "<request failed>";
assert false
- |Some res ->
+ |Some (res, body) ->
show_headers (Response.headers res);
- Deferred.return ()
+ Pipe.iter body ~f:(fun b -> prerr_endline ("XX " ^ b); return ())
)
let test_cases =

0 comments on commit 2fc4170

Please sign in to comment.