Skip to content

Commit

Permalink
Update code base to be compatible with new async/core
Browse files Browse the repository at this point in the history
  • Loading branch information
rgrinberg committed Mar 25, 2018
1 parent b30207c commit bc340a6
Show file tree
Hide file tree
Showing 22 changed files with 152 additions and 118 deletions.
4 changes: 4 additions & 0 deletions cohttp-async.opam
Expand Up @@ -21,6 +21,10 @@ build: [
build-test: [["jbuilder" "runtest" "-p" name "-j" jobs]]
depends: [
"jbuilder" {build & >= "1.0+beta10"}
"async_kernel" {>= "v0.11.0"}
"async_unix" {>= "v0.11.0"}
"async_extra" {>= "v0.11.0"}
"base" {>= "v0.11.0"}
"cohttp"
"conduit-async"
"magic-mime"
Expand Down
25 changes: 13 additions & 12 deletions cohttp-async/bin/cohttp_curl_async.ml
Expand Up @@ -14,8 +14,8 @@
*
}}}*)

open Core
open Async
open Base
open Async_kernel
open Cohttp_async

let show_headers h =
Expand All @@ -31,21 +31,22 @@ let make_net_req uri meth' body () =
show_headers (Cohttp.Response.headers res);
body
|> Body.to_pipe
|> Pipe.iter ~f:(fun b -> print_string b; return ())
|> Pipe.iter ~f:(fun b -> Caml.Pervasives.print_string b; return ())

let _ =
(* enable logging to stdout *)
Fmt_tty.setup_std_outputs ();
Logs.set_level @@ Some Logs.Debug;
Logs.set_reporter (Logs_fmt.reporter ());
let open Command.Spec in
Command.async_spec ~summary:"Fetch URL and print it"
(empty
+> anon ("url" %: string)
+> flag "-X" (optional_with_default "GET" string)
~doc:" Set HTTP method"
+> flag "data-binary" (optional_with_default "" string)
~doc:" Data to send when using POST"
let open Async_extra.Command in
async_spec ~summary:"Fetch URL and print it"
Spec.(
empty
+> anon ("url" %: string)
+> flag "-X" (optional_with_default "GET" string)
~doc:" Set HTTP method"
+> flag "data-binary" (optional_with_default "" string)
~doc:" Data to send when using POST"
)
make_net_req
|> Command.run
|> run
15 changes: 8 additions & 7 deletions cohttp-async/bin/cohttp_server_async.ml
Expand Up @@ -15,8 +15,9 @@
*
}}}*)

open Core
open Async
open Base
open Async_kernel
open Async_unix

