Skip to content

Support the newly-released Async_ssl #102

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
avsm merged 4 commits into from
Mar 25, 2014
Merged

Support the newly-released Async_ssl #102

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
8242af2
use async_ssl
cgaebel Mar 21, 2014
7e1f68c
poke travis
cgaebel Mar 21, 2014
6e79414
poke travis
cgaebel Mar 21, 2014
4af11ec
code review fixup
cgaebel Mar 24, 2014
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion .travis-ci.sh
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
OPAM_DEPENDS="lwt async ssl uri re"
OPAM_DEPENDS="lwt async async_ssl ssl uri re"

case "$OCAML_VERSION,$OPAM_VERSION" in
4.00.1,1.0.0) ppa=avsm/ocaml40+opam10 ;;
Expand Down
2 changes: 1 addition & 1 deletion _oasis
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -56,7 +56,7 @@ Library cohttp_async
Path: async
Findlibname: async
FindlibParent: cohttp
BuildDepends: uri, cohttp, threads, async
BuildDepends: uri, cohttp, threads, async, async_ssl
Modules: Cohttp_async

Document cohttp
Expand Down
12 changes: 11 additions & 1 deletion _tags
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 94b391cd2b40dcfc668217d672bfe48a)
# DO NOT EDIT (digest: e97b0f440e37c91188c29722805bd766)
# Ignore VCS directories, you can use the same kind of rule outside
# OASIS_START/STOP if you want to exclude directories that contains
# useless stuff for the build process
Expand Down Expand Up @@ -62,6 +62,7 @@
# Library cohttp_async
"async/cohttp_async.cmxs": use_cohttp_async
<async/*.ml{,i}>: pkg_async
<async/*.ml{,i}>: pkg_async_ssl
<async/*.ml{,i}>: pkg_fieldslib
<async/*.ml{,i}>: pkg_fieldslib.syntax
<async/*.ml{,i}>: pkg_re
Expand Down Expand Up @@ -234,6 +235,7 @@
<lib_test/test_net_lwt_client_and_server.{native,byte}>: custom
# Executable test_net_async
<lib_test/test_net_async.{native,byte}>: pkg_async
<lib_test/test_net_async.{native,byte}>: pkg_async_ssl
<lib_test/test_net_async.{native,byte}>: pkg_fieldslib
<lib_test/test_net_async.{native,byte}>: pkg_fieldslib.syntax
<lib_test/test_net_async.{native,byte}>: pkg_oUnit
Expand All @@ -248,6 +250,7 @@
<lib_test/test_net_async.{native,byte}>: custom
# Executable test_net_async_http10
<lib_test/test_net_async_http10.{native,byte}>: pkg_async
<lib_test/test_net_async_http10.{native,byte}>: pkg_async_ssl
<lib_test/test_net_async_http10.{native,byte}>: pkg_fieldslib
<lib_test/test_net_async_http10.{native,byte}>: pkg_fieldslib.syntax
<lib_test/test_net_async_http10.{native,byte}>: pkg_oUnit
Expand All @@ -262,6 +265,7 @@
<lib_test/test_net_async_http10.{native,byte}>: custom
# Executable test_net_async_multi_get
<lib_test/test_net_async_multi_get.{native,byte}>: pkg_async
<lib_test/test_net_async_multi_get.{native,byte}>: pkg_async_ssl
<lib_test/test_net_async_multi_get.{native,byte}>: pkg_fieldslib
<lib_test/test_net_async_multi_get.{native,byte}>: pkg_fieldslib.syntax
<lib_test/test_net_async_multi_get.{native,byte}>: pkg_oUnit
Expand All @@ -276,6 +280,7 @@
<lib_test/test_net_async_multi_get.{native,byte}>: custom
# Executable test_net_async_server
<lib_test/test_net_async_server.{native,byte}>: pkg_async
<lib_test/test_net_async_server.{native,byte}>: pkg_async_ssl
<lib_test/test_net_async_server.{native,byte}>: pkg_fieldslib
<lib_test/test_net_async_server.{native,byte}>: pkg_fieldslib.syntax
<lib_test/test_net_async_server.{native,byte}>: pkg_oUnit
Expand All @@ -288,6 +293,7 @@
<lib_test/test_net_async_server.{native,byte}>: use_cohttp
<lib_test/test_net_async_server.{native,byte}>: use_cohttp_async
<lib_test/*.ml{,i}>: pkg_async
<lib_test/*.ml{,i}>: pkg_async_ssl
<lib_test/*.ml{,i}>: pkg_fieldslib
<lib_test/*.ml{,i}>: pkg_fieldslib.syntax
<lib_test/*.ml{,i}>: pkg_oUnit
Expand All @@ -302,6 +308,7 @@
<lib_test/test_net_async_server.{native,byte}>: custom
# Executable cohttp-server
<bin/cohttp_server_async.{native,byte}>: pkg_async
<bin/cohttp_server_async.{native,byte}>: pkg_async_ssl
<bin/cohttp_server_async.{native,byte}>: pkg_fieldslib
<bin/cohttp_server_async.{native,byte}>: pkg_fieldslib.syntax
<bin/cohttp_server_async.{native,byte}>: pkg_re
Expand All @@ -313,6 +320,7 @@
<bin/cohttp_server_async.{native,byte}>: use_cohttp
<bin/cohttp_server_async.{native,byte}>: use_cohttp_async
<bin/*.ml{,i}>: pkg_async
<bin/*.ml{,i}>: pkg_async_ssl
<bin/*.ml{,i}>: pkg_fieldslib
<bin/*.ml{,i}>: pkg_fieldslib.syntax
<bin/*.ml{,i}>: pkg_re
Expand All @@ -326,6 +334,7 @@
<bin/cohttp_server_async.{native,byte}>: custom
# Executable async-hello-world
<examples/async/hello_world.{native,byte}>: pkg_async
<examples/async/hello_world.{native,byte}>: pkg_async_ssl
<examples/async/hello_world.{native,byte}>: pkg_fieldslib
<examples/async/hello_world.{native,byte}>: pkg_fieldslib.syntax
<examples/async/hello_world.{native,byte}>: pkg_re
Expand All @@ -337,6 +346,7 @@
<examples/async/hello_world.{native,byte}>: use_cohttp
<examples/async/hello_world.{native,byte}>: use_cohttp_async
<examples/async/*.ml{,i}>: pkg_async
<examples/async/*.ml{,i}>: pkg_async_ssl
<examples/async/*.ml{,i}>: pkg_fieldslib
<examples/async/*.ml{,i}>: pkg_fieldslib.syntax
<examples/async/*.ml{,i}>: pkg_re
Expand Down
96 changes: 65 additions & 31 deletions async/cohttp_async.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,7 @@

open Core.Std
open Async.Std
open Async_ssl.Std

module IO = struct
let check_debug norm_fn debug_fn =
Expand All @@ -34,7 +35,7 @@ module IO = struct
type oc = Writer.t

let iter fn x =
Deferred.List.iter x ~f:fn
Deferred.List.iter x ~f:fn

let read_line =
check_debug
Expand Down Expand Up @@ -66,11 +67,11 @@ module IO = struct

let write =
check_debug
(fun oc buf ->
Writer.write oc buf;
(fun oc buf ->
Writer.write oc buf;
return ())
(fun oc buf ->
eprintf "\n%4d >>> %s" (Pid.to_int (Unix.getpid ())) buf;
(fun oc buf ->
eprintf "\n%4d >>> %s" (Pid.to_int (Unix.getpid ())) buf;
Writer.write oc buf;
return ())

Expand All @@ -93,11 +94,24 @@ module IO = struct
end

module Net = struct
let connect ?interrupt uri =
let connect ?interrupt ?(ssl=false) uri =
let host = Option.value (Uri.host uri) ~default:"localhost" in
match Uri_services.tcp_port_of_uri ~default:"http" uri with
|None -> raise (Failure "Net.connect") (* TODO proper exception *)
|Some port -> Tcp.connect ?interrupt (Tcp.to_host_and_port host port)
|Some port ->
Tcp.connect ?interrupt (Tcp.to_host_and_port host port)
>>= fun (socket, net_to_ssl, ssl_to_net) ->
match ssl with
| false -> return (socket, net_to_ssl, ssl_to_net)
| true ->
let net_to_ssl = Reader.pipe net_to_ssl in
let ssl_to_net = Writer.pipe ssl_to_net in
let app_to_ssl, app_wr = Pipe.create () in
let app_rd, ssl_to_app = Pipe.create () in
don't_wait_for (Ssl.client ~app_to_ssl ~ssl_to_app ~net_to_ssl ~ssl_to_net ());
Reader.of_pipe (Info.of_string "cohttp_client_reader") app_rd >>= fun app_rd ->
Writer.of_pipe (Info.of_string "cohttp_client_writer") app_wr >>| fun (app_wr,_) ->
socket, app_rd, app_wr
end

module Request = struct
Expand All @@ -116,7 +130,7 @@ let pipe_of_body read_chunk ic oc =
let finished =
Deferred.repeat_until_finished ()
(fun () ->
read_chunk ic
read_chunk ic
>>= function
| Chunk buf ->
begin
Expand All @@ -126,7 +140,7 @@ let pipe_of_body read_chunk ic oc =
| `Ok _ -> `Repeat ()
end
| Final_chunk buf ->
Pipe.write_when_ready wr ~f:(fun wrfn -> wrfn buf)
Pipe.write_when_ready wr ~f:(fun wrfn -> wrfn buf)
>>| fun _ -> `Finished ()
| Done -> return (`Finished ())
) in
Expand Down Expand Up @@ -173,7 +187,7 @@ module Body = struct
| `String s -> Response.write_body response wr s
| `Pipe p ->
Pipe.iter p ~f:(fun buf ->
Response.write_body response wr buf
Response.write_body response wr buf
>>= fun () ->
match Response.flush response with
| true -> Writer.flushed wr
Expand All @@ -182,25 +196,25 @@ end

module Client = struct

let call ?interrupt ?headers ?(chunked=false) ?(body=`Empty) meth uri =
let call ?interrupt ?ssl ?headers ?(chunked=false) ?(body=`Empty) meth uri =
(* Convert the body Pipe to a list of chunks. *)
(match body with
| `Empty -> return []
| `String s -> return [s]
| `Pipe body -> Pipe.to_list body
| `Pipe body -> Pipe.to_list body
) >>= fun body_bufs ->
(* Figure out an appropriate transfer encoding *)
let req =
match body_bufs,chunked with
| [],true (* Dont used chunked encoding with an empty body *)
| _,false -> (* If we dont want chunked, calculate a content length *)
let body_length = List.fold ~init:0 ~f:(fun a b -> String.length b + a) body_bufs in
Request.make_for_client ?headers ~chunked:false ~body_length meth uri
Request.make_for_client ?headers ~chunked:false ~body_length meth uri
| _,true -> (* Use chunked encoding if there is a body *)
Request.make_for_client ?headers ~chunked meth uri
in
(* Connect to the remote side *)
Net.connect ?interrupt uri
Net.connect ?interrupt ?ssl uri
>>= fun (_,ic,oc) ->
(* Write request down the wire *)
Request.write_header req oc
Expand All @@ -218,10 +232,10 @@ module Client = struct
let rd = pipe_of_body (Response.read_body_chunk res) ic oc in
return (res, `Pipe rd)

let get ?interrupt ?headers uri =
let get ?interrupt ?ssl ?headers uri =
call ?interrupt ?headers ~chunked:false `GET uri

let head ?interrupt ?headers uri =
let head ?interrupt ?ssl ?headers uri =
call ?interrupt ?headers ~chunked:false `HEAD uri
>>= begin fun (res, body) ->
(match body with
Expand All @@ -230,17 +244,17 @@ module Client = struct
return res
end

let post ?interrupt ?headers ?(chunked=false) ?body uri =
call ?interrupt ?headers ~chunked ?body `POST uri
let post ?interrupt ?ssl ?headers ?(chunked=false) ?body uri =
call ?interrupt ?ssl ?headers ~chunked ?body `POST uri

let put ?interrupt ?headers ?(chunked=false) ?body uri =
call ?interrupt ?headers ~chunked ?body `PUT uri
let put ?interrupt ?ssl ?headers ?(chunked=false) ?body uri =
call ?interrupt ?ssl ?headers ~chunked ?body `PUT uri

let patch ?interrupt ?headers ?(chunked=false) ?body uri =
call ?interrupt ?headers ~chunked ?body `PATCH uri
let patch ?interrupt ?ssl ?headers ?(chunked=false) ?body uri =
call ?interrupt ?ssl ?headers ~chunked ?body `PATCH uri

let delete ?interrupt ?headers uri =
call ?interrupt ?headers ~chunked:false `DELETE uri
let delete ?interrupt ?ssl ?headers uri =
call ?interrupt ?ssl ?headers ~chunked:false `DELETE uri
end

module Server = struct
Expand All @@ -262,12 +276,32 @@ module Server = struct
let read_chunk = Request.read_body_chunk req in
`Pipe (pipe_of_body read_chunk rd wr)

let handle_client handle_request sock rd wr =
let handle_client ?ssl handle_request sock rd wr =
begin match ssl with
| None -> return (rd, wr)
| Some (`Crt_file_path crt_file, `Key_file_path key_file) ->
let net_to_ssl = Reader.pipe rd in
let ssl_to_net = Writer.pipe wr in
let app_to_ssl, app_wr = Pipe.create () in
let app_rd, ssl_to_app = Pipe.create () in
Ssl.server
~crt_file
Copy link
Copy Markdown
Member

@avsm avsm Mar 24, 2014

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It would be nice to extend Ssl.server to take a string as well a filename, to help implementations minimize their FS dependencies if they need to

Copy link
Copy Markdown
Contributor Author

@cgaebel cgaebel Mar 24, 2014

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't know how to make SSL do this. Do you?

Copy link
Copy Markdown
Member

@avsm avsm Mar 24, 2014

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ah, good old OpenSSL. I guess those bindings would have to create a temporary file behind the scenes. Not worth the trouble at this stage...

Copy link
Copy Markdown
Contributor Author

@cgaebel cgaebel Mar 24, 2014

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Even the man pages were broken on my system. Needless to say, it was an "interesting" project. ;)

~key_file
~app_to_ssl
~ssl_to_app
~net_to_ssl
~ssl_to_net
() |> don't_wait_for;
Reader.of_pipe (Info.of_string "cohttp_server_reader") app_rd >>= fun app_rd ->
Writer.of_pipe (Info.of_string "cohttp_server_writer") app_wr >>| fun (app_wr,_) ->
app_rd, app_wr
end
>>= fun (reader, writer) ->
let requests_pipe =
Reader.read_all rd (fun rd ->
Request.read rd
Request.read rd
>>| function
| `Eof | `Invalid _ -> `Eof
| `Eof | `Invalid _ -> `Eof
| `Ok req ->
let body = read_body req rd wr in
if not (Request.is_keep_alive req)
Expand Down Expand Up @@ -333,11 +367,11 @@ module Server = struct
|Error exn -> respond_with_string ~code:`Not_found error_body


let create ?max_connections ?max_pending_connections
let create ?max_connections ?ssl ?max_pending_connections
?buffer_age_limit ?on_handler_error where_to_listen handle_request =
Tcp.Server.create ?max_connections ?max_pending_connections
?buffer_age_limit ?on_handler_error
where_to_listen (handle_client handle_request)
Tcp.Server.create ?max_connections ?max_pending_connections
?buffer_age_limit ?on_handler_error
where_to_listen (handle_client ?ssl handle_request)
>>| fun server ->
{ server }

Expand Down
Loading