From 132414567411dc743901e85ca439789d431df5ab Mon Sep 17 00:00:00 2001 From: Sora Morimoto Date: Fri, 5 Feb 2021 14:49:16 +0900 Subject: [PATCH 1/5] Disable dune cache in GitHub Actions workflow Signed-off-by: Sora Morimoto --- .github/workflows/workflow.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 6a0fd44bf0..cf30d82ae0 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -28,7 +28,6 @@ jobs: uses: actions-ml/setup-ocaml@master with: ocaml-version: ${{ matrix.ocaml-version }} - dune-cache: true opam-depext: false opam-pin: false From f5af625da710c476fc81df54e53beb5f7a87fac1 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 5 Feb 2021 20:18:51 +0100 Subject: [PATCH 2/5] Use ocamlformat 0.16.0 --- .ocamlformat | 7 +- cohttp-async/bin/cohttp_curl_async.ml | 21 +- cohttp-async/bin/cohttp_server_async.ml | 164 ++-- cohttp-async/src/body.mli | 8 +- cohttp-async/src/body_raw.ml | 78 +- cohttp-async/src/client.ml | 206 +++-- cohttp-async/src/client.mli | 55 +- cohttp-async/src/io.ml | 73 +- cohttp-async/src/io.mli | 9 +- cohttp-async/src/server.ml | 231 +++--- cohttp-async/src/server.mli | 90 ++- cohttp-async/test/test_async_integration.ml | 219 +++--- cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml | 462 +++++------ cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli | 38 +- cohttp-lwt-unix/bin/cohttp_curl_lwt.ml | 102 +-- cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml | 61 +- cohttp-lwt-unix/bin/cohttp_server_lwt.ml | 190 ++--- cohttp-lwt-unix/src/client.ml | 2 +- cohttp-lwt-unix/src/client.mli | 21 +- cohttp-lwt-unix/src/cohttp_lwt_unix.ml | 10 +- cohttp-lwt-unix/src/debug.ml | 73 +- cohttp-lwt-unix/src/debug.mli | 8 +- cohttp-lwt-unix/src/io.ml | 64 +- cohttp-lwt-unix/src/io.mli | 11 +- cohttp-lwt-unix/src/net.ml | 41 +- cohttp-lwt-unix/src/net.mli | 55 +- cohttp-lwt-unix/src/server.ml | 89 +-- cohttp-lwt-unix/src/server.mli | 49 +- cohttp-lwt-unix/test/test_body.ml | 67 +- cohttp-lwt-unix/test/test_parser.ml | 351 +++++---- cohttp-lwt-unix/test/test_sanity.ml | 329 ++++---- cohttp-lwt-unix/test/test_sanity_noisy.ml | 116 +-- cohttp-lwt/src/body.ml | 98 ++- cohttp-lwt/src/body.mli | 13 +- cohttp-lwt/src/client.ml | 181 +++-- cohttp-lwt/src/client.mli | 11 +- cohttp-lwt/src/cohttp_lwt.ml | 2 - cohttp-lwt/src/make.ml | 13 +- cohttp-lwt/src/s.ml | 153 ++-- cohttp-lwt/src/server.ml | 163 ++-- cohttp-lwt/src/server.mli | 9 +- cohttp-lwt/src/string_io.ml | 5 +- cohttp-lwt/src/string_io.mli | 16 +- cohttp-mirage/src/client.ml | 32 +- cohttp-mirage/src/client.mli | 2 +- cohttp-mirage/src/cohttp_mirage.ml | 1 - cohttp-mirage/src/io.ml | 38 +- cohttp-mirage/src/io.mli | 9 +- cohttp-mirage/src/make.ml | 10 +- cohttp-mirage/src/make.mli | 6 +- cohttp-mirage/src/server_with_conduit.ml | 2 +- cohttp-mirage/src/server_with_conduit.mli | 9 +- cohttp-mirage/src/static.ml | 67 +- cohttp-mirage/src/static.mli | 22 +- cohttp-top/src/cohttp_top.ml | 10 +- cohttp/scripts/generate.ml | 355 ++++----- cohttp/src/accept.ml | 44 +- cohttp/src/accept.mli | 52 +- cohttp/src/accept_types.ml | 18 +- cohttp/src/auth.ml | 26 +- cohttp/src/auth.mli | 38 +- cohttp/src/body.ml | 26 +- cohttp/src/body.mli | 13 +- cohttp/src/conf.mli | 2 +- cohttp/src/connection.ml | 3 +- cohttp/src/connection.mli | 2 +- cohttp/src/cookie.ml | 176 +++-- cohttp/src/cookie.mli | 50 +- cohttp/src/header.ml | 233 +++--- cohttp/src/header.mli | 106 +-- cohttp/src/header_io.ml | 24 +- cohttp/src/header_io.mli | 4 +- cohttp/src/link.ml | 609 ++++++++------- cohttp/src/link.mli | 14 +- cohttp/src/request.ml | 207 ++--- cohttp/src/request.mli | 17 +- cohttp/src/response.ml | 96 ++- cohttp/src/response.mli | 21 +- cohttp/src/s.ml | 103 +-- cohttp/src/string_io.ml | 44 +- cohttp/src/string_io.mli | 23 +- cohttp/src/transfer.ml | 22 +- cohttp/src/transfer.mli | 27 +- cohttp/src/transfer_io.ml | 94 +-- cohttp/src/transfer_io.mli | 4 +- cohttp/test/test_accept.ml | 267 +++---- cohttp/test/test_body.ml | 30 +- cohttp/test/test_header.ml | 733 ++++++++++-------- cohttp/test/test_request.ml | 216 +++--- cohttp_async_test/src/cohttp_async_test.ml | 73 +- cohttp_async_test/src/cohttp_async_test.mli | 8 +- .../src/cohttp_lwt_unix_test.ml | 71 +- .../src/cohttp_lwt_unix_test.mli | 7 +- cohttp_server/cohttp_server.ml | 112 ++- cohttp_test/src/cohttp_test.ml | 23 +- cohttp_test/src/cohttp_test.mli | 36 +- examples/async/hello_world.ml | 27 +- examples/async/receive_post.ml | 23 +- examples/async/s3_cp.ml | 350 +++++---- examples/lwt_unix_doc/docker_lwt.ml | 3 +- 100 files changed, 4357 insertions(+), 4247 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 2e686658cb..379e9d62b0 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,2 +1,5 @@ -version = 0.15.0 -disable = true +version = 0.16.0 +profile = conventional +break-infix = fit-or-vertical +parse-docstrings = true +module-item-spacing = compact diff --git a/cohttp-async/bin/cohttp_curl_async.ml b/cohttp-async/bin/cohttp_curl_async.ml index cd634f945b..044e38d316 100644 --- a/cohttp-async/bin/cohttp_curl_async.ml +++ b/cohttp-async/bin/cohttp_curl_async.ml @@ -19,19 +19,23 @@ open Async_kernel open Cohttp_async let show_headers h = - Cohttp.Header.iter (fun k v -> - List.iter v ~f:(fun v_i -> Logs.info (fun m -> m "%s: %s%!" k v_i))) h + Cohttp.Header.iter + (fun k v -> + List.iter v ~f:(fun v_i -> Logs.info (fun m -> m "%s: %s%!" k v_i))) + h let make_net_req uri meth' body () = let meth = Cohttp.Code.method_of_string meth' in let uri = Uri.of_string uri in - let headers = Cohttp.Header.of_list [ "connection", "close" ] in + let headers = Cohttp.Header.of_list [ ("connection", "close") ] in Client.call meth ~headers ~body:Body.(of_string body) uri >>= fun (res, body) -> show_headers (Cohttp.Response.headers res); body |> Body.to_pipe - |> Pipe.iter ~f:(fun b -> Stdlib.print_string b; return ()) + |> Pipe.iter ~f:(fun b -> + Stdlib.print_string b; + return ()) let _ = (* enable logging to stdout *) @@ -43,10 +47,9 @@ let _ = 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" - ) + +> 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 |> run diff --git a/cohttp-async/bin/cohttp_server_async.ml b/cohttp-async/bin/cohttp_server_async.ml index 8f28bf9127..48e1caae8e 100644 --- a/cohttp-async/bin/cohttp_server_async.ml +++ b/cohttp-async/bin/cohttp_server_async.ml @@ -18,87 +18,84 @@ open Base open Async_kernel open Async_unix - open Cohttp_async open Cohttp_server -let method_filter meth (res,body) = match meth with - | `HEAD -> return (res,`Empty) - | _ -> return (res,body) +let method_filter meth (res, body) = + match meth with `HEAD -> return (res, `Empty) | _ -> return (res, body) let serve_file ~docroot ~uri = - Server.resolve_local_file ~docroot ~uri - |> Server.respond_with_file + Server.resolve_local_file ~docroot ~uri |> Server.respond_with_file let serve ~info ~docroot ~index uri path = (* Get a canonical filename from the URL and docroot *) let file_name = Server.resolve_local_file ~docroot ~uri in try_with (fun () -> - Unix.stat file_name - >>= fun stat -> - Logs.debug (fun f -> f "%s" (Sexp.to_string_hum (Unix.Stats.sexp_of_t stat))); - match stat.Unix.Stats.kind with - (* Get a list of current files and map to HTML *) - | `Directory -> begin - let path_len = String.length path in - 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) - >>= function - | `Yes -> (* Serve the index file directly *) - let uri = Uri.with_path uri (path / index) in - serve_file ~docroot ~uri - | `No | `Unknown -> (* Do a directory listing *) - Sys.ls_dir file_name - >>= Deferred.List.map ~f:(fun f -> - let file_name = file_name / f in - try_with (fun () -> - Unix.stat file_name - >>| fun stat -> (Some stat.Unix.Stats.kind, stat.Unix.Stats.size, f) - ) >>| function Ok v -> v | Error _ -> (None, 0L, f)) - >>= fun listing -> - html_of_listing uri path (sort ((Some `Directory,0L,"..")::listing)) info - |> Server.respond_string - end - (* Serve the local file contents *) - | `File -> serve_file ~docroot ~uri - (* Any other file type is simply forbidden *) - | `Socket | `Block | `Fifo | `Char | `Link -> - Server.respond_string ~status:`Forbidden - (html_of_forbidden_unnormal path info) - ) - >>= (function + Unix.stat file_name >>= fun stat -> + Logs.debug (fun f -> + f "%s" (Sexp.to_string_hum (Unix.Stats.sexp_of_t stat))); + match stat.Unix.Stats.kind with + (* Get a list of current files and map to HTML *) + | `Directory -> ( + let path_len = String.length path in + 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) >>= function + | `Yes -> + (* Serve the index file directly *) + let uri = Uri.with_path uri (path / index) in + serve_file ~docroot ~uri + | `No | `Unknown -> + (* Do a directory listing *) + Sys.ls_dir file_name + >>= Deferred.List.map ~f:(fun f -> + let file_name = file_name / f in + try_with (fun () -> + Unix.stat file_name >>| fun stat -> + (Some stat.Unix.Stats.kind, stat.Unix.Stats.size, f)) + >>| function + | Ok v -> v + | Error _ -> (None, 0L, f)) + >>= fun listing -> + html_of_listing uri path + (sort ((Some `Directory, 0L, "..") :: listing)) + info + |> Server.respond_string) + (* Serve the local file contents *) + | `File -> serve_file ~docroot ~uri + (* Any other file type is simply forbidden *) + | `Socket | `Block | `Fifo | `Char | `Link -> + Server.respond_string ~status:`Forbidden + (html_of_forbidden_unnormal path info)) + >>= function | Ok res -> return res - | Error exn -> - begin match Monitor.extract_exn exn with - | Unix.Unix_error (Unix.Error.ENOENT, "stat", p) -> - if String.equal p ("((filename "^file_name^"))") (* Really? *) - then Server.respond_string ~status:`Not_found - (html_of_not_found path info) - else raise exn - | _ -> raise exn - end - ) + | Error exn -> ( + match Monitor.extract_exn exn with + | Unix.Unix_error (Unix.Error.ENOENT, "stat", p) -> + if String.equal p ("((filename " ^ file_name ^ "))") (* Really? *) + then + Server.respond_string ~status:`Not_found + (html_of_not_found path info) + else raise exn + | _ -> raise exn) (** HTTP handler *) let handler ~info ~docroot ~index ~body:_ _sock req = let uri = Cohttp.Request.uri req in let path = Uri.path uri in (* Log the request to the console *) - printf "%s %s%!" - (Cohttp.(Code.string_of_method (Request.meth req))) - path; + printf "%s %s%!" Cohttp.(Code.string_of_method (Request.meth req)) path; match Request.meth req with | (`GET | `HEAD) as meth -> - serve ~info ~docroot ~index uri path - >>= method_filter meth + serve ~info ~docroot ~index uri path >>= method_filter meth | meth -> - let meth = Cohttp.Code.string_of_method meth in - let allowed = "GET, HEAD" in - let headers = Cohttp.Header.of_list ["allow", allowed] in - Server.respond_string ~headers ~status:`Method_not_allowed - (html_of_method_not_allowed meth allowed path info) + let meth = Cohttp.Code.string_of_method meth in + let allowed = "GET, HEAD" in + let headers = Cohttp.Header.of_list [ ("allow", allowed) ] in + Server.respond_string ~headers ~status:`Method_not_allowed + (html_of_method_not_allowed meth allowed path info) let determine_mode cert_file_path key_file_path = (* Determines if the server runs in http or https *) @@ -110,31 +107,38 @@ let determine_mode cert_file_path key_file_path = let start_server docroot port index cert_file key_file verbose () = (* enable logging to stdout *) Fmt_tty.setup_std_outputs (); - Logs.set_level @@ if verbose then (Some Logs.Debug) else (Some Logs.Info); + Logs.set_level @@ if verbose then Some Logs.Debug else Some Logs.Info; Logs.set_reporter (Logs_fmt.reporter ()); let mode = determine_mode cert_file key_file in - let mode_str = (match mode with `OpenSSL _ -> "HTTPS" | `TCP -> "HTTP") 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 = 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 + ~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) - (handler ~info ~docroot ~index) >>= fun _serv -> - Deferred.never () + (handler ~info ~docroot ~index) + >>= fun _serv -> Deferred.never () let () = let open Async_command in - run @@ - async_spec ~summary:"Serve the local directory contents via HTTP or HTTPS" - Spec.( - empty - +> anon (maybe_with_default "." ("docroot" %: string)) - +> flag "-p" (optional_with_default 8080 int) ~doc:"port TCP port to listen on" - +> flag "-i" (optional_with_default "index.html" string) ~doc:"file Name of index file in directory" - +> flag "-cert-file" (optional string) ~doc:"File of cert for https" - +> flag "-key-file" (optional string) ~doc:"File of private key for https" - +> flag "-v" no_arg ~doc:" Verbose logging output to console" - ) start_server + run + @@ async_spec ~summary:"Serve the local directory contents via HTTP or HTTPS" + Spec.( + empty + +> anon (maybe_with_default "." ("docroot" %: string)) + +> flag "-p" + (optional_with_default 8080 int) + ~doc:"port TCP port to listen on" + +> flag "-i" + (optional_with_default "index.html" string) + ~doc:"file Name of index file in directory" + +> flag "-cert-file" (optional string) ~doc:"File of cert for https" + +> flag "-key-file" (optional string) + ~doc:"File of private key for https" + +> flag "-v" no_arg ~doc:" Verbose logging output to console") + start_server diff --git a/cohttp-async/src/body.mli b/cohttp-async/src/body.mli index ff6f3d1c6c..154dc202be 100644 --- a/cohttp-async/src/body.mli +++ b/cohttp-async/src/body.mli @@ -2,10 +2,8 @@ open! Base open! Async_kernel open! Cohttp -type t = [ - | Cohttp.Body.t - | `Pipe of string Pipe.Reader.t -] [@@deriving sexp_of] +type t = [ Cohttp.Body.t | `Pipe of string Pipe.Reader.t ] [@@deriving sexp_of] + include Cohttp.S.Body with type t := t val drain : t -> unit Deferred.t @@ -16,4 +14,4 @@ val to_pipe : t -> string Pipe.Reader.t val of_pipe : string Pipe.Reader.t -> t val map : t -> f:(string -> string) -> t val as_pipe : t -> f:(string Pipe.Reader.t -> string Pipe.Reader.t) -> t -val to_form : t -> (string * string list) list Deferred.t \ No newline at end of file +val to_form : t -> (string * string list) list Deferred.t diff --git a/cohttp-async/src/body_raw.ml b/cohttp-async/src/body_raw.ml index 638cd7b625..60db20dc6a 100644 --- a/cohttp-async/src/body_raw.ml +++ b/cohttp-async/src/body_raw.ml @@ -2,13 +2,10 @@ open Base open Async_kernel module B = Cohttp.Body -type t = [ - | B.t - | `Pipe of string Pipe.Reader.t -] [@@deriving sexp_of] +type t = [ B.t | `Pipe of string Pipe.Reader.t ] [@@deriving sexp_of] let empty = `Empty -let of_string s = ((B.of_string s) :> t) +let of_string s = (B.of_string s :> t) let of_pipe p = `Pipe p let to_string = function @@ -19,30 +16,23 @@ let to_string_list = function | #B.t as body -> return (B.to_string_list body) | `Pipe s -> Pipe.to_list s -let drain = function - | #B.t -> return () - | `Pipe p -> Pipe.drain p +let drain = function #B.t -> return () | `Pipe p -> Pipe.drain p -let is_empty (body:t) = +let is_empty (body : t) = match body with | #B.t as body -> return (B.is_empty body) - | `Pipe pipe -> + | `Pipe pipe -> ( Deferred.repeat_until_finished () @@ fun () -> - Pipe.values_available pipe - >>= function - | `Eof -> return (`Finished true) - | `Ok -> begin - match Pipe.peek pipe with - | None -> return (`Finished true) - | Some "" -> - begin - Pipe.read pipe - >>| function - | `Eof -> `Finished true - | `Ok _ -> `Repeat () - end - | Some _ -> return (`Finished false) - end + Pipe.values_available pipe >>= function + | `Eof -> return (`Finished true) + | `Ok -> ( + match Pipe.peek pipe with + | None -> return (`Finished true) + | Some "" -> ( + Pipe.read pipe >>| function + | `Eof -> `Finished true + | `Ok _ -> `Repeat ()) + | Some _ -> return (`Finished false))) let to_pipe = function | `Empty -> Pipe.of_list [] @@ -53,10 +43,10 @@ let to_pipe = function let disable_chunked_encoding = function | #B.t as body -> return (body, B.length body) | `Pipe s -> - Pipe.to_list s >>| fun l -> - let body = `Strings l in - let len = B.length body in - body, len + Pipe.to_list s >>| fun l -> + let body = `Strings l in + let len = B.length body in + (body, len) let transfer_encoding = function | #B.t as t -> B.transfer_encoding t @@ -70,7 +60,6 @@ let map t ~f = | `Pipe p -> `Pipe (Pipe.map p ~f) let as_pipe t ~f = `Pipe (t |> to_pipe |> f) - let to_form t = to_string t >>| Uri.query_of_encoded let of_form ?scheme f = Uri.encoded_of_query ?scheme f |> of_string @@ -87,19 +76,18 @@ let pipe_of_body read_chunk ic = Deferred.repeat_until_finished () (fun () -> read_chunk ic >>= function | Chunk buf -> - (* Even if [writer] has been closed, the loop must continue reading - * from the input channel to ensure that it is left in a proper state - * for the next request to be processed (in the case of keep-alive). - * - * The only case where [writer] will be closed is when - * [Pipe.close_read] has been called on its read end. This could be - * done by a request handler to signal that it does not need to - * inspect the remainder of the body to fulfill the request. - *) - Pipe.write_when_ready writer ~f:(fun write -> write buf) - >>| fun _ -> `Repeat () + (* Even if [writer] has been closed, the loop must continue reading + * from the input channel to ensure that it is left in a proper state + * for the next request to be processed (in the case of keep-alive). + * + * The only case where [writer] will be closed is when + * [Pipe.close_read] has been called on its read end. This could be + * done by a request handler to signal that it does not need to + * inspect the remainder of the body to fulfill the request. + *) + Pipe.write_when_ready writer ~f:(fun write -> write buf) + >>| fun _ -> `Repeat () | Final_chunk buf -> - Pipe.write_when_ready writer ~f:(fun write -> write buf) - >>| fun _ -> `Finished () - | Done -> return (`Finished ())) - ) + Pipe.write_when_ready writer ~f:(fun write -> write buf) + >>| fun _ -> `Finished () + | Done -> return (`Finished ()))) diff --git a/cohttp-async/src/client.ml b/cohttp-async/src/client.ml index acbb0a3a62..f7e8d39b9e 100644 --- a/cohttp-async/src/client.ml +++ b/cohttp-async/src/client.ml @@ -4,112 +4,97 @@ open Async_unix module Request = struct include Cohttp.Request - include (Make(Io) : module type of Make(Io) with type t := t) -end + include (Make (Io) : module type of Make (Io) with type t := t) + end module Response = struct include Cohttp.Response - include (Make(Io) : module type of Make(Io) with type t := t) -end + include (Make (Io) : module type of Make (Io) with type t := t) + end module Net = struct - let lookup uri = let host = Uri.host_with_default ~default:"localhost" uri in match Uri_services.tcp_port_of_uri ~default:"http" uri with - | None -> Deferred.Or_error.error_string - "Net.lookup: failed to get TCP port form Uri" - | Some port -> - let open Unix in - Addr_info.get ~host [ Addr_info.AI_FAMILY PF_INET - ; Addr_info.AI_SOCKTYPE SOCK_STREAM] - >>| function - | { Addr_info.ai_addr=ADDR_INET (addr,_); _ }::_ -> - Or_error.return (host, Ipaddr_unix.of_inet_addr addr, port) - | _ -> Or_error.error "Failed to resolve Uri" uri Uri_sexp.sexp_of_t + | None -> + Deferred.Or_error.error_string + "Net.lookup: failed to get TCP port form Uri" + | Some port -> ( + let open Unix in + Addr_info.get ~host + [ Addr_info.AI_FAMILY PF_INET; Addr_info.AI_SOCKTYPE SOCK_STREAM ] + >>| function + | { Addr_info.ai_addr = ADDR_INET (addr, _); _ } :: _ -> + Or_error.return (host, Ipaddr_unix.of_inet_addr addr, port) + | _ -> Or_error.error "Failed to resolve Uri" uri Uri_sexp.sexp_of_t) let connect_uri ?interrupt ?ssl_config uri = (match Uri.scheme uri with - | Some "httpunix" -> - let host = Uri.host_with_default ~default:"localhost" uri in - return @@ `Unix_domain_socket host - | _ -> - lookup uri - |> Deferred.Or_error.ok_exn - >>= fun (host, addr, port) -> - return @@ match (Uri.scheme uri, ssl_config) with - | Some "https", Some config -> - `OpenSSL (addr, port, config) + | Some "httpunix" -> + let host = Uri.host_with_default ~default:"localhost" uri in + return @@ `Unix_domain_socket host + | _ -> ( + lookup uri |> Deferred.Or_error.ok_exn >>= fun (host, addr, port) -> + return + @@ + match (Uri.scheme uri, ssl_config) with + | Some "https", Some config -> `OpenSSL (addr, port, config) | Some "https", None -> - let config = Conduit_async.V2.Ssl.Config.create ~hostname:host () in - `OpenSSL (addr, port, config) - | _ -> `TCP (addr, port)) - >>= fun mode -> - Conduit_async.V2.connect ?interrupt mode + let config = Conduit_async.V2.Ssl.Config.create ~hostname:host () in + `OpenSSL (addr, port, config) + | _ -> `TCP (addr, port))) + >>= fun mode -> Conduit_async.V2.connect ?interrupt mode end let read_response ic = Response.read ic >>| function | `Eof -> failwith "Connection closed by remote host" | `Invalid reason -> failwith reason - | `Ok res -> - begin + | `Ok res -> ( match Response.has_body res with | `Yes | `Unknown -> - (* Build a response pipe for the body *) - let reader = Response.make_body_reader res ic in - let pipe = Body_raw.pipe_of_body Response.read_body_chunk reader in - (res, pipe) + (* Build a response pipe for the body *) + let reader = Response.make_body_reader res ic in + let pipe = Body_raw.pipe_of_body Response.read_body_chunk reader in + (res, pipe) | `No -> - let pipe = Pipe.of_list [] in - (res, pipe) - end + let pipe = Pipe.of_list [] in + (res, pipe)) -let request ?interrupt ?ssl_config ?uri ?(body=`Empty) req = +let request ?interrupt ?ssl_config ?uri ?(body = `Empty) req = (* Connect to the remote side *) - let uri = - match uri with - | Some t -> t - | None -> Request.uri req in - Net.connect_uri ?interrupt ?ssl_config uri - >>= fun (ic, oc) -> + let uri = match uri with Some t -> t | None -> Request.uri req in + Net.connect_uri ?interrupt ?ssl_config uri >>= fun (ic, oc) -> try_with (fun () -> - Request.write (fun writer -> - Body_raw.write_body Request.write_body body writer) req oc + Request.write + (fun writer -> Body_raw.write_body Request.write_body body writer) + req oc >>= fun () -> read_response ic >>| fun (resp, body) -> - don't_wait_for ( - Pipe.closed body >>= fun () -> - Deferred.all_unit [Reader.close ic; Writer.close oc]); - (resp, `Pipe body)) >>= begin function - | Ok res -> return res - | Error e -> + don't_wait_for + ( Pipe.closed body >>= fun () -> + Deferred.all_unit [ Reader.close ic; Writer.close oc ] ); + (resp, `Pipe body)) + >>= function + | Ok res -> return res + | Error e -> don't_wait_for (Reader.close ic); don't_wait_for (Writer.close oc); raise e - end module Connection = struct - type t' = - { ic : Reader.t - ; oc : Writer.t } + type t' = { ic : Reader.t; oc : Writer.t } (* we can't send concurrent requests over HTTP/1 *) type t = t' Sequencer.t let connect ?interrupt ?ssl_config uri = - Net.connect_uri ?interrupt ?ssl_config uri - >>| fun (ic, oc) -> - let t = - { ic ; oc } - |> Sequencer.create ~continue_on_error:false - in - Throttle.at_kill t (fun { ic ; oc } -> - Deferred.both (Writer.close oc) (Reader.close ic) - >>| fun ((), ()) -> ()); - (Deferred.any [ Writer.consumer_left oc ; Reader.close_finished ic ] - >>| fun () -> - Throttle.kill t) + Net.connect_uri ?interrupt ?ssl_config uri >>| fun (ic, oc) -> + let t = { ic; oc } |> Sequencer.create ~continue_on_error:false in + Throttle.at_kill t (fun { ic; oc } -> + Deferred.both (Writer.close oc) (Reader.close ic) >>| fun ((), ()) -> ()); + Deferred.any [ Writer.consumer_left oc; Reader.close_finished ic ] + >>| (fun () -> Throttle.kill t) |> don't_wait_for; t @@ -117,51 +102,54 @@ module Connection = struct Throttle.kill t; Throttle.cleaned t - let is_closed t = - Throttle.is_dead t + let is_closed t = Throttle.is_dead t - let request ?(body=Body.empty) t req = + let request ?(body = Body.empty) t req = let res = Ivar.create () in - Throttle.enqueue t (fun { ic ; oc } -> - Request.write (fun writer -> - Body_raw.write_body Request.write_body body writer) req oc - >>= fun () -> - read_response ic - >>= fun (resp, body) -> - Ivar.fill res (resp, `Pipe body); - (* block starting any more requests until the consumer has finished reading this request *) - Pipe.closed body) + Throttle.enqueue t (fun { ic; oc } -> + Request.write + (fun writer -> Body_raw.write_body Request.write_body body writer) + req oc + >>= fun () -> + read_response ic >>= fun (resp, body) -> + Ivar.fill res (resp, `Pipe body); + (* block starting any more requests until the consumer has finished reading this request *) + Pipe.closed body) |> don't_wait_for; Ivar.read res end let callv ?interrupt ?ssl_config uri reqs = - Connection.connect ?interrupt ?ssl_config uri - >>| fun connection -> + Connection.connect ?interrupt ?ssl_config uri >>| fun connection -> let responses = Pipe.map' ~max_queue_length:1 reqs ~f:(fun reqs -> - Deferred.Queue.map reqs ~f:(fun (req, body) -> - Connection.request ~body connection req)) + Deferred.Queue.map reqs ~f:(fun (req, body) -> + Connection.request ~body connection req)) in - (Pipe.closed responses >>= fun () -> Connection.close connection) |> don't_wait_for; + Pipe.closed responses + >>= (fun () -> Connection.close connection) + |> don't_wait_for; responses -let call ?interrupt ?ssl_config ?headers ?(chunked=false) ?(body=`Empty) meth uri = +let call ?interrupt ?ssl_config ?headers ?(chunked = false) ?(body = `Empty) + meth uri = (* Create a request, then make the request. Figure out an appropriate transfer encoding *) - begin - match chunked with - | false -> + (match chunked with + | false -> Body_raw.disable_chunked_encoding body >>| fun (body, body_length) -> - Request.make_for_client ?headers ~chunked ~body_length meth uri, body - | true -> begin - Body.is_empty body >>| function - | true -> (* Don't used chunked encoding with an empty body *) - Request.make_for_client ?headers ~chunked:false ~body_length:0L meth uri, body - | false -> (* Use chunked encoding if there is a body *) - Request.make_for_client ?headers ~chunked:true meth uri, body - end - end >>= fun (req, body) -> request ?interrupt ?ssl_config ~body ~uri req + (Request.make_for_client ?headers ~chunked ~body_length meth uri, body) + | true -> ( + Body.is_empty body >>| function + | true -> + (* Don't used chunked encoding with an empty body *) + ( Request.make_for_client ?headers ~chunked:false ~body_length:0L meth + uri, + body ) + | false -> + (* Use chunked encoding if there is a body *) + (Request.make_for_client ?headers ~chunked:true meth uri, body))) + >>= fun (req, body) -> request ?interrupt ?ssl_config ~body ~uri req let get ?interrupt ?ssl_config ?headers uri = call ?interrupt ?ssl_config ?headers ~chunked:false `GET uri @@ -169,25 +157,25 @@ let get ?interrupt ?ssl_config ?headers uri = let head ?interrupt ?ssl_config ?headers uri = call ?interrupt ?ssl_config ?headers ~chunked:false `HEAD uri >>| fun (res, body) -> - (match body with - | `Pipe p -> Pipe.close_read p; - | _ -> ()); + (match body with `Pipe p -> Pipe.close_read p | _ -> ()); res -let post ?interrupt ?ssl_config ?headers ?(chunked=false) ?body uri = +let post ?interrupt ?ssl_config ?headers ?(chunked = false) ?body uri = call ?interrupt ?ssl_config ?headers ~chunked ?body `POST uri let post_form ?interrupt ?ssl_config ?headers ~params uri = - let headers = Cohttp.Header.add_opt_unless_exists headers - "content-type" "application/x-www-form-urlencoded" in + let headers = + Cohttp.Header.add_opt_unless_exists headers "content-type" + "application/x-www-form-urlencoded" + in let body = Body.of_string (Uri.encoded_of_query params) in post ?interrupt ?ssl_config ~headers ~chunked:false ~body uri -let put ?interrupt ?ssl_config ?headers ?(chunked=false) ?body uri = +let put ?interrupt ?ssl_config ?headers ?(chunked = false) ?body uri = call ?interrupt ?ssl_config ?headers ~chunked ?body `PUT uri -let patch ?interrupt ?ssl_config ?headers ?(chunked=false) ?body uri = +let patch ?interrupt ?ssl_config ?headers ?(chunked = false) ?body uri = call ?interrupt ?ssl_config ?headers ~chunked ?body `PATCH uri -let delete ?interrupt ?ssl_config ?headers ?(chunked=false) ?body uri = +let delete ?interrupt ?ssl_config ?headers ?(chunked = false) ?body uri = call ?interrupt ?ssl_config ?headers ~chunked ?body `DELETE uri diff --git a/cohttp-async/src/client.mli b/cohttp-async/src/client.mli index ea5f5da43d..fd3d7143d5 100644 --- a/cohttp-async/src/client.mli +++ b/cohttp-async/src/client.mli @@ -1,5 +1,3 @@ -(** Send an HTTP request with an arbitrary body - The request is sent as-is. *) val request : ?interrupt:unit Async_kernel.Deferred.t -> ?ssl_config:Conduit_async.V2.Ssl.Config.t -> @@ -7,19 +5,8 @@ val request : ?body:Body.t -> Cohttp.Request.t -> (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t +(** Send an HTTP request with an arbitrary body The request is sent as-is. *) -(** Send an HTTP request with arbitrary method and a body - Infers the transfer encoding. Depending on the given [uri], - we choose a way to start a communication such as: - - {ul - {- If the scheme is [https], we try to initiate an SSL connection with - the given [ssl_ctx] or a default one on the default port ([*:443]) or - the specified one.} - {- If the scheme is [httpunix], we use a UNIX domain socket.} - {- If the scheme ie [http], we try an usual TCP/IP connection on the - default port ([*:80]) or the specified one.}} -*) val call : ?interrupt:unit Async_kernel.Deferred.t -> ?ssl_config:Conduit_async.V2.Ssl.Config.t -> @@ -29,7 +16,16 @@ val call : Cohttp.Code.meth -> Uri.t -> (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t +(** Send an HTTP request with arbitrary method and a body Infers the transfer + encoding. Depending on the given [uri], we choose a way to start a + communication such as: + - If the scheme is [https], we try to initiate an SSL connection with the + given [ssl_ctx] or a default one on the default port ([*:443]) or the + specified one. + - If the scheme is [httpunix], we use a UNIX domain socket. + - If the scheme ie [http], we try an usual TCP/IP connection on the default + port ([*:80]) or the specified one. *) module Connection : sig type t @@ -41,11 +37,10 @@ module Connection : sig t Async_kernel.Deferred.t val close : t -> unit Async_kernel.Deferred.t - val is_closed : t -> bool val request : - ?body: Body.t -> + ?body:Body.t -> t -> Cohttp.Request.t -> (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t @@ -56,25 +51,25 @@ val callv : ?ssl_config:Conduit_async.V2.Ssl.Config.t -> Uri.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 + (Cohttp.Response.t * Body.t) Async_kernel.Pipe.Reader.t + Async_kernel.Deferred.t -(** Send an HTTP GET request *) val get : ?interrupt:unit Async_kernel.Deferred.t -> ?ssl_config:Conduit_async.V2.Ssl.Config.t -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t +(** Send an HTTP GET request *) -(** Send an HTTP HEAD request *) val head : ?interrupt:unit Async_kernel.Deferred.t -> ?ssl_config:Conduit_async.V2.Ssl.Config.t -> ?headers:Cohttp.Header.t -> Uri.t -> Cohttp.Response.t Async_kernel.Deferred.t +(** Send an HTTP HEAD request *) -(** Send an HTTP DELETE request *) val delete : ?interrupt:unit Async_kernel.Deferred.t -> ?ssl_config:Conduit_async.V2.Ssl.Config.t -> @@ -83,10 +78,8 @@ val delete : ?body:Body.t -> Uri.t -> (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t +(** Send an HTTP DELETE request *) -(** Send an HTTP POST request. - [chunked] encoding is off by default as not many servers support it -*) val post : ?interrupt:unit Async_kernel.Deferred.t -> ?ssl_config:Conduit_async.V2.Ssl.Config.t -> @@ -95,10 +88,9 @@ val post : ?body:Body.t -> Uri.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 *) -(** Send an HTTP PUT request. - [chunked] encoding is off by default as not many servers support it -*) val put : ?interrupt:unit Async_kernel.Deferred.t -> ?ssl_config:Conduit_async.V2.Ssl.Config.t -> @@ -107,10 +99,9 @@ val put : ?body:Body.t -> Uri.t -> (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 *) -(** Send an HTTP PATCH request. - [chunked] encoding is off by default as not many servers support it -*) val patch : ?interrupt:unit Async_kernel.Deferred.t -> ?ssl_config:Conduit_async.V2.Ssl.Config.t -> @@ -119,12 +110,14 @@ val patch : ?body:Body.t -> Uri.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 *) -(** Send an HTTP POST request in form format *) -val post_form: +val post_form : ?interrupt:unit Async_kernel.Deferred.t -> ?ssl_config:Conduit_async.V2.Ssl.Config.t -> ?headers:Cohttp.Header.t -> params:(string * string list) list -> Uri.t -> (Response.t * Body.t) Async_kernel.Deferred.t +(** Send an HTTP POST request in form format *) diff --git a/cohttp-async/src/io.ml b/cohttp-async/src/io.ml index 8b7eefbc0e..9e11edb2f4 100644 --- a/cohttp-async/src/io.ml +++ b/cohttp-async/src/io.ml @@ -16,53 +16,55 @@ 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" + module Log = (val Logs.src_log src : Logs.LOG) let default_reporter () = let fmtr, fmtr_flush = let b = Buffer.create 512 in - ( Fmt.with_buffer ~like:Fmt.stderr b - , fun () -> - let m = Buffer.contents b in - Buffer.reset b; - m ) in + ( Fmt.with_buffer ~like:Fmt.stderr b, + fun () -> + let m = Buffer.contents b in + Buffer.reset b; + m ) + in let report src _level ~over k msgf = let k _ = - if String.equal (Logs.Src.name src) log_src_name then ( - Writer.write (Lazy.force Writer.stderr) (fmtr_flush ()) - ); + if String.equal (Logs.Src.name src) log_src_name then + Writer.write (Lazy.force Writer.stderr) (fmtr_flush ()); over (); - k () in + k () + in msgf @@ fun ?header:_ ?tags:_ fmt -> Format.kfprintf k fmtr Caml.("@[" ^^ fmt ^^ "@]@.") in { Logs.report } -let set_log = lazy ( - (* If no reporter has been set by the application, set default one - that prints to stderr. This way a user will see logs when the debug - flag is set without adding a reporter. *) - if phys_equal (Logs.reporter ()) Logs.nop_reporter - then - Logs.set_level @@ Some Logs.Debug; - Logs.set_reporter (default_reporter ()); -) +let set_log = + lazy + ((* If no reporter has been set by the application, set default one + that prints to stderr. This way a user will see logs when the debug + flag is set without adding a reporter. *) + if phys_equal (Logs.reporter ()) Logs.nop_reporter then + Logs.set_level @@ Some Logs.Debug; + Logs.set_reporter (default_reporter ())) let check_debug norm_fn debug_fn = match Caml.Sys.getenv "COHTTP_DEBUG" with | _ -> - Lazy.force set_log; debug_fn + Lazy.force set_log; + debug_fn | exception Caml.Not_found -> norm_fn type 'a t = 'a Deferred.t -let (>>=) = Deferred.(>>=) + +let ( >>= ) = Deferred.( >>= ) let return = Deferred.return type ic = Reader.t @@ -72,17 +74,15 @@ type conn = unit let read_line = check_debug (fun ic -> - Reader.read_line ic - >>| function - | `Ok s -> Some s - | `Eof -> None - ) + Reader.read_line ic >>| function `Ok s -> Some s | `Eof -> None) (fun ic -> - Reader.read_line ic - >>| function - | `Ok s -> Log.debug (fun fmt -> fmt "<<< %s" s); Some s - | `Eof -> Log.debug (fun fmt -> fmt "<<>| function + | `Ok s -> + Log.debug (fun fmt -> fmt "<<< %s" s); + Some s + | `Eof -> + Log.debug (fun fmt -> fmt "<< - Writer.write oc buf; - return ()) + Writer.write oc buf; + return ()) (fun oc buf -> - Log.debug - (fun fmt -> fmt "%4d >>> %s" (Unix.getpid ()) buf); - Writer.write oc buf; - return ()) + Log.debug (fun fmt -> fmt "%4d >>> %s" (Unix.getpid ()) buf); + Writer.write oc buf; + return ()) let flush = Writer.flushed diff --git a/cohttp-async/src/io.mli b/cohttp-async/src/io.mli index a86d127d36..97dbe0acbf 100644 --- a/cohttp-async/src/io.mli +++ b/cohttp-async/src/io.mli @@ -13,7 +13,8 @@ * PERFORMANCE OF THIS SOFTWARE. }}}*) -include Cohttp.S.IO - with type 'a t = 'a Async_kernel.Deferred.t - and type ic = Async_unix.Reader.t - and type oc = Async_unix.Writer.t +include + Cohttp.S.IO + with type 'a t = 'a Async_kernel.Deferred.t + and type ic = Async_unix.Reader.t + and type oc = Async_unix.Writer.t diff --git a/cohttp-async/src/server.ml b/cohttp-async/src/server.ml index cd4b777f79..b1ef020cde 100644 --- a/cohttp-async/src/server.ml +++ b/cohttp-async/src/server.ml @@ -4,31 +4,31 @@ open Async_unix module Request = struct include Cohttp.Request - include (Make(Io) : module type of Make(Io) with type t := t) -end + include (Make (Io) : module type of Make (Io) with type t := t) + end module Response = struct include Cohttp.Response - include (Make(Io) : module type of Make(Io) with type t := t) -end + include (Make (Io) : module type of Make (Io) with type t := t) + end type ('address, 'listening_on) t = { - server: ('address, 'listening_on) Tcp.Server.t [@sexp.opaque]; -} [@@deriving sexp_of] + server : ('address, 'listening_on) Tcp.Server.t; [@sexp.opaque] +} +[@@deriving sexp_of] type response = Response.t * Body.t [@@deriving sexp_of] type response_action = [ `Expert of Cohttp.Response.t * (Io.ic -> Io.oc -> unit Deferred.t) - | `Response of response - ] + | `Response of response ] type 'r respond_t = - ?flush : bool - -> ?headers : Cohttp.Header.t - -> ?body : Body.t - -> Cohttp.Code.status_code - -> 'r Deferred.t + ?flush:bool -> + ?headers:Cohttp.Header.t -> + ?body:Body.t -> + Cohttp.Code.status_code -> + 'r Deferred.t let close t = Tcp.Server.close t.server let close_finished t = Tcp.Server.close_finished t.server @@ -39,95 +39,90 @@ let read_body req rd = match Request.has_body req with (* TODO maybe attempt to read body *) | `No | `Unknown -> (`Empty, Deferred.unit) - | `Yes -> (* Create a Pipe for the body *) - let reader = Request.make_body_reader req rd in - let pipe = Body_raw.pipe_of_body Request.read_body_chunk reader in - (`Pipe pipe, Pipe.closed pipe) + | `Yes -> + (* Create a Pipe for the body *) + let reader = Request.make_body_reader req rd in + let pipe = Body_raw.pipe_of_body Request.read_body_chunk reader in + (`Pipe pipe, Pipe.closed pipe) let collect_errors writer ~f = let monitor = Writer.monitor writer in (* don't propagate errors up, we handle them here *) Monitor.detach_and_get_error_stream monitor |> (ignore : exn Stream.t -> unit); - choose [ - choice (Monitor.get_next_error monitor) - (fun e -> Error (Exn.Reraised ("Cohttp_async.Server.collect_errors", e))); - choice (try_with ~name:"Cohttp_async.Server.collect_errors" f) Fn.id; - ] -;; + choose + [ + choice (Monitor.get_next_error monitor) (fun e -> + Error (Exn.Reraised ("Cohttp_async.Server.collect_errors", e))); + choice (try_with ~name:"Cohttp_async.Server.collect_errors" f) Fn.id; + ] let handle_client handle_request sock rd wr = collect_errors wr ~f:(fun () -> - let last_body_pipe_drained = ref Deferred.unit in - let requests_pipe = - Reader.read_all rd (fun rd -> - !last_body_pipe_drained - >>= fun () -> - (* [`Expert] responses may close the [Reader.t] *) - if Reader.is_closed rd - then return `Eof - else begin - Request.read rd - >>= function - | `Eof | `Invalid _ -> return `Eof - | `Ok req -> - let body, finished = read_body req rd in - handle_request ~body sock req - >>| function - | `Expert (headers, io_handler) -> - let expert_finished = Ivar.create () in - last_body_pipe_drained := Deferred.all_unit [Ivar.read expert_finished; finished]; - `Ok (`Expert (headers, io_handler, body, expert_finished)) - | `Response r -> - last_body_pipe_drained := finished; - `Ok (`Response (req, body, r)) - end - ) - in - Pipe.iter ~continue_on_error:false requests_pipe ~f:(function - | `Expert (response, io_handler, body, finished) -> - Response.write_header response wr - >>= fun () -> - io_handler rd wr - >>= fun () -> - Body.drain body >>| fun () -> - Ivar.fill_if_empty finished () - | `Response(req, body, (res, res_body)) -> - let keep_alive = Request.is_keep_alive req in - let flush = Response.flush res in - let res = - let headers = Cohttp.Header.add_unless_exists - (Cohttp.Response.headers res) - "connection" - (if keep_alive then "keep-alive" else "close") in - { res with Response.headers } in - Response.write ~flush (Body_raw.write_body Response.write_body res_body) res wr - >>= fun () -> - Writer.(if keep_alive then flushed else close ?force_close:None) wr - >>= fun () -> - Body.drain body - ) - ) + let last_body_pipe_drained = ref Deferred.unit in + let requests_pipe = + Reader.read_all rd (fun rd -> + !last_body_pipe_drained >>= fun () -> + (* [`Expert] responses may close the [Reader.t] *) + if Reader.is_closed rd then return `Eof + else + Request.read rd >>= function + | `Eof | `Invalid _ -> return `Eof + | `Ok req -> ( + let body, finished = read_body req rd in + handle_request ~body sock req >>| function + | `Expert (headers, io_handler) -> + let expert_finished = Ivar.create () in + last_body_pipe_drained := + Deferred.all_unit + [ Ivar.read expert_finished; finished ]; + `Ok (`Expert (headers, io_handler, body, expert_finished)) + | `Response r -> + last_body_pipe_drained := finished; + `Ok (`Response (req, body, r)))) + in + Pipe.iter ~continue_on_error:false requests_pipe ~f:(function + | `Expert (response, io_handler, body, finished) -> + Response.write_header response wr >>= fun () -> + io_handler rd wr >>= fun () -> + Body.drain body >>| fun () -> Ivar.fill_if_empty finished () + | `Response (req, body, (res, res_body)) -> + let keep_alive = Request.is_keep_alive req in + let flush = Response.flush res in + let res = + let headers = + Cohttp.Header.add_unless_exists + (Cohttp.Response.headers res) + "connection" + (if keep_alive then "keep-alive" else "close") + in + { res with Response.headers } + in + Response.write ~flush + (Body_raw.write_body Response.write_body res_body) + res wr + >>= fun () -> + Writer.(if keep_alive then flushed else close ?force_close:None) wr + >>= fun () -> Body.drain body)) >>= fun res -> - Writer.close wr - >>= fun () -> - Reader.close rd - >>| fun () -> - Result.ok_exn res - -let respond ?(flush=true) ?(headers=Cohttp.Header.init ()) - ?(body=`Empty) status : response Deferred.t = + Writer.close wr >>= fun () -> + Reader.close rd >>| fun () -> Result.ok_exn res + +let respond ?(flush = true) ?(headers = Cohttp.Header.init ()) ?(body = `Empty) + status : response Deferred.t = let encoding = Body.transfer_encoding body in let resp = Response.make ~status ~flush ~encoding ~headers () in return (resp, body) -let respond_with_pipe ?flush ?headers ?(code=`OK) body = +let respond_with_pipe ?flush ?headers ?(code = `OK) body = respond ?flush ?headers ~body:(`Pipe body) code -let respond_string ?flush ?headers ?(status=`OK) body = +let respond_string ?flush ?headers ?(status = `OK) body = respond ?flush ?headers ~body:(`String body) status let respond_with_redirect ?headers uri = - let headers = Cohttp.Header.add_opt_unless_exists headers "location" (Uri.to_string uri) in + let headers = + Cohttp.Header.add_opt_unless_exists headers "location" (Uri.to_string uri) + in respond ~flush:false ~headers `Found let resolve_local_file ~docroot ~uri = @@ -135,50 +130,40 @@ let resolve_local_file ~docroot ~uri = Uri.(pct_decode (path (resolve "" (of_string "/") uri))) |> Caml.Filename.concat docroot -let error_body_default = - "

404 Not Found

" - -let respond_with_file ?flush ?headers ?(error_body=error_body_default) filename = - Monitor.try_with ~run:`Now - (fun () -> - Reader.open_file filename - >>= fun rd -> - let body = `Pipe (Reader.pipe rd) in - let mime_type = Magic_mime.lookup filename in - let headers = Cohttp.Header.add_opt_unless_exists headers "content-type" mime_type in - respond ?flush ~headers ~body `OK - ) +let error_body_default = "

404 Not Found

" + +let respond_with_file ?flush ?headers ?(error_body = error_body_default) + filename = + Monitor.try_with ~run:`Now (fun () -> + Reader.open_file filename >>= fun rd -> + let body = `Pipe (Reader.pipe rd) in + let mime_type = Magic_mime.lookup filename in + let headers = + Cohttp.Header.add_opt_unless_exists headers "content-type" mime_type + in + respond ?flush ~headers ~body `OK) >>= function - |Ok res -> return res - |Error _exn -> respond_string ~status:`Not_found error_body + | Ok res -> return res + | Error _exn -> respond_string ~status:`Not_found error_body type mode = Conduit_async.server -let create_raw ?max_connections ?backlog ?buffer_age_limit ?(mode=`TCP) +let create_raw ?max_connections ?backlog ?buffer_age_limit ?(mode = `TCP) + ~on_handler_error where_to_listen handle_request = + Conduit_async.serve ?max_connections ?backlog ?buffer_age_limit + ~on_handler_error mode where_to_listen + (handle_client handle_request) + >>| fun server -> { server } + +let create_expert ?max_connections ?backlog ?buffer_age_limit ?(mode = `TCP) + ~on_handler_error where_to_listen handle_request = + create_raw ?max_connections ?backlog ?buffer_age_limit ~on_handler_error ~mode + where_to_listen handle_request + +let create ?max_connections ?backlog ?buffer_age_limit ?(mode = `TCP) ~on_handler_error where_to_listen handle_request = - Conduit_async.serve ?max_connections ?backlog - ?buffer_age_limit ~on_handler_error mode - where_to_listen (handle_client handle_request) - >>| fun server -> - { server } - -let create_expert ?max_connections ?backlog - ?buffer_age_limit ?(mode=`TCP) ~on_handler_error where_to_listen handle_request = - create_raw ?max_connections ?backlog - ?buffer_age_limit ~on_handler_error ~mode where_to_listen - handle_request - -let create - ?max_connections - ?backlog - ?buffer_age_limit - ?(mode = `TCP) - ~on_handler_error - where_to_listen - handle_request = let handle_request ~body address request = handle_request ~body address request >>| fun r -> `Response r in - create_raw ?max_connections ?backlog - ?buffer_age_limit ~on_handler_error ~mode where_to_listen - handle_request + create_raw ?max_connections ?backlog ?buffer_age_limit ~on_handler_error ~mode + where_to_listen handle_request diff --git a/cohttp-async/src/server.mli b/cohttp-async/src/server.mli index 6c2d561d3d..89945ccaed 100644 --- a/cohttp-async/src/server.mli +++ b/cohttp-async/src/server.mli @@ -1,12 +1,11 @@ -type ('address, 'listening_on) t constraint 'address - = [< Async_unix.Socket.Address.t ] - [@@deriving sexp_of] +type ('address, 'listening_on) t + constraint 'address = [< Async_unix.Socket.Address.t ] +[@@deriving sexp_of] -val close : (_, _) t -> unit Async_kernel.Deferred.t +val close : (_, _) t -> unit Async_kernel.Deferred.t val close_finished : (_, _) t -> unit Async_kernel.Deferred.t -val is_closed : (_, _) t -> bool - -val listening_on : (_, 'listening_on) t -> 'listening_on +val is_closed : (_, _) t -> bool +val listening_on : (_, 'listening_on) t -> 'listening_on type response = Response.t * Body.t [@@deriving sexp_of] @@ -14,9 +13,18 @@ type 'r respond_t = ?flush:bool -> ?headers:Cohttp.Header.t -> ?body:Body.t -> - Cohttp.Code.status_code -> 'r Async_kernel.Deferred.t + Cohttp.Code.status_code -> + 'r Async_kernel.Deferred.t +type response_action = + [ `Expert of + Cohttp.Response.t + * (Async_unix.Reader.t -> + Async_unix.Writer.t -> + unit Async_kernel.Deferred.t) + | `Response of response ] (** A request handler can respond in two ways: + - Using [`Response], with a {!Response.t} and a {!Body.t}. - Using [`Expert], with a {!Response.t} and an IO function that is expected to write the response body. The IO function has access to the underlying @@ -25,71 +33,69 @@ type 'r respond_t = entirely (e.g. websockets). Processing of pipelined requests continue after the {!unit Async_kernel.Deferred.t} is resolved. The connection can be closed by closing the {!Async_unix.Reader.t}. *) -type response_action = - [ `Expert of Cohttp.Response.t - * (Async_unix.Reader.t - -> Async_unix.Writer.t - -> unit Async_kernel.Deferred.t) - | `Response of response ] val respond : response respond_t -(** Resolve a URI and a docroot into a concrete local filename. *) val resolve_local_file : docroot:string -> uri:Uri.t -> string +(** Resolve a URI and a docroot into a concrete local filename. *) +val respond_with_pipe : + ?flush:bool -> + ?headers:Cohttp.Header.t -> + ?code:Cohttp.Code.status_code -> + string Async_kernel.Pipe.Reader.t -> + response Async_kernel.Deferred.t (** Respond with a [string] Pipe that provides the response string Pipe.Reader.t. + @param code Default is HTTP 200 `OK *) -val respond_with_pipe : - ?flush:bool -> - ?headers:Cohttp.Header.t -> ?code:Cohttp.Code.status_code -> - string Async_kernel.Pipe.Reader.t -> response Async_kernel.Deferred.t val respond_string : ?flush:bool -> ?headers:Cohttp.Header.t -> ?status:Cohttp.Code.status_code -> - string -> response Async_kernel.Deferred.t + string -> + response Async_kernel.Deferred.t -(** Respond with a redirect to an absolute [uri] - @param uri Absolute URI to redirect the client to *) val respond_with_redirect : ?headers:Cohttp.Header.t -> Uri.t -> response Async_kernel.Deferred.t +(** Respond with a redirect to an absolute [uri] + @param uri Absolute URI to redirect the client to *) -(** Respond with file contents, and [error_string Pipe.Async_unix.Reader.t] if the file isn't found *) val respond_with_file : ?flush:bool -> - ?headers:Cohttp.Header.t -> ?error_body:string -> - string -> response Async_kernel.Deferred.t + ?headers:Cohttp.Header.t -> + ?error_body:string -> + string -> + response Async_kernel.Deferred.t +(** Respond with file contents, and [error_string Pipe.Async_unix.Reader.t] if + the file isn't found *) type mode = Conduit_async.server -(** Build a HTTP server and expose the [IO.ic] and [IO.oc]s, based on the - [Tcp.Server] interface. *) val create_expert : ?max_connections:int -> ?backlog:int -> ?buffer_age_limit:Async_unix.Writer.buffer_age_limit -> ?mode:mode -> - on_handler_error:[ `Call of 'address -> exn -> unit - | `Ignore - | `Raise ] -> - ('address, 'listening_on) Async.Tcp.Where_to_listen.t - -> (body:Body.t -> 'address -> Request.t - -> response_action Async_kernel.Deferred.t) - -> ('address, 'listening_on) t Async_kernel.Deferred.t - + on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ] -> + ('address, 'listening_on) Async.Tcp.Where_to_listen.t -> + (body:Body.t -> + 'address -> + Request.t -> + response_action Async_kernel.Deferred.t) -> + ('address, 'listening_on) t Async_kernel.Deferred.t +(** Build a HTTP server and expose the [IO.ic] and [IO.oc]s, based on the + [Tcp.Server] interface. *) -(** Build a HTTP server, based on the [Tcp.Server] interface *) val create : ?max_connections:int -> ?backlog:int -> ?buffer_age_limit:Async_unix.Writer.buffer_age_limit -> ?mode:Conduit_async.server -> - on_handler_error:[ `Call of 'address -> exn -> unit - | `Ignore - | `Raise ] -> - ('address, 'listening_on) Async.Tcp.Where_to_listen.t - -> (body:Body.t -> 'address -> Request.t -> response Async_kernel.Deferred.t) - -> ('address, 'listening_on) t Async_kernel.Deferred.t + on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ] -> + ('address, 'listening_on) Async.Tcp.Where_to_listen.t -> + (body:Body.t -> 'address -> Request.t -> response Async_kernel.Deferred.t) -> + ('address, 'listening_on) t Async_kernel.Deferred.t +(** Build a HTTP server, based on the [Tcp.Server] interface *) diff --git a/cohttp-async/test/test_async_integration.ml b/cohttp-async/test/test_async_integration.ml index a1cfeb22e4..5acc2a8b03 100644 --- a/cohttp-async/test/test_async_integration.ml +++ b/cohttp-async/test/test_async_integration.ml @@ -5,136 +5,133 @@ open Cohttp open Cohttp_async open Cohttp_async_test -let chunk_body = ["one"; ""; " "; "bar"; ""] - +let chunk_body = [ "one"; ""; " "; "bar"; "" ] let large_string = String.make (Int.pow 2 16) 'A' - -let response_bodies = [ "Testing" - ; "Foo bar" ] - +let response_bodies = [ "Testing"; "Foo bar" ] let ok s = Server.respond `OK ~body:(Body.of_string s) - let chunk size = String.init ~f:(Fn.const 'X') size let chunk_size = 33_000 let chunks = 3 let server = - [ (* empty_chunk *) + [ + (* empty_chunk *) const @@ Server.respond `OK ~body:(Body.of_string_list chunk_body); (* large response *) const @@ Server.respond_string large_string; (* large request *) (fun _ body -> - body |> Body.to_string >>| String.length >>= fun len -> - Server.respond_string (Int.to_string len) >>| response - ) - ] @ (* pipelined_chunk *) - (response_bodies |> List.map ~f:(Fn.compose const ok)) - @ - (* large response chunked *) - (fun _ _ -> - let body = - let (r, w) = Pipe.create () in - let chunk = chunk chunk_size in - for _ = 0 to chunks - 1 do - Pipe.write_without_pushback w chunk - done; - Pipe.close w; - r - in - Server.respond_with_pipe ~code:`OK body >>| response - ) - :: [ (* pipelined_expert *) + body |> Body.to_string >>| String.length >>= fun len -> + Server.respond_string (Int.to_string len) >>| response); + ] + (* pipelined_chunk *) + @ (response_bodies |> List.map ~f:(Fn.compose const ok)) + @ (* large response chunked *) + [ + (fun _ _ -> + let body = + let r, w = Pipe.create () in + let chunk = chunk chunk_size in + for _ = 0 to chunks - 1 do + Pipe.write_without_pushback w chunk + done; + Pipe.close w; + r + in + Server.respond_with_pipe ~code:`OK body >>| response); + (* pipelined_expert *) expert (fun _ic oc -> - Async_unix.Writer.write oc "8\r\nexpert 1\r\n0\r\n\r\n"; - Async_unix.Writer.flushed oc - ); + Async_unix.Writer.write oc "8\r\nexpert 1\r\n0\r\n\r\n"; + Async_unix.Writer.flushed oc); expert (fun ic oc -> - Async_unix.Writer.write oc "8\r\nexpert 2\r\n0\r\n\r\n"; - Async_unix.Writer.flushed oc >>= fun () -> - Async_unix.Reader.close ic - ) + Async_unix.Writer.write oc "8\r\nexpert 2\r\n0\r\n\r\n"; + Async_unix.Writer.flushed oc >>= fun () -> Async_unix.Reader.close ic); ] |> response_sequence - let ts = - test_server_s server begin fun uri -> - let headers = Header.init_with "connection" "close" in - let empty_chunk () = - Client.get ~headers uri >>= fun (_, body) -> - body |> Body.to_string >>| fun body -> - assert_equal body (String.concat ~sep:"" chunk_body) in - let large_response () = - Client.get ~headers uri >>= fun (_, body) -> - body |> Body.to_string >>| fun body -> - assert_equal body large_string in - let large_request () = - Client.post ~headers ~body:(Body.of_string large_string) uri - >>= fun (_, body) -> - body |> Body.to_string >>| fun s -> - assert_equal (String.length large_string) (Int.of_string s) in - let pipelined_chunk () = - let printer x = x in - let reqs = [ - Request.make ~meth:`POST uri, (Body.of_string "foo"); - Request.make ~meth:`POST uri, (Body.of_string "bar"); - ] in - let body_q = response_bodies |> Queue.of_list in - reqs - |> Pipe.of_list - |> Client.callv uri >>= fun responses -> responses - |> Pipe.to_list - >>= fun resps -> resps - |> Deferred.List.iter ~f:(fun (_resp, body) -> - let expected_body = body_q |> Queue.dequeue_exn in - body |> Body.to_string >>| fun body -> - assert_equal ~printer expected_body body - ) in - let large_chunked_response () = - Client.get ~headers uri >>= fun (resp, body) -> - assert_equal Cohttp.Transfer.Chunked (Response.encoding resp); - body |> Body.to_string >>| String.length >>| fun len -> - assert_equal ~printer:(Int.to_string) (chunk_size * chunks) len in - let expert_pipelined () = - let printer x = x in - Client.get uri >>= fun (_rsp, body) -> - Body.to_string body >>= fun body -> - assert_equal ~printer "expert 1" body; - Client.get ~headers uri >>= fun (_rsp, body) -> - Body.to_string body >>| fun body -> - assert_equal ~printer "expert 2" body in - let check_body_empty_status () = - let is_empty = Cohttp_async.Body.is_empty in - let tests = [ - "empty pipe", Pipe.of_list [], true - ; "pipe with elements", Pipe.of_list ["foo"; "bar"], false - ; "pipe with empty items at the beginning", Pipe.of_list [""; "baz"], false - ; "Pipe with empty strings", Pipe.of_list [""; ""; ""], true] + test_server_s server (fun uri -> + let headers = Header.init_with "connection" "close" in + let empty_chunk () = + Client.get ~headers uri >>= fun (_, body) -> + body |> Body.to_string >>| fun body -> + assert_equal body (String.concat ~sep:"" chunk_body) + in + let large_response () = + Client.get ~headers uri >>= fun (_, body) -> + body |> Body.to_string >>| fun body -> assert_equal body large_string + in + let large_request () = + Client.post ~headers ~body:(Body.of_string large_string) uri + >>= fun (_, body) -> + body |> Body.to_string >>| fun s -> + assert_equal (String.length large_string) (Int.of_string s) + in + let pipelined_chunk () = + let printer x = x in + let reqs = + [ + (Request.make ~meth:`POST uri, Body.of_string "foo"); + (Request.make ~meth:`POST uri, Body.of_string "bar"); + ] + in + let body_q = response_bodies |> Queue.of_list in + reqs |> Pipe.of_list |> Client.callv uri >>= fun responses -> + responses |> Pipe.to_list >>= fun resps -> + resps + |> Deferred.List.iter ~f:(fun (_resp, body) -> + let expected_body = body_q |> Queue.dequeue_exn in + body |> Body.to_string >>| fun body -> + assert_equal ~printer expected_body body) + in + let large_chunked_response () = + Client.get ~headers uri >>= fun (resp, body) -> + assert_equal Cohttp.Transfer.Chunked (Response.encoding resp); + body |> Body.to_string >>| String.length >>| fun len -> + assert_equal ~printer:Int.to_string (chunk_size * chunks) len + in + let expert_pipelined () = + let printer x = x in + Client.get uri >>= fun (_rsp, body) -> + Body.to_string body >>= fun body -> + assert_equal ~printer "expert 1" body; + Client.get ~headers uri >>= fun (_rsp, body) -> + Body.to_string body >>| fun body -> + assert_equal ~printer "expert 2" body + in + let check_body_empty_status () = + let is_empty = Cohttp_async.Body.is_empty in + let tests = + [ + ("empty pipe", Pipe.of_list [], true); + ("pipe with elements", Pipe.of_list [ "foo"; "bar" ], false); + ( "pipe with empty items at the beginning", + Pipe.of_list [ ""; "baz" ], + false ); + ("Pipe with empty strings", Pipe.of_list [ ""; ""; "" ], true); + ] + in + Deferred.List.iter tests ~f:(fun (msg, pipe, expected) -> + is_empty (`Pipe pipe) >>| fun real -> + assert_equal ~msg expected real) + >>= fun () -> + let b = Pipe.of_list [ ""; ""; "foo"; "bar" ] in + is_empty (`Pipe b) >>= fun _ -> + Pipe.to_list b >>| fun real -> + let msg = + "Checking if pipe is empty consumes all leading empty strings" + in + assert_equal ~msg [ "foo"; "bar" ] real in - Deferred.List.iter tests ~f:(fun (msg, pipe, expected) -> - is_empty (`Pipe pipe) - >>| fun real -> - assert_equal ~msg expected real; - ) - >>= fun () -> - let b = Pipe.of_list [""; ""; "foo"; "bar"] in - is_empty (`Pipe b) - >>= fun _ -> - Pipe.to_list b - >>| fun real -> - let msg = "Checking if pipe is empty consumes all leading empty strings" in - assert_equal ~msg ["foo"; "bar"] real - in - [ "empty chunk test", empty_chunk - ; "large response", large_response - ; "large request", large_request - ; "pipelined chunk test", pipelined_chunk - ; "large chunked response", large_chunked_response - ; "expert response", expert_pipelined - ; "check body is_empty status for pipes", check_body_empty_status - ] - end + [ + ("empty chunk test", empty_chunk); + ("large response", large_response); + ("large request", large_request); + ("pipelined chunk test", pipelined_chunk); + ("large chunked response", large_chunked_response); + ("expert response", expert_pipelined); + ("check body is_empty status for pipes", check_body_empty_status); + ]) let () = ts diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml index 24591b6a7c..7566f39f9b 100644 --- a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml @@ -19,8 +19,8 @@ open Js_of_ocaml module C = Cohttp module CLB = Cohttp_lwt.Body -let (>>=) = Lwt.(>>=) -let (>|=) = Lwt.(>|=) +let ( >>= ) = Lwt.( >>= ) +let ( >|= ) = Lwt.( >|= ) module type Params = sig val chunked_response : bool @@ -32,66 +32,56 @@ end let xhr_response_supported = (* from http://stackoverflow.com/questions/8926505/how-to-feature-detect-if-xmlhttprequest-supports-responsetype-arraybuffer *) let xhr = XmlHttpRequest.create () in - let rt = xhr ##. responseType in + let rt = xhr##.responseType in Js.to_string (Js.typeof rt) = "string" - let binary_string str = let len = String.length str in let a = new%js Typed_array.uint8Array len in for i = 0 to len - 1 do - Typed_array.set a i (Char.code (String.get str i)) + Typed_array.set a i (Char.code str.[i]) done; a let string_of_uint8array u8a offset len = - String.init - len - (fun i -> Char.chr (Typed_array.unsafe_get u8a (offset + i))) - -module Body_builder(P : Params) = struct + String.init len (fun i -> Char.chr (Typed_array.unsafe_get u8a (offset + i))) +module Body_builder (P : Params) = struct (* perform the body transfer in chunks from string. *) let chunked_body_str text = let body_len = text##.length in let pos = ref 0 in let chunkerizer () = - if !pos = body_len then - Lwt.return C.Transfer.Done - else - if !pos + P.chunk_size >= body_len then begin - let str = text##(substring_toEnd (!pos)) in + if !pos = body_len then Lwt.return C.Transfer.Done + else if !pos + P.chunk_size >= body_len then ( + let str = text ## (substring_toEnd !pos) in pos := body_len; - Lwt.return (C.Transfer.Final_chunk (P.convert_body_string str)) - end else begin - let str = text##(substring (!pos) (!pos+P.chunk_size)) in + Lwt.return (C.Transfer.Final_chunk (P.convert_body_string str))) + else + let str = text ## (substring !pos (!pos + P.chunk_size)) in pos := !pos + P.chunk_size; Lwt.return (C.Transfer.Chunk (P.convert_body_string str)) - end in - if body_len=0 then CLB.empty + if body_len = 0 then CLB.empty else CLB.of_stream (CLB.create_stream chunkerizer ()) (* perform the body transfer in chunks from arrayBuffer. *) let chunked_body_binary (ab : Typed_array.arrayBuffer Js.t) = let body_len = ab##.byteLength in - let u8a = new%js Typed_array.uint8Array_fromBuffer(ab) in + let u8a = new%js Typed_array.uint8Array_fromBuffer ab in let pos = ref 0 in let chunkerizer () = - if !pos = body_len then - Lwt.return C.Transfer.Done - else - if !pos + P.chunk_size >= body_len then begin + if !pos = body_len then Lwt.return C.Transfer.Done + else if !pos + P.chunk_size >= body_len then ( let str = string_of_uint8array u8a !pos (body_len - !pos) in pos := body_len; - Lwt.return (C.Transfer.Final_chunk str) - end else begin + Lwt.return (C.Transfer.Final_chunk str)) + else let str = string_of_uint8array u8a !pos P.chunk_size in pos := !pos + P.chunk_size; Lwt.return (C.Transfer.Chunk str) - end in - if body_len=0 then CLB.empty + if body_len = 0 then CLB.empty else CLB.of_stream (CLB.create_stream chunkerizer ()) (* choose between chunked and direct transfer *) @@ -102,23 +92,22 @@ module Body_builder(P : Params) = struct | `ArrayBuffer ab -> if P.chunked_response then chunked_body_binary ab else - let u8a = new%js Typed_array.uint8Array_fromBuffer(ab) in - CLB.of_string (string_of_uint8array u8a 0 (ab##.byteLength)) + let u8a = new%js Typed_array.uint8Array_fromBuffer ab in + CLB.of_string (string_of_uint8array u8a 0 ab##.byteLength) end -module Make_api(X : sig - - module Request : Cohttp.S.Request - module Response : Cohttp.S.Response - - val call : - ?headers:Cohttp.Header.t -> - ?body:Cohttp_lwt.Body.t -> - Cohttp.Code.meth -> - Uri.t -> (Response.t * Cohttp_lwt.Body.t) Lwt.t - - end) = struct - +module Make_api (X : sig + module Request : Cohttp.S.Request + module Response : Cohttp.S.Response + + val call : + ?headers:Cohttp.Header.t -> + ?body:Cohttp_lwt.Body.t -> + Cohttp.Code.meth -> + Uri.t -> + (Response.t * Cohttp_lwt.Body.t) Lwt.t +end) = +struct module Request = X.Request module Response = X.Response @@ -130,213 +119,228 @@ module Make_api(X : sig (* The HEAD should not have a response body *) let head ?ctx ?headers uri = let open Lwt in - call ?ctx ?headers ~chunked:false `HEAD uri - >|= fst + call ?ctx ?headers ~chunked:false `HEAD uri >|= fst let get ?ctx ?headers uri = call ?ctx ?headers ~chunked:false `GET uri - let delete ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `DELETE uri - let post ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `POST uri - let put ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `PUT uri - let patch ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `PATCH uri + + let delete ?ctx ?body ?chunked ?headers uri = + call ?ctx ?headers ?body ?chunked `DELETE uri + + let post ?ctx ?body ?chunked ?headers uri = + call ?ctx ?headers ?body ?chunked `POST uri + + let put ?ctx ?body ?chunked ?headers uri = + call ?ctx ?headers ?body ?chunked `PUT uri + + let patch ?ctx ?body ?chunked ?headers uri = + call ?ctx ?headers ?body ?chunked `PATCH uri let post_form ?ctx ?headers ~params uri = - let headers = C.Header.add_opt headers "content-type" "application/x-www-form-urlencoded" in + let headers = + C.Header.add_opt headers "content-type" + "application/x-www-form-urlencoded" + in let body = Cohttp_lwt.Body.of_string (Uri.encoded_of_query params) in post ?ctx ~chunked:false ~headers ~body uri (* No implementation (can it be done?). What should the failure exception be? *) exception Cohttp_lwt_xhr_callv_not_implemented - let callv ?ctx:_ _uri _reqs = - Lwt.fail Cohttp_lwt_xhr_callv_not_implemented (* ??? *) + let callv ?ctx:_ _uri _reqs = Lwt.fail Cohttp_lwt_xhr_callv_not_implemented + + (* ??? *) end module String_io = Cohttp__String_io module IO = Cohttp_lwt__String_io -module Header_io = Cohttp__Header_io.Make(IO) - -module Make_client_async(P : Params) = Make_api(struct - - module Response = Cohttp.Response - module Request = Cohttp.Request - module Bb = Body_builder(P) - - let call ?headers ?body meth uri = - let xml = XmlHttpRequest.create () in - xml ##. withCredentials := (Js.bool P.with_credentials) ; - if xhr_response_supported then - xml ##. responseType := Js.string "arraybuffer" ; - let (res : (Response.t Lwt.t * CLB.t) Lwt.t), wake = Lwt.task () in - let () = xml##(_open (Js.string (C.Code.string_of_method meth)) - (Js.string (Uri.to_string uri)) - (Js._true)) (* asynchronous call *) - in - (* set request headers *) - let () = - match headers with - | None -> () - | Some(headers) -> +module Header_io = Cohttp__Header_io.Make (IO) + +module Make_client_async (P : Params) = Make_api (struct + module Response = Cohttp.Response + module Request = Cohttp.Request + module Bb = Body_builder (P) + + let call ?headers ?body meth uri = + let xml = XmlHttpRequest.create () in + xml##.withCredentials := Js.bool P.with_credentials; + if xhr_response_supported then xml##.responseType := Js.string "arraybuffer"; + let (res : (Response.t Lwt.t * CLB.t) Lwt.t), wake = Lwt.task () in + let () = + xml + ## (_open + (Js.string (C.Code.string_of_method meth)) + (Js.string (Uri.to_string uri)) + Js._true) + (* asynchronous call *) + in + (* set request headers *) + let () = + match headers with + | None -> () + | Some headers -> C.Header.iter (fun k v -> - (* some headers lead to errors in the javascript console, should - we filter then out here? *) - List.iter - (fun v -> xml##(setRequestHeader (Js.string k) (Js.string v))) v) + (* some headers lead to errors in the javascript console, should + we filter then out here? *) + List.iter + (fun v -> xml ## (setRequestHeader (Js.string k) (Js.string v))) + v) headers - in + in - xml##.onreadystatechange := - Js.wrap_callback - (fun _ -> - match xml##.readyState with - | XmlHttpRequest.DONE -> - begin - try - (* construct body *) - let body = - let b = - let respText () = - Js.Opt.case xml##.responseText (fun () -> `String (Js.string "")) - (fun s -> `String s) - in - if xhr_response_supported then - Js.Opt.case - (File.CoerceTo.arrayBuffer xml##.response) - (fun () -> Firebug.console##log - (Js.string "XHR Response is not an arrayBuffer; using responseText"); - (respText ())) - (fun ab -> `ArrayBuffer ab) - else - respText () - in - Bb.get b - in - (* (re-)construct the response *) - let response = - let resp_headers = Js.to_string (xml##getAllResponseHeaders) in - let channel = String_io.open_in resp_headers in - Lwt.(Header_io.parse channel >|= fun resp_headers -> - Response.make - ~version:`HTTP_1_1 - ~status:(C.Code.status_of_code xml##.status) - ~flush:false (* ??? *) - ~encoding:(CLB.transfer_encoding body) - ~headers:resp_headers - ()) + xml##.onreadystatechange := + Js.wrap_callback (fun _ -> + match xml##.readyState with + | XmlHttpRequest.DONE -> ( + try + (* construct body *) + let body = + let b = + let respText () = + Js.Opt.case xml##.responseText + (fun () -> `String (Js.string "")) + (fun s -> `String s) in - (* Note; a type checker subversion seems to be possible here (4.01.0). - * Remove the type constraint on Lwt.task above and return any old - * guff here. It'll compile and crash in the browser! *) - Lwt.wakeup wake (response, body) - with - | e -> Lwt.wakeup_exn wake e - end - | _ -> () - ); - - (* perform call *) - (match body with - | None -> Lwt.return (xml##(send (Js.null))) - | Some(body) -> - CLB.to_string body >>= fun body -> - let bs = binary_string body in - (*Js.Opt.case (File.CoerceTo.blob (Obj.magic blob)) - (fun () -> Lwt.fail_with "could not coerce to blob") - (fun blob -> Lwt.return (xml##(send_blob blob)))*) - (*Lwt.return (xml##send (Js.Opt.return bs)) *) - Lwt.return (xml##send (Js.Opt.return (Obj.magic bs))) - ) - >>= fun () -> - Lwt.on_cancel res (fun () -> xml##abort); - - (* unwrap the response *) - Lwt.(res >>= fun (r, b) -> r >>= fun r -> Lwt.return (r,b)) - - end) - -module Make_client_sync(P : Params) = Make_api(struct - - module Response = Cohttp.Response - module Request = Cohttp.Request - module Bb = Body_builder(P) - - let call ?headers ?body meth uri = - let xml = XmlHttpRequest.create () in - xml ##. withCredentials := (Js.bool P.with_credentials) ; - if xhr_response_supported then - xml ##. responseType := Js.string "arraybuffer" ; - let () = xml##(_open (Js.string (C.Code.string_of_method meth)) - (Js.string (Uri.to_string uri)) - (Js._false)) (* synchronous call *) - in - (* set request headers *) - let () = - match headers with - | None -> () - | Some(headers) -> + if xhr_response_supported then + Js.Opt.case + (File.CoerceTo.arrayBuffer xml##.response) + (fun () -> + Firebug.console##log + (Js.string + "XHR Response is not an arrayBuffer; using \ + responseText"); + respText ()) + (fun ab -> `ArrayBuffer ab) + else respText () + in + Bb.get b + in + (* (re-)construct the response *) + let response = + let resp_headers = Js.to_string xml##getAllResponseHeaders in + let channel = String_io.open_in resp_headers in + Lwt.( + Header_io.parse channel >|= fun resp_headers -> + Response.make ~version:`HTTP_1_1 + ~status:(C.Code.status_of_code xml##.status) + ~flush:false (* ??? *) + ~encoding:(CLB.transfer_encoding body) + ~headers:resp_headers ()) + in + (* Note; a type checker subversion seems to be possible here (4.01.0). + * Remove the type constraint on Lwt.task above and return any old + * guff here. It'll compile and crash in the browser! *) + Lwt.wakeup wake (response, body) + with e -> Lwt.wakeup_exn wake e) + | _ -> ()); + + (* perform call *) + (match body with + | None -> Lwt.return xml ## (send Js.null) + | Some body -> + CLB.to_string body >>= fun body -> + let bs = binary_string body in + (*Js.Opt.case (File.CoerceTo.blob (Obj.magic blob)) + (fun () -> Lwt.fail_with "could not coerce to blob") + (fun blob -> Lwt.return (xml##(send_blob blob)))*) + (*Lwt.return (xml##send (Js.Opt.return bs)) *) + Lwt.return (xml##send (Js.Opt.return (Obj.magic bs)))) + >>= fun () -> + Lwt.on_cancel res (fun () -> xml##abort); + + (* unwrap the response *) + Lwt.( + res >>= fun (r, b) -> + r >>= fun r -> Lwt.return (r, b)) +end) + +module Make_client_sync (P : Params) = Make_api (struct + module Response = Cohttp.Response + module Request = Cohttp.Request + module Bb = Body_builder (P) + + let call ?headers ?body meth uri = + let xml = XmlHttpRequest.create () in + xml##.withCredentials := Js.bool P.with_credentials; + if xhr_response_supported then xml##.responseType := Js.string "arraybuffer"; + let () = + xml + ## (_open + (Js.string (C.Code.string_of_method meth)) + (Js.string (Uri.to_string uri)) + Js._false) + (* synchronous call *) + in + (* set request headers *) + let () = + match headers with + | None -> () + | Some headers -> C.Header.iter - (fun k v -> List.iter - (* some headers lead to errors in the javascript console, should - we filter then out here? *) - (fun v -> - xml##(setRequestHeader (Js.string k) (Js.string v))) v) + (fun k v -> + List.iter + (* some headers lead to errors in the javascript console, should + we filter then out here? *) + (fun v -> + xml ## (setRequestHeader (Js.string k) (Js.string v))) + v) headers + in + (* perform call *) + (match body with + | None -> Lwt.return xml ## (send Js.null) + | Some body -> + CLB.to_string body >|= fun body -> + let bs = binary_string body in + xml ## (send (Js.Opt.return (Obj.magic bs)))) + >>= fun _body -> + (* TODO: FIXME: looks like an indenting or cut-and-pasto here. Check this - avsm *) + (* construct body *) + let body = + let b = + let respText () = + Js.Opt.case xml##.responseText + (fun () -> `String (Js.string "")) + (fun s -> `String s) + in + if xhr_response_supported then + Js.Opt.case + (File.CoerceTo.arrayBuffer xml##.response) + (fun () -> + Firebug.console##log + (Js.string + "XHR Response is not an arrayBuffer; using responseText"); + respText ()) + (fun ab -> `ArrayBuffer ab) + else respText () in - (* perform call *) - (match body with - | None -> Lwt.return (xml##(send (Js.null))) - | Some(body) -> - CLB.to_string body >|= fun body -> - let bs = binary_string body in - (xml##(send (Js.Opt.return (Obj.magic bs))))) >>= fun _body -> - (* TODO: FIXME: looks like an indenting or cut-and-pasto here. Check this - avsm *) - (* construct body *) - let body = - let b = - let respText () = - Js.Opt.case xml##.responseText (fun () -> `String (Js.string "")) - (fun s -> `String s) in - if xhr_response_supported then - Js.Opt.case - (File.CoerceTo.arrayBuffer xml##.response) - (fun () -> Firebug.console##log - (Js.string "XHR Response is not an arrayBuffer; using responseText"); - (respText ())) - (fun ab -> `ArrayBuffer ab) - else - respText () - in - Bb.get b - in - - (* (re-)construct the response *) - let resp_headers = Js.to_string (xml##getAllResponseHeaders) in - Header_io.parse (String_io.open_in resp_headers) - >>= fun resp_headers -> - - let response = Response.make - ~version:`HTTP_1_1 - ~status:(Cohttp.Code.status_of_code xml##.status) - ~flush:false - ~encoding:(CLB.transfer_encoding body) - ~headers:resp_headers - () - in - - Lwt.return (response,body) + Bb.get b + in + + (* (re-)construct the response *) + let resp_headers = Js.to_string xml##getAllResponseHeaders in + Header_io.parse (String_io.open_in resp_headers) >>= fun resp_headers -> + let response = + Response.make ~version:`HTTP_1_1 + ~status:(Cohttp.Code.status_of_code xml##.status) + ~flush:false + ~encoding:(CLB.transfer_encoding body) + ~headers:resp_headers () + in + + Lwt.return (response, body) +end) +module Client = Make_client_async (struct + let chunked_response = true + let chunk_size = 128 * 1024 + let convert_body_string = Js.to_bytestring + let with_credentials = false end) -module Client = Make_client_async(struct - let chunked_response = true - let chunk_size = 128 * 1024 - let convert_body_string = Js.to_bytestring - let with_credentials = false - end) - -module Client_sync = Make_client_sync(struct - let chunked_response = false - let chunk_size = 0 - let convert_body_string = Js.to_bytestring - let with_credentials = false - end) +module Client_sync = Make_client_sync (struct + let chunked_response = false + let chunk_size = 0 + let convert_body_string = Js.to_bytestring + let with_credentials = false +end) diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli index cba8e13c14..71b6382c40 100644 --- a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli @@ -19,37 +19,35 @@ (** Configuration parameters for the XmlHttpRequest engines *) module type Params = sig - (** Should the response body data be chunked? *) val chunked_response : bool + (** Should the response body data be chunked? *) - (** Size of chunks *) val chunk_size : int + (** Size of chunks *) - (** JavaScript string to OCaml conversion. [Js.to_bytestring] or - [Js.to_string] *) val convert_body_string : Js_of_ocaml.Js.js_string Js_of_ocaml.Js.t -> string + (** JavaScript string to OCaml conversion. [Js.to_bytestring] or + [Js.to_string] *) - (** Whether withCredentials property of XHR is set. *) val with_credentials : bool + (** Whether withCredentials property of XHR is set. *) end -(** Build an asynchronous engine with chunked/unchucked response data - treated as raw bytes or UTF *) -module Make_client_async(P : Params) : Cohttp_lwt.S.Client +(** Build an asynchronous engine with chunked/unchucked response data treated as + raw bytes or UTF *) +module Make_client_async (P : Params) : Cohttp_lwt.S.Client -(** Build a synchronous engine with chunked/unchucked response data - treated as raw bytes or UTF *) -module Make_client_sync(P : Params) : Cohttp_lwt.S.Client +(** Build a synchronous engine with chunked/unchucked response data treated as + raw bytes or UTF *) +module Make_client_sync (P : Params) : Cohttp_lwt.S.Client -(** The [Client] module implements an HTTP client interface - using asynchronous XmlHttpRequests. The response body is returned - in chucked form with 128Kb / chunk. Body data is treated as raw bytes. - withCredentials property of XHR is set to false. *) module Client : Cohttp_lwt.S.Client +(** The [Client] module implements an HTTP client interface using asynchronous + XmlHttpRequests. The response body is returned in chucked form with 128Kb / + chunk. Body data is treated as raw bytes. withCredentials property of XHR is + set to false. *) -(** The [Client_sync] module implements an HTTP client interface - using synchronous XmlHttpRequests. The response is not chunked - and treated as raw bytes. - withCredentials property of XHR is set to false. *) module Client_sync : Cohttp_lwt.S.Client - +(** The [Client_sync] module implements an HTTP client interface using + synchronous XmlHttpRequests. The response is not chunked and treated as raw + bytes. withCredentials property of XHR is set to false. *) diff --git a/cohttp-lwt-unix/bin/cohttp_curl_lwt.ml b/cohttp-lwt-unix/bin/cohttp_curl_lwt.ml index e391675dd5..2ca0785f42 100644 --- a/cohttp-lwt-unix/bin/cohttp_curl_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_curl_lwt.ml @@ -19,7 +19,9 @@ open Lwt open Cohttp open Cohttp_lwt_unix -let src = Logs.Src.create "cohttp.lwt.curl" ~doc:"Cohttp Lwt curl implementation" +let src = + Logs.Src.create "cohttp.lwt.curl" ~doc:"Cohttp Lwt curl implementation" + module Log = (val Logs.src_log src : Logs.LOG) let client uri ofile meth' = @@ -29,76 +31,80 @@ let client uri ofile meth' = Client.call meth uri >>= fun (resp, body) -> let status = Response.status resp in Log.debug (fun d -> - d "Client %s returned: %s" meth' (Code.string_of_status status) - ); + d "Client %s returned: %s" meth' (Code.string_of_status status)); (* TODO follow redirects *) match Code.is_success (Code.code_of_status status) with | false -> - prerr_endline (Code.string_of_status status); - exit 1 - | true -> - Cohttp_lwt.Body.length body >>= fun (len, body) -> - Log.debug (fun d -> d "Client body length: %Ld" len); - Cohttp_lwt.Body.to_string body >>= fun _s -> - let output_body c = - Lwt_stream.iter_s (Lwt_io.fprint c) (Cohttp_lwt.Body.to_stream body) in - match ofile with - | None -> output_body Lwt_io.stdout - | Some fname -> Lwt_io.with_file ~mode:Lwt_io.output fname output_body + prerr_endline (Code.string_of_status status); + exit 1 + | true -> ( + Cohttp_lwt.Body.length body >>= fun (len, body) -> + Log.debug (fun d -> d "Client body length: %Ld" len); + Cohttp_lwt.Body.to_string body >>= fun _s -> + let output_body c = + Lwt_stream.iter_s (Lwt_io.fprint c) (Cohttp_lwt.Body.to_stream body) + in + match ofile with + | None -> output_body Lwt_io.stdout + | Some fname -> Lwt_io.with_file ~mode:Lwt_io.output fname output_body) let run_client verbose ofile uri meth = - Lwt_main.run ( - (if verbose - then ( - (* activate debug sets the reporter *) - Cohttp_lwt_unix.Debug.activate_debug (); - Log.debug (fun d -> d ">>> Debug active"); - return ()) - else return ()) - >>= fun () -> - client uri ofile meth - ) + Lwt_main.run + ( (if verbose then ( + (* activate debug sets the reporter *) + Cohttp_lwt_unix.Debug.activate_debug (); + Log.debug (fun d -> d ">>> Debug active"); + return ()) + else return ()) + >>= fun () -> client uri ofile meth ) open Cmdliner let uri = let loc : Uri.t Arg.converter = let parse s = - try `Ok (Uri.of_string s) - with Failure _ -> `Error "unable to parse URI" in - parse, fun ppf p -> Format.fprintf ppf "%s" (Uri.to_string p) + try `Ok (Uri.of_string s) with Failure _ -> `Error "unable to parse URI" + in + (parse, fun ppf p -> Format.fprintf ppf "%s" (Uri.to_string p)) in - Arg.(required & pos 0 (some loc) None & info [] ~docv:"URI" - ~doc:"string of the remote address (e.g. https://google.com)") + Arg.( + required + & pos 0 (some loc) None + & info [] ~docv:"URI" + ~doc:"string of the remote address (e.g. https://google.com)") let meth = let doc = "Set http method" in - Arg.(value & opt string "GET" & info ["X"; "request"] ~doc) + Arg.(value & opt string "GET" & info [ "X"; "request" ] ~doc) let verb = let doc = "Display additional debugging to standard error." in - Arg.(value & flag & info ["v"; "verbose"] ~doc) + Arg.(value & flag & info [ "v"; "verbose" ] ~doc) let ofile = let doc = "Output filename to store the URI into." in - Arg.(value & opt (some string) None & info ["o"] ~docv:"FILE" ~doc) + Arg.(value & opt (some string) None & info [ "o" ] ~docv:"FILE" ~doc) let cmd = let doc = "retrieve a remote URI contents" in - let man = [ - `S "DESCRIPTION"; - `P "$(tname) fetches the remote $(i,URI) and prints it to standard output. \ - The output file can also be specified with the $(b,-o) option, and \ - more verbose debugging out obtained via the $(b,-v) option."; - `S "BUGS"; - `P "Report them via e-mail to , or \ - on the issue tracker at "; - `S "SEE ALSO"; - `P "$(b,curl)(1), $(b,wget)(1)" ] + let man = + [ + `S "DESCRIPTION"; + `P + "$(tname) fetches the remote $(i,URI) and prints it to standard \ + output. The output file can also be specified with the $(b,-o) \ + option, and more verbose debugging out obtained via the $(b,-v) \ + option."; + `S "BUGS"; + `P + "Report them via e-mail to , or \ + on the issue tracker at \ + "; + `S "SEE ALSO"; + `P "$(b,curl)(1), $(b,wget)(1)"; + ] in - Term.(pure run_client $ verb $ ofile $ uri $ meth), - Term.info "cohttp-curl" ~version:Cohttp.Conf.version ~doc ~man + ( Term.(pure run_client $ verb $ ofile $ uri $ meth), + Term.info "cohttp-curl" ~version:Cohttp.Conf.version ~doc ~man ) -let () = - match Term.eval cmd - with `Error _ -> exit 1 | _ -> exit 0 +let () = match Term.eval cmd with `Error _ -> exit 1 | _ -> exit 0 diff --git a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml index c2fa604465..923b4936f2 100644 --- a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml @@ -17,7 +17,6 @@ }}}*) open Printf - open Lwt open Cohttp open Cohttp_lwt_unix @@ -25,10 +24,11 @@ open Cohttp_lwt_unix let handler ~verbose _ req body = let uri = Cohttp.Request.uri req in (* Log the request to the console *) - if verbose then eprintf "--> %s %s %s\n%!" - (Cohttp.(Code.string_of_method (Request.meth req))) - (Uri.to_string uri) - (Sexplib0.Sexp.to_string_hum (Request.sexp_of_t req)); + if verbose then + eprintf "--> %s %s %s\n%!" + Cohttp.(Code.string_of_method (Request.meth req)) + (Uri.to_string uri) + (Sexplib0.Sexp.to_string_hum (Request.sexp_of_t req)); (* Strip out hop-by-hop connection headers *) let headers = Request.headers req |> fun h -> @@ -49,8 +49,7 @@ let handler ~verbose _ req body = let headers = Response.headers resp |> fun h -> Header.remove h "transfer-encoding" |> fun h -> - Header.remove h "content-length" |> fun h -> - Header.remove h "connection" + Header.remove h "content-length" |> fun h -> Header.remove h "connection" in Server.respond ~headers ~status ~body () @@ -60,13 +59,16 @@ let sockaddr_of_host_and_port host port = let start_proxy port host verbose cert key () = printf "Listening for HTTP request on: %s %d\n%!" host port; - let conn_closed (ch,_conn) = + let conn_closed (ch, _conn) = printf "Connection %s closed\n%!" - (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch)) in + (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch)) + in let callback = handler ~verbose in let config = Server.make ~callback ~conn_closed () in - let mode = match cert, key with - | Some c, Some k -> `TLS (`Crt_file_path c, `Key_file_path k, `No_password, `Port port) + let mode = + match (cert, key) with + | Some c, Some k -> + `TLS (`Crt_file_path c, `Key_file_path k, `No_password, `Port port) | _ -> `TCP (`Port port) in Server.create ~mode config @@ -78,37 +80,38 @@ open Cmdliner let host = let doc = "IP address to listen on." in - Arg.(value & opt string "0.0.0.0" & info ["s"] ~docv:"HOST" ~doc) + Arg.(value & opt string "0.0.0.0" & info [ "s" ] ~docv:"HOST" ~doc) let port = let doc = "TCP port to listen on." in - Arg.(value & opt int 8080 & info ["p"] ~docv:"PORT" ~doc) + Arg.(value & opt int 8080 & info [ "p" ] ~docv:"PORT" ~doc) let verb = let doc = "Logging output to console." in - Arg.(value & flag & info ["v"; "verbose"] ~doc) + Arg.(value & flag & info [ "v"; "verbose" ] ~doc) let ssl_cert = let doc = "SSL certificate file." in - Arg.(value & opt (some string) None & info ["c"] ~docv:"SSL_CERT" ~doc) + Arg.(value & opt (some string) None & info [ "c" ] ~docv:"SSL_CERT" ~doc) let ssl_key = let doc = "SSL key file." in - Arg.(value & opt (some string) None & info ["k"] ~docv:"SSL_KEY" ~doc) + Arg.(value & opt (some string) None & info [ "k" ] ~docv:"SSL_KEY" ~doc) let cmd = let doc = "a simple http proxy" in - let man = [ - `S "DESCRIPTION"; - `P "$(tname) sets up a simple http proxy with lwt as backend"; - `S "BUGS"; - `P "Report them via e-mail to , or \ - on the issue tracker at "; - ] in - Term.(pure lwt_start_proxy $ port $ host $ verb $ ssl_cert $ ssl_key), - Term.info "cohttp-proxy" ~version:Cohttp.Conf.version ~doc ~man + let man = + [ + `S "DESCRIPTION"; + `P "$(tname) sets up a simple http proxy with lwt as backend"; + `S "BUGS"; + `P + "Report them via e-mail to , or \ + on the issue tracker at \ + "; + ] + in + ( Term.(pure lwt_start_proxy $ port $ host $ verb $ ssl_cert $ ssl_key), + Term.info "cohttp-proxy" ~version:Cohttp.Conf.version ~doc ~man ) -let () = - match Term.eval cmd with - | `Error _ -> exit 1 - | _ -> exit 0 +let () = match Term.eval cmd with `Error _ -> exit 1 | _ -> exit 0 diff --git a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml index 219d654b52..cc3ddef2d2 100644 --- a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml @@ -18,15 +18,16 @@ open Lwt.Infix open Cohttp_lwt_unix - open Cohttp_server let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server" + module Log = (val Logs.src_log src : Logs.LOG) -let method_filter meth (res,body) = match meth with - | `HEAD -> Lwt.return (res,`Empty) - | _ -> Lwt.return (res,body) +let method_filter meth (res, body) = + match meth with + | `HEAD -> Lwt.return (res, `Empty) + | _ -> Lwt.return (res, body) let serve_file ~docroot ~uri = let fname = Server.resolve_local_file ~docroot ~uri in @@ -34,118 +35,128 @@ let serve_file ~docroot ~uri = let ls_dir dir = Lwt_stream.to_list - (Lwt_stream.filter ((<>) ".") - (Lwt_unix.files_of_directory dir)) + (Lwt_stream.filter (( <> ) ".") (Lwt_unix.files_of_directory dir)) let serve ~info ~docroot ~index uri path = let file_name = Server.resolve_local_file ~docroot ~uri in - Lwt.catch (fun () -> - Lwt_unix.stat file_name - >>= fun stat -> - match kind_of_unix_kind stat.Unix.st_kind with - | `Directory -> begin - let path_len = String.length path in - if path_len <> 0 && path.[path_len - 1] <> '/' - then Server.respond_redirect ~uri:(Uri.with_path uri (path^"/")) () - else match Sys.file_exists (file_name / index) with - | true -> let uri = Uri.with_path uri (path / index) in + Lwt.catch + (fun () -> + Lwt_unix.stat file_name >>= fun stat -> + match kind_of_unix_kind stat.Unix.st_kind with + | `Directory -> ( + let path_len = String.length path in + if path_len <> 0 && path.[path_len - 1] <> '/' then + Server.respond_redirect ~uri:(Uri.with_path uri (path ^ "/")) () + else + match Sys.file_exists (file_name / index) with + | true -> + let uri = Uri.with_path uri (path / index) in serve_file ~docroot ~uri - | false -> - ls_dir file_name - >>= Lwt_list.map_s (fun f -> - let file_name = file_name / f in - Lwt.try_bind - (fun () -> Lwt_unix.LargeFile.stat file_name) - (fun stat -> - Lwt.return (Some (kind_of_unix_kind stat.Unix.LargeFile.st_kind), - stat.Unix.LargeFile.st_size, - f)) - (fun _exn -> Lwt.return (None, 0L, f))) - >>= fun listing -> - let body = html_of_listing uri path (sort listing) info in - Server.respond_string ~status:`OK ~body () - end - | `File -> serve_file ~docroot ~uri - | _ -> - Server.respond_string ~status:`Forbidden - ~body:(html_of_forbidden_unnormal path info) - () - ) (function - | Unix.Unix_error(Unix.ENOENT, "stat", p) as e -> - if p = file_name - then Server.respond_string ~status:`Not_found - ~body:(html_of_not_found path info) - () - else Lwt.fail e - | e -> Lwt.fail e - ) - -let handler ~info ~docroot ~index (ch,_conn) req _body = + | false -> + ls_dir file_name + >>= Lwt_list.map_s (fun f -> + let file_name = file_name / f in + Lwt.try_bind + (fun () -> Lwt_unix.LargeFile.stat file_name) + (fun stat -> + Lwt.return + ( Some + (kind_of_unix_kind stat.Unix.LargeFile.st_kind), + stat.Unix.LargeFile.st_size, + f )) + (fun _exn -> Lwt.return (None, 0L, f))) + >>= fun listing -> + let body = html_of_listing uri path (sort listing) info in + Server.respond_string ~status:`OK ~body ()) + | `File -> serve_file ~docroot ~uri + | _ -> + Server.respond_string ~status:`Forbidden + ~body:(html_of_forbidden_unnormal path info) + ()) + (function + | Unix.Unix_error (Unix.ENOENT, "stat", p) as e -> + if p = file_name then + Server.respond_string ~status:`Not_found + ~body:(html_of_not_found path info) + () + else Lwt.fail e + | e -> Lwt.fail e) + +let handler ~info ~docroot ~index (ch, _conn) req _body = let uri = Cohttp.Request.uri req in let path = Uri.path uri in (* Log the request to the console *) - Log.debug (fun m -> m - "%s %s %s" - (Cohttp.(Code.string_of_method (Request.meth req))) - path - (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))); + Log.debug (fun m -> + m "%s %s %s" + Cohttp.(Code.string_of_method (Request.meth req)) + path + (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))); (* Get a canonical filename from the URL and docroot *) match Request.meth req with | (`GET | `HEAD) as meth -> - serve ~info ~docroot ~index uri path - >>= method_filter meth + serve ~info ~docroot ~index uri path >>= method_filter meth | meth -> - let meth = Cohttp.Code.string_of_method meth in - let allowed = ["GET"; "HEAD"] in - let headers = Cohttp.Header.(add_multi (init ()) "allow" allowed) in - Server.respond_string ~headers ~status:`Method_not_allowed - ~body:(html_of_method_not_allowed meth (String.concat "," allowed) path info) () + let meth = Cohttp.Code.string_of_method meth in + let allowed = [ "GET"; "HEAD" ] in + let headers = Cohttp.Header.(add_multi (init ()) "allow" allowed) in + Server.respond_string ~headers ~status:`Method_not_allowed + ~body: + (html_of_method_not_allowed meth + (String.concat "," allowed) + path info) + () let start_server docroot port host index tls () = Log.info (fun m -> m "Listening for HTTP request on: %s %d" host port); - let info = Printf.sprintf "Served by Cohttp/Lwt listening on %s:%d" host port in - let conn_closed (ch,_conn) = - Log.debug (fun m -> m "connection %s closed" - (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))) in + let info = + Printf.sprintf "Served by Cohttp/Lwt listening on %s:%d" host port + in + let conn_closed (ch, _conn) = + Log.debug (fun m -> + m "connection %s closed" + (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))) + in let callback = handler ~info ~docroot ~index in let config = Server.make ~callback ~conn_closed () in - let mode = match tls with - | Some (c, k) -> `TLS (`Crt_file_path c, `Key_file_path k, `No_password, `Port port) + let mode = + match tls with + | Some (c, k) -> + `TLS (`Crt_file_path c, `Key_file_path k, `No_password, `Port port) | None -> `TCP (`Port port) in - Conduit_lwt_unix.init ~src:host () - >>= fun ctx -> + Conduit_lwt_unix.init ~src:host () >>= fun ctx -> let ctx = Cohttp_lwt_unix.Net.init ~ctx () in Server.create ~ctx ~mode config let lwt_start_server docroot port host index verbose tls = - if verbose <> None then begin + if verbose <> None then ( (* activate_debug sets the reporter *) Cohttp_lwt_unix.Debug.activate_debug (); - Logs.set_level verbose - end; + Logs.set_level verbose); Lwt_main.run (start_server docroot port host index tls ()) - open Cmdliner let host = let doc = "IP address to listen on." in - Arg.(value & opt string "::" & info ["s"] ~docv:"HOST" ~doc) + Arg.(value & opt string "::" & info [ "s" ] ~docv:"HOST" ~doc) let port = let doc = "TCP port to listen on." in - Arg.(value & opt int 8080 & info ["p"] ~docv:"PORT" ~doc) + Arg.(value & opt int 8080 & info [ "p" ] ~docv:"PORT" ~doc) let index = let doc = "Name of index file in directory." in - Arg.(value & opt string "index.html" & info ["i"] ~docv:"INDEX" ~doc) + Arg.(value & opt string "index.html" & info [ "i" ] ~docv:"INDEX" ~doc) let verb = Logs_cli.level () let tls = let doc = "TLS certificate files." in - Arg.(value & opt (some (pair string string)) None & info ["tls"] ~docv:"CERT,KEY" ~doc) + Arg.( + value + & opt (some (pair string string)) None + & info [ "tls" ] ~docv:"CERT,KEY" ~doc) let doc_root = let doc = "Serving directory." in @@ -153,17 +164,18 @@ let doc_root = let cmd = let doc = "a simple http server" in - let man = [ - `S "DESCRIPTION"; - `P "$(tname) sets up a simple http server with lwt as backend"; - `S "BUGS"; - `P "Report them via e-mail to , or \ - on the issue tracker at "; - ] in - Term.(pure lwt_start_server $ doc_root $ port $ host $ index $ verb $ tls), - Term.info "cohttp-server" ~version:Cohttp.Conf.version ~doc ~man - -let () = - match Term.eval cmd with - | `Error _ -> exit 1 - | _ -> exit 0 + let man = + [ + `S "DESCRIPTION"; + `P "$(tname) sets up a simple http server with lwt as backend"; + `S "BUGS"; + `P + "Report them via e-mail to , or \ + on the issue tracker at \ + "; + ] + in + ( Term.(pure lwt_start_server $ doc_root $ port $ host $ index $ verb $ tls), + Term.info "cohttp-server" ~version:Cohttp.Conf.version ~doc ~man ) + +let () = match Term.eval cmd with `Error _ -> exit 1 | _ -> exit 0 diff --git a/cohttp-lwt-unix/src/client.ml b/cohttp-lwt-unix/src/client.ml index 099be628a4..7d190532ed 100644 --- a/cohttp-lwt-unix/src/client.ml +++ b/cohttp-lwt-unix/src/client.ml @@ -1,3 +1,3 @@ -include Cohttp_lwt.Make_client(Io)(Net) +include Cohttp_lwt.Make_client (Io) (Net) let custom_ctx = Net.init diff --git a/cohttp-lwt-unix/src/client.mli b/cohttp-lwt-unix/src/client.mli index a883ab6e9a..af591aad0b 100644 --- a/cohttp-lwt-unix/src/client.mli +++ b/cohttp-lwt-unix/src/client.mli @@ -1,16 +1,13 @@ (** The [Client] module implements the full UNIX HTTP client interface, - including the UNIX-specific functions defined in {!C }. *) + including the UNIX-specific functions defined in {!C}. *) include Cohttp_lwt.S.Client with type ctx = Net.ctx - -(** [custom_ctx ?ctx ?resolver ()] will return a context that is the - same as the {!default_ctx}, but with either the connection handling - or resolution module overridden with [ctx] or [resolver] respectively. - This is useful to supply a {!Conduit_lwt_unix.ctx} with a custom - source network interface, or a {!Resolver_lwt.t} with a different - name resolution strategy (for instance to override a hostname to - point it to a Unix domain socket). *) -val custom_ctx: - ?ctx:Conduit_lwt_unix.ctx -> - ?resolver:Resolver_lwt.t -> unit -> ctx +val custom_ctx : + ?ctx:Conduit_lwt_unix.ctx -> ?resolver:Resolver_lwt.t -> unit -> ctx +(** [custom_ctx ?ctx ?resolver ()] will return a context that is the same as the + {!default_ctx}, but with either the connection handling or resolution module + overridden with [ctx] or [resolver] respectively. This is useful to supply a + {!Conduit_lwt_unix.ctx} with a custom source network interface, or a + {!Resolver_lwt.t} with a different name resolution strategy (for instance to + override a hostname to point it to a Unix domain socket). *) diff --git a/cohttp-lwt-unix/src/cohttp_lwt_unix.ml b/cohttp-lwt-unix/src/cohttp_lwt_unix.ml index 5c171184c7..14eb2cc29a 100644 --- a/cohttp-lwt-unix/src/cohttp_lwt_unix.ml +++ b/cohttp-lwt-unix/src/cohttp_lwt_unix.ml @@ -16,15 +16,13 @@ module Request = struct include Cohttp.Request - include (Make(Io) - : module type of Make(Io) with type t := t) -end + include (Make (Io) : module type of Make (Io) with type t := t) + end module Response = struct include Cohttp.Response - include (Make(Io) - : module type of Make(Io) with type t := t) -end + include (Make (Io) : module type of Make (Io) with type t := t) + end module Client = Client module Server = Server diff --git a/cohttp-lwt-unix/src/debug.ml b/cohttp-lwt-unix/src/debug.ml index 49c6638016..090f21e359 100644 --- a/cohttp-lwt-unix/src/debug.ml +++ b/cohttp-lwt-unix/src/debug.ml @@ -22,52 +22,63 @@ open Lwt.Infix let default_reporter (file_descr, ppf) = let ppf, flush = let buf = Buffer.create 0x100 in - Fmt.with_buffer ~like:ppf buf, - (fun () -> - let str = Buffer.contents buf in Buffer.reset buf ; str) in + ( Fmt.with_buffer ~like:ppf buf, + fun () -> + let str = Buffer.contents buf in + Buffer.reset buf; + str ) + in let report src level ~over k msgf = let k _ = let write () = let buf = Bytes.unsafe_of_string (flush ()) in let rec go off len = Lwt_unix.write file_descr buf off len >>= fun len' -> - if len' = len then Lwt.return_unit - else go (off + len') (len - len') in - go 0 (Bytes.length buf) in - let clean () = over () ; Lwt.return_unit in - Lwt.async (fun () -> Lwt.catch - (fun () -> Lwt.finalize write clean) - (fun exn -> - Logs.warn (fun m -> m "Flushing error: %s." (Printexc.to_string exn)) ; - Lwt.return_unit)) ; - k () in + if len' = len then Lwt.return_unit else go (off + len') (len - len') + in + go 0 (Bytes.length buf) + in + let clean () = + over (); + Lwt.return_unit + in + Lwt.async (fun () -> + Lwt.catch + (fun () -> Lwt.finalize write clean) + (fun exn -> + Logs.warn (fun m -> + m "Flushing error: %s." (Printexc.to_string exn)); + Lwt.return_unit)); + k () + in let with_metadata header _tags k ppf fmt = Format.kfprintf k ppf ("%a[%a]: " ^^ fmt ^^ "\n%!") Logs_fmt.pp_header (level, header) Fmt.(styled `Magenta string) - (Logs.Src.name src) in - msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in + (Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt + in { Logs.report } -let set_log = lazy ( - (* If no reporter has been set by the application, set default one - that prints to stderr *) - if (Logs.reporter ()) == Logs.nop_reporter - then - Logs.set_level @@ Some Logs.Debug; - Logs.set_reporter (default_reporter (Lwt_unix.stderr, Fmt.stderr)); -) +let set_log = + lazy + ((* If no reporter has been set by the application, set default one + that prints to stderr *) + if Logs.reporter () == Logs.nop_reporter then + Logs.set_level @@ Some Logs.Debug; + Logs.set_reporter (default_reporter (Lwt_unix.stderr, Fmt.stderr))) let activate_debug () = Lazy.force set_log; - if not !_debug_active - then ( _debug_active := true - ; Logs.debug (fun f -> f "Cohttp debugging output is active") ) + if not !_debug_active then ( + _debug_active := true; + Logs.debug (fun f -> f "Cohttp debugging output is active")) let () = - try ( - match Sys.getenv "COHTTP_DEBUG" with - | "false" | "0" -> () - | _ -> activate_debug () - ) with Not_found -> () + try + match Sys.getenv "COHTTP_DEBUG" with + | "false" | "0" -> () + | _ -> activate_debug () + with Not_found -> () diff --git a/cohttp-lwt-unix/src/debug.mli b/cohttp-lwt-unix/src/debug.mli index c921d14b9e..1261d2537e 100644 --- a/cohttp-lwt-unix/src/debug.mli +++ b/cohttp-lwt-unix/src/debug.mli @@ -17,9 +17,9 @@ (** Debugging output for Cohttp Unix *) val activate_debug : unit -> unit -(** [activate_debug] enables debugging output that will be sent to - standard error. *) +(** [activate_debug] enables debugging output that will be sent to standard + error. *) val debug_active : unit -> bool -(** [debug_active] returns true if [activate_debug] has been called and - false otherwise *) +(** [debug_active] returns true if [activate_debug] has been called and false + otherwise *) diff --git a/cohttp-lwt-unix/src/io.ml b/cohttp-lwt-unix/src/io.ml index b5579d6b24..70389dd90b 100644 --- a/cohttp-lwt-unix/src/io.ml +++ b/cohttp-lwt-unix/src/io.ml @@ -18,14 +18,13 @@ exception IO_error of exn let () = Printexc.register_printer (function - | IO_error e -> Some ("IO error: " ^ Printexc.to_string e) - | _ -> None - ); - if Sys.os_type <> "Win32" then - Sys.(set_signal sigpipe Signal_ignore); + | IO_error e -> Some ("IO error: " ^ Printexc.to_string e) + | _ -> None); + if Sys.os_type <> "Win32" then Sys.(set_signal sigpipe Signal_ignore) type 'a t = 'a Lwt.t -let (>>=) = Lwt.bind + +let ( >>= ) = Lwt.bind let return = Lwt.return type ic = Lwt_io.input_channel @@ -33,62 +32,51 @@ type oc = Lwt_io.output_channel type conn = Conduit_lwt_unix.flow let src = Logs.Src.create "cohttp.lwt.io" ~doc:"Cohttp Lwt IO module" + module Log = (val Logs.src_log src : Logs.LOG) let wrap_read f ~if_closed = (* TODO Use [Lwt_io.is_closed] when available: https://github.com/ocsigen/lwt/pull/635 *) - Lwt.catch f - (function - | Lwt_io.Channel_closed _ -> Lwt.return if_closed - | Unix.Unix_error _ as e -> Lwt.fail (IO_error e) - | exn -> raise exn - ) + Lwt.catch f (function + | Lwt_io.Channel_closed _ -> Lwt.return if_closed + | Unix.Unix_error _ as e -> Lwt.fail (IO_error e) + | exn -> raise exn) let wrap_write f = - Lwt.catch f - (function - | Unix.Unix_error _ as e -> Lwt.fail (IO_error e) - | exn -> raise exn - ) + Lwt.catch f (function + | Unix.Unix_error _ as e -> Lwt.fail (IO_error e) + | exn -> raise exn) let read_line ic = - wrap_read ~if_closed:None - (fun () -> + wrap_read ~if_closed:None (fun () -> Lwt_io.read_line_opt ic >>= function | None -> - Log.debug (fun f -> f "<<< EOF"); - Lwt.return_none + Log.debug (fun f -> f "<<< EOF"); + Lwt.return_none | Some l as x -> - Log.debug (fun f -> f "<<< %s" l); - Lwt.return x - ) + Log.debug (fun f -> f "<<< %s" l); + Lwt.return x) let read ic count = let count = min count Sys.max_string_length in - wrap_read ~if_closed:"" - (fun () -> + wrap_read ~if_closed:"" (fun () -> Lwt_io.read ~count ic >>= fun buf -> - Log.debug (fun f -> f "<<<[%d] %s" count buf); - Lwt.return buf - ) + Log.debug (fun f -> f "<<<[%d] %s" count buf); + Lwt.return buf) let write oc buf = wrap_write @@ fun () -> - Log.debug (fun f -> f ">>> %s" (String.trim buf)); + Log.debug (fun f -> f ">>> %s" (String.trim buf)); Lwt_io.write oc buf -let flush oc = - wrap_write @@ fun () -> - Lwt_io.flush oc +let flush oc = wrap_write @@ fun () -> Lwt_io.flush oc type error = exn let catch f = - Lwt.try_bind f Lwt.return_ok - (function - | IO_error e -> Lwt.return_error e - | ex -> Lwt.fail ex - ) + Lwt.try_bind f Lwt.return_ok (function + | IO_error e -> Lwt.return_error e + | ex -> Lwt.fail ex) let pp_error = Fmt.exn diff --git a/cohttp-lwt-unix/src/io.mli b/cohttp-lwt-unix/src/io.mli index 1e90ce1b11..9b088417e7 100644 --- a/cohttp-lwt-unix/src/io.mli +++ b/cohttp-lwt-unix/src/io.mli @@ -14,8 +14,9 @@ * }}}*) -include Cohttp_lwt.S.IO - with type ic = Lwt_io.input_channel - and type oc = Lwt_io.output_channel - and type conn = Conduit_lwt_unix.flow - and type error = exn +include + Cohttp_lwt.S.IO + with type ic = Lwt_io.input_channel + and type oc = Lwt_io.output_channel + and type conn = Conduit_lwt_unix.flow + and type error = exn diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index 7df92e5024..146d249f83 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -18,41 +18,30 @@ * into some connection-management framework such as andrenth/release *) open Lwt.Infix - module IO = Io -type ctx = { - ctx: Conduit_lwt_unix.ctx; - resolver: Resolver_lwt.t; -} [@@deriving sexp_of] +type ctx = { ctx : Conduit_lwt_unix.ctx; resolver : Resolver_lwt.t } +[@@deriving sexp_of] -let init - ?(ctx=Conduit_lwt_unix.default_ctx) - ?(resolver=Resolver_lwt_unix.system) () - = +let init ?(ctx = Conduit_lwt_unix.default_ctx) + ?(resolver = Resolver_lwt_unix.system) () = { ctx; resolver } -let default_ctx = { - resolver = Resolver_lwt_unix.system; - ctx = Conduit_lwt_unix.default_ctx; -} +let default_ctx = + { resolver = Resolver_lwt_unix.system; ctx = Conduit_lwt_unix.default_ctx } -let connect_uri ~ctx:{ctx; resolver} uri = - Resolver_lwt.resolve_uri ~uri resolver - >>= fun endp -> - Conduit_lwt_unix.endp_to_client ~ctx endp - >>= fun client -> +let connect_uri ~ctx:{ ctx; resolver } uri = + Resolver_lwt.resolve_uri ~uri resolver >>= fun endp -> + Conduit_lwt_unix.endp_to_client ~ctx endp >>= fun client -> Conduit_lwt_unix.connect ~ctx client -let close c = Lwt.catch - (fun () -> Lwt_io.close c) - (fun e -> - Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e)); - Lwt.return_unit - ) +let close c = + Lwt.catch + (fun () -> Lwt_io.close c) + (fun e -> + Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e)); + Lwt.return_unit) let close_in ic = Lwt.ignore_result (close ic) - let close_out oc = Lwt.ignore_result (close oc) - let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close oc) diff --git a/cohttp-lwt-unix/src/net.mli b/cohttp-lwt-unix/src/net.mli index f7844eff1a..956680ea56 100644 --- a/cohttp-lwt-unix/src/net.mli +++ b/cohttp-lwt-unix/src/net.mli @@ -14,46 +14,47 @@ * }}}*) -(** Basic satisfaction of {! Cohttp_lwt.Net } *) +(** Basic satisfaction of {!Cohttp_lwt.Net} *) module IO = Io -type ctx = { - ctx : Conduit_lwt_unix.ctx; - resolver : Resolver_lwt.t; -} [@@deriving sexp_of] +type ctx = { ctx : Conduit_lwt_unix.ctx; resolver : Resolver_lwt.t } +[@@deriving sexp_of] val default_ctx : ctx (** [default_ctx] is the default network context. It uses [Conduit_lwt_unix.default_ctx] and [Resolver_lwt_unix.system]. *) val init : ?ctx:Conduit_lwt_unix.ctx -> ?resolver:Resolver_lwt.t -> unit -> ctx -(** [init ?ctx ?resolver ()] is a network context that is the - same as the {!default_ctx}, but with either the connection handling - or resolution module overridden with [ctx] or [resolver] respectively. - This is useful to supply a {!Conduit_lwt_unix.resolver} with a custom - source network interface, or a {!Resolver_lwt.t} with a different - name resolution strategy (for instance to override a hostname to - point it to a Unix domain socket). *) +(** [init ?ctx ?resolver ()] is a network context that is the same as the + {!default_ctx}, but with either the connection handling or resolution module + overridden with [ctx] or [resolver] respectively. This is useful to supply a + {!Conduit_lwt_unix.resolver} with a custom source network interface, or a + {!Resolver_lwt.t} with a different name resolution strategy (for instance to + override a hostname to point it to a Unix domain socket). *) val connect_uri : ctx:ctx -> Uri.t -> - (Conduit_lwt_unix.flow * Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel) Lwt.t -(** [connect_uri ~ctx uri] starts a {i flow} on the given [uri]. The choice of the - protocol (with or without encryption) is done by the {i scheme} of the given [uri]: - - {ul - {- If the scheme is [https], we will {b extend} [ctx] to be able to start a TLS connection - with a default TLS configuration (no authentication) on the default or user-specified port.} - {- If the scheme is [http], we will {b extend} [ctx] to be able to start a simple TCP/IP - connection on the default or user-specified port.}} - - These extensions have the highest priority ([Conduit] will try to initiate a communication with - them first). By {i extension}, we mean that the user is able to fill its own [ctx] and we don't - overlap resolution functions from the given [ctx]. *) + (Conduit_lwt_unix.flow + * Lwt_io.input Lwt_io.channel + * Lwt_io.output Lwt_io.channel) + Lwt.t +(** [connect_uri ~ctx uri] starts a {i flow} on the given [uri]. The choice of + the protocol (with or without encryption) is done by the {i scheme} of the + given [uri]: + + - If the scheme is [https], we will {b extend} [ctx] to be able to start a + TLS connection with a default TLS configuration (no authentication) on the + default or user-specified port. + - If the scheme is [http], we will {b extend} [ctx] to be able to start a + simple TCP/IP connection on the default or user-specified port. + + These extensions have the highest priority ([Conduit] will try to initiate a + communication with them first). By {i extension}, we mean that the user is + able to fill its own [ctx] and we don't overlap resolution functions from + the given [ctx]. *) val close_in : 'a Lwt_io.channel -> unit val close_out : 'a Lwt_io.channel -> unit - -val close : 'a Lwt_io.channel -> 'b Lwt_io.channel -> unit +val close : 'a Lwt_io.channel -> 'b Lwt_io.channel -> unit diff --git a/cohttp-lwt-unix/src/server.ml b/cohttp-lwt-unix/src/server.ml index 1de7af9568..c8a3d96f08 100644 --- a/cohttp-lwt-unix/src/server.ml +++ b/cohttp-lwt-unix/src/server.ml @@ -1,10 +1,9 @@ - module Server_core = Cohttp_lwt.Make_server (Io) - include Server_core open Lwt.Infix let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server module" + module Log = (val Logs.src_log src : Logs.LOG) let blank_uri = Uri.of_string "" @@ -15,59 +14,61 @@ let resolve_file ~docroot ~uri = Filename.concat docroot frag exception Isnt_a_file + let respond_file ?headers ~fname () = - Lwt.catch (fun () -> + Lwt.catch + (fun () -> (* Check this isnt a directory first *) - (fname |> Lwt_unix.stat >>= fun s -> - if Unix.(s.st_kind <> S_REG) - then Lwt.fail Isnt_a_file - else Lwt.return_unit) >>= fun () -> + ( fname |> Lwt_unix.stat >>= fun s -> + if Unix.(s.st_kind <> S_REG) then Lwt.fail Isnt_a_file + else Lwt.return_unit ) + >>= fun () -> let count = 16384 in - Lwt_io.open_file - ~buffer:(Lwt_bytes.create count) - ~mode:Lwt_io.input fname >>= fun ic -> + Lwt_io.open_file ~buffer:(Lwt_bytes.create count) ~mode:Lwt_io.input fname + >>= fun ic -> Lwt_io.length ic >>= fun len -> let encoding = Cohttp.Transfer.Fixed len in - let stream = Lwt_stream.from (fun () -> - Lwt.catch (fun () -> - Lwt_io.read ~count ic >|= function - | "" -> None - | buf -> Some buf) - (fun exn -> - Log.warn - (fun m -> m "Error resolving file %s (%s)" - fname - (Printexc.to_string exn)); - Lwt.return_none) - ) in + let stream = + Lwt_stream.from (fun () -> + Lwt.catch + (fun () -> + Lwt_io.read ~count ic >|= function + | "" -> None + | buf -> Some buf) + (fun exn -> + Log.warn (fun m -> + m "Error resolving file %s (%s)" fname + (Printexc.to_string exn)); + Lwt.return_none)) + in Lwt.on_success (Lwt_stream.closed stream) (fun () -> - Lwt.ignore_result @@ Lwt.catch - (fun () -> Lwt_io.close ic) - (fun e -> - Log.warn (fun f -> - f "Closing channel failed: %s" (Printexc.to_string e)); - Lwt.return_unit - ) - ); + Lwt.ignore_result + @@ Lwt.catch + (fun () -> Lwt_io.close ic) + (fun e -> + Log.warn (fun f -> + f "Closing channel failed: %s" (Printexc.to_string e)); + Lwt.return_unit)); let body = Cohttp_lwt.Body.of_stream stream in let mime_type = Magic_mime.lookup fname in - let headers = Cohttp.Header.add_opt_unless_exists - headers "content-type" mime_type in + let headers = + Cohttp.Header.add_opt_unless_exists headers "content-type" mime_type + in let res = Cohttp.Response.make ~status:`OK ~encoding ~headers () in - Lwt.return (res, body) - ) (function - | Unix.Unix_error(Unix.ENOENT,_,_) | Isnt_a_file -> - respond_not_found () + Lwt.return (res, body)) + (function + | Unix.Unix_error (Unix.ENOENT, _, _) | Isnt_a_file -> + respond_not_found () | exn -> Lwt.fail exn) -let log_on_exn = - function +let log_on_exn = function | Unix.Unix_error (error, func, arg) -> - Log.warn (fun m -> m "Client connection error %s: %s(%S)" - (Unix.error_message error) func arg) + Log.warn (fun m -> + m "Client connection error %s: %s(%S)" (Unix.error_message error) func + arg) | exn -> Log.err (fun m -> m "Unhandled exception: %a" Fmt.exn exn) -let create ?timeout ?backlog ?stop ?(on_exn=log_on_exn) ?(ctx=Net.default_ctx) - ?(mode=`TCP (`Port 8080)) spec = - Conduit_lwt_unix.serve ?backlog ?timeout ?stop ~on_exn ~ctx:ctx.Net.ctx - ~mode (callback spec) +let create ?timeout ?backlog ?stop ?(on_exn = log_on_exn) + ?(ctx = Net.default_ctx) ?(mode = `TCP (`Port 8080)) spec = + Conduit_lwt_unix.serve ?backlog ?timeout ?stop ~on_exn ~ctx:ctx.Net.ctx ~mode + (callback spec) diff --git a/cohttp-lwt-unix/src/server.mli b/cohttp-lwt-unix/src/server.mli index 5050390dd7..6bb42bd677 100644 --- a/cohttp-lwt-unix/src/server.mli +++ b/cohttp-lwt-unix/src/server.mli @@ -7,36 +7,35 @@ val resolve_file : docroot:string -> uri:Uri.t -> string val respond_file : ?headers:Cohttp.Header.t -> - fname:string -> unit -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t + fname:string -> + unit -> + (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t +val create : + ?timeout:int -> + ?backlog:int -> + ?stop:unit Lwt.t -> + ?on_exn:(exn -> unit) -> + ?ctx:Net.ctx -> + ?mode:Conduit_lwt_unix.server -> + t -> + unit Lwt.t +(** [create ?timeout ?backlog ?stop ?on_exn ?mode t] is a new HTTP server. -(** [create ?timeout ?backlog ?stop ?on_exn ?mode t] is a new - HTTP server. - - The user can decide to start a simple HTTP server (without encryption) - or one with TLS encryption. It depends on what the user gives as [mode] - and how [conduit-unix] is configured. + The user can decide to start a simple HTTP server (without encryption) or + one with TLS encryption. It depends on what the user gives as [mode] and how + [conduit-unix] is configured. To create a simple HTTP server listening on port 8089: - {[ - let run = create (`TCP 8080) - ]} + {[ let run = create (`TCP 8080) ]} - When provided, the [stop] thread will terminate the server if it - ever becomes determined. + When provided, the [stop] thread will terminate the server if it ever + becomes determined. - When provided, [backlog] will limit the number of open - connections. + When provided, [backlog] will limit the number of open connections. - Every connection will be served in a new lightweight thread that - is invoked via the callback defined in [t]. If the callback raises - an exception, it is passed to [on_exn] (by default, to a function - that logs the exception using the {!Logs} library). *) -val create : - ?timeout:int -> - ?backlog:int -> - ?stop:unit Lwt.t -> - ?on_exn:(exn -> unit) -> - ?ctx:Net.ctx -> - ?mode:Conduit_lwt_unix.server -> t -> unit Lwt.t + Every connection will be served in a new lightweight thread that is invoked + via the callback defined in [t]. If the callback raises an exception, it is + passed to [on_exn] (by default, to a function that logs the exception using + the {!Logs} library). *) diff --git a/cohttp-lwt-unix/test/test_body.ml b/cohttp-lwt-unix/test/test_body.ml index 5e68679fbc..7a51ed2d46 100644 --- a/cohttp-lwt-unix/test/test_body.ml +++ b/cohttp-lwt-unix/test/test_body.ml @@ -1,57 +1,48 @@ open Lwt open Lwt.Infix open OUnit - module Body = Cohttp_lwt.Body let run_test f = Lwt.try_bind f (fun () -> return `Ok) (fun exn -> return (`Exn exn)) let test_empty_body () = - Body.is_empty (`Stream (Lwt_stream.of_list [])) - >|= fun res -> - assert_equal true res + Body.is_empty (`Stream (Lwt_stream.of_list [])) >|= fun res -> + assert_equal true res let test_non_empty_stream () = - Body.is_empty (`Stream (Lwt_stream.of_list ["foo"; "bar"])) - >|= fun res -> - assert_equal false res + Body.is_empty (`Stream (Lwt_stream.of_list [ "foo"; "bar" ])) >|= fun res -> + assert_equal false res let test_stream_with_leading_empty_strings () = - let s = Lwt_stream.of_list [""; ""; "foo"; ""; "bar"] in - Body.is_empty (`Stream s) - >>= fun res -> - assert_equal false res; - Lwt_stream.to_list s - >|= fun res -> - assert_equal ~msg:"is_empty should consume leading spaces" ["foo"; ""; "bar"] res + let s = Lwt_stream.of_list [ ""; ""; "foo"; ""; "bar" ] in + Body.is_empty (`Stream s) >>= fun res -> + assert_equal false res; + Lwt_stream.to_list s >|= fun res -> + assert_equal ~msg:"is_empty should consume leading spaces" + [ "foo"; ""; "bar" ] res let test_stream_empty_strings () = - Body.is_empty (`Stream (Lwt_stream.of_list [""; ""; ""])) - >|= fun res -> - assert_equal true res + Body.is_empty (`Stream (Lwt_stream.of_list [ ""; ""; "" ])) >|= fun res -> + assert_equal true res -let tests = - [ "Empty stream", test_empty_body - ; "Non empty stream", test_non_empty_stream - ; "Stream with leading empty strings", test_stream_with_leading_empty_strings - ; "Stream with empty strings", test_stream_empty_strings ] +let tests = + [ + ("Empty stream", test_empty_body); + ("Non empty stream", test_non_empty_stream); + ("Stream with leading empty strings", test_stream_with_leading_empty_strings); + ("Stream with empty strings", test_stream_empty_strings); + ] let test_suite = - Lwt_list.map_s (fun (title, test) -> - run_test test - >|= fun res -> (title, res) - ) tests + Lwt_list.map_s + (fun (title, test) -> run_test test >|= fun res -> (title, res)) + tests >|= fun results -> - let tests = - ListLabels.map results ~f:(fun (title, res) -> - title >:: fun () -> - match res with - | `Ok -> () - | `Exn exn -> raise exn - ) - in - "Cohttp_Lwt.Body" >::: tests - -let _ = - test_suite |> Cohttp_lwt_unix_test.run_async_tests |> Lwt_main.run + let tests = + ListLabels.map results ~f:(fun (title, res) -> + title >:: fun () -> match res with `Ok -> () | `Exn exn -> raise exn) + in + "Cohttp_Lwt.Body" >::: tests + +let _ = test_suite |> Cohttp_lwt_unix_test.run_async_tests |> Lwt_main.run diff --git a/cohttp-lwt-unix/test/test_parser.ml b/cohttp-lwt-unix/test/test_parser.ml index 14b9315d3b..9d26fec911 100644 --- a/cohttp-lwt-unix/test/test_parser.ml +++ b/cohttp-lwt-unix/test/test_parser.ml @@ -16,92 +16,87 @@ open OUnit -let basic_req = -"GET /index.html HTTP/1.1\r\nHost: www.example.com\r\n\r\n" +let basic_req = "GET /index.html HTTP/1.1\r\nHost: www.example.com\r\n\r\n" let basic_res = -"HTTP/1.1 200 OK\r\n\ -Date: Mon, 23 May 2005 22:38:34 GMT\r\n\ -Server: Apache/1.3.3.7 (Unix) (Red-Hat/Linux)\r\n\ -Last-Modified: Wed, 08 Jan 2003 23:11:55 GMT\r\n\ -Etag: \"3f80f-1b6-3e1cb03b\"\r\n\ -Accept-Ranges: none\r\n\ -Content-Length: 0\r\n\ -Connection: close\r\n\ -Content-Type: text/html; charset=UTF-8" + "HTTP/1.1 200 OK\r\n\ + Date: Mon, 23 May 2005 22:38:34 GMT\r\n\ + Server: Apache/1.3.3.7 (Unix) (Red-Hat/Linux)\r\n\ + Last-Modified: Wed, 08 Jan 2003 23:11:55 GMT\r\n\ + Etag: \"3f80f-1b6-3e1cb03b\"\r\n\ + Accept-Ranges: none\r\n\ + Content-Length: 0\r\n\ + Connection: close\r\n\ + Content-Type: text/html; charset=UTF-8" let basic_res_content = -"HTTP/1.1 200 OK\r\n\ -Date: Mon, 23 May 2005 22:38:34 GMT\r\n\ -Server: Apache/1.3.3.7 (Unix) (Red-Hat/Linux)\r\n\ -Last-Modified: Wed, 08 Jan 2003 23:11:55 GMT\r\n\ -Etag: \"3f80f-1b6-3e1cb03b\"\r\n\ -Accept-Ranges: none\r\n\ -Content-Length: 32\r\n\ -Connection: close\r\n\ -Content-Type: text/html; charset=UTF-8\r\n\ -\r\n\ -home=Cosby&favorite+flavor=flies" + "HTTP/1.1 200 OK\r\n\ + Date: Mon, 23 May 2005 22:38:34 GMT\r\n\ + Server: Apache/1.3.3.7 (Unix) (Red-Hat/Linux)\r\n\ + Last-Modified: Wed, 08 Jan 2003 23:11:55 GMT\r\n\ + Etag: \"3f80f-1b6-3e1cb03b\"\r\n\ + Accept-Ranges: none\r\n\ + Content-Length: 32\r\n\ + Connection: close\r\n\ + Content-Type: text/html; charset=UTF-8\r\n\ + \r\n\ + home=Cosby&favorite+flavor=flies" let post_req = -"POST /path/script.cgi HTTP/1.0\r\n\ -From: frog@jmarshall.com\r\n\ -User-Agent: HTTPTool/1.0\r\n\ -Content-Type: application/x-www-form-urlencoded\r\n\ -Content-Length: 32\r\n\ -\r\n\ -home=Cosby&favorite+flavor=flies" + "POST /path/script.cgi HTTP/1.0\r\n\ + From: frog@jmarshall.com\r\n\ + User-Agent: HTTPTool/1.0\r\n\ + Content-Type: application/x-www-form-urlencoded\r\n\ + Content-Length: 32\r\n\ + \r\n\ + home=Cosby&favorite+flavor=flies" let post_data_req = -"POST /path/script.cgi HTTP/1.0\r\n\ -From: frog@jmarshall.com\r\n\ -User-Agent: HTTPTool/1.0\r\n\ -Content-Length: 32\r\n\ -\r\n\ -home=Cosby&favorite+flavor=flies" + "POST /path/script.cgi HTTP/1.0\r\n\ + From: frog@jmarshall.com\r\n\ + User-Agent: HTTPTool/1.0\r\n\ + Content-Length: 32\r\n\ + \r\n\ + home=Cosby&favorite+flavor=flies" let post_chunked_req = -"POST /foo HTTP/1.1\r\n\ -Date: Fri, 31 Dec 1999 23:59:59 GMT\r\n\ -Content-Type: text/plain\r\n\ -Transfer-Encoding: chunked\r\n\ -\r\n\ -1a; ignore-stuff-here\r\n\ -abcdefghijklmnopqrstuvwxyz\r\n\ -10\r\n\ -1234567890abcdef\r\n\ -0\r\n\ -some-footer: some-value\r\n\ -another-footer: another-value\r\n\ -\r\n\ -" + "POST /foo HTTP/1.1\r\n\ + Date: Fri, 31 Dec 1999 23:59:59 GMT\r\n\ + Content-Type: text/plain\r\n\ + Transfer-Encoding: chunked\r\n\ + \r\n\ + 1a; ignore-stuff-here\r\n\ + abcdefghijklmnopqrstuvwxyz\r\n\ + 10\r\n\ + 1234567890abcdef\r\n\ + 0\r\n\ + some-footer: some-value\r\n\ + another-footer: another-value\r\n\ + \r\n" let chunked_res = -"HTTP/1.1 200 OK\r\n\ -Date: Fri, 31 Dec 1999 23:59:59 GMT\r\n\ -Content-Type: text/plain\r\n\ -Transfer-Encoding: chunked\r\n\ -\r\n\ -1a; ignore-stuff-here\r\n\ -abcdefghijklmnopqrstuvwxyz\r\n\ -10\r\n\ -1234567890abcdef\r\n\ -0\r\n\ -some-footer: some-value\r\n\ -another-footer: another-value\r\n\ -\r\n\ -" + "HTTP/1.1 200 OK\r\n\ + Date: Fri, 31 Dec 1999 23:59:59 GMT\r\n\ + Content-Type: text/plain\r\n\ + Transfer-Encoding: chunked\r\n\ + \r\n\ + 1a; ignore-stuff-here\r\n\ + abcdefghijklmnopqrstuvwxyz\r\n\ + 10\r\n\ + 1234567890abcdef\r\n\ + 0\r\n\ + some-footer: some-value\r\n\ + another-footer: another-value\r\n\ + \r\n" let user_agent = Cohttp.Header.user_agent - let basic_res_plus_crlf = basic_res ^ "\r\n\r\n" - let ic_of_buffer buf = Lwt_io.of_bytes ~mode:Lwt_io.input buf let oc_of_buffer buf = Lwt_io.of_bytes ~mode:Lwt_io.output buf open Lwt -let pp_diff fmt (a,b) = +let pp_diff fmt (a, b) = Format.pp_print_string fmt "Expected:"; Format.pp_print_newline fmt (); Format.pp_print_string fmt a; @@ -111,39 +106,39 @@ let pp_diff fmt (a,b) = let p_sexp f x = x |> f |> Sexplib0.Sexp.to_string -module Req_io = Cohttp.Request.Make(Cohttp_lwt_unix.IO) -module Rep_io = Cohttp.Response.Make(Cohttp_lwt_unix.IO) +module Req_io = Cohttp.Request.Make (Cohttp_lwt_unix.IO) +module Rep_io = Cohttp.Response.Make (Cohttp_lwt_unix.IO) let basic_req_parse () = let module CU = Cohttp_lwt_unix in let ic = ic_of_buffer (Lwt_bytes.of_string basic_req) in - Req_io.read ic >>= - function + Req_io.read ic >>= function | `Ok req -> - assert_equal (Cohttp.Request.version req) `HTTP_1_1; - assert_equal (CU.Request.meth req) `GET; - assert_equal ~printer:(fun x -> x) - "//www.example.com/index.html" - (Uri.to_string (CU.Request.uri req)); - return () + assert_equal (Cohttp.Request.version req) `HTTP_1_1; + assert_equal (CU.Request.meth req) `GET; + assert_equal + ~printer:(fun x -> x) + "//www.example.com/index.html" + (Uri.to_string (CU.Request.uri req)); + return () | _ -> assert false let basic_res_parse res () = let open Cohttp in let open Cohttp_lwt_unix in let ic = ic_of_buffer (Lwt_bytes.of_string res) in - Rep_io.read ic >>= - function + Rep_io.read ic >>= function | `Ok res -> - (* Parse first line *) - assert_equal (Response.version res) `HTTP_1_1; - assert_equal (Response.status res) `OK; - let headers = Response.headers res in - assert_equal (Header.get headers "connection") (Some "close"); - assert_equal (Header.get headers "Accept-ranges") (Some "none"); - assert_equal (Header.get headers "content-type") - (Some "text/html; charset=UTF-8"); - return () + (* Parse first line *) + assert_equal (Response.version res) `HTTP_1_1; + assert_equal (Response.status res) `OK; + let headers = Response.headers res in + assert_equal (Header.get headers "connection") (Some "close"); + assert_equal (Header.get headers "Accept-ranges") (Some "none"); + assert_equal + (Header.get headers "content-type") + (Some "text/html; charset=UTF-8"); + return () | _ -> assert false let req_parse () = @@ -151,10 +146,10 @@ let req_parse () = let ic = ic_of_buffer (Lwt_bytes.of_string basic_req) in Req_io.read ic >>= function | `Ok req -> - assert_equal `GET (Request.meth req); - assert_equal "/index.html" ((Uri.path (Request.uri req))); - assert_equal `HTTP_1_1 (Request.version req); - return () + assert_equal `GET (Request.meth req); + assert_equal "/index.html" (Uri.path (Request.uri req)); + assert_equal `HTTP_1_1 (Request.version req); + return () | _ -> assert false let post_data_parse () = @@ -162,14 +157,15 @@ let post_data_parse () = let ic = ic_of_buffer (Lwt_bytes.of_string post_data_req) in Req_io.read ic >>= function | `Ok req -> - let printer = p_sexp Transfer.sexp_of_chunk in - let reader = Req_io.make_body_reader req ic in - Req_io.read_body_chunk reader >>= fun body -> - assert_equal ~printer (Transfer.Final_chunk "home=Cosby&favorite+flavor=flies") body; - (* A subsequent request for the body will have consumed it, therefore None *) - Req_io.read_body_chunk reader >>= fun body -> - assert_equal ~printer Transfer.Done body; - return () + let printer = p_sexp Transfer.sexp_of_chunk in + let reader = Req_io.make_body_reader req ic in + Req_io.read_body_chunk reader >>= fun body -> + assert_equal ~printer + (Transfer.Final_chunk "home=Cosby&favorite+flavor=flies") body; + (* A subsequent request for the body will have consumed it, therefore None *) + Req_io.read_body_chunk reader >>= fun body -> + assert_equal ~printer Transfer.Done body; + return () | _ -> assert false let post_chunked_parse () = @@ -178,13 +174,15 @@ let post_chunked_parse () = let ic = ic_of_buffer (Lwt_bytes.of_string post_chunked_req) in Req_io.read ic >>= function | `Ok req -> - assert_equal (Transfer.string_of_encoding (Request.encoding req)) "chunked"; - let reader = Req_io.make_body_reader req ic in - Req_io.read_body_chunk reader >>= fun chunk -> - assert_equal chunk (Transfer.Chunk "abcdefghijklmnopqrstuvwxyz"); - Req_io.read_body_chunk reader >>= fun chunk -> - assert_equal chunk (Transfer.Chunk "1234567890abcdef"); - return () + assert_equal + (Transfer.string_of_encoding (Request.encoding req)) + "chunked"; + let reader = Req_io.make_body_reader req ic in + Req_io.read_body_chunk reader >>= fun chunk -> + assert_equal chunk (Transfer.Chunk "abcdefghijklmnopqrstuvwxyz"); + Req_io.read_body_chunk reader >>= fun chunk -> + assert_equal chunk (Transfer.Chunk "1234567890abcdef"); + return () | _ -> assert false let res_content_parse () = @@ -193,12 +191,13 @@ let res_content_parse () = let ic = ic_of_buffer (Lwt_bytes.of_string basic_res_content) in Rep_io.read ic >>= function | `Ok res -> - assert_equal `HTTP_1_1 (Response.version res); - assert_equal `OK (Response.status res); - let reader = Rep_io.make_body_reader res ic in - Rep_io.read_body_chunk reader >>= fun body -> - assert_equal (Transfer.Final_chunk "home=Cosby&favorite+flavor=flies") body; - return () + assert_equal `HTTP_1_1 (Response.version res); + assert_equal `OK (Response.status res); + let reader = Rep_io.make_body_reader res ic in + Rep_io.read_body_chunk reader >>= fun body -> + assert_equal (Transfer.Final_chunk "home=Cosby&favorite+flavor=flies") + body; + return () | _ -> assert false let res_chunked_parse () = @@ -207,14 +206,14 @@ let res_chunked_parse () = let ic = ic_of_buffer (Lwt_bytes.of_string chunked_res) in Rep_io.read ic >>= function | `Ok res -> - assert_equal `HTTP_1_1 (Response.version res); - assert_equal `OK (Response.status res); - let reader = Rep_io.make_body_reader res ic in - Rep_io.read_body_chunk reader >>= fun chunk -> - assert_equal chunk (Transfer.Chunk "abcdefghijklmnopqrstuvwxyz"); - Rep_io.read_body_chunk reader >>= fun chunk -> - assert_equal chunk (Transfer.Chunk "1234567890abcdef"); - return () + assert_equal `HTTP_1_1 (Response.version res); + assert_equal `OK (Response.status res); + let reader = Rep_io.make_body_reader res ic in + Rep_io.read_body_chunk reader >>= fun chunk -> + assert_equal chunk (Transfer.Chunk "abcdefghijklmnopqrstuvwxyz"); + Rep_io.read_body_chunk reader >>= fun chunk -> + assert_equal chunk (Transfer.Chunk "1234567890abcdef"); + return () | _ -> assert false (* Extract the substring of the byte buffer that has been written to *) @@ -229,89 +228,119 @@ let write_req expected req = let buf = Lwt_bytes.create 4096 in let oc = oc_of_buffer buf in let body = Cohttp_lwt.Body.of_string "foobar" in - Req_io.write (fun writer -> - Cohttp_lwt.Body.write_body (Req_io.write_body writer) body - ) req oc >>= fun () -> + Req_io.write + (fun writer -> Cohttp_lwt.Body.write_body (Req_io.write_body writer) body) + req oc + >>= fun () -> 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 let oc = oc_of_buffer buf in Req_io.write (fun writer -> Req_io.write_body writer "foobar") req oc - >|= fun () -> - assert_equal expected (get_substring oc buf) + >|= fun () -> assert_equal expected (get_substring oc buf) let make_simple_req () = let open Cohttp in let open Cohttp_lwt_unix in - let expected = "POST /foo/bar HTTP/1.1\r\nfoo: bar\r\nhost: localhost\r\ntransfer-encoding: chunked\r\nuser-agent: "^user_agent^"\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 + let expected = + "POST /foo/bar HTTP/1.1\r\n\ + foo: bar\r\n\ + host: localhost\r\n\ + transfer-encoding: chunked\r\n\ + user-agent: " + ^ user_agent + ^ "\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 () = let open Cohttp in let open Cohttp_lwt_unix in - let expected = "POST /foo/bar HTTP/1.1\r\nfoo: bar\r\nhost: localhost\r\ntransfer-encoding: chunked\r\nuser-agent: "^user_agent^"\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\n\ + foo: bar\r\n\ + host: localhost\r\n\ + transfer-encoding: chunked\r\n\ + user-agent: " + ^ user_agent + ^ "\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 req = Fieldslib.Field.fset Request.Fields.meth req `POST in write_req expected req let make_simple_res () = let open Cohttp in let open Cohttp_lwt_unix in - let expected = "HTTP/1.1 200 OK\r\nfoo: bar\r\ntransfer-encoding: chunked\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n" in + let expected = + "HTTP/1.1 200 OK\r\n\ + foo: bar\r\n\ + transfer-encoding: chunked\r\n\ + \r\n\ + 6\r\n\ + foobar\r\n\ + 0\r\n\ + \r\n" + in (* Use the low-level write_header/footer API *) let buf = Lwt_bytes.create 4096 in let oc = oc_of_buffer buf in - let res = Response.make ~headers:(Header.of_list [("foo","bar")]) () in + let res = Response.make ~headers:(Header.of_list [ ("foo", "bar") ]) () in let body = Cohttp_lwt.Body.of_string "foobar" in - Rep_io.write (fun writer -> - Cohttp_lwt.Body.write_body (Rep_io.write_body writer) body - ) res oc >>= fun () -> + Rep_io.write + (fun writer -> Cohttp_lwt.Body.write_body (Rep_io.write_body writer) body) + res oc + >>= fun () -> assert_equal 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 let oc = oc_of_buffer buf in - Rep_io.write (fun writer -> Rep_io.write_body writer "foobar") res oc >>= fun () -> + Rep_io.write (fun writer -> Rep_io.write_body writer "foobar") res oc + >>= fun () -> assert_equal expected (get_substring oc buf); return () let test_cases = - let tests = [ - "basic_req_parse", basic_req_parse; - "req_parse", req_parse; - "post_data_parse", post_data_parse; - "post_chunked_parse", post_chunked_parse; - "basic_res_parse 1", (basic_res_parse basic_res); - "basic_res_parse 2", (basic_res_parse basic_res_plus_crlf); - "res_content_parse", res_content_parse; - "make_simple_req", make_simple_req; - "mutate_simple_req", mutate_simple_req; - "make_simple_res", make_simple_res; - ] in - List.map (fun (n,x) -> n >:: (fun () -> Lwt_main.run (x ()))) tests + let tests = + [ + ("basic_req_parse", basic_req_parse); + ("req_parse", req_parse); + ("post_data_parse", post_data_parse); + ("post_chunked_parse", post_chunked_parse); + ("basic_res_parse 1", basic_res_parse basic_res); + ("basic_res_parse 2", basic_res_parse basic_res_plus_crlf); + ("res_content_parse", res_content_parse); + ("make_simple_req", make_simple_req); + ("mutate_simple_req", mutate_simple_req); + ("make_simple_res", make_simple_res); + ] + in + List.map (fun (n, x) -> n >:: fun () -> Lwt_main.run (x ())) tests (* Returns true if the result list contains successes only. Copied from oUnit source as it isnt exposed by the mli *) -let rec was_successful = - function - | [] -> true - | RSuccess _::t - | RSkip _::t -> - was_successful t - | RFailure _::_ - | RError _::_ - | RTodo _::_ -> - false +let rec was_successful = function + | [] -> true + | RSuccess _ :: t | RSkip _ :: t -> was_successful t + | RFailure _ :: _ | RError _ :: _ | RTodo _ :: _ -> false let _ = let suite = "Parser" >::: test_cases in let verbose = ref false in let set_verbose _ = verbose := true in Arg.parse - [("-verbose", Arg.Unit set_verbose, "Run the test in verbose mode.");] + [ ("-verbose", Arg.Unit set_verbose, "Run the test in verbose mode.") ] (fun x -> raise (Arg.Bad ("Bad argument : " ^ x))) ("Usage: " ^ Sys.argv.(0) ^ " [-verbose]"); - if not (was_successful (run_test_tt ~verbose:!verbose suite)) then - exit 1 + if not (was_successful (run_test_tt ~verbose:!verbose suite)) then exit 1 diff --git a/cohttp-lwt-unix/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml index 55a26e0eb4..94300eab03 100644 --- a/cohttp-lwt-unix/test/test_sanity.ml +++ b/cohttp-lwt-unix/test/test_sanity.ml @@ -2,89 +2,81 @@ open Lwt.Infix open OUnit open Cohttp_lwt_unix open Cohttp_lwt_unix_test - module Body = Cohttp_lwt.Body - module IO = Cohttp_lwt_unix.IO + module Request = struct include Cohttp.Request - include (Make(IO) : module type of Make(IO) with type t := t) -end + include (Make (IO) : module type of Make (IO) with type t := t) + end let message = "Hello sanity!" - -let chunk_body = ["one"; ""; " "; "bar"; ""] - +let chunk_body = [ "one"; ""; " "; "bar"; "" ] let leak_repeat = 1024 - let () = Debug.activate_debug () let () = Logs.set_level (Some Warning) - let cond = Lwt_condition.create () let server = - List.map const [ (* t *) - Server.respond_string ~status:`OK ~body:message (); - (* pipelined_chunk *) - Server.respond ~status:`OK ~body:(Body.of_string "") (); - Server.respond ~status:`OK ~body:(Body.of_string_list chunk_body) (); - Server.respond ~status:`OK ~body:(Body.of_string "") (); - (* pipelined_interleave *) - Server.respond_string ~status:`OK ~body:"one" (); - Server.respond_string ~status:`OK ~body:"two" (); - Server.respond_string ~status:`OK ~body:"three" (); - (* Massive chunked *) - Server.respond ~status:`OK ~body:begin - let count = ref 0 in - let chunk = String.make 64 '0' in - `Stream (Lwt_stream.from_direct (fun () -> - if !count < 1000 - then (incr count; Some chunk) - else None - )) - end() - ] - @ - ( - Array.init (leak_repeat * 2) (fun _ _ _ -> - (* no leaks *) - Server.respond_string ~status:`OK ~body:"no leak" () >|= fun rsp -> - `Response rsp - ) - |> Array.to_list - ) - @ (* pipelined_expert *) - [ - (fun _ _ -> - Lwt.return (`Expert ( - Cohttp.Response.make (), - fun _ic oc -> - Lwt_io.write oc "8\r\nexpert 1\r\n0\r\n\r\n" - )) - ); - (fun _ _ -> - Lwt.return (`Expert ( - Cohttp.Response.make (), - fun ic oc -> - Lwt_io.write oc "8\r\nexpert 2\r\n0\r\n\r\n" >>= fun () -> - Lwt_io.flush oc >>= fun () -> - Lwt_io.close ic - ) - )) - ] + List.map const + [ + (* t *) + Server.respond_string ~status:`OK ~body:message (); + (* pipelined_chunk *) + Server.respond ~status:`OK ~body:(Body.of_string "") (); + Server.respond ~status:`OK ~body:(Body.of_string_list chunk_body) (); + Server.respond ~status:`OK ~body:(Body.of_string "") (); + (* pipelined_interleave *) + Server.respond_string ~status:`OK ~body:"one" (); + Server.respond_string ~status:`OK ~body:"two" (); + Server.respond_string ~status:`OK ~body:"three" (); + (* Massive chunked *) + Server.respond ~status:`OK + ~body: + (let count = ref 0 in + let chunk = String.make 64 '0' in + `Stream + (Lwt_stream.from_direct (fun () -> + if !count < 1000 then ( + incr count; + Some chunk) + else None))) + (); + ] + @ (Array.init (leak_repeat * 2) (fun _ _ _ -> + (* no leaks *) + Server.respond_string ~status:`OK ~body:"no leak" () >|= fun rsp -> + `Response rsp) + |> Array.to_list) + (* pipelined_expert *) + @ [ + (fun _ _ -> + Lwt.return + (`Expert + ( Cohttp.Response.make (), + fun _ic oc -> Lwt_io.write oc "8\r\nexpert 1\r\n0\r\n\r\n" ))); + (fun _ _ -> + Lwt.return + (`Expert + ( Cohttp.Response.make (), + fun ic oc -> + Lwt_io.write oc "8\r\nexpert 2\r\n0\r\n\r\n" >>= fun () -> + Lwt_io.flush oc >>= fun () -> Lwt_io.close ic ))); + ] @ (* client_close *) [ - fun _ _ -> - let ready = Lwt_condition.wait cond in - let i = ref 0 in - let stream = Lwt_stream.from (fun () -> - ready >|= fun () -> - incr i; - if !i > 1000 then failwith "Connection should have failed by now!"; - Some (String.make 4096 'X') - ) - in - Lwt.return (`Response (Cohttp.Response.make ~status:`OK (), `Stream stream)) + (fun _ _ -> + let ready = Lwt_condition.wait cond in + let i = ref 0 in + let stream = + Lwt_stream.from (fun () -> + ready >|= fun () -> + incr i; + if !i > 1000 then failwith "Connection should have failed by now!"; + Some (String.make 4096 'X')) + in + Lwt.return + (`Response (Cohttp.Response.make ~status:`OK (), `Stream stream))); ] |> response_sequence @@ -96,101 +88,114 @@ let check_logs test () = Fmt.failwith "Test produced %d log messages at level >= warn" new_errs let ts = - Cohttp_lwt_unix_test.test_server_s server begin fun uri -> - let ctx = Cohttp_lwt_unix.Net.default_ctx in - let t () = - Client.get ~ctx uri >>= fun (_, body) -> - body |> Body.to_string >|= fun body -> - assert_equal body message in - let pipelined_chunk () = - let printer x = x in - let body = String.concat "" chunk_body in - let reqs = [ - Request.make ~meth:`HEAD uri, `Empty; - Request.make ~meth:`GET uri, `Empty; - Request.make ~meth:`HEAD uri, `Empty; - ] in - let counter = ref 0 in - Client.callv ~ctx uri (Lwt_stream.of_list reqs) >>= fun resps -> - Lwt_stream.iter_s (fun (_, rbody) -> - rbody |> Body.to_string >|= fun rbody -> - begin match !counter with - | 0 | 2 -> assert_equal ~printer "" rbody - | _ -> assert_equal ~printer body rbody - end; - incr counter - ) resps >>= fun () -> - assert_equal ~printer:string_of_int 3 !counter; - Lwt.return_unit in - let pipelined_interleave () = - let r n = - let uri = Uri.with_query' uri ["test", (string_of_int n)] in - (Request.make uri, Body.empty) in - let (reqs, push) = Lwt_stream.create () in - push (Some (r 1)); - push (Some (r 2)); - Client.callv ~ctx uri reqs >>= fun resps -> - let resps = Lwt_stream.map_s (fun (_, b) -> Body.to_string b) resps in - Lwt_stream.fold (fun b i -> - Logs.info (fun f -> f "Request %i\n" i); - begin match i with + Cohttp_lwt_unix_test.test_server_s server (fun uri -> + let ctx = Cohttp_lwt_unix.Net.default_ctx in + let t () = + Client.get ~ctx uri >>= fun (_, body) -> + body |> Body.to_string >|= fun body -> assert_equal body message + in + let pipelined_chunk () = + let printer x = x in + let body = String.concat "" chunk_body in + let reqs = + [ + (Request.make ~meth:`HEAD uri, `Empty); + (Request.make ~meth:`GET uri, `Empty); + (Request.make ~meth:`HEAD uri, `Empty); + ] + in + let counter = ref 0 in + Client.callv ~ctx uri (Lwt_stream.of_list reqs) >>= fun resps -> + Lwt_stream.iter_s + (fun (_, rbody) -> + rbody |> Body.to_string >|= fun rbody -> + (match !counter with + | 0 | 2 -> assert_equal ~printer "" rbody + | _ -> assert_equal ~printer body rbody); + incr counter) + resps + >>= fun () -> + assert_equal ~printer:string_of_int 3 !counter; + Lwt.return_unit + in + let pipelined_interleave () = + let r n = + let uri = Uri.with_query' uri [ ("test", string_of_int n) ] in + (Request.make uri, Body.empty) + in + let reqs, push = Lwt_stream.create () in + push (Some (r 1)); + push (Some (r 2)); + Client.callv ~ctx uri reqs >>= fun resps -> + let resps = Lwt_stream.map_s (fun (_, b) -> Body.to_string b) resps in + Lwt_stream.fold + (fun b i -> + Logs.info (fun f -> f "Request %i\n" i); + (match i with | 0 -> assert_equal b "one" | 1 -> - assert_equal b "two"; - Logs.info (fun f -> f "Sending extra request"); - push (Some (r 3)) + assert_equal b "two"; + Logs.info (fun f -> f "Sending extra request"); + push (Some (r 3)) | 2 -> - assert_equal b "three"; - push None; - | x -> assert_failure ("Test failed with " ^ string_of_int x) - end; - succ i - ) resps 0 >|= fun l -> - assert_equal l 3 - in - let massive_chunked () = - Client.get ~ctx uri >>= fun (_resp, body) -> - Body.to_string body >|= fun body -> - assert_equal ~printer:string_of_int (1000 * 64) (String.length body) in - let test_no_leak () = - let stream = Array.init leak_repeat (fun _ -> uri) |> Lwt_stream.of_array in - Lwt_stream.fold_s (fun uri () -> - Client.head ~ctx uri >>= fun resp_head -> - assert_equal (Response.status resp_head) `OK; - Client.get ~ctx uri >>= fun (resp_get, body) -> - assert_equal (Response.status resp_get) `OK; - Body.drain_body body) stream () - in - let expert_pipelined () = - let printer x = x in - Client.get ~ctx uri >>= fun (_rsp, body) -> - Body.to_string body >>= fun body -> - assert_equal ~printer "expert 1" body; - Client.get ~ctx uri >>= fun (_rsp, body) -> - Body.to_string body >|= fun body -> - assert_equal ~printer "expert 2" body - in - let client_close () = - Cohttp_lwt_unix.Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) -> - let req = Cohttp.Request.make_for_client ~chunked:false `GET (Uri.with_path uri "/test.html") in - Request.write (fun _writer -> Lwt.return_unit) req oc - >>= fun () -> - Response.read ic >>= function - | `Eof | `Invalid _ -> assert false - | `Ok rsp -> - assert_equal ~printer:Cohttp.Code.string_of_status `OK (Cohttp.Response.status rsp); - Cohttp_lwt_unix.Net.close ic oc; - Lwt_condition.broadcast cond (); - Lwt.pause () - in - [ "sanity test", check_logs t - ; "pipelined chunk test", check_logs pipelined_chunk - ; "pipelined with interleaving requests", check_logs pipelined_interleave - ; "massive chunked", check_logs massive_chunked - ; "no leaks on requests", check_logs test_no_leak - ; "expert response", check_logs expert_pipelined - ; "client_close", check_logs client_close - ] - end + assert_equal b "three"; + push None + | x -> assert_failure ("Test failed with " ^ string_of_int x)); + succ i) + resps 0 + >|= fun l -> assert_equal l 3 + in + let massive_chunked () = + Client.get ~ctx uri >>= fun (_resp, body) -> + Body.to_string body >|= fun body -> + assert_equal ~printer:string_of_int (1000 * 64) (String.length body) + in + let test_no_leak () = + let stream = + Array.init leak_repeat (fun _ -> uri) |> Lwt_stream.of_array + in + Lwt_stream.fold_s + (fun uri () -> + Client.head ~ctx uri >>= fun resp_head -> + assert_equal (Response.status resp_head) `OK; + Client.get ~ctx uri >>= fun (resp_get, body) -> + assert_equal (Response.status resp_get) `OK; + Body.drain_body body) + stream () + in + let expert_pipelined () = + let printer x = x in + Client.get ~ctx uri >>= fun (_rsp, body) -> + Body.to_string body >>= fun body -> + assert_equal ~printer "expert 1" body; + Client.get ~ctx uri >>= fun (_rsp, body) -> + Body.to_string body >|= fun body -> + assert_equal ~printer "expert 2" body + in + let client_close () = + Cohttp_lwt_unix.Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) -> + let req = + Cohttp.Request.make_for_client ~chunked:false `GET + (Uri.with_path uri "/test.html") + in + Request.write (fun _writer -> Lwt.return_unit) req oc >>= fun () -> + Response.read ic >>= function + | `Eof | `Invalid _ -> assert false + | `Ok rsp -> + assert_equal ~printer:Cohttp.Code.string_of_status `OK + (Cohttp.Response.status rsp); + Cohttp_lwt_unix.Net.close ic oc; + Lwt_condition.broadcast cond (); + Lwt.pause () + in + [ + ("sanity test", check_logs t); + ("pipelined chunk test", check_logs pipelined_chunk); + ("pipelined with interleaving requests", check_logs pipelined_interleave); + ("massive chunked", check_logs massive_chunked); + ("no leaks on requests", check_logs test_no_leak); + ("expert response", check_logs expert_pipelined); + ("client_close", check_logs client_close); + ]) let _ = ts |> run_async_tests |> Lwt_main.run diff --git a/cohttp-lwt-unix/test/test_sanity_noisy.ml b/cohttp-lwt-unix/test/test_sanity_noisy.ml index 927819c682..3368861fad 100644 --- a/cohttp-lwt-unix/test/test_sanity_noisy.ml +++ b/cohttp-lwt-unix/test/test_sanity_noisy.ml @@ -3,21 +3,17 @@ open OUnit open Cohttp open Cohttp_lwt_unix open Cohttp_lwt_unix_test - module Body = Cohttp_lwt.Body - module IO = Cohttp_lwt_unix.IO + module Request = struct include Cohttp.Request - include (Make(IO) : module type of Make(IO) with type t := t) -end + include (Make (IO) : module type of Make (IO) with type t := t) + end let message = "Hello sanity!" - -let chunk_body = ["one"; ""; " "; "bar"; ""] - +let chunk_body = [ "one"; ""; " "; "bar"; "" ] let leak_repeat = 1024 - let () = Logs.set_level (Some Info) let () = Logs.set_reporter Logs.nop_reporter @@ -29,55 +25,63 @@ let check_logs test () = Fmt.failwith "Test produced %d log messages at level >= warn" new_errs let server_noisy = - List.map const [ - (* empty_chunk *) - Server.respond ~status:`OK ~body:(Body.of_string_list chunk_body) (); - (* not modified *) - Server.respond ~status:`Not_modified ~body:Body.empty (); - ] - @ - [fun _ body -> (* Returns 500 on bad file *) - Body.to_string body >>= fun fname -> - Server.respond_file ~fname () >|= fun rsp -> - `Response rsp - ] |> response_sequence + List.map const + [ + (* empty_chunk *) + Server.respond ~status:`OK ~body:(Body.of_string_list chunk_body) (); + (* not modified *) + Server.respond ~status:`Not_modified ~body:Body.empty (); + ] + @ [ + (fun _ body -> + (* Returns 500 on bad file *) + Body.to_string body >>= fun fname -> + Server.respond_file ~fname () >|= fun rsp -> `Response rsp); + ] + |> response_sequence let ts_noisy = - Cohttp_lwt_unix_test.test_server_s ~port:10193 server_noisy begin fun uri -> - let ctx = Cohttp_lwt_unix.Net.default_ctx in - let empty_chunk () = - Client.get ~ctx uri >>= fun (_, body) -> - body |> Body.to_string >|= fun body -> - assert_equal body (String.concat "" chunk_body) in - let not_modified_has_no_body () = - Client.get ~ctx uri >>= fun (resp, body) -> - assert_equal (Response.status resp) `Not_modified; - let headers = Response.headers resp in - assert_equal ~printer:Transfer.string_of_encoding - Transfer.Unknown (Header.get_transfer_encoding headers); - body |> Body.is_empty >|= fun is_empty -> - assert_bool "No body returned when not modified" is_empty in - let unreadable_file_500 () = - let fname = "unreadable500" in - Lwt.finalize (fun () -> - Lwt_io.open_file ~flags:[Lwt_unix.O_CREAT] ~perm:0o006 - ~mode:Lwt_io.Output fname >>= fun oc -> - Lwt_io.write_line oc "never read" >>= fun () -> - Lwt_io.close oc >>= fun () -> - Client.post ~ctx uri ~body:(Body.of_string fname) - >>= begin fun (resp, body) -> - assert_equal ~printer:Code.string_of_status - (Response.status resp) `Internal_server_error; - Body.to_string body - end >|= fun body -> - assert_equal ~printer:(fun x -> "'" ^ x ^ "'") - body "Error: Internal Server Error" - ) (fun () -> Lwt_unix.unlink fname) - in - [ "empty chunk test", check_logs empty_chunk - ; "no body when response is not modified", check_logs not_modified_has_no_body - ; "unreadable file returns 500", unreadable_file_500 - ] - end + Cohttp_lwt_unix_test.test_server_s ~port:10193 server_noisy (fun uri -> + let ctx = Cohttp_lwt_unix.Net.default_ctx in + let empty_chunk () = + Client.get ~ctx uri >>= fun (_, body) -> + body |> Body.to_string >|= fun body -> + assert_equal body (String.concat "" chunk_body) + in + let not_modified_has_no_body () = + Client.get ~ctx uri >>= fun (resp, body) -> + assert_equal (Response.status resp) `Not_modified; + let headers = Response.headers resp in + assert_equal ~printer:Transfer.string_of_encoding Transfer.Unknown + (Header.get_transfer_encoding headers); + body |> Body.is_empty >|= fun is_empty -> + assert_bool "No body returned when not modified" is_empty + in + let unreadable_file_500 () = + let fname = "unreadable500" in + Lwt.finalize + (fun () -> + Lwt_io.open_file ~flags:[ Lwt_unix.O_CREAT ] ~perm:0o006 + ~mode:Lwt_io.Output fname + >>= fun oc -> + Lwt_io.write_line oc "never read" >>= fun () -> + Lwt_io.close oc >>= fun () -> + ( Client.post ~ctx uri ~body:(Body.of_string fname) + >>= fun (resp, body) -> + assert_equal ~printer:Code.string_of_status (Response.status resp) + `Internal_server_error; + Body.to_string body ) + >|= fun body -> + assert_equal + ~printer:(fun x -> "'" ^ x ^ "'") + body "Error: Internal Server Error") + (fun () -> Lwt_unix.unlink fname) + in + [ + ("empty chunk test", check_logs empty_chunk); + ( "no body when response is not modified", + check_logs not_modified_has_no_body ); + ("unreadable file returns 500", unreadable_file_500); + ]) let _ = ts_noisy |> run_async_tests |> Lwt_main.run diff --git a/cohttp-lwt/src/body.ml b/cohttp-lwt/src/body.ml index 0c901b8d35..2672d55f4e 100644 --- a/cohttp-lwt/src/body.ml +++ b/cohttp-lwt/src/body.ml @@ -17,93 +17,85 @@ open Cohttp open Lwt -type t = [ - | Body.t - | `Stream of (string Lwt_stream.t [@sexp.opaque]) -] [@@deriving sexp] +type t = [ Body.t | `Stream of (string Lwt_stream.t[@sexp.opaque]) ] +[@@deriving sexp] let empty = (Body.empty :> t) let create_stream fn arg = let fin = ref false in Lwt_stream.from (fun () -> - match !fin with - | true -> return_none - | false -> begin - fn arg >>= function - | Transfer.Done -> return_none - | Transfer.Final_chunk c -> - fin := true; - return (Some c); - | Transfer.Chunk c -> return (Some c) - end - ) - -let is_empty (body:t) = + match !fin with + | true -> return_none + | false -> ( + fn arg >>= function + | Transfer.Done -> return_none + | Transfer.Final_chunk c -> + fin := true; + return (Some c) + | Transfer.Chunk c -> return (Some c))) + +let is_empty (body : t) = match body with | #Body.t as body -> return (Body.is_empty body) | `Stream s -> - Lwt_stream.get_while (fun x -> x = "") s - >>= fun _ -> - Lwt_stream.is_empty s + Lwt_stream.get_while (fun x -> x = "") s >>= fun _ -> + Lwt_stream.is_empty s -let to_string (body:t) = +let to_string (body : t) = match body with | #Body.t as body -> return (Body.to_string body) - |`Stream s -> - let b = Buffer.create 1024 in - Lwt_stream.iter (Buffer.add_string b) s >>= fun () -> - return (Buffer.contents b) + | `Stream s -> + let b = Buffer.create 1024 in + Lwt_stream.iter (Buffer.add_string b) s >>= fun () -> + return (Buffer.contents b) -let to_string_list (body:t) = +let to_string_list (body : t) = match body with | #Body.t as body -> return (Body.to_string_list body) - |`Stream s -> Lwt_stream.to_list s + | `Stream s -> Lwt_stream.to_list s -let of_string s = ((Body.of_string s) :> t) +let of_string s = (Body.of_string s :> t) -let to_stream (body:t) = +let to_stream (body : t) = match body with - |`Empty -> Lwt_stream.of_list [] - |`Stream s -> s - |`String s -> Lwt_stream.of_list [s] - |`Strings sl -> Lwt_stream.of_list sl + | `Empty -> Lwt_stream.of_list [] + | `Stream s -> s + | `String s -> Lwt_stream.of_list [ s ] + | `Strings sl -> Lwt_stream.of_list sl -let drain_body (body:t) = +let drain_body (body : t) = match body with - |`Empty - |`String _ - |`Strings _ -> return_unit - |`Stream s -> Lwt_stream.junk_while (fun _ -> true) s + | `Empty | `String _ | `Strings _ -> return_unit + | `Stream s -> Lwt_stream.junk_while (fun _ -> true) s let of_string_list l = `Strings l - let of_stream s = `Stream s let transfer_encoding = function - |#Body.t as t -> Body.transfer_encoding t - |`Stream _ -> Transfer.Chunked + | #Body.t as t -> Body.transfer_encoding t + | `Stream _ -> Transfer.Chunked (* This will consume the body and return a length, and a * new body that should be used instead of the input *) -let length (body:t) : (int64 * t) Lwt.t = +let length (body : t) : (int64 * t) Lwt.t = match body with - |#Body.t as body -> return (Body.length body, body) - |`Stream _ -> - to_string body >>= fun buf -> - let len = Int64.of_int (String.length buf) in - return (len, `String buf) + | #Body.t as body -> return (Body.length body, body) + | `Stream _ -> + to_string body >>= fun buf -> + let len = Int64.of_int (String.length buf) in + return (len, `String buf) let write_body fn = function - |`Empty -> return_unit - |`Stream st -> Lwt_stream.iter_s fn st - |`String s -> fn s - |`Strings sl -> Lwt_list.iter_s fn sl + | `Empty -> return_unit + | `Stream st -> Lwt_stream.iter_s fn st + | `String s -> fn s + | `Strings sl -> Lwt_list.iter_s fn sl let map f t = match t with | #Body.t as t -> (Body.map f t :> t) | `Stream s -> `Stream (Lwt_stream.map f s) - let to_form (body:t) = to_string body >|= Uri.query_of_encoded - let of_form ?scheme f = Uri.encoded_of_query ?scheme f |> of_string +let to_form (body : t) = to_string body >|= Uri.query_of_encoded +let of_form ?scheme f = Uri.encoded_of_query ?scheme f |> of_string diff --git a/cohttp-lwt/src/body.mli b/cohttp-lwt/src/body.mli index ebf5db27c4..e4535e054d 100644 --- a/cohttp-lwt/src/body.mli +++ b/cohttp-lwt/src/body.mli @@ -14,27 +14,20 @@ * }}}*) -type t = [ - | Cohttp.Body.t - | `Stream of string Lwt_stream.t -] [@@deriving sexp] +type t = [ Cohttp.Body.t | `Stream of string Lwt_stream.t ] [@@deriving sexp] include Cohttp.S.Body with type t := t val is_empty : t -> bool Lwt.t - val to_string : t -> string Lwt.t val to_string_list : t -> string list Lwt.t - val to_stream : t -> string Lwt_stream.t val of_stream : string Lwt_stream.t -> t - val to_form : t -> (string * string list) list Lwt.t -val create_stream : ('a -> Cohttp.Transfer.chunk Lwt.t) -> 'a -> string Lwt_stream.t +val create_stream : + ('a -> Cohttp.Transfer.chunk Lwt.t) -> 'a -> string Lwt_stream.t val length : t -> (int64 * t) Lwt.t - val write_body : (string -> unit Lwt.t) -> t -> unit Lwt.t - val drain_body : t -> unit Lwt.t diff --git a/cohttp-lwt/src/client.ml b/cohttp-lwt/src/client.ml index 8f6770f8e2..106fbe149c 100644 --- a/cohttp-lwt/src/client.ml +++ b/cohttp-lwt/src/client.ml @@ -1,36 +1,36 @@ open Lwt.Infix - module Header = Cohttp.Header -module Make - (IO:S.IO) - (Net:S.Net with module IO = IO) = struct - +module Make (IO : S.IO) (Net : S.Net with module IO = IO) = struct module IO = IO - module Response = Make.Response(IO) - module Request = Make.Request(IO) + module Response = Make.Response (IO) + module Request = Make.Request (IO) type ctx = Net.ctx let read_body ~closefn ic res = match Response.has_body res with | `Yes | `Unknown -> - let reader = Response.make_body_reader res ic in - let stream = Body.create_stream Response.read_body_chunk reader in - let body = Body.of_stream stream in - let closed = ref false in - (* Lwt.on_success registers a callback in the stream. - * The GC will still be able to collect stream. *) - Lwt.on_success (Lwt_stream.closed stream) - (fun () -> closed := true; closefn ()); - (* finalise could run in a thread different from the lwt main thread. - * You may therefore not call into Lwt from a finaliser. *) - Gc.finalise_last - (fun () -> if not !closed then - prerr_endline "Cohttp_lwt: body not consumed - leaking stream!") - stream; - body - | `No -> closefn (); `Empty + let reader = Response.make_body_reader res ic in + let stream = Body.create_stream Response.read_body_chunk reader in + let body = Body.of_stream stream in + let closed = ref false in + (* Lwt.on_success registers a callback in the stream. + * The GC will still be able to collect stream. *) + Lwt.on_success (Lwt_stream.closed stream) (fun () -> + closed := true; + closefn ()); + (* finalise could run in a thread different from the lwt main thread. + * You may therefore not call into Lwt from a finaliser. *) + Gc.finalise_last + (fun () -> + if not !closed then + prerr_endline "Cohttp_lwt: body not consumed - leaking stream!") + stream; + body + | `No -> + closefn (); + `Empty let is_meth_chunked = function | `HEAD -> false @@ -38,101 +38,114 @@ module Make | `DELETE -> false | _ -> true - let call ?(ctx = Net.default_ctx) ?headers ?(body=`Empty) ?chunked meth uri = + let call ?(ctx = Net.default_ctx) ?headers ?(body = `Empty) ?chunked meth uri + = let headers = match headers with None -> Header.init () | Some h -> h in Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) -> let closefn () = Net.close ic oc in let chunked = + match chunked with None -> is_meth_chunked meth | Some v -> v + in + let sent = match chunked with - | None -> is_meth_chunked meth - | Some v -> v in - let sent = match chunked with | true -> - let req = Request.make_for_client ~headers ~chunked meth uri in - Request.write (fun writer -> - Body.write_body (Request.write_body writer) body) req oc + let req = Request.make_for_client ~headers ~chunked meth uri in + Request.write + (fun writer -> Body.write_body (Request.write_body writer) body) + req oc | false -> - (* If chunked is not allowed, then obtain the body length and - insert header *) - Body.length body >>= fun (body_length, buf) -> - let req = - Request.make_for_client ~headers ~chunked ~body_length meth uri - in - Request.write (fun writer -> - Body.write_body (Request.write_body writer) buf) req oc + (* If chunked is not allowed, then obtain the body length and + insert header *) + Body.length body >>= fun (body_length, buf) -> + let req = + Request.make_for_client ~headers ~chunked ~body_length meth uri + in + Request.write + (fun writer -> Body.write_body (Request.write_body writer) buf) + req oc in sent >>= fun () -> - Response.read ic >>= begin function - | `Invalid reason -> - Lwt.fail (Failure ("Failed to read response: " ^ reason)) - | `Eof -> - Lwt.fail (Failure "Server closed connection prematurely.") - | `Ok res -> - match meth with - | `HEAD -> - closefn () ; - Lwt.return (res, `Empty) - | _ -> - let body = read_body ~closefn ic res in - Lwt.return (res, body) end |> fun t -> - Lwt.on_cancel t closefn ; - Lwt.on_failure t (fun _exn -> closefn ()) ; + (Response.read ic >>= function + | `Invalid reason -> + Lwt.fail (Failure ("Failed to read response: " ^ reason)) + | `Eof -> Lwt.fail (Failure "Server closed connection prematurely.") + | `Ok res -> ( + match meth with + | `HEAD -> + closefn (); + Lwt.return (res, `Empty) + | _ -> + let body = read_body ~closefn ic res in + Lwt.return (res, body))) + |> fun t -> + Lwt.on_cancel t closefn; + Lwt.on_failure t (fun _exn -> closefn ()); t (* The HEAD should not have a response body *) - let head ?ctx ?headers uri = - call ?ctx ?headers `HEAD uri - >|= fst - + let head ?ctx ?headers uri = call ?ctx ?headers `HEAD uri >|= fst let get ?ctx ?headers uri = call ?ctx ?headers `GET uri + let delete ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `DELETE uri + let post ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `POST uri + let put ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `PUT uri + let patch ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `PATCH uri let post_form ?ctx ?headers ~params uri = - let headers = Header.add_opt_unless_exists headers - "content-type" "application/x-www-form-urlencoded" in + let headers = + Header.add_opt_unless_exists headers "content-type" + "application/x-www-form-urlencoded" + in let body = Body.of_string (Uri.encoded_of_query params) in post ?ctx ~chunked:false ~headers ~body uri let callv ?(ctx = Net.default_ctx) uri reqs = Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) -> (* Serialise the requests out to the wire *) - let meth_stream = Lwt_stream.map_s (fun (req,body) -> - Request.write (fun writer -> - Body.write_body (Request.write_body writer) body - ) req oc >>= fun () -> - Lwt.return (Request.meth req) - ) reqs in + let meth_stream = + Lwt_stream.map_s + (fun (req, body) -> + Request.write + (fun writer -> Body.write_body (Request.write_body writer) body) + req oc + >>= fun () -> Lwt.return (Request.meth req)) + reqs + in (* Read the responses. For each response, ensure that the previous response has consumed the body before continuing to the next response because HTTP/1.1-pipelining cannot be interleaved. *) let read_m = Lwt_mutex.create () in let closefn () = Lwt_mutex.unlock read_m in - let resps = Lwt_stream.map_s (fun meth -> - Lwt_mutex.with_lock read_m begin fun () -> - Response.read ic >>= begin function - | `Invalid reason -> - Lwt.fail (Failure ("Failed to read response: " ^ reason)) - | `Eof -> - Lwt.fail (Failure "Server closed connection prematurely.") - | `Ok res -> - match meth with - | `HEAD -> - closefn () ; - Lwt.return (res, `Empty) - | _ -> - let body = read_body ~closefn ic res in - Lwt.return (res, body) end |> fun t -> - Lwt.on_cancel t closefn ; - Lwt.on_failure t (fun _exn -> closefn ()) ; t - end - ) meth_stream in + let resps = + Lwt_stream.map_s + (fun meth -> + Lwt_mutex.with_lock read_m (fun () -> + (Response.read ic >>= function + | `Invalid reason -> + Lwt.fail (Failure ("Failed to read response: " ^ reason)) + | `Eof -> + Lwt.fail (Failure "Server closed connection prematurely.") + | `Ok res -> ( + match meth with + | `HEAD -> + closefn (); + Lwt.return (res, `Empty) + | _ -> + let body = read_body ~closefn ic res in + Lwt.return (res, body))) + |> fun t -> + Lwt.on_cancel t closefn; + Lwt.on_failure t (fun _exn -> closefn ()); + t)) + meth_stream + in Lwt.on_success (Lwt_stream.closed resps) (fun () -> Net.close ic oc); Lwt.return resps end diff --git a/cohttp-lwt/src/client.mli b/cohttp-lwt/src/client.mli index f76fc6f3f5..4846193b25 100644 --- a/cohttp-lwt/src/client.mli +++ b/cohttp-lwt/src/client.mli @@ -1,7 +1,6 @@ +(** The [Make] functor glues together a {!Cohttp.S.IO} implementation to send + requests down a connection that is established by the {!Net} module. The + resulting module satisfies the {!Client} module type. *) -(** The [Make] functor glues together a {! Cohttp.S.IO } implementation - to send requests down a connection that is established by the {! Net } - module. The resulting module satisfies the {! Client } module type. *) - -module Make (IO:S.IO) (Net:S.Net with module IO = IO) : S.Client - with type ctx = Net.ctx +module Make (IO : S.IO) (Net : S.Net with module IO = IO) : + S.Client with type ctx = Net.ctx diff --git a/cohttp-lwt/src/cohttp_lwt.ml b/cohttp-lwt/src/cohttp_lwt.ml index fe7c8c2951..9676c61b1f 100644 --- a/cohttp-lwt/src/cohttp_lwt.ml +++ b/cohttp-lwt/src/cohttp_lwt.ml @@ -18,9 +18,7 @@ module type IO = S.IO module Request = Cohttp.Request module Response = Cohttp.Response - module Make_client = Client.Make module Make_server = Server.Make module S = S module Body = Body - diff --git a/cohttp-lwt/src/make.ml b/cohttp-lwt/src/make.ml index 486d3aa0fe..964b0cf45f 100644 --- a/cohttp-lwt/src/make.ml +++ b/cohttp-lwt/src/make.ml @@ -1,10 +1,9 @@ - -module Request(IO:S.IO) = struct +module Request (IO : S.IO) = struct include Cohttp.Request - include (Make(IO) : module type of Make(IO) with type t := t) -end + include (Make (IO) : module type of Make (IO) with type t := t) + end -module Response(IO:S.IO) = struct +module Response (IO : S.IO) = struct include Cohttp.Response - include (Make(IO) : module type of Make(IO) with type t := t) -end + include (Make (IO) : module type of Make (IO) with type t := t) + end diff --git a/cohttp-lwt/src/s.ml b/cohttp-lwt/src/s.ml index ccaebe52ab..bed6e08fbc 100644 --- a/cohttp-lwt/src/s.ml +++ b/cohttp-lwt/src/s.ml @@ -1,24 +1,22 @@ +(** Portable Lwt implementation of HTTP client and server, without depending on + a particular I/O implementation. The various [Make] functors must be + instantiated by an implementation that provides a concrete IO monad. *) -(** Portable Lwt implementation of HTTP client and server, without - depending on a particular I/O implementation. The various [Make] - functors must be instantiated by an implementation that provides - a concrete IO monad. *) - +(** The IO module is specialized for the [Lwt] monad. *) module type IO = sig include Cohttp.S.IO with type 'a t = 'a Lwt.t type error val catch : (unit -> 'a t) -> ('a, error) result t - (** [catch f] is [f () >|= Result.ok], unless [f] fails with an IO error, - in which case it returns the error. *) + (** [catch f] is [f () >|= Result.ok], unless [f] fails with an IO error, in + which case it returns the error. *) val pp_error : Format.formatter -> error -> unit end -(** The IO module is specialized for the [Lwt] monad. *) -(** The [Net] module type defines how to connect to a remote node - and close the resulting channels to clean up. *) +(** The [Net] module type defines how to connect to a remote node and close the + resulting channels to clean up. *) module type Net = sig module IO : IO @@ -31,85 +29,89 @@ module type Net = sig val close : IO.ic -> IO.oc -> unit end -(** The [Client] module implements non-pipelined single HTTP client - calls. Each call will open a separate {! Net } connection. For - best results, the {! Body } that is returned should be - consumed in order to close the file descriptor in a timely - fashion. It will still be finalized by a GC hook if it is not used +(** The [Client] module implements non-pipelined single HTTP client calls. Each + call will open a separate {!Net} connection. For best results, the {!Body} + that is returned should be consumed in order to close the file descriptor in + a timely fashion. It will still be finalized by a GC hook if it is not used up, but this can take some additional time to happen. *) module type Client = sig type ctx - (** [call ?ctx ?headers ?body ?chunked meth uri] will resolve the - [uri] to a concrete network endpoint using context [ctx]. - It will then issue an HTTP request with method [meth], - adding request headers from [headers] if present. If a [body] - is specified then that will be included with the request, using - chunked encoding if [chunked] is true. The default is to disable - chunked encoding for HTTP request bodies for compatibility reasons. - - In most cases you should use the more specific helper calls in the - interface rather than invoke this function directly. See {!head}, - {!get} and {!post} for some examples. - - Depending on [ctx], the library is able to send a simple HTTP request - or an encrypted one with a secured protocol (such as TLS). Depending on - how conduit is configured, [ctx] might initiate a secured connection - with TLS (using [ocaml-tls]) or SSL (using [ocaml-ssl]), on [*:443] or on - the specified port by the user. If neitehr [ocaml-tls] or [ocaml-ssl] are - installed on the system, [cohttp]/[conduit] tries the usual ([*:80]) or - the specified port by the user in a non-secured way. *) val call : ?ctx:ctx -> ?headers:Cohttp.Header.t -> ?body:Body.t -> ?chunked:bool -> Cohttp.Code.meth -> - Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t + Uri.t -> + (Cohttp.Response.t * Body.t) Lwt.t + (** [call ?ctx ?headers ?body ?chunked meth uri] will resolve the [uri] to a + concrete network endpoint using context [ctx]. It will then issue an HTTP + request with method [meth], adding request headers from [headers] if + present. If a [body] is specified then that will be included with the + request, using chunked encoding if [chunked] is true. The default is to + disable chunked encoding for HTTP request bodies for compatibility + reasons. + + In most cases you should use the more specific helper calls in the + interface rather than invoke this function directly. See {!head}, {!get} + and {!post} for some examples. + + Depending on [ctx], the library is able to send a simple HTTP request or + an encrypted one with a secured protocol (such as TLS). Depending on how + conduit is configured, [ctx] might initiate a secured connection with TLS + (using [ocaml-tls]) or SSL (using [ocaml-ssl]), on [*:443] or on the + specified port by the user. If neitehr [ocaml-tls] or [ocaml-ssl] are + installed on the system, [cohttp]/[conduit] tries the usual ([*:80]) or + the specified port by the user in a non-secured way. *) val head : - ?ctx:ctx -> - ?headers:Cohttp.Header.t -> - Uri.t -> Cohttp.Response.t Lwt.t + ?ctx:ctx -> ?headers:Cohttp.Header.t -> Uri.t -> Cohttp.Response.t Lwt.t val get : ?ctx:ctx -> ?headers:Cohttp.Header.t -> - Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t + Uri.t -> + (Cohttp.Response.t * Body.t) Lwt.t val delete : ?ctx:ctx -> ?body:Body.t -> ?chunked:bool -> ?headers:Cohttp.Header.t -> - Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t + Uri.t -> + (Cohttp.Response.t * Body.t) Lwt.t val post : ?ctx:ctx -> ?body:Body.t -> ?chunked:bool -> ?headers:Cohttp.Header.t -> - Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t + Uri.t -> + (Cohttp.Response.t * Body.t) Lwt.t val put : ?ctx:ctx -> ?body:Body.t -> ?chunked:bool -> ?headers:Cohttp.Header.t -> - Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t + Uri.t -> + (Cohttp.Response.t * Body.t) Lwt.t val patch : ?ctx:ctx -> ?body:Body.t -> ?chunked:bool -> ?headers:Cohttp.Header.t -> - Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t + Uri.t -> + (Cohttp.Response.t * Body.t) Lwt.t val post_form : ?ctx:ctx -> ?headers:Cohttp.Header.t -> params:(string * string list) list -> - Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t + Uri.t -> + (Cohttp.Response.t * Body.t) Lwt.t val callv : ?ctx:ctx -> @@ -124,7 +126,11 @@ module type Server = sig type conn = IO.conn * Cohttp.Connection.t + type response_action = + [ `Expert of Cohttp.Response.t * (IO.ic -> IO.oc -> unit Lwt.t) + | `Response of Cohttp.Response.t * Body.t ] (** A request handler can respond in two ways: + - Using [`Response], with a {!Response.t} and a {!Body.t}. - Using [`Expert], with a {!Response.t} and an IO function that is expected to write the response body. The IO function has access to the @@ -133,75 +139,80 @@ module type Server = sig (e.g. websockets). Processing of pipelined requests continue after the {!unit Lwt.t} is resolved. The connection can be closed by closing the {!IO.ic}. *) - type response_action = - [ `Expert of Cohttp.Response.t - * (IO.ic - -> IO.oc - -> unit Lwt.t) - | `Response of Cohttp.Response.t * Body.t ] type t val make_response_action : ?conn_closed:(conn -> unit) -> - callback:(conn -> Cohttp.Request.t -> Body.t -> - response_action Lwt.t) -> + callback:(conn -> Cohttp.Request.t -> Body.t -> response_action Lwt.t) -> unit -> t val make_expert : ?conn_closed:(conn -> unit) -> - callback:(conn -> Cohttp.Request.t -> Body.t -> - (Cohttp.Response.t * (IO.ic -> IO.oc -> unit Lwt.t)) Lwt.t) -> + callback: + (conn -> + Cohttp.Request.t -> + Body.t -> + (Cohttp.Response.t * (IO.ic -> IO.oc -> unit Lwt.t)) Lwt.t) -> unit -> t val make : ?conn_closed:(conn -> unit) -> - callback:(conn -> Cohttp.Request.t -> Body.t -> - (Cohttp.Response.t * Body.t) Lwt.t) -> + callback: + (conn -> Cohttp.Request.t -> Body.t -> (Cohttp.Response.t * Body.t) Lwt.t) -> unit -> t - (** Resolve a URI and a docroot into a concrete local filename. *) val resolve_local_file : docroot:string -> uri:Uri.t -> string + (** Resolve a URI and a docroot into a concrete local filename. *) - (** [respond ?headers ?flush ~status ~body] will respond to an HTTP - request with the given [status] code and response [body]. If - [flush] is true, then every response chunk will be flushed to - the network rather than being buffered. [flush] is true by default. - The transfer encoding will be detected from the [body] value and - set to chunked encoding if it cannot be determined immediately. - You can override the encoding by supplying an appropriate [Content-length] - or [Transfer-encoding] in the [headers] parameter. *) val respond : ?headers:Cohttp.Header.t -> ?flush:bool -> status:Cohttp.Code.status_code -> - body:Body.t -> unit -> (Cohttp.Response.t * Body.t) Lwt.t + body:Body.t -> + unit -> + (Cohttp.Response.t * Body.t) Lwt.t + (** [respond ?headers ?flush ~status ~body] will respond to an HTTP request + with the given [status] code and response [body]. If [flush] is true, then + every response chunk will be flushed to the network rather than being + buffered. [flush] is true by default. The transfer encoding will be + detected from the [body] value and set to chunked encoding if it cannot be + determined immediately. You can override the encoding by supplying an + appropriate [Content-length] or [Transfer-encoding] in the [headers] + parameter. *) val respond_string : ?flush:bool -> ?headers:Cohttp.Header.t -> status:Cohttp.Code.status_code -> - body:string -> unit -> (Cohttp.Response.t * Body.t) Lwt.t + body:string -> + unit -> + (Cohttp.Response.t * Body.t) Lwt.t val respond_error : ?headers:Cohttp.Header.t -> ?status:Cohttp.Code.status_code -> - body:string -> unit -> (Cohttp.Response.t * Body.t) Lwt.t + body:string -> + unit -> + (Cohttp.Response.t * Body.t) Lwt.t val respond_redirect : ?headers:Cohttp.Header.t -> - uri:Uri.t -> unit -> (Cohttp.Response.t * Body.t) Lwt.t + uri:Uri.t -> + unit -> + (Cohttp.Response.t * Body.t) Lwt.t val respond_need_auth : ?headers:Cohttp.Header.t -> - auth:Cohttp.Auth.challenge -> unit -> (Cohttp.Response.t * Body.t) Lwt.t + auth:Cohttp.Auth.challenge -> + unit -> + (Cohttp.Response.t * Body.t) Lwt.t val respond_not_found : ?uri:Uri.t -> unit -> (Cohttp.Response.t * Body.t) Lwt.t val callback : t -> IO.conn -> IO.ic -> IO.oc -> unit Lwt.t - end diff --git a/cohttp-lwt/src/server.ml b/cohttp-lwt/src/server.ml index bcfcf271f5..948c2c85ae 100644 --- a/cohttp-lwt/src/server.ml +++ b/cohttp-lwt/src/server.ml @@ -1,163 +1,152 @@ open Lwt.Infix - module Header = Cohttp.Header -module Make(IO:S.IO) = struct +module Make (IO : S.IO) = struct module IO = IO - module Request = Make.Request(IO) - module Response = Make.Response(IO) + module Request = Make.Request (IO) + module Response = Make.Response (IO) let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server module" + module Log = (val Logs.src_log src : Logs.LOG) type conn = IO.conn * Cohttp.Connection.t type response_action = - [ `Expert of Cohttp.Response.t - * (IO.ic - -> IO.oc - -> unit Lwt.t) + [ `Expert of Cohttp.Response.t * (IO.ic -> IO.oc -> unit Lwt.t) | `Response of Cohttp.Response.t * Body.t ] type t = { - callback : - conn -> - Cohttp.Request.t -> - Body.t -> - response_action Lwt.t; - conn_closed: conn -> unit; + callback : conn -> Cohttp.Request.t -> Body.t -> response_action Lwt.t; + conn_closed : conn -> unit; } - let make_response_action ?(conn_closed=ignore) ~callback () = - { conn_closed ; callback } + let make_response_action ?(conn_closed = ignore) ~callback () = + { conn_closed; callback } let make ?conn_closed ~callback () = let callback conn req body = - callback conn req body >|= fun rsp -> - `Response rsp + callback conn req body >|= fun rsp -> `Response rsp in make_response_action ?conn_closed ~callback () let make_expert ?conn_closed ~callback () = let callback conn req body = - callback conn req body >|= fun rsp -> - `Expert rsp + callback conn req body >|= fun rsp -> `Expert rsp in make_response_action ?conn_closed ~callback () - module Transfer_IO = Cohttp__Transfer_io.Make(IO) + module Transfer_IO = Cohttp__Transfer_io.Make (IO) let resolve_local_file ~docroot ~uri = let path = Uri.(pct_decode (path (resolve "http" (of_string "/") uri))) in let rel_path = String.sub path 1 (String.length path - 1) in Filename.concat docroot rel_path - let respond ?headers ?(flush=true) ~status ~body () = + let respond ?headers ?(flush = true) ~status ~body () = let encoding = match headers with | None -> Body.transfer_encoding body - | Some headers -> - match Header.get_transfer_encoding headers with - | Cohttp.Transfer.Unknown -> Body.transfer_encoding body - | t -> t + | Some headers -> ( + match Header.get_transfer_encoding headers with + | Cohttp.Transfer.Unknown -> Body.transfer_encoding body + | t -> t) in let res = Response.make ~status ~flush ~encoding ?headers () in Lwt.return (res, body) - let respond_string ?(flush=true) ?headers ~status ~body () = - let res = Response.make ~status ~flush - ~encoding:(Cohttp.Transfer.Fixed - (Int64.of_int (String.length body))) - ?headers () in + let respond_string ?(flush = true) ?headers ~status ~body () = + let res = + Response.make ~status ~flush + ~encoding:(Cohttp.Transfer.Fixed (Int64.of_int (String.length body))) + ?headers () + in let body = Body.of_string body in - Lwt.return (res,body) + Lwt.return (res, body) - let respond_error ?headers ?(status=`Internal_server_error) ~body () = - respond_string ?headers ~status ~body:("Error: "^body) () + let respond_error ?headers ?(status = `Internal_server_error) ~body () = + respond_string ?headers ~status ~body:("Error: " ^ body) () let respond_redirect ?headers ~uri () = let headers = match headers with - |None -> Header.init_with "location" (Uri.to_string uri) - |Some h -> Header.add_unless_exists h "location" (Uri.to_string uri) + | None -> Header.init_with "location" (Uri.to_string uri) + | Some h -> Header.add_unless_exists h "location" (Uri.to_string uri) in respond ~headers ~status:`Found ~body:`Empty () let respond_need_auth ?headers ~auth () = - let headers = match headers with |None -> Header.init () |Some h -> h in + let headers = match headers with None -> Header.init () | Some h -> h in let headers = Header.add_authorization_req headers auth in respond ~headers ~status:`Unauthorized ~body:`Empty () let respond_not_found ?uri () = - let body = match uri with - |None -> "Not found" - |Some uri -> "Not found: " ^ (Uri.to_string uri) in + let body = + match uri with + | None -> "Not found" + | Some uri -> "Not found: " ^ Uri.to_string uri + in respond_string ~status:`Not_found ~body () let read_body ic req = match Request.has_body req with | `Yes -> - let reader = Request.make_body_reader req ic in - let body_stream = Body.create_stream - Request.read_body_chunk reader in - Body.of_stream body_stream - | `No | `Unknown -> - `Empty + let reader = Request.make_body_reader req ic in + let body_stream = Body.create_stream Request.read_body_chunk reader in + Body.of_stream body_stream + | `No | `Unknown -> `Empty let handle_request callback conn req body = - Log.debug (fun m -> m "Handle request: %a." Request.pp_hum req) ; + Log.debug (fun m -> m "Handle request: %a." Request.pp_hum req); Lwt.finalize (fun () -> - Lwt.catch - (fun () -> callback conn req body) - (function - | Out_of_memory -> Lwt.fail Out_of_memory - | exn -> - Log.err (fun f -> f "Error handling %a: %s" Request.pp_hum req (Printexc.to_string exn)); - respond_error ~body:"Internal Server Error" () >|= fun rsp -> - `Response rsp - )) + Lwt.catch + (fun () -> callback conn req body) + (function + | Out_of_memory -> Lwt.fail Out_of_memory + | exn -> + Log.err (fun f -> + f "Error handling %a: %s" Request.pp_hum req + (Printexc.to_string exn)); + respond_error ~body:"Internal Server Error" () >|= fun rsp -> + `Response rsp)) (fun () -> Body.drain_body body) let rec handle_client ic oc conn callback = Request.read ic >>= function | `Eof -> Lwt.return_unit | `Invalid data -> - Log.err (fun m -> m "invalid input %s while handling client" data); - Lwt.return_unit - | `Ok req -> - begin let body = read_body ic req in - handle_request callback conn req body >>= function - | `Response (res,body) -> - let flush = Response.flush res in - Response.write ~flush (fun writer -> - Body.write_body (Response.write_body writer) body - ) res oc >>= fun () -> - if Request.is_keep_alive req then - handle_client ic oc conn callback - else - Lwt.return_unit - | `Expert (res,io_handler) -> - Response.write_header res oc >>= fun () -> - io_handler ic oc >>= fun () -> - handle_client ic oc conn callback - end + Log.err (fun m -> m "invalid input %s while handling client" data); + Lwt.return_unit + | `Ok req -> ( + let body = read_body ic req in + handle_request callback conn req body >>= function + | `Response (res, body) -> + let flush = Response.flush res in + Response.write ~flush + (fun writer -> Body.write_body (Response.write_body writer) body) + res oc + >>= fun () -> + if Request.is_keep_alive req then handle_client ic oc conn callback + else Lwt.return_unit + | `Expert (res, io_handler) -> + Response.write_header res oc >>= fun () -> + io_handler ic oc >>= fun () -> handle_client ic oc conn callback) let callback spec io_id ic oc = let conn_id = Cohttp.Connection.create () in - let conn_closed () = spec.conn_closed (io_id,conn_id) in + let conn_closed () = spec.conn_closed (io_id, conn_id) in Lwt.finalize (fun () -> - IO.catch (fun () -> handle_client ic oc (io_id,conn_id) spec.callback) - >>= function - | Ok () -> Lwt.return_unit - | Error e -> - Log.info (fun m -> m "IO error while handling client: %a" IO.pp_error e); - Lwt.return_unit - ) + IO.catch (fun () -> handle_client ic oc (io_id, conn_id) spec.callback) + >>= function + | Ok () -> Lwt.return_unit + | Error e -> + Log.info (fun m -> + m "IO error while handling client: %a" IO.pp_error e); + Lwt.return_unit) (fun () -> - (* Clean up resources when the response stream terminates and call - * the user callback *) - conn_closed () |> Lwt.return - ) + (* Clean up resources when the response stream terminates and call + * the user callback *) + conn_closed () |> Lwt.return) end diff --git a/cohttp-lwt/src/server.mli b/cohttp-lwt/src/server.mli index e701575134..bbc46a07ff 100644 --- a/cohttp-lwt/src/server.mli +++ b/cohttp-lwt/src/server.mli @@ -1,5 +1,4 @@ - -(** The [Make] functor glues together a {! Cohttp.S.IO } implementation - to send requests down a connection that is established by the user. - The resulting module satisfies the {! Server } module type. *) -module Make (IO:S.IO) : S.Server with module IO = IO +(** The [Make] functor glues together a {!Cohttp.S.IO} implementation to send + requests down a connection that is established by the user. The resulting + module satisfies the {!Server} module type. *) +module Make (IO : S.IO) : S.Server with module IO = IO diff --git a/cohttp-lwt/src/string_io.ml b/cohttp-lwt/src/string_io.ml index b1102c57a5..ec94654eee 100644 --- a/cohttp-lwt/src/string_io.ml +++ b/cohttp-lwt/src/string_io.ml @@ -16,8 +16,9 @@ }}}*) type 'a t = 'a Lwt.t + let return = Lwt.return -let (>>=) = Lwt.bind +let ( >>= ) = Lwt.bind module Sio = Cohttp__String_io @@ -27,7 +28,5 @@ type conn = Sio.M.conn let read_line ic = return (Sio.M.read_line ic) let read ic n = return (Sio.M.read ic n) - let write oc str = return (Sio.M.write oc str) let flush oc = return (Sio.M.flush oc) - diff --git a/cohttp-lwt/src/string_io.mli b/cohttp-lwt/src/string_io.mli index add3623466..6d3603a8e3 100644 --- a/cohttp-lwt/src/string_io.mli +++ b/cohttp-lwt/src/string_io.mli @@ -17,11 +17,11 @@ (** Lwt IO implementation that uses strings to marshal and unmarshal HTTP *) -(** IO interface that uses {!buf} for input data and queues output - data into a {!Buffer.t}. Never actually blocks despite the Lwt - use, although a future revision may yield when parsing large - strings. *) -include Cohttp.S.IO - with type 'a t = 'a Lwt.t - and type ic = Cohttp__String_io.buf - and type oc = Buffer.t +(** IO interface that uses {!buf} for input data and queues output data into a + {!Buffer.t}. Never actually blocks despite the Lwt use, although a future + revision may yield when parsing large strings. *) +include + Cohttp.S.IO + with type 'a t = 'a Lwt.t + and type ic = Cohttp__String_io.buf + and type oc = Buffer.t diff --git a/cohttp-mirage/src/client.ml b/cohttp-mirage/src/client.ml index 31a1250ccc..dfd1e7e118 100644 --- a/cohttp-mirage/src/client.ml +++ b/cohttp-mirage/src/client.ml @@ -18,26 +18,20 @@ *) open Lwt.Infix - -module Channel = Mirage_channel.Make(Conduit_mirage.Flow) -module HTTP_IO = Io.Make(Channel) - +module Channel = Mirage_channel.Make (Conduit_mirage.Flow) +module HTTP_IO = Io.Make (Channel) module Net_IO = struct - module IO = HTTP_IO - type ctx = { - resolver: Resolver_lwt.t; - conduit : Conduit_mirage.t; - } + type ctx = { resolver : Resolver_lwt.t; conduit : Conduit_mirage.t } let sexp_of_ctx { resolver; _ } = Resolver_lwt.sexp_of_t resolver let default_ctx = { resolver = Resolver_mirage.localhost; conduit = Conduit_mirage.empty } - let connect_uri ~ctx:{resolver; conduit} uri = + let connect_uri ~ctx:{ resolver; conduit } uri = Resolver_lwt.resolve_uri ~uri resolver >>= fun endp -> Conduit_mirage.client endp >>= fun client -> Conduit_mirage.connect conduit client >>= fun flow -> @@ -46,16 +40,18 @@ module Net_IO = struct let close_in _ = () let close_out _ = () - let close ic _oc = Lwt.ignore_result @@ Lwt.catch - (fun () -> Channel.close ic) - (fun e -> - Logs.warn (fun f -> - f "Closing channel failed: %s" (Printexc.to_string e)); - Lwt.return @@ Ok () - ) + let close ic _oc = + Lwt.ignore_result + @@ Lwt.catch + (fun () -> Channel.close ic) + (fun e -> + Logs.warn (fun f -> + f "Closing channel failed: %s" (Printexc.to_string e)); + Lwt.return @@ Ok ()) end + let ctx resolver conduit = { Net_IO.resolver; conduit } (* Build all the core modules from the [Cohttp_lwt] functors *) -include Cohttp_lwt.Make_client(HTTP_IO)(Net_IO) +include Cohttp_lwt.Make_client (HTTP_IO) (Net_IO) diff --git a/cohttp-mirage/src/client.mli b/cohttp-mirage/src/client.mli index af9806a910..337c0c183f 100644 --- a/cohttp-mirage/src/client.mli +++ b/cohttp-mirage/src/client.mli @@ -1,3 +1,3 @@ include Cohttp_lwt.S.Client -val ctx: Resolver_lwt.t -> Conduit_mirage.t -> ctx +val ctx : Resolver_lwt.t -> Conduit_mirage.t -> ctx diff --git a/cohttp-mirage/src/cohttp_mirage.ml b/cohttp-mirage/src/cohttp_mirage.ml index ae0aef9010..502ec24b3c 100644 --- a/cohttp-mirage/src/cohttp_mirage.ml +++ b/cohttp-mirage/src/cohttp_mirage.ml @@ -1,4 +1,3 @@ - module Static = Static module Client = Client module Server = Make.Server diff --git a/cohttp-mirage/src/io.ml b/cohttp-mirage/src/io.ml index 69c32a311f..fe2f9d7668 100644 --- a/cohttp-mirage/src/io.ml +++ b/cohttp-mirage/src/io.ml @@ -19,8 +19,7 @@ open Lwt.Infix -module Make (Channel: Mirage_channel.S) = struct - +module Make (Channel : Mirage_channel.S) = struct type error = | Read_error of Channel.error | Write_error of Channel.write_error @@ -39,43 +38,42 @@ module Make (Channel: Mirage_channel.S) = struct let () = Printexc.register_printer (function - | Read_exn e -> Some (Format.asprintf "IO read error: %a" Channel.pp_error e) - | Write_exn e -> Some (Format.asprintf "IO write error: %a" Channel.pp_write_error e) - | _ -> None - ) + | Read_exn e -> + Some (Format.asprintf "IO read error: %a" Channel.pp_error e) + | Write_exn e -> + Some (Format.asprintf "IO write error: %a" Channel.pp_write_error e) + | _ -> None) let read_line ic = Channel.read_line ic >>= function - | Ok (`Data []) -> Lwt.return_none - | Ok `Eof -> Lwt.return_none + | Ok (`Data []) -> Lwt.return_none + | Ok `Eof -> Lwt.return_none | Ok (`Data bufs) -> Lwt.return_some (Cstruct.copyv bufs) - | Error e -> Lwt.fail (Read_exn e) + | Error e -> Lwt.fail (Read_exn e) let read ic len = Channel.read_some ~len ic >>= function | Ok (`Data buf) -> Lwt.return (Cstruct.to_string buf) - | Ok `Eof -> Lwt.return "" - | Error e -> Lwt.fail (Read_exn e) + | Ok `Eof -> Lwt.return "" + | Error e -> Lwt.fail (Read_exn e) let write oc buf = Channel.write_string oc buf 0 (String.length buf); Channel.flush oc >>= function - | Ok () -> Lwt.return_unit + | Ok () -> Lwt.return_unit | Error `Closed -> Lwt.fail_with "Trying to write on closed channel" - | Error e -> Lwt.fail (Write_exn e) + | Error e -> Lwt.fail (Write_exn e) let flush _ = (* NOOP since we flush in the normal writer functions above *) Lwt.return_unit - let (>>= ) = Lwt.( >>= ) + let ( >>= ) = Lwt.( >>= ) let return = Lwt.return let catch f = - Lwt.try_bind f Lwt.return_ok - (function - | Read_exn e -> Lwt.return_error (Read_error e) - | Write_exn e -> Lwt.return_error (Write_error e) - | ex -> Lwt.fail ex - ) + Lwt.try_bind f Lwt.return_ok (function + | Read_exn e -> Lwt.return_error (Read_error e) + | Write_exn e -> Lwt.return_error (Write_error e) + | ex -> Lwt.fail ex) end diff --git a/cohttp-mirage/src/io.mli b/cohttp-mirage/src/io.mli index 0fd5b9a08d..23e9792f90 100644 --- a/cohttp-mirage/src/io.mli +++ b/cohttp-mirage/src/io.mli @@ -19,7 +19,8 @@ (** Cohttp IO implementation using Mirage channels. *) -module Make (Channel: Mirage_channel.S) : Cohttp_lwt.S.IO - with type ic = Channel.t - and type oc = Channel.t - and type conn = Channel.flow +module Make (Channel : Mirage_channel.S) : + Cohttp_lwt.S.IO + with type ic = Channel.t + and type oc = Channel.t + and type conn = Channel.flow diff --git a/cohttp-mirage/src/make.ml b/cohttp-mirage/src/make.ml index bdc9f2b184..0a4d5f20b9 100644 --- a/cohttp-mirage/src/make.ml +++ b/cohttp-mirage/src/make.ml @@ -1,15 +1,13 @@ open Lwt.Infix -module Server (Flow: Mirage_flow.S) = struct - - module Channel = Mirage_channel.Make(Flow) - module HTTP_IO = Io.Make(Channel) - include Cohttp_lwt.Make_server(HTTP_IO) +module Server (Flow : Mirage_flow.S) = struct + module Channel = Mirage_channel.Make (Flow) + module HTTP_IO = Io.Make (Channel) + include Cohttp_lwt.Make_server (HTTP_IO) let listen spec flow = let ch = Channel.create flow in Lwt.finalize (fun () -> callback spec flow ch ch) (fun () -> Channel.close ch >|= fun _ -> ()) - end diff --git a/cohttp-mirage/src/make.mli b/cohttp-mirage/src/make.mli index 10090ad2d5..920bcf6fe9 100644 --- a/cohttp-mirage/src/make.mli +++ b/cohttp-mirage/src/make.mli @@ -1,6 +1,6 @@ - (** HTTP server. *) -module Server (Flow: Mirage_flow.S): sig +module Server (Flow : Mirage_flow.S) : sig include Cohttp_lwt.S.Server with type IO.conn = Flow.flow - val listen: t -> IO.conn -> unit Lwt.t + + val listen : t -> IO.conn -> unit Lwt.t end diff --git a/cohttp-mirage/src/server_with_conduit.ml b/cohttp-mirage/src/server_with_conduit.ml index f0c192b51c..21fb8b40d0 100644 --- a/cohttp-mirage/src/server_with_conduit.ml +++ b/cohttp-mirage/src/server_with_conduit.ml @@ -1,4 +1,4 @@ -include Make.Server(Conduit_mirage.Flow) +include Make.Server (Conduit_mirage.Flow) let connect t = let listen s f = Conduit_mirage.listen t s (listen f) in diff --git a/cohttp-mirage/src/server_with_conduit.mli b/cohttp-mirage/src/server_with_conduit.mli index 18485b5596..60bb1a4e0d 100644 --- a/cohttp-mirage/src/server_with_conduit.mli +++ b/cohttp-mirage/src/server_with_conduit.mli @@ -1,6 +1,5 @@ - -(** HTTP server with conduit. *) include Cohttp_lwt.S.Server with type IO.conn = Conduit_mirage.Flow.flow -val connect: - Conduit_mirage.t -> - (Conduit_mirage.server -> t -> unit Lwt.t) Lwt.t +(** HTTP server with conduit. *) + +val connect : + Conduit_mirage.t -> (Conduit_mirage.server -> t -> unit Lwt.t) Lwt.t diff --git a/cohttp-mirage/src/static.ml b/cohttp-mirage/src/static.ml index 709bd668c9..6c19bf0d96 100644 --- a/cohttp-mirage/src/static.ml +++ b/cohttp-mirage/src/static.ml @@ -19,8 +19,7 @@ module Key = Mirage_kv.Key -module HTTP(FS: Mirage_kv.RO)(S: Cohttp_lwt.S.Server) = struct - +module HTTP (FS : Mirage_kv.RO) (S : Cohttp_lwt.S.Server) = struct open Lwt.Infix open Astring @@ -29,43 +28,45 @@ module HTTP(FS: Mirage_kv.RO)(S: Cohttp_lwt.S.Server) = struct let read_fs t name = FS.get t (Key.v name) >>= function | Error e -> failf "read %a" FS.pp_error e - | Ok buf -> Lwt.return buf + | Ok buf -> Lwt.return buf let exists t name = - FS.exists t (Key.v name) >|= function - | Ok (Some `Value) -> true - | Ok (Some _ | None) -> false - | Error e -> Fmt.failwith "exists %a" FS.pp_error e + FS.exists t (Key.v name) >|= function + | Ok (Some `Value) -> true + | Ok (Some _ | None) -> false + | Error e -> Fmt.failwith "exists %a" FS.pp_error e let dispatcher request_fn = let rec fn fs uri = - match Uri.path uri with - | ("" | "/") as path -> - Logs.info (fun f -> f "request for '%s'" path); - fn fs (Uri.with_path uri "index.html") - | path when String.is_suffix ~affix:"/" path -> - Logs.info (fun f -> f "request for '%s'" path); - fn fs (Uri.with_path uri "index.html") - | path -> - Logs.info (fun f -> f "request for '%s'" path); - Lwt.catch (fun () -> - read_fs fs path >>= fun body -> - let mime_type = Magic_mime.lookup path in - let headers = Cohttp.Header.init_with "content-type" mime_type in - let headers = match request_fn with - | None -> headers - | Some fn -> fn uri headers in - S.respond_string ~status:`OK ~body ~headers () - ) (fun _exn -> - let with_index = Fmt.strf "%s/index.html" path in - exists fs with_index >>= function - | true -> fn fs (Uri.with_path uri with_index) - | false -> S.respond_not_found () - ) - in fn + match Uri.path uri with + | ("" | "/") as path -> + Logs.info (fun f -> f "request for '%s'" path); + fn fs (Uri.with_path uri "index.html") + | path when String.is_suffix ~affix:"/" path -> + Logs.info (fun f -> f "request for '%s'" path); + fn fs (Uri.with_path uri "index.html") + | path -> + Logs.info (fun f -> f "request for '%s'" path); + Lwt.catch + (fun () -> + read_fs fs path >>= fun body -> + let mime_type = Magic_mime.lookup path in + let headers = Cohttp.Header.init_with "content-type" mime_type in + let headers = + match request_fn with + | None -> headers + | Some fn -> fn uri headers + in + S.respond_string ~status:`OK ~body ~headers ()) + (fun _exn -> + let with_index = Fmt.strf "%s/index.html" path in + exists fs with_index >>= function + | true -> fn fs (Uri.with_path uri with_index) + | false -> S.respond_not_found ()) + in + fn let start ~http_port ?request_fn fs http = - let callback (_, cid) request _body = let uri = Cohttp.Request.uri request in let cid = Cohttp.Connection.to_string cid in @@ -74,7 +75,7 @@ module HTTP(FS: Mirage_kv.RO)(S: Cohttp_lwt.S.Server) = struct in let conn_closed (_, cid) = let cid = Cohttp.Connection.to_string cid in - Logs.info (fun f -> f "[%s] closing" cid); + Logs.info (fun f -> f "[%s] closing" cid) in Logs.info (fun f -> f "listening on %d/TCP" http_port); http (`TCP http_port) (S.make ~conn_closed ~callback ()) diff --git a/cohttp-mirage/src/static.mli b/cohttp-mirage/src/static.mli index 3f3d82f12c..8f73c992c3 100644 --- a/cohttp-mirage/src/static.mli +++ b/cohttp-mirage/src/static.mli @@ -20,17 +20,19 @@ (** Serve static HTTP sites from a Mirage key-value store. *) (** Plain HTTP file serving from a read-only key-value store. *) -module HTTP(FS: Mirage_kv.RO)(S:Cohttp_lwt.S.Server) : sig +module HTTP (FS : Mirage_kv.RO) (S : Cohttp_lwt.S.Server) : sig + (** [start http_port ?request_fn fs http] will start a static HTTP server + listening on [http_port]. The files to serve will be looked up from the + [fs] key-value store. - (** [start http_port ?request_fn fs http] will start a static - HTTP server listening on [http_port]. The files to serve will - be looked up from the [fs] key-value store. + If [request_fn] is supplied, the URI and default header set (including the + MIME content-type header) will be passed to it and the response used as + the response header set instead. *) - If [request_fn] is supplied, the URI and default header set - (including the MIME content-type header) will be passed to it - and the response used as the response header set instead. *) - - val start: http_port:int -> + val start : + http_port:int -> ?request_fn:(Uri.t -> Cohttp.Header.t -> Cohttp.Header.t) -> - FS.t -> ([> `TCP of int ] -> S.t -> 'a) -> 'a + FS.t -> + ([> `TCP of int ] -> S.t -> 'a) -> + 'a end diff --git a/cohttp-top/src/cohttp_top.ml b/cohttp-top/src/cohttp_top.ml index 04dc81059f..461b67515f 100644 --- a/cohttp-top/src/cohttp_top.ml +++ b/cohttp-top/src/cohttp_top.ml @@ -1,9 +1,8 @@ -let printers = [ "Cohttp.Header.pp_hum" - ; "Cohttp.Request.pp_hum" - ; "Cohttp.Response.pp_hum" ] +let printers = + [ "Cohttp.Header.pp_hum"; "Cohttp.Request.pp_hum"; "Cohttp.Response.pp_hum" ] -let eval_string - ?(print_outcome = false) ?(err_formatter = Format.err_formatter) str = +let eval_string ?(print_outcome = false) ?(err_formatter = Format.err_formatter) + str = let lexbuf = Lexing.from_string str in let phrase = !Toploop.parse_toplevel_phrase lexbuf in Toploop.execute_phrase print_outcome err_formatter phrase @@ -17,4 +16,3 @@ let rec install_printers = function let () = if not (install_printers printers) then Format.eprintf "Problem installing Cohttp-printers@." - diff --git a/cohttp/scripts/generate.ml b/cohttp/scripts/generate.ml index affb0f7c2c..b93d7059cc 100644 --- a/cohttp/scripts/generate.ml +++ b/cohttp/scripts/generate.ml @@ -26,54 +26,67 @@ exception Escape of ((int * int) * (int * int)) * Jsonm.error let json_of_src src = let d = Jsonm.decoder src in - let dec () = match Jsonm.decode d with + let dec () = + match Jsonm.decode d with | `Lexeme l -> l - | `Error e -> raise (Escape (Jsonm.decoded_range d, e)) - | `End - | `Await -> assert false + | `Error e -> raise (Escape (Jsonm.decoded_range d, e)) + | `End | `Await -> assert false in - let rec value v k = match v with + let rec value v k = + match v with | `Os -> obj [] k | `As -> arr [] k - | `Null - | `Bool _ - | `String _ - | `Float _ as v -> k v + | (`Null | `Bool _ | `String _ | `Float _) as v -> k v | _ -> assert false - and arr vs k = match dec () with + and arr vs k = + match dec () with | `Ae -> k (`A (List.rev vs)) - | v -> value v (fun v -> arr (v :: vs) k) - and obj ms k = match dec () with - | `Oe -> k (`O (List.rev ms)) + | v -> value v (fun v -> arr (v :: vs) k) + and obj ms k = + match dec () with + | `Oe -> k (`O (List.rev ms)) | `Name n -> value (dec ()) (fun v -> obj ((n, v) :: ms) k) - | _ -> assert false + | _ -> assert false in - try `JSON (value (dec ()) (fun v -> v)) - with Escape (r, e) -> `Error (r, e) + try `JSON (value (dec ()) (fun v -> v)) with Escape (r, e) -> `Error (r, e) -let json_to_dst ~minify dst (json:t) = +let json_to_dst ~minify dst (json : t) = let enc e l = ignore (Jsonm.encode e (`Lexeme l)) in - let rec value v k e = match v with + let rec value v k e = + match v with | `A vs -> arr vs k e | `O ms -> obj ms k e - | `Null | `Bool _ | `Float _ | `String _ as v -> enc e v; k e - and arr vs k e = enc e `As; arr_vs vs k e - and arr_vs vs k e = match vs with + | (`Null | `Bool _ | `Float _ | `String _) as v -> + enc e v; + k e + and arr vs k e = + enc e `As; + arr_vs vs k e + and arr_vs vs k e = + match vs with | v :: vs' -> value v (arr_vs vs' k) e - | [] -> enc e `Ae; k e - and obj ms k e = enc e `Os; obj_ms ms k e - and obj_ms ms k e = match ms with - | (n, v) :: ms -> enc e (`Name n); value v (obj_ms ms k) e - | [] -> enc e `Oe; k e + | [] -> + enc e `Ae; + k e + and obj ms k e = + enc e `Os; + obj_ms ms k e + and obj_ms ms k e = + match ms with + | (n, v) :: ms -> + enc e (`Name n); + value v (obj_ms ms k) e + | [] -> + enc e `Oe; + k e in let e = Jsonm.encoder ~minify dst in let finish e = ignore (Jsonm.encode e `End) in match json with - | `A _ | `O _ as json -> value json finish e + | (`A _ | `O _) as json -> value json finish e | _ -> invalid_arg "invalid json text" -let to_buffer buf (json:t) = - json_to_dst ~minify:true (`Buffer buf) json +let to_buffer buf (json : t) = json_to_dst ~minify:true (`Buffer buf) json let output t = let buf = Buffer.create 1024 in @@ -81,121 +94,110 @@ let output t = Buffer.contents buf let parse_error fmt = - Printf.kprintf (fun msg -> + Printf.kprintf + (fun msg -> Printf.eprintf "parse error: %s\n" msg; - exit 1 - ) fmt + exit 1) + fmt let string_of_error error = Jsonm.pp_error Format.str_formatter error; Format.flush_str_formatter () -let of_buffer buf: t = +let of_buffer buf : t = let str = Buffer.contents buf in match json_of_src (`String str) with - | `JSON j -> j - | `Error (_,e) -> parse_error "JSON.of_buffer %s" (string_of_error e) + | `JSON j -> j + | `Error (_, e) -> parse_error "JSON.of_buffer %s" (string_of_error e) let of_channel ic = match json_of_src (`Channel ic) with - | `JSON j -> j - | `Error (_,e) -> parse_error "JSON.of_buffer %s" (string_of_error e) + | `JSON j -> j + | `Error (_, e) -> parse_error "JSON.of_buffer %s" (string_of_error e) -let input str: t = +let input str : t = match json_of_src (`String str) with - | `JSON j -> j - | `Error (_,e) -> - Jsonm.pp_error Format.str_formatter e; - parse_error "JSON.input %s" (string_of_error e) + | `JSON j -> j + | `Error (_, e) -> + Jsonm.pp_error Format.str_formatter e; + parse_error "JSON.input %s" (string_of_error e) (* string *) let of_string s = `String s let to_string = function | `String s -> s - | j -> parse_error "JSON.to_string: %s" (output j) - -type code = { - code : int; - constr: string; - descr : string; - doc : string; -} + | j -> parse_error "JSON.to_string: %s" (output j) -type section = { - section: string; - codes : code list; -} +type code = { code : int; constr : string; descr : string; doc : string } +type section = { section : string; codes : code list } let normalize s = let b = Bytes.of_string s in - Bytes.iteri (fun i -> function - | 'A'..'Z' as c -> if i > 1 then Bytes.set b i (Char.lowercase_ascii c) - | ' '|'-'|'\'' -> Bytes.set b i '_' - | _ -> () - ) (Bytes.of_string s); + Bytes.iteri + (fun i -> function + | 'A' .. 'Z' as c -> if i > 1 then Bytes.set b i (Char.lowercase_ascii c) + | ' ' | '-' | '\'' -> Bytes.set b i '_' + | _ -> ()) + (Bytes.of_string s); Bytes.to_string b let read ic = let json = of_channel ic in match json with | `O o -> - let section = - match List.assoc "class" o with - | `O o -> - let s = String.uncapitalize_ascii (to_string (List.assoc "title" o)) in - normalize s - | _ -> assert false in - - let codes = - match List.assoc "codes" o with - | `O o -> - List.fold_left (fun codes (code, o) -> - let code = int_of_string code in - if code = 122 then - (* Same as 414 but for IE7 ??? *) - codes - else ( - let o = match o with - | `O o -> o - | _ -> assert false in - let descr = to_string (List.assoc "title" o) in - let constr = "`" ^ ( - try - let i = String.index descr '(' in - String.sub descr 0 (i-1) - with Not_found -> - descr - ) in - let constr = normalize constr in - (* XXX: dirty hack *) - let constr = if constr = "`Ok" then "`OK" else constr in - let doc = to_string (List.assoc "summary" o) in - { constr; descr; code; doc } :: codes - ) - ) [] o - | _ -> assert false - in - { section; codes = List.rev codes } + let section = + match List.assoc "class" o with + | `O o -> + let s = + String.uncapitalize_ascii (to_string (List.assoc "title" o)) + in + normalize s + | _ -> assert false + in + + let codes = + match List.assoc "codes" o with + | `O o -> + List.fold_left + (fun codes (code, o) -> + let code = int_of_string code in + if code = 122 then (* Same as 414 but for IE7 ??? *) + codes + else + let o = match o with `O o -> o | _ -> assert false in + let descr = to_string (List.assoc "title" o) in + let constr = + "`" + ^ + try + let i = String.index descr '(' in + String.sub descr 0 (i - 1) + with Not_found -> descr + in + let constr = normalize constr in + (* XXX: dirty hack *) + let constr = if constr = "`Ok" then "`OK" else constr in + let doc = to_string (List.assoc "summary" o) in + { constr; descr; code; doc } :: codes) + [] o + | _ -> assert false + in + { section; codes = List.rev codes } | _ -> assert false -let append oc fmt = - Printf.fprintf oc (fmt^^"\n") +let append oc fmt = Printf.fprintf oc (fmt ^^ "\n") let output_type oc ~mli t = append oc "type %s_status =" t.section; - List.iteri (fun i c -> - let doc = - if mli then Printf.sprintf " (** %s *)" c.doc - else "" in - if i = 0 then - append oc " [ %s%s" c.constr doc - else - append oc " | %s%s" c.constr doc - ) t.codes; + List.iteri + (fun i c -> + let doc = if mli then Printf.sprintf " (** %s *)" c.doc else "" in + if i = 0 then append oc " [ %s%s" c.constr doc + else append oc " | %s%s" c.constr doc) + t.codes; append oc " ] [@@deriving compare, sexp]"; - if mli then - append oc "(** %s *)" (String.capitalize_ascii t.section); + if mli then append oc "(** %s *)" (String.capitalize_ascii t.section); append oc "" let output_status_types oc ~mli t = @@ -205,91 +207,76 @@ let output_status_types oc ~mli t = append oc "] [@@deriving compare, sexp]"; append oc ""; if not mli then append oc "let compare_int = Int.compare\n" else (); - append oc "type status_code = [`Code of int | status ] [@@deriving compare, sexp]"; + append oc + "type status_code = [`Code of int | status ] [@@deriving compare, sexp]"; append oc "" -let iter fn s = - List.iter (fun s -> - List.iter fn s.codes - ) s +let iter fn s = List.iter (fun s -> List.iter fn s.codes) s let output_status_of_code oc ~mli s = if mli then ( append oc "val status_of_code: int -> status_code"; - append oc "(** Generate status values from int codes. *)" - ) else ( + append oc "(** Generate status values from int codes. *)") + else ( append oc "let status_of_code: int -> status_code = function"; - iter (fun c -> - append oc " | %d -> %s" c.code c.constr - ) s; - append oc " | cod -> `Code cod"; - ); + iter (fun c -> append oc " | %d -> %s" c.code c.constr) s; + append oc " | cod -> `Code cod"); append oc "" let output_code_of_status oc ~mli s = if mli then ( append oc "val code_of_status: status_code -> int"; - append oc "(** Generate an int code from a status value. *)"; - ) else ( + append oc "(** Generate an int code from a status value. *)") + else ( append oc "let code_of_status: status_code -> int = function"; - iter (fun c -> - append oc " | %s -> %d" c.constr c.code - ) s; - append oc " | `Code cod -> cod"; - ); + iter (fun c -> append oc " | %s -> %d" c.constr c.code) s; + append oc " | `Code cod -> cod"); append oc "" let output_string_of_status oc ~mli s = if mli then ( append oc "val string_of_status: status_code -> string"; - append oc "(** Give a description of the given status value. *)"; - ) else ( + append oc "(** Give a description of the given status value. *)") + else ( append oc "let string_of_status: status_code -> string = function"; - iter (fun c -> - append oc " | %s -> \"%d %s\"" c.constr c.code c.descr - ) s; - append oc " | `Code cod -> string_of_int cod"; - ); + iter (fun c -> append oc " | %s -> \"%d %s\"" c.constr c.code c.descr) s; + append oc " | `Code cod -> string_of_int cod"); append oc "" let output_reason_phrase_of_code oc ~mli s = if mli then ( append oc "val reason_phrase_of_code: int -> string"; - append oc "(** Give a description of the given int code. *)"; - ) else ( + append oc "(** Give a description of the given int code. *)") + else ( append oc "let reason_phrase_of_code: int -> string = function"; - iter (fun c -> - append oc " | %d -> %S" c.code c.descr - ) s; - append oc " | cod -> string_of_int cod"; - ); + iter (fun c -> append oc " | %d -> %S" c.code c.descr) s; + append oc " | cod -> string_of_int cod"); append oc "" let output_is_code oc ~mli t = - List.iter (fun t -> + List.iter + (fun t -> if mli then ( append oc "val is_%s: int -> bool" t.section; - append oc "(** Is the given int code belong to the class of %S return code ? *)" t.section; - ) else ( + append oc + "(** Is the given int code belong to the class of %S return code ? *)" + t.section) + else ( append oc "let is_%s code =" t.section; append oc " match status_of_code code with"; append oc " | #%s_status -> true" t.section; - append oc " | _ -> false"; - ); - append oc "" - ) t; + append oc " | _ -> false"); + append oc "") + t; append oc ""; if mli then ( append oc "val is_error: int -> bool"; - append oc "(** Return true for client and server error status codes. *)"; - ) else + append oc "(** Return true for client and server error status codes. *)") + else append oc "let is_error code = is_client_error code || is_server_error code"; append oc "" -type gen = { - constr: string; - string: string; -} +type gen = { constr : string; string : string } let g constr string = { constr; string } @@ -310,49 +297,45 @@ let output_gen_convert oc ~mli (name, typ, gens) = append oc ""; append oc "val compare_%s: %s -> %s -> int" name typ typ; append oc "(** Comparison function for [%s] values *)" name; - append oc ""; - ) else ( + append oc "") + else ( append oc "let string_of_%s: %s -> string = function" name typ; - List.iter (fun g -> - append oc " | %s -> %S" g.constr g.string - ) gens; + List.iter (fun g -> append oc " | %s -> %S" g.constr g.string) gens; append oc " | `Other s -> s"; append oc ""; append oc "let %s_of_string: string -> %s = function" name typ; - List.iter (fun g -> - append oc " | %S -> %s" g.string g.constr - ) gens; + List.iter (fun g -> append oc " | %S -> %s" g.string g.constr) gens; append oc " | s -> `Other s"; append oc ""; append oc "let compare_%s a b =" name; append oc " String.compare (string_of_%s a) (string_of_%s b)" name name; - append oc "" - ); + append oc ""); append oc "" let t = - List.map (fun f -> read (open_in f)) [ - "codes/1.json"; - "codes/2.json"; - "codes/3.json"; - "codes/4.json"; - "codes/5.json"; - ] - -let version = ("version" , "version", [ - g "`HTTP_1_0" "HTTP/1.0"; - g "`HTTP_1_1" "HTTP/1.1"; - ]) - -let known_methods = [ - g "`GET" "GET"; - g "`POST" "POST"; - g "`HEAD" "HEAD"; - g "`DELETE" "DELETE"; - g "`PATCH" "PATCH"; - g "`PUT" "PUT"; + List.map + (fun f -> read (open_in f)) + [ + "codes/1.json"; + "codes/2.json"; + "codes/3.json"; + "codes/4.json"; + "codes/5.json"; + ] + +let version = + ("version", "version", [ g "`HTTP_1_0" "HTTP/1.0"; g "`HTTP_1_1" "HTTP/1.1" ]) + +let known_methods = + [ + g "`GET" "GET"; + g "`POST" "POST"; + g "`HEAD" "HEAD"; + g "`DELETE" "DELETE"; + g "`PATCH" "PATCH"; + g "`PUT" "PUT"; g "`OPTIONS" "OPTIONS"; - g "`TRACE" "TRACE"; + g "`TRACE" "TRACE"; g "`CONNECT" "CONNECT"; ] diff --git a/cohttp/src/accept.ml b/cohttp/src/accept.ml index 67d8a16119..f65bbe8f12 100644 --- a/cohttp/src/accept.ml +++ b/cohttp/src/accept.ml @@ -22,49 +22,50 @@ module Parser = Accept_parser module Lexer = Accept_lexer let qsort l = - let compare ((i:int),_) (i',_) = + let compare ((i : int), _) (i', _) = (* The inversion is on purpose, we sort the biggest quality first. *) compare i' i in List.stable_sort compare l let parse_using p s = p Lexer.header_value (Lexing.from_string s) + let media_ranges = function | Some s -> parse_using Parser.media_ranges s - | None -> [1000,(AnyMedia, [])] + | None -> [ (1000, (AnyMedia, [])) ] + let charsets = function | Some s -> parse_using Parser.charsets s - | None -> [1000,AnyCharset] + | None -> [ (1000, AnyCharset) ] + let encodings = function | Some s -> parse_using Parser.encodings s - | None -> [1000,AnyEncoding] + | None -> [ (1000, AnyEncoding) ] + let languages = function | Some s -> parse_using Parser.languages s - | None -> [1000,AnyLanguage] + | None -> [ (1000, AnyLanguage) ] let rec string_of_pl = function | [] -> "" - | (k, v)::r -> - let e = Stringext.quote v in - if v = e - then sprintf ";%s=%s%s" k v (string_of_pl r) - else sprintf ";%s=\"%s\"%s" k e (string_of_pl r) + | (k, v) :: r -> + let e = Stringext.quote v in + if v = e then sprintf ";%s=%s%s" k v (string_of_pl r) + else sprintf ";%s=\"%s\"%s" k e (string_of_pl r) let string_of_q = function - | q when q < 0 -> - invalid_arg (Printf.sprintf "qvalue %d must be positive" q) + | q when q < 0 -> invalid_arg (Printf.sprintf "qvalue %d must be positive" q) | q when q > 1000 -> - invalid_arg (Printf.sprintf "qvalue %d must be less than 1000" q) + invalid_arg (Printf.sprintf "qvalue %d must be less than 1000" q) | 1000 -> "1" | q -> Printf.sprintf "0.%03d" q -let accept_el el pl q = - sprintf "%s;q=%s%s" el (string_of_q q) (string_of_pl pl) +let accept_el el pl q = sprintf "%s;q=%s%s" el (string_of_q q) (string_of_pl pl) let string_of_media_range = function - | (MediaType (t,st),pl) -> accept_el (sprintf "%s/%s" t st) pl - | (AnyMediaSubtype (t),pl) -> accept_el (sprintf "%s/*" t) pl - | (AnyMedia,pl) -> accept_el "*/*" pl + | MediaType (t, st), pl -> accept_el (sprintf "%s/%s" t st) pl + | AnyMediaSubtype t, pl -> accept_el (sprintf "%s/*" t) pl + | AnyMedia, pl -> accept_el "*/*" pl let string_of_charset = function | Charset c -> accept_el c [] @@ -84,10 +85,11 @@ let string_of_language = function let string_of_list s_of_el = let rec aux s = function - | (q,el)::[] -> s^(s_of_el el q) + | [ (q, el) ] -> s ^ s_of_el el q | [] -> s - | (q,el)::r -> aux (s^(s_of_el el q)^",") r - in aux "" + | (q, el) :: r -> aux (s ^ s_of_el el q ^ ",") r + in + aux "" let string_of_media_ranges = string_of_list string_of_media_range let string_of_charsets = string_of_list string_of_charset diff --git a/cohttp/src/accept.mli b/cohttp/src/accept.mli index f6da9c28cc..6cddf1a8ee 100644 --- a/cohttp/src/accept.mli +++ b/cohttp/src/accept.mli @@ -17,63 +17,51 @@ (** Accept-Encoding HTTP header parsing and generation *) -(** Qualities are integers between 0 and 1000. - A header with ["q=0.7"] corresponds to a quality of [700]. -*) type q = int [@@deriving sexp] +(** Qualities are integers between 0 and 1000. A header with ["q=0.7"] + corresponds to a quality of [700]. *) -(** Lists, annotated with qualities. *) type 'a qlist = (q * 'a) list [@@deriving sexp] +(** Lists, annotated with qualities. *) -(** Sort by quality, biggest first. - Respect the initial ordering. -*) val qsort : 'a qlist -> 'a qlist +(** Sort by quality, biggest first. Respect the initial ordering. *) type p = string * string [@@deriving sexp] -type media_range = - Accept_types.media_range = - MediaType of string * string +type media_range = Accept_types.media_range = + | MediaType of string * string | AnyMediaSubtype of string - | AnyMedia [@@deriving sexp] + | AnyMedia +[@@deriving sexp] -type charset = Accept_types.charset = - Charset of string - | AnyCharset [@@deriving sexp] +type charset = Accept_types.charset = Charset of string | AnyCharset +[@@deriving sexp] -type encoding = - Accept_types.encoding = - Encoding of string +type encoding = Accept_types.encoding = + | Encoding of string | Gzip | Compress | Deflate | Identity - | AnyEncoding [@@deriving sexp] + | AnyEncoding +[@@deriving sexp] -(** Basic language range tag. - ["en-gb"] is represented as [Language ["en"; "gb"]]. - @see the specification. -*) -type language = Accept_types.language = - Language of string list - | AnyLanguage [@@deriving sexp] +(** Basic language range tag. ["en-gb"] is represented as + [Language \["en"; "gb"\]]. + @see the specification. *) +type language = Accept_types.language = Language of string list | AnyLanguage +[@@deriving sexp] -val media_ranges : - string option -> (media_range * p list) qlist - +val media_ranges : string option -> (media_range * p list) qlist val charsets : string option -> charset qlist - val encodings : string option -> encoding qlist - val languages : string option -> language qlist - val string_of_media_range : media_range * p list -> q -> string val string_of_charset : charset -> q -> string val string_of_encoding : encoding -> q -> string val string_of_language : language -> q -> string - val string_of_media_ranges : (media_range * p list) qlist -> string val string_of_charsets : charset qlist -> string val string_of_encodings : encoding qlist -> string diff --git a/cohttp/src/accept_types.ml b/cohttp/src/accept_types.ml index 1c9cd57373..5692815550 100644 --- a/cohttp/src/accept_types.ml +++ b/cohttp/src/accept_types.ml @@ -20,22 +20,24 @@ open Sexplib0.Sexp_conv type p = string * string [@@deriving sexp] + type media_range = | MediaType of string * string | AnyMediaSubtype of string - | AnyMedia [@@deriving sexp] -type charset = - | Charset of string - | AnyCharset [@@deriving sexp] + | AnyMedia +[@@deriving sexp] + +type charset = Charset of string | AnyCharset [@@deriving sexp] + type encoding = | Encoding of string | Gzip | Compress | Deflate | Identity - | AnyEncoding [@@deriving sexp] -type language = - | Language of string list - | AnyLanguage [@@deriving sexp] + | AnyEncoding +[@@deriving sexp] + +type language = Language of string list | AnyLanguage [@@deriving sexp] type q = int [@@deriving sexp] type 'a qlist = (q * 'a) list [@@deriving sexp] diff --git a/cohttp/src/auth.ml b/cohttp/src/auth.ml index a153561627..545f3fe715 100644 --- a/cohttp/src/auth.ml +++ b/cohttp/src/auth.ml @@ -17,29 +17,25 @@ open Sexplib0.Sexp_conv open Printf -type challenge = [ - | `Basic of string (* realm *) -] [@@deriving sexp] +type challenge = [ `Basic of string (* realm *) ] [@@deriving sexp] -type credential = [ - | `Basic of string * string (* username, password *) - | `Other of string -] [@@deriving sexp] +type credential = + [ `Basic of string * string (* username, password *) | `Other of string ] +[@@deriving sexp] -let string_of_credential (cred:credential) = +let string_of_credential (cred : credential) = match cred with | `Basic (user, pass) -> - "Basic " ^ (Base64.encode_string (sprintf "%s:%s" user pass)) + "Basic " ^ Base64.encode_string (sprintf "%s:%s" user pass) | `Other buf -> buf -let credential_of_string (buf:string) : credential = +let credential_of_string (buf : string) : credential = try let b64 = Scanf.sscanf buf "Basic %s" (fun b -> b) in match Stringext.split ~on:':' (Base64.decode_exn b64) ~max:2 with - |[user;pass] -> `Basic (user,pass) - |_ -> `Other buf + | [ user; pass ] -> `Basic (user, pass) + | _ -> `Other buf with _ -> `Other buf -let string_of_challenge (ty:challenge) = - match ty with - |`Basic realm -> sprintf "Basic realm=\"%s\"" realm +let string_of_challenge (ty : challenge) = + match ty with `Basic realm -> sprintf "Basic realm=\"%s\"" realm diff --git a/cohttp/src/auth.mli b/cohttp/src/auth.mli index a7cafa79a1..19f1c3a1d9 100644 --- a/cohttp/src/auth.mli +++ b/cohttp/src/auth.mli @@ -16,35 +16,33 @@ (** HTTP Authentication and Authorization header parsing and generation *) +type challenge = [ `Basic of string (** Basic authentication within a realm *) ] +[@@deriving sexp] (** HTTP authentication challenge types *) -type challenge = [ - | `Basic of string (** Basic authentication within a realm *) -] [@@deriving sexp] -(** HTTP authorization credential types *) -type credential = [ - | `Basic of string * string - (** Basic authorization with a username and password *) +type credential = + [ `Basic of string * string + (** Basic authorization with a username and password *) | `Other of string - (** An unknown credential type that will be passed straight through - to the application layer *) -] [@@deriving sexp] + (** An unknown credential type that will be passed straight through to the + application layer *) ] +[@@deriving sexp] +(** HTTP authorization credential types *) +val string_of_credential : credential -> string (** [string_of_credential] converts the {!credential} to a string compatible with the HTTP/1.1 wire format for authorization credentials ("responses") *) -val string_of_credential : credential -> string -(** [credential_of_string cred_s] converts an HTTP response to an - authentication challenge into a {!credential}. If the credential is not - recognized, [`Other cred_s] is returned. *) val credential_of_string : string -> credential +(** [credential_of_string cred_s] converts an HTTP response to an authentication + challenge into a {!credential}. If the credential is not recognized, + [`Other cred_s] is returned. *) +val string_of_challenge : challenge -> string (** [string_of_challenge challenge] converts the {!challenge} to a string compatible with the HTTP/1.1 wire format for authentication challenges. - For example, a [`Basic] challenge with realm ["foo"] will be - marshalled to ["Basic realm=foo"], which can then be combined - with a [www-authenticate] HTTP header and sent back to the - client. There is a helper function {!Header.add_authorization_req} - that does just this. *) -val string_of_challenge : challenge -> string + For example, a [`Basic] challenge with realm ["foo"] will be marshalled to + ["Basic realm=foo"], which can then be combined with a [www-authenticate] + HTTP header and sent back to the client. There is a helper function + {!Header.add_authorization_req} that does just this. *) diff --git a/cohttp/src/body.ml b/cohttp/src/body.ml index 62bf4550db..23c32c4f9f 100644 --- a/cohttp/src/body.ml +++ b/cohttp/src/body.ml @@ -16,22 +16,16 @@ open Sexplib0.Sexp_conv -type t = [ - | `Empty - | `String of string - | `Strings of string list -] [@@deriving sexp] +type t = [ `Empty | `String of string | `Strings of string list ] +[@@deriving sexp] let empty = `Empty let is_empty = function - | `Empty - | `String "" -> true + | `Empty | `String "" -> true | `String _ -> false - | `Strings xs -> - match List.filter (fun s -> s <> "") xs with - | [] -> true - | _ -> false + | `Strings xs -> ( + match List.filter (fun s -> s <> "") xs with [] -> true | _ -> false) let to_string = function | `Empty -> "" @@ -40,7 +34,7 @@ let to_string = function let to_string_list = function | `Empty -> [] - | `String s -> [s] + | `String s -> [ s ] | `Strings sl -> sl let of_string s = `String s @@ -55,9 +49,10 @@ let length = function | `Empty -> 0L | `String s -> Int64.of_int (String.length s) | `Strings sl -> - sl - |> List.fold_left (fun a b -> - b |> String.length |> Int64.of_int |> Int64.add a) 0L + sl + |> List.fold_left + (fun a b -> b |> String.length |> Int64.of_int |> Int64.add a) + 0L let map f = function | `Empty -> `Empty @@ -66,4 +61,5 @@ let map f = function let to_form t = Uri.query_of_encoded (to_string t) let of_form ?scheme f = Uri.encoded_of_query ?scheme f |> of_string + (* TODO: maybe add a functor here that uses IO.S *) diff --git a/cohttp/src/body.mli b/cohttp/src/body.mli index 5b198d39b7..5a721afeb0 100644 --- a/cohttp/src/body.mli +++ b/cohttp/src/body.mli @@ -17,16 +17,13 @@ (** HTTP request and response body handling *) +type t = [ `Empty | `String of string | `Strings of string list ] +[@@deriving sexp] (** Every HTTP body can at least be an empty value or a [string] *) -type t = [ - | `Empty - | `String of string - | `Strings of string list -] [@@deriving sexp] -(** Signature for the core of HTTP body handling. Implementations - will extend this signature to add more functions for streaming - responses via backend-specific functionality. *) include S.Body with type t := t +(** Signature for the core of HTTP body handling. Implementations will extend + this signature to add more functions for streaming responses via + backend-specific functionality. *) val length : t -> int64 diff --git a/cohttp/src/conf.mli b/cohttp/src/conf.mli index 2aca9c2a62..e8e75a5243 100644 --- a/cohttp/src/conf.mli +++ b/cohttp/src/conf.mli @@ -17,5 +17,5 @@ (** Compile-time configuration variables *) -val version: string +val version : string (** The version number of this library. *) diff --git a/cohttp/src/connection.ml b/cohttp/src/connection.ml index 381dd67d8c..7aebaa7e7a 100644 --- a/cohttp/src/connection.ml +++ b/cohttp/src/connection.ml @@ -19,11 +19,10 @@ open Sexplib0.Sexp_conv type t = int [@@deriving sexp] let to_string = string_of_int - let count = ref 0 let create () = incr count; !count -let compare (a:t) (b:t) = Stdlib.compare a b +let compare (a : t) (b : t) = Stdlib.compare a b diff --git a/cohttp/src/connection.mli b/cohttp/src/connection.mli index 19c900cfc5..9d703a90fb 100644 --- a/cohttp/src/connection.mli +++ b/cohttp/src/connection.mli @@ -27,5 +27,5 @@ val to_string : t -> string (** Pretty-print a connection identifer. *) val compare : t -> t -> int -(** Comparison function for two identifiers. More recently constructed +(** Comparison function for two identifiers. More recently constructed identifiers will be greater than older ones. *) diff --git a/cohttp/src/cookie.ml b/cohttp/src/cookie.ml index e42fc71937..17ca9a43e3 100644 --- a/cohttp/src/cookie.ml +++ b/cohttp/src/cookie.ml @@ -17,144 +17,158 @@ open Sexplib0.Sexp_conv -type expiration = [ - | `Session - | `Max_age of int64 -] [@@deriving sexp] - +type expiration = [ `Session | `Max_age of int64 ] [@@deriving sexp] type cookie = string * string [@@deriving sexp] module Set_cookie_hdr = struct type t = { - cookie: cookie; + cookie : cookie; expiration : expiration; domain : string option; path : string option; secure : bool; - http_only: bool } [@@deriving fields, sexp] + http_only : bool; + } + [@@deriving fields, sexp] (* Does not check the contents of name or value for ';', ',', '\s', or name[0]='$' *) - let make ?(expiration=`Session) ?path ?domain ?(secure=false) ?(http_only=false) cookie = - { cookie ; expiration ; domain ; path ; secure ; http_only } + let make ?(expiration = `Session) ?path ?domain ?(secure = false) + ?(http_only = false) cookie = + { cookie; expiration; domain; path; secure; http_only } (* TODO: deprecated by RFC 6265 and almost certainly buggy without reference to cookie field *) let serialize_1_1 c = - let attrs = ["Version=1"] in - let attrs = if c.secure then ("Secure" :: attrs) else attrs in - let attrs = match c.path with None -> attrs - | Some p -> ("Path=" ^ p) :: attrs in - let attrs = match c.expiration with + let attrs = [ "Version=1" ] in + let attrs = if c.secure then "Secure" :: attrs else attrs in + let attrs = + match c.path with None -> attrs | Some p -> ("Path=" ^ p) :: attrs + in + let attrs = + match c.expiration with | `Session -> "Discard" :: attrs - | `Max_age age -> ("Max-Age=" ^ (Int64.to_string age)) :: attrs - in - let attrs = match c.domain with None -> attrs - | Some d -> ("Domain=" ^ d) :: attrs in - ("Set-Cookie2", String.concat "; " attrs) + | `Max_age age -> ("Max-Age=" ^ Int64.to_string age) :: attrs + in + let attrs = + match c.domain with None -> attrs | Some d -> ("Domain=" ^ d) :: attrs + in + ("Set-Cookie2", String.concat "; " attrs) let serialize_1_0 c = - let attrs = if c.http_only then ["httponly"] else [] in - let attrs = if c.secure then "secure"::attrs else attrs in - let attrs = match c.path with None -> attrs - | Some p -> ("path=" ^ p) :: attrs in - let attrs = match c.domain with None -> attrs - | Some d -> ("domain=" ^ d) :: attrs in - let attrs = match c.expiration with + let attrs = if c.http_only then [ "httponly" ] else [] in + let attrs = if c.secure then "secure" :: attrs else attrs in + let attrs = + match c.path with None -> attrs | Some p -> ("path=" ^ p) :: attrs + in + let attrs = + match c.domain with None -> attrs | Some d -> ("domain=" ^ d) :: attrs + in + let attrs = + match c.expiration with | `Session -> attrs - | `Max_age age -> ("Max-Age=" ^ (Int64.to_string age)) :: attrs + | `Max_age age -> ("Max-Age=" ^ Int64.to_string age) :: attrs in let n, c = c.cookie in (* TODO: may be buggy, some UAs will ignore cookie-strings without '='*) - let attrs = (n ^ (match c with "" -> "" - | v -> "=" ^ v)) :: attrs in - ("Set-Cookie", String.concat "; " attrs) + let attrs = (n ^ match c with "" -> "" | v -> "=" ^ v) :: attrs in + ("Set-Cookie", String.concat "; " attrs) - let serialize ?(version=`HTTP_1_0) c = + let serialize ?(version = `HTTP_1_0) c = match version with - | `HTTP_1_0 -> serialize_1_0 c - | `HTTP_1_1 -> serialize_1_1 c + | `HTTP_1_0 -> serialize_1_0 c + | `HTTP_1_1 -> serialize_1_1 c (* TODO: implement *) let extract_1_1 _cstr alist = alist let extract_1_0 cstr alist = let attrs = Stringext.split_trim_left cstr ~on:",;" ~trim:" \t" in - let attrs = List.map (fun attr -> - match Stringext.split ~on:'=' attr with - | [] -> ("","") - | n::v -> (n,String.concat "=" v) - ) attrs in + let attrs = + List.map + (fun attr -> + match Stringext.split ~on:'=' attr with + | [] -> ("", "") + | n :: v -> (n, String.concat "=" v)) + attrs + in try let cookie = List.hd attrs in - let attrs = List.map (fun (n,v) -> (String.lowercase_ascii n, v)) - (List.tl attrs) in + let attrs = + List.map (fun (n, v) -> (String.lowercase_ascii n, v)) (List.tl attrs) + in let path = try let v = List.assoc "path" attrs in - if v = "" || v.[0] <> '/' - then raise Not_found - else Some v + if v = "" || v.[0] <> '/' then raise Not_found else Some v with Not_found -> None in let domain = try let v = List.assoc "domain" attrs in if v = "" then raise Not_found - else Some - (String.lowercase_ascii - (if v.[0] = '.' then Stringext.string_after v 1 else v)) + else + Some + (String.lowercase_ascii + (if v.[0] = '.' then Stringext.string_after v 1 else v)) with Not_found -> None in (* TODO: trim wsp *) - (fst cookie, { - cookie; - (* TODO: respect expires attribute *) - expiration = `Session; - domain; - path; - http_only=List.mem_assoc "httponly" attrs; - secure = List.mem_assoc "secure" attrs; - })::alist + ( fst cookie, + { + cookie; + (* TODO: respect expires attribute *) + expiration = `Session; + domain; + path; + http_only = List.mem_assoc "httponly" attrs; + secure = List.mem_assoc "secure" attrs; + } ) + :: alist with Failure _ -> alist (* TODO: check dupes+order *) let extract hdr = - Header.fold (function - | "set-cookie" -> extract_1_0 - | "set-cookie2" -> extract_1_1 - | _ -> (fun _ a -> a) - ) hdr [] + Header.fold + (function + | "set-cookie" -> extract_1_0 + | "set-cookie2" -> extract_1_1 + | _ -> fun _ a -> a) + hdr [] - let value { cookie=(_,v); _ } = v + let value { cookie = _, v; _ } = v end module Cookie_hdr = struct (* RFC 2965 has - cookie = "Cookie:" cookie-version 1*((";" | ",") cookie-value) - cookie-value = NAME "=" VALUE [";" path] [";" domain] [";" port] - cookie-version = "$Version" "=" value - NAME = attr - VALUE = value - path = "$Path" "=" value - domain = "$Domain" "=" value - port = "$Port" [ "=" <"> value <"> ] + cookie = "Cookie:" cookie-version 1*((";" | ",") cookie-value) + cookie-value = NAME "=" VALUE [";" path] [";" domain] [";" port] + cookie-version = "$Version" "=" value + NAME = attr + VALUE = value + path = "$Path" "=" value + domain = "$Domain" "=" value + port = "$Port" [ "=" <"> value <"> ] *) let extract hdr = List.fold_left (fun acc header -> - let comps = Stringext.split_trim_left ~on:";" ~trim:" \t" header in - (* We don't handle $Path, $Domain, $Port, $Version (or $anything - $else) *) - let cookies = List.filter (fun s -> String.length s > 0 && s.[0] != '$') comps in - let split_pair nvp = - match Stringext.split ~on:'=' nvp ~max:2 with - | [] -> ("","") - | n :: [] -> (n, "") - | n :: v :: _ -> (n, v) - in (List.map split_pair cookies) @ acc - ) [] (Header.get_multi hdr "cookie") + let comps = Stringext.split_trim_left ~on:";" ~trim:" \t" header in + (* We don't handle $Path, $Domain, $Port, $Version (or $anything + $else) *) + let cookies = + List.filter (fun s -> String.length s > 0 && s.[0] != '$') comps + in + let split_pair nvp = + match Stringext.split ~on:'=' nvp ~max:2 with + | [] -> ("", "") + | [ n ] -> (n, "") + | n :: v :: _ -> (n, v) + in + List.map split_pair cookies @ acc) + [] + (Header.get_multi hdr "cookie") let serialize cookies = - "cookie", String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) cookies) + ("cookie", String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) cookies)) end diff --git a/cohttp/src/cookie.mli b/cohttp/src/cookie.mli index ba46d27091..59c43102d1 100644 --- a/cohttp/src/cookie.mli +++ b/cohttp/src/cookie.mli @@ -15,44 +15,49 @@ * }}}*) -(** Functions for the HTTP Cookie and Set-Cookie header fields. - Using the Set-Cookie header field, an HTTP server can pass name/value - pairs and associated metadata (called cookies) to a user agent. When - the user agent makes subsequent requests to the server, the user - agent uses the metadata and other information to determine whether to - return the name/value pairs in the Cookie header. *) - +(** Functions for the HTTP Cookie and Set-Cookie header fields. Using the + Set-Cookie header field, an HTTP server can pass name/value pairs and + associated metadata (called cookies) to a user agent. When the user agent + makes subsequent requests to the server, the user agent uses the metadata + and other information to determine whether to return the name/value pairs in + the Cookie header. *) + +type expiration = + [ `Session + (** Instructs the user agent to discard the cookie unconditionally when the + user agent terminates. *) + | `Max_age of int64 + (** The value of the Max-Age attribute is delta-seconds, the lifetime of the + cookie in seconds, a decimal non-negative integer. *) ] +[@@deriving sexp] (** Lifetime of the cookie after which the user agent discards it *) -type expiration = [ - | `Session (** Instructs the user agent to discard the cookie - unconditionally when the user agent terminates. *) - | `Max_age of int64 (** The value of the Max-Age attribute is delta-seconds, - the lifetime of the cookie in seconds, a decimal - non-negative integer. *) -] [@@deriving sexp] + type cookie = string * string (** A cookie is simply a key/value pair send from the client to the server *) module Set_cookie_hdr : sig - type t = { - cookie: cookie; + cookie : cookie; expiration : expiration; domain : string option; path : string option; secure : bool; - http_only : bool } [@@deriving fields, sexp] + http_only : bool; + } + [@@deriving fields, sexp] (** A header which a server sends to a client to request that the client - returns the cookie in future requests, under certain conditions. *) + returns the cookie in future requests, under certain conditions. *) val make : ?expiration:expiration -> ?path:string -> - ?domain:string -> ?secure:bool -> ?http_only:bool -> cookie -> t + ?domain:string -> + ?secure:bool -> + ?http_only:bool -> + cookie -> + t - val serialize : - ?version:[ `HTTP_1_0 | `HTTP_1_1 ] -> - t -> string * string + val serialize : ?version:[ `HTTP_1_0 | `HTTP_1_1 ] -> t -> string * string (** Return an HTTP header *) val extract : Header.t -> (string * t) list @@ -78,7 +83,6 @@ module Set_cookie_hdr : sig end module Cookie_hdr : sig - val extract : Header.t -> cookie list (** Return the list of cookies sent by the client *) diff --git a/cohttp/src/header.ml b/cohttp/src/header.ml index c49abfd794..26823b154d 100644 --- a/cohttp/src/header.ml +++ b/cohttp/src/header.ml @@ -18,29 +18,53 @@ module LString : sig type t - val of_string: string -> t - val to_string: t -> string - val compare: t -> t -> int + + val of_string : string -> t + val to_string : t -> string + val compare : t -> t -> int end = struct type t = string + let of_string x = String.lowercase_ascii x let to_string x = x let compare a b = String.compare a b end -module StringMap = Map.Make(LString) +module StringMap = Map.Make (LString) + type t = string list StringMap.t let user_agent = Printf.sprintf "ocaml-cohttp/%s" Conf.version - let compare = StringMap.compare Stdlib.compare -let headers_with_list_values = Array.map LString.of_string [| - "accept";"accept-charset";"accept-encoding";"accept-language"; - "accept-ranges";"allow";"cache-control";"connection";"content-encoding"; - "content-language";"expect";"if-match";"if-none-match";"link";"pragma"; - "proxy-authenticate";"te";"trailer";"transfer-encoding";"upgrade"; - "vary";"via";"warning";"www-authenticate"; |] +let headers_with_list_values = + Array.map LString.of_string + [| + "accept"; + "accept-charset"; + "accept-encoding"; + "accept-language"; + "accept-ranges"; + "allow"; + "cache-control"; + "connection"; + "content-encoding"; + "content-language"; + "expect"; + "if-match"; + "if-none-match"; + "link"; + "pragma"; + "proxy-authenticate"; + "te"; + "trailer"; + "transfer-encoding"; + "upgrade"; + "vary"; + "via"; + "warning"; + "www-authenticate"; + |] let is_transfer_encoding = let k = LString.of_string "transfer-encoding" in @@ -51,33 +75,21 @@ let is_header_with_list_value = headers_with_list_values |> Array.iter (fun h -> Hashtbl.add tbl h ()); fun h -> Hashtbl.mem tbl h -let init () = - StringMap.empty - +let init () = StringMap.empty let is_empty x = StringMap.is_empty x - -let init_with k v = - StringMap.singleton (LString.of_string k) [v] +let init_with k v = StringMap.singleton (LString.of_string k) [ v ] let add h k v = let k = LString.of_string k in - try + try if is_transfer_encoding k then - StringMap.add k ((StringMap.find k h) @ [v]) h - else - StringMap.add k (v::(StringMap.find k h)) h - with Not_found -> StringMap.add k [v] h + StringMap.add k (StringMap.find k h @ [ v ]) h + else StringMap.add k (v :: StringMap.find k h) h + with Not_found -> StringMap.add k [ v ] h -let add_list h l = - List.fold_left (fun h (k, v) -> add h k v) h l - -let add_multi h k l = - List.fold_left (fun h v -> add h k v) h l - -let add_opt h k v = - match h with - |None -> init_with k v - |Some h -> add h k v +let add_list h l = List.fold_left (fun h (k, v) -> add h k v) h l +let add_multi h k l = List.fold_left (fun h v -> add h k v) h l +let add_opt h k v = match h with None -> init_with k v | Some h -> add h k v let remove h k = let k = LString.of_string k in @@ -85,79 +97,76 @@ let remove h k = let replace h k v = let k = LString.of_string k in - StringMap.add k [v] h + StringMap.add k [ v ] h let get h k = let k = LString.of_string k in try let v = StringMap.find k h in - if is_header_with_list_value k - then Some (String.concat "," v) + if is_header_with_list_value k then Some (String.concat "," v) else Some (List.hd v) with Not_found | Failure _ -> None - let update h k f = - let vorig = get h k in - let k = LString.of_string k in - match f vorig, vorig with - | None, _ -> StringMap.remove k h - | Some s, Some s' when s == s' -> h - | Some s, _ -> +let update h k f = + let vorig = get h k in + let k = LString.of_string k in + match (f vorig, vorig) with + | None, _ -> StringMap.remove k h + | Some s, Some s' when s == s' -> h + | Some s, _ -> let v' = - if is_header_with_list_value k then - (String.split_on_char ',' s) - else [s] - in StringMap.add k v' h + if is_header_with_list_value k then String.split_on_char ',' s + else [ s ] + in + StringMap.add k v' h let mem h k = StringMap.mem (LString.of_string k) h - -let add_unless_exists h k v = - if mem h k - then h - else add h k v +let add_unless_exists h k v = if mem h k then h else add h k v let add_opt_unless_exists h k v = - match h with - | None -> init_with k v - | Some h -> add_unless_exists h k v + match h with None -> init_with k v | Some h -> add_unless_exists h k v let get_multi h k = let k = LString.of_string k in try StringMap.find k h with Not_found -> [] -let map fn h = StringMap.mapi (fun k v -> fn (LString.to_string k) v) h -let iter fn h = ignore(map fn h) -let fold fn h acc = StringMap.fold - (fun k v acc -> List.fold_left (fun acc v -> fn (LString.to_string k) v acc) acc v) - h acc -let of_list l = - List.fold_left (fun h (k,v) -> add h k v) (init ()) l +let map fn h = StringMap.mapi (fun k v -> fn (LString.to_string k) v) h +let iter fn h = ignore (map fn h) -let to_list h = List.rev (fold (fun k v acc -> (k,v)::acc) h []) +let fold fn h acc = + StringMap.fold + (fun k v acc -> + List.fold_left (fun acc v -> fn (LString.to_string k) v acc) acc v) + h acc + +let of_list l = List.fold_left (fun h (k, v) -> add h k v) (init ()) l +let to_list h = List.rev (fold (fun k v acc -> (k, v) :: acc) h []) let header_line k v = Printf.sprintf "%s: %s\r\n" k v -let to_lines h = List.rev (fold (fun k v acc -> (header_line k v)::acc) h []) +let to_lines h = List.rev (fold (fun k v acc -> header_line k v :: acc) h []) let to_frames = - let to_frame k v acc = (Printf.sprintf "%s: %s" k v) :: acc in + let to_frame k v acc = Printf.sprintf "%s: %s" k v :: acc in fun h -> List.rev (fold to_frame h []) let to_string h = let b = Buffer.create 128 in - h |> iter (fun k v -> - v |> List.iter (fun v -> - Buffer.add_string b k; - Buffer.add_string b ": "; - Buffer.add_string b v; - Buffer.add_string b "\r\n" - ); - ); + h + |> iter (fun k v -> + v + |> List.iter (fun v -> + Buffer.add_string b k; + Buffer.add_string b ": "; + Buffer.add_string b v; + Buffer.add_string b "\r\n")); Buffer.add_string b "\r\n"; Buffer.contents b let parse_content_range s = try let start, fini, total = - Scanf.sscanf s "bytes %Ld-%Ld/%Ld" (fun start fini total -> start, fini, total) in + Scanf.sscanf s "bytes %Ld-%Ld/%Ld" (fun start fini total -> + (start, fini, total)) + in Some (start, fini, total) with Scanf.Scan_failure _ -> None @@ -165,37 +174,32 @@ let parse_content_range s = number of bytes we attempt to read *) let get_content_range headers = match get headers "content-length" with - | Some clen -> (try Some (Int64.of_string clen) with _ -> None) - | None -> begin - match get headers "content-range" with - | Some range_s -> begin - match parse_content_range range_s with - | Some (start, fini, total) -> - (* some sanity checking before we act on these values *) - if fini < total && start <= total && 0L <= start && 0L <= total - then ( - let num_bytes_to_read = Int64.add (Int64.sub fini start) 1L in - Some num_bytes_to_read - ) else None - | None -> None - end - | None -> None - end + | Some clen -> ( try Some (Int64.of_string clen) with _ -> None) + | None -> ( + match get headers "content-range" with + | Some range_s -> ( + match parse_content_range range_s with + | Some (start, fini, total) -> + (* some sanity checking before we act on these values *) + if fini < total && start <= total && 0L <= start && 0L <= total + then + let num_bytes_to_read = Int64.add (Int64.sub fini start) 1L in + Some num_bytes_to_read + else None + | None -> None) + | None -> None) let get_connection_close headers = - match get headers "connection" with - | Some "close" -> true - | _ -> false - + match get headers "connection" with Some "close" -> true | _ -> false let media_type_re = let re = Re.Emacs.re ~case:true "[ \t]*\\([^ \t;]+\\)" in - Re.(compile (seq ([start; re]))) + Re.(compile (seq [ start; re ])) let get_first_match _re s = try let subs = Re.exec ~pos:0 media_type_re s in - let (start, stop) = Re.Group.offset subs 1 in + let start, stop = Re.Group.offset subs 1 in Some (String.sub s start (stop - start)) with Not_found -> None @@ -222,21 +226,21 @@ let get_acceptable_languages headers = let get_transfer_encoding headers = match get headers "transfer-encoding" with | Some "chunked" -> Transfer.Chunked - | Some _ | None -> begin - match get_content_range headers with - |Some len -> Transfer.Fixed len - |None -> Transfer.Unknown - end + | Some _ | None -> ( + match get_content_range headers with + | Some len -> Transfer.Fixed len + | None -> Transfer.Unknown) let add_transfer_encoding headers enc = let open Transfer in (* Only add a header if one doesnt already exist, e.g. from the app *) - match get_transfer_encoding headers, enc with - |Fixed _,_ (* App has supplied a content length, so use that *) - |Chunked, _ -> headers (* TODO: this is a protocol violation *) - |Unknown, Chunked -> add headers "transfer-encoding" "chunked" - |Unknown, Fixed len -> add headers "content-length" (Int64.to_string len) - |Unknown, Unknown -> headers + match (get_transfer_encoding headers, enc) with + | Fixed _, _ (* App has supplied a content length, so use that *) | Chunked, _ + -> + headers (* TODO: this is a protocol violation *) + | Unknown, Chunked -> add headers "transfer-encoding" "chunked" + | Unknown, Fixed len -> add headers "content-length" (Int64.to_string len) + | Unknown, Unknown -> headers let add_authorization_req headers challenge = add headers "www-authenticate" (Auth.string_of_challenge challenge) @@ -246,11 +250,11 @@ let add_authorization headers cred = let get_authorization headers = match get headers "authorization" with - |None -> None - |Some v -> Some (Auth.credential_of_string v) + | None -> None + | Some v -> Some (Auth.credential_of_string v) let is_form headers = - get_media_type headers = (Some "application/x-www-form-urlencoded") + get_media_type headers = Some "application/x-www-form-urlencoded" let get_location headers = match get headers "location" with @@ -258,9 +262,10 @@ let get_location headers = | Some u -> Some (Uri.of_string u) let get_links headers = - List.rev (List.fold_left - (fun list link_s -> List.rev_append (Link.of_string link_s) list) - [] (get_multi headers "link")) + List.rev + (List.fold_left + (fun list link_s -> List.rev_append (Link.of_string link_s) list) + [] (get_multi headers "link")) let add_links headers links = add_multi headers "link" (List.map Link.to_string links) @@ -268,8 +273,8 @@ let add_links headers links = let prepend_user_agent headers user_agent = let k = "user-agent" in match get headers k with - | Some ua -> replace headers k (user_agent^" "^ua) - | None -> add headers k user_agent + | Some ua -> replace headers k (user_agent ^ " " ^ ua) + | None -> add headers k user_agent let connection h = match get h "connection" with diff --git a/cohttp/src/header.mli b/cohttp/src/header.mli index 00f32a1f1d..6914b6964e 100644 --- a/cohttp/src/header.mli +++ b/cohttp/src/header.mli @@ -14,82 +14,81 @@ * }}}*) -(** Map of HTTP header key and value(s) associated with them. Since HTTP - headers can contain duplicate keys, this structure can return a list - of values associated with a single key. *) +(** Map of HTTP header key and value(s) associated with them. Since HTTP headers + can contain duplicate keys, this structure can return a list of values + associated with a single key. *) + type t [@@deriving sexp] +(** The type for HTTP headers. *) -(** Construct a fresh, empty map of HTTP headers. *) val init : unit -> t +(** Construct a fresh, empty map of HTTP headers. *) -(** Test whether HTTP headers are empty or not. *) val is_empty : t -> bool +(** Test whether HTTP headers are empty or not. *) +val init_with : string -> string -> t (** Construct a fresh map of HTTP headers with a single key and value entry. *) -val init_with : string -> string -> t -(** Add a key and value to an existing header map. *) val add : t -> string -> string -> t +(** Add a key and value to an existing header map. *) -(** Add multiple key and value pairs to an existing header map. *) val add_list : t -> (string * string) list -> t +(** Add multiple key and value pairs to an existing header map. *) -(** Add multiple values to a key in an existing header map. *) val add_multi : t -> string -> string list -> t +(** Add multiple values to a key in an existing header map. *) -(** Given an optional header, either update the existing one with - a key and value, or construct a fresh header with those values if - the header is [None]. *) val add_opt : t option -> string -> string -> t +(** Given an optional header, either update the existing one with a key and + value, or construct a fresh header with those values if the header is + [None]. *) -(** Given a header, update it with the key and value unless the key is - already present in the header. *) val add_unless_exists : t -> string -> string -> t +(** Given a header, update it with the key and value unless the key is already + present in the header. *) -(** [add_opt_unless_exists h k v] updates [h] with the key [k] and value [v] - unless the key is already present in the header. If [h] is [None] - then a fresh header is allocated containing the key [k] and the - value [v]. *) val add_opt_unless_exists : t option -> string -> string -> t +(** [add_opt_unless_exists h k v] updates [h] with the key [k] and value [v] + unless the key is already present in the header. If [h] is [None] then a + fresh header is allocated containing the key [k] and the value [v]. *) -(** Remove a key from the header map and return a fresh header set. The - original header parameter is not modified. *) val remove : t -> string -> t +(** Remove a key from the header map and return a fresh header set. The original + header parameter is not modified. *) +val replace : t -> string -> string -> t (** Replace the value of a key from the header map if it exists, otherwise it adds it to the header map. The original header parameter is not modified. *) -val replace : t -> string -> string -> t -(** [update h k f] returns a map containing the same headers as [h], - except for the header [k]. Depending on the value of [v] where [v] is - [f (get h k)], the header [k] is added, removed or updated. - If [v] is [None], the header is removed if it exists; otherwise, - if [v] is [Some z] then [k] is associated to [z] in the resulting headers. - If [k] was already associated in [h] to a value that is physically equal - to [z], [h] is returned unchanged. Similarly as for [get], if the header is - one of the set of headers defined to have list values, then all of the values - are concatenated into a single string separated by commas and passed to [f], - while the return value of [f] is split on commas and associated to [k]. - If it is a singleton header, then the first value is passed to [f] and - no concatenation is performed, similarly for the return value. - The original header parameters are not modified. *) -val update: t -> string -> (string option -> string option) -> t +val update : t -> string -> (string option -> string option) -> t +(** [update h k f] returns a map containing the same headers as [h], except for + the header [k]. Depending on the value of [v] where [v] is [f (get h k)], + the header [k] is added, removed or updated. If [v] is [None], the header is + removed if it exists; otherwise, if [v] is [Some z] then [k] is associated + to [z] in the resulting headers. If [k] was already associated in [h] to a + value that is physically equal to [z], [h] is returned unchanged. Similarly + as for [get], if the header is one of the set of headers defined to have + list values, then all of the values are concatenated into a single string + separated by commas and passed to [f], while the return value of [f] is + split on commas and associated to [k]. If it is a singleton header, then the + first value is passed to [f] and no concatenation is performed, similarly + for the return value. The original header parameters are not modified. *) -(** Check if a key exists in the header. *) val mem : t -> string -> bool +(** Check if a key exists in the header. *) -(** Structural comparison of two [Header] values. *) val compare : t -> t -> int +(** Structural comparison of two [Header] values. *) -(** Retrieve a key from a header. If the header is one of the set of - headers defined to have list values, then all of the values are - concatenated into a single string separated by commas and returned. - If it is a singleton header, then the first value is selected and - no concatenation is performed. *) val get : t -> string -> string option +(** Retrieve a key from a header. If the header is one of the set of headers + defined to have list values, then all of the values are concatenated into a + single string separated by commas and returned. If it is a singleton header, + then the first value is selected and no concatenation is performed. *) -(** Retrieve all of the values associated with a key *) val get_multi : t -> string -> string list +(** Retrieve all of the values associated with a key *) val iter : (string -> string list -> unit) -> t -> unit val map : (string -> string list -> string list) -> t -> t @@ -97,19 +96,21 @@ val fold : (string -> string -> 'a -> 'a) -> t -> 'a -> 'a val of_list : (string * string) list -> t val to_list : t -> (string * string) list -(** Return header fieds as a list of lines. Beware that each line - ends with "\r\n" characters. *) val to_lines : t -> string list +(** Return header fieds as a list of lines. Beware that each line ends with + "\r\n" characters. *) -(** Same as {!to_lines} but lines do not end with "\r\n" characters. *) val to_frames : t -> string list +(** Same as {!to_lines} but lines do not end with "\r\n" characters. *) val to_string : t -> string - val get_content_range : t -> Int64.t option val get_media_type : t -> string option val get_connection_close : t -> bool -val get_acceptable_media_ranges : t -> (Accept.media_range * Accept.p list) Accept.qlist + +val get_acceptable_media_ranges : + t -> (Accept.media_range * Accept.p list) Accept.qlist + val get_acceptable_charsets : t -> Accept.charset Accept.qlist val get_acceptable_encodings : t -> Accept.encoding Accept.qlist val get_acceptable_languages : t -> Accept.language Accept.qlist @@ -120,18 +121,17 @@ val get_authorization : t -> Auth.credential option val add_authorization_req : t -> Auth.challenge -> t val is_form : t -> bool val get_location : t -> Uri.t option - val add_links : t -> Link.t list -> t val get_links : t -> Link.t list val user_agent : string -(** The User-Agent header used by this library, including the version - of cohttp. *) +(** The User-Agent header used by this library, including the version of cohttp. *) + val prepend_user_agent : t -> string -> t (** Prepend [user_agent] to the product token already declared in the "User-Agent" field (if any). *) -val connection : t -> [`Keep_alive | `Close | `Unknown of string] option +val connection : t -> [ `Keep_alive | `Close | `Unknown of string ] option -(** Human-readable output, used by the toplevel printer *) val pp_hum : Format.formatter -> t -> unit +(** Human-readable output, used by the toplevel printer *) diff --git a/cohttp/src/header_io.ml b/cohttp/src/header_io.ml index 40193ac311..a4fc17619c 100644 --- a/cohttp/src/header_io.ml +++ b/cohttp/src/header_io.ml @@ -18,13 +18,12 @@ let split_header str = match Stringext.split ~max:2 ~on:':' str with - | x::y::[] -> [x; String.trim y] + | [ x; y ] -> [ x; String.trim y ] | x -> x -module Make(IO : S.IO) = struct +module Make (IO : S.IO) = struct open IO - - module Transfer_IO = Transfer_io.Make(IO) + module Transfer_IO = Transfer_io.Make (IO) let rev _k v = List.rev v @@ -32,16 +31,15 @@ module Make(IO : S.IO) = struct (* consume also trailing "^\r\n$" line *) let rec parse_headers' headers = read_line ic >>= function - |Some "" | None -> return (Header.map rev headers) - |Some line -> begin + | Some "" | None -> return (Header.map rev headers) + | Some line -> ( match split_header line with - | [hd;tl] -> + | [ hd; tl ] -> let header = String.lowercase_ascii hd in - parse_headers' (Header.add headers header tl); - | _ -> return headers - end - in parse_headers' (Header.init ()) + parse_headers' (Header.add headers header tl) + | _ -> return headers) + in + parse_headers' (Header.init ()) - let write headers oc = - IO.write oc (Header.to_string headers) + let write headers oc = IO.write oc (Header.to_string headers) end diff --git a/cohttp/src/header_io.mli b/cohttp/src/header_io.mli index e59cf050b3..0274fc9534 100644 --- a/cohttp/src/header_io.mli +++ b/cohttp/src/header_io.mli @@ -14,7 +14,7 @@ * }}}*) -module Make(IO : S.IO) : sig - val parse: IO.ic -> Header.t IO.t +module Make (IO : S.IO) : sig + val parse : IO.ic -> Header.t IO.t val write : Header.t -> IO.oc -> unit IO.t end diff --git a/cohttp/src/link.ml b/cohttp/src/link.ml index eee7dfd828..dbf284df65 100644 --- a/cohttp/src/link.ml +++ b/cohttp/src/link.ml @@ -104,30 +104,24 @@ module Rel = struct end module Language = struct - type t = string - [@@deriving sexp] + type t = string [@@deriving sexp] let to_string x = x let of_string x = x end module Charset = struct - type t = string - [@@deriving sexp] + type t = string [@@deriving sexp] let to_string x = x let of_string x = x end module Ext = struct - type 'a t = { - charset : Charset.t; - language : Language.t; - value : 'a; - } [@@deriving sexp, fields] - - let make ?(charset="") ?(language="") value = { charset; language; value } + type 'a t = { charset : Charset.t; language : Language.t; value : 'a } + [@@deriving sexp, fields] + let make ?(charset = "") ?(language = "") value = { charset; language; value } let map f x = { x with value = f x.value } end @@ -142,27 +136,24 @@ module Arc = struct media_type : (string * string) option; extensions : (string * string) list; extension_exts : (string * string Ext.t) list; - } [@@deriving sexp] - - let empty = { - reverse = false; - relation = []; - hreflang = None; - media = None; - title = None; - title_ext = None; - media_type = None; - extensions = []; - extension_exts = []; } + [@@deriving sexp] + let empty = + { + reverse = false; + relation = []; + hreflang = None; + media = None; + title = None; + title_ext = None; + media_type = None; + extensions = []; + extension_exts = []; + } end -type t = { - context : Uri_sexp.t; - arc : Arc.t; - target : Uri_sexp.t; -} +type t = { context : Uri_sexp.t; arc : Arc.t; target : Uri_sexp.t } [@@deriving sexp] (* TODO: this could be replaced with empty t/arc fupdate *) @@ -178,331 +169,365 @@ type param = | Link_extension of string * string let until s start cl = - let nextl = List.map (fun c -> - let pattern = String.make 1 c in - Stringext.find_from ~start s ~pattern - ) cl in - let min = List.fold_left (fun min_opt i_opt -> match min_opt, i_opt with - | None, None -> None - | Some i, None | None, Some i -> Some i - | Some i, Some j -> Some (min i j) - ) None nextl in + let nextl = + List.map + (fun c -> + let pattern = String.make 1 c in + Stringext.find_from ~start s ~pattern) + cl + in + let min = + List.fold_left + (fun min_opt i_opt -> + match (min_opt, i_opt) with + | None, None -> None + | Some i, None | None, Some i -> Some i + | Some i, Some j -> Some (min i j)) + None nextl + in match min with - | None -> Stringext.string_after s start, String.length s - | Some i -> String.sub s start (i - start), i - -let string_of_rel = Rel.(function - | Alternate -> "alternate" - | Appendix -> "appendix" - | Bookmark -> "bookmark" - | Chapter -> "chapter" - | Contents -> "contents" - | Copyright -> "copyright" - | Current -> "current" - | Described_by -> "describedby" - | Edit -> "edit" - | Edit_media -> "edit-media" - | Enclosure -> "enclosure" - | First -> "first" - | Glossary -> "glossary" - | Help -> "help" - | Hub -> "hub" - | Index -> "index" - | Last -> "last" - | Latest_version -> "latest-version" - | License -> "license" - | Next -> "next" - | Next_archive -> "next-archive" - | Payment -> "payment" - | Predecessor_version -> "predecessor-version" - | Prev -> "prev" - | Prev_archive -> "prev-archive" - | Related -> "related" - | Replies -> "replies" - | Section -> "section" - | Self -> "self" - | Service -> "service" - | Start -> "start" - | Stylesheet -> "stylesheet" - | Subsection -> "subsection" - | Successor_version -> "successor-version" - | Up -> "up" - | Version_history -> "version-history" - | Via -> "via" - | Working_copy -> "working-copy" - | Working_copy_of -> "working-copy-of" - | Extension uri -> Uri.to_string uri -) - -let rel_of_string s = Rel.( - try ignore (String.index s ':'); Extension (Uri.of_string s) - with Not_found -> match s with - | "alternate" -> Alternate - | "appendix" -> Appendix - | "bookmark" -> Bookmark - | "chapter" -> Chapter - | "contents" -> Contents - | "copyright" -> Copyright - | "current" -> Current - | "describedby" -> Described_by - | "edit" -> Edit - | "edit-media" -> Edit_media - | "enclosure" -> Enclosure - | "first" -> First - | "glossary" -> Glossary - | "help" -> Help - | "hub" -> Hub - | "index" -> Index - | "last" -> Last - | "latest-version" -> Latest_version - | "license" -> License - | "next" -> Next - | "next-archive" -> Next_archive - | "payment" -> Payment - | "predecessor-version" -> Predecessor_version - | "prev" | "previous" -> Prev - | "prev-archive" -> Prev_archive - | "related" -> Related - | "replies" -> Replies - | "section" -> Section - | "self" -> Self - | "service" -> Service - | "start" -> Start - | "stylesheet" -> Stylesheet - | "subsection" -> Subsection - | "successor-version" -> Successor_version - | "up" -> Up - | "version-history" -> Version_history - | "via" -> Via - | "working-copy" -> Working_copy - | "working-copy-of" -> Working_copy_of - | _ -> Extension (Uri.of_string s) -) + | None -> (Stringext.string_after s start, String.length s) + | Some i -> (String.sub s start (i - start), i) + +let string_of_rel = + Rel.( + function + | Alternate -> "alternate" + | Appendix -> "appendix" + | Bookmark -> "bookmark" + | Chapter -> "chapter" + | Contents -> "contents" + | Copyright -> "copyright" + | Current -> "current" + | Described_by -> "describedby" + | Edit -> "edit" + | Edit_media -> "edit-media" + | Enclosure -> "enclosure" + | First -> "first" + | Glossary -> "glossary" + | Help -> "help" + | Hub -> "hub" + | Index -> "index" + | Last -> "last" + | Latest_version -> "latest-version" + | License -> "license" + | Next -> "next" + | Next_archive -> "next-archive" + | Payment -> "payment" + | Predecessor_version -> "predecessor-version" + | Prev -> "prev" + | Prev_archive -> "prev-archive" + | Related -> "related" + | Replies -> "replies" + | Section -> "section" + | Self -> "self" + | Service -> "service" + | Start -> "start" + | Stylesheet -> "stylesheet" + | Subsection -> "subsection" + | Successor_version -> "successor-version" + | Up -> "up" + | Version_history -> "version-history" + | Via -> "via" + | Working_copy -> "working-copy" + | Working_copy_of -> "working-copy-of" + | Extension uri -> Uri.to_string uri) + +let rel_of_string s = + Rel.( + try + ignore (String.index s ':'); + Extension (Uri.of_string s) + with Not_found -> ( + match s with + | "alternate" -> Alternate + | "appendix" -> Appendix + | "bookmark" -> Bookmark + | "chapter" -> Chapter + | "contents" -> Contents + | "copyright" -> Copyright + | "current" -> Current + | "describedby" -> Described_by + | "edit" -> Edit + | "edit-media" -> Edit_media + | "enclosure" -> Enclosure + | "first" -> First + | "glossary" -> Glossary + | "help" -> Help + | "hub" -> Hub + | "index" -> Index + | "last" -> Last + | "latest-version" -> Latest_version + | "license" -> License + | "next" -> Next + | "next-archive" -> Next_archive + | "payment" -> Payment + | "predecessor-version" -> Predecessor_version + | "prev" | "previous" -> Prev + | "prev-archive" -> Prev_archive + | "related" -> Related + | "replies" -> Replies + | "section" -> Section + | "self" -> Self + | "service" -> Service + | "start" -> Start + | "stylesheet" -> Stylesheet + | "subsection" -> Subsection + | "successor-version" -> Successor_version + | "up" -> Up + | "version-history" -> Version_history + | "via" -> Via + | "working-copy" -> Working_copy + | "working-copy-of" -> Working_copy_of + | _ -> Extension (Uri.of_string s))) let quoted_string_of_string s q = let rec first_quote q = - match String.get s q with + match s.[q] with | ' ' -> first_quote (q + 1) - | '"' -> - let q = q + 1 in - begin match Stringext.find_from ~start:q s ~pattern:"\"" with - | None -> Stringext.string_after s q, String.length s - | Some q' -> String.sub s q (q' - q), q' + 1 - end - | _ -> until s q [';';','] + | '"' -> ( + let q = q + 1 in + match Stringext.find_from ~start:q s ~pattern:"\"" with + | None -> (Stringext.string_after s q, String.length s) + | Some q' -> (String.sub s q (q' - q), q' + 1)) + | _ -> until s q [ ';'; ',' ] in first_quote q let rels_of_string_ s q = let qs, i = quoted_string_of_string s q in let rels = Stringext.split qs ~on:' ' in - List.map rel_of_string (List.filter (fun s -> String.length s > 0) rels), i + (List.map rel_of_string (List.filter (fun s -> String.length s > 0) rels), i) let rels_of_string s i = - match Stringext.find_from ~start:i s ~pattern:"\"", - until s i [';';','] + match + (Stringext.find_from ~start:i s ~pattern:"\"", until s i [ ';'; ',' ]) with - | Some q, (_,d) when q < d -> rels_of_string_ s q - | _, (s,d) -> [rel_of_string s], d + | Some q, (_, d) when q < d -> rels_of_string_ s q + | _, (s, d) -> ([ rel_of_string s ], d) let anchor_of_string s i = let qs, i = quoted_string_of_string s i in - Uri.of_string qs, i + (Uri.of_string qs, i) let star_of_string s i = match Stringext.find_from ~start:i s ~pattern:"'" with - | None -> let s, i = quoted_string_of_string s i in "","",s,i - | Some a -> - let charset = String.sub s i (a - i) in - let i = a + 1 in - match Stringext.find_from ~start:i s ~pattern:"'" with - | None -> let s, i = quoted_string_of_string s i in charset,"",s,i - | Some a -> - let language = String.sub s i (a - i) in - let i = a + 1 in + | None -> let s, i = quoted_string_of_string s i in - charset, language, s, i + ("", "", s, i) + | Some a -> ( + let charset = String.sub s i (a - i) in + let i = a + 1 in + match Stringext.find_from ~start:i s ~pattern:"'" with + | None -> + let s, i = quoted_string_of_string s i in + (charset, "", s, i) + | Some a -> + let language = String.sub s i (a - i) in + let i = a + 1 in + let s, i = quoted_string_of_string s i in + (charset, language, s, i)) let media_type_of_string s i = let mt, i = quoted_string_of_string s i in match Stringext.split ~max:2 mt ~on:'/' with - | [] -> ("",""), i - | [t] -> (t,""), i - | t::st::_ -> (t,st), i + | [] -> (("", ""), i) + | [ t ] -> ((t, ""), i) + | t :: st :: _ -> ((t, st), i) let rec params_of_string s i ps = - let _,d = until s i [';';','] in - if d = String.length s - then ps, None - else if String.get s d = ',' - then ps, Some d + let _, d = until s i [ ';'; ',' ] in + if d = String.length s then (ps, None) + else if s.[d] = ',' then (ps, Some d) else let i = d + 1 in - let param, i = until s i ['='] in + let param, i = until s i [ '=' ] in let i = i + 1 in match String.trim param with | "rel" -> - let rels, i = rels_of_string s i in - params_of_string s i ((Rel rels)::ps) + let rels, i = rels_of_string s i in + params_of_string s i (Rel rels :: ps) | "anchor" -> - let uri, i = anchor_of_string s i in - params_of_string s i ((Anchor uri)::ps) + let uri, i = anchor_of_string s i in + params_of_string s i (Anchor uri :: ps) | "rev" -> - let rels, i = rels_of_string s i in - params_of_string s i ((Rev rels)::ps) + let rels, i = rels_of_string s i in + params_of_string s i (Rev rels :: ps) | "hreflang" -> - let hreflang, i = until s i [',';';'] in - params_of_string s i ((Hreflang hreflang)::ps) + let hreflang, i = until s i [ ','; ';' ] in + params_of_string s i (Hreflang hreflang :: ps) | "media" -> - let media, i = quoted_string_of_string s i in - params_of_string s i ((Media media)::ps) + let media, i = quoted_string_of_string s i in + params_of_string s i (Media media :: ps) | "title" -> - let title, i = quoted_string_of_string s i in - params_of_string s i ((Title title)::ps) + let title, i = quoted_string_of_string s i in + params_of_string s i (Title title :: ps) | "title*" -> - let charset, language, v, i = star_of_string s i in - params_of_string s i ((Star { Ext.charset; language; value = Title v })::ps) + let charset, language, v, i = star_of_string s i in + params_of_string s i + (Star { Ext.charset; language; value = Title v } :: ps) | "type" -> - let media_type, i = media_type_of_string s i in - params_of_string s i ((Type media_type)::ps) + let media_type, i = media_type_of_string s i in + params_of_string s i (Type media_type :: ps) | other when String.length other = 0 -> - let s, i = quoted_string_of_string s i in - params_of_string s i ((Link_extension ("", s))::ps) + let s, i = quoted_string_of_string s i in + params_of_string s i (Link_extension ("", s) :: ps) | other -> - let last = String.length other - 1 in - if String.get other last = '*' - then - let main = String.sub other 0 last in - let charset, language, v, i = star_of_string s i in - params_of_string s i - ((Star { Ext.charset; language; value = Link_extension (main, v) })::ps) - else - let v, i = quoted_string_of_string s i in - params_of_string s i ((Link_extension (other, v))::ps) + let last = String.length other - 1 in + if other.[last] = '*' then + let main = String.sub other 0 last in + let charset, language, v, i = star_of_string s i in + params_of_string s i + (Star { Ext.charset; language; value = Link_extension (main, v) } + :: ps) + else + let v, i = quoted_string_of_string s i in + params_of_string s i (Link_extension (other, v) :: ps) let rec find_or_default f d = function | [] -> d - | h::t -> match f h with - | None -> find_or_default f d t - | Some v -> v - -let arc_of_relation_params ?(reverse=false) relation params = - let extensions, extension_exts = List.fold_left (fun (x,xx) -> function - | Link_extension (k, v) -> ((k, v)::x,xx) - | Star { Ext.charset; language; value = Link_extension (k, value) } -> - (x,(k,{ Ext.charset; language; value })::xx) - | _ -> (x,xx) - ) ([],[]) params in + | h :: t -> ( match f h with None -> find_or_default f d t | Some v -> v) + +let arc_of_relation_params ?(reverse = false) relation params = + let extensions, extension_exts = + List.fold_left + (fun (x, xx) -> function + | Link_extension (k, v) -> ((k, v) :: x, xx) + | Star { Ext.charset; language; value = Link_extension (k, value) } -> + (x, (k, { Ext.charset; language; value }) :: xx) + | _ -> (x, xx)) + ([], []) params + in { Arc.reverse; relation; - hreflang=find_or_default - (function Hreflang l -> Some (Some l) | _ -> None) None params; - media=find_or_default - (function Media m -> Some (Some m) | _ -> None) None params; - title=find_or_default - (function Title t -> Some (Some t) | _ -> None) None params; - title_ext=find_or_default + hreflang = + find_or_default + (function Hreflang l -> Some (Some l) | _ -> None) + None params; + media = + find_or_default + (function Media m -> Some (Some m) | _ -> None) + None params; + title = + find_or_default + (function Title t -> Some (Some t) | _ -> None) + None params; + title_ext = + find_or_default (function | Star { Ext.charset; language; value = Title t } -> - Some (Some { Ext.charset; language; value = t }) - | _ -> None - ) + Some (Some { Ext.charset; language; value = t }) + | _ -> None) + None params; + media_type = + find_or_default + (function Type mt -> Some (Some mt) | _ -> None) None params; - media_type=find_or_default - (function Type mt -> Some (Some mt) | _ -> None) None params; extensions; extension_exts; } -let empty = { - context = Uri.of_string ""; - arc = Arc.empty; - target = Uri.of_string ""; -} +let empty = + { context = Uri.of_string ""; arc = Arc.empty; target = Uri.of_string "" } let rec unfold s list start = match Stringext.find_from ~start s ~pattern:"<" with | None -> list - | Some i -> - let uri_ref, i = until s (i + 1) ['>'] in - let i = i + 1 in - let target = Uri.of_string uri_ref in - let params, c_opt = params_of_string s i [] in - let params = List.rev params in - let context = find_or_default - (function Anchor uri -> Some uri | _ -> None) - (Uri.of_string "") - params - in - let link = match find_or_default - (function Rel rels -> Some rels | _ -> None) [] params - with - | (_::_) as relation -> - let arc = arc_of_relation_params relation params in - { context; arc; target } - | [] -> - match find_or_default - (function Rev rels -> Some rels | _ -> None) [] params + | Some i -> ( + let uri_ref, i = until s (i + 1) [ '>' ] in + let i = i + 1 in + let target = Uri.of_string uri_ref in + let params, c_opt = params_of_string s i [] in + let params = List.rev params in + let context = + find_or_default + (function Anchor uri -> Some uri | _ -> None) + (Uri.of_string "") params + in + let link = + match + find_or_default + (function Rel rels -> Some rels | _ -> None) + [] params with - | [] -> - let arc = arc_of_relation_params [] params in - { context; arc; target } - | rev -> - let arc = arc_of_relation_params ~reverse:true rev params in - { context = target; arc; target = context } - in - let list = link::list in - match c_opt with - | None -> list - | Some c -> unfold s list c - -let of_string s = - List.rev (unfold s [] 0) + | _ :: _ as relation -> + let arc = arc_of_relation_params relation params in + { context; arc; target } + | [] -> ( + match + find_or_default + (function Rev rels -> Some rels | _ -> None) + [] params + with + | [] -> + let arc = arc_of_relation_params [] params in + { context; arc; target } + | rev -> + let arc = arc_of_relation_params ~reverse:true rev params in + { context = target; arc; target = context }) + in + let list = link :: list in + match c_opt with None -> list | Some c -> unfold s list c) + +let of_string s = List.rev (unfold s [] 0) open Printf -let arc_to_string context arc = Arc.( - let attrs = match arc.relation with - | [] -> [] - | rels -> [ - sprintf "%s=\"%s\"" (if arc.reverse then "rev" else "rel") - (String.concat " " (List.map string_of_rel rels)) - ] - in - let attrs = match arc.hreflang with - | None -> attrs - | Some s -> ("hreflang="^s)::attrs - in - let attrs = match arc.media with - | None -> attrs - | Some s -> (sprintf "media=\"%s\"" s)::attrs - in - let attrs = match arc.title with - | None -> attrs - | Some s -> (sprintf "title=%S" s)::attrs (* TODO: this isn't quite right...*) - in - let attrs = match arc.title_ext with - | None -> attrs - | Some { Ext.charset; language; value } -> - (sprintf "title*=%s'%s'%s" charset language value)::attrs - in - let attrs = match arc.media_type with - | None -> attrs - | Some (typ,sub) -> (sprintf "type=%s/%s" typ sub)::attrs - in - let attrs = - (List.map (fun (k,v) -> sprintf "%s=%S" k v) arc.extensions)@attrs - in - let attrs = (List.map (fun (k,{ Ext.charset; language; value }) -> - sprintf "%s=%s'%s'%s" k charset language value - ) arc.extension_exts)@attrs in - let attrs = - if context = Uri.of_string "" - then attrs - else (sprintf "anchor=\"%s\"" (Uri.to_string context))::attrs - in String.concat "; " attrs -) +let arc_to_string context arc = + Arc.( + let attrs = + match arc.relation with + | [] -> [] + | rels -> + [ + sprintf "%s=\"%s\"" + (if arc.reverse then "rev" else "rel") + (String.concat " " (List.map string_of_rel rels)); + ] + in + let attrs = + match arc.hreflang with + | None -> attrs + | Some s -> ("hreflang=" ^ s) :: attrs + in + let attrs = + match arc.media with + | None -> attrs + | Some s -> sprintf "media=\"%s\"" s :: attrs + in + let attrs = + match arc.title with + | None -> attrs + | Some s -> sprintf "title=%S" s :: attrs + (* TODO: this isn't quite right...*) + in + let attrs = + match arc.title_ext with + | None -> attrs + | Some { Ext.charset; language; value } -> + sprintf "title*=%s'%s'%s" charset language value :: attrs + in + let attrs = + match arc.media_type with + | None -> attrs + | Some (typ, sub) -> sprintf "type=%s/%s" typ sub :: attrs + in + let attrs = + List.map (fun (k, v) -> sprintf "%s=%S" k v) arc.extensions @ attrs + in + let attrs = + List.map + (fun (k, { Ext.charset; language; value }) -> + sprintf "%s=%s'%s'%s" k charset language value) + arc.extension_exts + @ attrs + in + let attrs = + if context = Uri.of_string "" then attrs + else sprintf "anchor=\"%s\"" (Uri.to_string context) :: attrs + in + String.concat "; " attrs) -let to_string ({ context; arc; target }) = +let to_string { context; arc; target } = sprintf "<%s>; %s" (Uri.to_string target) (arc_to_string context arc) diff --git a/cohttp/src/link.mli b/cohttp/src/link.mli index 5b6d72739d..8f32cda922 100644 --- a/cohttp/src/link.mli +++ b/cohttp/src/link.mli @@ -14,8 +14,8 @@ * }}}*) -(** RFC 5988 ("Web Linking") and RFC 5987 ("Character Set and Language - Encoding for Hypertext Transfer Protocol (HTTP) Header Field Parameters") *) +(** RFC 5988 ("Web Linking") and RFC 5987 ("Character Set and Language Encoding + for Hypertext Transfer Protocol (HTTP) Header Field Parameters") *) module Rel : sig type t [@@deriving sexp] @@ -82,9 +82,7 @@ module Ext : sig val charset : 'a t -> Charset.t val language : 'a t -> Language.t val value : 'a t -> 'a - val make : ?charset:Charset.t -> ?language:Language.t -> 'a -> 'a t - val map : ('a -> 'b) -> 'a t -> 'b t end @@ -104,14 +102,8 @@ module Arc : sig val empty : t end -type t = { - context : Uri.t; - arc : Arc.t; - target : Uri.t; -} [@@deriving sexp] +type t = { context : Uri.t; arc : Arc.t; target : Uri.t } [@@deriving sexp] val empty : t - val of_string : string -> t list - val to_string : t -> string diff --git a/cohttp/src/request.ml b/cohttp/src/request.ml index cca81a5b1f..0368051b43 100644 --- a/cohttp/src/request.ml +++ b/cohttp/src/request.ml @@ -18,59 +18,68 @@ open Ppx_compare_lib.Builtin open Sexplib0.Sexp_conv type t = { - headers: Header.t; - meth: Code.meth; - scheme: string option; - resource: string; - version: Code.version; - encoding: Transfer.encoding; -} [@@deriving compare, fields, sexp] + headers : Header.t; + meth : Code.meth; + scheme : string option; + resource : string; + version : Code.version; + encoding : Transfer.encoding; +} +[@@deriving compare, fields, sexp] let fixed_zero = Transfer.Fixed Int64.zero -let guess_encoding ?(encoding=fixed_zero) headers = +let guess_encoding ?(encoding = fixed_zero) headers = match Header.get_transfer_encoding headers with | Transfer.(Chunked | Fixed _) as enc -> enc | Unknown -> encoding -let make ?(meth=`GET) ?(version=`HTTP_1_1) ?encoding ?headers uri = - let headers = - match headers with - | None -> Header.init () - | Some h -> h in +let make ?(meth = `GET) ?(version = `HTTP_1_1) ?encoding ?headers uri = + let headers = match headers with None -> Header.init () | Some h -> h in let headers = Header.add_unless_exists headers "host" (match Uri.scheme uri with | Some "httpunix" -> "" - | _ -> - Uri.host_with_default ~default:"localhost" uri ^ - match Uri.port uri with - | Some p -> ":" ^ string_of_int p - | None -> "") in + | _ -> ( + Uri.host_with_default ~default:"localhost" uri + ^ + match Uri.port uri with Some p -> ":" ^ string_of_int p | None -> "")) + in let headers = - Header.add_unless_exists headers "user-agent" Header.user_agent in + Header.add_unless_exists headers "user-agent" Header.user_agent + in let headers = (* Add user:password auth to headers from uri * if headers don't already have auth *) - match Header.get_authorization headers, Uri.user uri, Uri.password uri with + match + (Header.get_authorization headers, Uri.user uri, Uri.password uri) + with | None, Some user, Some pass -> - let auth = `Basic (user, pass) in - Header.add_authorization headers auth - | _, _, _ -> headers in + let auth = `Basic (user, pass) in + Header.add_authorization headers auth + | _, _, _ -> headers + in let encoding = guess_encoding ?encoding headers in - { meth; version; headers; scheme=(Uri.scheme uri); resource=(Uri.path_and_query uri); encoding } + { + meth; + version; + headers; + scheme = Uri.scheme uri; + resource = Uri.path_and_query uri; + encoding; + } let is_keep_alive { version; headers; _ } = - not (version = `HTTP_1_0 || - (match Header.connection headers with - | Some `Close -> true - | _ -> false)) + not + (version = `HTTP_1_0 + || match Header.connection headers with Some `Close -> true | _ -> false) (* Make a client request, which involves guessing encoding and adding content headers if appropriate. @param chunked Forces chunked encoding *) -let make_for_client ?headers ?(chunked=true) ?(body_length=Int64.zero) meth uri = +let make_for_client ?headers ?(chunked = true) ?(body_length = Int64.zero) meth + uri = let encoding = match chunked with | true -> Transfer.Chunked @@ -84,61 +93,66 @@ let pp_hum ppf r = (* Validate path when reading URI. Implemented for compatibility with old implementation rather than efficiency *) let is_valid_uri path meth = - path = "*" || meth = `CONNECT || - (match Uri.scheme (Uri.of_string path) with - | Some _ -> true - | None -> not (String.length path > 0 && path.[0] <> '/')) - -let uri { scheme ; resource ; headers ; meth ; _ } = + path = "*" + || meth = `CONNECT + || + match Uri.scheme (Uri.of_string path) with + | Some _ -> true + | None -> not (String.length path > 0 && path.[0] <> '/') + +let uri { scheme; resource; headers; meth; _ } = let uri = match resource with - | "*" -> - begin match Header.get headers "host" with - | None -> Uri.of_string "" - | Some host -> - let host_uri = Uri.of_string ("//"^host) in - Uri.(make ?host:(host host_uri) ?port:(port host_uri) ()) - end + | "*" -> ( + match Header.get headers "host" with + | None -> Uri.of_string "" + | Some host -> + let host_uri = Uri.of_string ("//" ^ host) in + Uri.(make ?host:(host host_uri) ?port:(port host_uri) ())) | authority when meth = `CONNECT -> Uri.of_string ("//" ^ authority) - | path -> - let uri = Uri.of_string path in - begin match Uri.scheme uri with - | Some _ -> (* we have an absoluteURI *) - Uri.(match path uri with "" -> with_path uri "/" | _ -> uri) - | None -> - let empty = Uri.of_string "" in - let empty_base = Uri.of_string "///" in - let pqs = match Stringext.split ~max:2 path ~on:'?' with - | [] -> empty_base - | [path] -> - Uri.resolve "http" empty_base (Uri.with_path empty path) - | path::qs::_ -> - let path_base = - Uri.resolve "http" empty_base (Uri.with_path empty path) + | path -> ( + let uri = Uri.of_string path in + match Uri.scheme uri with + | Some _ -> ( + (* we have an absoluteURI *) + Uri.( + match path uri with "" -> with_path uri "/" | _ -> uri)) + | None -> + let empty = Uri.of_string "" in + let empty_base = Uri.of_string "///" in + let pqs = + match Stringext.split ~max:2 path ~on:'?' with + | [] -> empty_base + | [ path ] -> + Uri.resolve "http" empty_base (Uri.with_path empty path) + | path :: qs :: _ -> + let path_base = + Uri.resolve "http" empty_base (Uri.with_path empty path) + in + Uri.with_query path_base (Uri.query_of_encoded qs) in - Uri.with_query path_base (Uri.query_of_encoded qs) - in - let uri = match Header.get headers "host" with - | None -> Uri.(with_scheme (with_host pqs None) None) - | Some host -> - let host_uri = Uri.of_string ("//"^host) in - let uri = Uri.with_host pqs (Uri.host host_uri) in - Uri.with_port uri (Uri.port host_uri) - in - uri - end + let uri = + match Header.get headers "host" with + | None -> Uri.(with_scheme (with_host pqs None) None) + | Some host -> + let host_uri = Uri.of_string ("//" ^ host) in + let uri = Uri.with_host pqs (Uri.host host_uri) in + Uri.with_port uri (Uri.port host_uri) + in + uri) in (* Only set the scheme if it's not already part of the URI *) - match Uri.scheme uri with - | Some _ -> uri - | None -> Uri.with_scheme uri scheme + match Uri.scheme uri with Some _ -> uri | None -> Uri.with_scheme uri scheme type tt = t -module Make(IO : S.IO) = struct + +module Make (IO : S.IO) = struct type t = tt + module IO = IO - module Header_IO = Header_io.Make(IO) - module Transfer_IO = Transfer_io.Make(IO) + module Header_IO = Header_io.Make (IO) + module Transfer_IO = Transfer_io.Make (IO) + type reader = Transfer_IO.reader type writer = Transfer_IO.writer @@ -147,16 +161,17 @@ module Make(IO : S.IO) = struct let parse_request_fst_line ic = let open Code in read_line ic >>= function - | Some request_line -> begin + | Some request_line -> ( match Stringext.split request_line ~on:' ' with - | [ meth_raw; path; http_ver_raw ] -> begin + | [ meth_raw; path; http_ver_raw ] -> ( let m = method_of_string meth_raw in match version_of_string http_ver_raw with - | `HTTP_1_1 | `HTTP_1_0 as v -> return (`Ok (m, path, v)) - | `Other _ -> return (`Invalid ("Malformed request HTTP version: " ^ http_ver_raw)) - end - | _ -> return (`Invalid ("Malformed request header: " ^ request_line)) - end + | (`HTTP_1_1 | `HTTP_1_0) as v -> return (`Ok (m, path, v)) + | `Other _ -> + return + (`Invalid ("Malformed request HTTP version: " ^ http_ver_raw)) + ) + | _ -> return (`Invalid ("Malformed request header: " ^ request_line))) | None -> return `Eof let read ic = @@ -164,19 +179,19 @@ module Make(IO : S.IO) = struct | `Eof -> return `Eof | `Invalid _reason as r -> return r | `Ok (meth, resource, version) -> - if is_valid_uri resource meth then - Header_IO.parse ic >>= fun headers -> - let encoding = Header.get_transfer_encoding headers in - return (`Ok { headers; meth; scheme = None; resource; version; encoding }) - else - return (`Invalid "bad request URI") + if is_valid_uri resource meth then + Header_IO.parse ic >>= fun headers -> + let encoding = Header.get_transfer_encoding headers in + return + (`Ok { headers; meth; scheme = None; resource; version; encoding }) + else return (`Invalid "bad request URI") (* Defined for method types in RFC7231 *) let has_body req = match req.meth with | `GET | `HEAD | `CONNECT | `TRACE -> `No | `DELETE | `POST | `PUT | `PATCH | `OPTIONS | `Other _ -> - Transfer.has_body req.encoding + Transfer.has_body req.encoding let make_body_reader req ic = Transfer_IO.make_reader req.encoding ic let read_body_chunk = Transfer_IO.read @@ -186,14 +201,15 @@ module Make(IO : S.IO) = struct Printf.sprintf "%s %s %s\r\n" (Code.string_of_method req.meth) (if req.resource = "" then "/" else req.resource) - (Code.string_of_version req.version) in + (Code.string_of_version req.version) + in let headers = req.headers in let headers = match has_body req with | `Yes | `Unknown -> Header.add_transfer_encoding headers req.encoding - | `No -> headers in - IO.write oc fst_line >>= fun _ -> - Header_IO.write headers oc + | `No -> headers + in + IO.write oc fst_line >>= fun _ -> Header_IO.write headers oc let make_body_writer ?flush req oc = Transfer_IO.make_writer ?flush req.encoding oc @@ -203,13 +219,12 @@ module Make(IO : S.IO) = struct let write_footer req oc = match req.encoding with | Transfer.Chunked -> - (* TODO Trailer header support *) - IO.write oc "0\r\n\r\n" + (* TODO Trailer header support *) + IO.write oc "0\r\n\r\n" | Transfer.Fixed _ | Transfer.Unknown -> return () let write ?flush write_body req oc = write_header req oc >>= fun () -> let writer = make_body_writer ?flush req oc in - write_body writer >>= fun () -> - write_footer req oc + write_body writer >>= fun () -> write_footer req oc end diff --git a/cohttp/src/request.mli b/cohttp/src/request.mli index 3c42776264..2c14bb02ee 100644 --- a/cohttp/src/request.mli +++ b/cohttp/src/request.mli @@ -16,20 +16,17 @@ (** HTTP/1.1 request handling *) -(** This contains the metadata for a HTTP/1.1 request header, including - the {!headers}, {!version}, {!meth} and {!uri}. The body is handled by - the separate {!S} module type, as it is dependent on the IO - implementation. +include S.Request +(** This contains the metadata for a HTTP/1.1 request header, including the + {!headers}, {!version}, {!meth} and {!uri}. The body is handled by the + separate {!S} module type, as it is dependent on the IO implementation. The interface exposes a [fieldslib] interface which provides individual - accessor functions for each of the records below. It also provides [sexp] + accessor functions for each of the records below. It also provides [sexp] serializers to convert to-and-from an {!Core.Std.Sexp.t}. *) -include S.Request -(** Human-readable output, used by the toplevel printer *) val pp_hum : Format.formatter -> t -> unit +(** Human-readable output, used by the toplevel printer *) (** Functor to construct the IO-specific HTTP request handling functions *) -module Make(IO : S.IO) : S.Http_io - with type t = t - and module IO = IO +module Make (IO : S.IO) : S.Http_io with type t = t and module IO = IO diff --git a/cohttp/src/response.ml b/cohttp/src/response.ml index d78458a038..b79e50d10f 100644 --- a/cohttp/src/response.ml +++ b/cohttp/src/response.ml @@ -19,17 +19,19 @@ open Sexplib0.Sexp_conv let compare_bool = Bool.compare type t = { - encoding: Transfer.encoding; - headers: Header.t; - version: Code.version; - status: Code.status_code; - flush: bool; -} [@@deriving compare, fields, sexp] - -let make ?(version=`HTTP_1_1) ?(status=`OK) ?(flush=false) ?(encoding=Transfer.Chunked) ?(headers=Header.init ()) () = + encoding : Transfer.encoding; + headers : Header.t; + version : Code.version; + status : Code.status_code; + flush : bool; +} +[@@deriving compare, fields, sexp] + +let make ?(version = `HTTP_1_1) ?(status = `OK) ?(flush = false) + ?(encoding = Transfer.Chunked) ?(headers = Header.init ()) () = let encoding = match Header.get_transfer_encoding headers with - | Transfer.(Chunked | Fixed _) as enc -> enc + | Transfer.(Chunked | Fixed _) as enc -> enc | Unknown -> encoding in { encoding; headers; version; flush; status } @@ -38,11 +40,14 @@ let pp_hum ppf r = Format.fprintf ppf "%s" (r |> sexp_of_t |> Sexplib0.Sexp.to_string_hum) type tt = t -module Make(IO : S.IO) = struct + +module Make (IO : S.IO) = struct type t = tt + module IO = IO - module Header_IO = Header_io.Make(IO) - module Transfer_IO = Transfer_io.Make(IO) + module Header_IO = Header_io.Make (IO) + module Transfer_IO = Transfer_io.Make (IO) + type reader = Transfer_IO.reader type writer = Transfer_IO.writer @@ -51,15 +56,18 @@ module Make(IO : S.IO) = struct let parse_response_fst_line ic = let open Code in read_line ic >>= function - | Some response_line -> begin - match Stringext.split response_line ~on:' ' with - | version_raw :: code_raw :: _ -> begin - match version_of_string version_raw with - | `HTTP_1_0 | `HTTP_1_1 as v -> return (`Ok (v, (status_of_code (int_of_string code_raw)))) - | `Other _ -> return (`Invalid ("Malformed response version: " ^ version_raw)) - end - | _ -> return (`Invalid ("Malformed response first line: " ^ response_line)) - end + | Some response_line -> ( + match Stringext.split response_line ~on:' ' with + | version_raw :: code_raw :: _ -> ( + match version_of_string version_raw with + | (`HTTP_1_0 | `HTTP_1_1) as v -> + return (`Ok (v, status_of_code (int_of_string code_raw))) + | `Other _ -> + return (`Invalid ("Malformed response version: " ^ version_raw)) + ) + | _ -> + return + (`Invalid ("Malformed response first line: " ^ response_line))) | None -> return `Eof let read ic = @@ -67,48 +75,50 @@ module Make(IO : S.IO) = struct | `Eof -> return `Eof | `Invalid _reason as r -> return r | `Ok (version, status) -> - Header_IO.parse ic >>= fun headers -> - let encoding = Header.get_transfer_encoding headers in - let flush = false in - return (`Ok { encoding; headers; version; status; flush }) + Header_IO.parse ic >>= fun headers -> + let encoding = Header.get_transfer_encoding headers in + let flush = false in + return (`Ok { encoding; headers; version; status; flush }) - let allowed_body response = (* rfc7230#section-5.7.1 *) + let allowed_body response = + (* rfc7230#section-5.7.1 *) match status response with | #Code.informational_status | `No_content | `Not_modified -> false | #Code.status_code -> true let has_body response = - if allowed_body response - then Transfer.has_body (encoding response) - else `No + if allowed_body response then Transfer.has_body (encoding response) else `No - let make_body_reader {encoding; _} ic = Transfer_IO.make_reader encoding ic + let make_body_reader { encoding; _ } ic = Transfer_IO.make_reader encoding ic let read_body_chunk = Transfer_IO.read let write_header res oc = - write oc (Printf.sprintf "%s %s\r\n" (Code.string_of_version res.version) - (Code.string_of_status res.status)) >>= fun () -> + write oc + (Printf.sprintf "%s %s\r\n" + (Code.string_of_version res.version) + (Code.string_of_status res.status)) + >>= fun () -> let headers = - if allowed_body res - then Header.add_transfer_encoding res.headers res.encoding - else res.headers in + if allowed_body res then + Header.add_transfer_encoding res.headers res.encoding + else res.headers + in Header_IO.write headers oc - let make_body_writer ?flush {encoding; _} oc = + let make_body_writer ?flush { encoding; _ } oc = Transfer_IO.make_writer ?flush encoding oc let write_body = Transfer_IO.write - let write_footer {encoding; _} oc = + let write_footer { encoding; _ } oc = match encoding with - |Transfer.Chunked -> - (* TODO Trailer header support *) - IO.write oc "0\r\n\r\n" - |Transfer.Fixed _ | Transfer.Unknown -> return () + | Transfer.Chunked -> + (* TODO Trailer header support *) + IO.write oc "0\r\n\r\n" + | Transfer.Fixed _ | Transfer.Unknown -> return () let write ?flush fn req oc = write_header req oc >>= fun () -> let writer = make_body_writer ?flush req oc in - fn writer >>= fun () -> - write_footer req oc + fn writer >>= fun () -> write_footer req oc end diff --git a/cohttp/src/response.mli b/cohttp/src/response.mli index f52bd4acd8..81902d82ca 100644 --- a/cohttp/src/response.mli +++ b/cohttp/src/response.mli @@ -16,22 +16,19 @@ (** HTTP/1.1 response handling *) -(** This contains the metadata for a HTTP/1.1 response header, including - the {!encoding}, {!headers}, {!version}, {!status} code and whether to - {!flush} the connection after every body chunk (useful for server-side - events and other long-lived connection protocols). The body is handled by - the separate {!S} module type, as it is dependent on the IO - implementation. +include S.Response +(** This contains the metadata for a HTTP/1.1 response header, including the + {!encoding}, {!headers}, {!version}, {!status} code and whether to {!flush} + the connection after every body chunk (useful for server-side events and + other long-lived connection protocols). The body is handled by the separate + {!S} module type, as it is dependent on the IO implementation. The interface exposes a [fieldslib] interface which provides individual - accessor functions for each of the records below. It also provides [sexp] + accessor functions for each of the records below. It also provides [sexp] serializers to convert to-and-from an {!Core.Std.Sexp.t}. *) -include S.Response -(** Human-readable output, used by the toplevel printer *) val pp_hum : Format.formatter -> t -> unit +(** Human-readable output, used by the toplevel printer *) (** Functor to construct the IO-specific response handling function *) -module Make(IO : S.IO) : S.Http_io - with type t = t - and module IO = IO +module Make (IO : S.IO) : S.Http_io with type t = t and module IO = IO diff --git a/cohttp/src/s.ml b/cohttp/src/s.ml index e34cea848c..f25eb199c1 100644 --- a/cohttp/src/s.ml +++ b/cohttp/src/s.ml @@ -17,56 +17,54 @@ (** Module type signatures for Cohttp components *) -(** The [IO] module defines the blocking interface for reading - and writing to Cohttp streams *) +(** The [IO] module defines the blocking interface for reading and writing to + Cohttp streams *) module type IO = sig - - (** ['a t] represents a blocking monad state *) type +'a t + (** ['a t] represents a blocking monad state *) - (** [a >>= b] will pass the result of [a] to the - [b] function. This is a monadic [bind]. *) - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t + (** [a >>= b] will pass the result of [a] to the [b] function. This is a + monadic [bind]. *) - (** [return a] will construct a constant IO value. *) val return : 'a -> 'a t + (** [return a] will construct a constant IO value. *) - (** [ic] represents an input channel *) type ic + (** [ic] represents an input channel *) - (** [oc] represents an output channel *) type oc + (** [oc] represents an output channel *) - (** [conn] represents the underlying network flow *) type conn + (** [conn] represents the underlying network flow *) - (** [read_line ic] will read a single line terminated - by CR or CRLF from the input channel [ic]. It returns - {!None} if EOF or other error condition is reached. *) val read_line : ic -> string option t + (** [read_line ic] will read a single line terminated by CR or CRLF from the + input channel [ic]. It returns {!None} if EOF or other error condition is + reached. *) - (** [read ic len] will block until a maximum of [len] characters - are read from the input channel [ic]. It returns an - empty string if EOF or some other error condition occurs - on the input channel, and can also return fewer than [len] - characters if input buffering is not sufficient to satisfy the - request. *) val read : ic -> int -> string t + (** [read ic len] will block until a maximum of [len] characters are read from + the input channel [ic]. It returns an empty string if EOF or some other + error condition occurs on the input channel, and can also return fewer + than [len] characters if input buffering is not sufficient to satisfy the + request. *) - (** [write oc s] will block until the complete [s] string is - written to the output channel [oc]. *) val write : oc -> string -> unit t + (** [write oc s] will block until the complete [s] string is written to the + output channel [oc]. *) - (** [flush oc] will return when all previously buffered content - from calling {!write} have been written to the output channel - [oc]. *) val flush : oc -> unit t + (** [flush oc] will return when all previously buffered content from calling + {!write} have been written to the output channel [oc]. *) end module type Http_io = sig type t type reader type writer + module IO : IO val read : IO.ic -> [ `Eof | `Invalid of string | `Ok of t ] IO.t @@ -74,7 +72,6 @@ module type Http_io = sig val make_body_writer : ?flush:bool -> t -> IO.oc -> writer val make_body_reader : t -> IO.ic -> reader val read_body_chunk : reader -> Transfer.chunk IO.t - val write_header : t -> IO.oc -> unit IO.t val write_body : writer -> string -> unit IO.t val write : ?flush:bool -> (writer -> unit IO.t) -> t -> IO.oc -> unit IO.t @@ -82,37 +79,47 @@ end module type Request = sig type t = { - headers: Header.t; (** HTTP request headers *) - meth: Code.meth; (** HTTP request method *) - scheme: string option; (** URI scheme (http or https) *) - resource: string; (** Request path and query *) - version: Code.version; (** HTTP version, usually 1.1 *) - encoding: Transfer.encoding; (** transfer encoding of this HTTP request *) - } [@@deriving compare, fields, sexp] - - val make : ?meth:Code.meth -> ?version:Code.version -> - ?encoding:Transfer.encoding -> ?headers:Header.t -> - Uri.t -> t - (** Return true whether the connection should be reused *) + headers : Header.t; (** HTTP request headers *) + meth : Code.meth; (** HTTP request method *) + scheme : string option; (** URI scheme (http or https) *) + resource : string; (** Request path and query *) + version : Code.version; (** HTTP version, usually 1.1 *) + encoding : Transfer.encoding; (** transfer encoding of this HTTP request *) + } + [@@deriving compare, fields, sexp] + + val make : + ?meth:Code.meth -> + ?version:Code.version -> + ?encoding:Transfer.encoding -> + ?headers:Header.t -> + Uri.t -> + t + val is_keep_alive : t -> bool + (** Return true whether the connection should be reused *) val uri : t -> Uri.t - val make_for_client: + val make_for_client : ?headers:Header.t -> ?chunked:bool -> ?body_length:int64 -> - Code.meth -> Uri.t -> t + Code.meth -> + Uri.t -> + t end module type Response = sig type t = { - encoding: Transfer.encoding; (** Transfer encoding of this HTTP response *) - headers: Header.t; (** response HTTP headers *) - version: Code.version; (** (** HTTP version, usually 1.1 *) *) - status: Code.status_code; (** HTTP status code of the response *) - flush: bool; - } [@@deriving compare, fields, sexp] + encoding : Transfer.encoding; + (** Transfer encoding of this HTTP response *) + headers : Header.t; (** response HTTP headers *) + version : Code.version; (** (** HTTP version, usually 1.1 *) *) + status : Code.status_code; (** HTTP status code of the response *) + flush : bool; + } + [@@deriving compare, fields, sexp] (* The response creates by [make ~encoding ~headers ()] has an encoding value determined from the content of [headers] or if no @@ -126,11 +133,13 @@ module type Response = sig ?flush:bool -> ?encoding:Transfer.encoding -> ?headers:Header.t -> - unit -> t + unit -> + t end module type Body = sig type t + val to_string : t -> string val to_string_list : t -> string list val to_form : t -> (string * string list) list diff --git a/cohttp/src/string_io.ml b/cohttp/src/string_io.ml index ccfdfc7034..ca84c31b01 100644 --- a/cohttp/src/string_io.ml +++ b/cohttp/src/string_io.ml @@ -16,25 +16,19 @@ }}}*) (* input channel type - a string with a (file) position and length *) -type buf = - { - str : string; - mutable pos : int; - len : int; - } +type buf = { str : string; mutable pos : int; len : int } -let open_in str = - { - str = str; - pos = 0; - len = String.length str; - } +let open_in str = { str; pos = 0; len = String.length str } module M = struct type 'a t = 'a + let return a = a + type conn = buf - let (>>=) = (|>) + + let ( >>= ) = ( |> ) + type ic = buf (* output channels are just buffers *) @@ -42,7 +36,7 @@ module M = struct (* the following read/write logic has only been lightly tested... *) let read_rest x = - let s = String.sub x.str x.pos (x.len-x.pos) in + let s = String.sub x.str x.pos (x.len - x.pos) in x.pos <- x.len; s @@ -53,32 +47,34 @@ module M = struct while x.str.[x.pos] != '\n' do x.pos <- x.pos + 1 done; - let l = if x.pos > 0 && x.str.[x.pos-1] = '\r' then x.pos-start-1 else x.pos-start in + let l = + if x.pos > 0 && x.str.[x.pos - 1] = '\r' then x.pos - start - 1 + else x.pos - start + in let s = String.sub x.str start l in x.pos <- x.pos + 1; Some s - with _ -> - Some (read_rest x) - else - None + with _ -> Some (read_rest x) + else None let read_line x = return (read_line' x) let read_exactly' x n = - if x.len-x.pos < n then None - else begin + if x.len - x.pos < n then None + else let s = String.sub x.str x.pos n in x.pos <- x.pos + n; Some s - end let read x n = match read_exactly' x n with | None when x.pos >= x.len -> raise End_of_file | None -> return (read_rest x) - | Some(x) -> return x + | Some x -> return x - let write x s = Buffer.add_string x s; return () + let write x s = + Buffer.add_string x s; + return () let flush _x = return () end diff --git a/cohttp/src/string_io.mli b/cohttp/src/string_io.mli index 4fd0a38165..65988b8fda 100644 --- a/cohttp/src/string_io.mli +++ b/cohttp/src/string_io.mli @@ -17,21 +17,14 @@ (** IO implementation that uses strings to marshal and unmarshal HTTP *) -(** The buffer structured used to keep track of where in the string - the library is currently reading from *) -type buf = { - str : string; - mutable pos : int; - len : int; -} +type buf = { str : string; mutable pos : int; len : int } +(** The buffer structured used to keep track of where in the string the library + is currently reading from *) -(** [open_in s] will make the string [s] available as a [buf] - that can be parsed via Cohttp *) val open_in : string -> buf +(** [open_in s] will make the string [s] available as a [buf] that can be parsed + via Cohttp *) -(** IO interface that uses {!buf} for input data and queues output - data into a {!Buffer.t} *) -module M : S.IO - with type 'a t = 'a - and type ic = buf - and type oc = Buffer.t +(** IO interface that uses {!buf} for input data and queues output data into a + {!Buffer.t} *) +module M : S.IO with type 'a t = 'a and type ic = buf and type oc = Buffer.t diff --git a/cohttp/src/transfer.ml b/cohttp/src/transfer.ml index 894bc91065..19d14db827 100644 --- a/cohttp/src/transfer.ml +++ b/cohttp/src/transfer.ml @@ -18,27 +18,15 @@ open Sexplib0.Sexp_conv let compare_int64 = Int64.compare -type encoding = - | Chunked - | Fixed of int64 - | Unknown -[@@deriving compare, sexp] +type encoding = Chunked | Fixed of int64 | Unknown [@@deriving compare, sexp] +type chunk = Chunk of string | Final_chunk of string | Done [@@deriving sexp] -type chunk = - | Chunk of string - | Final_chunk of string - | Done [@@deriving sexp] - -let string_of_encoding = - function +let string_of_encoding = function | Chunked -> "chunked" | Fixed i -> Printf.sprintf "fixed[%Ld]" i | Unknown -> "unknown" -let has_body = - function +let has_body = function | Fixed 0L -> `No - | Chunked - | Fixed _ -> `Yes + | Chunked | Fixed _ -> `Yes | Unknown -> `Unknown - diff --git a/cohttp/src/transfer.mli b/cohttp/src/transfer.mli index 65d2a64afd..cb97837885 100644 --- a/cohttp/src/transfer.mli +++ b/cohttp/src/transfer.mli @@ -14,30 +14,29 @@ * }}}*) -(** Read and write the HTTP/1.1 transfer-encoding formats. - Currently supported are [chunked] and [content-length]. - *) +(** Read and write the HTTP/1.1 transfer-encoding formats. Currently supported + are [chunked] and [content-length]. *) (** The encoding format detected from the [transfer-encoding] and [content-length] headers *) type encoding = - | Chunked (** dynamic chunked encoding *) - | Fixed of int64 (** fixed size content *) - | Unknown (** unknown body size, which leads to best-effort *) + | Chunked (** dynamic chunked encoding *) + | Fixed of int64 (** fixed size content *) + | Unknown (** unknown body size, which leads to best-effort *) [@@deriving compare, sexp] (** A chunk of body that also signals if there to more to arrive *) type chunk = - | Chunk of string (** chunk of data and not the end of stream *) - | Final_chunk of string (** the last chunk of data, so no more should be read *) - | Done (** no more body data is present *) + | Chunk of string (** chunk of data and not the end of stream *) + | Final_chunk of string + (** the last chunk of data, so no more should be read *) + | Done (** no more body data is present *) [@@deriving sexp] -(** Convert the encoding format to a human-readable string *) val string_of_encoding : encoding -> string +(** Convert the encoding format to a human-readable string *) -(** [has_body encoding] returns the appropriate variant that indicates - whether the HTTP request or response has an associated body. - It does not guess: instead [Unknown] is returned if there is no - explicit association. *) val has_body : encoding -> [ `No | `Unknown | `Yes ] +(** [has_body encoding] returns the appropriate variant that indicates whether + the HTTP request or response has an associated body. It does not guess: + instead [Unknown] is returned if there is no explicit association. *) diff --git a/cohttp/src/transfer_io.ml b/cohttp/src/transfer_io.ml index e7aa42bd62..25d28e15aa 100644 --- a/cohttp/src/transfer_io.ml +++ b/cohttp/src/transfer_io.ml @@ -16,13 +16,13 @@ open Transfer -module Make(IO : S.IO) = struct +module Make (IO : S.IO) = struct open IO + type reader = unit -> Transfer.chunk IO.t type writer = string -> unit IO.t module Chunked = struct - let remaining_length chunk remaining = let read_len = Int64.of_int (String.length chunk) in Int64.sub remaining read_len @@ -39,9 +39,9 @@ module Make(IO : S.IO) = struct > more chunk extensions, immediately following the chunk-size *) try String.sub chunk_size_hex 0 (String.index chunk_size_hex ';') - with _ -> chunk_size_hex in - try Some (Int64.of_string ("0x" ^ hex)) - with _ -> None + with _ -> chunk_size_hex + in + try Some (Int64.of_string ("0x" ^ hex)) with _ -> None let rec junk_until_empty_line ic = read_line ic >>= function @@ -53,27 +53,28 @@ module Make(IO : S.IO) = struct let read_chunk_fragment () = read_chunk ic !remaining >>= fun chunk -> remaining := remaining_length chunk !remaining; - (if !remaining = 0L (* End_of_chunk *) - then read_line ic (* Junk the CRLF at end of chunk *) - else return None) >>= fun _ -> - return chunk + (if !remaining = 0L (* End_of_chunk *) then read_line ic + (* Junk the CRLF at end of chunk *) + else return None) + >>= fun _ -> return chunk in if !remaining = 0L then (* Beginning of a chunk: read chunk size, read up to 32K bytes *) read_line ic >>= function | None -> return Done - | Some chunk_size_hex -> begin + | Some chunk_size_hex -> ( match parse_chunksize chunk_size_hex with | None -> return Done - | Some 0L -> (* TODO: Trailer header support *) - junk_until_empty_line ic - | Some count -> - remaining := count; - read_chunk_fragment () >>= function - | "" -> return Done (* 0 bytes read means EOF *) - | buf -> return (Chunk buf) - end - else (* Middle of a chunk, read up to 32K bytes *) + | Some 0L -> + (* TODO: Trailer header support *) + junk_until_empty_line ic + | Some count -> ( + remaining := count; + read_chunk_fragment () >>= function + | "" -> return Done (* 0 bytes read means EOF *) + | buf -> return (Chunk buf))) + else + (* Middle of a chunk, read up to 32K bytes *) read_chunk_fragment () >>= function | "" -> return Done (* 0 bytes read means EOF *) | buf -> return (Chunk buf) @@ -84,10 +85,8 @@ module Make(IO : S.IO) = struct chunked body *) if len <> 0 then write oc (Printf.sprintf "%x\r\n" len) >>= fun () -> - write oc buf >>= fun () -> - write oc "\r\n" - else - return () + write oc buf >>= fun () -> write oc "\r\n" + else return () end module Fixed = struct @@ -95,16 +94,16 @@ module Make(IO : S.IO) = struct (* TODO functorise string to a bigbuffer *) match !remaining with | 0L -> return Done - | len -> - let max_read_len = Int64.of_int 0x8000 in - let read_len = Int64.to_int (min len max_read_len) in - read ic read_len >>= function - | "" -> return Done - | buf -> - remaining := Int64.sub !remaining (Int64.of_int (String.length buf)); - return (match !remaining with - | 0L -> Final_chunk buf - | _ -> Chunk buf) + | len -> ( + let max_read_len = Int64.of_int 0x8000 in + let read_len = Int64.to_int (min len max_read_len) in + read ic read_len >>= function + | "" -> return Done + | buf -> + remaining := + Int64.sub !remaining (Int64.of_int (String.length buf)); + return + (match !remaining with 0L -> Final_chunk buf | _ -> Chunk buf)) (* TODO enforce that the correct length is written? *) let write = write @@ -115,41 +114,34 @@ module Make(IO : S.IO) = struct the remote party). *) let read ic () = read ic 4096 >>= fun buf -> - if buf = "" then return Done - else return (Chunk buf) + if buf = "" then return Done else return (Chunk buf) let write = write end - let write_and_flush fn oc buf = - fn oc buf >>= fun () -> - IO.flush oc + let write_and_flush fn oc buf = fn oc buf >>= fun () -> IO.flush oc - let make_reader = - function + let make_reader = function | Chunked -> Chunked.read ~remaining:(ref 0L) | Fixed len -> Fixed.read ~remaining:(ref len) | Unknown -> Unknown.read let write_ignore_blank writer io s = - if String.length s = 0 - then return () - else writer io s + if String.length s = 0 then return () else writer io s - let make_writer ?(flush=false) mode = + let make_writer ?(flush = false) mode = match flush with - | false -> begin + | false -> ( match mode with | Chunked -> Chunked.write | Fixed _ -> Fixed.write - | Unknown -> Unknown.write - end - | true -> begin - match mode with + | Unknown -> Unknown.write) + | true -> + (match mode with | Chunked -> write_and_flush Chunked.write | Fixed _ -> write_and_flush Fixed.write - | Unknown -> write_and_flush Unknown.write - end |> write_ignore_blank + | Unknown -> write_and_flush Unknown.write) + |> write_ignore_blank let read reader = reader () let write writer buf = writer buf diff --git a/cohttp/src/transfer_io.mli b/cohttp/src/transfer_io.mli index 406c40c1b1..d06a47ccf6 100644 --- a/cohttp/src/transfer_io.mli +++ b/cohttp/src/transfer_io.mli @@ -15,13 +15,13 @@ }}}*) open Transfer -module Make(IO : S.IO) : sig + +module Make (IO : S.IO) : sig type reader type writer val make_reader : encoding -> IO.ic -> reader val make_writer : ?flush:bool -> encoding -> IO.oc -> writer - val read : reader -> chunk IO.t val write : writer -> string -> unit IO.t end diff --git a/cohttp/test/test_accept.ml b/cohttp/test/test_accept.ml index 3b350b6076..914830073f 100644 --- a/cohttp/test/test_accept.ml +++ b/cohttp/test/test_accept.ml @@ -16,167 +16,172 @@ module A = Cohttp.Accept -let suite_of - : type a. (string option -> a) - -> a Alcotest.testable - -> (string * a) list - -> _ list - = fun pf t -> - List.map (fun (s, expected) -> - let test () = - Alcotest.check t s (pf (Some s)) expected in - (s, `Quick, test)) - -let suite_of_fail - : type a. (string option -> a) - -> a Alcotest.testable - -> (string * exn) list - -> _ list - = fun pf _ -> - List.map (fun (s, e) -> - let test () = - Alcotest.check_raises s e (fun () -> ignore (pf (Some s))) in - (s, `Quick, test)) - -let suite_to_string_of - : type a. (a -> string) - -> (a * string) list - -> _ list - = fun pf -> - List.map (fun (v, expected_str) -> - let test () = - Alcotest.(check string expected_str expected_str (pf v)) in - (expected_str, `Quick, test)) - -let suite_to_string_of_fail - : type a. (a -> string) - -> (a * string * exn) list - -> _ list - = fun pf -> - List.map (fun (v, descr, e) -> - let test () = - Alcotest.(check_raises descr e (fun () -> ignore (pf v))) in - ("", `Quick, test)) - -let valid_media_ranges = [ - "text/plain", [1000,(A.MediaType ("text","plain"),[])]; - "text/*", [1000,(A.AnyMediaSubtype "text",[])]; - "*/*", [1000,(A.AnyMedia,[])]; - "*/*;q=1", [1000,(A.AnyMedia,[])]; - "*/*;q=0", [0,(A.AnyMedia,[])]; - "*/*;q=1.", [1000,(A.AnyMedia,[])]; - "*/*;q=1.0", [1000,(A.AnyMedia,[])]; - "*/*;q=.0", [0,(A.AnyMedia,[])]; - "*/*;q=0.", [0,(A.AnyMedia,[])]; - "*/*;q=0.1", [100,(A.AnyMedia,[])]; - "image/*,text/*", [ - 1000,(A.AnyMediaSubtype "image",[]); - 1000,(A.AnyMediaSubtype "text",[]); - ]; - "text/plain; q=0.8; charset=utf-8,text/HTML;charset=utf-8;q=0.9", [ - 800,(A.MediaType ("text","plain"),["charset","utf-8"]); - 900,(A.MediaType ("text","html"),["charset","utf-8"]); - ]; - "text/*;foo=\"bar\"", [1000,(A.AnyMediaSubtype "text",["foo","bar"])]; - "*/*;qu=\"\\\"\"", [1000,(A.AnyMedia,["qu","\""])]; - "*/*;f=\";q=0,text/plain\"", [1000,(A.AnyMedia,["f",";q=0,text/plain"])]; -] - -let invalid_media_ranges = [ - "*/*;q=.", Parsing.Parse_error; -] +let suite_of : + type a. + (string option -> a) -> a Alcotest.testable -> (string * a) list -> _ list = + fun pf t -> + List.map (fun (s, expected) -> + let test () = Alcotest.check t s (pf (Some s)) expected in + (s, `Quick, test)) + +let suite_of_fail : + type a. + (string option -> a) -> a Alcotest.testable -> (string * exn) list -> _ list + = + fun pf _ -> + List.map (fun (s, e) -> + let test () = + Alcotest.check_raises s e (fun () -> ignore (pf (Some s))) + in + (s, `Quick, test)) + +let suite_to_string_of : type a. (a -> string) -> (a * string) list -> _ list = + fun pf -> + List.map (fun (v, expected_str) -> + let test () = Alcotest.(check string expected_str expected_str (pf v)) in + (expected_str, `Quick, test)) + +let suite_to_string_of_fail : + type a. (a -> string) -> (a * string * exn) list -> _ list = + fun pf -> + List.map (fun (v, descr, e) -> + let test () = Alcotest.(check_raises descr e (fun () -> ignore (pf v))) in + ("", `Quick, test)) + +let valid_media_ranges = + [ + ("text/plain", [ (1000, (A.MediaType ("text", "plain"), [])) ]); + ("text/*", [ (1000, (A.AnyMediaSubtype "text", [])) ]); + ("*/*", [ (1000, (A.AnyMedia, [])) ]); + ("*/*;q=1", [ (1000, (A.AnyMedia, [])) ]); + ("*/*;q=0", [ (0, (A.AnyMedia, [])) ]); + ("*/*;q=1.", [ (1000, (A.AnyMedia, [])) ]); + ("*/*;q=1.0", [ (1000, (A.AnyMedia, [])) ]); + ("*/*;q=.0", [ (0, (A.AnyMedia, [])) ]); + ("*/*;q=0.", [ (0, (A.AnyMedia, [])) ]); + ("*/*;q=0.1", [ (100, (A.AnyMedia, [])) ]); + ( "image/*,text/*", + [ + (1000, (A.AnyMediaSubtype "image", [])); + (1000, (A.AnyMediaSubtype "text", [])); + ] ); + ( "text/plain; q=0.8; charset=utf-8,text/HTML;charset=utf-8;q=0.9", + [ + (800, (A.MediaType ("text", "plain"), [ ("charset", "utf-8") ])); + (900, (A.MediaType ("text", "html"), [ ("charset", "utf-8") ])); + ] ); + ( "text/*;foo=\"bar\"", + [ (1000, (A.AnyMediaSubtype "text", [ ("foo", "bar") ])) ] ); + ("*/*;qu=\"\\\"\"", [ (1000, (A.AnyMedia, [ ("qu", "\"") ])) ]); + ( "*/*;f=\";q=0,text/plain\"", + [ (1000, (A.AnyMedia, [ ("f", ";q=0,text/plain") ])) ] ); + ] + +let invalid_media_ranges = [ ("*/*;q=.", Parsing.Parse_error) ] let valid_media_ranges_suite = let t_media_ranges = - Alcotest.testable (Fmt.of_to_string A.string_of_media_ranges) (=) in + Alcotest.testable (Fmt.of_to_string A.string_of_media_ranges) ( = ) + in suite_of A.media_ranges t_media_ranges valid_media_ranges let invalid_media_ranges_suite = let t_media_ranges = - Alcotest.testable (Fmt.of_to_string A.string_of_media_ranges) (=) in + Alcotest.testable (Fmt.of_to_string A.string_of_media_ranges) ( = ) + in suite_of_fail A.media_ranges t_media_ranges invalid_media_ranges -let valid_qualities = [ - (1000,(A.AnyMedia,[])), "*/*;q=1"; - (0,(A.AnyMedia,[])), "*/*;q=0.000"; - (353,(A.AnyMedia,[])), "*/*;q=0.353"; - (25,(A.AnyMedia,[])), "*/*;q=0.025"; - (1,(A.AnyMedia,[])), "*/*;q=0.001"; -] +let valid_qualities = + [ + ((1000, (A.AnyMedia, [])), "*/*;q=1"); + ((0, (A.AnyMedia, [])), "*/*;q=0.000"); + ((353, (A.AnyMedia, [])), "*/*;q=0.353"); + ((25, (A.AnyMedia, [])), "*/*;q=0.025"); + ((1, (A.AnyMedia, [])), "*/*;q=0.001"); + ] -let invalid_qualities = [ - (-3,(A.AnyMedia,[])), "negative", Invalid_argument "qvalue -3 must be positive"; - (1001,(A.AnyMedia,[])), "bigger than 1000", Invalid_argument "qvalue 1001 must be less than 1000"; -] +let invalid_qualities = + [ + ( (-3, (A.AnyMedia, [])), + "negative", + Invalid_argument "qvalue -3 must be positive" ); + ( (1001, (A.AnyMedia, [])), + "bigger than 1000", + Invalid_argument "qvalue 1001 must be less than 1000" ); + ] let valid_qualities_suite = - suite_to_string_of - (fun (q,a) -> A.string_of_media_range a q) valid_qualities + suite_to_string_of (fun (q, a) -> A.string_of_media_range a q) valid_qualities let invalid_qualities_suite = suite_to_string_of_fail - (fun (q, a) -> A.string_of_media_range a q) invalid_qualities - -let valid_charsets = [ - "utf-8", [1000,A.Charset "utf-8"]; - "UTF-8", [1000,A.Charset "utf-8"]; - "iso-8859-1", [1000,A.Charset "iso-8859-1"]; - "ISO-8859-1; q = 0.8, *; q=0.7", [ - 800,A.Charset "iso-8859-1"; - 700,A.AnyCharset; - ]; -] + (fun (q, a) -> A.string_of_media_range a q) + invalid_qualities + +let valid_charsets = + [ + ("utf-8", [ (1000, A.Charset "utf-8") ]); + ("UTF-8", [ (1000, A.Charset "utf-8") ]); + ("iso-8859-1", [ (1000, A.Charset "iso-8859-1") ]); + ( "ISO-8859-1; q = 0.8, *; q=0.7", + [ (800, A.Charset "iso-8859-1"); (700, A.AnyCharset) ] ); + ] let valid_charsets_suite = let t_charsets = - Alcotest.testable (Fmt.of_to_string A.string_of_charsets) (=) in + Alcotest.testable (Fmt.of_to_string A.string_of_charsets) ( = ) + in suite_of A.charsets t_charsets valid_charsets -let valid_encodings = [ - "compress, gzip", [1000,A.Compress; 1000,A.Gzip]; - "", []; - "*", [1000, A.AnyEncoding]; - "compress;q=0.5, gzip;q=1.0", [500,A.Compress; 1000,A.Gzip]; - "Gzip;q=1.0, identity; q=0.5, *;q=0", [ - 1000,A.Gzip; - 500,A.Identity; - 0,A.AnyEncoding; - ]; -] +let valid_encodings = + [ + ("compress, gzip", [ (1000, A.Compress); (1000, A.Gzip) ]); + ("", []); + ("*", [ (1000, A.AnyEncoding) ]); + ("compress;q=0.5, gzip;q=1.0", [ (500, A.Compress); (1000, A.Gzip) ]); + ( "Gzip;q=1.0, identity; q=0.5, *;q=0", + [ (1000, A.Gzip); (500, A.Identity); (0, A.AnyEncoding) ] ); + ] let valid_encodings_suite = let t_encodings = - Alcotest.testable (Fmt.of_to_string A.string_of_encodings) (=) in + Alcotest.testable (Fmt.of_to_string A.string_of_encodings) ( = ) + in suite_of A.encodings t_encodings valid_encodings -let valid_languages = [ - "en",[1000,A.Language["en"]]; - "en-US",[1000,A.Language["en";"us"]]; - "en-cockney",[1000,A.Language["en";"cockney"]]; - "i-cherokee",[1000,A.Language["i";"cherokee"]]; - "x-pig-latin",[1000,A.Language["x";"pig";"latin"]]; - "da, en-gb;q=0.8, en;q=0.7",[ - 1000,A.Language["da"]; - 800,A.Language["en";"gb"]; - 700,A.Language["en"]; - ]; - "en-US, *;q=0.9",[1000,A.Language["en";"us"]; 900,A.AnyLanguage]; -] +let valid_languages = + [ + ("en", [ (1000, A.Language [ "en" ]) ]); + ("en-US", [ (1000, A.Language [ "en"; "us" ]) ]); + ("en-cockney", [ (1000, A.Language [ "en"; "cockney" ]) ]); + ("i-cherokee", [ (1000, A.Language [ "i"; "cherokee" ]) ]); + ("x-pig-latin", [ (1000, A.Language [ "x"; "pig"; "latin" ]) ]); + ( "da, en-gb;q=0.8, en;q=0.7", + [ + (1000, A.Language [ "da" ]); + (800, A.Language [ "en"; "gb" ]); + (700, A.Language [ "en" ]); + ] ); + ( "en-US, *;q=0.9", + [ (1000, A.Language [ "en"; "us" ]); (900, A.AnyLanguage) ] ); + ] let valid_languages_suite = let t_languages = - Alcotest.testable (Fmt.of_to_string A.string_of_languages) (=) in + Alcotest.testable (Fmt.of_to_string A.string_of_languages) ( = ) + in suite_of A.languages t_languages valid_languages let () = Printexc.record_backtrace true let () = - Alcotest.run "test_accept" [ - "valid string to media range", valid_media_ranges_suite; - "invalid string to media range", invalid_media_ranges_suite; - "valid media range to string", valid_qualities_suite; - "invalid media range to string", invalid_qualities_suite; - "valid string to charset", valid_charsets_suite; - "valid string to encoding", valid_encodings_suite; - "valid string to language", valid_languages_suite; - ] + Alcotest.run "test_accept" + [ + ("valid string to media range", valid_media_ranges_suite); + ("invalid string to media range", invalid_media_ranges_suite); + ("valid media range to string", valid_qualities_suite); + ("invalid media range to string", invalid_qualities_suite); + ("valid string to charset", valid_charsets_suite); + ("valid string to encoding", valid_encodings_suite); + ("valid string to language", valid_languages_suite); + ] diff --git a/cohttp/test/test_body.ml b/cohttp/test/test_body.ml index ca680a01c4..f328d306f0 100644 --- a/cohttp/test/test_body.ml +++ b/cohttp/test/test_body.ml @@ -1,19 +1,23 @@ let test_if_body_empty () = - let tests = Cohttp.Body.[ - "empty string", of_string "", true - ; "empty list of strings", of_string_list [], true - ; "list of strings with empty bytes", of_string_list [""; ""; ""], true - ; "non empty list of strings", of_string_list [""; "foo"; "bar"], false - ] in - List.iter (fun (name, body, expected) -> - Alcotest.(check bool) name (Cohttp.Body.is_empty body) expected - ) tests + let tests = + Cohttp.Body. + [ + ("empty string", of_string "", true); + ("empty list of strings", of_string_list [], true); + ("list of strings with empty bytes", of_string_list [ ""; ""; "" ], true); + ("non empty list of strings", of_string_list [ ""; "foo"; "bar" ], false); + ] + in + List.iter + (fun (name, body, expected) -> + Alcotest.(check bool) name (Cohttp.Body.is_empty body) expected) + tests let () = Printexc.record_backtrace true let () = - Alcotest.run "test_body" [ - "Query body information", [ - "Check if body is empty", `Quick, test_if_body_empty; + Alcotest.run "test_body" + [ + ( "Query body information", + [ ("Check if body is empty", `Quick, test_if_body_empty) ] ); ] - ] diff --git a/cohttp/test/test_header.ml b/cohttp/test/test_header.ml index ca127a4052..7c83edc776 100644 --- a/cohttp/test/test_header.ml +++ b/cohttp/test/test_header.ml @@ -14,10 +14,9 @@ *}}}*) open Printf - module String_io = Cohttp__String_io -module StringResponse = Cohttp.Response.Make(String_io.M) -module HIO = Cohttp__Header_io.Make(String_io.M) +module StringResponse = Cohttp.Response.Make (String_io.M) +module HIO = Cohttp__Header_io.Make (String_io.M) module H = Cohttp.Header let aes = Alcotest.check Alcotest.string @@ -26,33 +25,40 @@ let aeso = Alcotest.check Alcotest.(option string) let t_credentials = Alcotest.testable (fun fmt c -> - let sexp = Cohttp.Auth.sexp_of_credential c in - Sexplib0.Sexp.pp_hum fmt sexp - ) (=) + let sexp = Cohttp.Auth.sexp_of_credential c in + Sexplib0.Sexp.pp_hum fmt sexp) + ( = ) let valid_auth () = let auth = `Basic ("Aladdin", "open sesame") in let h = H.add_authorization (H.init ()) auth in let digest = H.get h "authorization" in aeso "valid_auth 1" digest (Some "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ=="); - Alcotest.check (Alcotest.option t_credentials) + Alcotest.check + (Alcotest.option t_credentials) "valid_auth 2" (H.get_authorization h) (Some auth) let valid_set_cookie () = - let c = Cohttp.Cookie.Set_cookie_hdr.make ~expiration:`Session - ~path:"/foo/bar" ~domain:"ocaml.org" - ~secure:true ~http_only:true ("key", "value") in + let c = + Cohttp.Cookie.Set_cookie_hdr.make ~expiration:`Session ~path:"/foo/bar" + ~domain:"ocaml.org" ~secure:true ~http_only:true ("key", "value") + in let k, v = Cohttp.Cookie.Set_cookie_hdr.serialize ~version:`HTTP_1_0 c in aes "header key" "Set-Cookie" k; - aes "header value" "key=value; domain=ocaml.org; path=/foo/bar; secure; httponly" v; - let c = Cohttp.Cookie.Set_cookie_hdr.make ~expiration:(`Max_age 100L) - ~path:"/foo/bar" ~domain:"ocaml.org" ("key", "value") in + aes "header value" + "key=value; domain=ocaml.org; path=/foo/bar; secure; httponly" v; + let c = + Cohttp.Cookie.Set_cookie_hdr.make ~expiration:(`Max_age 100L) + ~path:"/foo/bar" ~domain:"ocaml.org" ("key", "value") + in let k, v = Cohttp.Cookie.Set_cookie_hdr.serialize ~version:`HTTP_1_0 c in aes "header key2" "Set-Cookie" k; - aes "header value2" "key=value; Max-Age=100; domain=ocaml.org; path=/foo/bar" v; + aes "header value2" "key=value; Max-Age=100; domain=ocaml.org; path=/foo/bar" + v; let k, v = Cohttp.Cookie.Set_cookie_hdr.serialize ~version:`HTTP_1_1 c in aes "header key 1.1" "Set-Cookie2" k; - aes "header value 1.1" "Domain=ocaml.org; Max-Age=100; Path=/foo/bar; Version=1" v + aes "header value 1.1" + "Domain=ocaml.org; Max-Age=100; Path=/foo/bar; Version=1" v let cookie_printer x = String.concat "; " (List.map (fun (x, y) -> x ^ ":" ^ y) x) @@ -60,29 +66,29 @@ let cookie_printer x = let t_cookies = Alcotest.(list (pair string string)) let cookie_with_eq_val () = - let cookies = [("test","me=")] in - let (k, v) = Cohttp.Cookie.Cookie_hdr.serialize cookies in - let h = Cohttp.Header.of_list [ k, v ] in + let cookies = [ ("test", "me=") ] in + let k, v = Cohttp.Cookie.Cookie_hdr.serialize cookies in + let h = Cohttp.Header.of_list [ (k, v) ] in let cookies = Cohttp.Cookie.Cookie_hdr.extract h in - Alcotest.check t_cookies "cookie_with_eq_val" cookies ["test", "me="] + Alcotest.check t_cookies "cookie_with_eq_val" cookies [ ("test", "me=") ] let ignores_empty_cookie () = - let cookies = ["foo", "bar"] in - let (k, v) = Cohttp.Cookie.Cookie_hdr.serialize cookies in + let cookies = [ ("foo", "bar") ] in + let k, v = Cohttp.Cookie.Cookie_hdr.serialize cookies in (* prepend an invalid empty component *) let v = "; " ^ v in - let h = Cohttp.Header.of_list [ k, v ] in + let h = Cohttp.Header.of_list [ (k, v) ] in let cookies = Cohttp.Cookie.Cookie_hdr.extract h in - Alcotest.check t_cookies "cookie" cookies ["foo", "bar"] + Alcotest.check t_cookies "cookie" cookies [ ("foo", "bar") ] let valid_cookie () = - let cookies = [ "foo", "bar"; "a", "b" ] in + let cookies = [ ("foo", "bar"); ("a", "b") ] in let k, v = Cohttp.Cookie.Cookie_hdr.serialize cookies in aes "key" "cookie" k; aes "value" "foo=bar; a=b" v; - let h = Cohttp.Header.of_list [ k, v ] in + let h = Cohttp.Header.of_list [ (k, v) ] in let cookies = Cohttp.Cookie.Cookie_hdr.extract h in - Alcotest.check t_cookies "headers" [ "foo", "bar"; "a", "b" ] cookies + Alcotest.check t_cookies "headers" [ ("foo", "bar"); ("a", "b") ] cookies let opt_printer f = function | None -> "nothing" @@ -91,8 +97,10 @@ let opt_printer f = function let get_media_type () = let mt = " foo/bar ; charset=UTF-8" in let header = Cohttp.Header.init_with "content-type" mt in - Alcotest.check Alcotest.(option string) "media type" - (Some "foo/bar") (Cohttp.Header.get_media_type header) + Alcotest.check + Alcotest.(option string) + "media type" (Some "foo/bar") + (Cohttp.Header.get_media_type header) let list_valued_header () = let h = H.init () in @@ -101,10 +109,11 @@ let list_valued_header () = aeso "list valued header" (H.get h "accept") (Some "bar,foo") let t_header = - Alcotest.testable (fun fmt h -> + Alcotest.testable + (fun fmt h -> let sexp = Cohttp.Header.sexp_of_t h in - Sexplib0.Sexp.pp_hum fmt sexp - ) (fun x y -> Cohttp.Header.compare x y = 0) + Sexplib0.Sexp.pp_hum fmt sexp) + (fun x y -> Cohttp.Header.compare x y = 0) let large_header () = let sz = 1024 * 1024 * 100 in @@ -122,432 +131,496 @@ let large_header () = let many_headers () = let size = 1000000 in let rec add_header num h = - match num with + match num with | 0 -> h | n -> - let k = sprintf "h%d" n in - let v = sprintf "v%d" n in - let h = H.add h k v in - add_header (num - 1) h + let k = sprintf "h%d" n in + let v = sprintf "v%d" n in + let h = H.add h k v in + add_header (num - 1) h in let h = add_header size (H.init ()) in Alcotest.(check int) "many_headers" (List.length (H.to_list h)) size module Updates = struct - let h = H.init () - |> fun h -> H.add h "first" "1" - |> fun h -> H.add h "second" "2" - |> fun h -> H.add h "accept" "foo" - |> fun h -> H.add h "accept" "bar" + let h = + H.init () |> fun h -> + H.add h "first" "1" |> fun h -> + H.add h "second" "2" |> fun h -> + H.add h "accept" "foo" |> fun h -> H.add h "accept" "bar" let replace_headers_if_exists () = let h = H.replace h "second" "2a" in - Alcotest.(check (option string)) "replace_existing_header" (Some "2a") (H.get h "second") + Alcotest.(check (option string)) + "replace_existing_header" (Some "2a") (H.get h "second") let replace_headers_if_absent () = let h = H.replace h "third" "3" in - Alcotest.(check (option string)) "replace_new_header" (Some "3") (H.get h "third") + Alcotest.(check (option string)) + "replace_new_header" (Some "3") (H.get h "third") let update_headers_if_exists () = - let h1 = H.update h "second" (function | Some _ -> Some "2a" | None -> None) in + let h1 = + H.update h "second" (function Some _ -> Some "2a" | None -> None) + in let h2 = H.replace h "second" "2a" in Alcotest.(check t_header) "update_existing_header" h1 h2 - + let update_headers_if_exists_rm () = - let h1 = H.update h "second" (function | Some _ -> None | None -> Some "3") in + let h1 = + H.update h "second" (function Some _ -> None | None -> Some "3") + in let h2 = H.remove h "second" in Alcotest.(check t_header) "update_remove_header" h1 h2 - + let update_headers_if_absent_add () = - let h = H.update h "third" (function | Some _ -> None | None -> Some "3") in - Alcotest.(check (option string)) "update_add_new_header" (Some "3") (H.get h "third") - + let h = H.update h "third" (function Some _ -> None | None -> Some "3") in + Alcotest.(check (option string)) + "update_add_new_header" (Some "3") (H.get h "third") + let update_headers_if_absent_rm () = let h1 = H.update h "third" (function _ -> None) in Alcotest.(check t_header) "update_remove_absent_header" h h1 let update_headers_if_exists_multi () = - let h1 = H.update h "accept" (function | Some v -> Some ("baz,"^v) | None -> None) in + let h1 = + H.update h "accept" (function + | Some v -> Some ("baz," ^ v) + | None -> None) + in let h2 = H.add h "accept" "baz" in - Alcotest.(check (option string)) "update_existing_header_multivalued" (H.get h1 "accept") (H.get h2 "accept") + Alcotest.(check (option string)) + "update_existing_header_multivalued" (H.get h1 "accept") + (H.get h2 "accept") let update_headers_if_absent () = - let h1 = H.update h "third" (function | Some _ -> Some "3" | None -> None) in + let h1 = + H.update h "third" (function Some _ -> Some "3" | None -> None) + in Alcotest.(check t_header) "update_new_header: unchanged" h h1; - Alcotest.(check (option string)) "update_new_header: map unchanged" None (H.get h "third") + Alcotest.(check (option string)) + "update_new_header: map unchanged" None (H.get h "third") end module Content_range = struct - let h1 = H.of_list ["Content-Length", "123"] - let h2 = H.of_list ["Content-Range", "bytes 200-300/1000"] + let h1 = H.of_list [ ("Content-Length", "123") ] + let h2 = H.of_list [ ("Content-Range", "bytes 200-300/1000") ] let aeio = Alcotest.(check (option int64)) - let none () = - aeio "none" None (H.init () |> H.get_content_range) + let none () = aeio "none" None (H.init () |> H.get_content_range) + let content_length () = aeio "content_length" (Some 123L) (H.get_content_range h1) + let content_range () = aeio "content_range" (Some 101L) (H.get_content_range h2) end module Link = Cohttp.Link -let t_links = Alcotest.testable (fun fmt links -> - Format.pp_print_list ~pp_sep:Format.pp_print_newline - (fun fmt l -> Format.fprintf fmt "%s" (Link.to_string l)) - fmt links - ) (=) +let t_links = + Alcotest.testable + (fun fmt links -> + Format.pp_print_list ~pp_sep:Format.pp_print_newline + (fun fmt l -> Format.fprintf fmt "%s" (Link.to_string l)) + fmt links) + ( = ) let headers_of_response test_name response_string = String_io.M.( - StringResponse.read (String_io.open_in response_string) - >>= function + StringResponse.read (String_io.open_in response_string) >>= function | `Ok resp -> Cohttp.Response.headers resp - | _ -> failwith (test_name ^ " response parse failed") - ) + | _ -> failwith (test_name ^ " response parse failed")) let get_resp lines = - "HTTP/1.1 200 OK\r\n"^(String.concat "\r\n" lines)^"\r\n\r\n" + "HTTP/1.1 200 OK\r\n" ^ String.concat "\r\n" lines ^ "\r\n\r\n" let empty_uri = Uri.of_string "" let link_simple () = let next_tgt = "/page/2" in - let resp = get_resp ["Link: <"^next_tgt^">; rel=next"] in + let resp = get_resp [ "Link: <" ^ next_tgt ^ ">; rel=next" ] in let headers = headers_of_response "link_simple" resp in - Alcotest.check t_links "link_simple" Link.([{ - context = empty_uri; - arc = Arc.({ empty with relation=Rel.([next]) }); - target = Uri.of_string next_tgt; - }]) (H.get_links headers) + Alcotest.check t_links "link_simple" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ next ] }; + target = Uri.of_string next_tgt; + }; + ] + (H.get_links headers) let link_multi_rel () = let next_tgt = "/page/2" in - let resp = get_resp ["Link: <"^next_tgt^">; rel=\"next last\""] in + let resp = get_resp [ "Link: <" ^ next_tgt ^ ">; rel=\"next last\"" ] in let headers = headers_of_response "link_multi_rel" resp in - Alcotest.check t_links "link_multi_rel" Link.([{ - context = empty_uri; - arc = Arc.({ empty with relation=Rel.([next; last]) }); - target = Uri.of_string next_tgt; - }]) (H.get_links headers) + Alcotest.check t_links "link_multi_rel" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ next; last ] }; + target = Uri.of_string next_tgt; + }; + ] + (H.get_links headers) let link_multi_line () = let self_tgt = "/page/1" in let next_tgt = "/page/2" in - let resp = get_resp [ - "Link: <"^next_tgt^">; rel=\"next\""; - "Link: <"^self_tgt^">; rel=self"; - ] in + let resp = + get_resp + [ + "Link: <" ^ next_tgt ^ ">; rel=\"next\""; + "Link: <" ^ self_tgt ^ ">; rel=self"; + ] + in let headers = headers_of_response "link_multi_line" resp in - Alcotest.check t_links "link_multi_line" Link.([ - { - context = empty_uri; - arc = Arc.({ empty with relation=Rel.([next]) }); - target = Uri.of_string next_tgt; - }; - { - context = empty_uri; - arc = Arc.({ empty with relation=Rel.([self]) }); - target = Uri.of_string self_tgt; - }; - ]) (H.get_links headers) + Alcotest.check t_links "link_multi_line" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ next ] }; + target = Uri.of_string next_tgt; + }; + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ self ] }; + target = Uri.of_string self_tgt; + }; + ] + (H.get_links headers) let link_multi_multi () = let next_tgt = "/page/2" in let last_tgt = "/page/3" in - let resp = get_resp [ - "Link: <"^next_tgt^">; rel=\"next\", <"^last_tgt^">; rel=last"; - ] in + let resp = + get_resp + [ "Link: <" ^ next_tgt ^ ">; rel=\"next\", <" ^ last_tgt ^ ">; rel=last" ] + in let headers = headers_of_response "link_multi_multi" resp in - Alcotest.check t_links "link_multi_multi" Link.([ - { - context = empty_uri; - arc = Arc.({ empty with relation=Rel.([next]) }); - target = Uri.of_string next_tgt; - }; - { - context = empty_uri; - arc = Arc.({ empty with relation=Rel.([last]) }); - target = Uri.of_string last_tgt; - }; - ]) (H.get_links headers) + Alcotest.check t_links "link_multi_multi" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ next ] }; + target = Uri.of_string next_tgt; + }; + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ last ] }; + target = Uri.of_string last_tgt; + }; + ] + (H.get_links headers) let link_rel_uri () = let uri_tgt = "/page/2" in let uri_s = "http://example.com/a,valid;uri" in - let resp = get_resp [ - "Link: <"^uri_tgt^">; rel=\"next "^uri_s^"\"; hreflang=en"; - ] in + let resp = + get_resp + [ "Link: <" ^ uri_tgt ^ ">; rel=\"next " ^ uri_s ^ "\"; hreflang=en" ] + in let headers = headers_of_response "link_rel_uri" resp in - Alcotest.check t_links "link_rel_uri" Link.([ - { - context = empty_uri; - arc = Arc.({ empty with - relation = Rel.([ - next; - extension (Uri.of_string uri_s); - ]); - hreflang = Some "en"; - }); - target = Uri.of_string uri_tgt; - }; - ]) (H.get_links headers) + Alcotest.check t_links "link_rel_uri" + Link. + [ + { + context = empty_uri; + arc = + Arc. + { + empty with + relation = Rel.[ next; extension (Uri.of_string uri_s) ]; + hreflang = Some "en"; + }; + target = Uri.of_string uri_tgt; + }; + ] + (H.get_links headers) let link_anchor () = let anchor = "/page/2" in let target = "/page/1" in - let resp = get_resp [ - "Link: <"^target^">; anchor=\""^anchor^"\"; rel=prev"; - ] in + let resp = + get_resp [ "Link: <" ^ target ^ ">; anchor=\"" ^ anchor ^ "\"; rel=prev" ] + in let headers = headers_of_response "link_rel_uri" resp in - Alcotest.check t_links "link_anchor" Link.([ - { - context = Uri.of_string anchor; - arc = Arc.({ empty with - relation = Rel.([ - prev; - ]); - }); - target = Uri.of_string target; - }; - ]) (H.get_links headers) + Alcotest.check t_links "link_anchor" + Link. + [ + { + context = Uri.of_string anchor; + arc = Arc.{ empty with relation = Rel.[ prev ] }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) let link_rev () = let anchor = "/page/2" in - let resp = get_resp [ - "Link: <"^anchor^">; rev=prev"; - ] in + let resp = get_resp [ "Link: <" ^ anchor ^ ">; rev=prev" ] in let headers = headers_of_response "link_rev" resp in - Alcotest.check t_links "link_multi_line" Link.([ - { - context = Uri.of_string anchor; - arc = Arc.({ empty with - reverse = true; - relation = Rel.([ - prev; - ]); - }); - target = empty_uri; - }; - ]) (H.get_links headers) + Alcotest.check t_links "link_multi_line" + Link. + [ + { + context = Uri.of_string anchor; + arc = Arc.{ empty with reverse = true; relation = Rel.[ prev ] }; + target = empty_uri; + }; + ] + (H.get_links headers) let link_media () = let target = "/page/2" in - let resp = get_resp [ - "Link: <"^target^">; media=screen"; - ] in + let resp = get_resp [ "Link: <" ^ target ^ ">; media=screen" ] in let headers = headers_of_response "link_media" resp in - Alcotest.check t_links "link_media" Link.([ - { - context = empty_uri; - arc = Arc.({ empty with - media = Some "screen"; - }); - target = Uri.of_string target; - }; - ]) (H.get_links headers) + Alcotest.check t_links "link_media" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with media = Some "screen" }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) let link_media_complex () = let target = "/page/2" in - let resp = get_resp [ - "Link: <"^target^">; media=\"screen, print and dpi < 200\""; - ] in + let resp = + get_resp [ "Link: <" ^ target ^ ">; media=\"screen, print and dpi < 200\"" ] + in let headers = headers_of_response "link_media_complex" resp in - Alcotest.check t_links "t_links" Link.([ - { - context = empty_uri; - arc = Arc.({ empty with - media = Some "screen, print and dpi < 200"; - }); - target = Uri.of_string target; - }; - ]) (H.get_links headers) + Alcotest.check t_links "t_links" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with media = Some "screen, print and dpi < 200" }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) let link_title () = let target = "/page/2" in - let resp = get_resp [ - "Link: <"^target^">; title=\"Next!\"; rel=next"; - ] in + let resp = get_resp [ "Link: <" ^ target ^ ">; title=\"Next!\"; rel=next" ] in let headers = headers_of_response "link_title" resp in - Alcotest.check t_links "link_title" Link.([ - { - context = empty_uri; - arc = Arc.({ empty with - relation = Rel.([ next ]); - title = Some "Next!"; - }); - target = Uri.of_string target; - }; - ]) (H.get_links headers) + Alcotest.check t_links "link_title" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ next ]; title = Some "Next!" }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) let link_title_star () = let target = "/page/2" in - let resp = get_resp [ - "Link: <"^target^">; title*=UTF-8'en'Next!; rel=next"; - ] in + let resp = + get_resp [ "Link: <" ^ target ^ ">; title*=UTF-8'en'Next!; rel=next" ] + in let headers = headers_of_response "link_title_star" resp in - Alcotest.check t_links "link_title_star" Link.([ - { - context = empty_uri; - arc = Arc.({ empty with - relation = Rel.([ next ]); - title_ext = Some - (Ext.make - ~charset:(Charset.of_string "UTF-8") - ~language:(Language.of_string "en") - "Next!"); - }); - target = Uri.of_string target; - }; - ]) (H.get_links headers) + Alcotest.check t_links "link_title_star" + Link. + [ + { + context = empty_uri; + arc = + Arc. + { + empty with + relation = Rel.[ next ]; + title_ext = + Some + (Ext.make + ~charset:(Charset.of_string "UTF-8") + ~language:(Language.of_string "en") "Next!"); + }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) let link_type_token () = let target = "/page/2" in - let resp = get_resp [ - "Link: <"^target^">; type=text/html; rel=next"; - ] in + let resp = get_resp [ "Link: <" ^ target ^ ">; type=text/html; rel=next" ] in let headers = headers_of_response "link_type_token" resp in - Alcotest.check t_links "link_type_token" Link.([ - { - context = empty_uri; - arc = Arc.({ empty with - relation = Rel.([ next ]); - media_type = Some ("text", "html"); - }); - target = Uri.of_string target; - }; - ]) (H.get_links headers) + Alcotest.check t_links "link_type_token" + Link. + [ + { + context = empty_uri; + arc = + Arc. + { + empty with + relation = Rel.[ next ]; + media_type = Some ("text", "html"); + }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) let link_type_quoted () = let target = "/page/2" in - let resp = get_resp [ - "Link: <"^target^">; type=\"text/html\"; rel=next"; - ] in + let resp = + get_resp [ "Link: <" ^ target ^ ">; type=\"text/html\"; rel=next" ] + in let headers = headers_of_response "link_type_quoted" resp in - Alcotest.check t_links "link_type_quoted" Link.([ - { - context = empty_uri; - arc = Arc.({ empty with - relation = Rel.([ next ]); - media_type = Some ("text", "html"); - }); - target = Uri.of_string target; - }; - ]) (H.get_links headers) + Alcotest.check t_links "link_type_quoted" + Link. + [ + { + context = empty_uri; + arc = + Arc. + { + empty with + relation = Rel.[ next ]; + media_type = Some ("text", "html"); + }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) let link_ext () = let target = "/page/2" in - let resp = get_resp [ - "Link: <"^target^">; see=saw; rel=next"; - ] in + let resp = get_resp [ "Link: <" ^ target ^ ">; see=saw; rel=next" ] in let headers = headers_of_response "link_ext" resp in - Alcotest.check t_links "link_ext" Link.([ - { - context = empty_uri; - arc = Arc.({ empty with - relation = Rel.([ next ]); - extensions = ["see", "saw"]; - }); - target = Uri.of_string target; - }; - ]) (H.get_links headers) + Alcotest.check t_links "link_ext" + Link. + [ + { + context = empty_uri; + arc = + Arc. + { + empty with + relation = Rel.[ next ]; + extensions = [ ("see", "saw") ]; + }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) let link_ext_star () = let target = "/page/2" in - let resp = get_resp [ - "Link: <"^target^">; zig*=''zag; rel=next"; - ] in + let resp = get_resp [ "Link: <" ^ target ^ ">; zig*=''zag; rel=next" ] in let headers = headers_of_response "link_ext" resp in - Alcotest.check t_links "link_ext_star" Link.([ - { - context = empty_uri; - arc = Arc.({ empty with - relation = Rel.([ next ]); - extension_exts = ["zig", - Ext.make - ~charset:(Charset.of_string "") - ~language:(Language.of_string "") - "zag" - ]; - }); - target = Uri.of_string target; - }; - ]) (H.get_links headers) + Alcotest.check t_links "link_ext_star" + Link. + [ + { + context = empty_uri; + arc = + Arc. + { + empty with + relation = Rel.[ next ]; + extension_exts = + [ + ( "zig", + Ext.make ~charset:(Charset.of_string "") + ~language:(Language.of_string "") "zag" ); + ]; + }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) let trim_ws () = - let resp = get_resp ["Age: 281 "] in + let resp = get_resp [ "Age: 281 " ] in let headers = headers_of_response "trim whitespace" resp in aeso "trim_ws" (H.get headers "age") (Some "281") let test_cachecontrol_concat () = - let resp = get_resp ["Cache-Control: public"; - "Cache-Control: max-age:86400"] in - let h = headers_of_response "concat Cache-Control" resp in - aeso "test_cachecontrol_concat" - (Some "public,max-age:86400") (H.get h "Cache-Control") + let resp = + get_resp [ "Cache-Control: public"; "Cache-Control: max-age:86400" ] + in + let h = headers_of_response "concat Cache-Control" resp in + aeso "test_cachecontrol_concat" (Some "public,max-age:86400") + (H.get h "Cache-Control") let transfer_encoding () = - let h = H.of_list ["transfer-encoding", "gzip"; - "transfer-encoding", "chunked"] in + let h = + H.of_list + [ ("transfer-encoding", "gzip"); ("transfer-encoding", "chunked") ] + in let sh = H.to_string h in - aes "transfer_encoding_string_is_ordered" - sh "transfer-encoding: gzip\r\ntransfer-encoding: chunked\r\n\r\n"; + aes "transfer_encoding_string_is_ordered" sh + "transfer-encoding: gzip\r\ntransfer-encoding: chunked\r\n\r\n"; let sh = H.get h "transfer-encoding" in aeso "transfer_encoding_get_is_ordered" (Some "gzip,chunked") sh let () = Printexc.record_backtrace true let () = - Alcotest.run "test_header" [ - "Link", [ - "simple", `Quick, link_simple; - "multiple rels", `Quick, link_multi_rel; - "multiple lines", `Quick, link_multi_line; - "multiheader", `Quick, link_multi_multi; - "rel uri", `Quick, link_rel_uri; - "anchor", `Quick, link_anchor; - "rev", `Quick, link_rev; - "media", `Quick, link_media; - "media complex", `Quick, link_media_complex; - "title", `Quick, link_title; - "title star", `Quick, link_title_star; - "type token", `Quick, link_type_token; - "type quoted", `Quick, link_type_quoted; - "extension", `Quick, link_ext; - "extension star", `Quick, link_ext_star; - ]; - "Media Type", [ - "Media Type", `Quick, get_media_type; - ]; - "Auth", [ - "Valid Auth", `Quick, valid_auth; - ]; - "Cookie", [ - "Valid Set-Cookie", `Quick, valid_set_cookie; - "Valid Cookie", `Quick, valid_cookie; - "Cookie with =", `Quick, cookie_with_eq_val; - "Ignores empty cookie", `Quick, ignores_empty_cookie; - ]; - "Content Range", [ - "none", `Quick, Content_range.none; - "content-length", `Quick, Content_range.content_length; - "content-range", `Quick, Content_range.content_range; - ]; - "Cache Control", [ - "concat", `Quick, test_cachecontrol_concat - ]; - "Header", [ - "get list valued", `Quick, list_valued_header; - "trim whitespace", `Quick, trim_ws; - "replace existing", `Quick, Updates.replace_headers_if_exists; - "replace absent", `Quick, Updates.replace_headers_if_absent; - "update existing", `Quick, Updates.update_headers_if_exists; - "update existing list", `Quick, Updates.update_headers_if_exists_multi; - "update add absent", `Quick, Updates.update_headers_if_absent_add; - "update rm existing", `Quick, Updates.update_headers_if_exists_rm; - "update rm absent", `Quick, Updates.update_headers_if_absent_rm; - "update absent", `Quick, Updates.update_headers_if_absent; - "many headers", `Slow, many_headers; - "transfer encoding is in correct order", `Quick, transfer_encoding; + Alcotest.run "test_header" + [ + ( "Link", + [ + ("simple", `Quick, link_simple); + ("multiple rels", `Quick, link_multi_rel); + ("multiple lines", `Quick, link_multi_line); + ("multiheader", `Quick, link_multi_multi); + ("rel uri", `Quick, link_rel_uri); + ("anchor", `Quick, link_anchor); + ("rev", `Quick, link_rev); + ("media", `Quick, link_media); + ("media complex", `Quick, link_media_complex); + ("title", `Quick, link_title); + ("title star", `Quick, link_title_star); + ("type token", `Quick, link_type_token); + ("type quoted", `Quick, link_type_quoted); + ("extension", `Quick, link_ext); + ("extension star", `Quick, link_ext_star); + ] ); + ("Media Type", [ ("Media Type", `Quick, get_media_type) ]); + ("Auth", [ ("Valid Auth", `Quick, valid_auth) ]); + ( "Cookie", + [ + ("Valid Set-Cookie", `Quick, valid_set_cookie); + ("Valid Cookie", `Quick, valid_cookie); + ("Cookie with =", `Quick, cookie_with_eq_val); + ("Ignores empty cookie", `Quick, ignores_empty_cookie); + ] ); + ( "Content Range", + [ + ("none", `Quick, Content_range.none); + ("content-length", `Quick, Content_range.content_length); + ("content-range", `Quick, Content_range.content_range); + ] ); + ("Cache Control", [ ("concat", `Quick, test_cachecontrol_concat) ]); + ( "Header", + [ + ("get list valued", `Quick, list_valued_header); + ("trim whitespace", `Quick, trim_ws); + ("replace existing", `Quick, Updates.replace_headers_if_exists); + ("replace absent", `Quick, Updates.replace_headers_if_absent); + ("update existing", `Quick, Updates.update_headers_if_exists); + ( "update existing list", + `Quick, + Updates.update_headers_if_exists_multi ); + ("update add absent", `Quick, Updates.update_headers_if_absent_add); + ("update rm existing", `Quick, Updates.update_headers_if_exists_rm); + ("update rm absent", `Quick, Updates.update_headers_if_absent_rm); + ("update absent", `Quick, Updates.update_headers_if_absent); + ("many headers", `Slow, many_headers); + ("transfer encoding is in correct order", `Quick, transfer_encoding); + ] + @ + if Sys.word_size = 64 then [ ("large header", `Slow, large_header) ] + else [] ); ] - @ if Sys.word_size = 64 then ["large header", `Slow, large_header] else [] - ] diff --git a/cohttp/test/test_request.ml b/cohttp/test/test_request.ml index 504390ec18..daded6c1b0 100644 --- a/cohttp/test/test_request.ml +++ b/cohttp/test/test_request.ml @@ -1,7 +1,6 @@ open Cohttp - module String_io = Cohttp__String_io -module StringRequest = Request.Make(String_io.M) +module StringRequest = Request.Make (String_io.M) let uri_userinfo = Uri.of_string "http://foo:bar%2525@ocaml.org" @@ -10,9 +9,7 @@ let header_auth = let h = Header.add_authorization h (`Basic ("qux", "qwerty")) in h -let is_some = function - | None -> false - | Some _ -> true +let is_some = function None -> false | Some _ -> true let header_has_auth _ = Alcotest.check Alcotest.bool "Test header has auth" @@ -27,20 +24,22 @@ let uri_has_userinfo _ = let t_credentials = Alcotest.testable (fun fmt c -> - let sexp = Cohttp.Auth.sexp_of_credential c in - Sexplib0.Sexp.pp_hum fmt sexp - ) (=) + let sexp = Cohttp.Auth.sexp_of_credential c in + Sexplib0.Sexp.pp_hum fmt sexp) + ( = ) let auth_uri_no_override _ = let r = Request.make ~headers:header_auth uri_userinfo in - Alcotest.check (Alcotest.option t_credentials) + Alcotest.check + (Alcotest.option t_credentials) "auth uri no override" (r |> Request.headers |> Header.get_authorization) (Header.get_authorization header_auth) let auth_uri _ = let r = Request.make uri_userinfo in - Alcotest.check (Alcotest.option t_credentials) + Alcotest.check + (Alcotest.option t_credentials) "auth_uri" (r |> Request.headers |> Header.get_authorization) (Some (`Basic ("foo", "bar%25"))) @@ -48,72 +47,78 @@ let auth_uri _ = let t_encoding = Alcotest.testable (fun fmt e -> - let sexp = Cohttp.Transfer.sexp_of_encoding e in - Sexplib0.Sexp.pp fmt sexp) (=) + let sexp = Cohttp.Transfer.sexp_of_encoding e in + Sexplib0.Sexp.pp fmt sexp) + ( = ) let encoding_content_length_header () = - let r = Request.make ~headers:(Cohttp.Header.of_list ["content-length", "100"]) (Uri.of_string "http://someuri.com") in - Alcotest.check t_encoding - "body encoding determined by content-length header" - (r |> Request.encoding) - (Fixed 100L) + let r = + Request.make + ~headers:(Cohttp.Header.of_list [ ("content-length", "100") ]) + (Uri.of_string "http://someuri.com") + in + Alcotest.check t_encoding "body encoding determined by content-length header" + (r |> Request.encoding) (Fixed 100L) let encoding_transfer_encoding_header () = - let r = Request.make ~headers:(Cohttp.Header.of_list ["transfer-encoding", "chunked"]) (Uri.of_string "http://someuri.com") in + let r = + Request.make + ~headers:(Cohttp.Header.of_list [ ("transfer-encoding", "chunked") ]) + (Uri.of_string "http://someuri.com") + in Alcotest.check t_encoding "body encoding determined by transfer-encoding header" - (r |> Request.encoding) - (Chunked) + (r |> Request.encoding) Chunked let encoding_both_headers () = - let r = Request.make ~headers:(Cohttp.Header.of_list ["transfer-encoding", "chunked"; "content-length", "100"]) (Uri.of_string "http://someuri.com") in + let r = + Request.make + ~headers: + (Cohttp.Header.of_list + [ ("transfer-encoding", "chunked"); ("content-length", "100") ]) + (Uri.of_string "http://someuri.com") + in Alcotest.check t_encoding "body encoding with content-length and transfer-encoding headers." - (r |> Request.encoding) - (Chunked) + (r |> Request.encoding) Chunked let encoding_header_opt_argument () = - let r = Request.make ~encoding:Chunked ~headers:(Cohttp.Header.of_list ["content-length", "100"]) (Uri.of_string "http://someuri.com") in + let r = + Request.make ~encoding:Chunked + ~headers:(Cohttp.Header.of_list [ ("content-length", "100") ]) + (Uri.of_string "http://someuri.com") + in Alcotest.check t_encoding "body encoding with content-length and transfer-encoding headers." - (r |> Request.encoding) - (Fixed 100L) + (r |> Request.encoding) (Fixed 100L) -let opt_default default = function - | None -> default - | Some v -> v +let opt_default default = function None -> default | Some v -> v module Parse_result = struct - type 'a t = [`Ok of 'a | `Invalid of string | `Eof] + type 'a t = [ `Ok of 'a | `Invalid of string | `Eof ] + let map t ~f = - match t with - | `Ok x -> `Ok (f x) - | (`Invalid _ | `Eof) as e -> e + match t with `Ok x -> `Ok (f x) | (`Invalid _ | `Eof) as e -> e end -let uri_testable - : Uri.t Alcotest.testable - = Alcotest.testable Uri.pp_hum Uri.equal +let uri_testable : Uri.t Alcotest.testable = + Alcotest.testable Uri.pp_hum Uri.equal -let t_parse_result_uri - : Uri.t Parse_result.t Alcotest.testable - = Alcotest.testable (fun fmt -> function +let t_parse_result_uri : Uri.t Parse_result.t Alcotest.testable = + Alcotest.testable + (fun fmt -> function | `Invalid s -> Format.fprintf fmt "`Invalid %s" s | `Eof -> Format.fprintf fmt "`Eof" - | `Ok u -> Uri.pp_hum fmt u - ) (fun x y -> - match x, y with - | `Ok x, `Ok y -> Uri.equal x y - | x, y -> x = y) + | `Ok u -> Uri.pp_hum fmt u) + (fun x y -> + match (x, y) with `Ok x, `Ok y -> Uri.equal x y | x, y -> x = y) let parse_request_uri_ r (expected : Uri.t Parse_result.t) name = String_io.M.( StringRequest.read (String_io.open_in r) >>= fun (result : Cohttp.Request.t Parse_result.t) -> let uri = Parse_result.map result ~f:Request.uri in - return @@ - Alcotest.check t_parse_result_uri name uri expected - ) + return @@ Alcotest.check t_parse_result_uri name uri expected) let bad_request = `Invalid "bad request URI" @@ -182,26 +187,26 @@ let parse_request_uri_host_path_like_scheme _ = let parse_request_uri_path_like_host_port _ = let path = "//example.net:8080" in - let r = "GET "^path^" HTTP/1.1\r\n\r\n" in + let r = "GET " ^ path ^ " HTTP/1.1\r\n\r\n" in let uri = `Ok (Uri.with_path (Uri.of_string "") path) in parse_request_uri_ r uri "parse_request_uri_path_like_host_port" let parse_request_uri_host_path_like_host_port _ = let path = "//example.net:8080" in - let r = "GET "^path^" HTTP/1.1\r\nHost: example.com\r\n\r\n" in + let r = "GET " ^ path ^ " HTTP/1.1\r\nHost: example.com\r\n\r\n" in let uri = `Ok (Uri.with_path (Uri.of_string "//example.com") path) in parse_request_uri_ r uri "parse_request_uri_host_path_like_host_port" let parse_request_uri_query _ = let pqs = "/?foo" in - let r = "GET "^pqs^" HTTP/1.1\r\n\r\n" in + let r = "GET " ^ pqs ^ " HTTP/1.1\r\n\r\n" in let uri = `Ok (Uri.of_string pqs) in parse_request_uri_ r uri "parse_request_uri_query" let parse_request_uri_host_query _ = let pqs = "/?foo" in - let r = "GET "^pqs^" HTTP/1.1\r\nHost: example.com\r\n\r\n" in - let uri = `Ok (Uri.of_string ("//example.com"^pqs)) in + let r = "GET " ^ pqs ^ " HTTP/1.1\r\nHost: example.com\r\n\r\n" in + let uri = `Ok (Uri.of_string ("//example.com" ^ pqs)) in parse_request_uri_ r uri "parse_request_uri_host_query" let parse_request_uri_query_no_slash _ = @@ -247,52 +252,69 @@ let parse_request_uri_host_traversal _ = let uri_round_trip _ = let expected_uri = Uri.of_string "https://www.example.com/test" in let actual_uri = Request.make expected_uri |> Request.uri in - Alcotest.check uri_testable "Request.make uri round-trip" actual_uri expected_uri + Alcotest.check uri_testable "Request.make uri round-trip" actual_uri + expected_uri let () = Printexc.record_backtrace true let () = - Alcotest.run "test_request" [ - "Auth", [ - "header has auth", `Quick, header_has_auth; - "URI has user info", `Quick, uri_has_userinfo; - "from URI - do not override", `Quick, auth_uri_no_override; - "from URI", `Quick, auth_uri; - ]; - "Encoding", [ - "from content-length header",`Quick, encoding_content_length_header; - "from transfer-encoding header",`Quick, encoding_transfer_encoding_header; - "with both headers",`Quick, encoding_both_headers; - "from both optional argument and headers", `Quick, encoding_header_opt_argument; - ]; - "Parse URI", [ - "simple", `Quick, parse_request_uri; - "with host", `Quick, parse_request_uri_host; - "with host and port", `Quick, parse_request_uri_host_port; - "double slash", `Quick, parse_request_uri_double_slash; - "double slash with host", `Quick, parse_request_uri_host_double_slash; - "triple slash", `Quick, parse_request_uri_triple_slash; - "triple slash with host", `Quick, parse_request_uri_host_triple_slash; - "no slash", `Quick, parse_request_uri_no_slash; - "no slash with host", `Quick, parse_request_uri_host_no_slash; - "empty", `Quick, parse_request_uri_empty; - "empty with host", `Quick, parse_request_uri_host_empty; - "path like scheme", `Quick, parse_request_uri_path_like_scheme; - "path like scheme with host", `Quick, parse_request_uri_host_path_like_scheme; - "path like host:port", `Quick, parse_request_uri_path_like_host_port; - "path like host:port with host", - `Quick, parse_request_uri_host_path_like_host_port; - "with query string", `Quick, parse_request_uri_query; - "with query with host", `Quick, parse_request_uri_host_query; - "no slash with query string", `Quick, parse_request_uri_query_no_slash; - "no slash with query with host", - `Quick, parse_request_uri_host_query_no_slash; - "CONNECT", `Quick, parse_request_connect; - "CONNECT with host", `Quick, parse_request_connect_host; - "OPTIONS", `Quick, parse_request_options; - "OPTIONS with host", `Quick, parse_request_options_host; - "parent traversal", `Quick, parse_request_uri_traversal; - "parent traversal with host", `Quick, parse_request_uri_host_traversal; - "uri round-trip", `Quick, uri_round_trip; - ]; - ] + Alcotest.run "test_request" + [ + ( "Auth", + [ + ("header has auth", `Quick, header_has_auth); + ("URI has user info", `Quick, uri_has_userinfo); + ("from URI - do not override", `Quick, auth_uri_no_override); + ("from URI", `Quick, auth_uri); + ] ); + ( "Encoding", + [ + ("from content-length header", `Quick, encoding_content_length_header); + ( "from transfer-encoding header", + `Quick, + encoding_transfer_encoding_header ); + ("with both headers", `Quick, encoding_both_headers); + ( "from both optional argument and headers", + `Quick, + encoding_header_opt_argument ); + ] ); + ( "Parse URI", + [ + ("simple", `Quick, parse_request_uri); + ("with host", `Quick, parse_request_uri_host); + ("with host and port", `Quick, parse_request_uri_host_port); + ("double slash", `Quick, parse_request_uri_double_slash); + ("double slash with host", `Quick, parse_request_uri_host_double_slash); + ("triple slash", `Quick, parse_request_uri_triple_slash); + ("triple slash with host", `Quick, parse_request_uri_host_triple_slash); + ("no slash", `Quick, parse_request_uri_no_slash); + ("no slash with host", `Quick, parse_request_uri_host_no_slash); + ("empty", `Quick, parse_request_uri_empty); + ("empty with host", `Quick, parse_request_uri_host_empty); + ("path like scheme", `Quick, parse_request_uri_path_like_scheme); + ( "path like scheme with host", + `Quick, + parse_request_uri_host_path_like_scheme ); + ("path like host:port", `Quick, parse_request_uri_path_like_host_port); + ( "path like host:port with host", + `Quick, + parse_request_uri_host_path_like_host_port ); + ("with query string", `Quick, parse_request_uri_query); + ("with query with host", `Quick, parse_request_uri_host_query); + ( "no slash with query string", + `Quick, + parse_request_uri_query_no_slash ); + ( "no slash with query with host", + `Quick, + parse_request_uri_host_query_no_slash ); + ("CONNECT", `Quick, parse_request_connect); + ("CONNECT with host", `Quick, parse_request_connect_host); + ("OPTIONS", `Quick, parse_request_options); + ("OPTIONS with host", `Quick, parse_request_options_host); + ("parent traversal", `Quick, parse_request_uri_traversal); + ( "parent traversal with host", + `Quick, + parse_request_uri_host_traversal ); + ("uri round-trip", `Quick, uri_round_trip); + ] ); + ] diff --git a/cohttp_async_test/src/cohttp_async_test.ml b/cohttp_async_test/src/cohttp_async_test.ml index cac24c5e4b..3212bb4cac 100644 --- a/cohttp_async_test/src/cohttp_async_test.ml +++ b/cohttp_async_test/src/cohttp_async_test.ml @@ -7,66 +7,67 @@ type 'a io = 'a Deferred.t type ic = Async_unix.Reader.t type oc = Async_unix.Writer.t type body = Body.t + type response_action = - [ `Expert of Cohttp.Response.t - * (ic - -> oc - -> unit io) + [ `Expert of Cohttp.Response.t * (ic -> oc -> unit io) | `Response of Cohttp.Response.t * body ] + type spec = Request.t -> body -> response_action io type async_test = unit -> unit io let response rsp = `Response rsp -let expert ?(rsp=Cohttp.Response.make ()) f _req _body = + +let expert ?(rsp = Cohttp.Response.make ()) f _req _body = return (`Expert (rsp, f)) -let const rsp _req _body = rsp >>| response +let const rsp _req _body = rsp >>| response let response_sequence = Cohttp_test.response_sequence failwith let get_port = let port = ref 10_080 in - (fun () -> let v = !port in Int.incr port ; v ) + fun () -> + let v = !port in + Int.incr port; + v let temp_server ?port spec callback = - let port = match port with - | None -> get_port () - | Some p -> p in - let uri = Uri.of_string ("http://0.0.0.0:" ^ (Int.to_string port)) in - let server = Server.create_expert ~on_handler_error:`Raise - (Async.Tcp.Where_to_listen.of_port port) - (fun ~body _sock req -> spec req body) in + let port = match port with None -> get_port () | Some p -> p in + let uri = Uri.of_string ("http://0.0.0.0:" ^ Int.to_string port) in + let server = + Server.create_expert ~on_handler_error:`Raise + (Async.Tcp.Where_to_listen.of_port port) (fun ~body _sock req -> + spec req body) + in server >>= fun server -> callback uri >>= fun res -> - Server.close server >>| fun () -> - res + Server.close server >>| fun () -> res -let test_server_s ?port ?(name="Cohttp Server Test") spec f = - temp_server ?port spec begin fun uri -> - Logs.info (fun m -> m "Test %s running on %s" name (Uri.to_string uri)); - let tests = f uri in - let results = - tests - |> Deferred.List.map ~how:`Sequential ~f:(fun (name, test) -> - Logs.debug (fun m -> m "Running %s" name); - let res = - try_with test >>| function - | Ok () -> `Ok - | Error exn -> `Exn exn in - res >>| (fun res -> (name, res))) in - results >>| (fun results -> +let test_server_s ?port ?(name = "Cohttp Server Test") spec f = + temp_server ?port spec (fun uri -> + Logs.info (fun m -> m "Test %s running on %s" name (Uri.to_string uri)); + let tests = f uri in + let results = + tests + |> Deferred.List.map ~how:`Sequential ~f:(fun (name, test) -> + Logs.debug (fun m -> m "Running %s" name); + let res = + try_with test >>| function + | Ok () -> `Ok + | Error exn -> `Exn exn + in + res >>| fun res -> (name, res)) + in + results >>| fun results -> let ounit_tests = results |> List.map ~f:(fun (name, res) -> - name >:: fun () -> - match res with - | `Ok -> () - | `Exn x -> raise x) in + name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x) + in name >::: ounit_tests) - end let run_async_tests test = (* enable logging to stdout *) Fmt_tty.setup_std_outputs (); Logs.set_level @@ Some Logs.Debug; Logs.set_reporter (Logs_fmt.reporter ()); - test >>| (fun a -> a |> OUnit.run_test_tt_main) + test >>| fun a -> a |> OUnit.run_test_tt_main diff --git a/cohttp_async_test/src/cohttp_async_test.mli b/cohttp_async_test/src/cohttp_async_test.mli index d292dd4ace..302d047806 100644 --- a/cohttp_async_test/src/cohttp_async_test.mli +++ b/cohttp_async_test/src/cohttp_async_test.mli @@ -1,4 +1,10 @@ open Async_kernel -include Cohttp_test.S with type 'a io = 'a Deferred.t and type body = Cohttp_async.Body.t and type ic = Async_unix.Reader.t and type oc = Async_unix.Writer.t +include + Cohttp_test.S + with type 'a io = 'a Deferred.t + and type body = Cohttp_async.Body.t + and type ic = Async_unix.Reader.t + and type oc = Async_unix.Writer.t + val run_async_tests : OUnit.test io -> OUnit.test_result list Deferred.t diff --git a/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml b/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml index 624b2b5546..f2c7493b33 100644 --- a/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml +++ b/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml @@ -8,64 +8,63 @@ type oc = Lwt_io.output_channel type body = Cohttp_lwt.Body.t type response_action = - [ `Expert of Cohttp.Response.t - * (ic - -> oc - -> unit io) + [ `Expert of Cohttp.Response.t * (ic -> oc -> unit io) | `Response of Cohttp.Response.t * body ] type spec = Request.t -> body -> response_action io - type async_test = unit -> unit Lwt.t let response rsp = `Response rsp -let expert ?(rsp=Cohttp.Response.make ()) f _req _body = + +let expert ?(rsp = Cohttp.Response.make ()) f _req _body = return (`Expert (rsp, f)) -let const rsp _req _body = rsp >|= response +let const rsp _req _body = rsp >|= response let response_sequence = Cohttp_test.response_sequence Lwt.fail_with - let () = Debug.activate_debug () let () = Logs.set_level (Some Info) let temp_server ?port spec callback = - let port = match port with - | None -> Cohttp_test.next_port () - | Some p -> p in - let server = Server.make_response_action ~callback:(fun _ req body -> spec req body) () in - let uri = Uri.of_string ("http://0.0.0.0:" ^ (string_of_int port)) in + let port = match port with None -> Cohttp_test.next_port () | Some p -> p in + let server = + Server.make_response_action ~callback:(fun _ req body -> spec req body) () + in + let uri = Uri.of_string ("http://0.0.0.0:" ^ string_of_int port) in let server_failed, server_failed_wake = Lwt.task () in - let server = Lwt.catch - (fun () -> Server.create ~backlog:40 ~mode:(`TCP (`Port port)) server) - (function - | Lwt.Canceled -> Lwt.return_unit - | x -> Lwt.wakeup_exn server_failed_wake x; Lwt.fail x) + let server = + Lwt.catch + (fun () -> Server.create ~backlog:40 ~mode:(`TCP (`Port port)) server) + (function + | Lwt.Canceled -> Lwt.return_unit + | x -> + Lwt.wakeup_exn server_failed_wake x; + Lwt.fail x) in Lwt.pick [ callback uri; server_failed ] >|= fun res -> Lwt.cancel server; res -let test_server_s ?port ?(name="Cohttp Server Test") spec f = - temp_server ?port spec begin fun uri -> - Logs.info (fun f -> f "Test %s running on %s" name (Uri.to_string uri)); - let tests = f uri in - let results = - tests - |> Lwt_list.map_s (fun (name, test) -> - Logs.info (fun f -> f "Running %s" name); - let res = Lwt.try_bind test - (fun () -> return `Ok) - (fun exn -> return (`Exn exn)) in - res >|= (fun res -> (name, res))) in - results >|= (fun results -> +let test_server_s ?port ?(name = "Cohttp Server Test") spec f = + temp_server ?port spec (fun uri -> + Logs.info (fun f -> f "Test %s running on %s" name (Uri.to_string uri)); + let tests = f uri in + let results = + tests + |> Lwt_list.map_s (fun (name, test) -> + Logs.info (fun f -> f "Running %s" name); + let res = + Lwt.try_bind test + (fun () -> return `Ok) + (fun exn -> return (`Exn exn)) + in + res >|= fun res -> (name, res)) + in + results >|= fun results -> let ounit_tests = results |> List.map (fun (name, res) -> - name >:: fun () -> - match res with - | `Ok -> () - | `Exn x -> raise x) in + name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x) + in name >::: ounit_tests) - end let run_async_tests test = test >|= OUnit.run_test_tt_main diff --git a/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.mli b/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.mli index 11c81beb93..e1529acc0d 100644 --- a/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.mli +++ b/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.mli @@ -1 +1,6 @@ -include Cohttp_test.S with type 'a io = 'a Lwt.t and type body = Cohttp_lwt.Body.t and type ic = Lwt_io.input_channel and type oc = Lwt_io.output_channel +include + Cohttp_test.S + with type 'a io = 'a Lwt.t + and type body = Cohttp_lwt.Body.t + and type ic = Lwt_io.input_channel + and type oc = Lwt_io.output_channel diff --git a/cohttp_server/cohttp_server.ml b/cohttp_server/cohttp_server.ml index f6583d86d3..008f475dc2 100644 --- a/cohttp_server/cohttp_server.ml +++ b/cohttp_server/cohttp_server.ml @@ -23,35 +23,37 @@ let ( / ) = Filename.concat let compare_kind = function | Some `Directory, Some `Directory -> 0 - | Some `Directory, _ -> -1 - | _ , Some `Directory -> 1 - | Some `File , Some `File -> 0 - | Some `File , _ -> 1 - | _ , Some `File -> -1 - | _ , _ -> 0 + | Some `Directory, _ -> -1 + | _, Some `Directory -> 1 + | Some `File, Some `File -> 0 + | Some `File, _ -> 1 + | _, Some `File -> -1 + | _, _ -> 0 -let sort lst = List.sort (fun (ka,_sa,a) (kb,_sb,b) -> - let c = compare_kind (ka,kb) in - if c <> 0 then c - else String.compare (String.lowercase_ascii a) (String.lowercase_ascii b) -) lst +let sort lst = + List.sort + (fun (ka, _sa, a) (kb, _sb, b) -> + let c = compare_kind (ka, kb) in + if c <> 0 then c + else String.compare (String.lowercase_ascii a) (String.lowercase_ascii b)) + lst let li ?title l = - let title = match title with - | None -> "" - | Some s -> sprintf "title=\"%s\" " s + let title = + match title with None -> "" | Some s -> sprintf "title=\"%s\" " s in sprintf "
  • %s
    • " title (Uri.to_string l) -let kind_of_unix_kind = Unix.(function - | S_DIR -> `Directory - | S_REG -> `File - | S_SOCK -> `Socket - | S_BLK -> `Block - | S_FIFO -> `Fifo - | S_CHR -> `Char - | S_LNK -> `Link -) +let kind_of_unix_kind = + Unix.( + function + | S_DIR -> `Directory + | S_REG -> `File + | S_SOCK -> `Socket + | S_BLK -> `Block + | S_FIFO -> `Fifo + | S_CHR -> `Char + | S_LNK -> `Link) let human_size_of_size size = let size = Int64.to_float size in @@ -62,50 +64,46 @@ let human_size_of_size size = if mibi < 1. then sprintf "%.1fKiB" kibi else let gibi = mibi /. 1024. in - if gibi < 1. then sprintf "%.1fMiB" mibi - else sprintf "%.1fGiB" gibi + if gibi < 1. then sprintf "%.1fMiB" mibi else sprintf "%.1fGiB" gibi let html_of_listing uri path listing info = - let html = List.map (fun (kind, size, f) -> - let encoded_f = Uri.pct_encode f in - match kind with - | Some `Directory -> - let link = Uri.with_path uri (path / encoded_f / "") in - li link (sprintf "%s/" f) - | Some `File -> - let link = Uri.with_path uri (path / encoded_f) in - li ~title:(human_size_of_size size) link f - | Some (`Socket|`Block|`Fifo|`Char|`Link) -> - sprintf "
  • %s
    • " f - | None -> sprintf "
  • Error with file: %s
    • " f - ) (sort listing) in + let html = + List.map + (fun (kind, size, f) -> + let encoded_f = Uri.pct_encode f in + match kind with + | Some `Directory -> + let link = Uri.with_path uri (path / encoded_f / "") in + li link (sprintf "%s/" f) + | Some `File -> + let link = Uri.with_path uri (path / encoded_f) in + li ~title:(human_size_of_size size) link f + | Some (`Socket | `Block | `Fifo | `Char | `Link) -> + sprintf "
  • %s
    • " f + | None -> sprintf "
  • Error with file: %s
    • " f) + (sort listing) + in let contents = String.concat "\n" html in - sprintf "\ -

    Directory Listing for %s

      %s
    \ -
    %s\ - " + sprintf + "

    Directory Listing for %s

      %s
    %s" (Uri.pct_decode path) contents info let html_of_forbidden_unnormal path info = - sprintf "\ -

    Forbidden

    \ -

    %sis not a normal file or directory

    \ -
    %s\ - " + sprintf + "

    Forbidden

    %sis not a normal file or \ + directory

    %s" path info let html_of_not_found path info = - sprintf "\ -

    Not Found

    %swas not found on this server

    \ -
    %s\ - " path info + sprintf + "

    Not Found

    %swas not found on this \ + server

    %s" + path info let html_of_method_not_allowed meth allowed path info = sprintf - "\ -

    Method Not Allowed

    \ -

    %sis not an allowed method on %s\ -

    Allowed methods on %s are %s

    \ -
    %s\ - " + "

    Method Not Allowed

    %sis not an allowed \ + method on %s

    Allowed methods on %s are \ + %s

    %s" meth path path allowed info diff --git a/cohttp_test/src/cohttp_test.ml b/cohttp_test/src/cohttp_test.ml index 68e1be49ed..df96d73a61 100644 --- a/cohttp_test/src/cohttp_test.ml +++ b/cohttp_test/src/cohttp_test.ml @@ -7,22 +7,25 @@ module type S = sig type body type response_action = - [ `Expert of Cohttp.Response.t - * (ic - -> oc - -> unit io) + [ `Expert of Cohttp.Response.t * (ic -> oc -> unit io) | `Response of Cohttp.Response.t * body ] type spec = Request.t -> body -> response_action io type async_test = unit -> unit io - val response : (Response.t * body) -> response_action + val response : Response.t * body -> response_action val expert : ?rsp:Cohttp.Response.t -> (ic -> oc -> unit io) -> spec val const : (Response.t * body) io -> spec val response_sequence : spec list -> spec val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io - val test_server_s : ?port:int -> ?name:string -> spec - -> (Uri.t -> (string * async_test) list) -> OUnit.test io + + val test_server_s : + ?port:int -> + ?name:string -> + spec -> + (Uri.t -> (string * async_test) list) -> + OUnit.test io + val run_async_tests : OUnit.test io -> OUnit.test_results io end @@ -37,7 +40,7 @@ let response_sequence fail responses = let xs = ref responses in fun req body -> match !xs with - | x::xs' -> - xs := xs'; - x req body + | x :: xs' -> + xs := xs'; + x req body | [] -> fail "response_sequence: Server exhausted responses" diff --git a/cohttp_test/src/cohttp_test.mli b/cohttp_test/src/cohttp_test.mli index fabac1a8b3..6e605c43b7 100644 --- a/cohttp_test/src/cohttp_test.mli +++ b/cohttp_test/src/cohttp_test.mli @@ -7,42 +7,44 @@ module type S = sig type body type response_action = - [ `Expert of Cohttp.Response.t - * (ic - -> oc - -> unit io) + [ `Expert of Cohttp.Response.t * (ic -> oc -> unit io) | `Response of Cohttp.Response.t * body ] - (** A server that is being tested must be defined by providing a spec *) type spec = Request.t -> body -> response_action io + (** A server that is being tested must be defined by providing a spec *) type async_test = unit -> unit io val response : Response.t * body -> response_action val expert : ?rsp:Response.t -> (ic -> oc -> unit io) -> spec - (** A constant handler that always returns its argument *) val const : (Response.t * body) io -> spec + (** A constant handler that always returns its argument *) - (** A server that process requests using the provided specs in sequence - and crashes on further reqeusts *) val response_sequence : spec list -> spec + (** A server that process requests using the provided specs in sequence and + crashes on further reqeusts *) + val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io (** Create a temporary server according to spec that lives until the callback thread is determined. The uri provided in the callback should be the base uri for any requests made to the temp server *) - val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io - (** Create a test suite against a server defined by spec. Tests - run sequentially. *) - val test_server_s : ?port:int -> ?name:string -> spec - -> (Uri.t -> (string * async_test) list) -> OUnit.test io + val test_server_s : + ?port:int -> + ?name:string -> + spec -> + (Uri.t -> (string * async_test) list) -> + OUnit.test io + (** Create a test suite against a server defined by spec. Tests run + sequentially. *) - (** Run an async unit test and return and print the result *) val run_async_tests : OUnit.test io -> OUnit.test_results io + (** Run an async unit test and return and print the result *) end -(** Internal API. Subject to breakage *) val next_port : unit -> int -val response_sequence : (string -> 'a) -> ('b -> 'c -> 'a) list - -> 'b -> 'c -> 'a +(** Internal API. Subject to breakage *) + +val response_sequence : + (string -> 'a) -> ('b -> 'c -> 'a) list -> 'b -> 'c -> 'a diff --git a/examples/async/hello_world.ml b/examples/async/hello_world.ml index b566fb6646..e6a620ef9b 100644 --- a/examples/async/hello_world.ml +++ b/examples/async/hello_world.ml @@ -12,28 +12,27 @@ let handler ~body:_ _sock req = let uri = Cohttp.Request.uri req in match Uri.path uri with | "/test" -> - Uri.get_query_param uri "hello" - |> Option.map ~f:(fun v -> "hello: " ^ v) - |> Option.value ~default:"No param hello supplied" - |> Server.respond_string - | _ -> - Server.respond_string ~status:`Not_found "Route not found" + Uri.get_query_param uri "hello" + |> Option.map ~f:(fun v -> "hello: " ^ v) + |> Option.value ~default:"No param hello supplied" + |> Server.respond_string + | _ -> Server.respond_string ~status:`Not_found "Route not found" let start_server port () = Caml.Printf.eprintf "Listening for HTTP on port %d\n" port; Caml.Printf.eprintf "Try 'curl http://localhost:%d/test?hello=xyz'\n%!" port; Cohttp_async.Server.create ~on_handler_error:`Raise - (Async.Tcp.Where_to_listen.of_port port) handler + (Async.Tcp.Where_to_listen.of_port port) + handler >>= fun _ -> Deferred.never () let () = let module Command = Async_command in - Command.async_spec - ~summary:"Start a hello world Async server" + Command.async_spec ~summary:"Start a hello world Async server" Command.Spec.( - empty +> - flag "-p" (optional_with_default 8080 int) - ~doc:"int Source port to listen on" - ) start_server - + empty + +> flag "-p" + (optional_with_default 8080 int) + ~doc:"int Source port to listen on") + start_server |> Command.run diff --git a/examples/async/receive_post.ml b/examples/async/receive_post.ml index 91ef78b918..cf0830c95a 100644 --- a/examples/async/receive_post.ml +++ b/examples/async/receive_post.ml @@ -7,24 +7,25 @@ open Cohttp_async let start_server port () = Caml.Printf.eprintf "Listening for HTTP on port %d\n" port; - Caml.Printf.eprintf "Try 'curl -X POST -d 'foo bar' http://localhost:%d\n" port; + Caml.Printf.eprintf "Try 'curl -X POST -d 'foo bar' http://localhost:%d\n" + port; Cohttp_async.Server.create ~on_handler_error:`Raise (Async.Tcp.Where_to_listen.of_port port) (fun ~body _ req -> match req |> Cohttp.Request.meth with | `POST -> - (Body.to_string body) >>= (fun body -> + Body.to_string body >>= fun body -> Caml.Printf.eprintf "Body: %s" body; - Server.respond `OK) - | _ -> Server.respond `Method_not_allowed - ) + Server.respond `OK + | _ -> Server.respond `Method_not_allowed) >>= fun _ -> Deferred.never () let () = let module Command = Async_command in - Command.async_spec - ~summary:"Simple http server that outputs body of POST's" - Command.Spec.(empty +> - flag "-p" (optional_with_default 8080 int) - ~doc:"int Source port to listen on" - ) start_server + Command.async_spec ~summary:"Simple http server that outputs body of POST's" + Command.Spec.( + empty + +> flag "-p" + (optional_with_default 8080 int) + ~doc:"int Source port to listen on") + start_server |> Command.run diff --git a/examples/async/s3_cp.ml b/examples/async/s3_cp.ml index 81efea28fc..22bc87fc27 100644 --- a/examples/async/s3_cp.ml +++ b/examples/async/s3_cp.ml @@ -14,34 +14,30 @@ * }}}*) -(** - This example is here to show how to get and put to s3 using the - async client code. +(** This example is here to show how to get and put to s3 using the async client + code. - This hopes to be a useful example because: - 1) it is a real world use of the client - 2) s3 auth requires a bit of fiddling with the headers - hopefully this is illustative for anyone else doing - the same + This hopes to be a useful example because: 1) it is a real world use of the + client 2) s3 auth requires a bit of fiddling with the headers hopefully this + is illustative for anyone else doing the same - The reader will want to be familiar with the S3 API Documentation - found here: http://docs.aws.amazon.com/AmazonS3/latest/API/Welcome.html - This example was written using the API Version 2006-03-01. + The reader will want to be familiar with the S3 API Documentation found + here: http://docs.aws.amazon.com/AmazonS3/latest/API/Welcome.html This + example was written using the API Version 2006-03-01. - There are two ways to authenticate with S3, this example uses the - authorization header approach (p. 19 of the api reference). + There are two ways to authenticate with S3, this example uses the + authorization header approach (p. 19 of the api reference). - Downloads from S3 are done using the GET method, and uploads are - done using the PUT method. + Downloads from S3 are done using the GET method, and uploads are done using + the PUT method. - To get this to work, you'll need an AWS access/secret key pair - that has the "s3:GetObject" and "s3:PutObject" permissions enabled - for the bucket you are interacting with. + To get this to work, you'll need an AWS access/secret key pair that has the + "s3:GetObject" and "s3:PutObject" permissions enabled for the bucket you are + interacting with. - As this is an example, straightforwardness is prized. One should - not use this for a production system, nor assume that it offers a good - example of abstraction, interface design or error handling. -*) + As this is an example, straightforwardness is prized. One should not use + this for a production system, nor assume that it offers a good example of + abstraction, interface design or error handling. *) open Base open Core @@ -49,11 +45,11 @@ open Async open Cohttp open Cohttp_async -let ksrt = fun (k,_) (k',_) -> String.compare k k' +let ksrt (k, _) (k', _) = String.compare k k' module Compat = struct (** Things we need to make this happen that, ideally, we'd like other - libraries to provide and that are orthogonal to the example here *) + libraries to provide and that are orthogonal to the example here *) let encode_string s = (* Percent encode the path as s3 wants it. Uri doesn't @@ -61,25 +57,20 @@ module Compat = struct If upstream allows that we can nix this function *) let n = String.length s in let buf = Buffer.create (n * 3) in - for i = 0 to (n-1) do - let c = String.get s i in + for i = 0 to n - 1 do + let c = s.[i] in match c with - | 'a' .. 'z' - |'A' .. 'Z' - | '0' .. '9' - | '_' | '-' | '~' | '.' | '/' -> Buffer.add_char buf c + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' | '~' | '.' | '/' -> + Buffer.add_char buf c | '%' -> - (* Sigh. Annoying we're expecting already escaped strings so ignore the escapes *) - begin + (* Sigh. Annoying we're expecting already escaped strings so ignore the escapes *) let is_hex = function | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> true - | _ -> false in - if (i + 2) < n then - if is_hex(String.get s (i+1)) && is_hex(String.get s (i+2)) then - Buffer.add_char buf c - else - Buffer.add_string buf "%25" - end + | _ -> false + in + if i + 2 < n then + if is_hex s.[i + 1] && is_hex s.[i + 2] then Buffer.add_char buf c + else Buffer.add_string buf "%25" | _ -> Buffer.add_string buf (Printf.sprintf "%%%X" (Char.to_int c)) done; Buffer.contents buf @@ -88,17 +79,17 @@ module Compat = struct let of_char c = let x = Char.to_int c in - hexa.[x lsr 4], hexa.[x land 0xf] + (hexa.[x lsr 4], hexa.[x land 0xf]) let cstruct_to_hex_string cs = let open Cstruct in let n = cs.len in let buf = Buffer.create (n * 2) in for i = 0 to n - 1 do - let c = Bigarray.Array1.get cs.buffer (cs.off+i) in - let (x,y) = of_char c in + let c = cs.buffer.{cs.off + i} in + let x, y = of_char c in Buffer.add_char buf x; - Buffer.add_char buf y; + Buffer.add_char buf y done; Buffer.contents buf @@ -109,35 +100,35 @@ module Compat = struct *) Uri.query uri |> List.sort ~compare:ksrt - |> List.map - ~f:(fun (k,v) -> (k, match v with [] -> [""] | x -> x)) + |> List.map ~f:(fun (k, v) -> (k, match v with [] -> [ "" ] | x -> x)) |> Uri.encoded_of_query let format_time t = (* Core.Std.Time doesn't have a format function that takes a timezone *) let d, s = Time.to_date_ofday ~zone:Time.Zone.utc t in let open Time.Span.Parts in - let {hr; min; sec; _} = Time.Ofday.to_parts s in + let { hr; min; sec; _ } = Time.Ofday.to_parts s in Printf.sprintf "%sT%.2d%.2d%.2dZ" - (Date.to_string_iso8601_basic d) hr min sec + (Date.to_string_iso8601_basic d) + hr min sec end -type region = [ - | `Ap_northeast_1 (* Asia Pacific (Tokyo) *) +type region = + [ `Ap_northeast_1 (* Asia Pacific (Tokyo) *) | `Ap_southeast_1 (* Asia Pacific (Singapore) *) | `Ap_southeast_2 (* Asia Pacific (Sydney) *) - | `Eu_central_1 (* EU (Frankfurt) *) - | `Eu_west_1 (* EU (Ireland) *) - | `Sa_east_1 (* South America (Sao Paulo) *) - | `Us_east_1 (* US East (N. Virginia) *) - | `Us_west_1 (* US West (N. California) *) - | `Us_west_2 (* US West (Oregon) *) -] [@@deriving sexp] + | `Eu_central_1 (* EU (Frankfurt) *) + | `Eu_west_1 (* EU (Ireland) *) + | `Sa_east_1 (* South America (Sao Paulo) *) + | `Us_east_1 (* US East (N. Virginia) *) + | `Us_west_1 (* US West (N. California) *) + | `Us_west_2 (* US West (Oregon) *) ] +[@@deriving sexp] let region_of_string = function | "ap-northeast-1" -> `Ap_northeast_1 | "ap-southeast-1" -> `Ap_southeast_1 - | "ap-southeast-2"-> `Ap_southeast_2 + | "ap-southeast-2" -> `Ap_southeast_2 | "eu-central-1" -> `Eu_central_1 | "eu-west-1" -> `Eu_west_1 | "sa-east-1" -> `Sa_east_1 @@ -168,12 +159,9 @@ let region_host_string = function | `Us_west_1 -> "s3-us-west-1.amazonaws.com" | `Us_west_2 -> "s3-us-west-2.amazonaws.com" -type service = [ - `S3 -] [@@deriving sexp] +type service = [ `S3 ] [@@deriving sexp] -let string_of_service = function - | `S3 -> "s3" +let string_of_service = function `S3 -> "s3" module Auth = struct (** AWS S3 Authorization *) @@ -187,12 +175,15 @@ module Auth = struct (* Return x-amz-date and x-amz-sha256 headers *) let hashed_payload = match body with - None -> "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" + | None -> + "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" | Some s -> digest s in - ([("x-amz-content-sha256", hashed_payload); - ("x-amz-date", Compat.format_time time);], - hashed_payload) + ( [ + ("x-amz-content-sha256", hashed_payload); + ("x-amz-date", Compat.format_time time); + ], + hashed_payload ) let canonical_request hashed_payload (request : Cohttp_async.Request.t) = (* This corresponds to p.21 of the s3 api doc @@ -211,31 +202,33 @@ module Auth = struct let canoncical_uri = Compat.encode_string (Uri.path uri) in (* Sort query string in alphabetical order by key *) let canonical_query = Compat.encode_query_string uri in - let sorted_headers = Header.to_list request.headers - |> List.sort ~compare:ksrt in - let canonical_headers = sorted_headers - |> List.fold ~init:"" ~f:(fun acc (k,v) -> - acc ^ - (Printf.sprintf "%s:%s\n" - (String.lowercase k) (String.strip v))) + let sorted_headers = + Header.to_list request.headers |> List.sort ~compare:ksrt + in + let canonical_headers = + sorted_headers + |> List.fold ~init:"" ~f:(fun acc (k, v) -> + acc + ^ Printf.sprintf "%s:%s\n" (String.lowercase k) (String.strip v)) in - let signed_headers = sorted_headers - |> List.map ~f:(fun (k,_) -> k) - |> String.concat ~sep:";" + let signed_headers = + sorted_headers |> List.map ~f:(fun (k, _) -> k) |> String.concat ~sep:";" in - (Printf.sprintf "%s\n%s\n%s\n%s\n%s\n%s" - http_method canoncical_uri canonical_query canonical_headers signed_headers - hashed_payload, signed_headers) + ( Printf.sprintf "%s\n%s\n%s\n%s\n%s\n%s" http_method canoncical_uri + canonical_query canonical_headers signed_headers hashed_payload, + signed_headers ) - let string_to_sign ?time ~scope ~service canonical_request:string = + let string_to_sign ?time ~scope ~service canonical_request : string = (* As per p. 23 of s3 api doc. The requests need current time in utc time parameter is there for testing. *) - let time_str = match time with - None -> Time.to_string_abs ~zone:Time.Zone.utc (Time.now()) + let time_str = + match time with + | None -> Time.to_string_abs ~zone:Time.Zone.utc (Time.now ()) | Some t -> Compat.format_time t in - let (scope_date, scope_region) = scope in - let scope_str = Printf.sprintf "%s/%s/%s/aws4_request" + let scope_date, scope_region = scope in + let scope_str = + Printf.sprintf "%s/%s/%s/aws4_request" (Date.to_string_iso8601_basic scope_date) (string_of_region scope_region) (string_of_service service) @@ -244,147 +237,166 @@ module Auth = struct Printf.sprintf "AWS4-HMAC-SHA256\n%s\n%s\n%s" time_str scope_str hashed_req let make_signing_key ?date ~region ~service ~secret_access_key = - let mac k v = Mirage_crypto.Hash.(mac `SHA256 - ~key:k - (Cstruct.of_string v)) in - let date' = match date with - None -> Date.today ~zone:Time.Zone.utc - | Some d -> d in + let mac k v = + Mirage_crypto.Hash.(mac `SHA256 ~key:k (Cstruct.of_string v)) + in + let date' = + match date with None -> Date.today ~zone:Time.Zone.utc | Some d -> d + in let date_str = Date.to_string_iso8601_basic date' in - let date_key = mac (Cstruct.of_string ("AWS4"^secret_access_key)) date_str in + let date_key = + mac (Cstruct.of_string ("AWS4" ^ secret_access_key)) date_str + in let date_region_key = mac date_key (string_of_region region) in - let date_region_service_key = mac date_region_key (string_of_service service) in + let date_region_service_key = + mac date_region_key (string_of_service service) + in let signing_key = mac date_region_service_key "aws4_request" in signing_key - let auth_request ?now ~hashed_payload ~region ~service ~aws_access_key ~aws_secret_key request = + let auth_request ?now ~hashed_payload ~region ~service ~aws_access_key + ~aws_secret_key request = (* Important use the same time for everything here *) - let time = Option.value ~default:(Time.now()) now in + let time = Option.value ~default:(Time.now ()) now in let date = Time.to_date ~zone:Time.Zone.utc time in - let (canonical_request, signed_headers) = canonical_request hashed_payload request in - let string_to_sign = string_to_sign ~time:time ~scope:(date, region) ~service canonical_request in - let signing_key = make_signing_key ~date ~region ~service ~secret_access_key:aws_secret_key in - let creds = Printf.sprintf "%s/%s/%s/%s/aws4_request" - aws_access_key (Date.to_string_iso8601_basic date) + let canonical_request, signed_headers = + canonical_request hashed_payload request + in + let string_to_sign = + string_to_sign ~time ~scope:(date, region) ~service canonical_request + in + let signing_key = + make_signing_key ~date ~region ~service ~secret_access_key:aws_secret_key + in + let creds = + Printf.sprintf "%s/%s/%s/%s/aws4_request" aws_access_key + (Date.to_string_iso8601_basic date) (string_of_region region) (string_of_service service) in - let signature = Mirage_crypto.Hash.(mac `SHA256 - ~key:signing_key - (Cstruct.of_string string_to_sign)) in - let auth_header = Printf.sprintf - "AWS4-HMAC-SHA256 Credential=%s,SignedHeaders=%s,Signature=%s" - creds signed_headers (Compat.cstruct_to_hex_string signature) + let signature = + Mirage_crypto.Hash.( + mac `SHA256 ~key:signing_key (Cstruct.of_string string_to_sign)) in - [("Authorization", auth_header);] - + let auth_header = + Printf.sprintf + "AWS4-HMAC-SHA256 Credential=%s,SignedHeaders=%s,Signature=%s" creds + signed_headers + (Compat.cstruct_to_hex_string signature) + in + [ ("Authorization", auth_header) ] end module S3 = struct - type conf = { region : region; aws_access_key : string; aws_secret_key : string; - } [@@deriving sexp] + } + [@@deriving sexp] let make_request ?body conf ~meth ~bucket ~objekt = let host_str = region_host_string conf.region in - let uri = Printf.sprintf "https://%s/%s/%s" host_str bucket objekt - |> Uri.of_string in + let uri = + Printf.sprintf "https://%s/%s/%s" host_str bucket objekt |> Uri.of_string + in let time = Time.now () in (* If PUT add content length *) - let headers = match meth with - | `PUT -> begin - let length = Option.value_map ~f:(String.length) ~default:0 body in - [("Content-length", Int.to_string length)] - end - | _ -> [] in - let headers = headers @ [("Host", host_str)] in - let (amz_headers, hashed_payload) = Auth.make_amz_headers time ?body in + let headers = + match meth with + | `PUT -> + let length = Option.value_map ~f:String.length ~default:0 body in + [ ("Content-length", Int.to_string length) ] + | _ -> [] + in + let headers = headers @ [ ("Host", host_str) ] in + let amz_headers, hashed_payload = Auth.make_amz_headers time ?body in let headers = headers @ amz_headers in - let request = Request.make ~meth - ~headers:(Header.of_list headers) - uri in - let auth_header = Auth.auth_request ~now:time - ~hashed_payload ~region:conf.region ~service:`S3 - ~aws_access_key:conf.aws_access_key + let request = Request.make ~meth ~headers:(Header.of_list headers) uri in + let auth_header = + Auth.auth_request ~now:time ~hashed_payload ~region:conf.region + ~service:`S3 ~aws_access_key:conf.aws_access_key ~aws_secret_key:conf.aws_secret_key request in - let headers = (headers @ auth_header) |> Header.of_list in - let request = {request with Cohttp.Request.headers} in + let headers = headers @ auth_header |> Header.of_list in + let request = { request with Cohttp.Request.headers } in match meth with - | `PUT -> Client.request - ~body:(Option.value_map ~f:(Body.of_string) ~default:`Empty body) - request + | `PUT -> + Client.request + ~body:(Option.value_map ~f:Body.of_string ~default:`Empty body) + request | `GET -> Client.request request | _ -> failwith "not possible right now" end -type s3path = {bucket : string; objekt : string} - -type cmd = - S3toLocal of s3path * string - | LocaltoS3 of string * s3path +type s3path = { bucket : string; objekt : string } +type cmd = S3toLocal of s3path * string | LocaltoS3 of string * s3path let determine_s3_parts s = (* Takes: string of the form s3:/// *) let s = String.drop_prefix s 5 in let parts = String.split ~on:'/' s in match parts with - | bucket::rst -> {bucket; objekt=(String.concat ~sep:"/" rst)} + | bucket :: rst -> { bucket; objekt = String.concat ~sep:"/" rst } | _ -> failwith "error format must be 's3:///'" let determine_paths src dst = let is_s3 s = String.is_prefix ~prefix:"s3://" s in - match is_s3 src, is_s3 dst with - | (true, false) -> S3toLocal (determine_s3_parts src, dst) - | (false, true) -> LocaltoS3 (src, determine_s3_parts dst) - | (false, false) -> failwith "Use cp(1) :)" - | (true, true) -> failwith "Does not support copying from s3 to s3" + match (is_s3 src, is_s3 dst) with + | true, false -> S3toLocal (determine_s3_parts src, dst) + | false, true -> LocaltoS3 (src, determine_s3_parts dst) + | false, false -> failwith "Use cp(1) :)" + | true, true -> failwith "Does not support copying from s3 to s3" let main region_str aws_access_key aws_secret_key src dst () = (* nb client does not support redirects or preflight 100 *) let open S3 in let region = region_of_string region_str in - let conf = {region; aws_access_key; aws_secret_key} in + let conf = { region; aws_access_key; aws_secret_key } in match determine_paths src dst with - | S3toLocal (src, dst) -> - begin + | S3toLocal (src, dst) -> ( make_request conf ~meth:`GET ~bucket:src.bucket ~objekt:src.objekt >>= fun (resp, body) -> match Cohttp.Response.(resp.status) with | #Code.success_status -> - Body.to_string body >>| fun s -> - Out_channel.with_file - ~f:(fun oc -> Out_channel.output_string oc s) - dst; - Core.Printf.printf "Wrote s3://%s to %s\n" (src.bucket ^ src.objekt) dst - | _ -> Core.Printf.printf "Error: %s\n" (Sexp.to_string (Response.sexp_of_t resp)); - return () - end - | LocaltoS3 (src, dst) -> - begin - let body = In_channel.with_file src ~f:(fun ic -> In_channel.input_all ic) in + Body.to_string body >>| fun s -> + Out_channel.with_file + ~f:(fun oc -> Out_channel.output_string oc s) + dst; + Core.Printf.printf "Wrote s3://%s to %s\n" (src.bucket ^ src.objekt) + dst + | _ -> + Core.Printf.printf "Error: %s\n" + (Sexp.to_string (Response.sexp_of_t resp)); + return ()) + | LocaltoS3 (src, dst) -> ( + let body = + In_channel.with_file src ~f:(fun ic -> In_channel.input_all ic) + in make_request ~body conf ~meth:`PUT ~bucket:dst.bucket ~objekt:dst.objekt >>= fun (resp, body) -> match Cohttp.Response.status resp with | #Code.success_status -> - Core.Printf.printf "Wrote %s to s3://%s\n" src (dst.bucket ^ dst.objekt); return () - | _ -> Body.to_string body >>| fun s -> - Core.Printf.printf "Error: %s\n%s\n" (Sexp.to_string (Response.sexp_of_t resp)) s - end + Core.Printf.printf "Wrote %s to s3://%s\n" src + (dst.bucket ^ dst.objekt); + return () + | _ -> + Body.to_string body >>| fun s -> + Core.Printf.printf "Error: %s\n%s\n" + (Sexp.to_string (Response.sexp_of_t resp)) + s) let () = let open Async_command in - async_spec - ~summary:"Simple command line client that copies files to/from S3" - Spec.(empty - +> flag "-r" (optional_with_default "us-east-1" string) - ~doc:"string AWS Region" - +> anon ("aws_access_key" %: string) - +> anon ("aws_secret_key" %: string) - +> anon ("src" %: string) - +> anon ("dst" %: string) - ) main + async_spec ~summary:"Simple command line client that copies files to/from S3" + Spec.( + empty + +> flag "-r" + (optional_with_default "us-east-1" string) + ~doc:"string AWS Region" + +> anon ("aws_access_key" %: string) + +> anon ("aws_secret_key" %: string) + +> anon ("src" %: string) + +> anon ("dst" %: string)) + main |> run diff --git a/examples/lwt_unix_doc/docker_lwt.ml b/examples/lwt_unix_doc/docker_lwt.ml index 0fe4dfb81d..3357fed083 100644 --- a/examples/lwt_unix_doc/docker_lwt.ml +++ b/examples/lwt_unix_doc/docker_lwt.ml @@ -10,8 +10,7 @@ let ctx = Cohttp_lwt_unix.Client.custom_ctx ~resolver () let t = - Client.get (Uri.of_string "http://docker/version") - >>= fun (resp, body) -> + Client.get (Uri.of_string "http://docker/version") >>= fun (resp, body) -> let open Cohttp in let code = resp |> Response.status |> Code.code_of_status in Printf.printf "Response code: %d\n" code; From 3c2e3ba0698d8fa1c25834c513718bffafca256c Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 6 Feb 2021 13:11:40 +0100 Subject: [PATCH 3/5] Remove dependency to base --- cohttp-lwt-unix/test/test_parser.ml | 2 +- cohttp.opam | 3 --- cohttp/scripts/generate.ml | 11 ++++------ cohttp/src/cookie.ml | 9 +++++++- cohttp/src/cookie.mli | 4 +++- cohttp/src/dune | 5 ++--- cohttp/src/link.ml | 5 ++++- cohttp/src/request.ml | 18 +++++++++++++--- cohttp/src/response.ml | 17 ++++++++++++--- cohttp/src/s.ml | 32 +++++++++++++++++++++-------- cohttp/src/transfer.ml | 4 +--- cohttp/src/transfer.mli | 2 +- 12 files changed, 76 insertions(+), 36 deletions(-) diff --git a/cohttp-lwt-unix/test/test_parser.ml b/cohttp-lwt-unix/test/test_parser.ml index 9d26fec911..000d1ea56b 100644 --- a/cohttp-lwt-unix/test/test_parser.ml +++ b/cohttp-lwt-unix/test/test_parser.ml @@ -276,7 +276,7 @@ let mutate_simple_req () = ~headers:(Header.init_with "foo" "bar") (Uri.of_string "/foo/bar") in - let req = Fieldslib.Field.fset Request.Fields.meth req `POST in + let req = { req with Request.meth = `POST } in write_req expected req let make_simple_res () = diff --git a/cohttp.opam b/cohttp.opam index 6cca69a75a..df413c4d41 100644 --- a/cohttp.opam +++ b/cohttp.opam @@ -37,11 +37,8 @@ depends: [ "re" {>= "1.9.0"} "uri" {>= "2.0.0"} "uri-sexp" - "fieldslib" "sexplib0" - "ppx_fields_conv" {>= "v0.9.0"} "ppx_sexp_conv" {>= "v0.13.0"} - "ppx_compare" {>= "v0.13.0"} "stringext" "base64" {>= "3.1.0"} "fmt" {with-test} diff --git a/cohttp/scripts/generate.ml b/cohttp/scripts/generate.ml index b93d7059cc..0319761ed0 100644 --- a/cohttp/scripts/generate.ml +++ b/cohttp/scripts/generate.ml @@ -196,7 +196,7 @@ let output_type oc ~mli t = if i = 0 then append oc " [ %s%s" c.constr doc else append oc " | %s%s" c.constr doc) t.codes; - append oc " ] [@@deriving compare, sexp]"; + append oc " ] [@@deriving sexp]"; if mli then append oc "(** %s *)" (String.capitalize_ascii t.section); append oc "" @@ -204,11 +204,9 @@ let output_status_types oc ~mli t = List.iter (output_type oc ~mli) t; append oc "type status = ["; List.iter (fun t -> append oc " | %s_status" t.section) t; - append oc "] [@@deriving compare, sexp]"; + append oc "] [@@deriving sexp]"; append oc ""; - if not mli then append oc "let compare_int = Int.compare\n" else (); - append oc - "type status_code = [`Code of int | status ] [@@deriving compare, sexp]"; + append oc "type status_code = [`Code of int | status ] [@@deriving sexp]"; append oc "" let iter fn s = List.iter (fun s -> List.iter fn s.codes) s @@ -284,7 +282,7 @@ let output_gen_types oc (_name, typ, gens) = append oc "type %s = [" typ; List.iter (fun { constr; _ } -> append oc " | %s" constr) gens; append oc " | `Other of string"; - append oc "] [@@deriving compare, sexp]"; + append oc "] [@@deriving sexp]"; append oc "" let output_gen_convert oc ~mli (name, typ, gens) = @@ -344,7 +342,6 @@ let meth = ("method", "meth", known_methods) let gen oc ~mli = append oc "(* Auto-Generated by 'ocaml generate.ml' *)"; append oc "open! Sexplib0.Sexp_conv"; - if not mli then append oc "open Ppx_compare_lib.Builtin"; append oc ""; output_gen_types oc version; output_gen_types oc meth; diff --git a/cohttp/src/cookie.ml b/cohttp/src/cookie.ml index 17ca9a43e3..89f1718c48 100644 --- a/cohttp/src/cookie.ml +++ b/cohttp/src/cookie.ml @@ -29,7 +29,14 @@ module Set_cookie_hdr = struct secure : bool; http_only : bool; } - [@@deriving fields, sexp] + [@@deriving sexp] + + let cookie t = t.cookie + let expiration t = t.expiration + let domain t = t.domain + let path t = t.path + let secure t = t.secure + let http_only t = t.http_only (* Does not check the contents of name or value for ';', ',', '\s', or name[0]='$' *) let make ?(expiration = `Session) ?path ?domain ?(secure = false) diff --git a/cohttp/src/cookie.mli b/cohttp/src/cookie.mli index 59c43102d1..70a0a8ef62 100644 --- a/cohttp/src/cookie.mli +++ b/cohttp/src/cookie.mli @@ -44,7 +44,7 @@ module Set_cookie_hdr : sig secure : bool; http_only : bool; } - [@@deriving fields, sexp] + [@@deriving sexp] (** A header which a server sends to a client to request that the client returns the cookie in future requests, under certain conditions. *) @@ -80,6 +80,8 @@ module Set_cookie_hdr : sig val secure : t -> bool (** Has the cookie's secure attribute been set? *) + + val http_only : t -> bool end module Cookie_hdr : sig diff --git a/cohttp/src/dune b/cohttp/src/dune index 0846994375..c115ca1e61 100644 --- a/cohttp/src/dune +++ b/cohttp/src/dune @@ -17,9 +17,8 @@ (public_name cohttp) (synopsis "Co-operative Client/Server HTTP library.") (preprocess - (pps ppx_compare ppx_fields_conv ppx_sexp_conv)) - (libraries ppx_compare.runtime-lib re stringext uri uri-sexp fieldslib - sexplib0 bytes base64)) + (pps ppx_sexp_conv)) + (libraries re stringext uri uri-sexp sexplib0 bytes base64)) (ocamllex accept_lexer) diff --git a/cohttp/src/link.ml b/cohttp/src/link.ml index dbf284df65..0343df62d7 100644 --- a/cohttp/src/link.ml +++ b/cohttp/src/link.ml @@ -119,8 +119,11 @@ end module Ext = struct type 'a t = { charset : Charset.t; language : Language.t; value : 'a } - [@@deriving sexp, fields] + [@@deriving sexp] + let charset t = t.charset + let language t = t.language + let value t = t.value let make ?(charset = "") ?(language = "") value = { charset; language; value } let map f x = { x with value = f x.value } end diff --git a/cohttp/src/request.ml b/cohttp/src/request.ml index 0368051b43..215086a090 100644 --- a/cohttp/src/request.ml +++ b/cohttp/src/request.ml @@ -14,7 +14,6 @@ * }}}*) -open Ppx_compare_lib.Builtin open Sexplib0.Sexp_conv type t = { @@ -25,8 +24,21 @@ type t = { version : Code.version; encoding : Transfer.encoding; } -[@@deriving compare, fields, sexp] - +[@@deriving sexp] + +let compare x y = + match Header.compare x.headers y.headers with + | 0 -> + let headers = Header.init () in + Stdlib.compare { x with headers } { y with headers } + | i -> i + +let headers t = t.headers +let meth t = t.meth +let scheme t = t.scheme +let resource t = t.resource +let version t = t.version +let encoding t = t.encoding let fixed_zero = Transfer.Fixed Int64.zero let guess_encoding ?(encoding = fixed_zero) headers = diff --git a/cohttp/src/response.ml b/cohttp/src/response.ml index b79e50d10f..b168ea7198 100644 --- a/cohttp/src/response.ml +++ b/cohttp/src/response.ml @@ -16,8 +16,6 @@ open Sexplib0.Sexp_conv -let compare_bool = Bool.compare - type t = { encoding : Transfer.encoding; headers : Header.t; @@ -25,7 +23,20 @@ type t = { status : Code.status_code; flush : bool; } -[@@deriving compare, fields, sexp] +[@@deriving sexp] + +let compare x y = + match Header.compare x.headers y.headers with + | 0 -> + let headers = Header.init () in + Stdlib.compare { x with headers } { y with headers } + | i -> i + +let headers t = t.headers +let encoding t = t.encoding +let version t = t.version +let status t = t.status +let flush t = t.flush let make ?(version = `HTTP_1_1) ?(status = `OK) ?(flush = false) ?(encoding = Transfer.Chunked) ?(headers = Header.init ()) () = diff --git a/cohttp/src/s.ml b/cohttp/src/s.ml index f25eb199c1..e09b15c719 100644 --- a/cohttp/src/s.ml +++ b/cohttp/src/s.ml @@ -86,7 +86,15 @@ module type Request = sig version : Code.version; (** HTTP version, usually 1.1 *) encoding : Transfer.encoding; (** transfer encoding of this HTTP request *) } - [@@deriving compare, fields, sexp] + [@@deriving sexp] + + val headers : t -> Header.t + val meth : t -> Code.meth + val scheme : t -> string option + val resource : t -> string + val version : t -> Code.version + val encoding : t -> Transfer.encoding + val compare : t -> t -> int val make : ?meth:Code.meth -> @@ -119,14 +127,15 @@ module type Response = sig status : Code.status_code; (** HTTP status code of the response *) flush : bool; } - [@@deriving compare, fields, sexp] - - (* The response creates by [make ~encoding ~headers ()] has an - encoding value determined from the content of [headers] or if no - proper header is present, using the value of [encoding]. Checked - headers are "content-lenght", "content-range" and - "transfer-encoding". The default value of [encoding] is - chunked. *) + [@@deriving sexp] + + val encoding : t -> Transfer.encoding + val headers : t -> Header.t + val version : t -> Code.version + val status : t -> Code.status_code + val flush : t -> bool + val compare : t -> t -> int + val make : ?version:Code.version -> ?status:Code.status_code -> @@ -135,6 +144,11 @@ module type Response = sig ?headers:Header.t -> unit -> t + (** The response creates by [make ~encoding ~headers ()] has an encoding value + determined from the content of [headers] or if no proper header is + present, using the value of [encoding]. Checked headers are + "content-lenght", "content-range" and "transfer-encoding". The default + value of [encoding] is chunked. *) end module type Body = sig diff --git a/cohttp/src/transfer.ml b/cohttp/src/transfer.ml index 19d14db827..d31a30f74b 100644 --- a/cohttp/src/transfer.ml +++ b/cohttp/src/transfer.ml @@ -16,9 +16,7 @@ open Sexplib0.Sexp_conv -let compare_int64 = Int64.compare - -type encoding = Chunked | Fixed of int64 | Unknown [@@deriving compare, sexp] +type encoding = Chunked | Fixed of int64 | Unknown [@@deriving sexp] type chunk = Chunk of string | Final_chunk of string | Done [@@deriving sexp] let string_of_encoding = function diff --git a/cohttp/src/transfer.mli b/cohttp/src/transfer.mli index cb97837885..63fda6c0b7 100644 --- a/cohttp/src/transfer.mli +++ b/cohttp/src/transfer.mli @@ -23,7 +23,7 @@ type encoding = | Chunked (** dynamic chunked encoding *) | Fixed of int64 (** fixed size content *) | Unknown (** unknown body size, which leads to best-effort *) -[@@deriving compare, sexp] +[@@deriving sexp] (** A chunk of body that also signals if there to more to arrive *) type chunk = From 4ee5fccd3ea1c63b96f7a6b44cd8fd9abf8b9ada Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 6 Feb 2021 13:16:01 +0100 Subject: [PATCH 4/5] cohttp: make sure we do not accidently pull with base as a dependency --- cohttp.opam | 2 +- cohttp/test/dune | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/cohttp.opam b/cohttp.opam index df413c4d41..4a9995d4e1 100644 --- a/cohttp.opam +++ b/cohttp.opam @@ -33,7 +33,7 @@ doc: "https://mirage.github.io/ocaml-cohttp/" bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" depends: [ "ocaml" {>= "4.08"} - "dune" {>= "1.1.0"} + "dune" {>= "2.0.0"} "re" {>= "1.9.0"} "uri" {>= "2.0.0"} "uri-sexp" diff --git a/cohttp/test/dune b/cohttp/test/dune index 4632550955..de9dd6bc91 100644 --- a/cohttp/test/dune +++ b/cohttp/test/dune @@ -1,6 +1,7 @@ (executable (name test_accept) (modules test_accept) + (forbidden_libraries base) (libraries cohttp alcotest fmt)) (rule @@ -12,6 +13,7 @@ (executable (name test_header) (modules test_header) + (forbidden_libraries base) (libraries cohttp alcotest fmt)) (rule @@ -23,6 +25,7 @@ (executable (name test_request) (modules test_request) + (forbidden_libraries base) (libraries cohttp alcotest fmt)) (rule @@ -34,6 +37,7 @@ (executable (name test_body) (modules test_body) + (forbidden_libraries base) (libraries cohttp alcotest fmt)) (rule From 930f8635c9da263bc0455d521b8fcd76092d9d03 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 6 Feb 2021 16:32:49 +0100 Subject: [PATCH 5/5] Update CHANGES --- CHANGES.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGES.md b/CHANGES.md index 5643cc6e98..7a36b75d33 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,6 @@ ## current +- Remove dependency to base (@samoht #745) - fix opam files and dependencies - add GitHub Actions workflow (@smorimoto #739) - lwt_jsoo: Forward exceptions to caller when response is null (@mefyl #738)