├── .github └── workflows │ └── test.yml ├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE ├── README.md ├── bench ├── dune ├── parser_bench.ml ├── rust-hyper │ ├── .gitignore │ ├── Cargo.lock │ ├── Cargo.toml │ └── src │ │ └── main.rs └── server_bench.ml ├── dune-project ├── example ├── dune ├── echo.ml └── hello_world.ml ├── http_async.opam ├── http_async.opam.template ├── src ├── body.ml ├── buffer_config.ml ├── buffer_config.mli ├── dune ├── headers.ml ├── headers.mli ├── http_async.ml ├── http_async.mli ├── logger.ml ├── logger.mli ├── meth.ml ├── meth.mli ├── parser.ml ├── parser.mli ├── request.ml ├── request.mli ├── response.ml ├── response.mli ├── server.ml ├── status.ml ├── status.mli ├── version.ml └── version.mli └── test ├── dune ├── test_http_server.ml ├── test_method.ml └── test_parser.ml /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Test 3 | 4 | on: 5 | - push 6 | - pull_request 7 | 8 | jobs: 9 | build: 10 | name: Build 11 | runs-on: ${{ matrix.operating-system }} 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | operating-system: 16 | - ubuntu-latest 17 | ocaml-version: 18 | - 4.14.x 19 | steps: 20 | - uses: actions/checkout@v2 21 | - name: Setup OCaml ${{ matrix.ocaml-version }} 22 | uses: ocaml/setup-ocaml@v2 23 | with: 24 | ocaml-compiler: ${{ matrix.ocaml-version }} 25 | dune-cache: true 26 | - name: Install Dependencies 27 | run: opam install . --deps-only --with-test 28 | - name: Run Tests 29 | run: opam exec -- dune runtest -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | _esy 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | parse-docstrings=true 3 | wrap-comments=true 4 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # 0.2.0 2 | 3 | * Allow running http_async servers on unix domain sockets 4 | * Forward peer socket address to service and error handler 5 | 6 | # 0.1.1 7 | 8 | * Parsing error should forward request to error handler if the request is fully parsed 9 | 10 | # 0.1.0 11 | 12 | * Don't use Eager_deferred 13 | * Increase lower-bound on shuttle to version 0.6.0 14 | 15 | # 0.0.4 16 | 17 | * Adapt to api changes in shuttle 0.5.0 18 | 19 | # 0.0.3 20 | 21 | * Streaming bodies use Bigstring based iovecs instead of strings 22 | 23 | # 0.0.2 24 | 25 | * Initial release 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020-2022 Anurag 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 | # Http_async 2 | 3 | HTTP 1.1 server for async applications. 4 | 5 | ### Installation 6 | 7 | ###### To use the version published on opam: 8 | 9 | ``` 10 | opam install http_async 11 | ``` 12 | 13 | ###### For the development version: 14 | 15 | ``` 16 | opam pin add http_async.dev git+https://github.com/anuragsoni/http_async.git 17 | ``` 18 | 19 | ### Hello World 20 | 21 | ```ocaml 22 | open! Core 23 | open! Async 24 | open Http_async 25 | 26 | let () = 27 | Command_unix.run 28 | (Server.run_command ~summary:"Hello world HTTP Server" (fun addr (request, _body) -> 29 | Log.Global.info 30 | "(%s): %s" 31 | (Socket.Address.Inet.to_string addr) 32 | (Request.path request); 33 | return (Response.create `Ok, Body.Writer.string "Hello World"))) 34 | ;; 35 | ``` 36 | 37 | ### Routing? 38 | 39 | Http_async doesn't ship with a router. There are multiple routing libraries available on opam and using `Http_async` with them should be fairly easy. As an example, integration with [ocaml-dispatch](https://github.com/inhabitedtype/ocaml-dispatch) can be done as so: 40 | 41 | ```ocaml 42 | open! Core 43 | open! Async 44 | open Http_async 45 | 46 | let routes = 47 | let open Dispatch in 48 | DSL.create 49 | [ ( "/hello/:name" 50 | , fun params _rest -> 51 | let name = List.Assoc.find_exn params ~equal:String.equal "name" in 52 | return (Response.create `Ok, Body.Writer.string (sprintf "Hello, %s" name)) ) 53 | ; ("/", fun _params _rest -> Response.create `Ok, Body.Writer.string "Hello World") 54 | ] 55 | ;; 56 | 57 | let service _addr (request, body) = 58 | let path = Request.path request in 59 | match Dispatch.dispatch routes path with 60 | | Some response -> response 61 | | None -> return (Response.create `Not_found, Body.Writer.string "Route not found") 62 | ;; 63 | 64 | let () = Command_unix.run (Server.run_command ~summary:"Hello world HTTP Server" service) 65 | ``` 66 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name parser_bench) 3 | (modules parser_bench) 4 | (libraries core_bench core_unix.command_unix http_async memtrace)) 5 | 6 | (executable 7 | (name server_bench) 8 | (modules server_bench) 9 | (preprocess 10 | (pps ppx_jane)) 11 | (libraries core core_unix.command_unix async http_async memtrace)) 12 | -------------------------------------------------------------------------------- /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 Http_async.Private.Parser.parse_request req with 33 | | Error _ -> assert false 34 | | Ok _ -> ()) 35 | ; Bench.Test.create ~name:"Parse chunk size" (fun () -> 36 | match Http_async.Private.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 () = 45 | Memtrace.trace_if_requested (); 46 | Command_unix.run (Bench.make_command tests) 47 | ;; 48 | -------------------------------------------------------------------------------- /bench/rust-hyper/.gitignore: -------------------------------------------------------------------------------- 1 | target 2 | -------------------------------------------------------------------------------- /bench/rust-hyper/Cargo.lock: -------------------------------------------------------------------------------- 1 | # This file is automatically @generated by Cargo. 2 | # It is not intended for manual editing. 3 | version = 3 4 | 5 | [[package]] 6 | name = "autocfg" 7 | version = "1.0.1" 8 | source = "registry+https://github.com/rust-lang/crates.io-index" 9 | checksum = "cdb031dd78e28731d87d56cc8ffef4a8f36ca26c38fe2de700543e627f8a464a" 10 | 11 | [[package]] 12 | name = "bitflags" 13 | version = "1.2.1" 14 | source = "registry+https://github.com/rust-lang/crates.io-index" 15 | checksum = "cf1de2fe8c75bc145a2f577add951f8134889b4795d47466a54a5c846d691693" 16 | 17 | [[package]] 18 | name = "bytes" 19 | version = "1.1.0" 20 | source = "registry+https://github.com/rust-lang/crates.io-index" 21 | checksum = "c4872d67bab6358e59559027aa3b9157c53d9358c51423c17554809a8858e0f8" 22 | 23 | [[package]] 24 | name = "cfg-if" 25 | version = "1.0.0" 26 | source = "registry+https://github.com/rust-lang/crates.io-index" 27 | checksum = "baf1de4339761588bc0619e3cbc0120ee582ebb74b53b4efbf79117bd2da40fd" 28 | 29 | [[package]] 30 | name = "fnv" 31 | version = "1.0.7" 32 | source = "registry+https://github.com/rust-lang/crates.io-index" 33 | checksum = "3f9eec918d3f24069decb9af1554cad7c880e2da24a9afd88aca000531ab82c1" 34 | 35 | [[package]] 36 | name = "futures-channel" 37 | version = "0.3.21" 38 | source = "registry+https://github.com/rust-lang/crates.io-index" 39 | checksum = "c3083ce4b914124575708913bca19bfe887522d6e2e6d0952943f5eac4a74010" 40 | dependencies = [ 41 | "futures-core", 42 | ] 43 | 44 | [[package]] 45 | name = "futures-core" 46 | version = "0.3.21" 47 | source = "registry+https://github.com/rust-lang/crates.io-index" 48 | checksum = "0c09fd04b7e4073ac7156a9539b57a484a8ea920f79c7c675d05d289ab6110d3" 49 | 50 | [[package]] 51 | name = "futures-sink" 52 | version = "0.3.21" 53 | source = "registry+https://github.com/rust-lang/crates.io-index" 54 | checksum = "21163e139fa306126e6eedaf49ecdb4588f939600f0b1e770f4205ee4b7fa868" 55 | 56 | [[package]] 57 | name = "futures-task" 58 | version = "0.3.21" 59 | source = "registry+https://github.com/rust-lang/crates.io-index" 60 | checksum = "57c66a976bf5909d801bbef33416c41372779507e7a6b3a5e25e4749c58f776a" 61 | 62 | [[package]] 63 | name = "futures-util" 64 | version = "0.3.21" 65 | source = "registry+https://github.com/rust-lang/crates.io-index" 66 | checksum = "d8b7abd5d659d9b90c8cba917f6ec750a74e2dc23902ef9cd4cc8c8b22e6036a" 67 | dependencies = [ 68 | "futures-core", 69 | "futures-task", 70 | "pin-project-lite", 71 | "pin-utils", 72 | ] 73 | 74 | [[package]] 75 | name = "h2" 76 | version = "0.3.11" 77 | source = "registry+https://github.com/rust-lang/crates.io-index" 78 | checksum = "d9f1f717ddc7b2ba36df7e871fd88db79326551d3d6f1fc406fbfd28b582ff8e" 79 | dependencies = [ 80 | "bytes", 81 | "fnv", 82 | "futures-core", 83 | "futures-sink", 84 | "futures-util", 85 | "http", 86 | "indexmap", 87 | "slab", 88 | "tokio", 89 | "tokio-util", 90 | "tracing", 91 | ] 92 | 93 | [[package]] 94 | name = "hashbrown" 95 | version = "0.9.1" 96 | source = "registry+https://github.com/rust-lang/crates.io-index" 97 | checksum = "d7afe4a420e3fe79967a00898cc1f4db7c8a49a9333a29f8a4bd76a253d5cd04" 98 | 99 | [[package]] 100 | name = "hermit-abi" 101 | version = "0.1.18" 102 | source = "registry+https://github.com/rust-lang/crates.io-index" 103 | checksum = "322f4de77956e22ed0e5032c359a0f1273f1f7f0d79bfa3b8ffbc730d7fbcc5c" 104 | dependencies = [ 105 | "libc", 106 | ] 107 | 108 | [[package]] 109 | name = "http" 110 | version = "0.2.6" 111 | source = "registry+https://github.com/rust-lang/crates.io-index" 112 | checksum = "31f4c6746584866f0feabcc69893c5b51beef3831656a968ed7ae254cdc4fd03" 113 | dependencies = [ 114 | "bytes", 115 | "fnv", 116 | "itoa", 117 | ] 118 | 119 | [[package]] 120 | name = "http-body" 121 | version = "0.4.4" 122 | source = "registry+https://github.com/rust-lang/crates.io-index" 123 | checksum = "1ff4f84919677303da5f147645dbea6b1881f368d03ac84e1dc09031ebd7b2c6" 124 | dependencies = [ 125 | "bytes", 126 | "http", 127 | "pin-project-lite", 128 | ] 129 | 130 | [[package]] 131 | name = "httparse" 132 | version = "1.6.0" 133 | source = "registry+https://github.com/rust-lang/crates.io-index" 134 | checksum = "9100414882e15fb7feccb4897e5f0ff0ff1ca7d1a86a23208ada4d7a18e6c6c4" 135 | 136 | [[package]] 137 | name = "httpdate" 138 | version = "1.0.2" 139 | source = "registry+https://github.com/rust-lang/crates.io-index" 140 | checksum = "c4a1e36c821dbe04574f602848a19f742f4fb3c98d40449f11bcad18d6b17421" 141 | 142 | [[package]] 143 | name = "hyper" 144 | version = "0.14.17" 145 | source = "registry+https://github.com/rust-lang/crates.io-index" 146 | checksum = "043f0e083e9901b6cc658a77d1eb86f4fc650bbb977a4337dd63192826aa85dd" 147 | dependencies = [ 148 | "bytes", 149 | "futures-channel", 150 | "futures-core", 151 | "futures-util", 152 | "h2", 153 | "http", 154 | "http-body", 155 | "httparse", 156 | "httpdate", 157 | "itoa", 158 | "pin-project-lite", 159 | "socket2", 160 | "tokio", 161 | "tower-service", 162 | "tracing", 163 | "want", 164 | ] 165 | 166 | [[package]] 167 | name = "indexmap" 168 | version = "1.6.2" 169 | source = "registry+https://github.com/rust-lang/crates.io-index" 170 | checksum = "824845a0bf897a9042383849b02c1bc219c2383772efcd5c6f9766fa4b81aef3" 171 | dependencies = [ 172 | "autocfg", 173 | "hashbrown", 174 | ] 175 | 176 | [[package]] 177 | name = "itoa" 178 | version = "1.0.1" 179 | source = "registry+https://github.com/rust-lang/crates.io-index" 180 | checksum = "1aab8fc367588b89dcee83ab0fd66b72b50b72fa1904d7095045ace2b0c81c35" 181 | 182 | [[package]] 183 | name = "lazy_static" 184 | version = "1.4.0" 185 | source = "registry+https://github.com/rust-lang/crates.io-index" 186 | checksum = "e2abad23fbc42b3700f2f279844dc832adb2b2eb069b2df918f455c4e18cc646" 187 | 188 | [[package]] 189 | name = "libc" 190 | version = "0.2.119" 191 | source = "registry+https://github.com/rust-lang/crates.io-index" 192 | checksum = "1bf2e165bb3457c8e098ea76f3e3bc9db55f87aa90d52d0e6be741470916aaa4" 193 | 194 | [[package]] 195 | name = "lock_api" 196 | version = "0.4.6" 197 | source = "registry+https://github.com/rust-lang/crates.io-index" 198 | checksum = "88943dd7ef4a2e5a4bfa2753aaab3013e34ce2533d1996fb18ef591e315e2b3b" 199 | dependencies = [ 200 | "scopeguard", 201 | ] 202 | 203 | [[package]] 204 | name = "log" 205 | version = "0.4.14" 206 | source = "registry+https://github.com/rust-lang/crates.io-index" 207 | checksum = "51b9bbe6c47d51fc3e1a9b945965946b4c44142ab8792c50835a980d362c2710" 208 | dependencies = [ 209 | "cfg-if", 210 | ] 211 | 212 | [[package]] 213 | name = "memchr" 214 | version = "2.4.0" 215 | source = "registry+https://github.com/rust-lang/crates.io-index" 216 | checksum = "b16bd47d9e329435e309c58469fe0791c2d0d1ba96ec0954152a5ae2b04387dc" 217 | 218 | [[package]] 219 | name = "mio" 220 | version = "0.8.0" 221 | source = "registry+https://github.com/rust-lang/crates.io-index" 222 | checksum = "ba272f85fa0b41fc91872be579b3bbe0f56b792aa361a380eb669469f68dafb2" 223 | dependencies = [ 224 | "libc", 225 | "log", 226 | "miow", 227 | "ntapi", 228 | "winapi", 229 | ] 230 | 231 | [[package]] 232 | name = "miow" 233 | version = "0.3.7" 234 | source = "registry+https://github.com/rust-lang/crates.io-index" 235 | checksum = "b9f1c5b025cda876f66ef43a113f91ebc9f4ccef34843000e0adf6ebbab84e21" 236 | dependencies = [ 237 | "winapi", 238 | ] 239 | 240 | [[package]] 241 | name = "ntapi" 242 | version = "0.3.7" 243 | source = "registry+https://github.com/rust-lang/crates.io-index" 244 | checksum = "c28774a7fd2fbb4f0babd8237ce554b73af68021b5f695a3cebd6c59bac0980f" 245 | dependencies = [ 246 | "winapi", 247 | ] 248 | 249 | [[package]] 250 | name = "num_cpus" 251 | version = "1.13.0" 252 | source = "registry+https://github.com/rust-lang/crates.io-index" 253 | checksum = "05499f3756671c15885fee9034446956fff3f243d6077b91e5767df161f766b3" 254 | dependencies = [ 255 | "hermit-abi", 256 | "libc", 257 | ] 258 | 259 | [[package]] 260 | name = "once_cell" 261 | version = "1.9.0" 262 | source = "registry+https://github.com/rust-lang/crates.io-index" 263 | checksum = "da32515d9f6e6e489d7bc9d84c71b060db7247dc035bbe44eac88cf87486d8d5" 264 | 265 | [[package]] 266 | name = "parking_lot" 267 | version = "0.12.0" 268 | source = "registry+https://github.com/rust-lang/crates.io-index" 269 | checksum = "87f5ec2493a61ac0506c0f4199f99070cbe83857b0337006a30f3e6719b8ef58" 270 | dependencies = [ 271 | "lock_api", 272 | "parking_lot_core", 273 | ] 274 | 275 | [[package]] 276 | name = "parking_lot_core" 277 | version = "0.9.1" 278 | source = "registry+https://github.com/rust-lang/crates.io-index" 279 | checksum = "28141e0cc4143da2443301914478dc976a61ffdb3f043058310c70df2fed8954" 280 | dependencies = [ 281 | "cfg-if", 282 | "libc", 283 | "redox_syscall", 284 | "smallvec", 285 | "windows-sys", 286 | ] 287 | 288 | [[package]] 289 | name = "pin-project-lite" 290 | version = "0.2.8" 291 | source = "registry+https://github.com/rust-lang/crates.io-index" 292 | checksum = "e280fbe77cc62c91527259e9442153f4688736748d24660126286329742b4c6c" 293 | 294 | [[package]] 295 | name = "pin-utils" 296 | version = "0.1.0" 297 | source = "registry+https://github.com/rust-lang/crates.io-index" 298 | checksum = "8b870d8c151b6f2fb93e84a13146138f05d02ed11c7e7c54f8826aaaf7c9f184" 299 | 300 | [[package]] 301 | name = "proc-macro2" 302 | version = "1.0.27" 303 | source = "registry+https://github.com/rust-lang/crates.io-index" 304 | checksum = "f0d8caf72986c1a598726adc988bb5984792ef84f5ee5aa50209145ee8077038" 305 | dependencies = [ 306 | "unicode-xid", 307 | ] 308 | 309 | [[package]] 310 | name = "quote" 311 | version = "1.0.9" 312 | source = "registry+https://github.com/rust-lang/crates.io-index" 313 | checksum = "c3d0b9745dc2debf507c8422de05d7226cc1f0644216dfdfead988f9b1ab32a7" 314 | dependencies = [ 315 | "proc-macro2", 316 | ] 317 | 318 | [[package]] 319 | name = "redox_syscall" 320 | version = "0.2.10" 321 | source = "registry+https://github.com/rust-lang/crates.io-index" 322 | checksum = "8383f39639269cde97d255a32bdb68c047337295414940c68bdd30c2e13203ff" 323 | dependencies = [ 324 | "bitflags", 325 | ] 326 | 327 | [[package]] 328 | name = "rust-hyper" 329 | version = "0.1.0" 330 | dependencies = [ 331 | "hyper", 332 | "tokio", 333 | ] 334 | 335 | [[package]] 336 | name = "scopeguard" 337 | version = "1.1.0" 338 | source = "registry+https://github.com/rust-lang/crates.io-index" 339 | checksum = "d29ab0c6d3fc0ee92fe66e2d99f700eab17a8d57d1c1d3b748380fb20baa78cd" 340 | 341 | [[package]] 342 | name = "signal-hook-registry" 343 | version = "1.4.0" 344 | source = "registry+https://github.com/rust-lang/crates.io-index" 345 | checksum = "e51e73328dc4ac0c7ccbda3a494dfa03df1de2f46018127f60c693f2648455b0" 346 | dependencies = [ 347 | "libc", 348 | ] 349 | 350 | [[package]] 351 | name = "slab" 352 | version = "0.4.3" 353 | source = "registry+https://github.com/rust-lang/crates.io-index" 354 | checksum = "f173ac3d1a7e3b28003f40de0b5ce7fe2710f9b9dc3fc38664cebee46b3b6527" 355 | 356 | [[package]] 357 | name = "smallvec" 358 | version = "1.8.0" 359 | source = "registry+https://github.com/rust-lang/crates.io-index" 360 | checksum = "f2dd574626839106c320a323308629dcb1acfc96e32a8cba364ddc61ac23ee83" 361 | 362 | [[package]] 363 | name = "socket2" 364 | version = "0.4.4" 365 | source = "registry+https://github.com/rust-lang/crates.io-index" 366 | checksum = "66d72b759436ae32898a2af0a14218dbf55efde3feeb170eb623637db85ee1e0" 367 | dependencies = [ 368 | "libc", 369 | "winapi", 370 | ] 371 | 372 | [[package]] 373 | name = "syn" 374 | version = "1.0.72" 375 | source = "registry+https://github.com/rust-lang/crates.io-index" 376 | checksum = "a1e8cdbefb79a9a5a65e0db8b47b723ee907b7c7f8496c76a1770b5c310bab82" 377 | dependencies = [ 378 | "proc-macro2", 379 | "quote", 380 | "unicode-xid", 381 | ] 382 | 383 | [[package]] 384 | name = "tokio" 385 | version = "1.17.0" 386 | source = "registry+https://github.com/rust-lang/crates.io-index" 387 | checksum = "2af73ac49756f3f7c01172e34a23e5d0216f6c32333757c2c61feb2bbff5a5ee" 388 | dependencies = [ 389 | "bytes", 390 | "libc", 391 | "memchr", 392 | "mio", 393 | "num_cpus", 394 | "once_cell", 395 | "parking_lot", 396 | "pin-project-lite", 397 | "signal-hook-registry", 398 | "socket2", 399 | "tokio-macros", 400 | "winapi", 401 | ] 402 | 403 | [[package]] 404 | name = "tokio-macros" 405 | version = "1.7.0" 406 | source = "registry+https://github.com/rust-lang/crates.io-index" 407 | checksum = "b557f72f448c511a979e2564e55d74e6c4432fc96ff4f6241bc6bded342643b7" 408 | dependencies = [ 409 | "proc-macro2", 410 | "quote", 411 | "syn", 412 | ] 413 | 414 | [[package]] 415 | name = "tokio-util" 416 | version = "0.6.9" 417 | source = "registry+https://github.com/rust-lang/crates.io-index" 418 | checksum = "9e99e1983e5d376cd8eb4b66604d2e99e79f5bd988c3055891dcd8c9e2604cc0" 419 | dependencies = [ 420 | "bytes", 421 | "futures-core", 422 | "futures-sink", 423 | "log", 424 | "pin-project-lite", 425 | "tokio", 426 | ] 427 | 428 | [[package]] 429 | name = "tower-service" 430 | version = "0.3.1" 431 | source = "registry+https://github.com/rust-lang/crates.io-index" 432 | checksum = "360dfd1d6d30e05fda32ace2c8c70e9c0a9da713275777f5a4dbb8a1893930c6" 433 | 434 | [[package]] 435 | name = "tracing" 436 | version = "0.1.31" 437 | source = "registry+https://github.com/rust-lang/crates.io-index" 438 | checksum = "f6c650a8ef0cd2dd93736f033d21cbd1224c5a967aa0c258d00fcf7dafef9b9f" 439 | dependencies = [ 440 | "cfg-if", 441 | "pin-project-lite", 442 | "tracing-core", 443 | ] 444 | 445 | [[package]] 446 | name = "tracing-core" 447 | version = "0.1.22" 448 | source = "registry+https://github.com/rust-lang/crates.io-index" 449 | checksum = "03cfcb51380632a72d3111cb8d3447a8d908e577d31beeac006f836383d29a23" 450 | dependencies = [ 451 | "lazy_static", 452 | ] 453 | 454 | [[package]] 455 | name = "try-lock" 456 | version = "0.2.3" 457 | source = "registry+https://github.com/rust-lang/crates.io-index" 458 | checksum = "59547bce71d9c38b83d9c0e92b6066c4253371f15005def0c30d9657f50c7642" 459 | 460 | [[package]] 461 | name = "unicode-xid" 462 | version = "0.2.2" 463 | source = "registry+https://github.com/rust-lang/crates.io-index" 464 | checksum = "8ccb82d61f80a663efe1f787a51b16b5a51e3314d6ac365b08639f52387b33f3" 465 | 466 | [[package]] 467 | name = "want" 468 | version = "0.3.0" 469 | source = "registry+https://github.com/rust-lang/crates.io-index" 470 | checksum = "1ce8a968cb1cd110d136ff8b819a556d6fb6d919363c61534f6860c7eb172ba0" 471 | dependencies = [ 472 | "log", 473 | "try-lock", 474 | ] 475 | 476 | [[package]] 477 | name = "winapi" 478 | version = "0.3.9" 479 | source = "registry+https://github.com/rust-lang/crates.io-index" 480 | checksum = "5c839a674fcd7a98952e593242ea400abe93992746761e38641405d28b00f419" 481 | dependencies = [ 482 | "winapi-i686-pc-windows-gnu", 483 | "winapi-x86_64-pc-windows-gnu", 484 | ] 485 | 486 | [[package]] 487 | name = "winapi-i686-pc-windows-gnu" 488 | version = "0.4.0" 489 | source = "registry+https://github.com/rust-lang/crates.io-index" 490 | checksum = "ac3b87c63620426dd9b991e5ce0329eff545bccbbb34f3be09ff6fb6ab51b7b6" 491 | 492 | [[package]] 493 | name = "winapi-x86_64-pc-windows-gnu" 494 | version = "0.4.0" 495 | source = "registry+https://github.com/rust-lang/crates.io-index" 496 | checksum = "712e227841d057c1ee1cd2fb22fa7e5a5461ae8e48fa2ca79ec42cfc1931183f" 497 | 498 | [[package]] 499 | name = "windows-sys" 500 | version = "0.32.0" 501 | source = "registry+https://github.com/rust-lang/crates.io-index" 502 | checksum = "3df6e476185f92a12c072be4a189a0210dcdcf512a1891d6dff9edb874deadc6" 503 | dependencies = [ 504 | "windows_aarch64_msvc", 505 | "windows_i686_gnu", 506 | "windows_i686_msvc", 507 | "windows_x86_64_gnu", 508 | "windows_x86_64_msvc", 509 | ] 510 | 511 | [[package]] 512 | name = "windows_aarch64_msvc" 513 | version = "0.32.0" 514 | source = "registry+https://github.com/rust-lang/crates.io-index" 515 | checksum = "d8e92753b1c443191654ec532f14c199742964a061be25d77d7a96f09db20bf5" 516 | 517 | [[package]] 518 | name = "windows_i686_gnu" 519 | version = "0.32.0" 520 | source = "registry+https://github.com/rust-lang/crates.io-index" 521 | checksum = "6a711c68811799e017b6038e0922cb27a5e2f43a2ddb609fe0b6f3eeda9de615" 522 | 523 | [[package]] 524 | name = "windows_i686_msvc" 525 | version = "0.32.0" 526 | source = "registry+https://github.com/rust-lang/crates.io-index" 527 | checksum = "146c11bb1a02615db74680b32a68e2d61f553cc24c4eb5b4ca10311740e44172" 528 | 529 | [[package]] 530 | name = "windows_x86_64_gnu" 531 | version = "0.32.0" 532 | source = "registry+https://github.com/rust-lang/crates.io-index" 533 | checksum = "c912b12f7454c6620635bbff3450962753834be2a594819bd5e945af18ec64bc" 534 | 535 | [[package]] 536 | name = "windows_x86_64_msvc" 537 | version = "0.32.0" 538 | source = "registry+https://github.com/rust-lang/crates.io-index" 539 | checksum = "504a2476202769977a040c6364301a3f65d0cc9e3fb08600b2bda150a0488316" 540 | -------------------------------------------------------------------------------- /bench/rust-hyper/Cargo.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "rust-hyper" 3 | version = "0.1.0" 4 | authors = ["Sadiq Jaffer ", 5 | "Steve Klabnik ", 6 | "Alexander Polyakov ", 7 | "Sean McArthur "] 8 | edition = "2018" 9 | 10 | [dependencies] 11 | hyper = { version = "0.14", features = ["full"] } 12 | tokio = { version = "1", features = ["full"] } 13 | 14 | [profile.release] 15 | opt-level = 3 16 | codegen-units = 1 17 | lto = true -------------------------------------------------------------------------------- /bench/rust-hyper/src/main.rs: -------------------------------------------------------------------------------- 1 | use std::{convert::Infallible, net::SocketAddr}; 2 | 3 | use hyper::{ 4 | service::{make_service_fn, service_fn}, 5 | Body, Request, Response, Server, 6 | }; 7 | 8 | static PLAINTEXT: &'static [u8] = b"CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of sitting by her sister on the bank, and of having nothing to do: once or twice she had peeped into the book her sister was reading, but it had no pictures or conversations in it, thought Alice So she was considering in her own mind (as well as she could, for the hot day made her feel very sleepy and stupid), whether the pleasure of making a daisy-chain would be worth the trouble of getting up and picking the daisies, when suddenly a White Rabbit with pink eyes ran close by her. There was nothing so very remarkable in that; nor did Alice think it so very much out of the way to hear the Rabbit say to itself, (when she thought it over afterwards, it occurred to her that she ought to have wondered at this, but at the time it all seemed quite natural); but when the Rabbit actually took a watch out of its waistcoat-pocket, and looked at it, and then hurried on, Alice started to her feet, for it flashed across her mind that she had never before seen a rabbit with either a waistcoat-pocket, or a watch to take out of it, and burning with curiosity, she ran across the field after it, and fortunately was just in time to see it pop down a large rabbit-hole under the hedge. In another moment down went Alice after it, never once considering how in the world she was to get out again. The rabbit-hole went straight on like a tunnel for some way, and then dipped suddenly down, so suddenly that Alice had not a moment to think about stopping herself before she found herself falling down a very deep well. Either the well was very deep, or she fell very slowly, for she had plenty of time as she went down to look about her and to wonder what was going to happen next. First, she tried to look down and make out what she was coming to, but it was too dark to see anything; then she looked at the sides of the well, and noticed that they were filled with cupboards......"; 9 | 10 | async fn benchmark(_req: Request) -> Result, Infallible> { 11 | Ok(Response::new(PLAINTEXT.into())) 12 | } 13 | 14 | // Use current_thread to run tokio with a single-threade scheduler 15 | // #[tokio::main(flavor = "current_thread")] 16 | #[tokio::main] 17 | async fn main() { 18 | let addr = SocketAddr::from(([127, 0, 0, 1], 8080)); 19 | 20 | let make_svc = make_service_fn(|_conn| async { Ok::<_, Infallible>(service_fn(benchmark)) }); 21 | 22 | let server = Server::bind(&addr).serve(make_svc); 23 | if let Err(e) = server.await { 24 | eprintln!("Error: {}", e); 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /bench/server_bench.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open Http_async 4 | 5 | let text = 6 | Bigstring.of_string 7 | "CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of sitting \ 8 | by her sister on the bank, and of having nothing to do: once or twice she had \ 9 | peeped into the book her sister was reading, but it had no pictures or \ 10 | conversations in it, thought Alice So she was considering in her own mind (as well as she \ 12 | could, for the hot day made her feel very sleepy and stupid), whether the pleasure \ 13 | of making a daisy-chain would be worth the trouble of getting up and picking the \ 14 | daisies, when suddenly a White Rabbit with pink eyes ran close by her. There was \ 15 | nothing so very remarkable in that; nor did Alice think it so very much out of the \ 16 | way to hear the Rabbit say to itself, (when \ 17 | she thought it over afterwards, it occurred to her that she ought to have wondered \ 18 | at this, but at the time it all seemed quite natural); but when the Rabbit actually \ 19 | took a watch out of its waistcoat-pocket, and looked at it, and then hurried on, \ 20 | Alice started to her feet, for it flashed across her mind that she had never before \ 21 | seen a rabbit with either a waistcoat-pocket, or a watch to take out of it, and \ 22 | burning with curiosity, she ran across the field after it, and fortunately was just \ 23 | in time to see it pop down a large rabbit-hole under the hedge. In another moment \ 24 | down went Alice after it, never once considering how in the world she was to get \ 25 | out again. The rabbit-hole went straight on like a tunnel for some way, and then \ 26 | dipped suddenly down, so suddenly that Alice had not a moment to think about \ 27 | stopping herself before she found herself falling down a very deep well. Either the \ 28 | well was very deep, or she fell very slowly, for she had plenty of time as she went \ 29 | down to look about her and to wonder what was going to happen next. First, she \ 30 | tried to look down and make out what she was coming to, but it was too dark to see \ 31 | anything; then she looked at the sides of the well, and noticed that they were \ 32 | filled with cupboards......" 33 | ;; 34 | 35 | let command = 36 | Command.async 37 | ~summary:"Start a hello world Async server" 38 | Command.Let_syntax.( 39 | let%map_open port = 40 | flag "-p" ~doc:"int Source port to listen on" (optional_with_default 8080 int) 41 | in 42 | fun () -> 43 | let%bind.Deferred server = 44 | Server.run 45 | ~backlog:11_000 46 | ~max_accepts_per_batch:64 47 | ~buffer_config:(Buffer_config.create ~initial_size:0x4000 ()) 48 | ~where_to_listen:(Tcp.Where_to_listen.of_port port) 49 | (fun _addr (_request, _body) -> 50 | Deferred.return (Response.create `Ok, Body.Writer.bigstring text)) 51 | in 52 | Deferred.forever () (fun () -> 53 | let%map.Deferred () = after Time.Span.(of_sec 0.5) in 54 | Log.Global.printf "Active connections: %d" (Tcp.Server.num_connections server)); 55 | Tcp.Server.close_finished_and_handlers_determined server) 56 | ;; 57 | 58 | let () = 59 | Memtrace.trace_if_requested (); 60 | Command_unix.run command 61 | ;; 62 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | 3 | (name http_async) 4 | 5 | (generate_opam_files true) 6 | 7 | (source 8 | (github anuragsoni/http_async)) 9 | 10 | (authors "Anurag Soni ") 11 | 12 | (maintainers "Anurag Soni ") 13 | 14 | (documentation "https://anuragsoni.github.io/http_async/") 15 | 16 | (license MIT) 17 | 18 | (package 19 | (name http_async) 20 | (synopsis "Async library for HTTP/1.1 servers") 21 | (description 22 | "http_async implements an efficient HTTP/1.1 server. It uses the shuttle library for network IO, and provides an easy-to-use interface for writing async http services while minimal overhead on top of the user provided http handler.") 23 | (tags 24 | (http-server http http1.1 async)) 25 | (depends 26 | (ocaml 27 | (>= 4.11.0)) 28 | (shuttle 29 | (>= 0.6.0)) 30 | (ppxlib 31 | (>= 0.23.0)))) 32 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names hello_world echo) 3 | (preprocess 4 | (pps ppx_jane)) 5 | (libraries core core_unix.command_unix async shuttle http_async)) 6 | -------------------------------------------------------------------------------- /example/echo.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open Http_async 4 | 5 | let () = 6 | Command_unix.run 7 | (Server.run_command ~summary:"echo" (fun _addr (_request, body) -> 8 | let response = Response.create `Ok in 9 | return (response, Body.Writer.stream (Body.Reader.pipe body)))) 10 | ;; 11 | -------------------------------------------------------------------------------- /example/hello_world.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open Http_async 4 | 5 | let () = 6 | Command_unix.run 7 | (Server.run_command ~summary:"Hello world HTTP Server" (fun addr (request, _body) -> 8 | Log.Global.info 9 | "(%s): %s" 10 | (Socket.Address.Inet.to_string addr) 11 | (Request.path request); 12 | return (Response.create `Ok, Body.Writer.string "Hello World"))) 13 | ;; 14 | -------------------------------------------------------------------------------- /http_async.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" 4 | description: 5 | "http_async implements an efficient HTTP/1.1 server. It uses the shuttle library for network IO, and provides an easy-to-use interface for writing async http services while minimal overhead on top of the user provided http handler." 6 | maintainer: ["Anurag Soni "] 7 | authors: ["Anurag Soni "] 8 | license: "MIT" 9 | tags: ["http-server" "http" "http1.1" "async"] 10 | homepage: "https://github.com/anuragsoni/http_async" 11 | doc: "https://anuragsoni.github.io/http_async/" 12 | bug-reports: "https://github.com/anuragsoni/http_async/issues" 13 | depends: [ 14 | "dune" {>= "2.9"} 15 | "ocaml" {>= "4.11.0"} 16 | "shuttle" {>= "0.6.0"} 17 | "ppxlib" {>= "0.23.0"} 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | [ 23 | "dune" 24 | "build" 25 | "-p" 26 | name 27 | "-j" 28 | jobs 29 | "--promote-install-files=false" 30 | "@install" 31 | "@runtest" {with-test} 32 | "@doc" {with-doc} 33 | ] 34 | ["dune" "install" "-p" name "--create-install-files" name] 35 | ] 36 | dev-repo: "git+https://github.com/anuragsoni/http_async.git" 37 | available: [ arch = "x86_64" | arch = "arm64" ] 38 | -------------------------------------------------------------------------------- /http_async.opam.template: -------------------------------------------------------------------------------- 1 | available: [ arch = "x86_64" | arch = "arm64" ] 2 | -------------------------------------------------------------------------------- /src/body.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | open Shuttle 4 | 5 | module Reader = struct 6 | type t = 7 | | Empty 8 | | Stream of 9 | { encoding : [ `Chunked | `Fixed of int ] 10 | ; reader : (Bigstring.t Core_unix.IOVec.t Pipe.Reader.t[@sexp.opaque]) 11 | } 12 | [@@deriving sexp_of] 13 | 14 | let empty = Empty 15 | 16 | module Private = struct 17 | let rec read_bigstring chan len = 18 | let view = Input_channel.view chan in 19 | if view.len > 0 20 | then ( 21 | let to_read = min len view.len in 22 | return (`Ok (Core_unix.IOVec.of_bigstring ~pos:view.pos ~len:to_read view.buf))) 23 | else 24 | Input_channel.refill chan 25 | >>= function 26 | | `Eof -> return `Eof 27 | | `Ok -> read_bigstring chan len 28 | ;; 29 | 30 | let fixed_reader len chan = 31 | Pipe.create_reader ~close_on_exception:false (fun writer -> 32 | Deferred.repeat_until_finished len (fun len -> 33 | read_bigstring chan len 34 | >>= function 35 | | `Eof -> return (`Finished ()) 36 | | `Ok chunk -> 37 | let consumed = chunk.len in 38 | Pipe.write_if_open writer chunk 39 | >>= fun () -> 40 | Pipe.downstream_flushed writer 41 | >>= fun _ -> 42 | Input_channel.consume chan consumed; 43 | if consumed = len 44 | then return (`Finished ()) 45 | else return (`Repeat (len - consumed)))) 46 | ;; 47 | 48 | let chunked_reader chan = 49 | Pipe.create_reader ~close_on_exception:false (fun writer -> 50 | Deferred.repeat_until_finished Parser.Start_chunk (fun state -> 51 | let view = Input_channel.view chan in 52 | match Parser.parse_chunk ~pos:view.pos ~len:view.len view.buf state with 53 | | Error (Fail error) -> Error.raise error 54 | | Error Partial -> 55 | Input_channel.refill chan 56 | >>| (function 57 | | `Ok -> `Repeat state 58 | | `Eof -> `Finished ()) 59 | | Ok (parse_result, consumed) -> 60 | (match parse_result with 61 | | Parser.Chunk_complete chunk -> 62 | Pipe.write_if_open writer chunk 63 | >>= fun () -> 64 | Pipe.downstream_flushed writer 65 | >>| fun _ -> 66 | Input_channel.consume chan consumed; 67 | `Repeat Parser.Start_chunk 68 | | Parser.Done -> return (`Finished ()) 69 | | Parser.Partial_chunk (chunk, to_consume) -> 70 | Pipe.write_if_open writer chunk 71 | >>= fun () -> 72 | Pipe.downstream_flushed writer 73 | >>| fun _ -> 74 | Input_channel.consume chan consumed; 75 | `Repeat (Parser.Continue_chunk to_consume)))) 76 | ;; 77 | 78 | let get_transfer_encoding headers = 79 | match List.rev @@ Headers.find_multi headers "Transfer-Encoding" with 80 | | x :: _ when String.Caseless.equal x "chunked" -> `Chunked 81 | | _x :: _ -> `Bad_request 82 | | [] -> 83 | (match 84 | List.dedup_and_sort 85 | ~compare:String.Caseless.compare 86 | (Headers.find_multi headers "Content-Length") 87 | with 88 | | [] -> `Fixed 0 89 | (* TODO: check for exceptions when converting to int *) 90 | | [ x ] -> 91 | let len = 92 | try Int.of_string x with 93 | | _ -> -1 94 | in 95 | if Int.(len >= 0) then `Fixed len else `Bad_request 96 | | _ -> `Bad_request) 97 | ;; 98 | 99 | let create req chan = 100 | match get_transfer_encoding (Request.headers req) with 101 | | `Fixed 0 -> Ok empty 102 | | `Fixed len as encoding -> 103 | let reader = fixed_reader len chan in 104 | Ok (Stream { encoding; reader }) 105 | | `Chunked as encoding -> Ok (Stream { encoding; reader = chunked_reader chan }) 106 | | `Bad_request -> Or_error.error_s [%sexp "Invalid transfer encoding"] 107 | ;; 108 | end 109 | 110 | let encoding t = 111 | match t with 112 | | Empty -> `Fixed 0 113 | | Stream { encoding; _ } -> encoding 114 | ;; 115 | 116 | let pipe t = 117 | match t with 118 | | Empty -> Pipe.empty () 119 | | Stream { reader; _ } -> reader 120 | ;; 121 | end 122 | 123 | module Writer = struct 124 | type kind = 125 | | Empty 126 | | String of string 127 | | Bigstring of Bigstring.t 128 | | Stream of (Bigstring.t Core_unix.IOVec.t Pipe.Reader.t[@sexp.opaque]) 129 | [@@deriving sexp_of] 130 | 131 | type t = 132 | { encoding : [ `Chunked | `Fixed of int ] 133 | ; kind : kind 134 | } 135 | [@@deriving sexp_of] 136 | 137 | let encoding t = t.encoding 138 | let empty = { encoding = `Fixed 0; kind = Empty } 139 | let string x = { encoding = `Fixed (Int.of_int (String.length x)); kind = String x } 140 | 141 | let bigstring x = 142 | { encoding = `Fixed (Int.of_int (Bigstring.length x)); kind = Bigstring x } 143 | ;; 144 | 145 | let stream ?(encoding = `Chunked) x = { encoding; kind = Stream x } 146 | 147 | module Private = struct 148 | let is_chunked t = 149 | match t.encoding with 150 | | `Chunked -> true 151 | | _ -> false 152 | ;; 153 | 154 | let make_writer t = 155 | match t.encoding with 156 | | `Chunked -> 157 | fun writer buf -> 158 | (* avoid writing empty payloads as that is used to indicate the end of a 159 | stream. *) 160 | if buf.Core_unix.IOVec.len = 0 161 | then Deferred.unit 162 | else ( 163 | Output_channel.writef writer "%x\r\n" buf.len; 164 | Output_channel.write_bigstring writer buf.buf ~pos:buf.pos ~len:buf.len; 165 | Output_channel.write writer "\r\n"; 166 | Output_channel.flush writer) 167 | | `Fixed _ -> 168 | fun writer buf -> 169 | if buf.len = 0 170 | then Deferred.unit 171 | else ( 172 | Output_channel.write_bigstring writer buf.buf ~pos:buf.pos ~len:buf.len; 173 | Output_channel.flush writer) 174 | ;; 175 | 176 | let write t writer = 177 | Deferred.create (fun ivar -> 178 | match t.kind with 179 | | Empty -> Output_channel.flush writer >>> fun () -> Ivar.fill ivar () 180 | | String x -> 181 | Output_channel.write writer x; 182 | Output_channel.flush writer >>> fun () -> Ivar.fill ivar () 183 | | Bigstring b -> 184 | Output_channel.write_bigstring writer b; 185 | Output_channel.flush writer >>> fun () -> Ivar.fill ivar () 186 | | Stream xs -> 187 | let write_chunk = make_writer t in 188 | Pipe.iter ~flushed:Pipe.Flushed.When_value_processed xs ~f:(fun buf -> 189 | write_chunk writer buf) 190 | >>> fun () -> 191 | if is_chunked t 192 | then ( 193 | Output_channel.write writer "0\r\n\r\n"; 194 | Output_channel.flush writer >>> fun () -> Ivar.fill ivar ()) 195 | else Ivar.fill ivar ()) 196 | ;; 197 | end 198 | end 199 | -------------------------------------------------------------------------------- /src/buffer_config.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | type t = 4 | { initial_size : int 5 | ; max_buffer_size : int 6 | } 7 | [@@deriving sexp_of] 8 | 9 | let validate t = 10 | if t.initial_size <= 0 || t.initial_size > t.max_buffer_size 11 | then raise_s [%sexp "Http_async.Buffer_config.validate: invalid config", { t : t }]; 12 | t 13 | ;; 14 | 15 | let create ?(initial_size = 16 * 1024) ?(max_buffer_size = Int.max_value) () = 16 | validate { initial_size; max_buffer_size } 17 | ;; 18 | 19 | let initial_size t = t.initial_size 20 | let max_buffer_size t = t.max_buffer_size 21 | -------------------------------------------------------------------------------- /src/buffer_config.mli: -------------------------------------------------------------------------------- 1 | type t [@@deriving sexp_of] 2 | 3 | val create : ?initial_size:int -> ?max_buffer_size:int -> unit -> t 4 | val initial_size : t -> int 5 | val max_buffer_size : t -> int 6 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name http_async) 3 | (preprocess 4 | (pps ppx_jane)) 5 | (libraries shuttle)) 6 | -------------------------------------------------------------------------------- /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 iter t ~f = List.iter t ~f:(fun (key, data) -> f ~key ~data) 8 | 9 | let rec mem t key = 10 | match t with 11 | | [] -> false 12 | | (k, _) :: t -> String.Caseless.equal k key || mem t key 13 | ;; 14 | 15 | let rec find t key = 16 | match t with 17 | | [] -> None 18 | | (k, v) :: t -> if String.Caseless.equal k key then Some v else find t key 19 | ;; 20 | 21 | let rec find_multi t key = 22 | match t with 23 | | [] -> [] 24 | | (k, v) :: t -> 25 | if String.Caseless.equal k key then v :: find_multi t key else find_multi t key 26 | ;; 27 | 28 | let empty = [] 29 | let add_unless_exists t ~key ~data = if not (mem t key) then (key, data) :: t else t 30 | -------------------------------------------------------------------------------- /src/headers.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t [@@deriving sexp] 4 | 5 | val of_rev_list : (string * string) list -> t 6 | val of_list : (string * string) list -> t 7 | val iter : t -> f:(key:string -> data:string -> unit) -> unit 8 | val mem : t -> string -> bool 9 | val find : t -> string -> string option 10 | val find_multi : t -> string -> string list 11 | val empty : t 12 | val add_unless_exists : t -> key:string -> data:string -> t 13 | -------------------------------------------------------------------------------- /src/http_async.ml: -------------------------------------------------------------------------------- 1 | module Server = Server 2 | module Body = Body 3 | module Logger = Logger 4 | module Status = Status 5 | module Meth = Meth 6 | module Request = Request 7 | module Version = Version 8 | module Response = Response 9 | module Headers = Headers 10 | module Buffer_config = Buffer_config 11 | 12 | module Private = struct 13 | module Parser = Parser 14 | end 15 | -------------------------------------------------------------------------------- /src/http_async.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open! Shuttle 4 | module Logger : Log.Global_intf 5 | module Status = Status 6 | module Request = Request 7 | module Version = Version 8 | module Response = Response 9 | module Meth = Meth 10 | module Headers = Headers 11 | module Buffer_config = Buffer_config 12 | 13 | module Body : sig 14 | (** [Reader] represents streaming request bodies. Readers can work with both fixed 15 | length and chunk encoded bodies. *) 16 | module Reader : sig 17 | type t [@@deriving sexp_of] 18 | 19 | val encoding : t -> [ `Chunked | `Fixed of int ] 20 | val pipe : t -> Core.Bigstring.t Core_unix.IOVec.t Async.Pipe.Reader.t 21 | end 22 | 23 | module Writer : sig 24 | (** [Writer] represents response bodies. It supports both fixed length bodies 25 | represented via strings/bigstrings, and streaming bodies. *) 26 | type t [@@deriving sexp_of] 27 | 28 | val encoding : t -> [ `Chunked | `Fixed of int ] 29 | val empty : t 30 | val string : string -> t 31 | val bigstring : Core.Bigstring.t -> t 32 | 33 | val stream 34 | : ?encoding:[ `Chunked | `Fixed of int ] 35 | -> Bigstring.t Core_unix.IOVec.t Async.Pipe.Reader.t 36 | -> t 37 | end 38 | end 39 | 40 | module Server : sig 41 | type error_handler = 42 | ?exn:Exn.t 43 | -> ?request:Request.t 44 | -> Status.t 45 | -> (Response.t * Body.Writer.t) Deferred.t 46 | 47 | (** [run_server_loop] accepts a HTTP service, and returns a callback that can be used to 48 | drive the server loop created via [Shuttle.Connection.listen]. This allows the user 49 | to customize the [Input_channel] and [Output_channel] and have control over the 50 | various Server configuration options like [accept_n], [backlog] and more. *) 51 | val run_server_loop 52 | : ?error_handler:error_handler 53 | -> (Request.t * Body.Reader.t -> (Response.t * Body.Writer.t) Deferred.t) 54 | -> Input_channel.t 55 | -> Output_channel.t 56 | -> unit Deferred.t 57 | 58 | (** [run] sets up a [Tcp.Server.t] and drives the HTTP server loop with the user 59 | provided request-handler. *) 60 | val run 61 | : ?max_connections:int 62 | -> ?max_accepts_per_batch:int 63 | -> ?backlog:int 64 | -> ?socket:([ `Unconnected ], ([< Socket.Address.t ] as 'a)) Socket.t 65 | -> ?buffer_config:Buffer_config.t 66 | -> ?error_handler:('a -> error_handler) 67 | -> where_to_listen:('a, 'b) Tcp.Where_to_listen.t 68 | -> ('a -> Request.t * Body.Reader.t -> (Response.t * Body.Writer.t) Deferred.t) 69 | -> ('a, 'b) Tcp.Server.t Deferred.t 70 | 71 | (** [run_command] is similar to [run] but instead returns an [Async.Command.t] that can 72 | be used to start the async event loop from a program's entrypoint. If [interrupt] is 73 | provided, the server will be stopped when [interrupt] is fulfilled. *) 74 | val run_command 75 | : ?interrupt:unit Deferred.t 76 | -> ?readme:(unit -> string) 77 | -> ?error_handler:(Socket.Address.Inet.t -> error_handler) 78 | -> summary:string 79 | -> (Socket.Address.Inet.t 80 | -> Request.t * Body.Reader.t 81 | -> (Response.t * Body.Writer.t) Deferred.t) 82 | -> Command.t 83 | end 84 | 85 | module Private : sig 86 | module Parser = Parser 87 | end 88 | -------------------------------------------------------------------------------- /src/logger.ml: -------------------------------------------------------------------------------- 1 | include Async.Log.Make_global () 2 | -------------------------------------------------------------------------------- /src/logger.mli: -------------------------------------------------------------------------------- 1 | include Async.Log.Global_intf 2 | -------------------------------------------------------------------------------- /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] 18 | end 19 | 20 | include T 21 | include Comparable.Make (T) 22 | 23 | let of_string = function 24 | | "GET" -> Some `GET 25 | | "HEAD" -> Some `HEAD 26 | | "POST" -> Some `POST 27 | | "PUT" -> Some `PUT 28 | | "DELETE" -> Some `DELETE 29 | | "CONNECT" -> Some `CONNECT 30 | | "OPTIONS" -> Some `OPTIONS 31 | | "TRACE" -> Some `TRACE 32 | | "PATCH" -> Some `PATCH 33 | | _ -> None 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 | -------------------------------------------------------------------------------- /src/meth.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type t = 4 | [ (* https://datatracker.ietf.org/doc/html/rfc7231#section-4.3 *) 5 | `GET 6 | | `HEAD 7 | | `POST 8 | | `PUT 9 | | `DELETE 10 | | `CONNECT 11 | | `OPTIONS 12 | | `TRACE 13 | | (* https://datatracker.ietf.org/doc/html/rfc5789 *) 14 | `PATCH 15 | ] 16 | [@@deriving sexp, compare, hash, enumerate] 17 | 18 | val of_string : string -> t option 19 | val to_string : t -> string 20 | 21 | include Comparable.S with type t := t 22 | -------------------------------------------------------------------------------- /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] to_iovec t ~pos ~len = 54 | Core_unix.IOVec.of_bigstring t.buffer ~pos:(t.pos + pos) ~len 55 | ;; 56 | 57 | let[@inline always] is_space = function 58 | | ' ' | '\012' | '\n' | '\r' | '\t' -> true 59 | | _ -> false 60 | ;; 61 | 62 | let[@inline always] to_string_trim t ~pos ~len = 63 | let last = ref (t.pos + len - 1) in 64 | let pos = ref (t.pos + pos) in 65 | while is_space (Bigstring.get t.buffer !pos) do 66 | incr pos 67 | done; 68 | while is_space (Bigstring.get t.buffer !last) do 69 | decr last 70 | done; 71 | let len = !last - !pos + 1 in 72 | let b = Bytes.create len in 73 | Bigstring.To_bytes.unsafe_blit ~src:t.buffer ~dst:b ~src_pos:!pos ~dst_pos:0 ~len; 74 | Bytes.unsafe_to_string ~no_mutation_while_string_reachable:b 75 | ;; 76 | 77 | let[@inline always] index t ch = 78 | let idx = Bigstring.unsafe_find t.buffer ch ~pos:t.pos ~len:(length t) in 79 | if idx < 0 then -1 else idx - t.pos 80 | ;; 81 | 82 | let[@inline always] consume_eol t = 83 | if length t < 2 then raise_notrace Partial; 84 | if Char.( 85 | Bigstring.get t.buffer t.pos = '\r' && Bigstring.get t.buffer (t.pos + 1) = '\n') 86 | then unsafe_advance t 2 87 | else raise_notrace (Fail (Error.of_string "Expected EOL")) 88 | ;; 89 | 90 | let parse_header tchar_map source = 91 | let pos = index source ':' in 92 | if pos = -1 93 | then raise_notrace Partial 94 | else if pos = 0 95 | then raise_notrace (Fail (Error.of_string "Invalid header: Empty header key")); 96 | for idx = 0 to pos - 1 do 97 | if not (Array.unsafe_get tchar_map (Char.to_int (unsafe_get source idx))) 98 | then raise_notrace (Fail (Error.of_string "Invalid Header Key")) 99 | done; 100 | let key = to_string source ~pos:0 ~len:pos in 101 | unsafe_advance source (pos + 1); 102 | let pos = index source '\r' in 103 | if pos = -1 then raise_notrace Partial; 104 | let v = to_string_trim source ~pos:0 ~len:pos in 105 | unsafe_advance source pos; 106 | key, v 107 | ;; 108 | end 109 | 110 | let[@inline always] ( .![] ) source idx = Source.unsafe_get source idx 111 | let invalid_method = Fail (Error.of_string "Invalid Method") 112 | 113 | let meth source = 114 | let pos = Source.index source ' ' in 115 | if pos = -1 then raise_notrace Partial; 116 | let meth = 117 | match pos with 118 | | 3 -> 119 | (match source.![0], source.![1], source.![2] with 120 | | 'G', 'E', 'T' -> `GET 121 | | 'P', 'U', 'T' -> `PUT 122 | | _ -> raise_notrace invalid_method) 123 | | 4 -> 124 | (match source.![0], source.![1], source.![2], source.![3] with 125 | | 'H', 'E', 'A', 'D' -> `HEAD 126 | | 'P', 'O', 'S', 'T' -> `POST 127 | | _ -> raise_notrace invalid_method) 128 | | 5 -> 129 | (match source.![0], source.![1], source.![2], source.![3], source.![4] with 130 | | 'P', 'A', 'T', 'C', 'H' -> `PATCH 131 | | 'T', 'R', 'A', 'C', 'E' -> `TRACE 132 | | _ -> raise_notrace invalid_method) 133 | | 6 -> 134 | (match 135 | source.![0], source.![1], source.![2], source.![3], source.![4], source.![5] 136 | with 137 | | 'D', 'E', 'L', 'E', 'T', 'E' -> `DELETE 138 | | _ -> raise_notrace invalid_method) 139 | | 7 -> 140 | (match 141 | ( source.![0] 142 | , source.![1] 143 | , source.![2] 144 | , source.![3] 145 | , source.![4] 146 | , source.![5] 147 | , source.![6] ) 148 | with 149 | | 'C', 'O', 'N', 'N', 'E', 'C', 'T' -> `CONNECT 150 | | 'O', 'P', 'T', 'I', 'O', 'N', 'S' -> `OPTIONS 151 | | _ -> raise_notrace invalid_method) 152 | | _ -> raise_notrace invalid_method 153 | in 154 | Source.unsafe_advance source (pos + 1); 155 | meth 156 | ;; 157 | 158 | let rec headers source = 159 | if (not (Source.is_empty source)) && Char.(Source.unsafe_get source 0 = '\r') 160 | then ( 161 | Source.consume_eol source; 162 | []) 163 | else ( 164 | let header = Source.parse_header tchar_map source in 165 | Source.consume_eol source; 166 | header :: headers source) 167 | ;; 168 | 169 | let chunk_length source = 170 | let length = ref 0 in 171 | let stop = ref false in 172 | let state = ref `Ok in 173 | let count = ref 0 in 174 | let processing_chunk = ref true in 175 | let in_chunk_extension = ref false in 176 | while not !stop do 177 | if Source.is_empty source 178 | then ( 179 | stop := true; 180 | state := `Partial) 181 | else if !count = 16 && not !in_chunk_extension 182 | then ( 183 | stop := true; 184 | state := `Chunk_too_big) 185 | else ( 186 | let ch = Source.unsafe_get source 0 in 187 | Source.unsafe_advance source 1; 188 | incr count; 189 | match ch with 190 | | '0' .. '9' as ch when !processing_chunk -> 191 | let curr = Char.to_int ch - Char.to_int '0' in 192 | length := (!length lsl 4) lor curr 193 | | 'a' .. 'f' as ch when !processing_chunk -> 194 | let curr = Char.to_int ch - Char.to_int 'a' + 10 in 195 | length := (!length lsl 4) lor curr 196 | | 'A' .. 'F' as ch when !processing_chunk -> 197 | let curr = Char.to_int ch - Char.to_int 'A' + 10 in 198 | length := (!length lsl 4) lor curr 199 | | ';' when not !in_chunk_extension -> 200 | in_chunk_extension := true; 201 | processing_chunk := false 202 | | ('\t' | ' ') when !processing_chunk -> processing_chunk := false 203 | | ('\t' | ' ') when (not !in_chunk_extension) && not !processing_chunk -> () 204 | | '\r' -> 205 | if Source.is_empty source 206 | then ( 207 | stop := true; 208 | state := `Partial) 209 | else if Char.(Source.unsafe_get source 0 = '\n') 210 | then ( 211 | Source.unsafe_advance source 1; 212 | stop := true) 213 | else ( 214 | stop := true; 215 | state := `Expected_newline) 216 | | _ when !in_chunk_extension -> 217 | (* Chunk extensions aren't very common, see: 218 | https://tools.ietf.org/html/rfc7230#section-4.1.1 Chunk extensions aren't 219 | pre-defined, and they are specific to invidividual connections. In the future 220 | we might surface these to the user somehow, but for now we will ignore any 221 | extensions. TODO: Should there be any limit on the size of chunk extensions we 222 | parse? We might want to error if a request contains really large chunk 223 | extensions. *) 224 | () 225 | | ch -> 226 | stop := true; 227 | state := `Invalid_char ch) 228 | done; 229 | match !state with 230 | | `Ok -> !length 231 | | `Partial -> raise_notrace Partial 232 | | `Expected_newline -> raise_notrace (Fail (Error.of_string "Expected_newline")) 233 | | `Chunk_too_big -> raise_notrace (Fail (Error.of_string "Chunk size is too large")) 234 | | `Invalid_char ch -> 235 | raise_notrace (Fail (Error.create "Invalid chunk_length character" ch sexp_of_char)) 236 | ;; 237 | 238 | let version source = 239 | if Source.length source < 8 then raise_notrace Partial; 240 | if Char.equal source.![0] 'H' 241 | && Char.equal source.![1] 'T' 242 | && Char.equal source.![2] 'T' 243 | && Char.equal source.![3] 'P' 244 | && Char.equal source.![4] '/' 245 | && Char.equal source.![5] '1' 246 | && Char.equal source.![6] '.' 247 | && Char.equal source.![7] '1' 248 | then ( 249 | Source.unsafe_advance source 8; 250 | Source.consume_eol source; 251 | Version.Http_1_1) 252 | else raise_notrace (Fail (Error.of_string "Invalid HTTP Version")) 253 | ;; 254 | 255 | let token source = 256 | let pos = Source.index source ' ' in 257 | if pos = -1 then raise_notrace Partial; 258 | let res = Source.to_string source ~pos:0 ~len:pos in 259 | Source.unsafe_advance source (pos + 1); 260 | res 261 | ;; 262 | 263 | let request source = 264 | let meth = meth source in 265 | let path = token source in 266 | let version = version source in 267 | let headers = Headers.of_rev_list (headers source) in 268 | Request.create ~version ~headers meth path 269 | ;; 270 | 271 | let take len source = 272 | let available = Source.length source in 273 | let to_consume = min len available in 274 | if to_consume = 0 then raise_notrace Partial; 275 | let payload = Source.to_iovec source ~pos:0 ~len:to_consume in 276 | Source.unsafe_advance source to_consume; 277 | payload 278 | ;; 279 | 280 | type chunk_kind = 281 | | Start_chunk 282 | | Continue_chunk of int 283 | 284 | type chunk_parser_result = 285 | | Chunk_complete of Bigstring.t Core_unix.IOVec.t 286 | | Done 287 | | Partial_chunk of Bigstring.t Core_unix.IOVec.t * int 288 | 289 | let chunk chunk_kind source = 290 | match chunk_kind with 291 | | Start_chunk -> 292 | let chunk_length = chunk_length source in 293 | if chunk_length = 0 294 | then ( 295 | Source.consume_eol source; 296 | Done) 297 | else ( 298 | let current_chunk = take chunk_length source in 299 | let current_chunk_length = current_chunk.len in 300 | if current_chunk_length = chunk_length 301 | then ( 302 | Source.consume_eol source; 303 | Chunk_complete current_chunk) 304 | else Partial_chunk (current_chunk, chunk_length - current_chunk_length)) 305 | | Continue_chunk len -> 306 | let chunk = take len source in 307 | let current_chunk_length = chunk.len in 308 | if current_chunk_length = len 309 | then ( 310 | Source.consume_eol source; 311 | Chunk_complete chunk) 312 | else Partial_chunk (chunk, len - current_chunk_length) 313 | ;; 314 | 315 | type error = 316 | | Partial 317 | | Fail of Error.t 318 | 319 | let run_parser ?(pos = 0) ?len buf p = 320 | let total_length = Bigstring.length buf in 321 | let len = 322 | match len with 323 | | Some v -> v 324 | | None -> total_length - pos 325 | in 326 | Ordered_collection_common.check_pos_len_exn ~pos ~len ~total_length; 327 | let source = Source.{ buffer = buf; pos; upper_bound = pos + len } in 328 | match p source with 329 | | exception Partial -> Error Partial 330 | | exception Fail m -> Error (Fail m) 331 | | v -> 332 | let consumed = source.pos - pos in 333 | Ok (v, consumed) 334 | ;; 335 | 336 | let parse_request ?pos ?len buf = run_parser ?pos ?len buf request 337 | let parse_chunk_length ?pos ?len buf = run_parser ?pos ?len buf chunk_length 338 | let parse_chunk ?pos ?len buf chunk_kind = run_parser ?pos ?len buf (chunk chunk_kind) 339 | 340 | module Private = struct 341 | let parse_method payload = run_parser (Bigstring.of_string payload) meth 342 | end 343 | -------------------------------------------------------------------------------- /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 Bigstring.t Core_unix.IOVec.t 13 | | Done 14 | | Partial_chunk of Bigstring.t Core_unix.IOVec.t * 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_chunk_length : ?pos:int -> ?len:int -> Bigstring.t -> (int * int, error) result 22 | 23 | val parse_chunk 24 | : ?pos:int 25 | -> ?len:int 26 | -> Bigstring.t 27 | -> chunk_kind 28 | -> (chunk_parser_result * int, error) result 29 | 30 | module Private : sig 31 | val parse_method : string -> (Meth.t * int, error) result 32 | end 33 | -------------------------------------------------------------------------------- /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 | } 9 | [@@deriving sexp] 10 | 11 | let create ?(version = Version.Http_1_1) ?(headers = Headers.empty) meth path = 12 | { meth; path; version; headers } 13 | ;; 14 | 15 | let meth t = t.meth 16 | let path t = t.path 17 | let version t = t.version 18 | let headers t = t.headers 19 | -------------------------------------------------------------------------------- /src/request.mli: -------------------------------------------------------------------------------- 1 | type t [@@deriving sexp] 2 | 3 | val create : ?version:Version.t -> ?headers:Headers.t -> Meth.t -> string -> t 4 | val meth : t -> Meth.t 5 | val path : t -> string 6 | val version : t -> Version.t 7 | val headers : t -> Headers.t 8 | -------------------------------------------------------------------------------- /src/response.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type t = 4 | { version : Version.t 5 | ; status : Status.t 6 | ; reason_phrase : string 7 | ; headers : Headers.t 8 | } 9 | [@@deriving sexp] 10 | 11 | let create ?(version = Version.Http_1_1) ?reason_phrase ?(headers = Headers.empty) status = 12 | let reason_phrase = Option.value reason_phrase ~default:(Status.to_string status) in 13 | { version; status; reason_phrase; headers } 14 | ;; 15 | 16 | let version t = t.version 17 | let status t = t.status 18 | let reason_phrase t = t.reason_phrase 19 | let headers t = t.headers 20 | -------------------------------------------------------------------------------- /src/response.mli: -------------------------------------------------------------------------------- 1 | type t [@@deriving sexp] 2 | 3 | val create 4 | : ?version:Version.t 5 | -> ?reason_phrase:string 6 | -> ?headers:Headers.t 7 | -> Status.t 8 | -> t 9 | 10 | val version : t -> Version.t 11 | val status : t -> Status.t 12 | val reason_phrase : t -> string 13 | val headers : t -> Headers.t 14 | -------------------------------------------------------------------------------- /src/server.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open! Shuttle 4 | 5 | type error_handler = 6 | ?exn:Exn.t -> ?request:Request.t -> Status.t -> (Response.t * Body.Writer.t) Deferred.t 7 | 8 | let keep_alive headers = 9 | match Headers.find headers "connection" with 10 | | Some x when String.Caseless.equal x "close" -> false 11 | | _ -> true 12 | ;; 13 | 14 | let write_response writer encoding res = 15 | Output_channel.write writer (Version.to_string (Response.version res)); 16 | Output_channel.write_char writer ' '; 17 | Output_channel.write writer (Status.to_string (Response.status res)); 18 | Output_channel.write_char writer ' '; 19 | Output_channel.write writer "\r\n"; 20 | let headers = Response.headers res in 21 | let headers = 22 | match encoding with 23 | | `Fixed len -> 24 | Headers.add_unless_exists headers ~key:"Content-Length" ~data:(Int.to_string len) 25 | | `Chunked -> 26 | Headers.add_unless_exists headers ~key:"Transfer-Encoding" ~data:"chunked" 27 | in 28 | Headers.iter 29 | ~f:(fun ~key ~data -> 30 | Output_channel.write writer key; 31 | Output_channel.write writer ": "; 32 | Output_channel.write writer data; 33 | Output_channel.write writer "\r\n") 34 | headers; 35 | Output_channel.write writer "\r\n" 36 | ;; 37 | 38 | let default_error_handler ?exn:_ ?request:_ status = 39 | let response = 40 | Response.create 41 | ~headers:(Headers.of_rev_list [ "Connection", "close"; "Content-Length", "0" ]) 42 | status 43 | in 44 | return (response, Body.Writer.empty) 45 | ;; 46 | 47 | let run_server_loop ?(error_handler = default_error_handler) handle_request reader writer = 48 | let monitor = Monitor.create () in 49 | let finished = Ivar.create () in 50 | let rec loop reader writer handle_request = 51 | let view = Input_channel.view reader in 52 | match Parser.parse_request view.buf ~pos:view.pos ~len:view.len with 53 | | Error Partial -> 54 | Input_channel.refill reader 55 | >>> (function 56 | | `Ok -> loop reader writer handle_request 57 | | `Eof -> Ivar.fill finished ()) 58 | | Error (Fail error) -> 59 | error_handler ~exn:(Error.to_exn error) `Bad_request 60 | >>> fun (res, res_body) -> 61 | write_response writer (Body.Writer.encoding res_body) res; 62 | Body.Writer.Private.write res_body writer >>> fun () -> Ivar.fill finished () 63 | | Ok (req, consumed) -> 64 | Input_channel.consume reader consumed; 65 | (match Body.Reader.Private.create req reader with 66 | | Error error -> 67 | error_handler ~exn:(Error.to_exn error) ~request:req `Bad_request 68 | >>> fun (res, res_body) -> 69 | write_response writer (Body.Writer.encoding res_body) res; 70 | Body.Writer.Private.write res_body writer >>> fun () -> Ivar.fill finished () 71 | | Ok req_body -> 72 | handle_request (req, req_body) 73 | >>> fun (res, res_body) -> 74 | let keep_alive = 75 | keep_alive (Request.headers req) && keep_alive (Response.headers res) 76 | in 77 | write_response writer (Body.Writer.encoding res_body) res; 78 | Body.Writer.Private.write res_body writer 79 | >>> fun () -> 80 | (match req_body with 81 | | Body.Reader.Empty -> 82 | if keep_alive 83 | then loop reader writer handle_request 84 | else Ivar.fill finished () 85 | | Stream { reader = body; _ } -> 86 | Pipe.drain body 87 | >>> fun () -> 88 | if keep_alive 89 | then loop reader writer handle_request 90 | else Ivar.fill finished ())) 91 | in 92 | (Monitor.detach_and_get_next_error monitor 93 | >>> fun exn -> 94 | error_handler ~exn `Internal_server_error 95 | >>> fun (res, res_body) -> 96 | write_response writer (Body.Writer.encoding res_body) res; 97 | Body.Writer.Private.write res_body writer >>> fun () -> Ivar.fill finished ()); 98 | Scheduler.within ~priority:Priority.Normal ~monitor (fun () -> 99 | loop reader writer handle_request); 100 | Ivar.read finished 101 | ;; 102 | 103 | let run 104 | ?max_connections 105 | ?(max_accepts_per_batch = 64) 106 | ?backlog 107 | ?socket 108 | ?(buffer_config = Buffer_config.create ()) 109 | ?(error_handler = fun _ -> default_error_handler) 110 | ~where_to_listen 111 | service 112 | = 113 | Shuttle.Connection.listen 114 | ~input_buffer_size:(Buffer_config.initial_size buffer_config) 115 | ~max_input_buffer_size:(Buffer_config.max_buffer_size buffer_config) 116 | ~output_buffer_size:(Buffer_config.initial_size buffer_config) 117 | ~max_output_buffer_size:(Buffer_config.max_buffer_size buffer_config) 118 | ?max_connections 119 | ?backlog 120 | ?socket 121 | ~max_accepts_per_batch 122 | where_to_listen 123 | ~on_handler_error:`Raise 124 | ~f:(fun addr reader writer -> 125 | let service = service addr in 126 | let error_handler = error_handler addr in 127 | run_server_loop ~error_handler service reader writer) 128 | ;; 129 | 130 | let run_command 131 | ?(interrupt = Deferred.never ()) 132 | ?readme 133 | ?(error_handler = fun _ -> default_error_handler) 134 | ~summary 135 | service 136 | = 137 | Command.async 138 | ~summary 139 | ?readme 140 | Command.Let_syntax.( 141 | let%map_open port = 142 | flag "-port" ~doc:"int Source port to listen on" (optional_with_default 8080 int) 143 | and max_connections = 144 | flag 145 | "-max-connections" 146 | ~doc:"int Maximum number of active connections" 147 | (optional int) 148 | and max_accepts_per_batch = 149 | flag 150 | "-max-accepts-per-batch" 151 | ~doc:"int Maximum number of connections to accept per Unix.accept call." 152 | (optional_with_default 64 int) 153 | and backlog = 154 | flag 155 | "-backlog" 156 | ~doc:"int Number of clients that can have a pending connection." 157 | (optional int) 158 | and initial_buffer_size = 159 | flag 160 | "-initial-buffer-size" 161 | ~doc:"int Initial size of the Read and Write buffers used by the server." 162 | (optional int) 163 | and max_buffer_size = 164 | flag 165 | "-max-buffer-size" 166 | ~doc:"int Maximum size of the Read and Write buffers used by the server." 167 | (optional int) 168 | in 169 | fun () -> 170 | let%bind.Deferred server = 171 | run 172 | ~error_handler 173 | ~where_to_listen:(Tcp.Where_to_listen.of_port port) 174 | ~max_accepts_per_batch 175 | ?max_connections 176 | ?backlog 177 | ~buffer_config: 178 | (Buffer_config.create ?initial_size:initial_buffer_size ?max_buffer_size ()) 179 | service 180 | in 181 | choose 182 | [ choice interrupt (fun () -> `Shutdown) 183 | ; choice (Tcp.Server.close_finished_and_handlers_determined server) (fun () -> 184 | `Closed) 185 | ] 186 | >>= function 187 | | `Shutdown -> Tcp.Server.close ~close_existing_connections:true server 188 | | `Closed -> Deferred.unit) 189 | ;; 190 | -------------------------------------------------------------------------------- /src/status.ml: -------------------------------------------------------------------------------- 1 | (* https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml *) 2 | type informational = 3 | [ `Continue (* [RFC7231, Section 6.2.1] *) 4 | | `Switching_protocols (* [RFC7231, Section 6.2.2] *) 5 | | `Processing (* [RFC2518] *) 6 | | `Early_hints (* [RFC8297] *) 7 | ] 8 | [@@deriving sexp, compare, hash] 9 | 10 | let informational_to_code = function 11 | | `Continue -> 100 12 | | `Switching_protocols -> 101 13 | | `Processing -> 102 14 | | `Early_hints -> 103 15 | ;; 16 | 17 | let informational_to_string = function 18 | | `Continue -> "100" 19 | | `Switching_protocols -> "101" 20 | | `Processing -> "102" 21 | | `Early_hints -> "103" 22 | ;; 23 | 24 | let informational_to_reason_phrase = function 25 | | `Continue -> "Continue" 26 | | `Switching_protocols -> "Switching Protocols" 27 | | `Processing -> "Processing" 28 | | `Early_hints -> "Early Hints" 29 | ;; 30 | 31 | type success = 32 | [ `Ok (* [RFC7231, Section 6.3.1] *) 33 | | `Created (* [RFC7231, Section 6.3.2] *) 34 | | `Accepted (* [RFC7231, Section 6.3.3] *) 35 | | `Non_authoritative_information (* [RFC7231, Section 6.3.4] *) 36 | | `No_content (* [RFC7231, Section 6.3.5] *) 37 | | `Reset_content (* [RFC7231, Section 6.3.6] *) 38 | | `Partial_content (* [RFC7233, Section 4.1] *) 39 | | `Multi_status (* [RFC4918] *) 40 | | `Already_reported (* [RFC5842] *) 41 | | `Im_used (* [RFC3229] *) 42 | ] 43 | [@@deriving sexp, compare, hash] 44 | 45 | let success_to_code = function 46 | | `Ok -> 200 47 | | `Created -> 201 48 | | `Accepted -> 202 49 | | `Non_authoritative_information -> 203 50 | | `No_content -> 204 51 | | `Reset_content -> 205 52 | | `Partial_content -> 206 53 | | `Multi_status -> 207 54 | | `Already_reported -> 208 55 | | `Im_used -> 226 56 | ;; 57 | 58 | let success_to_string = function 59 | | `Ok -> "200" 60 | | `Created -> "201" 61 | | `Accepted -> "202" 62 | | `Non_authoritative_information -> "203" 63 | | `No_content -> "204" 64 | | `Reset_content -> "205" 65 | | `Partial_content -> "206" 66 | | `Multi_status -> "207" 67 | | `Already_reported -> "208" 68 | | `Im_used -> "226" 69 | ;; 70 | 71 | let success_to_reason_phrase = function 72 | | `Ok -> "OK" 73 | | `Created -> "Created" 74 | | `Accepted -> "Accepted" 75 | | `Non_authoritative_information -> "Non-Authoritative Information" 76 | | `No_content -> "No Content" 77 | | `Reset_content -> "Reset Content" 78 | | `Partial_content -> "Partial Content" 79 | | `Multi_status -> "Multi-Status" 80 | | `Already_reported -> "Already Reported" 81 | | `Im_used -> "IM Used" 82 | ;; 83 | 84 | type redirection = 85 | [ `Multiple_choices (* [RFC7231, Section 6.4.1] *) 86 | | `Moved_permanently (* [RFC7231, Section 6.4.2] *) 87 | | `Found (* [RFC7231, Section 6.4.3] *) 88 | | `See_other (* [RFC7231, Section 6.4.4] *) 89 | | `Not_modified (* [RFC7232, Section 4.1] *) 90 | | `Use_proxy (* [RFC7231, Section 6.4.5] *) 91 | | `Temporary_redirect (* [RFC7231, Section 6.4.7] *) 92 | | `Permanent_redirect (* [RFC7538] *) 93 | ] 94 | [@@deriving sexp, compare, hash] 95 | 96 | let redirection_to_code = function 97 | | `Multiple_choices -> 300 98 | | `Moved_permanently -> 301 99 | | `Found -> 302 100 | | `See_other -> 303 101 | | `Not_modified -> 304 102 | | `Use_proxy -> 305 103 | | `Temporary_redirect -> 307 104 | | `Permanent_redirect -> 308 105 | ;; 106 | 107 | let redirection_to_string = function 108 | | `Multiple_choices -> "300" 109 | | `Moved_permanently -> "301" 110 | | `Found -> "302" 111 | | `See_other -> "303" 112 | | `Not_modified -> "304" 113 | | `Use_proxy -> "305" 114 | | `Temporary_redirect -> "307" 115 | | `Permanent_redirect -> "308" 116 | ;; 117 | 118 | let redirection_to_reason_phrase = function 119 | | `Multiple_choices -> "Multiple Choices" 120 | | `Moved_permanently -> "Moved Permanently" 121 | | `Found -> "Found" 122 | | `See_other -> "See Other" 123 | | `Not_modified -> "Not Modified" 124 | | `Use_proxy -> "Use Proxy" 125 | | `Temporary_redirect -> "Temporary Redirect" 126 | | `Permanent_redirect -> "Permanent Redirect" 127 | ;; 128 | 129 | type client_error = 130 | [ `Bad_request (* [RFC7231, Section 6.5.1] *) 131 | | `Unauthorized (* [RFC7235, Section 3.1] *) 132 | | `Payment_required (* [RFC7231, Section 6.5.2] *) 133 | | `Forbidden (* [RFC7231, Section 6.5.3] *) 134 | | `Not_found (* [RFC7231, Section 6.5.4] *) 135 | | `Method_not_allowed (* [RFC7231, Section 6.5.5] *) 136 | | `Not_acceptable (* [RFC7231, Section 6.5.6] *) 137 | | `Proxy_authentication_required (* [RFC7235, Section 3.2] *) 138 | | `Request_timeout (* [RFC7231, Section 6.5.7] *) 139 | | `Conflict (* [RFC7231, Section 6.5.8] *) 140 | | `Gone (* [RFC7231, Section 6.5.9] *) 141 | | `Length_required (* [RFC7231, Section 6.5.10] *) 142 | | `Precondition_failed (* [RFC7232, Section 4.2][RFC8144, Section 3.2] *) 143 | | `Payload_too_large (* [RFC7231, Section 6.5.11] *) 144 | | `Uri_too_long (* [RFC7231, Section 6.5.12] *) 145 | | `Unsupported_media_type (* [RFC7231, Section 6.5.13][RFC7694, Section 3] *) 146 | | `Range_not_satisfiable (* [RFC7233, Section 4.4] *) 147 | | `Expectation_failed (* [RFC7231, Section 6.5.14] *) 148 | | `Misdirected_request (* [RFC7540, Section 9.1.2] *) 149 | | `Unprocessable_entity (* [RFC4918] *) 150 | | `Locked (* [RFC4918] *) 151 | | `Failed_dependency (* [RFC4918] *) 152 | | `Too_early (* [RFC8470] *) 153 | | `Upgrade_required (* [RFC7231, Section 6.5.15] *) 154 | | `Precondition_required (* [RFC6585] *) 155 | | `Too_many_requests (* [RFC6585] *) 156 | | `Request_header_fields_too_large (* [RFC6585] *) 157 | | `Unavailable_for_legal_reasons (* [RFC7725] *) 158 | ] 159 | [@@deriving sexp, compare, hash] 160 | 161 | let client_error_to_code = function 162 | | `Bad_request -> 400 163 | | `Unauthorized -> 401 164 | | `Payment_required -> 402 165 | | `Forbidden -> 403 166 | | `Not_found -> 404 167 | | `Method_not_allowed -> 405 168 | | `Not_acceptable -> 406 169 | | `Proxy_authentication_required -> 407 170 | | `Request_timeout -> 408 171 | | `Conflict -> 409 172 | | `Gone -> 410 173 | | `Length_required -> 411 174 | | `Precondition_failed -> 412 175 | | `Payload_too_large -> 413 176 | | `Uri_too_long -> 414 177 | | `Unsupported_media_type -> 415 178 | | `Range_not_satisfiable -> 416 179 | | `Expectation_failed -> 417 180 | | `Misdirected_request -> 421 181 | | `Unprocessable_entity -> 422 182 | | `Locked -> 423 183 | | `Failed_dependency -> 424 184 | | `Too_early -> 425 185 | | `Upgrade_required -> 426 186 | | `Precondition_required -> 428 187 | | `Too_many_requests -> 429 188 | | `Request_header_fields_too_large -> 431 189 | | `Unavailable_for_legal_reasons -> 451 190 | ;; 191 | 192 | let client_error_to_string = function 193 | | `Bad_request -> "400" 194 | | `Unauthorized -> "401" 195 | | `Payment_required -> "402" 196 | | `Forbidden -> "403" 197 | | `Not_found -> "404" 198 | | `Method_not_allowed -> "405" 199 | | `Not_acceptable -> "406" 200 | | `Proxy_authentication_required -> "407" 201 | | `Request_timeout -> "408" 202 | | `Conflict -> "409" 203 | | `Gone -> "410" 204 | | `Length_required -> "411" 205 | | `Precondition_failed -> "412" 206 | | `Payload_too_large -> "413" 207 | | `Uri_too_long -> "414" 208 | | `Unsupported_media_type -> "415" 209 | | `Range_not_satisfiable -> "416" 210 | | `Expectation_failed -> "417" 211 | | `Misdirected_request -> "421" 212 | | `Unprocessable_entity -> "422" 213 | | `Locked -> "423" 214 | | `Failed_dependency -> "424" 215 | | `Too_early -> "425" 216 | | `Upgrade_required -> "426" 217 | | `Precondition_required -> "428" 218 | | `Too_many_requests -> "429" 219 | | `Request_header_fields_too_large -> "431" 220 | | `Unavailable_for_legal_reasons -> "451" 221 | ;; 222 | 223 | let client_error_to_reason_phrase = function 224 | | `Bad_request -> "Bad Request" 225 | | `Unauthorized -> "Unauthorized" 226 | | `Payment_required -> "Payment Required" 227 | | `Forbidden -> "Forbidden" 228 | | `Not_found -> "Not Found" 229 | | `Method_not_allowed -> "Method Not Allowed" 230 | | `Not_acceptable -> "Not Acceptable" 231 | | `Proxy_authentication_required -> "Proxy Authentication Required" 232 | | `Request_timeout -> "Request Timeout" 233 | | `Conflict -> "Conflict" 234 | | `Gone -> "Gone" 235 | | `Length_required -> "Length Required" 236 | | `Precondition_failed -> "Precondition Failed" 237 | | `Payload_too_large -> "Payload Too Large" 238 | | `Uri_too_long -> "URI Too Long" 239 | | `Unsupported_media_type -> "Unsupported Media Type" 240 | | `Range_not_satisfiable -> "Range Not Satisfiable" 241 | | `Expectation_failed -> "Expectation Failed" 242 | | `Misdirected_request -> "Misdirected Request" 243 | | `Unprocessable_entity -> "Unprocessable Entity" 244 | | `Locked -> "Locked" 245 | | `Failed_dependency -> "Failed Dependency" 246 | | `Too_early -> "Too Early" 247 | | `Upgrade_required -> "Upgrade Required" 248 | | `Precondition_required -> "Precondition Required" 249 | | `Too_many_requests -> "Too Many Requests" 250 | | `Request_header_fields_too_large -> "Request Header Fields Too Large" 251 | | `Unavailable_for_legal_reasons -> "Unavailable For Legal Reasons" 252 | ;; 253 | 254 | type server_error = 255 | [ `Internal_server_error (* [RFC7231, Section 6.6.1] *) 256 | | `Not_implemented (* [RFC7231, Section 6.6.2] *) 257 | | `Bad_gateway (* [RFC7231, Section 6.6.3] *) 258 | | `Service_unavailable (* [RFC7231, Section 6.6.4] *) 259 | | `Gateway_timeout (* [RFC7231, Section 6.6.5] *) 260 | | `Http_version_not_supported (* [RFC7231, Section 6.6.6] *) 261 | | `Variant_also_negotiates (* [RFC2295] *) 262 | | `Insufficient_storage (* [RFC4918] *) 263 | | `Loop_detected (* [RFC5842] *) 264 | | `Not_extended (* [RFC2774] *) 265 | | `Network_authentication_required (* [RFC6585] *) 266 | ] 267 | [@@deriving sexp, compare, hash] 268 | 269 | let server_error_to_code = function 270 | | `Internal_server_error -> 500 271 | | `Not_implemented -> 501 272 | | `Bad_gateway -> 502 273 | | `Service_unavailable -> 503 274 | | `Gateway_timeout -> 504 275 | | `Http_version_not_supported -> 505 276 | | `Variant_also_negotiates -> 506 277 | | `Insufficient_storage -> 507 278 | | `Loop_detected -> 508 279 | | `Not_extended -> 510 280 | | `Network_authentication_required -> 511 281 | ;; 282 | 283 | let server_error_to_string = function 284 | | `Internal_server_error -> "500" 285 | | `Not_implemented -> "501" 286 | | `Bad_gateway -> "502" 287 | | `Service_unavailable -> "503" 288 | | `Gateway_timeout -> "504" 289 | | `Http_version_not_supported -> "505" 290 | | `Variant_also_negotiates -> "506" 291 | | `Insufficient_storage -> "507" 292 | | `Loop_detected -> "508" 293 | | `Not_extended -> "510" 294 | | `Network_authentication_required -> "511" 295 | ;; 296 | 297 | let server_error_to_reason_phrase = function 298 | | `Internal_server_error -> "Internal Server Error" 299 | | `Not_implemented -> "Not Implemented" 300 | | `Bad_gateway -> "Bad Gateway" 301 | | `Service_unavailable -> "Service Unavailable" 302 | | `Gateway_timeout -> "Gateway Timeout" 303 | | `Http_version_not_supported -> "HTTP Version Not Supported" 304 | | `Variant_also_negotiates -> "Variant Also Negotiates" 305 | | `Insufficient_storage -> "Insufficient Storage" 306 | | `Loop_detected -> "Loop Detected" 307 | | `Not_extended -> "Not Extended" 308 | | `Network_authentication_required -> "Network Authentication Required" 309 | ;; 310 | 311 | type t = 312 | [ informational 313 | | success 314 | | redirection 315 | | client_error 316 | | server_error 317 | ] 318 | [@@deriving sexp, compare, hash] 319 | 320 | let to_int = function 321 | | #informational as c -> informational_to_code c 322 | | #success as c -> success_to_code c 323 | | #redirection as c -> redirection_to_code c 324 | | #client_error as c -> client_error_to_code c 325 | | #server_error as c -> server_error_to_code c 326 | ;; 327 | 328 | let to_string = function 329 | | #informational as c -> informational_to_string c 330 | | #success as c -> success_to_string c 331 | | #redirection as c -> redirection_to_string c 332 | | #client_error as c -> client_error_to_string c 333 | | #server_error as c -> server_error_to_string c 334 | ;; 335 | 336 | let to_reason_phrase = function 337 | | #informational as c -> informational_to_reason_phrase c 338 | | #success as c -> success_to_reason_phrase c 339 | | #redirection as c -> redirection_to_reason_phrase c 340 | | #client_error as c -> client_error_to_reason_phrase c 341 | | #server_error as c -> server_error_to_reason_phrase c 342 | ;; 343 | -------------------------------------------------------------------------------- /src/status.mli: -------------------------------------------------------------------------------- 1 | (* https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml *) 2 | type informational = 3 | [ `Continue (* [RFC7231, Section 6.2.1] *) 4 | | `Switching_protocols (* [RFC7231, Section 6.2.2] *) 5 | | `Processing (* [RFC2518] *) 6 | | `Early_hints (* [RFC8297] *) 7 | ] 8 | [@@deriving sexp, compare, hash] 9 | 10 | type success = 11 | [ `Ok (* [RFC7231, Section 6.3.1] *) 12 | | `Created (* [RFC7231, Section 6.3.2] *) 13 | | `Accepted (* [RFC7231, Section 6.3.3] *) 14 | | `Non_authoritative_information (* [RFC7231, Section 6.3.4] *) 15 | | `No_content (* [RFC7231, Section 6.3.5] *) 16 | | `Reset_content (* [RFC7231, Section 6.3.6] *) 17 | | `Partial_content (* [RFC7233, Section 4.1] *) 18 | | `Multi_status (* [RFC4918] *) 19 | | `Already_reported (* [RFC5842] *) 20 | | `Im_used (* [RFC3229] *) 21 | ] 22 | [@@deriving sexp, compare, hash] 23 | 24 | type redirection = 25 | [ `Multiple_choices (* [RFC7231, Section 6.4.1] *) 26 | | `Moved_permanently (* [RFC7231, Section 6.4.2] *) 27 | | `Found (* [RFC7231, Section 6.4.3] *) 28 | | `See_other (* [RFC7231, Section 6.4.4] *) 29 | | `Not_modified (* [RFC7232, Section 4.1] *) 30 | | `Use_proxy (* [RFC7231, Section 6.4.5] *) 31 | | `Temporary_redirect (* [RFC7231, Section 6.4.7] *) 32 | | `Permanent_redirect (* [RFC7538] *) 33 | ] 34 | [@@deriving sexp, compare, hash] 35 | 36 | type client_error = 37 | [ `Bad_request (* [RFC7231, Section 6.5.1] *) 38 | | `Unauthorized (* [RFC7235, Section 3.1] *) 39 | | `Payment_required (* [RFC7231, Section 6.5.2] *) 40 | | `Forbidden (* [RFC7231, Section 6.5.3] *) 41 | | `Not_found (* [RFC7231, Section 6.5.4] *) 42 | | `Method_not_allowed (* [RFC7231, Section 6.5.5] *) 43 | | `Not_acceptable (* [RFC7231, Section 6.5.6] *) 44 | | `Proxy_authentication_required (* [RFC7235, Section 3.2] *) 45 | | `Request_timeout (* [RFC7231, Section 6.5.7] *) 46 | | `Conflict (* [RFC7231, Section 6.5.8] *) 47 | | `Gone (* [RFC7231, Section 6.5.9] *) 48 | | `Length_required (* [RFC7231, Section 6.5.10] *) 49 | | `Precondition_failed (* [RFC7232, Section 4.2][RFC8144, Section 3.2] *) 50 | | `Payload_too_large (* [RFC7231, Section 6.5.11] *) 51 | | `Uri_too_long (* [RFC7231, Section 6.5.12] *) 52 | | `Unsupported_media_type (* [RFC7231, Section 6.5.13][RFC7694, Section 3] *) 53 | | `Range_not_satisfiable (* [RFC7233, Section 4.4] *) 54 | | `Expectation_failed (* [RFC7231, Section 6.5.14] *) 55 | | `Misdirected_request (* [RFC7540, Section 9.1.2] *) 56 | | `Unprocessable_entity (* [RFC4918] *) 57 | | `Locked (* [RFC4918] *) 58 | | `Failed_dependency (* [RFC4918] *) 59 | | `Too_early (* [RFC8470] *) 60 | | `Upgrade_required (* [RFC7231, Section 6.5.15] *) 61 | | `Precondition_required (* [RFC6585] *) 62 | | `Too_many_requests (* [RFC6585] *) 63 | | `Request_header_fields_too_large (* [RFC6585] *) 64 | | `Unavailable_for_legal_reasons (* [RFC7725] *) 65 | ] 66 | [@@deriving sexp, compare, hash] 67 | 68 | type server_error = 69 | [ `Internal_server_error (* [RFC7231, Section 6.6.1] *) 70 | | `Not_implemented (* [RFC7231, Section 6.6.2] *) 71 | | `Bad_gateway (* [RFC7231, Section 6.6.3] *) 72 | | `Service_unavailable (* [RFC7231, Section 6.6.4] *) 73 | | `Gateway_timeout (* [RFC7231, Section 6.6.5] *) 74 | | `Http_version_not_supported (* [RFC7231, Section 6.6.6] *) 75 | | `Variant_also_negotiates (* [RFC2295] *) 76 | | `Insufficient_storage (* [RFC4918] *) 77 | | `Loop_detected (* [RFC5842] *) 78 | | `Not_extended (* [RFC2774] *) 79 | | `Network_authentication_required (* [RFC6585] *) 80 | ] 81 | [@@deriving sexp, compare, hash] 82 | 83 | type t = 84 | [ informational 85 | | success 86 | | redirection 87 | | client_error 88 | | server_error 89 | ] 90 | [@@deriving sexp, compare, hash] 91 | 92 | val to_int : t -> int 93 | val to_string : t -> string 94 | val to_reason_phrase : t -> string 95 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /src/version.mli: -------------------------------------------------------------------------------- 1 | type t = Http_1_1 [@@deriving sexp] 2 | 3 | val to_string : t -> string 4 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_async_http) 3 | (inline_tests) 4 | (preprocess 5 | (pps ppx_jane)) 6 | (libraries http_async core async shuttle)) 7 | -------------------------------------------------------------------------------- /test/test_http_server.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open! Shuttle 4 | open Http_async 5 | 6 | let default_service _ = return (Response.create `Ok, Body.Writer.string "Hello World") 7 | 8 | let pipe () = 9 | Unix.pipe (Info.of_string "test shuttle http") 10 | >>| fun (`Reader reader, `Writer writer) -> 11 | let a = Input_channel.create reader in 12 | let b = Output_channel.create writer in 13 | a, b 14 | ;; 15 | 16 | let test_post_req_with_fixed_body = 17 | "POST /hello HTTP/1.1\r\nHost: www.example.com \r\nContent-Length: 5\r\n\r\nHello\r\n" 18 | ;; 19 | 20 | let test_post_req_with_invalid_body_length = 21 | "POST /hello HTTP/1.1\r\n\ 22 | Host: www.example.com \r\n\ 23 | Content-Length: 5\r\n\ 24 | Content-Length: 6\r\n\ 25 | \r\n\ 26 | Hello\r\n" 27 | ;; 28 | 29 | let%expect_test "test simple server" = 30 | let stdout = Lazy.force Writer.stdout in 31 | let handler (request, body) = 32 | let%bind () = 33 | Pipe.iter_without_pushback (Body.Reader.pipe body) ~f:(fun v -> 34 | Writer.write_line stdout (Bigstring.to_string v.buf ~pos:v.pos ~len:v.len)) 35 | in 36 | Writer.write_sexp 37 | ~hum:true 38 | stdout 39 | [%sexp { request : Request.t; body : Body.Reader.t }]; 40 | return 41 | ( Response.create 42 | ~headers:(Headers.of_rev_list [ "content-length", "5"; "connection", "close" ]) 43 | `Ok 44 | , Body.Writer.string "World" ) 45 | in 46 | let%bind reader, write_to_reader = pipe () in 47 | let%bind read_from_writer, writer = pipe () in 48 | let reader_pipe = Input_channel.pipe read_from_writer in 49 | let finished = Ivar.create () in 50 | (Server.run_server_loop handler reader writer >>> fun () -> Ivar.fill finished ()); 51 | Output_channel.write write_to_reader test_post_req_with_fixed_body; 52 | Output_channel.schedule_flush write_to_reader; 53 | let%bind () = Ivar.read finished in 54 | [%expect 55 | {| 56 | Hello 57 | ((request 58 | ((meth POST) (path /hello) (version Http_1_1) 59 | (headers ((Host www.example.com) (Content-Length 5))))) 60 | (body (Stream (encoding (Fixed 5)) (reader )))) |}]; 61 | let%bind () = Output_channel.close writer in 62 | let%map () = 63 | Pipe.iter_without_pushback reader_pipe ~f:(fun v -> Writer.writef stdout "%S" v) 64 | in 65 | [%expect {| "HTTP/1.1 200 \r\ncontent-length: 5\r\nconnection: close\r\n\r\nWorld" |}] 66 | ;; 67 | 68 | let%expect_test "test_default_error_handler" = 69 | let stdout = Lazy.force Writer.stdout in 70 | let service _request = failwith "ERROR" in 71 | let%bind reader, write_to_reader = pipe () in 72 | let%bind read_from_writer, writer = pipe () in 73 | let reader_pipe = Input_channel.pipe read_from_writer in 74 | let finished = Ivar.create () in 75 | (Server.run_server_loop service reader writer >>> fun () -> Ivar.fill finished ()); 76 | Output_channel.write write_to_reader test_post_req_with_fixed_body; 77 | Output_channel.schedule_flush write_to_reader; 78 | let%bind () = Ivar.read finished in 79 | let%bind () = Output_channel.close writer in 80 | let%map () = 81 | Pipe.iter_without_pushback reader_pipe ~f:(fun chunk -> 82 | Writer.writef stdout "%S" chunk) 83 | in 84 | [%expect {| "HTTP/1.1 500 \r\nConnection: close\r\nContent-Length: 0\r\n\r\n" |}] 85 | ;; 86 | 87 | let%expect_test "test_custom_error_handler" = 88 | let error_handler ?exn:_ ?request status = 89 | let body = 90 | match request with 91 | | None -> "Something bad happened" 92 | | Some request -> 93 | sprintf "Something bad happened in request: %s" (Request.path request) 94 | in 95 | return (Response.create status, Body.Writer.string body) 96 | in 97 | let stdout = Lazy.force Writer.stdout in 98 | let service _request = failwith "ERROR" in 99 | let%bind reader, write_to_reader = pipe () in 100 | let%bind read_from_writer, writer = pipe () in 101 | let reader_pipe = Input_channel.pipe read_from_writer in 102 | let finished = Ivar.create () in 103 | (Server.run_server_loop ~error_handler service reader writer 104 | >>> fun () -> Ivar.fill finished ()); 105 | Output_channel.write write_to_reader test_post_req_with_invalid_body_length; 106 | Output_channel.schedule_flush write_to_reader; 107 | let%bind () = Ivar.read finished in 108 | let%bind () = Output_channel.close writer in 109 | let%map () = 110 | Pipe.iter_without_pushback reader_pipe ~f:(fun chunk -> 111 | Writer.writef stdout "%S" chunk) 112 | in 113 | [%expect 114 | {| "HTTP/1.1 400 \r\nContent-Length: 41\r\n\r\nSomething bad happened in request: /hello" |}] 115 | ;; 116 | 117 | let%expect_test "catches bad request payload" = 118 | let error_handler ?exn:_ ?request status = 119 | let body = 120 | match request with 121 | | None -> "Something bad happened" 122 | | Some request -> 123 | sprintf "Something bad happened in request: %s" (Request.path request) 124 | in 125 | return (Response.create status, Body.Writer.string body) 126 | in 127 | let stdout = Lazy.force Writer.stdout in 128 | let service _request = failwith "ERROR" in 129 | let%bind reader, write_to_reader = pipe () in 130 | let%bind read_from_writer, writer = pipe () in 131 | let reader_pipe = Input_channel.pipe read_from_writer in 132 | let finished = Ivar.create () in 133 | (Server.run_server_loop ~error_handler service reader writer 134 | >>> fun () -> Ivar.fill finished ()); 135 | Output_channel.write write_to_reader test_post_req_with_fixed_body; 136 | Output_channel.schedule_flush write_to_reader; 137 | let%bind () = Ivar.read finished in 138 | let%bind () = Output_channel.close writer in 139 | let%map () = 140 | Pipe.iter_without_pushback reader_pipe ~f:(fun chunk -> 141 | Writer.writef stdout "%S" chunk) 142 | in 143 | [%expect {| "HTTP/1.1 500 \r\nContent-Length: 22\r\n\r\nSomething bad happened" |}] 144 | ;; 145 | 146 | let test_post_req_with_chunked_body = 147 | "POST /hello HTTP/1.1\r\n\ 148 | Host: www.example.com\r\n\ 149 | Transfer-Encoding: chunked\r\n\ 150 | \r\n\ 151 | 5\r\n\ 152 | Hello\r\n\ 153 | 0\r\n\ 154 | \r\n" 155 | ;; 156 | 157 | let%expect_test "streaming bodies" = 158 | let stdout = Lazy.force Writer.stdout in 159 | let service (_request, body) = 160 | return (Response.create `Ok, Body.Writer.stream (Body.Reader.pipe body)) 161 | in 162 | let%bind reader, write_to_reader = pipe () in 163 | let%bind read_from_writer, writer = pipe () in 164 | let reader_pipe = Input_channel.pipe read_from_writer in 165 | let finished = Ivar.create () in 166 | (Server.run_server_loop service reader writer >>> fun () -> Ivar.fill finished ()); 167 | Output_channel.write write_to_reader test_post_req_with_chunked_body; 168 | Output_channel.schedule_flush write_to_reader; 169 | let%bind () = Output_channel.close write_to_reader in 170 | let%bind () = Ivar.read finished in 171 | let%bind () = Output_channel.close writer in 172 | let%map () = 173 | Pipe.iter_without_pushback reader_pipe ~f:(fun chunk -> 174 | Writer.writef stdout "%S" chunk) 175 | in 176 | [%expect 177 | {| "HTTP/1.1 200 \r\nTransfer-Encoding: chunked\r\n\r\n5\r\nHello\r\n0\r\n\r\n" |}] 178 | ;; 179 | 180 | let%expect_test "bad transfer encoding header" = 181 | let stdout = Lazy.force Writer.stdout in 182 | let%bind reader, write_to_reader = pipe () in 183 | let%bind read_from_writer, writer = pipe () in 184 | let reader_pipe = Input_channel.pipe read_from_writer in 185 | let finished = Ivar.create () in 186 | (Server.run_server_loop default_service reader writer 187 | >>> fun () -> Ivar.fill finished ()); 188 | Output_channel.write 189 | write_to_reader 190 | "POST /hello HTTP/1.1\r\n\ 191 | Host: www.example.com \r\n\ 192 | Transfer-Encoding: foobar\r\n\ 193 | \r\n\ 194 | Hello\r\n"; 195 | Output_channel.schedule_flush write_to_reader; 196 | let%bind () = Ivar.read finished in 197 | let%bind () = Output_channel.close writer in 198 | let%map () = 199 | Pipe.iter_without_pushback reader_pipe ~f:(fun chunk -> 200 | Writer.writef stdout "%S" chunk) 201 | in 202 | [%expect {| "HTTP/1.1 400 \r\nConnection: close\r\nContent-Length: 0\r\n\r\n" |}] 203 | ;; 204 | -------------------------------------------------------------------------------- /test/test_method.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Http_async 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 -> Option.value_exn (Meth.of_string v)) 10 | in 11 | [%test_result: Meth.t list] ~expect:a b 12 | ;; 13 | -------------------------------------------------------------------------------- /test/test_parser.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Http_async 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 | let req = Bigstring.of_string req 22 | 23 | module P = Private.Parser 24 | 25 | type 'a success = 26 | { consumed : int 27 | ; value : 'a 28 | } 29 | [@@deriving sexp_of, compare] 30 | 31 | let parse_or_error res = 32 | match res with 33 | | Ok (value, consumed) -> Ok { value; consumed } 34 | | Error P.Partial -> Or_error.errorf "Partial" 35 | | Error (Fail error) -> Error (Error.tag error ~tag:"Parse error") 36 | ;; 37 | 38 | let%test_unit "Can parse HTTP methods" = 39 | let methods = Meth.all in 40 | let methods_string = List.map methods ~f:Meth.to_string in 41 | let result = 42 | List.map 43 | ~f:(fun m -> parse_or_error (Private.Parser.Private.parse_method (m ^ " "))) 44 | methods_string 45 | in 46 | [%test_result: Meth.t success Or_error.t list] 47 | result 48 | ~expect: 49 | (List.map methods ~f:(fun m -> 50 | Ok { value = m; consumed = String.length (Meth.to_string m) + 1 })) 51 | ;; 52 | 53 | let%expect_test "can parse single request" = 54 | print_s 55 | ([%sexp_of: Request.t success Or_error.t] (parse_or_error (P.parse_request req))); 56 | [%expect 57 | {| 58 | (Ok 59 | ((consumed 706) 60 | (value 61 | ((meth GET) 62 | (path /wp-content/uploads/2010/03/hello-kitty-darth-vader-pink.jpg) 63 | (version Http_1_1) 64 | (headers 65 | ((Host www.kittyhell.com) 66 | (User-Agent 67 | "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") 68 | (Accept 69 | "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8") 70 | (Accept-Language "ja,en-us;q=0.7,en;q=0.3") 71 | (Accept-Encoding gzip,deflate) 72 | (Accept-Charset "Shift_JIS,utf-8;q=0.7,*;q=0.7") (Keep-Alive 115) 73 | (Connection keep-alive) 74 | (Cookie 75 | "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"))))))) |}] 76 | ;; 77 | 78 | let%expect_test "reject headers with space before colon" = 79 | let req = 80 | Bigstring.of_string 81 | "GET / HTTP/1.1\r\nHost : www.kittyhell.com\r\nKeep-Alive: 115\r\n\r\n" 82 | in 83 | print_s 84 | ([%sexp_of: Request.t success Or_error.t] (parse_or_error (P.parse_request req))); 85 | [%expect {| (Error ("Parse error" "Invalid Header Key")) |}] 86 | ;; 87 | 88 | let more_requests = 89 | Bigstring.of_string 90 | "GET / HTTP/1.1\r\n\ 91 | Host: www.reddit.com\r\n\ 92 | User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) \r\n\ 93 | \ Gecko/20100101 Firefox/15.0.1\r\n\ 94 | Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\r\n\ 95 | Accept-Language: en-us,en;q=0.5\r\n\ 96 | Accept-Encoding: gzip, deflate\r\n\ 97 | Connection: keep-alive\r\n\ 98 | \r\n\ 99 | GET /reddit.v_EZwRzV-Ns.css HTTP/1.1\r\n\ 100 | Host: www.redditstatic.com\r\n\ 101 | User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 \ 102 | Firefox/15.0.1\r\n\ 103 | Accept: text/css,*/*;q=0.1\r\n\ 104 | Accept-Language: en-us,en;q=0.5\r\n\ 105 | Accept-Encoding: gzip, deflate\r\n\ 106 | Connection: keep-alive\r\n\ 107 | Referer: http://www.reddit.com/\r\n\ 108 | \r\n" 109 | ;; 110 | 111 | let%expect_test "can parse request at offset" = 112 | print_s 113 | ([%sexp_of: Request.t success Or_error.t] 114 | (parse_or_error (P.parse_request ~pos:304 more_requests))); 115 | [%expect 116 | {| 117 | (Ok 118 | ((consumed 315) 119 | (value 120 | ((meth GET) (path /reddit.v_EZwRzV-Ns.css) (version Http_1_1) 121 | (headers 122 | ((Host www.redditstatic.com) 123 | (User-Agent 124 | "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1") 125 | (Accept "text/css,*/*;q=0.1") (Accept-Language "en-us,en;q=0.5") 126 | (Accept-Encoding "gzip, deflate") (Connection keep-alive) 127 | (Referer http://www.reddit.com/))))))) |}] 128 | ;; 129 | 130 | let%expect_test "can report a partial parse" = 131 | print_s 132 | ([%sexp_of: Request.t success Or_error.t] 133 | (parse_or_error (P.parse_request ~len:50 req))); 134 | [%expect {| (Error Partial) |}] 135 | ;; 136 | 137 | let%expect_test "can validate http version" = 138 | let req = 139 | Bigstring.of_string 140 | "GET / HTTP/1.4\r\nHost: www.kittyhell.com\r\nKeep-Alive: 115\r\n\r\n" 141 | in 142 | print_s 143 | ([%sexp_of: Request.t success Or_error.t] (parse_or_error (P.parse_request req))); 144 | [%expect {| (Error ("Parse error" "Invalid HTTP Version")) |}] 145 | ;; 146 | 147 | let%expect_test "parse result indicates location of start of body" = 148 | let req = 149 | Bigstring.of_string 150 | "POST / HTTP/1.1\r\n\ 151 | Host: localhost:8080\r\n\ 152 | User-Agent: curl/7.64.1\r\n\ 153 | Accept: */*\r\n\ 154 | Content-Length: 6\r\n\ 155 | Content-Type: application/x-www-form-urlencoded\r\n\ 156 | \r\n\ 157 | foobar" 158 | in 159 | let { consumed; _ } = Or_error.ok_exn (parse_or_error (P.parse_request req)) in 160 | print_endline 161 | (Bigstring.To_string.sub req ~pos:consumed ~len:(Bigstring.length req - consumed)); 162 | [%expect {| foobar |}] 163 | ;; 164 | 165 | open Base_quickcheck 166 | 167 | let parse_chunk_length () = 168 | Test.run_exn 169 | (module struct 170 | type t = int [@@deriving quickcheck, sexp_of] 171 | end) 172 | ~f:(fun num -> 173 | let payload = 174 | let s = Bigstring.of_string (Printf.sprintf "%x\r\n" num) in 175 | s 176 | in 177 | match P.parse_chunk_length payload with 178 | | Ok res -> 179 | [%test_eq: int * int] res (num, String.length (Printf.sprintf "%x" num) + 2) 180 | | Error (P.Fail _) -> () 181 | | Error _ -> assert false) 182 | ;; 183 | 184 | let chunk_length_parse_case_insensitive () = 185 | let run_test num str = 186 | let buf = Bigstring.of_string str in 187 | match P.parse_chunk_length buf with 188 | | Ok res -> 189 | [%test_eq: int * int] res (num, String.length (Printf.sprintf "%x" num) + 2) 190 | | Error (P.Fail _) -> () 191 | | Error _ -> assert false 192 | in 193 | Test.run_exn 194 | (module struct 195 | type t = int [@@deriving quickcheck, sexp_of] 196 | end) 197 | ~f:(fun num -> 198 | let payload = Printf.sprintf "%x\r\n" num in 199 | run_test num (String.uppercase payload); 200 | run_test num (String.lowercase payload)) 201 | ;; 202 | 203 | let%expect_test "can parse chunk lengths" = 204 | List.iter 205 | ~f:(fun buf -> 206 | printf 207 | !"input: %S, parse_result: %{sexp: int success Or_error.t} \n" 208 | buf 209 | (parse_or_error (P.parse_chunk_length (Bigstring.of_string buf)))) 210 | [ "ab2\r\n" 211 | ; "4511ab\r\n" 212 | ; "4511ab ; a\r\n" 213 | ; "4511ab; now in extension\r\n" 214 | ; "4511ab a ; now in extension\r\n" 215 | ; "111111111111111\r\n" 216 | ; "1111111111111111\r\n" 217 | ; "abc\r12" 218 | ; "abc\n12" 219 | ; "121" 220 | ; "121\r" 221 | ]; 222 | [%expect 223 | {| 224 | input: "ab2\r\n", parse_result: (Ok ((consumed 5) (value 2738))) 225 | input: "4511ab\r\n", parse_result: (Ok ((consumed 8) (value 4526507))) 226 | input: "4511ab ; a\r\n", parse_result: (Ok ((consumed 13) (value 4526507))) 227 | input: "4511ab; now in extension\r\n", parse_result: (Ok ((consumed 26) (value 4526507))) 228 | input: "4511ab a ; now in extension\r\n", parse_result: (Error ("Parse error" ("Invalid chunk_length character" a))) 229 | input: "111111111111111\r\n", parse_result: (Ok ((consumed 17) (value 76861433640456465))) 230 | input: "1111111111111111\r\n", parse_result: (Error ("Parse error" "Chunk size is too large")) 231 | input: "abc\r12", parse_result: (Error ("Parse error" Expected_newline)) 232 | input: "abc\n12", parse_result: (Error ("Parse error" ("Invalid chunk_length character" "\n"))) 233 | input: "121", parse_result: (Error Partial) 234 | input: "121\r", parse_result: (Error Partial) |}] 235 | ;; 236 | --------------------------------------------------------------------------------