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