open Cohttp_async
open Cohttp_server
Expand All @@ -40,7 +41,7 @@ let serve ~info ~docroot ~index uri path =
(* Get a list of current files and map to HTML *)
| `Directory -> begin
let path_len = String.length path in
if path_len <> 0 && path.[path_len - 1] <> '/'
if Int.(path_len <> 0) && Char.(path.[path_len - 1] <> '/')
then Server.respond_with_redirect (Uri.with_path uri (path^"/"))
(* Check if the index file exists *)
else Sys.file_exists (file_name / index)
Expand Down Expand Up @@ -72,7 +73,7 @@ let serve ~info ~docroot ~index uri path =
| Error exn ->
begin match Monitor.extract_exn exn with
| Unix.Unix_error (Unix.ENOENT, "stat", p) ->
if p = ("((filename "^file_name^"))") (* Really? *)
if String.equal p ("((filename "^file_name^"))") (* Really? *)
then Server.respond_string ~status:`Not_found
(html_of_not_found path info)
else raise exn
Expand Down Expand Up @@ -114,18 +115,18 @@ let start_server docroot port index cert_file key_file verbose () =
let mode = determine_mode cert_file key_file in
let mode_str = (match mode with `OpenSSL _ -> "HTTPS" | `TCP -> "HTTP") in
Logs.info (fun f -> f "Listening for %s requests on %d" mode_str port);
let info = sprintf "Served by Cohttp/Async listening on %d" port in
let info = Printf.sprintf "Served by Cohttp/Async listening on %d" port in
Server.create
~on_handler_error:(`Call (fun addr exn ->
Logs.err (fun f -> f "Error from %s" (Socket.Address.to_string addr));
Logs.err (fun f -> f "%s" @@ Exn.to_string exn)))
~mode
(Tcp.Where_to_listen.of_port port)
(Async_extra.Tcp.Where_to_listen.of_port port)
(handler ~info ~docroot ~index) >>= fun _serv ->
Deferred.never ()

let () =
let open Command in
let open Async_extra.Command in
run @@
async_spec ~summary:"Serve the local directory contents via HTTP or HTTPS"
Spec.(
Expand Down
10 changes: 9 additions & 1 deletion cohttp-async/bin/jbuild
Expand Up @@ -3,5 +3,13 @@
(executables
((names (cohttp_curl_async cohttp_server_async))
(package cohttp-async)
(libraries (cohttp-async cohttp_server fmt.tty))
(libraries
(cohttp-async
async_kernel
async_extra
async_unix
base
cohttp
cohttp_server
fmt.tty))
(public_names (cohttp-curl-async cohttp-server-async))))
4 changes: 2 additions & 2 deletions cohttp-async/src/body.mli
@@ -1,5 +1,5 @@
open! Core
open! Async
open! Base
open! Async_kernel
open! Cohttp

type t = [
Expand Down
4 changes: 2 additions & 2 deletions cohttp-async/src/body_raw.ml
@@ -1,5 +1,5 @@
open Core
open Async
open Base
open Async_kernel
module B = Cohttp.Body

type t = [
Expand Down
11 changes: 6 additions & 5 deletions cohttp-async/src/client.ml
@@ -1,5 +1,6 @@
open Core
open Async
open Base
open Async_kernel
open Async_unix

module Request = struct
include Cohttp.Request
Expand Down Expand Up @@ -66,7 +67,7 @@ let request ?interrupt ?ssl_config ?uri ?(body=`Empty) req =
read_request ic >>| fun (resp, body) ->
don't_wait_for (
Pipe.closed body >>= fun () ->
Deferred.all_ignore [Reader.close ic; Writer.close oc]);
Deferred.all_unit [Reader.close ic; Writer.close oc]);
(resp, `Pipe body)) >>= begin function
| Ok res -> return res
| Error e ->
Expand All @@ -82,7 +83,7 @@ let callv ?interrupt ?ssl_config uri reqs =
try_with (fun () ->
reqs
|> Pipe.iter ~f:(fun (req, body) ->
incr reqs_c;
Int.incr reqs_c;
Request.write (fun w -> Body_raw.write_body Request.write_body body w)
req oc)
|> don't_wait_for;
Expand All @@ -93,7 +94,7 @@ let callv ?interrupt ?ssl_config uri reqs =
return `Eof
else
ic |> read_request >>| fun (resp, body) ->
incr resp_c;
Int.incr resp_c;
last_body_drained := Pipe.closed body;
`Ok (resp, `Pipe body)
) in
Expand Down
45 changes: 21 additions & 24 deletions cohttp-async/src/client.mli
@@ -1,102 +1,99 @@
open! Core
open! Async

(** Send an HTTP request with an arbitrary body
The request is sent as-is. *)
val request :
?interrupt:unit Deferred.t ->
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.Ssl.config ->
?uri:Uri.t ->
?body:Body.t ->
Cohttp.Request.t ->
(Cohttp.Response.t * Body.t) Deferred.t
(Cohttp.Response.t * Body.t) Async_kernel.Deferred.t

(** Send an HTTP request with arbitrary method and a body
Infers the transfer encoding *)
val call :
?interrupt:unit Deferred.t ->
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.Ssl.config ->
?headers:Cohttp.Header.t ->
?chunked:bool ->
?body:Body.t ->
Cohttp.Code.meth ->
Uri.t ->
(Cohttp.Response.t * Body.t) Deferred.t
(Cohttp.Response.t * Body.t) Async_kernel.Deferred.t

val callv :
?interrupt:unit Deferred.t ->
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.Ssl.config ->
Uri.t ->
(Cohttp.Request.t * Body.t) Pipe.Reader.t ->
(Cohttp.Response.t * Body.t) Pipe.Reader.t Deferred.t
(Cohttp.Request.t * Body.t) Async_kernel.Pipe.Reader.t ->
(Cohttp.Response.t * Body.t) Async_kernel.Pipe.Reader.t Async_kernel.Deferred.t

(** Send an HTTP GET request *)
val get :
?interrupt:unit Deferred.t ->
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.Ssl.config ->
?headers:Cohttp.Header.t ->
Uri.t ->
(Cohttp.Response.t * Body.t) Deferred.t
(Cohttp.Response.t * Body.t) Async_kernel.Deferred.t

(** Send an HTTP HEAD request *)
val head :
?interrupt:unit Deferred.t ->
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.Ssl.config ->
?headers:Cohttp.Header.t ->
Uri.t ->
Cohttp.Response.t Deferred.t
Cohttp.Response.t Async_kernel.Deferred.t

(** Send an HTTP DELETE request *)
val delete :
?interrupt:unit Deferred.t ->
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.Ssl.config ->
?headers:Cohttp.Header.t ->
?chunked:bool ->
?body:Body.t ->
Uri.t ->
(Cohttp.Response.t * Body.t) Deferred.t
(Cohttp.Response.t * Body.t) Async_kernel.Deferred.t

