├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE ├── README.md ├── certs ├── localhost.crt ├── localhost.key └── localhost.pem ├── dune-project ├── example ├── dune ├── http_client.ml └── http_server.ml ├── http ├── bench │ ├── dune │ ├── http_server_bench.ml │ └── parser_bench.ml ├── doc │ ├── dune │ └── index.mld ├── src │ ├── body.ml │ ├── body.mli │ ├── bytebuffer.ml │ ├── bytebuffer.mli │ ├── client.ml │ ├── client.mli │ ├── dune │ ├── headers.ml │ ├── headers.mli │ ├── input_channel.ml │ ├── input_channel.mli │ ├── input_channel0.ml │ ├── io_util.ml │ ├── meth.ml │ ├── meth.mli │ ├── output_channel.ml │ ├── output_channel.mli │ ├── output_channel0.ml │ ├── parser.ml │ ├── parser.mli │ ├── request.ml │ ├── request.mli │ ├── response.ml │ ├── response.mli │ ├── response0.ml │ ├── server.ml │ ├── server.mli │ ├── shuttle_http.ml │ ├── slice.ml │ ├── slice.mli │ ├── ssl.ml │ ├── ssl.mli │ ├── status.ml │ ├── status.mli │ ├── tcp_channel.ml │ ├── tcp_channel.mli │ ├── version.ml │ └── version.mli ├── test │ ├── dune │ ├── helper.ml │ ├── id_000000,sig_06,src_000000,time_3062,execs_583,op_havoc,rep_2 │ ├── id_000001,sig_06,src_000000,time_4184,execs_831,op_havoc,rep_8 │ ├── id_000002,sig_06,src_000000,time_5043,execs_1025,op_havoc,rep_2 │ ├── id_000003,sig_06,src_000000,time_5674,execs_1176,op_havoc,rep_2 │ ├── id_000004,sig_06,src_000000,time_9755,execs_2148,op_havoc,rep_2 │ ├── test_header.ml │ ├── test_http.ml │ ├── test_method.ml │ ├── test_parser.ml │ └── test_status.ml └── websocket │ ├── dune │ ├── shuttle_websocket.ml │ └── shuttle_websocket.mli ├── shuttle_http.opam ├── shuttle_http.opam.template └── shuttle_websocket.opam /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | _opam 4 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | parse-docstrings=true 3 | wrap-comments=true 4 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # 0.12.0 2 | 3 | * Adapt to Janestreet's 0.17 series. 4 | 5 | # 0.11.0 6 | 7 | * Forward a server context object to all http services. This can be used to lookup peer-socket address and ssl details (if using ssl) for the underlying connection. 8 | * Add support for websockets 9 | 10 | # 0.10.1 11 | 12 | * Accept a `(string * string) list` as http headers. 13 | * Add a `Body.to_string` for reading entire bodies as string. 14 | 15 | # 0.10.0 16 | 17 | * Adapt to changes in async_kernel 0.16 18 | * Only support OCaml 4.14 or newer 19 | * Only support HTTP codec in the library 20 | 21 | # 0.9.4 22 | 23 | * Allow setting an upper bound on buffer size. 24 | 25 | # 0.9.2 26 | 27 | * Allow creating ssl encrypted http servers. 28 | 29 | # 0.9.1 30 | 31 | * Add client that supports keep-alive. 32 | * Add http clients that leverage Async_kernel's persistent connections. 33 | 34 | # 0.9.0 35 | 36 | * Forward ssl connection details to shuttle_ssl server handlers 37 | * Remove listen and with_connection from shuttle_ssl. Use upgrade_server_connection and upgrade_client_connection with the regular Connection module provided within Shuttle. 38 | * Allow accessing the underlying buffer capacity for channels 39 | * Add helper method that creates server connections using inet sockets 40 | * Reliably schedule stream cleanup for all streaming server responses without forcing users to use any special functions to create the response 41 | * Add one-shot http client 42 | * Setup tcp server within http server module 43 | 44 | # 0.8.1 45 | 46 | * Same content as 0.8.0, but it re-works the integration tests to not spawn external processes, and adds a constraint on shuttle_http to only have it available on 64 bit systems. 47 | 48 | # 0.8.0 49 | * Revive the http codec as a new shuttle_http package 50 | - Http codec supports a timeout for reading Request headers 51 | - Server module reports a deferred that resolves when the server context closes. This can be usedul to register cleanup actions that should run when a server connection is torn down. 52 | - Using the utility methods within the Server module to create responses ensures that streams are torn down if the server connection is closed before a stream was fully consumed. 53 | 54 | # 0.7.0 55 | * Remove support for blocking file descriptors 56 | * Output_channel accepts an optional user-provided Async Time_source 57 | * Input_channel accepts an optional user-provided Async Time_source 58 | * Support timeouts for Input_channel.refill 59 | * Remove `read`, `read_line`, `lines` from Input_channel 60 | 61 | # 0.6.0 62 | * Increase upper bound for core/async to 0.15.0 63 | 64 | # 0.5.0 65 | * Remove Buffer_is_full in favor of Bytebuffers that can grow upto a user provided max size 66 | * Flush operations reports if the write operations encountered an error 67 | * Reliably wakeup pending flushes when there is an error encountered while flushing pending bytes 68 | 69 | # 0.4.0 70 | * Remove Bytebuffer from public api 71 | * Deprecate `schedule_bigstring`, `write_string` 72 | * Support reading lines from an input channel 73 | * Use Core_unix.IOVec to represent a view inside the input channel 74 | * Support file descriptors that don't support nonblocking IO 75 | * Remove the `read_one_chunk_at_a_time` interface from input channel 76 | * Switch to 0.15 series of core and async 77 | 78 | # 0.3.1 79 | * Add support for using format strings for writing to an output channel. 80 | * Remove support for deferred responses from chunked reader callbacks. 81 | * Add a new `shuttle_http` library that implements a driver for httpaf server_connection. 82 | 83 | # 0.3.0 84 | * Support creating a reader pipe from `Input_channel`. 85 | * Support creating a writer pipe from `Output_channel`. 86 | * Support encrypted channels using `async_ssl`. 87 | 88 | # 0.2.0 89 | 90 | * Support deferred's in `Input_channel.read_one_chunk_at_a_time` 91 | * Support writing characters to output channels 92 | 93 | # 0.1.0 94 | 95 | * Initial release 96 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Anurag Soni 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Shuttle_http is a HTTP/1.1 implementation for OCaml that uses [async](https://opensource.janestreet.com/async/) to provide asynchronous servers and clients. 2 | 3 | This is a relatively low-level library that attempts to provide building blocks for writing http servers and clients. The goal for this library is to be a building block for other libraries and applications. 4 | 5 | ## Getting Started 6 | 7 | You can install the library using opam. 8 | 9 | ```sh 10 | opam install shuttle_http 11 | ``` 12 | 13 | Once installed, you'll need to add `shuttle_http` as a dependency in your project's dune file. ex: 14 | 15 | ```scheme 16 | (executable 17 | (name foo) 18 | (libraries shuttle_http)) 19 | ``` 20 | 21 | API Documentation can be viewed online on the [OCaml package registry](https://ocaml.org/p/shuttle_http/0.9.1/doc/index.html). 22 | 23 | ### Getting Started with Servers 24 | 25 | Shuttle_http is built on top of `Core` and `Async`. Core is intended to be used as a replacement of the OCaml standard library, and Async is a library that implements a non-preemptive user-level threads and provides a high level api for asynchronous execution. The rest of this doc assumed the following modules have been opened: 26 | 27 | ```ocaml 28 | open! Core 29 | open! Async 30 | open! Shuttle_http 31 | ``` 32 | 33 | #### Defining a Service 34 | 35 | A Service defines how a server responds to incoming requests. It is an asynchronous function that accepts a HTTP request and returns 36 | a deferred HTTP Response. 37 | 38 | ```ocaml 39 | let hello_service (_ : Request.t) = 40 | return (Response.create ~body:(Body.string "Hello World") `Ok) 41 | ;; 42 | ``` 43 | 44 | This service will respond to all requests with a 200 status code and a body with the content "Hello World". Shuttle_http will automatically populate the Content-Length header in the response. 45 | 46 | #### Running a Server 47 | 48 | We will need to launch a server that will accept `hello_service` and start a running TCP server. 49 | 50 | ```ocaml 51 | let main port = 52 | let server = 53 | Server.run_inet (Tcp.Where_to_listen.of_port port) (fun _context -> service) 54 | in 55 | Log.Global.info 56 | !"Server listening on: %s" 57 | (Socket.Address.to_string (Tcp.Server.listening_on_address server)); 58 | Tcp.Server.close_finished_and_handlers_determined server 59 | ;; 60 | ``` 61 | 62 | To launch our server, we will leverage async's `Command.async`, which will use the `main` function we defined, start the Async scheduler before `main` is run, and will stop the scheduler once `main` returns. 63 | 64 | ```ocaml 65 | let () = 66 | Command.async 67 | ~summary:"Start an echo server" 68 | (Command.Param.return (fun () -> main 8080)) 69 | |> Command_unix.run 70 | ;; 71 | ``` 72 | 73 | #### Echo Server 74 | 75 | Our `hello_service` doesn't really do much, we'll now see examples of servers that do a little more work than always responding with the same payload for every request. This example will show how to echo the body received in an incoming request back to the client. We'll also need to do some routing and since `shuttle_http` doesn't ship with a router we'll rely on pattern matching: 76 | 77 | ```ocaml 78 | let websocket_handler = 79 | Shuttle_websocket.create (fun ws -> 80 | let rd, wr = Websocket.pipes ws in 81 | Pipe.transfer_id rd wr) 82 | ;; 83 | 84 | let service request = 85 | match Request.path request, Request.meth request with 86 | | "/echo", `POST -> return (Response.create ~body:(Request.body request) `Ok) 87 | | "/websocket", `GET -> websocket_handler request 88 | | "/", `GET -> return (Response.create ~body:(Body.string "Hello World") `Ok) 89 | | ("/echo" | "/"), _ -> return (Response.create `Method_not_allowed) 90 | | _ -> return (Response.create `Not_found) 91 | ;; 92 | ``` 93 | 94 | This is a more involved service, we use pattern matching to dispatch our service on a combination of request path and http method. If we receive a `POST` request on the `/echo` path, we return a new response that uses the same body stream as the incoming request. 95 | Shuttle_http will ensure that the incoming request body is streamed incrementally and echoed back out to the client. 96 | 97 | ### Getting Started with Clients 98 | 99 | We'll use `httpbin.org` has a target for all the examples related to HTTP clients. We'll need to create a new `address` entity that points to httpbin: 100 | 101 | ```ocaml 102 | let httpbin_address = 103 | Client.Address.of_host_and_port (Host_and_port.create ~host:"httpbin.org" ~port:443) 104 | ;; 105 | ``` 106 | 107 | If the incoming response's body fits entirely in the client's buffer Shuttle_http will represent the body as a fixed sized string, otherwise the body is read as an asynchronous stream so the response can be processed without having to wait for the entire body to arrive over the write. 108 | 109 | Shuttle_http offers a few different flavors of HTTP clients. The first one we'll see is a OneShot client. OneShot clients open a new TCP 110 | connection, send a HTTP Request, wait to receive a Response and then shut-down the TCP connection once the entire response has been consumed. 111 | 112 | #### Oneshot clients 113 | 114 | ```ocaml 115 | let one_shot_client () = 116 | let%bind response = 117 | Client.Oneshot.call 118 | ~ssl:(Client.Ssl_config.create ()) 119 | httpbin_address 120 | (Request.create `GET "/get") 121 | in 122 | printf "Response status: %d\n" (Response.status response |> Status.to_int); 123 | let%map body = Body.to_string (Response.body response) in 124 | print_endline body 125 | ;; 126 | ``` 127 | 128 | This client sends a request to `httpbin` using a TLS encrypted connection, and logs the response. 129 | 130 | #### Clients supporting keep-alive 131 | 132 | ```ocaml 133 | let persistent_client () = 134 | let%bind httpbin = 135 | Deferred.Or_error.ok_exn (Client.create ~ssl:(Client.Ssl_config.create ()) httpbin_address) 136 | in 137 | Monitor.protect 138 | ~finally:(fun () -> Client.close httpbin) 139 | (fun () -> 140 | let%bind response = Client.call httpbin (Request.create `GET "/stream/20") in 141 | printf !"Headers: %{sexp: (string * string) list}" (Response.headers response); 142 | let%bind () = 143 | Body.Stream.iter_without_pushback 144 | (Body.to_stream (Response.body response)) 145 | ~f:(fun chunk -> printf "%s" chunk) 146 | in 147 | let%bind response = Client.call httpbin (Request.create `GET "/get") in 148 | printf !"Headers: %{sexp: (string * string) list}" (Response.headers response); 149 | Body.Stream.iter_without_pushback 150 | (Body.to_stream (Response.body response)) 151 | ~f:(fun chunk -> printf "%s" chunk)) 152 | ;; 153 | ``` 154 | 155 | This example uses a client that supports keep-alive. The client object needs to be forward to every `Client.call` as it maintains internal state to ensure that the same tcp connection will be re-used for multiple requests. The client only send a new request once the previous response has been fully consumed. 156 | 157 | Persistent clients are nice as they avoid paying the price of establishing a new TCP connection for subsequent requests. The drawback is that users need to be remember to close the client once they are done with it to avoid leaking file handles. `Monitor.protect` can be a good option 158 | when using persistent clients as it'll provide a consistent cleanup stage via its `finally` callback which can be used to close the client object. 159 | -------------------------------------------------------------------------------- /certs/localhost.crt: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIDLzCCAhegAwIBAgIUTE0qppW7liTlZNFx1UbO0EcTxsswDQYJKoZIhvcNAQEL 3 | BQAwJzELMAkGA1UEBhMCVVMxGDAWBgNVBAMMD0V4YW1wbGUtUm9vdC1DQTAeFw0y 4 | MDAyMDYwMzMwNTZaFw0yMjExMjYwMzMwNTZaMCcxCzAJBgNVBAYTAlVTMRgwFgYD 5 | VQQDDA9FeGFtcGxlLVJvb3QtQ0EwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEK 6 | AoIBAQC9pogdeklEKTdCuDm2XuqkH4En8CqdDzuZBAH1ULrGrYqGRtiUIAMxzXkK 7 | z1l3GJjDxV2GHqn9NeXZ6n35UlTRIiIsxP1i+IPnOL7a7bLii2E5SW9BLdex+1nr 8 | RY0+Bf/5DEPgkkAWIDWl2eR+/+Ux3SSxqkcDd+6jI17sa6WZ5VFtQUg87MUT/CAF 9 | QBXqvMahAru8cwDVqhrYT0HoAbPanbkRnRITK8OzKW4HSyeDSqERS8EiLDN5zfPh 10 | n+C1/XchvCuwI/aq6hr9Lh6ago5uRVWlWgqN74w5ABKjkeaYXph8WyPTmxefVs0N 11 | JsDFctQFUduF4D/5hhkG1rt1nxRfAgMBAAGjUzBRMB0GA1UdDgQWBBQ68Sf/yzpl 12 | aJvrv1Nd/+npueuC0jAfBgNVHSMEGDAWgBQ68Sf/yzplaJvrv1Nd/+npueuC0jAP 13 | BgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQBafmpg2x99A/AYcyS0 14 | b7z2U1WqDdG8AuFlzwuKB7wz03KyU+DvJ/TXMb7bG1AYObjb/qpfw5/VpMCmK9YA 15 | gwrvdjAWU/CVZHC3x+P7q7L1pjaaJb4Islna8yQPfiQ1SciNaZ5S89CK/OL/IFEF 16 | yWwL+pehAOQj6WUz1QXh1XvIM/LG5fKBIohbeih0YuigcSKcPq5mC3nV8fwhThy7 17 | Srgz8YKuZakZ4y8Kh5/Y7OYNqcOtaOlFKrL3LiwA1LhULgkTa22HrVvDQ3gSBH2g 18 | OdeS/KfEkhAPyVBwxFCBzpZ0yyTpBmMHqFzdKs49/CO8J89Gcw4slyuUGc1yndqj 19 | 2tJI 20 | -----END CERTIFICATE----- 21 | -------------------------------------------------------------------------------- /certs/localhost.key: -------------------------------------------------------------------------------- 1 | -----BEGIN PRIVATE KEY----- 2 | MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQC9pogdeklEKTdC 3 | uDm2XuqkH4En8CqdDzuZBAH1ULrGrYqGRtiUIAMxzXkKz1l3GJjDxV2GHqn9NeXZ 4 | 6n35UlTRIiIsxP1i+IPnOL7a7bLii2E5SW9BLdex+1nrRY0+Bf/5DEPgkkAWIDWl 5 | 2eR+/+Ux3SSxqkcDd+6jI17sa6WZ5VFtQUg87MUT/CAFQBXqvMahAru8cwDVqhrY 6 | T0HoAbPanbkRnRITK8OzKW4HSyeDSqERS8EiLDN5zfPhn+C1/XchvCuwI/aq6hr9 7 | Lh6ago5uRVWlWgqN74w5ABKjkeaYXph8WyPTmxefVs0NJsDFctQFUduF4D/5hhkG 8 | 1rt1nxRfAgMBAAECggEAG9dXwiQSn2wBjcznxAsZHTD2z/sk9lunHyaEdxP753DQ 9 | ljfOUaiFb4k/jMO12ZMF0i+mNCtKPz7rWFthVPmuM+lz5OiiXiYnjwk4k4EzsqhN 10 | hJBwQbxOHvXMVIqoWoOc+V3AlTZDLDxcQ9XCApbkebaCTYa22B6CLPbjV4fSDs5n 11 | J44hVGX7uzlOo4nzaIOmXhi58ylhoUkcFEmm5c9OS6H7OuTwsuvEQg572Q5yHQzN 12 | XxF6aHzFTcbHEz/AQgW8Amazzn9MbZIDDRl3qMlr3PcktOpfo+IAzZUUrZ9asE+c 13 | J5kEScZP7d6K2fB1eWI5thRYJg7qf442/RE5zwr+gQKBgQD7/xK48eIK+j9r8jsN 14 | TK/t+BlRCjoNckPsuQiQZyqho7ZSZh3OQEe+WkhNFayEEUiDgPmJY4HRknVRlBGp 15 | pgiJEp9GtQWJWLC/yRDobJe/bRsnH1NTz5kPRtJmwl1Llt2mnf1Y0XTvk0BtOsKC 16 | 1dGwg4u+cIz9YSlDY9D63B+GHwKBgQDAqeI5HvF/qbAYO44mAeIyNDsu78JPJKL/ 17 | VXwXdGHHO8QRlFEOjq5LLChPEYrB5hpspcWGsWjnke5PfyiH2gWIYm5/QGC8wD0C 18 | /lnpdd1GMz3hdsA2lyBf9C1YXRf3bQwRa7S50ytMvEatFHqOMPzh1EI1mwfxgbMq 19 | HHUxHqApwQKBgD8DdacRtTiRgzJ3DBUzS/rxw0Lkj8e0/w8+5clWQu7QhVLtfh6J 20 | LGeJI/NCrDUKLVvU8JFOdLP3L6cKo7AMeK3uHi4MLio+J1SN7tBv9zJDEjsiNjAL 21 | BXcweoR/rdytCRgVAbkoB1mxNLcbrnARD7JX8qXYdykVFsBnQWa5jJh5AoGBAJKW 22 | r5FWgdjoext09MrmU/xu0Tj9I5KkBYDQwgH2gw7b4mqdtq6k0OhRSLogVrsBIMnZ 23 | t1isU20eE3xY+7WhpOQIQJqBmRkEC2fjrvV6wElRY5vQhp8CjZd0aav56OpRBgWb 24 | NX7NtPxFpGC8XCMkEsSgg1/V/U07qd44mNIuwx4BAoGAapDREdUdBMnGuOxNRSov 25 | XVPJ6hWNqfAfyIEnzCmfwMyUIeoitaOqy0I7vNu7XdwejDqvMx5ooTwAhMirm+RM 26 | MzljkKR+h1PVEr3099D+i46yT+5ARunj4tIFBNbwXGIZe9EBFLAUyiDQD4bgT4+K 27 | zkiBHKqSuaBFm6x5nz6mqLs= 28 | -----END PRIVATE KEY----- 29 | -------------------------------------------------------------------------------- /certs/localhost.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIDLzCCAhegAwIBAgIUTE0qppW7liTlZNFx1UbO0EcTxsswDQYJKoZIhvcNAQEL 3 | BQAwJzELMAkGA1UEBhMCVVMxGDAWBgNVBAMMD0V4YW1wbGUtUm9vdC1DQTAeFw0y 4 | MDAyMDYwMzMwNTZaFw0yMjExMjYwMzMwNTZaMCcxCzAJBgNVBAYTAlVTMRgwFgYD 5 | VQQDDA9FeGFtcGxlLVJvb3QtQ0EwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEK 6 | AoIBAQC9pogdeklEKTdCuDm2XuqkH4En8CqdDzuZBAH1ULrGrYqGRtiUIAMxzXkK 7 | z1l3GJjDxV2GHqn9NeXZ6n35UlTRIiIsxP1i+IPnOL7a7bLii2E5SW9BLdex+1nr 8 | RY0+Bf/5DEPgkkAWIDWl2eR+/+Ux3SSxqkcDd+6jI17sa6WZ5VFtQUg87MUT/CAF 9 | QBXqvMahAru8cwDVqhrYT0HoAbPanbkRnRITK8OzKW4HSyeDSqERS8EiLDN5zfPh 10 | n+C1/XchvCuwI/aq6hr9Lh6ago5uRVWlWgqN74w5ABKjkeaYXph8WyPTmxefVs0N 11 | JsDFctQFUduF4D/5hhkG1rt1nxRfAgMBAAGjUzBRMB0GA1UdDgQWBBQ68Sf/yzpl 12 | aJvrv1Nd/+npueuC0jAfBgNVHSMEGDAWgBQ68Sf/yzplaJvrv1Nd/+npueuC0jAP 13 | BgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQBafmpg2x99A/AYcyS0 14 | b7z2U1WqDdG8AuFlzwuKB7wz03KyU+DvJ/TXMb7bG1AYObjb/qpfw5/VpMCmK9YA 15 | gwrvdjAWU/CVZHC3x+P7q7L1pjaaJb4Islna8yQPfiQ1SciNaZ5S89CK/OL/IFEF 16 | yWwL+pehAOQj6WUz1QXh1XvIM/LG5fKBIohbeih0YuigcSKcPq5mC3nV8fwhThy7 17 | Srgz8YKuZakZ4y8Kh5/Y7OYNqcOtaOlFKrL3LiwA1LhULgkTa22HrVvDQ3gSBH2g 18 | OdeS/KfEkhAPyVBwxFCBzpZ0yyTpBmMHqFzdKs49/CO8J89Gcw4slyuUGc1yndqj 19 | 2tJI 20 | -----END CERTIFICATE----- 21 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.1) 2 | 3 | (name shuttle_http) 4 | 5 | (generate_opam_files true) 6 | 7 | (source 8 | (github anuragsoni/shuttle_http)) 9 | 10 | (maintainers "Anurag Soni ") 11 | 12 | (authors "Anurag Soni") 13 | 14 | (license MIT) 15 | 16 | (package 17 | (name shuttle_http) 18 | (tags 19 | (http-server http-client http http1.1 async)) 20 | (synopsis "Async library for HTTP/1.1 servers and clients") 21 | (description 22 | "Shuttle_http is a low level library for implementing HTTP/1.1 web services and clients in OCaml.") 23 | (depends 24 | (async 25 | (>= v0.17.0)) 26 | (async_log 27 | (>= v0.17.0)) 28 | (async_ssl 29 | (>= v0.17.0)) 30 | (core 31 | (>= v0.17.0)) 32 | (jane_rope 33 | (>= v0.17.0)) 34 | (ocaml 35 | (>= 5.1.0)) 36 | (ppx_jane 37 | (>= v0.17.0)) 38 | (re2 39 | (>= v0.17.0)) 40 | (core_unix :with-test))) 41 | 42 | (package 43 | (name shuttle_websocket) 44 | (tags 45 | (http-server websocket)) 46 | (synopsis "Websocket support for HTTP/1.1 servers using Async") 47 | (description 48 | "Shuttle_websocket is a companion library for shuttle_http that provides a HTTP service that performs websocket negotiation for HTTP/1.1 servers.") 49 | (depends 50 | (shuttle_http 51 | (= :version)) 52 | (async_websocket 53 | (>= v0.17.0)))) 54 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names http_server http_client) 3 | (preprocess 4 | (pps ppx_jane)) 5 | (libraries 6 | core 7 | core_unix 8 | core_unix.filename_unix 9 | core_unix.command_unix 10 | async 11 | shuttle_http 12 | shuttle_websocket)) 13 | -------------------------------------------------------------------------------- /example/http_client.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open Shuttle_http 4 | 5 | let httpbin_address = 6 | Client.Address.of_host_and_port (Host_and_port.create ~host:"httpbin.org" ~port:443) 7 | ;; 8 | 9 | let one_shot_client () = 10 | let%bind response = 11 | Client.Oneshot.call 12 | ~ssl:(Client.Ssl.create ()) 13 | httpbin_address 14 | (Request.create `GET "/get") 15 | in 16 | printf "Response status: %d\n" (Response.status response |> Status.to_int); 17 | let%map body = Body.to_string (Response.body response) in 18 | print_endline body 19 | ;; 20 | 21 | let persistent_client () = 22 | let%bind httpbin = 23 | Deferred.Or_error.ok_exn (Client.create ~ssl:(Client.Ssl.create ()) httpbin_address) 24 | in 25 | Monitor.protect 26 | ~finally:(fun () -> Client.close httpbin) 27 | (fun () -> 28 | let%bind response = Client.call httpbin (Request.create `GET "/stream/20") in 29 | printf !"Headers: %{sexp: (string * string) list}" (Response.headers response); 30 | let%bind () = 31 | Body.Stream.iter 32 | (Body.to_stream (Response.body response)) 33 | ~f:(fun chunk -> 34 | printf "%s" chunk; 35 | Deferred.unit) 36 | in 37 | let%bind response = Client.call httpbin (Request.create `GET "/get") in 38 | printf !"Headers: %{sexp: (string * string) list}" (Response.headers response); 39 | Body.Stream.iter 40 | (Body.to_stream (Response.body response)) 41 | ~f:(fun chunk -> 42 | printf "%s" chunk; 43 | Deferred.unit)) 44 | ;; 45 | 46 | let run () = 47 | Deferred.List.iter ~how:`Sequential [ one_shot_client; persistent_client ] ~f:(fun f -> 48 | f ()) 49 | ;; 50 | 51 | let () = 52 | Command.async ~summary:"Http client example" (Command.Param.return (fun () -> run ())) 53 | |> Command_unix.run 54 | ;; 55 | -------------------------------------------------------------------------------- /example/http_server.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open Shuttle_http 4 | 5 | let websocket_handler = 6 | Shuttle_websocket.create (fun ws -> 7 | let rd, wr = Websocket.pipes ws in 8 | Pipe.transfer_id rd wr) 9 | ;; 10 | 11 | let service context request = 12 | Log.Global.info "Peer address: %s" (Socket.Address.to_string (Server.peer_addr context)); 13 | match Request.path request, Request.meth request with 14 | | "/echo", `POST -> return (Response.create ~body:(Request.body request) `Ok) 15 | | "/websocket", `GET -> websocket_handler request 16 | | "/", `GET -> return (Response.create ~body:(Body.string "Hello World") `Ok) 17 | | ("/echo" | "/"), _ -> return (Response.create `Method_not_allowed) 18 | | _ -> return (Response.create `Not_found) 19 | ;; 20 | 21 | let run port = 22 | let server = Server.run_inet (Tcp.Where_to_listen.of_port port) service in 23 | Log.Global.info 24 | !"Server listening on: %s" 25 | (Socket.Address.to_string (Tcp.Server.listening_on_address server)); 26 | Deferred.forever () (fun () -> 27 | let%map.Deferred () = after Time_float.Span.(of_sec 0.5) in 28 | Log.Global.printf "Active connections: %d" (Tcp.Server.num_connections server)); 29 | Tcp.Server.close_finished_and_handlers_determined server 30 | ;; 31 | 32 | let command = 33 | Command.async 34 | ~summary:"Http-server demo" 35 | (let%map_open.Command port = 36 | flag "-p" ~doc:"int Port number to listen on" (optional_with_default 8080 int) 37 | in 38 | fun () -> run port) 39 | ;; 40 | 41 | let () = Command_unix.run command 42 | -------------------------------------------------------------------------------- /http/bench/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name parser_bench) 3 | (modules parser_bench) 4 | (libraries core_bench core_unix.command_unix shuttle_http)) 5 | 6 | (executable 7 | (name http_server_bench) 8 | (modules http_server_bench) 9 | (preprocess 10 | (pps ppx_jane)) 11 | (libraries shuttle_http core_unix.command_unix)) 12 | -------------------------------------------------------------------------------- /http/bench/http_server_bench.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open Shuttle_http 4 | 5 | let text = 6 | "CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of sitting by \ 7 | her sister on the bank, and of having nothing to do: once or twice she had peeped \ 8 | into the book her sister was reading, but it had no pictures or conversations in it, \ 9 | thought Alice \ 10 | So she was considering in her own mind (as well as she could, for the hot day made \ 11 | her feel very sleepy and stupid), whether the pleasure of making a daisy-chain would \ 12 | be worth the trouble of getting up and picking the daisies, when suddenly a White \ 13 | Rabbit with pink eyes ran close by her. There was nothing so very remarkable in that; \ 14 | nor did Alice think it so very much out of the way to hear the Rabbit say to itself, \ 15 | (when she thought it over afterwards, it \ 16 | occurred to her that she ought to have wondered at this, but at the time it all \ 17 | seemed quite natural); but when the Rabbit actually took a watch out of its \ 18 | waistcoat-pocket, and looked at it, and then hurried on, Alice started to her feet, \ 19 | for it flashed across her mind that she had never before seen a rabbit with either a \ 20 | waistcoat-pocket, or a watch to take out of it, and burning with curiosity, she ran \ 21 | across the field after it, and fortunately was just in time to see it pop down a \ 22 | large rabbit-hole under the hedge. In another moment down went Alice after it, never \ 23 | once considering how in the world she was to get out again. The rabbit-hole went \ 24 | straight on like a tunnel for some way, and then dipped suddenly down, so suddenly \ 25 | that Alice had not a moment to think about stopping herself before she found herself \ 26 | falling down a very deep well. Either the well was very deep, or she fell very \ 27 | slowly, for she had plenty of time as she went down to look about her and to wonder \ 28 | what was going to happen next. First, she tried to look down and make out what she \ 29 | was coming to, but it was too dark to see anything; then she looked at the sides of \ 30 | the well, and noticed that they were filled with cupboards......" 31 | ;; 32 | 33 | let run port = 34 | let server = 35 | Server.run_inet (Tcp.Where_to_listen.of_port port) (fun _context _request -> 36 | return (Response.create ~body:(Body.string text) `Ok)) 37 | in 38 | Log.Global.info 39 | !"Server listening on: %s" 40 | (Socket.Address.to_string (Tcp.Server.listening_on_address server)); 41 | Deferred.forever () (fun () -> 42 | let%map.Deferred () = after Time_float.Span.(of_sec 0.5) in 43 | Log.Global.printf "Active connections: %d" (Tcp.Server.num_connections server)); 44 | Tcp.Server.close_finished_and_handlers_determined server 45 | ;; 46 | 47 | let command = 48 | Command.async 49 | ~summary:"Http-server benchmark" 50 | (let%map_open.Command port = 51 | flag "-p" ~doc:"int Port number to listen on" (optional_with_default 8080 int) 52 | in 53 | fun () -> run port) 54 | ;; 55 | 56 | let () = Command_unix.run command 57 | -------------------------------------------------------------------------------- /http/bench/parser_bench.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | (* Test data taken from 4 | https://github.com/seanmonstar/httparse/blob/5c385a9b1751f0734db24af731d1926e1d2bc731/benches/parse.rs#L13 5 | https://github.com/rust-bakery/parser_benchmarks/blob/29b8b49759587d0bb44a75575c004a8b990939de/http/httparse/src/main.rs *) 6 | let req = 7 | "GET /wp-content/uploads/2010/03/hello-kitty-darth-vader-pink.jpg HTTP/1.1\r\n\ 8 | Host: www.kittyhell.com\r\n\ 9 | User-Agent: Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10.6; ja-JP-mac; rv:1.9.2.3) \ 10 | Gecko/20100401 Firefox/3.6.3 Pathtraq/0.9\r\n\ 11 | Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\r\n\ 12 | Accept-Language: ja,en-us;q=0.7,en;q=0.3\r\n\ 13 | Accept-Encoding: gzip,deflate\r\n\ 14 | Accept-Charset: Shift_JIS,utf-8;q=0.7,*;q=0.7\r\n\ 15 | Keep-Alive: 115\r\n\ 16 | Connection: keep-alive\r\n\ 17 | Cookie: wp_ozh_wsa_visits=2; wp_ozh_wsa_visit_lasttime=xxxxxxxxxx; \ 18 | __utma=xxxxxxxxx.xxxxxxxxxx.xxxxxxxxxx.xxxxxxxxxx.xxxxxxxxxx.x; \ 19 | __utmz=xxxxxxxxx.xxxxxxxxxx.x.x.utmccn=(referral)|utmcsr=reader.livedoor.com|utmcct=/reader/|utmcmd=referral\r\n\ 20 | \r\n" 21 | ;; 22 | 23 | let req = Bigstring.of_string req 24 | 25 | open Core_bench 26 | 27 | let hex_str = "fffffffe" 28 | let hex_chunk_size = Bigstring.of_string (Printf.sprintf "%s\r\n" hex_str) 29 | 30 | let tests = 31 | [ Bench.Test.create ~name:"H1 (httparse example)" (fun () -> 32 | match Shuttle_http.Parser.parse_request req with 33 | | Error _ -> assert false 34 | | Ok _ -> ()) 35 | ; Bench.Test.create ~name:"Parse chunk size" (fun () -> 36 | match Shuttle_http.Parser.parse_chunk_length hex_chunk_size with 37 | | Error _ -> assert false 38 | | Ok _ -> ()) 39 | ; Bench.Test.create ~name:"Parse hex number" (fun () -> 40 | Int64.of_string ("0x" ^ hex_str)) 41 | ] 42 | ;; 43 | 44 | let () = Command_unix.run (Bench.make_command tests) 45 | -------------------------------------------------------------------------------- /http/doc/dune: -------------------------------------------------------------------------------- 1 | (documentation 2 | (package shuttle_http)) 3 | -------------------------------------------------------------------------------- /http/doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Shuttle_http} 2 | 3 | Shuttle_http is a low level library for implementing HTTP/1.1 web services in OCaml using the {{: https://opensource.janestreet.com/async/} Async} library for lightweight concurrency. It allows defining services as simple OCaml {{!Shuttle_http.Server.service} functions}, and supports streaming bodies to allow working with large bodies incrementally. 4 | 5 | It supports error reporting using {{!Shuttle_http.Server.error_handler} error handlers} and provides a default implementation that responds with the error status code and an empty response body. Users can provide their own error handler implementation when setting up a {{!Shuttle_http.Server.Config.create} server config}. The library however only considers unhandled exceptions, and errors encountered while parsing the wire payload as use-cases that invoke the error handler. The expectation is that application specific errors will be dealt with by the user within their service definition. 6 | 7 | {1 Tutorial} 8 | 9 | {2 Basics} 10 | 11 | Shuttle_http is not a framework and hence doesn't ship with any abstractions beyond service definitions needing to be a function that accept a request and return a deferred response. 12 | 13 | A service definition in its most simple form might look like: 14 | 15 | {[ 16 | open Shuttle_http 17 | 18 | let my_service (request : Request.t) = 19 | return (Response.create ~body:(Body.string "Hello World") `Ok) 20 | ;; 21 | ]} 22 | 23 | {2 Streaming response } 24 | 25 | We saw how to define services that respond with data that's entirely in memory. For some use-cases (Specially when working with really large bodies created from external sources like files), one might want to use a streaming body to serve large amounts of data without loading it all in memory: 26 | 27 | {[ 28 | open Shuttle_http 29 | 30 | let my_service (context : Server.t) (request : Request.t) = 31 | let%map reader = 32 | (* This an example to show a stream that works with an external resource. *) 33 | Reader.open_file "" 34 | in 35 | (* Create a pipe from the reader that we will use as a streaming response body. *) 36 | let reader_pipe = Reader.pipe reader in 37 | (* Create a response from the reader's pipe. If the server is closed before the full 38 | response was served, the pipe will be closed which in-turn will close the reader and 39 | the underlying file descriptor. *) 40 | Response.create ~body:(Body.of_pipe `Chunked reader_pipe) `Ok 41 | ;; 42 | 43 | let main port = 44 | Server.run_inet (Tcp.Where_to_listen.of_port port) my_service 45 | ;; 46 | ]} 47 | 48 | {1 API docs} 49 | 50 | The following modules are part of the library: 51 | 52 | {!modules: 53 | Shuttle_http.Headers 54 | Shuttle_http.Meth 55 | Shuttle_http.Version 56 | Shuttle_http.Body 57 | Shuttle_http.Request 58 | Shuttle_http.Status 59 | Shuttle_http.Response 60 | Shuttle_http.Server 61 | Shuttle_http.Client 62 | } 63 | -------------------------------------------------------------------------------- /http/src/body.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | module Stream = struct 5 | type t = 6 | { encoding : [ `Chunked | `Fixed of int ] 7 | ; reader : string Pipe.Reader.t 8 | ; mutable read_started : bool 9 | } 10 | [@@deriving sexp_of] 11 | 12 | let of_pipe encoding reader = { encoding; reader; read_started = false } 13 | let close t = Pipe.close_read t.reader 14 | let encoding t = t.encoding 15 | 16 | let iter t ~f = 17 | if t.read_started then raise_s [%message "Only one consumer can read from a stream"]; 18 | t.read_started <- true; 19 | Pipe.iter t.reader ~f 20 | ;; 21 | 22 | let iter_without_pushback t ~f = 23 | if t.read_started then raise_s [%message "Only one consumer can read from a stream"]; 24 | t.read_started <- true; 25 | Pipe.iter_without_pushback t.reader ~f 26 | ;; 27 | 28 | let fold t ~init ~f = 29 | if t.read_started then raise_s [%message "Only one consumer can read from a stream"]; 30 | t.read_started <- true; 31 | Pipe.fold t.reader ~init ~f 32 | ;; 33 | 34 | let fold_without_pushback t ~init ~f = 35 | if t.read_started then raise_s [%message "Only one consumer can read from a stream"]; 36 | t.read_started <- true; 37 | Pipe.fold_without_pushback t.reader ~init ~f 38 | ;; 39 | 40 | let read_started t = t.read_started 41 | 42 | let drain t = 43 | if t.read_started 44 | then raise_s [%message "Cannot drain a body that's currently being read"]; 45 | Pipe.drain t.reader 46 | ;; 47 | 48 | let to_string t = 49 | if t.read_started 50 | then raise_s [%message "to_string: Only one consumer can read from a stream"]; 51 | t.read_started <- true; 52 | let%map rope = 53 | Pipe.fold_without_pushback t.reader ~init:Rope.empty ~f:(fun rope str -> 54 | Rope.(rope ^ of_string str)) 55 | in 56 | Rope.to_string rope 57 | ;; 58 | 59 | let closed t = Pipe.closed t.reader 60 | end 61 | 62 | type t = 63 | | Empty 64 | | Fixed of string 65 | | Stream of Stream.t 66 | [@@deriving sexp_of] 67 | 68 | let string x = Fixed x 69 | let empty = Empty 70 | let of_pipe encoding reader = Stream { Stream.encoding; reader; read_started = false } 71 | let stream stream = Stream stream 72 | 73 | let to_stream = function 74 | | Empty -> Stream.of_pipe (`Fixed 0) (Pipe.empty ()) 75 | | Fixed x -> Stream.of_pipe (`Fixed (String.length x)) (Pipe.singleton x) 76 | | Stream x -> x 77 | ;; 78 | 79 | let to_string = function 80 | | Empty -> return "" 81 | | Fixed s -> return s 82 | | Stream x -> Stream.to_string x 83 | ;; 84 | -------------------------------------------------------------------------------- /http/src/body.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | (** [Stream] represents streaming HTTP bodies. This module provides utilities to create 5 | and consume streams, while enforcing the invariant that only one consume can read from 6 | a stream, and that a stream can only be consumed once. *) 7 | module Stream : sig 8 | type t [@@deriving sexp_of] 9 | 10 | (** [of_pipe] is a convenience function that creates a stream from a user provided 11 | [Async_kernel.Pipe.Reader.t]. The pipe will be closed whenever the streaming body is 12 | closed, or EOF is reached. *) 13 | val of_pipe : [ `Chunked | `Fixed of int ] -> string Pipe.Reader.t -> t 14 | 15 | (** [close] allows for closing/tearing-down any resources that are used to produce the 16 | content for a stream. For servers, this function will be called if the underlying 17 | client socket connection is closed, or when the body is fully drained. *) 18 | val close : t -> unit 19 | 20 | (** [encoding] informs whether the body needs to be chunk encoded or not. For servers 21 | this function is used to automatically populate the transfer-encoding or 22 | content-length headers. *) 23 | val encoding : t -> [ `Chunked | `Fixed of int ] 24 | 25 | (** [iter t ~f] consumes chunks of data one at a time. The stream can only be iterated 26 | on once. *) 27 | val iter : t -> f:(string -> unit Deferred.t) -> unit Deferred.t 28 | 29 | val iter_without_pushback : t -> f:(string -> unit) -> unit Deferred.t 30 | val fold : t -> init:'a -> f:('a -> string -> 'a Deferred.t) -> 'a Deferred.t 31 | val fold_without_pushback : t -> init:'a -> f:('a -> string -> 'a) -> 'a Deferred.t 32 | 33 | (** [drain] should consume items one at a time from the stream and discard them. This 34 | function raises if its called after a consumer has started reading data from the 35 | stream. *) 36 | val drain : t -> unit Deferred.t 37 | 38 | (** [closed] is a deferred that should be resolved when the stream is closed/drained. *) 39 | val closed : t -> unit Deferred.t 40 | 41 | (** [read_started] indicated whether a user started to consume a stream or not. Servers 42 | will use [read_started] to verify if they should drain before starting the next 43 | cycle of the server loop, or if they should wait for the body to be closed by the 44 | user. *) 45 | val read_started : t -> bool 46 | 47 | (** [to_string] consumes the entire stream and converts it into a string. [to_string] 48 | consumes the entire stream so it can only be called once. *) 49 | val to_string : t -> string Deferred.t 50 | end 51 | 52 | type t = private 53 | | Empty 54 | | Fixed of string 55 | | Stream of Stream.t 56 | [@@deriving sexp_of] 57 | 58 | (** [string str] creates a fixed length encoded body from a user provided string. *) 59 | val string : string -> t 60 | 61 | (** [empty] is a zero length body. *) 62 | val empty : t 63 | 64 | (** [of_pipe] is a convenience function that creates a streaming body from a user provided 65 | [Async_kernel.Pipe.Reader.t]. The pipe will be closed whenever the streaming body is 66 | closed, or EOF is reached. *) 67 | val of_pipe : [ `Chunked | `Fixed of int ] -> string Pipe.Reader.t -> t 68 | 69 | (** [stream] creates a streaming body from a user provided streaming module. *) 70 | val stream : Stream.t -> t 71 | 72 | (** [to_stream] converts a HTTP body to a stream. *) 73 | val to_stream : t -> Stream.t 74 | 75 | (** [to_string] returns a deferred that will be fulfilled with the entire body converted 76 | to a string. *) 77 | val to_string : t -> string Deferred.t 78 | -------------------------------------------------------------------------------- /http/src/bytebuffer.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | (*= Bytebuffer is split into three regions using two separate indices that are used 4 | to support read and write operations. 5 | +--------------------+---------------------------+----------------------------+ 6 | | Consumed Bytes | Bytes available to read | Empty space for writing | 7 | +--------------------+---------------------------+----------------------------+ 8 | | 0 <= pos_read <= pos_fill <= capacity 9 | 10 | Consumed Bytes: This is content that's already consumed via a get/read operation. 11 | This space can be safely reclaimed. 12 | 13 | Bytes available to read: This is the actual content that will be surfaced to users via 14 | get/read operations on the bytebuffer. 15 | 16 | Empty space for writing: This is space that will be filled by any set/write operations 17 | on the bytebuffer. 18 | *) 19 | type t = 20 | { mutable buf : (Bigstring.t[@sexp.opaque]) 21 | ; mutable pos_read : int 22 | ; mutable pos_fill : int 23 | ; max_buffer_size : int 24 | } 25 | [@@deriving sexp_of] 26 | 27 | exception 28 | Maximum_buffer_size_exceeded of 29 | { current_length : int 30 | ; new_length_requested : int 31 | } 32 | 33 | let create ?max_buffer_size size = 34 | if size < 0 35 | then raise_s [%message "Buffer size cannot be negative" ~requested_size:(size : int)]; 36 | let max_buffer_size = 37 | match max_buffer_size with 38 | | None -> Int.max_value 39 | | Some s -> s 40 | in 41 | if size > max_buffer_size 42 | then 43 | raise_s 44 | [%message 45 | "Invalid buffer size" 46 | ~requested_size:(size : int) 47 | ~max_buffer_size:(max_buffer_size : int)]; 48 | let buf = Bigstring.create size in 49 | { buf; pos_read = 0; pos_fill = 0; max_buffer_size } 50 | ;; 51 | 52 | let compact t = 53 | if t.pos_read > 0 54 | then ( 55 | let len = t.pos_fill - t.pos_read in 56 | if len = 0 57 | then ( 58 | t.pos_read <- 0; 59 | t.pos_fill <- 0) 60 | else ( 61 | Bigstring.blit ~src:t.buf ~dst:t.buf ~src_pos:t.pos_read ~dst_pos:0 ~len; 62 | t.pos_read <- 0; 63 | t.pos_fill <- len)) 64 | ;; 65 | 66 | let length t = t.pos_fill - t.pos_read 67 | let capacity t = Bigstring.length t.buf 68 | let max_buffer_size t = t.max_buffer_size 69 | let available_to_write t = Bigstring.length t.buf - t.pos_fill 70 | 71 | let drop t len = 72 | if len < 0 || len > length t then invalid_arg "Bytebuffer.drop: Index out of bounds"; 73 | t.pos_read <- t.pos_read + len 74 | ;; 75 | 76 | let read_assume_fd_is_nonblocking t fd = 77 | let res = 78 | Bigstring_unix.read_assume_fd_is_nonblocking 79 | fd 80 | t.buf 81 | ~pos:t.pos_fill 82 | ~len:(Bigstring.length t.buf - t.pos_fill) 83 | in 84 | if Core_unix.Syscall_result.Int.is_ok res 85 | then ( 86 | let count = Core_unix.Syscall_result.Int.ok_exn res in 87 | if count > 0 then t.pos_fill <- t.pos_fill + count); 88 | res 89 | ;; 90 | 91 | let write_assume_fd_is_nonblocking t fd = 92 | let res = 93 | Bigstring_unix.write_assume_fd_is_nonblocking fd t.buf ~pos:t.pos_read ~len:(length t) 94 | in 95 | if res > 0 then t.pos_read <- t.pos_read + res; 96 | res 97 | ;; 98 | 99 | let ensure_space t len = 100 | if available_to_write t < len 101 | then ( 102 | let new_length = Bigstring.length t.buf + len in 103 | if new_length > t.max_buffer_size 104 | then 105 | raise 106 | (Maximum_buffer_size_exceeded 107 | { new_length_requested = new_length; current_length = length t }); 108 | let curr_len = t.pos_fill - t.pos_read in 109 | let len = Int.min t.max_buffer_size (Int.ceil_pow2 new_length) in 110 | let new_buf = Bigstring.create len in 111 | Bigstring.unsafe_blit 112 | ~src:t.buf 113 | ~dst:new_buf 114 | ~src_pos:t.pos_read 115 | ~dst_pos:0 116 | ~len:curr_len; 117 | t.buf <- new_buf; 118 | t.pos_read <- 0; 119 | t.pos_fill <- curr_len) 120 | ;; 121 | 122 | let add_char t ch = 123 | ensure_space t 1; 124 | Bigstring.set t.buf t.pos_fill ch; 125 | t.pos_fill <- t.pos_fill + 1 126 | ;; 127 | 128 | let add_gen t ?(pos = 0) ?len ~total_length ~blit str = 129 | let len = 130 | match len with 131 | | Some i -> i 132 | | None -> total_length - pos 133 | in 134 | Ordered_collection_common.check_pos_len_exn ~pos ~len ~total_length; 135 | ensure_space t len; 136 | blit ~src:str ~src_pos:pos ~dst:t.buf ~dst_pos:t.pos_fill ~len; 137 | t.pos_fill <- t.pos_fill + len 138 | ;; 139 | 140 | let add_string t ?pos ?len str = 141 | add_gen 142 | t 143 | ?pos 144 | ?len 145 | ~total_length:(String.length str) 146 | ~blit:Bigstring.From_string.blit 147 | str 148 | ;; 149 | 150 | let add_bigstring t ?pos ?len str = 151 | add_gen t ?pos ?len ~total_length:(Bigstring.length str) ~blit:Bigstring.blit str 152 | ;; 153 | 154 | let to_string t = Bigstring.To_string.sub t.buf ~pos:t.pos_read ~len:(length t) 155 | let unsafe_peek t = { Slice.buf = t.buf; pos = t.pos_read; len = length t } 156 | -------------------------------------------------------------------------------- /http/src/bytebuffer.mli: -------------------------------------------------------------------------------- 1 | (** Extensible buffers using bigstrings. *) 2 | 3 | open! Core 4 | 5 | type t [@@deriving sexp_of] 6 | 7 | exception 8 | Maximum_buffer_size_exceeded of 9 | { current_length : int 10 | ; new_length_requested : int 11 | } 12 | 13 | (** [create ?max_buffer_size size] returns a new empty bytebuffer. The bytebuffer will be 14 | resized automatically, up-to max_buffer_size, if attempting to add more than [size] 15 | characters to the bytebuffer. [max_buffer_size] defaults to [Int.max_value]. *) 16 | val create : ?max_buffer_size:int -> int -> t 17 | 18 | val compact : t -> unit 19 | val available_to_write : t -> int 20 | val ensure_space : t -> int -> unit 21 | 22 | (** [length] returns the number of characters in the bytebuffer. *) 23 | val length : t -> int 24 | 25 | (** [capacity] is the size of the underlying bigstring. *) 26 | val capacity : t -> int 27 | 28 | (** [max_buffer_size] is the maximum size that the underlying buffer can grow upto. *) 29 | val max_buffer_size : t -> int 30 | 31 | (** [drop n] removes [n] bytes from the beginning of the bytebuffer. This is usually 32 | called after a user processes some data from the buffer using a view into the internal 33 | bigstring via [unsafe_peek]. 34 | 35 | Raises [invalid_arg] if [n] is greater than the buffer's length. *) 36 | val drop : t -> int -> unit 37 | 38 | (** [read_assume_fd_is_nonblocking buf fd] is similar to [read] but it performs the read 39 | without yielding to other OCaml-threads. This function should only be called for 40 | non-blocking file-descriptors. 41 | 42 | Returns the number of bytes actually read. 43 | 44 | Raises Invalid_argument if the designated range is out of bounds. *) 45 | val read_assume_fd_is_nonblocking 46 | : t 47 | -> Core_unix.File_descr.t 48 | -> Core_unix.Syscall_result.Int.t 49 | 50 | (** [write_assume_fd_is_nonblocking buf fd] is similar to [write] buf it performs the 51 | write without yielding to other OCaml-threads. This function should only be called for 52 | non-blocking file-descriptors. 53 | 54 | Returns the number of bytes actually written. 55 | 56 | Raises [Core_unix.Unix_error] in case of i/o errors. *) 57 | val write_assume_fd_is_nonblocking : t -> Core_unix.File_descr.t -> int 58 | 59 | (** [add_char] appends the charater at the end of the bytebuffer. *) 60 | val add_char : t -> char -> unit 61 | 62 | (** [add_string] appends the string at the end of the bytebuffer. *) 63 | val add_string : t -> ?pos:int -> ?len:int -> string -> unit 64 | 65 | (** [add_bigstring] appends the bigstring at the end of the bytebuffer. *) 66 | val add_bigstring : t -> ?pos:int -> ?len:int -> Core.Bigstring.t -> unit 67 | 68 | (** [to_string] returns a copy of the current contents of the bytebuffer.*) 69 | val to_string : t -> string 70 | 71 | val unsafe_peek : t -> Slice.t 72 | -------------------------------------------------------------------------------- /http/src/client.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | module Ssl_conn = Ssl 4 | 5 | module Address = struct 6 | module T = struct 7 | type t = 8 | | Host_and_port of Host_and_port.t 9 | | Unix_domain of Filename.t 10 | [@@deriving sexp, equal, compare, hash] 11 | end 12 | 13 | include T 14 | include Comparable.Make (T) 15 | include Hashable.Make (T) 16 | 17 | let of_host_and_port host_and_port = Host_and_port host_and_port 18 | let of_unix_domain_socket file = Unix_domain file 19 | 20 | let hostname = function 21 | | Host_and_port host_and_port -> Some (Host_and_port.host host_and_port) 22 | | _ -> None 23 | ;; 24 | end 25 | 26 | let write_request writer request = 27 | Output_channel.write writer (Meth.to_string (Request.meth request)); 28 | Output_channel.write_char writer ' '; 29 | Output_channel.write writer (Request.path request); 30 | Output_channel.write_char writer ' '; 31 | Output_channel.write writer (Version.to_string (Request.version request)); 32 | Output_channel.write writer "\r\n"; 33 | let request = 34 | match Request.body request with 35 | | Body.Empty -> Request.add_transfer_encoding request (`Fixed 0) 36 | | Fixed x -> Request.add_transfer_encoding request (`Fixed (String.length x)) 37 | | Stream stream -> 38 | (match Body.Stream.encoding stream with 39 | | `Chunked -> Request.add_transfer_encoding request `Chunked 40 | | `Fixed _ as encoding -> Request.add_transfer_encoding request encoding) 41 | in 42 | Request.iter_headers 43 | ~f:(fun ~key ~data -> 44 | Output_channel.write writer key; 45 | Output_channel.write writer ": "; 46 | Output_channel.write writer data; 47 | Output_channel.write writer "\r\n") 48 | request; 49 | Output_channel.write writer "\r\n"; 50 | Io_util.write_body (Request.body request) writer 51 | ;; 52 | 53 | module Ssl = struct 54 | type t = 55 | { version : Async_ssl.Version.t option 56 | ; options : Async_ssl.Opt.t list option 57 | ; name : string option 58 | ; hostname : string option 59 | ; allowed_ciphers : [ `Only of string list | `Openssl_default | `Secure ] option 60 | ; ca_file : string option 61 | ; ca_path : string option 62 | ; crt_file : string option 63 | ; key_file : string option 64 | ; verify_modes : Async_ssl.Verify_mode.t list option 65 | ; session : (Async_ssl.Ssl.Session.t[@sexp.opaque]) option 66 | ; verify_certificate : (Async_ssl.Ssl.Connection.t -> unit Or_error.t) option 67 | } 68 | [@@deriving sexp_of] 69 | 70 | let create 71 | ?version 72 | ?options 73 | ?name 74 | ?hostname 75 | ?allowed_ciphers 76 | ?ca_file 77 | ?ca_path 78 | ?crt_file 79 | ?key_file 80 | ?verify_modes 81 | ?session 82 | ?verify_certificate 83 | () 84 | = 85 | { version 86 | ; options 87 | ; name 88 | ; allowed_ciphers 89 | ; ca_file 90 | ; ca_path 91 | ; hostname 92 | ; crt_file 93 | ; key_file 94 | ; verify_modes 95 | ; session 96 | ; verify_certificate 97 | } 98 | ;; 99 | end 100 | 101 | let host_matches ssl_hostname hostname = 102 | let ssl_hostname_parts = String.split ~on:'.' ssl_hostname in 103 | match ssl_hostname_parts with 104 | | [] -> false 105 | | x :: xs -> 106 | let wildcard_count = String.count x ~f:(fun ch -> Char.equal ch '*') in 107 | if wildcard_count > 1 108 | then 109 | raise_s 110 | [%message 111 | "More than one wildcard characters in hostname part" ~hostname:ssl_hostname] 112 | else if wildcard_count = 0 113 | then if String.Caseless.equal ssl_hostname hostname then true else false 114 | else ( 115 | let regex_parts_head = 116 | if String.equal x "*" 117 | then "[^.]+" 118 | else Re2.replace_exn ~f:(fun _ -> "[^.]+") (Re2.create_exn (Re2.escape "*")) x 119 | in 120 | let regex_parts = "\\A" :: regex_parts_head :: List.map xs ~f:Re2.escape in 121 | let pattern = 122 | regex_parts 123 | |> String.concat ~sep:(Re2.escape ".") 124 | |> Re2.create_exn ~options:{ Re2.Options.default with case_sensitive = true } 125 | in 126 | Re2.matches pattern hostname) 127 | ;; 128 | 129 | let default_ssl_verify_certificate ssl_conn hostname = 130 | match Async_ssl.Ssl.Connection.peer_certificate ssl_conn with 131 | | None -> Or_error.errorf "Missing ssl peer certificate" 132 | | Some (Error e) -> Error e 133 | | Some (Ok cert) -> 134 | (match Async_ssl.Ssl.Certificate.subject_alt_names cert with 135 | | [] -> 136 | let name = 137 | cert 138 | |> Async_ssl.Ssl.Certificate.subject 139 | |> List.find_map ~f:(function 140 | | "CN", name -> Some name 141 | | _ -> None) 142 | in 143 | (match name with 144 | | None -> Or_error.errorf "Could not find Common Name in ssl certificate" 145 | | Some name -> 146 | if host_matches name hostname 147 | then Ok () 148 | else 149 | Or_error.error_s 150 | [%message "SSL Certificate validation failed." ~common_name:name ~hostname]) 151 | | names -> 152 | if List.exists names ~f:(fun glob -> host_matches glob hostname) 153 | then Ok () 154 | else 155 | Or_error.error_s 156 | [%message 157 | "SSL Certificate validation failed." 158 | ~hostname_requested:hostname 159 | ~certificate_hostnames:(names : string list)]) 160 | ;; 161 | 162 | exception Remote_connection_closed 163 | exception Request_aborted 164 | 165 | module Connection = struct 166 | type conn = 167 | { reader : Input_channel.t 168 | ; writer : Output_channel.t 169 | ; address : Address.t 170 | } 171 | [@@deriving sexp_of] 172 | 173 | type t = conn Sequencer.t [@@deriving sexp_of] 174 | 175 | let close t = Throttle.kill t 176 | let is_closed t = Throttle.is_dead t 177 | let closed t = Throttle.cleaned t 178 | 179 | let create ?ssl ?connect_timeout ?interrupt address = 180 | let%bind reader, writer = 181 | match address with 182 | | Address.Host_and_port host_and_port -> 183 | Tcp_channel.connect 184 | ?connect_timeout 185 | ?interrupt 186 | (Tcp.Where_to_connect.of_host_and_port host_and_port) 187 | | Address.Unix_domain file -> 188 | Tcp_channel.connect 189 | ?connect_timeout 190 | ?interrupt 191 | (Tcp.Where_to_connect.of_file file) 192 | in 193 | match ssl with 194 | | None -> 195 | let conn = { reader; writer; address } in 196 | let t = Sequencer.create conn in 197 | Throttle.at_kill t (fun conn -> 198 | let%bind () = Output_channel.close conn.writer in 199 | Input_channel.close conn.reader); 200 | Deferred.Or_error.return t 201 | | Some ssl -> 202 | let ssl = 203 | match ssl.Ssl.hostname with 204 | | Some _ -> ssl 205 | | None -> { ssl with hostname = Address.hostname address } 206 | in 207 | Deferred.Or_error.try_with_join ~run:`Now (fun () -> 208 | let ivar = Ivar.create () in 209 | don't_wait_for 210 | (Ssl_conn.upgrade_client_connection 211 | ?version:ssl.Ssl.version 212 | ?options:ssl.options 213 | ?name:ssl.name 214 | ?hostname:ssl.hostname 215 | ?allowed_ciphers:ssl.allowed_ciphers 216 | ?ca_file:ssl.ca_file 217 | ?ca_path:ssl.ca_path 218 | ?crt_file:ssl.crt_file 219 | ?key_file:ssl.key_file 220 | ?verify_modes:ssl.verify_modes 221 | ?session:ssl.session 222 | reader 223 | writer 224 | ~f:(fun conn reader writer -> 225 | let verification_result = 226 | match ssl.verify_certificate with 227 | | None -> 228 | (match ssl.hostname with 229 | | None -> Ok () 230 | | Some hostname -> default_ssl_verify_certificate conn hostname) 231 | | Some v -> v conn 232 | in 233 | match verification_result with 234 | | Error err -> 235 | Ivar.fill_exn ivar (Error err); 236 | Deferred.unit 237 | | Ok () -> 238 | let conn = { reader; writer; address } in 239 | let t = Sequencer.create conn in 240 | Throttle.at_kill t (fun conn -> 241 | let%bind () = Output_channel.close conn.writer in 242 | Input_channel.close conn.reader); 243 | Ivar.fill_exn ivar (Ok t); 244 | closed t)); 245 | Ivar.read ivar) 246 | ;; 247 | 248 | let call t request = 249 | let ivar = Ivar.create () in 250 | don't_wait_for 251 | (Throttle.enqueue' t (fun conn -> 252 | let request = 253 | match conn.address with 254 | | Address.Host_and_port host_and_port -> 255 | request 256 | |> Request.add_header_unless_exists 257 | ~key:"Host" 258 | ~data:(Host_and_port.host host_and_port) 259 | | Unix_domain _ -> request 260 | in 261 | let%bind () = write_request conn.writer request in 262 | Deferred.repeat_until_finished () (fun () -> 263 | let view = Input_channel.view conn.reader in 264 | match Parser.parse_response view.buf ~pos:view.pos ~len:view.len with 265 | | Error Partial -> 266 | (match%map Input_channel.refill conn.reader with 267 | | `Eof -> raise Remote_connection_closed 268 | | `Ok -> `Repeat ()) 269 | | Error (Fail error) -> Error.raise error 270 | | Ok (response, consumed) -> 271 | Input_channel.consume conn.reader consumed; 272 | (match 273 | Io_util.parse_body conn.reader (Response.transfer_encoding response) 274 | with 275 | | Error error -> Error.raise error 276 | | Ok body -> 277 | let response = Response0.with_body response body in 278 | if not (Response.keep_alive response && Request.keep_alive request) 279 | then close t; 280 | Ivar.fill_exn ivar response; 281 | (match Response.body response with 282 | | Body.Fixed _ | Empty -> return (`Finished ()) 283 | | Stream stream -> 284 | let%map () = Body.Stream.closed stream in 285 | `Finished ())))) 286 | >>| function 287 | | `Ok () -> () 288 | | `Raised exn -> 289 | Throttle.kill t; 290 | raise exn 291 | | `Aborted -> 292 | Throttle.kill t; 293 | raise Request_aborted); 294 | Ivar.read ivar 295 | ;; 296 | end 297 | 298 | module T = struct 299 | type t = Connection.t [@@deriving sexp_of] 300 | 301 | let create ?interrupt ?connect_timeout ?ssl address = 302 | Connection.create ?interrupt ?connect_timeout ?ssl address 303 | ;; 304 | 305 | let close t = 306 | Connection.close t; 307 | Connection.closed t 308 | ;; 309 | 310 | let closed t = Connection.closed t 311 | let close_finished t = closed t 312 | let is_closed t = Connection.is_closed t 313 | end 314 | 315 | include T 316 | 317 | let call t request = Connection.call t request 318 | 319 | module Persistent_connection = Persistent_connection_kernel.Make (T) 320 | 321 | module Persistent = struct 322 | type t = Persistent_connection.t [@@deriving sexp_of] 323 | 324 | let create ?random_state ?retry_delay ?time_source ?ssl ~server_name address = 325 | Persistent_connection.create 326 | ~server_name 327 | ~address:(module Address) 328 | ?retry_delay 329 | ?time_source 330 | ?random_state 331 | ~connect:(fun address -> Connection.create ?ssl address) 332 | address 333 | ;; 334 | 335 | let closed t = Persistent_connection.close_finished t 336 | let is_closed t = Persistent_connection.is_closed t 337 | let close t = Persistent_connection.close t 338 | 339 | let call t request = 340 | match%bind Persistent_connection.connected_or_failed_to_connect t with 341 | | Ok conn -> Connection.call conn request 342 | | Error err -> Error.raise err 343 | ;; 344 | end 345 | 346 | module Oneshot = struct 347 | let call ?interrupt ?connect_timeout ?ssl address request = 348 | let%bind conn = 349 | Deferred.Or_error.ok_exn 350 | (Connection.create ?ssl ?connect_timeout ?interrupt address) 351 | in 352 | Connection.call conn request 353 | ;; 354 | end 355 | -------------------------------------------------------------------------------- /http/src/client.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | module Address : sig 5 | type t [@@deriving sexp, equal, compare, hash] 6 | 7 | include Comparable.S with type t := t 8 | include Hashable.S with type t := t 9 | 10 | val of_host_and_port : Host_and_port.t -> t 11 | val of_unix_domain_socket : Filename.t -> t 12 | end 13 | 14 | module Ssl : sig 15 | type t [@@deriving sexp_of] 16 | 17 | (** ssl options that should be used when using a client over an encrypted connection. 18 | This can be used either when sending a {{!Shuttle_http.Client.Oneshot.call} one-shot 19 | request}, or when creating a client that supports keep-alive. If hostname is 20 | provided it'll be used for validating that the hostname in the peer's ssl 21 | certificate matches the hostname requested by the client. *) 22 | val create 23 | : ?version:Async_ssl.Version.t 24 | -> ?options:Async_ssl.Opt.t list 25 | -> ?name:string 26 | -> ?hostname:string 27 | -> ?allowed_ciphers:[ `Only of string list | `Openssl_default | `Secure ] 28 | -> ?ca_file:string 29 | -> ?ca_path:string 30 | -> ?crt_file:string 31 | -> ?key_file:string 32 | -> ?verify_modes:Async_ssl.Verify_mode.t list 33 | -> ?session:Async_ssl.Ssl.Session.t 34 | -> ?verify_certificate:(Async_ssl.Ssl.Connection.t -> unit Or_error.t) 35 | -> unit 36 | -> t 37 | end 38 | 39 | (** HTTP/1.1 client that supports keep-alives. A client entity can be created once with an 40 | {{!Shuttle_http.Client.Address.t} address} and re-used for multiple requests. The 41 | client is closed either when a user explicitly {{!Shuttle_http.Client.close} closes} 42 | it, or if there is an exception when performing a HTTP request using the client. 43 | 44 | It is the responsiblity of the user to check that a http call raised an exception and 45 | avoid using a connection once an exception is seen in a call. *) 46 | type t [@@deriving sexp_of] 47 | 48 | (** Initiate a TCP connection targeting the user provided Address and perform SSL 49 | handshake if needed. If an interrup deferred is provided the underlying socket is 50 | closed when it resolves. If address is a host + port pair the client will 51 | automatically populate the Host HTTP header for outgoing calls, and ensure that SNI 52 | and hostname validation is configured if using an SSL connection. *) 53 | val create 54 | : ?interrupt:unit Deferred.t 55 | -> ?connect_timeout:Time_float.Span.t 56 | -> ?ssl:Ssl.t 57 | -> Address.t 58 | -> t Deferred.Or_error.t 59 | 60 | (** [Remote_connection_closed] is raised if attempting if an EOF is reached before the 61 | full response has been read. *) 62 | exception Remote_connection_closed 63 | 64 | (** [Request_aborted] is raised if attempting to enqueue a request within a closed http 65 | client. *) 66 | exception Request_aborted 67 | 68 | (** [call] Attempts to perform a HTTP request using the user provided client. If the 69 | response contains a "Connection: close" header or if there's an exception when 70 | performing the call the client will be closed and should not be used for any future 71 | calls. If performing multiple calls on a client, users should ensure to only wait on a 72 | response promise if all previous responses have been fully read. *) 73 | val call : t -> Request.t -> Response.t Deferred.t 74 | 75 | (** [is_closed] returns if the client has been closed. *) 76 | val is_closed : t -> bool 77 | 78 | (** [closed] returns a deferred that's resolved when the http client is closed. *) 79 | val closed : t -> unit Deferred.t 80 | 81 | (** [close] initiates shutdown for an http client. Any request that's currently in-flight 82 | will be attempt to run, and any pending requests will fail with 83 | {{:Shuttle.Client.Request_aborted} exception}. *) 84 | val close : t -> unit Deferred.t 85 | 86 | module Oneshot : sig 87 | (** [call] Performs a one-shot http client call to the user provided connection target. 88 | If ssl options are provided the client will attempt to setup a SSL connection. If 89 | ssl options contain a hostname then the client will perform hostname verification to 90 | ensure the hostnames on the peer's ssl certificate matches the hostname provided by 91 | the caller. To disable this check or to customize how the ssl certificate is 92 | validated users can provide their own implementation of [verify_certificate] when 93 | creating the {{!Shuttle_http.Client.Ssl.t} ssl} options. *) 94 | val call 95 | : ?interrupt:unit Deferred.t 96 | -> ?connect_timeout:Time_float.Span.t 97 | -> ?ssl:Ssl.t 98 | -> Address.t 99 | -> Request.t 100 | -> Response.t Deferred.t 101 | end 102 | 103 | (** Persistent clients, not to be confused with HTTP/1.1 persistent connections are 104 | durable clients that maintain a connection to a service and eagerly and repeatedly 105 | reconnect if the underlying socket connection is lost. *) 106 | module Persistent : sig 107 | type t [@@deriving sexp_of] 108 | 109 | (** Create a new persistent http connection. Random state is forwarded to 110 | {{:Async_kernel.Persistent_connection_kernel} async} and is used to randomize how 111 | long to wait between re-connection attempts. A user provided callback is used to 112 | retrieve the address to connect to. Users can use this to potentially maintain a 113 | pool of service address to target, and decide to use a new target address if the 114 | underlying tcp connection is closed. *) 115 | val create 116 | : ?random_state:[ `Non_random | `State of Random.State.t ] 117 | -> ?retry_delay:(unit -> Time_ns.Span.t) 118 | -> ?time_source:Time_source.t 119 | -> ?ssl:Ssl.t 120 | -> server_name:string 121 | -> (unit -> Address.t Deferred.Or_error.t) 122 | -> t 123 | 124 | (** [closed] returns a deferred that's resolved when the http client is closed. *) 125 | val closed : t -> unit Deferred.t 126 | 127 | (** [is_closed] returns if the client has been closed. *) 128 | val is_closed : t -> bool 129 | 130 | (** [close] tears down the persistent connection. The deferred returned will resolve 131 | once the underlying http connection is closed. *) 132 | val close : t -> unit Deferred.t 133 | 134 | (** [call] Attempts to perform a HTTP request using the user provided client. If the 135 | underlying http connection has closed between two calls, and the user hasn't called 136 | {{!Shuttle_http.Client.Persistent.close} close} on the persistent connection, this 137 | function will initiate a new http connection and then perform the http client call. 138 | *) 139 | val call : t -> Request.t -> Response.t Deferred.t 140 | end 141 | -------------------------------------------------------------------------------- /http/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name shuttle_http) 3 | (preprocess 4 | (pps ppx_jane)) 5 | (libraries core async re2 async_ssl jane_rope async_log)) 6 | -------------------------------------------------------------------------------- /http/src/headers.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type t = (string, string) List.Assoc.t [@@deriving sexp] 4 | 5 | let of_rev_list xs = xs 6 | let of_list xs = List.rev xs 7 | let to_rev_list xs = xs 8 | let to_list xs = List.rev xs 9 | let iter t ~f = List.iter t ~f:(fun (key, data) -> f ~key ~data) 10 | 11 | let rec mem t key = 12 | match t with 13 | | [] -> false 14 | | (k, _) :: t -> String.Caseless.equal k key || mem t key 15 | ;; 16 | 17 | let rec find t key = 18 | match t with 19 | | [] -> None 20 | | (k, v) :: t -> if String.Caseless.equal k key then Some v else find t key 21 | ;; 22 | 23 | let rec find_multi t key = 24 | match t with 25 | | [] -> [] 26 | | (k, v) :: t -> 27 | if String.Caseless.equal k key then v :: find_multi t key else find_multi t key 28 | ;; 29 | 30 | let empty = [] 31 | 32 | let is_empty = function 33 | | [] -> true 34 | | _ -> false 35 | ;; 36 | 37 | let add_unless_exists t ~key ~data = if not (mem t key) then (key, data) :: t else t 38 | let add t ~key ~data = (key, data) :: t 39 | 40 | exception Stop 41 | 42 | let remove t name = 43 | let rec loop t name seen = 44 | match t with 45 | | [] -> if seen then [] else raise_notrace Stop 46 | | ((key, _) as x) :: xs -> 47 | if String.Caseless.equal key name then loop xs name true else x :: loop xs name seen 48 | in 49 | try loop t name false with 50 | | Stop -> t 51 | ;; 52 | 53 | let replace t ~key ~data = 54 | let t = remove t key in 55 | add t ~key ~data 56 | ;; 57 | -------------------------------------------------------------------------------- /http/src/headers.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t = (string * string) list [@@deriving sexp] 4 | 5 | val of_rev_list : (string * string) list -> t 6 | val of_list : (string * string) list -> t 7 | val to_rev_list : t -> (string * string) list 8 | val to_list : t -> (string * string) list 9 | val iter : t -> f:(key:string -> data:string -> unit) -> unit 10 | val mem : t -> string -> bool 11 | val find : t -> string -> string option 12 | val find_multi : t -> string -> string list 13 | val empty : t 14 | val is_empty : t -> bool 15 | val add_unless_exists : t -> key:string -> data:string -> t 16 | val add : t -> key:string -> data:string -> t 17 | val remove : t -> string -> t 18 | val replace : t -> key:string -> data:string -> t 19 | -------------------------------------------------------------------------------- /http/src/input_channel.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | include Input_channel0 4 | module Output_channel = Output_channel0 5 | 6 | let buffer_size t = Bytebuffer.capacity t.buf 7 | let max_buffer_size t = Bytebuffer.max_buffer_size t.buf 8 | let time_source t = t.time_source 9 | 10 | let of_pipe ?max_buffer_size ?buf_len info reader = 11 | Unix.pipe info 12 | >>| fun (`Reader rd, `Writer wr) -> 13 | let input_channel = create ?max_buffer_size ?buf_len rd in 14 | let output_channel = Output_channel.create ?max_buffer_size ?buf_len wr in 15 | don't_wait_for 16 | (let%bind () = Output_channel.write_from_pipe output_channel reader in 17 | Output_channel.close output_channel); 18 | input_channel 19 | ;; 20 | -------------------------------------------------------------------------------- /http/src/input_channel.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async_kernel 3 | open Async_unix 4 | 5 | type t [@@deriving sexp_of] 6 | 7 | val create 8 | : ?max_buffer_size:int 9 | -> ?buf_len:int 10 | -> ?time_source:[> read ] Time_source.T1.t 11 | -> Fd.t 12 | -> t 13 | 14 | val time_source : t -> Time_source.t 15 | val buffer_size : t -> int 16 | val max_buffer_size : t -> int 17 | val is_closed : t -> bool 18 | val closed : t -> unit Deferred.t 19 | val close : t -> unit Deferred.t 20 | val refill : t -> [> `Ok | `Eof ] Deferred.t 21 | val unread_bytes : t -> int 22 | 23 | exception Timeout 24 | 25 | val refill_with_timeout : t -> Time_ns.Span.t -> [> `Ok | `Eof ] Deferred.t 26 | val view : t -> Slice.t 27 | val consume : t -> int -> unit 28 | 29 | (** [drain t] reads chunks of data from the reader and discards them. *) 30 | val drain : t -> unit Deferred.t 31 | 32 | (** [pipe] returns a reader pipe that contains the results of reading chunks from an 33 | input_channel. *) 34 | val pipe : t -> string Pipe.Reader.t 35 | 36 | (** [transfer] will read chunks from an input channel and write them to the provided 37 | writer end of an async pipe. The deferred returned by the function will be determined 38 | on EOF or if the writer is closed. Use [transfer] in scenarios where [pipe] is needed, 39 | but if there is a need to not close the channel automatically once the transfer is 40 | finished. *) 41 | val transfer : t -> string Pipe.Writer.t -> unit Deferred.t 42 | 43 | val of_pipe 44 | : ?max_buffer_size:int 45 | -> ?buf_len:int 46 | -> Info.t 47 | -> string Pipe.Reader.t 48 | -> t Deferred.t 49 | 50 | val fd : t -> Fd.t 51 | -------------------------------------------------------------------------------- /http/src/input_channel0.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async_kernel 3 | open Async_unix 4 | open! Async_kernel_require_explicit_time_source 5 | 6 | type t = 7 | { fd : Fd.t 8 | ; mutable is_closed : bool 9 | ; closed : unit Ivar.t 10 | ; buf : Bytebuffer.t 11 | ; time_source : Time_source.t 12 | } 13 | [@@deriving sexp_of] 14 | 15 | let create ?max_buffer_size ?buf_len ?time_source fd = 16 | Fd.with_file_descr_exn fd ignore ~nonblocking:true; 17 | let time_source = 18 | match time_source with 19 | | None -> Time_source.wall_clock () 20 | | Some t -> Time_source.read_only t 21 | in 22 | let buf_len = 23 | match buf_len with 24 | | None -> 64 * 1024 25 | | Some buf_len -> 26 | if buf_len > 0 27 | then buf_len 28 | else 29 | raise_s 30 | [%message "Reader.create got negative buf_len" (buf_len : int) (fd : Fd.t)] 31 | in 32 | { fd 33 | ; is_closed = false 34 | ; closed = Ivar.create () 35 | ; buf = Bytebuffer.create ?max_buffer_size buf_len 36 | ; time_source 37 | } 38 | ;; 39 | 40 | let consume t n = Bytebuffer.drop t.buf n 41 | let is_closed t = t.is_closed 42 | let closed t = Ivar.read t.closed 43 | 44 | let close t = 45 | if not t.is_closed 46 | then ( 47 | t.is_closed <- true; 48 | Fd.close t.fd >>> fun () -> Ivar.fill_exn t.closed ()); 49 | closed t 50 | ;; 51 | 52 | let unread_bytes t = Bytebuffer.length t.buf 53 | let fd t = t.fd 54 | 55 | exception Timeout 56 | 57 | let refill_with_timeout t span = 58 | Bytebuffer.compact t.buf; 59 | if Bytebuffer.available_to_write t.buf = 0 then Bytebuffer.ensure_space t.buf 1; 60 | let result = Bytebuffer.read_assume_fd_is_nonblocking t.buf (Fd.file_descr_exn t.fd) in 61 | if Unix.Syscall_result.Int.is_ok result 62 | then ( 63 | match Unix.Syscall_result.Int.ok_exn result with 64 | | 0 -> return `Eof 65 | | n -> 66 | assert (n > 0); 67 | return `Ok) 68 | else ( 69 | match Unix.Syscall_result.Int.error_exn result with 70 | | EAGAIN | EWOULDBLOCK | EINTR -> 71 | let event = Time_source.Event.after t.time_source span in 72 | let interrupt = 73 | match%bind Time_source.Event.fired event with 74 | | Time_source.Event.Fired.Aborted () -> Deferred.never () 75 | | Time_source.Event.Fired.Happened () -> Deferred.unit 76 | in 77 | let rec loop t = 78 | Fd.interruptible_ready_to ~interrupt t.fd `Read 79 | >>= function 80 | | `Interrupted -> 81 | (match Time_source.Event.abort event () with 82 | | Time_source.Event.Abort_result.Previously_happened () -> raise Timeout 83 | | Ok | Previously_aborted () -> 84 | raise_s 85 | [%message 86 | "Input_channel.refill_with_timeout bug. Timeout event can't be aborted \ 87 | if Fd is interrupted"]) 88 | | `Ready -> 89 | let result = 90 | Bytebuffer.read_assume_fd_is_nonblocking t.buf (Fd.file_descr_exn t.fd) 91 | in 92 | if Unix.Syscall_result.Int.is_ok result 93 | then ( 94 | match Unix.Syscall_result.Int.ok_exn result with 95 | | 0 -> 96 | Time_source.Event.abort_if_possible event (); 97 | return `Eof 98 | | n -> 99 | assert (n > 0); 100 | Time_source.Event.abort_if_possible event (); 101 | return `Ok) 102 | else ( 103 | match Unix.Syscall_result.Int.error_exn result with 104 | | EAGAIN | EWOULDBLOCK | EINTR -> loop t 105 | | EPIPE 106 | | ECONNRESET 107 | | EHOSTUNREACH 108 | | ENETDOWN 109 | | ENETRESET 110 | | ENETUNREACH 111 | | ETIMEDOUT -> 112 | Time_source.Event.abort_if_possible event (); 113 | return `Eof 114 | | error -> 115 | Time_source.Event.abort_if_possible event (); 116 | raise (Unix.Unix_error (error, "read", ""))) 117 | | `Closed -> 118 | Time_source.Event.abort_if_possible event (); 119 | return `Eof 120 | | `Bad_fd -> 121 | let%bind () = close t in 122 | Time_source.Event.abort_if_possible event (); 123 | raise_s 124 | [%message 125 | "Shuttle.Input_channel.refill_with_timeout: bad file descriptor" 126 | ~fd:(t.fd : Fd.t)] 127 | in 128 | loop t 129 | | EPIPE | ECONNRESET | EHOSTUNREACH | ENETDOWN | ENETRESET | ENETUNREACH | ETIMEDOUT 130 | -> return `Eof 131 | | error -> raise (Unix.Unix_error (error, "read", ""))) 132 | ;; 133 | 134 | let refill t = 135 | Bytebuffer.compact t.buf; 136 | if Bytebuffer.available_to_write t.buf = 0 then Bytebuffer.ensure_space t.buf 1; 137 | let result = Bytebuffer.read_assume_fd_is_nonblocking t.buf (Fd.file_descr_exn t.fd) in 138 | if Unix.Syscall_result.Int.is_ok result 139 | then ( 140 | match Unix.Syscall_result.Int.ok_exn result with 141 | | 0 -> return `Eof 142 | | n -> 143 | assert (n > 0); 144 | return `Ok) 145 | else ( 146 | match Unix.Syscall_result.Int.error_exn result with 147 | | EAGAIN | EWOULDBLOCK | EINTR -> 148 | let rec loop t = 149 | Fd.ready_to t.fd `Read 150 | >>= function 151 | | `Ready -> 152 | let result = 153 | Bytebuffer.read_assume_fd_is_nonblocking t.buf (Fd.file_descr_exn t.fd) 154 | in 155 | if Unix.Syscall_result.Int.is_ok result 156 | then ( 157 | match Unix.Syscall_result.Int.ok_exn result with 158 | | 0 -> return `Eof 159 | | n -> 160 | assert (n > 0); 161 | return `Ok) 162 | else ( 163 | match Unix.Syscall_result.Int.error_exn result with 164 | | EAGAIN | EWOULDBLOCK | EINTR -> loop t 165 | | EPIPE 166 | | ECONNRESET 167 | | EHOSTUNREACH 168 | | ENETDOWN 169 | | ENETRESET 170 | | ENETUNREACH 171 | | ETIMEDOUT -> return `Eof 172 | | error -> raise (Unix.Unix_error (error, "read", ""))) 173 | | `Closed -> return `Eof 174 | | `Bad_fd -> 175 | raise_s 176 | [%message "Shuttle.Input_channel.read: bad file descriptor" ~fd:(t.fd : Fd.t)] 177 | in 178 | loop t 179 | | EPIPE | ECONNRESET | EHOSTUNREACH | ENETDOWN | ENETRESET | ENETUNREACH | ETIMEDOUT 180 | -> return `Eof 181 | | error -> raise (Unix.Unix_error (error, "read", ""))) 182 | ;; 183 | 184 | let view t = Bytebuffer.unsafe_peek t.buf 185 | 186 | let transfer t writer = 187 | let finished = Ivar.create () in 188 | upon (Pipe.closed writer) (fun () -> Ivar.fill_if_empty finished ()); 189 | let rec loop () = 190 | refill t 191 | >>> function 192 | | `Eof -> Ivar.fill_if_empty finished () 193 | | `Ok -> 194 | let payload = Bytebuffer.to_string t.buf in 195 | Bytebuffer.drop t.buf (String.length payload); 196 | Pipe.write writer payload >>> fun () -> loop () 197 | in 198 | loop (); 199 | Ivar.read finished 200 | ;; 201 | 202 | let pipe t = 203 | let reader, writer = Pipe.create () in 204 | (transfer t writer >>> fun () -> close t >>> fun () -> Pipe.close writer); 205 | reader 206 | ;; 207 | 208 | let drain t = Pipe.drain (pipe t) 209 | -------------------------------------------------------------------------------- /http/src/io_util.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | let write_body body writer = 5 | match body with 6 | | Body.Empty -> Output_channel.flush writer 7 | | Fixed x -> 8 | Output_channel.write writer x; 9 | Output_channel.flush writer 10 | | Stream stream -> 11 | (match Body.Stream.encoding stream with 12 | | `Fixed _ -> 13 | Body.Stream.iter stream ~f:(fun v -> 14 | Output_channel.write writer v; 15 | Output_channel.flush writer) 16 | | `Chunked -> 17 | let%bind () = 18 | Body.Stream.iter stream ~f:(fun v -> 19 | if String.is_empty v 20 | then Deferred.unit 21 | else ( 22 | Output_channel.writef writer "%x\r\n" (String.length v); 23 | Output_channel.write writer v; 24 | Output_channel.write writer "\r\n"; 25 | Output_channel.flush writer)) 26 | in 27 | Output_channel.write writer "0\r\n\r\n"; 28 | Output_channel.flush writer) 29 | ;; 30 | 31 | let parse_body reader transfer_encoding = 32 | match transfer_encoding with 33 | | `Fixed 0 -> Ok Body.empty 34 | | `Fixed len -> 35 | let view = Input_channel.view reader in 36 | if view.len >= len 37 | then ( 38 | let chunk = Bigstring.to_string view.buf ~pos:view.pos ~len in 39 | Input_channel.consume reader len; 40 | Ok (Body.string chunk)) 41 | else ( 42 | let pipe = 43 | Pipe.create_reader ~close_on_exception:false (fun writer -> 44 | Deferred.repeat_until_finished len (fun len -> 45 | let view = Input_channel.view reader in 46 | if view.len > 0 47 | then ( 48 | let to_read = min len view.len in 49 | let chunk = Bigstring.to_string view.buf ~pos:view.pos ~len:to_read in 50 | Input_channel.consume reader to_read; 51 | let%map () = Pipe.write_if_open writer chunk in 52 | if to_read = len then `Finished () else `Repeat (len - to_read)) 53 | else ( 54 | match%map Input_channel.refill reader with 55 | | `Eof -> `Finished () 56 | | `Ok -> `Repeat len))) 57 | in 58 | Ok (Body.of_pipe (`Fixed len) pipe)) 59 | | `Chunked -> 60 | let pipe = 61 | Pipe.create_reader ~close_on_exception:false (fun writer -> 62 | Deferred.repeat_until_finished Parser.Start_chunk (fun state -> 63 | let view = Input_channel.view reader in 64 | match Parser.parse_chunk ~pos:view.pos ~len:view.len view.buf state with 65 | | Error Partial -> 66 | (match%map Input_channel.refill reader with 67 | | `Eof -> `Finished () 68 | | `Ok -> `Repeat state) 69 | | Error (Fail error) -> Error.raise error 70 | | Ok (parse_result, consumed) -> 71 | Input_channel.consume reader consumed; 72 | (match parse_result with 73 | | Parser.Chunk_complete chunk -> 74 | let%map () = Pipe.write_if_open writer chunk in 75 | `Repeat Parser.Start_chunk 76 | | Parser.Done -> return (`Finished ()) 77 | | Parser.Partial_chunk (chunk, to_consume) -> 78 | let%map () = Pipe.write_if_open writer chunk in 79 | `Repeat (Parser.Continue_chunk to_consume)))) 80 | in 81 | Ok (Body.of_pipe `Chunked pipe) 82 | | `Bad_request | `Bad_response -> Or_error.error_s [%sexp "Invalid transfer encoding"] 83 | ;; 84 | -------------------------------------------------------------------------------- /http/src/meth.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module T = struct 4 | type t = 5 | [ (* https://datatracker.ietf.org/doc/html/rfc7231#section-4.3 *) 6 | `GET 7 | | `HEAD 8 | | `POST 9 | | `PUT 10 | | `DELETE 11 | | `CONNECT 12 | | `OPTIONS 13 | | `TRACE 14 | | (* https://datatracker.ietf.org/doc/html/rfc5789 *) 15 | `PATCH 16 | ] 17 | [@@deriving sexp, compare, hash, enumerate, quickcheck] 18 | end 19 | 20 | include T 21 | include Comparable.Make (T) 22 | 23 | let of_string = function 24 | | "GET" -> Ok `GET 25 | | "HEAD" -> Ok `HEAD 26 | | "POST" -> Ok `POST 27 | | "PUT" -> Ok `PUT 28 | | "DELETE" -> Ok `DELETE 29 | | "CONNECT" -> Ok `CONNECT 30 | | "OPTIONS" -> Ok `OPTIONS 31 | | "TRACE" -> Ok `TRACE 32 | | "PATCH" -> Ok `PATCH 33 | | meth -> Or_error.error "Invalid HTTP method" meth sexp_of_string 34 | ;; 35 | 36 | let to_string = function 37 | | `GET -> "GET" 38 | | `HEAD -> "HEAD" 39 | | `POST -> "POST" 40 | | `PUT -> "PUT" 41 | | `DELETE -> "DELETE" 42 | | `CONNECT -> "CONNECT" 43 | | `OPTIONS -> "OPTIONS" 44 | | `TRACE -> "TRACE" 45 | | `PATCH -> "PATCH" 46 | ;; 47 | 48 | let is_safe = function 49 | | `GET | `HEAD | `OPTIONS | `TRACE -> true 50 | | _ -> false 51 | ;; 52 | 53 | let is_idempotent = function 54 | | `PUT | `DELETE -> true 55 | | t -> is_safe t 56 | ;; 57 | 58 | let is_cacheable = function 59 | | `GET | `HEAD | `POST -> true 60 | | _ -> false 61 | ;; 62 | -------------------------------------------------------------------------------- /http/src/meth.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | (** Request method is used to indicate the purpose of a HTTP request. 4 | 5 | See {:https://datatracker.ietf.org/doc/html/rfc7231#section-4.3} for more details. *) 6 | type t = 7 | [ `GET 8 | | `HEAD 9 | | `POST 10 | | `PUT 11 | | `DELETE 12 | | `CONNECT 13 | | `OPTIONS 14 | | `TRACE 15 | | (* https://datatracker.ietf.org/doc/html/rfc5789 *) 16 | `PATCH 17 | ] 18 | [@@deriving sexp, compare, hash, enumerate, quickcheck] 19 | 20 | val of_string : string -> t Or_error.t 21 | val to_string : t -> string 22 | 23 | (** [is_safe t] returns true if the semantics for a HTTP method are essentially read-only, 24 | and the client does not expect any state change on the server as a result of the 25 | request. 26 | 27 | See {:https://datatracker.ietf.org/doc/html/rfc7231#section-4.2.1} for more details. 28 | *) 29 | val is_safe : t -> bool 30 | 31 | (** [is_idempotent t] returns true if multiple requests with a HTTP method are intended to 32 | have the same effect on the server as a single such request. This function returns 33 | true for PUT, DELETE and all safe methods. 34 | 35 | See {:https://datatracker.ietf.org/doc/html/rfc7231#section-4.2.2} for more details. 36 | *) 37 | val is_idempotent : t -> bool 38 | 39 | (** [is_cacheable t] indicates that responses to requests with an HTTP method are allowed 40 | to be strored for future reuse. This function returns true for GET, HEAD and POST. 41 | 42 | See {:https://datatracker.ietf.org/doc/html/rfc7231#section-4.2.3} for more details. 43 | *) 44 | val is_cacheable : t -> bool 45 | 46 | include Comparable.S with type t := t 47 | -------------------------------------------------------------------------------- /http/src/output_channel.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | include Output_channel0 4 | module Input_channel = Input_channel0 5 | 6 | let write_timeout t = t.write_timeout 7 | let time_source t = t.time_source 8 | let buffer_size t = Bytebuffer.capacity t.buf 9 | let max_buffer_size t = Bytebuffer.max_buffer_size t.buf 10 | 11 | let of_pipe ?max_buffer_size ?buf_len info pipe_writer = 12 | Async.Unix.pipe info 13 | >>| fun (`Reader rd, `Writer wr) -> 14 | let input_channel = Input_channel.create ?max_buffer_size ?buf_len rd in 15 | let output_channel = create ?max_buffer_size ?buf_len wr in 16 | let flushed = 17 | let%bind () = Input_channel.transfer input_channel pipe_writer in 18 | let%map () = Input_channel.close input_channel 19 | and () = close output_channel in 20 | Pipe.close pipe_writer 21 | in 22 | output_channel, flushed 23 | ;; 24 | -------------------------------------------------------------------------------- /http/src/output_channel.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async_kernel 3 | open Async_unix 4 | module Logger : Async_log.Global.S 5 | 6 | type t [@@deriving sexp_of] 7 | 8 | (** [create ?max_buffer_size ?buf_len ?write_timeout fd] creates a new writer. 9 | 10 | The writer doesn't flush automatically and the user is responsible for calling 11 | [flush], which triggers a write system call if needed. *) 12 | val create 13 | : ?max_buffer_size:int 14 | -> ?buf_len:int 15 | -> ?write_timeout:Time_ns.Span.t 16 | -> ?time_source:[> read ] Time_source.T1.t 17 | -> Fd.t 18 | -> t 19 | 20 | val fd : t -> Fd.t 21 | 22 | (** [write_timeout] is the maximum amount of time the writer will wait when attempting to 23 | write data to the underlying file descriptor. *) 24 | val write_timeout : t -> Time_ns.Span.t 25 | 26 | val buffer_size : t -> int 27 | val max_buffer_size : t -> int 28 | val time_source : t -> Time_source.t 29 | 30 | (** [monitor] returns the async monitor used by [Output_channel] for performing all write 31 | operations.*) 32 | val monitor : t -> Monitor.t 33 | 34 | (** [remote_closed] is a deferred that's resolved when the consumer that's reading the 35 | bytes written to the Output_channel is closed, i.e. the channel has received an EPIPE 36 | or ECONNRESET when it attempts to perform a write. *) 37 | val remote_closed : t -> unit Deferred.t 38 | 39 | val is_closed : t -> bool 40 | val is_open : t -> bool 41 | val close_started : t -> unit Deferred.t 42 | val close_finished : t -> unit Deferred.t 43 | 44 | (** [write_bigstring] copies the bigstring into the channel's internal buffer. It is safe 45 | to modify the bigstring once [write_bigstring] returns. *) 46 | val write_bigstring : t -> ?pos:int -> ?len:int -> Bigstring.t -> unit 47 | 48 | val schedule_bigstring : t -> ?pos:int -> ?len:int -> Bigstring.t -> unit 49 | [@@deprecated 50 | "schedule_bigstring will be removed in a future release. Use [write_bigstring] instead."] 51 | 52 | (** [write] copies the string into the channel's internal buffer. The string will surface 53 | the next time the writer schedules a write. *) 54 | val write : t -> ?pos:int -> ?len:int -> string -> unit 55 | 56 | val write_string : t -> ?pos:int -> ?len:int -> string -> unit 57 | [@@deprecated "write_string will be removed in a future release. Use [write] instead. "] 58 | 59 | val write_char : t -> char -> unit 60 | val writef : t -> ('a, unit, string, unit) format4 -> 'a 61 | 62 | (** [close] will close the underlying file descriptor after waiting for the writer to be 63 | flushed. *) 64 | val close : t -> unit Deferred.t 65 | 66 | (** [schedule_flush] will schedule a write system call if one is needed. *) 67 | val schedule_flush : t -> unit 68 | 69 | module Flush_result : sig 70 | (** [t] Result of a flush operation. 71 | 72 | - [Flushed] indicates all prior writes at the time [flush] was call have finished 73 | without any errors. 74 | 75 | - [Remote_closed] indicates that the consumer that's reading the bytes written to 76 | the Output_channel is closed, i.e. the channel has received an EPIPE or ECONNRESET 77 | when it attempts to perform a write. 78 | 79 | - [Error] indicates that the write operation was interrupted by an unhandled 80 | exception, or a timeout. *) 81 | type t = 82 | | Flushed 83 | | Remote_closed 84 | | Error 85 | [@@deriving sexp_of] 86 | end 87 | 88 | (** [flushed_or_fail t] returns a Deferred that is resolved when all previous writes 89 | complete, or if any of the write operations fail. *) 90 | val flushed_or_fail : t -> Flush_result.t Deferred.t 91 | 92 | (** [flushed t] returns a deferred that will get resolved when all previous writes have 93 | finished. Unlike [flushed_or_fail] if a write call fails then the deferred will never 94 | be resolved. *) 95 | val flushed : t -> unit Deferred.t 96 | 97 | (** [flush] schedules a write system call if one is needed and returns a deferred that is 98 | resolved when all prior writes have finished. If a write call fails then the deferred 99 | will never be resolved. *) 100 | val flush : t -> unit Deferred.t 101 | 102 | (** [flush_or_fail] schedules a write system call if one is needed and returns a deferred 103 | that is resolved when all previous writes complete, or if any of the write operations 104 | fail. *) 105 | val flush_or_fail : t -> Flush_result.t Deferred.t 106 | 107 | val pipe : t -> string Pipe.Writer.t 108 | 109 | val of_pipe 110 | : ?max_buffer_size:int 111 | -> ?buf_len:int 112 | -> Info.t 113 | -> string Pipe.Writer.t 114 | -> (t * unit Deferred.t) Deferred.t 115 | -------------------------------------------------------------------------------- /http/src/output_channel0.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async_kernel 3 | open Async_unix 4 | module Unix = Core_unix 5 | open! Async_kernel_require_explicit_time_source 6 | module Logger = Async_log.Global.Make () 7 | 8 | module Flush_result = struct 9 | type t = 10 | | Flushed 11 | | Remote_closed 12 | | Error 13 | [@@deriving sexp_of] 14 | end 15 | 16 | type flush = 17 | { pos : Int63.t 18 | ; ivar : Flush_result.t Ivar.t 19 | } 20 | [@@deriving sexp_of] 21 | 22 | type close_state = 23 | | Open 24 | | Start_close 25 | | Closed 26 | [@@deriving sexp_of] 27 | 28 | type writer_state = 29 | | Active 30 | | Stopped 31 | | Inactive 32 | [@@deriving sexp_of] 33 | 34 | type t = 35 | { fd : Fd.t 36 | ; write_timeout : Time_ns.Span.t 37 | ; buf : Bytebuffer.t 38 | ; monitor : Monitor.t 39 | ; flushes : flush Queue.t 40 | ; mutable close_state : close_state 41 | ; close_started : unit Ivar.t 42 | ; close_finished : unit Ivar.t 43 | ; remote_closed : unit Ivar.t 44 | ; mutable writer_state : writer_state 45 | ; mutable bytes_written : Int63.t 46 | ; time_source : Time_source.t 47 | } 48 | [@@deriving sexp_of] 49 | 50 | let default_write_timeout = Time_ns.Span.of_min 2. 51 | 52 | let create ?max_buffer_size ?buf_len ?write_timeout ?time_source fd = 53 | Fd.with_file_descr_exn fd ignore ~nonblocking:true; 54 | let buf_len = 55 | match buf_len with 56 | | None -> 64 * 1024 57 | | Some v -> v 58 | in 59 | if buf_len <= 0 then raise_s [%sexp "Buffer size must be greater than 0"]; 60 | let time_source = 61 | match time_source with 62 | | None -> Time_source.wall_clock () 63 | | Some t -> Time_source.read_only t 64 | in 65 | let write_timeout = 66 | match write_timeout with 67 | | Some v -> v 68 | | None -> default_write_timeout 69 | in 70 | if Time_ns.Span.( <= ) write_timeout Time_ns.Span.zero 71 | then raise_s [%message "Write timeout cannot be less than zero"]; 72 | { fd 73 | ; flushes = Queue.create () 74 | ; write_timeout 75 | ; writer_state = Inactive 76 | ; buf = Bytebuffer.create ?max_buffer_size buf_len 77 | ; monitor = Monitor.create () 78 | ; close_state = Open 79 | ; remote_closed = Ivar.create () 80 | ; close_started = Ivar.create () 81 | ; close_finished = Ivar.create () 82 | ; bytes_written = Int63.zero 83 | ; time_source 84 | } 85 | ;; 86 | 87 | let wakeup_flushes_with_error t error = 88 | while not (Queue.is_empty t.flushes) do 89 | Ivar.fill_exn (Queue.dequeue_exn t.flushes).ivar error 90 | done 91 | ;; 92 | 93 | let is_closed t = 94 | match t.close_state with 95 | | Open -> false 96 | | Closed | Start_close -> true 97 | ;; 98 | 99 | let flushed_or_fail t = 100 | if Bytebuffer.length t.buf = 0 101 | then return Flush_result.Flushed 102 | else if is_closed t 103 | then return Flush_result.Error 104 | else ( 105 | let flush = 106 | { pos = Int63.( + ) t.bytes_written (Int63.of_int (Bytebuffer.length t.buf)) 107 | ; ivar = Ivar.create () 108 | } 109 | in 110 | Queue.enqueue t.flushes flush; 111 | Ivar.read flush.ivar) 112 | ;; 113 | 114 | let flushed t = 115 | match%bind flushed_or_fail t with 116 | | Flush_result.Flushed -> Deferred.unit 117 | | Error | Remote_closed -> Deferred.never () 118 | ;; 119 | 120 | let close_started t = Ivar.read t.close_started 121 | let close_finished t = Ivar.read t.close_finished 122 | 123 | let close' t = 124 | match t.close_state with 125 | | Closed | Start_close -> () 126 | | Open -> 127 | t.close_state <- Start_close; 128 | Ivar.fill_exn t.close_started (); 129 | Deferred.any_unit 130 | [ Time_source.after t.time_source (Time_ns.Span.of_sec 5.) 131 | ; Deferred.ignore_m (flushed_or_fail t) 132 | ] 133 | >>> fun () -> 134 | t.close_state <- Closed; 135 | Fd.close t.fd >>> fun () -> Ivar.fill_exn t.close_finished () 136 | ;; 137 | 138 | let close t = 139 | close' t; 140 | close_finished t 141 | ;; 142 | 143 | let stop_writer t reason = 144 | wakeup_flushes_with_error t reason; 145 | t.writer_state <- Stopped; 146 | close' t 147 | ;; 148 | 149 | let monitor t = t.monitor 150 | let remote_closed t = Ivar.read t.remote_closed 151 | let is_open = Fn.non is_closed 152 | 153 | let dequeue_flushes t = 154 | while 155 | (not (Queue.is_empty t.flushes)) 156 | && Int63.( <= ) (Queue.peek_exn t.flushes).pos t.bytes_written 157 | do 158 | Ivar.fill_exn (Queue.dequeue_exn t.flushes).ivar Flush_result.Flushed 159 | done 160 | ;; 161 | 162 | let write_nonblocking t = 163 | match Bytebuffer.write_assume_fd_is_nonblocking t.buf (Fd.file_descr_exn t.fd) with 164 | | n -> 165 | assert (n >= 0); 166 | `Ok n 167 | | exception Unix.Unix_error ((EWOULDBLOCK | EAGAIN | EINTR), _, _) -> `Poll_again 168 | | exception 169 | Unix.Unix_error 170 | ( ( EPIPE 171 | | ECONNRESET 172 | | EHOSTUNREACH 173 | | ENETDOWN 174 | | ENETRESET 175 | | ENETUNREACH 176 | | ETIMEDOUT ) 177 | , _ 178 | , _ ) -> `Eof 179 | | exception exn -> 180 | stop_writer t Flush_result.Error; 181 | raise exn 182 | ;; 183 | 184 | let rec write_everything t = 185 | if Bytebuffer.length t.buf <= 0 186 | then t.writer_state <- Inactive 187 | else ( 188 | match write_nonblocking t with 189 | | `Eof -> 190 | Ivar.fill_exn t.remote_closed (); 191 | stop_writer t Flush_result.Remote_closed 192 | | `Poll_again -> wait_and_write_everything t 193 | | `Ok n -> 194 | Bytebuffer.compact t.buf; 195 | t.bytes_written <- Int63.( + ) t.bytes_written (Int63.of_int n); 196 | dequeue_flushes t; 197 | if Bytebuffer.length t.buf <= 0 198 | then t.writer_state <- Inactive 199 | else wait_and_write_everything t) 200 | 201 | and wait_and_write_everything t = 202 | Time_source.with_timeout t.time_source t.write_timeout (Fd.ready_to t.fd `Write) 203 | >>> fun result -> 204 | match result with 205 | | `Result `Ready -> write_everything t 206 | | `Timeout -> 207 | Logger.sexp 208 | ~level:`Error 209 | [%message 210 | "Shuttle.Output_channel timed out waiting to write on file descriptor. Closing \ 211 | the writer." 212 | ~timeout:(t.write_timeout : Time_ns.Span.t) 213 | (t : t)]; 214 | stop_writer t Flush_result.Error 215 | | `Result ((`Bad_fd | `Closed) as result) -> 216 | Logger.sexp 217 | ~level:`Error 218 | [%sexp 219 | "Shuttle.Output_channel: fd changed" 220 | , { t : t; ready_to_result = (result : [ `Bad_fd | `Closed ]) }]; 221 | stop_writer t Flush_result.Error 222 | ;; 223 | 224 | let is_writing t = 225 | match t.writer_state with 226 | | Active -> true 227 | | Inactive -> false 228 | | Stopped -> false 229 | ;; 230 | 231 | let schedule_flush t = 232 | if (not (is_writing t)) && Bytebuffer.length t.buf > 0 233 | then ( 234 | t.writer_state <- Active; 235 | Scheduler.within ~monitor:t.monitor (fun () -> write_everything t)) 236 | ;; 237 | 238 | let flush t = 239 | let flush_result = flushed t in 240 | schedule_flush t; 241 | flush_result 242 | ;; 243 | 244 | let flush_or_fail t = 245 | let flush_result = flushed_or_fail t in 246 | schedule_flush t; 247 | flush_result 248 | ;; 249 | 250 | let ensure_can_write t = 251 | match t.writer_state with 252 | | Inactive | Active -> () 253 | | Stopped -> raise_s [%sexp "Attempting to write to a closed writer", { t : t }] 254 | ;; 255 | 256 | let can_write t = 257 | match t.writer_state with 258 | | Inactive | Active -> true 259 | | Stopped -> false 260 | ;; 261 | 262 | let write_bigstring t ?pos ?len buf = 263 | ensure_can_write t; 264 | Bytebuffer.add_bigstring t.buf buf ?pos ?len 265 | ;; 266 | 267 | let schedule_bigstring t ?pos ?len buf = write_bigstring t ?pos ?len buf 268 | 269 | let write t ?pos ?len buf = 270 | ensure_can_write t; 271 | Bytebuffer.add_string t.buf buf ?pos ?len 272 | ;; 273 | 274 | let write_string t ?pos ?len buf = write t ?pos ?len buf 275 | let writef t fmt = ksprintf (fun str -> write t str) fmt 276 | 277 | let write_char t ch = 278 | ensure_can_write t; 279 | Bytebuffer.add_char t.buf ch 280 | ;; 281 | 282 | let write_from_pipe t reader = 283 | let finished = Ivar.create () in 284 | let consumer = 285 | (* Add a consumer so the pipe will take the output_channel into account when it checks 286 | if the reader contents have been flushed. *) 287 | Pipe.add_consumer reader ~downstream_flushed:(fun () -> 288 | let%map () = flushed t in 289 | `Ok) 290 | in 291 | let rec loop () = 292 | if can_write t && is_open t && not (Ivar.is_full t.remote_closed) 293 | then ( 294 | (* use [read_now'] as [iter] doesn't allow working on chunks of values at a time. *) 295 | match Pipe.read_now' ~consumer reader with 296 | | `Eof -> Ivar.fill_exn finished () 297 | | `Nothing_available -> Pipe.values_available reader >>> fun _ -> loop () 298 | | `Ok bufs -> 299 | Queue.iter bufs ~f:(fun buf -> write t buf); 300 | schedule_flush t; 301 | Pipe.Consumer.values_sent_downstream consumer; 302 | flushed t >>> loop) 303 | in 304 | loop (); 305 | choose 306 | [ choice (Ivar.read finished) (fun () -> `Finished) 307 | ; choice (close_finished t) (fun () -> `Closed) 308 | ; choice (remote_closed t) (fun () -> `Remote_closed) 309 | ] 310 | >>| function 311 | | `Finished -> () 312 | | `Closed | `Remote_closed -> 313 | (* Close the pipe (both read and write ends) since the channel is closed. This is 314 | desirable so all future calls to [Pipe.write] fail. *) 315 | Pipe.close_read reader 316 | ;; 317 | 318 | let pipe t = 319 | let reader, writer = Pipe.create () in 320 | don't_wait_for (write_from_pipe t reader); 321 | writer 322 | ;; 323 | 324 | let fd t = t.fd 325 | -------------------------------------------------------------------------------- /http/src/parser.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | exception Fail of Error.t 4 | exception Partial 5 | 6 | let tchar_map = 7 | Array.init 256 ~f:(fun idx -> 8 | match Char.of_int_exn idx with 9 | | '0' .. '9' 10 | | 'a' .. 'z' 11 | | 'A' .. 'Z' 12 | | '!' 13 | | '#' 14 | | '$' 15 | | '%' 16 | | '&' 17 | | '\'' 18 | | '*' 19 | | '+' 20 | | '-' 21 | | '.' 22 | | '^' 23 | | '_' 24 | | '`' 25 | | '|' 26 | | '~' -> true 27 | | _ -> false) 28 | ;; 29 | 30 | module Source = struct 31 | type t = 32 | { buffer : Bigstring.t 33 | ; mutable pos : int 34 | ; upper_bound : int 35 | } 36 | 37 | let[@inline always] unsafe_get t idx = Bigstring.get t.buffer (t.pos + idx) 38 | let[@inline always] unsafe_advance t count = t.pos <- t.pos + count 39 | let[@inline always] length t = t.upper_bound - t.pos 40 | let[@inline always] is_empty t = t.pos = t.upper_bound 41 | 42 | let[@inline always] to_string t ~pos ~len = 43 | let b = Bytes.create len in 44 | Bigstring.To_bytes.unsafe_blit 45 | ~src:t.buffer 46 | ~dst:b 47 | ~src_pos:(t.pos + pos) 48 | ~dst_pos:0 49 | ~len; 50 | Bytes.unsafe_to_string ~no_mutation_while_string_reachable:b 51 | ;; 52 | 53 | let[@inline always] is_space = function 54 | | ' ' | '\012' | '\n' | '\r' | '\t' -> true 55 | | _ -> false 56 | ;; 57 | 58 | let[@inline always] to_string_trim t ~pos ~len = 59 | let last = ref (t.pos + len - 1) in 60 | let pos = ref (t.pos + pos) in 61 | while is_space (Bigstring.get t.buffer !pos) && !pos < !last do 62 | incr pos 63 | done; 64 | while is_space (Bigstring.get t.buffer !last) && !last > !pos do 65 | decr last 66 | done; 67 | let len = !last - !pos + 1 in 68 | let b = Bytes.create len in 69 | Bigstring.To_bytes.unsafe_blit ~src:t.buffer ~dst:b ~src_pos:!pos ~dst_pos:0 ~len; 70 | Bytes.unsafe_to_string ~no_mutation_while_string_reachable:b 71 | ;; 72 | 73 | let[@inline always] index t ch = 74 | let idx = Bigstring.unsafe_find t.buffer ch ~pos:t.pos ~len:(length t) in 75 | if idx < 0 then -1 else idx - t.pos 76 | ;; 77 | 78 | let[@inline always] consume_eol t = 79 | if length t < 2 then raise_notrace Partial; 80 | if 81 | Char.( 82 | Bigstring.get t.buffer t.pos = '\r' && Bigstring.get t.buffer (t.pos + 1) = '\n') 83 | then unsafe_advance t 2 84 | else raise_notrace (Fail (Error.of_string "Expected EOL")) 85 | ;; 86 | 87 | let[@inline always] consume_space t = 88 | if length t < 1 then raise_notrace Partial; 89 | if Char.(Bigstring.get t.buffer t.pos = ' ') 90 | then unsafe_advance t 1 91 | else raise_notrace (Fail (Error.of_string "Expected space")) 92 | ;; 93 | 94 | let[@inline always] parse_reason_phrase t = 95 | let pos = index t '\r' in 96 | if pos = -1 97 | then raise_notrace Partial 98 | else if pos = 0 99 | then "" 100 | else ( 101 | let phrase = to_string t ~pos:0 ~len:pos in 102 | unsafe_advance t pos; 103 | phrase) 104 | ;; 105 | 106 | let parse_header tchar_map source = 107 | let pos = index source ':' in 108 | if pos = -1 109 | then raise_notrace Partial 110 | else if pos = 0 111 | then raise_notrace (Fail (Error.of_string "Invalid header: Empty header key")); 112 | for idx = 0 to pos - 1 do 113 | if not (Array.unsafe_get tchar_map (Char.to_int (unsafe_get source idx))) 114 | then raise_notrace (Fail (Error.of_string "Invalid Header Key")) 115 | done; 116 | let key = to_string source ~pos:0 ~len:pos in 117 | unsafe_advance source (pos + 1); 118 | let pos = index source '\r' in 119 | if pos = -1 then raise_notrace Partial; 120 | let v = to_string_trim source ~pos:0 ~len:pos in 121 | unsafe_advance source pos; 122 | key, v 123 | ;; 124 | end 125 | 126 | let[@inline always] ( .![] ) source idx = Source.unsafe_get source idx 127 | let invalid_method = Fail (Error.of_string "Invalid Method") 128 | 129 | let invalid_status_code = 130 | Fail (Error.of_string "Status codes must be three digit numbers") 131 | ;; 132 | 133 | let status source = 134 | if Source.length source < 3 then raise_notrace Partial; 135 | if Char.is_digit source.![0] && Char.is_digit source.![1] && Char.is_digit source.![2] 136 | then ( 137 | match Status.of_string (Source.to_string source ~pos:0 ~len:3) with 138 | | Ok code -> 139 | Source.unsafe_advance source 3; 140 | code 141 | | Error err -> raise_notrace (Fail err)) 142 | else raise_notrace invalid_status_code 143 | ;; 144 | 145 | let meth source = 146 | let pos = Source.index source ' ' in 147 | if pos = -1 then raise_notrace Partial; 148 | let meth = 149 | match pos with 150 | | 3 -> 151 | (match source.![0], source.![1], source.![2] with 152 | | 'G', 'E', 'T' -> `GET 153 | | 'P', 'U', 'T' -> `PUT 154 | | _ -> raise_notrace invalid_method) 155 | | 4 -> 156 | (match source.![0], source.![1], source.![2], source.![3] with 157 | | 'H', 'E', 'A', 'D' -> `HEAD 158 | | 'P', 'O', 'S', 'T' -> `POST 159 | | _ -> raise_notrace invalid_method) 160 | | 5 -> 161 | (match source.![0], source.![1], source.![2], source.![3], source.![4] with 162 | | 'P', 'A', 'T', 'C', 'H' -> `PATCH 163 | | 'T', 'R', 'A', 'C', 'E' -> `TRACE 164 | | _ -> raise_notrace invalid_method) 165 | | 6 -> 166 | (match 167 | source.![0], source.![1], source.![2], source.![3], source.![4], source.![5] 168 | with 169 | | 'D', 'E', 'L', 'E', 'T', 'E' -> `DELETE 170 | | _ -> raise_notrace invalid_method) 171 | | 7 -> 172 | (match 173 | ( source.![0] 174 | , source.![1] 175 | , source.![2] 176 | , source.![3] 177 | , source.![4] 178 | , source.![5] 179 | , source.![6] ) 180 | with 181 | | 'C', 'O', 'N', 'N', 'E', 'C', 'T' -> `CONNECT 182 | | 'O', 'P', 'T', 'I', 'O', 'N', 'S' -> `OPTIONS 183 | | _ -> raise_notrace invalid_method) 184 | | _ -> raise_notrace invalid_method 185 | in 186 | Source.unsafe_advance source (pos + 1); 187 | meth 188 | ;; 189 | 190 | let rec headers source = 191 | if (not (Source.is_empty source)) && Char.(Source.unsafe_get source 0 = '\r') 192 | then ( 193 | Source.consume_eol source; 194 | []) 195 | else ( 196 | let header = Source.parse_header tchar_map source in 197 | Source.consume_eol source; 198 | header :: headers source) 199 | ;; 200 | 201 | let chunk_length source = 202 | let length = ref 0 in 203 | let stop = ref false in 204 | let state = ref `Ok in 205 | let count = ref 0 in 206 | let processing_chunk = ref true in 207 | let in_chunk_extension = ref false in 208 | while not !stop do 209 | if Source.is_empty source 210 | then ( 211 | stop := true; 212 | state := `Partial) 213 | else if !count = 16 && not !in_chunk_extension 214 | then ( 215 | stop := true; 216 | state := `Chunk_too_big) 217 | else ( 218 | let ch = Source.unsafe_get source 0 in 219 | Source.unsafe_advance source 1; 220 | incr count; 221 | match ch with 222 | | '0' .. '9' as ch when !processing_chunk -> 223 | let curr = Char.to_int ch - Char.to_int '0' in 224 | length := (!length lsl 4) lor curr 225 | | 'a' .. 'f' as ch when !processing_chunk -> 226 | let curr = Char.to_int ch - Char.to_int 'a' + 10 in 227 | length := (!length lsl 4) lor curr 228 | | 'A' .. 'F' as ch when !processing_chunk -> 229 | let curr = Char.to_int ch - Char.to_int 'A' + 10 in 230 | length := (!length lsl 4) lor curr 231 | | ';' when not !in_chunk_extension -> 232 | in_chunk_extension := true; 233 | processing_chunk := false 234 | | ('\t' | ' ') when !processing_chunk -> processing_chunk := false 235 | | ('\t' | ' ') when (not !in_chunk_extension) && not !processing_chunk -> () 236 | | '\r' -> 237 | if Source.is_empty source 238 | then ( 239 | stop := true; 240 | state := `Partial) 241 | else if Char.(Source.unsafe_get source 0 = '\n') 242 | then ( 243 | Source.unsafe_advance source 1; 244 | stop := true) 245 | else ( 246 | stop := true; 247 | state := `Expected_newline) 248 | | _ when !in_chunk_extension -> 249 | (* Chunk extensions aren't very common, see: 250 | https://tools.ietf.org/html/rfc7230#section-4.1.1 Chunk extensions aren't 251 | pre-defined, and they are specific to invidividual connections. In the future 252 | we might surface these to the user somehow, but for now we will ignore any 253 | extensions. TODO: Should there be any limit on the size of chunk extensions we 254 | parse? We might want to error if a request contains really large chunk 255 | extensions. *) 256 | () 257 | | ch -> 258 | stop := true; 259 | state := `Invalid_char ch) 260 | done; 261 | match !state with 262 | | `Ok -> !length 263 | | `Partial -> raise_notrace Partial 264 | | `Expected_newline -> raise_notrace (Fail (Error.of_string "Expected_newline")) 265 | | `Chunk_too_big -> raise_notrace (Fail (Error.of_string "Chunk size is too large")) 266 | | `Invalid_char ch -> 267 | raise_notrace (Fail (Error.create "Invalid chunk_length character" ch sexp_of_char)) 268 | ;; 269 | 270 | let version source = 271 | if Source.length source < 8 then raise_notrace Partial; 272 | if 273 | Char.equal source.![0] 'H' 274 | && Char.equal source.![1] 'T' 275 | && Char.equal source.![2] 'T' 276 | && Char.equal source.![3] 'P' 277 | && Char.equal source.![4] '/' 278 | && Char.equal source.![5] '1' 279 | && Char.equal source.![6] '.' 280 | && Char.equal source.![7] '1' 281 | then ( 282 | Source.unsafe_advance source 8; 283 | Version.Http_1_1) 284 | else raise_notrace (Fail (Error.of_string "Invalid HTTP Version")) 285 | ;; 286 | 287 | let token source = 288 | let pos = Source.index source ' ' in 289 | if pos = -1 then raise_notrace Partial; 290 | let res = Source.to_string source ~pos:0 ~len:pos in 291 | Source.unsafe_advance source (pos + 1); 292 | res 293 | ;; 294 | 295 | let request source = 296 | let meth = meth source in 297 | let path = token source in 298 | let version = version source in 299 | Source.consume_eol source; 300 | let headers = headers source in 301 | Request.create ~version ~headers meth path 302 | ;; 303 | 304 | let response source = 305 | let version = version source in 306 | Source.consume_space source; 307 | let status = status source in 308 | Source.consume_space source; 309 | let reason_phrase = Source.parse_reason_phrase source in 310 | Source.consume_eol source; 311 | let headers = headers source in 312 | Response.create ~version ~headers ~reason_phrase status 313 | ;; 314 | 315 | let take len source = 316 | let available = Source.length source in 317 | let to_consume = min len available in 318 | if to_consume = 0 then raise_notrace Partial; 319 | let payload = Source.to_string source ~pos:0 ~len:to_consume in 320 | Source.unsafe_advance source to_consume; 321 | payload 322 | ;; 323 | 324 | type chunk_kind = 325 | | Start_chunk 326 | | Continue_chunk of int 327 | 328 | type chunk_parser_result = 329 | | Chunk_complete of string 330 | | Done 331 | | Partial_chunk of string * int 332 | 333 | let chunk chunk_kind source = 334 | match chunk_kind with 335 | | Start_chunk -> 336 | let chunk_length = chunk_length source in 337 | if chunk_length = 0 338 | then ( 339 | Source.consume_eol source; 340 | Done) 341 | else ( 342 | let current_chunk = take chunk_length source in 343 | let current_chunk_length = String.length current_chunk in 344 | if current_chunk_length = chunk_length 345 | then ( 346 | Source.consume_eol source; 347 | Chunk_complete current_chunk) 348 | else Partial_chunk (current_chunk, chunk_length - current_chunk_length)) 349 | | Continue_chunk len -> 350 | let chunk = take len source in 351 | let current_chunk_length = String.length chunk in 352 | if current_chunk_length = len 353 | then ( 354 | Source.consume_eol source; 355 | Chunk_complete chunk) 356 | else Partial_chunk (chunk, len - current_chunk_length) 357 | ;; 358 | 359 | type error = 360 | | Partial 361 | | Fail of Error.t 362 | 363 | let run_parser ?(pos = 0) ?len buf p = 364 | let total_length = Bigstring.length buf in 365 | let len = 366 | match len with 367 | | Some v -> v 368 | | None -> total_length - pos 369 | in 370 | Ordered_collection_common.check_pos_len_exn ~pos ~len ~total_length; 371 | let source = Source.{ buffer = buf; pos; upper_bound = pos + len } in 372 | match p source with 373 | | exception Partial -> Error Partial 374 | | exception Fail m -> Error (Fail m) 375 | | v -> 376 | let consumed = source.pos - pos in 377 | Ok (v, consumed) 378 | ;; 379 | 380 | let parse_request ?pos ?len buf = run_parser ?pos ?len buf request 381 | let parse_response ?pos ?len buf = run_parser ?pos ?len buf response 382 | let parse_chunk_length ?pos ?len buf = run_parser ?pos ?len buf chunk_length 383 | let parse_chunk ?pos ?len buf chunk_kind = run_parser ?pos ?len buf (chunk chunk_kind) 384 | 385 | module Private = struct 386 | let parse_method ?pos ?len buf = run_parser ?pos ?len buf meth 387 | end 388 | -------------------------------------------------------------------------------- /http/src/parser.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type error = 4 | | Partial 5 | | Fail of Error.t 6 | 7 | type chunk_kind = 8 | | Start_chunk 9 | | Continue_chunk of int 10 | 11 | type chunk_parser_result = 12 | | Chunk_complete of string 13 | | Done 14 | | Partial_chunk of string * int 15 | 16 | (** Attempts to parse a buffer into a HTTP request. If successful, it returns the parsed 17 | request and an offset value that indicates the starting point of unconsumed content 18 | left in the buffer. *) 19 | val parse_request : ?pos:int -> ?len:int -> Bigstring.t -> (Request.t * int, error) result 20 | 21 | val parse_response 22 | : ?pos:int 23 | -> ?len:int 24 | -> Bigstring.t 25 | -> (Response.t * int, error) result 26 | 27 | val parse_chunk_length : ?pos:int -> ?len:int -> Bigstring.t -> (int * int, error) result 28 | 29 | val parse_chunk 30 | : ?pos:int 31 | -> ?len:int 32 | -> Bigstring.t 33 | -> chunk_kind 34 | -> (chunk_parser_result * int, error) result 35 | 36 | module Private : sig 37 | val parse_method : ?pos:int -> ?len:int -> Bigstring.t -> (Meth.t * int, error) result 38 | end 39 | -------------------------------------------------------------------------------- /http/src/request.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type t = 4 | { meth : Meth.t 5 | ; path : string 6 | ; version : Version.t 7 | ; headers : Headers.t 8 | ; body : Body.t 9 | } 10 | [@@deriving sexp_of] 11 | 12 | let create ?(version = Version.Http_1_1) ?(headers = []) ?(body = Body.empty) meth path = 13 | { meth; path; version; headers; body } 14 | ;; 15 | 16 | let meth t = t.meth 17 | let path t = t.path 18 | let version t = t.version 19 | let headers t = t.headers 20 | let body t = t.body 21 | let with_body t body = if phys_equal t.body body then t else { t with body } 22 | let header t name = Headers.find t.headers name 23 | 24 | let transfer_encoding t = 25 | match List.rev @@ Headers.find_multi t.headers "Transfer-Encoding" with 26 | | x :: _ when String.Caseless.equal x "chunked" -> `Chunked 27 | | _x :: _ -> `Bad_request 28 | | [] -> 29 | (match 30 | List.dedup_and_sort 31 | ~compare:String.Caseless.compare 32 | (Headers.find_multi t.headers "Content-Length") 33 | with 34 | | [] -> `Fixed 0 35 | | [ x ] -> 36 | let len = 37 | try Int.of_string x with 38 | | _ -> -1 39 | in 40 | if Int.(len >= 0) then `Fixed len else `Bad_request 41 | | _ -> `Bad_request) 42 | ;; 43 | 44 | let keep_alive t = 45 | match Headers.find t.headers "connection" with 46 | | Some x when String.Caseless.equal x "close" -> false 47 | | _ -> true 48 | ;; 49 | 50 | let add_transfer_encoding t encoding = 51 | match encoding with 52 | | `Chunked -> 53 | if Headers.mem t.headers "Transfer-Encoding" 54 | then t 55 | else 56 | { t with headers = Headers.add t.headers ~key:"Transfer-Encoding" ~data:"chunked" } 57 | | `Fixed len -> 58 | if Headers.mem t.headers "Content-Length" 59 | then t 60 | else 61 | { t with 62 | headers = Headers.add t.headers ~key:"Content-Length" ~data:(Int.to_string len) 63 | } 64 | ;; 65 | 66 | let iter_headers t ~f = Headers.iter t.headers ~f 67 | 68 | let add_header_unless_exists t ~key ~data = 69 | if Headers.mem t.headers key 70 | then t 71 | else { t with headers = Headers.add t.headers ~key ~data } 72 | ;; 73 | 74 | let add_header t ~key ~data = { t with headers = Headers.add t.headers ~key ~data } 75 | let header_exists t key = Headers.mem t.headers key 76 | 77 | let remove_header t key = 78 | if Headers.mem t.headers key 79 | then { t with headers = Headers.remove t.headers key } 80 | else t 81 | ;; 82 | 83 | let header_multi t name = Headers.find_multi t.headers name 84 | 85 | let replace_header t ~key ~data = 86 | { t with headers = Headers.replace t.headers ~key ~data } 87 | ;; 88 | -------------------------------------------------------------------------------- /http/src/request.mli: -------------------------------------------------------------------------------- 1 | (** [t] Represents a HTTP 1.1 request. *) 2 | type t [@@deriving sexp_of] 3 | 4 | val create 5 | : ?version:Version.t 6 | -> ?headers:(string * string) list 7 | -> ?body:Body.t 8 | -> Meth.t 9 | -> string 10 | -> t 11 | 12 | (** [meth] returns the HTTP method of this request. *) 13 | val meth : t -> Meth.t 14 | 15 | (** [path] returns the path component and query parameters of the request URI *) 16 | val path : t -> string 17 | 18 | (** [version] returns the HTTP version number for the request. *) 19 | val version : t -> Version.t 20 | 21 | (** [headers] returns HTTP headers of this request. *) 22 | val headers : t -> (string * string) list 23 | 24 | (** [body] returns the body payload of this request. *) 25 | val body : t -> Body.t 26 | 27 | (** [with_body] returns a new request where every value is the same as the input request 28 | but the body is replaced with the function input. *) 29 | val with_body : t -> Body.t -> t 30 | 31 | (** [transfer_encoding] returns the inferred transfer encoding based on the request's http 32 | headers. *) 33 | val transfer_encoding : t -> [> `Bad_request | `Chunked | `Fixed of int ] 34 | 35 | (** [keep_alive] indicates whether the http connection should be reused.*) 36 | val keep_alive : t -> bool 37 | 38 | (** [add_transfer_encoding t encoding] adds transfer-encoding information to the request 39 | headers.*) 40 | val add_transfer_encoding : t -> [ `Chunked | `Fixed of int ] -> t 41 | 42 | (** [iter_headers t ~f] iterates over all request headers and forwards them to the user 43 | provided callback. *) 44 | val iter_headers : t -> f:(key:string -> data:string -> unit) -> unit 45 | 46 | (** [add_header_unless_exists t ~key ~data] returns a request with a new header added to 47 | it if the header isn't already present in the request. *) 48 | val add_header_unless_exists : t -> key:string -> data:string -> t 49 | 50 | (** [add_header t ~key ~data] returns a request with a new header added to it. *) 51 | val add_header : t -> key:string -> data:string -> t 52 | 53 | (** [header t key] returns [Some data] if [key] is found in the list of request headers. 54 | It returns [None] if the requested header isn't found.*) 55 | val header : t -> string -> string option 56 | 57 | (** [header_multi t key] returns a list of all values associated with the request header 58 | name. It returns an empty list if the requested header isn't found.*) 59 | val header_multi : t -> string -> string list 60 | 61 | (** [remove_header t key] removes all request headers that match the user provided key.*) 62 | val remove_header : t -> string -> t 63 | 64 | (** [header_exists t key] returns if a request header matches the user provided key. *) 65 | val header_exists : t -> string -> bool 66 | 67 | (** [replace_header] removes all response headers that match the user provided key and adds 68 | a new entry for the key with the new user provided data. *) 69 | val replace_header : t -> key:string -> data:string -> t 70 | -------------------------------------------------------------------------------- /http/src/response.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | include Response0 3 | 4 | let create 5 | ?(version = Version.Http_1_1) 6 | ?reason_phrase 7 | ?(headers = []) 8 | ?(body = Body.empty) 9 | status 10 | = 11 | let reason_phrase = Option.value reason_phrase ~default:(Status.to_string status) in 12 | { version; status; reason_phrase; headers; body = Response body } 13 | ;; 14 | 15 | let upgrade ?(headers = []) handler = 16 | let reason_phrase = Status.to_reason_phrase `Switching_protocols in 17 | { version = Http_1_1 18 | ; status = `Switching_protocols 19 | ; reason_phrase 20 | ; headers 21 | ; body = Upgrade handler 22 | } 23 | ;; 24 | 25 | let version t = t.version 26 | let status t = t.status 27 | let reason_phrase t = t.reason_phrase 28 | let headers t = t.headers 29 | 30 | let body t = 31 | match t.body with 32 | | Response b -> b 33 | | Upgrade _ -> Body.empty 34 | ;; 35 | 36 | let transfer_encoding t = 37 | match List.rev @@ Headers.find_multi t.headers "Transfer-Encoding" with 38 | | x :: _ when String.Caseless.equal x "chunked" -> `Chunked 39 | | _x :: _ -> `Bad_response 40 | | [] -> 41 | (match 42 | List.dedup_and_sort 43 | ~compare:String.Caseless.compare 44 | (Headers.find_multi t.headers "Content-Length") 45 | with 46 | | [] -> `Fixed 0 47 | | [ x ] -> 48 | let len = 49 | try Int.of_string x with 50 | | _ -> -1 51 | in 52 | if Int.(len >= 0) then `Fixed len else `Bad_response 53 | | _ -> `Bad_response) 54 | ;; 55 | 56 | let keep_alive t = 57 | match Headers.find t.headers "connection" with 58 | | Some x when String.Caseless.equal x "close" -> false 59 | | _ -> true 60 | ;; 61 | 62 | let add_transfer_encoding t encoding = 63 | match encoding with 64 | | `Chunked -> 65 | if Headers.mem t.headers "Transfer-Encoding" 66 | then t 67 | else 68 | { t with headers = Headers.add t.headers ~key:"Transfer-Encoding" ~data:"chunked" } 69 | | `Fixed len -> 70 | if Headers.mem t.headers "Content-Length" 71 | then t 72 | else 73 | { t with 74 | headers = Headers.add t.headers ~key:"Content-Length" ~data:(Int.to_string len) 75 | } 76 | ;; 77 | 78 | let iter_headers t ~f = Headers.iter t.headers ~f 79 | 80 | let add_header_unless_exists t ~key ~data = 81 | if Headers.mem t.headers key 82 | then t 83 | else { t with headers = Headers.add t.headers ~key ~data } 84 | ;; 85 | 86 | let add_header t ~key ~data = { t with headers = Headers.add t.headers ~key ~data } 87 | let header_exists t key = Headers.mem t.headers key 88 | 89 | let remove_header t key = 90 | if Headers.mem t.headers key 91 | then { t with headers = Headers.remove t.headers key } 92 | else t 93 | ;; 94 | 95 | let header_multi t name = Headers.find_multi t.headers name 96 | let header t name = Headers.find t.headers name 97 | 98 | let replace_header t ~key ~data = 99 | { t with headers = Headers.replace t.headers ~key ~data } 100 | ;; 101 | -------------------------------------------------------------------------------- /http/src/response.mli: -------------------------------------------------------------------------------- 1 | (** [t] Represents a HTTP 1.1 response. *) 2 | type t = Response0.t [@@deriving sexp_of] 3 | 4 | val create 5 | : ?version:Version.t 6 | -> ?reason_phrase:string 7 | -> ?headers:(string * string) list 8 | -> ?body:Body.t 9 | -> Status.t 10 | -> t 11 | 12 | val upgrade 13 | : ?headers:Headers.t 14 | -> (?unconsumed_data:string -> Async_unix.Fd.t -> unit Async_kernel.Deferred.t) 15 | -> t 16 | 17 | (** [version] returns the HTTP version number for the response. *) 18 | val version : t -> Version.t 19 | 20 | (** [status] returns the Status code for this response. *) 21 | val status : t -> Status.t 22 | 23 | (** [reason_phrase] returns the status reason phrase for the response. *) 24 | val reason_phrase : t -> string 25 | 26 | (** [headers] returns the HTTP headers for this response. *) 27 | val headers : t -> (string * string) list 28 | 29 | (** [body] returns the body payload of this response. *) 30 | val body : t -> Body.t 31 | 32 | (** [transfer_encoding] returns the inferred transfer encoding based on the response's 33 | http headers. *) 34 | val transfer_encoding : t -> [> `Bad_response | `Chunked | `Fixed of int ] 35 | 36 | (** [keep_alive] indicates whether the http connection should be reused.*) 37 | val keep_alive : t -> bool 38 | 39 | (** [add_transfer_encoding t encoding] adds transfer-encoding information to the response 40 | headers.*) 41 | val add_transfer_encoding : t -> [ `Chunked | `Fixed of int ] -> t 42 | 43 | (** [iter_headers t ~f] iterates over all response headers and forwards them to the user 44 | provided callback. *) 45 | val iter_headers : t -> f:(key:string -> data:string -> unit) -> unit 46 | 47 | (** [add_header_unless_exists t ~key ~data] returns a response with a new header added to 48 | it if the header isn't already present in the response. *) 49 | val add_header_unless_exists : t -> key:string -> data:string -> t 50 | 51 | (** [add_header t ~key ~data] returns a response with a new header added to it. *) 52 | val add_header : t -> key:string -> data:string -> t 53 | 54 | (** [header t key] returns [Some data] if [key] is found in the list of response headers. 55 | It returns [None] if the requested header isn't found.*) 56 | val header : t -> string -> string option 57 | 58 | (** [header_multi t key] returns a list of all values associated with the response header 59 | name. It returns an empty list if the requested header isn't found.*) 60 | val header_multi : t -> string -> string list 61 | 62 | (** [remove_header t key] removes all response headers that match the user provided key.*) 63 | val remove_header : t -> string -> t 64 | 65 | (** [header_exists t key] returns if a response header matches the user provided key. *) 66 | val header_exists : t -> string -> bool 67 | 68 | (** [replace_header] removes all response headers that match the user provided key and 69 | adds a new entry for the key with the new user provided data. *) 70 | val replace_header : t -> key:string -> data:string -> t 71 | -------------------------------------------------------------------------------- /http/src/response0.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | 4 | type body = 5 | | Response of Body.t 6 | | Upgrade of (?unconsumed_data:string -> Fd.t -> unit Deferred.t) 7 | [@@deriving sexp_of] 8 | 9 | type t = 10 | { version : Version.t 11 | ; status : Status.t 12 | ; reason_phrase : string 13 | ; headers : Headers.t 14 | ; body : body 15 | } 16 | [@@deriving sexp_of] 17 | 18 | let with_body t body = 19 | match t.body with 20 | | Response existing_body -> 21 | if phys_equal existing_body body then t else { t with body = Response body } 22 | | Upgrade _ -> raise_s [%message "Attempting to set a body for an upgrade response"] 23 | ;; 24 | -------------------------------------------------------------------------------- /http/src/server.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | module Logger = Async_log.Global.Make () 4 | module Ssl_conn = Ssl 5 | 6 | module Ssl = struct 7 | type t = 8 | { certificate_file : string 9 | ; key_file : string 10 | ; version : Async_ssl.Version.t option 11 | ; options : Async_ssl.Opt.t list option 12 | ; name : string option 13 | ; allowed_ciphers : [ `Only of string list | `Openssl_default | `Secure ] option 14 | ; ca_file : string option 15 | ; ca_path : string option 16 | ; verify_modes : Async_ssl.Verify_mode.t list option 17 | } 18 | [@@deriving sexp_of, fields] 19 | 20 | let create 21 | ?version 22 | ?options 23 | ?name 24 | ?allowed_ciphers 25 | ?ca_file 26 | ?ca_path 27 | ?verify_modes 28 | ~certificate_file 29 | ~key_file 30 | () 31 | = 32 | { certificate_file 33 | ; key_file 34 | ; version 35 | ; options 36 | ; name 37 | ; allowed_ciphers 38 | ; ca_file 39 | ; ca_path 40 | ; verify_modes 41 | } 42 | ;; 43 | end 44 | 45 | type error_handler = ?exn:Exn.t -> ?request:Request.t -> Status.t -> Response.t Deferred.t 46 | [@@deriving sexp_of] 47 | 48 | let default_error_handler ?exn:_ ?request:_ status = 49 | return 50 | (Response.create 51 | ~headers:[ "Connection", "close"; "Content-Length", "0" ] 52 | ~body:Body.empty 53 | status) 54 | ;; 55 | 56 | module Config = struct 57 | type t = 58 | { buf_len : int 59 | ; max_buffer_size : int option 60 | ; max_connections : int option 61 | ; max_accepts_per_batch : int option 62 | ; backlog : int option 63 | ; write_timeout : Time_ns.Span.t option 64 | ; read_header_timeout : Time_ns.Span.t option 65 | ; error_handler : error_handler 66 | ; ssl : Ssl.t option 67 | } 68 | [@@deriving sexp_of] 69 | 70 | let create 71 | ?(buf_len = 0x4000) 72 | ?max_buffer_size 73 | ?max_connections 74 | ?max_accepts_per_batch 75 | ?backlog 76 | ?write_timeout 77 | ?read_header_timeout 78 | ?(error_handler = default_error_handler) 79 | ?ssl 80 | () 81 | = 82 | { buf_len 83 | ; max_buffer_size 84 | ; max_connections 85 | ; max_accepts_per_batch 86 | ; backlog 87 | ; write_timeout 88 | ; read_header_timeout 89 | ; error_handler 90 | ; ssl 91 | } 92 | ;; 93 | 94 | let default = create ~max_accepts_per_batch:64 ~backlog:128 () 95 | end 96 | 97 | type 'a t = 98 | { closed : unit Ivar.t 99 | ; monitor : Monitor.t 100 | ; reader : Input_channel.t 101 | ; writer : Output_channel.t 102 | ; error_handler : error_handler 103 | ; read_header_timeout : Time_ns.Span.t 104 | ; ssl : Async_ssl.Ssl.Connection.t option 105 | ; addr : 'a 106 | } 107 | [@@deriving sexp_of] 108 | 109 | type 'addr service = 'addr t -> Request.t -> Response.t Deferred.t [@@deriving sexp_of] 110 | 111 | let closed t = Ivar.read t.closed 112 | let close t = if Ivar.is_empty t.closed then Ivar.fill_exn t.closed () 113 | let is_ssl t = Option.is_some t.ssl 114 | 115 | let ssl_peer_certificate t = 116 | let%bind.Option ssl = t.ssl in 117 | Async_ssl.Ssl.Connection.peer_certificate ssl 118 | ;; 119 | 120 | let ssl_version t = 121 | let%map.Option ssl = t.ssl in 122 | Async_ssl.Ssl.Connection.version ssl 123 | ;; 124 | 125 | let peer_addr t = t.addr 126 | 127 | let write_response t res = 128 | Output_channel.write t.writer (Version.to_string (Response.version res)); 129 | Output_channel.write_char t.writer ' '; 130 | Output_channel.write t.writer (Status.to_string (Response.status res)); 131 | Output_channel.write_char t.writer ' '; 132 | Output_channel.write t.writer "\r\n"; 133 | let res = 134 | match Response.body res with 135 | | Body.Empty -> Response.add_transfer_encoding res (`Fixed 0) 136 | | Fixed x -> Response.add_transfer_encoding res (`Fixed (String.length x)) 137 | | Stream stream -> 138 | (* Schedule a close operation for the response stream for whenever the server is 139 | closed. This should ensure that any resource held by the stream will get cleaned 140 | up. *) 141 | upon (closed t) (fun () -> Body.Stream.close stream); 142 | (match Body.Stream.encoding stream with 143 | | `Chunked -> Response.add_transfer_encoding res `Chunked 144 | | `Fixed _ as encoding -> Response.add_transfer_encoding res encoding) 145 | in 146 | Response.iter_headers 147 | ~f:(fun ~key ~data -> 148 | Output_channel.write t.writer key; 149 | Output_channel.write t.writer ": "; 150 | Output_channel.write t.writer data; 151 | Output_channel.write t.writer "\r\n") 152 | res; 153 | Output_channel.write t.writer "\r\n" 154 | ;; 155 | 156 | let create 157 | ?(error_handler = default_error_handler) 158 | ?(read_header_timeout = Time_ns.Span.minute) 159 | ?ssl 160 | addr 161 | reader 162 | writer 163 | = 164 | { closed = Ivar.create () 165 | ; monitor = Monitor.create () 166 | ; reader 167 | ; writer 168 | ; error_handler 169 | ; read_header_timeout 170 | ; ssl 171 | ; addr 172 | } 173 | ;; 174 | 175 | let run_server_loop t handler = 176 | let rec parse_request t = 177 | let view = Input_channel.view t.reader in 178 | match Parser.parse_request view.buf ~pos:view.pos ~len:view.len with 179 | | Error Partial -> 180 | Input_channel.refill t.reader 181 | >>> (function 182 | | `Eof -> Ivar.fill_exn t.closed () 183 | | `Ok -> parse_request t) 184 | | Error (Fail error) -> 185 | t.error_handler ~exn:(Error.to_exn error) `Bad_request 186 | >>> fun response -> 187 | (write_response t response; 188 | Io_util.write_body (Response.body response) t.writer) 189 | >>> fun () -> Ivar.fill_exn t.closed () 190 | | Ok (req, consumed) -> 191 | Input_channel.consume t.reader consumed; 192 | create_request_body_reader t req 193 | and parse_request_with_timeout t span = 194 | let view = Input_channel.view t.reader in 195 | match Parser.parse_request view.buf ~pos:view.pos ~len:view.len with 196 | | Error Partial -> 197 | let now = Time_ns.now () in 198 | Input_channel.refill_with_timeout t.reader span 199 | >>> fun v -> 200 | (match v with 201 | | `Eof -> Ivar.fill_exn t.closed () 202 | | `Ok -> 203 | let now' = Time_ns.now () in 204 | let diff = Time_ns.abs_diff now now' in 205 | parse_request_with_timeout t Time_ns.Span.(span - diff)) 206 | | Error (Fail error) -> 207 | t.error_handler ~exn:(Error.to_exn error) `Bad_request 208 | >>> fun response -> 209 | (write_response t response; 210 | Io_util.write_body (Response.body response) t.writer) 211 | >>> fun () -> Ivar.fill_exn t.closed () 212 | | Ok (req, consumed) -> 213 | Input_channel.consume t.reader consumed; 214 | create_request_body_reader t req 215 | and create_request_body_reader t req = 216 | match Io_util.parse_body t.reader (Request.transfer_encoding req) with 217 | | Error e -> 218 | t.error_handler ~exn:(Error.to_exn e) ~request:req `Bad_request 219 | >>> fun response -> 220 | (write_response t response; 221 | Io_util.write_body (Response.body response) t.writer) 222 | >>> fun () -> Ivar.fill_exn t.closed () 223 | | Ok req_body -> 224 | let req = Request.with_body req req_body in 225 | let promise = handler t req in 226 | if Deferred.is_determined promise 227 | then write_response_and_continue t req (Deferred.value_exn promise) 228 | else promise >>> fun response -> write_response_and_continue t req response 229 | and write_response_and_continue t req (response : Response0.t) = 230 | let is_keep_alive = Request.keep_alive req && Response.keep_alive response in 231 | (write_response t response; 232 | Io_util.write_body (Response.body response) t.writer) 233 | >>> fun () -> 234 | match response.body with 235 | | Upgrade handler -> 236 | let (view : Slice.t) = Input_channel.view t.reader in 237 | let unconsumed_data = 238 | if view.len = 0 239 | then None 240 | else Some (Bigstring.to_string view.buf ~pos:view.pos ~len:view.len) 241 | in 242 | let reader_fd = Input_channel.fd t.reader in 243 | let writer_fd = Output_channel.fd t.writer in 244 | assert (phys_equal reader_fd writer_fd); 245 | Monitor.try_with ~here:[%here] (fun () -> handler ?unconsumed_data reader_fd) 246 | >>> fun res -> 247 | (match res with 248 | | Ok () -> () 249 | | Error exn -> 250 | Logger.error "Error while running upgrade handler: %s" (Exn.to_string exn)); 251 | Ivar.fill_exn t.closed () 252 | | Response _ -> 253 | if is_keep_alive 254 | then ( 255 | match Request.body req with 256 | | Body.Empty | Fixed _ -> 257 | if Time_ns.Span.is_positive t.read_header_timeout 258 | then parse_request_with_timeout t t.read_header_timeout 259 | else parse_request t 260 | | Stream stream -> 261 | (if Body.Stream.read_started stream 262 | then Body.Stream.closed stream 263 | else Body.Stream.drain stream) 264 | >>> fun () -> 265 | if Time_ns.Span.is_positive t.read_header_timeout 266 | then parse_request_with_timeout t t.read_header_timeout 267 | else parse_request t) 268 | else Ivar.fill_exn t.closed () 269 | in 270 | Monitor.detach t.monitor; 271 | Scheduler.within ~priority:Priority.normal ~monitor:t.monitor (fun () -> 272 | if Time_ns.Span.is_positive t.read_header_timeout 273 | then parse_request_with_timeout t t.read_header_timeout 274 | else parse_request t); 275 | upon (Monitor.get_next_error t.monitor) (fun exn -> 276 | (match Monitor.extract_exn exn with 277 | | Input_channel.Timeout -> t.error_handler `Request_timeout 278 | | exn -> t.error_handler ~exn `Internal_server_error) 279 | >>> fun response -> 280 | if Ivar.is_empty t.closed 281 | then 282 | (write_response t response; 283 | Io_util.write_body (Response.body response) t.writer) 284 | >>> fun () -> Ivar.fill_exn t.closed ()); 285 | Ivar.read t.closed 286 | ;; 287 | 288 | let run_server ?ssl ~addr ~interrupt config reader writer service = 289 | let server = 290 | create 291 | ?ssl 292 | ~error_handler:config.Config.error_handler 293 | ?read_header_timeout:config.read_header_timeout 294 | addr 295 | reader 296 | writer 297 | in 298 | upon 299 | (Deferred.any_unit 300 | [ Output_channel.remote_closed writer 301 | ; Output_channel.close_started writer 302 | ; interrupt 303 | ]) 304 | (fun () -> close server); 305 | run_server_loop server service 306 | ;; 307 | 308 | let run_server_loop (config : Config.t) addr interrupt reader writer service = 309 | match config.ssl with 310 | | Some ssl -> 311 | Ssl_conn.upgrade_server_connection 312 | reader 313 | writer 314 | ~crt_file:ssl.Ssl.certificate_file 315 | ~key_file:ssl.key_file 316 | ?version:ssl.version 317 | ?options:ssl.options 318 | ?name:ssl.name 319 | ?allowed_ciphers:ssl.allowed_ciphers 320 | ?ca_file:ssl.ca_file 321 | ?ca_path:ssl.ca_path 322 | ?verify_modes:ssl.verify_modes 323 | ~f:(fun ssl_conn reader writer -> 324 | run_server 325 | ~addr 326 | ~ssl:ssl_conn 327 | ~interrupt:(Ivar.read interrupt) 328 | config 329 | reader 330 | writer 331 | service) 332 | | None -> run_server ~addr ~interrupt:(Ivar.read interrupt) config reader writer service 333 | ;; 334 | 335 | let run_inet ?(config = Config.default) addr service = 336 | let interrupt = Ivar.create () in 337 | let server = 338 | Tcp_channel.listen_inet 339 | ~buf_len:config.buf_len 340 | ?max_buffer_size:config.max_buffer_size 341 | ?max_connections:config.max_connections 342 | ?max_accepts_per_batch:config.max_accepts_per_batch 343 | ?backlog:config.backlog 344 | ?write_timeout:config.write_timeout 345 | ~on_handler_error: 346 | (`Call 347 | (fun _addr exn -> 348 | Ivar.fill_if_empty interrupt (); 349 | raise exn)) 350 | addr 351 | (fun addr reader writer -> 352 | run_server_loop config addr interrupt reader writer service) 353 | in 354 | upon (Tcp.Server.close_finished server) (fun () -> Ivar.fill_if_empty interrupt ()); 355 | server 356 | ;; 357 | 358 | let run ?(config = Config.default) addr service = 359 | let interrupt = Ivar.create () in 360 | let%map server = 361 | Tcp_channel.listen 362 | ~buf_len:config.buf_len 363 | ?max_buffer_size:config.max_buffer_size 364 | ?max_connections:config.max_connections 365 | ?max_accepts_per_batch:config.max_accepts_per_batch 366 | ?backlog:config.backlog 367 | ?write_timeout:config.write_timeout 368 | ~on_handler_error: 369 | (`Call 370 | (fun _addr exn -> 371 | Ivar.fill_if_empty interrupt (); 372 | raise exn)) 373 | addr 374 | (fun addr reader writer -> 375 | run_server_loop config addr interrupt reader writer service) 376 | in 377 | upon (Tcp.Server.close_finished server) (fun () -> Ivar.fill_if_empty interrupt ()); 378 | server 379 | ;; 380 | -------------------------------------------------------------------------------- /http/src/server.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | module Logger : Async_log.Global.S 4 | 5 | (** [error_handler] can be used to customize how the server deals with any unhandled 6 | exceptions. A default implementation is provided that will respond with a status code 7 | and an empty response body. *) 8 | type error_handler = ?exn:exn -> ?request:Request.t -> Status.t -> Response.t Deferred.t 9 | 10 | module Ssl : sig 11 | type t [@@deriving sexp_of] 12 | 13 | (** ssl options that should be used when creating a https server. *) 14 | val create 15 | : ?version:Async_ssl.Version.t 16 | -> ?options:Async_ssl.Opt.t list 17 | -> ?name:string 18 | -> ?allowed_ciphers:[ `Only of string list | `Openssl_default | `Secure ] 19 | -> ?ca_file:string 20 | -> ?ca_path:string 21 | -> ?verify_modes:Async_ssl.Verify_mode.t list 22 | -> certificate_file:string 23 | -> key_file:string 24 | -> unit 25 | -> t 26 | end 27 | 28 | module Config : sig 29 | type t [@@deriving sexp_of] 30 | 31 | val default : t 32 | 33 | (** HTTP Server configuration 34 | 35 | - [buf_len] is the buffer size used for the underlying tcp socket channel. The 36 | default value is 16_000 bytes. 37 | 38 | - [max_connections] is the maximum number of concurrent connections that can be 39 | active within a server. The default behavior is to have no upper bound on this 40 | number. 41 | 42 | - [max_accepts_per_batch] is the maximum number of socket connections that a server 43 | will attempt to accept in a single accept call. The default value is 1. 44 | 45 | - [backlog] is the number of clients that can have a pending connection. Additional 46 | connections can be rejected, enqueued or ignored based on the underlying operating 47 | system's behavior. 48 | 49 | - [write_timeout] is the maximum duration that the underlying socket will wait for 50 | any pending write syscalls to finish. 51 | 52 | - [read_header_timeout] is the maximum time span that the server loop is allowed to 53 | read a request's headers. The default value is 60 seconds. If read_header_timeout 54 | is zero then no timeout is used, and the server could potentially wait forever 55 | attempting to read enough data to parse request headers. 56 | 57 | - [error_handler] allows customizing how unhandled exceptions, and any potential 58 | parsing or i/o errors get rendered. The default implementation will attempt to 59 | send an HTTP response with a status code and an empty body. *) 60 | val create 61 | : ?buf_len:int 62 | -> ?max_buffer_size:int 63 | -> ?max_connections:int 64 | -> ?max_accepts_per_batch:int 65 | -> ?backlog:int 66 | -> ?write_timeout:Time_ns.Span.t 67 | -> ?read_header_timeout:Time_ns.Span.t 68 | -> ?error_handler:error_handler 69 | -> ?ssl:Ssl.t 70 | -> unit 71 | -> t 72 | end 73 | 74 | type 'addr t [@@deriving sexp_of] 75 | 76 | val peer_addr : 'addr t -> 'addr 77 | val is_ssl : 'addr t -> bool 78 | val ssl_peer_certificate : 'addr t -> Async_ssl.Ssl.Certificate.t Or_error.t option 79 | val ssl_version : 'addr t -> Async_ssl.Ssl.Version.t option 80 | 81 | (** A user provided [service] that is invoked for every request/response cycle for a HTTP 82 | connection. *) 83 | type 'addr service = 'addr t -> Request.t -> Response.t Deferred.t 84 | 85 | (** [run_inet ?config addr service] runs a http server where each request will be 86 | forwarded to the user provided service. *) 87 | val run_inet 88 | : ?config:Config.t 89 | -> Tcp.Where_to_listen.inet 90 | -> Socket.Address.Inet.t service 91 | -> Tcp.Server.inet 92 | 93 | (** [run ?config addr service] runs a http server where each request will be forwarded to 94 | the user provided service. *) 95 | val run 96 | : ?config:Config.t 97 | -> ('address, 'listening_on) Tcp.Where_to_listen.t 98 | -> 'address service 99 | -> ('address, 'listening_on) Tcp.Server.t Deferred.t 100 | -------------------------------------------------------------------------------- /http/src/shuttle_http.ml: -------------------------------------------------------------------------------- 1 | module Body = Body 2 | module Headers = Headers 3 | module Meth = Meth 4 | module Parser = Parser 5 | module Request = Request 6 | module Response = Response 7 | module Server = Server 8 | module Status = Status 9 | module Version = Version 10 | module Client = Client 11 | -------------------------------------------------------------------------------- /http/src/slice.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type t = 4 | { buf : Bigstring.t 5 | ; pos : int 6 | ; len : int 7 | } 8 | [@@deriving sexp_of] 9 | -------------------------------------------------------------------------------- /http/src/slice.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type t = 4 | { buf : Bigstring.t 5 | ; pos : int 6 | ; len : int 7 | } 8 | [@@deriving sexp_of] 9 | -------------------------------------------------------------------------------- /http/src/ssl.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open! Async_ssl 4 | 5 | let close_channels input_channel output_channel = 6 | let%bind () = Output_channel.close output_channel in 7 | Input_channel.close input_channel 8 | ;; 9 | 10 | let pipe_of_channels input_channel output_channel = 11 | let net_to_ssl, net_to_ssl_writer = Pipe.create () in 12 | upon (Input_channel.transfer input_channel net_to_ssl_writer) (fun () -> 13 | close_channels input_channel output_channel >>> fun () -> Pipe.close net_to_ssl_writer); 14 | let ssl_to_net = Output_channel.pipe output_channel in 15 | upon (Pipe.closed ssl_to_net) (fun () -> 16 | choose 17 | [ choice (after (Time_float.Span.of_sec 30.)) (fun () -> ()) 18 | ; choice (Pipe.downstream_flushed ssl_to_net) (fun (_ : Pipe.Flushed_result.t) -> 19 | ()) 20 | ] 21 | >>> fun () -> don't_wait_for (close_channels input_channel output_channel)); 22 | net_to_ssl, ssl_to_net 23 | ;; 24 | 25 | let upgrade_client_connection 26 | ?version 27 | ?options 28 | ?name 29 | ?hostname 30 | ?allowed_ciphers 31 | ?ca_file 32 | ?ca_path 33 | ?crt_file 34 | ?key_file 35 | ?verify_modes 36 | ?session 37 | ~f 38 | input_channel 39 | output_channel' 40 | = 41 | let net_to_ssl, ssl_to_net = pipe_of_channels input_channel output_channel' in 42 | let app_to_ssl, app_writer = Pipe.create () in 43 | let app_reader, ssl_to_app = Pipe.create () in 44 | match%bind 45 | Ssl.client 46 | ?version 47 | ?options 48 | ?name 49 | ?hostname 50 | ?allowed_ciphers 51 | ?ca_file 52 | ?ca_path 53 | ?crt_file 54 | ?key_file 55 | ?verify_modes 56 | ?session 57 | ~app_to_ssl 58 | ~ssl_to_app 59 | ~net_to_ssl 60 | ~ssl_to_net 61 | () 62 | with 63 | | Error e -> 64 | let%map () = close_channels input_channel output_channel' in 65 | Error.raise e 66 | | Ok conn -> 67 | let%bind input_channel = 68 | Input_channel.of_pipe 69 | ~max_buffer_size:(Input_channel.max_buffer_size input_channel) 70 | ~buf_len:(Input_channel.buffer_size input_channel) 71 | (Info.of_string "shuttle_ssl.ssl_reader") 72 | app_reader 73 | in 74 | upon (Input_channel.closed input_channel) (fun () -> Pipe.close_read app_reader); 75 | let%bind output_channel, flushed = 76 | Output_channel.of_pipe 77 | ~max_buffer_size:(Input_channel.max_buffer_size input_channel) 78 | ~buf_len:(Input_channel.buffer_size input_channel) 79 | (Info.of_string "shuttle_ssl.ssl_writer") 80 | app_writer 81 | in 82 | let shutdown () = 83 | let%bind () = Output_channel.close output_channel in 84 | let%bind () = flushed in 85 | Ssl.Connection.close conn; 86 | let%bind () = 87 | match%map Ssl.Connection.closed conn with 88 | | Ok _ -> () 89 | | Error e -> 90 | Log.Global.error !"Error while shutting down ssl connection %{sexp: Error.t}" e 91 | in 92 | Deferred.all_unit 93 | [ Input_channel.close input_channel 94 | ; Output_channel.close_finished output_channel' 95 | ] 96 | in 97 | Monitor.protect ~run:`Now ~finally:shutdown (fun () -> 98 | f conn input_channel output_channel) 99 | ;; 100 | 101 | let upgrade_server_connection 102 | ?version 103 | ?options 104 | ?name 105 | ?allowed_ciphers 106 | ?ca_file 107 | ?ca_path 108 | ?verify_modes 109 | ~crt_file 110 | ~key_file 111 | ~f 112 | input_channel 113 | output_channel' 114 | = 115 | let net_to_ssl, ssl_to_net = pipe_of_channels input_channel output_channel' in 116 | let app_to_ssl, app_writer = Pipe.create () in 117 | let app_reader, ssl_to_app = Pipe.create () in 118 | match%bind 119 | Ssl.server 120 | ?version 121 | ?options 122 | ?name 123 | ?allowed_ciphers 124 | ?ca_file 125 | ?ca_path 126 | ?verify_modes 127 | ~crt_file 128 | ~key_file 129 | ~net_to_ssl 130 | ~ssl_to_net 131 | ~ssl_to_app 132 | ~app_to_ssl 133 | () 134 | with 135 | | Error e -> 136 | let%map () = close_channels input_channel output_channel' in 137 | Error.raise e 138 | | Ok conn -> 139 | let%bind input_channel = 140 | Input_channel.of_pipe 141 | ~max_buffer_size:(Input_channel.max_buffer_size input_channel) 142 | ~buf_len:(Input_channel.buffer_size input_channel) 143 | (Info.of_string "shuttle_ssl.ssl_reader") 144 | app_reader 145 | in 146 | upon (Input_channel.closed input_channel) (fun () -> Pipe.close_read app_reader); 147 | let%bind output_channel, flushed = 148 | Output_channel.of_pipe 149 | ~max_buffer_size:(Input_channel.max_buffer_size input_channel) 150 | ~buf_len:(Input_channel.buffer_size input_channel) 151 | (Info.of_string "shuttle_ssl.ssl_writer") 152 | app_writer 153 | in 154 | let shutdown () = 155 | let%bind () = Output_channel.close output_channel in 156 | let%bind () = flushed in 157 | Ssl.Connection.close conn; 158 | let%bind () = 159 | match%map Ssl.Connection.closed conn with 160 | | Ok _ -> () 161 | | Error e -> 162 | Log.Global.error !"Error while shutting down ssl connection %{sexp: Error.t}" e 163 | in 164 | Deferred.all_unit 165 | [ Input_channel.close input_channel 166 | ; Output_channel.close_finished output_channel' 167 | ] 168 | in 169 | Monitor.protect ~run:`Now ~finally:shutdown (fun () -> 170 | f conn input_channel output_channel) 171 | ;; 172 | -------------------------------------------------------------------------------- /http/src/ssl.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Async 3 | 4 | (** [upgrade_server_connection] performs TLS negotiation and if it succeeds, applies [f] 5 | to the new encrypted channels. When the deferred returned by [f] resolves, the TLS 6 | connection is shutdown, and the channels are closed. *) 7 | val upgrade_server_connection 8 | : ?version:Async_ssl.Version.t 9 | -> ?options:Async_ssl.Opt.t list 10 | -> ?name:string 11 | -> ?allowed_ciphers:[ `Only of string list | `Openssl_default | `Secure ] 12 | -> ?ca_file:string 13 | -> ?ca_path:string 14 | -> ?verify_modes:Async_ssl.Verify_mode.t list 15 | -> crt_file:string 16 | -> key_file:string 17 | -> f: 18 | (Async_ssl.Ssl.Connection.t 19 | -> Input_channel.t 20 | -> Output_channel.t 21 | -> unit Deferred.t) 22 | -> Input_channel.t 23 | -> Output_channel.t 24 | -> unit Deferred.t 25 | 26 | val upgrade_client_connection 27 | : ?version:Async_ssl.Version.t 28 | -> ?options:Async_ssl.Opt.t list 29 | -> ?name:string 30 | -> ?hostname:string 31 | -> ?allowed_ciphers:[ `Only of string list | `Openssl_default | `Secure ] 32 | -> ?ca_file:string 33 | -> ?ca_path:string 34 | -> ?crt_file:string 35 | -> ?key_file:string 36 | -> ?verify_modes:Async_ssl.Verify_mode.t list 37 | -> ?session:Async_ssl.Ssl.Session.t 38 | -> f: 39 | (Async_ssl.Ssl.Connection.t 40 | -> Input_channel.t 41 | -> Output_channel.t 42 | -> unit Deferred.t) 43 | -> Input_channel.t 44 | -> Output_channel.t 45 | -> unit Deferred.t 46 | -------------------------------------------------------------------------------- /http/src/status.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | (* https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml *) 4 | type informational = 5 | [ `Continue (* [RFC7231, Section 6.2.1] *) 6 | | `Switching_protocols (* [RFC7231, Section 6.2.2] *) 7 | | `Processing (* [RFC2518] *) 8 | | `Early_hints (* [RFC8297] *) 9 | ] 10 | [@@deriving sexp, compare, hash, quickcheck, enumerate] 11 | 12 | let informational_to_code = function 13 | | `Continue -> 100 14 | | `Switching_protocols -> 101 15 | | `Processing -> 102 16 | | `Early_hints -> 103 17 | ;; 18 | 19 | let informational_to_string = function 20 | | `Continue -> "100" 21 | | `Switching_protocols -> "101" 22 | | `Processing -> "102" 23 | | `Early_hints -> "103" 24 | ;; 25 | 26 | let informational_to_reason_phrase = function 27 | | `Continue -> "Continue" 28 | | `Switching_protocols -> "Switching Protocols" 29 | | `Processing -> "Processing" 30 | | `Early_hints -> "Early Hints" 31 | ;; 32 | 33 | type success = 34 | [ `Ok (* [RFC7231, Section 6.3.1] *) 35 | | `Created (* [RFC7231, Section 6.3.2] *) 36 | | `Accepted (* [RFC7231, Section 6.3.3] *) 37 | | `Non_authoritative_information (* [RFC7231, Section 6.3.4] *) 38 | | `No_content (* [RFC7231, Section 6.3.5] *) 39 | | `Reset_content (* [RFC7231, Section 6.3.6] *) 40 | | `Partial_content (* [RFC7233, Section 4.1] *) 41 | | `Multi_status (* [RFC4918] *) 42 | | `Already_reported (* [RFC5842] *) 43 | | `Im_used (* [RFC3229] *) 44 | ] 45 | [@@deriving sexp, compare, hash, quickcheck, enumerate] 46 | 47 | let success_to_code = function 48 | | `Ok -> 200 49 | | `Created -> 201 50 | | `Accepted -> 202 51 | | `Non_authoritative_information -> 203 52 | | `No_content -> 204 53 | | `Reset_content -> 205 54 | | `Partial_content -> 206 55 | | `Multi_status -> 207 56 | | `Already_reported -> 208 57 | | `Im_used -> 226 58 | ;; 59 | 60 | let success_to_string = function 61 | | `Ok -> "200" 62 | | `Created -> "201" 63 | | `Accepted -> "202" 64 | | `Non_authoritative_information -> "203" 65 | | `No_content -> "204" 66 | | `Reset_content -> "205" 67 | | `Partial_content -> "206" 68 | | `Multi_status -> "207" 69 | | `Already_reported -> "208" 70 | | `Im_used -> "226" 71 | ;; 72 | 73 | let success_to_reason_phrase = function 74 | | `Ok -> "OK" 75 | | `Created -> "Created" 76 | | `Accepted -> "Accepted" 77 | | `Non_authoritative_information -> "Non-Authoritative Information" 78 | | `No_content -> "No Content" 79 | | `Reset_content -> "Reset Content" 80 | | `Partial_content -> "Partial Content" 81 | | `Multi_status -> "Multi-Status" 82 | | `Already_reported -> "Already Reported" 83 | | `Im_used -> "IM Used" 84 | ;; 85 | 86 | type redirection = 87 | [ `Multiple_choices (* [RFC7231, Section 6.4.1] *) 88 | | `Moved_permanently (* [RFC7231, Section 6.4.2] *) 89 | | `Found (* [RFC7231, Section 6.4.3] *) 90 | | `See_other (* [RFC7231, Section 6.4.4] *) 91 | | `Not_modified (* [RFC7232, Section 4.1] *) 92 | | `Use_proxy (* [RFC7231, Section 6.4.5] *) 93 | | `Temporary_redirect (* [RFC7231, Section 6.4.7] *) 94 | | `Permanent_redirect (* [RFC7538] *) 95 | ] 96 | [@@deriving sexp, compare, hash, quickcheck, enumerate] 97 | 98 | let redirection_to_code = function 99 | | `Multiple_choices -> 300 100 | | `Moved_permanently -> 301 101 | | `Found -> 302 102 | | `See_other -> 303 103 | | `Not_modified -> 304 104 | | `Use_proxy -> 305 105 | | `Temporary_redirect -> 307 106 | | `Permanent_redirect -> 308 107 | ;; 108 | 109 | let redirection_to_string = function 110 | | `Multiple_choices -> "300" 111 | | `Moved_permanently -> "301" 112 | | `Found -> "302" 113 | | `See_other -> "303" 114 | | `Not_modified -> "304" 115 | | `Use_proxy -> "305" 116 | | `Temporary_redirect -> "307" 117 | | `Permanent_redirect -> "308" 118 | ;; 119 | 120 | let redirection_to_reason_phrase = function 121 | | `Multiple_choices -> "Multiple Choices" 122 | | `Moved_permanently -> "Moved Permanently" 123 | | `Found -> "Found" 124 | | `See_other -> "See Other" 125 | | `Not_modified -> "Not Modified" 126 | | `Use_proxy -> "Use Proxy" 127 | | `Temporary_redirect -> "Temporary Redirect" 128 | | `Permanent_redirect -> "Permanent Redirect" 129 | ;; 130 | 131 | type client_error = 132 | [ `Bad_request (* [RFC7231, Section 6.5.1] *) 133 | | `Unauthorized (* [RFC7235, Section 3.1] *) 134 | | `Payment_required (* [RFC7231, Section 6.5.2] *) 135 | | `Forbidden (* [RFC7231, Section 6.5.3] *) 136 | | `Not_found (* [RFC7231, Section 6.5.4] *) 137 | | `Method_not_allowed (* [RFC7231, Section 6.5.5] *) 138 | | `Not_acceptable (* [RFC7231, Section 6.5.6] *) 139 | | `Proxy_authentication_required (* [RFC7235, Section 3.2] *) 140 | | `Request_timeout (* [RFC7231, Section 6.5.7] *) 141 | | `Conflict (* [RFC7231, Section 6.5.8] *) 142 | | `Gone (* [RFC7231, Section 6.5.9] *) 143 | | `Length_required (* [RFC7231, Section 6.5.10] *) 144 | | `Precondition_failed (* [RFC7232, Section 4.2][RFC8144, Section 3.2] *) 145 | | `Payload_too_large (* [RFC7231, Section 6.5.11] *) 146 | | `Uri_too_long (* [RFC7231, Section 6.5.12] *) 147 | | `Unsupported_media_type (* [RFC7231, Section 6.5.13][RFC7694, Section 3] *) 148 | | `Range_not_satisfiable (* [RFC7233, Section 4.4] *) 149 | | `Expectation_failed (* [RFC7231, Section 6.5.14] *) 150 | | `Misdirected_request (* [RFC7540, Section 9.1.2] *) 151 | | `Unprocessable_entity (* [RFC4918] *) 152 | | `Locked (* [RFC4918] *) 153 | | `Failed_dependency (* [RFC4918] *) 154 | | `Too_early (* [RFC8470] *) 155 | | `Upgrade_required (* [RFC7231, Section 6.5.15] *) 156 | | `Precondition_required (* [RFC6585] *) 157 | | `Too_many_requests (* [RFC6585] *) 158 | | `Request_header_fields_too_large (* [RFC6585] *) 159 | | `Unavailable_for_legal_reasons (* [RFC7725] *) 160 | ] 161 | [@@deriving sexp, compare, hash, quickcheck, enumerate] 162 | 163 | let client_error_to_code = function 164 | | `Bad_request -> 400 165 | | `Unauthorized -> 401 166 | | `Payment_required -> 402 167 | | `Forbidden -> 403 168 | | `Not_found -> 404 169 | | `Method_not_allowed -> 405 170 | | `Not_acceptable -> 406 171 | | `Proxy_authentication_required -> 407 172 | | `Request_timeout -> 408 173 | | `Conflict -> 409 174 | | `Gone -> 410 175 | | `Length_required -> 411 176 | | `Precondition_failed -> 412 177 | | `Payload_too_large -> 413 178 | | `Uri_too_long -> 414 179 | | `Unsupported_media_type -> 415 180 | | `Range_not_satisfiable -> 416 181 | | `Expectation_failed -> 417 182 | | `Misdirected_request -> 421 183 | | `Unprocessable_entity -> 422 184 | | `Locked -> 423 185 | | `Failed_dependency -> 424 186 | | `Too_early -> 425 187 | | `Upgrade_required -> 426 188 | | `Precondition_required -> 428 189 | | `Too_many_requests -> 429 190 | | `Request_header_fields_too_large -> 431 191 | | `Unavailable_for_legal_reasons -> 451 192 | ;; 193 | 194 | let client_error_to_string = function 195 | | `Bad_request -> "400" 196 | | `Unauthorized -> "401" 197 | | `Payment_required -> "402" 198 | | `Forbidden -> "403" 199 | | `Not_found -> "404" 200 | | `Method_not_allowed -> "405" 201 | | `Not_acceptable -> "406" 202 | | `Proxy_authentication_required -> "407" 203 | | `Request_timeout -> "408" 204 | | `Conflict -> "409" 205 | | `Gone -> "410" 206 | | `Length_required -> "411" 207 | | `Precondition_failed -> "412" 208 | | `Payload_too_large -> "413" 209 | | `Uri_too_long -> "414" 210 | | `Unsupported_media_type -> "415" 211 | | `Range_not_satisfiable -> "416" 212 | | `Expectation_failed -> "417" 213 | | `Misdirected_request -> "421" 214 | | `Unprocessable_entity -> "422" 215 | | `Locked -> "423" 216 | | `Failed_dependency -> "424" 217 | | `Too_early -> "425" 218 | | `Upgrade_required -> "426" 219 | | `Precondition_required -> "428" 220 | | `Too_many_requests -> "429" 221 | | `Request_header_fields_too_large -> "431" 222 | | `Unavailable_for_legal_reasons -> "451" 223 | ;; 224 | 225 | let client_error_to_reason_phrase = function 226 | | `Bad_request -> "Bad Request" 227 | | `Unauthorized -> "Unauthorized" 228 | | `Payment_required -> "Payment Required" 229 | | `Forbidden -> "Forbidden" 230 | | `Not_found -> "Not Found" 231 | | `Method_not_allowed -> "Method Not Allowed" 232 | | `Not_acceptable -> "Not Acceptable" 233 | | `Proxy_authentication_required -> "Proxy Authentication Required" 234 | | `Request_timeout -> "Request Timeout" 235 | | `Conflict -> "Conflict" 236 | | `Gone -> "Gone" 237 | | `Length_required -> "Length Required" 238 | | `Precondition_failed -> "Precondition Failed" 239 | | `Payload_too_large -> "Payload Too Large" 240 | | `Uri_too_long -> "URI Too Long" 241 | | `Unsupported_media_type -> "Unsupported Media Type" 242 | | `Range_not_satisfiable -> "Range Not Satisfiable" 243 | | `Expectation_failed -> "Expectation Failed" 244 | | `Misdirected_request -> "Misdirected Request" 245 | | `Unprocessable_entity -> "Unprocessable Entity" 246 | | `Locked -> "Locked" 247 | | `Failed_dependency -> "Failed Dependency" 248 | | `Too_early -> "Too Early" 249 | | `Upgrade_required -> "Upgrade Required" 250 | | `Precondition_required -> "Precondition Required" 251 | | `Too_many_requests -> "Too Many Requests" 252 | | `Request_header_fields_too_large -> "Request Header Fields Too Large" 253 | | `Unavailable_for_legal_reasons -> "Unavailable For Legal Reasons" 254 | ;; 255 | 256 | type server_error = 257 | [ `Internal_server_error (* [RFC7231, Section 6.6.1] *) 258 | | `Not_implemented (* [RFC7231, Section 6.6.2] *) 259 | | `Bad_gateway (* [RFC7231, Section 6.6.3] *) 260 | | `Service_unavailable (* [RFC7231, Section 6.6.4] *) 261 | | `Gateway_timeout (* [RFC7231, Section 6.6.5] *) 262 | | `Http_version_not_supported (* [RFC7231, Section 6.6.6] *) 263 | | `Variant_also_negotiates (* [RFC2295] *) 264 | | `Insufficient_storage (* [RFC4918] *) 265 | | `Loop_detected (* [RFC5842] *) 266 | | `Not_extended (* [RFC2774] *) 267 | | `Network_authentication_required (* [RFC6585] *) 268 | ] 269 | [@@deriving sexp, compare, hash, quickcheck, enumerate] 270 | 271 | let server_error_to_code = function 272 | | `Internal_server_error -> 500 273 | | `Not_implemented -> 501 274 | | `Bad_gateway -> 502 275 | | `Service_unavailable -> 503 276 | | `Gateway_timeout -> 504 277 | | `Http_version_not_supported -> 505 278 | | `Variant_also_negotiates -> 506 279 | | `Insufficient_storage -> 507 280 | | `Loop_detected -> 508 281 | | `Not_extended -> 510 282 | | `Network_authentication_required -> 511 283 | ;; 284 | 285 | let server_error_to_string = function 286 | | `Internal_server_error -> "500" 287 | | `Not_implemented -> "501" 288 | | `Bad_gateway -> "502" 289 | | `Service_unavailable -> "503" 290 | | `Gateway_timeout -> "504" 291 | | `Http_version_not_supported -> "505" 292 | | `Variant_also_negotiates -> "506" 293 | | `Insufficient_storage -> "507" 294 | | `Loop_detected -> "508" 295 | | `Not_extended -> "510" 296 | | `Network_authentication_required -> "511" 297 | ;; 298 | 299 | let server_error_to_reason_phrase = function 300 | | `Internal_server_error -> "Internal Server Error" 301 | | `Not_implemented -> "Not Implemented" 302 | | `Bad_gateway -> "Bad Gateway" 303 | | `Service_unavailable -> "Service Unavailable" 304 | | `Gateway_timeout -> "Gateway Timeout" 305 | | `Http_version_not_supported -> "HTTP Version Not Supported" 306 | | `Variant_also_negotiates -> "Variant Also Negotiates" 307 | | `Insufficient_storage -> "Insufficient Storage" 308 | | `Loop_detected -> "Loop Detected" 309 | | `Not_extended -> "Not Extended" 310 | | `Network_authentication_required -> "Network Authentication Required" 311 | ;; 312 | 313 | type t = 314 | [ informational 315 | | success 316 | | redirection 317 | | client_error 318 | | server_error 319 | ] 320 | [@@deriving sexp, compare, hash, quickcheck, enumerate] 321 | 322 | let to_int = function 323 | | #informational as c -> informational_to_code c 324 | | #success as c -> success_to_code c 325 | | #redirection as c -> redirection_to_code c 326 | | #client_error as c -> client_error_to_code c 327 | | #server_error as c -> server_error_to_code c 328 | ;; 329 | 330 | let to_string = function 331 | | #informational as c -> informational_to_string c 332 | | #success as c -> success_to_string c 333 | | #redirection as c -> redirection_to_string c 334 | | #client_error as c -> client_error_to_string c 335 | | #server_error as c -> server_error_to_string c 336 | ;; 337 | 338 | let to_reason_phrase = function 339 | | #informational as c -> informational_to_reason_phrase c 340 | | #success as c -> success_to_reason_phrase c 341 | | #redirection as c -> redirection_to_reason_phrase c 342 | | #client_error as c -> client_error_to_reason_phrase c 343 | | #server_error as c -> server_error_to_reason_phrase c 344 | ;; 345 | 346 | let of_string : string -> t Or_error.t = 347 | fun code -> 348 | match code with 349 | | "100" -> Ok `Continue 350 | | "101" -> Ok `Switching_protocols 351 | | "102" -> Ok `Processing 352 | | "103" -> Ok `Early_hints 353 | | "200" -> Ok `Ok 354 | | "201" -> Ok `Created 355 | | "202" -> Ok `Accepted 356 | | "203" -> Ok `Non_authoritative_information 357 | | "204" -> Ok `No_content 358 | | "205" -> Ok `Reset_content 359 | | "206" -> Ok `Partial_content 360 | | "207" -> Ok `Multi_status 361 | | "208" -> Ok `Already_reported 362 | | "226" -> Ok `Im_used 363 | | "300" -> Ok `Multiple_choices 364 | | "301" -> Ok `Moved_permanently 365 | | "302" -> Ok `Found 366 | | "303" -> Ok `See_other 367 | | "304" -> Ok `Not_modified 368 | | "305" -> Ok `Use_proxy 369 | | "307" -> Ok `Temporary_redirect 370 | | "308" -> Ok `Permanent_redirect 371 | | "400" -> Ok `Bad_request 372 | | "401" -> Ok `Unauthorized 373 | | "402" -> Ok `Payment_required 374 | | "403" -> Ok `Forbidden 375 | | "404" -> Ok `Not_found 376 | | "405" -> Ok `Method_not_allowed 377 | | "406" -> Ok `Not_acceptable 378 | | "407" -> Ok `Proxy_authentication_required 379 | | "408" -> Ok `Request_timeout 380 | | "409" -> Ok `Conflict 381 | | "410" -> Ok `Gone 382 | | "411" -> Ok `Length_required 383 | | "412" -> Ok `Precondition_failed 384 | | "413" -> Ok `Payload_too_large 385 | | "414" -> Ok `Uri_too_long 386 | | "415" -> Ok `Unsupported_media_type 387 | | "416" -> Ok `Range_not_satisfiable 388 | | "417" -> Ok `Expectation_failed 389 | | "421" -> Ok `Misdirected_request 390 | | "422" -> Ok `Unprocessable_entity 391 | | "423" -> Ok `Locked 392 | | "424" -> Ok `Failed_dependency 393 | | "425" -> Ok `Too_early 394 | | "426" -> Ok `Upgrade_required 395 | | "428" -> Ok `Precondition_required 396 | | "429" -> Ok `Too_many_requests 397 | | "431" -> Ok `Request_header_fields_too_large 398 | | "451" -> Ok `Unavailable_for_legal_reasons 399 | | "500" -> Ok `Internal_server_error 400 | | "501" -> Ok `Not_implemented 401 | | "502" -> Ok `Bad_gateway 402 | | "503" -> Ok `Service_unavailable 403 | | "504" -> Ok `Gateway_timeout 404 | | "505" -> Ok `Http_version_not_supported 405 | | "506" -> Ok `Variant_also_negotiates 406 | | "507" -> Ok `Insufficient_storage 407 | | "508" -> Ok `Loop_detected 408 | | "510" -> Ok `Not_extended 409 | | "511" -> Ok `Network_authentication_required 410 | | code -> Or_error.errorf "Invalid status code %s" code 411 | ;; 412 | 413 | let of_int : int -> t Or_error.t = 414 | fun code -> 415 | match code with 416 | | 100 -> Ok `Continue 417 | | 101 -> Ok `Switching_protocols 418 | | 102 -> Ok `Processing 419 | | 103 -> Ok `Early_hints 420 | | 200 -> Ok `Ok 421 | | 201 -> Ok `Created 422 | | 202 -> Ok `Accepted 423 | | 203 -> Ok `Non_authoritative_information 424 | | 204 -> Ok `No_content 425 | | 205 -> Ok `Reset_content 426 | | 206 -> Ok `Partial_content 427 | | 207 -> Ok `Multi_status 428 | | 208 -> Ok `Already_reported 429 | | 226 -> Ok `Im_used 430 | | 300 -> Ok `Multiple_choices 431 | | 301 -> Ok `Moved_permanently 432 | | 302 -> Ok `Found 433 | | 303 -> Ok `See_other 434 | | 304 -> Ok `Not_modified 435 | | 305 -> Ok `Use_proxy 436 | | 307 -> Ok `Temporary_redirect 437 | | 308 -> Ok `Permanent_redirect 438 | | 400 -> Ok `Bad_request 439 | | 401 -> Ok `Unauthorized 440 | | 402 -> Ok `Payment_required 441 | | 403 -> Ok `Forbidden 442 | | 404 -> Ok `Not_found 443 | | 405 -> Ok `Method_not_allowed 444 | | 406 -> Ok `Not_acceptable 445 | | 407 -> Ok `Proxy_authentication_required 446 | | 408 -> Ok `Request_timeout 447 | | 409 -> Ok `Conflict 448 | | 410 -> Ok `Gone 449 | | 411 -> Ok `Length_required 450 | | 412 -> Ok `Precondition_failed 451 | | 413 -> Ok `Payload_too_large 452 | | 414 -> Ok `Uri_too_long 453 | | 415 -> Ok `Unsupported_media_type 454 | | 416 -> Ok `Range_not_satisfiable 455 | | 417 -> Ok `Expectation_failed 456 | | 421 -> Ok `Misdirected_request 457 | | 422 -> Ok `Unprocessable_entity 458 | | 423 -> Ok `Locked 459 | | 424 -> Ok `Failed_dependency 460 | | 425 -> Ok `Too_early 461 | | 426 -> Ok `Upgrade_required 462 | | 428 -> Ok `Precondition_required 463 | | 429 -> Ok `Too_many_requests 464 | | 431 -> Ok `Request_header_fields_too_large 465 | | 451 -> Ok `Unavailable_for_legal_reasons 466 | | 500 -> Ok `Internal_server_error 467 | | 501 -> Ok `Not_implemented 468 | | 502 -> Ok `Bad_gateway 469 | | 503 -> Ok `Service_unavailable 470 | | 504 -> Ok `Gateway_timeout 471 | | 505 -> Ok `Http_version_not_supported 472 | | 506 -> Ok `Variant_also_negotiates 473 | | 507 -> Ok `Insufficient_storage 474 | | 508 -> Ok `Loop_detected 475 | | 510 -> Ok `Not_extended 476 | | 511 -> Ok `Network_authentication_required 477 | | code -> Or_error.errorf "Invalid status code %d" code 478 | ;; 479 | -------------------------------------------------------------------------------- /http/src/status.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | (* https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml *) 4 | type informational = 5 | [ `Continue (* [RFC7231, Section 6.2.1] *) 6 | | `Switching_protocols (* [RFC7231, Section 6.2.2] *) 7 | | `Processing (* [RFC2518] *) 8 | | `Early_hints (* [RFC8297] *) 9 | ] 10 | [@@deriving sexp, compare, hash, quickcheck, enumerate] 11 | 12 | type success = 13 | [ `Ok (* [RFC7231, Section 6.3.1] *) 14 | | `Created (* [RFC7231, Section 6.3.2] *) 15 | | `Accepted (* [RFC7231, Section 6.3.3] *) 16 | | `Non_authoritative_information (* [RFC7231, Section 6.3.4] *) 17 | | `No_content (* [RFC7231, Section 6.3.5] *) 18 | | `Reset_content (* [RFC7231, Section 6.3.6] *) 19 | | `Partial_content (* [RFC7233, Section 4.1] *) 20 | | `Multi_status (* [RFC4918] *) 21 | | `Already_reported (* [RFC5842] *) 22 | | `Im_used (* [RFC3229] *) 23 | ] 24 | [@@deriving sexp, compare, hash, quickcheck, enumerate] 25 | 26 | type redirection = 27 | [ `Multiple_choices (* [RFC7231, Section 6.4.1] *) 28 | | `Moved_permanently (* [RFC7231, Section 6.4.2] *) 29 | | `Found (* [RFC7231, Section 6.4.3] *) 30 | | `See_other (* [RFC7231, Section 6.4.4] *) 31 | | `Not_modified (* [RFC7232, Section 4.1] *) 32 | | `Use_proxy (* [RFC7231, Section 6.4.5] *) 33 | | `Temporary_redirect (* [RFC7231, Section 6.4.7] *) 34 | | `Permanent_redirect (* [RFC7538] *) 35 | ] 36 | [@@deriving sexp, compare, hash, quickcheck, enumerate] 37 | 38 | type client_error = 39 | [ `Bad_request (* [RFC7231, Section 6.5.1] *) 40 | | `Unauthorized (* [RFC7235, Section 3.1] *) 41 | | `Payment_required (* [RFC7231, Section 6.5.2] *) 42 | | `Forbidden (* [RFC7231, Section 6.5.3] *) 43 | | `Not_found (* [RFC7231, Section 6.5.4] *) 44 | | `Method_not_allowed (* [RFC7231, Section 6.5.5] *) 45 | | `Not_acceptable (* [RFC7231, Section 6.5.6] *) 46 | | `Proxy_authentication_required (* [RFC7235, Section 3.2] *) 47 | | `Request_timeout (* [RFC7231, Section 6.5.7] *) 48 | | `Conflict (* [RFC7231, Section 6.5.8] *) 49 | | `Gone (* [RFC7231, Section 6.5.9] *) 50 | | `Length_required (* [RFC7231, Section 6.5.10] *) 51 | | `Precondition_failed (* [RFC7232, Section 4.2][RFC8144, Section 3.2] *) 52 | | `Payload_too_large (* [RFC7231, Section 6.5.11] *) 53 | | `Uri_too_long (* [RFC7231, Section 6.5.12] *) 54 | | `Unsupported_media_type (* [RFC7231, Section 6.5.13][RFC7694, Section 3] *) 55 | | `Range_not_satisfiable (* [RFC7233, Section 4.4] *) 56 | | `Expectation_failed (* [RFC7231, Section 6.5.14] *) 57 | | `Misdirected_request (* [RFC7540, Section 9.1.2] *) 58 | | `Unprocessable_entity (* [RFC4918] *) 59 | | `Locked (* [RFC4918] *) 60 | | `Failed_dependency (* [RFC4918] *) 61 | | `Too_early (* [RFC8470] *) 62 | | `Upgrade_required (* [RFC7231, Section 6.5.15] *) 63 | | `Precondition_required (* [RFC6585] *) 64 | | `Too_many_requests (* [RFC6585] *) 65 | | `Request_header_fields_too_large (* [RFC6585] *) 66 | | `Unavailable_for_legal_reasons (* [RFC7725] *) 67 | ] 68 | [@@deriving sexp, compare, hash, quickcheck, enumerate] 69 | 70 | type server_error = 71 | [ `Internal_server_error (* [RFC7231, Section 6.6.1] *) 72 | | `Not_implemented (* [RFC7231, Section 6.6.2] *) 73 | | `Bad_gateway (* [RFC7231, Section 6.6.3] *) 74 | | `Service_unavailable (* [RFC7231, Section 6.6.4] *) 75 | | `Gateway_timeout (* [RFC7231, Section 6.6.5] *) 76 | | `Http_version_not_supported (* [RFC7231, Section 6.6.6] *) 77 | | `Variant_also_negotiates (* [RFC2295] *) 78 | | `Insufficient_storage (* [RFC4918] *) 79 | | `Loop_detected (* [RFC5842] *) 80 | | `Not_extended (* [RFC2774] *) 81 | | `Network_authentication_required (* [RFC6585] *) 82 | ] 83 | [@@deriving sexp, compare, hash, quickcheck, enumerate] 84 | 85 | type t = 86 | [ informational 87 | | success 88 | | redirection 89 | | client_error 90 | | server_error 91 | ] 92 | [@@deriving sexp, compare, hash, quickcheck, enumerate] 93 | 94 | val to_int : t -> int 95 | val of_int : int -> t Or_error.t 96 | val to_string : t -> string 97 | val of_string : string -> t Or_error.t 98 | val to_reason_phrase : t -> string 99 | -------------------------------------------------------------------------------- /http/src/tcp_channel.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | let close_channels reader writer = 5 | let%bind () = Output_channel.close writer in 6 | Input_channel.close reader 7 | ;; 8 | 9 | let collect_errors writer fn = 10 | let monitor = Output_channel.monitor writer in 11 | Monitor.detach monitor; 12 | choose 13 | [ choice (Monitor.get_next_error monitor) (fun e -> Error e) 14 | ; choice (Monitor.try_with ~run:`Now ~rest:`Log fn) Fn.id 15 | ] 16 | ;; 17 | 18 | let listen 19 | ?max_connections 20 | ?max_accepts_per_batch 21 | ?backlog 22 | ?socket 23 | ?max_buffer_size 24 | ?buf_len 25 | ?write_timeout 26 | ?time_source 27 | ~on_handler_error 28 | where_to_listen 29 | handler 30 | = 31 | Tcp.Server.create_sock 32 | ?max_connections 33 | ?max_accepts_per_batch 34 | ?backlog 35 | ?socket 36 | ?time_source 37 | ~on_handler_error 38 | where_to_listen 39 | (fun addr socket -> 40 | let fd = Socket.fd socket in 41 | let input_channel = 42 | Input_channel.create ?max_buffer_size ?buf_len ?time_source fd 43 | in 44 | let output_channel = 45 | Output_channel.create ?max_buffer_size ?buf_len ?write_timeout ?time_source fd 46 | in 47 | let%bind res = 48 | Deferred.any 49 | [ collect_errors output_channel (fun () -> 50 | handler addr input_channel output_channel) 51 | ; Output_channel.remote_closed output_channel |> Deferred.ok 52 | ] 53 | in 54 | let%bind () = close_channels input_channel output_channel in 55 | match res with 56 | | Ok () -> Deferred.unit 57 | | Error exn -> raise exn) 58 | ;; 59 | 60 | let listen_inet 61 | ?max_connections 62 | ?max_accepts_per_batch 63 | ?backlog 64 | ?socket 65 | ?max_buffer_size 66 | ?buf_len 67 | ?write_timeout 68 | ?time_source 69 | ~on_handler_error 70 | where_to_listen 71 | handler 72 | = 73 | Tcp.Server.create_sock_inet 74 | ?max_connections 75 | ?max_accepts_per_batch 76 | ?backlog 77 | ?socket 78 | ?time_source 79 | ~on_handler_error 80 | where_to_listen 81 | (fun addr socket -> 82 | let fd = Socket.fd socket in 83 | let input_channel = 84 | Input_channel.create ?max_buffer_size ?buf_len ?time_source fd 85 | in 86 | let output_channel = 87 | Output_channel.create ?max_buffer_size ?buf_len ?write_timeout ?time_source fd 88 | in 89 | let%bind res = 90 | Deferred.any 91 | [ collect_errors output_channel (fun () -> 92 | handler addr input_channel output_channel) 93 | ; Output_channel.remote_closed output_channel |> Deferred.ok 94 | ] 95 | in 96 | let%bind () = close_channels input_channel output_channel in 97 | match res with 98 | | Ok () -> Deferred.unit 99 | | Error exn -> raise exn) 100 | ;; 101 | 102 | let with_connection 103 | ?interrupt 104 | ?connect_timeout 105 | ?max_buffer_size 106 | ?buf_len 107 | ?write_timeout 108 | ?time_source 109 | where_to_connect 110 | f 111 | = 112 | let%bind socket = 113 | Tcp.connect_sock ?interrupt ?timeout:connect_timeout ?time_source where_to_connect 114 | in 115 | let fd = Socket.fd socket in 116 | let input_channel = Input_channel.create ?max_buffer_size ?buf_len ?time_source fd in 117 | let output_channel = 118 | Output_channel.create ?max_buffer_size ?buf_len ?time_source ?write_timeout fd 119 | in 120 | let res = collect_errors output_channel (fun () -> f input_channel output_channel) in 121 | let%bind () = 122 | Deferred.any_unit 123 | [ (res >>| fun _ -> ()) 124 | ; Output_channel.close_finished output_channel 125 | ; Input_channel.closed input_channel 126 | ] 127 | in 128 | let%bind () = close_channels input_channel output_channel in 129 | match%map res with 130 | | Ok v -> v 131 | | Error exn -> 132 | Exn.reraise exn "Shuttle.Connection: Unhandled exception in TCP client connection" 133 | ;; 134 | 135 | let connect 136 | ?interrupt 137 | ?connect_timeout 138 | ?max_buffer_size 139 | ?buf_len 140 | ?write_timeout 141 | ?time_source 142 | where_to_connect 143 | = 144 | let%map socket = 145 | Tcp.connect_sock ?interrupt ?timeout:connect_timeout ?time_source where_to_connect 146 | in 147 | let fd = Socket.fd socket in 148 | let reader = Input_channel.create ?max_buffer_size ?buf_len ?time_source fd in 149 | let writer = 150 | Output_channel.create ?max_buffer_size ?buf_len ?time_source ?write_timeout fd 151 | in 152 | reader, writer 153 | ;; 154 | -------------------------------------------------------------------------------- /http/src/tcp_channel.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | (** [listen] is a wrapper for [Async.Tcp.Server.create_sock]. It uses async to setup a tcp 5 | server, and creates a new [Input_channel] and [Output_channel] to forward to the user 6 | provided tcp handler. [listen] will shutdown the server socket either if the handler 7 | raises an exception, or the Output_channel can no longer write any more bytes (it 8 | encountered an EPIPE, ECONNRESET). If the server loop is stopped because of a user 9 | exception, the exception will be re-raised once the socket has been shutdown. *) 10 | val listen 11 | : ?max_connections:int 12 | -> ?max_accepts_per_batch:int 13 | -> ?backlog:int 14 | -> ?socket:([ `Unconnected ], ([< Socket.Address.t ] as 'address)) Socket.t 15 | -> ?max_buffer_size:int 16 | -> ?buf_len:int 17 | -> ?write_timeout:Time_ns.Span.t 18 | -> ?time_source:[> read ] Time_source.T1.t 19 | -> on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ] 20 | -> ('address, 'listening_on) Tcp.Where_to_listen.t 21 | -> ('address -> Input_channel.t -> Output_channel.t -> unit Deferred.t) 22 | -> ('address, 'listening_on) Tcp.Server.t Deferred.t 23 | 24 | val listen_inet 25 | : ?max_connections:int 26 | -> ?max_accepts_per_batch:int 27 | -> ?backlog:int 28 | -> ?socket:([ `Unconnected ], Socket.Address.Inet.t) Socket.t 29 | -> ?max_buffer_size:int 30 | -> ?buf_len:int 31 | -> ?write_timeout:Time_ns.Span.t 32 | -> ?time_source:[> read ] Time_source.T1.t 33 | -> on_handler_error:[ `Call of Socket.Address.Inet.t -> exn -> unit | `Ignore | `Raise ] 34 | -> Tcp.Where_to_listen.inet 35 | -> (Socket.Address.Inet.t -> Input_channel.t -> Output_channel.t -> unit Deferred.t) 36 | -> (Socket.Address.Inet.t, int) Tcp.Server.t 37 | 38 | (** [with_connection] is a wrapper for [Async.Tcp.connect_sock]. It uses async to setup a 39 | tcp client, and creates a new [Input_channel] and [Output_channel] to forward to the 40 | user provided handler. *) 41 | val with_connection 42 | : ?interrupt:unit Deferred.t 43 | -> ?connect_timeout:Time_float.Span.t 44 | -> ?max_buffer_size:int 45 | -> ?buf_len:int 46 | -> ?write_timeout:Time_ns.Span.t 47 | -> ?time_source:[> read ] Time_source.T1.t 48 | -> [< Socket.Address.t ] Tcp.Where_to_connect.t 49 | -> (Input_channel.t -> Output_channel.t -> 'res Deferred.t) 50 | -> 'res Async_kernel__Types.Deferred.t 51 | 52 | val connect 53 | : ?interrupt:unit Deferred.t 54 | -> ?connect_timeout:Time_float.Span.t 55 | -> ?max_buffer_size:int 56 | -> ?buf_len:int 57 | -> ?write_timeout:Time_ns.Span.t 58 | -> ?time_source:[> read ] Time_source.T1.t 59 | -> [< Socket.Address.t ] Tcp.Where_to_connect.t 60 | -> (Input_channel.t * Output_channel.t) Deferred.t 61 | -------------------------------------------------------------------------------- /http/src/version.ml: -------------------------------------------------------------------------------- 1 | type t = Http_1_1 [@@deriving sexp] 2 | 3 | let to_string = function 4 | | Http_1_1 -> "HTTP/1.1" 5 | ;; 6 | -------------------------------------------------------------------------------- /http/src/version.mli: -------------------------------------------------------------------------------- 1 | type t = Http_1_1 [@@deriving sexp] 2 | 3 | val to_string : t -> string 4 | -------------------------------------------------------------------------------- /http/test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_shuttle_http) 3 | (package shuttle_http) 4 | (preprocess 5 | (pps ppx_jane)) 6 | (inline_tests 7 | (deps 8 | ./id_000000,sig_06,src_000000,time_3062,execs_583,op_havoc,rep_2 9 | ./id_000001,sig_06,src_000000,time_4184,execs_831,op_havoc,rep_8 10 | ./id_000002,sig_06,src_000000,time_5043,execs_1025,op_havoc,rep_2 11 | ./id_000003,sig_06,src_000000,time_5674,execs_1176,op_havoc,rep_2 12 | ./id_000004,sig_06,src_000000,time_9755,execs_2148,op_havoc,rep_2)) 13 | (libraries shuttle_http)) 14 | -------------------------------------------------------------------------------- /http/test/helper.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | let rec connect port = 5 | match%bind 6 | Monitor.try_with (fun () -> 7 | Tcp.connect 8 | (Tcp.Where_to_connect.of_host_and_port 9 | (Host_and_port.create ~host:"localhost" ~port))) 10 | with 11 | | Ok (_, r, w) -> 12 | Writer.set_raise_when_consumer_leaves w false; 13 | return (r, w) 14 | | Error _ -> 15 | let%bind () = Clock_ns.after (Time_ns.Span.of_sec 0.01) in 16 | connect port 17 | ;; 18 | 19 | let with_client port ~f = 20 | let%bind r, w = connect port in 21 | Monitor.protect 22 | (fun () -> f r w) 23 | ~finally:(fun () -> Writer.close w >>= fun () -> Reader.close r) 24 | ;; 25 | 26 | let with_server ?buf_len ?max_buffer_size ?error_handler ?read_header_timeout handler ~f = 27 | let open Shuttle_http in 28 | let server = 29 | Server.run_inet 30 | ~config: 31 | (Server.Config.create 32 | ?buf_len 33 | ?max_buffer_size 34 | ?error_handler 35 | ?read_header_timeout 36 | ()) 37 | Tcp.Where_to_listen.of_port_chosen_by_os 38 | (fun _addr -> handler) 39 | in 40 | Monitor.protect 41 | ~finally:(fun () -> Tcp.Server.close server) 42 | (fun () -> f (Tcp.Server.listening_on server)) 43 | ;; 44 | 45 | let send_request_and_log_response r w req = 46 | Writer.write w req; 47 | let%bind () = Writer.flushed w in 48 | let reader = Reader.pipe r in 49 | let buf = Buffer.create 128 in 50 | let%map () = Pipe.iter_without_pushback reader ~f:(Buffer.add_string buf) in 51 | printf "%S" (Buffer.contents buf) 52 | ;; 53 | -------------------------------------------------------------------------------- /http/test/id_000000,sig_06,src_000000,time_3062,execs_583,op_havoc,rep_2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/anuragsoni/shuttle_http/29bd00f1571c5ff377ddaaf79c36a71556e595da/http/test/id_000000,sig_06,src_000000,time_3062,execs_583,op_havoc,rep_2 -------------------------------------------------------------------------------- /http/test/id_000001,sig_06,src_000000,time_4184,execs_831,op_havoc,rep_8: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/anuragsoni/shuttle_http/29bd00f1571c5ff377ddaaf79c36a71556e595da/http/test/id_000001,sig_06,src_000000,time_4184,execs_831,op_havoc,rep_8 -------------------------------------------------------------------------------- /http/test/id_000002,sig_06,src_000000,time_5043,execs_1025,op_havoc,rep_2: -------------------------------------------------------------------------------- 1 | GET HTTP/1.1 2 | Host: wwwom 3 | Ut: M 4 | Ace: j.3 5 | ncoding: gzie 6 | Aarset: S 7 | Ke: 115 8 | Ut: M 9 | Acj: j.3 10 | ncoding: 11 | 12 | -------------------------------------------------------------------------------- /http/test/id_000003,sig_06,src_000000,time_5674,execs_1176,op_havoc,rep_2: -------------------------------------------------------------------------------- 1 | GET HTTP/1.1 2 | Host: wwwom 3 | Ut: M 4 | Ace: j.3 5 | ncoding: gzie 6 | Aarset: S 7 | Ke: 115 8 | Connection: ke 9 | Cookie: 10 | Ke:"115 11 | Connection: ke 12 | Cowal 13 | 14 | -------------------------------------------------------------------------------- /http/test/id_000004,sig_06,src_000000,time_9755,execs_2148,op_havoc,rep_2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/anuragsoni/shuttle_http/29bd00f1571c5ff377ddaaf79c36a71556e595da/http/test/id_000004,sig_06,src_000000,time_9755,execs_2148,op_havoc,rep_2 -------------------------------------------------------------------------------- /http/test/test_header.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Shuttle_http 3 | 4 | let%expect_test "header operations" = 5 | printf !"%{sexp: Headers.t}\n" Headers.empty; 6 | [%expect {| () |}]; 7 | printf 8 | !"%{sexp: Headers.t}\n" 9 | (Headers.empty 10 | |> Headers.add ~key:"foo" ~data:"bar" 11 | |> Headers.add ~key:"foo" ~data:"baz" 12 | |> Headers.add_unless_exists ~key:"foo" ~data:"this won't be added"); 13 | [%expect {| ((foo baz) (foo bar)) |}]; 14 | let headers = 15 | Headers.of_rev_list [ "foo", "bar"; "hello", "world"; "foo", "second foo" ] 16 | in 17 | printf !"%{sexp: Headers.t}" headers; 18 | [%expect {| ((foo bar) (hello world) (foo "second foo")) |}]; 19 | printf !"%{sexp: Headers.t}" (Headers.remove headers "foo"); 20 | [%expect {| ((hello world)) |}]; 21 | printf !"%{sexp: Headers.t}" (Headers.remove headers "HeaderKeyNotInList"); 22 | [%expect {| ((foo bar) (hello world) (foo "second foo")) |}]; 23 | printf !"%{sexp: string option}" (Headers.find headers "FOO"); 24 | [%expect {| (bar) |}]; 25 | printf !"%{sexp: string list}" (Headers.find_multi headers "FOO"); 26 | [%expect {| (bar "second foo") |}]; 27 | printf !"%{sexp: string option}" (Headers.find headers "BAZ"); 28 | [%expect {| () |}]; 29 | printf !"%{sexp: bool}" (Headers.mem headers "FOO"); 30 | [%expect {| true |}]; 31 | printf 32 | !"%{sexp: Headers.t}" 33 | (Headers.replace headers ~key:"foo" ~data:"THIS IS A NEW KEY"); 34 | [%expect {| ((foo "THIS IS A NEW KEY") (hello world)) |}] 35 | ;; 36 | 37 | let tchar_map = 38 | Array.init 256 ~f:(fun idx -> 39 | match Char.of_int_exn idx with 40 | | '0' .. '9' 41 | | 'a' .. 'z' 42 | | 'A' .. 'Z' 43 | | '!' 44 | | '#' 45 | | '$' 46 | | '%' 47 | | '&' 48 | | '\'' 49 | | '*' 50 | | '+' 51 | | '-' 52 | | '.' 53 | | '^' 54 | | '_' 55 | | '`' 56 | | '|' 57 | | '~' -> true 58 | | _ -> false) 59 | ;; 60 | 61 | let tchar_generator = 62 | let open Base_quickcheck in 63 | Generator.union 64 | Generator. 65 | [ char_digit 66 | ; char_lowercase 67 | ; char_uppercase 68 | ; of_list 69 | [ '!'; '#'; '$'; '%'; '&'; '\''; '*'; '+'; '-'; '.'; '^'; '_'; '`'; '|'; '~' ] 70 | ] 71 | ;; 72 | 73 | let header_name_generator = Base_quickcheck.Generator.string_non_empty_of tchar_generator 74 | 75 | let header_generator = 76 | Base_quickcheck.Generator.map2 header_name_generator String.gen_nonempty ~f:(fun a b -> 77 | a, b) 78 | ;; 79 | 80 | let headers_generator = 81 | let open Base_quickcheck.Generator.Let_syntax in 82 | let%map xs = List.quickcheck_generator header_generator in 83 | Headers.of_rev_list xs 84 | ;; 85 | 86 | let%test_unit "Adding a header to headers always results in a non_empty headers" = 87 | let gen = 88 | let open Base_quickcheck.Generator.Let_syntax in 89 | let%map a = headers_generator 90 | and b = header_generator in 91 | a, b 92 | in 93 | Quickcheck.test 94 | ~sexp_of:[%sexp_of: Headers.t * (string * string)] 95 | gen 96 | ~f:(fun (headers, (key, data)) -> 97 | [%test_result: bool] 98 | ~expect:false 99 | (Headers.is_empty (Headers.add headers ~key ~data))) 100 | ;; 101 | 102 | let%test_unit "Headers.to_rev_list (Headers.of_rev_list xs) = xs" = 103 | Quickcheck.test 104 | ~sexp_of:[%sexp_of: (string * string) list] 105 | (Base_quickcheck.Generator.list header_generator) 106 | ~f:(fun keys -> 107 | [%test_result: (string * string) list] 108 | ~expect:keys 109 | (Headers.to_rev_list (Headers.of_rev_list keys))) 110 | ;; 111 | 112 | let%test_unit "Headers.to_list (Headers.of_list xs) = xs" = 113 | Quickcheck.test 114 | ~sexp_of:[%sexp_of: (string * string) list] 115 | (Base_quickcheck.Generator.list header_generator) 116 | ~f:(fun keys -> 117 | [%test_result: (string * string) list] 118 | ~expect:keys 119 | (Headers.to_list (Headers.of_list keys))) 120 | ;; 121 | 122 | let%test_unit "Headers.to_list (Headers.of_rev_list xs) = List.rev xs" = 123 | Quickcheck.test 124 | ~sexp_of:[%sexp_of: (string * string) list] 125 | (Base_quickcheck.Generator.list header_generator) 126 | ~f:(fun keys -> 127 | [%test_result: (string * string) list] 128 | ~expect:(List.rev keys) 129 | (Headers.to_list (Headers.of_rev_list keys))) 130 | ;; 131 | 132 | let%test_unit "Header lookups perform case insensitive comparisons" = 133 | let gen = 134 | let open Base_quickcheck.Generator.Let_syntax in 135 | let%map a = headers_generator 136 | and b = header_name_generator in 137 | a, b 138 | in 139 | Quickcheck.test ~sexp_of:[%sexp_of: Headers.t * string] gen ~f:(fun (headers, key) -> 140 | [%test_eq: bool] 141 | (Headers.mem headers key) 142 | (Headers.mem headers (String.lowercase key)); 143 | [%test_eq: bool] 144 | (Headers.mem headers key) 145 | (Headers.mem headers (String.uppercase key))) 146 | ;; 147 | 148 | let%test_unit 149 | "Attempting to remove a header name that doesn't exist in header set does not modify \ 150 | the headers" 151 | = 152 | let gen = 153 | let open Base_quickcheck.Generator.Let_syntax in 154 | let%map a = headers_generator 155 | and b = header_name_generator in 156 | a, b 157 | in 158 | Quickcheck.test ~sexp_of:[%sexp_of: Headers.t * string] gen ~f:(fun (headers, key) -> 159 | if not (Headers.mem headers key) 160 | then 161 | [%test_result: (string * string) list] 162 | ~expect:(Headers.to_rev_list headers) 163 | (Headers.to_rev_list (Headers.remove headers key))) 164 | ;; 165 | 166 | let%test_unit 167 | "Removing a header name from a list of headers removes all entries with the name" 168 | = 169 | let gen = 170 | let open Base_quickcheck.Generator.Let_syntax in 171 | let%map a = headers_generator 172 | and b = header_name_generator in 173 | a, b 174 | in 175 | Quickcheck.test ~sexp_of:[%sexp_of: Headers.t * string] gen ~f:(fun (headers, key) -> 176 | if (not (Headers.is_empty headers)) && Headers.mem headers key 177 | then ( 178 | let headers = Headers.remove headers key in 179 | [%test_result: bool] ~expect:false (Headers.mem headers key))) 180 | ;; 181 | -------------------------------------------------------------------------------- /http/test/test_http.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open! Shuttle_http 4 | 5 | let handler request = 6 | match Request.path request with 7 | | "/error" -> failwith "ERROR" 8 | | "/echo" -> return (Response.create ~body:(Request.body request) `Ok) 9 | | "/no-keep-alive" -> 10 | return 11 | (Response.create 12 | ~headers:[ "Connection", "close" ] 13 | ~body:(Body.string "This connection will be closed") 14 | `Ok) 15 | | _ -> return (Response.create ~body:(Body.string "Hello World") `Ok) 16 | ;; 17 | 18 | let%expect_test "Simple http endpoint" = 19 | Helper.with_server handler ~f:(fun port -> 20 | Helper.with_client port ~f:(fun r w -> 21 | let test_post_req_with_fixed_body = 22 | "POST /hello HTTP/1.1\r\n\ 23 | Host: www.example.com \r\n\ 24 | Content-Length: 5\r\n\ 25 | Connection: close\r\n\ 26 | \r\n\ 27 | Hello\r\n" 28 | in 29 | let%map () = 30 | Helper.send_request_and_log_response r w test_post_req_with_fixed_body 31 | in 32 | [%expect {| "HTTP/1.1 200 \r\nContent-Length: 11\r\n\r\nHello World" |}])) 33 | ;; 34 | 35 | let%expect_test "Simple http endpoint with http client" = 36 | Helper.with_server handler ~f:(fun port -> 37 | let%map response = 38 | Client.Oneshot.call 39 | (Client.Address.of_host_and_port (Host_and_port.create ~host:"localhost" ~port)) 40 | (Request.create 41 | ~headers:[ "Host", "www.example.com "; "Connection", "close" ] 42 | ~body:(Body.string "Hello") 43 | `POST 44 | "/hello") 45 | in 46 | printf !"%{sexp: Response.t}" response; 47 | [%expect 48 | {| 49 | ((version Http_1_1) (status Ok) (reason_phrase "") 50 | (headers ((Content-Length 11))) (body (Response (Fixed "Hello World")))) |}]) 51 | ;; 52 | 53 | let%expect_test "Test default error handler" = 54 | Helper.with_server handler ~f:(fun port -> 55 | Helper.with_client port ~f:(fun r w -> 56 | let%map () = 57 | Helper.send_request_and_log_response r w "GET /error HTTP/1.1\r\n\r\n" 58 | in 59 | [%expect {| "HTTP/1.1 500 \r\nConnection: close\r\nContent-Length: 0\r\n\r\n" |}])) 60 | ;; 61 | 62 | let%expect_test "Test custom error handler" = 63 | let error_handler ?exn:_ ?request status = 64 | let body = 65 | match request with 66 | | None -> Body.string "Something bad happened" 67 | | Some request -> 68 | Body.string 69 | (sprintf "Something bad happened in request %s" (Request.path request)) 70 | in 71 | return (Response.create ~body status) 72 | in 73 | Helper.with_server 74 | ~error_handler 75 | (fun _ -> failwith "ERROR") 76 | ~f:(fun port -> 77 | let%bind () = 78 | Helper.with_client port ~f:(fun r w -> 79 | let%map () = 80 | Helper.send_request_and_log_response r w "GET / HTTP/1.1\r\n\r\n" 81 | in 82 | [%expect 83 | {| "HTTP/1.1 500 \r\nContent-Length: 22\r\n\r\nSomething bad happened" |}]) 84 | in 85 | let test_post_req_with_invalid_body_length = 86 | "POST /hello HTTP/1.1\r\n\ 87 | Host: www.example.com \r\n\ 88 | Content-Length: 5\r\n\ 89 | Content-Length: 6\r\n\ 90 | \r\n\ 91 | Hello\r\n" 92 | in 93 | Helper.with_client port ~f:(fun r w -> 94 | let%map () = 95 | Helper.send_request_and_log_response r w test_post_req_with_invalid_body_length 96 | in 97 | [%expect 98 | {| "HTTP/1.1 400 \r\nContent-Length: 40\r\n\r\nSomething bad happened in request /hello" |}])) 99 | ;; 100 | 101 | let%expect_test "Can read chunked bodies" = 102 | let test_post_req_with_chunked_body = 103 | "POST /echo HTTP/1.1\r\n\ 104 | Host: www.example.com\r\n\ 105 | Transfer-Encoding: chunked\r\n\ 106 | Connection: close\r\n\ 107 | \r\n\ 108 | 5\r\n\ 109 | Hello\r\n\ 110 | 0\r\n\ 111 | \r\n" 112 | in 113 | Helper.with_server handler ~f:(fun port -> 114 | Helper.with_client port ~f:(fun r w -> 115 | let%map () = 116 | Helper.send_request_and_log_response r w test_post_req_with_chunked_body 117 | in 118 | [%expect 119 | {| "HTTP/1.1 200 \r\nTransfer-Encoding: chunked\r\n\r\n5\r\nHello\r\n0\r\n\r\n" |}])) 120 | ;; 121 | 122 | let%expect_test "Can catch bad transfer encoding header" = 123 | let test_post_req_with_bad_transfer_encoding = 124 | "POST /hello HTTP/1.1\r\n\ 125 | Host: www.example.com \r\n\ 126 | Transfer-Encoding: foobar\r\n\ 127 | \r\n\ 128 | Hello\r\n" 129 | in 130 | Helper.with_server handler ~f:(fun port -> 131 | Helper.with_client port ~f:(fun r w -> 132 | let%map () = 133 | Helper.send_request_and_log_response r w test_post_req_with_bad_transfer_encoding 134 | in 135 | [%expect {| "HTTP/1.1 400 \r\nConnection: close\r\nContent-Length: 0\r\n\r\n" |}])) 136 | ;; 137 | 138 | let%expect_test 139 | "Servers will respond with a timeout if they can't parse request headers in the \ 140 | given timeframe" 141 | = 142 | Helper.with_server 143 | ~read_header_timeout:(Time_ns.Span.of_ms 100.) 144 | handler 145 | ~f:(fun port -> 146 | Helper.with_client port ~f:(fun r w -> 147 | let test_post_req_with_fixed_body = 148 | "POST /hello HTTP/1.1\r\n\ 149 | Host: www.example.com \r\n\ 150 | Content-Length: 5\r\n\ 151 | Connection: close\r\n\ 152 | \r\n\ 153 | Hello\r\n" 154 | in 155 | let%map () = 156 | let%bind () = after (Time_float.Span.of_ms 101.) in 157 | Helper.send_request_and_log_response r w test_post_req_with_fixed_body 158 | in 159 | [%expect {| "HTTP/1.1 408 \r\nConnection: close\r\nContent-Length: 0\r\n\r\n" |}])) 160 | ;; 161 | 162 | let%expect_test "Client can send streaming bodies" = 163 | Helper.with_server handler ~f:(fun port -> 164 | let body = 165 | Body.of_pipe 166 | `Chunked 167 | (Pipe.create_reader ~close_on_exception:false (fun writer -> 168 | Deferred.repeat_until_finished 1 (fun count -> 169 | if count > 5 170 | then return (`Finished ()) 171 | else ( 172 | let%map () = Pipe.write writer (sprintf "Hello: %d " count) in 173 | `Repeat (count + 1))))) 174 | in 175 | let%bind response = 176 | Client.Oneshot.call 177 | (Client.Address.of_host_and_port (Host_and_port.create ~host:"localhost" ~port)) 178 | (Request.create ~body `POST "/echo") 179 | in 180 | let%map body = Body.Stream.to_string (Body.to_stream (Response.body response)) in 181 | print_s 182 | [%sexp 183 | { status = (Response.status response : Status.t) 184 | ; headers = (Response.headers response : (string * string) list) 185 | ; reason_phrase = (Response.reason_phrase response : string) 186 | }]; 187 | printf "\nBody: %S" body; 188 | [%expect 189 | {| 190 | ((status Ok) (headers ((Transfer-Encoding chunked))) (reason_phrase "")) 191 | 192 | Body: "Hello: 1 Hello: 2 Hello: 3 Hello: 4 Hello: 5 " |}]) 193 | ;; 194 | 195 | let%expect_test "Keep-alives in clients" = 196 | Helper.with_server handler ~f:(fun port -> 197 | let%bind client = 198 | Deferred.Or_error.ok_exn 199 | (Client.create 200 | (Client.Address.of_host_and_port 201 | (Host_and_port.create ~host:"localhost" ~port))) 202 | in 203 | Monitor.protect 204 | ~finally:(fun () -> Client.close client) 205 | (fun () -> 206 | let%bind response = Client.call client (Request.create `GET "/") in 207 | print_s 208 | [%sexp 209 | { status = (Response.status response : Status.t) 210 | ; headers = (Response.headers response : (string * string) list) 211 | ; reason_phrase = (Response.reason_phrase response : string) 212 | }]; 213 | let%bind body = Body.to_string (Response.body response) in 214 | printf "\nBody: %S" body; 215 | [%expect 216 | {| 217 | ((status Ok) (headers ((Content-Length 11))) (reason_phrase "")) 218 | 219 | Body: "Hello World" |}]; 220 | let%bind response = 221 | Client.call 222 | client 223 | (Request.create ~body:(Body.string "This is a body") `POST "/echo") 224 | in 225 | print_s 226 | [%sexp 227 | { status = (Response.status response : Status.t) 228 | ; headers = (Response.headers response : (string * string) list) 229 | ; reason_phrase = (Response.reason_phrase response : string) 230 | }]; 231 | let%map body = Body.to_string (Response.body response) in 232 | printf "\nBody: %S" body; 233 | [%expect 234 | {| 235 | ((status Ok) (headers ((Content-Length 14))) (reason_phrase "")) 236 | 237 | Body: "This is a body" |}])) 238 | ;; 239 | 240 | let ensure_aborted fn = 241 | Monitor.try_with fn 242 | >>= function 243 | | Ok response -> 244 | failwithf 245 | !"Expected request to be aborted, but received a response instead: %{sexp: \ 246 | Response.t}" 247 | response 248 | () 249 | | Error exn -> 250 | (match Monitor.extract_exn exn with 251 | | Client.Request_aborted -> return "Request aborted" 252 | | exn -> raise exn) 253 | ;; 254 | 255 | let%expect_test "No requests can be sent if a client is closed" = 256 | Helper.with_server handler ~f:(fun port -> 257 | let%bind client = 258 | Deferred.Or_error.ok_exn 259 | (Client.create 260 | (Client.Address.of_host_and_port 261 | (Host_and_port.create ~host:"localhost" ~port))) 262 | in 263 | Monitor.protect 264 | ~finally:(fun () -> Client.close client) 265 | (fun () -> 266 | let%bind response = Client.call client (Request.create `GET "/") in 267 | print_s 268 | [%sexp 269 | { status = (Response.status response : Status.t) 270 | ; headers = (Response.headers response : (string * string) list) 271 | ; reason_phrase = (Response.reason_phrase response : string) 272 | }]; 273 | let%bind body = Body.to_string (Response.body response) in 274 | printf "\nBody: %S" body; 275 | [%expect 276 | {| 277 | ((status Ok) (headers ((Content-Length 11))) (reason_phrase "")) 278 | 279 | Body: "Hello World" |}]; 280 | let%bind () = Client.close client in 281 | let%map msg = 282 | ensure_aborted (fun () -> 283 | Client.call 284 | client 285 | (Request.create ~body:(Body.string "This is a body") `POST "/echo")) 286 | in 287 | printf "%s" msg; 288 | [%expect {| Request aborted |}])) 289 | ;; 290 | 291 | let%expect_test 292 | "Clients are automatically closed if Connection:close header is present in request" 293 | = 294 | Helper.with_server handler ~f:(fun port -> 295 | let%bind client = 296 | Deferred.Or_error.ok_exn 297 | (Client.create 298 | (Client.Address.of_host_and_port 299 | (Host_and_port.create ~host:"localhost" ~port))) 300 | in 301 | Monitor.protect 302 | ~finally:(fun () -> Client.close client) 303 | (fun () -> 304 | let%bind response = 305 | Client.call client (Request.create ~headers:[ "Connection", "close" ] `GET "/") 306 | in 307 | print_s 308 | [%sexp 309 | { status = (Response.status response : Status.t) 310 | ; headers = (Response.headers response : (string * string) list) 311 | ; reason_phrase = (Response.reason_phrase response : string) 312 | }]; 313 | let%bind body = Body.to_string (Response.body response) in 314 | printf "\nBody: %S" body; 315 | [%expect 316 | {| 317 | ((status Ok) (headers ((Content-Length 11))) (reason_phrase "")) 318 | 319 | Body: "Hello World" |}]; 320 | let%map msg = 321 | ensure_aborted (fun () -> 322 | Client.call 323 | client 324 | (Request.create ~body:(Body.string "This is a body") `POST "/echo")) 325 | in 326 | printf "%s" msg; 327 | [%expect {| Request aborted |}])) 328 | ;; 329 | 330 | let%expect_test 331 | "Clients are automatically closed if Connection:close header is present in response" 332 | = 333 | Helper.with_server handler ~f:(fun port -> 334 | let%bind client = 335 | Deferred.Or_error.ok_exn 336 | (Client.create 337 | (Client.Address.of_host_and_port 338 | (Host_and_port.create ~host:"localhost" ~port))) 339 | in 340 | Monitor.protect 341 | ~finally:(fun () -> Client.close client) 342 | (fun () -> 343 | let%bind response = Client.call client (Request.create `GET "/no-keep-alive") in 344 | print_s 345 | [%sexp 346 | { status = (Response.status response : Status.t) 347 | ; headers = (Response.headers response : (string * string) list) 348 | ; reason_phrase = (Response.reason_phrase response : string) 349 | }]; 350 | let%bind body = Body.to_string (Response.body response) in 351 | printf "\nBody: %S" body; 352 | [%expect 353 | {| 354 | ((status Ok) (headers ((Content-Length 30) (Connection close))) 355 | (reason_phrase "")) 356 | 357 | Body: "This connection will be closed" |}]; 358 | let%map msg = 359 | ensure_aborted (fun () -> 360 | Client.call 361 | client 362 | (Request.create ~body:(Body.string "This is a body") `POST "/echo")) 363 | in 364 | printf "%s" msg; 365 | [%expect {| Request aborted |}])) 366 | ;; 367 | 368 | let%expect_test "Persistent clients will re-connect if connection is closed" = 369 | Helper.with_server handler ~f:(fun port -> 370 | let client = 371 | Client.Persistent.create 372 | ~random_state:`Non_random 373 | ~retry_delay:(fun () -> Time_ns.Span.of_sec 0.01) 374 | ~server_name:"test" 375 | (fun () -> 376 | Deferred.Or_error.return 377 | (Client.Address.of_host_and_port 378 | (Host_and_port.create ~host:"localhost" ~port))) 379 | in 380 | Monitor.protect 381 | ~finally:(fun () -> Client.Persistent.close client) 382 | (fun () -> 383 | let%bind response = 384 | Client.Persistent.call client (Request.create `GET "/no-keep-alive") 385 | in 386 | print_s 387 | [%sexp 388 | { status = (Response.status response : Status.t) 389 | ; headers = (Response.headers response : (string * string) list) 390 | ; reason_phrase = (Response.reason_phrase response : string) 391 | }]; 392 | let%bind body = Body.to_string (Response.body response) in 393 | printf "\nBody: %S" body; 394 | [%expect 395 | {| 396 | ((status Ok) (headers ((Content-Length 30) (Connection close))) 397 | (reason_phrase "")) 398 | 399 | Body: "This connection will be closed" |}]; 400 | (* Since we use persistent it will re-connent and use a fresh connection the next 401 | time we use `call` *) 402 | let%bind response = 403 | Client.Persistent.call 404 | client 405 | (Request.create ~body:(Body.string "This is a body") `POST "/echo") 406 | in 407 | print_s 408 | [%sexp 409 | { status = (Response.status response : Status.t) 410 | ; headers = (Response.headers response : (string * string) list) 411 | ; reason_phrase = (Response.reason_phrase response : string) 412 | }]; 413 | let%map body = Body.to_string (Response.body response) in 414 | printf "\nBody: %S" body; 415 | [%expect 416 | {| 417 | ((status Ok) (headers ((Content-Length 14))) (reason_phrase "")) 418 | 419 | Body: "This is a body" |}])) 420 | ;; 421 | -------------------------------------------------------------------------------- /http/test/test_method.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Shuttle_http 3 | 4 | let%test_unit "Http Methods can be coverted to strings and back" = 5 | let a = Meth.all in 6 | let b = 7 | a 8 | |> List.map ~f:Meth.to_string 9 | |> List.map ~f:(fun v -> Or_error.ok_exn (Meth.of_string v)) 10 | in 11 | [%test_result: Meth.t list] ~expect:a b 12 | ;; 13 | 14 | let%test_unit "Meth.of_string (Meth.to_string m) is never none" = 15 | Quickcheck.test ~sexp_of:[%sexp_of: Meth.t] Meth.quickcheck_generator ~f:(fun meth -> 16 | [%test_result: Meth.t Or_error.t] 17 | ~expect:(Ok meth) 18 | (Meth.of_string (Meth.to_string meth))) 19 | ;; 20 | -------------------------------------------------------------------------------- /http/test/test_parser.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Shuttle_http 3 | 4 | let req = 5 | "GET /wp-content/uploads/2010/03/hello-kitty-darth-vader-pink.jpg HTTP/1.1\r\n\ 6 | Host: www.kittyhell.com \r\n\ 7 | User-Agent: Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10.6; ja-JP-mac; rv:1.9.2.3) \ 8 | Gecko/20100401 Firefox/3.6.3 Pathtraq/0.9\r\n\ 9 | Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\r\n\ 10 | Accept-Language: ja,en-us;q=0.7,en;q=0.3\r\n\ 11 | Accept-Encoding: gzip,deflate\r\n\ 12 | Accept-Charset: Shift_JIS,utf-8;q=0.7,*;q=0.7\r\n\ 13 | Keep-Alive: 115\r\n\ 14 | Connection: keep-alive\r\n\ 15 | Cookie: wp_ozh_wsa_visits=2; wp_ozh_wsa_visit_lasttime=xxxxxxxxxx; \ 16 | __utma=xxxxxxxxx.xxxxxxxxxx.xxxxxxxxxx.xxxxxxxxxx.xxxxxxxxxx.x; \ 17 | __utmz=xxxxxxxxx.xxxxxxxxxx.x.x.utmccn=(referral)|utmcsr=reader.livedoor.com|utmcct=/reader/|utmcmd=referral\r\n\ 18 | \r\n" 19 | ;; 20 | 21 | type 'a success = 22 | { consumed : int 23 | ; value : 'a 24 | } 25 | [@@deriving sexp_of, compare] 26 | 27 | let parse_or_error parser ?pos ?len buf = 28 | match parser ?pos ?len (Bigstring.of_string buf) with 29 | | Ok (value, consumed) -> Ok { value; consumed } 30 | | Error Parser.Partial -> Or_error.errorf "Partial" 31 | | Error (Fail error) -> Error (Error.tag error ~tag:"Parse error") 32 | ;; 33 | 34 | let%test_unit "Can parse HTTP methods" = 35 | let methods = Meth.all in 36 | let methods_string = List.map methods ~f:Meth.to_string in 37 | let result = 38 | List.map 39 | ~f:(fun m -> parse_or_error Parser.Private.parse_method (m ^ " ")) 40 | methods_string 41 | in 42 | [%test_result: Meth.t success Or_error.t list] 43 | result 44 | ~expect: 45 | (List.map methods ~f:(fun m -> 46 | Ok { value = m; consumed = String.length (Meth.to_string m) + 1 })) 47 | ;; 48 | 49 | let%expect_test "can parse a single request" = 50 | print_s 51 | ([%sexp_of: Request.t success Or_error.t] (parse_or_error Parser.parse_request req)); 52 | [%expect 53 | {| 54 | (Ok 55 | ((consumed 706) 56 | (value 57 | ((meth GET) 58 | (path /wp-content/uploads/2010/03/hello-kitty-darth-vader-pink.jpg) 59 | (version Http_1_1) 60 | (headers 61 | ((Host www.kittyhell.com) 62 | (User-Agent 63 | "Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10.6; ja-JP-mac; rv:1.9.2.3) Gecko/20100401 Firefox/3.6.3 Pathtraq/0.9") 64 | (Accept 65 | "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8") 66 | (Accept-Language "ja,en-us;q=0.7,en;q=0.3") 67 | (Accept-Encoding gzip,deflate) 68 | (Accept-Charset "Shift_JIS,utf-8;q=0.7,*;q=0.7") (Keep-Alive 115) 69 | (Connection keep-alive) 70 | (Cookie 71 | "wp_ozh_wsa_visits=2; wp_ozh_wsa_visit_lasttime=xxxxxxxxxx; __utma=xxxxxxxxx.xxxxxxxxxx.xxxxxxxxxx.xxxxxxxxxx.xxxxxxxxxx.x; __utmz=xxxxxxxxx.xxxxxxxxxx.x.x.utmccn=(referral)|utmcsr=reader.livedoor.com|utmcct=/reader/|utmcmd=referral"))) 72 | (body Empty))))) |}] 73 | ;; 74 | 75 | let%expect_test "reject headers with space before colon" = 76 | let req = "GET / HTTP/1.1\r\nHost : www.kittyhell.com\r\nKeep-Alive: 115\r\n\r\n" in 77 | print_s 78 | ([%sexp_of: Request.t success Or_error.t] (parse_or_error Parser.parse_request req)); 79 | [%expect {| (Error ("Parse error" "Invalid Header Key")) |}] 80 | ;; 81 | 82 | let more_requests = 83 | "GET / HTTP/1.1\r\n\ 84 | Host: www.reddit.com\r\n\ 85 | User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) \r\n\ 86 | \ Gecko/20100101 Firefox/15.0.1\r\n\ 87 | Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\r\n\ 88 | Accept-Language: en-us,en;q=0.5\r\n\ 89 | Accept-Encoding: gzip, deflate\r\n\ 90 | Connection: keep-alive\r\n\ 91 | \r\n\ 92 | GET /reddit.v_EZwRzV-Ns.css HTTP/1.1\r\n\ 93 | Host: www.redditstatic.com\r\n\ 94 | User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 \ 95 | Firefox/15.0.1\r\n\ 96 | Accept: text/css,*/*;q=0.1\r\n\ 97 | Accept-Language: en-us,en;q=0.5\r\n\ 98 | Accept-Encoding: gzip, deflate\r\n\ 99 | Connection: keep-alive\r\n\ 100 | Referer: http://www.reddit.com/\r\n\ 101 | \r\n" 102 | ;; 103 | 104 | let%expect_test "can parse request at offset" = 105 | print_s 106 | ([%sexp_of: Request.t success Or_error.t] 107 | (parse_or_error Parser.parse_request more_requests ~pos:304)); 108 | [%expect 109 | {| 110 | (Ok 111 | ((consumed 315) 112 | (value 113 | ((meth GET) (path /reddit.v_EZwRzV-Ns.css) (version Http_1_1) 114 | (headers 115 | ((Host www.redditstatic.com) 116 | (User-Agent 117 | "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1") 118 | (Accept "text/css,*/*;q=0.1") (Accept-Language "en-us,en;q=0.5") 119 | (Accept-Encoding "gzip, deflate") (Connection keep-alive) 120 | (Referer http://www.reddit.com/))) 121 | (body Empty))))) |}] 122 | ;; 123 | 124 | let%expect_test "can report a partial parse" = 125 | print_s 126 | ([%sexp_of: Request.t success Or_error.t] 127 | (parse_or_error Parser.parse_request ~len:50 req)); 128 | [%expect {| (Error Partial) |}] 129 | ;; 130 | 131 | let%expect_test "can validate http version" = 132 | let req = "GET / HTTP/1.4\r\nHost: www.kittyhell.com\r\nKeep-Alive: 115\r\n\r\n" in 133 | print_s 134 | ([%sexp_of: Request.t success Or_error.t] (parse_or_error Parser.parse_request req)); 135 | [%expect {| (Error ("Parse error" "Invalid HTTP Version")) |}] 136 | ;; 137 | 138 | let%expect_test "parse result indicates location of start of body" = 139 | let req = 140 | "POST / HTTP/1.1\r\n\ 141 | Host: localhost:8080\r\n\ 142 | User-Agent: curl/7.64.1\r\n\ 143 | Accept: */*\r\n\ 144 | Content-Length: 6\r\n\ 145 | Content-Type: application/x-www-form-urlencoded\r\n\ 146 | \r\n\ 147 | foobar" 148 | in 149 | let { consumed; _ } = Or_error.ok_exn (parse_or_error Parser.parse_request req) in 150 | print_endline (String.subo req ~pos:consumed); 151 | [%expect {| foobar |}] 152 | ;; 153 | 154 | let%expect_test "can parse chunk lengths" = 155 | List.iter 156 | ~f:(fun buf -> 157 | printf 158 | !"input: %S, parse_result: %{sexp: int success Or_error.t} \n" 159 | buf 160 | (parse_or_error Parser.parse_chunk_length buf)) 161 | [ "ab2\r\n" 162 | ; "4511ab\r\n" 163 | ; "4511ab ; a\r\n" 164 | ; "4511ab; now in extension\r\n" 165 | ; "4511ab a ; now in extension\r\n" 166 | ; "111111111111111\r\n" 167 | ; "1111111111111111\r\n" 168 | ; "abc\r12" 169 | ; "abc\n12" 170 | ; "121" 171 | ; "121\r" 172 | ]; 173 | [%expect 174 | {| 175 | input: "ab2\r\n", parse_result: (Ok ((consumed 5) (value 2738))) 176 | input: "4511ab\r\n", parse_result: (Ok ((consumed 8) (value 4526507))) 177 | input: "4511ab ; a\r\n", parse_result: (Ok ((consumed 13) (value 4526507))) 178 | input: "4511ab; now in extension\r\n", parse_result: (Ok ((consumed 26) (value 4526507))) 179 | input: "4511ab a ; now in extension\r\n", parse_result: (Error ("Parse error" ("Invalid chunk_length character" a))) 180 | input: "111111111111111\r\n", parse_result: (Ok ((consumed 17) (value 76861433640456465))) 181 | input: "1111111111111111\r\n", parse_result: (Error ("Parse error" "Chunk size is too large")) 182 | input: "abc\r12", parse_result: (Error ("Parse error" Expected_newline)) 183 | input: "abc\n12", parse_result: (Error ("Parse error" ("Invalid chunk_length character" "\n"))) 184 | input: "121", parse_result: (Error Partial) 185 | input: "121\r", parse_result: (Error Partial) |}] 186 | ;; 187 | 188 | open Base_quickcheck 189 | 190 | let parse_chunk_length () = 191 | Test.run_exn 192 | (module struct 193 | type t = int [@@deriving quickcheck, sexp_of] 194 | end) 195 | ~f:(fun num -> 196 | let payload = 197 | let s = Bigstring.of_string (Printf.sprintf "%x\r\n" num) in 198 | s 199 | in 200 | match Parser.parse_chunk_length payload with 201 | | Ok res -> 202 | [%test_eq: int * int] res (num, String.length (Printf.sprintf "%x" num) + 2) 203 | | Error (Parser.Fail _) -> () 204 | | Error _ -> assert false) 205 | ;; 206 | 207 | let chunk_length_parse_case_insensitive () = 208 | let run_test num str = 209 | let buf = Bigstring.of_string str in 210 | match Parser.parse_chunk_length buf with 211 | | Ok res -> 212 | [%test_eq: int * int] res (num, String.length (Printf.sprintf "%x" num) + 2) 213 | | Error (Parser.Fail _) -> () 214 | | Error _ -> assert false 215 | in 216 | Test.run_exn 217 | (module struct 218 | type t = int [@@deriving quickcheck, sexp_of] 219 | end) 220 | ~f:(fun num -> 221 | let payload = Printf.sprintf "%x\r\n" num in 222 | run_test num (String.uppercase payload); 223 | run_test num (String.lowercase payload)) 224 | ;; 225 | 226 | let%expect_test "unexpected exception in to_string_trim caught via afl-fuzz" = 227 | let payloads = 228 | [ "./id_000000,sig_06,src_000000,time_3062,execs_583,op_havoc,rep_2" 229 | ; "./id_000001,sig_06,src_000000,time_4184,execs_831,op_havoc,rep_8" 230 | ; "./id_000002,sig_06,src_000000,time_5043,execs_1025,op_havoc,rep_2" 231 | ; "./id_000003,sig_06,src_000000,time_5674,execs_1176,op_havoc,rep_2" 232 | ; "./id_000004,sig_06,src_000000,time_9755,execs_2148,op_havoc,rep_2" 233 | ] 234 | in 235 | List.iteri payloads ~f:(fun idx payload -> 236 | let payload = In_channel.read_all payload in 237 | printf 238 | !"(%d) %{sexp: Request.t success Or_error.t}\n" 239 | (idx + 1) 240 | (parse_or_error Parser.parse_request payload)); 241 | [%expect 242 | {| 243 | (1) (Error Partial) 244 | (2) (Error ("Parse error" "Invalid Header Key")) 245 | (3) (Ok 246 | ((consumed 114) 247 | (value 248 | ((meth GET) (path "") (version Http_1_1) 249 | (headers 250 | ((Host wwwom) (Ut M) (Ace j.3) (ncoding gzie) (Aarset S) (Ke 115) 251 | (Ut M) (Acj j.3) (ncoding ""))) 252 | (body Empty))))) 253 | (4) (Error Partial) 254 | (5) (Error ("Parse error" "Expected EOL")) |}] 255 | ;; 256 | 257 | let%expect_test "can parse a single response" = 258 | let response = "HTTP/1.1 200 OK\r\nContent-Length: 21\r\nFoo: bar\r\n\r\n" in 259 | print_s 260 | ([%sexp_of: Response.t success Or_error.t * int] 261 | (parse_or_error Parser.parse_response response, String.length response)); 262 | [%expect 263 | {| 264 | ((Ok 265 | ((consumed 49) 266 | (value 267 | ((version Http_1_1) (status Ok) (reason_phrase OK) 268 | (headers ((Content-Length 21) (Foo bar))) (body (Response Empty)))))) 269 | 49) |}] 270 | ;; 271 | 272 | let%expect_test "Response parser catches invalid status code" = 273 | let response = "HTTP/1.1 20 OK\r\nContent-Length: 21\r\nFoo: bar\r\n\r\n" in 274 | print_s 275 | ([%sexp_of: Response.t success Or_error.t] 276 | (parse_or_error Parser.parse_response response)); 277 | [%expect 278 | {| 279 | (Error ("Parse error" "Status codes must be three digit numbers")) |}]; 280 | let response = "HTTP/1.1 999 OK\r\nContent-Length: 21\r\nFoo: bar\r\n\r\n" in 281 | print_s 282 | ([%sexp_of: Response.t success Or_error.t] 283 | (parse_or_error Parser.parse_response response)); 284 | [%expect {| (Error ("Parse error" "Invalid status code 999")) |}]; 285 | let response = "HTTP/1.1 001 OK\r\nContent-Length: 21\r\nFoo: bar\r\n\r\n" in 286 | print_s 287 | ([%sexp_of: Response.t success Or_error.t] 288 | (parse_or_error Parser.parse_response response)); 289 | [%expect {| (Error ("Parse error" "Invalid status code 001")) |}] 290 | ;; 291 | 292 | let%expect_test "Response parser catches spaces in header names" = 293 | let response = "HTTP/1.1 200 OK\r\nContent-Length : 21\r\nFoo: bar\r\n\r\n" in 294 | print_s 295 | ([%sexp_of: Response.t success Or_error.t] 296 | (parse_or_error Parser.parse_response response)); 297 | [%expect {| (Error ("Parse error" "Invalid Header Key")) |}] 298 | ;; 299 | -------------------------------------------------------------------------------- /http/test/test_status.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Shuttle_http 3 | 4 | let%test_unit "Http Status can be coverted to int and back" = 5 | let a = Status.all in 6 | let b = 7 | a 8 | |> List.map ~f:Status.to_int 9 | |> List.map ~f:(fun v -> Or_error.ok_exn (Status.of_int v)) 10 | in 11 | [%test_result: Status.t list] ~expect:a b 12 | ;; 13 | 14 | let%test_unit "Status.of_string (Int.to_string (Status.to_int c)) always succeeds" = 15 | let a = Status.all in 16 | let b = 17 | a 18 | |> List.map ~f:Status.to_int 19 | |> List.map ~f:Int.to_string 20 | |> List.map ~f:(fun v -> Or_error.ok_exn (Status.of_string v)) 21 | in 22 | [%test_result: Status.t list] ~expect:a b 23 | ;; 24 | 25 | let%test_unit "Status.of_int (Int.of_string (Status.to_string c)) always succeeds" = 26 | let a = Status.all in 27 | let b = 28 | a 29 | |> List.map ~f:Status.to_string 30 | |> List.map ~f:Int.of_string 31 | |> List.map ~f:(fun v -> Or_error.ok_exn (Status.of_int v)) 32 | in 33 | [%test_result: Status.t list] ~expect:a b 34 | ;; 35 | 36 | let%test_unit "Status.of_int (Status.to_int c) always succeeds" = 37 | Quickcheck.test 38 | ~sexp_of:[%sexp_of: Status.t] 39 | Status.quickcheck_generator 40 | ~f:(fun status -> 41 | [%test_result: Status.t Or_error.t] 42 | ~expect:(Ok status) 43 | (Status.of_int (Status.to_int status))) 44 | ;; 45 | -------------------------------------------------------------------------------- /http/websocket/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name shuttle_websocket) 3 | (preprocess 4 | (pps ppx_jane)) 5 | (libraries core async shuttle_http async_websocket)) 6 | -------------------------------------------------------------------------------- /http/websocket/shuttle_websocket.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open! Shuttle_http 4 | 5 | let default_error_handler ?exn:_ ?request:_ status = 6 | return 7 | (Response.create 8 | ~headers:[ "Connection", "close"; "Content-Length", "0" ] 9 | ~body:Body.empty 10 | status) 11 | ;; 12 | 13 | module Config = struct 14 | type t = 15 | { error_handler : Server.error_handler 16 | ; subprotocol : string list -> string option 17 | ; response_headers : (string * string) list 18 | ; opcode : [ `Text | `Binary ] option 19 | ; buffer_size : int 20 | } 21 | 22 | let create 23 | ?(buffer_size = 0x4000) 24 | ?(error_handler = default_error_handler) 25 | ?(response_headers = []) 26 | ?opcode 27 | ?(subprotocol = fun _ -> None) 28 | () 29 | = 30 | { buffer_size; error_handler; opcode; response_headers; subprotocol } 31 | ;; 32 | 33 | let default = create () 34 | end 35 | 36 | let create ?(config = Config.default) websocket_handler request = 37 | match Request.meth request with 38 | | `GET -> 39 | (match Request.header request "Sec-WebSocket-Key" with 40 | | None -> config.error_handler ~request `Bad_request 41 | | Some v -> 42 | let accept_key = 43 | Websocket.sec_websocket_accept_header_value ~sec_websocket_key:v 44 | in 45 | let subprotocol = 46 | match Request.header_multi request "Sec-WebSocket-Protocol" with 47 | | [] -> None 48 | | xs -> 49 | let protocols = 50 | List.concat_map xs ~f:(fun str -> 51 | str |> String.split ~on:',' |> List.map ~f:String.strip) 52 | in 53 | config.subprotocol protocols 54 | in 55 | let handler ?unconsumed_data fd = 56 | match unconsumed_data with 57 | | Some payload -> 58 | raise_s 59 | [%message 60 | "Websocket upgrade request contained unconsumed data" ~data:payload] 61 | | None -> 62 | let reader = Reader.create ~buf_len:config.buffer_size fd in 63 | let writer = Writer.create ~buf_len:config.buffer_size fd in 64 | let ws = 65 | Websocket.create 66 | ?opcode:config.opcode 67 | ~role:Websocket.Websocket_role.Server 68 | reader 69 | writer 70 | in 71 | websocket_handler ws 72 | in 73 | let headers = 74 | config.response_headers 75 | |> Headers.replace ~key:"Upgrade" ~data:"WebSocket" 76 | |> Headers.replace ~key:"Connection" ~data:"Upgrade" 77 | |> Headers.replace ~key:"Sec-WebSocket-Accept" ~data:accept_key 78 | |> fun headers -> 79 | match subprotocol with 80 | | None -> headers 81 | | Some protocol -> 82 | Headers.replace headers ~key:"Sec-WebSocket-Protocol" ~data:protocol 83 | in 84 | return (Response.upgrade ~headers handler)) 85 | | _ -> config.error_handler ~request `Method_not_allowed 86 | ;; 87 | -------------------------------------------------------------------------------- /http/websocket/shuttle_websocket.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | module Config : sig 5 | (* Configuration for how to negotiate a websocket connection. 6 | 7 | - [buffer_size] controls the initial buffer size for the underlying reader/writer 8 | pair that are handed off to async_websocket. The default is 16_000 bytes. 9 | 10 | - [error_handler] is a user provided handler that will be called if the websocket 11 | function encounters an invalid upgrade request. 12 | 13 | - [response_headers] any headers that should be sent with the successful 14 | Switching-Protocol response sent to the client. 15 | 16 | - [opcode] specifies whether to use Text of Binary frames on the websocket 17 | connection. 18 | 19 | - [subprotocol] If a client sends a list of subprotocols this function is called to 20 | check which subprotocol is selected by the server. Reply with None to indicate a null 21 | subprotocol. *) 22 | type t 23 | 24 | val create 25 | : ?buffer_size:int 26 | -> ?error_handler:Shuttle_http.Server.error_handler 27 | -> ?response_headers:(string * string) list 28 | -> ?opcode:[ `Binary | `Text ] 29 | -> ?subprotocol:(string list -> string option) 30 | -> unit 31 | -> t 32 | 33 | val default : t 34 | end 35 | 36 | (** [create] accepts a user provided websocket-handler and performs an HTTP/1.1 37 | protocol upgrade. [create] returns a {{!Shuttle_http.Response.t} http response} 38 | that either represents an error indicating a bad upgrade request, 39 | or contains a `Switching-Protocol` response with an HTTP protocol upgrade handler. 40 | If the protocol negotiation succeeds the user provided websocket handler 41 | will be called with a websocket descriptor. Once the deferred returned by the websocket-handler is resolved, 42 | or if there are any unhandled exceptions in the handler the underlying TCP connection is closed. 43 | *) 44 | val create 45 | : ?config:Config.t 46 | -> (Websocket.t -> unit Deferred.t) 47 | -> Shuttle_http.Request.t 48 | -> Shuttle_http.Response.t Deferred.t 49 | -------------------------------------------------------------------------------- /shuttle_http.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Async library for HTTP/1.1 servers and clients" 4 | description: 5 | "Shuttle_http is a low level library for implementing HTTP/1.1 web services and clients in OCaml." 6 | maintainer: ["Anurag Soni "] 7 | authors: ["Anurag Soni"] 8 | license: "MIT" 9 | tags: ["http-server" "http-client" "http" "http1.1" "async"] 10 | homepage: "https://github.com/anuragsoni/shuttle_http" 11 | bug-reports: "https://github.com/anuragsoni/shuttle_http/issues" 12 | depends: [ 13 | "dune" {>= "3.1"} 14 | "async" {>= "v0.17.0"} 15 | "async_log" {>= "v0.17.0"} 16 | "async_ssl" {>= "v0.17.0"} 17 | "core" {>= "v0.17.0"} 18 | "jane_rope" {>= "v0.17.0"} 19 | "ocaml" {>= "5.1.0"} 20 | "ppx_jane" {>= "v0.17.0"} 21 | "re2" {>= "v0.17.0"} 22 | "core_unix" {with-test} 23 | "odoc" {with-doc} 24 | ] 25 | dev-repo: "git+https://github.com/anuragsoni/shuttle_http.git" 26 | build: [ 27 | ["dune" "subst"] {dev} 28 | [ 29 | "dune" 30 | "build" 31 | "-p" 32 | name 33 | "-j" 34 | jobs 35 | "@install" 36 | "@runtest" {with-test & os != "macos"} 37 | "@doc" {with-doc} 38 | ] 39 | ] 40 | available: [ arch = "x86_64" | arch = "arm64" ] -------------------------------------------------------------------------------- /shuttle_http.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@runtest" {with-test & os != "macos"} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | available: [ arch = "x86_64" | arch = "arm64" ] -------------------------------------------------------------------------------- /shuttle_websocket.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Websocket support for HTTP/1.1 servers using Async" 4 | description: 5 | "Shuttle_websocket is a companion library for shuttle_http that provides a HTTP service that performs websocket negotiation for HTTP/1.1 servers." 6 | maintainer: ["Anurag Soni "] 7 | authors: ["Anurag Soni"] 8 | license: "MIT" 9 | tags: ["http-server" "websocket"] 10 | homepage: "https://github.com/anuragsoni/shuttle_http" 11 | bug-reports: "https://github.com/anuragsoni/shuttle_http/issues" 12 | depends: [ 13 | "dune" {>= "3.1"} 14 | "shuttle_http" {= version} 15 | "async_websocket" {>= "v0.17.0"} 16 | "odoc" {with-doc} 17 | ] 18 | build: [ 19 | ["dune" "subst"] {dev} 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/anuragsoni/shuttle_http.git" 33 | --------------------------------------------------------------------------------