diff --git a/.travis-ci.sh b/.travis-ci.sh index c3c77e7b43..019d35a235 100755 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -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 ;; diff --git a/_oasis b/_oasis index 26ccaf963e..6145a07e50 100644 --- a/_oasis +++ b/_oasis @@ -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 diff --git a/_tags b/_tags index d445675a8f..56a097110f 100644 --- a/_tags +++ b/_tags @@ -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 @@ -62,6 +62,7 @@ # Library cohttp_async "async/cohttp_async.cmxs": use_cohttp_async : pkg_async +: pkg_async_ssl : pkg_fieldslib : pkg_fieldslib.syntax : pkg_re @@ -234,6 +235,7 @@ : custom # Executable test_net_async : pkg_async +: pkg_async_ssl : pkg_fieldslib : pkg_fieldslib.syntax : pkg_oUnit @@ -248,6 +250,7 @@ : custom # Executable test_net_async_http10 : pkg_async +: pkg_async_ssl : pkg_fieldslib : pkg_fieldslib.syntax : pkg_oUnit @@ -262,6 +265,7 @@ : custom # Executable test_net_async_multi_get : pkg_async +: pkg_async_ssl : pkg_fieldslib : pkg_fieldslib.syntax : pkg_oUnit @@ -276,6 +280,7 @@ : custom # Executable test_net_async_server : pkg_async +: pkg_async_ssl : pkg_fieldslib : pkg_fieldslib.syntax : pkg_oUnit @@ -288,6 +293,7 @@ : use_cohttp : use_cohttp_async : pkg_async +: pkg_async_ssl : pkg_fieldslib : pkg_fieldslib.syntax : pkg_oUnit @@ -302,6 +308,7 @@ : custom # Executable cohttp-server : pkg_async +: pkg_async_ssl : pkg_fieldslib : pkg_fieldslib.syntax : pkg_re @@ -313,6 +320,7 @@ : use_cohttp : use_cohttp_async : pkg_async +: pkg_async_ssl : pkg_fieldslib : pkg_fieldslib.syntax : pkg_re @@ -326,6 +334,7 @@ : custom # Executable async-hello-world : pkg_async +: pkg_async_ssl : pkg_fieldslib : pkg_fieldslib.syntax : pkg_re @@ -337,6 +346,7 @@ : use_cohttp : use_cohttp_async : pkg_async +: pkg_async_ssl : pkg_fieldslib : pkg_fieldslib.syntax : pkg_re diff --git a/async/cohttp_async.ml b/async/cohttp_async.ml index 441166d009..ad64ae02a2 100644 --- a/async/cohttp_async.ml +++ b/async/cohttp_async.ml @@ -17,6 +17,7 @@ open Core.Std open Async.Std +open Async_ssl.Std module IO = struct let check_debug norm_fn debug_fn = @@ -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 @@ -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 ()) @@ -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 @@ -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 @@ -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 @@ -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 @@ -182,12 +196,12 @@ 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 = @@ -195,12 +209,12 @@ module Client = struct | [],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 @@ -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 @@ -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 @@ -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 + ~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) @@ -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 } diff --git a/async/cohttp_async.mli b/async/cohttp_async.mli index 399543e9f1..e6384ec932 100644 --- a/async/cohttp_async.mli +++ b/async/cohttp_async.mli @@ -48,6 +48,7 @@ module Client : sig (** Send an HTTP GET request *) val get : ?interrupt:unit Deferred.t -> + ?ssl:bool -> ?headers:Cohttp.Header.t -> Uri.t -> (Response.t * Body.t) Deferred.t @@ -55,6 +56,7 @@ module Client : sig (** Send an HTTP HEAD request *) val head : ?interrupt:unit Deferred.t -> + ?ssl:bool -> ?headers:Cohttp.Header.t -> Uri.t -> Response.t Deferred.t @@ -62,6 +64,7 @@ module Client : sig (** Send an HTTP DELETE request *) val delete : ?interrupt:unit Deferred.t -> + ?ssl:bool -> ?headers:Cohttp.Header.t -> Uri.t -> (Response.t * Body.t) Deferred.t @@ -71,6 +74,7 @@ module Client : sig *) val post : ?interrupt:unit Deferred.t -> + ?ssl:bool -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -82,6 +86,7 @@ module Client : sig *) val put : ?interrupt:unit Deferred.t -> + ?ssl:bool -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -93,6 +98,7 @@ module Client : sig *) val patch : ?interrupt:unit Deferred.t -> + ?ssl:bool -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -102,6 +108,7 @@ module Client : sig (** Send an HTTP request with arbitrary method and a body *) val call : ?interrupt:unit Deferred.t -> + ?ssl:bool -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -131,26 +138,26 @@ module Server : sig (** Respond with a [string] Pipe that provides the response string Pipe.Reader.t. @param code Default is HTTP 200 `OK *) - val respond_with_pipe : + val respond_with_pipe : ?flush:bool -> - ?headers:Cohttp.Header.t -> ?code:Cohttp.Code.status_code -> + ?headers:Cohttp.Header.t -> ?code:Cohttp.Code.status_code -> string Pipe.Reader.t -> response Deferred.t - (** Respond with a static [string] + (** Respond with a static [string] @param code Default is HTTP 200 `OK *) - val respond_with_string : + val respond_with_string : ?flush:bool -> - ?headers:Cohttp.Header.t -> ?code:Cohttp.Code.status_code -> + ?headers:Cohttp.Header.t -> ?code:Cohttp.Code.status_code -> string -> response Deferred.t (** Respond with a redirect to an absolute [uri] @param uri Absolute URI to redirect the client to *) - val respond_with_redirect : + val respond_with_redirect : ?headers:Cohttp.Header.t -> Uri.t -> response Deferred.t (** Respond with file contents, and [error_string Pipe.Reader.t] if the file isn't found *) - val respond_with_file : + val respond_with_file : ?flush:bool -> ?headers:Cohttp.Header.t -> ?error_body:string -> string -> response Deferred.t @@ -158,6 +165,7 @@ module Server : sig (** Build a HTTP server, based on the [Tcp.Server] interface *) val create : ?max_connections:int -> + ?ssl:([ `Crt_file_path of string ] * [ `Key_file_path of string ]) -> ?max_pending_connections:int -> ?buffer_age_limit: Writer.buffer_age_limit -> ?on_handler_error:[ `Call of 'address -> exn -> unit diff --git a/cohttp/META b/cohttp/META index 9deb429011..b136b9ac88 100644 --- a/cohttp/META +++ b/cohttp/META @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: bbe259e7a5077f3361c8a1638c27ee80) +# DO NOT EDIT (digest: 73064ff1914e993971bfbda4c43d61bc) version = "0.10.0" description = "HTTP library for Lwt, Async and Mirage" requires = @@ -34,7 +34,7 @@ package "lwt" ( package "async" ( version = "0.10.0" description = "HTTP library for Lwt, Async and Mirage" - requires = "uri cohttp threads async" + requires = "uri cohttp threads async async_ssl" archive(byte) = "cohttp_async.cma" archive(byte, plugin) = "cohttp_async.cma" archive(native) = "cohttp_async.cmxa" diff --git a/setup.ml b/setup.ml index b3be1303d2..0e666d0ec4 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: fec8be193e42e0c91b3b12cb12fb3f0f) *) +(* DO NOT EDIT (digest: d473c44219b88ae8323e5a89837f183d) *) (* Regenerated by OASIS v0.4.2 Visit http://oasis.forge.ocamlcore.org for more information and @@ -7144,7 +7144,8 @@ let setup_t = FindlibPackage ("uri", None); InternalLibrary "cohttp"; FindlibPackage ("threads", None); - FindlibPackage ("async", None) + FindlibPackage ("async", None); + FindlibPackage ("async_ssl", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -8003,7 +8004,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.2"; - oasis_digest = Some "«\133¬\029\0004\001Î\"¦'\145\rh]U"; + oasis_digest = Some "\234r\128,\248c$'5~\221=<\200\171\203"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -8011,6 +8012,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 8015 "setup.ml" +# 8016 "setup.ml" (* OASIS_STOP *) let () = setup ();;