├── dune-project ├── images └── httpaf-comparison.png ├── .gitignore ├── examples ├── lib │ ├── dune │ └── httpaf_examples.ml ├── async │ ├── dune │ ├── async_get.ml │ ├── async_echo_post.ml │ └── async_post.ml └── lwt │ ├── dune │ ├── lwt_get.ml │ ├── lwt_echo_post.ml │ └── lwt_post.ml ├── lib ├── dune ├── optional_thunk.mli ├── optional_thunk.ml ├── config.ml ├── httpaf.ml ├── headers.mli ├── iOVec.ml ├── version.ml ├── method.ml ├── message.ml ├── request.ml ├── response.ml ├── headers.ml ├── serialize.ml ├── body.ml ├── client_connection.ml ├── reqd.ml ├── status.ml ├── server_connection.ml ├── parse.ml └── httpaf.mli ├── lwt-unix ├── dune ├── httpaf_lwt_unix.mli └── httpaf_lwt_unix.ml ├── async ├── dune ├── httpaf_async.mli └── httpaf_async.ml ├── benchmarks ├── dune ├── wrk_lwt_benchmark.ml └── wrk_async_benchmark.ml ├── Makefile ├── lib_test ├── dune ├── test_httpaf.ml ├── test_version.ml ├── test_iovec.ml ├── test_method.ml ├── test_headers.ml ├── helpers.ml ├── test_request.ml ├── test_response.ml └── test_client_connection.ml ├── httpaf-async.opam ├── httpaf-lwt-unix.opam ├── httpaf.opam ├── LICENSE ├── .github └── workflows │ └── test.yml └── README.md /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.5) 2 | 3 | (name httpaf) 4 | -------------------------------------------------------------------------------- /images/httpaf-comparison.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inhabitedtype/httpaf/HEAD/images/httpaf-comparison.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.sw[po] 2 | _build/ 3 | _tests/ 4 | lib_test/tests_ 5 | *.native 6 | *.byte 7 | *.docdir 8 | .merlin 9 | *.install 10 | -------------------------------------------------------------------------------- /examples/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name httpaf_examples) 3 | (libraries httpaf base stdio) 4 | (flags (:standard -safe-string))) 5 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name httpaf) 3 | (public_name httpaf) 4 | (libraries 5 | angstrom faraday bigstringaf) 6 | (flags (:standard -safe-string))) 7 | -------------------------------------------------------------------------------- /lwt-unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name httpaf_lwt_unix) 3 | (public_name httpaf-lwt-unix) 4 | (libraries faraday-lwt-unix httpaf lwt.unix) 5 | (flags (:standard -safe-string))) 6 | -------------------------------------------------------------------------------- /async/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name httpaf_async) 3 | (public_name httpaf-async) 4 | (wrapped false) 5 | (libraries 6 | async core faraday-async httpaf) 7 | (flags (:standard -safe-string))) 8 | -------------------------------------------------------------------------------- /examples/async/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (libraries httpaf httpaf-async httpaf_examples async core) 3 | (names async_echo_post async_get async_post)) 4 | 5 | (alias 6 | (name examples) 7 | (deps (glob_files *.exe))) 8 | -------------------------------------------------------------------------------- /examples/lwt/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (libraries httpaf httpaf-lwt-unix httpaf_examples base stdio lwt lwt.unix) 3 | (names lwt_get lwt_post lwt_echo_post)) 4 | 5 | (alias 6 | (name examples) 7 | (deps (glob_files *.exe))) 8 | -------------------------------------------------------------------------------- /lib/optional_thunk.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val none : t 4 | val some : (unit -> unit) -> t 5 | 6 | val is_none : t -> bool 7 | val is_some : t -> bool 8 | 9 | val call_if_some : t -> unit 10 | val unchecked_value : t -> unit -> unit 11 | -------------------------------------------------------------------------------- /lib/optional_thunk.ml: -------------------------------------------------------------------------------- 1 | type t = unit -> unit 2 | 3 | let none = Sys.opaque_identity (fun () -> ()) 4 | let some f = 5 | if f == none 6 | then failwith "Optional_thunk: this function is not representable as a some value"; 7 | f 8 | 9 | let is_none t = t == none 10 | let is_some t = not (is_none t) 11 | let call_if_some t = t () 12 | let unchecked_value t = t 13 | -------------------------------------------------------------------------------- /lib/config.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { read_buffer_size : int 3 | ; request_body_buffer_size : int 4 | ; response_buffer_size : int 5 | ; response_body_buffer_size : int } 6 | 7 | let default = 8 | { read_buffer_size = 0x1000 9 | ; request_body_buffer_size = 0x1000 10 | ; response_buffer_size = 0x400 11 | ; response_body_buffer_size = 0x1000 } 12 | -------------------------------------------------------------------------------- /benchmarks/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name wrk_async_benchmark) 3 | (modules wrk_async_benchmark) 4 | (libraries httpaf httpaf_examples httpaf-async async core)) 5 | 6 | (executable 7 | (name wrk_lwt_benchmark) 8 | (modules Wrk_lwt_benchmark) 9 | (libraries httpaf httpaf_examples httpaf-lwt-unix lwt.unix base)) 10 | 11 | (alias 12 | (name benchmarks) 13 | (deps (glob_files *.exe))) 14 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all build clean test examples 2 | 3 | build: 4 | dune build @install 5 | 6 | all: build 7 | 8 | test: 9 | dune runtest 10 | 11 | examples: 12 | dune build @examples 13 | 14 | watch: 15 | dune build {httpaf,httpaf-async,httpaf-lwt-unix}.install @runtest --watch 16 | 17 | install: 18 | dune install 19 | 20 | uninstall: 21 | dune uninstall 22 | 23 | clean: 24 | rm -rf _build *.install 25 | -------------------------------------------------------------------------------- /lib_test/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (libraries bigstringaf httpaf alcotest) 3 | (modules 4 | helpers 5 | test_client_connection 6 | test_headers 7 | test_httpaf 8 | test_iovec 9 | test_method 10 | test_request 11 | test_response 12 | test_server_connection 13 | test_version) 14 | (names test_httpaf)) 15 | 16 | (alias 17 | (name runtest) 18 | (package httpaf) 19 | (deps test_httpaf.exe) 20 | (action (run %{deps}))) 21 | -------------------------------------------------------------------------------- /lib_test/test_httpaf.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.run "httpaf unit tests" 3 | [ "version" , Test_version.tests 4 | ; "method" , Test_method.tests 5 | ; "iovec" , Test_iovec.tests 6 | ; "headers" , Test_headers.tests 7 | ; "request" , Test_request.tests 8 | ; "response" , Test_response.tests 9 | ; "client connection", Test_client_connection.tests 10 | ; "server connection", Test_server_connection.tests 11 | ] 12 | -------------------------------------------------------------------------------- /lib/httpaf.ml: -------------------------------------------------------------------------------- 1 | module Headers = Headers 2 | module IOVec = IOVec 3 | module Method = Method 4 | module Reqd = Reqd 5 | module Request = Request 6 | module Response = Response 7 | module Status = Status 8 | module Version = Version 9 | module Body = Body 10 | module Config = Config 11 | 12 | module Server_connection = Server_connection 13 | module Client_connection = Client_connection.Oneshot 14 | 15 | module Httpaf_private = struct 16 | module Parse = Parse 17 | module Serialize = Serialize 18 | end 19 | -------------------------------------------------------------------------------- /async/httpaf_async.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Async 3 | 4 | open Httpaf 5 | 6 | module Server : sig 7 | val create_connection_handler 8 | : ?config : Config.t 9 | -> request_handler : ('a -> Server_connection.request_handler) 10 | -> error_handler : ('a -> Server_connection.error_handler) 11 | -> ([< Socket.Address.t] as 'a) 12 | -> ([`Active], 'a) Socket.t 13 | -> unit Deferred.t 14 | end 15 | 16 | module Client : sig 17 | val request 18 | : ?config : Config.t 19 | -> ([`Active], [< Socket.Address.t]) Socket.t 20 | -> Request.t 21 | -> error_handler : Client_connection.error_handler 22 | -> response_handler : Client_connection.response_handler 23 | -> Body.Writer.t 24 | end 25 | -------------------------------------------------------------------------------- /httpaf-async.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "httpaf-async" 3 | maintainer: "Spiros Eliopoulos " 4 | authors: [ "Spiros Eliopoulos " ] 5 | license: "BSD-3-clause" 6 | homepage: "https://github.com/inhabitedtype/httpaf" 7 | bug-reports: "https://github.com/inhabitedtype/httpaf/issues" 8 | dev-repo: "git+https://github.com/inhabitedtype/httpaf.git" 9 | build: [ 10 | ["dune" "subst"] {pinned} 11 | ["dune" "build" "-p" name "-j" jobs] 12 | ["dune" "runtest" "-p" name] {with-test} 13 | ] 14 | depends: [ 15 | "ocaml" {>= "4.08.0"} 16 | "dune" {>= "1.5.0"} 17 | "faraday-async" {>= "0.7.2"} 18 | "async" {>= "v0.14.0"} 19 | "httpaf" {= version} 20 | ] 21 | synopsis: "Async support for http/af" 22 | -------------------------------------------------------------------------------- /httpaf-lwt-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "httpaf-lwt-unix" 3 | maintainer: "Spiros Eliopoulos " 4 | authors: [ 5 | "Anton Bachin " 6 | "Spiros Eliopoulos " 7 | ] 8 | license: "BSD-3-clause" 9 | homepage: "https://github.com/inhabitedtype/httpaf" 10 | bug-reports: "https://github.com/inhabitedtype/httpaf/issues" 11 | dev-repo: "git+https://github.com/inhabitedtype/httpaf.git" 12 | build: [ 13 | ["dune" "subst"] {pinned} 14 | ["dune" "build" "-p" name "-j" jobs] 15 | ] 16 | depends: [ 17 | "ocaml" {>= "4.03.0"} 18 | "faraday-lwt-unix" 19 | "httpaf" {>= "0.6.0"} 20 | "dune" {>= "1.5.0"} 21 | "lwt" {>= "2.4.7"} 22 | ] 23 | synopsis: "Lwt support for http/af" 24 | -------------------------------------------------------------------------------- /lib_test/test_version.ml: -------------------------------------------------------------------------------- 1 | open Httpaf 2 | open Version 3 | 4 | let v1_0 = { major = 1; minor = 0 } 5 | let v1_1 = { major = 1; minor = 1 } 6 | 7 | let test_compare () = 8 | Alcotest.(check int) "compare v1_1 v1_0" (compare v1_1 v1_0) 1; 9 | Alcotest.(check int) "compare v1_1 v1_1" (compare v1_1 v1_1) 0; 10 | Alcotest.(check int) "compare v1_0 v1_0" (compare v1_0 v1_0) 0; 11 | Alcotest.(check int) "compare v1_0 v1_1" (compare v1_0 v1_1) (-1); 12 | ;; 13 | 14 | let test_to_string () = 15 | Alcotest.(check string) "to_string v1_1" (to_string v1_1) "HTTP/1.1"; 16 | Alcotest.(check string) "to_string v1_0" (to_string v1_0) "HTTP/1.0"; 17 | ;; 18 | 19 | let tests = 20 | [ "compare" , `Quick, test_compare 21 | ; "to_string", `Quick, test_to_string 22 | ] 23 | -------------------------------------------------------------------------------- /benchmarks/wrk_lwt_benchmark.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Httpaf_lwt_unix 3 | module Arg = Caml.Arg 4 | 5 | let main port = 6 | let open Lwt.Infix in 7 | let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in 8 | let request_handler _ = Httpaf_examples.Server.benchmark in 9 | let error_handler _ = Httpaf_examples.Server.error_handler in 10 | Lwt.async begin fun () -> 11 | Lwt_io.establish_server_with_client_socket 12 | ~backlog:11_000 13 | listen_address 14 | (Server.create_connection_handler ~request_handler ~error_handler) 15 | >>= fun _server -> Lwt.return_unit 16 | end; 17 | let forever, _ = Lwt.wait () in 18 | Lwt_main.run forever 19 | ;; 20 | 21 | let () = 22 | let port = ref 8080 in 23 | Arg.parse 24 | ["-p", Arg.Set_int port, " Listening port number (8080 by default)"] 25 | ignore 26 | "Responds to requests with a fixed string for benchmarking purposes."; 27 | main !port 28 | ;; 29 | -------------------------------------------------------------------------------- /lib/headers.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | type name = string 4 | type value = string 5 | 6 | (** Case-insensitive equality for testing header names or values *) 7 | val ci_equal : string -> string -> bool 8 | 9 | val empty : t 10 | 11 | val of_list : (name * value) list -> t 12 | val of_rev_list : (name * value) list -> t 13 | val to_list : t -> (name * value) list 14 | val to_rev_list : t -> (name * value) list 15 | 16 | val add : t -> name -> value -> t 17 | val add_unless_exists : t -> name -> value -> t 18 | val add_list : t -> (name * value) list -> t 19 | val add_multi : t -> (name * value list) list -> t 20 | 21 | val remove : t -> name -> t 22 | val replace : t -> name -> value -> t 23 | 24 | val mem : t -> name -> bool 25 | val get : t -> name -> value option 26 | val get_exn : t -> name -> value 27 | val get_multi : t -> name -> value list 28 | 29 | val iter : f:(name -> value -> unit) -> t -> unit 30 | val fold : f:(name -> value -> 'a -> 'a) -> init:'a -> t -> 'a 31 | 32 | val to_string : t -> string 33 | val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] 34 | -------------------------------------------------------------------------------- /examples/async/async_get.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Async 3 | 4 | open Httpaf 5 | open Httpaf_async 6 | 7 | let main port host () = 8 | let where_to_connect = Tcp.Where_to_connect.of_host_and_port { host; port } in 9 | Tcp.connect_sock where_to_connect 10 | >>= fun socket -> 11 | let finished = Ivar.create () in 12 | let response_handler = Httpaf_examples.Client.print ~on_eof:(Ivar.fill finished) in 13 | let headers = Headers.of_list [ "host", host ] in 14 | let request_body = 15 | Client.request 16 | ~error_handler:Httpaf_examples.Client.error_handler 17 | ~response_handler 18 | socket 19 | (Request.create ~headers `GET "/") 20 | in 21 | Body.Writer.close request_body; 22 | Ivar.read finished 23 | ;; 24 | 25 | let () = 26 | Command.async 27 | ~summary:"Start a hello world Async client" 28 | Command.Param.( 29 | map (both 30 | (flag "-p" (optional_with_default 80 int) 31 | ~doc:"int destination port") 32 | (anon ("host" %: string))) 33 | ~f:(fun (port, host) -> 34 | (fun () -> main port host ()))) 35 | |> Command.run 36 | -------------------------------------------------------------------------------- /httpaf.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Spiros Eliopoulos " 3 | authors: [ "Spiros Eliopoulos " ] 4 | license: "BSD-3-clause" 5 | homepage: "https://github.com/inhabitedtype/httpaf" 6 | bug-reports: "https://github.com/inhabitedtype/httpaf/issues" 7 | dev-repo: "git+https://github.com/inhabitedtype/httpaf.git" 8 | build: [ 9 | ["dune" "subst"] {pinned} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.03.0"} 15 | "dune" {>= "1.5.0"} 16 | "alcotest" {with-test} 17 | "bigstringaf" {>= "0.4.0"} 18 | "angstrom" {>= "0.14.0"} 19 | "faraday" {>= "0.6.1"} 20 | ] 21 | synopsis: 22 | "A high-performance, memory-efficient, and scalable web server for OCaml" 23 | description: """ 24 | http/af implements the HTTP 1.1 specification with respect to parsing, 25 | serialization, and connection pipelining as a state machine that is agnostic to 26 | the underlying IO mechanism, and is therefore portable across many platform. 27 | It uses the Angstrom and Faraday libraries to implement the parsing and 28 | serialization layers of the HTTP standard, hence the name.""" 29 | -------------------------------------------------------------------------------- /benchmarks/wrk_async_benchmark.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | open Httpaf_async 4 | 5 | let main port max_accepts_per_batch () = 6 | let where_to_listen = Tcp.Where_to_listen.of_port port in 7 | let request_handler _ = Httpaf_examples.Server.benchmark in 8 | let error_handler _ = Httpaf_examples.Server.error_handler in 9 | Tcp.(Server.create_sock ~on_handler_error:`Ignore 10 | ~backlog:11_000 ~max_connections:10_000 ~max_accepts_per_batch where_to_listen) 11 | (Server.create_connection_handler ~request_handler ~error_handler) 12 | >>= fun server -> 13 | Deferred.forever () (fun () -> 14 | Clock.after Time.Span.(of_sec 0.5) >>| fun () -> 15 | Log.Global.printf "conns: %d" (Tcp.Server.num_connections server)); 16 | Deferred.never () 17 | 18 | let () = 19 | Command.async 20 | ~summary:"Start a hello world Async server" 21 | Command.Param.( 22 | map (both 23 | (flag "-p" (optional_with_default 8080 int) 24 | ~doc:"int Source port to listen on") 25 | (flag "-a" (optional_with_default 1 int) 26 | ~doc:"int Maximum accepts per batch")) 27 | ~f:(fun (port, accepts) -> 28 | (fun () -> main port accepts ()))) 29 | |> Command.run 30 | -------------------------------------------------------------------------------- /examples/lwt/lwt_get.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Lwt.Infix 3 | module Arg = Caml.Arg 4 | 5 | open Httpaf 6 | open Httpaf_lwt_unix 7 | 8 | let main port host = 9 | Lwt_unix.getaddrinfo host (Int.to_string port) [Unix.(AI_FAMILY PF_INET)] 10 | >>= fun addresses -> 11 | let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 12 | Lwt_unix.connect socket (List.hd_exn addresses).Unix.ai_addr 13 | >>= fun () -> 14 | let finished, notify_finished = Lwt.wait () in 15 | let response_handler = 16 | Httpaf_examples.Client.print ~on_eof:(Lwt.wakeup_later notify_finished) 17 | in 18 | let headers = Headers.of_list [ "host", host ] in 19 | let request_body = 20 | Client.request 21 | ~error_handler:Httpaf_examples.Client.error_handler 22 | ~response_handler 23 | socket 24 | (Request.create ~headers `GET "/") 25 | in 26 | Body.Writer.close request_body; 27 | finished 28 | ;; 29 | 30 | let () = 31 | let host = ref None in 32 | let port = ref 80 in 33 | Arg.parse 34 | ["-p", Set_int port, " Port number (80 by default)"] 35 | (fun host_argument -> host := Some host_argument) 36 | "lwt_get.exe [-p N] HOST"; 37 | let host = 38 | match !host with 39 | | None -> failwith "No hostname provided" 40 | | Some host -> host 41 | in 42 | Lwt_main.run (main !port host) 43 | ;; 44 | -------------------------------------------------------------------------------- /examples/lwt/lwt_echo_post.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Lwt.Infix 3 | module Arg = Caml.Arg 4 | 5 | open Httpaf_lwt_unix 6 | 7 | let request_handler (_ : Unix.sockaddr) = Httpaf_examples.Server.echo_post 8 | let error_handler (_ : Unix.sockaddr) = Httpaf_examples.Server.error_handler 9 | 10 | let main port = 11 | let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in 12 | Lwt.async (fun () -> 13 | Lwt_io.establish_server_with_client_socket 14 | listen_address 15 | (Server.create_connection_handler ~request_handler ~error_handler) 16 | >|= fun _server -> 17 | Stdio.printf "Listening on port %i and echoing POST requests.\n" port; 18 | Stdio.printf "To send a POST request, try one of the following\n\n"; 19 | Stdio.printf " echo \"Testing echo POST\" | dune exec examples/async/async_post.exe\n"; 20 | Stdio.printf " echo \"Testing echo POST\" | dune exec examples/lwt/lwt_post.exe\n"; 21 | Stdio.printf " echo \"Testing echo POST\" | curl -XPOST --data @- http://localhost:%d\n\n%!" port); 22 | let forever, _ = Lwt.wait () in 23 | Lwt_main.run forever 24 | ;; 25 | 26 | let () = 27 | let port = ref 8080 in 28 | Arg.parse 29 | ["-p", Arg.Set_int port, " Listening port number (8080 by default)"] 30 | ignore 31 | "Echoes POST requests. Runs forever."; 32 | main !port 33 | ;; 34 | -------------------------------------------------------------------------------- /examples/async/async_echo_post.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | 4 | open Httpaf_async 5 | 6 | let request_handler (_ : Socket.Address.Inet.t) = Httpaf_examples.Server.echo_post 7 | let error_handler (_ : Socket.Address.Inet.t) = Httpaf_examples.Server.error_handler 8 | 9 | let main port max_accepts_per_batch () = 10 | let where_to_listen = Tcp.Where_to_listen.of_port port in 11 | Tcp.(Server.create_sock ~on_handler_error:`Raise 12 | ~backlog:10_000 ~max_connections:10_000 ~max_accepts_per_batch where_to_listen) 13 | (Server.create_connection_handler ~request_handler ~error_handler) 14 | >>= fun _server -> 15 | Stdio.printf "Listening on port %i and echoing POST requests.\n" port; 16 | Stdio.printf "To send a POST request, try one of the following\n\n"; 17 | Stdio.printf " echo \"Testing echo POST\" | dune exec examples/async/async_post.exe\n"; 18 | Stdio.printf " echo \"Testing echo POST\" | dune exec examples/lwt/lwt_post.exe\n"; 19 | Stdio.printf " echo \"Testing echo POST\" | curl -XPOST --data @- http://localhost:%d\n\n%!" port; 20 | Deferred.never () 21 | ;; 22 | 23 | let () = 24 | Command.async 25 | ~summary:"Echo POST requests" 26 | Command.Param.( 27 | map (both 28 | (flag "-p" (optional_with_default 8080 int) 29 | ~doc:"int Source port to listen on") 30 | (flag "-a" (optional_with_default 1 int) 31 | ~doc:"int Maximum accepts per batch")) 32 | ~f:(fun (port, accepts) -> 33 | (fun () -> main port accepts ()))) 34 | |> Command.run 35 | ;; 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Inhabited Type LLC 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /examples/lwt/lwt_post.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Lwt.Infix 3 | module Arg = Caml.Arg 4 | 5 | open Httpaf 6 | open Httpaf_lwt_unix 7 | 8 | let main port host = 9 | Lwt_io.(read stdin) 10 | >>= fun body -> 11 | Lwt_unix.getaddrinfo host (Int.to_string port) [Unix.(AI_FAMILY PF_INET)] 12 | >>= fun addresses -> 13 | let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 14 | Lwt_unix.connect socket (List.hd_exn addresses).Unix.ai_addr 15 | >>= fun () -> 16 | let finished, notify_finished = Lwt.wait () in 17 | let response_handler = 18 | Httpaf_examples.Client.print ~on_eof:(Lwt.wakeup_later notify_finished) 19 | in 20 | let headers = 21 | Headers.of_list 22 | [ "content-length" , (Int.to_string (String.length body)) 23 | ; "connection" , "close" 24 | ; "host" , host 25 | ] 26 | in 27 | let request_body = 28 | Client.request 29 | ~error_handler:Httpaf_examples.Client.error_handler 30 | ~response_handler 31 | socket 32 | (Request.create ~headers `POST "/") 33 | in 34 | Body.Writer.write_string request_body body; 35 | Body.Writer.close request_body; 36 | finished 37 | ;; 38 | 39 | let () = 40 | let host = ref None in 41 | let port = ref 8080 in 42 | 43 | Arg.parse 44 | ["-p", Set_int port, " Port number (8080 by default)"] 45 | (fun host_argument -> host := Some host_argument) 46 | "lwt_get.exe [-p N] HOST"; 47 | let host = 48 | match !host with 49 | | None -> failwith "No hostname provided" 50 | | Some host -> host 51 | in 52 | Lwt_main.run (main !port host) 53 | ;; 54 | -------------------------------------------------------------------------------- /lib_test/test_iovec.ml: -------------------------------------------------------------------------------- 1 | open Httpaf 2 | open IOVec 3 | 4 | (* The length of the buffer is ignored by iovec operations *) 5 | let buffer = Bigstringaf.empty 6 | 7 | let test_lengthv () = 8 | Alcotest.(check int) "lengthv [] = 0" (lengthv []) 0; 9 | Alcotest.(check int) "lengthv [iovec] = length iovec" 10 | (lengthv [{ buffer; off = 0; len = 0 }]) (length {buffer; off = 0; len = 0 }); 11 | Alcotest.(check int) "lengthv [iovec] = length iovec" 12 | (lengthv [{ buffer; off = 0; len = 10 }]) (length {buffer; off = 0; len = 10 }); 13 | ;; 14 | 15 | let test_shiftv_raises () = 16 | Alcotest.check_raises 17 | "IOVec.shiftv: -1 is a negative number" 18 | (Failure "IOVec.shiftv: -1 is a negative number") 19 | (fun () -> ignore (shiftv [] (-1))); 20 | let test f = 21 | Alcotest.check_raises 22 | "shiftv iovecs n raises when n > lengthv iovecs" 23 | (Failure "shiftv: n > lengthv iovecs") 24 | (fun () -> ignore (f ())) 25 | in 26 | test (fun () -> shiftv [] 1); 27 | test (fun () -> shiftv [{ buffer; off = 0; len = 1 }] 2); 28 | test (fun () -> shiftv [{ buffer; off = 0; len = 1 }; { buffer; off = 0; len = 1 }] 3); 29 | ;; 30 | 31 | let test_shiftv () = 32 | Alcotest.(check (of_pp pp_hum |> list)) "shiftv [] 0 = []" (shiftv [] 0) []; 33 | Alcotest.(check (of_pp pp_hum |> list)) "shiftv [{... len ... }] len = []" 34 | (shiftv [{ buffer; off = 0; len = 1 }] 1) []; 35 | Alcotest.(check (of_pp pp_hum |> list)) "shiftv [iovec] n when length iovec < n" 36 | (shiftv [{ buffer; off = 0; len = 4 }] 2) [{ buffer; off = 2; len = 2 }]; 37 | ;; 38 | 39 | let tests = 40 | [ "lengthv" , `Quick, test_lengthv 41 | ; "shiftv" , `Quick, test_shiftv 42 | ; "shiftv raises ", `Quick, test_shiftv_raises 43 | ] 44 | -------------------------------------------------------------------------------- /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | on: 4 | - push 5 | - pull_request 6 | 7 | jobs: 8 | builds: 9 | name: Earliest Supported Version 10 | strategy: 11 | fail-fast: false 12 | matrix: 13 | os: 14 | - ubuntu-latest 15 | ocaml-version: 16 | - 4.04.0 17 | 18 | runs-on: ${{ matrix.os }} 19 | 20 | steps: 21 | - name: Checkout code 22 | uses: actions/checkout@v2 23 | 24 | - name: Use OCaml ${{ matrix.ocaml-version }} 25 | uses: avsm/setup-ocaml@v1 26 | with: 27 | ocaml-version: ${{ matrix.ocaml-version }} 28 | 29 | - name: Deps 30 | run: | 31 | opam pin add -n httpaf . 32 | opam install --deps-only httpaf 33 | 34 | - name: Build 35 | run: opam exec -- dune build -p httpaf 36 | 37 | tests: 38 | name: Tests 39 | strategy: 40 | fail-fast: false 41 | matrix: 42 | os: 43 | - ubuntu-latest 44 | ocaml-version: 45 | - 4.08.1 46 | - 4.10.2 47 | - 4.11.2 48 | - 4.12.0 49 | 50 | runs-on: ${{ matrix.os }} 51 | 52 | steps: 53 | - name: Checkout code 54 | uses: actions/checkout@v2 55 | 56 | - name: Use OCaml ${{ matrix.ocaml-version }} 57 | uses: avsm/setup-ocaml@v1 58 | with: 59 | ocaml-version: ${{ matrix.ocaml-version }} 60 | 61 | - name: Deps 62 | run: | 63 | opam pin add -n httpaf . 64 | opam pin add -n httpaf-async . 65 | opam pin add -n httpaf-lwt-unix . 66 | opam install -t --deps-only . 67 | 68 | - name: Build 69 | run: opam exec -- dune build 70 | 71 | - name: Test 72 | run: opam exec -- dune runtest 73 | 74 | - name: Examples 75 | run: | 76 | opam exec -- make examples 77 | -------------------------------------------------------------------------------- /examples/async/async_post.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | 4 | open Httpaf 5 | open Httpaf_async 6 | 7 | let main port host () = 8 | let where_to_connect = Tcp.Where_to_connect.of_host_and_port { host; port } in 9 | Tcp.connect_sock where_to_connect 10 | >>= fun socket -> 11 | let finished = Ivar.create () in 12 | let response_handler = Httpaf_examples.Client.print ~on_eof:(Ivar.fill finished) in 13 | let headers = 14 | Headers.of_list 15 | [ "transfer-encoding", "chunked" 16 | ; "connection" , "close" 17 | ; "host" , host 18 | ] 19 | in 20 | let request_body = 21 | Client.request 22 | ~error_handler:Httpaf_examples.Client.error_handler 23 | ~response_handler 24 | socket 25 | (Request.create ~headers `POST "/") 26 | in 27 | let stdin = Lazy.force Reader.stdin in 28 | don't_wait_for ( 29 | Reader.read_one_chunk_at_a_time stdin ~handle_chunk:(fun bs ~pos:off ~len -> 30 | Body.Writer.write_bigstring request_body bs ~off ~len; 31 | Body.Writer.flush request_body (fun () -> ()); 32 | return (`Consumed(len, `Need_unknown))) 33 | >>| function 34 | | `Eof_with_unconsumed_data s -> Body.Writer.write_string request_body s; 35 | Body.Writer.close request_body 36 | | `Eof -> Body.Writer.close request_body 37 | | `Stopped () -> assert false); 38 | Ivar.read finished 39 | ;; 40 | 41 | let () = 42 | Command.async 43 | ~summary:"Start a hello world Async client" 44 | Command.Param.( 45 | map (both 46 | (flag "-p" (optional_with_default 80 int) 47 | ~doc:"int destination port") 48 | (anon ("host" %: string))) 49 | ~f:(fun (port, host) -> 50 | (fun () -> main port host ()))) 51 | |> Command.run 52 | -------------------------------------------------------------------------------- /lib_test/test_method.ml: -------------------------------------------------------------------------------- 1 | open Httpaf 2 | open Method 3 | 4 | let test_is_safe () = 5 | Alcotest.(check bool) "GET is safe" (is_safe `GET ) true; 6 | Alcotest.(check bool) "HEAD is safe" (is_safe `HEAD) true; 7 | Alcotest.(check bool) "POST is safe" (is_safe `POST) false; 8 | Alcotest.(check bool) "PUT is safe" (is_safe `PUT ) false; 9 | Alcotest.(check bool) "DELETE is safe" (is_safe `DELETE ) false; 10 | Alcotest.(check bool) "CONNECT is safe" (is_safe `CONNECT) false; 11 | Alcotest.(check bool) "OPTIONS is safe" (is_safe `OPTIONS) true; 12 | Alcotest.(check bool) "TRACE is safe" (is_safe `TRACE ) true; 13 | ;; 14 | 15 | let test_is_cacheable () = 16 | Alcotest.(check bool) "GET is cacheable" (is_cacheable `GET ) true; 17 | Alcotest.(check bool) "HEAD is cacheable" (is_cacheable `HEAD) true; 18 | Alcotest.(check bool) "POST is cacheable" (is_cacheable `POST) true; 19 | Alcotest.(check bool) "PUT is cacheable" (is_cacheable `PUT ) false; 20 | Alcotest.(check bool) "DELETE is cacheable" (is_cacheable `DELETE ) false; 21 | Alcotest.(check bool) "CONNECT is cacheable" (is_cacheable `CONNECT) false; 22 | Alcotest.(check bool) "OPTIONS is cacheable" (is_cacheable `OPTIONS) false; 23 | Alcotest.(check bool) "TRACE is cacheable" (is_cacheable `TRACE ) false; 24 | ;; 25 | 26 | let test_is_idempotent () = 27 | Alcotest.(check bool) "GET is idempotent" (is_idempotent `GET ) true; 28 | Alcotest.(check bool) "HEAD is idempotent" (is_idempotent `HEAD) true; 29 | Alcotest.(check bool) "POST is idempotent" (is_idempotent `POST) false; 30 | Alcotest.(check bool) "PUT is idempotent" (is_idempotent `PUT ) true; 31 | Alcotest.(check bool) "DELETE is idempotent" (is_idempotent `DELETE ) true; 32 | Alcotest.(check bool) "CONNECT is idempotent" (is_idempotent `CONNECT) false; 33 | Alcotest.(check bool) "OPTIONS is idempotent" (is_idempotent `OPTIONS) true; 34 | Alcotest.(check bool) "TRACE is idempotent" (is_idempotent `TRACE ) true; 35 | ;; 36 | 37 | let tests = 38 | [ "is_safe" , `Quick, test_is_safe 39 | ; "is_cacheable" , `Quick, test_is_cacheable 40 | ; "is_idempotent", `Quick, test_is_idempotent 41 | ] 42 | -------------------------------------------------------------------------------- /lib_test/test_headers.ml: -------------------------------------------------------------------------------- 1 | open Httpaf 2 | module Array = ArrayLabels 3 | module List = ListLabels 4 | 5 | let check msg ~expect actual = 6 | Alcotest.(check (list (pair string string))) msg expect (Headers.to_list actual) 7 | ;; 8 | 9 | let test_replace () = 10 | check "replace trailing element" 11 | ~expect:["c", "d"; "a", "d"] 12 | (Headers.replace 13 | (Headers.of_list ["c", "d"; "a", "b"]) 14 | "a" 15 | "d"); 16 | 17 | check "replace middle element" 18 | ~expect:["e", "f"; "c", "z"; "a", "b"] 19 | (Headers.replace 20 | (Headers.of_list ["e", "f"; "c", "d"; "a", "b"]) 21 | "c" 22 | "z"); 23 | 24 | check "remove multiple trailing elements" 25 | ~expect:["c", "d"; "a", "d"] 26 | (Headers.replace 27 | (Headers.of_list [ "c", "d"; "a", "b"; "a", "c"]) 28 | "a" 29 | "d"); 30 | ;; 31 | 32 | let test_remove () = 33 | check "remove leading element" 34 | ~expect:["c", "d"] 35 | (Headers.remove 36 | (Headers.of_list ["a", "b"; "c", "d"]) 37 | "a"); 38 | check "remove trailing element" 39 | ~expect:["c", "d"] 40 | (Headers.remove 41 | (Headers.of_list ["c", "d"; "a", "b"]) 42 | "a"); 43 | ;; 44 | 45 | let test_ci_equal () = 46 | let string_of_char x = String.init 1 (fun _ -> x) in 47 | let ascii = 48 | Array.init (0xff + 1) ~f:Char.chr 49 | |> Array.to_list 50 | in 51 | let ascii_pairs = 52 | List.map ascii ~f:(fun x -> 53 | List.map ascii ~f:(fun y -> x, y)) 54 | |> List.concat 55 | in 56 | (* Ensure that the branch free case-insensitive equality check is consistent 57 | * with a naive implementation. *) 58 | List.iter ascii_pairs ~f:(fun (x, y) -> 59 | let char_ci_equal = 60 | Char.compare (Char.lowercase_ascii x) (Char.lowercase_ascii y) = 0 61 | in 62 | let headers_equal = 63 | let headers = Headers.of_list [ string_of_char y, "value" ] in 64 | Headers.mem headers (string_of_char x) 65 | in 66 | Alcotest.(check bool) 67 | (Printf.sprintf "CI: %C = %C" x y) 68 | char_ci_equal 69 | headers_equal) 70 | ;; 71 | 72 | 73 | 74 | let tests = 75 | [ "remove" , `Quick, test_remove 76 | ; "replace" , `Quick, test_replace 77 | ; "CI equal", `Quick, test_ci_equal 78 | ] 79 | -------------------------------------------------------------------------------- /lib_test/helpers.ml: -------------------------------------------------------------------------------- 1 | open Httpaf 2 | 3 | let maybe_serialize_body f body = 4 | match body with 5 | | None -> () 6 | | Some body -> Faraday.write_string f body 7 | 8 | let request_to_string ?body r = 9 | let f = Faraday.create 0x1000 in 10 | Httpaf_private.Serialize.write_request f r; 11 | maybe_serialize_body f body; 12 | Faraday.serialize_to_string f 13 | 14 | let response_to_string ?body r = 15 | let f = Faraday.create 0x1000 in 16 | Httpaf_private.Serialize.write_response f r; 17 | maybe_serialize_body f body; 18 | Faraday.serialize_to_string f 19 | 20 | module Read_operation = struct 21 | type t = [ `Read | `Yield | `Close ] 22 | 23 | let pp_hum fmt (t : t) = 24 | let str = 25 | match t with 26 | | `Read -> "Read" 27 | | `Yield -> "Yield" 28 | | `Close -> "Close" 29 | in 30 | Format.pp_print_string fmt str 31 | ;; 32 | end 33 | 34 | module Write_operation = struct 35 | type t = [ `Write of Bigstringaf.t IOVec.t list | `Yield | `Close of int ] 36 | 37 | let iovecs_to_string iovecs = 38 | let len = IOVec.lengthv iovecs in 39 | let bytes = Bytes.create len in 40 | let dst_off = ref 0 in 41 | List.iter (fun { IOVec.buffer; off = src_off; len } -> 42 | Bigstringaf.unsafe_blit_to_bytes buffer ~src_off bytes ~dst_off:!dst_off ~len; 43 | dst_off := !dst_off + len) 44 | iovecs; 45 | Bytes.unsafe_to_string bytes 46 | ;; 47 | 48 | let pp_hum fmt (t : t) = 49 | match t with 50 | | `Write iovecs -> Format.fprintf fmt "Write %S" (iovecs_to_string iovecs) 51 | | `Yield -> Format.pp_print_string fmt "Yield" 52 | | `Close len -> Format.fprintf fmt "Close %i" len 53 | ;; 54 | 55 | let to_write_as_string t = 56 | match t with 57 | | `Write iovecs -> Some (iovecs_to_string iovecs) 58 | | `Close _ | `Yield -> None 59 | ;; 60 | end 61 | 62 | let write_operation = Alcotest.of_pp Write_operation.pp_hum 63 | let read_operation = Alcotest.of_pp Read_operation.pp_hum 64 | 65 | module Headers = struct 66 | include Headers 67 | 68 | let (@) a b = Headers.add_list a (Headers.to_list b) 69 | 70 | let connection_close = Headers.of_list ["connection", "close"] 71 | let encoding_chunked = Headers.of_list ["transfer-encoding", "chunked"] 72 | let encoding_fixed n = Headers.of_list ["content-length", string_of_int n] 73 | end 74 | -------------------------------------------------------------------------------- /lwt-unix/httpaf_lwt_unix.mli: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2018 Inhabited Type LLC. 3 | Copyright (c) 2018 Anton Bachin 4 | 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | 2. Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | 3. Neither the name of the author nor the names of his contributors 19 | may be used to endorse or promote products derived from this software 20 | without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 23 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 24 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 25 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 26 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 27 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 28 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 29 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 30 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | ----------------------------------------------------------------------------*) 34 | 35 | open Httpaf 36 | 37 | 38 | (* The function that results from [create_connection_handler] should be passed 39 | to [Lwt_io.establish_server_with_client_socket]. For an example, see 40 | [examples/lwt_echo_server.ml]. *) 41 | module Server : sig 42 | val create_connection_handler 43 | : ?config : Config.t 44 | -> request_handler : (Unix.sockaddr -> Server_connection.request_handler) 45 | -> error_handler : (Unix.sockaddr -> Server_connection.error_handler) 46 | -> Unix.sockaddr 47 | -> Lwt_unix.file_descr 48 | -> unit Lwt.t 49 | end 50 | 51 | (* For an example, see [examples/lwt_get.ml]. *) 52 | module Client : sig 53 | val request 54 | : ?config : Httpaf.Config.t 55 | -> Lwt_unix.file_descr 56 | -> Request.t 57 | -> error_handler : Client_connection.error_handler 58 | -> response_handler : Client_connection.response_handler 59 | -> Httpaf.Body.Writer.t 60 | end 61 | -------------------------------------------------------------------------------- /lib/iOVec.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | 35 | type 'a t = 'a Faraday.iovec = 36 | { buffer : 'a 37 | ; off : int 38 | ; len : int } 39 | 40 | let length { len; _ } = len 41 | let lengthv iovs = List.fold_left (fun acc { len; _ } -> acc + len) 0 iovs 42 | 43 | let shift { buffer; off; len } n = 44 | assert (n <= len); 45 | { buffer; off = off + n; len = len - n } 46 | 47 | let shiftv iovecs n = 48 | if n < 0 then failwith (Printf.sprintf "IOVec.shiftv: %d is a negative number" n); 49 | let rec loop iovecs n = 50 | if n = 0 51 | then iovecs 52 | else match iovecs with 53 | | [] -> failwith "shiftv: n > lengthv iovecs" 54 | | iovec::iovecs -> 55 | let iovec_len = length iovec in 56 | if iovec_len <= n 57 | then loop iovecs (n - iovec_len) 58 | else (shift iovec n)::iovecs 59 | in 60 | loop iovecs n 61 | 62 | let add_len { buffer; off; len } n = 63 | { buffer; off; len = len + n } 64 | 65 | let pp_hum fmt t = 66 | Format.fprintf fmt "{ buffer = ; off = %d; len = %d }" t.off t.len 67 | -------------------------------------------------------------------------------- /lib/version.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | 35 | type t = 36 | { major : int 37 | ; minor : int } 38 | 39 | let v1_0 = { major = 1; minor = 0 } 40 | let v1_1 = { major = 1; minor = 1 } 41 | 42 | let to_buffer b t = 43 | Buffer.add_string b "HTTP/"; 44 | Buffer.add_string b (string_of_int t.major); 45 | Buffer.add_char b '.'; 46 | Buffer.add_string b (string_of_int t.minor) 47 | 48 | let compare x y = 49 | let c = compare x.major y.major in 50 | if c <> 0 then c else compare x.minor y.minor 51 | 52 | let to_string t = 53 | match t with 54 | | { major = 1; minor = 0 } -> "HTTP/1.0" 55 | | { major = 1; minor = 1 } -> "HTTP/1.1" 56 | | _ -> 57 | let b = Buffer.create 8 in 58 | to_buffer b t; 59 | Buffer.contents b 60 | 61 | let of_string = function 62 | | "HTTP/1.1" -> { major = 1; minor = 1 } 63 | | "HTTP/1.0" -> { major = 1; minor = 0 } 64 | | s -> 65 | try Scanf.sscanf s "HTTP/%d.%d" (fun major minor -> { major; minor }) 66 | with _ -> raise (Failure "Version.of_string") 67 | 68 | let pp_hum fmt t = 69 | Format.fprintf fmt "HTTP/%d.%d" t.major t.minor 70 | -------------------------------------------------------------------------------- /lib/method.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | 35 | type standard = [ 36 | | `GET 37 | | `HEAD 38 | | `POST 39 | | `PUT 40 | | `DELETE 41 | | `CONNECT 42 | | `OPTIONS 43 | | `TRACE 44 | ] 45 | 46 | type t = [ 47 | | standard 48 | | `Other of string 49 | ] 50 | 51 | let is_safe = function 52 | | `GET | `HEAD | `OPTIONS | `TRACE -> true 53 | | _ -> false 54 | 55 | let is_cacheable = function 56 | | `GET | `HEAD | `POST -> true 57 | | _ -> false 58 | 59 | let is_idempotent = function 60 | | `PUT | `DELETE -> true 61 | | t -> is_safe t 62 | 63 | let to_string = function 64 | | `GET -> "GET" 65 | | `HEAD -> "HEAD" 66 | | `POST -> "POST" 67 | | `PUT -> "PUT" 68 | | `DELETE -> "DELETE" 69 | | `CONNECT -> "CONNECT" 70 | | `OPTIONS -> "OPTIONS" 71 | | `TRACE -> "TRACE" 72 | | `Other s -> s 73 | 74 | let of_string = 75 | function 76 | | "GET" -> `GET 77 | | "HEAD" -> `HEAD 78 | | "POST" -> `POST 79 | | "PUT" -> `PUT 80 | | "DELETE" -> `DELETE 81 | | "CONNECT" -> `CONNECT 82 | | "OPTIONS" -> `OPTIONS 83 | | "TRACE" -> `TRACE 84 | | s -> `Other s 85 | 86 | let pp_hum fmt t = 87 | Format.fprintf fmt "%s" (to_string t) 88 | -------------------------------------------------------------------------------- /lib/message.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | 35 | (* This module contains functionality that applies to both requests and 36 | responses, which are collectively referred to in the HTTP 1.1 specifications 37 | as 'messages'. *) 38 | 39 | let persistent_connection ?(proxy=false) version headers = 40 | let _ = proxy in 41 | (* XXX(seliopou): use proxy argument in the case of HTTP/1.0 as per 42 | https://tools.ietf.org/html/rfc7230#section-6.3 *) 43 | match Headers.get headers "connection" with 44 | | Some "close" -> false 45 | | Some "keep-alive" -> Version.(compare version v1_0) >= 0 46 | | _ -> Version.(compare version v1_1) >= 0 47 | 48 | let sort_uniq xs = 49 | (* Though {!List.sort_uniq} performs a check on the input length and returns 50 | * immediately for lists of length less than [2], it still allocates closures 51 | * before it does that check! To avoid that just do our own checking here to 52 | * avoid the allocations in the common case. *) 53 | match xs with 54 | | [] | [ _ ] -> xs 55 | | _ -> List.sort_uniq String.compare xs 56 | 57 | let unique_content_length_values headers = 58 | (* XXX(seliopou): perform proper content-length parsing *) 59 | sort_uniq (Headers.get_multi headers "content-length") 60 | 61 | let content_length_of_string s = 62 | try Int64.of_string s with _ -> -1L 63 | -------------------------------------------------------------------------------- /lib_test/test_request.ml: -------------------------------------------------------------------------------- 1 | open Httpaf 2 | open Request 3 | open Helpers 4 | 5 | let body_length = Alcotest.of_pp Request.Body_length.pp_hum 6 | 7 | let check = 8 | let alco = 9 | Alcotest.result 10 | (Alcotest.of_pp pp_hum) 11 | Alcotest.string 12 | in 13 | fun message ~expect input -> 14 | let actual = 15 | Angstrom.parse_string ~consume:All Httpaf_private.Parse.request input 16 | in 17 | Alcotest.check alco message expect actual 18 | ;; 19 | 20 | let test_parse_valid () = 21 | check 22 | "valid GET without headers" 23 | ~expect:(Ok (Request.create `GET "/")) 24 | "GET / HTTP/1.1\r\n\r\n"; 25 | check 26 | "valid non-standard method without headers" 27 | ~expect:(Ok (Request.create (`Other "some-other-verb") "/")) 28 | "some-other-verb / HTTP/1.1\r\n\r\n"; 29 | check 30 | "valid GET with headers" 31 | ~expect:(Ok (Request.create ~headers:(Headers.of_list [ "Link", "/path/to/some/website"]) `GET "/")) 32 | "GET / HTTP/1.1\r\nLink: /path/to/some/website\r\n\r\n"; 33 | ;; 34 | 35 | let test_parse_invalid_errors () = 36 | check 37 | "doesn't end" 38 | ~expect:(Error ": not enough input") 39 | "GET / HTTP/1.1\r\n"; 40 | check 41 | "invalid version" 42 | ~expect:(Error "eol: string") 43 | "GET / HTTP/1.22\r\n\r\n"; 44 | check 45 | "malformed header" 46 | ~expect:(Error "header: char ':'") 47 | "GET / HTTP/1.1\r\nLink : /path/to/some/website\r\n\r\n"; 48 | ;; 49 | 50 | let test_body_length () = 51 | let check message request ~expect = 52 | let actual = Request.body_length request in 53 | Alcotest.check body_length message expect actual 54 | in 55 | let req method_ headers = Request.create method_ ~headers "/" in 56 | check 57 | "no headers" 58 | ~expect:(`Fixed 0L) 59 | (req `GET Headers.empty); 60 | check 61 | "single fixed" 62 | ~expect:(`Fixed 10L) 63 | (req `GET Headers.(encoding_fixed 10)); 64 | check 65 | "negative fixed" 66 | ~expect:(`Error `Bad_request) 67 | (req `GET Headers.(encoding_fixed (-10))); 68 | check 69 | "multiple fixed" 70 | ~expect:(`Error `Bad_request) 71 | (req `GET Headers.(encoding_fixed 10 @ encoding_fixed 20)); 72 | check 73 | "chunked" 74 | ~expect:`Chunked 75 | (req `GET Headers.encoding_chunked); 76 | check 77 | "chunked multiple times" 78 | ~expect:`Chunked 79 | (req `GET Headers.(encoding_chunked @ encoding_chunked)); 80 | let encoding_gzip = Headers.of_list ["transfer-encoding", "gzip"] in 81 | check 82 | "non-chunked transfer-encoding" 83 | ~expect:(`Error `Bad_request) 84 | (req `GET encoding_gzip); 85 | check 86 | "chunked after non-chunked" 87 | ~expect:`Chunked 88 | (req `GET Headers.(encoding_gzip @ encoding_chunked)); 89 | check 90 | "chunked before non-chunked" 91 | ~expect:(`Error `Bad_request) 92 | (req `GET Headers.(encoding_chunked @ encoding_gzip)); 93 | check 94 | "chunked case-insensitive" 95 | ~expect:`Chunked 96 | (req `GET Headers.(of_list ["transfer-encoding", "CHUNKED"])); 97 | ;; 98 | 99 | 100 | let tests = 101 | [ "parse valid" , `Quick, test_parse_valid 102 | ; "parse invalid errors", `Quick, test_parse_invalid_errors 103 | ; "body length", `Quick, test_body_length 104 | ] 105 | -------------------------------------------------------------------------------- /lib/request.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | type t = 35 | { meth : Method.t 36 | ; target : string 37 | ; version : Version.t 38 | ; headers : Headers.t } 39 | 40 | let create ?(version=Version.v1_1) ?(headers=Headers.empty) meth target = 41 | { meth; target; version; headers } 42 | 43 | let bad_request = `Error `Bad_request 44 | 45 | module Body_length = struct 46 | type t = [ 47 | | `Fixed of Int64.t 48 | | `Chunked 49 | | `Error of [`Bad_request] 50 | ] 51 | 52 | let pp_hum fmt (len : t) = 53 | match len with 54 | | `Fixed n -> Format.fprintf fmt "Fixed %Li" n 55 | | `Chunked -> Format.pp_print_string fmt "Chunked" 56 | | `Error `Bad_request -> Format.pp_print_string fmt "Error: Bad request" 57 | ;; 58 | end 59 | 60 | let body_length { headers; _ } : Body_length.t = 61 | (* The last entry in transfer-encoding is the correct entry. We only accept 62 | chunked transfer-encodings. *) 63 | match List.rev (Headers.get_multi headers "transfer-encoding") with 64 | | value::_ when Headers.ci_equal value "chunked" -> `Chunked 65 | | _ ::_ -> bad_request 66 | | [] -> 67 | begin match Message.unique_content_length_values headers with 68 | | [] -> `Fixed 0L 69 | | [ len ] -> 70 | let len = Message.content_length_of_string len in 71 | if len >= 0L 72 | then `Fixed len 73 | else bad_request 74 | | _ -> bad_request 75 | end 76 | 77 | let persistent_connection ?proxy { version; headers; _ } = 78 | Message.persistent_connection ?proxy version headers 79 | 80 | let pp_hum fmt { meth; target; version; headers } = 81 | Format.fprintf fmt "((method \"%a\") (target %S) (version \"%a\") (headers %a))" 82 | Method.pp_hum meth target Version.pp_hum version Headers.pp_hum headers 83 | -------------------------------------------------------------------------------- /lib_test/test_response.ml: -------------------------------------------------------------------------------- 1 | open Httpaf 2 | open Response 3 | open Helpers 4 | 5 | let body_length = Alcotest.of_pp Response.Body_length.pp_hum 6 | 7 | let check = 8 | let alco = 9 | Alcotest.result 10 | (Alcotest.of_pp pp_hum) 11 | Alcotest.string 12 | in 13 | fun message ~expect input -> 14 | let actual = 15 | Angstrom.parse_string ~consume:All Httpaf_private.Parse.response input 16 | in 17 | Alcotest.check alco message expect actual 18 | ;; 19 | 20 | let test_parse_valid () = 21 | check 22 | "OK response without headers" 23 | ~expect:(Ok (Response.create `OK)) 24 | "HTTP/1.1 200 OK\r\n\r\n"; 25 | ;; 26 | 27 | let test_parse_invalid_error () = 28 | check 29 | "OK response without a status message" 30 | ~expect:(Error ": char ' '") 31 | "HTTP/1.1 200\r\n\r\n"; 32 | check 33 | "OK response without a status message" 34 | ~expect:(Error ": status-code empty") 35 | "HTTP/1.1 OK\r\n\r\n"; 36 | check 37 | "OK response without a status message" 38 | ~expect:(Error ": status-code too long: \"999999937377999999999200\"") 39 | "HTTP/1.1 999999937377999999999200\r\n\r\n"; 40 | ;; 41 | 42 | let test_body_length () = 43 | let check message request_method response ~expect = 44 | let actual = Response.body_length response ~request_method in 45 | Alcotest.check body_length message expect actual 46 | in 47 | let res status headers = Response.create status ~headers in 48 | check 49 | "requested HEAD" 50 | ~expect:(`Fixed 0L) 51 | `HEAD (res `OK Headers.empty); 52 | check 53 | "requested CONNECT" 54 | ~expect:(`Close_delimited) 55 | `CONNECT (res `OK Headers.empty); 56 | check 57 | "status: informational" 58 | ~expect:(`Fixed 0L) 59 | `GET (res `Continue Headers.empty); 60 | check 61 | "status: no content" 62 | ~expect:(`Fixed 0L) 63 | `GET (res `No_content Headers.empty); 64 | check 65 | "status: not modified" 66 | ~expect:(`Fixed 0L) 67 | `GET (res `Not_modified Headers.empty); 68 | check 69 | "no header" 70 | ~expect:(`Close_delimited) 71 | `GET (res `OK Headers.empty); 72 | check 73 | "single fixed" 74 | ~expect:(`Fixed 10L) 75 | `GET (res `OK Headers.(encoding_fixed 10)); 76 | check 77 | "negative fixed" 78 | ~expect:(`Error `Internal_server_error) 79 | `GET (res `OK Headers.(encoding_fixed (-10))); 80 | check 81 | "multiple fixed" 82 | ~expect:(`Error `Internal_server_error) 83 | `GET (res `OK Headers.(encoding_fixed 10 @ encoding_fixed 20)); 84 | check 85 | "chunked" 86 | ~expect:`Chunked 87 | `GET (res `OK Headers.encoding_chunked); 88 | check 89 | "chunked multiple times" 90 | ~expect:`Chunked 91 | `GET (res `OK Headers.(encoding_chunked @ encoding_chunked)); 92 | let encoding_gzip = Headers.of_list ["transfer-encoding", "gzip"] in 93 | check 94 | "non-chunked transfer-encoding" 95 | ~expect:`Close_delimited 96 | `GET (res `OK encoding_gzip); 97 | check 98 | "chunked after non-chunked" 99 | ~expect:`Chunked 100 | `GET (res `OK Headers.(encoding_gzip @ encoding_chunked)); 101 | check 102 | "chunked before non-chunked" 103 | ~expect:`Close_delimited 104 | `GET (res `OK Headers.(encoding_chunked @ encoding_gzip)); 105 | check 106 | "chunked case-insensitive" 107 | ~expect:`Chunked 108 | `GET (res `OK Headers.(of_list ["transfer-encoding", "CHUNKED"])); 109 | ;; 110 | 111 | let tests = 112 | [ "parse valid" , `Quick, test_parse_valid 113 | ; "parse invalid error", `Quick, test_parse_invalid_error 114 | ; "body length" , `Quick, test_body_length 115 | ] 116 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # http/af 2 | 3 | http/af is a high-performance, memory-efficient, and scalable web server for 4 | OCaml. It implements the HTTP 1.1 specification with respect to parsing, 5 | serialization, and connection pipelining as a state machine that is agnostic to 6 | the underlying IO mechanism, and is therefore portable across many platform. 7 | It uses the [Angstrom][angstrom] and [Faraday][faraday] libraries to implement 8 | the parsing and serialization layers of the HTTP standard, hence the name. 9 | 10 | [angstrom]: https://github.com/inhabitedtype/angstrom 11 | [faraday]: https://github.com/inhabitedtype/faraday 12 | [![Build Status](https://github.com/inhabitedtype/httpaf/workflows/build/badge.svg)](https://github.com/inhabitedtype/httpaf/actions?query=workflow%3A%22build%22)] 13 | 14 | ## Installation 15 | 16 | Install the library and its dependencies via [OPAM][opam]: 17 | 18 | [opam]: http://opam.ocaml.org/ 19 | 20 | ```bash 21 | opam install httpaf 22 | ``` 23 | 24 | ## Usage 25 | 26 | Here is a Hello, World! program written using httpaf. It only responds to `GET` 27 | requests to the `/hello/*` target. As it does not itself do any IO, it can be 28 | used with both the Async and Lwt runtimes. See the [`examples`][examples] directory for 29 | usage of the individual runtimes. 30 | 31 | [examples]: https://github.com/inhabitedtype/httpaf/tree/master/examples 32 | 33 | ```ocaml 34 | open Httpaf 35 | module String = Caml.String 36 | 37 | let invalid_request reqd status body = 38 | (* Responses without an explicit length or transfer-encoding are 39 | close-delimited. *) 40 | let headers = Headers.of_list [ "Connection", "close" ] in 41 | Reqd.respond_with_string reqd (Response.create ~headers status) body 42 | ;; 43 | 44 | let request_handler reqd = 45 | let { Request.meth; target; _ } = Reqd.request reqd in 46 | match meth with 47 | | `GET -> 48 | begin match String.split_on_char '/' target with 49 | | "" :: "hello" :: rest -> 50 | let who = 51 | match rest with 52 | | [] -> "world" 53 | | who :: _ -> who 54 | in 55 | let response_body = Printf.sprintf "Hello, %s!\n" who in 56 | (* Specify the length of the response. *) 57 | let headers = 58 | Headers.of_list 59 | [ "Content-length", string_of_int (String.length response_body) ] 60 | in 61 | Reqd.respond_with_string reqd (Response.create ~headers `OK) response_body 62 | | _ -> 63 | let response_body = Printf.sprintf "%S not found\n" target in 64 | invalid_request reqd `Not_found response_body 65 | end 66 | | meth -> 67 | let response_body = 68 | Printf.sprintf "%s is not an allowed method\n" (Method.to_string meth) 69 | in 70 | invalid_request reqd `Method_not_allowed response_body 71 | ;; 72 | ``` 73 | 74 | ## Performance 75 | 76 | The reason for http/af's existence is [mirage/ocaml-cohttp#328][328], which 77 | highlights the poor scalability of cohttp. This is due to a number of factors, 78 | including poor scheduling, excessive allocation, and starvation of the server's 79 | accept loop. Here is a comparison chart of the data from that issue, along with 80 | data from an async-based http/af server. This server was run on a VM with 3 81 | virtual cores, the host being circa 2015 MacBook Pro: 82 | 83 | [328]: https://github.com/mirage/ocaml-cohttp/issues/328 84 | 85 | ![http/af comparsion to cohttp](https://raw.githubusercontent.com/inhabitedtype/httpaf/master/images/httpaf-comparison.png) 86 | 87 | The http/af latency histogram, relative to the cohttp histograms, is pretty 88 | much flat along the x-axis. Here are some additional statistics from that run 89 | (with latencies in milliseconds): 90 | 91 | ``` 92 | #[Mean = 27.719, StdDeviation = 31.570] 93 | #[Max = 263.424, Total count = 1312140] 94 | #[Buckets = 27, SubBuckets = 2048] 95 | ---------------------------------------------------------- 96 | 1709909 requests in 1.00m, 3.33GB read 97 | ``` 98 | 99 | ## Development 100 | 101 | To install development dependencies, pin the package from the root of the 102 | repository: 103 | 104 | ```bash 105 | opam pin add -n httpaf . 106 | opam install --deps-only httpaf 107 | ``` 108 | 109 | After this, you may install a development version of the library using the 110 | install command as usual. 111 | 112 | Tests can be run via dune: 113 | 114 | ```bash 115 | dune runtest 116 | ``` 117 | 118 | ## License 119 | 120 | BSD3, see LICENSE files for its text. 121 | -------------------------------------------------------------------------------- /lib/response.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | type t = 35 | { version : Version.t 36 | ; status : Status.t 37 | ; reason : string 38 | ; headers : Headers.t } 39 | 40 | let create ?reason ?(version=Version.v1_1) ?(headers=Headers.empty) status = 41 | let reason = 42 | match reason with 43 | | Some reason -> reason 44 | | None -> 45 | begin match status with 46 | | #Status.standard as status -> Status.default_reason_phrase status 47 | | `Code _ -> "Non-standard status code" 48 | end 49 | in 50 | { version; status; reason; headers } 51 | 52 | let persistent_connection ?proxy { version; headers; _ } = 53 | Message.persistent_connection ?proxy version headers 54 | 55 | let proxy_error = `Error `Bad_gateway 56 | let server_error = `Error `Internal_server_error 57 | 58 | module Body_length = struct 59 | type t = [ 60 | | `Fixed of Int64.t 61 | | `Chunked 62 | | `Close_delimited 63 | | `Error of [ `Bad_gateway | `Internal_server_error ] 64 | ] 65 | 66 | let pp_hum fmt (len : t) = 67 | match len with 68 | | `Fixed n -> Format.fprintf fmt "Fixed %Li" n 69 | | `Chunked -> Format.pp_print_string fmt "Chunked" 70 | | `Close_delimited -> Format.pp_print_string fmt "Close delimited" 71 | | `Error `Bad_gateway -> Format.pp_print_string fmt "Error: Bad gateway" 72 | | `Error `Internal_server_error -> 73 | Format.pp_print_string fmt "Error: Internal server error" 74 | ;; 75 | end 76 | 77 | let body_length ?(proxy=false) ~request_method { status; headers; _ } : Body_length.t = 78 | match status, request_method with 79 | | _, `HEAD -> `Fixed 0L 80 | | (`No_content | `Not_modified), _ -> `Fixed 0L 81 | | s, _ when Status.is_informational s -> `Fixed 0L 82 | | s, `CONNECT when Status.is_successful s -> `Close_delimited 83 | | _, _ -> 84 | (* The last entry in transfer-encoding is the correct entry. We only handle 85 | chunked transfer-encodings. *) 86 | begin match List.rev (Headers.get_multi headers "transfer-encoding") with 87 | | value::_ when Headers.ci_equal value "chunked" -> `Chunked 88 | | _ ::_ -> `Close_delimited 89 | | [] -> 90 | begin match Message.unique_content_length_values headers with 91 | | [] -> `Close_delimited 92 | | [ len ] -> 93 | let len = Message.content_length_of_string len in 94 | if len >= 0L 95 | then `Fixed len 96 | else if proxy then proxy_error else server_error 97 | | _ -> 98 | if proxy then proxy_error else server_error 99 | end 100 | end 101 | 102 | let pp_hum fmt { version; status; reason; headers } = 103 | Format.fprintf fmt "((version \"%a\") (status %a) (reason %S) (headers %a))" 104 | Version.pp_hum version Status.pp_hum status reason Headers.pp_hum headers 105 | -------------------------------------------------------------------------------- /examples/lib/httpaf_examples.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Httpaf 3 | module Format = Caml.Format 4 | 5 | let print_string = Stdio.(Out_channel.output_string stdout) 6 | 7 | let text = "CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of sitting by her sister on the bank, and of having nothing to do: once or twice she had peeped into the book her sister was reading, but it had no pictures or conversations in it, thought Alice So she was considering in her own mind (as well as she could, for the hot day made her feel very sleepy and stupid), whether the pleasure of making a daisy-chain would be worth the trouble of getting up and picking the daisies, when suddenly a White Rabbit with pink eyes ran close by her. There was nothing so very remarkable in that; nor did Alice think it so very much out of the way to hear the Rabbit say to itself, (when she thought it over afterwards, it occurred to her that she ought to have wondered at this, but at the time it all seemed quite natural); but when the Rabbit actually took a watch out of its waistcoat-pocket, and looked at it, and then hurried on, Alice started to her feet, for it flashed across her mind that she had never before seen a rabbit with either a waistcoat-pocket, or a watch to take out of it, and burning with curiosity, she ran across the field after it, and fortunately was just in time to see it pop down a large rabbit-hole under the hedge. In another moment down went Alice after it, never once considering how in the world she was to get out again. The rabbit-hole went straight on like a tunnel for some way, and then dipped suddenly down, so suddenly that Alice had not a moment to think about stopping herself before she found herself falling down a very deep well. Either the well was very deep, or she fell very slowly, for she had plenty of time as she went down to look about her and to wonder what was going to happen next. First, she tried to look down and make out what she was coming to, but it was too dark to see anything; then she looked at the sides of the well, and noticed that they were filled with cupboards......" 8 | 9 | let text = Bigstringaf.of_string ~off:0 ~len:(String.length text) text 10 | 11 | module Client = struct 12 | exception Response_error 13 | 14 | let error_handler error = 15 | let error = 16 | match error with 17 | | `Malformed_response err -> Format.sprintf "Malformed response: %s" err 18 | | `Invalid_response_body_length _ -> "Invalid body length" 19 | | `Exn exn -> Format.sprintf "Exn raised: %s" (Exn.to_string exn) 20 | in 21 | Format.eprintf "Error handling response: %s\n%!" error; 22 | ;; 23 | 24 | let print ~on_eof response response_body = 25 | match response with 26 | | { Response.status = `OK; _ } as response -> 27 | Format.fprintf Format.std_formatter "%a\n%!" Response.pp_hum response; 28 | let rec on_read bs ~off ~len = 29 | Bigstringaf.substring ~off ~len bs |> print_string; 30 | Body.Reader.schedule_read response_body ~on_read ~on_eof 31 | in 32 | Body.Reader.schedule_read response_body ~on_read ~on_eof; 33 | | response -> 34 | Format.fprintf Format.err_formatter "%a\n%!" Response.pp_hum response; 35 | Caml.exit 1 36 | ;; 37 | end 38 | 39 | module Server = struct 40 | let echo_post reqd = 41 | match Reqd.request reqd with 42 | | { Request.meth = `POST; headers; _ } -> 43 | let response = 44 | let content_type = 45 | match Headers.get headers "content-type" with 46 | | None -> "application/octet-stream" 47 | | Some x -> x 48 | in 49 | Response.create ~headers:(Headers.of_list ["content-type", content_type; "connection", "close"]) `OK 50 | in 51 | let request_body = Reqd.request_body reqd in 52 | let response_body = Reqd.respond_with_streaming reqd response in 53 | let rec on_read buffer ~off ~len = 54 | Body.Writer.write_bigstring response_body buffer ~off ~len; 55 | Body.Reader.schedule_read request_body ~on_eof ~on_read; 56 | and on_eof () = 57 | Body.Writer.close response_body 58 | in 59 | Body.Reader.schedule_read (Reqd.request_body reqd) ~on_eof ~on_read 60 | | _ -> 61 | let headers = Headers.of_list [ "connection", "close" ] in 62 | Reqd.respond_with_string reqd (Response.create ~headers `Method_not_allowed) "" 63 | ;; 64 | 65 | let benchmark = 66 | let headers = Headers.of_list ["content-length", Int.to_string (Bigstringaf.length text)] in 67 | let handler reqd = 68 | let { Request.target; _ } = Reqd.request reqd in 69 | let request_body = Reqd.request_body reqd in 70 | Body.Reader.close request_body; 71 | match target with 72 | | "/" -> Reqd.respond_with_bigstring reqd (Response.create ~headers `OK) text; 73 | | _ -> Reqd.respond_with_string reqd (Response.create `Not_found) "Route not found" 74 | in 75 | handler 76 | ;; 77 | 78 | let error_handler ?request:_ error start_response = 79 | let response_body = start_response Headers.empty in 80 | begin match error with 81 | | `Exn exn -> 82 | Body.Writer.write_string response_body (Exn.to_string exn); 83 | Body.Writer.write_string response_body "\n"; 84 | | #Status.standard as error -> 85 | Body.Writer.write_string response_body (Status.default_reason_phrase error) 86 | end; 87 | Body.Writer.close response_body 88 | ;; 89 | end 90 | -------------------------------------------------------------------------------- /lib/headers.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | 35 | type name = string 36 | type value = string 37 | type t = (name * value) list 38 | 39 | let empty : t = [] 40 | 41 | let of_rev_list t = t 42 | let of_list t = of_rev_list (List.rev t) 43 | let to_rev_list t = t 44 | let to_list t = List.rev (to_rev_list t) 45 | 46 | module CI = struct 47 | (* Convert codes to upper case and compare them. This is a port of assembly 48 | code from the page: 49 | 50 | http://www.azillionmonkeys.com/qed/asmexample.html *) 51 | let[@inline always] char_code_equal_ci x y = 52 | let codes = (x lsl 8) lor y in 53 | let b = 0x8080 lor codes in 54 | let c = b - 0x6161 in 55 | let d = lnot (b - 0x7b7b) in 56 | let e = (c land d) land (lnot codes land 0x8080) in 57 | let upper = codes - (e lsr 2) in 58 | upper lsr 8 = upper land 0xff 59 | 60 | let equal x y = 61 | let len = String.length x in 62 | len = String.length y && ( 63 | let equal_so_far = ref true in 64 | let i = ref 0 in 65 | while !equal_so_far && !i < len do 66 | let c1 = Char.code (String.unsafe_get x !i) in 67 | let c2 = Char.code (String.unsafe_get y !i) in 68 | equal_so_far := char_code_equal_ci c1 c2; 69 | incr i 70 | done; 71 | !equal_so_far 72 | ) 73 | end 74 | 75 | let ci_equal = CI.equal 76 | 77 | let rec mem t name = 78 | match t with 79 | | (name', _)::t' -> CI.equal name name' || mem t' name 80 | | _ -> false 81 | 82 | let add t name value = (name,value)::t 83 | let add_list t ls = ls @ t (* XXX(seliopou): do better here *) 84 | let add_multi = 85 | let rec loop_outer t lss = 86 | match lss with 87 | | [] -> t 88 | | (n,vs)::lss' -> loop_inner t n vs lss' 89 | and loop_inner t n vs lss = 90 | match vs with 91 | | [] -> loop_outer t lss 92 | | v::vs' -> loop_inner ((n,v)::t) n vs' lss 93 | in 94 | loop_outer 95 | 96 | let add_unless_exists t name value = 97 | if mem t name then t else (name,value)::t 98 | 99 | exception Local 100 | 101 | let replace t name value = 102 | let rec loop t needle nv seen = 103 | match t with 104 | | [] -> 105 | if not seen then raise Local else [] 106 | | (name,_ as nv')::t -> 107 | if CI.equal needle name 108 | then ( 109 | if seen 110 | then loop t needle nv true 111 | else nv::loop t needle nv true) 112 | else nv'::loop t needle nv seen 113 | in 114 | try loop t name (name,value) false 115 | with Local -> t 116 | 117 | let remove t name = 118 | let rec loop s needle seen = 119 | match s with 120 | | [] -> 121 | if not seen then raise Local else [] 122 | | (name,_ as nv')::s' -> 123 | if CI.equal needle name 124 | then loop s' needle true 125 | else nv'::(loop s' needle seen) 126 | in 127 | try loop t name false 128 | with Local -> t 129 | 130 | let get t name = 131 | let rec loop t n = 132 | match t with 133 | | [] -> None 134 | | (n',v)::t' -> if CI.equal n n' then Some v else loop t' n 135 | in 136 | loop t name 137 | 138 | let get_exn t name = 139 | let rec loop t n = 140 | match t with 141 | | [] -> failwith (Printf.sprintf "Headers.get_exn: %S not found" name) 142 | | (n',v)::t' -> if CI.equal n n' then v else loop t' n 143 | in 144 | loop t name 145 | 146 | let get_multi t name = 147 | let rec loop t n acc = 148 | match t with 149 | | [] -> acc 150 | | (n',v)::t' -> 151 | if CI.equal n n' 152 | then loop t' n (v::acc) 153 | else loop t' n acc 154 | in 155 | loop t name [] 156 | 157 | let iter ~f t = 158 | List.iter (fun (name,value) -> f name value) t 159 | 160 | let fold ~f ~init t = 161 | List.fold_left (fun acc (name,value) -> f name value acc) init t 162 | 163 | let to_string t = 164 | let b = Buffer.create 128 in 165 | iter (to_list t) ~f:(fun name value -> 166 | Buffer.add_string b name; 167 | Buffer.add_string b ": "; 168 | Buffer.add_string b value; 169 | Buffer.add_string b "\r\n"); 170 | Buffer.add_string b "\r\n"; 171 | Buffer.contents b 172 | 173 | let pp_hum fmt t = 174 | let pp_elem fmt (n,v) = Format.fprintf fmt "@[(%S %S)@]" n v in 175 | Format.fprintf fmt "@[("; 176 | Format.pp_print_list pp_elem fmt (to_list t); 177 | Format.fprintf fmt ")@]"; 178 | -------------------------------------------------------------------------------- /lib/serialize.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | open Faraday 35 | 36 | let write_space t = write_char t ' ' 37 | let write_crlf t = write_string t "\r\n" 38 | 39 | let write_version t version = 40 | write_string t (Version.to_string version) 41 | 42 | let write_method t meth = 43 | write_string t (Method.to_string meth) 44 | 45 | let write_status t status = 46 | write_string t (Status.to_string status) 47 | 48 | let write_headers t headers = 49 | (* XXX(seliopou): escape these thigns *) 50 | List.iter (fun (name, value) -> 51 | write_string t name; 52 | write_string t ": "; 53 | write_string t value; 54 | write_crlf t) 55 | (Headers.to_list headers); 56 | write_crlf t 57 | 58 | let write_request t { Request.meth; target; version; headers } = 59 | write_method t meth ; write_space t; 60 | write_string t target ; write_space t; 61 | write_version t version; write_crlf t; 62 | write_headers t headers 63 | 64 | let write_response t { Response.version; status; reason; headers } = 65 | write_version t version; write_space t; 66 | write_status t status ; write_space t; 67 | write_string t reason ; write_crlf t; 68 | write_headers t headers 69 | 70 | let write_chunk_length t len = 71 | write_string t (Printf.sprintf "%x" len); 72 | write_crlf t 73 | 74 | let write_string_chunk t chunk = 75 | write_chunk_length t (String.length chunk); 76 | write_string t chunk; 77 | write_crlf t 78 | 79 | let write_bigstring_chunk t chunk = 80 | write_chunk_length t (Bigstringaf.length chunk); 81 | write_bigstring t chunk; 82 | write_crlf t 83 | 84 | let schedule_bigstring_chunk t chunk = 85 | write_chunk_length t (Bigstringaf.length chunk); 86 | schedule_bigstring t chunk; 87 | write_crlf t 88 | 89 | module Writer = struct 90 | type t = 91 | { buffer : Bigstringaf.t 92 | (* The buffer that the encoder uses for buffered writes. Managed by the 93 | * control module for the encoder. *) 94 | ; encoder : Faraday.t 95 | (* The encoder that handles encoding for writes. Uses the [buffer] 96 | * referenced above internally. *) 97 | ; mutable drained_bytes : int 98 | (* The number of bytes that were not written due to the output stream 99 | * being closed before all buffered output could be written. Useful for 100 | * detecting error cases. *) 101 | ; mutable wakeup : Optional_thunk.t 102 | (* The callback from the runtime to be invoked when output is ready to be 103 | * flushed. *) 104 | } 105 | 106 | let create ?(buffer_size=0x800) () = 107 | let buffer = Bigstringaf.create buffer_size in 108 | let encoder = Faraday.of_bigstring buffer in 109 | { buffer 110 | ; encoder 111 | ; drained_bytes = 0 112 | ; wakeup = Optional_thunk.none 113 | } 114 | 115 | let faraday t = t.encoder 116 | 117 | let write_request t request = 118 | write_request t.encoder request 119 | 120 | let write_response t response = 121 | write_response t.encoder response 122 | 123 | let write_string t ?off ?len string = 124 | write_string t.encoder ?off ?len string 125 | 126 | let write_bytes t ?off ?len bytes = 127 | write_bytes t.encoder ?off ?len bytes 128 | 129 | let write_bigstring t ?off ?len bigstring = 130 | write_bigstring t.encoder ?off ?len bigstring 131 | 132 | let schedule_bigstring t ?off ?len bigstring = 133 | schedule_bigstring t.encoder ?off ?len bigstring 134 | 135 | let schedule_fixed t iovecs = 136 | List.iter (fun { IOVec.buffer; off; len } -> 137 | schedule_bigstring t ~off ~len buffer) 138 | iovecs 139 | 140 | let schedule_chunk t iovecs = 141 | let length = IOVec.lengthv iovecs in 142 | write_chunk_length t.encoder length; 143 | schedule_fixed t iovecs; 144 | write_crlf t.encoder 145 | 146 | let on_wakeup t k = 147 | if Faraday.is_closed t.encoder 148 | then failwith "on_wakeup on closed writer" 149 | else if Optional_thunk.is_some t.wakeup 150 | then failwith "on_wakeup: only one callback can be registered at a time" 151 | else t.wakeup <- Optional_thunk.some k 152 | ;; 153 | 154 | let wakeup t = 155 | let f = t.wakeup in 156 | t.wakeup <- Optional_thunk.none; 157 | Optional_thunk.call_if_some f 158 | ;; 159 | 160 | let flush t f = 161 | flush t.encoder f 162 | 163 | let unyield t = 164 | (* This would be better implemented by a function that just takes the 165 | encoder out of a yielded state if it's in that state. Requires a change 166 | to the faraday library. *) 167 | flush t (fun () -> ()) 168 | 169 | let yield t = 170 | Faraday.yield t.encoder 171 | 172 | let close t = 173 | Faraday.close t.encoder 174 | 175 | let close_and_drain t = 176 | Faraday.close t.encoder; 177 | let drained = Faraday.drain t.encoder in 178 | t.drained_bytes <- t.drained_bytes + drained; 179 | wakeup t 180 | 181 | let is_closed t = 182 | Faraday.is_closed t.encoder 183 | 184 | let drained_bytes t = 185 | t.drained_bytes 186 | 187 | let report_result t result = 188 | match result with 189 | | `Closed -> close_and_drain t 190 | | `Ok len -> shift t.encoder len 191 | 192 | let next t = 193 | assert (Optional_thunk.is_none t.wakeup); 194 | match Faraday.operation t.encoder with 195 | | `Close -> `Close (drained_bytes t) 196 | | `Yield -> `Yield 197 | | `Writev iovecs -> `Write iovecs 198 | end 199 | -------------------------------------------------------------------------------- /lib/body.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2018 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | module Reader = struct 35 | type t = 36 | { faraday : Faraday.t 37 | ; mutable read_scheduled : bool 38 | ; mutable on_eof : unit -> unit 39 | ; mutable on_read : Bigstringaf.t -> off:int -> len:int -> unit 40 | } 41 | 42 | let default_on_eof = Sys.opaque_identity (fun () -> ()) 43 | let default_on_read = Sys.opaque_identity (fun _ ~off:_ ~len:_ -> ()) 44 | 45 | let create buffer = 46 | { faraday = Faraday.of_bigstring buffer 47 | ; read_scheduled = false 48 | ; on_eof = default_on_eof 49 | ; on_read = default_on_read 50 | } 51 | 52 | let create_empty () = 53 | let t = create Bigstringaf.empty in 54 | Faraday.close t.faraday; 55 | t 56 | 57 | let empty = create_empty () 58 | 59 | let is_closed t = 60 | Faraday.is_closed t.faraday 61 | 62 | let unsafe_faraday t = 63 | t.faraday 64 | 65 | let rec do_execute_read t on_eof on_read = 66 | match Faraday.operation t.faraday with 67 | | `Yield -> () 68 | | `Close -> 69 | t.read_scheduled <- false; 70 | t.on_eof <- default_on_eof; 71 | t.on_read <- default_on_read; 72 | on_eof () 73 | (* [Faraday.operation] never returns an empty list of iovecs *) 74 | | `Writev [] -> assert false 75 | | `Writev (iovec::_) -> 76 | t.read_scheduled <- false; 77 | t.on_eof <- default_on_eof; 78 | t.on_read <- default_on_read; 79 | let { IOVec.buffer; off; len } = iovec in 80 | Faraday.shift t.faraday len; 81 | on_read buffer ~off ~len; 82 | execute_read t 83 | and execute_read t = 84 | if t.read_scheduled then do_execute_read t t.on_eof t.on_read 85 | 86 | let schedule_read t ~on_eof ~on_read = 87 | if t.read_scheduled 88 | then failwith "Body.Reader.schedule_read: reader already scheduled"; 89 | if not (is_closed t) then begin 90 | t.read_scheduled <- true; 91 | t.on_eof <- on_eof; 92 | t.on_read <- on_read; 93 | end; 94 | do_execute_read t on_eof on_read 95 | 96 | let close t = 97 | Faraday.close t.faraday; 98 | execute_read t 99 | ;; 100 | 101 | let has_pending_output t = Faraday.has_pending_output t.faraday 102 | end 103 | 104 | module Writer = struct 105 | type encoding = 106 | | Identity 107 | | Chunked of { mutable written_final_chunk : bool } 108 | 109 | type t = 110 | { faraday : Faraday.t 111 | ; encoding : encoding 112 | ; when_ready_to_write : unit -> unit 113 | ; buffered_bytes : int ref 114 | } 115 | 116 | let of_faraday faraday ~encoding ~when_ready_to_write = 117 | let encoding = 118 | match encoding with 119 | | `Fixed _ | `Close_delimited -> Identity 120 | | `Chunked -> Chunked { written_final_chunk = false } 121 | in 122 | { faraday 123 | ; encoding 124 | ; when_ready_to_write 125 | ; buffered_bytes = ref 0 126 | } 127 | 128 | let create buffer ~encoding ~when_ready_to_write = 129 | of_faraday (Faraday.of_bigstring buffer) ~encoding ~when_ready_to_write 130 | 131 | let write_char t c = 132 | Faraday.write_char t.faraday c 133 | 134 | let write_string t ?off ?len s = 135 | Faraday.write_string ?off ?len t.faraday s 136 | 137 | let write_bigstring t ?off ?len b = 138 | Faraday.write_bigstring ?off ?len t.faraday b 139 | 140 | let schedule_bigstring t ?off ?len (b:Bigstringaf.t) = 141 | Faraday.schedule_bigstring ?off ?len t.faraday b 142 | 143 | let ready_to_write t = t.when_ready_to_write () 144 | 145 | let flush t kontinue = 146 | Faraday.flush t.faraday kontinue; 147 | ready_to_write t 148 | 149 | let is_closed t = 150 | Faraday.is_closed t.faraday 151 | 152 | let close t = 153 | Faraday.close t.faraday; 154 | ready_to_write t; 155 | ;; 156 | 157 | let has_pending_output t = 158 | (* Force another write poll to make sure that the final chunk is emitted for 159 | chunk-encoded bodies. *) 160 | let faraday_has_output = Faraday.has_pending_output t.faraday in 161 | let additional_encoding_output = 162 | match t.encoding with 163 | | Identity -> false 164 | | Chunked { written_final_chunk } -> 165 | Faraday.is_closed t.faraday && not written_final_chunk 166 | in 167 | faraday_has_output || additional_encoding_output 168 | 169 | let transfer_to_writer t writer = 170 | let faraday = t.faraday in 171 | begin match Faraday.operation faraday with 172 | | `Yield -> () 173 | | `Close -> 174 | (match t.encoding with 175 | | Identity -> () 176 | | Chunked ({ written_final_chunk } as chunked) -> 177 | if not written_final_chunk then begin 178 | chunked.written_final_chunk <- true; 179 | Serialize.Writer.schedule_chunk writer []; 180 | end); 181 | Serialize.Writer.unyield writer; 182 | | `Writev iovecs -> 183 | let buffered = t.buffered_bytes in 184 | begin match IOVec.shiftv iovecs !buffered with 185 | | [] -> () 186 | | iovecs -> 187 | let lengthv = IOVec.lengthv iovecs in 188 | buffered := !buffered + lengthv; 189 | begin match t.encoding with 190 | | Identity -> Serialize.Writer.schedule_fixed writer iovecs 191 | | Chunked _ -> Serialize.Writer.schedule_chunk writer iovecs 192 | end; 193 | Serialize.Writer.flush writer (fun () -> 194 | Faraday.shift faraday lengthv; 195 | buffered := !buffered - lengthv) 196 | end 197 | end 198 | end 199 | -------------------------------------------------------------------------------- /lib/client_connection.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017-2019 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | module Reader = Parse.Reader 35 | module Writer = Serialize.Writer 36 | 37 | module Oneshot = struct 38 | type error = 39 | [ `Malformed_response of string | `Invalid_response_body_length of Response.t | `Exn of exn ] 40 | 41 | type response_handler = Response.t -> Body.Reader.t -> unit 42 | type error_handler = error -> unit 43 | 44 | type state = 45 | | Awaiting_response 46 | | Received_response of Response.t * Body.Reader.t 47 | | Closed 48 | 49 | type t = 50 | { request : Request.t 51 | ; request_body : Body.Writer.t 52 | ; error_handler : (error -> unit) 53 | ; reader : Reader.response 54 | ; writer : Writer.t 55 | ; state : state ref 56 | ; mutable error_code : [ `Ok | error ] 57 | } 58 | 59 | let request ?(config=Config.default) request ~error_handler ~response_handler = 60 | let state = ref Awaiting_response in 61 | let request_method = request.Request.meth in 62 | let handler response body = 63 | state := Received_response(response, body); 64 | response_handler response body 65 | in 66 | let writer = Writer.create () in 67 | let request_body = 68 | let encoding = 69 | match Request.body_length request with 70 | | `Fixed _ | `Chunked as encoding -> encoding 71 | | `Error `Bad_request -> 72 | failwith "Httpaf.Client_connection.request: invalid body length" 73 | in 74 | Body.Writer.create (Bigstringaf.create config.request_body_buffer_size) 75 | ~encoding ~when_ready_to_write:(fun () -> Writer.wakeup writer) 76 | in 77 | let t = 78 | { request 79 | ; request_body 80 | ; error_handler 81 | ; error_code = `Ok 82 | ; reader = Reader.response ~request_method handler 83 | ; writer 84 | ; state } 85 | in 86 | Writer.write_request t.writer request; 87 | request_body, t 88 | ;; 89 | 90 | let flush_request_body t = 91 | if Body.Writer.has_pending_output t.request_body 92 | then Body.Writer.transfer_to_writer t.request_body t.writer 93 | ;; 94 | 95 | let set_error_and_handle_without_shutdown t error = 96 | t.state := Closed; 97 | t.error_code <- (error :> [`Ok | error]); 98 | t.error_handler error; 99 | ;; 100 | 101 | let unexpected_eof t = 102 | set_error_and_handle_without_shutdown t (`Malformed_response "unexpected eof"); 103 | ;; 104 | 105 | let shutdown_reader t = 106 | Reader.force_close t.reader; 107 | begin match !(t.state) with 108 | | Awaiting_response -> unexpected_eof t; 109 | | Closed -> () 110 | | Received_response(_, response_body) -> 111 | Body.Reader.close response_body; 112 | Body.Reader.execute_read response_body; 113 | end; 114 | ;; 115 | 116 | let shutdown_writer t = 117 | flush_request_body t; 118 | Writer.close t.writer; 119 | Body.Writer.close t.request_body; 120 | ;; 121 | 122 | let shutdown t = 123 | shutdown_reader t; 124 | shutdown_writer t; 125 | ;; 126 | 127 | let set_error_and_handle t error = 128 | Reader.force_close t.reader; 129 | begin match !(t.state) with 130 | | Closed -> () 131 | | Awaiting_response -> 132 | set_error_and_handle_without_shutdown t error; 133 | | Received_response(_, response_body) -> 134 | Body.Reader.close response_body; 135 | Body.Reader.execute_read response_body; 136 | set_error_and_handle_without_shutdown t error; 137 | end 138 | ;; 139 | 140 | let report_exn t exn = 141 | set_error_and_handle t (`Exn exn) 142 | ;; 143 | 144 | let flush_response_body t = 145 | match !(t.state) with 146 | | Awaiting_response | Closed -> () 147 | | Received_response(_, response_body) -> 148 | try Body.Reader.execute_read response_body 149 | with exn -> report_exn t exn 150 | ;; 151 | 152 | let _next_read_operation t = 153 | match !(t.state) with 154 | | Awaiting_response | Closed -> Reader.next t.reader 155 | | Received_response(_, response_body) -> 156 | if not (Body.Reader.is_closed response_body) 157 | then Reader.next t.reader 158 | else begin 159 | Reader.force_close t.reader; 160 | Reader.next t.reader 161 | end 162 | ;; 163 | 164 | let next_read_operation t = 165 | match _next_read_operation t with 166 | | `Error (`Parse(marks, message)) -> 167 | let message = String.concat "" [ String.concat ">" marks; ": "; message] in 168 | set_error_and_handle t (`Malformed_response message); 169 | `Close 170 | | `Error (`Invalid_response_body_length _ as error) -> 171 | set_error_and_handle t error; 172 | `Close 173 | | (`Read | `Close) as operation -> operation 174 | ;; 175 | 176 | let read_with_more t bs ~off ~len more = 177 | let consumed = Reader.read_with_more t.reader bs ~off ~len more in 178 | flush_response_body t; 179 | consumed 180 | ;; 181 | 182 | let read t bs ~off ~len = 183 | read_with_more t bs ~off ~len Incomplete 184 | 185 | let read_eof t bs ~off ~len = 186 | let bytes_read = read_with_more t bs ~off ~len Complete in 187 | begin match !(t.state) with 188 | | Received_response _ | Closed -> () 189 | | Awaiting_response -> unexpected_eof t; 190 | end; 191 | bytes_read 192 | ;; 193 | 194 | let next_write_operation t = 195 | flush_request_body t; 196 | if Body.Writer.is_closed t.request_body 197 | (* Even though we've just done [flush_request_body], it might still be the case that 198 | [Body.Writer.has_pending_output] returns true, because it does so when 199 | we've written all output except for the final chunk. *) 200 | && not (Body.Writer.has_pending_output t.request_body) 201 | then Writer.close t.writer; 202 | Writer.next t.writer 203 | ;; 204 | 205 | let yield_writer t k = 206 | if Body.Writer.is_closed t.request_body 207 | && not (Body.Writer.has_pending_output t.request_body) 208 | then begin 209 | Writer.close t.writer; 210 | k () 211 | end else 212 | Writer.on_wakeup t.writer k 213 | 214 | let report_write_result t result = 215 | Writer.report_result t.writer result 216 | 217 | let is_closed t = Reader.is_closed t.reader && Writer.is_closed t.writer 218 | end 219 | -------------------------------------------------------------------------------- /async/httpaf_async.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | 4 | (** XXX(seliopou): Replace Angstrom.Buffered with a module like this, while 5 | also supporting growing the buffer. Clients can use this to buffer and the 6 | use the unbuffered interface for actually running the parser. *) 7 | module Buffer : sig 8 | type t 9 | 10 | val create : int -> t 11 | 12 | val get : t -> f:(Bigstring.t -> off:int -> len:int -> int) -> int 13 | val put : t -> f:(Bigstring.t -> off:int -> len:int -> int) -> int 14 | end= struct 15 | type t = 16 | { buffer : Bigstring.t 17 | ; mutable off : int 18 | ; mutable len : int } 19 | 20 | let create size = 21 | let buffer = Bigstring.create size in 22 | { buffer; off = 0; len = 0 } 23 | ;; 24 | 25 | let compress t = 26 | if t.len = 0 27 | then begin 28 | t.off <- 0; 29 | t.len <- 0; 30 | end else if t.off > 0 31 | then begin 32 | Bigstring.blit ~src:t.buffer ~src_pos:t.off ~dst:t.buffer ~dst_pos:0 ~len:t.len; 33 | t.off <- 0; 34 | end 35 | ;; 36 | 37 | let get t ~f = 38 | let n = f t.buffer ~off:t.off ~len:t.len in 39 | t.off <- t.off + n; 40 | t.len <- t.len - n; 41 | if t.len = 0 42 | then t.off <- 0; 43 | n 44 | ;; 45 | 46 | let put t ~f = 47 | compress t; 48 | let n = f t.buffer ~off:(t.off + t.len) ~len:(Bigstring.length t.buffer - t.len) in 49 | t.len <- t.len + n; 50 | n 51 | ;; 52 | end 53 | 54 | let read fd buffer = 55 | let badfd fd = failwithf "read got back fd: %s" (Fd.to_string fd) () in 56 | let rec finish fd buffer result = 57 | let open Unix.Error in 58 | match result with 59 | | `Already_closed | `Ok 0 -> return `Eof 60 | | `Ok n -> return (`Ok n) 61 | | `Error (Unix.Unix_error ((EWOULDBLOCK | EAGAIN), _, _)) -> 62 | begin Fd.ready_to fd `Read 63 | >>= function 64 | | `Bad_fd -> badfd fd 65 | | `Closed -> return `Eof 66 | | `Ready -> go fd buffer 67 | end 68 | | `Error (Unix.Unix_error (EBADF, _, _)) -> 69 | badfd fd 70 | | `Error exn -> 71 | Deferred.don't_wait_for (Fd.close fd); 72 | raise exn 73 | and go fd buffer = 74 | if Fd.supports_nonblock fd then 75 | finish fd buffer 76 | (Fd.syscall fd ~nonblocking:true 77 | (fun file_descr -> 78 | Buffer.put buffer ~f:(fun bigstring ~off ~len -> 79 | Unix.Syscall_result.Int.ok_or_unix_error_exn ~syscall_name:"read" 80 | (Bigstring_unix.read_assume_fd_is_nonblocking file_descr bigstring ~pos:off ~len)))) 81 | else 82 | Fd.syscall_in_thread fd ~name:"read" 83 | (fun file_descr -> 84 | Buffer.put buffer ~f:(fun bigstring ~off ~len -> 85 | Bigstring_unix.read file_descr bigstring ~pos:off ~len)) 86 | >>= fun result -> finish fd buffer result 87 | in 88 | go fd buffer 89 | 90 | open Httpaf 91 | 92 | module Server = struct 93 | let create_connection_handler ?(config=Config.default) ~request_handler ~error_handler = 94 | fun client_addr socket -> 95 | let fd = Socket.fd socket in 96 | let writev = Faraday_async.writev_of_fd fd in 97 | let request_handler = request_handler client_addr in 98 | let error_handler = error_handler client_addr in 99 | let conn = Server_connection.create ~config ~error_handler request_handler in 100 | let read_complete = Ivar.create () in 101 | let buffer = Buffer.create config.read_buffer_size in 102 | let rec reader_thread () = 103 | match Server_connection.next_read_operation conn with 104 | | `Read -> 105 | (* Log.Global.printf "read(%d)%!" (Fd.to_int_exn fd); *) 106 | read fd buffer 107 | >>> begin function 108 | | `Eof -> 109 | Buffer.get buffer ~f:(fun bigstring ~off ~len -> 110 | Server_connection.read_eof conn bigstring ~off ~len) 111 | |> ignore; 112 | reader_thread () 113 | | `Ok _ -> 114 | Buffer.get buffer ~f:(fun bigstring ~off ~len -> 115 | Server_connection.read conn bigstring ~off ~len) 116 | |> ignore; 117 | reader_thread () 118 | end 119 | | `Yield -> 120 | (* Log.Global.printf "read_yield(%d)%!" (Fd.to_int_exn fd); *) 121 | Server_connection.yield_reader conn reader_thread 122 | | `Close -> 123 | (* Log.Global.printf "read_close(%d)%!" (Fd.to_int_exn fd); *) 124 | Ivar.fill read_complete (); 125 | if not (Fd.is_closed fd) 126 | then Socket.shutdown socket `Receive 127 | in 128 | let write_complete = Ivar.create () in 129 | let rec writer_thread () = 130 | match Server_connection.next_write_operation conn with 131 | | `Write iovecs -> 132 | (* Log.Global.printf "write(%d)%!" (Fd.to_int_exn fd); *) 133 | writev iovecs >>> fun result -> 134 | Server_connection.report_write_result conn result; 135 | writer_thread () 136 | | `Yield -> 137 | (* Log.Global.printf "write_yield(%d)%!" (Fd.to_int_exn fd); *) 138 | Server_connection.yield_writer conn writer_thread; 139 | | `Close _ -> 140 | (* Log.Global.printf "write_close(%d)%!" (Fd.to_int_exn fd); *) 141 | Ivar.fill write_complete (); 142 | if not (Fd.is_closed fd) 143 | then Socket.shutdown socket `Send 144 | in 145 | let conn_monitor = Monitor.create () in 146 | Scheduler.within ~monitor:conn_monitor reader_thread; 147 | Scheduler.within ~monitor:conn_monitor writer_thread; 148 | Monitor.detach_and_iter_errors conn_monitor ~f:(fun exn -> 149 | Server_connection.report_exn conn exn); 150 | (* The Tcp module will close the file descriptor once this becomes determined. *) 151 | Deferred.all_unit 152 | [ Ivar.read read_complete 153 | ; Ivar.read write_complete ] 154 | end 155 | 156 | module Client = struct 157 | let request ?(config=Config.default) socket request ~error_handler ~response_handler = 158 | let fd = Socket.fd socket in 159 | let writev = Faraday_async.writev_of_fd fd in 160 | let request_body, conn = 161 | Client_connection.request request ~error_handler ~response_handler in 162 | let read_complete = Ivar.create () in 163 | let buffer = Buffer.create config.read_buffer_size in 164 | let rec reader_thread () = 165 | match Client_connection.next_read_operation conn with 166 | | `Read -> 167 | (* Log.Global.printf "read(%d)%!" (Fd.to_int_exn fd); *) 168 | read fd buffer 169 | >>> begin function 170 | | `Eof -> 171 | Buffer.get buffer ~f:(fun bigstring ~off ~len -> 172 | Client_connection.read_eof conn bigstring ~off ~len) 173 | |> ignore; 174 | reader_thread () 175 | | `Ok _ -> 176 | Buffer.get buffer ~f:(fun bigstring ~off ~len -> 177 | Client_connection.read conn bigstring ~off ~len) 178 | |> ignore; 179 | reader_thread () 180 | end 181 | | `Close -> 182 | (* Log.Global.printf "read_close(%d)%!" (Fd.to_int_exn fd); *) 183 | Ivar.fill read_complete (); 184 | if not (Fd.is_closed fd) 185 | then Socket.shutdown socket `Receive 186 | in 187 | let write_complete = Ivar.create () in 188 | let rec writer_thread () = 189 | match Client_connection.next_write_operation conn with 190 | | `Write iovecs -> 191 | (* Log.Global.printf "write(%d)%!" (Fd.to_int_exn fd); *) 192 | writev iovecs >>> fun result -> 193 | Client_connection.report_write_result conn result; 194 | writer_thread () 195 | | `Yield -> 196 | (* Log.Global.printf "write_yield(%d)%!" (Fd.to_int_exn fd); *) 197 | Client_connection.yield_writer conn writer_thread; 198 | | `Close _ -> 199 | (* Log.Global.printf "write_close(%d)%!" (Fd.to_int_exn fd); *) 200 | Ivar.fill write_complete (); 201 | in 202 | let conn_monitor = Monitor.create () in 203 | Scheduler.within ~monitor:conn_monitor reader_thread; 204 | Scheduler.within ~monitor:conn_monitor writer_thread; 205 | Monitor.detach_and_iter_errors conn_monitor ~f:(fun exn -> 206 | Client_connection.report_exn conn exn); 207 | don't_wait_for ( 208 | Deferred.all_unit 209 | [ Ivar.read read_complete 210 | ; Ivar.read write_complete ] 211 | >>| fun () -> 212 | if not (Fd.is_closed fd) 213 | then don't_wait_for (Fd.close fd)); 214 | request_body 215 | end 216 | -------------------------------------------------------------------------------- /lwt-unix/httpaf_lwt_unix.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2018 Inhabited Type LLC. 3 | Copyright (c) 2018 Anton Bachin 4 | 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | 2. Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | 3. Neither the name of the author nor the names of his contributors 19 | may be used to endorse or promote products derived from this software 20 | without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 23 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 24 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 25 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 26 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 27 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 28 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 29 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 30 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | ----------------------------------------------------------------------------*) 34 | 35 | open Lwt.Infix 36 | 37 | module Buffer : sig 38 | type t 39 | 40 | val create : int -> t 41 | 42 | val get : t -> f:(Lwt_bytes.t -> off:int -> len:int -> int) -> int 43 | val put : t -> f:(Lwt_bytes.t -> off:int -> len:int -> int Lwt.t) -> int Lwt.t 44 | end = struct 45 | type t = 46 | { buffer : Lwt_bytes.t 47 | ; mutable off : int 48 | ; mutable len : int } 49 | 50 | let create size = 51 | let buffer = Lwt_bytes.create size in 52 | { buffer; off = 0; len = 0 } 53 | 54 | let compress t = 55 | if t.len = 0 56 | then begin 57 | t.off <- 0; 58 | t.len <- 0; 59 | end else if t.off > 0 60 | then begin 61 | Lwt_bytes.blit t.buffer t.off t.buffer 0 t.len; 62 | t.off <- 0; 63 | end 64 | 65 | let get t ~f = 66 | let n = f t.buffer ~off:t.off ~len:t.len in 67 | t.off <- t.off + n; 68 | t.len <- t.len - n; 69 | if t.len = 0 70 | then t.off <- 0; 71 | n 72 | 73 | let put t ~f = 74 | compress t; 75 | f t.buffer ~off:(t.off + t.len) ~len:(Lwt_bytes.length t.buffer - t.len) 76 | >>= fun n -> 77 | t.len <- t.len + n; 78 | Lwt.return n 79 | end 80 | 81 | let read fd buffer = 82 | Lwt.catch 83 | (fun () -> 84 | Buffer.put buffer ~f:(fun bigstring ~off ~len -> 85 | Lwt_bytes.read fd bigstring off len)) 86 | (function 87 | | Unix.Unix_error (Unix.EBADF, _, _) as exn -> 88 | Lwt.fail exn 89 | | exn -> 90 | Lwt.async (fun () -> 91 | Lwt_unix.close fd); 92 | Lwt.fail exn) 93 | 94 | >>= fun bytes_read -> 95 | if bytes_read = 0 then 96 | Lwt.return `Eof 97 | else 98 | Lwt.return (`Ok bytes_read) 99 | 100 | 101 | 102 | let shutdown socket command = 103 | try Lwt_unix.shutdown socket command 104 | with Unix.Unix_error (Unix.ENOTCONN, _, _) -> () 105 | 106 | module Config = Httpaf.Config 107 | 108 | module Server = struct 109 | let create_connection_handler ?(config=Config.default) ~request_handler ~error_handler = 110 | fun client_addr socket -> 111 | let module Server_connection = Httpaf.Server_connection in 112 | let connection = 113 | Server_connection.create 114 | ~config 115 | ~error_handler:(error_handler client_addr) 116 | (request_handler client_addr) 117 | in 118 | 119 | let read_buffer = Buffer.create config.read_buffer_size in 120 | let read_loop_exited, notify_read_loop_exited = Lwt.wait () in 121 | 122 | let rec read_loop () = 123 | let rec read_loop_step () = 124 | match Server_connection.next_read_operation connection with 125 | | `Read -> 126 | read socket read_buffer >>= begin function 127 | | `Eof -> 128 | Buffer.get read_buffer ~f:(fun bigstring ~off ~len -> 129 | Server_connection.read_eof connection bigstring ~off ~len) 130 | |> ignore; 131 | read_loop_step () 132 | | `Ok _ -> 133 | Buffer.get read_buffer ~f:(fun bigstring ~off ~len -> 134 | Server_connection.read connection bigstring ~off ~len) 135 | |> ignore; 136 | read_loop_step () 137 | end 138 | 139 | | `Yield -> 140 | Server_connection.yield_reader connection read_loop; 141 | Lwt.return_unit 142 | 143 | | `Close -> 144 | Lwt.wakeup_later notify_read_loop_exited (); 145 | if not (Lwt_unix.state socket = Lwt_unix.Closed) then begin 146 | shutdown socket Unix.SHUTDOWN_RECEIVE 147 | end; 148 | Lwt.return_unit 149 | in 150 | 151 | Lwt.async (fun () -> 152 | Lwt.catch 153 | read_loop_step 154 | (fun exn -> 155 | Server_connection.report_exn connection exn; 156 | Lwt.return_unit)) 157 | in 158 | 159 | 160 | let writev = Faraday_lwt_unix.writev_of_fd socket in 161 | let write_loop_exited, notify_write_loop_exited = Lwt.wait () in 162 | 163 | let rec write_loop () = 164 | let rec write_loop_step () = 165 | match Server_connection.next_write_operation connection with 166 | | `Write io_vectors -> 167 | writev io_vectors >>= fun result -> 168 | Server_connection.report_write_result connection result; 169 | write_loop_step () 170 | 171 | | `Yield -> 172 | Server_connection.yield_writer connection write_loop; 173 | Lwt.return_unit 174 | 175 | | `Close _ -> 176 | Lwt.wakeup_later notify_write_loop_exited (); 177 | if not (Lwt_unix.state socket = Lwt_unix.Closed) then begin 178 | shutdown socket Unix.SHUTDOWN_SEND 179 | end; 180 | Lwt.return_unit 181 | in 182 | 183 | Lwt.async (fun () -> 184 | Lwt.catch 185 | write_loop_step 186 | (fun exn -> 187 | Server_connection.report_exn connection exn; 188 | Lwt.return_unit)) 189 | in 190 | 191 | 192 | read_loop (); 193 | write_loop (); 194 | Lwt.join [read_loop_exited; write_loop_exited] >>= fun () -> 195 | 196 | if Lwt_unix.state socket <> Lwt_unix.Closed then 197 | Lwt.catch 198 | (fun () -> Lwt_unix.close socket) 199 | (fun _exn -> Lwt.return_unit) 200 | else 201 | Lwt.return_unit 202 | end 203 | 204 | 205 | 206 | module Client = struct 207 | let request ?(config=Config.default) socket request ~error_handler ~response_handler = 208 | let module Client_connection = Httpaf.Client_connection in 209 | let request_body, connection = 210 | Client_connection.request ~config request ~error_handler ~response_handler in 211 | 212 | 213 | let read_buffer = Buffer.create config.read_buffer_size in 214 | let read_loop_exited, notify_read_loop_exited = Lwt.wait () in 215 | 216 | let read_loop () = 217 | let rec read_loop_step () = 218 | match Client_connection.next_read_operation connection with 219 | | `Read -> 220 | read socket read_buffer >>= begin function 221 | | `Eof -> 222 | Buffer.get read_buffer ~f:(fun bigstring ~off ~len -> 223 | Client_connection.read_eof connection bigstring ~off ~len) 224 | |> ignore; 225 | read_loop_step () 226 | | `Ok _ -> 227 | Buffer.get read_buffer ~f:(fun bigstring ~off ~len -> 228 | Client_connection.read connection bigstring ~off ~len) 229 | |> ignore; 230 | read_loop_step () 231 | end 232 | 233 | | `Close -> 234 | Lwt.wakeup_later notify_read_loop_exited (); 235 | if not (Lwt_unix.state socket = Lwt_unix.Closed) then begin 236 | shutdown socket Unix.SHUTDOWN_RECEIVE 237 | end; 238 | Lwt.return_unit 239 | in 240 | 241 | Lwt.async (fun () -> 242 | Lwt.catch 243 | read_loop_step 244 | (fun exn -> 245 | Client_connection.report_exn connection exn; 246 | Lwt.return_unit)) 247 | in 248 | 249 | 250 | let writev = Faraday_lwt_unix.writev_of_fd socket in 251 | let write_loop_exited, notify_write_loop_exited = Lwt.wait () in 252 | 253 | let rec write_loop () = 254 | let rec write_loop_step () = 255 | match Client_connection.next_write_operation connection with 256 | | `Write io_vectors -> 257 | writev io_vectors >>= fun result -> 258 | Client_connection.report_write_result connection result; 259 | write_loop_step () 260 | 261 | | `Yield -> 262 | Client_connection.yield_writer connection write_loop; 263 | Lwt.return_unit 264 | 265 | | `Close _ -> 266 | Lwt.wakeup_later notify_write_loop_exited (); 267 | Lwt.return_unit 268 | in 269 | 270 | Lwt.async (fun () -> 271 | Lwt.catch 272 | write_loop_step 273 | (fun exn -> 274 | Client_connection.report_exn connection exn; 275 | Lwt.return_unit)) 276 | in 277 | 278 | 279 | read_loop (); 280 | write_loop (); 281 | 282 | Lwt.async (fun () -> 283 | Lwt.join [read_loop_exited; write_loop_exited] >>= fun () -> 284 | 285 | if Lwt_unix.state socket <> Lwt_unix.Closed then 286 | Lwt.catch 287 | (fun () -> Lwt_unix.close socket) 288 | (fun _exn -> Lwt.return_unit) 289 | else 290 | Lwt.return_unit); 291 | 292 | request_body 293 | end 294 | -------------------------------------------------------------------------------- /lib/reqd.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | type error = 35 | [ `Bad_request | `Bad_gateway | `Internal_server_error | `Exn of exn ] 36 | 37 | module Response_state = struct 38 | type t = 39 | | Waiting 40 | | Fixed of Response.t 41 | | Streaming of Response.t * Body.Writer.t 42 | end 43 | 44 | module Input_state = struct 45 | type t = 46 | | Ready 47 | | Complete 48 | end 49 | 50 | module Output_state = struct 51 | type t = 52 | | Waiting 53 | | Ready 54 | | Complete 55 | end 56 | 57 | type error_handler = 58 | ?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit 59 | 60 | module Writer = Serialize.Writer 61 | 62 | (* XXX(seliopou): The current design assumes that a new [Reqd.t] will be 63 | * allocated for each new request/response on a connection. This is wasteful, 64 | * as it creates garbage on persistent connections. A better approach would be 65 | * to allocate a single [Reqd.t] per connection and reuse it across 66 | * request/responses. This would allow a single [Faraday.t] to be allocated for 67 | * the body and reused. The [response_state] type could then be inlined into 68 | * the [Reqd.t] record, with dummy values occuping the fields for [response]. 69 | * Something like this: 70 | * 71 | * {[ 72 | * type 'handle t = 73 | * { mutable request : Request.t 74 | * ; mutable request_body : Response.Body.Reader.t 75 | * ; mutable response : Response.t (* Starts off as a dummy value, 76 | * * using [(==)] to identify it when 77 | * * necessary *) 78 | * ; mutable response_body : Response.Body.Writer.t 79 | * ; mutable persistent : bool 80 | * ; mutable response_state : [ `Waiting | `Started | `Streaming ] 81 | * } 82 | * ]} 83 | * 84 | * *) 85 | type t = 86 | { request : Request.t 87 | ; request_body : Body.Reader.t 88 | ; writer : Writer.t 89 | ; response_body_buffer : Bigstringaf.t 90 | ; error_handler : error_handler 91 | ; mutable persistent : bool 92 | ; mutable response_state : Response_state.t 93 | ; mutable error_code : [`Ok | error ] 94 | } 95 | 96 | let create error_handler request request_body writer response_body_buffer = 97 | { request 98 | ; request_body 99 | ; writer 100 | ; response_body_buffer 101 | ; error_handler 102 | ; persistent = Request.persistent_connection request 103 | ; response_state = Waiting 104 | ; error_code = `Ok 105 | } 106 | 107 | let request { request; _ } = request 108 | let request_body { request_body; _ } = request_body 109 | 110 | let response { response_state; _ } = 111 | match response_state with 112 | | Waiting -> None 113 | | Streaming (response, _) 114 | | Fixed response -> Some response 115 | 116 | let response_exn { response_state; _ } = 117 | match response_state with 118 | | Waiting -> failwith "httpaf.Reqd.response_exn: response has not started" 119 | | Streaming (response, _) 120 | | Fixed response -> response 121 | 122 | let respond_with_string t response str = 123 | if t.error_code <> `Ok then 124 | failwith "httpaf.Reqd.respond_with_string: invalid state, currently handling error"; 125 | match t.response_state with 126 | | Waiting -> 127 | (* XXX(seliopou): check response body length *) 128 | Writer.write_response t.writer response; 129 | Writer.write_string t.writer str; 130 | if t.persistent then 131 | t.persistent <- Response.persistent_connection response; 132 | t.response_state <- Fixed response; 133 | Writer.wakeup t.writer; 134 | | Streaming _ -> 135 | failwith "httpaf.Reqd.respond_with_string: response already started" 136 | | Fixed _ -> 137 | failwith "httpaf.Reqd.respond_with_string: response already complete" 138 | 139 | let respond_with_bigstring t response (bstr:Bigstringaf.t) = 140 | if t.error_code <> `Ok then 141 | failwith "httpaf.Reqd.respond_with_bigstring: invalid state, currently handling error"; 142 | match t.response_state with 143 | | Waiting -> 144 | (* XXX(seliopou): check response body length *) 145 | Writer.write_response t.writer response; 146 | Writer.schedule_bigstring t.writer bstr; 147 | if t.persistent then 148 | t.persistent <- Response.persistent_connection response; 149 | t.response_state <- Fixed response; 150 | Writer.wakeup t.writer; 151 | | Streaming _ -> 152 | failwith "httpaf.Reqd.respond_with_bigstring: response already started" 153 | | Fixed _ -> 154 | failwith "httpaf.Reqd.respond_with_bigstring: response already complete" 155 | 156 | let unsafe_respond_with_streaming ~flush_headers_immediately t response = 157 | match t.response_state with 158 | | Waiting -> 159 | let encoding = 160 | match Response.body_length ~request_method:t.request.meth response with 161 | | `Fixed _ | `Close_delimited | `Chunked as encoding -> encoding 162 | | `Error (`Bad_gateway | `Internal_server_error) -> 163 | failwith "httpaf.Reqd.respond_with_streaming: invalid response body length" 164 | in 165 | let response_body = 166 | Body.Writer.create t.response_body_buffer ~encoding ~when_ready_to_write:(fun () -> 167 | Writer.wakeup t.writer) 168 | in 169 | Writer.write_response t.writer response; 170 | if t.persistent then 171 | t.persistent <- Response.persistent_connection response; 172 | t.response_state <- Streaming (response, response_body); 173 | if flush_headers_immediately 174 | then Writer.wakeup t.writer; 175 | response_body 176 | | Streaming _ -> 177 | failwith "httpaf.Reqd.respond_with_streaming: response already started" 178 | | Fixed _ -> 179 | failwith "httpaf.Reqd.respond_with_streaming: response already complete" 180 | 181 | let respond_with_streaming ?(flush_headers_immediately=false) t response = 182 | if t.error_code <> `Ok then 183 | failwith "httpaf.Reqd.respond_with_streaming: invalid state, currently handling error"; 184 | unsafe_respond_with_streaming ~flush_headers_immediately t response 185 | 186 | let report_error t error = 187 | t.persistent <- false; 188 | Body.Reader.close t.request_body; 189 | match t.response_state, t.error_code with 190 | | Waiting, `Ok -> 191 | t.error_code <- (error :> [`Ok | error]); 192 | let status = 193 | match (error :> [error | Status.standard]) with 194 | | `Exn _ -> `Internal_server_error 195 | | #Status.standard as status -> status 196 | in 197 | t.error_handler ~request:t.request error (fun headers -> 198 | unsafe_respond_with_streaming ~flush_headers_immediately:true t 199 | (Response.create ~headers status)) 200 | | Waiting, `Exn _ -> 201 | (* XXX(seliopou): Decide what to do in this unlikely case. There is an 202 | * outstanding call to the [error_handler], but an intervening exception 203 | * has been reported as well. *) 204 | failwith "httpaf.Reqd.report_exn: NYI" 205 | | Streaming (_response, response_body), `Ok -> 206 | Body.Writer.close response_body 207 | | Streaming (_response, response_body), `Exn _ -> 208 | Body.Writer.close response_body; 209 | Writer.close_and_drain t.writer 210 | | (Fixed _ | Streaming _ | Waiting) , _ -> 211 | (* XXX(seliopou): Once additional logging support is added, log the error 212 | * in case it is not spurious. *) 213 | () 214 | 215 | let report_exn t exn = 216 | report_error t (`Exn exn) 217 | 218 | let try_with t f : (unit, exn) result = 219 | try f (); Ok () with exn -> report_exn t exn; Error exn 220 | 221 | (* Private API, not exposed to the user through httpaf.mli *) 222 | 223 | let close_request_body { request_body; _ } = 224 | Body.Reader.close request_body 225 | 226 | let error_code t = 227 | match t.error_code with 228 | | #error as error -> Some error 229 | | `Ok -> None 230 | 231 | let persistent_connection t = 232 | t.persistent 233 | 234 | let input_state t : Input_state.t = 235 | if Body.Reader.is_closed t.request_body 236 | then Complete 237 | else Ready 238 | ;; 239 | 240 | let output_state t : Output_state.t = 241 | match t.response_state with 242 | | Fixed _ -> Complete 243 | | Streaming (_, response_body) -> 244 | if Body.Writer.has_pending_output response_body 245 | then Ready 246 | else if Body.Writer.is_closed response_body 247 | then Complete 248 | else Waiting 249 | | Waiting -> Waiting 250 | ;; 251 | 252 | let flush_request_body t = 253 | if Body.Reader.has_pending_output t.request_body 254 | then try Body.Reader.execute_read t.request_body 255 | with exn -> report_exn t exn 256 | 257 | let flush_response_body t = 258 | match t.response_state with 259 | | Streaming (_, response_body) -> 260 | Body.Writer.transfer_to_writer response_body t.writer 261 | | _ -> () 262 | -------------------------------------------------------------------------------- /lib_test/test_client_connection.ml: -------------------------------------------------------------------------------- 1 | open Httpaf 2 | open Helpers 3 | open Client_connection 4 | 5 | let response_error_pp_hum fmt = function 6 | | `Malformed_response str -> 7 | Format.fprintf fmt "Malformed_response: %s" str 8 | | `Invalid_response_body_length resp -> 9 | Format.fprintf fmt "Invalid_response_body_length: %s" (response_to_string resp) 10 | | `Exn exn -> 11 | Format.fprintf fmt "Exn (%s)" (Printexc.to_string exn) 12 | ;; 13 | 14 | module Response = struct 15 | include Response 16 | 17 | let pp = pp_hum 18 | let equal x y = x = y 19 | end 20 | 21 | module Alcotest = struct 22 | include Alcotest 23 | 24 | let response_error = of_pp response_error_pp_hum 25 | end 26 | 27 | let feed_string t str = 28 | let len = String.length str in 29 | let input = Bigstringaf.of_string str ~off:0 ~len in 30 | read t input ~off:0 ~len 31 | 32 | let read_string t str = 33 | let c = feed_string t str in 34 | Alcotest.(check int) "read consumes all input" (String.length str) c; 35 | ;; 36 | 37 | let read_response t r = 38 | let response_string = response_to_string r in 39 | read_string t response_string 40 | ;; 41 | 42 | let reader_ready t = 43 | Alcotest.check read_operation "Reader is ready" 44 | `Read (next_read_operation t :> [`Close | `Read | `Yield]); 45 | ;; 46 | 47 | let reader_closed t = 48 | Alcotest.check read_operation "Reader is closed" 49 | `Close (next_read_operation t :> [`Close | `Read | `Yield]); 50 | ;; 51 | 52 | let write_string ?(msg="output written") t str = 53 | let len = String.length str in 54 | Alcotest.(check (option string)) msg 55 | (Some str) 56 | (next_write_operation t |> Write_operation.to_write_as_string); 57 | report_write_result t (`Ok len); 58 | ;; 59 | 60 | let write_request ?(msg="request written") t r = 61 | let request_string = request_to_string r in 62 | write_string ~msg t request_string 63 | ;; 64 | 65 | let writer_yielded t = 66 | Alcotest.check write_operation "Writer is in a yield state" 67 | `Yield (next_write_operation t); 68 | ;; 69 | 70 | let writer_closed t = 71 | Alcotest.check write_operation "Writer is closed" 72 | (`Close 0) (next_write_operation t); 73 | ;; 74 | 75 | let connection_is_shutdown t = 76 | Alcotest.check read_operation "Reader is closed" 77 | `Close (next_read_operation t :> [`Close | `Read | `Yield]); 78 | writer_closed t; 79 | ;; 80 | 81 | let default_response_handler expected_response response body = 82 | Alcotest.check (module Response) "expected response" expected_response response; 83 | let on_read _ ~off:_ ~len:_ = () in 84 | let on_eof () = () in 85 | Body.Reader.schedule_read body ~on_read ~on_eof; 86 | ;; 87 | 88 | let no_error_handler _ = assert false 89 | 90 | let test_get () = 91 | let request' = Request.create `GET "/" in 92 | let response = Response.create `OK in 93 | 94 | (* Single GET *) 95 | let body, t = 96 | request 97 | request' 98 | ~response_handler:(default_response_handler response) 99 | ~error_handler:no_error_handler 100 | in 101 | Body.Writer.close body; 102 | write_request t request'; 103 | writer_closed t; 104 | read_response t response; 105 | 106 | (* Single GET, response closes connection *) 107 | let response = Response.create `OK ~headers:Headers.connection_close in 108 | let body, t = 109 | request 110 | request' 111 | ~response_handler:(default_response_handler response) 112 | ~error_handler:no_error_handler 113 | in 114 | Body.Writer.close body; 115 | write_request t request'; 116 | read_response t response; 117 | let c = read_eof t Bigstringaf.empty ~off:0 ~len:0 in 118 | Alcotest.(check int) "read_eof with no input returns 0" 0 c; 119 | connection_is_shutdown t; 120 | 121 | (* Single GET, streaming body *) 122 | let response = Response.create `OK ~headers:Headers.encoding_chunked in 123 | let body, t = 124 | request 125 | request' 126 | ~response_handler:(default_response_handler response) 127 | ~error_handler:no_error_handler 128 | in 129 | Body.Writer.close body; 130 | write_request t request'; 131 | read_response t response; 132 | read_string t "d\r\nHello, world!\r\n0\r\n\r\n" 133 | ;; 134 | 135 | let test_send_streaming_body () = 136 | let request' = Request.create `GET "/" ~headers:Headers.encoding_chunked in 137 | let response = Response.create `OK ~headers:Headers.encoding_chunked in 138 | let body, t = 139 | request 140 | request' 141 | ~response_handler:(default_response_handler response) 142 | ~error_handler:no_error_handler 143 | in 144 | write_request t request'; 145 | read_response t response; 146 | Body.Writer.write_string body "hello"; 147 | write_string t "5\r\nhello\r\n"; 148 | Body.Writer.write_string body "world"; 149 | Body.Writer.close body; 150 | write_string t "5\r\nworld\r\n"; 151 | write_string t "0\r\n\r\n"; 152 | writer_closed t 153 | ;; 154 | 155 | let test_response_eof () = 156 | let request' = Request.create `GET "/" in 157 | let response = Response.create `OK in (* not actually writen to the channel *) 158 | 159 | let error_message = ref None in 160 | let body, t = 161 | request 162 | request' 163 | ~response_handler:(default_response_handler response) 164 | ~error_handler:(function 165 | | `Malformed_response msg -> error_message := Some msg 166 | | _ -> assert false) 167 | in 168 | Body.Writer.close body; 169 | write_request t request'; 170 | writer_closed t; 171 | reader_ready t; 172 | let c = read_eof t Bigstringaf.empty ~off:0 ~len:0 in 173 | Alcotest.(check int) "read_eof with no input returns 0" 0 c; 174 | connection_is_shutdown t; 175 | Alcotest.(check (option string)) "unexpected eof" 176 | (Some "unexpected eof") 177 | !error_message 178 | ;; 179 | 180 | let test_response_header_order () = 181 | let request' = Request.create `GET "/" in 182 | let headers = 183 | [ "a", "1" 184 | ; "b", "2" 185 | ; "c", "3" 186 | ] 187 | in 188 | let response = Response.create `OK ~headers:(Headers.of_list headers) in 189 | let received = ref None in 190 | let body, t = 191 | request 192 | request' 193 | ~response_handler:(fun response _ -> received := Some response) 194 | ~error_handler:no_error_handler 195 | in 196 | Body.Writer.close body; 197 | write_request t request'; 198 | writer_closed t; 199 | read_response t response; 200 | match !received with 201 | | None -> assert false 202 | | Some received -> 203 | Alcotest.(check (list (pair string string))) "headers are equal" 204 | headers (Headers.to_list received.headers); 205 | ;; 206 | 207 | let test_report_exn () = 208 | let request' = Request.create `GET "/" in 209 | let response = Response.create `OK in (* not actually writen to the channel *) 210 | 211 | let error_message = ref None in 212 | let body, t = 213 | request 214 | request' 215 | ~response_handler:(default_response_handler response) 216 | ~error_handler:(function 217 | | `Exn (Failure msg) -> error_message := Some msg 218 | | _ -> assert false) 219 | in 220 | Body.Writer.close body; 221 | write_request t request'; 222 | writer_closed t; 223 | reader_ready t; 224 | report_exn t (Failure "something went wrong"); 225 | connection_is_shutdown t; 226 | Alcotest.(check (option string)) "something went wrong" 227 | (Some "something went wrong") 228 | !error_message 229 | ;; 230 | 231 | let test_input_shrunk () = 232 | let request' = Request.create `GET "/" in 233 | let response = Response.create `OK in (* not actually writen to the channel *) 234 | 235 | let error_message = ref None in 236 | let body, t = 237 | request 238 | request' 239 | ~response_handler:(default_response_handler response) 240 | ~error_handler:(function 241 | | `Exn (Failure msg) -> error_message := Some msg 242 | | _ -> assert false) 243 | in 244 | Body.Writer.close body; 245 | write_request t request'; 246 | writer_closed t; 247 | reader_ready t; 248 | let c = feed_string t "HTTP/1.1 200 OK\r\nDate" in 249 | Alcotest.(check int) "read the status line" c 17; 250 | report_exn t (Failure "something went wrong"); 251 | connection_is_shutdown t; 252 | Alcotest.(check (option string)) "something went wrong" 253 | (Some "something went wrong") 254 | !error_message 255 | ;; 256 | 257 | let test_failed_response_parse () = 258 | let request' = Request.create `GET "/" in 259 | 260 | let test response bytes_read expected_error = 261 | let error = ref None in 262 | let body, t = 263 | request 264 | request' 265 | ~response_handler:(fun _ _ -> assert false) 266 | ~error_handler:(fun e -> error := Some e) 267 | in 268 | Body.Writer.close body; 269 | write_request t request'; 270 | writer_closed t; 271 | reader_ready t; 272 | let len = feed_string t response in 273 | Alcotest.(check int) "bytes read" len bytes_read; 274 | connection_is_shutdown t; 275 | Alcotest.(check (option response_error)) "Response error" 276 | (Some expected_error) !error; 277 | in 278 | 279 | test "HTTP/1.1 200\r\n\r\n" 12 (`Malformed_response ": char ' '"); 280 | 281 | let response = Response.create `OK ~headers:(Headers.encoding_fixed (-1)) in 282 | test (response_to_string response) 39 (`Invalid_response_body_length response); 283 | ;; 284 | 285 | let test_schedule_read_with_data_available () = 286 | let request' = Request.create `GET "/" in 287 | let response = Response.create `OK ~headers:(Headers.encoding_fixed 6) in 288 | 289 | let body = ref None in 290 | let response_handler response' body' = 291 | body := Some body'; 292 | Alcotest.check (module Response) "expected response" response response'; 293 | in 294 | let req_body, t = 295 | request request' ~response_handler ~error_handler:no_error_handler 296 | in 297 | Body.Writer.close req_body; 298 | write_request t request'; 299 | writer_closed t; 300 | read_response t response; 301 | 302 | let body = Option.get !body in 303 | let schedule_read expected = 304 | let did_read = ref false in 305 | Body.Reader.schedule_read body 306 | ~on_read:(fun buf ~off ~len -> 307 | let actual = Bigstringaf.substring buf ~off ~len in 308 | did_read := true; 309 | Alcotest.(check string) "Body" expected actual) 310 | ~on_eof:(fun () -> assert false); 311 | Alcotest.(check bool) "on_read called" true !did_read; 312 | in 313 | 314 | (* We get some data on the connection, but not the full response yet. *) 315 | read_string t "Hello"; 316 | 317 | (* Schedule a read when there is already data available. on_read should be called 318 | straight away, as who knows how long it'll be before more data arrives. *) 319 | schedule_read "Hello"; 320 | read_string t "!"; 321 | schedule_read "!"; 322 | let did_eof = ref false in 323 | Body.Reader.schedule_read body 324 | ~on_read:(fun _ ~off:_ ~len:_ -> Alcotest.fail "Expected eof") 325 | ~on_eof:(fun () -> did_eof := true); 326 | Alcotest.(check bool) "on_eof called" true !did_eof; 327 | reader_closed t; 328 | ;; 329 | 330 | let tests = 331 | [ "GET" , `Quick, test_get 332 | ; "send streaming body", `Quick, test_send_streaming_body 333 | ; "Response EOF", `Quick, test_response_eof 334 | ; "Response header order preserved", `Quick, test_response_header_order 335 | ; "report_exn" , `Quick, test_report_exn 336 | ; "input_shrunk", `Quick, test_input_shrunk 337 | ; "failed response parse", `Quick, test_failed_response_parse 338 | ; "schedule read with data available", `Quick, test_schedule_read_with_data_available 339 | ] 340 | -------------------------------------------------------------------------------- /lib/status.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | 35 | type informational = [ 36 | | `Continue 37 | | `Switching_protocols 38 | ] 39 | 40 | type successful = [ 41 | | `OK 42 | | `Created 43 | | `Accepted 44 | | `Non_authoritative_information 45 | | `No_content 46 | | `Reset_content 47 | | `Partial_content 48 | ] 49 | 50 | type redirection = [ 51 | | `Multiple_choices 52 | | `Moved_permanently 53 | | `Found 54 | | `See_other 55 | | `Not_modified 56 | | `Use_proxy 57 | | `Temporary_redirect 58 | ] 59 | 60 | type client_error = [ 61 | | `Bad_request 62 | | `Unauthorized 63 | | `Payment_required 64 | | `Forbidden 65 | | `Not_found 66 | | `Method_not_allowed 67 | | `Not_acceptable 68 | | `Proxy_authentication_required 69 | | `Request_timeout 70 | | `Conflict 71 | | `Gone 72 | | `Length_required 73 | | `Precondition_failed 74 | | `Payload_too_large 75 | | `Uri_too_long 76 | | `Unsupported_media_type 77 | | `Range_not_satisfiable 78 | | `Expectation_failed 79 | | `I_m_a_teapot 80 | | `Enhance_your_calm 81 | | `Upgrade_required 82 | ] 83 | 84 | type server_error = [ 85 | | `Internal_server_error 86 | | `Not_implemented 87 | | `Bad_gateway 88 | | `Service_unavailable 89 | | `Gateway_timeout 90 | | `Http_version_not_supported 91 | ] 92 | 93 | type standard = [ 94 | | informational 95 | | successful 96 | | redirection 97 | | client_error 98 | | server_error 99 | ] 100 | 101 | type t = [ 102 | | standard 103 | | `Code of int ] 104 | 105 | let default_reason_phrase = function 106 | (* Informational *) 107 | | `Continue -> "Continue" 108 | | `Switching_protocols -> "Switching Protocols" 109 | (* Successful *) 110 | | `OK -> "OK" 111 | | `Created -> "Created" 112 | | `Accepted -> "Accepted" 113 | | `Non_authoritative_information -> "Non-Authoritative Information" 114 | | `No_content -> "No Content" 115 | | `Reset_content -> "Reset Content" 116 | | `Partial_content -> "Partial Content" 117 | (* Redirection *) 118 | | `Multiple_choices -> "Multiple Choices" 119 | | `Moved_permanently -> "Moved Permanently" 120 | | `Found -> "Found" 121 | | `See_other -> "See Other" 122 | | `Not_modified -> "Not Modified" 123 | | `Use_proxy -> "Use Proxy" 124 | | `Temporary_redirect -> "Temporary Redirect" 125 | (* Client error *) 126 | | `Bad_request -> "Bad Request" 127 | | `Unauthorized -> "Unauthorized" 128 | | `Payment_required -> "Payment Required" 129 | | `Forbidden -> "Forbidden" 130 | | `Not_found -> "Not Found" 131 | | `Method_not_allowed -> "Method Not Allowed" 132 | | `Not_acceptable-> "Not Acceptable" 133 | | `Proxy_authentication_required -> "Proxy Authentication Required" 134 | | `Request_timeout -> "Request Timeout" 135 | | `Conflict -> "Conflict" 136 | | `Gone -> "Gone" 137 | | `Length_required -> "Length Required" 138 | | `Precondition_failed -> "Precondition Failed" 139 | | `Payload_too_large -> "Payload Too Large" 140 | | `Uri_too_long -> "URI Too Long" 141 | | `Unsupported_media_type -> "Unsupported Media Type" 142 | | `Range_not_satisfiable -> "Range Not Satisfiable" 143 | | `Expectation_failed -> "Expectation Failed" 144 | | `I_m_a_teapot -> "I'm a teapot" (* RFC 2342 *) 145 | | `Enhance_your_calm -> "Enhance Your Calm" 146 | | `Upgrade_required -> "Upgrade Required" 147 | (* Server error *) 148 | | `Internal_server_error -> "Internal Server Error" 149 | | `Not_implemented -> "Not Implemented" 150 | | `Bad_gateway -> "Bad Gateway" 151 | | `Service_unavailable-> "Service Unavailable" 152 | | `Gateway_timeout -> "Gateway Timeout" 153 | | `Http_version_not_supported -> "HTTP Version Not Supported" 154 | 155 | let to_code = function 156 | (* Informational *) 157 | | `Continue -> 100 158 | | `Switching_protocols -> 101 159 | (* Successful *) 160 | | `OK -> 200 161 | | `Created -> 201 162 | | `Accepted -> 202 163 | | `Non_authoritative_information -> 203 164 | | `No_content -> 204 165 | | `Reset_content -> 205 166 | | `Partial_content -> 206 167 | (* Redirection *) 168 | | `Multiple_choices -> 300 169 | | `Moved_permanently -> 301 170 | | `Found -> 302 171 | | `See_other -> 303 172 | | `Not_modified -> 304 173 | | `Use_proxy -> 305 174 | | `Temporary_redirect -> 307 175 | (* Client error *) 176 | | `Bad_request -> 400 177 | | `Unauthorized -> 401 178 | | `Payment_required -> 402 179 | | `Forbidden -> 403 180 | | `Not_found -> 404 181 | | `Method_not_allowed -> 405 182 | | `Not_acceptable -> 406 183 | | `Proxy_authentication_required -> 407 184 | | `Request_timeout -> 408 185 | | `Conflict -> 409 186 | | `Gone -> 410 187 | | `Length_required -> 411 188 | | `Precondition_failed -> 412 189 | | `Payload_too_large -> 413 190 | | `Uri_too_long -> 414 191 | | `Unsupported_media_type -> 415 192 | | `Range_not_satisfiable -> 416 193 | | `Expectation_failed -> 417 194 | | `I_m_a_teapot -> 418 195 | | `Enhance_your_calm -> 420 196 | | `Upgrade_required -> 426 197 | (* Server error *) 198 | | `Internal_server_error -> 500 199 | | `Not_implemented -> 501 200 | | `Bad_gateway -> 502 201 | | `Service_unavailable-> 503 202 | | `Gateway_timeout -> 504 203 | | `Http_version_not_supported -> 505 204 | | `Code c -> c 205 | 206 | let really_unsafe_of_code = function 207 | (* Informational *) 208 | | 100 -> `Continue 209 | | 101 -> `Switching_protocols 210 | (* Successful *) 211 | | 200 -> `OK 212 | | 201 -> `Created 213 | | 202 -> `Accepted 214 | | 203 -> `Non_authoritative_information 215 | | 204 -> `No_content 216 | | 205 -> `Reset_content 217 | | 206 -> `Partial_content 218 | (* Redirection *) 219 | | 300 -> `Multiple_choices 220 | | 301 -> `Moved_permanently 221 | | 302 -> `Found 222 | | 303 -> `See_other 223 | | 304 -> `Not_modified 224 | | 305 -> `Use_proxy 225 | | 307 -> `Temporary_redirect 226 | (* Client error *) 227 | | 400 -> `Bad_request 228 | | 401 -> `Unauthorized 229 | | 402 -> `Payment_required 230 | | 403 -> `Forbidden 231 | | 404 -> `Not_found 232 | | 405 -> `Method_not_allowed 233 | | 406 -> `Not_acceptable 234 | | 407 -> `Proxy_authentication_required 235 | | 408 -> `Request_timeout 236 | | 409 -> `Conflict 237 | | 410 -> `Gone 238 | | 411 -> `Length_required 239 | | 412 -> `Precondition_failed 240 | | 413 -> `Payload_too_large 241 | | 414 -> `Uri_too_long 242 | | 415 -> `Unsupported_media_type 243 | | 416 -> `Range_not_satisfiable 244 | | 417 -> `Expectation_failed 245 | | 418 -> `I_m_a_teapot 246 | | 420 -> `Enhance_your_calm 247 | | 426 -> `Upgrade_required 248 | (* Server error *) 249 | | 500 -> `Internal_server_error 250 | | 501 -> `Not_implemented 251 | | 502 -> `Bad_gateway 252 | | 503 -> `Service_unavailable 253 | | 504 -> `Gateway_timeout 254 | | 505 -> `Http_version_not_supported 255 | | c -> `Code c 256 | 257 | let unsafe_of_code c = 258 | match really_unsafe_of_code c with 259 | | `Code c -> 260 | if c < 0 261 | then failwith (Printf.sprintf "Status.unsafe_of_code: %d is negative" c) 262 | else `Code c 263 | | s -> s 264 | 265 | let of_code c = 266 | match really_unsafe_of_code c with 267 | | `Code c -> 268 | if c < 100 || c > 999 269 | then failwith (Printf.sprintf "Status.of_code: %d is not a three-digit number" c) 270 | else `Code c 271 | | s -> s 272 | 273 | let is_informational t = 274 | match t with 275 | | #informational -> true 276 | | `Code n -> n >= 100 && n <= 199 277 | | _ -> false 278 | 279 | let is_successful t = 280 | match t with 281 | | #successful -> true 282 | | `Code n -> n >= 200 && n <= 299 283 | | _ -> false 284 | 285 | let is_redirection t = 286 | match t with 287 | | #redirection -> true 288 | | `Code n -> n >= 300 && n <= 399 289 | | _ -> false 290 | 291 | let is_client_error t = 292 | match t with 293 | | #client_error -> true 294 | | `Code n -> n >= 400 && n <= 499 295 | | _ -> false 296 | 297 | let is_server_error t = 298 | match t with 299 | | #server_error -> true 300 | | `Code n -> n >= 500 && n <= 599 301 | | _ -> false 302 | 303 | let is_error t = 304 | is_client_error t || is_server_error t 305 | 306 | 307 | let to_string = function (* don't allocate *) 308 | (* Informational *) 309 | | `Continue -> "100" 310 | | `Switching_protocols -> "101" 311 | (* Successful *) 312 | | `OK -> "200" 313 | | `Created -> "201" 314 | | `Accepted -> "202" 315 | | `Non_authoritative_information -> "203" 316 | | `No_content -> "204" 317 | | `Reset_content -> "205" 318 | | `Partial_content -> "206" 319 | (* Redirection *) 320 | | `Multiple_choices -> "300" 321 | | `Moved_permanently -> "301" 322 | | `Found -> "302" 323 | | `See_other -> "303" 324 | | `Not_modified -> "304" 325 | | `Use_proxy -> "305" 326 | | `Temporary_redirect -> "307" 327 | (* Client error *) 328 | | `Bad_request -> "400" 329 | | `Unauthorized -> "401" 330 | | `Payment_required -> "402" 331 | | `Forbidden -> "403" 332 | | `Not_found -> "404" 333 | | `Method_not_allowed -> "405" 334 | | `Not_acceptable -> "406" 335 | | `Proxy_authentication_required -> "407" 336 | | `Request_timeout -> "408" 337 | | `Conflict -> "409" 338 | | `Gone -> "410" 339 | | `Length_required -> "411" 340 | | `Precondition_failed -> "412" 341 | | `Payload_too_large -> "413" 342 | | `Uri_too_long -> "414" 343 | | `Unsupported_media_type -> "415" 344 | | `Range_not_satisfiable -> "416" 345 | | `Expectation_failed -> "417" 346 | | `I_m_a_teapot -> "418" 347 | | `Enhance_your_calm -> "420" 348 | | `Upgrade_required -> "426" 349 | (* Server error *) 350 | | `Internal_server_error -> "500" 351 | | `Not_implemented -> "501" 352 | | `Bad_gateway -> "502" 353 | | `Service_unavailable-> "503" 354 | | `Gateway_timeout -> "504" 355 | | `Http_version_not_supported -> "505" 356 | | `Code c -> string_of_int c (* except for this *) 357 | 358 | let of_string x = 359 | of_code (int_of_string x) 360 | 361 | let pp_hum fmt t = 362 | Format.fprintf fmt "%u" (to_code t) 363 | -------------------------------------------------------------------------------- /lib/server_connection.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | 35 | module Queue = struct 36 | include Queue 37 | 38 | let peek_exn = peek 39 | 40 | let peek t = 41 | if is_empty t 42 | then None 43 | else Some (peek_exn t) 44 | end 45 | 46 | module Reader = Parse.Reader 47 | module Writer = Serialize.Writer 48 | 49 | 50 | type request_handler = Reqd.t -> unit 51 | 52 | type error = 53 | [ `Bad_gateway | `Bad_request | `Internal_server_error | `Exn of exn] 54 | 55 | type error_handler = 56 | ?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit 57 | 58 | type t = 59 | { reader : Reader.request 60 | ; writer : Writer.t 61 | ; response_body_buffer : Bigstringaf.t 62 | ; request_handler : request_handler 63 | ; error_handler : error_handler 64 | ; request_queue : Reqd.t Queue.t 65 | (* invariant: If [request_queue] is not empty, then the head of the queue 66 | has already had [request_handler] called on it. *) 67 | ; mutable is_errored : bool 68 | (* if there is a parse or connection error, we invoke the [error_handler] 69 | and set [is_errored] to indicate we should not close the writer yet. *) 70 | ; mutable wakeup_reader : Optional_thunk.t 71 | } 72 | 73 | let is_closed t = 74 | Reader.is_closed t.reader && Writer.is_closed t.writer 75 | 76 | let is_active t = 77 | not (Queue.is_empty t.request_queue) 78 | 79 | let current_reqd_exn t = 80 | Queue.peek_exn t.request_queue 81 | 82 | let yield_reader t k = 83 | if is_closed t 84 | then failwith "yield_reader on closed conn" 85 | else if Optional_thunk.is_some t.wakeup_reader 86 | then failwith "yield_reader: only one callback can be registered at a time" 87 | else t.wakeup_reader <- Optional_thunk.some k 88 | ;; 89 | 90 | let wakeup_reader t = 91 | let f = t.wakeup_reader in 92 | t.wakeup_reader <- Optional_thunk.none; 93 | Optional_thunk.call_if_some f 94 | ;; 95 | 96 | let yield_writer t k = 97 | if Writer.is_closed t.writer 98 | then k () 99 | else Writer.on_wakeup t.writer k 100 | ;; 101 | 102 | let wakeup_writer t = Writer.wakeup t.writer 103 | 104 | let default_error_handler ?request:_ error handle = 105 | let message = 106 | match error with 107 | | `Exn exn -> Printexc.to_string exn 108 | | (#Status.client_error | #Status.server_error) as error -> Status.to_string error 109 | in 110 | let body = handle Headers.empty in 111 | Body.Writer.write_string body message; 112 | Body.Writer.close body 113 | ;; 114 | 115 | let create ?(config=Config.default) ?(error_handler=default_error_handler) request_handler = 116 | let 117 | { Config 118 | . response_buffer_size 119 | ; response_body_buffer_size 120 | ; _ } = config 121 | in 122 | let writer = Writer.create ~buffer_size:response_buffer_size () in 123 | let request_queue = Queue.create () in 124 | let response_body_buffer = Bigstringaf.create response_body_buffer_size in 125 | let handler request request_body = 126 | let reqd = 127 | Reqd.create error_handler request request_body writer response_body_buffer 128 | in 129 | Queue.push reqd request_queue; 130 | in 131 | { reader = Reader.request handler 132 | ; writer 133 | ; response_body_buffer 134 | ; request_handler = request_handler 135 | ; error_handler = error_handler 136 | ; request_queue 137 | ; is_errored = false 138 | ; wakeup_reader = Optional_thunk.none 139 | } 140 | 141 | let shutdown_reader t = 142 | if is_active t 143 | then Reqd.close_request_body (current_reqd_exn t); 144 | Reader.force_close t.reader; 145 | wakeup_reader t 146 | 147 | let shutdown_writer t = 148 | if is_active t then ( 149 | let reqd = current_reqd_exn t in 150 | (* XXX(dpatti): I'm not sure I understand why we close the *request* body 151 | here. Maybe we can write a test such that removing this line causes it to 152 | fail? *) 153 | Reqd.close_request_body reqd; 154 | Reqd.flush_response_body reqd); 155 | Writer.close t.writer; 156 | wakeup_writer t 157 | 158 | let error_code t = 159 | if is_active t 160 | then Reqd.error_code (current_reqd_exn t) 161 | else None 162 | 163 | let shutdown t = 164 | shutdown_reader t; 165 | shutdown_writer t 166 | 167 | let set_error_and_handle ?request t error = 168 | if is_active t then begin 169 | assert (request = None); 170 | let reqd = current_reqd_exn t in 171 | Reqd.report_error reqd error 172 | end else begin 173 | t.is_errored <- true; 174 | let status = 175 | match (error :> [error | Status.standard]) with 176 | | `Exn _ -> `Internal_server_error 177 | | #Status.standard as status -> status 178 | in 179 | shutdown_reader t; 180 | let writer = t.writer in 181 | t.error_handler ?request error (fun headers -> 182 | let response = Response.create ~headers status in 183 | Writer.write_response writer response; 184 | let encoding = 185 | (* If we haven't parsed the request method, just use GET as a standard 186 | placeholder. The method is only used for edge cases, like HEAD or 187 | CONNECT. *) 188 | let request_method = 189 | match request with 190 | | None -> `GET 191 | | Some request -> request.meth 192 | in 193 | match Response.body_length ~request_method response with 194 | | `Fixed _ | `Close_delimited as encoding -> encoding 195 | | `Chunked -> 196 | (* XXX(dpatti): Because we pass the writer's faraday directly to the 197 | new body, we don't write the chunked encoding. A client won't be 198 | able to interpret this. *) 199 | `Close_delimited 200 | | `Error (`Bad_gateway | `Internal_server_error) -> 201 | failwith "httpaf.Server_connection.error_handler: invalid response body length" 202 | in 203 | Body.Writer.of_faraday (Writer.faraday writer) ~encoding 204 | ~when_ready_to_write:(fun () -> Writer.wakeup writer)); 205 | end 206 | 207 | let report_exn t exn = 208 | set_error_and_handle t (`Exn exn) 209 | 210 | let advance_request_queue t = 211 | ignore (Queue.take t.request_queue); 212 | if not (Queue.is_empty t.request_queue) 213 | then t.request_handler (Queue.peek_exn t.request_queue); 214 | ;; 215 | 216 | let rec _next_read_operation t = 217 | if not (is_active t) 218 | then ( 219 | (* If the request queue is empty, there is no connection error, and the 220 | reader is closed, then we can assume that no more user code will be able 221 | to write. *) 222 | if Reader.is_closed t.reader && not t.is_errored 223 | then shutdown_writer t; 224 | Reader.next t.reader 225 | ) else ( 226 | let reqd = current_reqd_exn t in 227 | match Reqd.input_state reqd with 228 | | Ready -> Reader.next t.reader 229 | | Complete -> _final_read_operation_for t reqd 230 | ) 231 | 232 | and _final_read_operation_for t reqd = 233 | if not (Reqd.persistent_connection reqd) then ( 234 | shutdown_reader t; 235 | Reader.next t.reader; 236 | ) else ( 237 | match Reqd.output_state reqd with 238 | | Waiting | Ready -> 239 | (* XXX(dpatti): This is a way in which the reader and writer are not 240 | parallel -- we tell the writer when it needs to yield but the reader is 241 | always asking for more data. This is the only branch in either 242 | operation function that does not return `(Reader|Writer).next`, which 243 | means there are surprising states you can get into. For example, we ask 244 | the runtime to yield but then raise when it tries to because the reader 245 | is closed. I don't think checking `is_closed` here makes sense 246 | semantically, but I don't think checking it in `_next_read_operation` 247 | makes sense either. I chose here so I could describe why. *) 248 | if Reader.is_closed t.reader 249 | then Reader.next t.reader 250 | else `Yield 251 | | Complete -> 252 | advance_request_queue t; 253 | _next_read_operation t; 254 | ) 255 | ;; 256 | 257 | let next_read_operation t = 258 | match _next_read_operation t with 259 | | `Error (`Parse _) -> set_error_and_handle t `Bad_request; `Close 260 | | `Error (`Bad_request request) -> set_error_and_handle ~request t `Bad_request; `Close 261 | | (`Read | `Yield | `Close) as operation -> operation 262 | 263 | let rec read_with_more t bs ~off ~len more = 264 | let call_handler = Queue.is_empty t.request_queue in 265 | let consumed = Reader.read_with_more t.reader bs ~off ~len more in 266 | if is_active t 267 | then ( 268 | let reqd = current_reqd_exn t in 269 | if call_handler 270 | then t.request_handler reqd; 271 | Reqd.flush_request_body reqd; 272 | ); 273 | (* Keep consuming input as long as progress is made and data is 274 | available, in case multiple requests were received at once. *) 275 | if consumed > 0 && consumed < len then 276 | let off = off + consumed 277 | and len = len - consumed in 278 | consumed + read_with_more t bs ~off ~len more 279 | else 280 | consumed 281 | ;; 282 | 283 | let read t bs ~off ~len = 284 | read_with_more t bs ~off ~len Incomplete 285 | 286 | let read_eof t bs ~off ~len = 287 | read_with_more t bs ~off ~len Complete 288 | 289 | let rec _next_write_operation t = 290 | if not (is_active t) 291 | then Writer.next t.writer 292 | else ( 293 | let reqd = current_reqd_exn t in 294 | match Reqd.output_state reqd with 295 | | Waiting -> Writer.next t.writer 296 | | Ready -> 297 | Reqd.flush_response_body reqd; 298 | Writer.next t.writer 299 | | Complete -> _final_write_operation_for t reqd 300 | ) 301 | 302 | and _final_write_operation_for t reqd = 303 | let next = 304 | if not (Reqd.persistent_connection reqd) then ( 305 | shutdown_writer t; 306 | Writer.next t.writer; 307 | ) else ( 308 | match Reqd.input_state reqd with 309 | | Ready -> Writer.next t.writer; 310 | | Complete -> 311 | advance_request_queue t; 312 | _next_write_operation t; 313 | ) 314 | in 315 | (* The only reason the reader yields is to wait for the writer, so we need to 316 | notify it that we've completed. *) 317 | wakeup_reader t; 318 | next 319 | ;; 320 | 321 | let next_write_operation t = _next_write_operation t 322 | 323 | let report_write_result t result = 324 | Writer.report_result t.writer result 325 | -------------------------------------------------------------------------------- /lib/parse.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2016 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | 35 | include Angstrom 36 | 37 | module P = struct 38 | let is_space = 39 | function | ' ' | '\t' -> true | _ -> false 40 | 41 | let is_cr = 42 | function | '\r' -> true | _ -> false 43 | 44 | let is_space_or_colon = 45 | function | ' ' | '\t' | ':' -> true | _ -> false 46 | 47 | let is_hex = 48 | function | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false 49 | 50 | let is_digit = 51 | function '0' .. '9' -> true | _ -> false 52 | 53 | let is_separator = 54 | function 55 | | ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"' 56 | | '/' | '[' | ']' | '?' | '=' | '{' | '}' | ' ' | '\t' -> true 57 | | _ -> false 58 | 59 | let is_token = 60 | (* The commented-out ' ' and '\t' are not necessary because of the range at 61 | * the top of the match. *) 62 | function 63 | | '\000' .. '\031' | '\127' 64 | | ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"' 65 | | '/' | '[' | ']' | '?' | '=' | '{' | '}' (* | ' ' | '\t' *) -> false 66 | | _ -> true 67 | end 68 | 69 | let unit = return () 70 | let token = take_while1 P.is_token 71 | let spaces = skip_while P.is_space 72 | 73 | let digit = 74 | satisfy P.is_digit 75 | >>| function 76 | | '0' -> 0 | '1' -> 1 | '2' -> 2 | '3' -> 3 | '4' -> 4 | '5' -> 5 77 | | '6' -> 6 | '7' -> 7 | '8' -> 8 | '9' -> 9 | _ -> assert false 78 | 79 | let eol = string "\r\n" "eol" 80 | let hex str = 81 | try return (Int64.of_string ("0x" ^ str)) with _ -> fail "hex" 82 | let skip_line = take_till P.is_cr *> eol 83 | 84 | let version = 85 | string "HTTP/" *> 86 | lift2 (fun major minor -> { Version.major; minor }) 87 | (digit <* char '.') 88 | digit 89 | 90 | let header = 91 | (* From RFC7230§3.2.4: 92 | 93 | "No whitespace is allowed between the header field-name and colon. In 94 | the past, differences in the handling of such whitespace have led to 95 | security vulnerabilities in request routing and response handling. A 96 | server MUST reject any received request message that contains whitespace 97 | between a header field-name and colon with a response code of 400 (Bad 98 | Request). A proxy MUST remove any such whitespace from a response 99 | message before forwarding the message downstream." 100 | 101 | This can be detected by checking the message and marks in a parse failure, 102 | which should look like this when serialized "... > header > :". *) 103 | lift2 (fun key value -> (key, value)) 104 | (take_till P.is_space_or_colon <* char ':' <* spaces) 105 | (take_till P.is_cr <* eol >>| String.trim) 106 | "header" 107 | 108 | let headers = 109 | let cons x xs = x :: xs in 110 | fix (fun headers -> 111 | let _emp = return [] in 112 | let _rec = lift2 cons header headers in 113 | peek_char_fail 114 | >>= function 115 | | '\r' -> _emp 116 | | _ -> _rec) 117 | >>| Headers.of_list 118 | 119 | let request = 120 | let meth = take_till P.is_space >>| Method.of_string in 121 | lift4 (fun meth target version headers -> 122 | Request.create ~version ~headers meth target) 123 | (meth <* char ' ') 124 | (take_till P.is_space <* char ' ') 125 | (version <* eol <* commit) 126 | (headers <* eol) 127 | 128 | let response = 129 | let status = 130 | take_while P.is_digit 131 | >>= fun str -> 132 | if String.length str = 0 133 | then fail "status-code empty" 134 | else ( 135 | if String.length str > 3 136 | then fail (Printf.sprintf "status-code too long: %S" str) 137 | else return (Status.of_string str)) 138 | in 139 | lift4 (fun version status reason headers -> 140 | Response.create ~reason ~version ~headers status) 141 | (version <* char ' ') 142 | (status <* char ' ') 143 | (take_till P.is_cr <* eol <* commit) 144 | (headers <* eol) 145 | 146 | let finish body = 147 | Body.Reader.close body; 148 | commit 149 | 150 | let schedule_size body n = 151 | let faraday = Body.Reader.unsafe_faraday body in 152 | (* XXX(seliopou): performance regression due to switching to a single output 153 | * format in Farady. Once a specialized operation is exposed to avoid the 154 | * intemediate copy, this should be back to the original performance. *) 155 | begin if Faraday.is_closed faraday 156 | then advance n 157 | else take n >>| fun s -> Faraday.write_string faraday s 158 | end *> commit 159 | 160 | let body ~encoding body = 161 | let rec fixed n ~unexpected = 162 | if n = 0L 163 | then unit 164 | else 165 | at_end_of_input 166 | >>= function 167 | | true -> 168 | finish body *> fail unexpected 169 | | false -> 170 | available >>= fun m -> 171 | let m' = Int64.(min (of_int m) n) in 172 | let n' = Int64.sub n m' in 173 | schedule_size body (Int64.to_int m') >>= fun () -> fixed n' ~unexpected 174 | in 175 | match encoding with 176 | | `Fixed n -> 177 | fixed n ~unexpected:"expected more from fixed body" 178 | >>= fun () -> finish body 179 | | `Chunked -> 180 | (* XXX(seliopou): The [eol] in this parser should really parse a collection 181 | * of "chunk extensions", as defined in RFC7230§4.1. These do not show up 182 | * in the wild very frequently, and the httpaf API has no way of exposing 183 | * them to the suer, so for now the parser does not attempt to recognize 184 | * them. This means that any chunked messages that contain chunk extensions 185 | * will fail to parse. *) 186 | fix (fun p -> 187 | let _hex = 188 | (take_while1 P.is_hex >>= fun size -> hex size) 189 | (* swallows chunk-ext, if present, and CRLF *) 190 | <* (eol *> commit) 191 | in 192 | _hex >>= fun size -> 193 | if size = 0L 194 | then eol >>= fun _eol -> finish body 195 | else fixed size ~unexpected:"expected more from body chunk" *> eol *> p) 196 | | `Close_delimited -> 197 | fix (fun p -> 198 | let _rec = (available >>= fun n -> schedule_size body n) *> p in 199 | at_end_of_input 200 | >>= function 201 | | true -> finish body 202 | | false -> _rec) 203 | 204 | module Reader = struct 205 | module AU = Angstrom.Unbuffered 206 | 207 | type request_error = [ 208 | | `Bad_request of Request.t 209 | | `Parse of string list * string ] 210 | 211 | type response_error = [ 212 | | `Invalid_response_body_length of Response.t 213 | | `Parse of string list * string ] 214 | 215 | type 'error parse_state = 216 | | Done 217 | | Fail of 'error 218 | | Partial of (Bigstringaf.t -> off:int -> len:int -> AU.more -> (unit, 'error) result AU.state) 219 | 220 | type 'error t = 221 | { parser : (unit, 'error) result Angstrom.t 222 | ; mutable parse_state : 'error parse_state 223 | (* The state of the parse for the current request *) 224 | ; mutable closed : bool 225 | (* Whether the input source has left the building, indicating that no 226 | * further input will be received. *) 227 | } 228 | 229 | type request = request_error t 230 | type response = response_error t 231 | 232 | let create parser = 233 | { parser 234 | ; parse_state = Done 235 | ; closed = false 236 | } 237 | 238 | let ok = return (Ok ()) 239 | 240 | let request handler = 241 | let parser = 242 | request <* commit >>= fun request -> 243 | match Request.body_length request with 244 | | `Error `Bad_request -> return (Error (`Bad_request request)) 245 | | `Fixed 0L -> 246 | handler request Body.Reader.empty; 247 | ok 248 | | `Fixed _ | `Chunked as encoding -> 249 | let request_body = Body.Reader.create Bigstringaf.empty in 250 | handler request request_body; 251 | body ~encoding request_body *> ok 252 | in 253 | create parser 254 | 255 | let response ~request_method handler = 256 | let parser = 257 | response <* commit >>= fun response -> 258 | let proxy = false in 259 | match Response.body_length ~request_method response with 260 | | `Error `Bad_gateway -> assert (not proxy); assert false 261 | | `Error `Internal_server_error -> return (Error (`Invalid_response_body_length response)) 262 | | `Fixed 0L -> 263 | handler response Body.Reader.empty; 264 | ok 265 | | `Fixed _ | `Chunked | `Close_delimited as encoding -> 266 | (* We do not trust the length provided in the [`Fixed] case, as the 267 | client could DOS easily. *) 268 | let response_body = Body.Reader.create Bigstringaf.empty in 269 | handler response response_body; 270 | body ~encoding response_body *> ok 271 | in 272 | create parser 273 | ;; 274 | 275 | 276 | let is_closed t = 277 | t.closed 278 | 279 | let transition t state = 280 | match state with 281 | | AU.Done(consumed, Ok ()) -> 282 | t.parse_state <- Done; 283 | consumed 284 | | AU.Done(consumed, Error error) -> 285 | t.parse_state <- Fail error; 286 | consumed 287 | | AU.Fail(consumed, marks, msg) -> 288 | t.parse_state <- Fail (`Parse(marks, msg)); 289 | consumed 290 | | AU.Partial { committed; continue } -> 291 | t.parse_state <- Partial continue; 292 | committed 293 | and start t state = 294 | match state with 295 | | AU.Done _ -> failwith "httpaf.Parse.unable to start parser" 296 | | AU.Fail(0, marks, msg) -> 297 | t.parse_state <- Fail (`Parse(marks, msg)) 298 | | AU.Partial { committed = 0; continue } -> 299 | t.parse_state <- Partial continue 300 | | _ -> assert false 301 | ;; 302 | 303 | let rec read_with_more t bs ~off ~len more = 304 | let consumed = 305 | match t.parse_state with 306 | | Fail _ -> 0 307 | (* Don't feed empty input when we're at a request boundary *) 308 | | Done when len = 0 -> 0 309 | | Done -> 310 | start t (AU.parse t.parser); 311 | read_with_more t bs ~off ~len more; 312 | | Partial continue -> 313 | transition t (continue bs more ~off ~len) 314 | in 315 | begin match more with 316 | | Complete when consumed = len -> t.closed <- true; 317 | | Complete | Incomplete -> () 318 | end; 319 | consumed; 320 | ;; 321 | 322 | let force_close t = 323 | t.closed <- true; 324 | ;; 325 | 326 | let next t = 327 | match t.parse_state with 328 | | Fail err -> `Error err 329 | | Done | Partial _ -> 330 | if t.closed 331 | then `Close 332 | else `Read 333 | ;; 334 | end 335 | -------------------------------------------------------------------------------- /lib/httpaf.mli: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2017 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | (** Http/af is a high-performance, memory-efficient, and scalable web server 35 | for OCaml. It implements the HTTP 1.1 specification with respect to 36 | parsing, serialization, and connection pipelining. For compatibility, 37 | http/af respects the imperatives of the [Server_connection] header when handling 38 | HTTP 1.0 connections. 39 | 40 | To use this library effectively, the user must be familiar with the HTTP 41 | 1.1 specification, and the basic principles of memory management and 42 | vectorized IO. *) 43 | 44 | (** {2 Basic HTTP Types} *) 45 | 46 | 47 | (** Protocol Version 48 | 49 | HTTP uses a "." numbering scheme to indicate versions of the 50 | protocol. The protocol version as a whole indicates the sender's conformance 51 | with the set of requirements laid out in that version's corresponding 52 | specification of HTTP. 53 | 54 | See {{:https://tools.ietf.org/html/rfc7230#section-2.6} RFC7230§2.6} for 55 | more details. *) 56 | module Version : sig 57 | type t = 58 | { major : int (** The major protocol number. *) 59 | ; minor : int (** The minor protocol number. *) 60 | } 61 | 62 | val compare : t -> t -> int 63 | 64 | val to_string : t -> string 65 | val of_string : string -> t 66 | 67 | val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] 68 | end 69 | 70 | 71 | (** Request Method 72 | 73 | The request method token is the primary source of request semantics; 74 | it indicates the purpose for which the client has made this request 75 | and what is expected by the client as a successful result. 76 | 77 | See {{:https://tools.ietf.org/html/rfc7231#section-4} RFC7231§4} for more 78 | details. *) 79 | module Method : sig 80 | type standard = [ 81 | | `GET 82 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.1} RFC7231§4.3.1}. Safe, Cacheable. *) 83 | | `HEAD 84 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.2} RFC7231§4.3.2}. Safe, Cacheable. *) 85 | | `POST 86 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.3} RFC7231§4.3.3}. Cacheable. *) 87 | | `PUT 88 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.4} RFC7231§4.3.4}. Idempotent. *) 89 | | `DELETE 90 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.5} RFC7231§4.3.5}. Idempotent. *) 91 | | `CONNECT 92 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.6} RFC7231§4.3.6}. *) 93 | | `OPTIONS 94 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.7} RFC7231§4.3.7}. Safe.*) 95 | | `TRACE 96 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.8} RFC7231§4.3.8}. Safe.*) 97 | ] 98 | 99 | type t = [ 100 | | standard 101 | | `Other of string 102 | (** Methods defined outside of RFC7231, or custom methods. *) 103 | ] 104 | 105 | val is_safe : standard -> bool 106 | (** Request methods are considered "safe" if their defined semantics are 107 | essentially read-only; i.e., the client does not request, and does not 108 | expect, any state change on the origin server as a result of applying a 109 | safe method to a target resource. Likewise, reasonable use of a safe 110 | method is not expected to cause any harm, loss of property, or unusual 111 | burden on the origin server. 112 | 113 | See {{:https://tools.ietf.org/html/rfc7231#section-4.2.1} RFC7231§4.2.1} 114 | for more details. *) 115 | 116 | val is_cacheable : standard -> bool 117 | (** Request methods can be defined as "cacheable" to indicate that responses 118 | to them are allowed to be stored for future reuse. 119 | 120 | See {{:https://tools.ietf.org/html/rfc7234} RFC7234} for more details. *) 121 | 122 | val is_idempotent : standard -> bool 123 | (** A request method is considered "idempotent" if the intended effect on 124 | the server of multiple identical requests with that method is the same as 125 | the effect for a single such request. Of the request methods defined by 126 | this specification, PUT, DELETE, and safe request methods are idempotent. 127 | 128 | See {{:https://tools.ietf.org/html/rfc7231#section-4.2.2} RFC7231§4.2.2} 129 | for more details. *) 130 | 131 | val to_string : t -> string 132 | val of_string : string -> t 133 | 134 | val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] 135 | end 136 | 137 | 138 | (** Response Status Codes 139 | 140 | The status-code element is a three-digit integer code giving the result of 141 | the attempt to understand and satisfy the request. 142 | 143 | See {{:https://tools.ietf.org/html/rfc7231#section-6} RFC7231§6} for more 144 | details. *) 145 | module Status : sig 146 | type informational = [ 147 | | `Continue 148 | | `Switching_protocols 149 | ] 150 | (** The 1xx (Informational) class of status code indicates an interim 151 | response for communicating connection status or request progress 152 | prior to completing the requested action and sending a final 153 | response. 154 | 155 | See {{:https://tools.ietf.org/html/rfc7231#section-6.2} RFC7231§6.2} 156 | for more details. *) 157 | 158 | type successful = [ 159 | | `OK 160 | | `Created 161 | | `Accepted 162 | | `Non_authoritative_information 163 | | `No_content 164 | | `Reset_content 165 | | `Partial_content 166 | ] 167 | (** The 2xx (Successful) class of status code indicates that the client's 168 | request was successfully received, understood, and accepted. 169 | 170 | See {{:https://tools.ietf.org/html/rfc7231#section-6.3} RFC7231§6.3} 171 | for more details. *) 172 | 173 | type redirection = [ 174 | | `Multiple_choices 175 | | `Moved_permanently 176 | | `Found 177 | | `See_other 178 | | `Not_modified 179 | | `Use_proxy 180 | | `Temporary_redirect 181 | ] 182 | (** The 3xx (Redirection) class of status code indicates that further 183 | action needs to be taken by the user agent in order to fulfill the 184 | request. 185 | 186 | See {{:https://tools.ietf.org/html/rfc7231#section-6.4} RFC7231§6.4} for 187 | more details. *) 188 | 189 | type client_error = [ 190 | | `Bad_request 191 | | `Unauthorized 192 | | `Payment_required 193 | | `Forbidden 194 | | `Not_found 195 | | `Method_not_allowed 196 | | `Not_acceptable 197 | | `Proxy_authentication_required 198 | | `Request_timeout 199 | | `Conflict 200 | | `Gone 201 | | `Length_required 202 | | `Precondition_failed 203 | | `Payload_too_large 204 | | `Uri_too_long 205 | | `Unsupported_media_type 206 | | `Range_not_satisfiable 207 | | `Expectation_failed 208 | | `Upgrade_required 209 | | `I_m_a_teapot 210 | | `Enhance_your_calm 211 | ] 212 | (** The 4xx (Client Error) class of status code indicates that the client 213 | seems to have erred. 214 | 215 | See {{:https://tools.ietf.org/html/rfc7231#section-6.5} RFC7231§6.5} for 216 | more details. *) 217 | 218 | type server_error = [ 219 | | `Internal_server_error 220 | | `Not_implemented 221 | | `Bad_gateway 222 | | `Service_unavailable 223 | | `Gateway_timeout 224 | | `Http_version_not_supported 225 | ] 226 | (** The 5xx (Server Error) class of status code indicates that the server is 227 | aware that it has erred or is incapable of performing the requested 228 | method. 229 | 230 | See {{:https://tools.ietf.org/html/rfc7231#section-6.6} RFC7231§6.6} for 231 | more details. *) 232 | 233 | type standard = [ 234 | | informational 235 | | successful 236 | | redirection 237 | | client_error 238 | | server_error 239 | ] 240 | (** The status codes defined in the HTTP 1.1 RFCs *) 241 | 242 | type t = [ 243 | | standard 244 | | `Code of int ] 245 | (** The standard codes along with support for custom codes. *) 246 | 247 | val default_reason_phrase : standard -> string 248 | (** [default_reason_phrase standard] is the example reason phrase provided 249 | by RFC7231 for the [standard] status code. The RFC allows servers to use 250 | reason phrases besides these in responses. *) 251 | 252 | val to_code : t -> int 253 | (** [to_code t] is the integer representation of [t]. *) 254 | 255 | val of_code : int -> t 256 | (** [of_code i] is the [t] representation of [i]. [of_code] raises [Failure] 257 | if [i] is not a positive three-digit number. *) 258 | 259 | val unsafe_of_code : int -> t 260 | (** [unsafe_of_code i] is equivalent to [of_code i], except it accepts any 261 | positive code, regardless of the number of digits it has. On negative 262 | codes, it will still raise [Failure]. *) 263 | 264 | val is_informational : t -> bool 265 | (** [is_informational t] is true iff [t] belongs to the Informational class 266 | of status codes. *) 267 | 268 | val is_successful : t -> bool 269 | (** [is_successful t] is true iff [t] belongs to the Successful class of 270 | status codes. *) 271 | 272 | val is_redirection : t -> bool 273 | (** [is_redirection t] is true iff [t] belongs to the Redirection class of 274 | status codes. *) 275 | 276 | val is_client_error : t -> bool 277 | (** [is_client_error t] is true iff [t] belongs to the Client Error class of 278 | status codes. *) 279 | 280 | val is_server_error : t -> bool 281 | (** [is_server_error t] is true iff [t] belongs to the Server Error class of 282 | status codes. *) 283 | 284 | val is_error : t -> bool 285 | (** [is_error t] is true iff [t] belongs to the Client Error or Server Error 286 | class of status codes. *) 287 | 288 | val to_string : t -> string 289 | val of_string : string -> t 290 | 291 | val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] 292 | end 293 | 294 | 295 | (** Header Fields 296 | 297 | Each header field consists of a case-insensitive {b field name} and a {b 298 | field value}. The order in which header fields {i with differing field 299 | names} are received is not significant. However, it is good practice to 300 | send header fields that contain control data first so that implementations 301 | can decide when not to handle a message as early as possible. 302 | 303 | A sender MUST NOT generate multiple header fields with the same field name 304 | in a message unless either the entire field value for that header field is 305 | defined as a comma-separated list or the header field is a well-known 306 | exception, e.g., [Set-Cookie]. 307 | 308 | A recipient MAY combine multiple header fields with the same field name 309 | into one "field-name: field-value" pair, without changing the semantics of 310 | the message, by appending each subsequent field value to the combined field 311 | value in order, separated by a comma. {i The order in which header fields 312 | with the same field name are received is therefore significant to the 313 | interpretation of the combined field value}; a proxy MUST NOT change the 314 | order of these field values when forwarding a message. 315 | 316 | {i Note.} Unless otherwise specified, all operations preserve header field 317 | order and all reference to equality on names is assumed to be 318 | case-insensitive. 319 | 320 | See {{:https://tools.ietf.org/html/rfc7230#section-3.2} RFC7230§3.2} for 321 | more details. *) 322 | module Headers : sig 323 | type t 324 | 325 | type name = string 326 | (** The type of a case-insensitive header name. *) 327 | 328 | type value = string 329 | (** The type of a header value. *) 330 | 331 | (** {3 Constructor} *) 332 | 333 | val empty : t 334 | (** [empty] is the empty collection of header fields. *) 335 | 336 | val of_list : (name * value) list -> t 337 | (** [of_list assoc] is a collection of header fields defined by the 338 | association list [assoc]. [of_list] assumes the order of header fields in 339 | [assoc] is the intended transmission order. The following equations 340 | should hold: 341 | 342 | {ul 343 | {- [to_list (of_list lst) = lst] } 344 | {- [get (of_list [("k", "v1"); ("k", "v2")]) "k" = Some "v2"]. }} *) 345 | 346 | val of_rev_list : (name * value) list -> t 347 | (** [of_list assoc] is a collection of header fields defined by the 348 | association list [assoc]. [of_list] assumes the order of header fields in 349 | [assoc] is the {i reverse} of the intended trasmission order. The 350 | following equations should hold: 351 | 352 | {ul 353 | {- [to_list (of_rev_list lst) = List.rev lst] } 354 | {- [get (of_rev_list [("k", "v1"); ("k", "v2")]) "k" = Some "v1"]. }} *) 355 | 356 | val to_list : t -> (name * value) list 357 | (** [to_list t] is the association list of header fields contained in [t] in 358 | transmission order. *) 359 | 360 | val to_rev_list : t -> (name * value) list 361 | (** [to_rev_list t] is the association list of header fields contained in [t] 362 | in {i reverse} transmission order. *) 363 | 364 | val add : t -> name -> value -> t 365 | (** [add t name value] is a collection of header fields that is the same as 366 | [t] except with [(name, value)] added at the end of the trasmission order. 367 | The following equations should hold: 368 | 369 | {ul 370 | {- [get (add t name value) name = Some value] }} *) 371 | 372 | val add_unless_exists : t -> name -> value -> t 373 | (** [add_unless_exists t name value] is a collection of header fields that is 374 | the same as [t] if [t] already inclues [name], and otherwise is 375 | equivalent to [add t name value]. *) 376 | 377 | val add_list : t -> (name * value) list -> t 378 | (** [add_list t assoc] is a collection of header fields that is the same as 379 | [t] except with all the header fields in [assoc] added to the end of the 380 | transmission order, in reverse order. *) 381 | 382 | val add_multi : t -> (name * value list) list -> t 383 | (** [add_multi t assoc] is the same as 384 | 385 | {[ 386 | add_list t (List.concat_map assoc ~f:(fun (name, values) -> 387 | List.map values ~f:(fun value -> (name, value)))) 388 | ]} 389 | 390 | but is implemented more efficiently. For example, 391 | 392 | {[ 393 | add_multi t ["name1", ["x", "y"]; "name2", ["p", "q"]] 394 | = add_list ["name1", "x"; "name1", "y"; "name2", "p"; "name2", "q"] 395 | ]} *) 396 | 397 | val remove : t -> name -> t 398 | (** [remove t name] is a collection of header fields that contains all the 399 | header fields of [t] except those that have a header-field name that are 400 | equal to [name]. If [t] contains multiple header fields whose name is 401 | [name], they will all be removed. *) 402 | 403 | val replace : t -> name -> value -> t 404 | (** [replace t name value] is a collection of header fields that is the same 405 | as [t] except with all header fields with a name equal to [name] removed 406 | and replaced with a single header field whose name is [name] and whose 407 | value is [value]. This new header field will appear in the transmission 408 | order where the first occurrence of a header field with a name matching 409 | [name] was found. 410 | 411 | If no header field with a name equal to [name] is present in [t], then 412 | the result is simply [t], unchanged. *) 413 | 414 | (** {3 Destructors} *) 415 | 416 | val mem : t -> name -> bool 417 | (** [mem t name] is true iff [t] includes a header field with a name that is 418 | equal to [name]. *) 419 | 420 | val get : t -> name -> value option 421 | (** [get t name] returns the last header from [t] with name [name], or [None] 422 | if no such header is present. *) 423 | 424 | val get_exn : t -> name -> value 425 | (** [get t name] returns the last header from [t] with name [name], or raises 426 | if no such header is present. *) 427 | 428 | val get_multi : t -> name -> value list 429 | (** [get_multi t name] is the list of header values in [t] whose names are 430 | equal to [name]. The returned list is in transmission order. *) 431 | 432 | (** {3 Iteration} *) 433 | 434 | val iter : f:(name -> value -> unit) -> t -> unit 435 | val fold : f:(name -> value -> 'a -> 'a) -> init:'a -> t -> 'a 436 | 437 | (** {3 Utilities} *) 438 | 439 | val to_string : t -> string 440 | 441 | val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] 442 | end 443 | 444 | (** {2 Message Body} *) 445 | 446 | module Body : sig 447 | module Reader : sig 448 | type t 449 | 450 | val schedule_read 451 | : t 452 | -> on_eof : (unit -> unit) 453 | -> on_read : (Bigstringaf.t -> off:int -> len:int -> unit) 454 | -> unit 455 | (** [schedule_read t ~on_eof ~on_read] will setup [on_read] and [on_eof] as 456 | callbacks for when bytes are available in [t] for the application to 457 | consume, or when the input channel has been closed and no further bytes 458 | will be received by the application. 459 | 460 | Once either of these callbacks have been called, they become inactive. 461 | The application is responsible for scheduling subsequent reads, either 462 | within the [on_read] callback or by some other mechanism. *) 463 | 464 | val close : t -> unit 465 | (** [close t] closes [t], indicating that any subsequent input 466 | received should be discarded. *) 467 | 468 | val is_closed : t -> bool 469 | (** [is_closed t] is [true] if {!close} has been called on [t] and [false] 470 | otherwise. A closed [t] may still have bytes available for reading. *) 471 | end 472 | 473 | module Writer : sig 474 | type t 475 | 476 | val write_char : t -> char -> unit 477 | (** [write_char w char] copies [char] into an internal buffer. If possible, 478 | this write will be combined with previous and/or subsequent writes 479 | before transmission. *) 480 | 481 | val write_string : t -> ?off:int -> ?len:int -> string -> unit 482 | (** [write_string w ?off ?len str] copies [str] into an internal buffer. If 483 | possible, this write will be combined with previous and/or subsequent 484 | writes before transmission. *) 485 | 486 | val write_bigstring : t -> ?off:int -> ?len:int -> Bigstringaf.t -> unit 487 | (** [write_bigstring w ?off ?len bs] copies [bs] into an internal buffer. If 488 | possible, this write will be combined with previous and/or subsequent 489 | writes before transmission. *) 490 | 491 | val schedule_bigstring : t -> ?off:int -> ?len:int -> Bigstringaf.t -> unit 492 | (** [schedule_bigstring w ?off ?len bs] schedules [bs] to be transmitted at 493 | the next opportunity without performing a copy. [bs] should not be 494 | modified until a subsequent call to {!flush} has successfully 495 | completed. *) 496 | 497 | val flush : t -> (unit -> unit) -> unit 498 | (** [flush t f] makes all bytes in [t] available for writing to the awaiting 499 | output channel. Once those bytes have reached that output channel, [f] 500 | will be called. 501 | 502 | The type of the output channel is runtime-dependent, as are guarantees 503 | about whether those packets have been queued for delivery or have 504 | actually been received by the intended recipient. *) 505 | 506 | val close : t -> unit 507 | (** [close t] closes [t], causing subsequent write calls to raise. If 508 | [t] is writable, this will cause any pending output to become available 509 | to the output channel. *) 510 | 511 | val is_closed : t -> bool 512 | (** [is_closed t] is [true] if {!close} has been called on [t] and [false] 513 | otherwise. A closed [t] may still have pending output. *) 514 | end 515 | 516 | end 517 | 518 | 519 | (** {2 Message Types} *) 520 | 521 | (** Request 522 | 523 | A client-initiated HTTP message. *) 524 | module Request : sig 525 | type t = 526 | { meth : Method.t 527 | ; target : string 528 | ; version : Version.t 529 | ; headers : Headers.t } 530 | 531 | val create 532 | : ?version:Version.t (** default is HTTP 1.1 *) 533 | -> ?headers:Headers.t (** default is {!Headers.empty} *) 534 | -> Method.t 535 | -> string 536 | -> t 537 | 538 | module Body_length : sig 539 | type t = [ 540 | | `Fixed of Int64.t 541 | | `Chunked 542 | | `Error of [`Bad_request] 543 | ] 544 | 545 | val pp_hum : Format.formatter -> t -> unit 546 | end 547 | 548 | val body_length : t -> Body_length.t 549 | (** [body_length t] is the length of the message body accompanying [t]. It is 550 | an error to generate a request with a close-delimited message body. 551 | 552 | See {{:https://tools.ietf.org/html/rfc7230#section-3.3.3} RFC7230§3.3.3} 553 | for more details. *) 554 | 555 | val persistent_connection : ?proxy:bool -> t -> bool 556 | (** [persistent_connection ?proxy t] indicates whether the connection for [t] 557 | can be reused for multiple requests and responses. If the calling code 558 | is acting as a proxy, it should pass [~proxy:true]. 559 | 560 | See {{:https://tools.ietf.org/html/rfc7230#section-6.3} RFC7230§6.3 for 561 | more details. *) 562 | 563 | val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] 564 | end 565 | 566 | 567 | (** Response 568 | 569 | A server-generated message to a {Request}. *) 570 | module Response : sig 571 | type t = 572 | { version : Version.t 573 | ; status : Status.t 574 | ; reason : string 575 | ; headers : Headers.t } 576 | 577 | val create 578 | : ?reason:string (** default is determined by {!Status.default_reason_phrase} *) 579 | -> ?version:Version.t (** default is HTTP 1.1 *) 580 | -> ?headers:Headers.t (** default is {!Headers.empty} *) 581 | -> Status.t 582 | -> t 583 | (** [create ?reason ?version ?headers status] creates an HTTP response with 584 | the given parameters. For typical use cases, it's sufficient to provide 585 | values for [headers] and [status]. *) 586 | 587 | module Body_length : sig 588 | type t = [ 589 | | `Fixed of Int64.t 590 | | `Chunked 591 | | `Close_delimited 592 | | `Error of [ `Bad_gateway | `Internal_server_error ] 593 | ] 594 | 595 | val pp_hum : Format.formatter -> t -> unit 596 | end 597 | 598 | val body_length : ?proxy:bool -> request_method:Method.standard -> t -> Body_length.t 599 | (** [body_length ?proxy ~request_method t] is the length of the message body 600 | accompanying [t] assuming it is a response to a request whose method was 601 | [request_method]. If the calling code is acting as a proxy, it should 602 | pass [~proxy:true]. This optional parameter only affects error reporting. 603 | 604 | See {{:https://tools.ietf.org/html/rfc7230#section-3.3.3} RFC7230§3.3.3} 605 | for more details. *) 606 | 607 | val persistent_connection : ?proxy:bool -> t -> bool 608 | (** [persistent_connection ?proxy t] indicates whether the connection for [t] 609 | can be reused for multiple requests and responses. If the calling code 610 | is acting as a proxy, it should pass [~proxy:true]. 611 | 612 | See {{:https://tools.ietf.org/html/rfc7230#section-6.3} RFC7230§6.3 for 613 | more details. *) 614 | 615 | val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] 616 | end 617 | 618 | 619 | (** IOVec *) 620 | module IOVec : sig 621 | type 'a t = 'a Faraday.iovec = 622 | { buffer : 'a 623 | ; off : int 624 | ; len : int } 625 | 626 | val length : _ t -> int 627 | val lengthv : _ t list -> int 628 | 629 | val shift : 'a t -> int -> 'a t 630 | val shiftv : 'a t list -> int -> 'a t list 631 | 632 | val pp_hum : Format.formatter -> _ t -> unit [@@ocaml.toplevel_printer] 633 | end 634 | 635 | (** {2 Request Descriptor} *) 636 | module Reqd : sig 637 | type t 638 | 639 | val request : t -> Request.t 640 | val request_body : t -> Body.Reader.t 641 | 642 | val response : t -> Response.t option 643 | val response_exn : t -> Response.t 644 | 645 | (** Responding 646 | 647 | The following functions will initiate a response for the corresponding 648 | request in [t]. Depending on the state of the current connection, and the 649 | header values of the response, this may cause the connection to close or 650 | to persist for reuse by the client. 651 | 652 | See {{:https://tools.ietf.org/html/rfc7230#section-6.3} RFC7230§6.3} for 653 | more details. *) 654 | 655 | val respond_with_string : t -> Response.t -> string -> unit 656 | val respond_with_bigstring : t -> Response.t -> Bigstringaf.t -> unit 657 | val respond_with_streaming : ?flush_headers_immediately:bool -> t -> Response.t -> Body.Writer.t 658 | 659 | (** {3 Exception Handling} *) 660 | 661 | val report_exn : t -> exn -> unit 662 | val try_with : t -> (unit -> unit) -> (unit, exn) result 663 | end 664 | 665 | (** {2 Buffer Size Configuration} *) 666 | module Config : sig 667 | type t = 668 | { read_buffer_size : int (** Default is [4096] *) 669 | ; request_body_buffer_size : int (** Default is [4096] *) 670 | ; response_buffer_size : int (** Default is [1024] *) 671 | ; response_body_buffer_size : int (** Default is [4096] *) 672 | } 673 | 674 | val default : t 675 | (** [default] is a configuration record with all parameters set to their 676 | default values. *) 677 | end 678 | 679 | (** {2 Server Connection} *) 680 | 681 | module Server_connection : sig 682 | type t 683 | 684 | type error = 685 | [ `Bad_request | `Bad_gateway | `Internal_server_error | `Exn of exn ] 686 | 687 | type request_handler = Reqd.t -> unit 688 | 689 | type error_handler = 690 | ?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit 691 | 692 | val create 693 | : ?config:Config.t 694 | -> ?error_handler:error_handler 695 | -> request_handler 696 | -> t 697 | (** [create ?config ?error_handler ~request_handler] creates a connection 698 | handler that will service individual requests with [request_handler]. *) 699 | 700 | val next_read_operation : t -> [ `Read | `Yield | `Close ] 701 | (** [next_read_operation t] returns a value describing the next operation 702 | that the caller should conduct on behalf of the connection. *) 703 | 704 | val read : t -> Bigstringaf.t -> off:int -> len:int -> int 705 | (** [read t bigstring ~off ~len] reads bytes of input from the provided range 706 | of [bigstring] and returns the number of bytes consumed by the 707 | connection. {!read} should be called after {!next_read_operation} 708 | returns a [`Read] value and additional input is available for the 709 | connection to consume. *) 710 | 711 | val read_eof : t -> Bigstringaf.t -> off:int -> len:int -> int 712 | (** [read_eof t bigstring ~off ~len] reads bytes of input from the provided 713 | range of [bigstring] and returns the number of bytes consumed by the 714 | connection. {!read_eof} should be called after {!next_read_operation} 715 | returns a [`Read] and an EOF has been received from the communication 716 | channel. The connection will attempt to consume any buffered input and 717 | then shutdown the HTTP parser for the connection. *) 718 | 719 | val yield_reader : t -> (unit -> unit) -> unit 720 | (** [yield_reader t continue] registers with the connection to call 721 | [continue] when reading should resume. {!yield_reader} should be called 722 | after {next_read_operation} returns a [`Yield] value. *) 723 | 724 | val next_write_operation : t -> [ 725 | | `Write of Bigstringaf.t IOVec.t list 726 | | `Yield 727 | | `Close of int ] 728 | (** [next_write_operation t] returns a value describing the next operation 729 | that the caller should conduct on behalf of the connection. *) 730 | 731 | val report_write_result : t -> [`Ok of int | `Closed] -> unit 732 | (** [report_write_result t result] reports the result of the latest write 733 | attempt to the connection. {report_write_result} should be called after a 734 | call to {next_write_operation} that returns a [`Write buffer] value. 735 | 736 | {ul 737 | {- [`Ok n] indicates that the caller successfully wrote [n] bytes of 738 | output from the buffer that the caller was provided by 739 | {next_write_operation}. } 740 | {- [`Closed] indicates that the output destination will no longer 741 | accept bytes from the write processor. }} *) 742 | 743 | val yield_writer : t -> (unit -> unit) -> unit 744 | (** [yield_writer t continue] registers with the connection to call 745 | [continue] when writing should resume. {!yield_writer} should be called 746 | after {next_write_operation} returns a [`Yield] value. *) 747 | 748 | val report_exn : t -> exn -> unit 749 | (** [report_exn t exn] reports that an error [exn] has been caught and 750 | that it has been attributed to [t]. Calling this function will switch [t] 751 | into an error state. Depending on the state [t] is transitioning from, it 752 | may call its error handler before terminating the connection. *) 753 | 754 | val is_closed : t -> bool 755 | (** [is_closed t] is [true] if both the read and write processors have been 756 | shutdown. When this is the case {!next_read_operation} will return 757 | [`Close _] and {!next_write_operation} will return [`Write _] until all 758 | buffered output has been flushed. *) 759 | 760 | val error_code : t -> error option 761 | (** [error_code t] returns the [error_code] that caused the connection to 762 | close, if one exists. *) 763 | 764 | (**/**) 765 | val shutdown : t -> unit 766 | (**/**) 767 | end 768 | 769 | (** {2 Client Connection} *) 770 | 771 | module Client_connection : sig 772 | 773 | type t 774 | 775 | type error = 776 | [ `Malformed_response of string | `Invalid_response_body_length of Response.t | `Exn of exn ] 777 | 778 | type response_handler = Response.t -> Body.Reader.t -> unit 779 | 780 | type error_handler = error -> unit 781 | 782 | val request 783 | : ?config:Config.t 784 | -> Request.t 785 | -> error_handler:error_handler 786 | -> response_handler:response_handler 787 | -> Body.Writer.t * t 788 | 789 | val next_read_operation : t -> [ `Read | `Close ] 790 | (** [next_read_operation t] returns a value describing the next operation 791 | that the caller should conduct on behalf of the connection. *) 792 | 793 | val read : t -> Bigstringaf.t -> off:int -> len:int -> int 794 | (** [read t bigstring ~off ~len] reads bytes of input from the provided range 795 | of [bigstring] and returns the number of bytes consumed by the 796 | connection. {!read} should be called after {!next_read_operation} 797 | returns a [`Read] value and additional input is available for the 798 | connection to consume. *) 799 | 800 | val read_eof : t -> Bigstringaf.t -> off:int -> len:int -> int 801 | (** [read_eof t bigstring ~off ~len] reads bytes of input from the provided 802 | range of [bigstring] and returns the number of bytes consumed by the 803 | connection. {!read_eof} should be called after {!next_read_operation} 804 | returns a [`Read] and an EOF has been received from the communication 805 | channel. The connection will attempt to consume any buffered input and 806 | then shutdown the HTTP parser for the connection. *) 807 | 808 | val next_write_operation : t -> [ 809 | | `Write of Bigstringaf.t IOVec.t list 810 | | `Yield 811 | | `Close of int ] 812 | (** [next_write_operation t] returns a value describing the next operation 813 | that the caller should conduct on behalf of the connection. *) 814 | 815 | val report_write_result : t -> [`Ok of int | `Closed] -> unit 816 | (** [report_write_result t result] reports the result of the latest write 817 | attempt to the connection. {report_write_result} should be called after a 818 | call to {next_write_operation} that returns a [`Write buffer] value. 819 | 820 | {ul 821 | {- [`Ok n] indicates that the caller successfully wrote [n] bytes of 822 | output from the buffer that the caller was provided by 823 | {next_write_operation}. } 824 | {- [`Closed] indicates that the output destination will no longer 825 | accept bytes from the write processor. }} *) 826 | 827 | val yield_writer : t -> (unit -> unit) -> unit 828 | (** [yield_writer t continue] registers with the connection to call 829 | [continue] when writing should resume. {!yield_writer} should be called 830 | after {next_write_operation} returns a [`Yield] value. *) 831 | 832 | val report_exn : t -> exn -> unit 833 | (** [report_exn t exn] reports that an error [exn] has been caught and 834 | that it has been attributed to [t]. Calling this function will switch [t] 835 | into an error state. Depending on the state [t] is transitioning from, it 836 | may call its error handler before terminating the connection. *) 837 | 838 | val is_closed : t -> bool 839 | 840 | (**/**) 841 | val shutdown : t -> unit 842 | (**/**) 843 | end 844 | 845 | (**/**) 846 | 847 | module Httpaf_private : sig 848 | module Parse : sig 849 | val request : Request.t Angstrom.t 850 | val response : Response.t Angstrom.t 851 | end 852 | 853 | module Serialize : sig 854 | val write_request : Faraday.t -> Request.t -> unit 855 | val write_response : Faraday.t -> Response.t -> unit 856 | end 857 | end 858 | --------------------------------------------------------------------------------