From 2f0a313e9a52876cb2b7a34c1baa7567510f5c0a Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Wed, 4 Mar 2015 14:43:52 +0000 Subject: [PATCH 01/13] Simplify the Net signature which needs to be provided for lwt servers --- lwt/cohttp_lwt.ml | 8 +------- lwt/cohttp_lwt.mli | 7 +------ lwt/cohttp_lwt_unix.ml | 7 +++---- lwt/cohttp_lwt_unix.mli | 1 - 4 files changed, 5 insertions(+), 18 deletions(-) diff --git a/lwt/cohttp_lwt.ml b/lwt/cohttp_lwt.ml index fa1b02d25d..15c9cf2797 100644 --- a/lwt/cohttp_lwt.ml +++ b/lwt/cohttp_lwt.ml @@ -219,9 +219,6 @@ module type Server = sig module Request : Request module Response : Response - type ctx with sexp_of - val default_ctx : ctx - type conn = IO.conn * Cohttp.Connection.t type t @@ -268,14 +265,11 @@ end module Make_server(IO:IO) (Request:Request with module IO=IO) (Response:Response with module IO=IO) - (Net:Net with module IO=IO) = struct += struct module IO = IO module Request = Request module Response = Response - type ctx = Net.ctx with sexp_of - let default_ctx = Net.default_ctx - type conn = IO.conn * Cohttp.Connection.t type t = { diff --git a/lwt/cohttp_lwt.mli b/lwt/cohttp_lwt.mli index 8809508a38..64d980b0bf 100644 --- a/lwt/cohttp_lwt.mli +++ b/lwt/cohttp_lwt.mli @@ -163,9 +163,6 @@ module type Server = sig module Request : Request module Response : Response - type ctx with sexp_of - val default_ctx : ctx - type conn = IO.conn * Cohttp.Connection.t type t @@ -225,8 +222,6 @@ module Make_server (IO:IO) (Request:Request with module IO=IO) (Response:Response with module IO=IO) - (Net:Net with module IO = IO) : - Server with module IO = IO + : Server with module IO = IO and module Request = Request and module Response = Response - and type ctx = Net.ctx diff --git a/lwt/cohttp_lwt_unix.ml b/lwt/cohttp_lwt_unix.ml index 268bb1b682..8a6982e35b 100644 --- a/lwt/cohttp_lwt_unix.ml +++ b/lwt/cohttp_lwt_unix.ml @@ -37,8 +37,8 @@ module Client = struct let custom_ctx = Cohttp_lwt_unix_net.custom_ctx end -module Server_core = Cohttp_lwt.Make_server - (Cohttp_lwt_unix_io)(Request)(Response)(Cohttp_lwt_unix_net) +module Server_core = + Cohttp_lwt.Make_server (Cohttp_lwt_unix_io)(Request)(Response) module Server = struct include Server_core @@ -86,7 +86,7 @@ module Server = struct let body = Printexc.to_string exn in respond_error ~status:`Internal_server_error ~body () - let create ?timeout ?stop ?(ctx=default_ctx) ?(mode=`TCP (`Port 8080)) spec = + let create ?timeout ?stop ?(ctx=Cohttp_lwt_unix_net.default_ctx) ?(mode=`TCP (`Port 8080)) spec = Conduit_lwt_unix.serve ?timeout ?stop ~ctx:ctx.Cohttp_lwt_unix_net.ctx ~mode (fun conn ic oc -> (callback spec) conn ic oc) end @@ -96,7 +96,6 @@ module type S = sig include Cohttp_lwt.Server with module IO = Cohttp_lwt_unix_io and module Request = Request and module Response = Response - and type ctx = Cohttp_lwt_unix_net.ctx val resolve_file : docroot:string -> uri:Uri.t -> string diff --git a/lwt/cohttp_lwt_unix.mli b/lwt/cohttp_lwt_unix.mli index 99e368ecc8..4d393175a6 100644 --- a/lwt/cohttp_lwt_unix.mli +++ b/lwt/cohttp_lwt_unix.mli @@ -63,7 +63,6 @@ module type S = sig include Cohttp_lwt.Server with module IO = Cohttp_lwt_unix_io and module Request = Request and module Response = Response - and type ctx = Cohttp_lwt_unix_net.ctx val resolve_file : docroot:string -> uri:Uri.t -> string From 151902884cde7c6be9aa7ca6c26a8e42673a224b Mon Sep 17 00:00:00 2001 From: Trevor Summers Smith Date: Wed, 11 Mar 2015 10:09:45 -0400 Subject: [PATCH 02/13] Extend async file server example to run in http or https mode --- bin/cohttp_server_async.ml | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/bin/cohttp_server_async.ml b/bin/cohttp_server_async.ml index 59c71f9888..aa454d71e8 100644 --- a/bin/cohttp_server_async.ml +++ b/bin/cohttp_server_async.ml @@ -87,9 +87,17 @@ let rec handler ~info ~docroot ~verbose ~index ~body sock req = end ) +let determine_mode cert_file_path key_file_path = + (* Determines if the server runs in http or https *) + match (cert_file_path, key_file_path) with + | (Some c, Some k) -> `OpenSSL (`Crt_file_path c, `Key_file_path k) + | (None, None) -> `TCP + | _ -> failwith "Error must specify both cert and key" -let start_server docroot port host index verbose () = - printf "Listening for HTTP requests on: %s %d\n%!" host port; +let start_server docroot port host index verbose cert_file key_file () = + let mode = determine_mode cert_file key_file in + let mode_str = (match mode with `OpenSSL _ -> "HTTPS" | `TCP -> "HTTP") in + printf "Listening for %s requests on: %s %d\n%!" mode_str host port; let info = sprintf "Served by Cohttp/Async listening on %s:%d" host port in Unix.Inet_addr.of_string_or_getbyname host >>= fun host -> @@ -100,13 +108,14 @@ let start_server docroot port host index verbose () = in Server.create ~on_handler_error:`Ignore + ~mode:(determine_mode cert_file key_file) listen_on (handler ~info ~docroot ~index ~verbose) >>= fun _ -> never () let _ = Command.async_basic - ~summary:"Serve the local directory contents via HTTP" + ~summary:"Serve the local directory contents via HTTP or HTTPS" Command.Spec.( empty +> anon (maybe_with_default "." ("docroot" %: string)) @@ -114,5 +123,7 @@ let _ = +> flag "-s" (optional_with_default "0.0.0.0" string) ~doc:"address IP address to listen on" +> flag "-i" (optional_with_default "index.html" string) ~doc:"file Name of index file in directory" +> flag "-v" (optional_with_default false bool) ~doc:" Verbose logging output to console" + +> flag "-cert-file" (optional file) ~doc:"File of cert for https" + +> flag "-key-file" (optional file) ~doc:"File of private key for https" ) start_server |> Command.run From bbf5df7532abf9d418e0f804ec5cca0be6dcaefb Mon Sep 17 00:00:00 2001 From: Josh Allmann Date: Sat, 21 Mar 2015 19:22:46 -0700 Subject: [PATCH 03/13] Lwt_unix_io: Split large reads. With the Lwt backend, reads hang if trying to fetch more than Sys.max_string_length due to a byte allocation failure in Lwt_io.read. Problematic for large uploads, etc. Upper layer callers (eg, Transfer_io) seem to handle recombining these split reads without any issues. --- lwt/cohttp_lwt_unix_io.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/lwt/cohttp_lwt_unix_io.ml b/lwt/cohttp_lwt_unix_io.ml index 4a57b07b86..711ec40624 100644 --- a/lwt/cohttp_lwt_unix_io.ml +++ b/lwt/cohttp_lwt_unix_io.ml @@ -37,6 +37,7 @@ let read_line ic = Lwt_io.read_line_opt ic let read ic count = + let count = min count Sys.max_string_length in if !CD.debug_active then (lwt buf = try_lwt Lwt_io.read ~count ic From 31e63f6171f088e7b94a029d5e201f5a5c816995 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sun, 22 Mar 2015 14:00:03 +0000 Subject: [PATCH 04/13] Fix two parser test cases to reflect new behaviour * Parsing a request will end up with `//host/bar` instead of hardcoding `http://` now. * A `GET` request cannot have a body (and hence transfer encoding headers), so the manual request parser uses `POST` now. --- lib_test/test_parser.ml | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/lib_test/test_parser.ml b/lib_test/test_parser.ml index e4bf35f3bc..57a821ce9a 100644 --- a/lib_test/test_parser.ml +++ b/lib_test/test_parser.ml @@ -101,6 +101,14 @@ let oc_of_buffer buf = Lwt_io.of_bytes ~mode:Lwt_io.output buf open Lwt +let pp_diff fmt (a,b) = + Format.pp_print_string fmt "Expected:"; + Format.pp_print_newline fmt (); + Format.pp_print_string fmt a; + Format.pp_print_string fmt "Result:"; + Format.pp_print_newline fmt (); + Format.pp_print_string fmt b + let p_sexp f x = x |> f |> Sexplib.Sexp.to_string let basic_req_parse () = @@ -112,7 +120,7 @@ let basic_req_parse () = assert_equal (Cohttp.Request.version req) `HTTP_1_1; assert_equal (CU.Request.meth req) `GET; assert_equal ~printer:(fun x -> x) - "http://www.example.com/index.html" + "//www.example.com/index.html" (Uri.to_string (CU.Request.uri req)); return () | _ -> assert false @@ -239,7 +247,7 @@ let write_req expected req = Request.write (fun writer -> Cohttp_lwt_body.write_body (Request.write_body writer) body ) req oc >>= fun () -> - assert_equal expected (get_substring oc buf); + assert_equal ~pp_diff expected (get_substring oc buf); (* Use the high-level write API. This also tests that req is immutable * by re-using it *) let buf = Lwt_bytes.create 4096 in @@ -251,8 +259,8 @@ let write_req expected req = let make_simple_req () = let open Cohttp in let open Cohttp_lwt_unix in - let expected = "GET /foo/bar HTTP/1.1\r\nfoo: bar\r\nhost: localhost\r\ntransfer-encoding: chunked\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n" in - let req = Request.make ~encoding:Transfer.Chunked ~headers:(Header.init_with "Foo" "bar") (Uri.of_string "/foo/bar") in + let expected = "POST /foo/bar HTTP/1.1\r\nfoo: bar\r\nhost: localhost\r\ntransfer-encoding: chunked\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n" in + let req = Request.make ~encoding:Transfer.Chunked ~meth:`POST ~headers:(Header.init_with "Foo" "bar") (Uri.of_string "/foo/bar") in write_req expected req let mutate_simple_req () = From c47260064b8e4e9015d5f617a553e12b0c799253 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sun, 22 Mar 2015 14:02:38 +0000 Subject: [PATCH 05/13] test async_ssl as well --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 59a3b99e14..247f7ec309 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,3 +4,4 @@ script: bash -ex .travis-opam.sh env: - PACKAGE="cohttp" OCAML_VERSION=4.01 DEPOPTS="async lwt js_of_ocaml" POST_INSTALL_HOOK="opam install github cowabloga" - PACKAGE="cohttp" OCAML_VERSION=latest DEPOPTS="async lwt js_of_ocaml" POST_INSTALL_HOOK="opam install github cowabloga" + - PACKAGE="cohttp" OCAML_VERSION=latest DEPOPTS="async_ssl" POST_INSTALL_HOOK="opam install github cowabloga" From 73234ae1d70e567b1cc1c149eed0f9010c7668bb Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sun, 22 Mar 2015 14:03:57 +0000 Subject: [PATCH 06/13] fix use of deprecated String.create with Bytes.create --- lib_test/test_parser.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib_test/test_parser.ml b/lib_test/test_parser.ml index 57a821ce9a..0eb4075bfe 100644 --- a/lib_test/test_parser.ml +++ b/lib_test/test_parser.ml @@ -233,7 +233,7 @@ let res_chunked_parse () = (* Extract the substring of the byte buffer that has been written to *) let get_substring oc buf = let len = Int64.to_int (Lwt_io.position oc) in - let b = String.create len in + let b = Bytes.create len in Lwt_bytes.blit_to_bytes buf 0 b 0 len; b From 6ed070b26f09b940612fea67989454130ffee0d5 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sun, 22 Mar 2015 14:05:09 +0000 Subject: [PATCH 07/13] sync CHANGES --- CHANGES | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES b/CHANGES index bcbdbf0a38..f685e5efdf 100644 --- a/CHANGES +++ b/CHANGES @@ -3,6 +3,9 @@ Compatibility breaking interface changes: * [lwt] Fix types in `post_form` to be a `string * string list` instead of a `Header.t` (#257) +* Simplify the `Net` signature which needs to be provided for Lwt servers + to not be required. Only the Lwt client needs a `Net` functor argument + to make outgoing connections. (#274) New features and bug fixes: * Copy basic auth from `Uri.userinfo` into the Authorization header From e239d4f16b14b7ec02506f50d555d9400c14ae3c Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sun, 22 Mar 2015 18:42:36 +0000 Subject: [PATCH 08/13] sync CHANGES --- CHANGES | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES b/CHANGES index f685e5efdf..517e7633e7 100644 --- a/CHANGES +++ b/CHANGES @@ -26,6 +26,9 @@ New features and bug fixes: specify the `content-length` or `transfer-encoding` headers (#268). * `cohttp_server_lwt` and `cohttp_server_async` now include sizes in directory listing titles +* With the Lwt backend, `read` hangs if trying to fetch more than + `Sys.max_string_length` (which can be triggered on 32-bit platforms). + Read only a maximum that fits into a string (#282). 0.15.2 (2015-02-15): * When transfer encoding is unknown, read until EOF when body size is unknown. (#241) From 20c92a2561fb192667d3b4cfec99bf9f6d3f0993 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sun, 22 Mar 2015 18:43:27 +0000 Subject: [PATCH 09/13] opam: depend explicitly on base-bytes via @rgrinberg --- opam | 1 + 1 file changed, 1 insertion(+) diff --git a/opam b/opam index 1cd4beef16..9b82349d0f 100644 --- a/opam +++ b/opam @@ -30,6 +30,7 @@ install: [make "PREFIX=%{prefix}%" "install"] remove: [["ocamlfind" "remove" "cohttp"]] depends: [ + "base-bytes" "ocamlfind" {build} "cmdliner" {build & >= "0.9.4"} "re" From 3a8b923cc44235cc0b03e4bd0577c0f250d70f4a Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sun, 22 Mar 2015 18:52:53 +0000 Subject: [PATCH 10/13] update changes with more --- CHANGES | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/CHANGES b/CHANGES index 517e7633e7..30af772dbb 100644 --- a/CHANGES +++ b/CHANGES @@ -8,6 +8,7 @@ Compatibility breaking interface changes: to make outgoing connections. (#274) New features and bug fixes: +* Add a `cohttp-lwt-proxy` to act as an HTTP proxy. (#248) * Copy basic auth from `Uri.userinfo` into the Authorization header for HTTP requests. (#255) * Install binaries via an OPAM `.install` file to ensure that they are @@ -26,6 +27,10 @@ New features and bug fixes: specify the `content-length` or `transfer-encoding` headers (#268). * `cohttp_server_lwt` and `cohttp_server_async` now include sizes in directory listing titles +* Add `Header.add_multi` to initialise a header structure with multiple + fields more efficiently (#272). +* Expose `IO.ic` and `IO.oc` types for `Cohttp_async` (#271). +* Skip empty body chunks in `Transfer_io.write` (#270). * With the Lwt backend, `read` hangs if trying to fetch more than `Sys.max_string_length` (which can be triggered on 32-bit platforms). Read only a maximum that fits into a string (#282). From 163af62bc4ec80d47746c0ae032117933f6dfb90 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sun, 22 Mar 2015 18:53:37 +0000 Subject: [PATCH 11/13] stamp a date in CHANGES --- CHANGES | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGES b/CHANGES index 30af772dbb..70a1d55a8e 100644 --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,4 @@ -0.16.0 (trunk): +0.16.0 (2015-03-23): Compatibility breaking interface changes: * [lwt] Fix types in `post_form` to be a `string * string list` instead From 651cbfeda3aecd1c7283e0b5ba21277e8465617e Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sun, 22 Mar 2015 18:59:04 +0000 Subject: [PATCH 12/13] tweak the error message for cohttp_server_async and bad ssl flags --- bin/cohttp_server_async.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/bin/cohttp_server_async.ml b/bin/cohttp_server_async.ml index aa454d71e8..1a477031dd 100644 --- a/bin/cohttp_server_async.ml +++ b/bin/cohttp_server_async.ml @@ -90,9 +90,9 @@ let rec handler ~info ~docroot ~verbose ~index ~body sock req = let determine_mode cert_file_path key_file_path = (* Determines if the server runs in http or https *) match (cert_file_path, key_file_path) with - | (Some c, Some k) -> `OpenSSL (`Crt_file_path c, `Key_file_path k) - | (None, None) -> `TCP - | _ -> failwith "Error must specify both cert and key" + | Some c, Some k -> `OpenSSL (`Crt_file_path c, `Key_file_path k) + | None, None -> `TCP + | _ -> failwith "Error: must specify both certificate and key for HTTPS" let start_server docroot port host index verbose cert_file key_file () = let mode = determine_mode cert_file key_file in From d6ef5ef2d18c76265e21a06d9ccbae1ec4c4a15d Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sun, 22 Mar 2015 19:00:01 +0000 Subject: [PATCH 13/13] sync CHANGES --- CHANGES | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGES b/CHANGES index 70a1d55a8e..204d78a8dc 100644 --- a/CHANGES +++ b/CHANGES @@ -9,6 +9,7 @@ Compatibility breaking interface changes: New features and bug fixes: * Add a `cohttp-lwt-proxy` to act as an HTTP proxy. (#248) +* Extend `cohttp-server-async` file server to work with HTTPS (#277). * Copy basic auth from `Uri.userinfo` into the Authorization header for HTTP requests. (#255) * Install binaries via an OPAM `.install` file to ensure that they are