(** Send an HTTP POST request.
[chunked] encoding is off by default as not many servers support it
*)
val post :
?interrupt:unit Deferred.t ->
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.Ssl.config ->
?headers:Cohttp.Header.t ->
?chunked:bool ->
?body:Body.t ->
Uri.t ->
(Cohttp.Response.t * Body.t) Deferred.t
(Cohttp.Response.t * Body.t) Async_kernel.Deferred.t

(** Send an HTTP PUT request.
[chunked] encoding is off by default as not many servers support it
*)
val put :
?interrupt:unit Deferred.t ->
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.Ssl.config ->
?headers:Cohttp.Header.t ->
?chunked:bool ->
?body:Body.t ->
Uri.t ->
(Response.t * Body.t) Deferred.t
(Response.t * Body.t) Async_kernel.Deferred.t

(** Send an HTTP PATCH request.
[chunked] encoding is off by default as not many servers support it
*)
val patch :
?interrupt:unit Deferred.t ->
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.Ssl.config ->
?headers:Cohttp.Header.t ->
?chunked:bool ->
?body:Body.t ->
Uri.t ->
(Response.t * Body.t) Deferred.t
(Response.t * Body.t) Async_kernel.Deferred.t

(** Send an HTTP POST request in form format *)
val post_form:
?interrupt:unit Deferred.t ->
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.Ssl.config ->
?headers:Cohttp.Header.t ->
params:(string * string list) list ->
Uri.t ->
(Response.t * Body.t) Deferred.t
(Response.t * Body.t) Async_kernel.Deferred.t
20 changes: 12 additions & 8 deletions cohttp-async/src/io.ml
Expand Up @@ -14,8 +14,12 @@
*
}}}*)

open Core
open Async
open Base
open Async_kernel

module Writer = Async_unix.Writer
module Reader = Async_unix.Reader
module Format = Caml.Format

let log_src_name = "cohttp.async.io"
let src = Logs.Src.create log_src_name ~doc:"Cohttp Async IO module"
Expand All @@ -31,13 +35,13 @@ let default_reporter () =
m ) in
let report src _level ~over k msgf =
let k _ =
if Logs.Src.name src = log_src_name then (
if String.equal (Logs.Src.name src) log_src_name then (
Writer.write (Lazy.force Writer.stderr) (fmtr_flush ())
);
over ();
k () in
msgf @@ fun ?header:_ ?tags:_ fmt ->
Format.kfprintf k fmtr ("@[" ^^ fmt ^^ "@]@.")
Format.kfprintf k fmtr Caml.("@[" ^^ fmt ^^ "@]@.")
in
{ Logs.report }

Expand All @@ -52,10 +56,10 @@ let set_log = lazy (
)

let check_debug norm_fn debug_fn =
match Sys.getenv "COHTTP_DEBUG" with
| Some _ ->
match Caml.Sys.getenv "COHTTP_DEBUG" with
| _ ->
Lazy.force set_log; debug_fn
| None -> norm_fn
| exception Caml.Not_found -> norm_fn

type 'a t = 'a Deferred.t
let (>>=) = Deferred.(>>=)
Expand Down Expand Up @@ -93,7 +97,7 @@ let write =
return ())
(fun oc buf ->
Log.debug
(fun fmt -> fmt "%4d >>> %s" (Pid.to_int (Unix.getpid ())) buf);
(fun fmt -> fmt "%4d >>> %s" (Unix.getpid ()) buf);
Writer.write oc buf;
return ())

Expand Down
8 changes: 3 additions & 5 deletions cohttp-async/src/io.mli
Expand Up @@ -13,9 +13,7 @@
* PERFORMANCE OF THIS SOFTWARE.
}}}*)

open Async

include Cohttp.S.IO
with type 'a t = 'a Deferred.t
and type ic = Reader.t
and type oc = Writer.t
with type 'a t = 'a Async_kernel.Deferred.t
and type ic = Async_unix.Reader.t
and type oc = Async_unix.Writer.t
5 changes: 4 additions & 1 deletion cohttp-async/src/jbuild
Expand Up @@ -6,8 +6,11 @@
(public_name cohttp-async)
(libraries
(logs.fmt
base
fmt
async
async_unix
async_kernel
async_extra
uri
uri.services
ipaddr.unix
Expand Down
6 changes: 4 additions & 2 deletions cohttp-async/src/server.ml
@@ -1,5 +1,7 @@
open Core
open Async
open Base
open Async_kernel
open Async_unix
open Async_extra

module Request = struct
include Cohttp.Request
Expand Down

0 comments on commit bc340a6

Please sign in to comment.