Repository: inhabitedtype/httpaf Branch: master Commit: 9cefa96f3971 Files: 60 Total size: 224.0 KB Directory structure: gitextract_en118sas/ ├── .github/ │ └── workflows/ │ └── test.yml ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── async/ │ ├── dune │ ├── httpaf_async.ml │ └── httpaf_async.mli ├── benchmarks/ │ ├── dune │ ├── wrk_async_benchmark.ml │ └── wrk_lwt_benchmark.ml ├── dune-project ├── examples/ │ ├── async/ │ │ ├── async_echo_post.ml │ │ ├── async_get.ml │ │ ├── async_post.ml │ │ └── dune │ ├── lib/ │ │ ├── dune │ │ └── httpaf_examples.ml │ └── lwt/ │ ├── dune │ ├── lwt_echo_post.ml │ ├── lwt_get.ml │ └── lwt_post.ml ├── httpaf-async.opam ├── httpaf-lwt-unix.opam ├── httpaf.opam ├── lib/ │ ├── body.ml │ ├── client_connection.ml │ ├── config.ml │ ├── dune │ ├── headers.ml │ ├── headers.mli │ ├── httpaf.ml │ ├── httpaf.mli │ ├── iOVec.ml │ ├── message.ml │ ├── method.ml │ ├── optional_thunk.ml │ ├── optional_thunk.mli │ ├── parse.ml │ ├── reqd.ml │ ├── request.ml │ ├── response.ml │ ├── serialize.ml │ ├── server_connection.ml │ ├── status.ml │ └── version.ml ├── lib_test/ │ ├── dune │ ├── helpers.ml │ ├── test_client_connection.ml │ ├── test_headers.ml │ ├── test_httpaf.ml │ ├── test_iovec.ml │ ├── test_method.ml │ ├── test_request.ml │ ├── test_response.ml │ ├── test_server_connection.ml │ └── test_version.ml └── lwt-unix/ ├── dune ├── httpaf_lwt_unix.ml └── httpaf_lwt_unix.mli ================================================ FILE CONTENTS ================================================ ================================================ FILE: .github/workflows/test.yml ================================================ name: build on: - push - pull_request jobs: builds: name: Earliest Supported Version strategy: fail-fast: false matrix: os: - ubuntu-latest ocaml-version: - 4.04.0 runs-on: ${{ matrix.os }} steps: - name: Checkout code uses: actions/checkout@v2 - name: Use OCaml ${{ matrix.ocaml-version }} uses: avsm/setup-ocaml@v1 with: ocaml-version: ${{ matrix.ocaml-version }} - name: Deps run: | opam pin add -n httpaf . opam install --deps-only httpaf - name: Build run: opam exec -- dune build -p httpaf tests: name: Tests strategy: fail-fast: false matrix: os: - ubuntu-latest ocaml-version: - 4.08.1 - 4.10.2 - 4.11.2 - 4.12.0 runs-on: ${{ matrix.os }} steps: - name: Checkout code uses: actions/checkout@v2 - name: Use OCaml ${{ matrix.ocaml-version }} uses: avsm/setup-ocaml@v1 with: ocaml-version: ${{ matrix.ocaml-version }} - name: Deps run: | opam pin add -n httpaf . opam pin add -n httpaf-async . opam pin add -n httpaf-lwt-unix . opam install -t --deps-only . - name: Build run: opam exec -- dune build - name: Test run: opam exec -- dune runtest - name: Examples run: | opam exec -- make examples ================================================ FILE: .gitignore ================================================ .*.sw[po] _build/ _tests/ lib_test/tests_ *.native *.byte *.docdir .merlin *.install ================================================ FILE: LICENSE ================================================ Copyright (c) 2016, Inhabited Type LLC All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: Makefile ================================================ .PHONY: all build clean test examples build: dune build @install all: build test: dune runtest examples: dune build @examples watch: dune build {httpaf,httpaf-async,httpaf-lwt-unix}.install @runtest --watch install: dune install uninstall: dune uninstall clean: rm -rf _build *.install ================================================ FILE: README.md ================================================ # http/af http/af is a high-performance, memory-efficient, and scalable web server for OCaml. It implements the HTTP 1.1 specification with respect to parsing, serialization, and connection pipelining as a state machine that is agnostic to the underlying IO mechanism, and is therefore portable across many platform. It uses the [Angstrom][angstrom] and [Faraday][faraday] libraries to implement the parsing and serialization layers of the HTTP standard, hence the name. [angstrom]: https://github.com/inhabitedtype/angstrom [faraday]: https://github.com/inhabitedtype/faraday [![Build Status](https://github.com/inhabitedtype/httpaf/workflows/build/badge.svg)](https://github.com/inhabitedtype/httpaf/actions?query=workflow%3A%22build%22)] ## Installation Install the library and its dependencies via [OPAM][opam]: [opam]: http://opam.ocaml.org/ ```bash opam install httpaf ``` ## Usage Here is a Hello, World! program written using httpaf. It only responds to `GET` requests to the `/hello/*` target. As it does not itself do any IO, it can be used with both the Async and Lwt runtimes. See the [`examples`][examples] directory for usage of the individual runtimes. [examples]: https://github.com/inhabitedtype/httpaf/tree/master/examples ```ocaml open Httpaf module String = Caml.String let invalid_request reqd status body = (* Responses without an explicit length or transfer-encoding are close-delimited. *) let headers = Headers.of_list [ "Connection", "close" ] in Reqd.respond_with_string reqd (Response.create ~headers status) body ;; let request_handler reqd = let { Request.meth; target; _ } = Reqd.request reqd in match meth with | `GET -> begin match String.split_on_char '/' target with | "" :: "hello" :: rest -> let who = match rest with | [] -> "world" | who :: _ -> who in let response_body = Printf.sprintf "Hello, %s!\n" who in (* Specify the length of the response. *) let headers = Headers.of_list [ "Content-length", string_of_int (String.length response_body) ] in Reqd.respond_with_string reqd (Response.create ~headers `OK) response_body | _ -> let response_body = Printf.sprintf "%S not found\n" target in invalid_request reqd `Not_found response_body end | meth -> let response_body = Printf.sprintf "%s is not an allowed method\n" (Method.to_string meth) in invalid_request reqd `Method_not_allowed response_body ;; ``` ## Performance The reason for http/af's existence is [mirage/ocaml-cohttp#328][328], which highlights the poor scalability of cohttp. This is due to a number of factors, including poor scheduling, excessive allocation, and starvation of the server's accept loop. Here is a comparison chart of the data from that issue, along with data from an async-based http/af server. This server was run on a VM with 3 virtual cores, the host being circa 2015 MacBook Pro: [328]: https://github.com/mirage/ocaml-cohttp/issues/328 ![http/af comparsion to cohttp](https://raw.githubusercontent.com/inhabitedtype/httpaf/master/images/httpaf-comparison.png) The http/af latency histogram, relative to the cohttp histograms, is pretty much flat along the x-axis. Here are some additional statistics from that run (with latencies in milliseconds): ``` #[Mean = 27.719, StdDeviation = 31.570] #[Max = 263.424, Total count = 1312140] #[Buckets = 27, SubBuckets = 2048] ---------------------------------------------------------- 1709909 requests in 1.00m, 3.33GB read ``` ## Development To install development dependencies, pin the package from the root of the repository: ```bash opam pin add -n httpaf . opam install --deps-only httpaf ``` After this, you may install a development version of the library using the install command as usual. Tests can be run via dune: ```bash dune runtest ``` ## License BSD3, see LICENSE files for its text. ================================================ FILE: async/dune ================================================ (library (name httpaf_async) (public_name httpaf-async) (wrapped false) (libraries async core faraday-async httpaf) (flags (:standard -safe-string))) ================================================ FILE: async/httpaf_async.ml ================================================ open Core open Async (** XXX(seliopou): Replace Angstrom.Buffered with a module like this, while also supporting growing the buffer. Clients can use this to buffer and the use the unbuffered interface for actually running the parser. *) module Buffer : sig type t val create : int -> t val get : t -> f:(Bigstring.t -> off:int -> len:int -> int) -> int val put : t -> f:(Bigstring.t -> off:int -> len:int -> int) -> int end= struct type t = { buffer : Bigstring.t ; mutable off : int ; mutable len : int } let create size = let buffer = Bigstring.create size in { buffer; off = 0; len = 0 } ;; let compress t = if t.len = 0 then begin t.off <- 0; t.len <- 0; end else if t.off > 0 then begin Bigstring.blit ~src:t.buffer ~src_pos:t.off ~dst:t.buffer ~dst_pos:0 ~len:t.len; t.off <- 0; end ;; let get t ~f = let n = f t.buffer ~off:t.off ~len:t.len in t.off <- t.off + n; t.len <- t.len - n; if t.len = 0 then t.off <- 0; n ;; let put t ~f = compress t; let n = f t.buffer ~off:(t.off + t.len) ~len:(Bigstring.length t.buffer - t.len) in t.len <- t.len + n; n ;; end let read fd buffer = let badfd fd = failwithf "read got back fd: %s" (Fd.to_string fd) () in let rec finish fd buffer result = let open Unix.Error in match result with | `Already_closed | `Ok 0 -> return `Eof | `Ok n -> return (`Ok n) | `Error (Unix.Unix_error ((EWOULDBLOCK | EAGAIN), _, _)) -> begin Fd.ready_to fd `Read >>= function | `Bad_fd -> badfd fd | `Closed -> return `Eof | `Ready -> go fd buffer end | `Error (Unix.Unix_error (EBADF, _, _)) -> badfd fd | `Error exn -> Deferred.don't_wait_for (Fd.close fd); raise exn and go fd buffer = if Fd.supports_nonblock fd then finish fd buffer (Fd.syscall fd ~nonblocking:true (fun file_descr -> Buffer.put buffer ~f:(fun bigstring ~off ~len -> Unix.Syscall_result.Int.ok_or_unix_error_exn ~syscall_name:"read" (Bigstring_unix.read_assume_fd_is_nonblocking file_descr bigstring ~pos:off ~len)))) else Fd.syscall_in_thread fd ~name:"read" (fun file_descr -> Buffer.put buffer ~f:(fun bigstring ~off ~len -> Bigstring_unix.read file_descr bigstring ~pos:off ~len)) >>= fun result -> finish fd buffer result in go fd buffer open Httpaf module Server = struct let create_connection_handler ?(config=Config.default) ~request_handler ~error_handler = fun client_addr socket -> let fd = Socket.fd socket in let writev = Faraday_async.writev_of_fd fd in let request_handler = request_handler client_addr in let error_handler = error_handler client_addr in let conn = Server_connection.create ~config ~error_handler request_handler in let read_complete = Ivar.create () in let buffer = Buffer.create config.read_buffer_size in let rec reader_thread () = match Server_connection.next_read_operation conn with | `Read -> (* Log.Global.printf "read(%d)%!" (Fd.to_int_exn fd); *) read fd buffer >>> begin function | `Eof -> Buffer.get buffer ~f:(fun bigstring ~off ~len -> Server_connection.read_eof conn bigstring ~off ~len) |> ignore; reader_thread () | `Ok _ -> Buffer.get buffer ~f:(fun bigstring ~off ~len -> Server_connection.read conn bigstring ~off ~len) |> ignore; reader_thread () end | `Yield -> (* Log.Global.printf "read_yield(%d)%!" (Fd.to_int_exn fd); *) Server_connection.yield_reader conn reader_thread | `Close -> (* Log.Global.printf "read_close(%d)%!" (Fd.to_int_exn fd); *) Ivar.fill read_complete (); if not (Fd.is_closed fd) then Socket.shutdown socket `Receive in let write_complete = Ivar.create () in let rec writer_thread () = match Server_connection.next_write_operation conn with | `Write iovecs -> (* Log.Global.printf "write(%d)%!" (Fd.to_int_exn fd); *) writev iovecs >>> fun result -> Server_connection.report_write_result conn result; writer_thread () | `Yield -> (* Log.Global.printf "write_yield(%d)%!" (Fd.to_int_exn fd); *) Server_connection.yield_writer conn writer_thread; | `Close _ -> (* Log.Global.printf "write_close(%d)%!" (Fd.to_int_exn fd); *) Ivar.fill write_complete (); if not (Fd.is_closed fd) then Socket.shutdown socket `Send in let conn_monitor = Monitor.create () in Scheduler.within ~monitor:conn_monitor reader_thread; Scheduler.within ~monitor:conn_monitor writer_thread; Monitor.detach_and_iter_errors conn_monitor ~f:(fun exn -> Server_connection.report_exn conn exn); (* The Tcp module will close the file descriptor once this becomes determined. *) Deferred.all_unit [ Ivar.read read_complete ; Ivar.read write_complete ] end module Client = struct let request ?(config=Config.default) socket request ~error_handler ~response_handler = let fd = Socket.fd socket in let writev = Faraday_async.writev_of_fd fd in let request_body, conn = Client_connection.request request ~error_handler ~response_handler in let read_complete = Ivar.create () in let buffer = Buffer.create config.read_buffer_size in let rec reader_thread () = match Client_connection.next_read_operation conn with | `Read -> (* Log.Global.printf "read(%d)%!" (Fd.to_int_exn fd); *) read fd buffer >>> begin function | `Eof -> Buffer.get buffer ~f:(fun bigstring ~off ~len -> Client_connection.read_eof conn bigstring ~off ~len) |> ignore; reader_thread () | `Ok _ -> Buffer.get buffer ~f:(fun bigstring ~off ~len -> Client_connection.read conn bigstring ~off ~len) |> ignore; reader_thread () end | `Close -> (* Log.Global.printf "read_close(%d)%!" (Fd.to_int_exn fd); *) Ivar.fill read_complete (); if not (Fd.is_closed fd) then Socket.shutdown socket `Receive in let write_complete = Ivar.create () in let rec writer_thread () = match Client_connection.next_write_operation conn with | `Write iovecs -> (* Log.Global.printf "write(%d)%!" (Fd.to_int_exn fd); *) writev iovecs >>> fun result -> Client_connection.report_write_result conn result; writer_thread () | `Yield -> (* Log.Global.printf "write_yield(%d)%!" (Fd.to_int_exn fd); *) Client_connection.yield_writer conn writer_thread; | `Close _ -> (* Log.Global.printf "write_close(%d)%!" (Fd.to_int_exn fd); *) Ivar.fill write_complete (); in let conn_monitor = Monitor.create () in Scheduler.within ~monitor:conn_monitor reader_thread; Scheduler.within ~monitor:conn_monitor writer_thread; Monitor.detach_and_iter_errors conn_monitor ~f:(fun exn -> Client_connection.report_exn conn exn); don't_wait_for ( Deferred.all_unit [ Ivar.read read_complete ; Ivar.read write_complete ] >>| fun () -> if not (Fd.is_closed fd) then don't_wait_for (Fd.close fd)); request_body end ================================================ FILE: async/httpaf_async.mli ================================================ open! Core open Async open Httpaf module Server : sig val create_connection_handler : ?config : Config.t -> request_handler : ('a -> Server_connection.request_handler) -> error_handler : ('a -> Server_connection.error_handler) -> ([< Socket.Address.t] as 'a) -> ([`Active], 'a) Socket.t -> unit Deferred.t end module Client : sig val request : ?config : Config.t -> ([`Active], [< Socket.Address.t]) Socket.t -> Request.t -> error_handler : Client_connection.error_handler -> response_handler : Client_connection.response_handler -> Body.Writer.t end ================================================ FILE: benchmarks/dune ================================================ (executable (name wrk_async_benchmark) (modules wrk_async_benchmark) (libraries httpaf httpaf_examples httpaf-async async core)) (executable (name wrk_lwt_benchmark) (modules Wrk_lwt_benchmark) (libraries httpaf httpaf_examples httpaf-lwt-unix lwt.unix base)) (alias (name benchmarks) (deps (glob_files *.exe))) ================================================ FILE: benchmarks/wrk_async_benchmark.ml ================================================ open Core open Async open Httpaf_async let main port max_accepts_per_batch () = let where_to_listen = Tcp.Where_to_listen.of_port port in let request_handler _ = Httpaf_examples.Server.benchmark in let error_handler _ = Httpaf_examples.Server.error_handler in Tcp.(Server.create_sock ~on_handler_error:`Ignore ~backlog:11_000 ~max_connections:10_000 ~max_accepts_per_batch where_to_listen) (Server.create_connection_handler ~request_handler ~error_handler) >>= fun server -> Deferred.forever () (fun () -> Clock.after Time.Span.(of_sec 0.5) >>| fun () -> Log.Global.printf "conns: %d" (Tcp.Server.num_connections server)); Deferred.never () let () = Command.async ~summary:"Start a hello world Async server" Command.Param.( map (both (flag "-p" (optional_with_default 8080 int) ~doc:"int Source port to listen on") (flag "-a" (optional_with_default 1 int) ~doc:"int Maximum accepts per batch")) ~f:(fun (port, accepts) -> (fun () -> main port accepts ()))) |> Command.run ================================================ FILE: benchmarks/wrk_lwt_benchmark.ml ================================================ open Base open Httpaf_lwt_unix module Arg = Caml.Arg let main port = let open Lwt.Infix in let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in let request_handler _ = Httpaf_examples.Server.benchmark in let error_handler _ = Httpaf_examples.Server.error_handler in Lwt.async begin fun () -> Lwt_io.establish_server_with_client_socket ~backlog:11_000 listen_address (Server.create_connection_handler ~request_handler ~error_handler) >>= fun _server -> Lwt.return_unit end; let forever, _ = Lwt.wait () in Lwt_main.run forever ;; let () = let port = ref 8080 in Arg.parse ["-p", Arg.Set_int port, " Listening port number (8080 by default)"] ignore "Responds to requests with a fixed string for benchmarking purposes."; main !port ;; ================================================ FILE: dune-project ================================================ (lang dune 1.5) (name httpaf) ================================================ FILE: examples/async/async_echo_post.ml ================================================ open Core open Async open Httpaf_async let request_handler (_ : Socket.Address.Inet.t) = Httpaf_examples.Server.echo_post let error_handler (_ : Socket.Address.Inet.t) = Httpaf_examples.Server.error_handler let main port max_accepts_per_batch () = let where_to_listen = Tcp.Where_to_listen.of_port port in Tcp.(Server.create_sock ~on_handler_error:`Raise ~backlog:10_000 ~max_connections:10_000 ~max_accepts_per_batch where_to_listen) (Server.create_connection_handler ~request_handler ~error_handler) >>= fun _server -> Stdio.printf "Listening on port %i and echoing POST requests.\n" port; Stdio.printf "To send a POST request, try one of the following\n\n"; Stdio.printf " echo \"Testing echo POST\" | dune exec examples/async/async_post.exe\n"; Stdio.printf " echo \"Testing echo POST\" | dune exec examples/lwt/lwt_post.exe\n"; Stdio.printf " echo \"Testing echo POST\" | curl -XPOST --data @- http://localhost:%d\n\n%!" port; Deferred.never () ;; let () = Command.async ~summary:"Echo POST requests" Command.Param.( map (both (flag "-p" (optional_with_default 8080 int) ~doc:"int Source port to listen on") (flag "-a" (optional_with_default 1 int) ~doc:"int Maximum accepts per batch")) ~f:(fun (port, accepts) -> (fun () -> main port accepts ()))) |> Command.run ;; ================================================ FILE: examples/async/async_get.ml ================================================ open! Core open Async open Httpaf open Httpaf_async let main port host () = let where_to_connect = Tcp.Where_to_connect.of_host_and_port { host; port } in Tcp.connect_sock where_to_connect >>= fun socket -> let finished = Ivar.create () in let response_handler = Httpaf_examples.Client.print ~on_eof:(Ivar.fill finished) in let headers = Headers.of_list [ "host", host ] in let request_body = Client.request ~error_handler:Httpaf_examples.Client.error_handler ~response_handler socket (Request.create ~headers `GET "/") in Body.Writer.close request_body; Ivar.read finished ;; let () = Command.async ~summary:"Start a hello world Async client" Command.Param.( map (both (flag "-p" (optional_with_default 80 int) ~doc:"int destination port") (anon ("host" %: string))) ~f:(fun (port, host) -> (fun () -> main port host ()))) |> Command.run ================================================ FILE: examples/async/async_post.ml ================================================ open Core open Async open Httpaf open Httpaf_async let main port host () = let where_to_connect = Tcp.Where_to_connect.of_host_and_port { host; port } in Tcp.connect_sock where_to_connect >>= fun socket -> let finished = Ivar.create () in let response_handler = Httpaf_examples.Client.print ~on_eof:(Ivar.fill finished) in let headers = Headers.of_list [ "transfer-encoding", "chunked" ; "connection" , "close" ; "host" , host ] in let request_body = Client.request ~error_handler:Httpaf_examples.Client.error_handler ~response_handler socket (Request.create ~headers `POST "/") in let stdin = Lazy.force Reader.stdin in don't_wait_for ( Reader.read_one_chunk_at_a_time stdin ~handle_chunk:(fun bs ~pos:off ~len -> Body.Writer.write_bigstring request_body bs ~off ~len; Body.Writer.flush request_body (fun () -> ()); return (`Consumed(len, `Need_unknown))) >>| function | `Eof_with_unconsumed_data s -> Body.Writer.write_string request_body s; Body.Writer.close request_body | `Eof -> Body.Writer.close request_body | `Stopped () -> assert false); Ivar.read finished ;; let () = Command.async ~summary:"Start a hello world Async client" Command.Param.( map (both (flag "-p" (optional_with_default 80 int) ~doc:"int destination port") (anon ("host" %: string))) ~f:(fun (port, host) -> (fun () -> main port host ()))) |> Command.run ================================================ FILE: examples/async/dune ================================================ (executables (libraries httpaf httpaf-async httpaf_examples async core) (names async_echo_post async_get async_post)) (alias (name examples) (deps (glob_files *.exe))) ================================================ FILE: examples/lib/dune ================================================ (library (name httpaf_examples) (libraries httpaf base stdio) (flags (:standard -safe-string))) ================================================ FILE: examples/lib/httpaf_examples.ml ================================================ open Base open Httpaf module Format = Caml.Format let print_string = Stdio.(Out_channel.output_string stdout) let text = "CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of sitting by her sister on the bank, and of having nothing to do: once or twice she had peeped into the book her sister was reading, but it had no pictures or conversations in it, thought Alice So she was considering in her own mind (as well as she could, for the hot day made her feel very sleepy and stupid), whether the pleasure of making a daisy-chain would be worth the trouble of getting up and picking the daisies, when suddenly a White Rabbit with pink eyes ran close by her. There was nothing so very remarkable in that; nor did Alice think it so very much out of the way to hear the Rabbit say to itself, (when she thought it over afterwards, it occurred to her that she ought to have wondered at this, but at the time it all seemed quite natural); but when the Rabbit actually took a watch out of its waistcoat-pocket, and looked at it, and then hurried on, Alice started to her feet, for it flashed across her mind that she had never before seen a rabbit with either a waistcoat-pocket, or a watch to take out of it, and burning with curiosity, she ran across the field after it, and fortunately was just in time to see it pop down a large rabbit-hole under the hedge. In another moment down went Alice after it, never once considering how in the world she was to get out again. The rabbit-hole went straight on like a tunnel for some way, and then dipped suddenly down, so suddenly that Alice had not a moment to think about stopping herself before she found herself falling down a very deep well. Either the well was very deep, or she fell very slowly, for she had plenty of time as she went down to look about her and to wonder what was going to happen next. First, she tried to look down and make out what she was coming to, but it was too dark to see anything; then she looked at the sides of the well, and noticed that they were filled with cupboards......" let text = Bigstringaf.of_string ~off:0 ~len:(String.length text) text module Client = struct exception Response_error let error_handler error = let error = match error with | `Malformed_response err -> Format.sprintf "Malformed response: %s" err | `Invalid_response_body_length _ -> "Invalid body length" | `Exn exn -> Format.sprintf "Exn raised: %s" (Exn.to_string exn) in Format.eprintf "Error handling response: %s\n%!" error; ;; let print ~on_eof response response_body = match response with | { Response.status = `OK; _ } as response -> Format.fprintf Format.std_formatter "%a\n%!" Response.pp_hum response; let rec on_read bs ~off ~len = Bigstringaf.substring ~off ~len bs |> print_string; Body.Reader.schedule_read response_body ~on_read ~on_eof in Body.Reader.schedule_read response_body ~on_read ~on_eof; | response -> Format.fprintf Format.err_formatter "%a\n%!" Response.pp_hum response; Caml.exit 1 ;; end module Server = struct let echo_post reqd = match Reqd.request reqd with | { Request.meth = `POST; headers; _ } -> let response = let content_type = match Headers.get headers "content-type" with | None -> "application/octet-stream" | Some x -> x in Response.create ~headers:(Headers.of_list ["content-type", content_type; "connection", "close"]) `OK in let request_body = Reqd.request_body reqd in let response_body = Reqd.respond_with_streaming reqd response in let rec on_read buffer ~off ~len = Body.Writer.write_bigstring response_body buffer ~off ~len; Body.Reader.schedule_read request_body ~on_eof ~on_read; and on_eof () = Body.Writer.close response_body in Body.Reader.schedule_read (Reqd.request_body reqd) ~on_eof ~on_read | _ -> let headers = Headers.of_list [ "connection", "close" ] in Reqd.respond_with_string reqd (Response.create ~headers `Method_not_allowed) "" ;; let benchmark = let headers = Headers.of_list ["content-length", Int.to_string (Bigstringaf.length text)] in let handler reqd = let { Request.target; _ } = Reqd.request reqd in let request_body = Reqd.request_body reqd in Body.Reader.close request_body; match target with | "/" -> Reqd.respond_with_bigstring reqd (Response.create ~headers `OK) text; | _ -> Reqd.respond_with_string reqd (Response.create `Not_found) "Route not found" in handler ;; let error_handler ?request:_ error start_response = let response_body = start_response Headers.empty in begin match error with | `Exn exn -> Body.Writer.write_string response_body (Exn.to_string exn); Body.Writer.write_string response_body "\n"; | #Status.standard as error -> Body.Writer.write_string response_body (Status.default_reason_phrase error) end; Body.Writer.close response_body ;; end ================================================ FILE: examples/lwt/dune ================================================ (executables (libraries httpaf httpaf-lwt-unix httpaf_examples base stdio lwt lwt.unix) (names lwt_get lwt_post lwt_echo_post)) (alias (name examples) (deps (glob_files *.exe))) ================================================ FILE: examples/lwt/lwt_echo_post.ml ================================================ open Base open Lwt.Infix module Arg = Caml.Arg open Httpaf_lwt_unix let request_handler (_ : Unix.sockaddr) = Httpaf_examples.Server.echo_post let error_handler (_ : Unix.sockaddr) = Httpaf_examples.Server.error_handler let main port = let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in Lwt.async (fun () -> Lwt_io.establish_server_with_client_socket listen_address (Server.create_connection_handler ~request_handler ~error_handler) >|= fun _server -> Stdio.printf "Listening on port %i and echoing POST requests.\n" port; Stdio.printf "To send a POST request, try one of the following\n\n"; Stdio.printf " echo \"Testing echo POST\" | dune exec examples/async/async_post.exe\n"; Stdio.printf " echo \"Testing echo POST\" | dune exec examples/lwt/lwt_post.exe\n"; Stdio.printf " echo \"Testing echo POST\" | curl -XPOST --data @- http://localhost:%d\n\n%!" port); let forever, _ = Lwt.wait () in Lwt_main.run forever ;; let () = let port = ref 8080 in Arg.parse ["-p", Arg.Set_int port, " Listening port number (8080 by default)"] ignore "Echoes POST requests. Runs forever."; main !port ;; ================================================ FILE: examples/lwt/lwt_get.ml ================================================ open Base open Lwt.Infix module Arg = Caml.Arg open Httpaf open Httpaf_lwt_unix let main port host = Lwt_unix.getaddrinfo host (Int.to_string port) [Unix.(AI_FAMILY PF_INET)] >>= fun addresses -> let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in Lwt_unix.connect socket (List.hd_exn addresses).Unix.ai_addr >>= fun () -> let finished, notify_finished = Lwt.wait () in let response_handler = Httpaf_examples.Client.print ~on_eof:(Lwt.wakeup_later notify_finished) in let headers = Headers.of_list [ "host", host ] in let request_body = Client.request ~error_handler:Httpaf_examples.Client.error_handler ~response_handler socket (Request.create ~headers `GET "/") in Body.Writer.close request_body; finished ;; let () = let host = ref None in let port = ref 80 in Arg.parse ["-p", Set_int port, " Port number (80 by default)"] (fun host_argument -> host := Some host_argument) "lwt_get.exe [-p N] HOST"; let host = match !host with | None -> failwith "No hostname provided" | Some host -> host in Lwt_main.run (main !port host) ;; ================================================ FILE: examples/lwt/lwt_post.ml ================================================ open Base open Lwt.Infix module Arg = Caml.Arg open Httpaf open Httpaf_lwt_unix let main port host = Lwt_io.(read stdin) >>= fun body -> Lwt_unix.getaddrinfo host (Int.to_string port) [Unix.(AI_FAMILY PF_INET)] >>= fun addresses -> let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in Lwt_unix.connect socket (List.hd_exn addresses).Unix.ai_addr >>= fun () -> let finished, notify_finished = Lwt.wait () in let response_handler = Httpaf_examples.Client.print ~on_eof:(Lwt.wakeup_later notify_finished) in let headers = Headers.of_list [ "content-length" , (Int.to_string (String.length body)) ; "connection" , "close" ; "host" , host ] in let request_body = Client.request ~error_handler:Httpaf_examples.Client.error_handler ~response_handler socket (Request.create ~headers `POST "/") in Body.Writer.write_string request_body body; Body.Writer.close request_body; finished ;; let () = let host = ref None in let port = ref 8080 in Arg.parse ["-p", Set_int port, " Port number (8080 by default)"] (fun host_argument -> host := Some host_argument) "lwt_get.exe [-p N] HOST"; let host = match !host with | None -> failwith "No hostname provided" | Some host -> host in Lwt_main.run (main !port host) ;; ================================================ FILE: httpaf-async.opam ================================================ opam-version: "2.0" name: "httpaf-async" maintainer: "Spiros Eliopoulos " authors: [ "Spiros Eliopoulos " ] license: "BSD-3-clause" homepage: "https://github.com/inhabitedtype/httpaf" bug-reports: "https://github.com/inhabitedtype/httpaf/issues" dev-repo: "git+https://github.com/inhabitedtype/httpaf.git" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name] {with-test} ] depends: [ "ocaml" {>= "4.08.0"} "dune" {>= "1.5.0"} "faraday-async" {>= "0.7.2"} "async" {>= "v0.14.0"} "httpaf" {= version} ] synopsis: "Async support for http/af" ================================================ FILE: httpaf-lwt-unix.opam ================================================ opam-version: "2.0" name: "httpaf-lwt-unix" maintainer: "Spiros Eliopoulos " authors: [ "Anton Bachin " "Spiros Eliopoulos " ] license: "BSD-3-clause" homepage: "https://github.com/inhabitedtype/httpaf" bug-reports: "https://github.com/inhabitedtype/httpaf/issues" dev-repo: "git+https://github.com/inhabitedtype/httpaf.git" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.03.0"} "faraday-lwt-unix" "httpaf" {>= "0.6.0"} "dune" {>= "1.5.0"} "lwt" {>= "2.4.7"} ] synopsis: "Lwt support for http/af" ================================================ FILE: httpaf.opam ================================================ opam-version: "2.0" maintainer: "Spiros Eliopoulos " authors: [ "Spiros Eliopoulos " ] license: "BSD-3-clause" homepage: "https://github.com/inhabitedtype/httpaf" bug-reports: "https://github.com/inhabitedtype/httpaf/issues" dev-repo: "git+https://github.com/inhabitedtype/httpaf.git" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name] {with-test} ] depends: [ "ocaml" {>= "4.03.0"} "dune" {>= "1.5.0"} "alcotest" {with-test} "bigstringaf" {>= "0.4.0"} "angstrom" {>= "0.14.0"} "faraday" {>= "0.6.1"} ] synopsis: "A high-performance, memory-efficient, and scalable web server for OCaml" description: """ http/af implements the HTTP 1.1 specification with respect to parsing, serialization, and connection pipelining as a state machine that is agnostic to the underlying IO mechanism, and is therefore portable across many platform. It uses the Angstrom and Faraday libraries to implement the parsing and serialization layers of the HTTP standard, hence the name.""" ================================================ FILE: lib/body.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2018 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) module Reader = struct type t = { faraday : Faraday.t ; mutable read_scheduled : bool ; mutable on_eof : unit -> unit ; mutable on_read : Bigstringaf.t -> off:int -> len:int -> unit } let default_on_eof = Sys.opaque_identity (fun () -> ()) let default_on_read = Sys.opaque_identity (fun _ ~off:_ ~len:_ -> ()) let create buffer = { faraday = Faraday.of_bigstring buffer ; read_scheduled = false ; on_eof = default_on_eof ; on_read = default_on_read } let create_empty () = let t = create Bigstringaf.empty in Faraday.close t.faraday; t let empty = create_empty () let is_closed t = Faraday.is_closed t.faraday let unsafe_faraday t = t.faraday let rec do_execute_read t on_eof on_read = match Faraday.operation t.faraday with | `Yield -> () | `Close -> t.read_scheduled <- false; t.on_eof <- default_on_eof; t.on_read <- default_on_read; on_eof () (* [Faraday.operation] never returns an empty list of iovecs *) | `Writev [] -> assert false | `Writev (iovec::_) -> t.read_scheduled <- false; t.on_eof <- default_on_eof; t.on_read <- default_on_read; let { IOVec.buffer; off; len } = iovec in Faraday.shift t.faraday len; on_read buffer ~off ~len; execute_read t and execute_read t = if t.read_scheduled then do_execute_read t t.on_eof t.on_read let schedule_read t ~on_eof ~on_read = if t.read_scheduled then failwith "Body.Reader.schedule_read: reader already scheduled"; if not (is_closed t) then begin t.read_scheduled <- true; t.on_eof <- on_eof; t.on_read <- on_read; end; do_execute_read t on_eof on_read let close t = Faraday.close t.faraday; execute_read t ;; let has_pending_output t = Faraday.has_pending_output t.faraday end module Writer = struct type encoding = | Identity | Chunked of { mutable written_final_chunk : bool } type t = { faraday : Faraday.t ; encoding : encoding ; when_ready_to_write : unit -> unit ; buffered_bytes : int ref } let of_faraday faraday ~encoding ~when_ready_to_write = let encoding = match encoding with | `Fixed _ | `Close_delimited -> Identity | `Chunked -> Chunked { written_final_chunk = false } in { faraday ; encoding ; when_ready_to_write ; buffered_bytes = ref 0 } let create buffer ~encoding ~when_ready_to_write = of_faraday (Faraday.of_bigstring buffer) ~encoding ~when_ready_to_write let write_char t c = Faraday.write_char t.faraday c let write_string t ?off ?len s = Faraday.write_string ?off ?len t.faraday s let write_bigstring t ?off ?len b = Faraday.write_bigstring ?off ?len t.faraday b let schedule_bigstring t ?off ?len (b:Bigstringaf.t) = Faraday.schedule_bigstring ?off ?len t.faraday b let ready_to_write t = t.when_ready_to_write () let flush t kontinue = Faraday.flush t.faraday kontinue; ready_to_write t let is_closed t = Faraday.is_closed t.faraday let close t = Faraday.close t.faraday; ready_to_write t; ;; let has_pending_output t = (* Force another write poll to make sure that the final chunk is emitted for chunk-encoded bodies. *) let faraday_has_output = Faraday.has_pending_output t.faraday in let additional_encoding_output = match t.encoding with | Identity -> false | Chunked { written_final_chunk } -> Faraday.is_closed t.faraday && not written_final_chunk in faraday_has_output || additional_encoding_output let transfer_to_writer t writer = let faraday = t.faraday in begin match Faraday.operation faraday with | `Yield -> () | `Close -> (match t.encoding with | Identity -> () | Chunked ({ written_final_chunk } as chunked) -> if not written_final_chunk then begin chunked.written_final_chunk <- true; Serialize.Writer.schedule_chunk writer []; end); Serialize.Writer.unyield writer; | `Writev iovecs -> let buffered = t.buffered_bytes in begin match IOVec.shiftv iovecs !buffered with | [] -> () | iovecs -> let lengthv = IOVec.lengthv iovecs in buffered := !buffered + lengthv; begin match t.encoding with | Identity -> Serialize.Writer.schedule_fixed writer iovecs | Chunked _ -> Serialize.Writer.schedule_chunk writer iovecs end; Serialize.Writer.flush writer (fun () -> Faraday.shift faraday lengthv; buffered := !buffered - lengthv) end end end ================================================ FILE: lib/client_connection.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017-2019 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) module Reader = Parse.Reader module Writer = Serialize.Writer module Oneshot = struct type error = [ `Malformed_response of string | `Invalid_response_body_length of Response.t | `Exn of exn ] type response_handler = Response.t -> Body.Reader.t -> unit type error_handler = error -> unit type state = | Awaiting_response | Received_response of Response.t * Body.Reader.t | Closed type t = { request : Request.t ; request_body : Body.Writer.t ; error_handler : (error -> unit) ; reader : Reader.response ; writer : Writer.t ; state : state ref ; mutable error_code : [ `Ok | error ] } let request ?(config=Config.default) request ~error_handler ~response_handler = let state = ref Awaiting_response in let request_method = request.Request.meth in let handler response body = state := Received_response(response, body); response_handler response body in let writer = Writer.create () in let request_body = let encoding = match Request.body_length request with | `Fixed _ | `Chunked as encoding -> encoding | `Error `Bad_request -> failwith "Httpaf.Client_connection.request: invalid body length" in Body.Writer.create (Bigstringaf.create config.request_body_buffer_size) ~encoding ~when_ready_to_write:(fun () -> Writer.wakeup writer) in let t = { request ; request_body ; error_handler ; error_code = `Ok ; reader = Reader.response ~request_method handler ; writer ; state } in Writer.write_request t.writer request; request_body, t ;; let flush_request_body t = if Body.Writer.has_pending_output t.request_body then Body.Writer.transfer_to_writer t.request_body t.writer ;; let set_error_and_handle_without_shutdown t error = t.state := Closed; t.error_code <- (error :> [`Ok | error]); t.error_handler error; ;; let unexpected_eof t = set_error_and_handle_without_shutdown t (`Malformed_response "unexpected eof"); ;; let shutdown_reader t = Reader.force_close t.reader; begin match !(t.state) with | Awaiting_response -> unexpected_eof t; | Closed -> () | Received_response(_, response_body) -> Body.Reader.close response_body; Body.Reader.execute_read response_body; end; ;; let shutdown_writer t = flush_request_body t; Writer.close t.writer; Body.Writer.close t.request_body; ;; let shutdown t = shutdown_reader t; shutdown_writer t; ;; let set_error_and_handle t error = Reader.force_close t.reader; begin match !(t.state) with | Closed -> () | Awaiting_response -> set_error_and_handle_without_shutdown t error; | Received_response(_, response_body) -> Body.Reader.close response_body; Body.Reader.execute_read response_body; set_error_and_handle_without_shutdown t error; end ;; let report_exn t exn = set_error_and_handle t (`Exn exn) ;; let flush_response_body t = match !(t.state) with | Awaiting_response | Closed -> () | Received_response(_, response_body) -> try Body.Reader.execute_read response_body with exn -> report_exn t exn ;; let _next_read_operation t = match !(t.state) with | Awaiting_response | Closed -> Reader.next t.reader | Received_response(_, response_body) -> if not (Body.Reader.is_closed response_body) then Reader.next t.reader else begin Reader.force_close t.reader; Reader.next t.reader end ;; let next_read_operation t = match _next_read_operation t with | `Error (`Parse(marks, message)) -> let message = String.concat "" [ String.concat ">" marks; ": "; message] in set_error_and_handle t (`Malformed_response message); `Close | `Error (`Invalid_response_body_length _ as error) -> set_error_and_handle t error; `Close | (`Read | `Close) as operation -> operation ;; let read_with_more t bs ~off ~len more = let consumed = Reader.read_with_more t.reader bs ~off ~len more in flush_response_body t; consumed ;; let read t bs ~off ~len = read_with_more t bs ~off ~len Incomplete let read_eof t bs ~off ~len = let bytes_read = read_with_more t bs ~off ~len Complete in begin match !(t.state) with | Received_response _ | Closed -> () | Awaiting_response -> unexpected_eof t; end; bytes_read ;; let next_write_operation t = flush_request_body t; if Body.Writer.is_closed t.request_body (* Even though we've just done [flush_request_body], it might still be the case that [Body.Writer.has_pending_output] returns true, because it does so when we've written all output except for the final chunk. *) && not (Body.Writer.has_pending_output t.request_body) then Writer.close t.writer; Writer.next t.writer ;; let yield_writer t k = if Body.Writer.is_closed t.request_body && not (Body.Writer.has_pending_output t.request_body) then begin Writer.close t.writer; k () end else Writer.on_wakeup t.writer k let report_write_result t result = Writer.report_result t.writer result let is_closed t = Reader.is_closed t.reader && Writer.is_closed t.writer end ================================================ FILE: lib/config.ml ================================================ type t = { read_buffer_size : int ; request_body_buffer_size : int ; response_buffer_size : int ; response_body_buffer_size : int } let default = { read_buffer_size = 0x1000 ; request_body_buffer_size = 0x1000 ; response_buffer_size = 0x400 ; response_body_buffer_size = 0x1000 } ================================================ FILE: lib/dune ================================================ (library (name httpaf) (public_name httpaf) (libraries angstrom faraday bigstringaf) (flags (:standard -safe-string))) ================================================ FILE: lib/headers.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) type name = string type value = string type t = (name * value) list let empty : t = [] let of_rev_list t = t let of_list t = of_rev_list (List.rev t) let to_rev_list t = t let to_list t = List.rev (to_rev_list t) module CI = struct (* Convert codes to upper case and compare them. This is a port of assembly code from the page: http://www.azillionmonkeys.com/qed/asmexample.html *) let[@inline always] char_code_equal_ci x y = let codes = (x lsl 8) lor y in let b = 0x8080 lor codes in let c = b - 0x6161 in let d = lnot (b - 0x7b7b) in let e = (c land d) land (lnot codes land 0x8080) in let upper = codes - (e lsr 2) in upper lsr 8 = upper land 0xff let equal x y = let len = String.length x in len = String.length y && ( let equal_so_far = ref true in let i = ref 0 in while !equal_so_far && !i < len do let c1 = Char.code (String.unsafe_get x !i) in let c2 = Char.code (String.unsafe_get y !i) in equal_so_far := char_code_equal_ci c1 c2; incr i done; !equal_so_far ) end let ci_equal = CI.equal let rec mem t name = match t with | (name', _)::t' -> CI.equal name name' || mem t' name | _ -> false let add t name value = (name,value)::t let add_list t ls = ls @ t (* XXX(seliopou): do better here *) let add_multi = let rec loop_outer t lss = match lss with | [] -> t | (n,vs)::lss' -> loop_inner t n vs lss' and loop_inner t n vs lss = match vs with | [] -> loop_outer t lss | v::vs' -> loop_inner ((n,v)::t) n vs' lss in loop_outer let add_unless_exists t name value = if mem t name then t else (name,value)::t exception Local let replace t name value = let rec loop t needle nv seen = match t with | [] -> if not seen then raise Local else [] | (name,_ as nv')::t -> if CI.equal needle name then ( if seen then loop t needle nv true else nv::loop t needle nv true) else nv'::loop t needle nv seen in try loop t name (name,value) false with Local -> t let remove t name = let rec loop s needle seen = match s with | [] -> if not seen then raise Local else [] | (name,_ as nv')::s' -> if CI.equal needle name then loop s' needle true else nv'::(loop s' needle seen) in try loop t name false with Local -> t let get t name = let rec loop t n = match t with | [] -> None | (n',v)::t' -> if CI.equal n n' then Some v else loop t' n in loop t name let get_exn t name = let rec loop t n = match t with | [] -> failwith (Printf.sprintf "Headers.get_exn: %S not found" name) | (n',v)::t' -> if CI.equal n n' then v else loop t' n in loop t name let get_multi t name = let rec loop t n acc = match t with | [] -> acc | (n',v)::t' -> if CI.equal n n' then loop t' n (v::acc) else loop t' n acc in loop t name [] let iter ~f t = List.iter (fun (name,value) -> f name value) t let fold ~f ~init t = List.fold_left (fun acc (name,value) -> f name value acc) init t let to_string t = let b = Buffer.create 128 in iter (to_list t) ~f:(fun name value -> Buffer.add_string b name; Buffer.add_string b ": "; Buffer.add_string b value; Buffer.add_string b "\r\n"); Buffer.add_string b "\r\n"; Buffer.contents b let pp_hum fmt t = let pp_elem fmt (n,v) = Format.fprintf fmt "@[(%S %S)@]" n v in Format.fprintf fmt "@[("; Format.pp_print_list pp_elem fmt (to_list t); Format.fprintf fmt ")@]"; ================================================ FILE: lib/headers.mli ================================================ type t type name = string type value = string (** Case-insensitive equality for testing header names or values *) val ci_equal : string -> string -> bool val empty : t val of_list : (name * value) list -> t val of_rev_list : (name * value) list -> t val to_list : t -> (name * value) list val to_rev_list : t -> (name * value) list val add : t -> name -> value -> t val add_unless_exists : t -> name -> value -> t val add_list : t -> (name * value) list -> t val add_multi : t -> (name * value list) list -> t val remove : t -> name -> t val replace : t -> name -> value -> t val mem : t -> name -> bool val get : t -> name -> value option val get_exn : t -> name -> value val get_multi : t -> name -> value list val iter : f:(name -> value -> unit) -> t -> unit val fold : f:(name -> value -> 'a -> 'a) -> init:'a -> t -> 'a val to_string : t -> string val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] ================================================ FILE: lib/httpaf.ml ================================================ module Headers = Headers module IOVec = IOVec module Method = Method module Reqd = Reqd module Request = Request module Response = Response module Status = Status module Version = Version module Body = Body module Config = Config module Server_connection = Server_connection module Client_connection = Client_connection.Oneshot module Httpaf_private = struct module Parse = Parse module Serialize = Serialize end ================================================ FILE: lib/httpaf.mli ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) (** Http/af is a high-performance, memory-efficient, and scalable web server for OCaml. It implements the HTTP 1.1 specification with respect to parsing, serialization, and connection pipelining. For compatibility, http/af respects the imperatives of the [Server_connection] header when handling HTTP 1.0 connections. To use this library effectively, the user must be familiar with the HTTP 1.1 specification, and the basic principles of memory management and vectorized IO. *) (** {2 Basic HTTP Types} *) (** Protocol Version HTTP uses a "." numbering scheme to indicate versions of the protocol. The protocol version as a whole indicates the sender's conformance with the set of requirements laid out in that version's corresponding specification of HTTP. See {{:https://tools.ietf.org/html/rfc7230#section-2.6} RFC7230§2.6} for more details. *) module Version : sig type t = { major : int (** The major protocol number. *) ; minor : int (** The minor protocol number. *) } val compare : t -> t -> int val to_string : t -> string val of_string : string -> t val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] end (** Request Method The request method token is the primary source of request semantics; it indicates the purpose for which the client has made this request and what is expected by the client as a successful result. See {{:https://tools.ietf.org/html/rfc7231#section-4} RFC7231§4} for more details. *) module Method : sig type standard = [ | `GET (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.1} RFC7231§4.3.1}. Safe, Cacheable. *) | `HEAD (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.2} RFC7231§4.3.2}. Safe, Cacheable. *) | `POST (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.3} RFC7231§4.3.3}. Cacheable. *) | `PUT (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.4} RFC7231§4.3.4}. Idempotent. *) | `DELETE (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.5} RFC7231§4.3.5}. Idempotent. *) | `CONNECT (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.6} RFC7231§4.3.6}. *) | `OPTIONS (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.7} RFC7231§4.3.7}. Safe.*) | `TRACE (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.8} RFC7231§4.3.8}. Safe.*) ] type t = [ | standard | `Other of string (** Methods defined outside of RFC7231, or custom methods. *) ] val is_safe : standard -> bool (** Request methods are considered "safe" if their defined semantics are essentially read-only; i.e., the client does not request, and does not expect, any state change on the origin server as a result of applying a safe method to a target resource. Likewise, reasonable use of a safe method is not expected to cause any harm, loss of property, or unusual burden on the origin server. See {{:https://tools.ietf.org/html/rfc7231#section-4.2.1} RFC7231§4.2.1} for more details. *) val is_cacheable : standard -> bool (** Request methods can be defined as "cacheable" to indicate that responses to them are allowed to be stored for future reuse. See {{:https://tools.ietf.org/html/rfc7234} RFC7234} for more details. *) val is_idempotent : standard -> bool (** A request method is considered "idempotent" if the intended effect on the server of multiple identical requests with that method is the same as the effect for a single such request. Of the request methods defined by this specification, PUT, DELETE, and safe request methods are idempotent. See {{:https://tools.ietf.org/html/rfc7231#section-4.2.2} RFC7231§4.2.2} for more details. *) val to_string : t -> string val of_string : string -> t val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] end (** Response Status Codes The status-code element is a three-digit integer code giving the result of the attempt to understand and satisfy the request. See {{:https://tools.ietf.org/html/rfc7231#section-6} RFC7231§6} for more details. *) module Status : sig type informational = [ | `Continue | `Switching_protocols ] (** The 1xx (Informational) class of status code indicates an interim response for communicating connection status or request progress prior to completing the requested action and sending a final response. See {{:https://tools.ietf.org/html/rfc7231#section-6.2} RFC7231§6.2} for more details. *) type successful = [ | `OK | `Created | `Accepted | `Non_authoritative_information | `No_content | `Reset_content | `Partial_content ] (** The 2xx (Successful) class of status code indicates that the client's request was successfully received, understood, and accepted. See {{:https://tools.ietf.org/html/rfc7231#section-6.3} RFC7231§6.3} for more details. *) type redirection = [ | `Multiple_choices | `Moved_permanently | `Found | `See_other | `Not_modified | `Use_proxy | `Temporary_redirect ] (** The 3xx (Redirection) class of status code indicates that further action needs to be taken by the user agent in order to fulfill the request. See {{:https://tools.ietf.org/html/rfc7231#section-6.4} RFC7231§6.4} for more details. *) type client_error = [ | `Bad_request | `Unauthorized | `Payment_required | `Forbidden | `Not_found | `Method_not_allowed | `Not_acceptable | `Proxy_authentication_required | `Request_timeout | `Conflict | `Gone | `Length_required | `Precondition_failed | `Payload_too_large | `Uri_too_long | `Unsupported_media_type | `Range_not_satisfiable | `Expectation_failed | `Upgrade_required | `I_m_a_teapot | `Enhance_your_calm ] (** The 4xx (Client Error) class of status code indicates that the client seems to have erred. See {{:https://tools.ietf.org/html/rfc7231#section-6.5} RFC7231§6.5} for more details. *) type server_error = [ | `Internal_server_error | `Not_implemented | `Bad_gateway | `Service_unavailable | `Gateway_timeout | `Http_version_not_supported ] (** The 5xx (Server Error) class of status code indicates that the server is aware that it has erred or is incapable of performing the requested method. See {{:https://tools.ietf.org/html/rfc7231#section-6.6} RFC7231§6.6} for more details. *) type standard = [ | informational | successful | redirection | client_error | server_error ] (** The status codes defined in the HTTP 1.1 RFCs *) type t = [ | standard | `Code of int ] (** The standard codes along with support for custom codes. *) val default_reason_phrase : standard -> string (** [default_reason_phrase standard] is the example reason phrase provided by RFC7231 for the [standard] status code. The RFC allows servers to use reason phrases besides these in responses. *) val to_code : t -> int (** [to_code t] is the integer representation of [t]. *) val of_code : int -> t (** [of_code i] is the [t] representation of [i]. [of_code] raises [Failure] if [i] is not a positive three-digit number. *) val unsafe_of_code : int -> t (** [unsafe_of_code i] is equivalent to [of_code i], except it accepts any positive code, regardless of the number of digits it has. On negative codes, it will still raise [Failure]. *) val is_informational : t -> bool (** [is_informational t] is true iff [t] belongs to the Informational class of status codes. *) val is_successful : t -> bool (** [is_successful t] is true iff [t] belongs to the Successful class of status codes. *) val is_redirection : t -> bool (** [is_redirection t] is true iff [t] belongs to the Redirection class of status codes. *) val is_client_error : t -> bool (** [is_client_error t] is true iff [t] belongs to the Client Error class of status codes. *) val is_server_error : t -> bool (** [is_server_error t] is true iff [t] belongs to the Server Error class of status codes. *) val is_error : t -> bool (** [is_error t] is true iff [t] belongs to the Client Error or Server Error class of status codes. *) val to_string : t -> string val of_string : string -> t val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] end (** Header Fields Each header field consists of a case-insensitive {b field name} and a {b field value}. The order in which header fields {i with differing field names} are received is not significant. However, it is good practice to send header fields that contain control data first so that implementations can decide when not to handle a message as early as possible. A sender MUST NOT generate multiple header fields with the same field name in a message unless either the entire field value for that header field is defined as a comma-separated list or the header field is a well-known exception, e.g., [Set-Cookie]. A recipient MAY combine multiple header fields with the same field name into one "field-name: field-value" pair, without changing the semantics of the message, by appending each subsequent field value to the combined field value in order, separated by a comma. {i The order in which header fields with the same field name are received is therefore significant to the interpretation of the combined field value}; a proxy MUST NOT change the order of these field values when forwarding a message. {i Note.} Unless otherwise specified, all operations preserve header field order and all reference to equality on names is assumed to be case-insensitive. See {{:https://tools.ietf.org/html/rfc7230#section-3.2} RFC7230§3.2} for more details. *) module Headers : sig type t type name = string (** The type of a case-insensitive header name. *) type value = string (** The type of a header value. *) (** {3 Constructor} *) val empty : t (** [empty] is the empty collection of header fields. *) val of_list : (name * value) list -> t (** [of_list assoc] is a collection of header fields defined by the association list [assoc]. [of_list] assumes the order of header fields in [assoc] is the intended transmission order. The following equations should hold: {ul {- [to_list (of_list lst) = lst] } {- [get (of_list [("k", "v1"); ("k", "v2")]) "k" = Some "v2"]. }} *) val of_rev_list : (name * value) list -> t (** [of_list assoc] is a collection of header fields defined by the association list [assoc]. [of_list] assumes the order of header fields in [assoc] is the {i reverse} of the intended trasmission order. The following equations should hold: {ul {- [to_list (of_rev_list lst) = List.rev lst] } {- [get (of_rev_list [("k", "v1"); ("k", "v2")]) "k" = Some "v1"]. }} *) val to_list : t -> (name * value) list (** [to_list t] is the association list of header fields contained in [t] in transmission order. *) val to_rev_list : t -> (name * value) list (** [to_rev_list t] is the association list of header fields contained in [t] in {i reverse} transmission order. *) val add : t -> name -> value -> t (** [add t name value] is a collection of header fields that is the same as [t] except with [(name, value)] added at the end of the trasmission order. The following equations should hold: {ul {- [get (add t name value) name = Some value] }} *) val add_unless_exists : t -> name -> value -> t (** [add_unless_exists t name value] is a collection of header fields that is the same as [t] if [t] already inclues [name], and otherwise is equivalent to [add t name value]. *) val add_list : t -> (name * value) list -> t (** [add_list t assoc] is a collection of header fields that is the same as [t] except with all the header fields in [assoc] added to the end of the transmission order, in reverse order. *) val add_multi : t -> (name * value list) list -> t (** [add_multi t assoc] is the same as {[ add_list t (List.concat_map assoc ~f:(fun (name, values) -> List.map values ~f:(fun value -> (name, value)))) ]} but is implemented more efficiently. For example, {[ add_multi t ["name1", ["x", "y"]; "name2", ["p", "q"]] = add_list ["name1", "x"; "name1", "y"; "name2", "p"; "name2", "q"] ]} *) val remove : t -> name -> t (** [remove t name] is a collection of header fields that contains all the header fields of [t] except those that have a header-field name that are equal to [name]. If [t] contains multiple header fields whose name is [name], they will all be removed. *) val replace : t -> name -> value -> t (** [replace t name value] is a collection of header fields that is the same as [t] except with all header fields with a name equal to [name] removed and replaced with a single header field whose name is [name] and whose value is [value]. This new header field will appear in the transmission order where the first occurrence of a header field with a name matching [name] was found. If no header field with a name equal to [name] is present in [t], then the result is simply [t], unchanged. *) (** {3 Destructors} *) val mem : t -> name -> bool (** [mem t name] is true iff [t] includes a header field with a name that is equal to [name]. *) val get : t -> name -> value option (** [get t name] returns the last header from [t] with name [name], or [None] if no such header is present. *) val get_exn : t -> name -> value (** [get t name] returns the last header from [t] with name [name], or raises if no such header is present. *) val get_multi : t -> name -> value list (** [get_multi t name] is the list of header values in [t] whose names are equal to [name]. The returned list is in transmission order. *) (** {3 Iteration} *) val iter : f:(name -> value -> unit) -> t -> unit val fold : f:(name -> value -> 'a -> 'a) -> init:'a -> t -> 'a (** {3 Utilities} *) val to_string : t -> string val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] end (** {2 Message Body} *) module Body : sig module Reader : sig type t val schedule_read : t -> on_eof : (unit -> unit) -> on_read : (Bigstringaf.t -> off:int -> len:int -> unit) -> unit (** [schedule_read t ~on_eof ~on_read] will setup [on_read] and [on_eof] as callbacks for when bytes are available in [t] for the application to consume, or when the input channel has been closed and no further bytes will be received by the application. Once either of these callbacks have been called, they become inactive. The application is responsible for scheduling subsequent reads, either within the [on_read] callback or by some other mechanism. *) val close : t -> unit (** [close t] closes [t], indicating that any subsequent input received should be discarded. *) val is_closed : t -> bool (** [is_closed t] is [true] if {!close} has been called on [t] and [false] otherwise. A closed [t] may still have bytes available for reading. *) end module Writer : sig type t val write_char : t -> char -> unit (** [write_char w char] copies [char] into an internal buffer. If possible, this write will be combined with previous and/or subsequent writes before transmission. *) val write_string : t -> ?off:int -> ?len:int -> string -> unit (** [write_string w ?off ?len str] copies [str] into an internal buffer. If possible, this write will be combined with previous and/or subsequent writes before transmission. *) val write_bigstring : t -> ?off:int -> ?len:int -> Bigstringaf.t -> unit (** [write_bigstring w ?off ?len bs] copies [bs] into an internal buffer. If possible, this write will be combined with previous and/or subsequent writes before transmission. *) val schedule_bigstring : t -> ?off:int -> ?len:int -> Bigstringaf.t -> unit (** [schedule_bigstring w ?off ?len bs] schedules [bs] to be transmitted at the next opportunity without performing a copy. [bs] should not be modified until a subsequent call to {!flush} has successfully completed. *) val flush : t -> (unit -> unit) -> unit (** [flush t f] makes all bytes in [t] available for writing to the awaiting output channel. Once those bytes have reached that output channel, [f] will be called. The type of the output channel is runtime-dependent, as are guarantees about whether those packets have been queued for delivery or have actually been received by the intended recipient. *) val close : t -> unit (** [close t] closes [t], causing subsequent write calls to raise. If [t] is writable, this will cause any pending output to become available to the output channel. *) val is_closed : t -> bool (** [is_closed t] is [true] if {!close} has been called on [t] and [false] otherwise. A closed [t] may still have pending output. *) end end (** {2 Message Types} *) (** Request A client-initiated HTTP message. *) module Request : sig type t = { meth : Method.t ; target : string ; version : Version.t ; headers : Headers.t } val create : ?version:Version.t (** default is HTTP 1.1 *) -> ?headers:Headers.t (** default is {!Headers.empty} *) -> Method.t -> string -> t module Body_length : sig type t = [ | `Fixed of Int64.t | `Chunked | `Error of [`Bad_request] ] val pp_hum : Format.formatter -> t -> unit end val body_length : t -> Body_length.t (** [body_length t] is the length of the message body accompanying [t]. It is an error to generate a request with a close-delimited message body. See {{:https://tools.ietf.org/html/rfc7230#section-3.3.3} RFC7230§3.3.3} for more details. *) val persistent_connection : ?proxy:bool -> t -> bool (** [persistent_connection ?proxy t] indicates whether the connection for [t] can be reused for multiple requests and responses. If the calling code is acting as a proxy, it should pass [~proxy:true]. See {{:https://tools.ietf.org/html/rfc7230#section-6.3} RFC7230§6.3 for more details. *) val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] end (** Response A server-generated message to a {Request}. *) module Response : sig type t = { version : Version.t ; status : Status.t ; reason : string ; headers : Headers.t } val create : ?reason:string (** default is determined by {!Status.default_reason_phrase} *) -> ?version:Version.t (** default is HTTP 1.1 *) -> ?headers:Headers.t (** default is {!Headers.empty} *) -> Status.t -> t (** [create ?reason ?version ?headers status] creates an HTTP response with the given parameters. For typical use cases, it's sufficient to provide values for [headers] and [status]. *) module Body_length : sig type t = [ | `Fixed of Int64.t | `Chunked | `Close_delimited | `Error of [ `Bad_gateway | `Internal_server_error ] ] val pp_hum : Format.formatter -> t -> unit end val body_length : ?proxy:bool -> request_method:Method.standard -> t -> Body_length.t (** [body_length ?proxy ~request_method t] is the length of the message body accompanying [t] assuming it is a response to a request whose method was [request_method]. If the calling code is acting as a proxy, it should pass [~proxy:true]. This optional parameter only affects error reporting. See {{:https://tools.ietf.org/html/rfc7230#section-3.3.3} RFC7230§3.3.3} for more details. *) val persistent_connection : ?proxy:bool -> t -> bool (** [persistent_connection ?proxy t] indicates whether the connection for [t] can be reused for multiple requests and responses. If the calling code is acting as a proxy, it should pass [~proxy:true]. See {{:https://tools.ietf.org/html/rfc7230#section-6.3} RFC7230§6.3 for more details. *) val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] end (** IOVec *) module IOVec : sig type 'a t = 'a Faraday.iovec = { buffer : 'a ; off : int ; len : int } val length : _ t -> int val lengthv : _ t list -> int val shift : 'a t -> int -> 'a t val shiftv : 'a t list -> int -> 'a t list val pp_hum : Format.formatter -> _ t -> unit [@@ocaml.toplevel_printer] end (** {2 Request Descriptor} *) module Reqd : sig type t val request : t -> Request.t val request_body : t -> Body.Reader.t val response : t -> Response.t option val response_exn : t -> Response.t (** Responding The following functions will initiate a response for the corresponding request in [t]. Depending on the state of the current connection, and the header values of the response, this may cause the connection to close or to persist for reuse by the client. See {{:https://tools.ietf.org/html/rfc7230#section-6.3} RFC7230§6.3} for more details. *) val respond_with_string : t -> Response.t -> string -> unit val respond_with_bigstring : t -> Response.t -> Bigstringaf.t -> unit val respond_with_streaming : ?flush_headers_immediately:bool -> t -> Response.t -> Body.Writer.t (** {3 Exception Handling} *) val report_exn : t -> exn -> unit val try_with : t -> (unit -> unit) -> (unit, exn) result end (** {2 Buffer Size Configuration} *) module Config : sig type t = { read_buffer_size : int (** Default is [4096] *) ; request_body_buffer_size : int (** Default is [4096] *) ; response_buffer_size : int (** Default is [1024] *) ; response_body_buffer_size : int (** Default is [4096] *) } val default : t (** [default] is a configuration record with all parameters set to their default values. *) end (** {2 Server Connection} *) module Server_connection : sig type t type error = [ `Bad_request | `Bad_gateway | `Internal_server_error | `Exn of exn ] type request_handler = Reqd.t -> unit type error_handler = ?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit val create : ?config:Config.t -> ?error_handler:error_handler -> request_handler -> t (** [create ?config ?error_handler ~request_handler] creates a connection handler that will service individual requests with [request_handler]. *) val next_read_operation : t -> [ `Read | `Yield | `Close ] (** [next_read_operation t] returns a value describing the next operation that the caller should conduct on behalf of the connection. *) val read : t -> Bigstringaf.t -> off:int -> len:int -> int (** [read t bigstring ~off ~len] reads bytes of input from the provided range of [bigstring] and returns the number of bytes consumed by the connection. {!read} should be called after {!next_read_operation} returns a [`Read] value and additional input is available for the connection to consume. *) val read_eof : t -> Bigstringaf.t -> off:int -> len:int -> int (** [read_eof t bigstring ~off ~len] reads bytes of input from the provided range of [bigstring] and returns the number of bytes consumed by the connection. {!read_eof} should be called after {!next_read_operation} returns a [`Read] and an EOF has been received from the communication channel. The connection will attempt to consume any buffered input and then shutdown the HTTP parser for the connection. *) val yield_reader : t -> (unit -> unit) -> unit (** [yield_reader t continue] registers with the connection to call [continue] when reading should resume. {!yield_reader} should be called after {next_read_operation} returns a [`Yield] value. *) val next_write_operation : t -> [ | `Write of Bigstringaf.t IOVec.t list | `Yield | `Close of int ] (** [next_write_operation t] returns a value describing the next operation that the caller should conduct on behalf of the connection. *) val report_write_result : t -> [`Ok of int | `Closed] -> unit (** [report_write_result t result] reports the result of the latest write attempt to the connection. {report_write_result} should be called after a call to {next_write_operation} that returns a [`Write buffer] value. {ul {- [`Ok n] indicates that the caller successfully wrote [n] bytes of output from the buffer that the caller was provided by {next_write_operation}. } {- [`Closed] indicates that the output destination will no longer accept bytes from the write processor. }} *) val yield_writer : t -> (unit -> unit) -> unit (** [yield_writer t continue] registers with the connection to call [continue] when writing should resume. {!yield_writer} should be called after {next_write_operation} returns a [`Yield] value. *) val report_exn : t -> exn -> unit (** [report_exn t exn] reports that an error [exn] has been caught and that it has been attributed to [t]. Calling this function will switch [t] into an error state. Depending on the state [t] is transitioning from, it may call its error handler before terminating the connection. *) val is_closed : t -> bool (** [is_closed t] is [true] if both the read and write processors have been shutdown. When this is the case {!next_read_operation} will return [`Close _] and {!next_write_operation} will return [`Write _] until all buffered output has been flushed. *) val error_code : t -> error option (** [error_code t] returns the [error_code] that caused the connection to close, if one exists. *) (**/**) val shutdown : t -> unit (**/**) end (** {2 Client Connection} *) module Client_connection : sig type t type error = [ `Malformed_response of string | `Invalid_response_body_length of Response.t | `Exn of exn ] type response_handler = Response.t -> Body.Reader.t -> unit type error_handler = error -> unit val request : ?config:Config.t -> Request.t -> error_handler:error_handler -> response_handler:response_handler -> Body.Writer.t * t val next_read_operation : t -> [ `Read | `Close ] (** [next_read_operation t] returns a value describing the next operation that the caller should conduct on behalf of the connection. *) val read : t -> Bigstringaf.t -> off:int -> len:int -> int (** [read t bigstring ~off ~len] reads bytes of input from the provided range of [bigstring] and returns the number of bytes consumed by the connection. {!read} should be called after {!next_read_operation} returns a [`Read] value and additional input is available for the connection to consume. *) val read_eof : t -> Bigstringaf.t -> off:int -> len:int -> int (** [read_eof t bigstring ~off ~len] reads bytes of input from the provided range of [bigstring] and returns the number of bytes consumed by the connection. {!read_eof} should be called after {!next_read_operation} returns a [`Read] and an EOF has been received from the communication channel. The connection will attempt to consume any buffered input and then shutdown the HTTP parser for the connection. *) val next_write_operation : t -> [ | `Write of Bigstringaf.t IOVec.t list | `Yield | `Close of int ] (** [next_write_operation t] returns a value describing the next operation that the caller should conduct on behalf of the connection. *) val report_write_result : t -> [`Ok of int | `Closed] -> unit (** [report_write_result t result] reports the result of the latest write attempt to the connection. {report_write_result} should be called after a call to {next_write_operation} that returns a [`Write buffer] value. {ul {- [`Ok n] indicates that the caller successfully wrote [n] bytes of output from the buffer that the caller was provided by {next_write_operation}. } {- [`Closed] indicates that the output destination will no longer accept bytes from the write processor. }} *) val yield_writer : t -> (unit -> unit) -> unit (** [yield_writer t continue] registers with the connection to call [continue] when writing should resume. {!yield_writer} should be called after {next_write_operation} returns a [`Yield] value. *) val report_exn : t -> exn -> unit (** [report_exn t exn] reports that an error [exn] has been caught and that it has been attributed to [t]. Calling this function will switch [t] into an error state. Depending on the state [t] is transitioning from, it may call its error handler before terminating the connection. *) val is_closed : t -> bool (**/**) val shutdown : t -> unit (**/**) end (**/**) module Httpaf_private : sig module Parse : sig val request : Request.t Angstrom.t val response : Response.t Angstrom.t end module Serialize : sig val write_request : Faraday.t -> Request.t -> unit val write_response : Faraday.t -> Response.t -> unit end end ================================================ FILE: lib/iOVec.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) type 'a t = 'a Faraday.iovec = { buffer : 'a ; off : int ; len : int } let length { len; _ } = len let lengthv iovs = List.fold_left (fun acc { len; _ } -> acc + len) 0 iovs let shift { buffer; off; len } n = assert (n <= len); { buffer; off = off + n; len = len - n } let shiftv iovecs n = if n < 0 then failwith (Printf.sprintf "IOVec.shiftv: %d is a negative number" n); let rec loop iovecs n = if n = 0 then iovecs else match iovecs with | [] -> failwith "shiftv: n > lengthv iovecs" | iovec::iovecs -> let iovec_len = length iovec in if iovec_len <= n then loop iovecs (n - iovec_len) else (shift iovec n)::iovecs in loop iovecs n let add_len { buffer; off; len } n = { buffer; off; len = len + n } let pp_hum fmt t = Format.fprintf fmt "{ buffer = ; off = %d; len = %d }" t.off t.len ================================================ FILE: lib/message.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) (* This module contains functionality that applies to both requests and responses, which are collectively referred to in the HTTP 1.1 specifications as 'messages'. *) let persistent_connection ?(proxy=false) version headers = let _ = proxy in (* XXX(seliopou): use proxy argument in the case of HTTP/1.0 as per https://tools.ietf.org/html/rfc7230#section-6.3 *) match Headers.get headers "connection" with | Some "close" -> false | Some "keep-alive" -> Version.(compare version v1_0) >= 0 | _ -> Version.(compare version v1_1) >= 0 let sort_uniq xs = (* Though {!List.sort_uniq} performs a check on the input length and returns * immediately for lists of length less than [2], it still allocates closures * before it does that check! To avoid that just do our own checking here to * avoid the allocations in the common case. *) match xs with | [] | [ _ ] -> xs | _ -> List.sort_uniq String.compare xs let unique_content_length_values headers = (* XXX(seliopou): perform proper content-length parsing *) sort_uniq (Headers.get_multi headers "content-length") let content_length_of_string s = try Int64.of_string s with _ -> -1L ================================================ FILE: lib/method.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) type standard = [ | `GET | `HEAD | `POST | `PUT | `DELETE | `CONNECT | `OPTIONS | `TRACE ] type t = [ | standard | `Other of string ] let is_safe = function | `GET | `HEAD | `OPTIONS | `TRACE -> true | _ -> false let is_cacheable = function | `GET | `HEAD | `POST -> true | _ -> false let is_idempotent = function | `PUT | `DELETE -> true | t -> is_safe t let to_string = function | `GET -> "GET" | `HEAD -> "HEAD" | `POST -> "POST" | `PUT -> "PUT" | `DELETE -> "DELETE" | `CONNECT -> "CONNECT" | `OPTIONS -> "OPTIONS" | `TRACE -> "TRACE" | `Other s -> s let of_string = function | "GET" -> `GET | "HEAD" -> `HEAD | "POST" -> `POST | "PUT" -> `PUT | "DELETE" -> `DELETE | "CONNECT" -> `CONNECT | "OPTIONS" -> `OPTIONS | "TRACE" -> `TRACE | s -> `Other s let pp_hum fmt t = Format.fprintf fmt "%s" (to_string t) ================================================ FILE: lib/optional_thunk.ml ================================================ type t = unit -> unit let none = Sys.opaque_identity (fun () -> ()) let some f = if f == none then failwith "Optional_thunk: this function is not representable as a some value"; f let is_none t = t == none let is_some t = not (is_none t) let call_if_some t = t () let unchecked_value t = t ================================================ FILE: lib/optional_thunk.mli ================================================ type t val none : t val some : (unit -> unit) -> t val is_none : t -> bool val is_some : t -> bool val call_if_some : t -> unit val unchecked_value : t -> unit -> unit ================================================ FILE: lib/parse.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2016 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) include Angstrom module P = struct let is_space = function | ' ' | '\t' -> true | _ -> false let is_cr = function | '\r' -> true | _ -> false let is_space_or_colon = function | ' ' | '\t' | ':' -> true | _ -> false let is_hex = function | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false let is_digit = function '0' .. '9' -> true | _ -> false let is_separator = function | ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"' | '/' | '[' | ']' | '?' | '=' | '{' | '}' | ' ' | '\t' -> true | _ -> false let is_token = (* The commented-out ' ' and '\t' are not necessary because of the range at * the top of the match. *) function | '\000' .. '\031' | '\127' | ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"' | '/' | '[' | ']' | '?' | '=' | '{' | '}' (* | ' ' | '\t' *) -> false | _ -> true end let unit = return () let token = take_while1 P.is_token let spaces = skip_while P.is_space let digit = satisfy P.is_digit >>| function | '0' -> 0 | '1' -> 1 | '2' -> 2 | '3' -> 3 | '4' -> 4 | '5' -> 5 | '6' -> 6 | '7' -> 7 | '8' -> 8 | '9' -> 9 | _ -> assert false let eol = string "\r\n" "eol" let hex str = try return (Int64.of_string ("0x" ^ str)) with _ -> fail "hex" let skip_line = take_till P.is_cr *> eol let version = string "HTTP/" *> lift2 (fun major minor -> { Version.major; minor }) (digit <* char '.') digit let header = (* From RFC7230§3.2.4: "No whitespace is allowed between the header field-name and colon. In the past, differences in the handling of such whitespace have led to security vulnerabilities in request routing and response handling. A server MUST reject any received request message that contains whitespace between a header field-name and colon with a response code of 400 (Bad Request). A proxy MUST remove any such whitespace from a response message before forwarding the message downstream." This can be detected by checking the message and marks in a parse failure, which should look like this when serialized "... > header > :". *) lift2 (fun key value -> (key, value)) (take_till P.is_space_or_colon <* char ':' <* spaces) (take_till P.is_cr <* eol >>| String.trim) "header" let headers = let cons x xs = x :: xs in fix (fun headers -> let _emp = return [] in let _rec = lift2 cons header headers in peek_char_fail >>= function | '\r' -> _emp | _ -> _rec) >>| Headers.of_list let request = let meth = take_till P.is_space >>| Method.of_string in lift4 (fun meth target version headers -> Request.create ~version ~headers meth target) (meth <* char ' ') (take_till P.is_space <* char ' ') (version <* eol <* commit) (headers <* eol) let response = let status = take_while P.is_digit >>= fun str -> if String.length str = 0 then fail "status-code empty" else ( if String.length str > 3 then fail (Printf.sprintf "status-code too long: %S" str) else return (Status.of_string str)) in lift4 (fun version status reason headers -> Response.create ~reason ~version ~headers status) (version <* char ' ') (status <* char ' ') (take_till P.is_cr <* eol <* commit) (headers <* eol) let finish body = Body.Reader.close body; commit let schedule_size body n = let faraday = Body.Reader.unsafe_faraday body in (* XXX(seliopou): performance regression due to switching to a single output * format in Farady. Once a specialized operation is exposed to avoid the * intemediate copy, this should be back to the original performance. *) begin if Faraday.is_closed faraday then advance n else take n >>| fun s -> Faraday.write_string faraday s end *> commit let body ~encoding body = let rec fixed n ~unexpected = if n = 0L then unit else at_end_of_input >>= function | true -> finish body *> fail unexpected | false -> available >>= fun m -> let m' = Int64.(min (of_int m) n) in let n' = Int64.sub n m' in schedule_size body (Int64.to_int m') >>= fun () -> fixed n' ~unexpected in match encoding with | `Fixed n -> fixed n ~unexpected:"expected more from fixed body" >>= fun () -> finish body | `Chunked -> (* XXX(seliopou): The [eol] in this parser should really parse a collection * of "chunk extensions", as defined in RFC7230§4.1. These do not show up * in the wild very frequently, and the httpaf API has no way of exposing * them to the suer, so for now the parser does not attempt to recognize * them. This means that any chunked messages that contain chunk extensions * will fail to parse. *) fix (fun p -> let _hex = (take_while1 P.is_hex >>= fun size -> hex size) (* swallows chunk-ext, if present, and CRLF *) <* (eol *> commit) in _hex >>= fun size -> if size = 0L then eol >>= fun _eol -> finish body else fixed size ~unexpected:"expected more from body chunk" *> eol *> p) | `Close_delimited -> fix (fun p -> let _rec = (available >>= fun n -> schedule_size body n) *> p in at_end_of_input >>= function | true -> finish body | false -> _rec) module Reader = struct module AU = Angstrom.Unbuffered type request_error = [ | `Bad_request of Request.t | `Parse of string list * string ] type response_error = [ | `Invalid_response_body_length of Response.t | `Parse of string list * string ] type 'error parse_state = | Done | Fail of 'error | Partial of (Bigstringaf.t -> off:int -> len:int -> AU.more -> (unit, 'error) result AU.state) type 'error t = { parser : (unit, 'error) result Angstrom.t ; mutable parse_state : 'error parse_state (* The state of the parse for the current request *) ; mutable closed : bool (* Whether the input source has left the building, indicating that no * further input will be received. *) } type request = request_error t type response = response_error t let create parser = { parser ; parse_state = Done ; closed = false } let ok = return (Ok ()) let request handler = let parser = request <* commit >>= fun request -> match Request.body_length request with | `Error `Bad_request -> return (Error (`Bad_request request)) | `Fixed 0L -> handler request Body.Reader.empty; ok | `Fixed _ | `Chunked as encoding -> let request_body = Body.Reader.create Bigstringaf.empty in handler request request_body; body ~encoding request_body *> ok in create parser let response ~request_method handler = let parser = response <* commit >>= fun response -> let proxy = false in match Response.body_length ~request_method response with | `Error `Bad_gateway -> assert (not proxy); assert false | `Error `Internal_server_error -> return (Error (`Invalid_response_body_length response)) | `Fixed 0L -> handler response Body.Reader.empty; ok | `Fixed _ | `Chunked | `Close_delimited as encoding -> (* We do not trust the length provided in the [`Fixed] case, as the client could DOS easily. *) let response_body = Body.Reader.create Bigstringaf.empty in handler response response_body; body ~encoding response_body *> ok in create parser ;; let is_closed t = t.closed let transition t state = match state with | AU.Done(consumed, Ok ()) -> t.parse_state <- Done; consumed | AU.Done(consumed, Error error) -> t.parse_state <- Fail error; consumed | AU.Fail(consumed, marks, msg) -> t.parse_state <- Fail (`Parse(marks, msg)); consumed | AU.Partial { committed; continue } -> t.parse_state <- Partial continue; committed and start t state = match state with | AU.Done _ -> failwith "httpaf.Parse.unable to start parser" | AU.Fail(0, marks, msg) -> t.parse_state <- Fail (`Parse(marks, msg)) | AU.Partial { committed = 0; continue } -> t.parse_state <- Partial continue | _ -> assert false ;; let rec read_with_more t bs ~off ~len more = let consumed = match t.parse_state with | Fail _ -> 0 (* Don't feed empty input when we're at a request boundary *) | Done when len = 0 -> 0 | Done -> start t (AU.parse t.parser); read_with_more t bs ~off ~len more; | Partial continue -> transition t (continue bs more ~off ~len) in begin match more with | Complete when consumed = len -> t.closed <- true; | Complete | Incomplete -> () end; consumed; ;; let force_close t = t.closed <- true; ;; let next t = match t.parse_state with | Fail err -> `Error err | Done | Partial _ -> if t.closed then `Close else `Read ;; end ================================================ FILE: lib/reqd.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) type error = [ `Bad_request | `Bad_gateway | `Internal_server_error | `Exn of exn ] module Response_state = struct type t = | Waiting | Fixed of Response.t | Streaming of Response.t * Body.Writer.t end module Input_state = struct type t = | Ready | Complete end module Output_state = struct type t = | Waiting | Ready | Complete end type error_handler = ?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit module Writer = Serialize.Writer (* XXX(seliopou): The current design assumes that a new [Reqd.t] will be * allocated for each new request/response on a connection. This is wasteful, * as it creates garbage on persistent connections. A better approach would be * to allocate a single [Reqd.t] per connection and reuse it across * request/responses. This would allow a single [Faraday.t] to be allocated for * the body and reused. The [response_state] type could then be inlined into * the [Reqd.t] record, with dummy values occuping the fields for [response]. * Something like this: * * {[ * type 'handle t = * { mutable request : Request.t * ; mutable request_body : Response.Body.Reader.t * ; mutable response : Response.t (* Starts off as a dummy value, * * using [(==)] to identify it when * * necessary *) * ; mutable response_body : Response.Body.Writer.t * ; mutable persistent : bool * ; mutable response_state : [ `Waiting | `Started | `Streaming ] * } * ]} * * *) type t = { request : Request.t ; request_body : Body.Reader.t ; writer : Writer.t ; response_body_buffer : Bigstringaf.t ; error_handler : error_handler ; mutable persistent : bool ; mutable response_state : Response_state.t ; mutable error_code : [`Ok | error ] } let create error_handler request request_body writer response_body_buffer = { request ; request_body ; writer ; response_body_buffer ; error_handler ; persistent = Request.persistent_connection request ; response_state = Waiting ; error_code = `Ok } let request { request; _ } = request let request_body { request_body; _ } = request_body let response { response_state; _ } = match response_state with | Waiting -> None | Streaming (response, _) | Fixed response -> Some response let response_exn { response_state; _ } = match response_state with | Waiting -> failwith "httpaf.Reqd.response_exn: response has not started" | Streaming (response, _) | Fixed response -> response let respond_with_string t response str = if t.error_code <> `Ok then failwith "httpaf.Reqd.respond_with_string: invalid state, currently handling error"; match t.response_state with | Waiting -> (* XXX(seliopou): check response body length *) Writer.write_response t.writer response; Writer.write_string t.writer str; if t.persistent then t.persistent <- Response.persistent_connection response; t.response_state <- Fixed response; Writer.wakeup t.writer; | Streaming _ -> failwith "httpaf.Reqd.respond_with_string: response already started" | Fixed _ -> failwith "httpaf.Reqd.respond_with_string: response already complete" let respond_with_bigstring t response (bstr:Bigstringaf.t) = if t.error_code <> `Ok then failwith "httpaf.Reqd.respond_with_bigstring: invalid state, currently handling error"; match t.response_state with | Waiting -> (* XXX(seliopou): check response body length *) Writer.write_response t.writer response; Writer.schedule_bigstring t.writer bstr; if t.persistent then t.persistent <- Response.persistent_connection response; t.response_state <- Fixed response; Writer.wakeup t.writer; | Streaming _ -> failwith "httpaf.Reqd.respond_with_bigstring: response already started" | Fixed _ -> failwith "httpaf.Reqd.respond_with_bigstring: response already complete" let unsafe_respond_with_streaming ~flush_headers_immediately t response = match t.response_state with | Waiting -> let encoding = match Response.body_length ~request_method:t.request.meth response with | `Fixed _ | `Close_delimited | `Chunked as encoding -> encoding | `Error (`Bad_gateway | `Internal_server_error) -> failwith "httpaf.Reqd.respond_with_streaming: invalid response body length" in let response_body = Body.Writer.create t.response_body_buffer ~encoding ~when_ready_to_write:(fun () -> Writer.wakeup t.writer) in Writer.write_response t.writer response; if t.persistent then t.persistent <- Response.persistent_connection response; t.response_state <- Streaming (response, response_body); if flush_headers_immediately then Writer.wakeup t.writer; response_body | Streaming _ -> failwith "httpaf.Reqd.respond_with_streaming: response already started" | Fixed _ -> failwith "httpaf.Reqd.respond_with_streaming: response already complete" let respond_with_streaming ?(flush_headers_immediately=false) t response = if t.error_code <> `Ok then failwith "httpaf.Reqd.respond_with_streaming: invalid state, currently handling error"; unsafe_respond_with_streaming ~flush_headers_immediately t response let report_error t error = t.persistent <- false; Body.Reader.close t.request_body; match t.response_state, t.error_code with | Waiting, `Ok -> t.error_code <- (error :> [`Ok | error]); let status = match (error :> [error | Status.standard]) with | `Exn _ -> `Internal_server_error | #Status.standard as status -> status in t.error_handler ~request:t.request error (fun headers -> unsafe_respond_with_streaming ~flush_headers_immediately:true t (Response.create ~headers status)) | Waiting, `Exn _ -> (* XXX(seliopou): Decide what to do in this unlikely case. There is an * outstanding call to the [error_handler], but an intervening exception * has been reported as well. *) failwith "httpaf.Reqd.report_exn: NYI" | Streaming (_response, response_body), `Ok -> Body.Writer.close response_body | Streaming (_response, response_body), `Exn _ -> Body.Writer.close response_body; Writer.close_and_drain t.writer | (Fixed _ | Streaming _ | Waiting) , _ -> (* XXX(seliopou): Once additional logging support is added, log the error * in case it is not spurious. *) () let report_exn t exn = report_error t (`Exn exn) let try_with t f : (unit, exn) result = try f (); Ok () with exn -> report_exn t exn; Error exn (* Private API, not exposed to the user through httpaf.mli *) let close_request_body { request_body; _ } = Body.Reader.close request_body let error_code t = match t.error_code with | #error as error -> Some error | `Ok -> None let persistent_connection t = t.persistent let input_state t : Input_state.t = if Body.Reader.is_closed t.request_body then Complete else Ready ;; let output_state t : Output_state.t = match t.response_state with | Fixed _ -> Complete | Streaming (_, response_body) -> if Body.Writer.has_pending_output response_body then Ready else if Body.Writer.is_closed response_body then Complete else Waiting | Waiting -> Waiting ;; let flush_request_body t = if Body.Reader.has_pending_output t.request_body then try Body.Reader.execute_read t.request_body with exn -> report_exn t exn let flush_response_body t = match t.response_state with | Streaming (_, response_body) -> Body.Writer.transfer_to_writer response_body t.writer | _ -> () ================================================ FILE: lib/request.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) type t = { meth : Method.t ; target : string ; version : Version.t ; headers : Headers.t } let create ?(version=Version.v1_1) ?(headers=Headers.empty) meth target = { meth; target; version; headers } let bad_request = `Error `Bad_request module Body_length = struct type t = [ | `Fixed of Int64.t | `Chunked | `Error of [`Bad_request] ] let pp_hum fmt (len : t) = match len with | `Fixed n -> Format.fprintf fmt "Fixed %Li" n | `Chunked -> Format.pp_print_string fmt "Chunked" | `Error `Bad_request -> Format.pp_print_string fmt "Error: Bad request" ;; end let body_length { headers; _ } : Body_length.t = (* The last entry in transfer-encoding is the correct entry. We only accept chunked transfer-encodings. *) match List.rev (Headers.get_multi headers "transfer-encoding") with | value::_ when Headers.ci_equal value "chunked" -> `Chunked | _ ::_ -> bad_request | [] -> begin match Message.unique_content_length_values headers with | [] -> `Fixed 0L | [ len ] -> let len = Message.content_length_of_string len in if len >= 0L then `Fixed len else bad_request | _ -> bad_request end let persistent_connection ?proxy { version; headers; _ } = Message.persistent_connection ?proxy version headers let pp_hum fmt { meth; target; version; headers } = Format.fprintf fmt "((method \"%a\") (target %S) (version \"%a\") (headers %a))" Method.pp_hum meth target Version.pp_hum version Headers.pp_hum headers ================================================ FILE: lib/response.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) type t = { version : Version.t ; status : Status.t ; reason : string ; headers : Headers.t } let create ?reason ?(version=Version.v1_1) ?(headers=Headers.empty) status = let reason = match reason with | Some reason -> reason | None -> begin match status with | #Status.standard as status -> Status.default_reason_phrase status | `Code _ -> "Non-standard status code" end in { version; status; reason; headers } let persistent_connection ?proxy { version; headers; _ } = Message.persistent_connection ?proxy version headers let proxy_error = `Error `Bad_gateway let server_error = `Error `Internal_server_error module Body_length = struct type t = [ | `Fixed of Int64.t | `Chunked | `Close_delimited | `Error of [ `Bad_gateway | `Internal_server_error ] ] let pp_hum fmt (len : t) = match len with | `Fixed n -> Format.fprintf fmt "Fixed %Li" n | `Chunked -> Format.pp_print_string fmt "Chunked" | `Close_delimited -> Format.pp_print_string fmt "Close delimited" | `Error `Bad_gateway -> Format.pp_print_string fmt "Error: Bad gateway" | `Error `Internal_server_error -> Format.pp_print_string fmt "Error: Internal server error" ;; end let body_length ?(proxy=false) ~request_method { status; headers; _ } : Body_length.t = match status, request_method with | _, `HEAD -> `Fixed 0L | (`No_content | `Not_modified), _ -> `Fixed 0L | s, _ when Status.is_informational s -> `Fixed 0L | s, `CONNECT when Status.is_successful s -> `Close_delimited | _, _ -> (* The last entry in transfer-encoding is the correct entry. We only handle chunked transfer-encodings. *) begin match List.rev (Headers.get_multi headers "transfer-encoding") with | value::_ when Headers.ci_equal value "chunked" -> `Chunked | _ ::_ -> `Close_delimited | [] -> begin match Message.unique_content_length_values headers with | [] -> `Close_delimited | [ len ] -> let len = Message.content_length_of_string len in if len >= 0L then `Fixed len else if proxy then proxy_error else server_error | _ -> if proxy then proxy_error else server_error end end let pp_hum fmt { version; status; reason; headers } = Format.fprintf fmt "((version \"%a\") (status %a) (reason %S) (headers %a))" Version.pp_hum version Status.pp_hum status reason Headers.pp_hum headers ================================================ FILE: lib/serialize.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) open Faraday let write_space t = write_char t ' ' let write_crlf t = write_string t "\r\n" let write_version t version = write_string t (Version.to_string version) let write_method t meth = write_string t (Method.to_string meth) let write_status t status = write_string t (Status.to_string status) let write_headers t headers = (* XXX(seliopou): escape these thigns *) List.iter (fun (name, value) -> write_string t name; write_string t ": "; write_string t value; write_crlf t) (Headers.to_list headers); write_crlf t let write_request t { Request.meth; target; version; headers } = write_method t meth ; write_space t; write_string t target ; write_space t; write_version t version; write_crlf t; write_headers t headers let write_response t { Response.version; status; reason; headers } = write_version t version; write_space t; write_status t status ; write_space t; write_string t reason ; write_crlf t; write_headers t headers let write_chunk_length t len = write_string t (Printf.sprintf "%x" len); write_crlf t let write_string_chunk t chunk = write_chunk_length t (String.length chunk); write_string t chunk; write_crlf t let write_bigstring_chunk t chunk = write_chunk_length t (Bigstringaf.length chunk); write_bigstring t chunk; write_crlf t let schedule_bigstring_chunk t chunk = write_chunk_length t (Bigstringaf.length chunk); schedule_bigstring t chunk; write_crlf t module Writer = struct type t = { buffer : Bigstringaf.t (* The buffer that the encoder uses for buffered writes. Managed by the * control module for the encoder. *) ; encoder : Faraday.t (* The encoder that handles encoding for writes. Uses the [buffer] * referenced above internally. *) ; mutable drained_bytes : int (* The number of bytes that were not written due to the output stream * being closed before all buffered output could be written. Useful for * detecting error cases. *) ; mutable wakeup : Optional_thunk.t (* The callback from the runtime to be invoked when output is ready to be * flushed. *) } let create ?(buffer_size=0x800) () = let buffer = Bigstringaf.create buffer_size in let encoder = Faraday.of_bigstring buffer in { buffer ; encoder ; drained_bytes = 0 ; wakeup = Optional_thunk.none } let faraday t = t.encoder let write_request t request = write_request t.encoder request let write_response t response = write_response t.encoder response let write_string t ?off ?len string = write_string t.encoder ?off ?len string let write_bytes t ?off ?len bytes = write_bytes t.encoder ?off ?len bytes let write_bigstring t ?off ?len bigstring = write_bigstring t.encoder ?off ?len bigstring let schedule_bigstring t ?off ?len bigstring = schedule_bigstring t.encoder ?off ?len bigstring let schedule_fixed t iovecs = List.iter (fun { IOVec.buffer; off; len } -> schedule_bigstring t ~off ~len buffer) iovecs let schedule_chunk t iovecs = let length = IOVec.lengthv iovecs in write_chunk_length t.encoder length; schedule_fixed t iovecs; write_crlf t.encoder let on_wakeup t k = if Faraday.is_closed t.encoder then failwith "on_wakeup on closed writer" else if Optional_thunk.is_some t.wakeup then failwith "on_wakeup: only one callback can be registered at a time" else t.wakeup <- Optional_thunk.some k ;; let wakeup t = let f = t.wakeup in t.wakeup <- Optional_thunk.none; Optional_thunk.call_if_some f ;; let flush t f = flush t.encoder f let unyield t = (* This would be better implemented by a function that just takes the encoder out of a yielded state if it's in that state. Requires a change to the faraday library. *) flush t (fun () -> ()) let yield t = Faraday.yield t.encoder let close t = Faraday.close t.encoder let close_and_drain t = Faraday.close t.encoder; let drained = Faraday.drain t.encoder in t.drained_bytes <- t.drained_bytes + drained; wakeup t let is_closed t = Faraday.is_closed t.encoder let drained_bytes t = t.drained_bytes let report_result t result = match result with | `Closed -> close_and_drain t | `Ok len -> shift t.encoder len let next t = assert (Optional_thunk.is_none t.wakeup); match Faraday.operation t.encoder with | `Close -> `Close (drained_bytes t) | `Yield -> `Yield | `Writev iovecs -> `Write iovecs end ================================================ FILE: lib/server_connection.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) module Queue = struct include Queue let peek_exn = peek let peek t = if is_empty t then None else Some (peek_exn t) end module Reader = Parse.Reader module Writer = Serialize.Writer type request_handler = Reqd.t -> unit type error = [ `Bad_gateway | `Bad_request | `Internal_server_error | `Exn of exn] type error_handler = ?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit type t = { reader : Reader.request ; writer : Writer.t ; response_body_buffer : Bigstringaf.t ; request_handler : request_handler ; error_handler : error_handler ; request_queue : Reqd.t Queue.t (* invariant: If [request_queue] is not empty, then the head of the queue has already had [request_handler] called on it. *) ; mutable is_errored : bool (* if there is a parse or connection error, we invoke the [error_handler] and set [is_errored] to indicate we should not close the writer yet. *) ; mutable wakeup_reader : Optional_thunk.t } let is_closed t = Reader.is_closed t.reader && Writer.is_closed t.writer let is_active t = not (Queue.is_empty t.request_queue) let current_reqd_exn t = Queue.peek_exn t.request_queue let yield_reader t k = if is_closed t then failwith "yield_reader on closed conn" else if Optional_thunk.is_some t.wakeup_reader then failwith "yield_reader: only one callback can be registered at a time" else t.wakeup_reader <- Optional_thunk.some k ;; let wakeup_reader t = let f = t.wakeup_reader in t.wakeup_reader <- Optional_thunk.none; Optional_thunk.call_if_some f ;; let yield_writer t k = if Writer.is_closed t.writer then k () else Writer.on_wakeup t.writer k ;; let wakeup_writer t = Writer.wakeup t.writer let default_error_handler ?request:_ error handle = let message = match error with | `Exn exn -> Printexc.to_string exn | (#Status.client_error | #Status.server_error) as error -> Status.to_string error in let body = handle Headers.empty in Body.Writer.write_string body message; Body.Writer.close body ;; let create ?(config=Config.default) ?(error_handler=default_error_handler) request_handler = let { Config . response_buffer_size ; response_body_buffer_size ; _ } = config in let writer = Writer.create ~buffer_size:response_buffer_size () in let request_queue = Queue.create () in let response_body_buffer = Bigstringaf.create response_body_buffer_size in let handler request request_body = let reqd = Reqd.create error_handler request request_body writer response_body_buffer in Queue.push reqd request_queue; in { reader = Reader.request handler ; writer ; response_body_buffer ; request_handler = request_handler ; error_handler = error_handler ; request_queue ; is_errored = false ; wakeup_reader = Optional_thunk.none } let shutdown_reader t = if is_active t then Reqd.close_request_body (current_reqd_exn t); Reader.force_close t.reader; wakeup_reader t let shutdown_writer t = if is_active t then ( let reqd = current_reqd_exn t in (* XXX(dpatti): I'm not sure I understand why we close the *request* body here. Maybe we can write a test such that removing this line causes it to fail? *) Reqd.close_request_body reqd; Reqd.flush_response_body reqd); Writer.close t.writer; wakeup_writer t let error_code t = if is_active t then Reqd.error_code (current_reqd_exn t) else None let shutdown t = shutdown_reader t; shutdown_writer t let set_error_and_handle ?request t error = if is_active t then begin assert (request = None); let reqd = current_reqd_exn t in Reqd.report_error reqd error end else begin t.is_errored <- true; let status = match (error :> [error | Status.standard]) with | `Exn _ -> `Internal_server_error | #Status.standard as status -> status in shutdown_reader t; let writer = t.writer in t.error_handler ?request error (fun headers -> let response = Response.create ~headers status in Writer.write_response writer response; let encoding = (* If we haven't parsed the request method, just use GET as a standard placeholder. The method is only used for edge cases, like HEAD or CONNECT. *) let request_method = match request with | None -> `GET | Some request -> request.meth in match Response.body_length ~request_method response with | `Fixed _ | `Close_delimited as encoding -> encoding | `Chunked -> (* XXX(dpatti): Because we pass the writer's faraday directly to the new body, we don't write the chunked encoding. A client won't be able to interpret this. *) `Close_delimited | `Error (`Bad_gateway | `Internal_server_error) -> failwith "httpaf.Server_connection.error_handler: invalid response body length" in Body.Writer.of_faraday (Writer.faraday writer) ~encoding ~when_ready_to_write:(fun () -> Writer.wakeup writer)); end let report_exn t exn = set_error_and_handle t (`Exn exn) let advance_request_queue t = ignore (Queue.take t.request_queue); if not (Queue.is_empty t.request_queue) then t.request_handler (Queue.peek_exn t.request_queue); ;; let rec _next_read_operation t = if not (is_active t) then ( (* If the request queue is empty, there is no connection error, and the reader is closed, then we can assume that no more user code will be able to write. *) if Reader.is_closed t.reader && not t.is_errored then shutdown_writer t; Reader.next t.reader ) else ( let reqd = current_reqd_exn t in match Reqd.input_state reqd with | Ready -> Reader.next t.reader | Complete -> _final_read_operation_for t reqd ) and _final_read_operation_for t reqd = if not (Reqd.persistent_connection reqd) then ( shutdown_reader t; Reader.next t.reader; ) else ( match Reqd.output_state reqd with | Waiting | Ready -> (* XXX(dpatti): This is a way in which the reader and writer are not parallel -- we tell the writer when it needs to yield but the reader is always asking for more data. This is the only branch in either operation function that does not return `(Reader|Writer).next`, which means there are surprising states you can get into. For example, we ask the runtime to yield but then raise when it tries to because the reader is closed. I don't think checking `is_closed` here makes sense semantically, but I don't think checking it in `_next_read_operation` makes sense either. I chose here so I could describe why. *) if Reader.is_closed t.reader then Reader.next t.reader else `Yield | Complete -> advance_request_queue t; _next_read_operation t; ) ;; let next_read_operation t = match _next_read_operation t with | `Error (`Parse _) -> set_error_and_handle t `Bad_request; `Close | `Error (`Bad_request request) -> set_error_and_handle ~request t `Bad_request; `Close | (`Read | `Yield | `Close) as operation -> operation let rec read_with_more t bs ~off ~len more = let call_handler = Queue.is_empty t.request_queue in let consumed = Reader.read_with_more t.reader bs ~off ~len more in if is_active t then ( let reqd = current_reqd_exn t in if call_handler then t.request_handler reqd; Reqd.flush_request_body reqd; ); (* Keep consuming input as long as progress is made and data is available, in case multiple requests were received at once. *) if consumed > 0 && consumed < len then let off = off + consumed and len = len - consumed in consumed + read_with_more t bs ~off ~len more else consumed ;; let read t bs ~off ~len = read_with_more t bs ~off ~len Incomplete let read_eof t bs ~off ~len = read_with_more t bs ~off ~len Complete let rec _next_write_operation t = if not (is_active t) then Writer.next t.writer else ( let reqd = current_reqd_exn t in match Reqd.output_state reqd with | Waiting -> Writer.next t.writer | Ready -> Reqd.flush_response_body reqd; Writer.next t.writer | Complete -> _final_write_operation_for t reqd ) and _final_write_operation_for t reqd = let next = if not (Reqd.persistent_connection reqd) then ( shutdown_writer t; Writer.next t.writer; ) else ( match Reqd.input_state reqd with | Ready -> Writer.next t.writer; | Complete -> advance_request_queue t; _next_write_operation t; ) in (* The only reason the reader yields is to wait for the writer, so we need to notify it that we've completed. *) wakeup_reader t; next ;; let next_write_operation t = _next_write_operation t let report_write_result t result = Writer.report_result t.writer result ================================================ FILE: lib/status.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) type informational = [ | `Continue | `Switching_protocols ] type successful = [ | `OK | `Created | `Accepted | `Non_authoritative_information | `No_content | `Reset_content | `Partial_content ] type redirection = [ | `Multiple_choices | `Moved_permanently | `Found | `See_other | `Not_modified | `Use_proxy | `Temporary_redirect ] type client_error = [ | `Bad_request | `Unauthorized | `Payment_required | `Forbidden | `Not_found | `Method_not_allowed | `Not_acceptable | `Proxy_authentication_required | `Request_timeout | `Conflict | `Gone | `Length_required | `Precondition_failed | `Payload_too_large | `Uri_too_long | `Unsupported_media_type | `Range_not_satisfiable | `Expectation_failed | `I_m_a_teapot | `Enhance_your_calm | `Upgrade_required ] type server_error = [ | `Internal_server_error | `Not_implemented | `Bad_gateway | `Service_unavailable | `Gateway_timeout | `Http_version_not_supported ] type standard = [ | informational | successful | redirection | client_error | server_error ] type t = [ | standard | `Code of int ] let default_reason_phrase = function (* Informational *) | `Continue -> "Continue" | `Switching_protocols -> "Switching Protocols" (* Successful *) | `OK -> "OK" | `Created -> "Created" | `Accepted -> "Accepted" | `Non_authoritative_information -> "Non-Authoritative Information" | `No_content -> "No Content" | `Reset_content -> "Reset Content" | `Partial_content -> "Partial Content" (* Redirection *) | `Multiple_choices -> "Multiple Choices" | `Moved_permanently -> "Moved Permanently" | `Found -> "Found" | `See_other -> "See Other" | `Not_modified -> "Not Modified" | `Use_proxy -> "Use Proxy" | `Temporary_redirect -> "Temporary Redirect" (* Client error *) | `Bad_request -> "Bad Request" | `Unauthorized -> "Unauthorized" | `Payment_required -> "Payment Required" | `Forbidden -> "Forbidden" | `Not_found -> "Not Found" | `Method_not_allowed -> "Method Not Allowed" | `Not_acceptable-> "Not Acceptable" | `Proxy_authentication_required -> "Proxy Authentication Required" | `Request_timeout -> "Request Timeout" | `Conflict -> "Conflict" | `Gone -> "Gone" | `Length_required -> "Length Required" | `Precondition_failed -> "Precondition Failed" | `Payload_too_large -> "Payload Too Large" | `Uri_too_long -> "URI Too Long" | `Unsupported_media_type -> "Unsupported Media Type" | `Range_not_satisfiable -> "Range Not Satisfiable" | `Expectation_failed -> "Expectation Failed" | `I_m_a_teapot -> "I'm a teapot" (* RFC 2342 *) | `Enhance_your_calm -> "Enhance Your Calm" | `Upgrade_required -> "Upgrade Required" (* Server error *) | `Internal_server_error -> "Internal Server Error" | `Not_implemented -> "Not Implemented" | `Bad_gateway -> "Bad Gateway" | `Service_unavailable-> "Service Unavailable" | `Gateway_timeout -> "Gateway Timeout" | `Http_version_not_supported -> "HTTP Version Not Supported" let to_code = function (* Informational *) | `Continue -> 100 | `Switching_protocols -> 101 (* Successful *) | `OK -> 200 | `Created -> 201 | `Accepted -> 202 | `Non_authoritative_information -> 203 | `No_content -> 204 | `Reset_content -> 205 | `Partial_content -> 206 (* Redirection *) | `Multiple_choices -> 300 | `Moved_permanently -> 301 | `Found -> 302 | `See_other -> 303 | `Not_modified -> 304 | `Use_proxy -> 305 | `Temporary_redirect -> 307 (* Client error *) | `Bad_request -> 400 | `Unauthorized -> 401 | `Payment_required -> 402 | `Forbidden -> 403 | `Not_found -> 404 | `Method_not_allowed -> 405 | `Not_acceptable -> 406 | `Proxy_authentication_required -> 407 | `Request_timeout -> 408 | `Conflict -> 409 | `Gone -> 410 | `Length_required -> 411 | `Precondition_failed -> 412 | `Payload_too_large -> 413 | `Uri_too_long -> 414 | `Unsupported_media_type -> 415 | `Range_not_satisfiable -> 416 | `Expectation_failed -> 417 | `I_m_a_teapot -> 418 | `Enhance_your_calm -> 420 | `Upgrade_required -> 426 (* Server error *) | `Internal_server_error -> 500 | `Not_implemented -> 501 | `Bad_gateway -> 502 | `Service_unavailable-> 503 | `Gateway_timeout -> 504 | `Http_version_not_supported -> 505 | `Code c -> c let really_unsafe_of_code = function (* Informational *) | 100 -> `Continue | 101 -> `Switching_protocols (* Successful *) | 200 -> `OK | 201 -> `Created | 202 -> `Accepted | 203 -> `Non_authoritative_information | 204 -> `No_content | 205 -> `Reset_content | 206 -> `Partial_content (* Redirection *) | 300 -> `Multiple_choices | 301 -> `Moved_permanently | 302 -> `Found | 303 -> `See_other | 304 -> `Not_modified | 305 -> `Use_proxy | 307 -> `Temporary_redirect (* Client error *) | 400 -> `Bad_request | 401 -> `Unauthorized | 402 -> `Payment_required | 403 -> `Forbidden | 404 -> `Not_found | 405 -> `Method_not_allowed | 406 -> `Not_acceptable | 407 -> `Proxy_authentication_required | 408 -> `Request_timeout | 409 -> `Conflict | 410 -> `Gone | 411 -> `Length_required | 412 -> `Precondition_failed | 413 -> `Payload_too_large | 414 -> `Uri_too_long | 415 -> `Unsupported_media_type | 416 -> `Range_not_satisfiable | 417 -> `Expectation_failed | 418 -> `I_m_a_teapot | 420 -> `Enhance_your_calm | 426 -> `Upgrade_required (* Server error *) | 500 -> `Internal_server_error | 501 -> `Not_implemented | 502 -> `Bad_gateway | 503 -> `Service_unavailable | 504 -> `Gateway_timeout | 505 -> `Http_version_not_supported | c -> `Code c let unsafe_of_code c = match really_unsafe_of_code c with | `Code c -> if c < 0 then failwith (Printf.sprintf "Status.unsafe_of_code: %d is negative" c) else `Code c | s -> s let of_code c = match really_unsafe_of_code c with | `Code c -> if c < 100 || c > 999 then failwith (Printf.sprintf "Status.of_code: %d is not a three-digit number" c) else `Code c | s -> s let is_informational t = match t with | #informational -> true | `Code n -> n >= 100 && n <= 199 | _ -> false let is_successful t = match t with | #successful -> true | `Code n -> n >= 200 && n <= 299 | _ -> false let is_redirection t = match t with | #redirection -> true | `Code n -> n >= 300 && n <= 399 | _ -> false let is_client_error t = match t with | #client_error -> true | `Code n -> n >= 400 && n <= 499 | _ -> false let is_server_error t = match t with | #server_error -> true | `Code n -> n >= 500 && n <= 599 | _ -> false let is_error t = is_client_error t || is_server_error t let to_string = function (* don't allocate *) (* Informational *) | `Continue -> "100" | `Switching_protocols -> "101" (* Successful *) | `OK -> "200" | `Created -> "201" | `Accepted -> "202" | `Non_authoritative_information -> "203" | `No_content -> "204" | `Reset_content -> "205" | `Partial_content -> "206" (* Redirection *) | `Multiple_choices -> "300" | `Moved_permanently -> "301" | `Found -> "302" | `See_other -> "303" | `Not_modified -> "304" | `Use_proxy -> "305" | `Temporary_redirect -> "307" (* Client error *) | `Bad_request -> "400" | `Unauthorized -> "401" | `Payment_required -> "402" | `Forbidden -> "403" | `Not_found -> "404" | `Method_not_allowed -> "405" | `Not_acceptable -> "406" | `Proxy_authentication_required -> "407" | `Request_timeout -> "408" | `Conflict -> "409" | `Gone -> "410" | `Length_required -> "411" | `Precondition_failed -> "412" | `Payload_too_large -> "413" | `Uri_too_long -> "414" | `Unsupported_media_type -> "415" | `Range_not_satisfiable -> "416" | `Expectation_failed -> "417" | `I_m_a_teapot -> "418" | `Enhance_your_calm -> "420" | `Upgrade_required -> "426" (* Server error *) | `Internal_server_error -> "500" | `Not_implemented -> "501" | `Bad_gateway -> "502" | `Service_unavailable-> "503" | `Gateway_timeout -> "504" | `Http_version_not_supported -> "505" | `Code c -> string_of_int c (* except for this *) let of_string x = of_code (int_of_string x) let pp_hum fmt t = Format.fprintf fmt "%u" (to_code t) ================================================ FILE: lib/version.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2017 Inhabited Type LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) type t = { major : int ; minor : int } let v1_0 = { major = 1; minor = 0 } let v1_1 = { major = 1; minor = 1 } let to_buffer b t = Buffer.add_string b "HTTP/"; Buffer.add_string b (string_of_int t.major); Buffer.add_char b '.'; Buffer.add_string b (string_of_int t.minor) let compare x y = let c = compare x.major y.major in if c <> 0 then c else compare x.minor y.minor let to_string t = match t with | { major = 1; minor = 0 } -> "HTTP/1.0" | { major = 1; minor = 1 } -> "HTTP/1.1" | _ -> let b = Buffer.create 8 in to_buffer b t; Buffer.contents b let of_string = function | "HTTP/1.1" -> { major = 1; minor = 1 } | "HTTP/1.0" -> { major = 1; minor = 0 } | s -> try Scanf.sscanf s "HTTP/%d.%d" (fun major minor -> { major; minor }) with _ -> raise (Failure "Version.of_string") let pp_hum fmt t = Format.fprintf fmt "HTTP/%d.%d" t.major t.minor ================================================ FILE: lib_test/dune ================================================ (executables (libraries bigstringaf httpaf alcotest) (modules helpers test_client_connection test_headers test_httpaf test_iovec test_method test_request test_response test_server_connection test_version) (names test_httpaf)) (alias (name runtest) (package httpaf) (deps test_httpaf.exe) (action (run %{deps}))) ================================================ FILE: lib_test/helpers.ml ================================================ open Httpaf let maybe_serialize_body f body = match body with | None -> () | Some body -> Faraday.write_string f body let request_to_string ?body r = let f = Faraday.create 0x1000 in Httpaf_private.Serialize.write_request f r; maybe_serialize_body f body; Faraday.serialize_to_string f let response_to_string ?body r = let f = Faraday.create 0x1000 in Httpaf_private.Serialize.write_response f r; maybe_serialize_body f body; Faraday.serialize_to_string f module Read_operation = struct type t = [ `Read | `Yield | `Close ] let pp_hum fmt (t : t) = let str = match t with | `Read -> "Read" | `Yield -> "Yield" | `Close -> "Close" in Format.pp_print_string fmt str ;; end module Write_operation = struct type t = [ `Write of Bigstringaf.t IOVec.t list | `Yield | `Close of int ] let iovecs_to_string iovecs = let len = IOVec.lengthv iovecs in let bytes = Bytes.create len in let dst_off = ref 0 in List.iter (fun { IOVec.buffer; off = src_off; len } -> Bigstringaf.unsafe_blit_to_bytes buffer ~src_off bytes ~dst_off:!dst_off ~len; dst_off := !dst_off + len) iovecs; Bytes.unsafe_to_string bytes ;; let pp_hum fmt (t : t) = match t with | `Write iovecs -> Format.fprintf fmt "Write %S" (iovecs_to_string iovecs) | `Yield -> Format.pp_print_string fmt "Yield" | `Close len -> Format.fprintf fmt "Close %i" len ;; let to_write_as_string t = match t with | `Write iovecs -> Some (iovecs_to_string iovecs) | `Close _ | `Yield -> None ;; end let write_operation = Alcotest.of_pp Write_operation.pp_hum let read_operation = Alcotest.of_pp Read_operation.pp_hum module Headers = struct include Headers let (@) a b = Headers.add_list a (Headers.to_list b) let connection_close = Headers.of_list ["connection", "close"] let encoding_chunked = Headers.of_list ["transfer-encoding", "chunked"] let encoding_fixed n = Headers.of_list ["content-length", string_of_int n] end ================================================ FILE: lib_test/test_client_connection.ml ================================================ open Httpaf open Helpers open Client_connection let response_error_pp_hum fmt = function | `Malformed_response str -> Format.fprintf fmt "Malformed_response: %s" str | `Invalid_response_body_length resp -> Format.fprintf fmt "Invalid_response_body_length: %s" (response_to_string resp) | `Exn exn -> Format.fprintf fmt "Exn (%s)" (Printexc.to_string exn) ;; module Response = struct include Response let pp = pp_hum let equal x y = x = y end module Alcotest = struct include Alcotest let response_error = of_pp response_error_pp_hum end let feed_string t str = let len = String.length str in let input = Bigstringaf.of_string str ~off:0 ~len in read t input ~off:0 ~len let read_string t str = let c = feed_string t str in Alcotest.(check int) "read consumes all input" (String.length str) c; ;; let read_response t r = let response_string = response_to_string r in read_string t response_string ;; let reader_ready t = Alcotest.check read_operation "Reader is ready" `Read (next_read_operation t :> [`Close | `Read | `Yield]); ;; let reader_closed t = Alcotest.check read_operation "Reader is closed" `Close (next_read_operation t :> [`Close | `Read | `Yield]); ;; let write_string ?(msg="output written") t str = let len = String.length str in Alcotest.(check (option string)) msg (Some str) (next_write_operation t |> Write_operation.to_write_as_string); report_write_result t (`Ok len); ;; let write_request ?(msg="request written") t r = let request_string = request_to_string r in write_string ~msg t request_string ;; let writer_yielded t = Alcotest.check write_operation "Writer is in a yield state" `Yield (next_write_operation t); ;; let writer_closed t = Alcotest.check write_operation "Writer is closed" (`Close 0) (next_write_operation t); ;; let connection_is_shutdown t = Alcotest.check read_operation "Reader is closed" `Close (next_read_operation t :> [`Close | `Read | `Yield]); writer_closed t; ;; let default_response_handler expected_response response body = Alcotest.check (module Response) "expected response" expected_response response; let on_read _ ~off:_ ~len:_ = () in let on_eof () = () in Body.Reader.schedule_read body ~on_read ~on_eof; ;; let no_error_handler _ = assert false let test_get () = let request' = Request.create `GET "/" in let response = Response.create `OK in (* Single GET *) let body, t = request request' ~response_handler:(default_response_handler response) ~error_handler:no_error_handler in Body.Writer.close body; write_request t request'; writer_closed t; read_response t response; (* Single GET, response closes connection *) let response = Response.create `OK ~headers:Headers.connection_close in let body, t = request request' ~response_handler:(default_response_handler response) ~error_handler:no_error_handler in Body.Writer.close body; write_request t request'; read_response t response; let c = read_eof t Bigstringaf.empty ~off:0 ~len:0 in Alcotest.(check int) "read_eof with no input returns 0" 0 c; connection_is_shutdown t; (* Single GET, streaming body *) let response = Response.create `OK ~headers:Headers.encoding_chunked in let body, t = request request' ~response_handler:(default_response_handler response) ~error_handler:no_error_handler in Body.Writer.close body; write_request t request'; read_response t response; read_string t "d\r\nHello, world!\r\n0\r\n\r\n" ;; let test_send_streaming_body () = let request' = Request.create `GET "/" ~headers:Headers.encoding_chunked in let response = Response.create `OK ~headers:Headers.encoding_chunked in let body, t = request request' ~response_handler:(default_response_handler response) ~error_handler:no_error_handler in write_request t request'; read_response t response; Body.Writer.write_string body "hello"; write_string t "5\r\nhello\r\n"; Body.Writer.write_string body "world"; Body.Writer.close body; write_string t "5\r\nworld\r\n"; write_string t "0\r\n\r\n"; writer_closed t ;; let test_response_eof () = let request' = Request.create `GET "/" in let response = Response.create `OK in (* not actually writen to the channel *) let error_message = ref None in let body, t = request request' ~response_handler:(default_response_handler response) ~error_handler:(function | `Malformed_response msg -> error_message := Some msg | _ -> assert false) in Body.Writer.close body; write_request t request'; writer_closed t; reader_ready t; let c = read_eof t Bigstringaf.empty ~off:0 ~len:0 in Alcotest.(check int) "read_eof with no input returns 0" 0 c; connection_is_shutdown t; Alcotest.(check (option string)) "unexpected eof" (Some "unexpected eof") !error_message ;; let test_response_header_order () = let request' = Request.create `GET "/" in let headers = [ "a", "1" ; "b", "2" ; "c", "3" ] in let response = Response.create `OK ~headers:(Headers.of_list headers) in let received = ref None in let body, t = request request' ~response_handler:(fun response _ -> received := Some response) ~error_handler:no_error_handler in Body.Writer.close body; write_request t request'; writer_closed t; read_response t response; match !received with | None -> assert false | Some received -> Alcotest.(check (list (pair string string))) "headers are equal" headers (Headers.to_list received.headers); ;; let test_report_exn () = let request' = Request.create `GET "/" in let response = Response.create `OK in (* not actually writen to the channel *) let error_message = ref None in let body, t = request request' ~response_handler:(default_response_handler response) ~error_handler:(function | `Exn (Failure msg) -> error_message := Some msg | _ -> assert false) in Body.Writer.close body; write_request t request'; writer_closed t; reader_ready t; report_exn t (Failure "something went wrong"); connection_is_shutdown t; Alcotest.(check (option string)) "something went wrong" (Some "something went wrong") !error_message ;; let test_input_shrunk () = let request' = Request.create `GET "/" in let response = Response.create `OK in (* not actually writen to the channel *) let error_message = ref None in let body, t = request request' ~response_handler:(default_response_handler response) ~error_handler:(function | `Exn (Failure msg) -> error_message := Some msg | _ -> assert false) in Body.Writer.close body; write_request t request'; writer_closed t; reader_ready t; let c = feed_string t "HTTP/1.1 200 OK\r\nDate" in Alcotest.(check int) "read the status line" c 17; report_exn t (Failure "something went wrong"); connection_is_shutdown t; Alcotest.(check (option string)) "something went wrong" (Some "something went wrong") !error_message ;; let test_failed_response_parse () = let request' = Request.create `GET "/" in let test response bytes_read expected_error = let error = ref None in let body, t = request request' ~response_handler:(fun _ _ -> assert false) ~error_handler:(fun e -> error := Some e) in Body.Writer.close body; write_request t request'; writer_closed t; reader_ready t; let len = feed_string t response in Alcotest.(check int) "bytes read" len bytes_read; connection_is_shutdown t; Alcotest.(check (option response_error)) "Response error" (Some expected_error) !error; in test "HTTP/1.1 200\r\n\r\n" 12 (`Malformed_response ": char ' '"); let response = Response.create `OK ~headers:(Headers.encoding_fixed (-1)) in test (response_to_string response) 39 (`Invalid_response_body_length response); ;; let test_schedule_read_with_data_available () = let request' = Request.create `GET "/" in let response = Response.create `OK ~headers:(Headers.encoding_fixed 6) in let body = ref None in let response_handler response' body' = body := Some body'; Alcotest.check (module Response) "expected response" response response'; in let req_body, t = request request' ~response_handler ~error_handler:no_error_handler in Body.Writer.close req_body; write_request t request'; writer_closed t; read_response t response; let body = Option.get !body in let schedule_read expected = let did_read = ref false in Body.Reader.schedule_read body ~on_read:(fun buf ~off ~len -> let actual = Bigstringaf.substring buf ~off ~len in did_read := true; Alcotest.(check string) "Body" expected actual) ~on_eof:(fun () -> assert false); Alcotest.(check bool) "on_read called" true !did_read; in (* We get some data on the connection, but not the full response yet. *) read_string t "Hello"; (* Schedule a read when there is already data available. on_read should be called straight away, as who knows how long it'll be before more data arrives. *) schedule_read "Hello"; read_string t "!"; schedule_read "!"; let did_eof = ref false in Body.Reader.schedule_read body ~on_read:(fun _ ~off:_ ~len:_ -> Alcotest.fail "Expected eof") ~on_eof:(fun () -> did_eof := true); Alcotest.(check bool) "on_eof called" true !did_eof; reader_closed t; ;; let tests = [ "GET" , `Quick, test_get ; "send streaming body", `Quick, test_send_streaming_body ; "Response EOF", `Quick, test_response_eof ; "Response header order preserved", `Quick, test_response_header_order ; "report_exn" , `Quick, test_report_exn ; "input_shrunk", `Quick, test_input_shrunk ; "failed response parse", `Quick, test_failed_response_parse ; "schedule read with data available", `Quick, test_schedule_read_with_data_available ] ================================================ FILE: lib_test/test_headers.ml ================================================ open Httpaf module Array = ArrayLabels module List = ListLabels let check msg ~expect actual = Alcotest.(check (list (pair string string))) msg expect (Headers.to_list actual) ;; let test_replace () = check "replace trailing element" ~expect:["c", "d"; "a", "d"] (Headers.replace (Headers.of_list ["c", "d"; "a", "b"]) "a" "d"); check "replace middle element" ~expect:["e", "f"; "c", "z"; "a", "b"] (Headers.replace (Headers.of_list ["e", "f"; "c", "d"; "a", "b"]) "c" "z"); check "remove multiple trailing elements" ~expect:["c", "d"; "a", "d"] (Headers.replace (Headers.of_list [ "c", "d"; "a", "b"; "a", "c"]) "a" "d"); ;; let test_remove () = check "remove leading element" ~expect:["c", "d"] (Headers.remove (Headers.of_list ["a", "b"; "c", "d"]) "a"); check "remove trailing element" ~expect:["c", "d"] (Headers.remove (Headers.of_list ["c", "d"; "a", "b"]) "a"); ;; let test_ci_equal () = let string_of_char x = String.init 1 (fun _ -> x) in let ascii = Array.init (0xff + 1) ~f:Char.chr |> Array.to_list in let ascii_pairs = List.map ascii ~f:(fun x -> List.map ascii ~f:(fun y -> x, y)) |> List.concat in (* Ensure that the branch free case-insensitive equality check is consistent * with a naive implementation. *) List.iter ascii_pairs ~f:(fun (x, y) -> let char_ci_equal = Char.compare (Char.lowercase_ascii x) (Char.lowercase_ascii y) = 0 in let headers_equal = let headers = Headers.of_list [ string_of_char y, "value" ] in Headers.mem headers (string_of_char x) in Alcotest.(check bool) (Printf.sprintf "CI: %C = %C" x y) char_ci_equal headers_equal) ;; let tests = [ "remove" , `Quick, test_remove ; "replace" , `Quick, test_replace ; "CI equal", `Quick, test_ci_equal ] ================================================ FILE: lib_test/test_httpaf.ml ================================================ let () = Alcotest.run "httpaf unit tests" [ "version" , Test_version.tests ; "method" , Test_method.tests ; "iovec" , Test_iovec.tests ; "headers" , Test_headers.tests ; "request" , Test_request.tests ; "response" , Test_response.tests ; "client connection", Test_client_connection.tests ; "server connection", Test_server_connection.tests ] ================================================ FILE: lib_test/test_iovec.ml ================================================ open Httpaf open IOVec (* The length of the buffer is ignored by iovec operations *) let buffer = Bigstringaf.empty let test_lengthv () = Alcotest.(check int) "lengthv [] = 0" (lengthv []) 0; Alcotest.(check int) "lengthv [iovec] = length iovec" (lengthv [{ buffer; off = 0; len = 0 }]) (length {buffer; off = 0; len = 0 }); Alcotest.(check int) "lengthv [iovec] = length iovec" (lengthv [{ buffer; off = 0; len = 10 }]) (length {buffer; off = 0; len = 10 }); ;; let test_shiftv_raises () = Alcotest.check_raises "IOVec.shiftv: -1 is a negative number" (Failure "IOVec.shiftv: -1 is a negative number") (fun () -> ignore (shiftv [] (-1))); let test f = Alcotest.check_raises "shiftv iovecs n raises when n > lengthv iovecs" (Failure "shiftv: n > lengthv iovecs") (fun () -> ignore (f ())) in test (fun () -> shiftv [] 1); test (fun () -> shiftv [{ buffer; off = 0; len = 1 }] 2); test (fun () -> shiftv [{ buffer; off = 0; len = 1 }; { buffer; off = 0; len = 1 }] 3); ;; let test_shiftv () = Alcotest.(check (of_pp pp_hum |> list)) "shiftv [] 0 = []" (shiftv [] 0) []; Alcotest.(check (of_pp pp_hum |> list)) "shiftv [{... len ... }] len = []" (shiftv [{ buffer; off = 0; len = 1 }] 1) []; Alcotest.(check (of_pp pp_hum |> list)) "shiftv [iovec] n when length iovec < n" (shiftv [{ buffer; off = 0; len = 4 }] 2) [{ buffer; off = 2; len = 2 }]; ;; let tests = [ "lengthv" , `Quick, test_lengthv ; "shiftv" , `Quick, test_shiftv ; "shiftv raises ", `Quick, test_shiftv_raises ] ================================================ FILE: lib_test/test_method.ml ================================================ open Httpaf open Method let test_is_safe () = Alcotest.(check bool) "GET is safe" (is_safe `GET ) true; Alcotest.(check bool) "HEAD is safe" (is_safe `HEAD) true; Alcotest.(check bool) "POST is safe" (is_safe `POST) false; Alcotest.(check bool) "PUT is safe" (is_safe `PUT ) false; Alcotest.(check bool) "DELETE is safe" (is_safe `DELETE ) false; Alcotest.(check bool) "CONNECT is safe" (is_safe `CONNECT) false; Alcotest.(check bool) "OPTIONS is safe" (is_safe `OPTIONS) true; Alcotest.(check bool) "TRACE is safe" (is_safe `TRACE ) true; ;; let test_is_cacheable () = Alcotest.(check bool) "GET is cacheable" (is_cacheable `GET ) true; Alcotest.(check bool) "HEAD is cacheable" (is_cacheable `HEAD) true; Alcotest.(check bool) "POST is cacheable" (is_cacheable `POST) true; Alcotest.(check bool) "PUT is cacheable" (is_cacheable `PUT ) false; Alcotest.(check bool) "DELETE is cacheable" (is_cacheable `DELETE ) false; Alcotest.(check bool) "CONNECT is cacheable" (is_cacheable `CONNECT) false; Alcotest.(check bool) "OPTIONS is cacheable" (is_cacheable `OPTIONS) false; Alcotest.(check bool) "TRACE is cacheable" (is_cacheable `TRACE ) false; ;; let test_is_idempotent () = Alcotest.(check bool) "GET is idempotent" (is_idempotent `GET ) true; Alcotest.(check bool) "HEAD is idempotent" (is_idempotent `HEAD) true; Alcotest.(check bool) "POST is idempotent" (is_idempotent `POST) false; Alcotest.(check bool) "PUT is idempotent" (is_idempotent `PUT ) true; Alcotest.(check bool) "DELETE is idempotent" (is_idempotent `DELETE ) true; Alcotest.(check bool) "CONNECT is idempotent" (is_idempotent `CONNECT) false; Alcotest.(check bool) "OPTIONS is idempotent" (is_idempotent `OPTIONS) true; Alcotest.(check bool) "TRACE is idempotent" (is_idempotent `TRACE ) true; ;; let tests = [ "is_safe" , `Quick, test_is_safe ; "is_cacheable" , `Quick, test_is_cacheable ; "is_idempotent", `Quick, test_is_idempotent ] ================================================ FILE: lib_test/test_request.ml ================================================ open Httpaf open Request open Helpers let body_length = Alcotest.of_pp Request.Body_length.pp_hum let check = let alco = Alcotest.result (Alcotest.of_pp pp_hum) Alcotest.string in fun message ~expect input -> let actual = Angstrom.parse_string ~consume:All Httpaf_private.Parse.request input in Alcotest.check alco message expect actual ;; let test_parse_valid () = check "valid GET without headers" ~expect:(Ok (Request.create `GET "/")) "GET / HTTP/1.1\r\n\r\n"; check "valid non-standard method without headers" ~expect:(Ok (Request.create (`Other "some-other-verb") "/")) "some-other-verb / HTTP/1.1\r\n\r\n"; check "valid GET with headers" ~expect:(Ok (Request.create ~headers:(Headers.of_list [ "Link", "/path/to/some/website"]) `GET "/")) "GET / HTTP/1.1\r\nLink: /path/to/some/website\r\n\r\n"; ;; let test_parse_invalid_errors () = check "doesn't end" ~expect:(Error ": not enough input") "GET / HTTP/1.1\r\n"; check "invalid version" ~expect:(Error "eol: string") "GET / HTTP/1.22\r\n\r\n"; check "malformed header" ~expect:(Error "header: char ':'") "GET / HTTP/1.1\r\nLink : /path/to/some/website\r\n\r\n"; ;; let test_body_length () = let check message request ~expect = let actual = Request.body_length request in Alcotest.check body_length message expect actual in let req method_ headers = Request.create method_ ~headers "/" in check "no headers" ~expect:(`Fixed 0L) (req `GET Headers.empty); check "single fixed" ~expect:(`Fixed 10L) (req `GET Headers.(encoding_fixed 10)); check "negative fixed" ~expect:(`Error `Bad_request) (req `GET Headers.(encoding_fixed (-10))); check "multiple fixed" ~expect:(`Error `Bad_request) (req `GET Headers.(encoding_fixed 10 @ encoding_fixed 20)); check "chunked" ~expect:`Chunked (req `GET Headers.encoding_chunked); check "chunked multiple times" ~expect:`Chunked (req `GET Headers.(encoding_chunked @ encoding_chunked)); let encoding_gzip = Headers.of_list ["transfer-encoding", "gzip"] in check "non-chunked transfer-encoding" ~expect:(`Error `Bad_request) (req `GET encoding_gzip); check "chunked after non-chunked" ~expect:`Chunked (req `GET Headers.(encoding_gzip @ encoding_chunked)); check "chunked before non-chunked" ~expect:(`Error `Bad_request) (req `GET Headers.(encoding_chunked @ encoding_gzip)); check "chunked case-insensitive" ~expect:`Chunked (req `GET Headers.(of_list ["transfer-encoding", "CHUNKED"])); ;; let tests = [ "parse valid" , `Quick, test_parse_valid ; "parse invalid errors", `Quick, test_parse_invalid_errors ; "body length", `Quick, test_body_length ] ================================================ FILE: lib_test/test_response.ml ================================================ open Httpaf open Response open Helpers let body_length = Alcotest.of_pp Response.Body_length.pp_hum let check = let alco = Alcotest.result (Alcotest.of_pp pp_hum) Alcotest.string in fun message ~expect input -> let actual = Angstrom.parse_string ~consume:All Httpaf_private.Parse.response input in Alcotest.check alco message expect actual ;; let test_parse_valid () = check "OK response without headers" ~expect:(Ok (Response.create `OK)) "HTTP/1.1 200 OK\r\n\r\n"; ;; let test_parse_invalid_error () = check "OK response without a status message" ~expect:(Error ": char ' '") "HTTP/1.1 200\r\n\r\n"; check "OK response without a status message" ~expect:(Error ": status-code empty") "HTTP/1.1 OK\r\n\r\n"; check "OK response without a status message" ~expect:(Error ": status-code too long: \"999999937377999999999200\"") "HTTP/1.1 999999937377999999999200\r\n\r\n"; ;; let test_body_length () = let check message request_method response ~expect = let actual = Response.body_length response ~request_method in Alcotest.check body_length message expect actual in let res status headers = Response.create status ~headers in check "requested HEAD" ~expect:(`Fixed 0L) `HEAD (res `OK Headers.empty); check "requested CONNECT" ~expect:(`Close_delimited) `CONNECT (res `OK Headers.empty); check "status: informational" ~expect:(`Fixed 0L) `GET (res `Continue Headers.empty); check "status: no content" ~expect:(`Fixed 0L) `GET (res `No_content Headers.empty); check "status: not modified" ~expect:(`Fixed 0L) `GET (res `Not_modified Headers.empty); check "no header" ~expect:(`Close_delimited) `GET (res `OK Headers.empty); check "single fixed" ~expect:(`Fixed 10L) `GET (res `OK Headers.(encoding_fixed 10)); check "negative fixed" ~expect:(`Error `Internal_server_error) `GET (res `OK Headers.(encoding_fixed (-10))); check "multiple fixed" ~expect:(`Error `Internal_server_error) `GET (res `OK Headers.(encoding_fixed 10 @ encoding_fixed 20)); check "chunked" ~expect:`Chunked `GET (res `OK Headers.encoding_chunked); check "chunked multiple times" ~expect:`Chunked `GET (res `OK Headers.(encoding_chunked @ encoding_chunked)); let encoding_gzip = Headers.of_list ["transfer-encoding", "gzip"] in check "non-chunked transfer-encoding" ~expect:`Close_delimited `GET (res `OK encoding_gzip); check "chunked after non-chunked" ~expect:`Chunked `GET (res `OK Headers.(encoding_gzip @ encoding_chunked)); check "chunked before non-chunked" ~expect:`Close_delimited `GET (res `OK Headers.(encoding_chunked @ encoding_gzip)); check "chunked case-insensitive" ~expect:`Chunked `GET (res `OK Headers.(of_list ["transfer-encoding", "CHUNKED"])); ;; let tests = [ "parse valid" , `Quick, test_parse_valid ; "parse invalid error", `Quick, test_parse_invalid_error ; "body length" , `Quick, test_body_length ] ================================================ FILE: lib_test/test_server_connection.ml ================================================ open Httpaf open Helpers let trace fmt = Format.ksprintf (Format.printf "%s\n%!") fmt let request_error_pp_hum fmt = function | `Bad_request -> Format.fprintf fmt "Bad_request" | `Bad_gateway -> Format.fprintf fmt "Bad_gateway" | `Internal_server_error -> Format.fprintf fmt "Internal_server_error" | `Exn exn -> Format.fprintf fmt "Exn (%s)" (Printexc.to_string exn) ;; module Alcotest = struct include Alcotest let request_error = Alcotest.of_pp request_error_pp_hum let request = Alcotest.of_pp (fun fmt req -> Format.fprintf fmt "%s" (request_to_string req)) ;; end module Runtime : sig type t val create : ?config:Config.t -> ?error_handler:Server_connection.error_handler -> Server_connection.request_handler -> t val current_read_operation : t -> Read_operation.t val current_write_operation : t -> Write_operation.t val do_read : t -> (Server_connection.t -> 'a) -> 'a val do_write : t -> (Server_connection.t -> Bigstringaf.t IOVec.t list -> 'a) -> 'a (** Returns a [ref] that is set to [true] after the callback was fired *) val on_reader_unyield : t -> (unit -> unit) -> bool ref val on_writer_unyield : t -> (unit -> unit) -> bool ref val report_exn : t -> exn -> unit val shutdown : t -> unit end = struct open Server_connection type t = { server_connection : Server_connection.t ; mutable read_operation : [`Initial | Read_operation.t] ; mutable write_operation : [`Initial | Write_operation.t] ; read_loop : (unit -> unit) ; write_loop : (unit -> unit) ; mutable read_unyield_hook : (unit -> unit) option ; mutable write_unyield_hook : (unit -> unit) option } let rec read_step t = match next_read_operation t.server_connection with | `Read -> trace "reader: Read"; t.read_operation <- `Read | `Yield -> trace "reader: Yield"; t.read_operation <- `Yield; yield_reader t.server_connection (fun () -> trace "reader: Yield callback"; read_step t; t.read_unyield_hook |> Option.iter (fun f -> t.read_unyield_hook <- None; f ())) | `Close -> trace "reader: Close"; t.read_operation <- `Close ;; let rec write_step t = match next_write_operation t.server_connection with | `Write xs -> trace "writer: Write"; t.write_operation <- `Write xs | `Yield -> t.write_operation <- `Yield; trace "writer: Yield"; yield_writer t.server_connection (fun () -> trace "writer: Yield callback"; write_step t; t.write_unyield_hook |> Option.iter (fun f -> t.write_unyield_hook <- None; f ())) | `Close n -> trace "writer: Close"; t.write_operation <- `Close n ;; let create ?config ?error_handler request_handler = let request_handler r = trace "invoked: request_handler"; request_handler r in let error_handler = Option.map (fun error_handler ?request -> trace "invoked: error_handler"; error_handler ?request) error_handler in let rec t = lazy ( { server_connection = create ?config ?error_handler request_handler ; read_operation = `Initial ; write_operation = `Initial ; read_loop = (fun () -> read_step (Lazy.force_val t)) ; write_loop = (fun () -> write_step (Lazy.force_val t)) ; read_unyield_hook = None ; write_unyield_hook = None }) in let t = Lazy.force_val t in t.read_loop (); t.write_loop (); t ;; let current_read_operation t = match t.read_operation with | `Initial -> assert false | `Read | `Yield | `Close as op -> op ;; let current_write_operation t = match t.write_operation with | `Initial -> assert false | `Write _ | `Yield | `Close _ as op -> op ;; let do_read t f = match current_read_operation t with | `Read -> trace "read: start"; let res = f t.server_connection in trace "read: finished"; t.read_loop (); res | `Yield | `Close as op -> Alcotest.failf "Read attempted during operation: %a" Read_operation.pp_hum op ;; let do_write t f = match current_write_operation t with | `Write bufs -> trace "write: start"; let res = f t.server_connection bufs in trace "write: finished"; t.write_loop (); res | `Yield | `Close _ as op -> Alcotest.failf "Write attempted during operation: %a" Write_operation.pp_hum op ;; let on_reader_unyield t f = let called = ref false in assert (Option.is_none t.read_unyield_hook); t.read_unyield_hook <- Some (fun () -> called := true; f ()); called ;; let on_writer_unyield t f = let called = ref false in assert (Option.is_none t.write_unyield_hook); t.write_unyield_hook <- Some (fun () -> called := true; f ()); called ;; let report_exn t = Server_connection.report_exn t.server_connection let shutdown t = Server_connection.shutdown t.server_connection end open Runtime let read ?(eof=false) t str ~off ~len = do_read t (fun conn -> if eof then Server_connection.read_eof conn str ~off ~len else Server_connection.read conn str ~off ~len) ;; let read_eof = read ~eof:true let feed_string ?eof t str = let len = String.length str in let input = Bigstringaf.of_string str ~off:0 ~len in read ?eof t input ~off:0 ~len ;; let read_string ?eof t str = let c = feed_string ?eof t str in Alcotest.(check int) "read consumes all input" (String.length str) c; ;; let read_request ?eof t r = let request_string = request_to_string r in read_string ?eof t request_string ;; let reader_ready t = Alcotest.check read_operation "Reader is ready" `Read (current_read_operation t); ;; let reader_yielded t = Alcotest.check read_operation "Reader is in a yield state" `Yield (current_read_operation t); ;; let reader_closed t = Alcotest.check read_operation "Reader is closed" `Close (current_read_operation t); ;; (* Checks that the [len] prefixes of expected and the write match, and returns the rest. *) let write_partial_string ?(msg="output written") t expected len = do_write t (fun conn bufs -> let actual = String.sub (Write_operation.iovecs_to_string bufs) 0 len in Alcotest.(check string) msg (String.sub expected 0 len) actual; Server_connection.report_write_result conn (`Ok len); String.sub expected len (String.length expected - len)); ;; let write_string ?(msg="output written") t expected = do_write t (fun conn bufs -> let len = String.length expected in let actual = Write_operation.iovecs_to_string bufs in Alcotest.(check string) msg expected actual; Server_connection.report_write_result conn (`Ok len)); ;; let write_response ?(msg="response written") ?body t r = let response_string = response_to_string ?body r in write_string ~msg t response_string ;; let write_eof t = do_write t (fun conn _ -> Server_connection.report_write_result conn `Closed) ;; let writer_ready t = let is_write = Alcotest.testable Write_operation.pp_hum (fun a b -> match a, b with | `Write _, `Write _ -> true | _ -> false) in Alcotest.check is_write "Writer is ready" (`Write []) (current_write_operation t); ;; let writer_yielded t = Alcotest.check write_operation "Writer is in a yield state" `Yield (current_write_operation t); ;; let writer_closed ?(unread = 0) t = Alcotest.check write_operation "Writer is closed" (`Close unread) (current_write_operation t); ;; let connection_is_shutdown t = reader_closed t; writer_closed t; ;; let raises_writer_closed f = (* This is raised when you write to a closed [Faraday.t] *) Alcotest.check_raises "raises because writer is closed" (Failure "cannot write to closed writer") f ;; let request_handler_with_body body reqd = Body.Reader.close (Reqd.request_body reqd); Reqd.respond_with_string reqd (Response.create `OK) body ;; let default_request_handler reqd = request_handler_with_body "" reqd ;; let echo_handler response reqd = let request_body = Reqd.request_body reqd in let response_body = Reqd.respond_with_streaming reqd response in let rec on_read buffer ~off ~len = Body.Writer.write_string response_body (Bigstringaf.substring ~off ~len buffer); Body.Writer.flush response_body (fun () -> Body.Reader.schedule_read request_body ~on_eof ~on_read) and on_eof () = print_endline "echo handler eof"; Body.Writer.close response_body in Body.Reader.schedule_read request_body ~on_eof ~on_read; ;; let streaming_handler ?(flush=false) response writes reqd = let writes = ref writes in let request_body = Reqd.request_body reqd in Body.Reader.close request_body; let body = Reqd.respond_with_streaming ~flush_headers_immediately:flush reqd response in let rec write () = match !writes with | [] -> Body.Writer.close body | w :: ws -> Body.Writer.write_string body w; writes := ws; Body.Writer.flush body write in write (); ;; let synchronous_raise reqd = Reqd.report_exn reqd (Failure "caught this exception") ;; let error_handler ?request:_ _error start_response = let resp_body = start_response Headers.empty in Body.Writer.write_string resp_body "got an error"; Body.Writer.close resp_body ;; let test_initial_reader_state () = let t = create default_request_handler in Alcotest.check read_operation "A new reader wants input" `Read (current_read_operation t); ;; let test_reader_is_closed_after_eof () = let t = create default_request_handler in let c = read_eof t Bigstringaf.empty ~off:0 ~len:0 in Alcotest.(check int) "read_eof with no input returns 0" 0 c; connection_is_shutdown t; let t = create default_request_handler in let c = read t Bigstringaf.empty ~off:0 ~len:0 in Alcotest.(check int) "read with no input returns 0" 0 c; let c = read_eof t Bigstringaf.empty ~off:0 ~len:0; in Alcotest.(check int) "read_eof with no input returns 0" 0 c; connection_is_shutdown t; ;; let test_single_get () = (* Single GET *) let t = create default_request_handler in read_request t (Request.create `GET "/"); write_response t (Response.create `OK); (* Single GET, close the connection *) let t = create default_request_handler in read_request t (Request.create `GET "/" ~headers:Headers.connection_close); write_response t (Response.create `OK); connection_is_shutdown t; (* Single GET, with reponse body *) let response_body = "This is a test" in let t = create (request_handler_with_body response_body) in read_request t (Request.create `GET "/" ~headers:Headers.connection_close); write_response t ~body:response_body (Response.create `OK); connection_is_shutdown t; ;; let test_asynchronous_response () = let response_body = "hello, world!" in let response_body_length = String.length response_body in let response = Response.create `OK ~headers:(Headers.encoding_fixed response_body_length) in let continue = ref (fun () -> ()) in let t = create (fun reqd -> continue := fun () -> Body.Reader.close (Reqd.request_body reqd); let data = Bigstringaf.of_string ~off:0 ~len:response_body_length response_body in let size = Bigstringaf.length data in let response = Response.create `OK ~headers:(Headers.encoding_fixed size) in let response_body = Reqd.respond_with_streaming reqd response in Body.Writer.write_bigstring response_body data; Body.Writer.close response_body) in read_request t (Request.create `GET "/"); reader_yielded t; writer_yielded t; !continue (); write_response t ~body:response_body response; read_request t (Request.create `GET "/"); reader_yielded t; writer_yielded t; !continue (); write_response t ~body:response_body response ;; let test_echo_post () = let request = Request.create `GET "/" ~headers:Headers.encoding_chunked in (* Echo a single chunk *) let response = Response.create `OK ~headers:Headers.encoding_chunked in let t = create (echo_handler response) in read_request t request; read_string t "e\r\nThis is a test"; write_response t ~body:"e\r\nThis is a test\r\n" response; read_string t "\r\n0\r\n\r\n"; write_string t "0\r\n\r\n"; writer_yielded t; (* Echo two chunks *) let response = Response.create `OK ~headers:Headers.encoding_chunked in let t = create (echo_handler response) in read_request t request; read_string t "e\r\nThis is a test"; write_response t ~body:"e\r\nThis is a test\r\n" response; read_string t "\r\n21\r\n... that involves multiple chunks"; write_string t "21\r\n... that involves multiple chunks\r\n"; read_string t "\r\n0\r\n\r\n"; write_string t "0\r\n\r\n"; writer_yielded t; (* Echo and close *) let response = Response.create `OK ~headers:Headers.connection_close in let t = create (echo_handler response) in read_request t request; read_string t "e\r\nThis is a test"; write_response t ~body:"This is a test" response; read_string t "\r\n21\r\n... that involves multiple chunks"; read_string t "\r\n0\r\n\r\n"; write_string t "... that involves multiple chunks"; connection_is_shutdown t; ;; let test_streaming_response () = let request = Request.create `GET "/" in let response = Response.create `OK in let t = create (streaming_handler response ["Hello "; "world!"]) in read_request t request; write_response t ~body:"Hello " response; write_string t "world!"; writer_yielded t; ;; let test_asynchronous_streaming_response () = let request = Request.create `GET "/" ~headers:Headers.connection_close in let response = Response.create `OK in let body = ref None in let t = create (fun reqd -> body := Some (Reqd.respond_with_streaming reqd response)) in writer_yielded t; let writer_woken_up = on_writer_unyield t (fun () -> write_response t ~body:"Hello " response) in read_request t request; let body = match !body with | None -> failwith "no body found" | Some body -> body in Body.Writer.write_string body "Hello "; Alcotest.(check bool) "Writer not woken up" false !writer_woken_up; Body.Writer.flush body ignore; Alcotest.(check bool) "Writer woken up" true !writer_woken_up; writer_yielded t; let writer_woken_up = on_writer_unyield t (fun () -> write_string t "world!"; writer_closed t) in Body.Writer.write_string body "world!"; Alcotest.(check bool) "Writer not woken up" false !writer_woken_up; Body.Writer.close body; Alcotest.(check bool) "Writer woken up" true !writer_woken_up ;; let test_asynchronous_streaming_response_with_immediate_flush () = let request = Request.create `GET "/" ~headers:Headers.connection_close in let response = Response.create `OK in let body = ref None in let t = create (fun reqd -> body := Some (Reqd.respond_with_streaming reqd response ~flush_headers_immediately:true)) in writer_yielded t; let writer_woken_up = on_writer_unyield t (fun () -> write_response t response); in Alcotest.(check bool) "Writer not woken up" false !writer_woken_up; read_request t request; let body = match !body with | None -> failwith "no body found" | Some body -> body in Alcotest.(check bool) "Writer woken up" true !writer_woken_up; writer_yielded t; let writer_woken_up = on_writer_unyield t (fun () -> writer_closed t) in Body.Writer.close body; Alcotest.(check bool) "Writer woken up" true !writer_woken_up ;; let test_empty_fixed_streaming_response () = let request = Request.create `GET "/" in let response = Response.create `OK ~headers:(Headers.encoding_fixed 0) in let t = create (streaming_handler response []) in read_request t request; write_response t response; writer_yielded t; ;; let test_empty_chunked_streaming_response () = let request = Request.create `GET "/" in let response = Response.create `OK ~headers:Headers.encoding_chunked in let t = create (streaming_handler response []) in read_request t request; write_response t response ~body:"0\r\n\r\n"; writer_yielded t; ;; let test_multiple_get () = let t = create default_request_handler in read_request t (Request.create `GET "/"); write_response t (Response.create `OK); read_request t (Request.create `GET "/"); write_response t (Response.create `OK); ;; let test_connection_error () = let t = create ~error_handler (fun _ -> assert false) in let writer_woken_up = on_writer_unyield t ignore in report_exn t (Failure "connection failure"); Alcotest.(check bool) "Writer woken up" true !writer_woken_up; write_response t ~msg:"Error response written" (Response.create `Internal_server_error) ~body:"got an error" ;; let test_synchronous_error () = let t = create ~error_handler synchronous_raise in let writer_woken_up = on_writer_unyield t ignore in read_request t (Request.create `GET "/"); Alcotest.check read_operation "Error shuts down the reader" `Close (current_read_operation t); Alcotest.(check bool) "Writer woken up" true !writer_woken_up; (* This shows up in two flushes because [Reqd] creates error reposnses with [~flush_headers_immediately:true] *) write_response t ~msg:"Error response written" (Response.create `Internal_server_error); write_string t "got an error"; ;; let test_synchronous_error_asynchronous_handling () = let continue = ref (fun () -> ()) in let error_handler ?request error start_response = continue := (fun () -> error_handler ?request error start_response) in let t = create ~error_handler synchronous_raise in writer_yielded t; let writer_woken_up = on_writer_unyield t ignore in read_request t (Request.create `GET "/"); Alcotest.check read_operation "Error shuts down the reader" `Close (current_read_operation t); Alcotest.(check bool) "Writer not woken up" false !writer_woken_up; !continue (); Alcotest.(check bool) "Writer woken up" true !writer_woken_up; (* This shows up in two flushes because [Reqd] creates error reposnses with [~flush_headers_immediately:true] *) write_response t ~msg:"Error response written" (Response.create `Internal_server_error); write_string t "got an error"; ;; let test_asynchronous_error () = let continue = ref (fun () -> ()) in let asynchronous_raise reqd = continue := (fun () -> synchronous_raise reqd) in let t = create ~error_handler asynchronous_raise in writer_yielded t; let writer_woken_up = on_writer_unyield t ignore in read_request t (Request.create `GET "/"); Alcotest.(check bool) "Writer not woken up" false !writer_woken_up; reader_yielded t; !continue (); Alcotest.(check bool) "Writer woken up" true !writer_woken_up; (* This shows up in two flushes because [Reqd] creates error reposnses with [~flush_headers_immediately:true] *) write_response t ~msg:"Error response written" (Response.create `Internal_server_error); write_string t "got an error"; connection_is_shutdown t ;; let test_asynchronous_error_asynchronous_handling () = let continue_request = ref (fun () -> ()) in let asynchronous_raise reqd = continue_request := (fun () -> synchronous_raise reqd) in let continue_error = ref (fun () -> ()) in let error_handler ?request error start_response = continue_error := (fun () -> error_handler ?request error start_response) in let t = create ~error_handler asynchronous_raise in writer_yielded t; let writer_woken_up = on_writer_unyield t ignore in read_request t (Request.create `GET "/"); Alcotest.(check bool) "Writer not woken up" false !writer_woken_up; reader_yielded t; !continue_request (); Alcotest.(check bool) "Writer not woken up" false !writer_woken_up; !continue_error (); Alcotest.(check bool) "Writer woken up" true !writer_woken_up; (* This shows up in two flushes because [Reqd] creates error reposnses with [~flush_headers_immediately:true] *) write_response t ~msg:"Error response written" (Response.create `Internal_server_error); write_string t "got an error"; connection_is_shutdown t ;; let test_error_while_parsing () = let continue_error = ref (fun () -> ()) in let error_handler ?request error start_response = continue_error := (fun () -> error_handler ?request error start_response) in let setup () = let t = create ~error_handler (fun _ -> assert false) in let n = feed_string t "GET / HTTP/1.1\r\n" in Alcotest.(check int) "read bytes" 16 n; reader_ready t; report_exn t (Failure "runtime error during parse"); t in (* Handle before read *) let t = setup () in !continue_error (); write_response t ~msg:"Error response written" (Response.create `Internal_server_error) ~body:"got an error"; writer_closed t; (* XXX(dpatti): Runtime is in a read loop and must report something. I don't know if this could ever deadlock or if that's a runtime concern. *) reader_ready t; let n = feed_string t "Host: localhost\r\n" in Alcotest.(check int) "read bytes" 0 n; reader_closed t; (* Read before handle *) let t = setup () in reader_ready t; let n = feed_string t "Host: localhost\r\n" in Alcotest.(check int) "read bytes" 0 n; reader_closed t; !continue_error (); write_response t ~msg:"Error response written" (Response.create `Internal_server_error) ~body:"got an error"; writer_closed t; ;; let test_error_before_read () = let request_handler _ = assert false in let invoked_error_handler = ref false in let error_handler ?request:_ _ _ = invoked_error_handler := true; in let t = create ~error_handler request_handler in report_exn t (Failure "immediate runtime error"); reader_ready t; writer_yielded t; (* XXX(dpatti): This seems wrong to me. Should we be sending responses when we haven't even read any bytes yet? Maybe too much of an edge case to worry. *) Alcotest.(check bool) "Error handler was invoked" true !invoked_error_handler; ;; let test_error_left_unhandled () = let error_handler ?request:_ _ _ = () in let t = create ~error_handler (fun _ -> ()) in read_request t (Request.create `GET "/"); report_exn t (Failure "runtime error"); (* If the error handler is invoked and does not try to complete a response, the connection will hang. This is not necessarily desirable but rather a tradeoff to let the user respond asynchronously. *) reader_yielded t; writer_yielded t; ;; let test_chunked_encoding () = let request_handler reqd = let response = Response.create `OK ~headers:Headers.encoding_chunked in let resp_body = Reqd.respond_with_streaming reqd response in Body.Writer.write_string resp_body "First chunk"; Body.Writer.flush resp_body (fun () -> Body.Writer.write_string resp_body "Second chunk"; Body.Writer.close resp_body); in let t = create ~error_handler request_handler in writer_yielded t; read_request t (Request.create `GET "/"); write_response t ~msg:"First chunk written" ~body:"b\r\nFirst chunk\r\n" (Response.create `OK ~headers:Headers.encoding_chunked); write_string t ~msg:"Second chunk" "c\r\nSecond chunk\r\n"; write_string t ~msg:"Final chunk written" "0\r\n\r\n"; Alcotest.check read_operation "Keep-alive" `Read (current_read_operation t); ;; let test_chunked_encoding_for_error () = let error_handler ?request error start_response = Alcotest.(check (option request)) "No parsed request" None request; Alcotest.(check request_error) "Request error" `Bad_request error; let body = start_response Headers.encoding_chunked in Body.Writer.write_string body "Bad"; Body.Writer.flush body (fun () -> Body.Writer.write_string body " request"; Body.Writer.close body); in let t = create ~error_handler (fun _ -> assert false) in let c = feed_string t " X\r\n\r\n" in Alcotest.(check int) "Partial read" 2 c; (* XXX(dpatti): Note that even if we use a chunked encoding header, we still write it without any encoding *) write_response t (Response.create `Bad_request ~headers:Headers.encoding_chunked) ~body:"Bad"; write_string t " request"; connection_is_shutdown t; ;; let test_blocked_write_on_chunked_encoding () = let request_handler reqd = let response = Response.create `OK ~headers:Headers.encoding_chunked in let resp_body = Reqd.respond_with_streaming reqd response in Body.Writer.write_string resp_body "gets partially written"; Body.Writer.flush resp_body ignore; (* Response body never gets closed but for the purposes of the test, that's * OK. *) in let t = create ~error_handler request_handler in writer_yielded t; read_request t (Request.create `GET "/"); let response_bytes = "HTTP/1.1 200 OK\r\ntransfer-encoding: chunked\r\n\r\n16\r\ngets partially written\r\n" in let second_write = write_partial_string t ~msg:"first write" response_bytes 16 in write_string t ~msg:"second write" second_write ;; let test_unexpected_eof () = let t = create default_request_handler in read_request t (Request.create `GET "/"); write_eof t; writer_closed t ~unread:19; ;; let test_input_shrunk () = let continue_response = ref (fun () -> ()) in let error_handler ?request:_ _ = assert false in let request_handler reqd = Alcotest.(check (list (pair string string))) "got expected headers" [ "Host" , "example.com" ; "Connection" , "close" ; "Accept" , "application/json, text/plain, */*" ; "Accept-Language", "en-US,en;q=0.5" ] (Headers.to_list (Reqd.request reqd).headers); Body.Reader.close (Reqd.request_body reqd); continue_response := (fun () -> Reqd.respond_with_string reqd (Response.create `OK) ""); in let t = create ~error_handler request_handler in reader_ready t; writer_yielded t; let writer_woken_up = on_writer_unyield t (fun () -> write_response t (Response.create `OK)) in let len = feed_string t "GET /v1/b HTTP/1.1\r\nH" in Alcotest.(check int) "partial read" 20 len; read_string t "Host: example.com\r\n\ Connection: close\r\n\ Accept: application/json, text/plain, */*\r\n\ Accept-Language: en-US,en;q=0.5\r\n\r\n"; Alcotest.(check bool) "Writer not woken up" false !writer_woken_up; reader_closed t; !continue_response (); Alcotest.(check bool) "Writer woken up" true !writer_woken_up; writer_closed t; ;; let test_failed_request_parse () = let error_handler_fired = ref false in let error_handler ?request error start_response = error_handler_fired := true; Alcotest.(check (option request)) "No parsed request" None request; Alcotest.(check request_error) "Request error" `Bad_request error; start_response Headers.empty |> Body.Writer.close; in let request_handler _reqd = assert false in let t = create ~error_handler request_handler in reader_ready t; writer_yielded t; let writer_woken_up = on_writer_unyield t ignore in let len = feed_string t "GET /v1/b HTTP/1.1\r\nHost : example.com\r\n\r\n" in (* Reads through the end of "Host" *) Alcotest.(check int) "partial read" 24 len; reader_closed t; Alcotest.(check bool) "Error handler fired" true !error_handler_fired; Alcotest.(check bool) "Writer woken up" true !writer_woken_up; write_response t (Response.create `Bad_request); ;; let test_bad_request () = (* A `Bad_request is returned in a number of cases surrounding transfer-encoding or content-length headers. *) let request = Request.create `GET "/" ~headers:(Headers.encoding_fixed (-1)) in let error_handler_fired = ref false in let error_handler ?request:request' error start_response = error_handler_fired := true; Alcotest.(check (option request)) "Parsed request" (Some request) request'; Alcotest.(check request_error) "Request error" `Bad_request error; start_response Headers.empty |> Body.Writer.close; in let request_handler _reqd = assert false in let t = create ~error_handler request_handler in reader_ready t; writer_yielded t; let writer_woken_up = on_writer_unyield t ignore in read_request t request; reader_closed t; Alcotest.(check bool) "Error handler fired" true !error_handler_fired; Alcotest.(check bool) "Writer woken up" true !writer_woken_up; write_response t (Response.create `Bad_request); ;; let test_multiple_requests_in_single_read () = let response = Response.create `OK in let t = create (fun reqd -> Reqd.respond_with_string reqd response "") in let reqs = request_to_string (Request.create `GET "/") ^ request_to_string (Request.create `GET "/") in read_string t reqs; write_response t response; write_response t response; ;; let test_multiple_async_requests_in_single_read () = let response = Response.create `OK in let reqs_handled = ref 0 in let finish_handler = ref (fun () -> assert false) in let t = create (fun reqd -> reqs_handled := !reqs_handled + 1; finish_handler := (fun () -> Reqd.respond_with_string reqd response "")) in let reqs = request_to_string (Request.create `GET "/") ^ request_to_string (Request.create `GET "/") in read_string t reqs; reader_yielded t; writer_yielded t; Alcotest.(check int) "fired handler once" 1 !reqs_handled; !finish_handler (); write_response t response; Alcotest.(check int) "fired handler again" 2 !reqs_handled; !finish_handler (); write_response t response; reader_ready t; ;; let test_multiple_requests_in_single_read_with_close () = let response = Response.create `OK ~headers:Headers.connection_close in let t = create (fun reqd -> Reqd.respond_with_string reqd response "") in let reqs = request_to_string (Request.create `GET "/") ^ request_to_string (Request.create `GET "/") in read_string t reqs; write_response t response; connection_is_shutdown t; ;; let test_multiple_requests_in_single_read_with_eof () = let response = Response.create `OK in let t = create (fun reqd -> Reqd.respond_with_string reqd response "") in let reqs = request_to_string (Request.create `GET "/") ^ request_to_string (Request.create `GET "/") in read_string t reqs ~eof:true; write_response t response; write_response t response; connection_is_shutdown t; ;; let test_parse_failure_after_checkpoint () = let error_queue = ref None in let error_handler ?request:_ error _start_response = Alcotest.(check (option reject)) "Error queue is empty" !error_queue None; error_queue := Some error in let request_handler _reqd = assert false in let t = create ~error_handler request_handler in reader_ready t; read_string t "GET index.html HTTP/1.1\r\n"; let result = feed_string t " index.html HTTP/1.1\r\n\r\n" in Alcotest.(check int) "Bad header not consumed" result 0; reader_closed t; match !error_queue with | None -> Alcotest.fail "Expected error" | Some error -> Alcotest.(check request_error) "Error" error `Bad_request ;; let test_parse_failure_at_eof () = let error_queue = ref None in let continue = ref (fun () -> ()) in let error_handler ?request error start_response = Alcotest.(check (option reject)) "Error queue is empty" !error_queue None; Alcotest.(check (option reject)) "Request was not parsed" request None; error_queue := Some error; continue := (fun () -> let resp_body = start_response Headers.empty in Body.Writer.write_string resp_body "got an error"; Body.Writer.close resp_body); in let request_handler _reqd = assert false in let t = create ~error_handler request_handler in reader_ready t; read_string t "GET index.html HTTP/1.1\r\n"; let result = feed_string ~eof:true t " index.html HTTP/1.1\r\n\r\n" in Alcotest.(check int) "Bad header not consumed" result 0; reader_closed t; (match !error_queue with | None -> Alcotest.fail "Expected error" | Some error -> Alcotest.(check request_error) "Error" error `Bad_request); !continue (); write_response t (Response.create `Bad_request) ~body:"got an error"; writer_closed t; ;; let test_response_finished_before_body_read () = let response = Response.create `OK ~headers:(Headers.encoding_fixed 4) in let rev_body_chunks = ref [] in let request_handler reqd = let rec read_body () = Body.Reader.schedule_read (Reqd.request_body reqd) ~on_read:(fun buf ~off ~len -> rev_body_chunks := Bigstringaf.substring buf ~off ~len :: !rev_body_chunks; read_body ()) ~on_eof:ignore; in read_body (); Reqd.respond_with_string reqd response "done" in let t = create request_handler in read_request t (Request.create `GET "/" ~headers:(Headers.encoding_fixed 12)); write_response t response ~body:"done"; (* Finish the request and send another *) read_string t "hello, "; read_string t "world"; Alcotest.(check (list string)) "received body" ["world"; "hello, "] !rev_body_chunks; read_request t (Request.create `GET "/"); write_response t response ~body:"done"; ;; let test_shutdown_in_request_handler () = let request = Request.create `GET "/" in let rec t = lazy (create (fun _ -> shutdown (Lazy.force t))) in let t = Lazy.force t in read_request t request; reader_closed t; writer_closed t ;; let test_shutdown_during_asynchronous_request () = let request = Request.create `GET "/" in let response = Response.create `OK in let continue = ref (fun () -> ()) in let t = create (fun reqd -> continue := (fun () -> Reqd.respond_with_string reqd response "")) in read_request t request; shutdown t; raises_writer_closed !continue; reader_closed t; writer_closed t ;; let test_flush_response_before_shutdown () = let request = Request.create `GET "/" ~headers:(Headers.encoding_fixed 0) in let response = Response.create `OK ~headers:Headers.encoding_chunked in let continue = ref (fun () -> ()) in let request_handler reqd = let body = Reqd.respond_with_streaming ~flush_headers_immediately:true reqd response in continue := (fun () -> Body.Writer.write_string body "hello world"; Body.Writer.close body); in let t = create request_handler in read_request t request; write_response t response; !continue (); shutdown t; raises_writer_closed (fun () -> write_string t "b\r\nhello world\r\n"; connection_is_shutdown t); ;; let test_schedule_read_with_data_available () = let response = Response.create `OK in let body = ref None in let continue = ref (fun () -> ()) in let request_handler reqd = body := Some (Reqd.request_body reqd); continue := (fun () -> Reqd.respond_with_string reqd response "") in let t = create request_handler in read_request t (Request.create `GET "/" ~headers:(Headers.encoding_fixed 6)); let body = Option.get !body in let schedule_read expected = let did_read = ref false in Body.Reader.schedule_read body ~on_read:(fun buf ~off ~len -> let actual = Bigstringaf.substring buf ~off ~len in did_read := true; Alcotest.(check string) "Body" expected actual) ~on_eof:(fun () -> assert false); Alcotest.(check bool) "on_read called" true !did_read; in (* We get some data on the connection, but not the full response yet. *) read_string t "Hello"; (* Schedule a read when there is already data available. on_read should be called synchronously *) schedule_read "Hello"; read_string t "!"; schedule_read "!"; (* Also works with eof *) Body.Reader.schedule_read body ~on_read:(fun _ ~off:_ ~len:_ -> Alcotest.fail "Expected eof") ~on_eof:(fun () -> !continue ()); write_response t response; ;; let tests = [ "initial reader state" , `Quick, test_initial_reader_state ; "shutdown reader closed", `Quick, test_reader_is_closed_after_eof ; "single GET" , `Quick, test_single_get ; "multiple GETs" , `Quick, test_multiple_get ; "asynchronous response" , `Quick, test_asynchronous_response ; "echo POST" , `Quick, test_echo_post ; "streaming response" , `Quick, test_streaming_response ; "asynchronous streaming response", `Quick, test_asynchronous_streaming_response ; "asynchronous streaming response, immediate flush", `Quick, test_asynchronous_streaming_response_with_immediate_flush ; "empty fixed streaming response", `Quick, test_empty_fixed_streaming_response ; "empty chunked streaming response", `Quick, test_empty_chunked_streaming_response ; "connection error", `Quick, test_connection_error ; "synchronous error, synchronous handling", `Quick, test_synchronous_error ; "synchronous error, asynchronous handling", `Quick, test_synchronous_error_asynchronous_handling ; "asynchronous error, synchronous handling", `Quick, test_asynchronous_error ; "asynchronous error, asynchronous handling", `Quick, test_asynchronous_error_asynchronous_handling ; "error while parsing", `Quick, test_error_while_parsing ; "error before read", `Quick, test_error_before_read ; "error left unhandled", `Quick, test_error_left_unhandled ; "chunked encoding", `Quick, test_chunked_encoding ; "chunked encoding for error", `Quick, test_chunked_encoding_for_error ; "blocked write on chunked encoding", `Quick, test_blocked_write_on_chunked_encoding ; "writer unexpected eof", `Quick, test_unexpected_eof ; "input shrunk", `Quick, test_input_shrunk ; "failed request parse", `Quick, test_failed_request_parse ; "bad request", `Quick, test_bad_request ; "multiple requests in single read", `Quick, test_multiple_requests_in_single_read ; "multiple async requests in single read", `Quick, test_multiple_async_requests_in_single_read ; "multiple requests with connection close", `Quick, test_multiple_requests_in_single_read_with_close ; "multiple requests with eof", `Quick, test_multiple_requests_in_single_read_with_eof ; "parse failure after checkpoint", `Quick, test_parse_failure_after_checkpoint ; "parse failure at eof", `Quick, test_parse_failure_at_eof ; "response finished before body read", `Quick, test_response_finished_before_body_read ; "shutdown in request handler", `Quick, test_shutdown_in_request_handler ; "shutdown during asynchronous request", `Quick, test_shutdown_during_asynchronous_request ; "flush response before shutdown", `Quick, test_flush_response_before_shutdown ; "schedule read with data available", `Quick, test_schedule_read_with_data_available ] ================================================ FILE: lib_test/test_version.ml ================================================ open Httpaf open Version let v1_0 = { major = 1; minor = 0 } let v1_1 = { major = 1; minor = 1 } let test_compare () = Alcotest.(check int) "compare v1_1 v1_0" (compare v1_1 v1_0) 1; Alcotest.(check int) "compare v1_1 v1_1" (compare v1_1 v1_1) 0; Alcotest.(check int) "compare v1_0 v1_0" (compare v1_0 v1_0) 0; Alcotest.(check int) "compare v1_0 v1_1" (compare v1_0 v1_1) (-1); ;; let test_to_string () = Alcotest.(check string) "to_string v1_1" (to_string v1_1) "HTTP/1.1"; Alcotest.(check string) "to_string v1_0" (to_string v1_0) "HTTP/1.0"; ;; let tests = [ "compare" , `Quick, test_compare ; "to_string", `Quick, test_to_string ] ================================================ FILE: lwt-unix/dune ================================================ (library (name httpaf_lwt_unix) (public_name httpaf-lwt-unix) (libraries faraday-lwt-unix httpaf lwt.unix) (flags (:standard -safe-string))) ================================================ FILE: lwt-unix/httpaf_lwt_unix.ml ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2018 Inhabited Type LLC. Copyright (c) 2018 Anton Bachin All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) open Lwt.Infix module Buffer : sig type t val create : int -> t val get : t -> f:(Lwt_bytes.t -> off:int -> len:int -> int) -> int val put : t -> f:(Lwt_bytes.t -> off:int -> len:int -> int Lwt.t) -> int Lwt.t end = struct type t = { buffer : Lwt_bytes.t ; mutable off : int ; mutable len : int } let create size = let buffer = Lwt_bytes.create size in { buffer; off = 0; len = 0 } let compress t = if t.len = 0 then begin t.off <- 0; t.len <- 0; end else if t.off > 0 then begin Lwt_bytes.blit t.buffer t.off t.buffer 0 t.len; t.off <- 0; end let get t ~f = let n = f t.buffer ~off:t.off ~len:t.len in t.off <- t.off + n; t.len <- t.len - n; if t.len = 0 then t.off <- 0; n let put t ~f = compress t; f t.buffer ~off:(t.off + t.len) ~len:(Lwt_bytes.length t.buffer - t.len) >>= fun n -> t.len <- t.len + n; Lwt.return n end let read fd buffer = Lwt.catch (fun () -> Buffer.put buffer ~f:(fun bigstring ~off ~len -> Lwt_bytes.read fd bigstring off len)) (function | Unix.Unix_error (Unix.EBADF, _, _) as exn -> Lwt.fail exn | exn -> Lwt.async (fun () -> Lwt_unix.close fd); Lwt.fail exn) >>= fun bytes_read -> if bytes_read = 0 then Lwt.return `Eof else Lwt.return (`Ok bytes_read) let shutdown socket command = try Lwt_unix.shutdown socket command with Unix.Unix_error (Unix.ENOTCONN, _, _) -> () module Config = Httpaf.Config module Server = struct let create_connection_handler ?(config=Config.default) ~request_handler ~error_handler = fun client_addr socket -> let module Server_connection = Httpaf.Server_connection in let connection = Server_connection.create ~config ~error_handler:(error_handler client_addr) (request_handler client_addr) in let read_buffer = Buffer.create config.read_buffer_size in let read_loop_exited, notify_read_loop_exited = Lwt.wait () in let rec read_loop () = let rec read_loop_step () = match Server_connection.next_read_operation connection with | `Read -> read socket read_buffer >>= begin function | `Eof -> Buffer.get read_buffer ~f:(fun bigstring ~off ~len -> Server_connection.read_eof connection bigstring ~off ~len) |> ignore; read_loop_step () | `Ok _ -> Buffer.get read_buffer ~f:(fun bigstring ~off ~len -> Server_connection.read connection bigstring ~off ~len) |> ignore; read_loop_step () end | `Yield -> Server_connection.yield_reader connection read_loop; Lwt.return_unit | `Close -> Lwt.wakeup_later notify_read_loop_exited (); if not (Lwt_unix.state socket = Lwt_unix.Closed) then begin shutdown socket Unix.SHUTDOWN_RECEIVE end; Lwt.return_unit in Lwt.async (fun () -> Lwt.catch read_loop_step (fun exn -> Server_connection.report_exn connection exn; Lwt.return_unit)) in let writev = Faraday_lwt_unix.writev_of_fd socket in let write_loop_exited, notify_write_loop_exited = Lwt.wait () in let rec write_loop () = let rec write_loop_step () = match Server_connection.next_write_operation connection with | `Write io_vectors -> writev io_vectors >>= fun result -> Server_connection.report_write_result connection result; write_loop_step () | `Yield -> Server_connection.yield_writer connection write_loop; Lwt.return_unit | `Close _ -> Lwt.wakeup_later notify_write_loop_exited (); if not (Lwt_unix.state socket = Lwt_unix.Closed) then begin shutdown socket Unix.SHUTDOWN_SEND end; Lwt.return_unit in Lwt.async (fun () -> Lwt.catch write_loop_step (fun exn -> Server_connection.report_exn connection exn; Lwt.return_unit)) in read_loop (); write_loop (); Lwt.join [read_loop_exited; write_loop_exited] >>= fun () -> if Lwt_unix.state socket <> Lwt_unix.Closed then Lwt.catch (fun () -> Lwt_unix.close socket) (fun _exn -> Lwt.return_unit) else Lwt.return_unit end module Client = struct let request ?(config=Config.default) socket request ~error_handler ~response_handler = let module Client_connection = Httpaf.Client_connection in let request_body, connection = Client_connection.request ~config request ~error_handler ~response_handler in let read_buffer = Buffer.create config.read_buffer_size in let read_loop_exited, notify_read_loop_exited = Lwt.wait () in let read_loop () = let rec read_loop_step () = match Client_connection.next_read_operation connection with | `Read -> read socket read_buffer >>= begin function | `Eof -> Buffer.get read_buffer ~f:(fun bigstring ~off ~len -> Client_connection.read_eof connection bigstring ~off ~len) |> ignore; read_loop_step () | `Ok _ -> Buffer.get read_buffer ~f:(fun bigstring ~off ~len -> Client_connection.read connection bigstring ~off ~len) |> ignore; read_loop_step () end | `Close -> Lwt.wakeup_later notify_read_loop_exited (); if not (Lwt_unix.state socket = Lwt_unix.Closed) then begin shutdown socket Unix.SHUTDOWN_RECEIVE end; Lwt.return_unit in Lwt.async (fun () -> Lwt.catch read_loop_step (fun exn -> Client_connection.report_exn connection exn; Lwt.return_unit)) in let writev = Faraday_lwt_unix.writev_of_fd socket in let write_loop_exited, notify_write_loop_exited = Lwt.wait () in let rec write_loop () = let rec write_loop_step () = match Client_connection.next_write_operation connection with | `Write io_vectors -> writev io_vectors >>= fun result -> Client_connection.report_write_result connection result; write_loop_step () | `Yield -> Client_connection.yield_writer connection write_loop; Lwt.return_unit | `Close _ -> Lwt.wakeup_later notify_write_loop_exited (); Lwt.return_unit in Lwt.async (fun () -> Lwt.catch write_loop_step (fun exn -> Client_connection.report_exn connection exn; Lwt.return_unit)) in read_loop (); write_loop (); Lwt.async (fun () -> Lwt.join [read_loop_exited; write_loop_exited] >>= fun () -> if Lwt_unix.state socket <> Lwt_unix.Closed then Lwt.catch (fun () -> Lwt_unix.close socket) (fun _exn -> Lwt.return_unit) else Lwt.return_unit); request_body end ================================================ FILE: lwt-unix/httpaf_lwt_unix.mli ================================================ (*---------------------------------------------------------------------------- Copyright (c) 2018 Inhabited Type LLC. Copyright (c) 2018 Anton Bachin All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------*) open Httpaf (* The function that results from [create_connection_handler] should be passed to [Lwt_io.establish_server_with_client_socket]. For an example, see [examples/lwt_echo_server.ml]. *) module Server : sig val create_connection_handler : ?config : Config.t -> request_handler : (Unix.sockaddr -> Server_connection.request_handler) -> error_handler : (Unix.sockaddr -> Server_connection.error_handler) -> Unix.sockaddr -> Lwt_unix.file_descr -> unit Lwt.t end (* For an example, see [examples/lwt_get.ml]. *) module Client : sig val request : ?config : Httpaf.Config.t -> Lwt_unix.file_descr -> Request.t -> error_handler : Client_connection.error_handler -> response_handler : Client_connection.response_handler -> Httpaf.Body.Writer.t end