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