--- /dev/null
+version: 2
+updates:
+ - package-ecosystem: github-actions
+ directory: /
+ schedule:
+ interval: weekly
--- /dev/null
+name: Changelog check
+
+on:
+ pull_request:
+ branches: [master]
+ types: [opened, synchronize, reopened, labeled, unlabeled]
+
+jobs:
+ Changelog-Entry-Check:
+ name: Check Changelog Action
+ runs-on: ubuntu-latest
+ steps:
+ - uses: tarides/changelog-check-action@v3
--- /dev/null
+name: "Nix"
+on:
+ pull_request:
+ push:
+jobs:
+ tests:
+ runs-on: ubuntu-latest
+ env:
+ NIXPKGS_ALLOW_INSECURE: 1
+ steps:
+ - name: Checkout tree
+ uses: actions/checkout@v4
+ with:
+ submodules: true
+ - uses: cachix/install-nix-action@v30
+ with:
+ nix_path: nixpkgs=channel:nixos-unstable
+ - run: nix develop -c dune build @runtest @check
name: Main workflow
on:
+ workflow_dispatch:
pull_request:
push:
schedule:
# Prime the caches every Monday
- cron: 0 1 * * MON
+concurrency:
+ group: ${{ github.workflow }}-${{ github.ref }}-${{ github.event_name == 'pull_request' || github.sha }}
+ cancel-in-progress: true
+
jobs:
- build:
+ build-test-default:
+ if: github.event.pull_request.draft == false
strategy:
fail-fast: false
matrix:
os:
+ - ubuntu-latest
- macos-latest
+ ocaml-compiler:
+ - "5"
+ local-packages:
+ - |
+ *.opam
+ !cohttp-eio.opam
+ !cohttp-curl-async.opam
+ !cohttp-async.opam
+ !cohttp-bench.opam
+
+ runs-on: ${{ matrix.os }}
+
+ steps:
+ - name: Checkout tree
+ uses: actions/checkout@v4
+
+ - name: Set-up OCaml ${{ matrix.ocaml-compiler }}
+ uses: ocaml/setup-ocaml@v3
+ with:
+ ocaml-compiler: ${{ matrix.ocaml-compiler }}
+ dune-cache: true
+ opam-local-packages: ${{ matrix.local-packages }}
+
+ - run: |
+ sudo apt-get update && sudo apt-get upgrade
+ opam install conf-libcurl
+ if: ${{ matrix.os == 'ubuntu-latest' }}
+
+ - run: |
+ brew update
+ if: ${{ matrix.os == 'macos-latest' }}
+
+ - run: echo "PKG_CONFIG_PATH=$(brew --prefix openssl)/lib/pkgconfig" >>"$GITHUB_ENV"
+ if: ${{ matrix.os == 'macos-latest' }}
+
+ - run: opam install --with-test --deps-only http cohttp cohttp-lwt cohttp-lwt-unix cohttp-server-lwt-unix cohttp-mirage cohttp-curl-lwt cohttp-curl cohttp-top
+ - run: opam exec -- dune build http cohttp cohttp-lwt cohttp-lwt-unix cohttp-server-lwt-unix cohttp-mirage cohttp-curl-lwt cohttp-curl cohttp-top
+ - run: opam exec -- dune runtest http cohttp cohttp-lwt cohttp-lwt-unix cohttp-server-lwt-unix cohttp-mirage cohttp-curl-lwt cohttp-curl cohttp-top
+
+ build-test-cohttp-async:
+ if: github.event.pull_request.draft == false
+ strategy:
+ fail-fast: false
+ matrix:
+ os:
- ubuntu-latest
+ - macos-latest
ocaml-compiler:
- - 4.14.x
+ - "5"
+ local-packages:
+ - |
+ *.opam
+ !cohttp-mirage.opam
+ !cohttp-curl-lwt.opam
+ !cohttp-lwt-jsoo.opam
+ !cohttp-lwt-unix.opam
+ !cohttp-lwt.opam
+ !cohttp-server-lwt-unix.opam
+ !cohttp-eio.opam
+ !cohttp-bench.opam
runs-on: ${{ matrix.os }}
steps:
- - name: Checkout code
- uses: actions/checkout@v2
+ - name: Checkout tree
+ uses: actions/checkout@v4
- - name: Use OCaml ${{ matrix.ocaml-compiler }}
- uses: ocaml/setup-ocaml@v2
+ - name: Set-up OCaml ${{ matrix.ocaml-compiler }}
+ uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: ${{ matrix.ocaml-compiler }}
- dune-cache: ${{ matrix.os == 'ubuntu-latest' }}
+ dune-cache: true
+ opam-local-packages: ${{ matrix.local-packages }}
- - run: yarn --frozen-lockfile
- working-directory: cohttp_lwt_jsoo_test
+ - run: |
+ sudo apt-get update && sudo apt-get upgrade
+ opam install conf-libcurl
+ if: ${{ matrix.os == 'ubuntu-latest' }}
- run: echo "PKG_CONFIG_PATH=$(brew --prefix openssl)/lib/pkgconfig" >>"$GITHUB_ENV"
if: ${{ matrix.os == 'macos-latest' }}
- - run: opam install . --deps-only --with-test
+ - run: opam install --with-test --deps-only http cohttp cohttp-async cohttp-curl-async cohttp-curl cohttp-top
+ - run: opam exec -- dune build http cohttp cohttp-async cohttp-curl-async cohttp-curl cohttp-top
+ - run: opam exec -- dune runtest http cohttp cohttp-async cohttp-curl-async cohttp-curl cohttp-top
- - run: opam exec -- make build
+ build-test-cohttp-eio:
+ if: github.event.pull_request.draft == false
+ strategy:
+ fail-fast: false
+ matrix:
+ os:
+ - ubuntu-latest
+ - macos-latest
+ ocaml-compiler:
+ - "5"
+ local-packages:
+ - |
+ http.opam
+ cohttp.opam
+ cohttp-eio.opam
- - run: opam exec -- make test
+ runs-on: ${{ matrix.os }}
+
+ steps:
+ - name: Checkout tree
+ uses: actions/checkout@v4
+
+ - name: Set-up OCaml ${{ matrix.ocaml-compiler }}
+ uses: ocaml/setup-ocaml@v3
+ with:
+ ocaml-compiler: ${{ matrix.ocaml-compiler }}
+ dune-cache: true
+ opam-local-packages: ${{ matrix.local-packages }}
+ opam-repositories: |
+ default: https://github.com/ocaml/opam-repository.git
+ alpha: https://github.com/kit-ty-kate/opam-alpha-repository.git
+
+ - run: opam install --with-test --deps-only cohttp-eio
+ - run: opam exec -- dune build cohttp-eio
+ - run: opam exec -- dune runtest cohttp-eio
+
+ build-test-cohttp-bench:
+ if: github.event.pull_request.draft == false
+ strategy:
+ fail-fast: false
+ matrix:
+ os:
+ - ubuntu-latest
+ ocaml-compiler:
+ - "5"
+ local-packages:
+ - |
+ *.opam
+
+ runs-on: ${{ matrix.os }}
+
+ steps:
+ - name: Checkout tree
+ uses: actions/checkout@v4
+
+ - name: Set-up OCaml ${{ matrix.ocaml-compiler }}
+ uses: ocaml/setup-ocaml@v3
+ with:
+ ocaml-compiler: ${{ matrix.ocaml-compiler }}
+ dune-cache: true
+ opam-local-packages: ${{ matrix.local-packages }}
+ opam-repositories: |
+ default: https://github.com/ocaml/opam-repository.git
+ alpha: https://github.com/kit-ty-kate/opam-alpha-repository.git
- - run: opam exec -- make js-test
+ - run: opam install --with-test --deps-only cohttp-bench
+ - run: opam exec -- dune build cohttp-bench
+ - run: opam exec -- dune runtest cohttp-bench
.merlin
_opam/
node_modules
+dune.lock/
-version = 0.20.0
-profile = conventional
-break-infix = fit-or-vertical
-parse-docstrings = true
+version = 0.26.2
+profile=conventional
+break-infix=fit-or-vertical
+parse-docstrings=true
-## v5.3.1 (2023-12-13)
-
-- cohttp: case-insensitive check of set-cookies (chomosuke, #1008)
-
-## v5.3.0 (2023-07-21)
-
-- cohttp-async: support for base/async v0.16
-
-## v5.2.0 (2023-07-07)
-
-- cohttp-lwt server: call conn_closed before drainig the body of response on error (pirbo)
-
-## v5.1.0 (2023-04-04)
-
+## v6.0.0 (2024-11-21)
+
+- bump minimum dune version to 3.8 (@avsm)
+- cohttp-eio: Use system authenticator in example.
+- http, cohttp: remove the scheme field from requests. This means that
+ [Request.uri] no longer returns the same URI as was to create the request
+ with [Request.make] (@rgrinberg 1086)
+- cohttp-eio: Remove unused `Client_intf` module (talex5 #1081)
+- cohttp-eio: Make server response type abstract and allow streaming in cohttp-eio (talex5 #1024)
+- cohttp-{lwt,eio}: server: add connection header to response if not present (ushitora-anqou #1025)
+- cohttp-curl: Curl no longer prepends the first HTTP request header to the output. (jonahbeckford #1030, #987)
+- cohttp-eio: client: use permissive argument type for make_generic
+- cohttp-eio: Improve error handling in example server (talex5 #1023)
+- cohttp-eio: Don't blow up `Server.callback` on client disconnections. (mefyl #1015)
+- http: Fix assertion in `Source.to_string_trim` when `pos <> 0` (mefyl #1017)
+- cohttp: `Cohttp.Request.make_for_client` no longer allows setting both
+ `~chunked:true` and `~body_length`.
+- cohttp-lwt-unix: Don't blow up when certificates are not available and no-network requests are made. (akuhlens #1027)
+ + Makes `cohttp-lwt.S.default_ctx` lazy.
+
+## v6.0.0~beta2 (2024-01-05)
+
+- cohttp-eio: Don't blow up `Server.run` on client disconnections. (mefyl #1011)
+- cohttp-eio: Match body encoding with headers. (mefyl #1012)
+- cohttp-lwt: Preserve extended `Server.S.IO` signature. (mefyl #1013)
+
+## v6.0.0~beta1 (2023-10-27)
+- cohttp-eio: move new Cohttp.{Client,Server} modules under Cohttp.Generic (mseri #1003)
+- cohttp-eio: Add Client.make_generic and HTTPS support. (talex5 #1002)
+- cohttp: move generic client and server signatures to cohttp and use them across all packages. (mefyl #984)
+- cohttp-eio: Complete rewrite to follow common interfaces and behaviors. (mefyl #984)
+
+## v6.0.0~alpha2 (2023-08-08)
+- cohttp-lwt: Do not leak exceptions to `Lwt.async_exception_hook`. (mefyl #992, #995)
+- http.header, cohttp, cohttp-eio: remove "first" and "move_to_first" and the special treatment of the "host" header (mseri #988, #986)
+- http.header: introduce "iter_ord" to guarantee iteration following the order of the entries in the headers (mseri #986)
+- do not omit mandatory null Content-Length headers (mefyl #985)
+- cohttp-async, cohttp-curl-async: compatibility with core/async v0.16.0 (mseri, dkalinichenko-js #976)
+- cohttp-lwt server: call conn_closed before drainig the body of response on error (pirbo #982)
+- cohttp-eio: Relax socket interface requirement on `Server.connection_handler`. (mefyl #983)
+
+## v6.0.0~alpha1 (2023-04-28)
- cohttp,cohttp-async server: correctly close broken streams (reported by Stéphane Glondu, fix by samhot and anuragsoni)
+- cohttp-eio: remove unused code from tests to work with Eio 0.8 (talex5 #967)
+- Upgrade dune to v3.0 (bikallem #947)
+- cohttp-eio: allow client to optionally configure request pipelining (bikallem #949)
+- cohttp-eio: update to Eio 0.7 (talex5 #952)
+- cohttp-eio: update examples to use eio 0.7 primitives (bikallem #957)
+- cohttp-eio: generate Date header in responses (bikallem #955)
+- cohttp-eio: further improve Cohttp_eio.Client ergonomics (bikallem #?)
+- cohttp-eio: server api improvements (bikallem #962)
+
+## v6.0.0~alpha0 (2022-10-24)
+- cohttp-eio: ensure "Host" header is the first header in http client requests (bikallem #939)
+- cohttp-eio: add TE header in client. Check TE header is server (bikallem #941)
+- cohttp-eio: add User-Agent header to request from Client (bikallem #940)
+- cohttp-eio: add Content-Length header to request/response (bikallem #929)
+- cohttp-eio: add cohttp-eio client api - Cohttp_eio.Client (bikallem #879)
+- http: add requires_content_length function for requests and responses (bikallem #879)
+- cohttp-eio: use Eio.Buf_write and improve server API (talex5 #887)
+- cohttp-eio: update to Eio 0.3 (talex5 #886)
+- cohttp-eio: convert to Eio.Buf_read (talex5 #882)
+- cohttp lwt client: Connection cache and explicit pipelining (madroach #853)
+- http: add Http.Request.make and simplify Http.Response.make (bikallem mseri #878)
+- http: add pretty printer functions (bikallem #880)
+- New eio based client and server on top of the http library (bikallem #857)
+- New curl based clients (rgrinberg #813)
+ + cohttp-curl-lwt for an Lwt backend
+ + cohttp-curl-async for an Async backend
+- Completely new Parsing layers for servers (anuragsoni #819)
+ + Cohttp now uses an optimized parser for requests.
+ + The new parser produces much less temporary buffers during read operations
+ in servers.
+- Faster header comparison (gasche #818)
+- Introduce http package containing common signatures and structures useful for
+ compatibility with cohttp - and no dependencies (rgrinberg #812)
+- async(server): allow reading number of active connections (anuragsoni #809)
+- Various internal refactors (rgrinberg, mseri, #802, #812, #820, #800, #799,
+ #797)
+- http (all cohttp server backends): Consider the connection header in response
+ in addition to the request when deciding on whether to keep a connection
+ alive (anuragsoni, #843)
+ + The user provided Response can contain a connection header. That header
+ will also be considered in addition to the connection header in requests
+ when deciding whether to use keep-alive. This allows a handler to decide to
+ close a connection even if the client requested a keep-alive in the
+ request.
+- async(server): allow creating a server without using conduit (anuragsoni #839)
+ + Add `Cohttp_async.Server.Expert.create` and
+ `Cohttp_async.Server.Expert.create_with_response_action`that can be used to
+ create a server without going through Conduit. This allows creating an
+ async TCP server using the Tcp module from `Async_unix` and lets the user
+ have more control over how the `Reader.t` and `Writer.t` are created.
+- http(header): faster `to_lines` and `to_frames` implementation (mseri #847)
+- cohttp(cookies): use case-insensitive comparison to check for `set-cookies` (mseri #858)
+- New lwt based server implementation: cohttp-server-lwt-unix
+ + This new implementation does not depend on conduit and has a simpler and
+ more flexible API
+- async: Adapt cohttp-curl-async to work with core_unix.
+- *Breaking changes*
+ + refactor: move opam metadata to dune-project (rgrinberg #811)
+ + refactor: deprecate Cohttp_async.Io (rgrinberg #807)
+ + fix: move more internals to Private (rgrinberg #806)
+ + fix: deprecate transfer encoding field (rgrinberg #805)
+ + refactor: deprecate Cohttp_async.Body_raw (rgrinberg #804)
+ + fix: deprecate more aliases (rgrinberg #803)
+ + refactor: deprecate connection value(rgrinberg #798)
+ + refactor: deprecate using attributes (rgrinberg #796)
+ + cleanup: remove cohttp-{curl,server}-async (rgrinberg #904)
+ + cleanup: remove cohttp-{curl,server,proxy}-lwt (rgrinberg #904)
+ + fix: all parsers now follow the spec and require `\r\n` endings.
+ Previously, the `\r` was optional. (rgrinberg, #921)
+- `cohttp-lwt-jsoo`: do not instantiate `XMLHttpRequest` object on boot (mefyl #922)
## v5.0.0 (2021-12-15)
**Breaking** the headers are no-longer lowercased when parsed, the headers key comparison is case insensitive instead.
- cohttp-lwt-unix: Adopt ocaml-conduit 5.0.0 (smorimoto #787)
- **Breaking** `Conduit_lwt_unix.connect`'s `ctx` param type chaged from `ctx` to `ctx Lazy.t`
+ **Breaking** `Conduit_lwt_unix.connect`'s `ctx` param type changed from `ctx` to `ctx Lazy.t`
- cohttp-mirage: fix deprecated fmt usage (tmcgilchrist #783)
- lwt_jsoo: Use logs for the warnings and document it (mseri #776)
- Use implicit executable dependency for generate.exe (TheLortex #735)
- cohttp: fix chunked encoding of empty body (mefyl #715)
- cohttp-async: fix body not being uploaded with unchunked Async.Pipe (mefyl #706)
-- cohttp-{async, lwt}: fix suprising behaviours of Body.is_empty (anuragsoni #714 #712 #713)
+- cohttp-{async, lwt}: fix surprising behaviours of Body.is_empty (anuragsoni #714 #712 #713)
- refactoring of tests (mseri #709, dinosaure #692)
- update documentation (dinosaure #716, mseri #720)
- fix deadlock in logging (dinosaure #722)
In cohttp.0.99, a number of subpackages were turned into explicit
opam packages to simplify dependency management.
-To aid migration, some compatability shims were left in place so that
+To aid migration, some compatibility shims were left in place so that
the old findlib names would continue to work. They have now been removed
as of this release. If you were still using them, then please rename
them as follows:
## 0.22.0 (2017-03-09)
-* Lwt: ensure conn_closed is cosed once client goes away (#528)
+* Lwt: ensure conn_closed is closed once client goes away (#528)
* Use the Logs library for logging. (#532)
## 0.21.1 (2017-02-18)
-.PHONY: build clean test clean
+.PHONY: build clean test clean eio eio-shell eio-test fmt js-test
build:
dune build
clean:
dune clean
+
+fmt:
+ dune b @fmt --auto-promote
+
+eio: #build eio
+ dune build cohttp-eio
+
+eio-test:
+ dune runtest cohttp-eio
+
+eio-shell: # nix-shell for eio dev
+ nix develop .#eio
HTTP parser, and implementations using various asynchronous programming
libraries:
+* `Http` provides essential type definitions used in Cohttp and an extremely
+ fast http parser. It is designed to have no dependencies and make it easy
+ for other packages to easily interoperate with Cohttp.
* `Cohttp_lwt_unix` uses the [Lwt](https://ocsigen.org/lwt/) library, and
specifically the UNIX bindings. It uses [ocaml-tls](https://github.com/mirleft/ocaml-tls)
as the TLS implementation to handle HTTPS connections.
* `Cohttp_lwt_jsoo` compiles to a JavaScript module that maps the Cohttp
calls to XMLHTTPRequests. This is used to compile OCaml libraries like
the GitHub bindings to JavaScript and still run efficiently.
+* `Cohttp_curl` uses `libcurl`, via `ocurl`, as backend. It also comes
+ with lwt (`Cohttp_curl_lwt`) and async backends (`Cohttp_curl_async`).
+* `Cohttp_eio` uses `eio` to leverage new features from multicore ocaml 5.0.
+* `Cohttp_server_lwt_unix` uses lwt to implement a more efficient web server
+ with a minimal interface.
You can implement other targets using the parser very easily. Look at the `IO`
signature in `lib/s.mli` and implement that in the desired backend.
- [Installation](#installation)
- [Client Tutorial](#client-tutorial)
- * [Compile and execute with ocamlbuild](#compile-and-execute-with-ocamlbuild)
* [Compile and execute with dune](#compile-and-execute-with-dune)
- [Dealing with timeouts](#dealing-with-timeouts)
- [Managing sessions](#managing-sessions)
- [Creating custom resolver: a Docker Socket Client example](#creating-custom-resolver--a-docker-socket-client-example)
- [Dealing with redirects](#dealing-with-redirects)
- [Basic Server Tutorial](#basic-server-tutorial)
- * [Compile and execute with ocamlbuild](#compile-and-execute-with-ocamlbuild-1)
* [Compile and execute with dune](#compile-and-execute-with-dune-1)
- [Installed Binaries](#installed-binaries)
- [Debugging](#debugging)
run the event loop and return with final value of `body` which we then print.
Note that `Cohttp_lwt_unix`/`Cohttp_async` are able to request an HTTPS page
-by default. For `Cohttp_lwt_unix`, we use [ocaml-tls](https://github.com/mirleft/ocaml-tls.git)
-(to use `lwt_ssl` is enough to use `Cohttp_lwt_unix_ssl` from the analogously
-named package, the rest of the code does not change). For `Cohttp_async`, we use
-`async_ssl` (but the user is able to use `ocaml-tls` with some modifications).
+by default. For `Cohttp_lwt_unix` users can use [ocaml-tls](https://github.com/mirleft/ocaml-tls.git) by installing `tls-lwt` or [ocaml-ssl](https://github.com/savonet/ocaml-ssl) by installing `lwt_ssl`. The latter is the default if both are installed but it is possible to force the selection of tls with the environment variable `CONDUIT_TLS=native`. For `Cohttp_async` the default is to use
+`async_ssl` (but users are able to use `ocaml-tls` with some modifications).
Consult the following modules for reference:
The full documentation for the latest published version of the library is
available on the [repository github pages](https://mirage.github.io/ocaml-cohttp/).
-### Compile and execute with ocamlbuild
-
-Build and execute with:
-
-```
-$ ocamlbuild -use-ocamlfind -tag thread -pkg cohttp-lwt-unix client_example.native
-$ ./client_example.native
-```
-
-For manual builds, it is usually enough to remember that cohttp ships with 6
-findlib (`ocamlfind`) libraries:
-
-* `cohttp` - Base `Cohttp` module. No platform specific functionality
-* `cohttp-async` - Async backend `Cohttp_async`
-* `cohttp-lwt` - Lwt backend without unix specifics
-* `cohttp-lwt-unix` - Unix based lwt backend
-* `cohttp-lwt-jsoo` - Jsoo (XHR) client
-* `cohttp-top` - Print cohttp types in the toplevel (`#require "cohttp-top"`)
-
### Compile and execute with dune
Create this `dune` file
```
cat - > dune <<EOF
(executable
- ; (public_name client_example)
- (name client_example)
- (libraries cohttp-lwt-unix))
+ (public_name client_example)
+ (name client_example)
+ (libraries cohttp-lwt-unix))
EOF
```
then build and execute the example with
let body =
let get () = Client.get (Uri.of_string "https://www.reddit.com/") in
compute ~time:0.1 ~f:get >>= function
- | `Timeout -> Lwt.fail_with "Timeout expired"
+ | `Timeout -> failwith "Timeout expired"
| `Done (resp, body) -> Lwt.return (resp, body)
```
```ocaml
let get_body ~uri ~timeout =
let%bind _, body = Cohttp_async.Client.get ~interrupt:(after (sec timeout)) uri in
- Body.to_string body
+ Body.to_string body
let body =
let uri = Uri.of_string "https://www.reddit.com/" in
```
$ cat - > dune <<EOF
(executable
- ;(public_name docker_example)
- (name docker_example)
- (libraries cohttp-lwt-unix conduit-lwt))
+ (public_name docker_example)
+ (name docker_example)
+ (libraries cohttp-lwt-unix conduit-lwt))
EOF
```
then run the example with
and follow_redirect ~max_redirects request_uri (response, body) =
let open Lwt.Syntax in
- let status = Cohttp.Response.status response in
+ let status = Http.Response.status response in
(* The unconsumed body would otherwise leak memory *)
let* () =
if status <> `OK then Cohttp_lwt.Body.drain_body body else Lwt.return_unit
handle_redirect ~permanent:true ~max_redirects request_uri response
| `Found | `Temporary_redirect ->
handle_redirect ~permanent:false ~max_redirects request_uri response
- | `Not_found | `Gone -> Lwt.fail_with "Not found"
+ | `Not_found | `Gone -> failwith "Not found"
| status ->
- Lwt.fail_with
- (Printf.sprintf "Unhandled status: %s"
- (Cohttp.Code.string_of_status status))
+ Printf.ksprintf failwith "Unhandled status: %s"
+ (Cohttp.Code.string_of_status status)
and handle_redirect ~permanent ~max_redirects request_uri response =
- if max_redirects <= 0 then Lwt.fail_with "Too many redirects"
+ if max_redirects <= 0 then failwith "Too many redirects"
else
- let headers = Cohttp.Response.headers response in
- let location = Cohttp.Header.get headers "location" in
+ let headers = Http.Response.headers response in
+ let location = Http.Header.get headers "location" in
match location with
- | None -> Lwt.fail_with "Redirection without Location header"
+ | None -> failwith "Redirection without Location header"
| Some url ->
let open Lwt.Syntax in
let uri = Uri.of_string url in
let* () =
if permanent then
- Logs.warn (fun m ->
+ Logs_lwt.warn (fun m ->
m "Permanent redirection from %s to %s"
(Uri.to_string request_uri)
url)
is mostly equivalent to implementing a function of type :
```
-conn -> Cohttp.Request.t -> Cohttp_lwt.Body.t -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t
+conn -> Http.Request.t -> Cohttp_lwt.Body.t -> (Http.Response.t * Cohttp_lwt.Body.t) Lwt.t
```
The parameters are self explanatory but we'll summarize them quickly here:
* `conn` - contains connection information
-* `Cohttp.Request.t` - Request information such as method, uri, headers, etc.
+* `Http.Request.t` - Request information such as method, uri, headers, etc.
* `Cohttp_lwt.Body.t` - Contains the request body. You must manually decode the
request body into json, form encoded pairs, etc. For cohttp, the body is
simply binary data.
>>= fun body -> Server.respond_string ~status:`OK ~body ()
in
Server.create ~mode:(`TCP (`Port 8000)) (Server.make ~callback ())
-```
-
-### Compile and execute with ocamlbuild
-Build and execute with:
-```
-$ ocamlbuild -use-ocamlfind -tag thread -pkg cohttp-lwt-unix server_example.native
-$ ./server_example.native
+let () = ignore (Lwt_main.run server)
```
### Compile and execute with dune
```
cat - > dune <<EOF
(executable
- ; (public_name server_example)
- (name server_example)
- (libraries cohttp-lwt-unix conduit-lwt))
+ (public_name server_example)
+ (name server_example)
+ (libraries cohttp-lwt-unix conduit-lwt))
EOF
```
then build and execute the example with
```
-$ dune exec ./client_example.exe
+$ dune exec ./server_example.exe
```
As in the previous example, here we are explicitly mentioning conduit-lwt to
$ cohttp-curl-lwt 'http://0.0.0.0:8080/README.md'
```
-Other examples using the async api are avaliable in the
-[examples/async](https://github.com/mirage/ocaml-cohttp/tree/master/examples)
-folder in the sources
+Other examples using the async api are available in the
+[cohttp-async/examples](https://github.com/mirage/ocaml-cohttp/tree/master/cohttp-async/examples)
+folder in the sources.
## Debugging
+++ /dev/null
-Planned changes for 1.0:
-
-* Make the Lwt response stream bounded (new in lwt-2.4+)
-
-Planned changes for 2.0:
-
-* Make the Header.t header parsing more efficient by only lazily parsing them
- instead of copying into a Map as we do now.
-
-Better HTTP support:
-
-- Range requests need to be fully implemented (206)
-- 100 Continue should be a noop
-- Awwww crap, so much to do : http://www.and.org/texts/server-http
-- A client interface that deals with redirects
-- Proxy support (manual means a full URI in the request)
-
-Tests:
-
-- Test the lib_test server scripts via external invocations of
- curl and httperf, so that the tests terminate.
-
-- Test the HTTP timeout support
-version: "5.3.1"
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
-maintainer: "anil@recoil.org"
+synopsis: "CoHTTP implementation for the Async concurrency library"
+description: """
+An implementation of an HTTP client and server using the Async
+concurrency library. See the `Cohttp_async` module for information
+on how to use this. The package also installs `cohttp-curl-async`
+and a `cohttp-server-async` binaries for quick uses of a HTTP(S)
+client and server respectively.
+"""
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
authors: [
"Anil Madhavapeddy"
"Stefano Zacchiroli"
"David Scott"
"Rudi Grinberg"
"Andy Ray"
+ "Anurag Soni"
]
-synopsis: "CoHTTP implementation for the Async concurrency library"
-description: """
-An implementation of an HTTP client and server using the Async
-concurrency library. See the `Cohttp_async` module for information
-on how to use this. The package also installs `cohttp-curl-async`
-and a `cohttp-server-async` binaries for quick uses of a HTTP(S)
-client and server respectively.
-"""
license: "ISC"
-tags: ["org:mirage" "org:xapi-project"]
homepage: "https://github.com/mirage/ocaml-cohttp"
doc: "https://mirage.github.io/ocaml-cohttp/"
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
+ "dune" {>= "3.8"}
"ocaml" {>= "4.14"}
- "dune" {>= "2.0"}
+ "http" {= version}
+ "cohttp" {= version}
"async_kernel" {>= "v0.16.0"}
"async_unix" {>= "v0.16.0"}
"async" {>= "v0.16.0"}
"base" {>= "v0.16.0"}
"core" {with-test}
- "core_unix" {>= "v0.16.0"}
- "cohttp" {= version}
+ "core_unix" {>= "v0.14.0"}
"conduit-async" {>= "1.2.0"}
"magic-mime"
- "mirage-crypto" {with-test}
+ "digestif" {with-test}
"logs"
"fmt" {>= "0.8.2"}
"sexplib0"
"ppx_sexp_conv" {>= "v0.13.0"}
- "ounit" {with-test}
+ "ounit2" {with-test}
"uri" {>= "2.0.0"}
"uri-sexp"
"ipaddr"
+ "odoc" {with-doc}
]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
build: [
["dune" "subst"] {dev}
- ["dune" "build" "-p" name "-j" jobs]
- ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-async/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
]
-available: arch != "s390x"
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+available: arch != "s390x"
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-async/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
+available: arch != "s390x"
open Base
open Async_kernel
-open Cohttp_async
+module Body = Cohttp_async.Body
+module Client = Cohttp_async.Client
let show_headers h =
Cohttp.Header.iter (fun k v -> Logs.info (fun m -> m "%s: %s%!" k v)) h
let headers = Cohttp.Header.of_list [ ("connection", "close") ] in
Client.call meth ~headers ~body:Body.(of_string body) uri
>>= fun (res, body) ->
- show_headers (Cohttp.Response.headers res);
+ show_headers (Http.Response.headers res);
body
|> Body.to_pipe
|> Pipe.iter ~f:(fun b ->
open Base
open Async_kernel
open Async_unix
-open Cohttp_async
+module Server = Cohttp_async.Server
open Cohttp_server
let method_filter meth (res, body) =
let uri = Cohttp.Request.uri req in
let path = Uri.path uri in
(* Log the request to the console *)
- printf "%s %s%!" Cohttp.(Code.string_of_method (Request.meth req)) path;
- match Request.meth req with
+ printf "%s %s%!" Http.(Method.to_string (Request.meth req)) path;
+ match Http.Request.meth req with
| (`GET | `HEAD) as meth ->
serve ~info ~docroot ~index uri path >>= method_filter meth
| meth ->
- let meth = Cohttp.Code.string_of_method meth in
+ let meth = Http.Method.to_string meth in
let allowed = "GET, HEAD" in
- let headers = Cohttp.Header.of_list [ ("allow", allowed) ] in
+ let headers = Http.Header.of_list [ ("allow", allowed) ] in
Server.respond_string ~headers ~status:`Method_not_allowed
(html_of_method_not_allowed meth allowed path info)
(executables
(names cohttp_curl_async cohttp_server_async)
- (package cohttp-async)
- (public_names cohttp-curl-async cohttp-server-async)
- (libraries cohttp-async async_kernel async.async_command async_unix base
- cohttp cohttp_server fmt.tty core_unix.command_unix))
+ (libraries
+ cohttp-async
+ async_kernel
+ async.async_command
+ async_unix
+ base
+ cohttp
+ cohttp_server
+ fmt.tty
+ core_unix.command_unix))
--- /dev/null
+(executables
+ (names hello_world receive_post)
+ (libraries
+ digestif.c
+ http
+ cohttp-async
+ base
+ async_kernel
+ core_unix.command_unix))
+
+(alias
+ (name runtest)
+ (package cohttp-async)
+ (deps hello_world.exe receive_post.exe))
--- /dev/null
+(* This file is in the public domain *)
+open Core
+open Async_kernel
+module Server = Cohttp_async.Server
+
+(* given filename: hello_world.ml compile with:
+ $ corebuild hello_world.native -pkg cohttp.async
+*)
+
+let handler ~body:_ _sock req =
+ let uri = Cohttp.Request.uri req in
+ match Uri.path uri with
+ | "/test" ->
+ Uri.get_query_param uri "hello"
+ |> Option.map ~f:(fun v -> "hello: " ^ v)
+ |> Option.value ~default:"No param hello supplied"
+ |> Server.respond_string
+ | _ -> Server.respond_string ~status:`Not_found "Route not found"
+
+let start_server port () =
+ Stdlib.Printf.eprintf "Listening for HTTP on port %d\n" port;
+ Stdlib.Printf.eprintf "Try 'curl http://localhost:%d/test?hello=xyz'\n%!" port;
+ Server.create ~on_handler_error:`Raise
+ (Async.Tcp.Where_to_listen.of_port port)
+ handler
+ >>= fun server ->
+ Deferred.forever () (fun () ->
+ after Time_ns.Span.(of_sec 0.5) >>| fun () ->
+ Async.Log.Global.printf "Active connections: %d"
+ (Server.num_connections server));
+ Deferred.never ()
+
+let () =
+ let module Command = Async_command in
+ Command.async_spec ~summary:"Start a hello world Async server"
+ Command.Spec.(
+ empty
+ +> flag "-p"
+ (optional_with_default 8080 int)
+ ~doc:"int Source port to listen on")
+ start_server
+ |> Command_unix.run
--- /dev/null
+(* This file is in the public domain *)
+open Base
+open Async_kernel
+module Body = Cohttp_async.Body
+module Server = Cohttp_async.Server
+
+(* compile with: $ corebuild receive_post.native -pkg cohttp.async *)
+
+let start_server port () =
+ Stdlib.Printf.eprintf "Listening for HTTP on port %d\n" port;
+ Stdlib.Printf.eprintf "Try 'curl -X POST -d 'foo bar' http://localhost:%d\n"
+ port;
+ Cohttp_async.Server.create ~on_handler_error:`Raise
+ (Async.Tcp.Where_to_listen.of_port port) (fun ~body _ req ->
+ match req |> Http.Request.meth with
+ | `POST ->
+ Body.to_string body >>= fun body ->
+ Stdlib.Printf.eprintf "Body: %s" body;
+ Server.respond `OK
+ | _ -> Server.respond `Method_not_allowed)
+ >>= fun _ -> Deferred.never ()
+
+let () =
+ let module Command = Async_command in
+ Command.async_spec ~summary:"Simple http server that outputs body of POST's"
+ Command.Spec.(
+ empty
+ +> flag "-p"
+ (optional_with_default 8080 int)
+ ~doc:"int Source port to listen on")
+ start_server
+ |> Command_unix.run
--- /dev/null
+(*{{{ Copyright (C) 2015 Trevor Smith <trevorsummerssmith@gmail.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ }}}*)
+
+(** This example is here to show how to get and put to s3 using the async client
+ code.
+
+ This hopes to be a useful example because: 1) it is a real world use of the
+ client 2) s3 auth requires a bit of fiddling with the headers hopefully this
+ is illustative for anyone else doing the same
+
+ The reader will want to be familiar with the S3 API Documentation found
+ here: http://docs.aws.amazon.com/AmazonS3/latest/API/Welcome.html This
+ example was written using the API Version 2006-03-01.
+
+ There are two ways to authenticate with S3, this example uses the
+ authorization header approach (p. 19 of the api reference).
+
+ Downloads from S3 are done using the GET method, and uploads are done using
+ the PUT method.
+
+ To get this to work, you'll need an AWS access/secret key pair that has the
+ "s3:GetObject" and "s3:PutObject" permissions enabled for the bucket you are
+ interacting with.
+
+ As this is an example, straightforwardness is prized. One should not use
+ this for a production system, nor assume that it offers a good example of
+ abstraction, interface design or error handling. *)
+
+open Base
+open Core
+open Async
+module Time = Time_float
+
+(* open Cohttp *)
+module Client = Cohttp_async.Client
+module Body = Cohttp_async.Body
+
+let ksrt (k, _) (k', _) = String.compare k k'
+
+module Compat = struct
+ (** Things we need to make this happen that, ideally, we'd like other
+ libraries to provide and that are orthogonal to the example here *)
+
+ let encode_string s =
+ (* Percent encode the path as s3 wants it. Uri doesn't
+ encode $, or the other sep characters in a path.
+ If upstream allows that we can nix this function *)
+ let n = String.length s in
+ let buf = Buffer.create (n * 3) in
+ for i = 0 to n - 1 do
+ let c = s.[i] in
+ match c with
+ | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' | '~' | '.' | '/' ->
+ Buffer.add_char buf c
+ | '%' ->
+ (* Sigh. Annoying we're expecting already escaped strings so ignore the escapes *)
+ let is_hex = function
+ | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> true
+ | _ -> false
+ in
+ if i + 2 < n then
+ if is_hex s.[i + 1] && is_hex s.[i + 2] then Buffer.add_char buf c
+ else Buffer.add_string buf "%25"
+ | _ -> Buffer.add_string buf (Printf.sprintf "%%%X" (Char.to_int c))
+ done;
+ Buffer.contents buf
+
+ let hexa = "0123456789abcdef"
+
+ let of_char c =
+ let x = Char.to_int c in
+ (hexa.[x lsr 4], hexa.[x land 0xf])
+
+ let cstruct_to_hex_string cs =
+ let open Cstruct in
+ let n = cs.len in
+ let buf = Buffer.create (n * 2) in
+ for i = 0 to n - 1 do
+ let c = cs.buffer.{cs.off + i} in
+ let x, y = of_char c in
+ Buffer.add_char buf x;
+ Buffer.add_char buf y
+ done;
+ Buffer.contents buf
+
+ let encode_query_string uri =
+ (* Sort and encode query string.
+ Note that AWS wants null keys to have '=' for all keys.
+ URI.encoded_of_query encodes [""] as ?a=, and [] as ?a.
+ *)
+ Uri.query uri
+ |> List.sort ~compare:ksrt
+ |> List.map ~f:(fun (k, v) -> (k, match v with [] -> [ "" ] | x -> x))
+ |> Uri.encoded_of_query
+
+ let format_time t =
+ (* Core.Std.Time doesn't have a format function that takes a timezone *)
+ let d, s = Time.to_date_ofday ~zone:Time.Zone.utc t in
+ let open Time.Span.Parts in
+ let { hr; min; sec; _ } = Time.Ofday.to_parts s in
+ Printf.sprintf "%sT%.2d%.2d%.2dZ"
+ (Date.to_string_iso8601_basic d)
+ hr min sec
+end
+
+type region =
+ [ `Ap_northeast_1 (* Asia Pacific (Tokyo) *)
+ | `Ap_southeast_1 (* Asia Pacific (Singapore) *)
+ | `Ap_southeast_2 (* Asia Pacific (Sydney) *)
+ | `Eu_central_1 (* EU (Frankfurt) *)
+ | `Eu_west_1 (* EU (Ireland) *)
+ | `Sa_east_1 (* South America (Sao Paulo) *)
+ | `Us_east_1 (* US East (N. Virginia) *)
+ | `Us_west_1 (* US West (N. California) *)
+ | `Us_west_2 (* US West (Oregon) *) ]
+[@@deriving sexp]
+
+let region_of_string = function
+ | "ap-northeast-1" -> `Ap_northeast_1
+ | "ap-southeast-1" -> `Ap_southeast_1
+ | "ap-southeast-2" -> `Ap_southeast_2
+ | "eu-central-1" -> `Eu_central_1
+ | "eu-west-1" -> `Eu_west_1
+ | "sa-east-1" -> `Sa_east_1
+ | "us-east-1" -> `Us_east_1
+ | "us-west-1" -> `Us_west_1
+ | "us-west-2" -> `Us_west_2
+ | s -> raise (Invalid_argument ("region_of_string: " ^ s))
+
+let string_of_region = function
+ | `Ap_northeast_1 -> "ap-northeast-1"
+ | `Ap_southeast_1 -> "ap-southeast-1"
+ | `Ap_southeast_2 -> "ap-southeast-2"
+ | `Eu_central_1 -> "eu-central-1"
+ | `Eu_west_1 -> "eu-west-1"
+ | `Sa_east_1 -> "sa-east-1"
+ | `Us_east_1 -> "us-east-1"
+ | `Us_west_1 -> "us-west-1"
+ | `Us_west_2 -> "us-west-2"
+
+let region_host_string = function
+ | `Ap_northeast_1 -> "s3-ap-northeast-1.amazonaws.com"
+ | `Ap_southeast_1 -> "s3-ap-southeast-1.amazonaws.com"
+ | `Ap_southeast_2 -> "s3-ap-southeast-2.amazonaws.com"
+ | `Eu_central_1 -> "s3-eu-central-1.amazonaws.com"
+ | `Eu_west_1 -> "s3-eu-west-1.amazonaws.com"
+ | `Sa_east_1 -> "s3-sa-east-1.amazonaws.com"
+ | `Us_east_1 -> "s3.amazonaws.com"
+ | `Us_west_1 -> "s3-us-west-1.amazonaws.com"
+ | `Us_west_2 -> "s3-us-west-2.amazonaws.com"
+
+type service = [ `S3 ] [@@deriving sexp]
+
+let string_of_service = function `S3 -> "s3"
+
+module Auth = struct
+ (** AWS S3 Authorization *)
+
+ let digest s =
+ (* string -> sha256 as a hex string *)
+ Digestif.SHA256.(digest_string s |> to_hex)
+
+ let make_amz_headers ?body time =
+ (* Return x-amz-date and x-amz-sha256 headers *)
+ let hashed_payload =
+ match body with
+ | None ->
+ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
+ | Some s -> digest s
+ in
+ ( [
+ ("x-amz-content-sha256", hashed_payload);
+ ("x-amz-date", Compat.format_time time);
+ ],
+ hashed_payload )
+
+ let canonical_request hashed_payload (request : Http.Request.t) =
+ (* This corresponds to p.21 of the s3 api doc
+ we're making:
+ <HTTPMethod>\n
+ <CanonicalURI>\n
+ <CanonicalQueryString>\n
+ <CanonicalHeaders>\n
+ <SignedHeaders>\n
+ <HashedPayload>
+ *)
+ let http_method = Http.Method.to_string request.meth in
+ (* Nb the path will be url encoded as per spec *)
+ let uri = Cohttp.Request.uri request in
+ let canoncical_uri = Compat.encode_string (Uri.path uri) in
+ (* Sort query string in alphabetical order by key *)
+ let canonical_query = Compat.encode_query_string uri in
+ let sorted_headers =
+ Http.Header.to_list request.headers |> List.sort ~compare:ksrt
+ in
+ let canonical_headers =
+ sorted_headers
+ |> List.fold ~init:"" ~f:(fun acc (k, v) ->
+ acc
+ ^ Printf.sprintf "%s:%s\n" (String.lowercase k) (String.strip v))
+ in
+ let signed_headers =
+ sorted_headers |> List.map ~f:(fun (k, _) -> k) |> String.concat ~sep:";"
+ in
+ ( Printf.sprintf "%s\n%s\n%s\n%s\n%s\n%s" http_method canoncical_uri
+ canonical_query canonical_headers signed_headers hashed_payload,
+ signed_headers )
+
+ let string_to_sign ?time ~scope ~service canonical_request : string =
+ (* As per p. 23 of s3 api doc. The requests need current time in utc
+ time parameter is there for testing. *)
+ let time_str =
+ match time with
+ | None -> Time.to_string_abs ~zone:Time.Zone.utc (Time.now ())
+ | Some t -> Compat.format_time t
+ in
+ let scope_date, scope_region = scope in
+ let scope_str =
+ Printf.sprintf "%s/%s/%s/aws4_request"
+ (Date.to_string_iso8601_basic scope_date)
+ (string_of_region scope_region)
+ (string_of_service service)
+ in
+ let hashed_req = digest canonical_request in
+ Printf.sprintf "AWS4-HMAC-SHA256\n%s\n%s\n%s" time_str scope_str hashed_req
+
+ let make_signing_key ?date ~region ~service ~secret_access_key () =
+ let mac k v = Digestif.SHA256.(hmac_string ~key:k v |> to_raw_string) in
+ let date' =
+ match date with None -> Date.today ~zone:Time.Zone.utc | Some d -> d
+ in
+ let date_str = Date.to_string_iso8601_basic date' in
+ let date_key = mac ("AWS4" ^ secret_access_key) date_str in
+ let date_region_key = mac date_key (string_of_region region) in
+ let date_region_service_key =
+ mac date_region_key (string_of_service service)
+ in
+ let signing_key = mac date_region_service_key "aws4_request" in
+ signing_key
+
+ let auth_request ?now ~hashed_payload ~region ~service ~aws_access_key
+ ~aws_secret_key request =
+ (* Important use the same time for everything here *)
+ let time = Option.value ~default:(Time.now ()) now in
+ let date = Time.to_date ~zone:Time.Zone.utc time in
+ let canonical_request, signed_headers =
+ canonical_request hashed_payload request
+ in
+ let string_to_sign =
+ string_to_sign ~time ~scope:(date, region) ~service canonical_request
+ in
+ let signing_key =
+ make_signing_key ~date ~region ~service ~secret_access_key:aws_secret_key
+ ()
+ in
+ let creds =
+ Printf.sprintf "%s/%s/%s/%s/aws4_request" aws_access_key
+ (Date.to_string_iso8601_basic date)
+ (string_of_region region)
+ (string_of_service service)
+ in
+ let signature =
+ Digestif.SHA256.(hmac_string ~key:signing_key string_to_sign |> to_hex)
+ in
+ let auth_header =
+ Printf.sprintf
+ "AWS4-HMAC-SHA256 Credential=%s,SignedHeaders=%s,Signature=%s" creds
+ signed_headers signature
+ in
+ [ ("Authorization", auth_header) ]
+end
+
+module S3 = struct
+ type conf = {
+ region : region;
+ aws_access_key : string;
+ aws_secret_key : string;
+ }
+ [@@deriving sexp]
+
+ let make_request ?body conf ~meth ~bucket ~object_ =
+ let host_str = region_host_string conf.region in
+ let uri =
+ Printf.sprintf "https://%s/%s/%s" host_str bucket object_ |> Uri.of_string
+ in
+ let time = Time.now () in
+ (* If PUT add content length *)
+ let headers =
+ match meth with
+ | `PUT ->
+ let length = Option.value_map ~f:String.length ~default:0 body in
+ [ ("Content-length", Int.to_string length) ]
+ | _ -> []
+ in
+ let headers = headers @ [ ("Host", host_str) ] in
+ let amz_headers, hashed_payload = Auth.make_amz_headers time ?body in
+ let headers = headers @ amz_headers in
+ let request =
+ Cohttp.Request.make ~meth ~headers:(Http.Header.of_list headers) uri
+ in
+ let auth_header =
+ Auth.auth_request ~now:time ~hashed_payload ~region:conf.region
+ ~service:`S3 ~aws_access_key:conf.aws_access_key
+ ~aws_secret_key:conf.aws_secret_key request
+ in
+ let headers = headers @ auth_header |> Http.Header.of_list in
+ let request = { request with Cohttp.Request.headers } in
+ match meth with
+ | `PUT ->
+ Client.request
+ ~body:(Option.value_map ~f:Body.of_string ~default:`Empty body)
+ request
+ | `GET -> Client.request request
+ | _ -> failwith "not possible right now"
+end
+
+type s3path = { bucket : string; object_ : string }
+type cmd = S3toLocal of s3path * string | LocaltoS3 of string * s3path
+
+let determine_s3_parts s =
+ (* Takes: string of the form s3://<bucket>/<object_> *)
+ let s = String.drop_prefix s 5 in
+ let parts = String.split ~on:'/' s in
+ match parts with
+ | bucket :: rst -> { bucket; object_ = String.concat ~sep:"/" rst }
+ | _ -> failwith "error format must be 's3://<bucket>/<object_>'"
+
+let determine_paths src dst =
+ let is_s3 s = String.is_prefix ~prefix:"s3://" s in
+ match (is_s3 src, is_s3 dst) with
+ | true, false -> S3toLocal (determine_s3_parts src, dst)
+ | false, true -> LocaltoS3 (src, determine_s3_parts dst)
+ | false, false -> failwith "Use cp(1) :)"
+ | true, true -> failwith "Does not support copying from s3 to s3"
+
+let main region_str aws_access_key aws_secret_key src dst () =
+ (* nb client does not support redirects or preflight 100 *)
+ let open S3 in
+ let region = region_of_string region_str in
+ let conf = { region; aws_access_key; aws_secret_key } in
+ match determine_paths src dst with
+ | S3toLocal (src, dst) -> (
+ make_request conf ~meth:`GET ~bucket:src.bucket ~object_:src.object_
+ >>= fun (resp, body) ->
+ match Http.Response.(resp.status) with
+ | #Http.Status.success ->
+ Body.to_string body >>| fun s ->
+ Out_channel.with_file
+ ~f:(fun oc -> Out_channel.output_string oc s)
+ dst;
+ Core.Printf.printf "Wrote s3://%s to %s\n" (src.bucket ^ src.object_)
+ dst
+ | _ ->
+ Core.Printf.printf "Error: %s\n"
+ (Sexp.to_string (Cohttp.Response.sexp_of_t resp));
+ return ())
+ | LocaltoS3 (src, dst) -> (
+ let body =
+ In_channel.with_file src ~f:(fun ic -> In_channel.input_all ic)
+ in
+ make_request ~body conf ~meth:`PUT ~bucket:dst.bucket ~object_:dst.object_
+ >>= fun (resp, body) ->
+ match Http.Response.status resp with
+ | #Http.Status.success ->
+ Core.Printf.printf "Wrote %s to s3://%s\n" src
+ (dst.bucket ^ dst.object_);
+ return ()
+ | _ ->
+ Body.to_string body >>| fun s ->
+ Core.Printf.printf "Error: %s\n%s\n"
+ (Sexp.to_string (Cohttp.Response.sexp_of_t resp))
+ s)
+
+let () =
+ let open Async_command in
+ async_spec ~summary:"Simple command line client that copies files to/from S3"
+ Spec.(
+ empty
+ +> flag "-r"
+ (optional_with_default "us-east-1" string)
+ ~doc:"string AWS Region"
+ +> anon ("aws_access_key" %: string)
+ +> anon ("aws_secret_key" %: string)
+ +> anon ("src" %: string)
+ +> anon ("dst" %: string))
+ main
+ |> Command_unix.run
-include Body_raw
+open Base
+open Async_kernel
+module B = Cohttp.Body
+
+type t = [ B.t | `Pipe of string Pipe.Reader.t ] [@@deriving sexp_of]
+
+let empty = `Empty
+let of_string s = (B.of_string s :> t)
+let of_pipe p = `Pipe p
+
+let to_string = function
+ | #B.t as body -> return (B.to_string body)
+ | `Pipe s -> Pipe.to_list s >>| String.concat
+
+let to_string_list = function
+ | #B.t as body -> return (B.to_string_list body)
+ | `Pipe s -> Pipe.to_list s
+
+let drain = function #B.t -> return () | `Pipe p -> Pipe.drain p
+
+let is_empty (body : t) =
+ match body with
+ | #B.t as body -> if B.is_empty body then `True else `False
+ | `Pipe _ -> `Unknown
+
+let to_pipe = function
+ | `Empty -> Pipe.of_list []
+ | `String s -> Pipe.singleton s
+ | `Strings sl -> Pipe.of_list sl
+ | `Pipe p -> p
+
+let disable_chunked_encoding = function
+ | #B.t as body -> return (body, B.length body)
+ | `Pipe s ->
+ Pipe.to_list s >>| fun l ->
+ let body = `Strings l in
+ let len = B.length body in
+ (body, len)
+
+let transfer_encoding = function
+ | #B.t as t -> B.transfer_encoding t
+ | `Pipe _ -> Cohttp.Transfer.Chunked
+
+let of_string_list strings = `Strings strings
+
+let map t ~f =
+ match t with
+ | #B.t as t -> (B.map f t :> t)
+ | `Pipe p -> `Pipe (Pipe.map p ~f)
+
+let as_pipe t ~f = `Pipe (t |> to_pipe |> f)
+let to_form t = to_string t >>| Uri.query_of_encoded
+let of_form ?scheme f = Uri.encoded_of_query ?scheme f |> of_string
+
+let write_body write_body (body : t) writer =
+ match body with
+ | `Empty -> return ()
+ | `String s -> write_body writer s
+ | `Strings sl -> Deferred.List.iter ~how:`Sequential sl ~f:(write_body writer)
+ | `Pipe p -> Pipe.iter p ~f:(write_body writer)
+
+let pipe_of_body read_chunk ic =
+ Pipe.create_reader ~close_on_exception:false (fun writer ->
+ Deferred.repeat_until_finished () (fun () ->
+ read_chunk ic >>= function
+ | Cohttp.Transfer.Chunk buf ->
+ (* Even if [writer] has been closed, the loop must continue reading
+ * from the input channel to ensure that it is left in a proper state
+ * for the next request to be processed (in the case of keep-alive).
+ *
+ * The only case where [writer] will be closed is when
+ * [Pipe.close_read] has been called on its read end. This could be
+ * done by a request handler to signal that it does not need to
+ * inspect the remainder of the body to fulfill the request.
+ *)
+ Pipe.write_when_ready writer ~f:(fun write -> write buf)
+ >>| fun _ -> `Repeat ()
+ | Final_chunk buf ->
+ Pipe.write_when_ready writer ~f:(fun write -> write buf)
+ >>| fun _ -> `Finished ()
+ | Done -> return (`Finished ())))
+
+module Private = struct
+ let write_body = write_body
+ let pipe_of_body = pipe_of_body
+ let disable_chunked_encoding = disable_chunked_encoding
+ let drain = drain
+end
open! Base
open! Async_kernel
-open! Cohttp
type t = [ Cohttp.Body.t | `Pipe of string Pipe.Reader.t ] [@@deriving sexp_of]
include Cohttp.S.Body with type t := t
-val drain : t -> unit Deferred.t
-val is_empty : t -> bool Deferred.t
val to_string : t -> string Deferred.t
val to_string_list : t -> string list Deferred.t
val to_pipe : t -> string Pipe.Reader.t
val map : t -> f:(string -> string) -> t
val as_pipe : t -> f:(string Pipe.Reader.t -> string Pipe.Reader.t) -> t
val to_form : t -> (string * string list) list Deferred.t
+val is_empty : t -> [ `True | `False | `Unknown ]
+
+module Private : sig
+ val write_body :
+ ('a -> string -> unit Deferred.t) -> t -> 'a -> unit Deferred.t
+
+ val pipe_of_body :
+ ('a -> Cohttp.Transfer.chunk Deferred.t) -> 'a -> string Pipe.Reader.t
+
+ val disable_chunked_encoding : t -> (t * int64) Deferred.t
+ val drain : t -> unit Deferred.t
+end
+++ /dev/null
-open Base
-open Async_kernel
-module B = Cohttp.Body
-
-type t = [ B.t | `Pipe of string Pipe.Reader.t ] [@@deriving sexp_of]
-
-let empty = `Empty
-let of_string s = (B.of_string s :> t)
-let of_pipe p = `Pipe p
-
-let to_string = function
- | #B.t as body -> return (B.to_string body)
- | `Pipe s -> Pipe.to_list s >>| String.concat
-
-let to_string_list = function
- | #B.t as body -> return (B.to_string_list body)
- | `Pipe s -> Pipe.to_list s
-
-let drain = function #B.t -> return () | `Pipe p -> Pipe.drain p
-
-let is_empty (body : t) =
- match body with
- | #B.t as body -> return (B.is_empty body)
- | `Pipe pipe -> (
- Deferred.repeat_until_finished () @@ fun () ->
- Pipe.values_available pipe >>= function
- | `Eof -> return (`Finished true)
- | `Ok -> (
- match Pipe.peek pipe with
- | None -> return (`Finished true)
- | Some "" -> (
- Pipe.read pipe >>| function
- | `Eof -> `Finished true
- | `Ok _ -> `Repeat ())
- | Some _ -> return (`Finished false)))
-
-let to_pipe = function
- | `Empty -> Pipe.of_list []
- | `String s -> Pipe.singleton s
- | `Strings sl -> Pipe.of_list sl
- | `Pipe p -> p
-
-let disable_chunked_encoding = function
- | #B.t as body -> return (body, B.length body)
- | `Pipe s ->
- Pipe.to_list s >>| fun l ->
- let body = `Strings l in
- let len = B.length body in
- (body, len)
-
-let transfer_encoding = function
- | #B.t as t -> B.transfer_encoding t
- | `Pipe _ -> Cohttp.Transfer.Chunked
-
-let of_string_list strings = `Pipe (Pipe.of_list strings)
-
-let map t ~f =
- match t with
- | #B.t as t -> (B.map f t :> t)
- | `Pipe p -> `Pipe (Pipe.map p ~f)
-
-let as_pipe t ~f = `Pipe (t |> to_pipe |> f)
-let to_form t = to_string t >>| Uri.query_of_encoded
-let of_form ?scheme f = Uri.encoded_of_query ?scheme f |> of_string
-
-let write_body write_body (body : t) writer =
- match body with
- | `Empty -> return ()
- | `String s -> write_body writer s
- | `Strings sl -> Deferred.List.iter ~how:`Sequential sl ~f:(write_body writer)
- | `Pipe p -> Pipe.iter p ~f:(write_body writer)
-
-let pipe_of_body read_chunk ic =
- let open Cohttp.Transfer in
- Pipe.create_reader ~close_on_exception:false (fun writer ->
- Deferred.repeat_until_finished () (fun () ->
- read_chunk ic >>= function
- | Chunk buf ->
- (* Even if [writer] has been closed, the loop must continue reading
- * from the input channel to ensure that it is left in a proper state
- * for the next request to be processed (in the case of keep-alive).
- *
- * The only case where [writer] will be closed is when
- * [Pipe.close_read] has been called on its read end. This could be
- * done by a request handler to signal that it does not need to
- * inspect the remainder of the body to fulfill the request.
- *)
- Pipe.write_when_ready writer ~f:(fun write -> write buf)
- >>| fun _ -> `Repeat ()
- | Final_chunk buf ->
- Pipe.write_when_ready writer ~f:(fun write -> write buf)
- >>| fun _ -> `Finished ()
- | Done -> return (`Finished ())))
open Async_kernel
open Async_unix
-module Request = struct
- include Cohttp.Request
- include (Make (Io) : module type of Make (Io) with type t := t)
- end
-
-module Response = struct
- include Cohttp.Response
- include (Make (Io) : module type of Make (Io) with type t := t)
- end
-
module Net = struct
let lookup uri =
let host = Uri.host_with_default ~default:"localhost" uri in
let config = Conduit_async.V2.Ssl.Config.create ~hostname:host () in
`OpenSSL (addr, port, config)
| _ -> `TCP (addr, port)))
- >>= fun mode -> Conduit_async.V2.connect ?interrupt mode
+ >>= fun mode ->
+ Conduit_async.V2.connect ?interrupt mode >>| fun (r, w) ->
+ (Input_channel.create r, w)
end
let read_response ic =
- Response.read ic >>| function
+ Io.Response.read ic >>| function
| `Eof -> failwith "Connection closed by remote host"
| `Invalid reason -> failwith reason
| `Ok res -> (
- match Response.has_body res with
+ match Cohttp.Response.has_body res with
| `Yes | `Unknown ->
(* Build a response pipe for the body *)
- let reader = Response.make_body_reader res ic in
- let pipe = Body_raw.pipe_of_body Response.read_body_chunk reader in
+ let reader = Io.Response.make_body_reader res ic in
+ let pipe =
+ Body.Private.pipe_of_body Io.Response.read_body_chunk reader
+ in
(res, pipe)
| `No ->
let pipe = Pipe.of_list [] in
let request ?interrupt ?ssl_config ?uri ?(body = `Empty) req =
(* Connect to the remote side *)
- let uri = match uri with Some t -> t | None -> Request.uri req in
+ let uri = match uri with Some t -> t | None -> Cohttp.Request.uri req in
Net.connect_uri ?interrupt ?ssl_config uri >>= fun (ic, oc) ->
try_with (fun () ->
- Request.write
- (fun writer -> Body_raw.write_body Request.write_body body writer)
+ Io.Request.write ~flush:false
+ (fun writer ->
+ Body.Private.write_body Io.Request.write_body body writer)
req oc
>>= fun () ->
read_response ic >>| fun (resp, body) ->
don't_wait_for
( Pipe.closed body >>= fun () ->
- Deferred.all_unit [ Reader.close ic; Writer.close oc ] );
+ Deferred.all_unit [ Input_channel.close ic; Writer.close oc ] );
(resp, `Pipe body))
>>= function
| Ok res -> return res
| Error e ->
- don't_wait_for (Reader.close ic);
+ don't_wait_for (Input_channel.close ic);
don't_wait_for (Writer.close oc);
raise e
module Connection = struct
- type t' = { ic : Reader.t; oc : Writer.t }
+ type t' = { ic : Input_channel.t; oc : Writer.t }
(* we can't send concurrent requests over HTTP/1 *)
type t = t' Sequencer.t
Net.connect_uri ?interrupt ?ssl_config uri >>| fun (ic, oc) ->
let t = { ic; oc } |> Sequencer.create ~continue_on_error:false in
Throttle.at_kill t (fun { ic; oc } ->
- Deferred.both (Writer.close oc) (Reader.close ic) >>| fun ((), ()) -> ());
- Deferred.any [ Writer.consumer_left oc; Reader.close_finished ic ]
+ Deferred.both (Writer.close oc) (Input_channel.close ic)
+ >>| fun ((), ()) -> ());
+ Deferred.any [ Writer.consumer_left oc; Input_channel.close_finished ic ]
>>| (fun () -> Throttle.kill t)
|> don't_wait_for;
t
Throttle.kill t;
Throttle.cleaned t
+ let close_finished t = Throttle.cleaned t
let is_closed t = Throttle.is_dead t
let request ?(body = Body.empty) t req =
let res = Ivar.create () in
Throttle.enqueue t (fun { ic; oc } ->
- Request.write
- (fun writer -> Body_raw.write_body Request.write_body body writer)
+ Io.Request.write ~flush:false
+ (fun writer ->
+ Body.Private.write_body Io.Request.write_body body writer)
req oc
>>= fun () ->
read_response ic >>= fun (resp, body) ->
- Ivar.fill res (resp, `Pipe body);
+ Ivar.fill_exn res (resp, `Pipe body);
(* block starting any more requests until the consumer has finished reading this request *)
Pipe.closed body)
|> don't_wait_for;
transfer encoding *)
(match chunked with
| false ->
- Body_raw.disable_chunked_encoding body >>| fun (body, body_length) ->
- (Request.make_for_client ?headers ~chunked ~body_length meth uri, body)
- | true -> (
- Body.is_empty body >>| function
- | true ->
- (* Don't used chunked encoding with an empty body *)
- ( Request.make_for_client ?headers ~chunked:false ~body_length:0L meth
- uri,
- body )
- | false ->
- (* Use chunked encoding if there is a body *)
- (Request.make_for_client ?headers ~chunked:true meth uri, body)))
+ Body.Private.disable_chunked_encoding body >>| fun (body, body_length) ->
+ ( Cohttp.Request.make_for_client ?headers ~chunked ~body_length meth uri,
+ body )
+ | true ->
+ Deferred.return
+ (match Body.is_empty body with
+ | `True ->
+ (* Don't used chunked encoding with an empty body *)
+ ( Cohttp.Request.make_for_client ?headers ~chunked:false
+ ~body_length:0L meth uri,
+ body )
+ | `Unknown | `False ->
+ (* Use chunked encoding if there is a body *)
+ ( Cohttp.Request.make_for_client ?headers ~chunked:true meth uri,
+ body )))
>>= fun (req, body) -> request ?interrupt ?ssl_config ~body ~uri req
let get ?interrupt ?ssl_config ?headers uri =
?ssl_config:Conduit_async.V2.Ssl.Config.t ->
?uri:Uri.t ->
?body:Body.t ->
- Cohttp.Request.t ->
- (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t
+ Http.Request.t ->
+ (Http.Response.t * Body.t) Async_kernel.Deferred.t
(** Send an HTTP request with an arbitrary body The request is sent as-is. *)
val call :
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.V2.Ssl.Config.t ->
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
?chunked:bool ->
?body:Body.t ->
- Cohttp.Code.meth ->
+ Http.Method.t ->
Uri.t ->
- (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t
+ (Http.Response.t * Body.t) Async_kernel.Deferred.t
(** Send an HTTP request with arbitrary method and a body Infers the transfer
encoding. Depending on the given [uri], we choose a way to start a
communication such as:
t Async_kernel.Deferred.t
val close : t -> unit Async_kernel.Deferred.t
+ val close_finished : t -> unit Async_kernel.Deferred.t
val is_closed : t -> bool
val request :
?body:Body.t ->
t ->
- Cohttp.Request.t ->
- (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t
+ Http.Request.t ->
+ (Http.Response.t * Body.t) Async_kernel.Deferred.t
end
val callv :
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.V2.Ssl.Config.t ->
Uri.t ->
- (Cohttp.Request.t * Body.t) Async_kernel.Pipe.Reader.t ->
- (Cohttp.Response.t * Body.t) Async_kernel.Pipe.Reader.t
- Async_kernel.Deferred.t
+ (Http.Request.t * Body.t) Async_kernel.Pipe.Reader.t ->
+ (Http.Response.t * Body.t) Async_kernel.Pipe.Reader.t Async_kernel.Deferred.t
val get :
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.V2.Ssl.Config.t ->
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
Uri.t ->
- (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t
+ (Http.Response.t * Body.t) Async_kernel.Deferred.t
(** Send an HTTP GET request *)
val head :
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.V2.Ssl.Config.t ->
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
Uri.t ->
- Cohttp.Response.t Async_kernel.Deferred.t
+ Http.Response.t Async_kernel.Deferred.t
(** Send an HTTP HEAD request *)
val delete :
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.V2.Ssl.Config.t ->
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
?chunked:bool ->
?body:Body.t ->
Uri.t ->
- (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t
+ (Http.Response.t * Body.t) Async_kernel.Deferred.t
(** Send an HTTP DELETE request *)
val post :
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.V2.Ssl.Config.t ->
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
?chunked:bool ->
?body:Body.t ->
Uri.t ->
- (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t
+ (Http.Response.t * Body.t) Async_kernel.Deferred.t
(** Send an HTTP POST request. [chunked] encoding is off by default as not many
servers support it *)
val put :
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.V2.Ssl.Config.t ->
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
?chunked:bool ->
?body:Body.t ->
Uri.t ->
- (Response.t * Body.t) Async_kernel.Deferred.t
+ (Http.Response.t * Body.t) Async_kernel.Deferred.t
(** Send an HTTP PUT request. [chunked] encoding is off by default as not many
servers support it *)
val patch :
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.V2.Ssl.Config.t ->
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
?chunked:bool ->
?body:Body.t ->
Uri.t ->
- (Response.t * Body.t) Async_kernel.Deferred.t
+ (Http.Response.t * Body.t) Async_kernel.Deferred.t
(** Send an HTTP PATCH request. [chunked] encoding is off by default as not many
servers support it *)
val post_form :
?interrupt:unit Async_kernel.Deferred.t ->
?ssl_config:Conduit_async.V2.Ssl.Config.t ->
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
params:(string * string list) list ->
Uri.t ->
- (Response.t * Body.t) Async_kernel.Deferred.t
+ (Http.Response.t * Body.t) Async_kernel.Deferred.t
(** Send an HTTP POST request in form format *)
--- /dev/null
+module Body = Body
+module Body_raw = Body [@@deprecated "Use Body"]
+module Client = Client
+module Io = Io [@@deprecated "This module is not for public consumption"]
+module Request = Cohttp.Request [@@deprecated "Use Cohttp.Request directly"]
+module Response = Cohttp.Response [@@deprecated "Use Cohttp.Response directly"]
+module Server = Server
(name cohttp_async)
(synopsis "Async backend")
(public_name cohttp-async)
- (libraries logs.fmt base fmt async_unix async_kernel uri uri.services
- uri-sexp ipaddr.unix conduit-async magic-mime cohttp)
+ (libraries
+ logs.fmt
+ base
+ fmt
+ async_unix
+ async_kernel
+ uri
+ uri.services
+ uri-sexp
+ ipaddr.unix
+ conduit-async
+ magic-mime
+ http
+ http_bytebuffer
+ cohttp)
(preprocess
(pps ppx_sexp_conv)))
--- /dev/null
+open! Core
+open! Async
+
+module Bytebuffer = struct
+ module Bytebuffer = Http_bytebuffer.Bytebuffer
+ include Bytebuffer
+
+ include
+ Bytebuffer.Make
+ (Deferred)
+ (struct
+ type src = Reader.t
+
+ let refill reader buf ~pos ~len = Reader.read reader ~pos ~len buf
+ end)
+end
+
+type t = { buf : Bytebuffer.t; reader : Reader.t }
+
+let create ?(buf_len = 0x4000) reader =
+ { buf = Bytebuffer.create buf_len; reader }
+
+let read_line_opt t = Bytebuffer.read_line t.buf t.reader
+let read t count = Bytebuffer.read t.buf t.reader count
+let refill t = Bytebuffer.refill t.buf t.reader
+
+let with_input_buffer t ~f =
+ let buf = Bytebuffer.unsafe_buf t.buf in
+ let pos = Bytebuffer.pos t.buf in
+ let len = Bytebuffer.length t.buf in
+ let res, consumed =
+ f (Bytes.unsafe_to_string ~no_mutation_while_string_reachable:buf) ~pos ~len
+ in
+ Bytebuffer.drop t.buf consumed;
+ res
+
+let is_closed t = Reader.is_closed t.reader
+let close t = Reader.close t.reader
+let close_finished t = Reader.close_finished t.reader
+
+let transfer t writer =
+ let finished = Ivar.create () in
+ upon (Pipe.closed writer) (fun () -> Ivar.fill_if_empty finished ());
+ let rec loop () =
+ refill t >>> function
+ | `Eof -> Ivar.fill_if_empty finished ()
+ | `Ok ->
+ let payload =
+ with_input_buffer t ~f:(fun buf ~pos ~len ->
+ (String.sub buf ~pos ~len, len))
+ in
+ Pipe.write writer payload >>> fun () -> loop ()
+ in
+ loop ();
+ Ivar.read finished
+
+let to_reader info ic =
+ let reader, writer = Pipe.create () in
+ ( transfer ic writer >>> fun () ->
+ close ic >>> fun () -> Pipe.close writer );
+ Reader.of_pipe info reader
--- /dev/null
+open Async
+
+type t
+
+val create : ?buf_len:int -> Reader.t -> t
+val read_line_opt : t -> string option Deferred.t
+val read : t -> int -> string Deferred.t
+val refill : t -> [ `Eof | `Ok ] Deferred.t
+val with_input_buffer : t -> f:(string -> pos:int -> len:int -> 'a * int) -> 'a
+val is_closed : t -> bool
+val close : t -> unit Deferred.t
+val close_finished : t -> unit Deferred.t
+val to_reader : Base.Info.t -> t -> Reader.t Deferred.t
open Base
open Async_kernel
-module Writer = Async_unix.Writer
-module Reader = Async_unix.Reader
-module Format = Stdlib.Format
-let log_src_name = "cohttp.async.io"
-let src = Logs.Src.create log_src_name ~doc:"Cohttp Async IO module"
+module IO = struct
+ module Writer = Async_unix.Writer
+ module Reader = Async_unix.Reader
+ module Format = Stdlib.Format
-module Log = (val Logs.src_log src : Logs.LOG)
+ let log_src_name = "cohttp.async.io"
+ let src = Logs.Src.create log_src_name ~doc:"Cohttp Async IO module"
-let default_reporter () =
- let fmtr, fmtr_flush =
- let b = Buffer.create 512 in
- ( Fmt.with_buffer ~like:Fmt.stderr b,
- fun () ->
- let m = Buffer.contents b in
- Buffer.reset b;
- m )
- in
- let report src _level ~over k msgf =
- let k _ =
- if String.equal (Logs.Src.name src) log_src_name then
- Writer.write (Lazy.force Writer.stderr) (fmtr_flush ());
- over ();
- k ()
+ module Log = (val Logs.src_log src : Logs.LOG)
+
+ let default_reporter () =
+ let fmtr, fmtr_flush =
+ let b = Buffer.create 512 in
+ ( Fmt.with_buffer ~like:Fmt.stderr b,
+ fun () ->
+ let m = Buffer.contents b in
+ Buffer.reset b;
+ m )
+ in
+ let report src _level ~over k msgf =
+ let k _ =
+ if String.equal (Logs.Src.name src) log_src_name then
+ Writer.write (Lazy.force Writer.stderr) (fmtr_flush ());
+ over ();
+ k ()
+ in
+ msgf @@ fun ?header:_ ?tags:_ fmt ->
+ Format.kfprintf k fmtr Stdlib.("@[" ^^ fmt ^^ "@]@.")
in
- msgf @@ fun ?header:_ ?tags:_ fmt ->
- Format.kfprintf k fmtr Stdlib.("@[" ^^ fmt ^^ "@]@.")
- in
- { Logs.report }
+ { Logs.report }
+
+ let set_log =
+ lazy
+ ((* If no reporter has been set by the application, set default one
+ that prints to stderr. This way a user will see logs when the debug
+ flag is set without adding a reporter. *)
+ if phys_equal (Logs.reporter ()) Logs.nop_reporter then
+ Logs.set_level @@ Some Logs.Debug;
+ Logs.set_reporter (default_reporter ()))
-let set_log =
- lazy
- ((* If no reporter has been set by the application, set default one
- that prints to stderr. This way a user will see logs when the debug
- flag is set without adding a reporter. *)
- if phys_equal (Logs.reporter ()) Logs.nop_reporter then
- Logs.set_level @@ Some Logs.Debug;
- Logs.set_reporter (default_reporter ()))
+ let check_debug norm_fn debug_fn =
+ match Stdlib.Sys.getenv "COHTTP_DEBUG" with
+ | _ ->
+ Lazy.force set_log;
+ debug_fn
+ | exception Stdlib.Not_found -> norm_fn
-let check_debug norm_fn debug_fn =
- match Stdlib.Sys.getenv "COHTTP_DEBUG" with
- | _ ->
- Lazy.force set_log;
- debug_fn
- | exception Stdlib.Not_found -> norm_fn
+ type 'a t = 'a Deferred.t
-type 'a t = 'a Deferred.t
+ let ( >>= ) = Deferred.( >>= )
+ let return = Deferred.return
-let ( >>= ) = Deferred.( >>= )
-let return = Deferred.return
+ type ic = Input_channel.t
+ type oc = Writer.t
+ type conn = unit
-type ic = Reader.t
-type oc = Writer.t
-type conn = unit
+ let read_line =
+ check_debug
+ (fun ic -> Input_channel.read_line_opt ic)
+ (fun ic ->
+ Input_channel.read_line_opt ic >>| function
+ | Some s ->
+ Log.debug (fun fmt -> fmt "<<< %s" s);
+ Some s
+ | None ->
+ Log.debug (fun fmt -> fmt "<<<EOF");
+ None)
-let read_line =
- check_debug
- (fun ic ->
- Reader.read_line ic >>| function `Ok s -> Some s | `Eof -> None)
- (fun ic ->
- Reader.read_line ic >>| function
- | `Ok s ->
- Log.debug (fun fmt -> fmt "<<< %s" s);
- Some s
- | `Eof ->
- Log.debug (fun fmt -> fmt "<<<EOF");
- None)
+ let read ic len = Input_channel.read ic len
-let read ic len =
- let buf = Bytes.create len in
- Reader.read ic ~len buf >>| function
- | `Ok len' -> Bytes.To_string.sub buf ~pos:0 ~len:len'
- | `Eof -> ""
+ let write =
+ check_debug
+ (fun oc buf ->
+ Writer.write oc buf;
+ return ())
+ (fun oc buf ->
+ Log.debug (fun fmt -> fmt "%4d >>> %s" (Unix.getpid ()) buf);
+ Writer.write oc buf;
+ return ())
-let write =
- check_debug
- (fun oc buf ->
- Writer.write oc buf;
- return ())
- (fun oc buf ->
- Log.debug (fun fmt -> fmt "%4d >>> %s" (Unix.getpid ()) buf);
- Writer.write oc buf;
- return ())
+ let refill ic = Input_channel.refill ic
+ let with_input_buffer ic = Input_channel.with_input_buffer ic
+ let flush = Writer.flushed
+end
-let flush = Writer.flushed
+module Request = Cohttp.Request.Private.Make (IO)
+module Response = Cohttp.Response.Private.Make (IO)
* PERFORMANCE OF THIS SOFTWARE.
}}}*)
-include
+module IO :
Cohttp.S.IO
with type 'a t = 'a Async_kernel.Deferred.t
- and type ic = Async_unix.Reader.t
+ and type ic = Input_channel.t
and type oc = Async_unix.Writer.t
+
+module Request :
+ Cohttp.S.Http_io with type t := Http.Request.t and module IO := IO
+
+module Response :
+ Cohttp.S.Http_io with type t := Http.Response.t and module IO := IO
+++ /dev/null
-include Cohttp.Request
+++ /dev/null
-include Cohttp.S.Request with type t = Cohttp.Request.t
+++ /dev/null
-include Cohttp.Response
+++ /dev/null
-include Cohttp.S.Response with type t = Cohttp.Response.t
open Async_kernel
open Async_unix
-module Request = struct
- include Cohttp.Request
- include (Make (Io) : module type of Make (Io) with type t := t)
- end
-
-module Response = struct
- include Cohttp.Response
- include (Make (Io) : module type of Make (Io) with type t := t)
- end
-
type ('address, 'listening_on) t = {
server : ('address, 'listening_on) Tcp.Server.t; [@sexp.opaque]
}
[@@deriving sexp_of]
-type response = Response.t * Body.t [@@deriving sexp_of]
+let num_connections t = Tcp.Server.num_connections t.server
+
+type response = Cohttp.Response.t * Body.t [@@deriving sexp_of]
type response_action =
- [ `Expert of Cohttp.Response.t * (Io.ic -> Io.oc -> unit Deferred.t)
+ [ `Expert of Http.Response.t * (Reader.t -> Writer.t -> unit Deferred.t)
| `Response of response ]
type 'r respond_t =
- ?flush:bool ->
- ?headers:Cohttp.Header.t ->
- ?body:Body.t ->
- Cohttp.Code.status_code ->
- 'r Deferred.t
+ ?headers:Http.Header.t -> ?body:Body.t -> Http.Status.t -> 'r Deferred.t
let close t = Tcp.Server.close t.server
let close_finished t = Tcp.Server.close_finished t.server
let listening_on t = Tcp.Server.listening_on t.server
let read_body req rd =
- match Request.has_body req with
+ match Http.Request.has_body req with
(* TODO maybe attempt to read body *)
- | `No | `Unknown -> (`Empty, Deferred.unit)
+ | `No | `Unknown -> `Empty
| `Yes ->
(* Create a Pipe for the body *)
- let reader = Request.make_body_reader req rd in
- let pipe = Body_raw.pipe_of_body Request.read_body_chunk reader in
- (`Pipe pipe, Pipe.closed pipe)
+ let reader = Io.Request.make_body_reader req rd in
+ let pipe = Body.Private.pipe_of_body Io.Request.read_body_chunk reader in
+ `Pipe pipe
let collect_errors writer ~f =
let monitor = Writer.monitor writer in
choice (try_with ~name:"Cohttp_async.Server.collect_errors" f) Fn.id;
]
+let reader_info = Info.of_string "Cohttp_async.Server.Expert: Create reader"
+
let handle_client handle_request sock rd wr =
collect_errors wr ~f:(fun () ->
- let last_body_pipe_drained = ref Deferred.unit in
- let requests_pipe =
- Reader.read_all rd (fun rd ->
- !last_body_pipe_drained >>= fun () ->
- (* [`Expert] responses may close the [Reader.t] *)
- if Reader.is_closed rd then return `Eof
- else
- Request.read rd >>= function
- | `Eof | `Invalid _ -> return `Eof
- | `Ok req -> (
- let body, finished = read_body req rd in
- handle_request ~body sock req >>| function
- | `Expert (headers, io_handler) ->
- let expert_finished = Ivar.create () in
- last_body_pipe_drained :=
- Deferred.all_unit
- [ Ivar.read expert_finished; finished ];
- `Ok (`Expert (headers, io_handler, body, expert_finished))
- | `Response r ->
- last_body_pipe_drained := finished;
- `Ok (`Response (req, body, r))))
+ let rd = Input_channel.create rd in
+ let rec loop rd wr sock handle_request =
+ if Input_channel.is_closed rd then Deferred.unit
+ else
+ Io.Request.read rd >>= function
+ | `Eof | `Invalid _ -> Deferred.unit
+ | `Ok req -> (
+ let req_body = read_body req rd in
+ handle_request ~body:req_body sock req >>= function
+ | `Expert (res, handler) ->
+ Io.Response.write_header res wr >>= fun () ->
+ Input_channel.to_reader reader_info rd >>= fun reader ->
+ handler reader wr
+ | `Response (res, res_body) ->
+ (* There are scenarios if a client leaves before consuming the full response,
+ we might have a reference to an async Pipe that doesn't get drained.
+
+ Not draining or closing a pipe can lead to issues if its holding a resource like
+ a file handle as those resources will never be closed, leading to a leak.
+
+ Async writers have a promise that's fulfilled whenever they are closed,
+ so we can use it to schedule a close operation on the stream to ensure that we
+ don't leave a stream open if the underlying channels are closed. *)
+ (match res_body with
+ | `Empty | `String _ | `Strings _ -> ()
+ | `Pipe stream ->
+ Deferred.any_unit
+ [ Writer.close_finished wr; Writer.consumer_left wr ]
+ >>> fun () -> Pipe.close_read stream);
+ let keep_alive =
+ Http.Request.is_keep_alive req
+ && Http.Response.is_keep_alive res
+ in
+ let res =
+ let headers =
+ Http.Header.add_unless_exists
+ (Http.Response.headers res)
+ "connection"
+ (if keep_alive then "keep-alive" else "close")
+ in
+ { res with Http.Response.headers }
+ in
+ Io.Response.write ~flush:false
+ (Body.Private.write_body Io.Response.write_body res_body)
+ res wr
+ >>= fun () ->
+ Body.Private.drain req_body >>= fun () ->
+ if keep_alive then loop rd wr sock handle_request
+ else Deferred.unit)
in
- Pipe.iter ~continue_on_error:false requests_pipe ~f:(function
- | `Expert (response, io_handler, body, finished) ->
- Response.write_header response wr >>= fun () ->
- io_handler rd wr >>= fun () ->
- Body.drain body >>| fun () -> Ivar.fill_if_empty finished ()
- | `Response (req, body, (res, res_body)) ->
- (* There are scenarios if a client leaves before consuming the full response,
- we might have a reference to an async Pipe that doesn't get drained.
-
- Not draining or closing a pipe can lead to issues if its holding a resource like
- a file handle as those resources will never be closed, leading to a leak.
-
- Async writers have a promise that's fulfilled whenever they are closed,
- so we can use it to schedule a close operation on the stream to ensure that we
- don't leave a stream open if the underlying channels are closed. *)
- (match res_body with
- | `Empty | `String _ | `Strings _ -> ()
- | `Pipe stream ->
- Deferred.any_unit
- [ Writer.close_finished wr; Writer.consumer_left wr ]
- >>> fun () -> Pipe.close_read stream);
- let keep_alive = Request.is_keep_alive req in
- let flush = Response.flush res in
- let res =
- let headers =
- Cohttp.Header.add_unless_exists
- (Cohttp.Response.headers res)
- "connection"
- (if keep_alive then "keep-alive" else "close")
- in
- { res with Response.headers }
- in
- Response.write ~flush
- (Body_raw.write_body Response.write_body res_body)
- res wr
- >>= fun () ->
- Writer.(if keep_alive then flushed else close ?force_close:None) wr
- >>= fun () -> Body.drain body))
- >>= fun res ->
- Writer.close wr >>= fun () ->
- Reader.close rd >>| fun () -> Result.ok_exn res
-
-let respond ?(flush = true) ?(headers = Cohttp.Header.init ()) ?(body = `Empty)
- status : response Deferred.t =
+ loop rd wr sock handle_request)
+ >>| Result.ok_exn
+
+let respond ?(headers = Http.Header.init ()) ?(body = `Empty) status :
+ response Deferred.t =
let encoding = Body.transfer_encoding body in
- let resp = Response.make ~status ~flush ~encoding ~headers () in
+ let resp = Cohttp.Response.make ~status ~encoding ~headers () in
return (resp, body)
-let respond_with_pipe ?flush ?headers ?(code = `OK) body =
- respond ?flush ?headers ~body:(`Pipe body) code
+let respond_with_pipe ?headers ?(code = `OK) body =
+ respond ?headers ~body:(`Pipe body) code
-let respond_string ?flush ?headers ?(status = `OK) body =
- respond ?flush ?headers ~body:(`String body) status
+let respond_string ?headers ?(status = `OK) body =
+ respond ?headers ~body:(`String body) status
let respond_with_redirect ?headers uri =
let headers =
- Cohttp.Header.add_opt_unless_exists headers "location" (Uri.to_string uri)
+ Http.Header.add_opt_unless_exists headers "location" (Uri.to_string uri)
in
- respond ~flush:false ~headers `Found
+ respond ~headers `Found
-(* Deprecated *)
let resolve_local_file ~docroot ~uri =
Cohttp.Path.resolve_local_file ~docroot ~uri
let error_body_default = "<html><body><h1>404 Not Found</h1></body></html>"
-let respond_with_file ?flush ?headers ?(error_body = error_body_default)
- filename =
+let respond_with_file ?headers ?(error_body = error_body_default) filename =
Monitor.try_with ~run:`Now (fun () ->
Reader.open_file filename >>= fun rd ->
let body = `Pipe (Reader.pipe rd) in
let mime_type = Magic_mime.lookup filename in
let headers =
- Cohttp.Header.add_opt_unless_exists headers "content-type" mime_type
+ Http.Header.add_opt_unless_exists headers "content-type" mime_type
in
- respond ?flush ~headers ~body `OK)
+ respond ~headers ~body `OK)
>>= function
| Ok res -> return res
| Error _exn -> respond_string ~status:`Not_found error_body
in
create_raw ?max_connections ?backlog ?buffer_age_limit ~on_handler_error ~mode
where_to_listen handle_request
+
+module Expert = struct
+ let create handle_request addr reader writer =
+ let handle_request ~body addr request =
+ handle_request ~body addr request >>| fun r -> `Response r
+ in
+ handle_client handle_request addr reader writer
+
+ let create_with_response_action handle_request addr reader writer =
+ handle_client handle_request addr reader writer
+end
val close_finished : (_, _) t -> unit Async_kernel.Deferred.t
val is_closed : (_, _) t -> bool
val listening_on : (_, 'listening_on) t -> 'listening_on
+val num_connections : (_, _) t -> int
-type response = Response.t * Body.t [@@deriving sexp_of]
+type response = Http.Response.t * Body.t [@@deriving sexp_of]
type 'r respond_t =
- ?flush:bool ->
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
?body:Body.t ->
- Cohttp.Code.status_code ->
+ Http.Status.t ->
'r Async_kernel.Deferred.t
type response_action =
[ `Expert of
- Cohttp.Response.t
+ Http.Response.t
* (Async_unix.Reader.t ->
Async_unix.Writer.t ->
unit Async_kernel.Deferred.t)
| `Response of response ]
(** A request handler can respond in two ways:
- - Using [`Response], with a {!Response.t} and a {!Body.t}.
- - Using [`Expert], with a {!Response.t} and an IO function that is expected
- to write the response body. The IO function has access to the underlying
- {!Async_unix.Reader.t} and {!Async_unix.Writer.t}, which allows writing a
- response body more efficiently, stream a response or to switch protocols
- entirely (e.g. websockets). Processing of pipelined requests continue
- after the {!unit Async_kernel.Deferred.t} is resolved. The connection can
- be closed by closing the {!Async_unix.Reader.t}. *)
+ - Using [`Response], with a {!Http.Response.t} and a {!Body.t}.
+ - Using [`Expert], with a {!Http.Response.t} and an IO function that is
+ expected to write the response body. The IO function has access to the
+ underlying {!Async_unix.Reader.t} and {!Async_unix.Writer.t}, which allows
+ writing a response body more efficiently, stream a response or to switch
+ protocols entirely (e.g. websockets). Processing of pipelined requests
+ continue after the [unit Async_kernel.Deferred.t] is resolved. The
+ connection can be closed by closing the {!Async_unix.Reader.t}. *)
val respond : response respond_t
val resolve_local_file : docroot:string -> uri:Uri.t -> string
-(** Resolve a URI and a docroot into a concrete local filename.
-
- Deprecated. Please use Cohttp.Path.resolve_local_file. *)
+[@@deprecated "Please use Cohttp.Path.resolve_local_file. "]
+(** Resolve a URI and a docroot into a concrete local filename. *)
val respond_with_pipe :
- ?flush:bool ->
- ?headers:Cohttp.Header.t ->
- ?code:Cohttp.Code.status_code ->
+ ?headers:Http.Header.t ->
+ ?code:Http.Status.t ->
string Async_kernel.Pipe.Reader.t ->
response Async_kernel.Deferred.t
(** Respond with a [string] Pipe that provides the response string
@param code Default is HTTP 200 `OK *)
val respond_string :
- ?flush:bool ->
- ?headers:Cohttp.Header.t ->
- ?status:Cohttp.Code.status_code ->
+ ?headers:Http.Header.t ->
+ ?status:Http.Status.t ->
string ->
response Async_kernel.Deferred.t
val respond_with_redirect :
- ?headers:Cohttp.Header.t -> Uri.t -> response Async_kernel.Deferred.t
+ ?headers:Http.Header.t -> Uri.t -> response Async_kernel.Deferred.t
(** Respond with a redirect to an absolute [uri]
@param uri Absolute URI to redirect the client to *)
val respond_with_file :
- ?flush:bool ->
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
?error_body:string ->
string ->
response Async_kernel.Deferred.t
('address, 'listening_on) Async.Tcp.Where_to_listen.t ->
(body:Body.t ->
'address ->
- Request.t ->
+ Http.Request.t ->
response_action Async_kernel.Deferred.t) ->
('address, 'listening_on) t Async_kernel.Deferred.t
(** Build a HTTP server and expose the [IO.ic] and [IO.oc]s, based on the
?mode:Conduit_async.server ->
on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ] ->
('address, 'listening_on) Async.Tcp.Where_to_listen.t ->
- (body:Body.t -> 'address -> Request.t -> response Async_kernel.Deferred.t) ->
+ (body:Body.t ->
+ 'address ->
+ Http.Request.t ->
+ response Async_kernel.Deferred.t) ->
('address, 'listening_on) t Async_kernel.Deferred.t
(** Build a HTTP server, based on the [Tcp.Server] interface *)
+
+module Expert : sig
+ val create :
+ (body:Body.t -> 'addr -> Http.Request.t -> response Async_kernel.Deferred.t) ->
+ 'addr ->
+ Async_unix.Reader.t ->
+ Async_unix.Writer.t ->
+ unit Async_kernel.Deferred.t
+ (** [create] accepts a user provided cohttp handler, and creates a server
+ callback that works with user provided socket address,
+ [Async_unix.Reader.t] and [Async_unix.Writer.t]. This can be useful if
+ there is a need for more control over how the Reader and Writer get
+ created. *)
+
+ val create_with_response_action :
+ (body:Body.t ->
+ 'addr ->
+ Http.Request.t ->
+ response_action Async_kernel.Deferred.t) ->
+ 'addr ->
+ Async_unix.Reader.t ->
+ Async_unix.Writer.t ->
+ unit Async_kernel.Deferred.t
+ (** [create_with_response_action] is similar to [create] but the user provided
+ handler can use [Cohttp_async.Server.response_action], and has access to
+ using the Expert mode response that can access the underlying
+ reader/writer pair from within the http handler. *)
+end
--- /dev/null
+open Base
+open Async_kernel
+open OUnit
+module Server = Cohttp_async.Server
+module Body = Cohttp_async.Body
+
+type 'a io = 'a Deferred.t
+type ic = Async_unix.Reader.t
+type oc = Async_unix.Writer.t
+type body = Body.t
+
+type response_action =
+ [ `Expert of Http.Response.t * (ic -> oc -> unit io)
+ | `Response of Http.Response.t * body ]
+
+type spec = Http.Request.t -> body -> response_action io
+type async_test = unit -> unit io
+
+let response rsp = `Response rsp
+
+let expert ?(rsp = Cohttp.Response.make ()) f _req _body =
+ return (`Expert (rsp, f))
+
+let const rsp _req _body = rsp >>| response
+let response_sequence = Cohttp_test.response_sequence failwith
+
+let get_port =
+ let port = ref 10_080 in
+ fun () ->
+ let v = !port in
+ Int.incr port;
+ v
+
+let temp_server ?port spec callback =
+ let port = match port with None -> get_port () | Some p -> p in
+ let uri = Uri.of_string ("http://0.0.0.0:" ^ Int.to_string port) in
+ let server =
+ Server.create_expert ~on_handler_error:`Raise
+ (Async.Tcp.Where_to_listen.of_port port) (fun ~body _sock req ->
+ spec req body)
+ in
+ server >>= fun server ->
+ callback uri >>= fun res ->
+ Server.close server >>| fun () -> res
+
+let test_server_s ?port ?(name = "Cohttp Server Test") spec f =
+ temp_server ?port spec (fun uri ->
+ Logs.info (fun m -> m "Test %s running on %s" name (Uri.to_string uri));
+ let tests = f uri in
+ let results =
+ tests
+ |> Deferred.List.map ~how:`Sequential ~f:(fun (name, test) ->
+ Logs.debug (fun m -> m "Running %s" name);
+ let res =
+ try_with test >>| function
+ | Ok () -> `Ok
+ | Error exn -> `Exn exn
+ in
+ res >>| fun res -> (name, res))
+ in
+ results >>| fun results ->
+ let ounit_tests =
+ results
+ |> List.map ~f:(fun (name, res) ->
+ name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x)
+ in
+ name >::: ounit_tests)
+
+let run_async_tests test =
+ (* enable logging to stdout *)
+ Fmt_tty.setup_std_outputs ();
+ Logs.set_level @@ Some Logs.Debug;
+ Logs.set_reporter (Logs_fmt.reporter ());
+ test >>| fun a -> a |> OUnit.run_test_tt_main
--- /dev/null
+open Async_kernel
+
+include
+ Cohttp_test.S
+ with type 'a io = 'a Deferred.t
+ and type body = Cohttp_async.Body.t
+ and type ic = Async_unix.Reader.t
+ and type oc = Async_unix.Writer.t
+
+val run_async_tests : OUnit.test io -> OUnit.test_result list Deferred.t
--- /dev/null
+(library
+ (name cohttp_async_test)
+ (libraries fmt.tty uri.services async_kernel cohttp_test cohttp-async))
(executable
(name test_async_integration)
- (libraries cohttp_async_test async_unix base core async_kernel oUnit
- cohttp-async))
+ (libraries
+ cohttp_async_test
+ async_unix
+ base
+ core
+ async_kernel
+ ounit2
+ cohttp-async))
(rule
(alias runtest)
open Async_kernel
open OUnit
open Cohttp
-open Cohttp_async
open Cohttp_async_test
+module Server = Cohttp_async.Server
+module Client = Cohttp_async.Client
+module Body = Cohttp_async.Body
let chunk_body = [ "one"; ""; " "; "bar"; "" ]
let large_string = String.make (Int.pow 2 16) 'A'
Body.to_string body >>| fun body ->
assert_equal ~printer "expert 2" body
in
- let check_body_empty_status () =
- let is_empty = Cohttp_async.Body.is_empty in
- let tests =
- [
- ("empty pipe", Pipe.of_list [], true);
- ("pipe with elements", Pipe.of_list [ "foo"; "bar" ], false);
- ( "pipe with empty items at the beginning",
- Pipe.of_list [ ""; "baz" ],
- false );
- ("Pipe with empty strings", Pipe.of_list [ ""; ""; "" ], true);
- ]
- in
- Deferred.List.iter ~how:`Sequential tests ~f:(fun (msg, pipe, expected) ->
- is_empty (`Pipe pipe) >>| fun real ->
- assert_equal ~msg expected real)
- >>= fun () ->
- let b = Pipe.of_list [ ""; ""; "foo"; "bar" ] in
- is_empty (`Pipe b) >>= fun _ ->
- Pipe.to_list b >>| fun real ->
- let msg =
- "Checking if pipe is empty consumes all leading empty strings"
- in
- assert_equal ~msg [ "foo"; "bar" ] real
- in
[
("empty chunk test", empty_chunk);
("large response", large_response);
("pipelined chunk test", pipelined_chunk);
("large chunked response", large_chunked_response);
("expert response", expert_pipelined);
- ("check body is_empty status for pipes", check_body_empty_status);
])
let () =
--- /dev/null
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Benchmarks binaries for Cohttp"
+description: """
+This package contains some benchmarks for http and cohttp.
+The benchmarks for the server latency will require wrk2
+(https://github.com/giltene/wrk2) to run. The latency graphs
+can then be generated with HdrHistogram plotter, also available
+online at https://hdrhistogram.github.io/HdrHistogram/plotFiles.html."""
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
+authors: [
+ "Anil Madhavapeddy"
+ "Stefano Zacchiroli"
+ "David Sheets"
+ "Thomas Gazagnaire"
+ "David Scott"
+ "Rudi Grinberg"
+ "Andy Ray"
+ "Anurag Soni"
+]
+license: "ISC"
+homepage: "https://github.com/mirage/ocaml-cohttp"
+doc: "https://mirage.github.io/ocaml-cohttp/"
+bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
+depends: [
+ "dune" {>= "3.8"}
+ "core" {>= "v0.13.0"}
+ "core_bench"
+ "eio" {>= "0.12"}
+ "eio_main"
+ "http" {= version}
+ "cohttp" {= version}
+ "cohttp-eio" {= version}
+ "cohttp-lwt-unix" {= version}
+ "cohttp-server-lwt-unix" {= version}
+ "cohttp-async" {= version}
+ "odoc" {with-doc}
+]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-bench/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-bench/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
--- /dev/null
+open Core
+open Async
+module Server = Cohttp_async.Server
+
+let length = 2053
+let text = String.make length 'a'
+let headers = Cohttp.Header.of_list [ ("content-length", Int.to_string length) ]
+let handler ~body:_ _sock _req = Server.respond_string ~headers text
+
+let start_server port () =
+ Cohttp_async.Server.create ~on_handler_error:`Raise
+ (Tcp.Where_to_listen.of_port port)
+ handler
+ >>= fun server ->
+ Deferred.forever () (fun () ->
+ after Time_float.Span.(of_sec 0.5) >>| fun () ->
+ Log.Global.printf "Active connections: %d" (Server.num_connections server));
+ Deferred.never ()
+
+let () =
+ let module Command = Async_command in
+ Command.async_spec ~summary:"Start a hello world Async server"
+ Command.Spec.(
+ empty
+ +> flag "-p"
+ (optional_with_default 8080 int)
+ ~doc:"int Source port to listen on")
+ start_server
+ |> Command_unix.run
--- /dev/null
+module Command = Core.Command
+module Staged = Core.Staged
+open Core_bench
+
+let header_names =
+ [
+ "Accept";
+ "Accept-Encoding";
+ "Accept-Language";
+ "Cache-Control";
+ "Connection";
+ "Host";
+ "If-Modified-Since";
+ "If-None-Match";
+ "Origin";
+ "Referer";
+ "Sec-Fetch-Dest";
+ "Sec-Fetch-Mode";
+ "Sec-Fetch-Site";
+ ]
+
+let header =
+ header_names |> List.map (fun s -> (s, "value")) |> Http.Header.of_list
+
+let bench_header_mem =
+ Bench.Test.create ~name:"Header.mem" (fun () ->
+ List.iter (fun key -> assert (Http.Header.mem header key)) header_names)
+
+let () = Command_unix.run @@ Bench.make_command [ bench_header_mem ]
--- /dev/null
+(executable
+ (name bench)
+ (modules bench)
+ (libraries http core core_unix.command_unix core_bench))
+
+(executable
+ (name lwt_unix_server)
+ (modules lwt_unix_server)
+ (libraries cohttp-lwt-unix logs.fmt fmt.tty))
+
+(executable
+ (name async_server)
+ (modules async_server)
+ (libraries cohttp-async core_unix.command_unix logs.fmt fmt.tty))
+
+(executable
+ (name eio_server)
+ (modules eio_server)
+ (libraries cohttp-eio eio_main))
+
+(rule
+ (alias bench)
+ (package cohttp-bench)
+ (enabled_if %{arch_sixtyfour})
+ (action
+ (run ./bench.exe time cycles)))
+
+(rule
+ (alias latency)
+ (deps lwt_unix_server.exe async_server.exe)
+ (package cohttp-bench)
+ (action
+ (run ./latency.sh)))
+
+(executable
+ (name lwt_unix_server_new)
+ (modules lwt_unix_server_new)
+ (libraries cohttp_server_lwt_unix lwt.unix lwt http unix))
--- /dev/null
+open Cohttp_eio
+
+let length = 2053
+let text = String.make length 'a'
+let headers = Cohttp.Header.of_list [ ("content-length", Int.to_string length) ]
+
+let server_callback _conn _req _body =
+ Server.respond_string ~headers ~status:`OK ~body:text ()
+
+let () =
+ let port = ref 8080 in
+ Arg.parse
+ [ ("-p", Arg.Set_int port, " Listening port number(8080 by default)") ]
+ ignore "An HTTP/1.1 server";
+ Eio_main.run @@ fun env ->
+ Eio.Switch.run @@ fun sw ->
+ let socket =
+ Eio.Net.listen env#net ~sw ~backlog:11_000 ~reuse_addr:true
+ (`Tcp (Eio.Net.Ipaddr.V4.loopback, !port))
+ and server = Cohttp_eio.Server.make ~callback:server_callback () in
+ Cohttp_eio.Server.run socket server ~on_error:raise
--- /dev/null
+#! /usr/bin/env bash
+set -xe
+
+rm -rf output/*
+mkdir -p output
+
+for cmd in "lwt_unix_server" "async_server" "lwt_unix_server_new" "eio_server"; do
+ ./$cmd.exe &
+ running_pid=$!
+ echo "Measuring latency of $cmd"
+ sleep 2;
+ wrk2 \
+ -t2 -c1000 -d5s \
+ --timeout 2000 \
+ -R 80000 --latency \
+ -H 'Connection: keep-alive' \
+ "http://localhost:8080" > output/run-$cmd.txt;
+ kill ${running_pid};
+ sleep 1;
+done
+echo "The results are available in $PWD/output"
--- /dev/null
+module Server = Cohttp_lwt_unix.Server
+
+let length = 2053
+let text = String.make length 'a'
+let headers = Cohttp.Header.of_list [ ("content-length", Int.to_string length) ]
+
+let server_callback _conn _req _body =
+ Server.respond_string ~headers ~status:`OK ~body:text ()
+
+let main () =
+ Server.create ~backlog:11_000 (Server.make ~callback:server_callback ())
+
+let () =
+ Printexc.record_backtrace true;
+ Logs.set_level (Some Info);
+ Logs.set_reporter (Logs_fmt.reporter ());
+ ignore (Lwt_main.run (main ()))
--- /dev/null
+open Lwt.Syntax
+module Context = Cohttp_server_lwt_unix.Context
+module Body = Cohttp_server_lwt_unix.Body
+
+let text = String.make 2053 'a'
+
+let server_callback ctx =
+ Lwt.join
+ [
+ Context.discard_body ctx;
+ Context.respond ctx (Http.Response.make ()) (Body.string text);
+ ]
+
+let main () =
+ let* _server =
+ let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in
+ let server =
+ Cohttp_server_lwt_unix.create
+ ~on_exn:(fun exn ->
+ Format.eprintf "unexpected:@.%s@." (Printexc.to_string exn))
+ server_callback
+ in
+ Lwt_io.establish_server_with_client_address ~backlog:10_000 listen_address
+ (fun _addr ch -> Cohttp_server_lwt_unix.handle_connection server ch)
+ in
+ let forever, _ = Lwt.wait () in
+ forever
+
+let () =
+ Printexc.record_backtrace true;
+ ignore (Lwt_main.run (main ()))
--- /dev/null
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Cohttp client using Curl & Async as the backend"
+description: """
+An HTTP client that relies on Curl + Async for the backend. Does not require
+conduit for SSL."""
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
+authors: [
+ "Anil Madhavapeddy"
+ "Stefano Zacchiroli"
+ "David Sheets"
+ "Thomas Gazagnaire"
+ "David Scott"
+ "Rudi Grinberg"
+ "Andy Ray"
+ "Anurag Soni"
+]
+license: "ISC"
+homepage: "https://github.com/mirage/ocaml-cohttp"
+doc: "https://mirage.github.io/ocaml-cohttp/"
+bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
+depends: [
+ "dune" {>= "3.8"}
+ "ocurl" {>= "0.9.2"}
+ "http" {= version}
+ "stringext"
+ "cohttp-curl" {= version}
+ "core" {>= "v0.16.0"}
+ "core_unix" {>= "v0.14.0"}
+ "core_kernel" {with-test}
+ "async_kernel" {with-test & >= "v0.17.0"}
+ "async_unix" {with-test}
+ "cohttp-async" {with-test & = version}
+ "uri" {with-test & >= "4.2.0"}
+ "fmt" {with-test}
+ "ounit2" {with-test}
+ "alcotest" {with-test & >= "1.7.0"}
+ "odoc" {with-doc}
+]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-curl-async/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-curl-async/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
--- /dev/null
+open Cohttp
+module Curl = Cohttp_curl_async
+module Sexp = Sexplib0.Sexp
+open Async_kernel
+module Writer = Async_unix.Writer
+module Time = Core.Time_float
+
+let ( let* ) x f = Deferred.bind x ~f
+
+let client uri meth' () =
+ let meth = Cohttp.Code.method_of_string meth' in
+ let reply =
+ let context = Curl.Context.create () in
+ let request =
+ Curl.Request.create ~timeout:(Time.Span.of_ms 5000.) meth ~uri
+ ~input:Curl.Source.empty ~output:Curl.Sink.string
+ in
+ Curl.submit context request
+ in
+ let* resp, response_body =
+ Deferred.both (Curl.Response.response reply) (Curl.Response.body reply)
+ >>| function
+ | Ok r, Ok b -> (r, b)
+ | _, Error e | Error e, _ ->
+ Format.eprintf "error: %s@.%!" (Curl.Error.message e);
+ exit 1
+ in
+ Format.eprintf "response:%a@.%!" Sexp.pp_hum (Response.sexp_of_t resp);
+ let status = Response.status resp in
+ (match Code.is_success (Code.code_of_status status) with
+ | false -> prerr_endline (Code.string_of_status status)
+ | true -> ());
+ let output_body c =
+ Writer.write c response_body;
+ Writer.flushed c
+ in
+ output_body (Lazy.force Writer.stdout)
+
+let _ =
+ let open Async_command in
+ async_spec ~summary:"Fetch URL and print it"
+ Spec.(
+ empty
+ +> anon ("url" %: string)
+ +> flag "-X" (optional_with_default "GET" string) ~doc:" Set HTTP method")
+ client
+ |> Command_unix.run
--- /dev/null
+(executable
+ (name curl)
+ (libraries
+ sexplib0
+ cohttp
+ cohttp_curl_async
+ core_kernel
+ async_unix
+ async_kernel
+ async.async_command
+ core_unix.command_unix))
--- /dev/null
+open Async_kernel
+module Time = Core.Time_float
+module Fd = Async_unix.Fd
+module Clock = Async_unix.Clock
+
+let ( let+ ) x f = Deferred.map x ~f
+
+module Cohttp_curl = Cohttp_curl.Private
+module Sink = Cohttp_curl.Sink
+module Source = Cohttp_curl.Source
+module Error = Cohttp_curl.Error
+
+module Context = struct
+ type fd_events = {
+ fd : Fd.t;
+ mutable read : unit Ivar.t option;
+ mutable write : unit Ivar.t option;
+ }
+
+ type t = {
+ mt : Curl.Multi.mt;
+ wakeners : (Curl.t, Curl.curlCode Ivar.t) Hashtbl.t;
+ all_events : (Unix.file_descr, fd_events) Hashtbl.t;
+ mutable timeout : (unit, unit) Clock.Event.t option;
+ }
+
+ let create () =
+ let t =
+ {
+ mt = Curl.Multi.create ();
+ wakeners = Hashtbl.create 32;
+ all_events = Hashtbl.create 32;
+ timeout = None;
+ }
+ in
+ let rec finished () =
+ match Curl.Multi.remove_finished t.mt with
+ | None -> ()
+ | Some (h, code) ->
+ (match Hashtbl.find_opt t.wakeners h with
+ | None -> ()
+ | Some w ->
+ Hashtbl.remove t.wakeners h;
+ Ivar.fill_exn w code);
+ finished ()
+ in
+ let on_readable fd =
+ let (_ : int) = Curl.Multi.action t.mt (Fd.file_descr_exn fd) EV_IN in
+ finished ()
+ in
+ let on_writable fd =
+ let (_ : int) = Curl.Multi.action t.mt (Fd.file_descr_exn fd) EV_OUT in
+ finished ()
+ in
+ let on_timer () =
+ Curl.Multi.action_timeout t.mt;
+ finished ()
+ in
+ Curl.Multi.set_timer_function t.mt (fun timeout ->
+ (match t.timeout with
+ | None -> ()
+ | Some event -> Clock.Event.abort_if_possible event ());
+ let duration = Time.Span.of_ms (float_of_int timeout) in
+ t.timeout <- Some (Clock.Event.run_after duration on_timer ()));
+ let socket_function fd (what : Curl.Multi.poll) =
+ let create_event fd what =
+ let interrupt = Ivar.create () in
+ let f () =
+ match what with `Read -> on_readable fd | `Write -> on_writable fd
+ in
+ let event =
+ Fd.interruptible_every_ready_to fd what
+ ~interrupt:(Ivar.read interrupt)
+ (fun () -> f ())
+ ()
+ |> Deferred.map ~f:(function
+ | `Bad_fd | `Closed -> assert false
+ | `Unsupported -> assert false
+ | `Interrupted -> ())
+ |> Deferred.ignore_m
+ in
+ don't_wait_for event;
+ interrupt
+ in
+ let needs_read = what = POLL_IN || what = POLL_INOUT in
+ let needs_write = what = POLL_OUT || what = POLL_INOUT in
+ let+ current =
+ match Hashtbl.find_opt t.all_events fd with
+ | Some fd -> Deferred.return fd
+ | None ->
+ Deferred.return
+ {
+ fd =
+ Fd.create (Fd.Kind.Socket `Active) fd
+ (Base.Info.createf "curl");
+ read = None;
+ write = None;
+ }
+ in
+ let update fd set_event set needs what =
+ match (set, needs) with
+ | None, false -> ()
+ | Some _, true -> ()
+ | None, true -> set_event (Some (create_event fd what))
+ | Some ivar, false ->
+ Ivar.fill_exn ivar ();
+ set_event None
+ in
+ update current.fd
+ (fun ivar -> current.read <- ivar)
+ current.read needs_read `Read;
+ update current.fd
+ (fun ivar -> current.write <- ivar)
+ current.write needs_write `Write;
+ Hashtbl.replace t.all_events fd current
+ in
+ Curl.Multi.set_socket_function t.mt (fun fd what ->
+ don't_wait_for (socket_function fd what));
+ t
+
+ let unregister t curl =
+ Curl.Multi.remove t.mt curl;
+ Hashtbl.remove t.wakeners curl
+
+ let register t curl wk =
+ Hashtbl.add t.wakeners curl wk;
+ Curl.Multi.add t.mt curl
+end
+
+module Method = Http.Method
+module Header = Http.Header
+
+module Response = struct
+ type 'a t = {
+ curl : Curl.t;
+ response : (Http.Response.t, Error.t) result Deferred.t;
+ body : ('a, Error.t) result Deferred.t;
+ context : Context.t;
+ }
+
+ let response t = t.response
+ let body t = t.body
+ let cancel t = Context.unregister t.context t.curl
+
+ module Expert = struct
+ let curl t = t.curl
+ end
+end
+
+module Request = struct
+ type 'a t = {
+ body_ready : Curl.curlCode Ivar.t;
+ response_ready : (Http.Response.t, Error.t) result Ivar.t;
+ base : 'a Cohttp_curl.Request.t;
+ }
+
+ module Expert = struct
+ let curl t = Cohttp_curl.Request.curl t.base
+ end
+
+ let create (type a) ?timeout ?headers method_ ~uri ~(input : Source.t)
+ ~(output : a Sink.t) : a t =
+ let response_ready = Ivar.create () in
+ let body_ready = Ivar.create () in
+ let base =
+ let timeout_ms =
+ Option.map
+ (fun timeout -> Time.Span.to_ms timeout |> int_of_float)
+ timeout
+ in
+ Cohttp_curl.Request.create ?timeout_ms ?headers method_ ~uri ~input
+ ~output ~on_response:(fun response ->
+ Ivar.fill_exn response_ready (Ok response))
+ in
+ { base; response_ready; body_ready }
+end
+
+let submit (type a) context (request : a Request.t) : a Response.t =
+ let curl = Cohttp_curl.Request.curl request.base in
+ Context.register context curl request.body_ready;
+ let body =
+ Ivar.read request.body_ready >>| function
+ | Curl.CURLE_OK -> Ok (Cohttp_curl.Request.body request.base : a)
+ | code ->
+ let error = Error (Error.create code) in
+ Ivar.fill_exn request.response_ready error;
+ error
+ in
+ { Response.body; context; response = Ivar.read request.response_ready; curl }
--- /dev/null
+(** Curl & Async based client *)
+
+module Sink : sig
+ (** A sink defines where the response body may be written *)
+
+ type 'a t
+
+ val string : string t
+ val discard : unit t
+end
+
+module Source : sig
+ (** A source defines where the request body is read from *)
+
+ type t
+
+ val empty : t
+ val string : string -> t
+end
+
+module Context : sig
+ (** A context shares the curl event handling logic for all curl requests
+ associated to it *)
+
+ type t
+
+ val create : unit -> t
+end
+
+module Error : sig
+ type t
+
+ val message : t -> string
+ val is_timeout : t -> bool
+end
+
+module Response : sig
+ (** Response for the http requests *)
+
+ type 'a t
+ (** ['a t] represents a response for a request. ['a] determines how the
+ response body is handled *)
+
+ val response :
+ _ t -> (Http.Response.t, Error.t) result Async_kernel.Deferred.t
+
+ val body : 'a t -> ('a, Error.t) result Async_kernel.Deferred.t
+ val cancel : _ t -> unit
+
+ module Expert : sig
+ val curl : _ t -> Curl.t
+ end
+end
+
+module Request : sig
+ (** Http requests *)
+
+ type 'a t
+ (** ['a t] represents an http request ['a] determines how the response body is
+ handled. *)
+
+ val create :
+ ?timeout:Core.Time_float.Span.t (** timeout for the request *) ->
+ ?headers:Http.Header.t (** http headers *) ->
+ Http.Method.t (** http method *) ->
+ uri:string (** uri *) ->
+ input:Source.t (** request body *) ->
+ output:'a Sink.t (** response body *) ->
+ 'a t
+
+ module Expert : sig
+ val curl : _ t -> Curl.t
+ end
+end
+
+val submit : Context.t -> 'a Request.t -> 'a Response.t
+(** [submit ctx request] submits a request and returns the response. Once a
+ request is submitted, it may not be submitted again. *)
--- /dev/null
+(library
+ (name cohttp_curl_async)
+ (libraries http cohttp-curl core curl stringext async_kernel async_unix))
--- /dev/null
+module Server = Cohttp_async.Server
+module Body = Cohttp_async.Body
+module Deferred = Async_kernel.Deferred
+open Async_kernel
+
+let ( let+ ) x f = Deferred.map x ~f
+let ( let* ) x f = Deferred.bind x ~f
+
+let server =
+ List.map Cohttp_async_test.const
+ [
+ (let body : Body.t = Body.of_string "hello curl" in
+ Server.respond `OK ~body);
+ ]
+ |> Cohttp_async_test.response_sequence
+
+let test =
+ Cohttp_async_test.test_server_s ~port:25_290 server (fun uri ->
+ [
+ ( "simple request",
+ fun () ->
+ let uri = Uri.to_string uri in
+ let input = Cohttp_curl_async.Source.empty in
+ let output = Cohttp_curl_async.Sink.string in
+ let ctx = Cohttp_curl_async.Context.create () in
+ let req =
+ Cohttp_curl_async.Request.create `GET ~uri ~input ~output
+ in
+ let resp = Cohttp_curl_async.submit ctx req in
+ let+ body =
+ Cohttp_curl_async.Response.body resp >>| function
+ | Ok s -> s
+ | Error _ -> assert false
+ in
+ Alcotest.check Alcotest.string "test 1" body "hello curl" );
+ ])
+
+let _ =
+ let run =
+ let* _ = Cohttp_async_test.run_async_tests test in
+ Async_unix.Shutdown.exit 0
+ in
+ Deferred.don't_wait_for run;
+ Core.never_returns (Async_unix.Scheduler.go ())
--- /dev/null
+(test
+ (name cohttp_curl_async_tests)
+ (libraries
+ http
+ core_kernel
+ async_unix
+ uri
+ async_kernel
+ alcotest
+ cohttp_async_test
+ cohttp_curl_async)
+ (package cohttp-curl-async))
--- /dev/null
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Cohttp client using Curl & Lwt as the backend"
+description: """
+An HTTP client that relies on Curl + Lwt for the backend. Does not require
+conduit for SSL."""
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
+authors: [
+ "Anil Madhavapeddy"
+ "Stefano Zacchiroli"
+ "David Sheets"
+ "Thomas Gazagnaire"
+ "David Scott"
+ "Rudi Grinberg"
+ "Andy Ray"
+ "Anurag Soni"
+]
+license: "ISC"
+homepage: "https://github.com/mirage/ocaml-cohttp"
+doc: "https://mirage.github.io/ocaml-cohttp/"
+bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
+depends: [
+ "dune" {>= "3.8"}
+ "ocaml" {>= "4.08"}
+ "ocurl" {>= "0.9.2"}
+ "http" {= version}
+ "cohttp-curl" {= version}
+ "stringext"
+ "lwt" {>= "5.3.0"}
+ "uri" {with-test & >= "4.2.0"}
+ "alcotest" {with-test & >= "1.7.0"}
+ "cohttp-lwt-unix" {with-test & = version}
+ "cohttp" {with-test & = version}
+ "cohttp-lwt" {with-test & = version}
+ "conduit-lwt" {with-test}
+ "ounit2" {with-test}
+ "odoc" {with-doc}
+]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-curl-lwt/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-curl-lwt/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
--- /dev/null
+open Lwt.Syntax
+open Cohttp
+module Curl = Cohttp_curl_lwt
+module Sexp = Sexplib0.Sexp
+
+let src =
+ Logs.Src.create "cohttp.lwt.curl" ~doc:"Cohttp Lwt curl implementation"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let client uri ofile meth' =
+ Log.debug (fun d -> d "Client with URI %s" (Uri.to_string uri));
+ let meth = Cohttp.Code.method_of_string meth' in
+ Log.debug (fun d -> d "Client %s issued" meth');
+ let reply =
+ let context = Curl.Context.create () in
+ let request =
+ Curl.Request.create ~timeout_ms:5000 meth ~uri:(Uri.to_string uri)
+ ~input:Curl.Source.empty ~output:Curl.Sink.string
+ in
+ Curl.submit context request
+ in
+ let* resp, response_body =
+ Lwt.both (Curl.Response.response reply) (Curl.Response.body reply)
+ in
+ let resp, response_body =
+ match (resp, response_body) with
+ | Ok _, Error _ | Error _, Ok _ -> assert false
+ | Ok x, Ok y -> (x, y)
+ | Error _, Error e ->
+ Format.eprintf "error: %s@.%!" (Curl.Error.message e);
+ exit 1
+ in
+ Format.eprintf "response:%a@.%!" Sexp.pp_hum (Response.sexp_of_t resp);
+ let status = Response.status resp in
+ Log.debug (fun d ->
+ d "Client %s returned: %s" meth' (Code.string_of_status status));
+ (match Code.is_success (Code.code_of_status status) with
+ | false -> prerr_endline (Code.string_of_status status)
+ | true -> ());
+ let len = String.length response_body in
+ Log.debug (fun d -> d "Client body length: %d" len);
+ let output_body c = Lwt_io.write c response_body in
+ match ofile with
+ | None -> output_body Lwt_io.stdout
+ | Some fname -> Lwt_io.with_file ~mode:Lwt_io.output fname output_body
+
+let debug =
+ match Sys.getenv_opt "COHTTP_CURL_DEBUG" with None -> false | Some _ -> true
+
+let run_client level ofile uri meth =
+ if debug then (
+ Fmt_tty.setup_std_outputs ();
+ Logs.set_level ~all:true level);
+ Lwt_main.run (client uri ofile meth)
+
+open Cmdliner
+
+let uri =
+ let loc : Uri.t Arg.conv =
+ let parse s =
+ try `Ok (Uri.of_string s) with Failure _ -> `Error "unable to parse URI"
+ in
+ (parse, fun ppf p -> Format.fprintf ppf "%s" (Uri.to_string p))
+ in
+ Arg.(
+ required
+ & pos 0 (some loc) None
+ & info [] ~docv:"URI"
+ ~doc:"string of the remote address (e.g. https://google.com)")
+
+let meth =
+ let doc = "Set http method" in
+ Arg.(value & opt string "GET" & info [ "X"; "request" ] ~doc)
+
+let verb = Logs_cli.level ()
+
+let ofile =
+ let doc = "Output filename to store the URI into." in
+ Arg.(value & opt (some string) None & info [ "o" ] ~docv:"FILE" ~doc)
+
+let cmd =
+ let info =
+ let version = Cohttp.Conf.version in
+ let doc = "retrieve a remote URI contents" in
+ let man =
+ [
+ `S "DESCRIPTION";
+ `P
+ "$(tname) fetches the remote $(i,URI) and prints it to standard \
+ output. The output file can also be specified with the $(b,-o) \
+ option, and more verbose debugging out obtained via the $(b,-v) \
+ option.";
+ `S "BUGS";
+ `P
+ "Report them via e-mail to <mirageos-devel@lists.xenproject.org>, or \
+ on the issue tracker at \
+ <https://github.com/mirage/ocaml-cohttp/issues>";
+ `S "SEE ALSO";
+ `P "$(b,curl)(1), $(b,wget)(1)";
+ ]
+ in
+ Cmd.info "cohttp-curl" ~version ~doc ~man
+ in
+
+ let term = Term.(const run_client $ verb $ ofile $ uri $ meth) in
+ Cmd.v info term
+
+let () = exit @@ Cmd.eval cmd
--- /dev/null
+(executable
+ (name curl)
+ (libraries
+ sexplib0
+ cohttp
+ cohttp_curl_lwt
+ lwt.unix
+ lwt
+ logs
+ logs.cli
+ uri
+ fmt.tty
+ cmdliner))
--- /dev/null
+(* {[
+ Copyright (c) 2003, Lars Nilsson, <lars@quantumchamaeleon.com>
+ Copyright (c) 2009, ygrek, <ygrek@autistici.org>
+
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ ]} *)
+
+module Cohttp_curl = Cohttp_curl.Private
+module Sink = Cohttp_curl.Sink
+module Source = Cohttp_curl.Source
+module Error = Cohttp_curl.Error
+open Lwt.Infix
+
+module Context = struct
+ type t = {
+ mt : Curl.Multi.mt;
+ wakeners : (Curl.t, Curl.curlCode Lwt.u) Hashtbl.t;
+ all_events : (Unix.file_descr, Lwt_engine.event list) Hashtbl.t;
+ by_fd : (Unix.file_descr, Curl.t list) Hashtbl.t;
+ mutable timer_event : Lwt_engine.event;
+ }
+
+ let unregister t curl =
+ Curl.get_activesocket curl
+ |> Option.iter (fun fd ->
+ match Hashtbl.find_opt t.by_fd fd with
+ | None -> ()
+ | Some curls ->
+ Hashtbl.replace t.by_fd fd
+ (List.filter (fun c -> c = curl) curls));
+ Curl.Multi.remove t.mt curl;
+ Hashtbl.remove t.wakeners curl
+
+ let create () =
+ (* Most of this is taken from https://github.com/ygrek/ocurl/blob/master/curl_lwt.ml *)
+ let t =
+ {
+ mt = Curl.Multi.create ();
+ wakeners = Hashtbl.create 32;
+ all_events = Hashtbl.create 32;
+ by_fd = Hashtbl.create 32;
+ timer_event = Lwt_engine.fake_event;
+ }
+ in
+ let rec finished () =
+ match Curl.Multi.remove_finished t.mt with
+ | None -> ()
+ | Some (h, code) ->
+ (match Hashtbl.find_opt t.wakeners h with
+ | None -> ()
+ | Some w ->
+ Hashtbl.remove t.wakeners h;
+ Lwt.wakeup w code);
+ finished ()
+ in
+ let handle fd f =
+ match f () with
+ | (_ : int) -> finished ()
+ | exception exn -> (
+ match Hashtbl.find_opt t.by_fd fd with
+ | None -> ()
+ | Some curls ->
+ Hashtbl.remove t.by_fd fd;
+ List.iter
+ (fun curl ->
+ match Hashtbl.find_opt t.wakeners curl with
+ | None -> ()
+ | Some w -> Lwt.wakeup_exn w exn)
+ curls)
+ in
+ let on_readable fd _ =
+ handle fd (fun () -> Curl.Multi.action t.mt fd EV_IN)
+ in
+ let on_writable fd _ =
+ handle fd (fun () -> Curl.Multi.action t.mt fd EV_OUT)
+ in
+ let on_timer _ =
+ Lwt_engine.stop_event t.timer_event;
+ (try Curl.Multi.action_timeout t.mt
+ with exn ->
+ (* I'm not sure where to report this error *)
+ !Lwt.async_exception_hook exn);
+ finished ()
+ in
+ Curl.Multi.set_timer_function t.mt (fun timeout ->
+ Lwt_engine.stop_event t.timer_event;
+ t.timer_event <-
+ Lwt_engine.on_timer (float_of_int timeout /. 1000.) false on_timer);
+ Curl.Multi.set_socket_function t.mt (fun fd what ->
+ (match Hashtbl.find_opt t.all_events fd with
+ | None -> ()
+ | Some events ->
+ List.iter Lwt_engine.stop_event events;
+ Hashtbl.remove t.all_events fd);
+ let events =
+ match what with
+ | POLL_REMOVE | POLL_NONE -> []
+ | POLL_IN -> [ Lwt_engine.on_readable fd (on_readable fd) ]
+ | POLL_OUT -> [ Lwt_engine.on_writable fd (on_writable fd) ]
+ | POLL_INOUT ->
+ [
+ Lwt_engine.on_readable fd (on_readable fd);
+ Lwt_engine.on_writable fd (on_writable fd);
+ ]
+ in
+ match events with [] -> () | _ -> Hashtbl.add t.all_events fd events);
+ t
+
+ let register t curl wk =
+ Hashtbl.add t.wakeners curl wk;
+ Curl.Multi.add t.mt curl;
+ match Curl.get_activesocket curl with
+ | None -> assert false
+ | Some fd -> (
+ match Hashtbl.find_opt t.by_fd fd with
+ | None -> Hashtbl.replace t.by_fd fd [ curl ]
+ | Some curls -> Hashtbl.replace t.by_fd fd (curl :: curls))
+end
+
+module Method = Http.Method
+module Header = Http.Header
+
+module Response = struct
+ type 'a t = {
+ curl : Curl.t;
+ response : (Http.Response.t, Error.t) result Lwt.t;
+ body : ('a, Error.t) result Lwt.t;
+ }
+
+ let response t = t.response
+ let body t = t.body
+
+ module Expert = struct
+ let curl t = t.curl
+ end
+end
+
+module Request = struct
+ type 'a t = {
+ wk_body : Curl.curlCode Lwt.u;
+ wt_body : Curl.curlCode Lwt.t;
+ wt_response : (Http.Response.t, Error.t) result Lwt.t;
+ wk_response : (Http.Response.t, Error.t) result Lwt.u;
+ base : 'a Cohttp_curl.Request.t;
+ }
+
+ module Expert = struct
+ let curl t = Cohttp_curl.Request.curl t.base
+ end
+
+ let create (type a) ?timeout_ms ?headers method_ ~uri ~input
+ ~(output : a Sink.t) : a t =
+ let wt_response, wk_response = Lwt.wait () in
+ let wt_body, wk_body = Lwt.wait () in
+ let wt_response = Lwt.protected wt_response in
+ let wt_body = Lwt.protected wt_body in
+ let base =
+ Cohttp_curl.Request.create ?timeout_ms ?headers method_ ~uri ~input
+ ~output ~on_response:(fun resp -> Lwt.wakeup wk_response (Ok resp))
+ in
+ { base; wt_response; wk_body; wt_body; wk_response }
+end
+
+let submit (type a) context (request : a Request.t) : a Response.t =
+ let curl = Cohttp_curl.Request.curl request.base in
+ let cancel = lazy (Context.unregister context curl) in
+ Lwt.on_cancel request.wt_response (fun () -> Lazy.force cancel);
+ Lwt.on_cancel request.wt_body (fun () -> Lazy.force cancel);
+ Context.register context curl request.wk_body;
+ let body =
+ request.wt_body >|= function
+ | Curl.CURLE_OK -> Ok (Cohttp_curl.Request.body request.base : a)
+ | code ->
+ let error = Error (Error.create code) in
+ Lwt.wakeup_later request.wk_response error;
+ error
+ in
+ { Response.body; response = request.wt_response; curl }
--- /dev/null
+(** Curl based client *)
+
+module Sink : sig
+ (** A sink defines where the response body may be written *)
+
+ type 'a t
+
+ val string : string t
+ val discard : unit t
+end
+
+module Source : sig
+ (** A source defines where the request body is read from *)
+
+ type t
+
+ val empty : t
+ val string : string -> t
+end
+
+module Context : sig
+ (** A context shares the curl event handling logic for all curl requests
+ associated to it *)
+
+ type t
+
+ val create : unit -> t
+end
+
+module Error : sig
+ type t
+
+ val message : t -> string
+ val is_timeout : t -> bool
+end
+
+module Response : sig
+ (** Response for the http requests *)
+
+ type 'a t
+ (** ['a t] represents a response for a request. ['a] determines how the
+ response body is handled *)
+
+ val response : _ t -> (Http.Response.t, Error.t) result Lwt.t
+ val body : 'a t -> ('a, Error.t) result Lwt.t
+
+ module Expert : sig
+ val curl : _ t -> Curl.t
+ end
+end
+
+module Request : sig
+ (** Http requests *)
+
+ type 'a t
+ (** ['a t] represents an http request ['a] determines how the response body is
+ handled. *)
+
+ val create :
+ ?timeout_ms:int (** timeout for the request in milliseconds *) ->
+ ?headers:Http.Header.t (** http headers *) ->
+ Http.Method.t (** http method *) ->
+ uri:string (** uri *) ->
+ input:Source.t (** request body *) ->
+ output:'a Sink.t (** response body *) ->
+ 'a t
+
+ module Expert : sig
+ val curl : _ t -> Curl.t
+ end
+end
+
+val submit : Context.t -> 'a Request.t -> 'a Response.t
+(** [submit ctx request] submits a request and returns the response. Once a
+ request is submitted, it may not be submitted again. *)
--- /dev/null
+(library
+ (name cohttp_curl_lwt)
+ (public_name cohttp-curl-lwt)
+ (libraries http cohttp-curl stringext lwt lwt.unix curl))
--- /dev/null
+module Server = Cohttp_lwt_unix.Server
+module Body = Cohttp_lwt.Body
+open Lwt.Syntax
+open Lwt.Infix
+
+let server =
+ List.map Cohttp_lwt_unix_test.const
+ [
+ (let body : Body.t = Body.of_string "hello curl" in
+ Server.respond ~status:`OK ~body ());
+ ]
+ |> Cohttp_lwt_unix_test.response_sequence
+
+let check_error = function Ok _ -> failwith "expected error" | Error _ -> ()
+
+let without_error = function
+ | Ok s -> s
+ | Error e -> failwith (Cohttp_curl_lwt.Error.message e)
+
+let test =
+ Cohttp_lwt_unix_test.test_server_s ~port:25_190 server (fun uri ->
+ [
+ ( "simple request",
+ fun () ->
+ let uri = Uri.to_string uri in
+ let input = Cohttp_curl_lwt.Source.empty in
+ let output = Cohttp_curl_lwt.Sink.string in
+ let ctx = Cohttp_curl_lwt.Context.create () in
+ let req = Cohttp_curl_lwt.Request.create `GET ~uri ~input ~output in
+ let resp = Cohttp_curl_lwt.submit ctx req in
+ let+ body = Cohttp_curl_lwt.Response.body resp >|= without_error in
+ Alcotest.check Alcotest.string "test 1" body "hello curl" );
+ ( "failing request",
+ fun () ->
+ let uri = "0.0.0.0:45_120" in
+ let input = Cohttp_curl_lwt.Source.empty in
+ let output = Cohttp_curl_lwt.Sink.string in
+ let ctx = Cohttp_curl_lwt.Context.create () in
+ let req = Cohttp_curl_lwt.Request.create `GET ~uri ~input ~output in
+ let resp = Cohttp_curl_lwt.submit ctx req in
+ let* http_resp = Cohttp_curl_lwt.Response.response resp in
+ check_error http_resp;
+ let+ body = Cohttp_curl_lwt.Response.body resp in
+ check_error body );
+ ])
+
+let _ = test |> Cohttp_lwt_unix_test.run_async_tests |> Lwt_main.run
--- /dev/null
+(test
+ (name cohttp_curl_lwt_tests)
+ (libraries http alcotest uri cohttp_lwt_unix_test cohttp_curl_lwt)
+ (package cohttp-curl-lwt))
--- /dev/null
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Shared code between the individual cohttp-curl clients"
+description: "Use cohttp-curl-lwt or cohttp-curl-async"
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
+authors: [
+ "Anil Madhavapeddy"
+ "Stefano Zacchiroli"
+ "David Sheets"
+ "Thomas Gazagnaire"
+ "David Scott"
+ "Rudi Grinberg"
+ "Andy Ray"
+ "Anurag Soni"
+]
+license: "ISC"
+homepage: "https://github.com/mirage/ocaml-cohttp"
+doc: "https://mirage.github.io/ocaml-cohttp/"
+bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
+depends: [
+ "dune" {>= "3.8"}
+ "ocaml" {>= "4.08"}
+ "ocurl" {>= "0.9.2"}
+ "http" {= version}
+ "stringext"
+ "odoc" {with-doc}
+]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-curl/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-curl/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
--- /dev/null
+module Sink = struct
+ type _ t = String : string t | Discard : unit t
+
+ let string = String
+ let discard = Discard
+end
+
+module Error = struct
+ type t = Curl.curlCode
+
+ let create x = x
+
+ let is_timeout (t : t) =
+ match t with Curl.CURLE_OPERATION_TIMEOUTED -> true | _ -> false
+
+ let message t = Curl.strerror t
+end
+
+module Source = struct
+ type t = Empty | String of string
+
+ let empty = Empty
+ let string s = String s
+
+ let to_curl_callback t =
+ match t with
+ | Empty -> fun _ -> ""
+ | String s ->
+ let len = String.length s in
+ let pos = ref 0 in
+ fun max_asked ->
+ if !pos >= len then ""
+ else
+ let chunk_len = min (len - !pos) max_asked in
+ let res = String.sub s !pos chunk_len in
+ pos := !pos + chunk_len;
+ res
+end
+
+module Request = struct
+ type 'a t = {
+ curl : Curl.t;
+ body : 'a Sink.t;
+ mutable body_buffer : Buffer.t option;
+ }
+
+ let curl t = t.curl
+
+ let body (type a) (t : a t) : a =
+ match t.body with
+ | Discard ->
+ assert (t.body_buffer = None);
+ ()
+ | String ->
+ let res =
+ Buffer.contents
+ (match t.body_buffer with None -> assert false | Some s -> s)
+ in
+ t.body_buffer <- None;
+ res
+
+ let create (type a) ?timeout_ms ?headers method_ ~uri ~(input : Source.t)
+ ~(output : a Sink.t) ~on_response : a t =
+ let response_header_acc = ref [] in
+ let response_body = ref None in
+ let h = Curl.init () in
+ Curl.setopt h (CURLOPT_URL uri);
+ Curl.setopt h (CURLOPT_CUSTOMREQUEST (Http.Method.to_string method_));
+ let () =
+ match headers with
+ | None -> ()
+ | Some headers ->
+ let buf = Buffer.create 128 in
+ let headers =
+ Http.Header.fold
+ (fun key value acc ->
+ Buffer.clear buf;
+ Buffer.add_string buf key;
+ Buffer.add_string buf ": ";
+ Buffer.add_string buf value;
+ Buffer.contents buf :: acc)
+ headers []
+ |> List.rev
+ in
+ Curl.setopt h (CURLOPT_HTTPHEADER headers)
+ in
+ Curl.setopt h
+ (CURLOPT_HEADERFUNCTION
+ (let status_code_ready = ref false in
+ let response_http_version = ref None in
+ fun header ->
+ (match !status_code_ready with
+ | false ->
+ (match String.split_on_char ' ' header with
+ | v :: _ ->
+ response_http_version := Some (Http.Version.of_string v)
+ | _ -> (* TODO *) invalid_arg "invalid request");
+ status_code_ready := true
+ | true -> (
+ match header with
+ | "\r\n" ->
+ let response =
+ let headers =
+ Http.Header.of_list_rev !response_header_acc
+ in
+ response_header_acc := [];
+ let status =
+ match Curl.getinfo h CURLINFO_HTTP_CODE with
+ | CURLINFO_Long l -> Http.Status.of_int l
+ | _ -> assert false
+ in
+ let version =
+ match !response_http_version with
+ | None -> assert false
+ | Some v -> v
+ in
+ Http.Response.make ~version ~status ~headers ()
+ in
+ on_response response
+ | _ ->
+ let k, v =
+ match Stringext.cut header ~on:":" with
+ | None -> invalid_arg "proper abort needed"
+ | Some (k, v) -> (String.trim k, String.trim v)
+ in
+ response_header_acc := (k, v) :: !response_header_acc));
+ String.length header));
+ Curl.setopt h (CURLOPT_READFUNCTION (Source.to_curl_callback input));
+ Curl.setopt h
+ (CURLOPT_WRITEFUNCTION
+ (match output with
+ | Discard -> fun s -> String.length s
+ | String ->
+ let buf = Buffer.create 128 in
+ response_body := Some buf;
+ fun s ->
+ Buffer.add_string buf s;
+ String.length s));
+ (match timeout_ms with
+ | None -> ()
+ | Some tms -> Curl.setopt h (CURLOPT_TIMEOUTMS tms));
+ { curl = h; body = output; body_buffer = !response_body }
+end
+
+module Private = struct
+ module Error = Error
+ module Sink = Sink
+ module Source = Source
+ module Request = Request
+end
--- /dev/null
+module Private : sig
+ module Error : sig
+ type t
+
+ val create : Curl.curlCode -> t
+ val message : t -> string
+ val is_timeout : t -> bool
+ end
+
+ module Sink : sig
+ type 'a t
+
+ val string : string t
+ val discard : unit t
+ end
+
+ module Source : sig
+ type t
+
+ val empty : t
+ val string : string -> t
+ end
+
+ module Request : sig
+ type 'a t
+
+ val curl : _ t -> Curl.t
+
+ val body : 'a t -> 'a
+ (** [body t] this must be called after curl completes the requests. it can
+ only be called once *)
+
+ val create :
+ ?timeout_ms:int ->
+ ?headers:Http.Header.t ->
+ Http.Method.t ->
+ uri:string ->
+ input:Source.t ->
+ output:'a Sink.t ->
+ on_response:(Http.Response.t -> unit) ->
+ 'a t
+ end
+end
--- /dev/null
+(library
+ (name cohttp_curl)
+ (public_name cohttp-curl)
+ (libraries http curl stringext))
--- /dev/null
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "CoHTTP implementation with eio backend"
+description:
+ "A CoHTTP server and client implementation based on `eio` library. `cohttp-eio`features a multicore capable HTTP 1.1 server. The library promotes and is built with direct style of coding as opposed to a monadic."
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
+authors: [
+ "Anil Madhavapeddy"
+ "Stefano Zacchiroli"
+ "David Sheets"
+ "Thomas Gazagnaire"
+ "David Scott"
+ "Rudi Grinberg"
+ "Andy Ray"
+ "Anurag Soni"
+]
+license: "ISC"
+homepage: "https://github.com/mirage/ocaml-cohttp"
+doc: "https://mirage.github.io/ocaml-cohttp/"
+bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
+depends: [
+ "dune" {>= "3.8"}
+ "alcotest" {with-test & >= "1.7.0"}
+ "base-domains"
+ "cohttp" {= version}
+ "eio" {>= "0.12"}
+ "eio_main" {with-test}
+ "mdx" {with-test}
+ "logs"
+ "uri"
+ "tls-eio" {with-test & >= "1.0.0"}
+ "mirage-crypto-rng-eio" {with-test & >= "0.11.2"}
+ "ca-certs" {with-test & >= "1.0.0"}
+ "fmt"
+ "ptime"
+ "http" {= version}
+ "ppx_here" {with-test}
+ "odoc" {with-doc}
+]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-eio/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-eio/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
--- /dev/null
+open Cohttp_eio
+
+let () = Logs.set_reporter (Logs_fmt.reporter ())
+
+and () =
+ (* The eio backend does not leverage domains yet, but might in the near future *)
+ Logs_threaded.enable ()
+
+and () = Logs.Src.set_level Cohttp_eio.src (Some Debug)
+
+let () =
+ Eio_main.run @@ fun env ->
+ let client = Client.make ~https:None env#net in
+ Eio.Switch.run @@ fun sw ->
+ let resp, body = Client.get ~sw client (Uri.of_string "http://example.com") in
+ if Http.Status.compare resp.status `OK = 0 then
+ print_string @@ Eio.Buf_read.(parse_exn take_all) body ~max_size:max_int
+ else Fmt.epr "Unexpected HTTP status: %a" Http.Status.pp resp.status
--- /dev/null
+open Cohttp_eio
+
+let () =
+ Eio_main.run @@ fun env ->
+ let client = Client.make ~https:None env#net in
+ (* Increment/decrement this value to see success/failure. *)
+ let timeout_s = 0.01 in
+ Eio.Time.with_timeout env#clock timeout_s (fun () ->
+ Eio.Switch.run @@ fun sw ->
+ let _, body =
+ Client.get client ~sw (Uri.of_string "http://www.example.org")
+ in
+ Eio.Buf_read.(of_flow ~max_size:max_int body |> take_all) |> Result.ok)
+ |> function
+ | Ok s -> print_string s
+ | Error (`Fatal e) -> Fmt.epr "fatal error: %s@." e
+ | Error `Timeout -> Fmt.epr "Connection timed out@."
--- /dev/null
+open Cohttp_eio
+
+let authenticator =
+ match Ca_certs.authenticator () with
+ | Ok x -> x
+ | Error (`Msg m) ->
+ Fmt.failwith "Failed to create system store X509 authenticator: %s" m
+
+let () =
+ Logs.set_reporter (Logs_fmt.reporter ());
+ Logs_threaded.enable ();
+ Logs.Src.set_level Cohttp_eio.src (Some Debug)
+
+let https ~authenticator =
+ let tls_config =
+ match Tls.Config.client ~authenticator () with
+ | Error (`Msg msg) -> failwith ("tls configuration problem: " ^ msg)
+ | Ok tls_config -> tls_config
+ in
+ fun uri raw ->
+ let host =
+ Uri.host uri
+ |> Option.map (fun x -> Domain_name.(host_exn (of_string_exn x)))
+ in
+ Tls_eio.client_of_flow ?host tls_config raw
+
+let () =
+ Eio_main.run @@ fun env ->
+ Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () ->
+ let client = Client.make ~https:(Some (https ~authenticator)) env#net in
+ Eio.Switch.run @@ fun sw ->
+ let resp, body =
+ Client.get ~sw client (Uri.of_string "https://example.com")
+ in
+ if Http.Status.compare resp.status `OK = 0 then
+ print_string @@ Eio.Buf_read.(parse_exn take_all) body ~max_size:max_int
+ else Fmt.epr "Unexpected HTTP status: %a" Http.Status.pp resp.status
--- /dev/null
+module Switch = Eio.Switch
+module Net = Eio.Net
+module Stdenv = Eio.Stdenv
+module Client = Cohttp_eio.Client
+module Response = Http.Response
+module Status = Http.Status
+
+let () = Logs.set_reporter (Logs_fmt.reporter ())
+and () = Logs.Src.set_level Cohttp_eio.src (Some Debug)
+
+let () =
+ Eio_main.run @@ fun env ->
+ let client = Client.make ~https:None env#net in
+ Eio.Switch.run @@ fun sw ->
+ let response, body =
+ Client.get client ~sw
+ @@ Uri.make ~scheme:"httpunix" ~host:"/var/run/docker.sock" ~path:"/version"
+ ()
+ in
+ let code = response |> Response.status |> Status.to_int in
+ Printf.printf "Response code: %d\n" code;
+ Printf.printf "Headers: %s\n"
+ (response |> Response.headers |> Http.Header.to_string);
+ let body = Eio.Buf_read.(of_flow ~max_size:max_int body |> take_all) in
+ Printf.printf "Body of length: %d\n" (String.length body);
+ print_endline ("Received body\n" ^ body)
--- /dev/null
+(executables
+ (names server1 server2 client1 docker_client client_timeout client_tls)
+ (libraries
+ cohttp-eio
+ eio_main
+ eio.unix
+ fmt
+ unix
+ logs.fmt
+ logs.threaded
+ tls-eio
+ ca-certs
+ mirage-crypto-rng-eio))
+
+(alias
+ (name runtest)
+ (package cohttp-eio)
+ (deps server1.exe))
--- /dev/null
+let text =
+ "CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of \
+ sitting by her sister on the bank, and of having nothing to do: once or \
+ twice she had peeped into the book her sister was reading, but it had no \
+ pictures or conversations in it, <and what is the use of a book,> thought \
+ Alice <without pictures or conversations?> So she was considering in her \
+ own mind (as well as she could, for the hot day made her feel very sleepy \
+ and stupid), whether the pleasure of making a daisy-chain would be worth \
+ the trouble of getting up and picking the daisies, when suddenly a White \
+ Rabbit with pink eyes ran close by her. There was nothing so very \
+ remarkable in that; nor did Alice think it so very much out of the way to \
+ hear the Rabbit say to itself, <Oh dear! Oh dear! I shall be late!> (when \
+ she thought it over afterwards, it occurred to her that she ought to have \
+ wondered at this, but at the time it all seemed quite natural); but when \
+ the Rabbit actually took a watch out of its waistcoat-pocket, and looked at \
+ it, and then hurried on, Alice started to her feet, for it flashed across \
+ her mind that she had never before seen a rabbit with either a \
+ waistcoat-pocket, or a watch to take out of it, and burning with curiosity, \
+ she ran across the field after it, and fortunately was just in time to see \
+ it pop down a large rabbit-hole under the hedge. In another moment down \
+ went Alice after it, never once considering how in the world she was to get \
+ out again. The rabbit-hole went straight on like a tunnel for some way, and \
+ then dipped suddenly down, so suddenly that Alice had not a moment to think \
+ about stopping herself before she found herself falling down a very deep \
+ well. Either the well was very deep, or she fell very slowly, for she had \
+ plenty of time as she went down to look about her and to wonder what was \
+ going to happen next. First, she tried to look down and make out what she \
+ was coming to, but it was too dark to see anything; then she looked at the \
+ sides of the well, and noticed that they were filled with cupboards......"
+
+let () = Logs.set_reporter (Logs_fmt.reporter ())
+and () = Logs.Src.set_level Cohttp_eio.src (Some Debug)
+
+let handler _socket request _body =
+ match Http.Request.resource request with
+ | "/" -> Cohttp_eio.Server.respond_string ~status:`OK ~body:text ()
+ | "/html" ->
+ (* Use a plain flow to test chunked encoding *)
+ let body = Eio.Flow.string_source text in
+ Cohttp_eio.Server.respond () ~status:`OK
+ ~headers:(Http.Header.of_list [ ("content-type", "text/html") ])
+ ~body
+ | _ -> Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
+
+let log_warning ex = Logs.warn (fun f -> f "%a" Eio.Exn.pp ex)
+
+let () =
+ let port = ref 8080 in
+ Arg.parse
+ [ ("-p", Arg.Set_int port, " Listening port number(8080 by default)") ]
+ ignore "An HTTP/1.1 server";
+ Eio_main.run @@ fun env ->
+ Eio.Switch.run @@ fun sw ->
+ let socket =
+ Eio.Net.listen env#net ~sw ~backlog:128 ~reuse_addr:true
+ (`Tcp (Eio.Net.Ipaddr.V4.loopback, !port))
+ and server = Cohttp_eio.Server.make ~callback:handler () in
+ Cohttp_eio.Server.run socket server ~on_error:log_warning
--- /dev/null
+let () = Logs.set_reporter (Logs_fmt.reporter ())
+and () = Logs.Src.set_level Cohttp_eio.src (Some Debug)
+
+let ( / ) = Eio.Path.( / )
+
+(* To stream a file, we take the extra [writer] argument explicitly.
+ This means that we stream the response while the function is still
+ running and the file is still open. *)
+let handler dir _socket request _body writer =
+ let path =
+ Http.Request.resource request
+ |> String.split_on_char '/'
+ |> List.filter (( <> ) "")
+ |> String.concat "/"
+ in
+ let path = if path = "" then "index.html" else path in
+ Eio.Path.with_open_in (dir / path) @@ fun flow ->
+ Cohttp_eio.Server.respond () ~status:`OK
+ ~headers:(Http.Header.of_list [ ("content-type", "text/html") ])
+ ~body:flow writer
+
+let log_warning ex = Logs.warn (fun f -> f "%a" Eio.Exn.pp ex)
+
+let () =
+ let port = ref 8080 in
+ Arg.parse
+ [ ("-p", Arg.Set_int port, " Listening port number(8080 by default)") ]
+ ignore "An HTTP/1.1 server";
+ Eio_main.run @@ fun env ->
+ Eio.Switch.run @@ fun sw ->
+ (* Restrict to current directory: *)
+ let htdocs = Eio.Stdenv.cwd env in
+ let socket =
+ Eio.Net.listen env#net ~sw ~backlog:128 ~reuse_addr:true
+ (`Tcp (Eio.Net.Ipaddr.V4.loopback, !port))
+ and server = Cohttp_eio.Server.make ~callback:(handler htdocs) () in
+ Cohttp_eio.Server.run socket server ~on_error:log_warning
--- /dev/null
+type t = Eio.Flow.source_ty Eio.Resource.t
+type 't Eio.Flow.read_method += String of ('t -> string)
+
+module String_source = struct
+ type t = { s : string; mutable offset : int }
+
+ let single_read t dst =
+ if t.offset = String.length t.s then raise End_of_file;
+ let len = min (Cstruct.length dst) (String.length t.s - t.offset) in
+ Cstruct.blit_from_string t.s t.offset dst 0 len;
+ t.offset <- t.offset + len;
+ len
+
+ let original_string t = t.s
+ let read_methods = [ String original_string ]
+ let create s = { s; offset = 0 }
+end
+
+let of_string =
+ let ops = Eio.Flow.Pi.source (module String_source) in
+ fun s -> Eio.Resource.T (String_source.create s, ops)
--- /dev/null
+open Eio.Std
+open Utils
+
+type connection = Eio.Flow.two_way_ty r
+type t = sw:Switch.t -> Uri.t -> connection
+
+include
+ Cohttp.Generic.Client.Make
+ (struct
+ type 'a io = 'a
+ type body = Body.t
+ type 'a with_context = t -> sw:Eio.Switch.t -> 'a
+
+ let map_context v f t ~sw = f (v t ~sw)
+
+ let call (t : t) ~sw ?headers ?body ?(chunked = false) meth uri =
+ let socket = t ~sw uri in
+ let body_length =
+ if chunked then None
+ else
+ match body with
+ | None -> Some 0L
+ | Some (Eio.Resource.T (body, ops)) ->
+ let module X = (val Eio.Resource.get ops Eio.Flow.Pi.Source) in
+ List.find_map
+ (function
+ | Body.String m ->
+ Some (String.length (m body) |> Int64.of_int)
+ | _ -> None)
+ X.read_methods
+ in
+ let request =
+ Cohttp.Request.make_for_client ?headers
+ ~chunked:(Option.is_none body_length)
+ ?body_length meth uri
+ in
+ Eio.Buf_write.with_flow socket @@ fun output ->
+ let () =
+ Eio.Fiber.fork ~sw @@ fun () ->
+ Io.Request.write ~flush:false
+ (fun writer ->
+ match body with
+ | None -> ()
+ | Some body -> flow_to_writer body writer Io.Request.write_body)
+ request output
+ in
+ let input = Eio.Buf_read.of_flow ~max_size:max_int socket in
+ match Io.Response.read input with
+ | `Eof -> failwith "connection closed by peer"
+ | `Invalid reason -> failwith reason
+ | `Ok response -> (
+ match Cohttp.Response.has_body response with
+ | `No -> (response, Eio.Flow.string_source "")
+ | `Yes | `Unknown ->
+ let body =
+ let reader = Io.Response.make_body_reader response input in
+ flow_of_reader (fun () -> Io.Response.read_body_chunk reader)
+ in
+ (response, body))
+ end)
+ (Io.IO)
+
+let make_generic fn = (fn :> t)
+
+let unix_address uri =
+ match Uri.host uri with
+ | Some path -> `Unix path
+ | None -> Fmt.failwith "no host specified (in %a)" Uri.pp uri
+
+let tcp_address ~net uri =
+ let service =
+ match Uri.port uri with
+ | Some port -> Int.to_string port
+ | _ -> Uri.scheme uri |> Option.value ~default:"http"
+ in
+ match
+ Eio.Net.getaddrinfo_stream ~service net
+ (Uri.host_with_default ~default:"localhost" uri)
+ with
+ | ip :: _ -> ip
+ | [] -> failwith "failed to resolve hostname"
+
+let make ~https net : t =
+ let net = (net :> [ `Generic ] Eio.Net.ty r) in
+ let https =
+ (https
+ :> (Uri.t -> [ `Generic ] Eio.Net.stream_socket_ty r -> connection) option)
+ in
+ fun ~sw uri ->
+ match Uri.scheme uri with
+ | Some "httpunix" ->
+ (* FIXME: while there is no standard, http+unix seems more widespread *)
+ (Eio.Net.connect ~sw net (unix_address uri) :> connection)
+ | Some "http" ->
+ (Eio.Net.connect ~sw net (tcp_address ~net uri) :> connection)
+ | Some "https" -> (
+ match https with
+ | Some wrap ->
+ wrap uri @@ Eio.Net.connect ~sw net (tcp_address ~net uri)
+ | None -> Fmt.failwith "HTTPS not enabled (for %a)" Uri.pp uri)
+ | x ->
+ Fmt.failwith "Unknown scheme %a"
+ Fmt.(option ~none:(any "None") Dump.string)
+ x
--- /dev/null
+open Eio.Std
+
+type t
+
+include
+ Cohttp.Generic.Client.S
+ with type 'a with_context = t -> sw:Switch.t -> 'a
+ and type 'a io = 'a
+ and type body = Body.t
+
+val make :
+ https:
+ (Uri.t -> [ `Generic ] Eio.Net.stream_socket_ty r -> _ Eio.Flow.two_way)
+ option ->
+ _ Eio.Net.t ->
+ t
+(** [make ~https net] is a convenience wrapper around {!make_generic} that uses
+ [net] to make connections.
+
+ - URIs of the form "http://host:port/..." connect to the given TCP host and
+ port.
+ - URIs of the form "https://host:port/..." connect to the given TCP host and
+ port, and are then wrapped by [https] (or rejected if that is [None]).
+ - URIs of the form "httpunix://unix-path/http-path" connect to the given
+ Unix path. *)
+
+val make_generic : (sw:Switch.t -> Uri.t -> _ Eio.Flow.two_way) -> t
+(** [make_generic connect] is an HTTP client that uses [connect] to get the
+ connection to use for a given URI. *)
--- /dev/null
+module Body = Body
+module Client = Client
+module Server = Server
+
+module Private = struct
+ module IO = Io.IO
+end
+
+let src = Utils.src
--- /dev/null
+(library
+ (name cohttp_eio)
+ (public_name cohttp-eio)
+ (libraries cohttp eio fmt http logs ptime uri uri.services))
--- /dev/null
+let src = Logs.Src.create "cohttp.eio.io" ~doc:"Cohttp Eio IO module"
+
+module Logs = (val Logs.src_log src : Logs.LOG)
+
+module IO = struct
+ type 'a t = 'a
+
+ let ( >>= ) v f = f v
+ let return v = v
+
+ type ic = Eio.Buf_read.t
+ type oc = Eio.Buf_write.t
+ type conn = Eio.Switch.t * Eio.Net.Sockaddr.stream
+
+ let refill ic =
+ try
+ let () = Eio.Buf_read.(ensure ic (buffered_bytes ic + 1)) in
+ `Ok
+ with End_of_file -> `Eof
+
+ let with_input_buffer ic ~f =
+ let contents = Eio.Buf_read.peek ic in
+ let res, consumed =
+ f (Cstruct.to_string contents) ~pos:0 ~len:(Cstruct.length contents)
+ in
+ let () = Eio.Buf_read.consume ic consumed in
+ res
+
+ let read_line ic =
+ try
+ let line = Eio.Buf_read.line ic in
+ let () = Logs.debug (fun f -> f "<<< %s" line) in
+ Some line
+ with End_of_file ->
+ let () = Logs.debug (fun f -> f "<<< EOF") in
+ None
+
+ let read ic len =
+ match Eio.Buf_read.ensure ic 1 with
+ | exception End_of_file ->
+ let () = Logs.debug (fun f -> f "<<< EOF") in
+ ""
+ | () ->
+ let len = Int.min len (Eio.Buf_read.buffered_bytes ic) in
+ let read = Eio.Buf_read.take len ic in
+ let () = Logs.debug (fun f -> f "<<< %s" read) in
+ read
+
+ let write oc string =
+ let () = Logs.debug (fun f -> f ">>> %s" (String.trim string)) in
+ Eio.Buf_write.string oc string
+
+ let flush = Eio.Buf_write.flush
+end
+
+module Request = Cohttp.Request.Private.Make (IO)
+module Response = Cohttp.Response.Private.Make (IO)
+module Transfer = Cohttp.Private.Transfer_io.Make (IO)
--- /dev/null
+module IO :
+ Cohttp.S.IO
+ with type 'a t = 'a
+ and type conn = Eio.Switch.t * Eio.Net.Sockaddr.stream
+ and type ic = Eio.Buf_read.t
+ and type oc = Eio.Buf_write.t
+
+module Request :
+ Cohttp.S.Http_io with type t := Http.Request.t and module IO := IO
+
+module Response :
+ Cohttp.S.Http_io with type t := Http.Response.t and module IO := IO
+
+(* module Transfer : module type of Cohttp.Private.Transfer_io.Make (IO) *)
--- /dev/null
+open Utils
+module IO = Io.IO
+
+type body = Body.t
+type conn = IO.conn * Cohttp.Connection.t [@@warning "-3"]
+type writer = Http.Request.t * IO.oc
+type response = writer -> unit
+
+type response_action =
+ [ `Expert of Http.Response.t * (IO.ic -> IO.oc -> unit)
+ | `Response of response ]
+
+type t = {
+ conn_closed : conn -> unit;
+ handler : conn -> Http.Request.t -> body -> IO.ic -> IO.oc -> unit;
+}
+
+let make_response_action ?(conn_closed = fun _ -> ()) ~callback () =
+ {
+ conn_closed;
+ handler =
+ (fun conn request body ic oc ->
+ match callback conn request body with
+ | `Expert (response, handler) ->
+ Io.Response.write_header response oc;
+ handler ic oc
+ | `Response fn -> fn (request, oc));
+ }
+
+let make_expert ?conn_closed ~callback () =
+ make_response_action ?conn_closed
+ ~callback:(fun conn request body ->
+ let expert = callback conn request body in
+ `Expert expert)
+ ()
+
+let make ?(conn_closed = fun _ -> ()) ~callback () =
+ {
+ conn_closed;
+ handler =
+ (fun conn request body _ic oc -> callback conn request body (request, oc));
+ }
+
+let read input =
+ match Io.Request.read input with
+ | (`Eof | `Invalid _) as e -> e
+ | `Ok request -> (
+ match Http.Request.has_body request with
+ | `No -> `Ok (request, Eio.Flow.string_source "")
+ | _ ->
+ let body =
+ let reader = Io.Request.make_body_reader request input in
+ flow_of_reader (fun () -> Io.Request.read_body_chunk reader)
+ in
+ `Ok (request, body))
+
+let write output (response : Cohttp.Response.t) body =
+ let response =
+ let content_length =
+ let (Eio.Resource.T (body, ops)) = body in
+ let module X = (val Eio.Resource.get ops Eio.Flow.Pi.Source) in
+ List.find_map
+ (function
+ | Body.String get -> Some (String.length (get body)) | _ -> None)
+ X.read_methods
+ in
+ (* encoding field might be deprecated but it is still used
+ to compute headers and encode the body*)
+ match
+ (Cohttp.Header.get_transfer_encoding response.headers, content_length)
+ with
+ | Unknown, None ->
+ let headers =
+ Cohttp.Header.add_transfer_encoding response.headers Chunked
+ in
+ { response with headers }
+ | Unknown, Some size ->
+ let headers =
+ Cohttp.Header.add_transfer_encoding response.headers
+ (Fixed (Int64.of_int size))
+ in
+ { response with headers }
+ | _, _ -> response
+ in
+ let () = Logs.debug (fun m -> m "send headers") in
+ let () =
+ Io.Response.write ~flush:false
+ (fun writer ->
+ let () =
+ Logs.debug (fun m ->
+ m "send body (%a)" Cohttp.Transfer.pp_encoding
+ (Cohttp.Header.get_transfer_encoding response.headers))
+ in
+ flow_to_writer body writer Io.Response.write_body)
+ response output
+ in
+ Eio.Buf_write.flush output
+
+let respond ?encoding ?(headers = Cohttp.Header.init ()) ~status ~body ()
+ (request, oc) =
+ let keep_alive = Http.Request.is_keep_alive request in
+ let headers =
+ match Cohttp.Header.connection headers with
+ | Some _ -> headers
+ | None ->
+ Http.Header.add headers "connection"
+ (if keep_alive then "keep-alive" else "close")
+ in
+ let response = Cohttp.Response.make ?encoding ~headers ~status () in
+ write oc response body
+
+let respond_string ?headers ~status ~body () =
+ respond
+ ~encoding:(Fixed (String.length body |> Int64.of_int))
+ ?headers ~status ~body:(Body.of_string body) ()
+
+let respond ?headers ~status ~body () response =
+ respond ?encoding:None ?headers ~status ~body () response
+
+let callback { conn_closed; handler } ((_, peer_address) as conn) input output =
+ let id = (Cohttp.Connection.create () [@ocaml.warning "-3"]) in
+ let rec handle () =
+ match read input with
+ | `Eof ->
+ let () =
+ Logs.info (fun m ->
+ m "%a: disconnected" Eio.Net.Sockaddr.pp peer_address)
+ in
+ conn_closed (conn, id)
+ | exception Eio.Io (Eio.Net.E (Connection_reset _), _) ->
+ let () =
+ Logs.info (fun m ->
+ m "%a: connection reset" Eio.Net.Sockaddr.pp peer_address)
+ in
+ ()
+ | `Invalid e ->
+ write output
+ (Http.Response.make ~status:`Bad_request ())
+ (Body.of_string e)
+ | `Ok (request, body) ->
+ let () =
+ try handler (conn, id) request body input output
+ with Eio.Io (Eio.Net.E (Connection_reset _), _) ->
+ Logs.info (fun m ->
+ m "%a: connection reset" Eio.Net.Sockaddr.pp peer_address)
+ in
+ if Cohttp.Request.is_keep_alive request then handle ()
+ in
+ handle ()
+
+let run ?max_connections ?additional_domains ?stop ~on_error socket server =
+ Eio.Net.run_server socket ?max_connections ?additional_domains ?stop ~on_error
+ (fun socket peer_address ->
+ Eio.Switch.run @@ fun sw ->
+ let () =
+ Logs.info (fun m ->
+ m "%a: accept connection" Eio.Net.Sockaddr.pp peer_address)
+ and input = Eio.Buf_read.of_flow ~max_size:max_int socket in
+ try
+ Eio.Buf_write.with_flow socket @@ fun output ->
+ callback server (sw, peer_address) input output
+ with Eio.Io (Eio.Net.E (Connection_reset _), _) ->
+ Logs.info (fun m ->
+ m "%a: connection reset" Eio.Net.Sockaddr.pp peer_address))
--- /dev/null
+type writer
+
+include
+ Cohttp.Generic.Server.S
+ with module IO = Io.IO
+ and type body = Body.t
+ and type response = writer -> unit
+
+val respond :
+ ?headers:Http.Header.t ->
+ status:Http.Status.t ->
+ body:_ Eio.Flow.source ->
+ unit ->
+ response IO.t
+
+val run :
+ ?max_connections:int ->
+ ?additional_domains:_ Eio__Domain_manager.t * int ->
+ ?stop:'a Eio.Promise.t ->
+ on_error:(exn -> unit) ->
+ _ Eio.Net.listening_socket ->
+ t ->
+ 'a
--- /dev/null
+let src = Logs.Src.create "cohttp.eio" ~doc:"Cohttp Eio backend"
+
+module Logs = (val Logs.src_log src)
+
+module Reader_flow = struct
+ type t = {
+ read_body_chunk : unit -> Cohttp.Transfer.chunk;
+ mutable buffered : (string * int) option;
+ }
+
+ let v read_body_chunk = { read_body_chunk; buffered = None }
+
+ let single_read t output =
+ let output_length = Cstruct.length output in
+ let send buffer pos =
+ let available = String.length buffer - pos in
+ if output_length >= available then
+ let () = Cstruct.blit_from_string buffer pos output 0 available
+ and () = t.buffered <- None in
+ available
+ else
+ let () = Cstruct.blit_from_string buffer 0 output 0 output_length
+ and () = t.buffered <- Some (buffer, pos + output_length) in
+ output_length
+ in
+ match t.buffered with
+ | Some (buffer, pos) -> send buffer pos
+ | None -> (
+ match t.read_body_chunk () with
+ | Cohttp.Transfer.Done ->
+ let () = Logs.debug (fun m -> m "end of inbound body") in
+ raise End_of_file
+ | Chunk data | Final_chunk data ->
+ let () =
+ Logs.debug (fun m ->
+ m "received %d bytes of body" (String.length data))
+ in
+ send data 0)
+
+ let read_methods = []
+end
+
+let flow_of_reader =
+ let handler = Eio.Flow.Pi.source (module Reader_flow) in
+ fun read_body_chunk -> Eio.Resource.T (Reader_flow.v read_body_chunk, handler)
+
+let flow_to_writer flow writer write_body =
+ let input = Eio.Buf_read.of_flow ~max_size:max_int flow in
+ let rec loop () =
+ let () =
+ let () = Eio.Buf_read.ensure input 1 in
+ let contents = Eio.Buf_read.(take (buffered_bytes input) input) in
+ let () =
+ Logs.debug (fun m -> m "send %d bytes of body" (String.length contents))
+ in
+ write_body writer contents
+ in
+ loop ()
+ in
+ try loop ()
+ with End_of_file ->
+ let () = Logs.debug (fun m -> m "end of outbound body") in
+ ()
--- /dev/null
+(test
+ (name test)
+ (libraries alcotest cohttp-eio eio eio.mock eio_main logs.fmt)
+ (package cohttp-eio)
+ (preprocess
+ (pps ppx_here)))
--- /dev/null
+let () =
+ Logs.set_level ~all:true @@ Some Logs.Debug;
+ Logs.set_reporter (Logs_fmt.reporter ())
+
+let handler _conn request body =
+ match Http.Request.resource request with
+ | "/" -> Cohttp_eio.Server.respond_string ~status:`OK ~body:"root" ()
+ | "/stream" ->
+ let body = Eio_mock.Flow.make "streaming body" in
+ let () =
+ Eio_mock.Flow.on_read body
+ [ `Return "Hello"; `Yield_then (`Return "World") ]
+ in
+ Cohttp_eio.Server.respond ~status:`OK ~body ()
+ | "/post" -> Cohttp_eio.Server.respond ~status:`OK ~body ()
+ | _ -> Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
+
+let () =
+ Eio_main.run @@ fun env ->
+ Eio.Switch.run @@ fun sw ->
+ let () =
+ let socket =
+ Eio.Net.listen env#net ~sw ~backlog:128 ~reuse_addr:true ~reuse_port:true
+ (`Tcp (Eio.Net.Ipaddr.V4.loopback, 4242))
+ and server = Cohttp_eio.Server.make ~callback:handler () in
+ Eio.Fiber.fork_daemon ~sw @@ fun () ->
+ let () = Cohttp_eio.Server.run socket server ~on_error:raise in
+ `Stop_daemon
+ in
+ let test_case name f =
+ let f () =
+ let socket =
+ Eio.Net.connect ~sw env#net (`Tcp (Eio.Net.Ipaddr.V4.loopback, 4242))
+ in
+ f socket
+ in
+ Alcotest.test_case name `Quick f
+ in
+ let root socket =
+ let () =
+ Eio.Flow.write socket
+ [ Cstruct.of_string "GET / HTTP/1.1\r\nconnection: close\r\n\r\n" ]
+ in
+ Alcotest.(check ~here:[%here] string)
+ "response"
+ "HTTP/1.1 200 OK\r\nconnection: close\r\ncontent-length: 4\r\n\r\nroot"
+ Eio.Buf_read.(of_flow ~max_size:max_int socket |> take_all)
+ and missing socket =
+ let () =
+ Eio.Flow.write socket
+ [
+ Cstruct.of_string "GET /missing HTTP/1.1\r\nconnection: close\r\n\r\n";
+ ]
+ in
+ Alcotest.(check ~here:[%here] string)
+ "response"
+ "HTTP/1.1 404 Not Found\r\nconnection: close\r\ncontent-length: 0\r\n\r\n"
+ Eio.Buf_read.(of_flow ~max_size:max_int socket |> take_all)
+ and streaming_response socket =
+ let () =
+ Eio.Flow.write socket
+ [
+ Cstruct.of_string "GET /stream HTTP/1.1\r\nconnection: close\r\n\r\n";
+ ]
+ in
+ Alcotest.(check ~here:[%here] string)
+ "response"
+ "HTTP/1.1 200 OK\r\n\
+ connection: close\r\n\
+ transfer-encoding: chunked\r\n\
+ \r\n\
+ 5\r\n\
+ Hello\r\n\
+ 5\r\n\
+ World\r\n\
+ 0\r\n\
+ \r\n"
+ Eio.Buf_read.(of_flow ~max_size:max_int socket |> take_all)
+ and request_body socket =
+ let () =
+ Eio.Flow.write socket
+ [
+ Cstruct.of_string
+ "POST /post HTTP/1.1\r\n\
+ connection: close\r\n\
+ content-length:12\r\n\
+ \r\n\
+ hello world!";
+ ]
+ in
+ Alcotest.(check ~here:[%here] string)
+ "response"
+ "HTTP/1.1 200 OK\r\n\
+ connection: close\r\n\
+ transfer-encoding: chunked\r\n\
+ \r\n\
+ c\r\n\
+ hello world!\r\n\
+ 0\r\n\
+ \r\n"
+ Eio.Buf_read.(of_flow ~max_size:max_int socket |> take_all)
+ in
+ Alcotest.run "cohttp-eio"
+ [
+ ( "cohttp-eio server",
+ [
+ test_case "root" root;
+ test_case "missing" missing;
+ test_case "streaming response" streaming_response;
+ test_case "request body" request_body;
+ ] );
+ ]
-version: "5.3.1"
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
-maintainer: "anil@recoil.org"
+synopsis: "CoHTTP implementation for the Js_of_ocaml JavaScript compiler"
+description: """
+An implementation of an HTTP client for JavaScript, but using the
+CoHTTP types. This lets you build HTTP clients that can compile
+natively (using one of the other Cohttp backends such as `cohttp-lwt-unix`)
+and also to native JavaScript via js_of_ocaml.
+"""
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
authors: [
"Anil Madhavapeddy"
"Stefano Zacchiroli"
"David Scott"
"Rudi Grinberg"
"Andy Ray"
+ "Anurag Soni"
]
-synopsis: "CoHTTP implementation for the Js_of_ocaml JavaScript compiler"
-description: """
-An implementation of an HTTP client for JavaScript, but using the
-CoHTTP types. This lets you build HTTP clients that can compile
-natively (using one of the other Cohttp backends such as `cohttp-lwt-unix`)
-and also to native JavaScript via js_of_ocaml.
-"""
license: "ISC"
-tags: ["org:mirage" "org:xapi-project"]
homepage: "https://github.com/mirage/ocaml-cohttp"
doc: "https://mirage.github.io/ocaml-cohttp/"
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
+ "dune" {>= "3.8"}
"ocaml" {>= "4.08"}
- "dune" {>= "2.0"}
+ "http" {= version}
"cohttp" {= version}
"cohttp-lwt" {= version}
"logs"
"js_of_ocaml" {>= "3.3.0"}
"js_of_ocaml-ppx" {>= "3.3.0"}
"js_of_ocaml-lwt" {>= "3.5.0"}
+ "odoc" {with-doc}
]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
build: [
["dune" "subst"] {dev}
- ["dune" "build" "-p" name "-j" jobs]
- ["dune" "runtest" "-p" name "-j" jobs] {with-test}
-]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-lwt-jsoo/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-lwt-jsoo/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
let xhr_response_supported =
(* from http://stackoverflow.com/questions/8926505/how-to-feature-detect-if-xmlhttprequest-supports-responsetype-arraybuffer *)
- let xhr = XmlHttpRequest.create () in
- let rt = xhr##.responseType in
- Js.to_string (Js.typeof rt) = "string"
+ lazy
+ (let xhr = XmlHttpRequest.create () in
+ let rt = xhr##.responseType in
+ Js.to_string (Js.typeof rt) = "string")
let binary_string str =
let len = String.length str in
let string_of_uint8array u8a offset len =
String.init len (fun i -> Char.chr (Typed_array.unsafe_get u8a (offset + i)))
-module String_io = Cohttp__String_io
-module IO = Cohttp_lwt__String_io
-module Header_io = Cohttp__Header_io.Make (IO)
+module String_io = Cohttp.Private.String_io
+module IO = Cohttp_lwt.Private.String_io
+module Header_io = Cohttp.Private.Header_io.Make (IO)
module Body_builder (P : Params) = struct
let src = Logs.Src.create "cohttp.lwt.jsoo" ~doc:"Cohttp Lwt JSOO module"
(fun () -> `String (Js.string ""))
(fun s -> `String s)
in
- match xhr_response_supported with
+ match Lazy.force xhr_response_supported with
| true when Js.Opt.return xml##.response == Js.null ->
Log.warn (fun m -> m "XHR Response is null; using empty string");
`String (Js.string "")
module Response : Cohttp.S.Response
val call :
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
?body:Cohttp_lwt.Body.t ->
- Cohttp.Code.meth ->
+ Http.Method.t ->
Uri.t ->
(Response.t * Cohttp_lwt.Body.t) Lwt.t
end) =
module Request = X.Request
module Response = X.Response
+ type 'a io = 'a Lwt.t
+ type body = Cohttp_lwt.Body.t
type ctx = unit
+ type 'a with_context = ?ctx:ctx -> 'a
+
+ let map_context v f ?ctx = f (v ?ctx)
let call ?ctx:_ ?headers ?body ?chunked:_ meth uri =
X.call ?headers ?body meth uri
let body = Cohttp_lwt.Body.of_string (Uri.encoded_of_query params) in
post ?ctx ~chunked:false ~headers ~body uri
+ exception Cohttp_lwt_xhr_set_cache_not_implemented
+
+ let set_cache _ = raise Cohttp_lwt_xhr_set_cache_not_implemented
+
(* No implementation (can it be done?). What should the failure exception be? *)
exception Cohttp_lwt_xhr_callv_not_implemented
- let callv ?ctx:_ _uri _reqs = Lwt.fail Cohttp_lwt_xhr_callv_not_implemented
+ let callv ?ctx:_ _uri _reqs = raise Cohttp_lwt_xhr_callv_not_implemented
(* ??? *)
end
let call ?headers ?body meth uri =
let xml = XmlHttpRequest.create () in
xml##.withCredentials := Js.bool P.with_credentials;
- if xhr_response_supported then xml##.responseType := Js.string "arraybuffer";
- let (res : (Response.t Lwt.t * CLB.t) Lwt.t), wake = Lwt.task () in
+ if Lazy.force xhr_response_supported then
+ xml##.responseType := Js.string "arraybuffer";
+ let (res : (Http.Response.t Lwt.t * CLB.t) Lwt.t), wake = Lwt.task () in
let () =
xml
## (_open
Header_io.parse channel >|= fun resp_headers ->
Cohttp.Response.make ~version:`HTTP_1_1
~status:(C.Code.status_of_code xml##.status)
- ~flush:false (* ??? *)
~encoding:(CLB.transfer_encoding body)
~headers:resp_headers ())
in
with
| e
(* If we exhaust the stack, it is possible that
- Lwt.wakeup just aboves marks the promise as
+ Lwt.wakeup just above marks the promise as
completed, but raises Stack_overflow while
running the promise callbacks. In this case
waking calling wakeup_exn on the already
CLB.to_string body >>= fun body ->
let bs = binary_string body in
(*Js.Opt.case (File.CoerceTo.blob (Obj.magic blob))
- (fun () -> Lwt.fail_with "could not coerce to blob")
+ (fun () -> failwith "could not coerce to blob")
(fun blob -> Lwt.return (xml##(send_blob blob)))*)
(*Lwt.return (xml##send (Js.Opt.return bs)) *)
Lwt.return (xml##send (Js.Opt.return (Obj.magic bs))))
let call ?headers ?body meth uri =
let xml = XmlHttpRequest.create () in
xml##.withCredentials := Js.bool P.with_credentials;
- if xhr_response_supported then xml##.responseType := Js.string "arraybuffer";
+ if Lazy.force xhr_response_supported then
+ xml##.responseType := Js.string "arraybuffer";
let () =
xml
## (_open
let response =
Response.make ~version:`HTTP_1_1
~status:(Cohttp.Code.status_of_code xml##.status)
- ~flush:false
~encoding:(CLB.transfer_encoding body)
~headers:resp_headers ()
in
(** Build an asynchronous engine with chunked/unchucked response data treated as
raw bytes or UTF *)
-module Make_client_async (P : Params) : Cohttp_lwt.S.Client
+module Make_client_async (_ : Params) : Cohttp_lwt.S.Client
(** Build a synchronous engine with chunked/unchucked response data treated as
raw bytes or UTF *)
-module Make_client_sync (P : Params) : Cohttp_lwt.S.Client
+module Make_client_sync (_ : Params) : Cohttp_lwt.S.Client
module Client : Cohttp_lwt.S.Client
(** The [Client] module implements an HTTP client interface using asynchronous
--- /dev/null
+{
+ "license": "ISC",
+ "dependencies": {
+ "xmlhttprequest": "1.8.0"
+ }
+}
--- /dev/null
+module Client = Cohttp_lwt_jsoo.Client
+module Js = Js_of_ocaml.Js
+
+let _Promise = Js.Unsafe.global##._Promise
+let ( let* ) = Lwt.( >>= )
+let ( let+ ) = Lwt.( >|= )
+
+let promise_of_lwt lwt =
+ new%js _Promise
+ (Js.wrap_callback (fun resolve reject ->
+ try%lwt
+ let+ res = lwt () in
+ Js.Unsafe.fun_call resolve [| Js.Unsafe.inject res |]
+ with e ->
+ let msg = Printexc.to_string e in
+ Js.Unsafe.fun_call reject
+ [| Js.Unsafe.inject (new%js Js.error_constr (Js.string msg)) |]))
+
+let () =
+ Js.export_all
+ (object%js
+ method request uri =
+ let f () =
+ let uri = Uri.of_string (Js.to_string uri) in
+ let* response, body = Client.get uri in
+ let+ body = Cohttp_lwt.Body.to_string body in
+ let status =
+ Http.Response.status response |> Cohttp.Code.code_of_status
+ in
+ Js.array
+ [| Js.Unsafe.inject status; Js.Unsafe.inject @@ Js.string body |]
+ in
+ promise_of_lwt f
+ end)
--- /dev/null
+(executable
+ (name cohttp_lwt_jsoo_test)
+ (modes js)
+ (libraries http cohttp cohttp-lwt cohttp-lwt-jsoo lwt js_of_ocaml-lwt)
+ (preprocess
+ (pps lwt_ppx js_of_ocaml-ppx)))
+
+(rule
+ (alias runjstest)
+ (deps test.js cohttp_lwt_jsoo_test.bc.js)
+ (action
+ (setenv
+ NODE_PATH
+ "%{project_root}/cohttp-lwt-jsoo/test/node_modules"
+ (run ./test.js))))
--- /dev/null
+#!/usr/bin/env node
+
+const assert = require("assert");
+const { XMLHttpRequest } = require("xmlhttprequest");
+
+global.XMLHttpRequest = XMLHttpRequest;
+
+const tests = require("./cohttp_lwt_jsoo_test.bc.js");
+
+async function main() {
+ {
+ const [status, _body] = await tests.request("https://mirage.io");
+ assert(status === 200);
+ }
+ {
+ const [status, _body] = await tests.request(
+ "https://this.domain.does.not.exist"
+ );
+ assert(status === 0);
+ }
+}
+
+main();
--- /dev/null
+# THIS IS AN AUTOGENERATED FILE. DO NOT EDIT THIS FILE DIRECTLY.
+# yarn lockfile v1
+
+
+xmlhttprequest@1.8.0:
+ version "1.8.0"
+ resolved "https://registry.yarnpkg.com/xmlhttprequest/-/xmlhttprequest-1.8.0.tgz#67fe075c5c24fef39f9d65f5f7b7fe75171968fc"
+ integrity sha1-Z/4HXFwk/vOfnWX197f+dRcZaPw=
-version: "5.3.1"
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
-maintainer: "anil@recoil.org"
-authors: [
- "Anil Madhavapeddy"
- "Stefano Zacchiroli"
- "David Sheets"
- "Thomas Gazagnaire"
- "David Scott"
- "Rudi Grinberg"
- "Andy Ray"
-]
synopsis: "CoHTTP implementation for Unix and Windows using Lwt"
description: """
An implementation of an HTTP client and server using the Lwt
client and server respectively.
Although the name implies that this only works under Unix, it
-should also be fine under Windows too."""
+should also be fine under Windows too.
+"""
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
+authors: [
+ "Anil Madhavapeddy"
+ "Stefano Zacchiroli"
+ "David Sheets"
+ "Thomas Gazagnaire"
+ "David Scott"
+ "Rudi Grinberg"
+ "Andy Ray"
+ "Anurag Soni"
+]
license: "ISC"
-tags: ["org:mirage" "org:xapi-project"]
homepage: "https://github.com/mirage/ocaml-cohttp"
doc: "https://mirage.github.io/ocaml-cohttp/"
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
+ "dune" {>= "3.8"}
"ocaml" {>= "4.08"}
- "dune" {>= "2.0"}
+ "http" {= version}
+ "cohttp" {= version}
+ "cohttp-lwt" {= version}
+ "cmdliner" {>= "1.1.0"}
+ "lwt" {>= "3.0.0"}
"conduit-lwt" {>= "5.0.0"}
"conduit-lwt-unix" {>= "5.0.0"}
- "cmdliner" {>= "1.1.0"}
- "magic-mime"
- "logs"
"fmt" {>= "0.8.2"}
- "cohttp-lwt" {= version}
- "ppx_sexp_conv" {>= "v0.13.0"}
- "lwt" {>= "3.0.0"}
"base-unix"
- "ounit" {with-test}
+ "ppx_sexp_conv" {>= "v0.13.0"}
+ "magic-mime"
+ "logs"
+ "ounit2" {with-test}
+ "odoc" {with-doc}
]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
build: [
["dune" "subst"] {dev}
- ["dune" "build" "-p" name "-j" jobs]
- ["dune" "runtest" "-p" name "-j" jobs] {with-test}
-]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-lwt-unix/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-lwt-unix/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
in
Server.respond ~headers ~status ~body ()
-let sockaddr_of_host_and_port host port =
- let inet_addr = Unix.inet_addr_of_string host in
- Unix.ADDR_INET (inet_addr, port)
-
let start_proxy port host verbose cert key () =
printf "Listening for HTTP request on: %s %d\n%!" host port;
let conn_closed (ch, _conn) =
Server.respond_string ~status:`Not_found
~body:(html_of_not_found path info)
()
- else Lwt.fail e
- | e -> Lwt.fail e)
+ else Lwt.reraise e
+ | e -> Lwt.reraise e)
let handler ~info ~docroot ~index (ch, _conn) req _body =
let uri = Cohttp.Request.uri req in
logs.cli
cmdliner
conduit-lwt
- fmt.tty)
- (package cohttp-lwt-unix)
- (public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt))
+ fmt.tty))
--- /dev/null
+open Lwt
+open Cohttp
+open Cohttp_lwt_unix
+
+let body =
+ Client.get (Uri.of_string "https://www.reddit.com/") >>= fun (resp, body) ->
+ let code = resp |> Response.status |> Code.code_of_status in
+ Printf.printf "Response code: %d\n" code;
+ Printf.printf "Headers: %s\n" (resp |> Response.headers |> Header.to_string);
+ body |> Cohttp_lwt.Body.to_string >|= fun body ->
+ Printf.printf "Body of length: %d\n" (String.length body);
+ body
+
+let () =
+ let body = Lwt_main.run body in
+ print_endline ("Received body\n" ^ body)
--- /dev/null
+open Lwt
+open Cohttp
+open Cohttp_lwt_unix
+
+let compute ~time ~f =
+ Lwt.pick
+ [
+ (f () >|= fun v -> `Done v); (Lwt_unix.sleep time >|= fun () -> `Timeout);
+ ]
+
+let body =
+ let get () = Client.get (Uri.of_string "https://www.reddit.com/") in
+ compute ~time:0.1 ~f:get >>= function
+ | `Timeout -> failwith "Timeout expired"
+ | `Done (resp, body) ->
+ let code = resp |> Response.status |> Code.code_of_status in
+ Printf.printf "Response code: %d\n" code;
+ Printf.printf "Headers: %s\n"
+ (resp |> Response.headers |> Header.to_string);
+ body |> Cohttp_lwt.Body.to_string >|= fun body ->
+ Printf.printf "Body of length: %d\n" (String.length body);
+ body
+
+let () =
+ let body = Lwt_main.run body in
+ print_endline ("Received body\n" ^ body)
--- /dev/null
+open Lwt.Infix
+
+let ctx =
+ let resolver =
+ let h = Hashtbl.create 1 in
+ Hashtbl.add h "docker" (`Unix_domain_socket "/var/run/docker.sock");
+ Resolver_lwt_unix.static h
+ in
+ Cohttp_lwt_unix.Client.custom_ctx ~resolver ()
+
+let t =
+ Cohttp_lwt_unix.Client.get ~ctx (Uri.of_string "http://docker/version")
+ >>= fun (resp, body) ->
+ let open Cohttp in
+ let code = resp |> Response.status |> Code.code_of_status in
+ Printf.printf "Response code: %d\n" code;
+ Printf.printf "Headers: %s\n" (resp |> Response.headers |> Header.to_string);
+ body |> Cohttp_lwt.Body.to_string >|= fun body ->
+ Printf.printf "Body of length: %d\n" (String.length body);
+ print_endline ("Received body\n" ^ body)
+
+let _ = Lwt_main.run t
--- /dev/null
+(executables
+ (names client_lwt client_lwt_timeout docker_lwt server_lwt)
+ (libraries cohttp-lwt-unix))
+
+(alias
+ (name runtest)
+ (package cohttp-lwt-unix)
+ (deps client_lwt.exe client_lwt_timeout.exe docker_lwt.exe server_lwt.exe))
--- /dev/null
+open Lwt
+open Cohttp
+open Cohttp_lwt_unix
+
+let server =
+ let callback _conn req body =
+ let uri = req |> Request.uri |> Uri.to_string in
+ let meth = req |> Request.meth |> Code.string_of_method in
+ let headers = req |> Request.headers |> Header.to_string in
+ ( body |> Cohttp_lwt.Body.to_string >|= fun body ->
+ Printf.sprintf "Uri: %s\nMethod: %s\nHeaders\nHeaders: %s\nBody: %s" uri
+ meth headers body )
+ >>= fun body -> Server.respond_string ~status:`OK ~body ()
+ in
+ Server.create ~mode:(`TCP (`Port 8000)) (Server.make ~callback ())
+
+let () = ignore (Lwt_main.run server)
+++ /dev/null
-include Cohttp_lwt.Make_client (Io) (Net)
-
-let custom_ctx = Net.init
+++ /dev/null
-(** The [Client] module implements the full UNIX HTTP client interface,
- including the UNIX-specific functions defined in {!C}. *)
-
-include Cohttp_lwt.S.Client with type ctx = Net.ctx
-
-val custom_ctx :
- ?ctx:Conduit_lwt_unix.ctx -> ?resolver:Resolver_lwt.t -> unit -> ctx
-(** [custom_ctx ?ctx ?resolver ()] will return a context that is the same as the
- {!default_ctx}, but with either the connection handling or resolution module
- overridden with [ctx] or [resolver] respectively. This is useful to supply a
- {!Conduit_lwt_unix.ctx} with a custom source network interface, or a
- {!Resolver_lwt.t} with a different name resolution strategy (for instance to
- override a hostname to point it to a Unix domain socket). *)
module Request = struct
include Cohttp.Request
- include (Make (Io) : module type of Make (Io) with type t := t)
+
+ include (
+ Private.Make (Io) : module type of Private.Make (Io) with type t := t)
end
module Response = struct
include Cohttp.Response
- include (Make (Io) : module type of Make (Io) with type t := t)
+
+ include (
+ Private.Make (Io) : module type of Private.Make (Io) with type t := t)
end
-module Client = Client
+module Connection = Cohttp_lwt.Connection.Make (Net)
+
+module Connection_cache =
+ Cohttp_lwt.Connection_cache.Make
+ (Connection)
+ (struct
+ (* : Mirage_time.S *)
+ let sleep_ns ns = Lwt_unix.sleep (Int64.to_float ns /. 1_000_000_000.)
+ end)
+
+module Client : sig
+ (** The [Client] module implements the full UNIX HTTP client interface,
+ including the UNIX-specific functions defined in {!C}. *)
+
+ include Cohttp_lwt.S.Client with type ctx = Net.ctx
+
+ val custom_ctx :
+ ?ctx:Conduit_lwt_unix.ctx -> ?resolver:Resolver_lwt.t -> unit -> Net.ctx
+ (** [custom_ctx ?ctx ?resolver ()] will return a context that is the same as
+ the {!default_ctx}, but with either the connection handling or resolution
+ module overridden with [ctx] or [resolver] respectively. This is useful to
+ supply a {!Conduit_lwt_unix.ctx} with a custom source network interface,
+ or a {!Resolver_lwt.t} with a different name resolution strategy (for
+ instance to override a hostname to point it to a Unix domain socket). *)
+end = struct
+ include Cohttp_lwt.Client.Make (Connection)
+
+ let custom_ctx = Net.init
+end
+
module Server = Server
module Debug = Debug
module Net = Net
-module IO = Io
+module IO = Io [@@deprecated "This module is not for public consumption"]
+
+module Private = struct
+ module Input_channel = Input_channel
+ module IO = Io
+end
let set_logger =
lazy
(if
- (* If no reporter has been set by the application, set default one
- that prints to stderr *)
- Logs.reporter () == Logs.nop_reporter
- then Logs.set_reporter default_reporter)
+ (* If no reporter has been set by the application, set default one
+ that prints to stderr *)
+ Logs.reporter () == Logs.nop_reporter
+ then Logs.set_reporter default_reporter)
let activate_debug () =
if not !_debug_active then (
(synopsis "Lwt/Unix backend for Cohttp")
(preprocess
(pps ppx_sexp_conv))
- (libraries fmt logs logs.lwt conduit-lwt magic-mime lwt.unix
- conduit-lwt-unix cohttp cohttp-lwt logs.fmt))
+ (libraries
+ fmt
+ logs
+ logs.lwt
+ conduit-lwt
+ magic-mime
+ lwt.unix
+ conduit-lwt-unix
+ http
+ cohttp
+ cohttp-lwt
+ logs.fmt))
--- /dev/null
+open Lwt.Infix
+module Bytebuffer = Cohttp_lwt.Private.Bytebuffer
+
+type t = { buf : Bytebuffer.t; chan : Lwt_io.input_channel }
+
+let refill ic buf ~pos ~len =
+ Lwt.catch
+ (fun () ->
+ Lwt_io.read_into ic buf pos len >|= fun c -> if c > 0 then `Ok c else `Eof)
+ (function Lwt_io.Channel_closed _ -> Lwt.return `Eof | exn -> raise exn)
+
+let create ?(buf_len = 0x4000) chan = { buf = Bytebuffer.create buf_len; chan }
+let read_line_opt t = Bytebuffer.read_line t.buf (refill t.chan)
+let read t count = Bytebuffer.read t.buf (refill t.chan) count
+let refill t = Bytebuffer.refill t.buf (refill t.chan)
+
+let with_input_buffer t ~f =
+ let buf = Bytebuffer.unsafe_buf t.buf in
+ let pos = Bytebuffer.pos t.buf in
+ let len = Bytebuffer.length t.buf in
+ let res, consumed = f (Bytes.unsafe_to_string buf) ~pos ~len in
+ Bytebuffer.drop t.buf consumed;
+ res
+
+let close t = Lwt_io.close t.chan
let ( >>= ) = Lwt.bind
let return = Lwt.return
-type ic = Lwt_io.input_channel
+type ic = Input_channel.t
type oc = Lwt_io.output_channel
type conn = Conduit_lwt_unix.flow
https://github.com/ocsigen/lwt/pull/635 *)
Lwt.catch f (function
| Lwt_io.Channel_closed _ -> Lwt.return if_closed
- | Unix.Unix_error _ as e -> Lwt.fail (IO_error e)
+ | Unix.Unix_error _ as e -> raise (IO_error e)
| exn -> raise exn)
let wrap_write f =
Lwt.catch f (function
- | Unix.Unix_error _ as e -> Lwt.fail (IO_error e)
+ | Unix.Unix_error _ as e -> raise (IO_error e)
| exn -> raise exn)
let read_line ic =
wrap_read ~if_closed:None (fun () ->
- Lwt_io.read_line_opt ic >>= function
+ Input_channel.read_line_opt ic >>= function
| None ->
Log.debug (fun f -> f "<<< EOF");
Lwt.return_none
let read ic count =
let count = min count Sys.max_string_length in
wrap_read ~if_closed:"" (fun () ->
- Lwt_io.read ~count ic >>= fun buf ->
+ Input_channel.read ic count >>= fun buf ->
Log.debug (fun f -> f "<<<[%d] %s" count buf);
Lwt.return buf)
+let refill ic = Input_channel.refill ic
+let with_input_buffer ic = Input_channel.with_input_buffer ic
+
let write oc buf =
wrap_write @@ fun () ->
Log.debug (fun f -> f ">>> %s" (String.trim buf));
let catch f =
Lwt.try_bind f Lwt.return_ok (function
| IO_error e -> Lwt.return_error e
- | ex -> Lwt.fail ex)
+ | ex -> Lwt.reraise ex)
let pp_error = Fmt.exn
include
Cohttp_lwt.S.IO
- with type ic = Lwt_io.input_channel
+ with type ic = Input_channel.t
and type oc = Lwt_io.output_channel
and type conn = Conduit_lwt_unix.flow
and type error = exn
{ ctx; resolver }
let default_ctx =
- {
- resolver = Resolver_lwt_unix.system;
- ctx = Lazy.force Conduit_lwt_unix.default_ctx;
- }
+ lazy
+ {
+ resolver = Resolver_lwt_unix.system;
+ ctx = Lazy.force Conduit_lwt_unix.default_ctx;
+ }
-let connect_uri ~ctx:{ ctx; resolver } uri =
- Resolver_lwt.resolve_uri ~uri resolver >>= fun endp ->
+type endp = Conduit.endp
+
+let resolve ~ctx uri = Resolver_lwt.resolve_uri ~uri ctx.resolver
+
+let connect_endp ~ctx:{ ctx; _ } endp =
Conduit_lwt_unix.endp_to_client ~ctx endp >>= fun client ->
- Conduit_lwt_unix.connect ~ctx client
+ Conduit_lwt_unix.connect ~ctx client >|= fun (flow, ic, oc) ->
+ let ic = Input_channel.create ic in
+ (flow, ic, oc)
+
+let connect_uri ~ctx uri = resolve ~ctx uri >>= connect_endp ~ctx
let close c =
+ Lwt.catch
+ (fun () -> Input_channel.close c)
+ (fun e ->
+ Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e));
+ Lwt.return_unit)
+
+let close_oc c =
Lwt.catch
(fun () -> Lwt_io.close c)
(fun e ->
Lwt.return_unit)
let close_in ic = Lwt.ignore_result (close ic)
-let close_out oc = Lwt.ignore_result (close oc)
-let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close oc)
+let close_out oc = Lwt.ignore_result (close_oc oc)
+let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close_oc oc)
(** Basic satisfaction of {!Cohttp_lwt.Net} *)
-module IO = Io
-
type ctx = { ctx : Conduit_lwt_unix.ctx; resolver : Resolver_lwt.t }
[@@deriving sexp_of]
-val default_ctx : ctx
-(** [default_ctx] is the default network context. It uses
- [Conduit_lwt_unix.default_ctx] and [Resolver_lwt_unix.system]. *)
+include
+ Cohttp_lwt.S.Net
+ with module IO = Io
+ and type ctx := ctx
+ and type endp = Conduit.endp
val init : ?ctx:Conduit_lwt_unix.ctx -> ?resolver:Resolver_lwt.t -> unit -> ctx
(** [init ?ctx ?resolver ()] is a network context that is the same as the
{!Conduit_lwt_unix.resolver} with a custom source network interface, or a
{!Resolver_lwt.t} with a different name resolution strategy (for instance to
override a hostname to point it to a Unix domain socket). *)
-
-val connect_uri :
- ctx:ctx ->
- Uri.t ->
- (Conduit_lwt_unix.flow
- * Lwt_io.input Lwt_io.channel
- * Lwt_io.output Lwt_io.channel)
- Lwt.t
-(** [connect_uri ~ctx uri] starts a {i flow} on the given [uri]. The choice of
- the protocol (with or without encryption) is done by the {i scheme} of the
- given [uri]:
-
- - If the scheme is [https], we will {b extend} [ctx] to be able to start a
- TLS connection with a default TLS configuration (no authentication) on the
- default or user-specified port.
- - If the scheme is [http], we will {b extend} [ctx] to be able to start a
- simple TCP/IP connection on the default or user-specified port.
-
- These extensions have the highest priority ([Conduit] will try to initiate a
- communication with them first). By {i extension}, we mean that the user is
- able to fill its own [ctx] and we don't overlap resolution functions from
- the given [ctx]. *)
-
-val close_in : 'a Lwt_io.channel -> unit
-val close_out : 'a Lwt_io.channel -> unit
-val close : 'a Lwt_io.channel -> 'b Lwt_io.channel -> unit
module Log = (val Logs.src_log src : Logs.LOG)
-(* Deprecated *)
let resolve_file ~docroot ~uri = Cohttp.Path.resolve_local_file ~docroot ~uri
exception Isnt_a_file
let respond_file ?headers ~fname () =
Lwt.catch
(fun () ->
- (* Check this isnt a directory first *)
+ (* Check this isn't a directory first *)
( fname |> Lwt_unix.stat >>= fun s ->
- if Unix.(s.st_kind <> S_REG) then Lwt.fail Isnt_a_file
- else Lwt.return_unit )
+ if Unix.(s.st_kind <> S_REG) then raise Isnt_a_file else Lwt.return_unit
+ )
>>= fun () ->
let count = 16384 in
Lwt_io.open_file ~buffer:(Lwt_bytes.create count) ~mode:Lwt_io.input fname
>>= fun ic ->
Lwt_io.length ic >>= fun len ->
- let encoding = Cohttp.Transfer.Fixed len in
+ let encoding = Http.Transfer.Fixed len in
let stream =
Lwt_stream.from (fun () ->
Lwt.catch
let body = Cohttp_lwt.Body.of_stream stream in
let mime_type = Magic_mime.lookup fname in
let headers =
- Cohttp.Header.add_opt_unless_exists headers "content-type" mime_type
+ Http.Header.add_opt_unless_exists headers "content-type" mime_type
in
let res = Cohttp.Response.make ~status:`OK ~encoding ~headers () in
Lwt.return (res, body))
(function
| Unix.Unix_error (Unix.ENOENT, _, _) | Isnt_a_file ->
respond_not_found ()
- | exn -> Lwt.fail exn)
+ | exn -> Lwt.reraise exn)
let log_on_exn = function
| Unix.Unix_error (error, func, arg) ->
| exn -> Log.err (fun m -> m "Unhandled exception: %a" Fmt.exn exn)
let create ?timeout ?backlog ?stop ?(on_exn = log_on_exn)
- ?(ctx = Net.default_ctx) ?(mode = `TCP (`Port 8080)) spec =
+ ?(ctx = Lazy.force Net.default_ctx) ?(mode = `TCP (`Port 8080)) spec =
Conduit_lwt_unix.serve ?backlog ?timeout ?stop ~on_exn ~ctx:ctx.Net.ctx ~mode
- (callback spec)
+ (fun flow ic oc ->
+ let ic = Input_channel.create ic in
+ callback spec flow ic oc)
include Cohttp_lwt.S.Server with module IO = Io
val resolve_file : docroot:string -> uri:Uri.t -> string
-(** Deprecated. Please use Cohttp.Path.resolve_local_file. *)
+[@@deprecated "Please use Cohttp.Path.resolve_local_file. "]
val respond_file :
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
fname:string ->
unit ->
- (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t
+ (Http.Response.t * Cohttp_lwt.Body.t) Lwt.t
val create :
?timeout:int ->
To create a simple HTTP server listening on port 8089:
- {[ let run = create (`TCP 8080) ]}
+ {[
+ let run = create (`TCP 8080)
+ ]}
When provided, the [stop] thread will terminate the server if it ever
becomes determined.
--- /dev/null
+open Lwt
+open OUnit
+open Cohttp_lwt_unix
+
+type 'a io = 'a Lwt.t
+type ic = Cohttp_lwt_unix.Private.Input_channel.t
+type oc = Lwt_io.output_channel
+type body = Cohttp_lwt.Body.t
+
+type response_action =
+ [ `Expert of Http.Response.t * (ic -> oc -> unit io)
+ | `Response of Http.Response.t * body ]
+
+type spec = Request.t -> body -> response_action io
+type async_test = unit -> unit Lwt.t
+
+let response rsp = `Response rsp
+
+let expert ?(rsp = Http.Response.make ()) f _req _body =
+ return (`Expert (rsp, f))
+
+let const rsp _req _body = rsp >|= response
+let response_sequence = Cohttp_test.response_sequence failwith
+let () = Debug.activate_debug ()
+let () = Logs.set_level (Some Info)
+
+let temp_server ?port spec callback =
+ let port = match port with None -> Cohttp_test.next_port () | Some p -> p in
+ let server =
+ Server.make_response_action ~callback:(fun _ req body -> spec req body) ()
+ in
+ let uri = Uri.of_string ("http://localhost:" ^ string_of_int port) in
+ let server_failed, server_failed_wake = Lwt.task () in
+ let server =
+ Lwt.catch
+ (fun () -> Server.create ~backlog:40 ~mode:(`TCP (`Port port)) server)
+ (function
+ | Lwt.Canceled -> Lwt.return_unit
+ | exn ->
+ Lwt.wakeup_exn server_failed_wake exn;
+ Lwt.reraise exn)
+ in
+ Lwt.pick [ Lwt_unix.with_timeout 5.0 (fun () -> callback uri); server_failed ]
+ >|= fun res ->
+ Lwt.cancel server;
+ res
+
+let test_server_s ?port ?(name = "Cohttp Server Test") spec f =
+ temp_server ?port spec (fun uri ->
+ Logs.info (fun f -> f "Test %s running on %s" name (Uri.to_string uri));
+ let tests = f uri in
+ let results =
+ tests
+ |> Lwt_list.map_s (fun (name, test) ->
+ Logs.info (fun f -> f "Running %s" name);
+ let res =
+ Lwt.try_bind test
+ (fun () -> return `Ok)
+ (fun exn -> return (`Exn exn))
+ in
+ res >|= fun res -> (name, res))
+ in
+ results >|= fun results ->
+ let ounit_tests =
+ results
+ |> List.map (fun (name, res) ->
+ name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x)
+ in
+ name >::: ounit_tests)
+
+let run_async_tests test = test >|= OUnit.run_test_tt_main
--- /dev/null
+include
+ Cohttp_test.S
+ with type 'a io = 'a Lwt.t
+ and type body = Cohttp_lwt.Body.t
+ and type ic = Cohttp_lwt_unix.Private.Input_channel.t
+ and type oc = Lwt_io.output_channel
--- /dev/null
+(library
+ (name cohttp_lwt_unix_test)
+ (libraries conduit-lwt cohttp-lwt-unix cohttp_test ounit2))
(executable
(name test_parser)
(modules test_parser)
- (libraries cohttp-lwt-unix oUnit lwt.unix))
+ (libraries cohttp-lwt-unix ounit2 lwt.unix))
(rule
(alias runtest)
(package cohttp-lwt-unix)
(action
(run ./test_body.exe)))
+
+(executable
+ (modules test_client)
+ (name test_client)
+ (libraries cohttp_lwt_unix_test cohttp-lwt-unix))
+
+(rule
+ (alias runtest)
+ (package cohttp-lwt-unix)
+ (action
+ (run ./test_client.exe)))
--- /dev/null
+open Lwt.Infix
+open OUnit
+open Cohttp
+open Cohttp_lwt_unix
+module Body = Cohttp_lwt.Body
+
+(* This file implements a key-value store utilising HTTP as RPC-Interface.
+ * The URI path is used as key. The body is used as value.
+ * The Backend is a Hashtbl.t.
+ * The Hashtbl functions translate to HTTP methods as follows:
+ * replace -> PUT
+ * get -> GET
+ * mem -> HEAD
+ * remove -> DELETE *)
+
+(* This is the server side. *)
+let test_server tests =
+ let store = Hashtbl.create ~random:true 8 in
+ let spec req body =
+ Body.to_string body >>= fun body ->
+ let uri = Request.uri req in
+ let path = Uri.path uri in
+ (match Request.meth req with
+ | `PUT ->
+ let status = if Hashtbl.mem store path then `Created else `No_content in
+ Hashtbl.replace store path body;
+ Server.respond_string ~status ~body:"" ()
+ | `DELETE ->
+ if Hashtbl.mem store path then (
+ Hashtbl.remove store path;
+ Server.respond_string ~status:`No_content ~body:"" ())
+ else Server.respond_not_found ~uri ()
+ | `HEAD ->
+ if Hashtbl.mem store path then
+ Server.respond_string ~body:"" ~status:`OK ()
+ else Server.respond_string ~body:"" ~status:`Not_found ()
+ | `GET -> (
+ match Hashtbl.find_opt store path with
+ | Some body -> Server.respond_string ~status:`OK ~body ()
+ | None -> Server.respond_not_found ~uri ())
+ | meth ->
+ Server.respond_string ~status:`Method_not_allowed
+ ~body:("Unsupported method " ^ Code.string_of_method meth)
+ ())
+ >|= Cohttp_lwt_unix_test.response
+ in
+ Cohttp_lwt_unix_test.test_server_s ~name:"mutable resources" spec tests
+
+(* Client side of the RPC interface *)
+let methods (handler : Cohttp_lwt.S.call) uri =
+ let put k v =
+ let body = Body.of_string v in
+ handler ~body `PUT Uri.(with_path uri k) >>= fun (res, body) ->
+ Body.drain_body body >>= fun () ->
+ match Response.status res with
+ | `Created | `No_content | `OK -> Lwt.return_unit
+ | _ -> failwith "put failed"
+ and get k =
+ handler `GET Uri.(with_path uri k) >>= fun (res, body) ->
+ match Response.status res with
+ | `OK | `No_content -> Body.to_string body
+ | _ -> Body.drain_body body >>= fun () -> raise Not_found
+ and delete k =
+ handler `DELETE Uri.(with_path uri k) >>= fun (res, body) ->
+ Body.drain_body body >>= fun () ->
+ match Response.status res with
+ | `OK | `No_content -> Lwt.return_unit
+ | _ -> raise Not_found
+ and mem k =
+ handler `HEAD Uri.(with_path uri k) >>= fun (res, body) ->
+ Body.drain_body body >|= fun () ->
+ match Response.status res with `OK | `No_content -> true | _ -> false
+ in
+ (put, get, delete, mem)
+
+(* Use the key-value store implemented above to store a map of numbers 0-6 to
+ * corresponding days of the week. *)
+let tests handler uri =
+ let put, get, delete, mem = methods handler uri in
+ let weekdays =
+ [|
+ "Monday";
+ "Tuesday";
+ "Wednesday";
+ "Thursday";
+ "Friday";
+ "Saturday";
+ "Sunday";
+ |]
+ in
+ (* Pipelining is facilitated by not binding (>>=) on responses, but joining them. *)
+ Array.mapi (fun i d -> put (string_of_int i) d) weekdays
+ |> Array.to_list
+ |> Lwt.join
+ >>= fun () ->
+ List.init 7 (fun i -> mem (string_of_int i) >|= assert_bool "mem") |> Lwt.join
+ >>= fun () ->
+ mem "7" >>= fun b ->
+ assert_bool "mem" (not b);
+ List.init 7 (fun i -> get (string_of_int i) >|= assert_equal weekdays.(i))
+ |> Lwt.join
+ >>= fun () -> List.init 7 (fun i -> delete (string_of_int i)) |> Lwt.join
+
+(* Now run those tests through the different low- and highlevel interfaces *)
+
+module Connection = Cohttp_lwt_unix.Connection
+
+(* Use the high-level Client interface *)
+let test_client uri =
+ (* high-level convenience functions. *)
+ Client.put ~body:(`String "Spring") (Uri.with_path uri "season") >>= fun _ ->
+ Client.get (Uri.with_path uri "season") >>= fun (_response, body) ->
+ Body.to_string body >>= fun body ->
+ assert_equal ~printer:Fun.id "Spring" body;
+
+ (* simple request function accepting custom requests. *)
+ let handler ?headers ?body meth uri = Client.call ?headers ?body meth uri in
+ tests handler uri
+
+(* The Client.{call, get, put, ...} functions by default use a new
+ * connection for each request. In a high-latency environment or when
+ * connection setup is expensive due to TLS one might want to use a persistent
+ * connection. This can be done by using the lower-level Connection or
+ * Connection_cache interface or by providing a different default connection
+ * cache to the Client module. *)
+
+(* Simple case: The server is known to support pipelining and won't close the
+ * connection unexpectantly (timeout or number of requests may be limited). *)
+let test_persistent uri =
+ Connection.Net.resolve
+ ~ctx:(Lazy.force Connection.Net.default_ctx)
+ uri (* resolve hostname. *)
+ >>= Connection.connect ~persistent:true
+ >>= fun connection ->
+ (* open connection *)
+ let handler = Connection.call connection in
+ tests handler uri >|= fun () -> Connection.close connection
+
+(* In case persistent connections are not used, a new connection needs to be
+ * opened for each request.
+ * This might result in a massive amount of parallel connections. *)
+let test_non_persistent uri =
+ (* the resolved endpoint may be buffered to avoid stressing the resolver: *)
+ Connection.Net.resolve ~ctx:(Lazy.force Connection.Net.default_ctx) uri
+ >>= fun endp ->
+ let handler ?headers ?body meth uri =
+ Connection.connect ~persistent:false endp >>= fun connection ->
+ Connection.call connection ?headers ?body meth uri
+ in
+ tests handler uri
+
+(* Now the difficult case: We want to use persistent connections, but they may
+ * not be supported or the server may close the connection unexpectedly.
+ * In such a case the pending requests will fail with Connection.Retry. *)
+let test_unknown uri =
+ Connection.Net.resolve ~ctx:(Lazy.force Connection.Net.default_ctx) uri
+ >>= fun endp ->
+ (* buffer resolved endp *)
+ Connection.connect ~persistent:false endp >>= fun c ->
+ let connection = ref c in
+ (* reference to open connection *)
+ let rec handler ?headers ?body meth uri =
+ Lwt.catch
+ (fun () -> Connection.call !connection ?headers ?body meth uri)
+ (function
+ | Connection.Retry -> (
+ (* We may safely retry. The request has not yet been processed by the
+ * remote host. The connection has been gracefully shutdown. *)
+ assert_bool "connection closed" (Connection.is_closed !connection);
+ Connection.connect ~persistent:false endp >>= fun c ->
+ connection := c;
+ match body with
+ (* Still, body may have been (partially) consumed and needs re-creation. *)
+ | Some (`Stream _) -> raise Connection.Retry
+ | None | Some (`Empty | `String _ | `Strings _) ->
+ handler ?headers ?body meth uri)
+ | e -> Lwt.reraise e)
+ in
+ tests handler uri
+
+(* In that difficult case one might be better off using a Connection_cache which
+ * will take care of those trivial retries and reconnecting: *)
+
+module Cache = Cohttp_lwt_unix.Connection_cache
+
+let test_cache uri =
+ let cache = Cache.create () in
+ let handler = Cache.call cache in
+ (* <- this is a partial application *)
+ tests handler uri
+
+(* In case you want to stick with the convenience Client.{call, get, put, ...}
+ * functions, you may set another default connection cache: *)
+
+let test_client_cached uri =
+ let cache = Cache.create () in
+ Client.set_cache (Cache.call cache);
+ test_client uri
+
+let tests uri =
+ [
+ ("high-level interface", fun () -> test_persistent uri);
+ ("persistent connection", fun () -> test_persistent uri);
+ ("non-persistent connection", fun () -> test_non_persistent uri);
+ ("unknown persistence connection", fun () -> test_unknown uri);
+ ("cache", fun () -> test_cache uri);
+ ("high-level cached interface", fun () -> test_client_cached uri);
+ ]
+
+let _ =
+ test_server tests |> Cohttp_lwt_unix_test.run_async_tests |> Lwt_main.run
Accept-Ranges: none\r\n\
Content-Length: 0\r\n\
Connection: close\r\n\
- Content-Type: text/html; charset=UTF-8"
+ Content-Type: text/html; charset=UTF-8\r\n\
+ \r\n"
let basic_res_content =
"HTTP/1.1 200 OK\r\n\
let user_agent = Cohttp.Header.user_agent
let basic_res_plus_crlf = basic_res ^ "\r\n\r\n"
-let ic_of_buffer buf = Lwt_io.of_bytes ~mode:Lwt_io.input buf
+
+let ic_of_buffer buf =
+ Cohttp_lwt_unix.Private.Input_channel.create
+ (Lwt_io.of_bytes ~mode:Lwt_io.input buf)
+
let oc_of_buffer buf = Lwt_io.of_bytes ~mode:Lwt_io.output buf
open Lwt
let p_sexp f x = x |> f |> Sexplib0.Sexp.to_string
-module Req_io = Cohttp.Request.Make (Cohttp_lwt_unix.IO)
-module Rep_io = Cohttp.Response.Make (Cohttp_lwt_unix.IO)
+module Req_io = Cohttp.Request.Private.Make (Cohttp_lwt_unix.Private.IO)
+module Rep_io = Cohttp.Response.Private.Make (Cohttp_lwt_unix.Private.IO)
let basic_req_parse () =
let module CU = Cohttp_lwt_unix in
return ()
| _ -> assert false
+let post_req_parse () =
+ let open Cohttp in
+ let ic = ic_of_buffer (Lwt_bytes.of_string post_req) in
+ Req_io.read ic >>= function
+ | `Ok req ->
+ let printer = p_sexp Transfer.sexp_of_chunk in
+ let reader = Req_io.make_body_reader req ic in
+ Req_io.read_body_chunk reader >>= fun body ->
+ assert_equal ~printer
+ (Transfer.Final_chunk "home=Cosby&favorite+flavor=flies") body;
+ (* A subsequent request for the body will have consumed it, therefore None *)
+ Req_io.read_body_chunk reader >>= fun body ->
+ assert_equal ~printer Transfer.Done body;
+ return ()
+ | _ -> assert false
+
let post_data_parse () =
let open Cohttp in
let ic = ic_of_buffer (Lwt_bytes.of_string post_data_req) in
let ic = ic_of_buffer (Lwt_bytes.of_string basic_res_content) in
Rep_io.read ic >>= function
| `Ok res ->
- assert_equal `HTTP_1_1 (Response.version res);
- assert_equal `OK (Response.status res);
+ assert_equal ~printer:Http.Version.to_string `HTTP_1_1
+ (Response.version res);
+ assert_equal ~printer:Http.Status.to_string `OK (Response.status res);
let reader = Rep_io.make_body_reader res ic in
Rep_io.read_body_chunk reader >>= fun body ->
- assert_equal (Transfer.Final_chunk "home=Cosby&favorite+flavor=flies")
- body;
+ assert_equal
+ ~printer:(fun chunk ->
+ Transfer.sexp_of_chunk chunk |> Sexplib0.Sexp.to_string_hum)
+ (Transfer.Final_chunk "home=Cosby&favorite+flavor=flies") body;
return ()
| _ -> assert false
let buf = Lwt_bytes.create 4096 in
let oc = oc_of_buffer buf in
let body = Cohttp_lwt.Body.of_string "foobar" in
- Req_io.write
+ Req_io.write ~flush:false
(fun writer -> Cohttp_lwt.Body.write_body (Req_io.write_body writer) body)
req oc
>>= fun () ->
* by re-using it *)
let buf = Lwt_bytes.create 4096 in
let oc = oc_of_buffer buf in
- Req_io.write (fun writer -> Req_io.write_body writer "foobar") req oc
+ Req_io.write ~flush:false
+ (fun writer -> Req_io.write_body writer "foobar")
+ req oc
>|= fun () -> assert_equal expected (get_substring oc buf)
let make_simple_req () =
let oc = oc_of_buffer buf in
let res = Response.make ~headers:(Header.of_list [ ("foo", "bar") ]) () in
let body = Cohttp_lwt.Body.of_string "foobar" in
- Rep_io.write
+ Rep_io.write ~flush:false
(fun writer -> Cohttp_lwt.Body.write_body (Rep_io.write_body writer) body)
res oc
>>= fun () ->
* by re-using it *)
let buf = Lwt_bytes.create 4096 in
let oc = oc_of_buffer buf in
- Rep_io.write (fun writer -> Rep_io.write_body writer "foobar") res oc
+ Rep_io.write ~flush:false
+ (fun writer -> Rep_io.write_body writer "foobar")
+ res oc
>>= fun () ->
assert_equal expected (get_substring oc buf);
return ()
[
("basic_req_parse", basic_req_parse);
("req_parse", req_parse);
+ ("post_req_parse", post_req_parse);
("post_data_parse", post_data_parse);
("post_chunked_parse", post_chunked_parse);
("basic_res_parse 1", basic_res_parse basic_res);
("basic_res_parse 2", basic_res_parse basic_res_plus_crlf);
("res_content_parse", res_content_parse);
+ ("res_chunk_parse", res_chunked_parse);
("make_simple_req", make_simple_req);
("mutate_simple_req", mutate_simple_req);
("make_simple_res", make_simple_res);
List.map (fun (n, x) -> n >:: fun () -> Lwt_main.run (x ())) tests
(* Returns true if the result list contains successes only.
- Copied from oUnit source as it isnt exposed by the mli *)
+ Copied from ounit2 source as it isn't exposed by the mli *)
let rec was_successful = function
| [] -> true
| RSuccess _ :: t | RSkip _ :: t -> was_successful t
open Cohttp_lwt_unix
open Cohttp_lwt_unix_test
module Body = Cohttp_lwt.Body
-module IO = Cohttp_lwt_unix.IO
-
-module Request = struct
- include Cohttp.Request
- include (Make (IO) : module type of Make (IO) with type t := t)
- end
+module IO = Cohttp_lwt_unix.Private.IO
let message = "Hello sanity!"
let chunk_body = [ "one"; ""; " "; "bar"; "" ]
else None)))
();
]
- @ (Array.init (leak_repeat * 2) (fun _ _ _ ->
- (* no leaks *)
- Server.respond_string ~status:`OK ~body:"no leak" () >|= fun rsp ->
- `Response rsp)
- |> Array.to_list)
+ @ List.init (leak_repeat * 2) (fun i _ _ ->
+ (* no leaks *)
+ if i mod 2 = 0 then
+ Server.respond_string ~status:`OK ~body:"" () >|= fun rsp ->
+ `Response rsp
+ else
+ Server.respond_string ~status:`OK ~body:"no leak" () >|= fun rsp ->
+ `Response rsp)
(* pipelined_expert *)
@ [
(fun _ _ ->
Lwt.return
(`Expert
- ( Cohttp.Response.make (),
- fun _ic oc -> Lwt_io.write oc "8\r\nexpert 1\r\n0\r\n\r\n" )));
+ (let headers =
+ Http.(
+ Header.add_transfer_encoding (Header.init ()) Transfer.Chunked)
+ in
+ ( Http.Response.make ~headers (),
+ fun _ic oc -> Lwt_io.write oc "8\r\nexpert 1\r\n0\r\n\r\n" ))));
(fun _ _ ->
Lwt.return
(`Expert
- ( Cohttp.Response.make (),
+ ( (* Alternatively, cohttp.response.make injects the Chunked encoding when no
+ encoding is already in the headers. *)
+ Cohttp.Response.make (),
fun ic oc ->
Lwt_io.write oc "8\r\nexpert 2\r\n0\r\n\r\n" >>= fun () ->
- Lwt_io.flush oc >>= fun () -> Lwt_io.close ic )));
+ Lwt_io.flush oc >>= fun () ->
+ Cohttp_lwt_unix.Private.Input_channel.close ic )));
]
|> response_sequence
let ts =
Cohttp_lwt_unix_test.test_server_s server (fun uri ->
- let ctx = Cohttp_lwt_unix.Net.default_ctx in
+ let ctx = Lazy.force Cohttp_lwt_unix.Net.default_ctx in
let t () =
Client.get ~ctx uri >>= fun (_, body) ->
body |> Body.to_string >|= fun body -> assert_equal body message
open Cohttp_lwt_unix
open Cohttp_lwt_unix_test
module Body = Cohttp_lwt.Body
-module IO = Cohttp_lwt_unix.IO
+module IO = Cohttp_lwt_unix.Private.IO
-module Request = struct
- include Cohttp.Request
- include (Make (IO) : module type of Make (IO) with type t := t)
- end
-
-let message = "Hello sanity!"
let chunk_body = [ "one"; ""; " "; "bar"; "" ]
-let leak_repeat = 1024
let () = Logs.set_level (Some Info)
let () = Logs.set_reporter Logs.nop_reporter
let ts_noisy =
Cohttp_lwt_unix_test.test_server_s ~port:10193 server_noisy (fun uri ->
- let ctx = Cohttp_lwt_unix.Net.default_ctx in
+ let ctx = Lazy.force Cohttp_lwt_unix.Net.default_ctx in
let empty_chunk () =
Client.get ~ctx uri >>= fun (_, body) ->
body |> Body.to_string >|= fun body ->
Client.get ~ctx uri >>= fun (resp, body) ->
assert_equal (Response.status resp) `Not_modified;
let headers = Response.headers resp in
- assert_equal ~printer:Transfer.string_of_encoding Transfer.Unknown
+ assert_equal ~printer:Transfer.string_of_encoding
+ Transfer.(Fixed 0L)
(Header.get_transfer_encoding headers);
body |> Body.is_empty >|= fun is_empty ->
assert_bool "No body returned when not modified" is_empty
-version: "5.3.1"
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
-maintainer: "anil@recoil.org"
+synopsis: "CoHTTP implementation using the Lwt concurrency library"
+description: """
+This is a portable implementation of HTTP that uses the Lwt concurrency library
+to multiplex IO. It implements as much of the logic in an OS-independent way
+as possible, so that more specialised modules can be tailored for different
+targets. For example, you can install `cohttp-lwt-unix` or `cohttp-lwt-jsoo`
+for a Unix or JavaScript backend, or `cohttp-mirage` for the MirageOS unikernel
+version of the library. All of these implementations share the same IO logic
+from this module."""
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
authors: [
"Anil Madhavapeddy"
"Stefano Zacchiroli"
"David Scott"
"Rudi Grinberg"
"Andy Ray"
+ "Anurag Soni"
]
-synopsis: "CoHTTP implementation using the Lwt concurrency library"
-description: """
-This is a portable implementation of HTTP that uses the Lwt
-concurrency library to multiplex IO. It implements as much of the
-logic in an OS-independent way as possible, so that more specialised
-modules can be tailored for different targets. For example, you
-can install `cohttp-lwt-unix` or `cohttp-lwt-jsoo` for a Unix or
-JavaScript backend, or `cohttp-mirage` for the MirageOS unikernel
-version of the library. All of these implementations share the same
-IO logic from this module."""
license: "ISC"
-tags: ["org:mirage" "org:xapi-project"]
homepage: "https://github.com/mirage/ocaml-cohttp"
doc: "https://mirage.github.io/ocaml-cohttp/"
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
+ "dune" {>= "3.8"}
"ocaml" {>= "4.08"}
- "dune" {>= "2.0"}
+ "http" {= version}
"cohttp" {= version}
- "lwt" {>= "2.5.0"}
+ "lwt" {>= "5.4.0"}
"sexplib0"
"ppx_sexp_conv" {>= "v0.13.0"}
"logs"
"uri" {>= "2.0.0"}
+ "odoc" {with-doc}
]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
build: [
["dune" "subst"] {dev}
- ["dune" "build" "-p" name "-j" jobs]
- ["dune" "runtest" "-p" name "-j" jobs] {with-test}
-]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-lwt/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-lwt/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
*
}}}*)
-open Cohttp
+module Body = Cohttp.Body
+module Transfer = Cohttp.Transfer
open Lwt
type t = [ Body.t | `Stream of (string Lwt_stream.t[@sexp.opaque]) ]
| false -> (
fn arg >>= function
| Transfer.Done -> return_none
- | Transfer.Final_chunk c ->
+ | Final_chunk c ->
fin := true;
return (Some c)
- | Transfer.Chunk c -> return (Some c)))
+ | Chunk c -> return (Some c)))
let is_empty (body : t) =
match body with
--- /dev/null
+include Http_bytebuffer.Bytebuffer
+
+include
+ Http_bytebuffer.Bytebuffer.Make
+ (struct
+ include Lwt
+
+ let ( >>| ) x f = Lwt.map f x
+ end)
+ (struct
+ type src = bytes -> pos:int -> len:int -> [ `Ok of int | `Eof ] Lwt.t
+
+ let refill src = src
+ end)
open Lwt.Infix
module Header = Cohttp.Header
-module Make (IO : S.IO) (Net : S.Net with module IO = IO) = struct
- module IO = IO
- module Response = Make.Response (IO)
- module Request = Make.Request (IO)
+module Make (Connection : S.Connection) = struct
+ module Net = Connection.Net
+ module No_cache = Connection_cache.Make_no_cache (Connection)
+ module Request = Make.Request (Net.IO)
- let src = Logs.Src.create "cohttp.lwt.client" ~doc:"Cohttp Lwt client"
-
- module Log = (val Logs.src_log src : Logs.LOG)
+ let cache = ref No_cache.(call (create ()))
+ let set_cache c = cache := c
type ctx = Net.ctx
- let read_body ~closefn ic res =
- match Response.has_body res with
- | `Yes | `Unknown ->
- let reader = Response.make_body_reader res ic in
- let stream = Body.create_stream Response.read_body_chunk reader in
- let body = Body.of_stream stream in
- let closed = ref false in
- (* Lwt.on_success registers a callback in the stream.
- * The GC will still be able to collect stream. *)
- Lwt.on_success (Lwt_stream.closed stream) (fun () ->
- closed := true;
- closefn ());
- (* finalise could run in a thread different from the lwt main thread.
- * You may therefore not call into Lwt from a finaliser. *)
- Gc.finalise_last
- (fun () ->
- if not !closed then
- Log.warn (fun m ->
- m
- "Body not consumed, leaking stream! Refer to \
- https://github.com/mirage/ocaml-cohttp/issues/730 for \
- additional details"))
- stream;
- body
- | `No ->
- closefn ();
- `Empty
-
- let is_meth_chunked = function
- | `HEAD -> false
- | `GET -> false
- | `DELETE -> false
- | _ -> true
-
- let call ?(ctx = Net.default_ctx) ?headers ?(body = `Empty) ?chunked meth uri
- =
- let headers = match headers with None -> Header.init () | Some h -> h in
- Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) ->
- let closefn () = Net.close ic oc in
- let chunked =
- match chunked with None -> is_meth_chunked meth | Some v -> v
- in
- let sent =
- match chunked with
- | true ->
- let req = Request.make_for_client ~headers ~chunked meth uri in
- Request.write
- (fun writer -> Body.write_body (Request.write_body writer) body)
- req oc
- | false ->
- (* If chunked is not allowed, then obtain the body length and
- insert header *)
- Body.length body >>= fun (body_length, buf) ->
- let req =
- Request.make_for_client ~headers ~chunked ~body_length meth uri
- in
- Request.write
- (fun writer -> Body.write_body (Request.write_body writer) buf)
- req oc
- in
- sent >>= fun () ->
- (Response.read ic >>= function
- | `Invalid reason ->
- Lwt.fail (Failure ("Failed to read response: " ^ reason))
- | `Eof -> Lwt.fail (Failure "Server closed connection prematurely.")
- | `Ok res -> (
- match meth with
- | `HEAD ->
- closefn ();
- Lwt.return (res, `Empty)
- | _ ->
- let body = read_body ~closefn ic res in
- Lwt.return (res, body)))
- |> fun t ->
- Lwt.on_cancel t closefn;
- Lwt.on_failure t (fun _exn -> closefn ());
- t
+ let cache ?ctx =
+ match ctx with
+ | None -> !cache
+ | Some ctx -> No_cache.(call (create ~ctx ()))
- (* The HEAD should not have a response body *)
- let head ?ctx ?headers uri = call ?ctx ?headers `HEAD uri >|= fst
- let get ?ctx ?headers uri = call ?ctx ?headers `GET uri
+ include
+ Cohttp.Generic.Client.Make
+ (struct
+ type 'a io = 'a Lwt.t
+ type body = Body.t
+ type 'a with_context = ?ctx:ctx -> 'a
- let delete ?ctx ?body ?chunked ?headers uri =
- call ?ctx ?headers ?body ?chunked `DELETE uri
+ let map_context v f ?ctx = f (v ?ctx)
- let post ?ctx ?body ?chunked ?headers uri =
- call ?ctx ?headers ?body ?chunked `POST uri
-
- let put ?ctx ?body ?chunked ?headers uri =
- call ?ctx ?headers ?body ?chunked `PUT uri
-
- let patch ?ctx ?body ?chunked ?headers uri =
- call ?ctx ?headers ?body ?chunked `PATCH uri
+ let call ?ctx ?headers ?body ?chunked meth uri =
+ let add_transfer =
+ Header.add_transfer_encoding
+ (Option.value ~default:(Header.init ()) headers)
+ in
+ match chunked with
+ | None -> cache ?ctx ?headers ?body meth uri
+ | Some true ->
+ let headers = add_transfer Cohttp.Transfer.Chunked in
+ cache ?ctx ~headers ?body meth uri
+ | Some false ->
+ Option.value ~default:`Empty body |> Body.length
+ >>= fun (length, body) ->
+ let headers = add_transfer (Cohttp.Transfer.Fixed length) in
+ cache ?ctx ~headers ~body meth uri
+ end)
+ (Connection.Net.IO)
let post_form ?ctx ?headers ~params uri =
let headers =
let body = Body.of_string (Uri.encoded_of_query params) in
post ?ctx ~chunked:false ~headers ~body uri
- let callv ?(ctx = Net.default_ctx) uri reqs =
- Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) ->
- (* Serialise the requests out to the wire *)
- let meth_stream =
- Lwt_stream.map_s
- (fun (req, body) ->
- Request.write
- (fun writer -> Body.write_body (Request.write_body writer) body)
- req oc
- >>= fun () -> Lwt.return (Request.meth req))
- reqs
- in
- (* Read the responses. For each response, ensure that the previous
- response has consumed the body before continuing to the next
- response because HTTP/1.1-pipelining cannot be interleaved. *)
- let read_m = Lwt_mutex.create () in
- let closefn () = Lwt_mutex.unlock read_m in
- let resps =
- Lwt_stream.map_s
- (fun meth ->
- Lwt_mutex.with_lock read_m (fun () ->
- (Response.read ic >>= function
- | `Invalid reason ->
- Lwt.fail (Failure ("Failed to read response: " ^ reason))
- | `Eof ->
- Lwt.fail (Failure "Server closed connection prematurely.")
- | `Ok res -> (
- match meth with
- | `HEAD ->
- closefn ();
- Lwt.return (res, `Empty)
- | _ ->
- let body = read_body ~closefn ic res in
- Lwt.return (res, body)))
- |> fun t ->
- Lwt.on_cancel t closefn;
- Lwt.on_failure t (fun _exn -> closefn ());
- t))
- meth_stream
- in
- Lwt.on_success (Lwt_stream.closed resps) (fun () -> Net.close ic oc);
- Lwt.return resps
+ let callv ?(ctx = Lazy.force Net.default_ctx) uri reqs =
+ let mutex = Lwt_mutex.create () in
+ Net.resolve ~ctx uri >>= Connection.connect ~ctx >>= fun connection ->
+ Lwt.return
+ @@ Lwt_stream.from
+ @@ fun () ->
+ Lwt_stream.get reqs >>= function
+ | None ->
+ Connection.close connection |> ignore;
+ Lwt.return_none
+ | Some (req, body) ->
+ Lwt_mutex.with_lock mutex @@ fun () ->
+ let headers, meth, uri, enc =
+ Request.(headers req, meth req, uri req, encoding req)
+ in
+ let headers = Header.add_transfer_encoding headers enc in
+ Connection.call connection ~headers ~body meth uri >|= Option.some
end
When logging is enabled (at least {b warning} level), eventual body leaks
will be logged and easier to track. *)
-module Make (IO : S.IO) (Net : S.Net with module IO = IO) :
- S.Client with type ctx = Net.ctx
+module Make (Connection : S.Connection) :
+ S.Client with type ctx = Connection.Net.ctx
module type IO = S.IO
-module Request = Cohttp.Request
-module Response = Cohttp.Response
-module Make_client = Client.Make
+module Request = Cohttp.Request [@@deprecated "Use Cohttp.Request directly"]
+module Response = Cohttp.Response [@@deprecated "Use Cohttp.Response directly"]
+module Connection = Connection
+module Connection_cache = Connection_cache
+module Client = Client
+module Server = Server
+
+(** @deprecated use {!module:Client.Make} instead. *)
+module Make_client (IO : IO) (Net : S.Net with module IO = IO) =
+ Client.Make (Connection.Make (Net))
+
module Make_server = Server.Make
+(** @deprecated use {!module:Server.Make} instead. *)
+
module S = S
module Body = Body
+
+module Private = struct
+ module Bytebuffer = Bytebuffer
+ module String_io = String_io
+end
--- /dev/null
+exception Retry
+(** Raised on failed requests that may be safely retried - even on
+ non-idempotent requests. Raised for example on timeout or connection
+ suhtdown by remote end. *)
+
+module Make (Net : S.Net) : S.Connection with module Net = Net = struct
+ module Net = Net
+ module IO = Net.IO
+ module Response = Make.Response (IO)
+ module Request = Make.Request (IO)
+ module Header = Cohttp.Header
+ open IO
+
+ let src = Logs.Src.create "cohttp.lwt.client" ~doc:"Cohttp Lwt client"
+
+ module Log = (val Logs.src_log src : Logs.LOG)
+
+ exception Retry = Retry
+
+ type state =
+ | Connecting of (IO.ic * IO.oc) Lwt.t
+ (* Waiting for the TCP handshake / TLS connection setup *)
+ | Full of (IO.ic * IO.oc)
+ (* "full-duplex". May send requests, may be waiting for responses / EOF. *)
+ | Closing of (IO.ic * IO.oc)
+ (* still in "full-duplex", but no new requests may be queued.
+ * Will shutdown oc as soon as the last request went out. *)
+ | Half of IO.ic
+ (* oc has been closed, waiting for outstanding responses on ic. *)
+ | Closed
+ | Failed of exn
+ [@@warning "-37"]
+ (* enable warning when https://github.com/mirage/ocaml-conduit/pull/319 is released *)
+
+ type req_resr = {
+ uri : Uri.t;
+ meth : Cohttp.Code.meth;
+ headers : Header.t;
+ body : Body.t;
+ res_r : (Response.t * Body.t) Lwt.u;
+ }
+
+ type persistent = [ `True | `False | `Unknown ]
+
+ type t = {
+ mutable state : state;
+ mutable persistent : persistent;
+ (* keep alive + Chunked supported ? -> essentially HTTP 1.1 *)
+ in_flight : req_resr Queue.t (* writer handles and fails this queue *);
+ waiting : req_resr Queue.t (* reader handles and fails this queue *);
+ condition : unit Lwt_condition.t (* watching queues *);
+ finalise : t -> unit Lwt.t;
+ }
+
+ let length connection =
+ Queue.length connection.in_flight + Queue.length connection.waiting
+
+ let notify connection = Lwt_condition.wait connection.condition
+
+ let queue_fail connection q e =
+ Queue.iter (fun { res_r; _ } -> Lwt.wakeup_later_exn res_r e) q;
+ Queue.clear q;
+ Lwt_condition.broadcast_exn connection.condition e
+
+ let close_with state connection =
+ match connection.state with
+ | Connecting channels ->
+ connection.state <- state;
+ Lwt.cancel channels;
+ Lwt.on_success channels (fun (ic, oc) -> Net.close ic oc);
+ Lwt_condition.broadcast connection.condition ()
+ | Closing (ic, oc) | Full (ic, oc) ->
+ connection.state <- state;
+ Net.close ic oc;
+ Lwt_condition.broadcast connection.condition ()
+ | Half ic ->
+ connection.state <- state;
+ Net.close_in ic;
+ Lwt_condition.broadcast connection.condition ()
+ | Closed | Failed _ -> ()
+
+ let close = close_with Closed
+
+ let shutdown connection =
+ match connection.state with
+ | Connecting channels ->
+ Lwt.async @@ fun () ->
+ channels >>= fun channels ->
+ connection.state <- Closing channels;
+ Lwt.return_unit
+ | Full channels -> connection.state <- Closing channels
+ | Closing _ | Half _ | Closed | Failed _ -> ()
+
+ let is_closed connection =
+ match connection.state with
+ | Full _ -> false
+ | Connecting _ -> false
+ | Closing _ | Half _ -> true
+ | Closed | Failed _ -> true
+
+ let rec reader connection =
+ match connection.state with
+ | Connecting _ | Failed _ -> assert false
+ | Closed -> Lwt.return_unit
+ | Full (ic, _) | Closing (ic, _) | Half ic -> (
+ Response.read ic >>= fun res ->
+ match res with
+ | `Ok res ->
+ if
+ connection.persistent = `Unknown
+ && Response.version res = `HTTP_1_1
+ && not (Header.mem (Response.headers res) "Connection")
+ then connection.persistent <- `True;
+ (* don't take from queue yet, because body may still be in flight *)
+ let { meth; res_r; _ } = Queue.peek connection.in_flight in
+
+ (* A response header to a HEAD request is indistinguishable from a
+ * response header to a GET request. Therefore look at the method. *)
+ (if
+ match Response.has_body res with
+ | _ when meth = `HEAD -> false
+ | `No -> false
+ | `Yes | `Unknown -> true
+ then (
+ let stream =
+ Body.create_stream Response.read_body_chunk
+ (Response.make_body_reader res ic)
+ in
+ (* finalise could run in a thread different from the lwt main thread.
+ * You may therefore not call into Lwt from a finaliser. *)
+ let closed = ref false in
+ Gc.finalise_last
+ (fun () ->
+ if not !closed then
+ Log.warn (fun m ->
+ m
+ "Body not consumed, leaking stream! Refer to \
+ https://github.com/mirage/ocaml-cohttp/issues/730 \
+ for additional details"))
+ stream;
+ Lwt.wakeup_later res_r (res, Body.of_stream stream);
+ Lwt_stream.closed stream >>= fun () ->
+ closed := true;
+ Lwt.return_unit)
+ else (
+ Lwt.wakeup_later res_r (res, `Empty);
+ Lwt.return_unit))
+ >>= fun () ->
+ Queue.take connection.in_flight |> ignore;
+ Lwt_condition.broadcast connection.condition ();
+ if connection.persistent = `False then (
+ close_with Closed connection;
+ Lwt.return_unit)
+ else reader connection
+ | `Eof ->
+ close_with Closed connection;
+ connection.finalise connection >>= fun () ->
+ queue_fail connection connection.in_flight Retry;
+ Lwt.return_unit
+ | `Invalid reason ->
+ let e = Failure ("Cohttp_lwt failed to read response: " ^ reason) in
+ close_with (Failed e) connection;
+ connection.finalise connection >>= fun () ->
+ queue_fail connection connection.in_flight e;
+ Lwt.return_unit)
+
+ let call connection ?headers ?(body = `Empty) meth uri =
+ let headers = match headers with Some h -> h | None -> Header.init () in
+ match connection.state with
+ | Connecting _ | Full _ ->
+ let res, res_r = Lwt.wait () in
+ Queue.push { uri; meth; headers; body; res_r } connection.waiting;
+ Lwt_condition.broadcast connection.condition ();
+ res
+ | Closing _ | Half _ | Closed | Failed _ -> raise Retry
+
+ let rec writer connection =
+ match connection.state with
+ | Full _
+ when Queue.is_empty connection.waiting
+ || not
+ (Queue.is_empty connection.in_flight
+ || connection.persistent = `True) ->
+ Lwt.try_bind
+ (fun () -> Lwt_condition.wait connection.condition)
+ (fun _ -> writer connection)
+ (fun _ -> writer connection)
+ | Closing (_ic, _oc) when Queue.is_empty connection.waiting ->
+ (* uncomment when https://github.com/mirage/ocaml-conduit/pull/319 is released *)
+ (*
+ Net.close_out oc;
+ connection.state <- Half ic;
+ *)
+ Lwt.return_unit
+ | Full (ic, oc) | Closing (ic, oc) ->
+ let ({ uri; meth; headers; body; res_r } as work) =
+ Queue.take connection.waiting
+ in
+
+ (* select encoding based on (1st) header or (2nd) body *)
+ (match Header.get_transfer_encoding headers with
+ | Unknown -> (
+ match Body.transfer_encoding body with
+ | Fixed _ as e -> Lwt.return (e, body)
+ | Chunked as e when connection.persistent = `True ->
+ Lwt.return (e, body)
+ | Chunked (* connection.persistent <> `True *) ->
+ (* We don't know yet whether chunked encoding is supported.
+ * Therefore use fixed length encoding. *)
+ Body.length body >>= fun (length, body) ->
+ Lwt.return (Cohttp.Transfer.Fixed length, body)
+ | Unknown -> assert false)
+ | e -> Lwt.return (e, body))
+ >>= fun (encoding, body) ->
+ let headers =
+ if
+ match connection.state with
+ | _ when connection.persistent = `False -> true
+ | Closing _ when Queue.is_empty connection.waiting -> true
+ | _ -> false
+ then Header.add_unless_exists headers "Connection" "close"
+ else headers
+ in
+
+ let req = Request.make ~encoding ~meth ~headers uri in
+
+ Queue.push work connection.in_flight;
+
+ Lwt.catch
+ (fun () ->
+ (* try *)
+ Request.write ~flush:false
+ (fun writer -> Body.write_body (Request.write_body writer) body)
+ req oc)
+ (fun e ->
+ (* with *)
+ (* uncomment when https://github.com/mirage/ocaml-conduit/pull/319 is released *)
+ (*
+ (try Net.close_out oc with _ -> ());
+ connection.state <- Half ic;
+ *)
+ connection.state <- Closing (ic, oc);
+ Lwt.wakeup_later_exn res_r e;
+ queue_fail connection connection.waiting Retry;
+ Lwt.return_unit)
+ >>= fun () ->
+ if connection.persistent = `False then (
+ (* uncomment when https://github.com/mirage/ocaml-conduit/pull/319 is released *)
+ (*
+ Net.close_out oc;
+ connection.state <- Half ic;
+ *)
+ connection.state <- Closing (ic, oc);
+ queue_fail connection connection.waiting Retry;
+ Lwt.return_unit)
+ else writer connection
+ | Closed ->
+ queue_fail connection connection.waiting Retry;
+ Lwt.return_unit
+ | Failed e ->
+ queue_fail connection connection.waiting e;
+ Lwt.return_unit
+ | Half _ -> Lwt.return_unit
+ | Connecting _ -> assert false
+
+ let create ?(finalise = fun _ -> Lwt.return_unit) ?persistent
+ ?(ctx = Lazy.force Net.default_ctx) endp =
+ let persistent =
+ match persistent with
+ | None -> `Unknown
+ | Some true -> `True
+ | Some false -> `False
+ in
+ let channels =
+ Net.connect_endp ~ctx endp >>= fun (_, ic, oc) -> return (ic, oc)
+ in
+ let connection =
+ {
+ finalise;
+ in_flight = Queue.create ();
+ waiting = Queue.create ();
+ state = Connecting channels;
+ condition = Lwt_condition.create ();
+ persistent;
+ }
+ in
+ let on_failure e = connection.state <- Failed e in
+ Lwt.on_any channels
+ (fun channels ->
+ connection.state <- Full channels;
+ Lwt.dont_wait (fun () -> reader connection) on_failure;
+ Lwt.dont_wait (fun () -> writer connection) on_failure)
+ on_failure;
+ connection
+
+ let connect ?finalise ?persistent ?ctx uri =
+ let connection = create ?finalise ?persistent ?ctx uri in
+ match connection.state with
+ | Connecting channels -> channels >>= fun _ -> Lwt.return connection
+ | _ -> Lwt.return connection
+end
--- /dev/null
+exception Retry = Connection.Retry
+
+(** This functor establishes a new connection for each request. *)
+module Make_no_cache (Connection : S.Connection) : sig
+ include S.Connection_cache
+
+ val create : ?ctx:Connection.Net.ctx -> unit -> t
+ (** [create ?ctx ()] creates a connection for handling a single request. The
+ connection accepts only a single request and will automatically be closed
+ as soon as possible.
+ @param ctx See {!Connection.Net.ctx} *)
+end = struct
+ module Net = Connection.Net
+ module IO = Net.IO
+ open IO
+
+ type t = S.call
+
+ let call = Fun.id
+
+ let create ?(ctx = Lazy.force Net.default_ctx) () ?headers ?body meth uri =
+ Net.resolve ~ctx uri
+ (* TODO: Support chunked encoding without ~persistent:true ? *)
+ >>= Connection.connect ~ctx ~persistent:true
+ >>= fun connection ->
+ let res = Connection.call connection ?headers ?body meth uri in
+ (* this can be simplified when https://github.com/mirage/ocaml-conduit/pull/319 is released. *)
+ Lwt.dont_wait
+ (fun () ->
+ res >>= fun (_, body) ->
+ (match body with
+ | `Empty | `String _ | `Strings _ -> Lwt.return_unit
+ | `Stream stream -> Lwt_stream.closed stream)
+ >>= fun () ->
+ Connection.close connection;
+ Lwt.return_unit)
+ (function Retry -> () | e -> raise e);
+ res
+end
+
+(** This functor keeps a cache of connections for reuse. Connections are reused
+ based on their remote {!type:Conduit.endp} (effectively IP / port). *)
+module Make (Connection : S.Connection) (Sleep : S.Sleep) : sig
+ include S.Connection_cache
+
+ val create :
+ ?ctx:Connection.Net.ctx ->
+ ?keep:int64 ->
+ ?retry:int ->
+ ?parallel:int ->
+ ?depth:int ->
+ unit ->
+ t
+ (** Create a new connection cache
+
+ @param ctx Conduit context to use. See {!type:Connection.Net.ctx}.
+ @param keep Number of nanoseconds to keep an idle connection around.
+ @param retry
+ Number of times a {e gracefully} failed request is automatically
+ retried. {e graceful} means failed with {!exception:Connection.Retry}.
+ Requests with a [`Stream] {!module:Body} cannot be retried
+ automatically. Such requests will fail with
+ {!exception:Connection.Retry} and a new {!module:Body} will need to be
+ provided to retry.
+ @param parallel
+ maximum number of connections to establish to a single endpoint. Beware:
+ A single hostname may resolve to multiple endpoints. In such a case
+ connections may be created in excess to what was intended.
+ @param depth
+ maximum number of requests to queue and / or send on a single
+ connection. *)
+end = struct
+ module Net = Connection.Net
+ module IO = Net.IO
+ open IO
+
+ type ctx = Net.ctx
+
+ type t = {
+ cache : (Net.endp, Connection.t) Hashtbl.t;
+ ctx : ctx;
+ keep : int64;
+ retry : int;
+ parallel : int;
+ depth : int;
+ }
+
+ let create ?(ctx = Lazy.force Net.default_ctx) ?(keep = 60_000_000_000L)
+ ?(retry = 2) ?(parallel = 4) ?(depth = 100) () =
+ {
+ cache = Hashtbl.create ~random:true 10;
+ ctx;
+ keep;
+ retry;
+ parallel;
+ depth;
+ }
+
+ let rec get_connection self endp =
+ let finalise connection =
+ let rec remove keep =
+ let current = Hashtbl.find self.cache endp in
+ Hashtbl.remove self.cache endp;
+ if current == connection then
+ List.iter (Hashtbl.add self.cache endp) keep
+ else remove (current :: keep)
+ in
+ remove [];
+ Lwt.return_unit
+ in
+ let create () =
+ let connection = Connection.create ~finalise ~ctx:self.ctx endp
+ and timeout = ref Lwt.return_unit in
+ let rec busy () =
+ Lwt.cancel !timeout;
+ if Connection.length connection = 0 then (
+ timeout :=
+ Sleep.sleep_ns self.keep >>= fun () ->
+ Connection.close connection;
+ (* failure is ignored *)
+ Lwt.return_unit);
+ Lwt.on_termination (Connection.notify connection) busy
+ in
+ busy ();
+ connection
+ in
+ match Hashtbl.find_all self.cache endp with
+ | [] ->
+ let connection = create () in
+ Hashtbl.add self.cache endp connection;
+ Lwt.return connection
+ | conns -> (
+ let rec search length = function
+ | [ a ] -> (a, length + 1)
+ | a :: b :: tl when Connection.length a < Connection.length b ->
+ search (length + 1) (a :: tl)
+ | _ :: tl -> search (length + 1) tl
+ | [] -> assert false
+ in
+ match search 0 conns with
+ | shallowest, _ when Connection.length shallowest = 0 ->
+ Lwt.return shallowest
+ | _, length when length < self.parallel ->
+ let connection = create () in
+ Hashtbl.add self.cache endp connection;
+ Lwt.return connection
+ | shallowest, _ when Connection.length shallowest < self.depth ->
+ Lwt.return shallowest
+ | _ ->
+ Lwt.try_bind
+ (fun () -> Lwt.choose (List.map Connection.notify conns))
+ (fun _ -> get_connection self endp)
+ (fun _ -> get_connection self endp))
+
+ let call self ?headers ?body meth uri =
+ Net.resolve ~ctx:self.ctx uri >>= fun endp ->
+ let rec request retry =
+ get_connection self endp >>= fun conn ->
+ Lwt.catch
+ (fun () -> Connection.call conn ?headers ?body meth uri)
+ (function
+ | Retry -> (
+ match body with
+ | Some (`Stream _) -> raise Retry
+ | None | Some `Empty | Some (`String _) | Some (`Strings _) ->
+ if retry <= 0 then raise Retry else request (retry - 1))
+ | e -> Lwt.reraise e)
+ in
+ request self.retry
+end
(synopsis "Lwt backend")
(preprocess
(pps ppx_sexp_conv))
- (libraries lwt uri cohttp logs logs.lwt))
+ (libraries lwt uri http_bytebuffer cohttp logs logs.lwt))
module Request (IO : S.IO) = struct
include Cohttp.Request
- include (Make (IO) : module type of Make (IO) with type t := t)
+
+ include (
+ Private.Make (IO) : module type of Private.Make (IO) with type t := t)
end
module Response (IO : S.IO) = struct
include Cohttp.Response
- include (Make (IO) : module type of Make (IO) with type t := t)
+
+ include (
+ Private.Make (IO) : module type of Private.Make (IO) with type t := t)
end
module type Net = sig
module IO : IO
+ type endp
+
type ctx [@@deriving sexp_of]
+ (** Conduit context. Contains configuration of resolver, local source address,
+ TLS / SSL library, certificates, keys.
+
+ Depending on [ctx], the library is able to send HTTP requests unencrypted
+ or encrypted one with a secured protocol (such as TLS). Depending on how
+ conduit is configured, [ctx] might initiate a secured connection with TLS
+ (using [ocaml-tls]) or SSL (using [ocaml-ssl]), on [*:443] or on the
+ specified port by the user. If neitehr [ocaml-tls] or [ocaml-ssl] are
+ installed on the system, [cohttp]/[conduit] tries the usual ([*:80]) or
+ the specified port by the user in a non-secured way. *)
+
+ val default_ctx : ctx Lazy.t
+
+ val resolve : ctx:ctx -> Uri.t -> endp IO.t
+ (** [resolve ~ctx uri] resolves [uri] into an endpoint description. This is
+ [Resolver_lwt.resolve_uri ~uri ctx.resolver]. *)
+
+ val connect_uri : ctx:ctx -> Uri.t -> (IO.conn * IO.ic * IO.oc) IO.t
+ (** [connect_uri ~ctx uri] starts a {i flow} on the given [uri]. The choice of
+ the protocol (with or without encryption) is done by the {i scheme} of the
+ given [uri]:
+
+ - If the scheme is [https], we will {b extend} [ctx] to be able to start a
+ TLS connection with a default TLS configuration (no authentication) on
+ the default or user-specified port.
+ - If the scheme is [http], we will {b extend} [ctx] to be able to start a
+ simple TCP/IP connection on the default or user-specified port.
+
+ These extensions have the highest priority ([Conduit] will try to initiate
+ a communication with them first). By {i extension}, we mean that the user
+ is able to fill its own [ctx] and we don't overlap resolution functions
+ from the given [ctx].
+
+ This is [resolve ~ctx uri >>= connect_endp ~ctx]. *)
+
+ val connect_endp : ctx:ctx -> endp -> (IO.conn * IO.ic * IO.oc) IO.t
+ (** [connect_endp ~ctx endp] starts a {i flow} to the given [endp]. [endp]
+ describes address and protocol of the endpoint to connect to. *)
- val default_ctx : ctx
- val connect_uri : ctx:ctx -> Uri.t -> (IO.conn * IO.ic * IO.oc) Lwt.t
val close_in : IO.ic -> unit
val close_out : IO.oc -> unit
val close : IO.ic -> IO.oc -> unit
end
-(** The [Client] module implements non-pipelined single HTTP client calls. Each
- call will open a separate {!Net} connection. For best results, the {!Body}
- that is returned should be consumed in order to close the file descriptor in
- a timely fashion. It will still be finalized by a GC hook if it is not used
- up, but this can take some additional time to happen. *)
-module type Client = sig
- type ctx
+(** This is compatible with [Mirage_time.S]. It may be satisfied by
+ mirage-time-unix [Time] or [Mirage_time]. *)
+module type Sleep = sig
+ val sleep_ns : int64 -> unit Lwt.t
+end
- val call :
- ?ctx:ctx ->
- ?headers:Cohttp.Header.t ->
- ?body:Body.t ->
- ?chunked:bool ->
- Cohttp.Code.meth ->
- Uri.t ->
- (Cohttp.Response.t * Body.t) Lwt.t
- (** [call ?ctx ?headers ?body ?chunked meth uri] will resolve the [uri] to a
- concrete network endpoint using context [ctx]. It will then issue an HTTP
- request with method [meth], adding request headers from [headers] if
- present. If a [body] is specified then that will be included with the
- request, using chunked encoding if [chunked] is true. The default is to
- disable chunked encoding for HTTP request bodies for compatibility
- reasons.
-
- In most cases you should use the more specific helper calls in the
- interface rather than invoke this function directly. See {!head}, {!get}
- and {!post} for some examples.
-
- To avoid leaks, the body needs to be consumed, using the functions
- provided in the {!Body} module and, if not necessary, should be explicitly
- drained calling {!Body.drain_body}. Leaks are logged as debug messages by
- the client, these can be enabled activating the debug logging. For
- example, this can be done as follows in [cohttp-lwt-unix]
+type call =
+ ?headers:Http.Header.t ->
+ ?body:Body.t ->
+ Http.Method.t ->
+ Uri.t ->
+ (Cohttp.Response.t * Body.t) Lwt.t
+(** [call ?headers ?body method uri] Function type used to handle http requests
+
+ @return
+ [(response, response_body)] [response_body] is not buffered, but stays on
+ the wire until consumed. It must therefore be consumed in a timely manner.
+ Otherwise the connection would stay open and a file descriptor leak may be
+ caused. Following responses would get blocked. Functions in the {!Body}
+ module can be used to consume [response_body]. Use {!Body.drain_body} if
+ you don't consume the body by other means.
+
+ Leaks are detected by the GC and logged as debug messages, these can be
+ enabled activating the debug logging. For example, this can be done as
+ follows in
+ [cohttp-lwt-unix]
{[
Cohttp_lwt_unix.Debug.activate_debug ();
Logs.set_level (Some Logs.Warning)
]}
- Depending on [ctx], the library is able to send a simple HTTP request or
- an encrypted one with a secured protocol (such as TLS). Depending on how
- conduit is configured, [ctx] might initiate a secured connection with TLS
- (using [ocaml-tls]) or SSL (using [ocaml-ssl]), on [*:443] or on the
- specified port by the user. If neitehr [ocaml-tls] or [ocaml-ssl] are
- installed on the system, [cohttp]/[conduit] tries the usual ([*:80]) or
- the specified port by the user in a non-secured way. *)
+ @raise {!Connection.Retry}
+ on recoverable errors like the remote endpoint closing the connection
+ gracefully. Even non-idempotent requests are guaranteed to not have been
+ processed by the remote endpoint and should be retried. But beware that a
+ [`Stream] [body] may have been consumed. *)
- val head :
- ?ctx:ctx -> ?headers:Cohttp.Header.t -> Uri.t -> Cohttp.Response.t Lwt.t
+(** The [Connection] module handles a single, possibly pipelined, http
+ connection. *)
+module type Connection = sig
+ module Net : Net
- val get :
- ?ctx:ctx ->
- ?headers:Cohttp.Header.t ->
- Uri.t ->
- (Cohttp.Response.t * Body.t) Lwt.t
+ exception Retry
- val delete :
- ?ctx:ctx ->
- ?body:Body.t ->
- ?chunked:bool ->
- ?headers:Cohttp.Header.t ->
- Uri.t ->
- (Cohttp.Response.t * Body.t) Lwt.t
+ type t
- val post :
- ?ctx:ctx ->
- ?body:Body.t ->
- ?chunked:bool ->
- ?headers:Cohttp.Header.t ->
- Uri.t ->
- (Cohttp.Response.t * Body.t) Lwt.t
+ val create :
+ ?finalise:(t -> unit Net.IO.t) ->
+ ?persistent:bool ->
+ ?ctx:Net.ctx ->
+ Net.endp ->
+ t
+ (** [create ?finalise ?persistent ?ctx endp] connects to [endp]. The
+ connection handle may be used immediately, although the connection may not
+ yet be established.
+
+ @param finalise
+ called when the connection is closed, but before still waiting requests
+ are failed.
+ @param persistent
+ if [false], a [Connection: close] header is sent and the connection
+ closed as soon as possible. If [true], it is assumed the remote end does
+ support pipelining and multiple requests may be sent even before
+ receiving any reply. By default we wait for the first response to decide
+ whether connection keep-alive and pipelining is supported. Chunked
+ encoding can only be used when pipelining is supported. Therefore better
+ avoid using chunked encoding on the very first request.
+ @param ctx See [Net.ctx]
+ @param endp The remote address, port and protocol to connect to. *)
+
+ val connect :
+ ?finalise:(t -> unit Net.IO.t) ->
+ ?persistent:bool ->
+ ?ctx:Net.ctx ->
+ Net.endp ->
+ t Net.IO.t
+ (** Same as [create], but returns d promise which gets fulfilled when the
+ connection is established or rejected when connecting fails. *)
+
+ val shutdown : t -> unit
+ (** Send {e EOF}. On {e TCP} connections send a {e FIN} packet. On {e TLS}
+ connections send a {e close notify}. No new requests can be sent
+ afterwards, but responses may still be received. *)
+
+ val close : t -> unit
+ (** Immediately close connection. All outstanding requests will fail, but
+ non-idempotent requests that already went out on the wire may have
+ produced side-effects. *)
+
+ val is_closed : t -> bool
+ (** If [is_closed connection] is [false] the [connection] still accepts new
+ requests. *)
+
+ val length : t -> int
+ (** Number of unfulfilled requests. This includes requests already sent out
+ and requests still waitung to be sent. *)
+
+ val notify : t -> unit Net.IO.t
+ (** Request notification on change of [length] and on closing. *)
+
+ val call : t -> call
+ (** Queue a request. Please see {!type:requester}. *)
+end
- val put :
- ?ctx:ctx ->
- ?body:Body.t ->
- ?chunked:bool ->
- ?headers:Cohttp.Header.t ->
- Uri.t ->
- (Cohttp.Response.t * Body.t) Lwt.t
+(** A [Connection_cache] handles http requests. It not necessarily caches
+ connections. *)
+module type Connection_cache = sig
+ type t
- val patch :
- ?ctx:ctx ->
- ?body:Body.t ->
- ?chunked:bool ->
- ?headers:Cohttp.Header.t ->
- Uri.t ->
- (Cohttp.Response.t * Body.t) Lwt.t
+ val call : t -> call
+ (** Process a request. Please see {!type:call}. *)
+end
+
+(** The [Client] module is a collection of convenience functions for
+ constructing and processing requests. *)
+module type Client = sig
+ type ctx
+
+ (** @param ctx
+ If provided, no connection cache is used, but
+ {!val:Connection_cache.Make_no_cache.create} is used to resolve uri and
+ create a dedicated connection with [ctx].
+
+ In most cases you should use the more specific helper calls in the
+ interface rather than invoke this function directly. See {!head}, {!get}
+ and {!post} for some examples. *)
+ include
+ Cohttp.Generic.Client.S
+ with type 'a io = 'a Lwt.t
+ and type body = Body.t
+ and type 'a with_context = ?ctx:ctx -> 'a
+
+ val set_cache : call -> unit
+ (** Provide a function used to process requests. Please see {!type:call}. The
+ provided function is only used when no [ctx] argument is passed to the
+ convenience functions below. *)
val post_form :
?ctx:ctx ->
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
params:(string * string list) list ->
Uri.t ->
- (Cohttp.Response.t * Body.t) Lwt.t
+ (Http.Response.t * Body.t) Lwt.t
val callv :
?ctx:ctx ->
Uri.t ->
- (Cohttp.Request.t * Body.t) Lwt_stream.t ->
- (Cohttp.Response.t * Body.t) Lwt_stream.t Lwt.t
+ (Http.Request.t * Body.t) Lwt_stream.t ->
+ (Http.Response.t * Body.t) Lwt_stream.t Lwt.t
+ (** @deprecated use {!module:Cohttp_lwt.Connection} instead. *)
end
(** The [Server] module implements a pipelined HTTP/1.1 server. *)
module type Server = sig
module IO : IO
- type conn = IO.conn * Cohttp.Connection.t
-
- type response_action =
- [ `Expert of Cohttp.Response.t * (IO.ic -> IO.oc -> unit Lwt.t)
- | `Response of Cohttp.Response.t * Body.t ]
- (** A request handler can respond in two ways:
-
- - Using [`Response], with a {!Response.t} and a {!Body.t}.
- - Using [`Expert], with a {!Response.t} and an IO function that is
- expected to write the response body. The IO function has access to the
- underlying {!IO.ic} and {!IO.oc}, which allows writing a response body
- more efficiently, stream a response or to switch protocols entirely
- (e.g. websockets). Processing of pipelined requests continue after the
- {!unit Lwt.t} is resolved. The connection can be closed by closing the
- {!IO.ic}. *)
-
- type t
-
- val make_response_action :
- ?conn_closed:(conn -> unit) ->
- callback:(conn -> Cohttp.Request.t -> Body.t -> response_action Lwt.t) ->
- unit ->
- t
-
- val make_expert :
- ?conn_closed:(conn -> unit) ->
- callback:
- (conn ->
- Cohttp.Request.t ->
- Body.t ->
- (Cohttp.Response.t * (IO.ic -> IO.oc -> unit Lwt.t)) Lwt.t) ->
- unit ->
- t
-
- val make :
- ?conn_closed:(conn -> unit) ->
- callback:
- (conn -> Cohttp.Request.t -> Body.t -> (Cohttp.Response.t * Body.t) Lwt.t) ->
- unit ->
- t
+ include
+ Cohttp.Generic.Server.S
+ with type body = Body.t
+ and module IO := IO
+ and type response = Http.Response.t * Body.t
val resolve_local_file : docroot:string -> uri:Uri.t -> string
- (** Resolve a URI and a docroot into a concrete local filename.
-
- Deprecated. Please use Cohttp.Path.resolve_local_file. *)
-
- val respond :
- ?headers:Cohttp.Header.t ->
- ?flush:bool ->
- status:Cohttp.Code.status_code ->
- body:Body.t ->
- unit ->
- (Cohttp.Response.t * Body.t) Lwt.t
- (** [respond ?headers ?flush ~status ~body] will respond to an HTTP request
- with the given [status] code and response [body]. If [flush] is true, then
- every response chunk will be flushed to the network rather than being
- buffered. [flush] is true by default. The transfer encoding will be
- detected from the [body] value and set to chunked encoding if it cannot be
- determined immediately. You can override the encoding by supplying an
- appropriate [Content-length] or [Transfer-encoding] in the [headers]
- parameter. *)
-
- val respond_string :
- ?flush:bool ->
- ?headers:Cohttp.Header.t ->
- status:Cohttp.Code.status_code ->
- body:string ->
- unit ->
- (Cohttp.Response.t * Body.t) Lwt.t
+ [@@deprecated "Please use Cohttp.Path.resolve_local_file. "]
+ (** Resolve a URI and a docroot into a concrete local filename. *)
val respond_error :
- ?headers:Cohttp.Header.t ->
- ?status:Cohttp.Code.status_code ->
+ ?headers:Http.Header.t ->
+ ?status:Http.Status.t ->
body:string ->
unit ->
- (Cohttp.Response.t * Body.t) Lwt.t
+ (Http.Response.t * body) IO.t
val respond_redirect :
- ?headers:Cohttp.Header.t ->
- uri:Uri.t ->
- unit ->
- (Cohttp.Response.t * Body.t) Lwt.t
+ ?headers:Http.Header.t -> uri:Uri.t -> unit -> (Http.Response.t * body) IO.t
val respond_need_auth :
- ?headers:Cohttp.Header.t ->
+ ?headers:Http.Header.t ->
auth:Cohttp.Auth.challenge ->
unit ->
- (Cohttp.Response.t * Body.t) Lwt.t
-
- val respond_not_found :
- ?uri:Uri.t -> unit -> (Cohttp.Response.t * Body.t) Lwt.t
+ (Http.Response.t * body) IO.t
- val callback : t -> IO.conn -> IO.ic -> IO.oc -> unit Lwt.t
+ val respond_not_found : ?uri:Uri.t -> unit -> (Http.Response.t * body) IO.t
end
open Lwt.Infix
module Header = Cohttp.Header
+module Connection = Cohttp.Connection [@@warning "-3"]
module Make (IO : S.IO) = struct
module IO = IO
module Request = Make.Request (IO)
module Response = Make.Response (IO)
+ type response = Http.Response.t * Body.t
+ type body = Body.t
+
let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server module"
module Log = (val Logs.src_log src : Logs.LOG)
- type conn = IO.conn * Cohttp.Connection.t
+ type conn = IO.conn * Connection.t
type response_action =
- [ `Expert of Cohttp.Response.t * (IO.ic -> IO.oc -> unit Lwt.t)
- | `Response of Cohttp.Response.t * Body.t ]
+ [ `Expert of Http.Response.t * (IO.ic -> IO.oc -> unit Lwt.t)
+ | `Response of Http.Response.t * Body.t ]
type t = {
- callback : conn -> Cohttp.Request.t -> Body.t -> response_action Lwt.t;
+ callback : conn -> Http.Request.t -> Body.t -> response_action Lwt.t;
conn_closed : conn -> unit;
}
in
make_response_action ?conn_closed ~callback ()
- module Transfer_IO = Cohttp__Transfer_io.Make (IO)
+ module Transfer_IO = Cohttp.Private.Transfer_io.Make (IO)
- (* Deprecated *)
let resolve_local_file ~docroot ~uri =
Cohttp.Path.resolve_local_file ~docroot ~uri
- let respond ?headers ?(flush = true) ~status ~body () =
+ let respond ?headers ~status ~body () =
let encoding =
match headers with
| None -> Body.transfer_encoding body
| Some headers -> (
match Header.get_transfer_encoding headers with
- | Cohttp.Transfer.Unknown -> Body.transfer_encoding body
+ | Http.Transfer.Unknown -> Body.transfer_encoding body
| t -> t)
in
- let res = Response.make ~status ~flush ~encoding ?headers () in
+ let res = Response.make ~status ~encoding ?headers () in
Lwt.return (res, body)
- let respond_string ?(flush = true) ?headers ~status ~body () =
+ let respond_string ?headers ~status ~body () =
let res =
- Response.make ~status ~flush
- ~encoding:(Cohttp.Transfer.Fixed (Int64.of_int (String.length body)))
+ Response.make ~status
+ ~encoding:(Http.Transfer.Fixed (Int64.of_int (String.length body)))
?headers ()
in
let body = Body.of_string body in
respond_string ~status:`Not_found ~body ()
let read_body ic req =
- match Request.has_body req with
+ match Http.Request.has_body req with
| `Yes ->
let reader = Request.make_body_reader req ic in
let body_stream = Body.create_stream Request.read_body_chunk reader in
Lwt.catch
(fun () -> callback conn req body)
(function
- | Out_of_memory -> Lwt.fail Out_of_memory
+ | Out_of_memory -> Lwt.reraise Out_of_memory
| exn ->
Log.err (fun f ->
f "Error handling %a: %s" Request.pp_hum req
let handle_response ~keep_alive oc res body conn_closed handle_client =
IO.catch (fun () ->
- let flush = Response.flush res in
- Response.write ~flush
+ Response.write ~flush:false
(fun writer -> Body.write_body (Response.write_body writer) body)
res oc)
>>= function
let body = read_body ic req in
handle_request spec.callback conn req body >>= function
| `Response (res, body) ->
- let keep_alive = Request.is_keep_alive req in
+ let keep_alive =
+ Http.Request.is_keep_alive req && Http.Response.is_keep_alive res
+ in
+ let res =
+ let headers =
+ Http.Header.add_unless_exists
+ (Http.Response.headers res)
+ "connection"
+ (if keep_alive then "keep-alive" else "close")
+ in
+ { res with Http.Response.headers }
+ in
handle_response ~keep_alive oc res body
(fun () -> spec.conn_closed conn)
(fun oc -> handle_client ic oc conn spec)
io_handler ic oc >>= fun () -> handle_client ic oc conn spec)
let callback spec io_id ic oc =
- let conn_id = Cohttp.Connection.create () in
+ let conn_id = Connection.create () in
let conn_closed () = spec.conn_closed (io_id, conn_id) in
Lwt.catch
(fun () ->
Lwt.return_unit)
(fun e ->
conn_closed ();
- Lwt.fail e)
+ Lwt.reraise e)
end
let return = Lwt.return
let ( >>= ) = Lwt.bind
-module Sio = Cohttp__String_io
+module Sio = Cohttp.Private.String_io
type ic = Sio.M.ic
type oc = Sio.M.oc
type conn = Sio.M.conn
+let refill ic = return (Sio.M.refill ic)
+let with_input_buffer ic ~f = Sio.M.with_input_buffer ic ~f
let read_line ic = return (Sio.M.read_line ic)
let read ic n = return (Sio.M.read ic n)
let write oc str = return (Sio.M.write oc str)
(** Lwt IO implementation that uses strings to marshal and unmarshal HTTP *)
-(** IO interface that uses {!buf} for input data and queues output data into a
- {!Buffer.t}. Never actually blocks despite the Lwt use, although a future
- revision may yield when parsing large strings. *)
+(** IO interface that uses {!Cohttp.Private.String_io.buf} for input data and
+ queues output data into a {!Buffer.t}. Never actually blocks despite the Lwt
+ use, although a future revision may yield when parsing large strings. *)
include
Cohttp.S.IO
with type 'a t = 'a Lwt.t
- and type ic = Cohttp__String_io.buf
+ and type ic = Cohttp.Private.String_io.buf
and type oc = Buffer.t
--- /dev/null
+module Bytebuffer = Cohttp_lwt.Private.Bytebuffer
+
+let%expect_test "read" =
+ let line = "foobar\r\n" in
+ let test buf_size =
+ let buf = Bytebuffer.create buf_size in
+ let refill =
+ let line_pos = ref 0 in
+ let reads_left = ref 10 in
+ fun buf ~pos ~len ->
+ if !reads_left = 0 then raise Exit;
+ decr reads_left;
+ let available = String.length line - !line_pos in
+ if available = 0 then Lwt.return `Eof
+ else
+ let read_len = min len available in
+ BytesLabels.blit_string ~src:line ~src_pos:!line_pos ~dst:buf
+ ~dst_pos:pos ~len:read_len;
+ line_pos := !line_pos + read_len;
+ Lwt.return (`Ok read_len)
+ in
+ let open Lwt.Syntax in
+ Lwt_main.run
+ @@ Lwt.catch
+ (fun () ->
+ let+ res = Bytebuffer.read_line buf refill in
+ match res with
+ | None -> print_endline "failed to read line"
+ | Some line -> Printf.printf "read line: %S\n" line)
+ (function
+ | Exit -> Lwt.return @@ print_endline "failed to read"
+ | _ -> assert false)
+ in
+ test (String.length line);
+ [%expect {| read line: "foobar" |}];
+ test (String.length line - 1);
+ [%expect {| read line: "foobar" |}]
-version: "5.3.1"
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
-maintainer: "anil@recoil.org"
-authors: ["Anil Madhavapeddy" "Thomas Gazagnaire"]
-license: "ISC"
-tags: ["org:mirage" "org:xapi-project"]
-homepage: "https://github.com/mirage/ocaml-cohttp"
-doc: "https://mirage.github.io/ocaml-cohttp/"
-bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
synopsis: "CoHTTP implementation for the MirageOS unikernel"
description: """
-This HTTP implementation uses the Cohttp portable implementaiton
+This HTTP implementation uses the Cohttp portable implementation
along with the Lwt threading library in order to provide a
`Cohttp_mirage` functor that can be used in MirageOS unikernels
to build very small and efficient HTTP clients and servers
Please see <https://mirage.io> for a self-hosted explanation
and instructions on how to use this library."""
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
+authors: [
+ "Anil Madhavapeddy"
+ "Stefano Zacchiroli"
+ "David Sheets"
+ "Thomas Gazagnaire"
+ "David Scott"
+ "Rudi Grinberg"
+ "Andy Ray"
+ "Anurag Soni"
+]
+license: "ISC"
+homepage: "https://github.com/mirage/ocaml-cohttp"
+doc: "https://mirage.github.io/ocaml-cohttp/"
+bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
+ "dune" {>= "3.8"}
"ocaml" {>= "4.08"}
- "dune" {>= "2.0"}
"mirage-flow" {>= "2.0.0"}
"mirage-channel" {>= "4.0.0"}
"conduit" {>= "2.0.2"}
"conduit-mirage" {>= "2.3.0"}
"mirage-kv" {>= "3.0.0"}
"lwt" {>= "2.4.3"}
- "cohttp" {= version}
"cohttp-lwt" {= version}
+ "cstruct" {>= "6.0.0"}
"fmt" {>= "0.8.7"}
"astring"
"magic-mime"
"ppx_sexp_conv" {>= "v0.13.0"}
+ "cohttp" {= version}
+ "odoc" {with-doc}
]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
build: [
["dune" "subst"] {dev}
- ["dune" "build" "-p" name "-j" jobs]
- ["dune" "runtest" "-p" name "-j" jobs] {with-test}
-]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-mirage/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-mirage/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v5.0.0-25-g0bb4e19
+ * cohttp v6.0.0
*)
-open Lwt.Infix
-
module Make
(P : Mirage_clock.PCLOCK)
(R : Resolver_mirage.S)
(S : Conduit_mirage.S) =
struct
- module Channel = Mirage_channel.Make (S.Flow)
- module HTTP_IO = Io.Make (Channel)
- module Endpoint = Conduit_mirage.Endpoint (P)
-
- module Net_IO = struct
- module IO = HTTP_IO
-
- type ctx = {
- resolver : R.t;
- conduit : S.t option;
- authenticator : X509.Authenticator.t option;
- }
-
- let sexp_of_ctx { resolver; _ } = R.sexp_of_t resolver
-
- let default_ctx =
- { resolver = R.localhost; conduit = None; authenticator = None }
-
- let connect_uri ~ctx:{ resolver; conduit; authenticator } uri =
- R.resolve_uri ~uri resolver >>= fun endp ->
- Endpoint.client ?tls_authenticator:authenticator endp >>= fun client ->
- match conduit with
- | None -> failwith "conduit not initialised"
- | Some c ->
- S.connect c client >>= fun flow ->
- let ch = Channel.create flow in
- Lwt.return (flow, ch, ch)
-
- let close_in _ = ()
- let close_out _ = ()
-
- let close ic _oc =
- Lwt.ignore_result
- @@ Lwt.catch
- (fun () -> Channel.close ic)
- (fun e ->
- Logs.warn (fun f ->
- f "Closing channel failed: %s" (Printexc.to_string e));
- Lwt.return @@ Ok ())
- end
+ module Net = Net.Make (P) (R) (S)
+ module Connection = Cohttp_lwt.Connection.Make (Net)
+ include Cohttp_lwt.Client.Make (Connection)
let ctx ?authenticator resolver conduit =
- { Net_IO.resolver; conduit = Some conduit; authenticator }
-
- let with_authenticator a ctx = { ctx with Net_IO.authenticator = Some a }
+ { Net.resolver; conduit = Some conduit; authenticator }
- (* Build all the core modules from the [Cohttp_lwt] functors *)
- include Cohttp_lwt.Make_client (HTTP_IO) (Net_IO)
+ let with_authenticator a ctx = { ctx with Net.authenticator = Some a }
end
module Make
- (P : Mirage_clock.PCLOCK)
+ (_ : Mirage_clock.PCLOCK)
(R : Resolver_mirage.S)
(S : Conduit_mirage.S) : sig
- include Cohttp_lwt.S.Client
+ module Connection : Cohttp_lwt.S.Connection
+ include Cohttp_lwt.S.Client with type ctx = Connection.Net.ctx
val ctx : ?authenticator:X509.Authenticator.t -> R.t -> S.t -> ctx
val with_authenticator : X509.Authenticator.t -> ctx -> ctx
-module Static = Static
+(** IO modules *)
+
+module IO = Io.Make
+
+module Net = Net.Make
+(** The resulting {!modtype:Cohttp_lwt.S.Net} module can be used to build the
+ low-level client interfaces with {!module:Cohttp_lwt.Connection.Make} and
+ from that {!module:Cohttp_lwt.Connection_cache.Make}. *)
+
+(** client modules *)
+
+(** simple, high-level interface *)
+
module Client = Client
+
+(** server modules *)
+
+module Static = Static
+(** Serve static HTTP sites from a Mirage key-value store. *)
+
module Server = Server
-module IO = Io.Make
(synopsis "Mirage backend for cohttp")
(preprocess
(pps ppx_sexp_conv))
- (libraries conduit-mirage cohttp-lwt mirage-channel mirage-kv mirage-flow
- magic-mime astring))
+ (libraries
+ conduit-mirage
+ cohttp-lwt
+ mirage-channel
+ mirage-kv
+ mirage-flow
+ magic-mime
+ astring))
--- /dev/null
+open Lwt.Infix
+module Bytebuffer = Cohttp_lwt.Private.Bytebuffer
+
+module Make (Channel : Mirage_channel.S) = struct
+ exception Read_exn of Channel.error
+
+ type t = { chan : Channel.t; buf : Bytebuffer.t }
+
+ let refill chan buf ~pos ~len =
+ Channel.read_some ~len chan >>= function
+ | Ok (`Data v) ->
+ let len = Cstruct.length v in
+ Cstruct.blit_to_bytes v 0 buf pos len;
+ Lwt.return (`Ok len)
+ | Ok `Eof -> Lwt.return `Eof
+ | Error e -> raise (Read_exn e)
+
+ let create ?(buf_len = 0x4000) chan =
+ { buf = Bytebuffer.create buf_len; chan }
+
+ let read_line_opt t = Bytebuffer.read_line t.buf (refill t.chan)
+ let read t count = Bytebuffer.read t.buf (refill t.chan) count
+ let refill t = Bytebuffer.refill t.buf (refill t.chan)
+
+ let with_input_buffer t ~f =
+ let buf = Bytebuffer.unsafe_buf t.buf in
+ let pos = Bytebuffer.pos t.buf in
+ let len = Bytebuffer.length t.buf in
+ let res, consumed = f (Bytes.unsafe_to_string buf) ~pos ~len in
+ Bytebuffer.drop t.buf consumed;
+ res
+
+ let close t = Channel.close t.chan
+end
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v5.0.0-25-g0bb4e19
+ * cohttp v6.0.0
*)
open Lwt.Infix
module Make (Channel : Mirage_channel.S) = struct
+ module Input_channel = Input_channel.Make (Channel)
+
type error =
| Read_error of Channel.error
| Write_error of Channel.write_error
| Write_error e -> Channel.pp_write_error f e
type 'a t = 'a Lwt.t
- type ic = Channel.t
+ type ic = Input_channel.t
type oc = Channel.t
type conn = Channel.flow
- exception Read_exn of Channel.error
exception Write_exn of Channel.write_error
let () =
Printexc.register_printer (function
- | Read_exn e ->
+ | Input_channel.Read_exn e ->
Some (Format.asprintf "IO read error: %a" Channel.pp_error e)
| Write_exn e ->
Some (Format.asprintf "IO write error: %a" Channel.pp_write_error e)
| _ -> None)
- let read_line ic =
- Channel.read_line ic >>= function
- | Ok (`Data []) -> Lwt.return_none
- | Ok `Eof -> Lwt.return_none
- | Ok (`Data bufs) -> Lwt.return_some (Cstruct.copyv bufs)
- | Error e -> Lwt.fail (Read_exn e)
-
- let read ic len =
- Channel.read_some ~len ic >>= function
- | Ok (`Data buf) -> Lwt.return (Cstruct.to_string buf)
- | Ok `Eof -> Lwt.return ""
- | Error e -> Lwt.fail (Read_exn e)
+ let read_line ic = Input_channel.read_line_opt ic
+ let read ic len = Input_channel.read ic len
+ let refill ic = Input_channel.refill ic
+ let with_input_buffer ic ~f = Input_channel.with_input_buffer ic ~f
let write oc buf =
Channel.write_string oc buf 0 (String.length buf);
Channel.flush oc >>= function
| Ok () -> Lwt.return_unit
- | Error `Closed -> Lwt.fail_with "Trying to write on closed channel"
- | Error e -> Lwt.fail (Write_exn e)
+ | Error `Closed -> failwith "Trying to write on closed channel"
+ | Error e -> raise (Write_exn e)
let flush _ =
(* NOOP since we flush in the normal writer functions above *)
let catch f =
Lwt.try_bind f Lwt.return_ok (function
- | Read_exn e -> Lwt.return_error (Read_error e)
+ | Input_channel.Read_exn e -> Lwt.return_error (Read_error e)
| Write_exn e -> Lwt.return_error (Write_error e)
- | ex -> Lwt.fail ex)
+ | ex -> Lwt.reraise ex)
end
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v5.0.0-25-g0bb4e19
+ * cohttp v6.0.0
*)
(** Cohttp IO implementation using Mirage channels. *)
module Make (Channel : Mirage_channel.S) :
Cohttp_lwt.S.IO
- with type ic = Channel.t
+ with type ic = Input_channel.Make(Channel).t
and type oc = Channel.t
and type conn = Channel.flow
module Server (Flow : Mirage_flow.S) = struct
module Channel = Mirage_channel.Make (Flow)
module HTTP_IO = Io.Make (Channel)
+ module Input_channel = Input_channel.Make (Channel)
include Cohttp_lwt.Make_server (HTTP_IO)
let listen spec flow =
let ch = Channel.create flow in
Lwt.finalize
- (fun () -> callback spec flow ch ch)
+ (fun () -> callback spec flow (Input_channel.create ch) ch)
(fun () -> Channel.close ch >|= fun _ -> ())
end
--- /dev/null
+module Make
+ (P : Mirage_clock.PCLOCK)
+ (R : Resolver_mirage.S)
+ (S : Conduit_mirage.S) =
+struct
+ module Channel = Mirage_channel.Make (S.Flow)
+ module Input_channel = Input_channel.Make (Channel)
+ module Endpoint = Conduit_mirage.Endpoint (P)
+ module IO = Io.Make (Channel)
+ open IO
+
+ type ctx = {
+ resolver : R.t;
+ conduit : S.t option;
+ authenticator : X509.Authenticator.t option;
+ }
+
+ let sexp_of_ctx { resolver; _ } = R.sexp_of_t resolver
+
+ let default_ctx =
+ lazy { resolver = R.localhost; conduit = None; authenticator = None }
+
+ type endp = Conduit.endp
+
+ let resolve ~ctx uri = R.resolve_uri ~uri ctx.resolver
+
+ let connect_endp ~ctx endp =
+ Endpoint.client ?tls_authenticator:ctx.authenticator endp >>= fun client ->
+ match ctx.conduit with
+ | None -> failwith "conduit not initialised"
+ | Some c ->
+ S.connect c client >>= fun flow ->
+ let ch = Channel.create flow in
+ Lwt.return (flow, Input_channel.create ch, ch)
+
+ let connect_uri ~ctx uri = resolve ~ctx uri >>= connect_endp ~ctx
+ let close_in _ = ()
+ let close_out _ = ()
+
+ let close ic _oc =
+ Lwt.ignore_result
+ @@ Lwt.catch
+ (fun () -> Input_channel.close ic)
+ (fun e ->
+ Logs.warn (fun f ->
+ f "Closing channel failed: %s" (Printexc.to_string e));
+ Lwt.return @@ Ok ())
+end
--- /dev/null
+module Make
+ (_ : Mirage_clock.PCLOCK)
+ (R : Resolver_mirage.S)
+ (S : Conduit_mirage.S) : sig
+ type ctx = {
+ resolver : R.t;
+ conduit : S.t option;
+ authenticator : X509.Authenticator.t option;
+ }
+
+ include Cohttp_lwt.S.Net with type ctx := ctx
+end
module Flow (F : Mirage_flow.S) = struct
module Channel = Mirage_channel.Make (F)
module HTTP_IO = Io.Make (Channel)
+ module Input_channel = Input_channel.Make (Channel)
include Cohttp_lwt.Make_server (HTTP_IO)
let callback spec flow =
let ch = Channel.create flow in
Lwt.finalize
- (fun () -> callback spec flow ch ch)
+ (fun () -> callback spec flow (Input_channel.create ch) ch)
(fun () -> Channel.close ch >|= fun _ -> ())
end
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v5.0.0-25-g0bb4e19
+ * cohttp v6.0.0
*)
module Key = Mirage_kv.Key
+module Connection = Cohttp.Connection [@@warning "-3"]
module HTTP (FS : Mirage_kv.RO) (S : Cohttp_lwt.S.Server) = struct
open Lwt.Infix
open Astring
- let failf fmt = Fmt.kstr Lwt.fail_with fmt
+ let failf fmt = Fmt.failwith fmt
let read_fs t name =
FS.get t (Key.v name) >>= function
let start ~http_port ?request_fn fs http =
let callback (_, cid) request _body =
let uri = Cohttp.Request.uri request in
- let cid = Cohttp.Connection.to_string cid in
+ let cid = Connection.to_string cid in
Logs.info (fun f -> f "[%s] serving %s" cid (Uri.to_string uri));
dispatcher request_fn fs uri
in
let conn_closed (_, cid) =
- let cid = Cohttp.Connection.to_string cid in
+ let cid = Connection.to_string cid in
Logs.info (fun f -> f "[%s] closing" cid)
in
Logs.info (fun f -> f "listening on %d/TCP" http_port);
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v5.0.0-25-g0bb4e19
+ * cohttp v6.0.0
*)
(** Serve static HTTP sites from a Mirage key-value store. *)
val start :
http_port:int ->
- ?request_fn:(Uri.t -> Cohttp.Header.t -> Cohttp.Header.t) ->
+ ?request_fn:(Uri.t -> Http.Header.t -> Http.Header.t) ->
FS.t ->
([> `TCP of int ] -> S.t -> 'a) ->
'a
--- /dev/null
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Lightweight Cohttp + Lwt based HTTP server"
+description: """
+This server implementation is faster than cohttp-lwt-unix and is independent of
+conduit.
+"""
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
+authors: [
+ "Anil Madhavapeddy"
+ "Stefano Zacchiroli"
+ "David Sheets"
+ "Thomas Gazagnaire"
+ "David Scott"
+ "Rudi Grinberg"
+ "Andy Ray"
+ "Anurag Soni"
+]
+license: "ISC"
+homepage: "https://github.com/mirage/ocaml-cohttp"
+doc: "https://mirage.github.io/ocaml-cohttp/"
+bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
+depends: [
+ "dune" {>= "3.8"}
+ "ocaml" {>= "4.08"}
+ "http" {= version}
+ "lwt" {>= "5.5.0"}
+ "conduit-lwt-unix" {with-test}
+ "cohttp-lwt-unix" {with-test & = version}
+ "cohttp-lwt" {with-test & = version}
+ "lwt"
+ "odoc" {with-doc}
+]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-server-lwt-unix/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-server-lwt-unix/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
--- /dev/null
+(*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ }}}*)
+
+open Lwt.Syntax
+open Lwt.Infix
+
+module Body = struct
+ module Substring = struct
+ type t = { base : string; pos : int; len : int }
+ end
+
+ module Encoding = struct
+ type t = Fixed of int64 | Chunked
+
+ let fixed i = Fixed i
+ let chunked = Chunked
+ end
+
+ type t =
+ Encoding.t
+ * [ `String of string | `Stream of unit -> Substring.t option Lwt.t ]
+
+ let encoding = fst
+
+ let string ?encoding s =
+ let encoding =
+ match encoding with
+ | Some s -> s
+ | None -> Encoding.Fixed (Int64.of_int (String.length s))
+ in
+ (encoding, `String s)
+
+ let stream ?(encoding = Encoding.Chunked) f : t = (encoding, `Stream f)
+ let chunk_size = 4096
+
+ let write_chunk oc (sub : Substring.t) =
+ let* () = Lwt_io.write oc (Printf.sprintf "%x\r\n" sub.len) in
+ let* () = Lwt_io.write_from_string_exactly oc sub.base sub.pos sub.len in
+ Lwt_io.write oc "\r\n"
+
+ let next_chunk base ~pos =
+ let len = String.length base in
+ if pos >= len then None
+ else Some { Substring.base; pos; len = min chunk_size (len - pos) }
+
+ let rec write_string_as_chunks oc s ~pos =
+ match next_chunk s ~pos with
+ | None -> Lwt_io.write oc "\r\n"
+ | Some chunk ->
+ let* () = write_chunk oc chunk in
+ let pos = pos + chunk.len in
+ write_string_as_chunks oc s ~pos
+
+ let rec write_fixed_stream oc f =
+ f () >>= function
+ | None -> Lwt.return_unit
+ | Some { Substring.base; pos; len } ->
+ let* () = Lwt_io.write_from_string_exactly oc base pos len in
+ write_fixed_stream oc f
+
+ let rec write_chunks_stream oc f =
+ f () >>= function
+ | None -> Lwt_io.write oc "\r\n"
+ | Some chunk ->
+ let* () = write_chunk oc chunk in
+ write_chunks_stream oc f
+
+ let write ((encoding, body) : t) oc =
+ match body with
+ | `String s -> (
+ match encoding with
+ | Fixed _ -> Lwt_io.write oc s
+ | Chunked -> write_string_as_chunks oc s ~pos:0)
+ | `Stream f -> (
+ match encoding with
+ | Fixed _ -> write_fixed_stream oc f
+ | Chunked -> write_chunks_stream oc f)
+end
+
+module Input_channel = struct
+ module Bytebuffer = Http_bytebuffer.Bytebuffer
+
+ module Refill =
+ Bytebuffer.Make
+ (struct
+ include Lwt
+
+ let ( >>| ) = ( >|= )
+ end)
+ (struct
+ type src = Lwt_io.input_channel
+
+ let rec refill ic buf ~pos ~len =
+ let open Lwt.Infix in
+ if Lwt_io.is_closed ic then Lwt.return `Eof
+ else
+ Lwt.catch
+ (fun () ->
+ Lwt_io.direct_access ic (fun da ->
+ let available = da.da_max - da.da_ptr in
+ if available = 0 then
+ let+ read = da.da_perform () in
+ if read = 0 then `Eof else `Refill
+ else
+ let read_len = min available len in
+ Lwt_bytes.blit_to_bytes da.da_buffer da.da_ptr buf pos
+ read_len;
+ da.da_ptr <- da.da_ptr + read_len;
+ Lwt.return (`Ok read_len)))
+ (function
+ | Unix.Unix_error (ECONNRESET, _, _) | Lwt_io.Channel_closed _
+ ->
+ let* () = Lwt_io.close ic in
+ Lwt.return `Eof
+ | exn -> raise exn)
+ >>= function
+ | `Eof ->
+ let* () = Lwt_io.close ic in
+ Lwt.return `Eof
+ | `Ok n -> Lwt.return (`Ok n)
+ | `Refill -> refill ic buf ~pos ~len
+ end)
+
+ type t = { buf : Bytebuffer.t; ic : Lwt_io.input_channel }
+
+ let create ?(buf_len = 0x4000) ic = { buf = Bytebuffer.create buf_len; ic }
+ let read_line_opt t = Refill.read_line t.buf t.ic
+ let read t count = Refill.read t.buf t.ic count
+ let refill t = Refill.refill t.buf t.ic
+ let remaining t = Bytebuffer.length t.buf
+
+ let with_input_buffer (t : t) ~f =
+ let buf = Bytebuffer.unsafe_buf t.buf in
+ let pos = Bytebuffer.pos t.buf in
+ let len = Bytebuffer.length t.buf in
+ let res, consumed = f (Bytes.unsafe_to_string buf) ~pos ~len in
+ Bytebuffer.drop t.buf consumed;
+ res
+
+ let with_input_buffer' (t : t) ~f =
+ let buf = Bytebuffer.unsafe_buf t.buf in
+ let pos = Bytebuffer.pos t.buf in
+ let len = Bytebuffer.length t.buf in
+ let+ res, consumed = f (Bytes.unsafe_to_string buf) ~pos ~len in
+ Bytebuffer.drop t.buf consumed;
+ res
+end
+
+module Context = struct
+ type request_body = Unread | Reading of unit Lwt.t
+
+ type t = {
+ request : Http.Request.t;
+ ic : Input_channel.t;
+ oc : Lwt_io.output_channel;
+ mutable request_body : request_body;
+ response_sent : Http.Response.t Lwt.t;
+ response_send : Http.Response.t Lwt.u;
+ }
+
+ let request t = t.request
+
+ let create request ic oc =
+ let response_sent, response_send = Lwt.wait () in
+ { request; ic; oc; response_sent; response_send; request_body = Unread }
+
+ let rec step_fixed t ~(f : Body.Substring.t -> _ -> _ Lwt.t) ~init ~left :
+ (_ * int) option Lwt.t =
+ if left = 0 then Lwt.return_none
+ else if Input_channel.remaining t.ic = 0 then
+ Input_channel.refill t.ic >>= function
+ | `Ok -> step_fixed t ~f ~init ~left
+ | `Eof -> Lwt.return_none (* TODO invalid input *)
+ else
+ let+ res =
+ Input_channel.with_input_buffer' t.ic ~f:(fun base ~pos ~len ->
+ let len = min left len in
+ let+ acc = f { Body.Substring.base; pos; len } init in
+ ((acc, left - len), len))
+ in
+ Some res
+
+ let parse_chunksize chunk_size_hex =
+ let hex =
+ (* From https://tools.ietf.org/html/rfc7230#section-4.1.1
+ > The chunked encoding allows each chunk to include zero or
+ > more chunk extensions, immediately following the chunk-size
+ *)
+ try String.sub chunk_size_hex 0 (String.index chunk_size_hex ';')
+ with _ -> chunk_size_hex
+ in
+ Int64.of_string_opt ("0x" ^ hex)
+
+ let step_chunked :
+ 'a.
+ t ->
+ f:(Body.Substring.t -> 'acc -> 'acc Lwt.t) ->
+ init:'acc ->
+ 'acc option Lwt.t =
+ fun t ~f ~init ->
+ Input_channel.read_line_opt t.ic >>= function
+ | None -> Lwt.return_none (* TODO invalid input *)
+ | Some "" -> Lwt.return_none
+ | Some line -> (
+ match parse_chunksize line with
+ | None -> Lwt.return_none
+ | Some size ->
+ let size = Int64.to_int size in
+ let* base = Input_channel.read t.ic size in
+ let chunk =
+ { Body.Substring.base; pos = 0; len = String.length base }
+ in
+ let+ init = f chunk init in
+ Some init)
+
+ let read_body t (encoding : Body.Encoding.t) ~init ~f =
+ match encoding with
+ | Fixed i ->
+ let rec loop init left =
+ step_fixed t ~f ~init ~left >>= function
+ | None -> Lwt.return init
+ | Some (acc, left) -> loop acc left
+ in
+ loop init (Int64.to_int i)
+ | Chunked ->
+ let rec loop init =
+ step_chunked t ~f ~init >>= function
+ | None -> Lwt.return init
+ | Some acc -> loop acc
+ in
+ loop init
+
+ let with_body t ~init ~f =
+ assert (t.request_body = Unread);
+ match Http.Request.has_body t.request with
+ | `Unknown | `No ->
+ t.request_body <- Reading Lwt.return_unit;
+ Lwt.return init
+ | `Yes ->
+ let rt, ru = Lwt.wait () in
+ t.request_body <- Reading rt;
+ let encoding =
+ match Http.Header.get_transfer_encoding t.request.headers with
+ | Chunked -> Body.Encoding.Chunked
+ | Fixed i -> Fixed i
+ | Unknown -> assert false
+ in
+ let+ acc = read_body t encoding ~init ~f in
+ Lwt.wakeup_later ru ();
+ acc
+
+ let read_body t =
+ let+ buf =
+ with_body t ~init:(Buffer.create 128)
+ ~f:(fun { Body.Substring.base; pos; len } acc ->
+ Buffer.add_substring acc base pos len;
+ Lwt.return acc)
+ in
+ Buffer.contents buf
+
+ let discard_body t = with_body t ~init:() ~f:(fun _ () -> Lwt.return_unit)
+
+ let respond t (response : Http.Response.t) (body : Body.t) =
+ let headers =
+ let encoding =
+ match (Body.encoding body : Body.Encoding.t) with
+ | Fixed i -> Http.Transfer.Fixed i
+ | Chunked -> Chunked
+ in
+ Http.Header.add_transfer_encoding response.headers encoding
+ in
+ let* () =
+ let* () = Lwt_io.write t.oc (Http.Version.to_string response.version) in
+ let* () = Lwt_io.write_char t.oc ' ' in
+ let* () = Lwt_io.write t.oc (Http.Status.to_string response.status) in
+ let* () = Lwt_io.write t.oc "\r\n" in
+ let* () =
+ Http.Header.to_list headers
+ |> Lwt_list.iter_s (fun (k, v) ->
+ let* () = Lwt_io.write t.oc k in
+ let* () = Lwt_io.write t.oc ": " in
+ let* () = Lwt_io.write t.oc v in
+ Lwt_io.write t.oc "\r\n")
+ in
+ let* () = Lwt_io.write t.oc "\r\n" in
+ Body.write body t.oc
+ in
+ Lwt.wakeup_later t.response_send response;
+ Lwt_io.flush t.oc
+end
+
+type on_exn = Hook | Callback of (exn -> unit)
+type t = { callback : Context.t -> unit Lwt.t; on_exn : on_exn }
+
+let create ?on_exn callback =
+ let on_exn = match on_exn with None -> Hook | Some f -> Callback f in
+ { on_exn; callback }
+
+let rec read_request ic =
+ let result =
+ Input_channel.with_input_buffer ic ~f:(fun buf ~pos ~len ->
+ match Http.Private.Parser.parse_request ~pos ~len buf with
+ | Ok (req, consumed) -> (`Ok req, consumed)
+ | Error Partial -> (`Partial, 0)
+ | Error (Msg msg) -> (`Invalid msg, 0))
+ in
+ match result with
+ | `Partial -> (
+ Input_channel.refill ic >>= function
+ | `Ok -> read_request ic
+ | `Eof -> Lwt.return `Eof)
+ | `Ok req -> Lwt.return (`Ok req)
+ | `Invalid msg -> Lwt.return (`Error msg)
+
+let handle_connection { callback; on_exn } (ic, oc) =
+ let on_exn =
+ match on_exn with
+ | Hook -> fun exn -> !Lwt.async_exception_hook exn
+ | Callback f -> f
+ in
+ let rec loop callback ic oc =
+ read_request ic >>= function
+ | `Error _ | `Eof -> Lwt.return_unit
+ | `Ok req ->
+ let context = Context.create req ic oc in
+ Lwt.dont_wait (fun () -> callback context) on_exn;
+ let* response =
+ match context.request_body with
+ | Unread -> assert false (* TODO *)
+ | Reading body ->
+ let+ (), response = Lwt.both body context.response_sent in
+ response
+ in
+ let keep_alive =
+ Http.Request.is_keep_alive req
+ &&
+ match Http.Header.connection (Http.Response.headers response) with
+ | Some `Keep_alive -> true
+ | Some `Close | Some (`Unknown _) -> false
+ | None -> Http.Response.version response = `HTTP_1_1
+ in
+ if keep_alive then loop callback ic oc else Lwt.return_unit
+ in
+ loop callback (Input_channel.create ic) oc
--- /dev/null
+(** High performance lwt server
+
+ This module is an alternative to the server offered in
+ [Cohttp_lwt_unix.Server]. It's a simplified implementation that has less
+ functionality but offers more control and better performance. The
+ differences are as follows:
+
+ - Vastly improved performance due to optimized buffer handling
+ - No dependency on conduit
+ - No builtin logging
+
+ An example server:
+
+ {[
+ open Lwt.Syntax
+
+ let server_callback ctx =
+ Lwt.join
+ [
+ Cohttp_server_lwt_unix.ontext.discard_body ctx;
+ Cohttp_server_lwt_unix.ontext.respond ctx (Http.Response.make ())
+ (Cohttp_server_lwt_unix.Body.string "hello world");
+ ]
+
+ let main () =
+ let* _server =
+ let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in
+ let server = Cohttp_server_lwt_unix.create server_callback in
+ Lwt_io.establish_server_with_client_address ~backlog:10_000
+ listen_address (fun _addr ch ->
+ Cohttp_server_lwt_unix.handle_connection server ch)
+ in
+ let forever, _ = Lwt.wait () in
+ forever
+
+ let () = ignore (Lwt_main.run (main ()))
+ ]} *)
+
+module Body : sig
+ module Encoding : sig
+ type t
+ (** HTTP body encoding *)
+
+ val fixed : int64 -> t
+ val chunked : t
+ end
+
+ type t
+ (** A response body *)
+
+ val string : ?encoding:Encoding.t -> string -> t
+ (** [string ?encoding s] respond with body [s].
+
+ [?encoding] the encoding to use. by default this is [Encoding.fixed] *)
+
+ module Substring : sig
+ type t = { base : string; pos : int; len : int }
+ end
+
+ val stream : ?encoding:Encoding.t -> (unit -> Substring.t option Lwt.t) -> t
+ (** [stream ?encoding f] respond with body generated by repeatedly applying
+ [f]. When [f] returns [None], it will be considered terminated.
+
+ [?encoding] is the encoding to use. By default this is [Encoding.chunked]. *)
+end
+
+module Context : sig
+ type t
+ (** A request context *)
+
+ val request : t -> Http.Request.t
+ (** [request t] returns the HTTP request *)
+
+ val read_body : t -> string Lwt.t
+ (** [read_body t] read the request body as a string *)
+
+ val discard_body : t -> unit Lwt.t
+ (** [discard_body t] discard the request body *)
+
+ val respond : t -> Http.Response.t -> Body.t -> unit Lwt.t
+ (** [respond t response body] respond to the request with [response] and
+ [body] *)
+end
+
+type t
+(** The type of an HTTP server able to handle requests. *)
+
+val create : ?on_exn:(exn -> unit) -> (Context.t -> unit Lwt.t) -> t
+(** [create ?on_exn f] creates an HTTP server that will handle every incoming
+ request with [f] concurrently.
+
+ [on_exn] will be called on exceptions not caught in [f] or raised by the
+ server itself. If [on_exn] isn't provided [Lwt.async_exception_hook] will be
+ used. *)
+
+val handle_connection :
+ t -> Lwt_io.input_channel * Lwt_io.output_channel -> unit Lwt.t
+(** [handle_connection t (i, o)] will handle all HTTP requests incoming from [i]
+ and write them to [o].
+
+ This function should be used with
+ [Lwt_io.establish_server_with_client_address] to setup a running HTTP
+ server. *)
--- /dev/null
+(library
+ (name cohttp_server_lwt_unix)
+ (public_name cohttp-server-lwt-unix)
+ (libraries lwt lwt.unix http http_bytebuffer))
--- /dev/null
+(test
+ (name test)
+ (package cohttp-server-lwt-unix)
+ (libraries
+ lwt.unix
+ lwt
+ http
+ conduit-lwt-unix
+ cohttp-lwt
+ cohttp-lwt-unix
+ cohttp-server-lwt-unix))
--- /dev/null
+open Lwt.Syntax
+
+let expected_response = "shutdown received"
+
+let http_server =
+ let module Context = Cohttp_server_lwt_unix.Context in
+ Cohttp_server_lwt_unix.create (fun ctx ->
+ let* () = Context.discard_body ctx in
+ let req = Context.request ctx in
+ match Http.Request.resource req with
+ | "/shutdown" ->
+ let resp = Http.Response.make () in
+ Context.respond ctx resp
+ (Cohttp_server_lwt_unix.Body.string expected_response)
+ | _ -> assert false)
+
+let fname = "test-lwt-unix"
+let delete_socket () = try Unix.unlink fname with Unix.Unix_error _ -> ()
+
+let server () =
+ delete_socket ();
+ let sockaddr = Unix.ADDR_UNIX fname in
+ Lwt_io.establish_server_with_client_address sockaddr (fun _ conn ->
+ Cohttp_server_lwt_unix.handle_connection http_server conn)
+
+let client server =
+ let uri = Uri.of_string "http://localhost/shutdown" in
+ let ctx =
+ let resolver =
+ Resolver_lwt.init
+ ~service:(fun _ ->
+ Lwt.return_some { Resolver.name = "http"; port = 80; tls = false })
+ ~rewrites:
+ [ ("localhost", fun _ _ -> Lwt.return (`Unix_domain_socket fname)) ]
+ ()
+ in
+ Cohttp_lwt_unix.Net.init ~resolver ()
+ in
+ let* _, body = Cohttp_lwt_unix.Client.call ~ctx `GET uri in
+ let* body = Cohttp_lwt.Body.to_string body in
+ assert (String.equal body expected_response);
+ Lwt_io.shutdown_server server
+
+let () =
+ at_exit delete_socket;
+ Lwt_main.run
+ (let* server = server () in
+ client server)
-version: "5.3.1"
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
-maintainer: "anil@recoil.org"
+synopsis: "CoHTTP toplevel pretty printers for HTTP types"
+description: """
+This library installs toplevel prettyprinters for CoHTTP
+types such as the `Request`, `Response` and `Types` modules.
+Once this library has been loaded, you can directly see the
+values of those types in toplevels such as `utop` or `ocaml`.
+"""
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
authors: [
"Anil Madhavapeddy"
"Stefano Zacchiroli"
"David Scott"
"Rudi Grinberg"
"Andy Ray"
+ "Anurag Soni"
]
-synopsis: "CoHTTP toplevel pretty printers for HTTP types"
-description: """
-This library installs toplevel prettyprinters for CoHTTP
-types such as the `Request`, `Response` and `Types` modules.
-Once this library has been loaded, you can directly see the
-values of those types in toplevels such as `utop` or `ocaml`."""
license: "ISC"
-tags: ["org:mirage" "org:xapi-project"]
homepage: "https://github.com/mirage/ocaml-cohttp"
doc: "https://mirage.github.io/ocaml-cohttp/"
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
+ "dune" {>= "3.8"}
"ocaml" {>= "4.08"}
- "dune" {>= "2.0"}
"cohttp" {= version}
+ "odoc" {with-doc}
]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
build: [
["dune" "subst"] {dev}
- ["dune" "build" "-p" name "-j" jobs]
- ["dune" "runtest" "-p" name "-j" jobs] {with-test}
-]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-top/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp-top/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
-version: "5.3.1"
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
-maintainer: "anil@recoil.org"
-authors: [
- "Anil Madhavapeddy"
- "Stefano Zacchiroli"
- "David Sheets"
- "Thomas Gazagnaire"
- "David Scott"
- "Rudi Grinberg"
- "Andy Ray"
-]
synopsis: "An OCaml library for HTTP clients and servers"
description: """
Cohttp is an OCaml library for creating HTTP daemons. It has a portable
You can activate some runtime debugging by setting `COHTTP_DEBUG` to any
value, and all requests and responses will be written to stderr. Further
debugging of the connection layer can be obtained by setting `CONDUIT_DEBUG`
-to any value."""
+to any value.
+"""
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
+authors: [
+ "Anil Madhavapeddy"
+ "Stefano Zacchiroli"
+ "David Sheets"
+ "Thomas Gazagnaire"
+ "David Scott"
+ "Rudi Grinberg"
+ "Andy Ray"
+ "Anurag Soni"
+]
license: "ISC"
-tags: ["org:mirage" "org:xapi-project"]
homepage: "https://github.com/mirage/ocaml-cohttp"
doc: "https://mirage.github.io/ocaml-cohttp/"
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
+ "dune" {>= "3.8"}
+ "http" {= version}
"ocaml" {>= "4.08"}
- "dune" {>= "2.0"}
"re" {>= "1.9.0"}
"uri" {>= "2.0.0"}
"uri-sexp"
+ "logs"
"sexplib0"
"ppx_sexp_conv" {>= "v0.13.0"}
"stringext"
"base64" {>= "3.1.0"}
"fmt" {with-test}
- "jsonm" {build}
- "alcotest" {with-test}
- "crowbar" {with-test & >= "0.2"}
+ "alcotest" {with-test & >= "1.7.0"}
+ "odoc" {with-doc}
]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
build: [
["dune" "subst"] {dev}
- ["dune" "build" "-p" name "-j" jobs]
- ["dune" "runtest" "-p" name "-j" jobs] {with-test}
-]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@cohttp/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
+++ /dev/null
-(executable
- (name fuzz_header)
- (libraries crowbar cohttp))
-
-(rule
- (alias runtest)
- (package cohttp)
- (action
- (run ./fuzz_header.exe)))
-
-(rule
- (alias fuzz)
- (deps
- (:exe fuzz_header.exe)
- (source_tree inputs))
- (action
- (run afl-fuzz -i inputs -o findings -- ./%{exe} @@)))
-
-(rule
- (alias bun-fuzz)
- (locks %{project_root}/bun)
- (deps
- (:exe fuzz_me.exe)
- (source_tree input))
- (action
- (run bun --input inputs --output findings -- ./%{exe})))
+++ /dev/null
-(*{{{ Copyright (c) 2021 Carine Morel <carine@tarides.com>
- *
- * Permission to use, copy, modify, and distribute this software for any
- * purpose with or without fee is hereby granted, provided that the above
- * copyright notice and this permission notice appear in all copies.
- *
- * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
- * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
- * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
- * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
- * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
- * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
- * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
- *}}}*)
-
-module H = Cohttp.Header
-
-(** Here, we test the Header module with fuzzing. Some of these tests may be
- redundant with Alcotest tests.
-
- The tests are launched with [dune runtest] but can also be run with [afl]
- with the command line : [dune build @cohttp/fuzz/fuzz --no-buffer].
-
- The tests below reflects the semantics we want for each function, however in
- some cases, it may actually be specific to the current implementation and
- does not necessary need to be enforced in future implementations. To make it
- clear, tests are annoted by their categories:
-
- - FS (Functions semantics): tests the semantics described in the
- documentation.
-
- - SI (Specific to current Implementation): these tests are here to check the
- implementation is doing what we think it is doing but may change
- accordingly to implementation changes. *)
-
-(* Generators *)
-let list_value_headers =
- [|
- "accept";
- "accept-charset";
- "accept-encoding";
- "accept-language";
- "accept-ranges";
- "allow";
- "cache-control";
- "connection";
- "content-encoding";
- "content-language";
- "expect";
- "if-match";
- "if-none-match";
- "link";
- "pragma";
- "proxy-authenticate";
- "te";
- "trailer";
- "transfer-encoding";
- "upgrade";
- "vary";
- "via";
- "warning";
- "www-authenticate";
- |]
-
-(** Pick a random list-value header name from a predefined array of values. *)
-let list_value_header_gen =
- let open Crowbar in
- let gen =
- map
- [ range (Array.length list_value_headers) ]
- (fun i -> list_value_headers.(i))
- in
- let printer fmt str = pp fmt "%s" str in
- with_printer printer gen
-
-(** Generate a tchar following
- {{:https://tools.ietf.org/html/rfc7230#appendix-B} RFC 7230}.
-
- tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" /
- "_" / "`" / "|" / "~" / DIGIT / ALPHA *)
-let tchar_gen =
- let tchar_code_gen =
- let uppercased_letter = Crowbar.range ~min:65 26 in
- let lowercased_letter = Crowbar.range ~min:97 26 in
- let others =
- List.map
- (fun i -> Crowbar.const i)
- [
- 33 (* ! *);
- 35 (* # *);
- 36 (* $ *);
- 37 (* % *);
- 38 (* & *);
- 42 (* * *);
- 43 (* + *);
- 45 (* - *);
- 46 (* . *);
- 94 (* ^ *);
- 95 (* _ *);
- 96 (* ` *);
- 124 (* | *);
- 126 (* ~ *);
- ]
- |> Crowbar.choose
- in
- let digit_and_others = Crowbar.(choose [ others; range ~min:48 10 ]) in
- Crowbar.(choose [ lowercased_letter; uppercased_letter; digit_and_others ])
- in
- Crowbar.(map [ tchar_code_gen ] (fun i -> Char.escaped (Char.chr i)))
-
-(** Generate a non-empty word of arbitrary length (composed of tchar only). *)
-let word_gen =
- let open Crowbar in
- let gen =
- fix (fun word_gen ->
- choose
- [
- (* one letter word *)
- tchar_gen;
- (* two letters word *)
- map [ tchar_gen; tchar_gen ] (fun l1 l2 -> l1 ^ l2);
- (* add one letter *)
- map [ tchar_gen; word_gen ] (fun l w -> l ^ w);
- ])
- in
- let printer = pp_string in
- with_printer printer gen
-
-(** Generate an header name: either a predefined list-value header or a random
- word *)
-let header_name_gen =
- let open Crowbar in
- let gen = choose [ list_value_header_gen; word_gen ] in
- let printer = pp_string in
- with_printer printer gen
-
-let header_printer fmt (k, v) = Crowbar.pp fmt "%s, %s" k v
-
-(** Generate a header key/value pair *)
-let header_gen : (string * string) Crowbar.gen =
- let open Crowbar in
- let gen_setcookie = pair (const "Set-cookie") word_gen in
- let gen_otherheader = pair header_name_gen word_gen in
- let gen =
- (* one in ten generated header is a "set-cookie" header *)
- choose (gen_setcookie :: List.init 9 (fun _ -> gen_otherheader))
- in
- with_printer header_printer gen
-
-(** Generate a list of headers *)
-let header_list_gen : (string * string) list Crowbar.gen =
- let open Crowbar in
- let gen = list header_gen in
- let printer = pp_list header_printer in
- with_printer printer gen
-
-(** Generate a [Cohttp.Header.t] headers. *)
-let headers_gen : H.t Crowbar.gen =
- let open Crowbar in
- let gen =
- fix (fun headers_gen ->
- choose
- [
- (* empty header *)
- const (H.init ());
- (* add one pair (k, v) *)
- map [ header_gen; headers_gen ] (fun (k, v) h -> H.add h k v);
- (* add a list of headers *)
- map [ headers_gen; header_list_gen ] (fun h l -> H.add_list h l);
- ])
- in
- let printer fmt h = Crowbar.pp fmt "\n%s@." (H.to_string h) in
- with_printer printer gen
-
-(* Tests *)
-(* Important note : keys must be lowercased before comparison *)
-let eqssl l1 l2 =
- List.map (fun (k, v) -> (String.lowercase_ascii k, v)) l1
- = List.map (fun (k, v) -> (String.lowercase_ascii k, v)) l2
-
-let is_empty_test () =
- Crowbar.(
- (* FS *)
- (* forall h, k, v. is_empty (add h k v) = false) *)
- add_test ~name:"[is_empty] returns false on a non empty header"
- [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
- check_eq false H.(is_empty (add h k v))))
-
-let init_with_test () =
- Crowbar.(
- (* FS *)
- (* forall k v. to_list (init_with k v) = [k, v] *)
- add_test ~name:"[init_list k v] is [k, v]" [ header_name_gen; word_gen ]
- (fun k v -> check_eq H.(to_list (init_with k v)) [ (k, v) ]))
-
-let mem_test () =
- Crowbar.(
- (* FS *)
- (* forall k. mem (init ()) k = false *)
- add_test ~name:"[mem h k] on an empty header is always false"
- [ header_name_gen ] (fun k -> check_eq false H.(mem (init ()) k));
- (* SI *)
- (* forall h, k. H.mem h k = List.(mem_assoc (String.lowercase_ascii x) (List.map (fun (k, v) -> String.lowercase_ascii k, v) (H.to_list h))) *)
- add_test ~name:"Header.mem has the same behavior than List.mem_assoc"
- [ headers_gen; header_name_gen ] (fun h k ->
- check_eq
- H.(mem h k)
- List.(
- mem_assoc (String.lowercase_ascii k)
- (List.map
- (fun (k, v) -> (String.lowercase_ascii k, v))
- (H.to_list h)))))
-
-let add_test () =
- Crowbar.(
- (* FS *)
- (* forall k, v, h. mem (add h k v) k = true *)
- add_test ~name:"mem (add h k v) k = true"
- [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
- check_eq true H.(mem (add h k v) k));
- add_test
- (* FS *)
- (* forall h, k, v. to_list (add h k v) = to_list h @ [lowercase k, v] *)
- ~name:"[add] adds a value at the header end"
- [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
- check_eq (H.to_list h @ [ (k, v) ]) H.(to_list (add h k v))))
-
-let to_list_of_list_test () =
- Crowbar.(
- (* FS *)
- (* forall h. to_list (of_list h) = h (with lowercase key comparison) *)
- add_test ~name:"to_list (of_list h) = h" [ header_list_gen ] (fun h ->
- check_eq ~eq:eqssl H.(to_list (of_list h)) h);
-
- (* FS and RFC *)
- (* forall h, k1, v1, k2, v2. to_list (add (add h k1 v1) k2 v2) = to_list \
- h @ [k1, v1; k2, v2] *)
- add_test ~name:"checking [to_list] order after multiple [add] calls"
- [ headers_gen; header_name_gen; word_gen; header_name_gen; word_gen ]
- (fun h k1 v1 k2 v2 ->
- check_eq ~eq:eqssl
- H.(to_list (add (add h k1 v1) k2 v2))
- H.(to_list h @ [ (k1, v1); (k2, v2) ])))
-
-let add_opt_test () =
- Crowbar.(
- (* FS *)
- (* forall hopt, k, v.
- add_opt hopt k v = | add h k v if hopt = Some h
- | init_with k v if hopt = None *)
- add_test ~name:"add_opt (Some h) = add and add_opt None = init_with"
- [ option headers_gen; header_name_gen; word_gen ]
- (fun hopt k v ->
- check_eq
- H.(match hopt with None -> init_with k v | Some h -> add h k v)
- H.(add_opt hopt k v)))
-
-let add_unless_exists_test () =
- Crowbar.(
- (* FS *)
- (* forall h, k, v. if mem h k = true then add_unless_exists h k v = h *)
- add_test ~name:"[add_unless_exists h k v] does nothing if k exists"
- [ headers_gen; header_list_gen; header_name_gen; word_gen; word_gen ]
- (fun h l k v1 v2 ->
- (* A random header such as mem h k = true *)
- let h = H.(add_list (add h k v1) l) in
- check_eq H.(add_unless_exists h k v2) h);
- (* FS *)
- (* forall h, k, v. if mem h k = false then add_unless_exists h k v = add \
- h k v *)
- add_test ~name:"add_unless_exists = add if key does not exist"
- [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
- (* Making sure as mem h k = false *)
- guard (not (H.mem h k));
- check_eq H.(add_unless_exists h k v) H.(add h k v)))
-
-let add_list () =
- Crowbar.(
- (* FS *)
- (* forall h, l. to_list (add_list h l) = to_list h @ l *)
- add_test
- ~name:"[add_list h l] adds all headers in [l] in order at the end of [h]"
- [ headers_gen; header_list_gen ] (fun h l ->
- check_eq ~eq:eqssl H.(to_list (add_list h l)) H.(to_list h @ l)))
-
-let add_multi () =
- Crowbar.(
- (* FS *)
- (* forall h, k, vs. add_multi h k vs = add_list h (List.map (fun v -> k, v) vs) *)
- add_test ~name:"[add_list] and [add_multi] have compatible semantics"
- [ headers_gen; header_name_gen; list word_gen ]
- (fun h k vs ->
- check_eq
- H.(add_multi h k vs)
- H.(add_list h (List.map (fun v -> (k, v)) vs)));
- (* FS *)
- (* forall h, k, l. get_multi (add_multi h k l) k = get_multi h k @ l *)
- add_test ~name:"get_multi (add_multi h k l) k = get_multi h k @ l"
- [ headers_gen; header_name_gen; Crowbar.list word_gen ]
- (fun h k l ->
- check_eq H.(get_multi (add_multi h k l) k) H.(get_multi h k @ l)))
-
-let get_test () =
- Crowbar.(
- (* FS *)
- (* forall h k, if mem h k = false then get h k = None *)
- add_test ~name:"[get h k] returns None if k does not exists in h"
- [ headers_gen; header_name_gen ] (fun h k ->
- guard H.(not (mem h k));
- check_eq H.(get h k) None);
- (* FS *)
- (* forall h k, get (add h k v) = Some v *)
- add_test ~name:"get (add h k v) = Some v"
- [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
- check_eq H.(get (add h k v) k) (Some v)))
-
-let get_multi_test () =
- Crowbar.(
- (* FS *)
- (* forall h k, if mem h k = false then get_multi h k = [] *)
- add_test ~name:"[get_multi h k] returns [] if k does not exists in h"
- [ headers_gen; header_name_gen ] (fun h k ->
- guard H.(not (mem h k));
- check_eq H.(get_multi h k) []);
- (* FS *)
- (* forall l1, l2, k, v.
- get_multi (of_list (l1 @ [ (k, v) ] @ l2)) k =
- get_multi (of_list l1) k @ [ v ] @ get_multi (of_list l2) k *)
- add_test ~name:"[get_multi] returns values in transmission order"
- [ header_list_gen; header_list_gen; header_name_gen; word_gen ]
- (fun l1 l2 k v ->
- check_eq
- H.(get_multi (of_list (l1 @ [ (k, v) ] @ l2)) k)
- H.(get_multi (of_list l1) k @ [ v ] @ get_multi (of_list l2) k));
- (* FS and RFC7230§3.2.2 *)
- (* forall h, v1, v2, forall k in list values headers.
- get_multi (add (add h k v1) k v2)) k = get_multi h k @ [v1; v2] *)
- add_test ~name:"headers order is preserved"
- [ headers_gen; list_value_header_gen; word_gen; word_gen ]
- (fun h k v1 v2 ->
- check_eq
- H.(get_multi (add (add h k v1) k v2) k)
- (H.(get_multi h k) @ [ v1; v2 ])))
-
-let remove_test () =
- Crowbar.(
- (* FS *)
- (* forall h, k. mem (remove h k) k = false *)
- add_test ~name:"[remove] removes all values associated to a key"
- [ headers_gen; header_name_gen ] (fun h k ->
- check_eq false H.(mem (remove h k) k));
- (* FS *)
- (* forall h, k. remove (remove h k) k = remove h k*)
- add_test ~name:"(fun x -> remove x k) is idempotent"
- [ headers_gen; header_name_gen ] (fun h k ->
- check_eq H.(remove (remove h k) k) H.(remove h k)))
-
-let replace_test () =
- Crowbar.(
- (* FS *)
- (* forall h, k, v. get_multi (replace h k v) = [ v ] *)
- add_test ~name:"[replace] replaces the last value and remove the others"
- [ headers_gen; header_list_gen; header_name_gen; word_gen; word_gen ]
- (fun h l k v1 v2 ->
- check_eq H.(get_multi (replace h k v1) k) [ v1 ];
- (* This second check is to make sure the case where mem h k = true is tested *)
- let h =
- H.(add_list (add h k v1) l)
- (* h is built such as mem h k = true *)
- in
- check_eq H.(get_multi (replace h k v2) k) [ v2 ]);
- (* FS *)
- (* forall h, k, v. if mem h k = false then replace h k v = add h k v) *)
- add_test ~name:"replace h k v = add h k v if k does not exists in h"
- [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
- guard H.(mem h k = false);
- check_eq H.(replace h k v) H.(add h k v));
- (* SI *)
- (* forall h, l, k, v1, v2.
- if mem (of_list l) k = false then
- replace (add_list h ([ k, v1 ] @ l)) k v2 =
- add_list (add (remove h k) k v2) l k) *)
- add_test ~name:"[replace] does not change headers order"
- [ headers_gen; header_list_gen; header_name_gen; word_gen; word_gen ]
- (fun h l k v1 v2 ->
- guard H.(not (mem (of_list l) k));
- (* A random headers such as mem h k = true *)
- let h1 = H.(add_list h ([ (k, v1) ] @ l)) in
- let h2 = H.(add_list (remove h k) ([ (k, v2) ] @ l)) in
- check_eq ~eq:eqssl H.(to_list (replace h1 k v2)) H.(to_list h2)))
-
-let update_test () =
- Crowbar.(
- (* FS *)
- (* forall h k, update h k id = h *)
- add_test ~name:"[update h k id] does nothing"
- [ headers_gen; header_name_gen ] (fun h k ->
- check_eq H.(update h k (fun x -> x)) h);
- (*FS*)
- (* forall h k f, remove (update h k f) k = remove h k *)
- add_test ~name:"[update h k _] only changes k "
- [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
- check_eq H.(remove (update h k (fun _ -> None)) k) H.(remove h k);
- check_eq H.(remove (update h k (fun _ -> Some w)) k) H.(remove h k));
- (*FS*)
- add_test ~name:"[update h k (fun _ -> None)] removes last occurence of k."
- [ headers_gen; header_name_gen ] (fun h k ->
- let h1 = H.update h k (fun _ -> None) in
- let r1 = H.get_multi h1 k in
- let r2 =
- match List.rev (H.get_multi h k) with
- | [] -> []
- | _ :: xs -> List.rev xs
- in
- check_eq r1 r2);
- (*FS*)
- add_test
- ~name:
- "[update h k (function Some _ -> Some w)] replaces last occurence of k."
- [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
- let h1 = H.update h k (fun _ -> Some w) in
- let r1 = H.get_multi h1 k in
- let r2 =
- match List.rev (H.get_multi h k) with
- | [] -> [ w ]
- | _ :: xs -> List.rev (w :: xs)
- in
- check_eq r1 r2))
-
-let update_all_test () =
- Crowbar.(
- (* FS *)
- (* forall h k, update_all h k id = h *)
- add_test ~name:"[update_all h k id] does nothing"
- [ headers_gen; header_name_gen ] (fun h k ->
- check_eq H.(update_all h k (fun x -> x)) h);
- (*FS*)
- (* forall h k f, remove (update_all h k f) k = remove h k *)
- add_test ~name:"[update_all h k _] only changes k "
- [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
- check_eq H.(remove (update_all h k (fun _ -> [])) k) H.(remove h k);
- check_eq H.(remove (update_all h k (fun _ -> [ w ])) k) H.(remove h k));
- (*FS*)
- add_test ~name:"[update_all h k (fun _ -> [])] removes all occurences of k."
- [ headers_gen; header_name_gen ] (fun h k ->
- let h1 = H.update_all h k (fun _ -> []) in
- check_eq H.(get_multi h1 k) []);
- (*FS*)
- add_test
- ~name:
- "[update_all h k (function _ -> [w])] removes all occurences of k and \
- adds w." [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
- let h1 = H.update_all h k (fun _ -> [ w ]) in
- let r1 = H.get_multi h1 k in
- let r2 = [ w ] in
- check_eq r1 r2))
-
-let get_multi_concat_test () =
- Crowbar.(
- (* FS *)
- (* forall h, k. if mem h k = false then get_multi_concat h k = None *)
- add_test
- ~name:"[get_multi_concat h k] returns \"\" if k does not exists in h"
- [ headers_gen; header_name_gen ] (fun h k ->
- guard H.(not (mem h k));
- check_eq H.(get_multi_concat h k) None);
- (* FS *)
- (* forall h, k. get_multi_concat ~list_value_only:true h k = get h k
- if k is not a list value header *)
- add_test ~name:"[get_multi_concat] optional argument works properly"
- [ headers_gen; word_gen ] (fun h k ->
- guard (not (Array.mem (String.lowercase_ascii k) list_value_headers));
- check_eq H.(get_multi_concat ~list_value_only:true h k) H.(get h k));
- (* FS - Very important for RFC 7230.3.2.2 *)
- add_test ~name:"[get_multi_concat] returns values in transmission order"
- [ header_list_gen; header_list_gen; header_name_gen; word_gen ]
- (fun l1 l2 k v ->
- let str_opt ?(bfr = false) ?(aft = false) s =
- match s with
- | None -> ""
- | Some v -> if bfr then "," ^ v else if aft then v ^ "," else v
- in
- check_eq
- H.(str_opt (get_multi_concat (of_list (l1 @ [ (k, v) ] @ l2)) k))
- H.(
- str_opt ~aft:true (get_multi_concat (of_list l1) k)
- ^ v
- ^ str_opt ~bfr:true (get_multi_concat (of_list l2) k))))
-
-(* Note : clean_dup does nothing to already concatenated headers. For
- example, ["a", "v1,v2"] will be not be cleaned. *)
-let clean_dup_test () =
- Crowbar.(
- (* FS *)
- (* Check that there is no more duplicates (except set-cookie). *)
- add_test
- ~name:
- "All headers name in [h] appears strictly once in [clean_dup h] except \
- for [set-cookie]" [ headers_gen ] (fun h ->
- let h = H.remove h "set-cookie" in
- let h = H.(to_list (clean_dup h)) in
- let compare_key (k, _) (k', _) = compare k k' in
- check_eq (List.sort_uniq compare_key h) (List.sort compare_key h));
- (* FS *)
- (* forall h, k in list_value_headers.
- String.concat "," (get_multi_concat h k) = get (clean_dup h) k *)
- add_test ~name:"[clean_dup] concatenates properly list-value headers"
- [ headers_gen; list_value_header_gen ] (fun h k ->
- check_eq H.(get_multi_concat h k) H.(get (clean_dup h) k));
- (* FS *)
- (* forall h. clean_dup (clean_dup h) = clean_dup h *)
- add_test ~name:"[clean_dup] is idempotent" [ headers_gen ] (fun h ->
- check_eq H.(clean_dup (clean_dup h)) H.(clean_dup h));
- (* FS *)
- (* forall h. get_multi (clean_dup h) "set-cookie" = get_multi h "set-cookie"*)
- add_test ~name:"[clean_dup] does nothing to [set-cookie] headers"
- [ headers_gen ] (fun h ->
- check_eq
- H.(get_multi h "set-cookie")
- H.(get_multi (clean_dup h) "set-cookie"));
- (* FS *)
- (* As the generated header values are only composed of tchar (it
- does not generate concatenated values like "gzip,chunked"), the
- only cases where there are commas in a value is if [clean_dup]
- concatenated multiple values.
-
- This test checks that only one value is kept for non-list-value
- headers and that this value is the last one. *)
- add_test
- ~name:"Only list-value headers can have multiple concatenated values "
- [ headers_gen ] (fun h ->
- (* As it is an exception, [set-cookie] is removed. *)
- let h = H.remove h "set-cookie" in
- let h' = H.(clean_dup h) in
- let has_multiple_values v =
- match String.split_on_char ',' v with
- | [] | [ _ ] -> false
- | _ -> true
- in
- check_eq true
- H.(
- fold
- (fun k v b ->
- if Array.mem k list_value_headers then b
- else if has_multiple_values v then false
- else b && get h k = Some v)
- h' true)))
-
-let () =
- init_with_test ();
- is_empty_test ();
- mem_test ();
- add_test ();
- to_list_of_list_test ();
- add_opt_test ();
- add_unless_exists_test ();
- add_list ();
- add_multi ();
- get_test ();
- get_multi_test ();
- get_multi_concat_test ();
- remove_test ();
- replace_test ();
- update_test ();
- update_all_test ();
- clean_dup_test ();
- ()
+++ /dev/null
-something
\ No newline at end of file
+++ /dev/null
-{
- "class":{
- "title":"Informational",
- "class":"1"
- },
- "codes":{
- "100":{
- "code":"100",
- "title":"Continue",
- "summary":"Client should continue with request",
- "descriptions":{
- "wikipedia":{
- "body":"This means that the server has received the request headers, and that the client should proceed to send the request body (in the case of a request for which a body needs to be sent; for example, a POST request). If the request body is large, sending it to a server when a request has already been rejected based upon inappropriate headers is inefficient. To have a server check if the request could be accepted based on the request's headers alone, a client must send Expect: 100-continue as a header in its initial request and check if a 100 Continue status code is received in response before continuing (or receive 417 Expectation Failed and not continue).",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#100"
- },
- "ietf":{
- "body":"The client SHOULD continue with its request. This interim response is used to inform the client that the initial part of the request has been received and has not yet been rejected by the server. The client SHOULD continue by sending the remainder of the request or, if the request has already been completed, ignore this response. The server MUST send a final response after the request has been completed.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":continue"
- }
- }
- },
- "101":{
- "code":"101",
- "title":"Switching Protocols",
- "summary":"Server is switching protocols",
- "descriptions":{
- "wikipedia":{
- "body":"This means the requester has asked the server to switch protocols and the server is acknowledging that it will do so.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#101"
- },
- "ietf":{
- "body":"The server understands and is willing to comply with the client's request, via the Upgrade message header field, for a change in the application protocol being used on this connection. The server will switch protocols to those defined by the response's Upgrade header field immediately after the empty line which terminates the 101 response. \r\nThe protocol SHOULD be switched only when it is advantageous to do so. For example, switching to a newer version of HTTP is advantageous over older versions, and switching to a real-time, synchronous protocol might be advantageous when delivering resources that use such features.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":switching_protocols"
- }
- }
- },
- "102":{
- "code":"102",
- "title":"Processing (WebDAV) (RFC 2518)",
- "summary":"Server has received and is processing the request",
- "descriptions":{
- "wikipedia":{
- "body":"As a WebDAV request may contain many sub-requests involving file operations, it may take a long time to complete the request. This code indicates that the server has received and is processing the request, but no response is available yet. This prevents the client from timing out and assuming the request was lost.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#102"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":processing"
- }
- }
- },
- "103":{
- "code":"103",
- "title":"Checkpoint",
- "summary":"resume aborted PUT or POST requests",
- "descriptions":{
- "wikipedia":{
- "body":"This code is used in the Resumable HTTP Requests Proposal to resume aborted PUT or POST requests.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#103"
- }
- }
- },
- "122":{
- "code":"122",
- "title":"Request-URI too long",
- "summary":"URI is longer than a maximum of 2083 characters",
- "descriptions":{
- "wikipedia":{
- "body":"This is a non-standard IE7-only code which means the URI is longer than a maximum of 2083 characters.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#122"
- }
- }
- }
- }
-}
\ No newline at end of file
+++ /dev/null
-{
- "class":{
- "title":"Success",
- "class":"2"
- },
- "codes":{
- "200":{
- "code":"200",
- "title":"OK",
- "summary":"standard response for successful HTTP requests",
- "descriptions":{
- "wikipedia":{
- "body":"Standard response for successful HTTP requests. The actual response will depend on the request method used. In a GET request, the response will contain an entity corresponding to the requested resource. In a POST request the response will contain an entity describing or containing the result of the action.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#200"
- },
- "ietf":{
- "body":"The request has succeeded. The information returned with the response is dependent on the method used in the request, for example: GET an entity corresponding to the requested resource is sent in the response; HEAD the entity-header fields corresponding to the requested resource are sent in the response without any message-body; POST an entity describing or containing the result of the action;",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":ok"
- }
- }
- },
- "201":{
- "code":"201",
- "title":"Created",
- "summary":"request has been fulfilled; new resource created",
- "descriptions":{
- "wikipedia":{
- "body":"The request has been fulfilled and resulted in a new resource being created.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#201"
- },
- "ietf":{
- "body":"The request has been fulfilled and resulted in a new resource being created. The newly created resource can be referenced by the URI(s) returned in the entity of the response, with the most specific URI for the resource given by a Location header field. The response SHOULD include an entity containing a list of resource characteristics and location(s) from which the user or user agent can choose the one most appropriate. The entity format is specified by the media type given in the Content-Type header field. The origin server MUST create the resource before returning the 201 status code. If the action cannot be carried out immediately, the server SHOULD respond with 202 (Accepted) response instead.\r\n A 201 response MAY contain an ETag response header field indicating the current value of the entity tag for the requested variant just created.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":created"
- }
- }
- },
- "202":{
- "code":"202",
- "title":"Accepted",
- "summary":"request accepted, processing pending",
- "descriptions":{
- "wikipedia":{
- "body":"The request has been accepted for processing, but the processing has not been completed. The request might or might not eventually be acted upon, as it might be disallowed when processing actually takes place.[2]",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#202"
- },
- "ietf":{
- "body":"The request has been accepted for processing, but the processing has not been completed. The request might or might not eventually be acted upon, as it might be disallowed when processing actually takes place. There is no facility for re-sending a status code from an asynchronous operation such as this. \r\nThe 202 response is intentionally non-committal. Its purpose is to allow a server to accept a request for some other process (perhaps a batch-oriented process that is only run once per day) without requiring that the user agent's connection to the server persist until the process is completed. The entity returned with this response SHOULD include an indication of the request's current status and either a pointer to a status monitor or some estimate of when the user can expect the request to be fulfilled.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":accepted"
- }
- }
- },
- "203":{
- "code":"203",
- "title":"Non-Authoritative Information (since HTTP\/1.1)",
- "summary":"request processed, information may be from another source",
- "descriptions":{
- "wikipedia":{
- "body":"The server successfully processed the request, but is returning information that may be from another source.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#203"
- },
- "ietf":{
- "body":"The returned metainformation in the entity-header is not the definitive set as available from the origin server, but is gathered from a local or a third-party copy. The set presented MAY be a subset or superset of the original version. For example, including local annotation information about the resource might result in a superset of the metainformation known by the origin server. Use of this response code is not required and is only appropriate when the response would otherwise be 200 (OK).",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":non_authoritative_information"
- }
- }
- },
- "204":{
- "code":"204",
- "title":"No Content",
- "summary":"request processed, no content returned",
- "descriptions":{
- "wikipedia":{
- "body":"The server successfully processed the request, but is not returning any content.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#204"
- },
- "ietf":{
- "body":"The server has fulfilled the request but does not need to return an entity-body, and might want to return updated metainformation. The response MAY include new or updated metainformation in the form of entity-headers, which if present SHOULD be associated with the requested variant.\r\nIf the client is a user agent, it SHOULD NOT change its document view from that which caused the request to be sent. This response is primarily intended to allow input for actions to take place without causing a change to the user agent's active document view, although any new or updated metainformation SHOULD be applied to the document currently in the user agent's active view.\r\nThe 204 response MUST NOT include a message-body, and thus is always terminated by the first empty line after the header fields.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":no_content"
- }
- }
- },
- "205":{
- "code":"205",
- "title":"Reset Content",
- "summary":"request processed, no content returned, reset document view",
- "descriptions":{
- "wikipedia":{
- "body":"The server successfully processed the request, but is not returning any content. Unlike a 204 response, this response requires that the requester reset the document view.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#205"
- },
- "ietf":{
- "body":"The server has fulfilled the request and the user agent SHOULD reset the document view which caused the request to be sent. This response is primarily intended to allow input for actions to take place via user input, followed by a clearing of the form in which the input is given so that the user can easily initiate another input action. The response MUST NOT include an entity.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":reset_content"
- }
- }
- },
- "206":{
- "code":"206",
- "title":"Partial Content",
- "summary":"partial resource return due to request header",
- "descriptions":{
- "wikipedia":{
- "body":"The server is delivering only part of the resource due to a range header sent by the client. The range header is used by tools like wget to enable resuming of interrupted downloads, or split a download into multiple simultaneous streams.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#206"
- },
- "ietf":{
- "body":"The server has fulfilled the partial GET request for the resource. The request MUST have included a Range header field indicating the desired range, and MAY have included an If-Range header field to make the request conditional.\r\nThe response MUST include the following header fields:\r\nEither a Content-Range header field (section 14.16) indicating the range included with this response, or a multipart\/byteranges Content-Type including Content-Range fields for each part. If a Content-Length header field is present in the response, its value MUST match the actual number of OCTETs transmitted in the message-body.\r\nDate\r\nETag and\/or Content-Location, if the header would have been sent in a 200 response to the same request\r\nExpires, Cache-Control, and\/or Vary, if the field-value might differ from that sent in any previous response for the same variant\r\nIf the 206 response is the result of an If-Range request that used a strong cache validator, the response SHOULD NOT include other entity-headers. If the response is the result of an If-Range request that used a weak validator, the response MUST NOT include other entity-headers; this prevents inconsistencies between cached entity-bodies and updated headers. Otherwise, the response MUST include all of the entity-headers that would have been returned with a 200 (OK) response to the same request.\r\nA cache MUST NOT combine a 206 response with other previously cached content if the ETag or Last-Modified headers do not match exactly.\r\nA cache that does not support the Range and Content-Range headers MUST NOT cache 206 (Partial) responses.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":partial_content"
- }
- }
- },
- "207":{
- "code":"207",
- "title":"Multi-Status (WebDAV) (RFC 4918)",
- "summary":"XML, can contain multiple separate responses",
- "descriptions":{
- "wikipedia":{
- "body":"The message body that follows is an XML message and can contain a number of separate response codes, depending on how many sub-requests were made.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#207"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":multi_status"
- }
- }
- },
- "208":{
- "code":"208",
- "title":"Already Reported (WebDAV) (RFC 5842)",
- "summary":"results previously returned ",
- "descriptions":{
- "wikipedia":{
- "body":"The members of a DAV binding have already been enumerated in a previous reply to this request, and are not being included again.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#208"
- }
- }
- },
- "226":{
- "code":"226",
- "title":"IM Used (RFC 3229)",
- "summary":"request fulfilled, reponse is instance-manipulations",
- "descriptions":{
- "wikipedia":{
- "body":"The server has fulfilled a GET request for the resource, and the response is a representation of the result of one or more instance-manipulations applied to the current instance.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#226"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":im_used"
- }
- }
- }
- }
-}
+++ /dev/null
-{
- "class":{
- "title":"Redirection",
- "class":"3"
- },
- "codes":{
- "300":{
- "code":"300",
- "title":"Multiple Choices",
- "summary":"multiple options for the resource delivered",
- "descriptions":{
- "wikipedia":{
- "body":"Indicates multiple options for the resource that the client may follow. It, for instance, could be used to present different format options for video, list files with different extensions, or word sense disambiguation.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#300"
- },
- "ietf":{
- "body":"The requested resource corresponds to any one of a set of representations, each with its own specific location, and agent- driven negotiation information is being provided so that the user (or user agent) can select a preferred representation and redirect its request to that location.\r\nUnless it was a HEAD request, the response SHOULD include an entity containing a list of resource characteristics and location(s) from which the user or user agent can choose the one most appropriate. The entity format is specified by the media type given in the Content- Type header field. Depending upon the format and the capabilities of the user agent, selection of the most appropriate choice MAY be performed automatically. However, this specification does not define any standard for such automatic selection.\r\nIf the server has a preferred choice of representation, it SHOULD include the specific URI for that representation in the Location field; user agents MAY use the Location field value for automatic redirection. This response is cacheable unless indicated otherwise.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":multiple_choices"
- }
- }
- },
- "301":{
- "code":"301",
- "title":"Moved Permanently",
- "summary":"this and all future requests directed to the given URI",
- "descriptions":{
- "wikipedia":{
- "body":"This and all future requests should be directed to the given URI.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#301"
- },
- "ietf":{
- "body":"The requested resource has been assigned a new permanent URI and any future references to this resource SHOULD use one of the returned URIs. Clients with link editing capabilities ought to automatically re-link references to the Request-URI to one or more of the new references returned by the server, where possible. This response is cacheable unless indicated otherwise.\r\nThe new permanent URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).\r\nIf the 301 status code is received in response to a request other than GET or HEAD, the user agent MUST NOT automatically redirect the request unless it can be confirmed by the user, since this might change the conditions under which the request was issued.\r\nNote: When automatically redirecting a POST request after receiving a 301 status code, some existing HTTP\/1.0 user agents will erroneously change it into a GET request.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":moved_permanently"
- }
- }
- },
- "302":{
- "code":"302",
- "title":"Found",
- "summary":"temporary response to request found via alternative URI",
- "descriptions":{
- "wikipedia":{
- "body":"This is an example of industrial practice contradicting the standard. HTTP\/1.0 specification (RFC 1945) required the client to perform a temporary redirect (the original describing phrase was \"Moved Temporarily\"), but popular browsers implemented 302 with the functionality of a 303 See Other. Therefore, HTTP\/1.1 added status codes 303 and 307 to distinguish between the two behaviours. However, some Web applications and frameworks use the 302 status code as if it were the 303.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#302"
- },
- "ietf":{
- "body":"The requested resource resides temporarily under a different URI. Since the redirection might be altered on occasion, the client SHOULD continue to use the Request-URI for future requests. This response is only cacheable if indicated by a Cache-Control or Expires header field.\r\nThe temporary URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).\r\nIf the 302 status code is received in response to a request other than GET or HEAD, the user agent MUST NOT automatically redirect the request unless it can be confirmed by the user, since this might change the conditions under which the request was issued.\r\nNote: RFC 1945 and RFC 2068 specify that the client is not allowed to change the method on the redirected request. However, most existing user agent implementations treat 302 as if it were a 303 response, performing a GET on the Location field-value regardless of the original request method. The status codes 303 and 307 have been added for servers that wish to make unambiguously clear which kind of reaction is expected of the client.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":found"
- }
- }
- },
- "303":{
- "code":"303",
- "title":"See Other",
- "summary":"permanent response to request found via alternative URI",
- "descriptions":{
- "wikipedia":{
- "body":"The response to the request can be found under another URI using a GET method. When received in response to a POST (or PUT\/DELETE), it should be assumed that the server has received the data and the redirect should be issued with a separate GET message.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#303"
- },
- "ietf":{
- "body":"The response to the request can be found under a different URI and SHOULD be retrieved using a GET method on that resource. This method exists primarily to allow the output of a POST-activated script to redirect the user agent to a selected resource. The new URI is not a substitute reference for the originally requested resource. The 303 response MUST NOT be cached, but the response to the second (redirected) request might be cacheable.\r\nThe different URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).\r\nNote: Many pre-HTTP\/1.1 user agents do not understand the 303 status. When interoperability with such clients is a concern, the 302 status code may be used instead, since most user agents react to a 302 response as described here for 303.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":see_other"
- }
- }
- },
- "304":{
- "code":"304",
- "title":"Not Modified",
- "summary":"resource has not been modified since last requested",
- "descriptions":{
- "wikipedia":{
- "body":"Indicates the resource has not been modified since last requested. Typically, the HTTP client provides a header like the If-Modified-Since header to provide a time against which to compare. Using this saves bandwidth and reprocessing on both the server and client, as only the header data must be sent and received in comparison to the entirety of the page being re-processed by the server, then sent again using more bandwidth of the server and client.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#304"
- },
- "ietf":{
- "body":"If the client has performed a conditional GET request and access is allowed, but the document has not been modified, the server SHOULD respond with this status code. The 304 response MUST NOT contain a message-body, and thus is always terminated by the first empty line after the header fields.\r\nThe response MUST include the following header fields:\r\nDate, unless its omission is required\r\nIf a clockless origin server obeys these rules, and proxies and clients add their own Date to any response received without one (as already specified by RFC 2068), caches will operate correctly.\r\nETag and\/or Content-Location, if the header would have been sent in a 200 response to the same request\r\nExpires, Cache-Control, and\/or Vary, if the field-value might differ from that sent in any previous response for the same variant\r\nIf the conditional GET used a strong cache validator, the response SHOULD NOT include other entity-headers. Otherwise (i.e., the conditional GET used a weak validator), the response MUST NOT include other entity-headers; this prevents inconsistencies between cached entity-bodies and updated headers.\r\nIf a 304 response indicates an entity not currently cached, then the cache MUST disregard the response and repeat the request without the conditional.\r\nIf a cache uses a received 304 response to update a cache entry, the cache MUST update the entry to reflect any new field values given in the response.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":not_modified"
- }
- }
- },
- "305":{
- "code":"305",
- "title":"Use Proxy (since HTTP\/1.1)",
- "summary":"content located elsewhere, retrieve from there",
- "descriptions":{
- "wikipedia":{
- "body":"Many HTTP clients (such as Mozilla and Internet Explorer) do not correctly handle responses with this status code, primarily for security reasons.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#305"
- },
- "ietf":{
- "body":"The requested resource MUST be accessed through the proxy given by the Location field. The Location field gives the URI of the proxy. The recipient is expected to repeat this single request via the proxy. 305 responses MUST only be generated by origin servers.\r\nNote: RFC 2068 was not clear that 305 was intended to redirect a single request, and to be generated by origin servers only. Not observing these limitations has significant security consequences.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":use_proxy"
- }
- }
- },
- "306":{
- "code":"306",
- "title":"Switch Proxy",
- "summary":"subsequent requests should use the specified proxy",
- "descriptions":{
- "wikipedia":{
- "body":"No longer used. Originally meant \"Subsequent requests should use the specified proxy.\"",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#306"
- },
- "ietf":{
- "body":"The 306 status code was used in a previous version of the specification, is no longer used, and the code is reserved.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- }
- },
- "307":{
- "code":"307",
- "title":"Temporary Redirect (since HTTP\/1.1)",
- "summary":"connect again to different URI as provided",
- "descriptions":{
- "wikipedia":{
- "body":"In this occasion, the request should be repeated with another URI, but future requests can still use the original URI. In contrast to 303, the request method should not be changed when reissuing the original request. For instance, a POST request must be repeated using another POST request.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#307"
- },
- "ietf":{
- "body":"The requested resource resides temporarily under a different URI. Since the redirection MAY be altered on occasion, the client SHOULD continue to use the Request-URI for future requests. This response is only cacheable if indicated by a Cache-Control or Expires header field.\r\nThe temporary URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s) , since many pre-HTTP\/1.1 user agents do not understand the 307 status. Therefore, the note SHOULD contain the information necessary for a user to repeat the original request on the new URI.\r\nIf the 307 status code is received in response to a request other than GET or HEAD, the user agent MUST NOT automatically redirect the request unless it can be confirmed by the user, since this might change the conditions under which the request was issued.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":temporary_redirect"
- }
- }
- },
- "308":{
- "code":"308",
- "title":"Permanent Redirect",
- "summary":"connect again to a different URI using the same method",
- "descriptions":{
- "wikipedia":{
- "body":"The request, and all future requests should be repeated using another URI. 307 and 308 (as proposed) parallel the behaviours of 302 and 301, but do not allow the HTTP method to change. So, for example, submitting a form to a permanently redirected resource may continue smoothly.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#308"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":no_content"
- }
- }
- }
- }
-}
+++ /dev/null
-{
- "class":{
- "title":"Client Error",
- "class":"4"
- },
- "codes":{
- "400":{
- "code":"400",
- "title":"Bad Request",
- "summary":"request cannot be fulfilled due to bad syntax",
- "descriptions":{
- "wikipedia":{
- "body":"The request cannot be fulfilled due to bad syntax.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#400"
- },
- "ietf":{
- "body":"The request could not be understood by the server due to malformed syntax. The client SHOULD NOT repeat the request without modifications.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":bad_request"
- }
- }
- },
- "401":{
- "code":"401",
- "title":"Unauthorized",
- "summary":"authentication is possible but has failed ",
- "descriptions":{
- "wikipedia":{
- "body":"Similar to 403 Forbidden, but specifically for use when authentication is possible but has failed or not yet been provided. The response must include a WWW-Authenticate header field containing a challenge applicable to the requested resource. See Basic access authentication and Digest access authentication.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#401"
- },
- "ietf":{
- "body":"The request requires user authentication. The response MUST include a WWW-Authenticate header field containing a challenge applicable to the requested resource. The client MAY repeat the request with a suitable Authorization header field. If the request already included Authorization credentials, then the 401 response indicates that authorization has been refused for those credentials. If the 401 response contains the same challenge as the prior response, and the user agent has already attempted authentication at least once, then the user SHOULD be presented the entity that was given in the response, since that entity might include relevant diagnostic information. HTTP access authentication is explained in \"HTTP Authentication: Basic and Digest Access Authentication\".",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":unauthorized"
- }
- }
- },
- "402":{
- "code":"402",
- "title":"Payment Required",
- "summary":"payment required, reserved for future use",
- "descriptions":{
- "wikipedia":{
- "body":"Reserved for future use. The original intention was that this code might be used as part of some form of digital cash or micropayment scheme, but that has not happened, and this code is not usually used. As an example of its use, however, Apple's MobileMe service generates a 402 error (\"httpStatusCode:402\" in the Mac OS X Console log) if the MobileMe account is delinquent.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#402"
- },
- "ietf":{
- "body":"This code is reserved for future use.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":payment_required"
- }
- }
- },
- "403":{
- "code":"403",
- "title":"Forbidden",
- "summary":"server refuses to respond to request",
- "descriptions":{
- "wikipedia":{
- "body":"The request was a legal request, but the server is refusing to respond to it. Unlike a 401 Unauthorized response, authenticating will make no difference.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#403"
- },
- "ietf":{
- "body":"The server understood the request, but is refusing to fulfill it. Authorization will not help and the request SHOULD NOT be repeated. If the request method was not HEAD and the server wishes to make public why the request has not been fulfilled, it SHOULD describe the reason for the refusal in the entity. If the server does not wish to make this information available to the client, the status code 404 (Not Found) can be used instead.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":forbidden"
- }
- }
- },
- "404":{
- "code":"404",
- "title":"Not Found",
- "summary":"requested resource could not be found",
- "descriptions":{
- "wikipedia":{
- "body":"The requested resource could not be found but may be available again in the future. Subsequent requests by the client are permissible.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#404"
- },
- "ietf":{
- "body":"The server has not found anything matching the Request-URI. No indication is given of whether the condition is temporary or permanent. The 410 (Gone) status code SHOULD be used if the server knows, through some internally configurable mechanism, that an old resource is permanently unavailable and has no forwarding address. This status code is commonly used when the server does not wish to reveal exactly why the request has been refused, or when no other response is applicable.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":not_found"
- }
- }
- },
- "405":{
- "code":"405",
- "title":"Method Not Allowed",
- "summary":"request method not supported by that resource",
- "descriptions":{
- "wikipedia":{
- "body":"A request was made of a resource using a request method not supported by that resource; for example, using GET on a form which requires data to be presented via POST, or using PUT on a read-only resource.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#405"
- },
- "ietf":{
- "body":"The method specified in the Request-Line is not allowed for the resource identified by the Request-URI. The response MUST include an Allow header containing a list of valid methods for the requested resource.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":method_not_allowed"
- }
- }
- },
- "406":{
- "code":"406",
- "title":"Not Acceptable",
- "summary":"content not acceptable according to the Accept headers",
- "descriptions":{
- "wikipedia":{
- "body":"The requested resource is only capable of generating content not acceptable according to the Accept headers sent in the request.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#406"
- },
- "ietf":{
- "body":"The resource identified by the request is only capable of generating response entities which have content characteristics not acceptable according to the accept headers sent in the request.\r\nUnless it was a HEAD request, the response SHOULD include an entity containing a list of available entity characteristics and location(s) from which the user or user agent can choose the one most appropriate. The entity format is specified by the media type given in the Content-Type header field. Depending upon the format and the capabilities of the user agent, selection of the most appropriate choice MAY be performed automatically. However, this specification does not define any standard for such automatic selection.\r\nNote: HTTP\/1.1 servers are allowed to return responses which are not acceptable according to the accept headers sent in the request. In some cases, this may even be preferable to sending a 406 response. User agents are encouraged to inspect the headers of an incoming response to determine if it is acceptable.\r\nIf the response could be unacceptable, a user agent SHOULD temporarily stop receipt of more data and query the user for a decision on further actions.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":not_acceptable"
- }
- }
- },
- "407":{
- "code":"407",
- "title":"Proxy Authentication Required",
- "summary":"client must first authenticate itself with the proxy",
- "descriptions":{
- "wikipedia":{
- "body":"The client must first authenticate itself with the proxy.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#407"
- },
- "ietf":{
- "body":"This code is similar to 401 (Unauthorized), but indicates that the client must first authenticate itself with the proxy. The proxy MUST return a Proxy-Authenticate header field containing a challenge applicable to the proxy for the requested resource. The client MAY repeat the request with a suitable Proxy-Authorization header field. HTTP access authentication is explained in \"HTTP Authentication: Basic and Digest Access Authentication\".",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":proxy_authentication_required"
- }
- }
- },
- "408":{
- "code":"408",
- "title":"Request Timeout",
- "summary":"server timed out waiting for the request",
- "descriptions":{
- "wikipedia":{
- "body":"The server timed out waiting for the request. According to W3 HTTP specifications: \"The client did not produce a request within the time that the server was prepared to wait. The client MAY repeat the request without modifications at any later time.\"",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#408"
- },
- "ietf":{
- "body":"The client did not produce a request within the time that the server was prepared to wait. The client MAY repeat the request without modifications at any later time.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":request_timeout"
- }
- }
- },
- "409":{
- "code":"409",
- "title":"Conflict",
- "summary":"request could not be processed because of conflict",
- "descriptions":{
- "wikipedia":{
- "body":"Indicates that the request could not be processed because of conflict in the request, such as an edit conflict.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#409"
- },
- "ietf":{
- "body":"The request could not be completed due to a conflict with the current state of the resource. This code is only allowed in situations where it is expected that the user might be able to resolve the conflict and resubmit the request. The response body SHOULD include enough information for the user to recognize the source of the conflict. Ideally, the response entity would include enough information for the user or user agent to fix the problem; however, that might not be possible and is not required.\r\nConflicts are most likely to occur in response to a PUT request. For example, if versioning were being used and the entity being PUT included changes to a resource which conflict with those made by an earlier (third-party) request, the server might use the 409 response to indicate that it can't complete the request. In this case, the response entity would likely contain a list of the differences between the two versions in a format defined by the response Content-Type.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":conflict"
- }
- }
- },
- "410":{
- "code":"410",
- "title":"Gone",
- "summary":"resource is no longer available and will not be available again",
- "descriptions":{
- "wikipedia":{
- "body":"Indicates that the resource requested is no longer available and will not be available again. This should be used when a resource has been intentionally removed and the resource should be purged. Upon receiving a 410 status code, the client should not request the resource again in the future. Clients such as search engines should remove the resource from their indices. Most use cases do not require clients and search engines to purge the resource, and a \"404 Not Found\" may be used instead.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#410"
- },
- "ietf":{
- "body":"The requested resource is no longer available at the server and no forwarding address is known. This condition is expected to be considered permanent. Clients with link editing capabilities SHOULD delete references to the Request-URI after user approval. If the server does not know, or has no facility to determine, whether or not the condition is permanent, the status code 404 (Not Found) SHOULD be used instead. This response is cacheable unless indicated otherwise.\r\nThe 410 response is primarily intended to assist the task of web maintenance by notifying the recipient that the resource is intentionally unavailable and that the server owners desire that remote links to that resource be removed. Such an event is common for limited-time, promotional services and for resources belonging to individuals no longer working at the server's site. It is not necessary to mark all permanently unavailable resources as \"gone\" or to keep the mark for any length of time -- that is left to the discretion of the server owner.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":gone"
- }
- }
- },
- "411":{
- "code":"411",
- "title":"Length Required",
- "summary":"request did not specify the length of its content",
- "descriptions":{
- "wikipedia":{
- "body":"The request did not specify the length of its content, which is required by the requested resource.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#411"
- },
- "ietf":{
- "body":"The server refuses to accept the request without a defined Content- Length. The client MAY repeat the request if it adds a valid Content-Length header field containing the length of the message-body in the request message.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":length_required"
- }
- }
- },
- "412":{
- "code":"412",
- "title":"Precondition Failed",
- "summary":"server does not meet request preconditions",
- "descriptions":{
- "wikipedia":{
- "body":"The server does not meet one of the preconditions that the requester put on the request.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#412"
- },
- "ietf":{
- "body":"The precondition given in one or more of the request-header fields evaluated to false when it was tested on the server. This response code allows the client to place preconditions on the current resource metainformation (header field data) and thus prevent the requested method from being applied to a resource other than the one intended.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":precondition_failed"
- }
- }
- },
- "413":{
- "code":"413",
- "title":"Request Entity Too Large",
- "summary":"request is larger than the server is willing or able to process",
- "descriptions":{
- "wikipedia":{
- "body":"The request is larger than the server is willing or able to process.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#413"
- },
- "ietf":{
- "body":"The server is refusing to process a request because the request entity is larger than the server is willing or able to process. The server MAY close the connection to prevent the client from continuing the request.\r\nIf the condition is temporary, the server SHOULD include a Retry- After header field to indicate that it is temporary and after what time the client MAY try again.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":request_entity_too_large"
- }
- }
- },
- "414":{
- "code":"414",
- "title":"Request-URI Too Long",
- "summary":"URI provided was too long for the server to process",
- "descriptions":{
- "wikipedia":{
- "body":"The URI provided was too long for the server to process.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#414"
- },
- "ietf":{
- "body":"The server is refusing to service the request because the Request-URI is longer than the server is willing to interpret. This rare condition is only likely to occur when a client has improperly converted a POST request to a GET request with long query information, when the client has descended into a URI \"black hole\" of redirection (e.g., a redirected URI prefix that points to a suffix of itself), or when the server is under attack by a client attempting to exploit security holes present in some servers using fixed-length buffers for reading or manipulating the Request-URI.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":request_uri_too_long"
- }
- }
- },
- "415":{
- "code":"415",
- "title":"Unsupported Media Type",
- "summary":"server does not support media type",
- "descriptions":{
- "wikipedia":{
- "body":"The request entity has a media type which the server or resource does not support. For example, the client uploads an image as image\/svg+xml, but the server requires that images use a different format.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#415"
- },
- "ietf":{
- "body":"The server is refusing to service the request because the entity of the request is in a format not supported by the requested resource for the requested method.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":unsupported_media_type"
- }
- }
- },
- "416":{
- "code":"416",
- "title":"Requested Range Not Satisfiable",
- "summary":"client has asked for unprovidable portion of the file",
- "descriptions":{
- "wikipedia":{
- "body":"The client has asked for a portion of the file, but the server cannot supply that portion. For example, if the client asked for a part of the file that lies beyond the end of the file.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#416"
- },
- "ietf":{
- "body":"A server SHOULD return a response with this status code if a request included a Range request-header field, and none of the range-specifier values in this field overlap the current extent of the selected resource, and the request did not include an If-Range request-header field. (For byte-ranges, this means that the first- byte-pos of all of the byte-range-spec values were greater than the current length of the selected resource.)\r\nWhen this status code is returned for a byte-range request, the response SHOULD include a Content-Range entity-header field specifying the current length of the selected resource. This response MUST NOT use the multipart\/byteranges content- type.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":requested_range_not_satisfiable"
- }
- }
- },
- "417":{
- "code":"417",
- "title":"Expectation Failed",
- "summary":"server cannot meet requirements of Expect request-header field",
- "descriptions":{
- "wikipedia":{
- "body":"The server cannot meet the requirements of the Expect request-header field.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#417"
- },
- "ietf":{
- "body":"The expectation given in an Expect request-header field could not be met by this server, or, if the server is a proxy, the server has unambiguous evidence that the request could not be met by the next-hop server.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":expectation_failed"
- }
- }
- },
- "418":{
- "code":"418",
- "title":"I'm a teapot (RFC 2324)",
- "summary":"I'm a teapot",
- "descriptions":{
- "wikipedia":{
- "body":"This code was defined in 1998 as one of the traditional IETF April Fools' jokes, in RFC 2324, Hyper Text Coffee Pot Control Protocol, and is not expected to be implemented by actual HTTP servers. However, known implementations do exist. An Nginx HTTP server uses this code to simulate goto-like behaviour in its configuration.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#418"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":\"i'm_a_teapot\" <small>(<a href=\"https://gist.github.com/3134563\">explanation<\/a> <sup>gist.github.com<\/sup>)<\/small>"
- }
- }
- },
- "420":{
- "code":"420",
- "title":"Enhance Your Calm",
- "summary":"Twitter rate limiting",
- "descriptions":{
- "wikipedia":{
- "body":"Returned by the Twitter Search and Trends API when the client is being rate limited.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#420"
- }
- }
- },
- "422":{
- "code":"422",
- "title":"Unprocessable Entity (WebDAV) (RFC 4918)",
- "summary":"request unable to be followed due to semantic errors",
- "descriptions":{
- "wikipedia":{
- "body":"The request was well-formed but was unable to be followed due to semantic errors.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#422"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":unprocessable_entity"
- }
- }
- },
- "423":{
- "code":"423",
- "title":"Locked (WebDAV) (RFC 4918)",
- "summary":"resource that is being accessed is locked",
- "descriptions":{
- "wikipedia":{
- "body":"The resource that is being accessed is locked.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#423"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":locked"
- }
- }
- },
- "424":{
- "code":"424",
- "title":"Failed Dependency (WebDAV) (RFC 4918)",
- "summary":"request failed due to failure of a previous request",
- "descriptions":{
- "wikipedia":{
- "body":"The request failed due to failure of a previous request (e.g. a PROPPATCH).",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#424"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":failed_dependency"
- }
- }
- },
- "426":{
- "code":"426",
- "title":"Upgrade Required (RFC 2817)",
- "summary":"client should switch to a different protocol",
- "descriptions":{
- "wikipedia":{
- "body":"The client should switch to a different protocol such as TLS\/1.0.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#426"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":upgrade_required"
- }
- }
- },
- "428":{
- "code":"428",
- "title":"Precondition Required",
- "summary":"origin server requires the request to be conditional",
- "descriptions":{
- "wikipedia":{
- "body":"The origin server requires the request to be conditional. Intended to prevent \"the 'lost update' problem, where a client GETs a resource's state, modifies it, and PUTs it back to the server, when meanwhile a third party has modified the state on the server, leading to a conflict.\" Proposed in an Internet-Draft.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#428"
- }
- }
- },
- "429":{
- "code":"429",
- "title":"Too Many Requests",
- "summary":"user has sent too many requests in a given amount of time",
- "descriptions":{
- "wikipedia":{
- "body":"The user has sent too many requests in a given amount of time. Intended for use with rate limiting schemes. Proposed in an Internet-Draft.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#429"
- }
- }
- },
- "431":{
- "code":"431",
- "title":"Request Header Fields Too Large",
- "summary":"server is unwilling to process the request",
- "descriptions":{
- "wikipedia":{
- "body":"The server is unwilling to process the request because either an individual header field, or all the header fields collectively, are too large. Proposed in an Internet-Draft.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#431"
- }
- }
- },
- "444":{
- "code":"444",
- "title":"No Response",
- "summary":"server returns no information and closes the connection",
- "descriptions":{
- "wikipedia":{
- "body":"An nginx HTTP server extension. The server returns no information to the client and closes the connection (useful as a deterrent for malware).",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#444"
- }
- }
- },
- "449":{
- "code":"449",
- "title":"Retry With",
- "summary":"request should be retried after performing action",
- "descriptions":{
- "wikipedia":{
- "body":"A Microsoft extension. The request should be retried after performing the appropriate action.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#449"
- }
- }
- },
- "450":{
- "code":"450",
- "title":"Blocked by Windows Parental Controls",
- "summary":"Windows Parental Controls blocking access to webpage",
- "descriptions":{
- "wikipedia":{
- "body":"A Microsoft extension. This error is given when Windows Parental Controls are turned on and are blocking access to the given webpage.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#450"
- }
- }
- },
- "451":{
- "code":"451",
- "title":"Wrong Exchange server",
- "summary":"the server cannot reach the client's mailbox",
- "descriptions":{
- "MS-ASHTTP":{
- "body":"If the client is attempting to connect to the wrong server (that is, a server that cannot access the user's mailbox), or if there is a more efficient server to use to reach the user's mailbox, then a 451 Redirect error is returned.",
- "link":"http://msdn.microsoft.com/en-us/library/gg651019"
- }
- }
- },
- "499":{
- "code":"499",
- "title":"Client Closed Request",
- "summary":"connection closed by client while HTTP server is processing",
- "descriptions":{
- "wikipedia":{
- "body":"An Nginx HTTP server extension. This code is introduced to log the case when the connection is closed by client while HTTP server is processing its request, making server unable to send the HTTP header back.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#499"
- }
- }
- }
- }
-}
+++ /dev/null
-{
- "class":{
- "title":"Server Error",
- "class":"5"
- },
- "codes":{
- "500":{
- "code":"500",
- "title":"Internal Server Error",
- "summary":"generic error message",
- "descriptions":{
- "wikipedia":{
- "body":"A generic error message, given when no more specific message is suitable.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#500"
- },
- "ietf":{
- "body":"The server encountered an unexpected condition which prevented it from fulfilling the request.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":internal_server_error"
- }
- }
- },
- "501":{
- "code":"501",
- "title":"Not Implemented",
- "summary":"server does not recognise method or lacks ability to fulfill",
- "descriptions":{
- "wikipedia":{
- "body":"The server either does not recognise the request method, or it lacks the ability to fulfill the request.[2]",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#501"
- },
- "ietf":{
- "body":"The server does not support the functionality required to fulfill the request. This is the appropriate response when the server does not recognize the request method and is not capable of supporting it for any resource.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":not_implemented"
- }
- }
- },
- "502":{
- "code":"502",
- "title":"Bad Gateway",
- "summary":"server received an invalid response from upstream server",
- "descriptions":{
- "wikipedia":{
- "body":"The server was acting as a gateway or proxy and received an invalid response from the upstream server.[2]",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#502"
- },
- "ietf":{
- "body":"The server, while acting as a gateway or proxy, received an invalid response from the upstream server it accessed in attempting to fulfill the request.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":bad_gateway"
- }
- }
- },
- "503":{
- "code":"503",
- "title":"Service Unavailable",
- "summary":"server is currently unavailable",
- "descriptions":{
- "wikipedia":{
- "body":"The server is currently unavailable (because it is overloaded or down for maintenance).[2] Generally, this is a temporary state.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#503"
- },
- "ietf":{
- "body":"The server is currently unable to handle the request due to a temporary overloading or maintenance of the server. The implication is that this is a temporary condition which will be alleviated after some delay. If known, the length of the delay MAY be indicated in a Retry-After header. If no Retry-After is given, the client SHOULD handle the response as it would for a 500 response.\r\nNote: The existence of the 503 status code does not imply that a server must use it when becoming overloaded. Some servers may wish to simply refuse the connection.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":service_unavailable"
- }
- }
- },
- "504":{
- "code":"504",
- "title":"Gateway Timeout",
- "summary":"gateway did not receive response from upstream server",
- "descriptions":{
- "wikipedia":{
- "body":"The server was acting as a gateway or proxy and did not receive a timely response from the upstream server.[2]",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#504"
- },
- "ietf":{
- "body":"The server, while acting as a gateway or proxy, did not receive a timely response from the upstream server specified by the URI (e.g. HTTP, FTP, LDAP) or some other auxiliary server (e.g. DNS) it needed to access in attempting to complete the request.\r\nNote: Note to implementors: some deployed proxies are known to return 400 or 500 when DNS lookups time out.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":gateway_timeout"
- }
- }
- },
- "505":{
- "code":"505",
- "title":"HTTP Version Not Supported",
- "summary":"server does not support the HTTP protocol version",
- "descriptions":{
- "wikipedia":{
- "body":"The server does not support the HTTP protocol version used in the request.[2]",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#505"
- },
- "ietf":{
- "body":"The server does not support, or refuses to support, the HTTP protocol version that was used in the request message. The server is indicating that it is unable or unwilling to complete the request using the same major version as the client. The response SHOULD contain an entity describing why that version is not supported and what other protocols are supported by that server.",
- "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":http_version_not_supported"
- }
- }
- },
- "506":{
- "code":"506",
- "title":"Variant Also Negotiates (RFC 2295)",
- "summary":"content negotiation for the request results in a circular reference",
- "descriptions":{
- "wikipedia":{
- "body":"Transparent content negotiation for the request results in a circular reference.[23]",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#506"
- }
- }
- },
- "507":{
- "code":"507",
- "title":"Insufficient Storage (WebDAV) (RFC 4918)",
- "summary":"server is unable to store the representation",
- "descriptions":{
- "wikipedia":{
- "body":"The server is unable to store the representation needed to complete the request.[7]",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#507"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":insufficient_storage"
- }
- }
- },
- "508":{
- "code":"508",
- "title":"Loop Detected (WebDAV) (RFC 5842)",
- "summary":"server detected an infinite loop while processing the request",
- "descriptions":{
- "wikipedia":{
- "body":"The server detected an infinite loop while processing the request (sent in lieu of 208).",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#508"
- }
- }
- },
- "509":{
- "code":"509",
- "title":"Bandwidth Limit Exceeded (Apache bw\/limited extension)",
- "summary":"bandwidth limit exceeded",
- "descriptions":{
- "wikipedia":{
- "body":"This status code, while used by many servers, is not specified in any RFCs.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#509"
- }
- }
- },
- "510":{
- "code":"510",
- "title":"Not Extended (RFC 2774)",
- "summary":"further extensions to the request are required",
- "descriptions":{
- "wikipedia":{
- "body":"Further extensions to the request are required for the server to fulfill it.[24]",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#510"
- }
- },
- "references":{
- "rails":{
- "title":"Rails HTTP Status Symbol",
- "value":":not_extended"
- }
- }
- },
- "511":{
- "code":"511",
- "title":"Network Authentication Required",
- "summary":"client needs to authenticate to gain network access",
- "descriptions":{
- "wikipedia":{
- "body":"The client needs to authenticate to gain network access. Intended for use by intercepting proxies used to control access to the network (e.g. \"captive portals\" used to require agreement to Terms of Service before granting full Internet access via a Wi-Fi hotspot). Proposed in an Internet-Draft.[19]",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#511"
- }
- }
- },
- "598":{
- "code":"598",
- "title":"Network read timeout error",
- "summary":"network read timeout behind the proxy ",
- "descriptions":{
- "wikipedia":{
- "body":"This status code is not specified in any RFCs, but is used by some HTTP proxies to signal a network read timeout behind the proxy to a client in front of the proxy.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#598"
- }
- }
- },
- "599":{
- "code":"599",
- "title":"Network connect timeout error",
- "summary":"network connect timeout behind the proxy",
- "descriptions":{
- "wikipedia":{
- "body":"This status code is not specified in any RFCs, but is used by some HTTP proxies to signal a network connect timeout behind the proxy to a client in front of the proxy.",
- "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#599"
- }
- }
- }
- }
-}
\ No newline at end of file
+++ /dev/null
-Copyright (C) 2012 - 2013 Samuel Ryan (citricsquid)
-
-Permission is hereby granted, free of charge, to any person obtaining a copy of
-this software and associated documentation files (the "Software"), to deal in
-the Software without restriction, including without limitation the rights to use,
-copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the
-Software, and to permit persons to whom the Software is furnished to do so,
-subject to the following conditions:
-
-The above copyright notice and this permission notice shall be included in all
-copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
\ No newline at end of file
+++ /dev/null
-(executable
- (name generate)
- (libraries jsonm))
+++ /dev/null
-(*{{{ Copyright (c) 2013 Thomas Gazagnaire <thomas@gazagnaire.org>
- *
- * Permission to use, copy, modify, and distribute this software for any
- * purpose with or without fee is hereby granted, provided that the above
- * copyright notice and this permission notice appear in all copies.
- *
- * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
- * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
- * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
- * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
- * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
- * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
- * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
- }}}*)
-
-(* From http://erratique.ch/software/jsonm/doc/Jsonm.html#datamodel *)
-type t =
- [ `Null
- | `Bool of bool
- | `Float of float
- | `String of string
- | `A of t list
- | `O of (string * t) list ]
-
-exception Escape of ((int * int) * (int * int)) * Jsonm.error
-
-let json_of_src src =
- let d = Jsonm.decoder src in
- let dec () =
- match Jsonm.decode d with
- | `Lexeme l -> l
- | `Error e -> raise (Escape (Jsonm.decoded_range d, e))
- | `End | `Await -> assert false
- in
- let rec value v k =
- match v with
- | `Os -> obj [] k
- | `As -> arr [] k
- | (`Null | `Bool _ | `String _ | `Float _) as v -> k v
- | _ -> assert false
- and arr vs k =
- match dec () with
- | `Ae -> k (`A (List.rev vs))
- | v -> value v (fun v -> arr (v :: vs) k)
- and obj ms k =
- match dec () with
- | `Oe -> k (`O (List.rev ms))
- | `Name n -> value (dec ()) (fun v -> obj ((n, v) :: ms) k)
- | _ -> assert false
- in
- try `JSON (value (dec ()) (fun v -> v)) with Escape (r, e) -> `Error (r, e)
-
-let json_to_dst ~minify dst (json : t) =
- let enc e l = ignore (Jsonm.encode e (`Lexeme l)) in
- let rec value v k e =
- match v with
- | `A vs -> arr vs k e
- | `O ms -> obj ms k e
- | (`Null | `Bool _ | `Float _ | `String _) as v ->
- enc e v;
- k e
- and arr vs k e =
- enc e `As;
- arr_vs vs k e
- and arr_vs vs k e =
- match vs with
- | v :: vs' -> value v (arr_vs vs' k) e
- | [] ->
- enc e `Ae;
- k e
- and obj ms k e =
- enc e `Os;
- obj_ms ms k e
- and obj_ms ms k e =
- match ms with
- | (n, v) :: ms ->
- enc e (`Name n);
- value v (obj_ms ms k) e
- | [] ->
- enc e `Oe;
- k e
- in
- let e = Jsonm.encoder ~minify dst in
- let finish e = ignore (Jsonm.encode e `End) in
- match json with
- | (`A _ | `O _) as json -> value json finish e
- | _ -> invalid_arg "invalid json text"
-
-let to_buffer buf (json : t) = json_to_dst ~minify:true (`Buffer buf) json
-
-let output t =
- let buf = Buffer.create 1024 in
- to_buffer buf t;
- Buffer.contents buf
-
-let parse_error fmt =
- Printf.ksprintf
- (fun msg ->
- Printf.eprintf "parse error: %s\n" msg;
- exit 1)
- fmt
-
-let string_of_error error =
- Jsonm.pp_error Format.str_formatter error;
- Format.flush_str_formatter ()
-
-let of_buffer buf : t =
- let str = Buffer.contents buf in
- match json_of_src (`String str) with
- | `JSON j -> j
- | `Error (_, e) -> parse_error "JSON.of_buffer %s" (string_of_error e)
-
-let of_channel ic =
- match json_of_src (`Channel ic) with
- | `JSON j -> j
- | `Error (_, e) -> parse_error "JSON.of_buffer %s" (string_of_error e)
-
-let input str : t =
- match json_of_src (`String str) with
- | `JSON j -> j
- | `Error (_, e) ->
- Jsonm.pp_error Format.str_formatter e;
- parse_error "JSON.input %s" (string_of_error e)
-
-(* string *)
-let of_string s = `String s
-
-let to_string = function
- | `String s -> s
- | j -> parse_error "JSON.to_string: %s" (output j)
-
-type code = { code : int; constr : string; descr : string; doc : string }
-type section = { section : string; codes : code list }
-
-let normalize s =
- let b = Bytes.of_string s in
- Bytes.iteri
- (fun i -> function
- | 'A' .. 'Z' as c -> if i > 1 then Bytes.set b i (Char.lowercase_ascii c)
- | ' ' | '-' | '\'' -> Bytes.set b i '_'
- | _ -> ())
- (Bytes.of_string s);
- Bytes.to_string b
-
-let read ic =
- let json = of_channel ic in
- match json with
- | `O o ->
- let section =
- match List.assoc "class" o with
- | `O o ->
- let s =
- String.uncapitalize_ascii (to_string (List.assoc "title" o))
- in
- normalize s
- | _ -> assert false
- in
-
- let codes =
- match List.assoc "codes" o with
- | `O o ->
- List.fold_left
- (fun codes (code, o) ->
- let code = int_of_string code in
- if code = 122 then (* Same as 414 but for IE7 ??? *)
- codes
- else
- let o = match o with `O o -> o | _ -> assert false in
- let descr = to_string (List.assoc "title" o) in
- let constr =
- "`"
- ^
- try
- let i = String.index descr '(' in
- String.sub descr 0 (i - 1)
- with Not_found -> descr
- in
- let constr = normalize constr in
- (* XXX: dirty hack *)
- let constr = if constr = "`Ok" then "`OK" else constr in
- let doc = to_string (List.assoc "summary" o) in
- { constr; descr; code; doc } :: codes)
- [] o
- | _ -> assert false
- in
- { section; codes = List.rev codes }
- | _ -> assert false
-
-let append oc fmt = Printf.fprintf oc (fmt ^^ "\n")
-
-let output_type oc ~mli t =
- append oc "type %s_status =" t.section;
- List.iteri
- (fun i c ->
- let doc = if mli then Printf.sprintf " (** %s *)" c.doc else "" in
- if i = 0 then append oc " [ %s%s" c.constr doc
- else append oc " | %s%s" c.constr doc)
- t.codes;
- append oc " ] [@@deriving sexp]";
- if mli then append oc "(** %s *)" (String.capitalize_ascii t.section);
- append oc ""
-
-let output_status_types oc ~mli t =
- List.iter (output_type oc ~mli) t;
- append oc "type status = [";
- List.iter (fun t -> append oc " | %s_status" t.section) t;
- append oc "] [@@deriving sexp]";
- append oc "";
- append oc "type status_code = [`Code of int | status ] [@@deriving sexp]";
- append oc ""
-
-let iter fn s = List.iter (fun s -> List.iter fn s.codes) s
-
-let output_status_of_code oc ~mli s =
- if mli then (
- append oc "val status_of_code: int -> status_code";
- append oc "(** Generate status values from int codes. *)")
- else (
- append oc "let status_of_code: int -> status_code = function";
- iter (fun c -> append oc " | %d -> %s" c.code c.constr) s;
- append oc " | cod -> `Code cod");
- append oc ""
-
-let output_code_of_status oc ~mli s =
- if mli then (
- append oc "val code_of_status: status_code -> int";
- append oc "(** Generate an int code from a status value. *)")
- else (
- append oc "let code_of_status: status_code -> int = function";
- iter (fun c -> append oc " | %s -> %d" c.constr c.code) s;
- append oc " | `Code cod -> cod");
- append oc ""
-
-let output_string_of_status oc ~mli s =
- if mli then (
- append oc "val string_of_status: status_code -> string";
- append oc "(** Give a description of the given status value. *)")
- else (
- append oc "let string_of_status: status_code -> string = function";
- iter (fun c -> append oc " | %s -> \"%d %s\"" c.constr c.code c.descr) s;
- (* the response status must include an extra space even if no description is present, cf. #752 *)
- append oc " | `Code cod ->";
- append oc " let code = string_of_int cod in";
- append oc " code ^ \" Status \" ^ code");
- append oc ""
-
-let output_reason_phrase_of_code oc ~mli s =
- if mli then (
- append oc "val reason_phrase_of_code: int -> string";
- append oc "(** Give a description of the given int code. *)")
- else (
- append oc "let reason_phrase_of_code: int -> string = function";
- iter (fun c -> append oc " | %d -> %S" c.code c.descr) s;
- append oc " | cod -> string_of_int cod");
- append oc ""
-
-let output_is_code oc ~mli t =
- List.iter
- (fun t ->
- if mli then (
- append oc "val is_%s: int -> bool" t.section;
- append oc
- "(** Is the given int code belong to the class of %S return code ? *)"
- t.section)
- else (
- append oc "let is_%s code =" t.section;
- append oc " match status_of_code code with";
- append oc " | #%s_status -> true" t.section;
- append oc " | _ -> false");
- append oc "")
- t;
- append oc "";
- if mli then (
- append oc "val is_error: int -> bool";
- append oc "(** Return true for client and server error status codes. *)")
- else
- append oc "let is_error code = is_client_error code || is_server_error code";
- append oc ""
-
-type gen = { constr : string; string : string }
-
-let g constr string = { constr; string }
-
-let output_gen_types oc (_name, typ, gens) =
- append oc "type %s = [" typ;
- List.iter (fun { constr; _ } -> append oc " | %s" constr) gens;
- append oc " | `Other of string";
- append oc "] [@@deriving sexp]";
- append oc ""
-
-let output_gen_convert oc ~mli (name, typ, gens) =
- if mli then (
- append oc "val string_of_%s: %s -> string" name typ;
- append oc "(** Convert a %s to a string. *)" name;
- append oc "";
- append oc "val %s_of_string: string -> %s" name typ;
- append oc "(** Convert a string to a %s. *)" name;
- append oc "";
- append oc "val compare_%s: %s -> %s -> int" name typ typ;
- append oc "(** Comparison function for [%s] values *)" name;
- append oc "")
- else (
- append oc "let string_of_%s: %s -> string = function" name typ;
- List.iter (fun g -> append oc " | %s -> %S" g.constr g.string) gens;
- append oc " | `Other s -> s";
- append oc "";
- append oc "let %s_of_string: string -> %s = function" name typ;
- List.iter (fun g -> append oc " | %S -> %s" g.string g.constr) gens;
- append oc " | s -> `Other s";
- append oc "";
- append oc "let compare_%s a b =" name;
- append oc " String.compare (string_of_%s a) (string_of_%s b)" name name;
- append oc "");
- append oc ""
-
-let t =
- List.map
- (fun f -> read (open_in f))
- [
- "codes/1.json";
- "codes/2.json";
- "codes/3.json";
- "codes/4.json";
- "codes/5.json";
- ]
-
-let version =
- ("version", "version", [ g "`HTTP_1_0" "HTTP/1.0"; g "`HTTP_1_1" "HTTP/1.1" ])
-
-let known_methods =
- [
- g "`GET" "GET";
- g "`POST" "POST";
- g "`HEAD" "HEAD";
- g "`DELETE" "DELETE";
- g "`PATCH" "PATCH";
- g "`PUT" "PUT";
- g "`OPTIONS" "OPTIONS";
- g "`TRACE" "TRACE";
- g "`CONNECT" "CONNECT";
- ]
-
-let meth = ("method", "meth", known_methods)
-
-let gen oc ~mli =
- append oc "(* Auto-Generated by 'ocaml generate.ml' *)";
- append oc "open! Sexplib0.Sexp_conv";
- append oc "";
- output_gen_types oc version;
- output_gen_types oc meth;
- output_status_types oc ~mli t;
- output_gen_convert oc ~mli version;
- output_gen_convert oc ~mli meth;
- output_status_of_code oc ~mli t;
- output_code_of_status oc ~mli t;
- output_string_of_status oc ~mli t;
- output_reason_phrase_of_code oc ~mli t;
- output_is_code oc ~mli t
-
-let () =
- let ml = open_out "../src/code.ml" in
- let mli = open_out "../src/code.mli" in
- gen ml ~mli:false;
- gen mli ~mli:true;
- close_out ml;
- close_out mli
[@@deriving sexp]
(** Basic language range tag. ["en-gb"] is represented as
- [Language \["en"; "gb"\]].
+ [Language ["en"; "gb"]].
@see <https://tools.ietf.org/html/rfc7231#section-5.3.5> the specification. *)
type language = Accept_types.language = Language of string list | AnyLanguage
language :
| TOK params {
- (get_q $2, Language (Stringext.split ~on:'-' (String.lowercase_ascii $1)))
+ (get_q $2, Language (String.split_on_char '-' (String.lowercase_ascii $1)))
}
| STAR params { (get_q $2, AnyLanguage) }
--- /dev/null
+(** The [Client] module is a collection of convenience functions for
+ constructing and processing requests. *)
+module type BASE = sig
+ type +'a io
+ type 'a with_context
+ type body
+
+ val map_context : 'a with_context -> ('a -> 'b) -> 'b with_context
+
+ val call :
+ (?headers:Http.Header.t ->
+ ?body:body ->
+ ?chunked:bool ->
+ Http.Method.t ->
+ Uri.t ->
+ (Http.Response.t * body) io)
+ with_context
+ (** [call ?headers ?body ?chunked meth uri]
+
+ @return
+ [(response, response_body)] Consume [response_body] in a timely fashion.
+ Please see {!val:call} about how and why.
+ @param chunked
+ use chunked encoding if [true]. The default is [false] for compatibility
+ reasons. *)
+end
+
+module type S = sig
+ include BASE
+
+ val head :
+ (?headers:Http.Header.t -> Uri.t -> Http.Response.t io) with_context
+
+ val get :
+ (?headers:Http.Header.t -> Uri.t -> (Http.Response.t * body) io)
+ with_context
+
+ val delete :
+ (?body:body ->
+ ?chunked:bool ->
+ ?headers:Http.Header.t ->
+ Uri.t ->
+ (Http.Response.t * body) io)
+ with_context
+
+ val post :
+ (?body:body ->
+ ?chunked:bool ->
+ ?headers:Http.Header.t ->
+ Uri.t ->
+ (Http.Response.t * body) io)
+ with_context
+
+ val put :
+ (?body:body ->
+ ?chunked:bool ->
+ ?headers:Http.Header.t ->
+ Uri.t ->
+ (Http.Response.t * body) io)
+ with_context
+
+ val patch :
+ (?body:body ->
+ ?chunked:bool ->
+ ?headers:Http.Header.t ->
+ Uri.t ->
+ (Http.Response.t * body) io)
+ with_context
+end
+
+module Make (Base : BASE) (IO : S.IO with type 'a t = 'a Base.io) = struct
+ include Base
+ open IO
+
+ let call =
+ map_context call (fun call ?headers ?body ?chunked meth uri ->
+ let () =
+ Logs.info (fun m -> m "%a %a" Http.Method.pp meth Uri.pp uri)
+ in
+ call ?headers ?body ?chunked meth uri)
+
+ let delete =
+ map_context call (fun call ?body ?chunked ?headers uri ->
+ call ?body ?chunked ?headers `DELETE uri)
+
+ let get = map_context call (fun call ?headers uri -> call ?headers `GET uri)
+
+ let head =
+ map_context call (fun call ?headers uri ->
+ call ?headers `HEAD uri >>= fun (response, _body) -> return response)
+
+ let patch =
+ map_context call (fun call ?body ?chunked ?headers uri ->
+ call ?body ?chunked ?headers `PATCH uri)
+
+ let post =
+ map_context call (fun call ?body ?chunked ?headers uri ->
+ call ?body ?chunked ?headers `POST uri)
+
+ let put =
+ map_context call (fun call ?body ?chunked ?headers uri ->
+ call ?body ?chunked ?headers `PUT uri)
+end
--- /dev/null
+open! Sexplib0.Sexp_conv
+
+type version = [ `HTTP_1_0 | `HTTP_1_1 | `Other of string ] [@@deriving sexp]
+
+type meth =
+ [ `GET
+ | `POST
+ | `HEAD
+ | `DELETE
+ | `PATCH
+ | `PUT
+ | `OPTIONS
+ | `TRACE
+ | `CONNECT
+ | `Other of string ]
+[@@deriving sexp]
+
+type informational_status =
+ [ `Continue | `Switching_protocols | `Processing | `Checkpoint ]
+[@@deriving sexp]
+
+type success_status =
+ [ `OK
+ | `Created
+ | `Accepted
+ | `Non_authoritative_information
+ | `No_content
+ | `Reset_content
+ | `Partial_content
+ | `Multi_status
+ | `Already_reported
+ | `Im_used ]
+[@@deriving sexp]
+
+type redirection_status =
+ [ `Multiple_choices
+ | `Moved_permanently
+ | `Found
+ | `See_other
+ | `Not_modified
+ | `Use_proxy
+ | `Switch_proxy
+ | `Temporary_redirect
+ | `Permanent_redirect ]
+[@@deriving sexp]
+
+type client_error_status =
+ [ `Bad_request
+ | `Unauthorized
+ | `Payment_required
+ | `Forbidden
+ | `Not_found
+ | `Method_not_allowed
+ | `Not_acceptable
+ | `Proxy_authentication_required
+ | `Request_timeout
+ | `Conflict
+ | `Gone
+ | `Length_required
+ | `Precondition_failed
+ | `Request_entity_too_large
+ | `Request_uri_too_long
+ | `Unsupported_media_type
+ | `Requested_range_not_satisfiable
+ | `Expectation_failed
+ | `I_m_a_teapot
+ | `Enhance_your_calm
+ | `Unprocessable_entity
+ | `Locked
+ | `Failed_dependency
+ | `Upgrade_required
+ | `Precondition_required
+ | `Too_many_requests
+ | `Request_header_fields_too_large
+ | `No_response
+ | `Retry_with
+ | `Blocked_by_windows_parental_controls
+ | `Wrong_exchange_server
+ | `Client_closed_request ]
+[@@deriving sexp]
+
+type server_error_status =
+ [ `Internal_server_error
+ | `Not_implemented
+ | `Bad_gateway
+ | `Service_unavailable
+ | `Gateway_timeout
+ | `Http_version_not_supported
+ | `Variant_also_negotiates
+ | `Insufficient_storage
+ | `Loop_detected
+ | `Bandwidth_limit_exceeded
+ | `Not_extended
+ | `Network_authentication_required
+ | `Network_read_timeout_error
+ | `Network_connect_timeout_error ]
+[@@deriving sexp]
+
+type status =
+ [ informational_status
+ | success_status
+ | redirection_status
+ | client_error_status
+ | server_error_status ]
+[@@deriving sexp]
+
+type status_code = [ `Code of int | status ] [@@deriving sexp]
+
+let string_of_version = Http.Version.to_string
+let version_of_string = Http.Version.of_string
+
+let compare_version a b =
+ String.compare (string_of_version a) (string_of_version b)
+
+let string_of_method = Http.Method.to_string
+let method_of_string = Http.Method.of_string
+
+let compare_method a b =
+ String.compare (string_of_method a) (string_of_method b)
+
+let status_of_code = Http.Status.of_int
+let code_of_status = Http.Status.to_int
+let string_of_status = Http.Status.to_string
+let reason_phrase_of_code = Http.Status.reason_phrase_of_code
+
+let is_informational code =
+ match status_of_code code with #informational_status -> true | _ -> false
+
+let is_success code =
+ match status_of_code code with #success_status -> true | _ -> false
+
+let is_redirection code =
+ match status_of_code code with #redirection_status -> true | _ -> false
+
+let is_client_error code =
+ match status_of_code code with #client_error_status -> true | _ -> false
+
+let is_server_error code =
+ match status_of_code code with #server_error_status -> true | _ -> false
+
+let is_error code = is_client_error code || is_server_error code
--- /dev/null
+open! Sexplib0.Sexp_conv
+
+type version = [ `HTTP_1_0 | `HTTP_1_1 | `Other of string ] [@@deriving sexp]
+
+type meth =
+ [ `GET
+ | `POST
+ | `HEAD
+ | `DELETE
+ | `PATCH
+ | `PUT
+ | `OPTIONS
+ | `TRACE
+ | `CONNECT
+ | `Other of string ]
+[@@deriving sexp]
+
+type informational_status =
+ [ `Continue (** Client should continue with request *)
+ | `Switching_protocols (** Server is switching protocols *)
+ | `Processing (** Server has received and is processing the request *)
+ | `Checkpoint (** resume aborted PUT or POST requests *) ]
+[@@deriving sexp]
+(** Informational *)
+
+type success_status =
+ [ `OK (** standard response for successful HTTP requests *)
+ | `Created (** request has been fulfilled; new resource created *)
+ | `Accepted (** request accepted, processing pending *)
+ | `Non_authoritative_information
+ (** request processed, information may be from another source *)
+ | `No_content (** request processed, no content returned *)
+ | `Reset_content
+ (** request processed, no content returned, reset document view *)
+ | `Partial_content (** partial resource return due to request header *)
+ | `Multi_status (** XML, can contain multiple separate responses *)
+ | `Already_reported (** results previously returned *)
+ | `Im_used (** request fulfilled, response is instance-manipulations *) ]
+[@@deriving sexp]
+(** Success *)
+
+type redirection_status =
+ [ `Multiple_choices (** multiple options for the resource delivered *)
+ | `Moved_permanently
+ (** this and all future requests directed to the given URI *)
+ | `Found (** temporary response to request found via alternative URI *)
+ | `See_other (** permanent response to request found via alternative URI *)
+ | `Not_modified (** resource has not been modified since last requested *)
+ | `Use_proxy (** content located elsewhere, retrieve from there *)
+ | `Switch_proxy (** subsequent requests should use the specified proxy *)
+ | `Temporary_redirect (** connect again to different URI as provided *)
+ | `Permanent_redirect
+ (** connect again to a different URI using the same method *) ]
+[@@deriving sexp]
+(** Redirection *)
+
+type client_error_status =
+ [ `Bad_request (** request cannot be fulfilled due to bad syntax *)
+ | `Unauthorized (** authentication is possible but has failed *)
+ | `Payment_required (** payment required, reserved for future use *)
+ | `Forbidden (** server refuses to respond to request *)
+ | `Not_found (** requested resource could not be found *)
+ | `Method_not_allowed (** request method not supported by that resource *)
+ | `Not_acceptable
+ (** content not acceptable according to the Accept headers *)
+ | `Proxy_authentication_required
+ (** client must first authenticate itself with the proxy *)
+ | `Request_timeout (** server timed out waiting for the request *)
+ | `Conflict (** request could not be processed because of conflict *)
+ | `Gone
+ (** resource is no longer available and will not be available again *)
+ | `Length_required (** request did not specify the length of its content *)
+ | `Precondition_failed (** server does not meet request preconditions *)
+ | `Request_entity_too_large
+ (** request is larger than the server is willing or able to process *)
+ | `Request_uri_too_long
+ (** URI provided was too long for the server to process *)
+ | `Unsupported_media_type (** server does not support media type *)
+ | `Requested_range_not_satisfiable
+ (** client has asked for unprovidable portion of the file *)
+ | `Expectation_failed
+ (** server cannot meet requirements of Expect request-header field *)
+ | `I_m_a_teapot (** I'm a teapot *)
+ | `Enhance_your_calm (** Twitter rate limiting *)
+ | `Unprocessable_entity
+ (** request unable to be followed due to semantic errors *)
+ | `Locked (** resource that is being accessed is locked *)
+ | `Failed_dependency
+ (** request failed due to failure of a previous request *)
+ | `Upgrade_required (** client should switch to a different protocol *)
+ | `Precondition_required
+ (** origin server requires the request to be conditional *)
+ | `Too_many_requests
+ (** user has sent too many requests in a given amount of time *)
+ | `Request_header_fields_too_large
+ (** server is unwilling to process the request *)
+ | `No_response (** server returns no information and closes the connection *)
+ | `Retry_with (** request should be retried after performing action *)
+ | `Blocked_by_windows_parental_controls
+ (** Windows Parental Controls blocking access to webpage *)
+ | `Wrong_exchange_server (** the server cannot reach the client's mailbox *)
+ | `Client_closed_request
+ (** connection closed by client while HTTP server is processing *) ]
+[@@deriving sexp]
+(** Client_error *)
+
+type server_error_status =
+ [ `Internal_server_error (** generic error message *)
+ | `Not_implemented
+ (** server does not recognise method or lacks ability to fulfill *)
+ | `Bad_gateway
+ (** server received an invalid response from upstream server *)
+ | `Service_unavailable (** server is currently unavailable *)
+ | `Gateway_timeout
+ (** gateway did not receive response from upstream server *)
+ | `Http_version_not_supported
+ (** server does not support the HTTP protocol version *)
+ | `Variant_also_negotiates
+ (** content negotiation for the request results in a circular reference *)
+ | `Insufficient_storage (** server is unable to store the representation *)
+ | `Loop_detected
+ (** server detected an infinite loop while processing the request *)
+ | `Bandwidth_limit_exceeded (** bandwidth limit exceeded *)
+ | `Not_extended (** further extensions to the request are required *)
+ | `Network_authentication_required
+ (** client needs to authenticate to gain network access *)
+ | `Network_read_timeout_error (** network read timeout behind the proxy *)
+ | `Network_connect_timeout_error
+ (** network connect timeout behind the proxy *) ]
+[@@deriving sexp]
+(** Server_error *)
+
+type status =
+ [ informational_status
+ | success_status
+ | redirection_status
+ | client_error_status
+ | server_error_status ]
+[@@deriving sexp]
+
+type status_code = [ `Code of int | status ] [@@deriving sexp]
+
+val string_of_version : version -> string
+(** Convert a version to a string. *)
+
+val version_of_string : string -> version
+(** Convert a string to a version. *)
+
+val compare_version : version -> version -> int
+(** Comparison function for [version] values *)
+
+val string_of_method : meth -> string
+(** Convert a method to a string. *)
+
+val method_of_string : string -> meth
+(** Convert a string to a method. *)
+
+val compare_method : meth -> meth -> int
+(** Comparison function for [method] values *)
+
+val status_of_code : int -> status_code
+(** Generate status values from int codes. *)
+
+val code_of_status : status_code -> int
+(** Generate an int code from a status value. *)
+
+val string_of_status : status_code -> string
+(** Give a description of the given status value. *)
+
+val reason_phrase_of_code : int -> string
+(** Give a description of the given int code. *)
+
+val is_informational : int -> bool
+(** Is the given int code belong to the class of "informational" return code ? *)
+
+val is_success : int -> bool
+(** Is the given int code belong to the class of "success" return code ? *)
+
+val is_redirection : int -> bool
+(** Is the given int code belong to the class of "redirection" return code ? *)
+
+val is_client_error : int -> bool
+(** Is the given int code belong to the class of "client_error" return code ? *)
+
+val is_server_error : int -> bool
+(** Is the given int code belong to the class of "server_error" return code ? *)
+
+val is_error : int -> bool
+(** Return true for client and server error status codes. *)
module Auth = Auth
module Body = Body
module Conf = Conf
-module Connection = Connection
+module Connection = Connection [@@deprecated "Connection.t values are useless."]
module Code = Code
module Cookie = Cookie
module Header = Header
module S = S
module Path = Path
module Transfer = Transfer
+
+module Generic = struct
+ module Client = Client
+ module Server = Server
+end
+
+module Private = struct
+ module Transfer_io = Transfer_io
+ module String_io = String_io
+ module Header_io = Header_io
+end
(** Create a fresh connection identifier. *)
val to_string : t -> string
-(** Pretty-print a connection identifer. *)
+(** Pretty-print a connection identifier. *)
val compare : t -> t -> int
(** Comparison function for two identifiers. More recently constructed
let attrs =
List.map
(fun attr ->
- match Stringext.split ~on:'=' attr with
+ match String.split_on_char '=' attr with
| [] -> ("", "")
| n :: v -> (n, String.concat "=" v))
attrs
:: alist
with Failure _ -> alist
- let caseless_equal a b =
- if a == b then true
- else
- let len = String.length a in
- len = String.length b
- &&
- let stop = ref false in
- let idx = ref 0 in
- while (not !stop) && !idx < len do
- let c1 = String.unsafe_get a !idx in
- let c2 = String.unsafe_get b !idx in
- if Char.lowercase_ascii c1 <> Char.lowercase_ascii c2 then stop := true;
- incr idx
- done;
- not !stop
-
(* TODO: check dupes+order *)
let extract hdr =
+ let caseless_equal = Http.Header.Private.caseless_equal in
Header.fold
(fun k c a ->
if caseless_equal k "set-cookie" then extract_1_0 c a
conf.ml
(echo "let version = \"%{version:cohttp}\"")))
-(rule
- (targets code.ml code.mli)
- (deps
- (source_tree "../scripts/codes"))
- (action
- (chdir
- "../scripts"
- (run ./generate.exe))))
-
(library
(name cohttp)
(public_name cohttp)
(synopsis "Co-operative Client/Server HTTP library.")
(preprocess
(pps ppx_sexp_conv))
- (libraries re stringext uri uri-sexp sexplib0 bytes base64))
+ (libraries
+ base64
+ logs
+ (re_export http)
+ re
+ sexplib0
+ stringext
+ uri
+ uri-sexp))
(ocamllex accept_lexer)
*
}}}*)
-let caseless_equal a b =
- if a == b then true
- else
- let len = String.length a in
- len = String.length b
- &&
- let stop = ref false in
- let idx = ref 0 in
- while (not !stop) && !idx < len do
- let c1 = String.unsafe_get a !idx in
- let c2 = String.unsafe_get b !idx in
- if Char.lowercase_ascii c1 <> Char.lowercase_ascii c2 then stop := true;
- incr idx
- done;
- not !stop
-
-type t = (string * string) list
-
-let compare = Stdlib.compare
-let init () = []
-let is_empty = function [] -> true | _ -> false
-let init_with k v = [ (k, v) ]
-
-let mem h k =
- let rec loop = function
- | [] -> false
- | (k', _) :: h' -> if caseless_equal k k' then true else loop h'
- in
- loop h
-
-let add h k v : t = (k, v) :: h
-let add_list h l = List.fold_left (fun h (k, v) -> add h k v) h l
-let add_multi h k l = List.fold_left (fun h v -> add h k v) h l
-
-let add_opt h_opt k v =
- match h_opt with None -> init_with k v | Some h -> add h k v
-
-let add_unless_exists h k v = if mem h k then h else add h k v
-
-let add_opt_unless_exists h k v =
- match h with None -> init_with k v | Some h -> add_unless_exists h k v
-
-let get h k =
- let rec loop h =
- match h with
- | [] -> None
- | (k', v) :: h' -> if caseless_equal k k' then Some v else loop h'
- in
- loop h
-
-let get_multi (h : t) (k : string) =
- let rec loop h acc =
- match h with
- | [] -> acc
- | (k', v) :: h' ->
- if caseless_equal k k' then loop h' (v :: acc) else loop h' acc
- in
- loop h []
-
-let remove h k =
- let rec loop seen = function
- | [] -> if seen then [] else raise Not_found
- | (k', _) :: h when caseless_equal k k' -> loop true h
- | x :: h -> x :: loop seen h
- in
- try loop false h with Not_found -> h
-
-let remove_last h k =
- let rec loop seen = function
- | [] -> raise Not_found
- | (k', _) :: h when caseless_equal k k' -> h
- | x :: h -> x :: loop seen h
- in
- try loop false h with Not_found -> h
-
-let replace_ last h k v =
- let rec loop seen = function
- | [] -> if seen then [] else raise Not_found
- | (k'', _) :: h when caseless_equal k k'' ->
- if last then (k'', v) :: h
- else if not seen then (k, v) :: loop true h
- else loop seen h
- | x :: h -> x :: loop seen h
- in
- try loop false h with Not_found -> add h k v
-
-let replace = replace_ false
-
-let update h k f =
- let vorig = get h k in
- match (f vorig, vorig) with
- | None, None -> h
- | None, _ -> remove_last h k
- | Some s, Some s' when s == s' -> h
- | Some s, _ -> replace_ true h k s
-
-let update_all h k f =
- let vorig = get_multi h k in
- match (f vorig, vorig) with
- | [], [] -> h
- | [], _ -> remove h k
- | xs, xs' when xs = xs' -> h
- | xs, _ ->
- let h = remove h k in
- add_multi h k xs
-
-let map (f : string -> string -> string) (h : t) : t =
- List.map
- (fun (k, v) ->
- let vs' = f k v in
- (k, vs'))
- h
-
-let iter (f : string -> string -> unit) (h : t) : unit =
- List.iter (fun (k, v) -> f k v) h
-
-let fold (f : string -> string -> 'a -> 'a) (h : t) (init : 'a) : 'a =
- List.fold_left (fun acc (k, v) -> f k v acc) init h
-
-let of_list h = List.rev h
-let to_list h = List.rev h
-
-let to_lines (h : t) =
- let header_line k v = Printf.sprintf "%s: %s\r\n" k v in
- List.fold_left (fun acc (k, v) -> header_line k v :: acc) [] h
-
-let to_frames h =
- let to_frame k v = Printf.sprintf "%s: %s" k v in
- List.fold_left (fun acc (k, v) -> to_frame k v :: acc) [] h
-
-let to_string h =
- let b = Buffer.create 128 in
- to_list h
- |> List.iter (fun (k, v) ->
- Buffer.add_string b k;
- Buffer.add_string b ": ";
- Buffer.add_string b v;
- Buffer.add_string b "\r\n");
- Buffer.add_string b "\r\n";
- Buffer.contents b
-
-let headers_with_list_values =
- [|
- "accept";
- "accept-charset";
- "accept-encoding";
- "accept-language";
- "accept-ranges";
- "allow";
- "cache-control";
- "connection";
- "content-encoding";
- "content-language";
- "expect";
- "if-match";
- "if-none-match";
- "link";
- "pragma";
- "proxy-authenticate";
- "te";
- "trailer";
- "transfer-encoding";
- "upgrade";
- "vary";
- "via";
- "warning";
- "www-authenticate";
- |]
-
-let is_header_with_list_value =
- let tbl = Hashtbl.create (Array.length headers_with_list_values) in
- headers_with_list_values |> Array.iter (fun h -> Hashtbl.add tbl h ());
- fun h -> Hashtbl.mem tbl h
-
-let is_set_cookie k = caseless_equal k "set-cookie"
-
-(* set-cookie is an exception according to
- {{:https://tools.ietf.org/html/rfc7230#section-3.2.2}
- RFC7230§3.2.2} and can appear multiple times in a response message.
-*)
-let clean_dup (h : t) : t =
- let add h k v =
- if is_set_cookie k then (k, v) :: h
- else
- let to_add = ref false in
- let rec loop = function
- | [] ->
- to_add := true;
- []
- | (k', v') :: hs ->
- if caseless_equal k k' then
- if is_header_with_list_value k then (k, v' ^ "," ^ v) :: hs
- else (
- to_add := true;
- hs)
- else (k', v') :: loop hs
- in
- let h = loop h in
- if !to_add then (k, v) :: h else h
- in
- List.rev h |> List.fold_left (fun acc (k, v) -> add acc k v) []
-
-let get_multi_concat ?(list_value_only = false) h k : string option =
- if (not list_value_only) || is_header_with_list_value k then
- let vs = get_multi h k in
- match vs with [] -> None | _ -> Some (String.concat "," vs)
- else get h k
-
-let parse_content_range s =
- try
- let start, fini, total =
- Scanf.sscanf s "bytes %Ld-%Ld/%Ld" (fun start fini total ->
- (start, fini, total))
- in
- Some (start, fini, total)
- with Scanf.Scan_failure _ -> None
-
-(* If we see a "Content-Range" header, than we should limit the
- number of bytes we attempt to read *)
-let get_content_range headers =
- match get headers "content-length" with
- | Some clen -> ( try Some (Int64.of_string clen) with _ -> None)
- | None -> (
- match get headers "content-range" with
- | Some range_s -> (
- match parse_content_range range_s with
- | Some (start, fini, total) ->
- (* some sanity checking before we act on these values *)
- if fini < total && start <= total && 0L <= start && 0L <= total
- then
- let num_bytes_to_read = Int64.add (Int64.sub fini start) 1L in
- Some num_bytes_to_read
- else None
- | None -> None)
- | None -> None)
-
-let get_connection_close headers =
- match get headers "connection" with Some "close" -> true | _ -> false
+include Http.Header
let media_type_re =
let re = Re.Emacs.re ~case:true "[ \t]*\\([^ \t;]+\\)" in
Re.(compile (seq [ start; re ]))
-let get_first_match _re s =
+let get_first_match s =
try
let subs = Re.exec ~pos:0 media_type_re s in
let start, stop = Re.Group.offset subs 1 in
(* Grab "foo/bar" from " foo/bar ; charset=UTF-8" *)
let get_media_type headers =
match get headers "content-type" with
- | Some s -> get_first_match media_type_re s
+ | Some s -> get_first_match s
| None -> None
let get_acceptable_media_ranges headers =
Accept.languages
(get_multi_concat ~list_value_only:true headers "accept-language")
-(* Parse the transfer-encoding and content-length headers to
- * determine how to decode a body *)
-let get_transfer_encoding headers =
- (* It should actually be [get] as the interresting value is actually the last.*)
- match get_multi_concat ~list_value_only:true headers "transfer-encoding" with
- | Some "chunked" -> Transfer.Chunked
- | Some _ | None -> (
- match get_content_range headers with
- | Some len -> Transfer.Fixed len
- | None -> Transfer.Unknown)
-
-let add_transfer_encoding headers enc =
- let open Transfer in
- (* Only add a header if one doesnt already exist, e.g. from the app *)
- match (get_transfer_encoding headers, enc) with
- | Fixed _, _ (* App has supplied a content length, so use that *) | Chunked, _
- ->
- headers (* TODO: this is a protocol violation *)
- | Unknown, Chunked -> add headers "transfer-encoding" "chunked"
- | Unknown, Fixed len -> add headers "content-length" (Int64.to_string len)
- | Unknown, Unknown -> headers
-
let add_authorization_req headers challenge =
add headers "www-authenticate" (Auth.string_of_challenge challenge)
get_media_type headers = Some "application/x-www-form-urlencoded"
let get_location headers =
- match get headers "location" with
+ match get_location headers with
| None -> None
| Some u -> Some (Uri.of_string u)
| Some ua -> replace headers k (user_agent ^ " " ^ ua)
| None -> add headers k user_agent
-let connection h =
- match get h "connection" with
- | Some v when v = "keep-alive" -> Some `Keep_alive
- | Some v when v = "close" -> Some `Close
- | Some x -> Some (`Unknown x)
- | _ -> None
-
open Sexplib0.Sexp_conv
let sexp_of_t t =
(** Associative list representing HTTP headers. Order of transmission is
preserved, which implies that headers with same name are neither removed or
concataned by default (see [clean_dup] to do that). *)
-type t [@@deriving sexp]
+include module type of Http.Header with type t = Http.Header.t
(** The type for HTTP headers. *)
+val sexp_of_t : t -> Sexplib0.Sexp.t
+val t_of_sexp : Sexplib0.Sexp.t -> t
+
val init : unit -> t
(** [init ()] constructs a fresh, empty list of HTTP headers. *)
val is_empty : t -> bool
(** [is_empty h] tests whether HTTP headers [h] are empty or not. *)
+val of_list_rev : (string * string) list -> t
+
val of_list : (string * string) list -> t
(** [of_list l] construct a fresh headers from the content of [l] and in same
order. [to_list] and [of_list] are defined such as [to_list (of_list l) = l]
val replace : t -> string -> string -> t
(** [replace h k v] replaces the last added value of [k] from [h] and removed
- all other occurences of [k] if it exists. Otherwise it adds [(k, v)] to [h].
+ all other occurrences of [k] if it exists. Otherwise it adds [(k, v)] to
+ [h].
- {e Invariant:} [forall h, k, v. get_multi (replace h k v) = \[ v \]] *)
+ {e Invariant:} [forall h, k, v. get_multi (replace h k v) = [ v ]] *)
val mem : t -> string -> bool
(** [mem h k] returns [true] if the header name [k] appears in [h] and [false]
except for the header name [k]. Depending on the value of [v] where [v] is
[f (get h k)], the header pair [(k, v)] is added, removed or updated.
- - If [v] is [None], the last occurence of [k] in [h] is removed;
+ - If [v] is [None], the last occurrence of [k] in [h] is removed;
- If [v] is [Some w] then the last value paired with [k] in [h] is replaced
by [w] if it exists. Otherwise, the pair [(k, w)] is added;
[vs] is [f (get_multi h k)], the values associated to the header [k] are
added, removed or updated.
- - If [vs] is an empty list, every occurences of the header [k] in [h] are
+ - If [vs] is an empty list, every occurrences of the header [k] in [h] are
removed;
- If [vs] is a non-empty list, all values previously associated to [k] are
val fold : (string -> string -> 'a -> 'a) -> t -> 'a -> 'a
val to_lines : t -> string list
-(** [to_lines h] returns header fieds as a list of lines. Beware that each line
+(** [to_lines h] returns header fields as a list of lines. Beware that each line
ends with "\r\n" characters. *)
val to_frames : t -> string list
host: anhost.com, anotherhost.com
v}
- Finally, following {{:https://tools.ietf.org/html/rfc7230#section-3.2.2}
- RFC7230§3.2.2}, the header [Set-cookie] is treated as an exception and
- ignored by [clean_dup]. *)
+ Finally, following
+ {{:https://tools.ietf.org/html/rfc7230#section-3.2.2} RFC7230§3.2.2}, the
+ header [Set-cookie] is treated as an exception and ignored by [clean_dup]. *)
val get_content_range : t -> Int64.t option
val get_media_type : t -> string option
let rels_of_string_ s q =
let qs, i = quoted_string_of_string s q in
- let rels = Stringext.split qs ~on:' ' in
+ let rels = String.split_on_char ' ' qs in
(List.map rel_of_string (List.filter (fun s -> String.length s > 0) rels), i)
let rels_of_string s i =
open Sexplib0.Sexp_conv
-type t = {
+type t = Http.Request.t = {
headers : Header.t;
meth : Code.meth;
- scheme : string option;
resource : string;
version : Code.version;
- encoding : Transfer.encoding;
}
[@@deriving sexp]
-let compare x y =
- match Header.compare x.headers y.headers with
- | 0 ->
- let headers = Header.init () in
- Stdlib.compare { x with headers } { y with headers }
+let compare { headers; meth; resource; version } y =
+ match Header.compare headers y.headers with
+ | 0 -> (
+ match Code.compare_method meth y.meth with
+ | 0 -> (
+ match String.compare resource y.resource with
+ | 0 -> Code.compare_version version y.version
+ | i -> i)
+ | i -> i)
| i -> i
let headers t = t.headers
let meth t = t.meth
-let scheme t = t.scheme
let resource t = t.resource
let version t = t.version
-let encoding t = t.encoding
-let fixed_zero = Transfer.Fixed Int64.zero
+let encoding t = Header.get_transfer_encoding t.headers
-let guess_encoding ?(encoding = fixed_zero) headers =
- match Header.get_transfer_encoding headers with
- | Transfer.(Chunked | Fixed _) as enc -> enc
- | Unknown -> encoding
-
-let make ?(meth = `GET) ?(version = `HTTP_1_1) ?encoding ?headers uri =
- let headers = match headers with None -> Header.init () | Some h -> h in
+let make ?(meth = `GET) ?(version = `HTTP_1_1) ?encoding
+ ?(headers = Header.init ()) uri =
let headers =
Header.add_unless_exists headers "host"
(match Uri.scheme uri with
Header.add_authorization headers auth
| _, _, _ -> headers
in
- let encoding = guess_encoding ?encoding headers in
- {
- meth;
- version;
- headers;
- scheme = Uri.scheme uri;
- resource = Uri.path_and_query uri;
- encoding;
- }
-
-let is_keep_alive { version; headers; _ } =
- not
- (version = `HTTP_1_0
- || match Header.connection headers with Some `Close -> true | _ -> false)
+ let resource = Uri.path_and_query uri in
+ let headers =
+ match encoding with
+ | None -> headers
+ | Some encoding -> Header.add_transfer_encoding headers encoding
+ in
+ { headers; meth; resource; version }
+
+let is_keep_alive t = Http.Request.is_keep_alive t
(* Make a client request, which involves guessing encoding and
adding content headers if appropriate.
@param chunked Forces chunked encoding
*)
-let make_for_client ?headers ?(chunked = true) ?(body_length = Int64.zero) meth
- uri =
+let make_for_client ?headers ?chunked ?body_length meth uri =
let encoding =
- match chunked with
- | true -> Transfer.Chunked
- | false -> Transfer.Fixed body_length
+ match (chunked, body_length) with
+ | Some true, None -> Transfer.Chunked
+ | (None | Some false), Some fixed -> Transfer.Fixed fixed
+ | (Some false | None), None -> Transfer.Unknown
+ | Some true, Some _ ->
+ invalid_arg "cannot set both ?chunked and ?body_length:"
in
make ~meth ~encoding ?headers uri
| Some _ -> true
| None -> not (String.length path > 0 && path.[0] <> '/')
-let uri { scheme; resource; headers; meth; _ } =
- let uri =
- match resource with
- | "*" -> (
- match Header.get headers "host" with
- | None -> Uri.of_string ""
- | Some host ->
- let host_uri = Uri.of_string ("//" ^ host) in
- Uri.(make ?host:(host host_uri) ?port:(port host_uri) ()))
- | authority when meth = `CONNECT -> Uri.of_string ("//" ^ authority)
- | path -> (
- let uri = Uri.of_string path in
- match Uri.scheme uri with
- | Some _ -> (
+let uri { resource; headers; meth; _ } =
+ match resource with
+ | "*" -> (
+ match Header.get headers "host" with
+ | None -> Uri.of_string ""
+ | Some host ->
+ let host_uri = Uri.of_string ("//" ^ host) in
+ Uri.(make ?host:(host host_uri) ?port:(port host_uri) ()))
+ | authority when meth = `CONNECT -> Uri.of_string ("//" ^ authority)
+ | path -> (
+ let uri = Uri.of_string path in
+ match Uri.scheme uri with
+ | Some _ -> (
+ Uri.(
(* we have an absoluteURI *)
- Uri.(
- match path uri with "" -> with_path uri "/" | _ -> uri))
- | None ->
- let empty = Uri.of_string "" in
- let empty_base = Uri.of_string "///" in
- let pqs =
- match Stringext.split ~max:2 path ~on:'?' with
- | [] -> empty_base
- | [ path ] ->
+ match path uri with "" -> with_path uri "/" | _ -> uri))
+ | None -> (
+ let empty = Uri.of_string "" in
+ let empty_base = Uri.of_string "///" in
+ let pqs =
+ match Stringext.split ~max:2 path ~on:'?' with
+ | [] -> empty_base
+ | [ path ] ->
+ Uri.resolve "http" empty_base (Uri.with_path empty path)
+ | path :: qs :: _ ->
+ let path_base =
Uri.resolve "http" empty_base (Uri.with_path empty path)
- | path :: qs :: _ ->
- let path_base =
- Uri.resolve "http" empty_base (Uri.with_path empty path)
- in
- Uri.with_query path_base (Uri.query_of_encoded qs)
- in
- let uri =
- match Header.get headers "host" with
- | None -> Uri.(with_scheme (with_host pqs None) None)
- | Some host ->
- let host_uri = Uri.of_string ("//" ^ host) in
- let uri = Uri.with_host pqs (Uri.host host_uri) in
- Uri.with_port uri (Uri.port host_uri)
- in
- uri)
- in
- (* Only set the scheme if it's not already part of the URI *)
- match Uri.scheme uri with Some _ -> uri | None -> Uri.with_scheme uri scheme
+ in
+ Uri.with_query path_base (Uri.query_of_encoded qs)
+ in
+ match Header.get headers "host" with
+ | None -> Uri.(with_scheme (with_host pqs None) None)
+ | Some host ->
+ let host_uri = Uri.of_string ("//" ^ host) in
+ let uri = Uri.with_host pqs (Uri.host host_uri) in
+ Uri.with_port uri (Uri.port host_uri)))
type tt = t
open IO
- let parse_request_fst_line ic =
- let open Code in
- read_line ic >>= function
- | Some request_line -> (
- match Stringext.split request_line ~on:' ' with
- | [ meth_raw; path; http_ver_raw ] -> (
- let m = method_of_string meth_raw in
- match version_of_string http_ver_raw with
- | (`HTTP_1_1 | `HTTP_1_0) as v -> return (`Ok (m, path, v))
- | `Other _ ->
- return
- (`Invalid ("Malformed request HTTP version: " ^ http_ver_raw))
- )
- | _ -> return (`Invalid ("Malformed request header: " ^ request_line)))
- | None -> return `Eof
-
- let read ic =
- parse_request_fst_line ic >>= function
- | `Eof -> return `Eof
- | `Invalid _reason as r -> return r
- | `Ok (meth, resource, version) ->
- if is_valid_uri resource meth then
- Header_IO.parse ic >>= fun headers ->
- let encoding = Header.get_transfer_encoding headers in
- return
- (`Ok { headers; meth; scheme = None; resource; version; encoding })
+ let rec read ic =
+ let result =
+ IO.with_input_buffer ic ~f:(fun buf ~pos ~len ->
+ match Http.Private.Parser.parse_request ~pos ~len buf with
+ | Ok (req, consumed) -> (`Ok req, consumed)
+ | Error Partial -> (`Partial, 0)
+ | Error (Msg msg) -> (`Invalid msg, 0))
+ in
+ match result with
+ | `Partial -> (
+ IO.refill ic >>= function `Ok -> read ic | `Eof -> return `Eof)
+ | `Ok req ->
+ if is_valid_uri (Http.Request.resource req) (Http.Request.meth req) then
+ return (`Ok req)
else return (`Invalid "bad request URI")
+ | `Invalid msg -> return (`Invalid msg)
- (* Defined for method types in RFC7231 *)
- let has_body req =
- match req.meth with
- | `GET | `HEAD | `CONNECT | `TRACE -> `No
- | `DELETE | `POST | `PUT | `PATCH | `OPTIONS | `Other _ ->
- Transfer.has_body req.encoding
+ let make_body_reader req ic =
+ Transfer_IO.make_reader (Header.get_transfer_encoding req.headers) ic
- let make_body_reader req ic = Transfer_IO.make_reader req.encoding ic
let read_body_chunk = Transfer_IO.read
let write_header req oc =
let fst_line =
Printf.sprintf "%s %s %s\r\n"
- (Code.string_of_method req.meth)
+ (Http.Method.to_string req.meth)
(if req.resource = "" then "/" else req.resource)
- (Code.string_of_version req.version)
- in
- let headers = req.headers in
- let headers =
- match has_body req with
- | `Yes | `Unknown -> Header.add_transfer_encoding headers req.encoding
- | `No -> headers
+ (Http.Version.to_string req.version)
in
- IO.write oc fst_line >>= fun _ -> Header_IO.write headers oc
+ IO.write oc fst_line >>= fun _ -> Header_IO.write req.headers oc
- let make_body_writer ?flush req oc =
- Transfer_IO.make_writer ?flush req.encoding oc
+ let make_body_writer ~flush req oc =
+ Transfer_IO.make_writer ~flush (Header.get_transfer_encoding req.headers) oc
let write_body = Transfer_IO.write
- let write_footer req oc =
- match req.encoding with
+ let write_footer headers oc =
+ match Header.get_transfer_encoding headers with
| Transfer.Chunked ->
(* TODO Trailer header support *)
IO.write oc "0\r\n\r\n"
| Transfer.Fixed _ | Transfer.Unknown -> return ()
- let write ?flush write_body req oc =
+ let write ~flush write_body req oc =
write_header req oc >>= fun () ->
- let writer = make_body_writer ?flush req oc in
- write_body writer >>= fun () -> write_footer req oc
+ let writer = make_body_writer ~flush req oc in
+ write_body writer >>= fun () -> write_footer req.headers oc
end
+
+module Private = struct
+ module Make = Make
+end
+
+let has_body = Http.Request.has_body
(** HTTP/1.1 request handling *)
-include S.Request
-(** This contains the metadata for a HTTP/1.1 request header, including the
- {!headers}, {!version}, {!meth} and {!uri}. The body is handled by the
- separate {!S} module type, as it is dependent on the IO implementation.
+include S.Request with type t = Http.Request.t
+(** This contains the metadata for a HTTP/1.x request header, including the
+ {!field-headers}, {!field-version}, {!field-meth} and {!field-uri}. The body
+ is handled by the separate {!S} module type, as it is dependent on the IO
+ implementation.
The interface exposes a [fieldslib] interface which provides individual
accessor functions for each of the records below. It also provides [sexp]
serializers to convert to-and-from an {!Core.Std.Sexp.t}. *)
+val has_body : t -> [ `No | `Unknown | `Yes ]
+
val pp_hum : Format.formatter -> t -> unit
(** Human-readable output, used by the toplevel printer *)
-(** Functor to construct the IO-specific HTTP request handling functions *)
module Make (IO : S.IO) : S.Http_io with type t = t and module IO = IO
+[@@deprecated "This functor is not part of the public API."]
+
+module Private : sig
+ module Make (IO : S.IO) : S.Http_io with type t = t and module IO = IO
+end
*
}}}*)
-open Sexplib0.Sexp_conv
-
-type t = {
- encoding : Transfer.encoding;
+type t = Http.Response.t = {
headers : Header.t;
version : Code.version;
status : Code.status_code;
- flush : bool;
}
[@@deriving sexp]
-let compare x y =
- match Header.compare x.headers y.headers with
- | 0 ->
- let headers = Header.init () in
- Stdlib.compare { x with headers } { y with headers }
+let compare { headers; version; status } y =
+ match Header.compare headers y.headers with
+ | 0 -> (
+ match Stdlib.compare status y.status with
+ | 0 -> (
+ match Stdlib.compare status y.status with
+ | 0 -> Code.compare_version version y.version
+ | i -> i)
+ | i -> i)
| i -> i
let headers t = t.headers
-let encoding t = t.encoding
+let encoding t = Header.get_transfer_encoding t.headers
let version t = t.version
let status t = t.status
-let flush t = t.flush
-
-let make ?(version = `HTTP_1_1) ?(status = `OK) ?(flush = false)
- ?(encoding = Transfer.Chunked) ?(headers = Header.init ()) () =
- let encoding =
- match Header.get_transfer_encoding headers with
- | Transfer.(Chunked | Fixed _) as enc -> enc
- | Unknown -> encoding
+
+let make ?(version = `HTTP_1_1) ?(status = `OK) ?(encoding = Transfer.Unknown)
+ ?(headers = Header.init ()) () =
+ let headers =
+ match encoding with
+ | Unknown -> (
+ match Header.get_transfer_encoding headers with
+ | Unknown -> Header.add_transfer_encoding headers Chunked
+ | _ -> headers)
+ | _ -> Header.add_transfer_encoding headers encoding
in
- { encoding; headers; version; flush; status }
+ { headers; version; status }
let pp_hum ppf r =
Format.fprintf ppf "%s" (r |> sexp_of_t |> Sexplib0.Sexp.to_string_hum)
+let allowed_body response =
+ (* rfc7230#section-5.7.1 *)
+ match status response with
+ | #Code.informational_status | `No_content | `Not_modified -> false
+ | #Code.status_code -> true
+
+let has_body response =
+ if allowed_body response then Transfer.has_body (encoding response) else `No
+
type tt = t
module Make (IO : S.IO) = struct
let open Code in
read_line ic >>= function
| Some response_line -> (
- match Stringext.split response_line ~on:' ' with
+ match String.split_on_char ' ' response_line with
| version_raw :: code_raw :: _ -> (
match version_of_string version_raw with
| (`HTTP_1_0 | `HTTP_1_1) as v ->
| `Invalid _reason as r -> return r
| `Ok (version, status) ->
Header_IO.parse ic >>= fun headers ->
- let encoding = Header.get_transfer_encoding headers in
- let flush = false in
- return (`Ok { encoding; headers; version; status; flush })
+ return (`Ok { headers; version; status })
- let allowed_body response =
- (* rfc7230#section-5.7.1 *)
- match status response with
- | #Code.informational_status | `No_content | `Not_modified -> false
- | #Code.status_code -> true
-
- let has_body response =
- if allowed_body response then Transfer.has_body (encoding response) else `No
-
- let make_body_reader { encoding; _ } ic = Transfer_IO.make_reader encoding ic
+ let make_body_reader t ic = Transfer_IO.make_reader (encoding t) ic
let read_body_chunk = Transfer_IO.read
let write_header res oc =
>>= fun () ->
let headers =
if allowed_body res then
- Header.add_transfer_encoding res.headers res.encoding
+ Header.add_transfer_encoding res.headers (encoding res)
else res.headers
in
Header_IO.write headers oc
- let make_body_writer ?flush { encoding; _ } oc =
- Transfer_IO.make_writer ?flush encoding oc
+ let make_body_writer ~flush t oc =
+ Transfer_IO.make_writer ~flush (encoding t) oc
let write_body = Transfer_IO.write
- let write_footer { encoding; _ } oc =
- match encoding with
+ let write_footer t oc =
+ match encoding t with
| Transfer.Chunked ->
(* TODO Trailer header support *)
IO.write oc "0\r\n\r\n"
| Transfer.Fixed _ | Transfer.Unknown -> return ()
- let write ?flush fn req oc =
+ let write ~flush fn req oc =
write_header req oc >>= fun () ->
- let writer = make_body_writer ?flush req oc in
+ let writer = make_body_writer ~flush req oc in
fn writer >>= fun () -> write_footer req oc
end
+
+module Private = struct
+ module Make = Make
+end
(** HTTP/1.1 response handling *)
-include S.Response
+include S.Response with type t = Http.Response.t
(** This contains the metadata for a HTTP/1.1 response header, including the
- {!encoding}, {!headers}, {!version}, {!status} code and whether to {!flush}
- the connection after every body chunk (useful for server-side events and
- other long-lived connection protocols). The body is handled by the separate
- {!S} module type, as it is dependent on the IO implementation.
+ {!field-encoding}, {!field-headers}, {!field-version}, {!field-status} code
+ and whether to flush the connection after every body chunk (useful for
+ server-side events and other long-lived connection protocols). The body is
+ handled by the separate {!S} module type, as it is dependent on the IO
+ implementation.
The interface exposes a [fieldslib] interface which provides individual
accessor functions for each of the records below. It also provides [sexp]
serializers to convert to-and-from an {!Core.Std.Sexp.t}. *)
+val has_body : t -> [ `No | `Unknown | `Yes ]
+
val pp_hum : Format.formatter -> t -> unit
(** Human-readable output, used by the toplevel printer *)
-(** Functor to construct the IO-specific response handling function *)
module Make (IO : S.IO) : S.Http_io with type t = t and module IO = IO
+[@@deprecated "This functor is not part of the public API."]
+
+module Private : sig
+ module Make (IO : S.IO) : S.Http_io with type t = t and module IO = IO
+end
type conn
(** [conn] represents the underlying network flow *)
+ val refill : ic -> [ `Ok | `Eof ] t
+
+ val with_input_buffer :
+ ic -> f:(string -> pos:int -> len:int -> 'a * int) -> 'a
+
val read_line : ic -> string option t
(** [read_line ic] will read a single line terminated by CR or CRLF from the
input channel [ic]. It returns {!None} if EOF or other error condition is
module IO : IO
val read : IO.ic -> [ `Eof | `Invalid of string | `Ok of t ] IO.t
- val has_body : t -> [ `No | `Unknown | `Yes ]
- val make_body_writer : ?flush:bool -> t -> IO.oc -> writer
+ val make_body_writer : flush:bool -> t -> IO.oc -> writer
val make_body_reader : t -> IO.ic -> reader
val read_body_chunk : reader -> Transfer.chunk IO.t
val write_header : t -> IO.oc -> unit IO.t
val write_body : writer -> string -> unit IO.t
- val write : ?flush:bool -> (writer -> unit IO.t) -> t -> IO.oc -> unit IO.t
+ val write : flush:bool -> (writer -> unit IO.t) -> t -> IO.oc -> unit IO.t
end
module type Request = sig
type t = {
headers : Header.t; (** HTTP request headers *)
meth : Code.meth; (** HTTP request method *)
- scheme : string option; (** URI scheme (http or https) *)
resource : string; (** Request path and query *)
version : Code.version; (** HTTP version, usually 1.1 *)
- encoding : Transfer.encoding; (** transfer encoding of this HTTP request *)
}
[@@deriving sexp]
val headers : t -> Header.t
val meth : t -> Code.meth
- val scheme : t -> string option
val resource : t -> string
val version : t -> Code.version
val encoding : t -> Transfer.encoding
?headers:Header.t ->
Uri.t ->
t
+ (** [make ()] is a value of {!type:t}. The default values for the request, if
+ not specified, are: [status] is [`Ok], [version] is [`HTTP_1_1], [flush]
+ is [false] and [headers] is [Header.empty]. The request encoding value is
+ determined via the [Header.get_transfer_encoding] function and, if not
+ found, uses the default value [Transfer.Fixed 0]. *)
val is_keep_alive : t -> bool
(** Return true whether the connection should be reused *)
module type Response = sig
type t = {
- encoding : Transfer.encoding;
- (** Transfer encoding of this HTTP response *)
headers : Header.t; (** response HTTP headers *)
version : Code.version; (** (** HTTP version, usually 1.1 *) *)
status : Code.status_code; (** HTTP status code of the response *)
- flush : bool;
}
[@@deriving sexp]
val headers : t -> Header.t
val version : t -> Code.version
val status : t -> Code.status_code
- val flush : t -> bool
val compare : t -> t -> int
val make :
?version:Code.version ->
?status:Code.status_code ->
- ?flush:bool ->
?encoding:Transfer.encoding ->
?headers:Header.t ->
unit ->
t
- (** The response creates by [make ~encoding ~headers ()] has an encoding value
- determined from the content of [headers] or if no proper header is
- present, using the value of [encoding]. Checked headers are
- "content-length", "content-range" and "transfer-encoding". The default
- value of [encoding] is chunked. *)
+ (** [make ()] is a value of {!type:t}. The default values for the request, if
+ not specified, are: [status] is [`Ok], [version] is [`HTTP_1_1], [flush]
+ is [false] and [headers] is [Header.empty]. The request encoding value is
+ determined via the [Header.get_transfer_encoding] function and, if not
+ found, uses the default value [Transfer.Chunked]. *)
end
module type Body = sig
--- /dev/null
+module type S = sig
+ module IO : S.IO
+
+ type body
+ type conn = IO.conn * Connection.t [@@warning "-3"]
+ type response
+
+ type response_action =
+ [ `Expert of Http.Response.t * (IO.ic -> IO.oc -> unit IO.t)
+ | `Response of response ]
+ (** A request handler can respond in two ways:
+
+ - Using [`Response], with a {!Response.t} and a {!body}.
+ - Using [`Expert], with a {!Response.t} and an IO function that is
+ expected to write the response body. The IO function has access to the
+ underlying {!IO.ic} and {!IO.oc}, which allows writing a response body
+ more efficiently, stream a response or to switch protocols entirely
+ (e.g. websockets). Processing of pipelined requests continue after the
+ [unit IO.t] is resolved. The connection can be closed by closing the
+ {!IO.ic}. *)
+
+ type t
+
+ val make_response_action :
+ ?conn_closed:(conn -> unit) ->
+ callback:(conn -> Http.Request.t -> body -> response_action IO.t) ->
+ unit ->
+ t
+
+ val make_expert :
+ ?conn_closed:(conn -> unit) ->
+ callback:
+ (conn ->
+ Http.Request.t ->
+ body ->
+ (Http.Response.t * (IO.ic -> IO.oc -> unit IO.t)) IO.t) ->
+ unit ->
+ t
+
+ val make :
+ ?conn_closed:(conn -> unit) ->
+ callback:(conn -> Http.Request.t -> body -> response IO.t) ->
+ unit ->
+ t
+
+ val respond :
+ ?headers:Http.Header.t ->
+ status:Http.Status.t ->
+ body:body ->
+ unit ->
+ response IO.t
+ (** [respond ?headers ~status ~body] will respond to an HTTP request with the
+ given [status] code and response [body]. The transfer encoding will be
+ detected from the [body] value and set to chunked encoding if it cannot be
+ determined immediately. You can override the encoding by supplying an
+ appropriate [Content-length] or [Transfer-encoding] in the [headers]
+ parameter. *)
+
+ val respond_string :
+ ?headers:Http.Header.t ->
+ status:Http.Status.t ->
+ body:string ->
+ unit ->
+ response IO.t
+
+ val callback : t -> IO.conn -> IO.ic -> IO.oc -> unit IO.t
+end
x.pos <- x.pos + n;
Some s
+ let refill _ = `Eof
+
+ let with_input_buffer t ~f =
+ let res, count = f t.str ~pos:t.pos ~len:(t.len - t.pos) in
+ t.pos <- t.pos + count;
+ res
+
let read x n =
match read_exactly' x n with
| None when x.pos >= x.len -> raise End_of_file
open Sexplib0.Sexp_conv
-type encoding = Chunked | Fixed of int64 | Unknown [@@deriving sexp]
+type encoding = Http.Transfer.encoding = Chunked | Fixed of int64 | Unknown
+[@@deriving sexp]
+
+let pp_encoding fmt = function
+ | Chunked -> Format.pp_print_string fmt "chunked"
+ | Fixed size -> Format.fprintf fmt "fixed %Ld" size
+ | Unknown -> Format.pp_print_string fmt "unknown"
+
type chunk = Chunk of string | Final_chunk of string | Done [@@deriving sexp]
let string_of_encoding = function
| Fixed i -> Printf.sprintf "fixed[%Ld]" i
| Unknown -> "unknown"
-let has_body = function
- | Fixed 0L -> `No
- | Chunked | Fixed _ -> `Yes
- | Unknown -> `Unknown
+let has_body = Http.Transfer.Private.has_body
(** The encoding format detected from the [transfer-encoding] and
[content-length] headers *)
-type encoding =
+type encoding = Http.Transfer.encoding =
| Chunked (** dynamic chunked encoding *)
| Fixed of int64 (** fixed size content *)
| Unknown (** unknown body size, which leads to best-effort *)
[@@deriving sexp]
+val pp_encoding : Format.formatter -> encoding -> unit
+(** Human-readable output. *)
+
(** A chunk of body that also signals if there to more to arrive *)
type chunk =
| Chunk of string (** chunk of data and not the end of stream *)
let len = min size max_read_len in
read ic (Int64.to_int len)
- let parse_chunksize chunk_size_hex =
- let hex =
- (* From https://tools.ietf.org/html/rfc7230#section-4.1.1
- > The chunked encoding allows each chunk to include zero or
- > more chunk extensions, immediately following the chunk-size
- *)
- try String.sub chunk_size_hex 0 (String.index chunk_size_hex ';')
- with _ -> chunk_size_hex
- in
- try Some (Int64.of_string ("0x" ^ hex)) with _ -> None
-
let rec junk_until_empty_line ic =
read_line ic >>= function
| None | Some "" -> return Done
read_chunk ic !remaining >>= fun chunk ->
remaining := remaining_length chunk !remaining;
(if !remaining = 0L (* End_of_chunk *) then read_line ic
- (* Junk the CRLF at end of chunk *)
- else return None)
+ (* Junk the CRLF at end of chunk *)
+ else return None)
>>= fun _ -> return chunk
in
if !remaining = 0L then
read_line ic >>= function
| None -> return Done
| Some chunk_size_hex -> (
- match parse_chunksize chunk_size_hex with
- | None -> return Done
- | Some 0L ->
+ match
+ Http.Private.Parser.parse_chunk_length (chunk_size_hex ^ "\r\n")
+ with
+ | Error Partial ->
+ assert false
+ (* this branch will never be reached here since we feed the full line *)
+ | Error (Msg _) -> return Done
+ | Ok (0L, _consumed) ->
(* TODO: Trailer header support *)
junk_until_empty_line ic
- | Some count -> (
+ | Ok (count, _consumed) -> (
remaining := count;
read_chunk_fragment () >>= function
| "" -> return Done (* 0 bytes read means EOF *)
let write_ignore_blank writer io s =
if String.length s = 0 then return () else writer io s
- let make_writer ?(flush = false) mode =
+ let make_writer ~flush mode =
+ let write =
+ match mode with
+ | Chunked -> Chunked.write
+ | Fixed _ -> Fixed.write
+ | Unknown -> Unknown.write
+ in
match flush with
- | false -> (
- match mode with
- | Chunked -> Chunked.write
- | Fixed _ -> Fixed.write
- | Unknown -> Unknown.write)
- | true ->
- (match mode with
- | Chunked -> write_and_flush Chunked.write
- | Fixed _ -> write_and_flush Fixed.write
- | Unknown -> write_and_flush Unknown.write)
- |> write_ignore_blank
+ | false -> write
+ | true -> write_and_flush write |> write_ignore_blank
let read reader = reader ()
let write writer buf = writer buf
type writer
val make_reader : encoding -> IO.ic -> reader
- val make_writer : ?flush:bool -> encoding -> IO.oc -> writer
+ val make_writer : flush:bool -> encoding -> IO.oc -> writer
val read : reader -> chunk IO.t
val write : writer -> string -> unit IO.t
end
(executable
(name test_header)
- (modules unitary_test_header test_header)
+ (modules test_header)
(forbidden_libraries base)
- (libraries cohttp alcotest fmt))
+ (libraries cohttp alcotest sexplib0))
(rule
(alias runtest)
(name test_request)
(modules test_request)
(forbidden_libraries base)
- (libraries cohttp alcotest fmt))
+ (libraries alcotest cohttp fmt http_bytebuffer))
(rule
(alias runtest)
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*}}}*)
-module String_io = Cohttp__String_io
-module StringResponse = Cohttp.Response.Make (String_io.M)
+module String_io = Cohttp.Private.String_io
+module StringResponse = Cohttp.Response.Private.Make (String_io.M)
module H = Cohttp.Header
let aes = Alcotest.check Alcotest.string
aes "header value 1.1"
"Domain=ocaml.org; Max-Age=100; Path=/foo/bar; Version=1" v
-let cookie_printer x =
- String.concat "; " (List.map (fun (x, y) -> x ^ ":" ^ y) x)
-
let t_cookies = Alcotest.(list (pair string string))
let cookie_with_eq_val () =
let cookies = Cohttp.Cookie.Cookie_hdr.extract h in
Alcotest.check t_cookies "headers" [ ("foo", "bar"); ("a", "b") ] cookies
-let opt_printer f = function
- | None -> "nothing"
- | Some x -> Printf.sprintf "'%s'" (f x)
-
let get_media_type () =
let mt = " foo/bar ; charset=UTF-8" in
let header = Cohttp.Header.init_with "content-type" mt in
let headers_of_response test_name response_string =
String_io.M.(
StringResponse.read (String_io.open_in response_string) >>= function
- | `Ok resp -> Cohttp.Response.headers resp
+ | `Ok resp -> Http.Response.headers resp
| _ -> failwith (test_name ^ " response parse failed"))
let get_resp lines =
aeso "test_cachecontrol_concat" (Some "public,max-age:86400")
(H.get_multi_concat h "Cache-Control")
+module HIO = Cohttp.Private.Header_io.Make (String_io.M)
+
+let t_header =
+ Alcotest.testable
+ (fun fmt h ->
+ let sexp = H.sexp_of_t h in
+ Sexplib0.Sexp.pp_hum fmt sexp)
+ (fun x y -> H.compare x y = 0)
+
+let large_header () =
+ let sz = 1024 * 1024 * 100 in
+ let h = H.init () in
+ let v1 = String.make sz 'a' in
+ let h = H.add h "x-large" v1 in
+ let h = H.add h v1 "foo" in
+ aeso "x-large" (H.get h "x-large") (Some v1);
+ let obuf = Buffer.create (sz + 1024) in
+ HIO.write h obuf;
+ let ibuf = Buffer.contents obuf in
+ let sbuf = String_io.open_in ibuf in
+ Alcotest.check t_header "large_header" (HIO.parse sbuf) h
+
let () = Printexc.record_backtrace true
let () =
("extension star", `Quick, link_ext_star);
] );
("Media Type", [ ("Media Type", `Quick, get_media_type) ]);
+ ("Trim", [ ("Trim Whitespace", `Quick, trim_ws) ]);
("Auth", [ ("Valid Auth", `Quick, valid_auth) ]);
( "Cookie",
[
("content-range", `Quick, Content_range.content_range);
] );
("Cache Control", [ ("concat", `Quick, test_cachecontrol_concat) ]);
- Unitary_test_header.tests;
+ ( "Serialization/Deserialization",
+ if Sys.word_size = 64 then [ ("large header", `Slow, large_header) ]
+ else [] );
]
open Cohttp
-module String_io = Cohttp__String_io
-module StringRequest = Request.Make (String_io.M)
+module String_io = Cohttp.Private.String_io
+module StringRequest = Request.Private.Make (String_io.M)
+let user_agent = Cohttp.Header.user_agent
let uri_userinfo = Uri.of_string "http://foo:bar%2525@ocaml.org"
let header_auth =
"body encoding with content-length and transfer-encoding headers."
(r |> Request.encoding) (Fixed 100L)
-let opt_default default = function None -> default | Some v -> v
-
module Parse_result = struct
type 'a t = [ `Ok of 'a | `Invalid of string | `Eof ]
let parse_request_uri_ r (expected : Uri.t Parse_result.t) name =
String_io.M.(
StringRequest.read (String_io.open_in r)
- >>= fun (result : Cohttp.Request.t Parse_result.t) ->
+ >>= fun (result : Http.Request.t Parse_result.t) ->
let uri = Parse_result.map result ~f:Request.uri in
return @@ Alcotest.check t_parse_result_uri name uri expected)
parse_request_uri_ r bad_request "parse_request_uri_host_query_no_slash"
let parse_request_connect _ =
- let r = "CONNECT vpn.example.net:443 HTTP/1.1\r\n" in
+ let r = "CONNECT vpn.example.net:443 HTTP/1.1\r\n\r\n" in
let uri = `Ok (Uri.of_string "//vpn.example.net:443") in
parse_request_uri_ r uri "parse_request_connect"
parse_request_uri_ r uri "parse_request_uri_host_traversal"
let uri_round_trip _ =
- let expected_uri = Uri.of_string "https://www.example.com/test" in
- let actual_uri = Request.make expected_uri |> Request.uri in
+ let expected_uri =
+ let uri = Uri.of_string "https://www.example.com/test" in
+ Uri.with_userinfo uri (Some "foo")
+ in
+ let actual_uri =
+ let uri = Request.make expected_uri |> Request.uri in
+ (* These are the fields that aren't preserved: *)
+ let uri = Uri.with_scheme uri (Uri.scheme expected_uri) in
+ Uri.with_userinfo uri (Uri.userinfo expected_uri)
+ in
Alcotest.check uri_testable "Request.make uri round-trip" actual_uri
expected_uri
let () = Printexc.record_backtrace true
+module Buffer = struct
+ include Http_bytebuffer.Bytebuffer
+
+ include
+ Http_bytebuffer.Bytebuffer.Make
+ (struct
+ type 'a t = 'a
+
+ let ( >>= ) v f = f v
+ let ( >>| ) v f = f v
+ let return v = v
+ end)
+ (struct
+ type src = string
+
+ let refill s buffer ~pos ~len =
+ if String.equal s "" then `Eof
+ else
+ let len = min len (String.length s) in
+ let () = Bytes.blit_string s 0 buffer pos len in
+ `Ok len
+ end)
+end
+
+module Test_io = struct
+ type 'a t = 'a
+
+ let ( >>= ) v f = f v
+ let return v = v
+
+ type ic = Buffer.t
+ type oc = Buffer.t
+ type conn = unit
+
+ let refill _ = `Eof
+
+ let with_input_buffer b ~f =
+ let contents = Buffer.to_string b in
+ let res, read = f contents ~pos:0 ~len:(String.length contents) in
+ let () = Buffer.drop b read in
+ res
+
+ let read_line buffer = Buffer.read_line buffer ""
+ let read buffer = Buffer.read buffer ""
+ let write buffer string = Buffer.refill buffer string |> ignore
+ let flush _ = ()
+end
+
+module Request = Request.Private.Make (Test_io)
+
+let null_content_length_header () =
+ let output = Buffer.create 1024 in
+ let () =
+ (* The user-agent in releases contentsontains the version, we need to strip
+ it for the test *)
+ let r =
+ Cohttp.Request.make_for_client ~chunked:false ~body_length:0L `PUT
+ (Uri.of_string "http://someuri.com")
+ in
+ Request.write_header r output
+ in
+ let expected =
+ "PUT / HTTP/1.1\r\nhost: someuri.com\r\nuser-agent: "
+ ^ user_agent
+ ^ "\r\ncontent-length: 0\r\n\r\n"
+ in
+ Alcotest.(check string)
+ "null content-length header are sent" expected (Buffer.to_string output)
+
+let useless_null_content_length_header () =
+ let output = Buffer.create 1024 in
+ let () =
+ let r =
+ Cohttp.Request.make_for_client `GET (Uri.of_string "http://someuri.com")
+ in
+ Request.write_header r output
+ in
+ let expected =
+ "GET / HTTP/1.1\r\nhost: someuri.com\r\nuser-agent: "
+ ^ user_agent
+ ^ "\r\n\r\n"
+ in
+ Alcotest.(check string)
+ "null content-length header are not sent for bodyless methods" expected
+ (Buffer.to_string output)
+
let () =
Alcotest.run "test_request"
[
( "from both optional argument and headers",
`Quick,
encoding_header_opt_argument );
+ ("null content-length", `Quick, null_content_length_header);
+ ( "useless null content-length",
+ `Quick,
+ useless_null_content_length_header );
] );
( "Parse URI",
[
+++ /dev/null
-(*{{{ Copyright (c) 2021 Carine Morel <carine@tarides.com>
- *
- * Permission to use, copy, modify, and distribute this software for any
- * purpose with or without fee is hereby granted, provided that the above
- * copyright notice and this permission notice appear in all copies.
- *
- * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
- * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
- * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
- * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
- * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
- * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
- * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
- *}}}*)
-
-module H = Cohttp.Header
-(** These tests try as much as possible to tests each header functions
- independently. *)
-
-let aei = Alcotest.check Alcotest.int
-let aes = Alcotest.check Alcotest.string
-let aeso = Alcotest.check Alcotest.(option string)
-let aesl = Alcotest.check Alcotest.(list string)
-let aessl = Alcotest.check Alcotest.(list (pair string string))
-let aeb = Alcotest.check Alcotest.bool
-
-let t_header =
- Alcotest.testable
- (fun fmt h ->
- let sexp = Cohttp.Header.sexp_of_t h in
- Sexplib0.Sexp.pp_hum fmt sexp)
- (fun x y -> Cohttp.Header.compare x y = 0)
-
-let aeh = Alcotest.check t_header
-
-let hstr =
- [
- ("accept", "application/xml");
- ("transfer-encoding", "chunked");
- ("accept", "text/html");
- ("content-length", "100");
- ]
-
-let prebuilt = H.of_list hstr
-let to_list_rev h = List.rev (H.to_list h)
-
-let to_list_tests () =
- aessl "to_list (init ())" [] H.(to_list (init ()));
- aessl "to_list (add (init ()) k v"
- [ ("a", "a1") ]
- H.(to_list (add (init ()) "a" "a1"));
- aessl "to_list (of_list h) = h" hstr H.(to_list prebuilt)
-
-let is_empty_tests () =
- aeb "is_empty (init ())" true H.(is_empty (init ()));
- aeb "is_empty (add (init ()) k v" false H.(is_empty (add (init ()) "a" "a1"));
- aeb "is_empty (remove (add (init ()) k v) k)" true
- H.(is_empty (remove (add (init ()) "a" "a1") "a"))
-
-let init_with_tests () =
- aessl "init_with k v"
- [ ("traNsfer-eNcoding", "chunked") ]
- H.(to_list (init_with "traNsfer-eNcoding" "chunked"))
-
-let mem_tests () =
- aeb "mem (init ()) k = false" false H.(mem (init ()) "a");
- aeb "mem h k" true H.(mem prebuilt "accept");
- aeb "mem h k" true H.(mem prebuilt "content-length");
- aeb "mem h k" false H.(mem prebuilt "a")
-
-let add_tests () =
- aessl "add h k v" (hstr @ [ ("a", "a1") ]) H.(to_list (add prebuilt "a" "a1"));
- aessl "add (add h k v) k v"
- (hstr @ [ ("a", "a1"); ("a", "a1") ])
- H.(to_list (add (add prebuilt "a" "a1") "a" "a1"));
- aessl "add (add h k' v') k v"
- (hstr @ [ ("a", "a1"); ("b", "b1") ])
- H.(to_list (add (add prebuilt "a" "a1") "b" "b1"))
-
-let get_tests () =
- aeso "get (add (init () k v) k" (Some "a1")
- H.(get (add (init ()) "a" "a1") "a");
- aeso "get (add h k v) k when mem h k = false" (Some "a1")
- H.(get (add prebuilt "a" "a1") "a");
- aeso "get (add h k v) k when mem h k = true" (Some "text/html")
- H.(get (add prebuilt "a" "a1") "accept");
- aeso "get (add (add h k v') k v) k = v" (Some "a2")
- H.(get (add (add prebuilt "a" "a1") "a" "a2") "a")
-
-let add_list_tests () =
- let l = [ ("a", "a1"); ("b", "b1") ] in
- aessl "add_list (init ()) []" [] H.(to_list (add_list (init ()) []));
- aessl "add_list (init ()) l" l H.(to_list (add_list (init ()) l));
- aessl "add_list h []" hstr H.(to_list (add_list prebuilt []));
- aessl "add_list h [k, v]"
- (hstr @ [ ("a", "a1") ])
- H.(to_list (add_list prebuilt [ ("a", "a1") ]));
- aessl "add_list h l" (hstr @ l) H.(to_list (add_list prebuilt l))
-
-let add_multi_tests () =
- let k, vals = ("a", [ "a1"; "a2"; "a3" ]) in
- let l = List.map (fun v -> ("a", v)) vals in
- aessl "add_multi (init ()) k []" [] H.(to_list (add_multi (init ()) k []));
- aessl "add_multi (init ()) k vals" l H.(to_list (add_multi (init ()) k vals));
- aessl "add_multi h k []" hstr H.(to_list (add_multi prebuilt k []));
- aessl "add_multi h k vals" (hstr @ l) H.(to_list (add_multi prebuilt k vals))
-
-let add_unless_exists_tests () =
- let k, v = ("a", "a1") in
- let k', v' = ("transfer-encoding", "chunked") in
- let k'', v'' = ("accept", "text/*") in
- aessl "add_unless_exists (init ()) k v"
- [ (k, v) ]
- H.(to_list (add_unless_exists (init ()) k v));
- aessl "add_unless_exists h k v when mem h k = false"
- (hstr @ [ (k, v) ])
- H.(to_list (add_unless_exists prebuilt k v));
- aessl "add_unless_exists h k v when mem h k = true)" hstr
- H.(to_list (add_unless_exists prebuilt k' v'));
- aessl "add_unless_exists h k v when mem h k = true)" hstr
- H.(to_list (add_unless_exists prebuilt k'' v''))
-
-let remove_tests () =
- aessl "remove (init ()) k" [] H.(to_list (remove (init ()) "accept"));
- aessl "remove (add (add (init ()) k v) k v) k" []
- H.(to_list (remove (add (add (init ()) "k" "v") "k" "v") "k"));
- aessl "remove h k when mem h k = false" hstr H.(to_list (remove prebuilt "a"));
- aessl "remove h k when mem h k = true"
- [
- ("accept", "application/xml");
- ("accept", "text/html");
- ("content-length", "100");
- ]
- H.(to_list (remove prebuilt "transfer-encoding"));
- aessl "remove h k when mem h k = true"
- [ ("transfer-encoding", "chunked"); ("content-length", "100") ]
- H.(to_list (remove prebuilt "accept"))
-
-let replace_tests () =
- let k, v, v' = ("a", "a1", "a2") in
- aessl "replace (init ()) k v" [ (k, v) ] H.(to_list (replace (init ()) k v));
- aessl "replace (add (init ()) k v) k v"
- [ (k, v) ]
- H.(to_list (replace (add (init ()) k v) k v));
- aessl "replace (add (init ()) k v) k v'"
- [ (k, v') ]
- H.(to_list (replace (add (init ()) k v) k v'));
- aessl "replace h k v when mem h k = false"
- (hstr @ [ (k, v) ])
- H.(to_list (replace prebuilt k v));
- aessl "replace h k v when mem h k = true"
- [
- ("accept", "application/xml");
- ("transfer-encoding", "gzip");
- ("accept", "text/html");
- ("content-length", "100");
- ]
- H.(to_list (replace prebuilt "transfer-encoding" "gzip"));
- aessl "replace h k v when mem h = true"
- [
- ("transfer-encoding", "chunked");
- ("accept", "text/*");
- ("content-length", "100");
- ]
- H.(to_list (replace prebuilt "accept" "text/*"))
-
-let h =
- H.init () |> fun h ->
- H.add h "first" "1" |> fun h ->
- H.add h "second" "2" |> fun h ->
- H.add h "accept" "foo" |> fun h -> H.add h "accept" "bar"
-
-let update_tests () =
- let h1 =
- H.update h "second" (function Some _ -> Some "2a" | None -> None)
- in
- let h2 = H.replace h "second" "2a" in
- aeh "update existing header" h1 h2;
- let h1 = H.update h "second" (function Some _ -> None | None -> Some "3") in
- let h2 = H.remove h "second" in
- aeh "update remove header" h1 h2;
- let h1 =
- H.update h "accept" (function Some _ -> Some "baz" | None -> None)
- in
- aesl "update existing header with multiple values"
- H.(get_multi h1 "accept")
- [ "foo"; "baz" ];
- let h' = H.update h "third" (function Some _ -> None | None -> Some "3") in
- aesl "update add new header" (H.get_multi h' "third") [ "3" ];
- let h1 = H.update h "third" (function _ -> None) in
- aeh "update_remove_absent_header" h h1;
- let h1 = H.update h "third" (function Some _ -> Some "3" | None -> None) in
- aeh "update_new_header: unchanged" h h1;
- let h1 = H.update h "accept" (function Some _ -> None | None -> None) in
- aeso "update_existing_header_remove_multivalue: remove last" (Some "foo")
- (H.get h1 "accept")
-
-let update_all_tests () =
- let h1 = H.update_all h "second" (function [] -> [] | _ -> [ "2a" ]) in
- let h2 = H.(add (remove h "second") "second" "2a") in
- aeh "update_all existing header" h1 h2;
- let h1 = H.update_all h "second" (function [] -> [ "3" ] | _ -> []) in
- let h2 = H.remove h "second" in
- aeh "update_all remove header" h1 h2;
- let h1 = H.update_all h "accept" (function [] -> [] | _ -> [ "baz" ]) in
- aesl "update_all existing header with multiple values"
- H.(get_multi h1 "accept")
- [ "baz" ];
- let h1 =
- H.update_all h "accept" (function [] -> [] | xs -> xs @ [ "baz" ])
- in
- let h2 = H.add h "accept" "baz" in
- aeso "update_all_existing_header_multivalued"
- (H.get_multi_concat h1 "accept")
- (H.get_multi_concat h2 "accept");
- let h1 = H.update_all h "accept" (function _ -> []) in
- aeh "update_all_existing_header_multivalue : remove all" (H.remove h "accept")
- h1;
- let h1 = H.update_all h "third" (function [] -> [ "3"; "33" ] | _ -> []) in
- let h2 = H.add_multi h "third" [ "3"; "33" ] in
- aeh "update add new header" h1 h2;
- let h1 = H.update_all h "third" (function _ -> []) in
- aeh "update_remove_absent_header" h h1;
- let h1 = H.update_all h "third" (function [] -> [] | _ -> [ "3" ]) in
- aeh "update_new_header: unchanged" h h1
-
-let get_multi_tests () =
- aesl "get_multi (init ()) k" [] H.(get_multi (init ()) "a");
- aesl "get_multi h k when mem h k = false" [] H.(get_multi prebuilt "a");
- aesl "get_multi h k when mem h k = true" [ "chunked" ]
- H.(get_multi prebuilt "transfer-encoding");
- aesl "get_multi h k when mem h k = true"
- [ "application/xml"; "text/html" ]
- H.(get_multi prebuilt "accept")
-
-let hstr =
- [
- ("accept", "application/xml");
- ("transfer-encoding", "chunked");
- ("accept", "text/html");
- ("content-length", "100");
- ]
-
-let get_multi_concat_tests () =
- let h1 = H.(add (add prebuilt "a" "a1") "a" "a2") in
- aeso "get_multi_concat (init ()) k" None H.(get_multi_concat (init ()) "a");
- aeso "get_multi_concat h k when mem h k = false" None
- H.(get_multi_concat prebuilt "a");
- aeso "get_multi_concat h k when mem h k = true"
- (Some "application/xml,text/html")
- H.(get_multi_concat prebuilt "accept");
- aeso "get_multi_concat ~list_value_only:false h k when mem h k = true"
- (Some "a1,a2")
- H.(get_multi_concat h1 "a");
- aeso "get_multi_concat ~list_value_only:true h k when mem h k = true"
- (Some "a2")
- H.(get_multi_concat ~list_value_only:true h1 "a")
-
-let map_tests () =
- let a = ", a" in
- aessl "map (fun _ v -> v) (init ())" []
- H.(to_list (map (fun _k v -> v) (init ())));
- aessl "map (fun _ v -> v) (init ())" (H.to_list prebuilt)
- H.(to_list (map (fun _k v -> v) prebuilt));
- aessl "map (fun _ v -> v ^ a ) (init ())"
- [
- ("accept", "application/xml, a");
- ("transfer-encoding", "chunked, a");
- ("accept", "text/html, a");
- ("content-length", "100, a");
- ]
- H.(to_list (map (fun _k v -> v ^ a) prebuilt))
-
-let fold_tests () =
- let rev k v acc = H.(add acc k v) in
- let h1 = H.(fold rev prebuilt (init ())) in
- aessl
- "[fold (fun k v acc -> H.(add acc k v)) h (init ())] reverses the header"
- (List.rev H.(to_list h1))
- H.(to_list prebuilt);
- let h1 = H.(fold rev (fold rev prebuilt (init ())) (init ())) in
- aeh "[fold rev (fold rev h (init ())) (init ()) = h] " h1 prebuilt;
- let count _ _ acc = acc + 1 in
- aei "[fold (fun _ _ acc -> acc+1) h 0] returns the length of h"
- (List.length H.(to_list prebuilt))
- H.(fold count prebuilt 0)
-
-let iter_tests () =
- let h = ref H.(init ()) in
- let rev k v = h := H.(add !h k v) in
- H.(iter rev prebuilt);
- aessl "[iter (fun k v -> href := H.(add !href k v)) h] reverses the header"
- (List.rev H.(to_list !h))
- H.(to_list prebuilt);
- let c = ref 0 in
- let count _ _ = c := !c + 1 in
- aei "[iter (fun _ _ -> count := !count+1) h] works fine"
- (List.length H.(to_list prebuilt))
- (H.(iter count prebuilt);
- !c)
-
-let to_lines_tests () =
- aesl "to_lines h"
- [
- "accept: application/xml\r\n";
- "transfer-encoding: chunked\r\n";
- "accept: text/html\r\n";
- "content-length: 100\r\n";
- ]
- H.(to_lines prebuilt)
-
-let to_frames_tests () =
- aesl "to_frames h"
- [
- "accept: application/xml";
- "transfer-encoding: chunked";
- "accept: text/html";
- "content-length: 100";
- ]
- H.(to_frames prebuilt)
-
-let to_string_tests () =
- aes "to_string h"
- "accept: application/xml\r\n\
- transfer-encoding: chunked\r\n\
- accept: text/html\r\n\
- content-length: 100\r\n\
- \r\n"
- H.(to_string prebuilt)
-
-let many_headers () =
- let size = 1000000 in
- let rec add_header num h =
- match num with
- | 0 -> h
- | n ->
- let k = Printf.sprintf "h%d" n in
- let v = Printf.sprintf "v%d" n in
- let h = H.add h k v in
- add_header (num - 1) h
- in
- let h = add_header size (H.init ()) in
- Alcotest.(check int) "many_headers" (List.length (H.to_list h)) size
-
-let transfer_encoding_tests () =
- let h =
- H.of_list
- [ ("transfer-encoding", "gzip"); ("transfer-encoding", "chunked") ]
- in
- let sh = H.to_string h in
- aes "transfer_encoding_string_is_ordered" sh
- "transfer-encoding: gzip\r\ntransfer-encoding: chunked\r\n\r\n";
- let sh = H.get_multi_concat h "transfer-encoding" in
- aeso "transfer_encoding_get_is_ordered" (Some "gzip,chunked") sh
-
-module String_io = Cohttp__String_io
-module HIO = Cohttp__Header_io.Make (String_io.M)
-
-let large_header () =
- let sz = 1024 * 1024 * 100 in
- let h = H.init () in
- let v1 = String.make sz 'a' in
- let h = H.add h "x-large" v1 in
- let h = H.add h v1 "foo" in
- aeso "x-large" (H.get h "x-large") (Some v1);
- let obuf = Buffer.create (sz + 1024) in
- HIO.write h obuf;
- let ibuf = Buffer.contents obuf in
- let sbuf = String_io.open_in ibuf in
- Alcotest.check t_header "large_header" (HIO.parse sbuf) h
-
-let tests =
- ( "Unitary Header tests",
- [
- ("Header.to_list", `Quick, to_list_tests);
- ("Header.is_empty", `Quick, is_empty_tests);
- ("Header.init_with", `Quick, init_with_tests);
- ("Header.mem", `Quick, mem_tests);
- ("Header.add", `Quick, add_tests);
- ("Header.get", `Quick, get_tests);
- ("Header.add_list", `Quick, add_list_tests);
- ("Header.add_multi", `Quick, add_multi_tests);
- ("Header.add_unless_exists", `Quick, add_unless_exists_tests);
- ("Header.remove", `Quick, remove_tests);
- ("Header.replace", `Quick, replace_tests);
- ("Header.get_multi", `Quick, get_multi_tests);
- ("Header.get_multi_concat", `Quick, get_multi_concat_tests);
- ("Header.to_lines", `Quick, to_lines_tests);
- ("Header.to_frames", `Quick, to_frames_tests);
- ("Header.to_string", `Quick, to_string_tests);
- ("Header.map", `Quick, map_tests);
- ("Header.fold", `Quick, fold_tests);
- ("Header.iter", `Quick, iter_tests);
- ("Header.update", `Quick, update_tests);
- ("Header.update_all", `Quick, update_all_tests);
- ("many headers", `Slow, many_headers);
- ("transfer encoding is in correct order", `Quick, transfer_encoding_tests);
- ]
- @
- if Sys.word_size = 64 then [ ("large header", `Slow, large_header) ] else []
- )
+++ /dev/null
-open Base
-open Async_kernel
-open OUnit
-open Cohttp_async
-
-type 'a io = 'a Deferred.t
-type ic = Async_unix.Reader.t
-type oc = Async_unix.Writer.t
-type body = Body.t
-
-type response_action =
- [ `Expert of Cohttp.Response.t * (ic -> oc -> unit io)
- | `Response of Cohttp.Response.t * body ]
-
-type spec = Request.t -> body -> response_action io
-type async_test = unit -> unit io
-
-let response rsp = `Response rsp
-
-let expert ?(rsp = Cohttp.Response.make ()) f _req _body =
- return (`Expert (rsp, f))
-
-let const rsp _req _body = rsp >>| response
-let response_sequence = Cohttp_test.response_sequence failwith
-
-let get_port =
- let port = ref 10_080 in
- fun () ->
- let v = !port in
- Int.incr port;
- v
-
-let temp_server ?port spec callback =
- let port = match port with None -> get_port () | Some p -> p in
- let uri = Uri.of_string ("http://0.0.0.0:" ^ Int.to_string port) in
- let server =
- Server.create_expert ~on_handler_error:`Raise
- (Async.Tcp.Where_to_listen.of_port port) (fun ~body _sock req ->
- spec req body)
- in
- server >>= fun server ->
- callback uri >>= fun res ->
- Server.close server >>| fun () -> res
-
-let test_server_s ?port ?(name = "Cohttp Server Test") spec f =
- temp_server ?port spec (fun uri ->
- Logs.info (fun m -> m "Test %s running on %s" name (Uri.to_string uri));
- let tests = f uri in
- let results =
- tests
- |> Deferred.List.map ~how:`Sequential ~f:(fun (name, test) ->
- Logs.debug (fun m -> m "Running %s" name);
- let res =
- try_with test >>| function
- | Ok () -> `Ok
- | Error exn -> `Exn exn
- in
- res >>| fun res -> (name, res))
- in
- results >>| fun results ->
- let ounit_tests =
- results
- |> List.map ~f:(fun (name, res) ->
- name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x)
- in
- name >::: ounit_tests)
-
-let run_async_tests test =
- (* enable logging to stdout *)
- Fmt_tty.setup_std_outputs ();
- Logs.set_level @@ Some Logs.Debug;
- Logs.set_reporter (Logs_fmt.reporter ());
- test >>| fun a -> a |> OUnit.run_test_tt_main
+++ /dev/null
-open Async_kernel
-
-include
- Cohttp_test.S
- with type 'a io = 'a Deferred.t
- and type body = Cohttp_async.Body.t
- and type ic = Async_unix.Reader.t
- and type oc = Async_unix.Writer.t
-
-val run_async_tests : OUnit.test io -> OUnit.test_result list Deferred.t
+++ /dev/null
-(library
- (name cohttp_async_test)
- (libraries fmt.tty uri.services async_kernel cohttp_test cohttp-async))
+++ /dev/null
-{
- "name": "ocaml-cohttp",
- "version": "4.0.0",
- "description": "An OCaml library for HTTP clients and servers",
- "repository": "https://github.com/mirage/ocaml-cohttp",
- "license": "ISC",
- "dependencies": {
- "xmlhttprequest": "^1.8.0"
- }
-}
+++ /dev/null
-module Client = Cohttp_lwt_jsoo.Client
-module Js = Js_of_ocaml.Js
-
-let _Promise = Js.Unsafe.global##._Promise
-let ( let* ) = Lwt.( >>= )
-let ( let+ ) = Lwt.( >|= )
-
-let promise_of_lwt lwt =
- new%js _Promise
- (Js.wrap_callback (fun resolve reject ->
- try%lwt
- let+ res = lwt () in
- Js.Unsafe.fun_call resolve [| Js.Unsafe.inject res |]
- with e ->
- let msg = Printexc.to_string e in
- Js.Unsafe.fun_call reject
- [| Js.Unsafe.inject (new%js Js.error_constr (Js.string msg)) |]))
-
-let () =
- Js.export_all
- (object%js
- method request uri =
- let f () =
- let uri = Uri.of_string (Js.to_string uri) in
- let* response, body = Client.get uri in
- let+ body = Cohttp_lwt.Body.to_string body in
- let status =
- Cohttp.Response.status response |> Cohttp.Code.code_of_status
- in
- Js.array
- [| Js.Unsafe.inject status; Js.Unsafe.inject @@ Js.string body |]
- in
- promise_of_lwt f
- end)
+++ /dev/null
-(executable
- (name cohttp_lwt_jsoo_test)
- (modes js)
- (libraries cohttp cohttp-lwt cohttp-lwt-jsoo lwt js_of_ocaml-lwt)
- (preprocess
- (pps lwt_ppx js_of_ocaml-ppx)))
-
-(rule
- (alias runjstest)
- (deps test.js cohttp_lwt_jsoo_test.bc.js)
- (action
- (setenv
- NODE_PATH
- "%{project_root}/cohttp_lwt_jsoo_test/node_modules"
- (run ./test.js))))
+++ /dev/null
-#!/usr/bin/env node
-
-const assert = require('assert');
-
-global.XMLHttpRequest = require("xmlhttprequest").XMLHttpRequest;
-const tests = require('./cohttp_lwt_jsoo_test.bc.js')
-
-async function main() {
- {
- const [status, body] = await tests.request("https://mirage.io");
- assert(status == 200);
- }
- {
- const [status, body] = await tests.request("https://this.domain.does.not.exist");
- assert(status == 0);
- }
-}
-
-main()
+++ /dev/null
-# THIS IS AN AUTOGENERATED FILE. DO NOT EDIT THIS FILE DIRECTLY.
-# yarn lockfile v1
-
-
-xmlhttprequest@^1.8.0:
- version "1.8.0"
- resolved "https://registry.yarnpkg.com/xmlhttprequest/-/xmlhttprequest-1.8.0.tgz#67fe075c5c24fef39f9d65f5f7b7fe75171968fc"
- integrity sha1-Z/4HXFwk/vOfnWX197f+dRcZaPw=
+++ /dev/null
-open Lwt
-open OUnit
-open Cohttp_lwt_unix
-
-type 'a io = 'a Lwt.t
-type ic = Lwt_io.input_channel
-type oc = Lwt_io.output_channel
-type body = Cohttp_lwt.Body.t
-
-type response_action =
- [ `Expert of Cohttp.Response.t * (ic -> oc -> unit io)
- | `Response of Cohttp.Response.t * body ]
-
-type spec = Request.t -> body -> response_action io
-type async_test = unit -> unit Lwt.t
-
-let response rsp = `Response rsp
-
-let expert ?(rsp = Cohttp.Response.make ()) f _req _body =
- return (`Expert (rsp, f))
-
-let const rsp _req _body = rsp >|= response
-let response_sequence = Cohttp_test.response_sequence Lwt.fail_with
-let () = Debug.activate_debug ()
-let () = Logs.set_level (Some Info)
-
-let temp_server ?port spec callback =
- let port = match port with None -> Cohttp_test.next_port () | Some p -> p in
- let server =
- Server.make_response_action ~callback:(fun _ req body -> spec req body) ()
- in
- let uri = Uri.of_string ("http://0.0.0.0:" ^ string_of_int port) in
- let server_failed, server_failed_wake = Lwt.task () in
- let server =
- Lwt.catch
- (fun () -> Server.create ~backlog:40 ~mode:(`TCP (`Port port)) server)
- (function
- | Lwt.Canceled -> Lwt.return_unit
- | x ->
- Lwt.wakeup_exn server_failed_wake x;
- Lwt.fail x)
- in
- Lwt.pick [ callback uri; server_failed ] >|= fun res ->
- Lwt.cancel server;
- res
-
-let test_server_s ?port ?(name = "Cohttp Server Test") spec f =
- temp_server ?port spec (fun uri ->
- Logs.info (fun f -> f "Test %s running on %s" name (Uri.to_string uri));
- let tests = f uri in
- let results =
- tests
- |> Lwt_list.map_s (fun (name, test) ->
- Logs.info (fun f -> f "Running %s" name);
- let res =
- Lwt.try_bind test
- (fun () -> return `Ok)
- (fun exn -> return (`Exn exn))
- in
- res >|= fun res -> (name, res))
- in
- results >|= fun results ->
- let ounit_tests =
- results
- |> List.map (fun (name, res) ->
- name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x)
- in
- name >::: ounit_tests)
-
-let run_async_tests test = test >|= OUnit.run_test_tt_main
+++ /dev/null
-include
- Cohttp_test.S
- with type 'a io = 'a Lwt.t
- and type body = Cohttp_lwt.Body.t
- and type ic = Lwt_io.input_channel
- and type oc = Lwt_io.output_channel
+++ /dev/null
-(library
- (name cohttp_lwt_unix_test)
- (libraries conduit-lwt cohttp-lwt-unix cohttp_test oUnit))
+++ /dev/null
-(*{{{ Copyright (c) 2014-2015 David Sheets <sheets@alum.mit.edu>
- *
- * Permission to use, copy, modify, and distribute this software for any
- * purpose with or without fee is hereby granted, provided that the above
- * copyright notice and this permission notice appear in all copies.
- *
- * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
- * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
- * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
- * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
- * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
- * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
- * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
- *
- }}}*)
-
-(* This module contains I/O agnostic functions used by
- Cohttp_server_lwt and Cohttp_server_async. *)
-
-open Printf
-
-let ( / ) = Filename.concat
-
-let compare_kind = function
- | Some `Directory, Some `Directory -> 0
- | Some `Directory, _ -> -1
- | _, Some `Directory -> 1
- | Some `File, Some `File -> 0
- | Some `File, _ -> 1
- | _, Some `File -> -1
- | _, _ -> 0
-
-let sort lst =
- List.sort
- (fun (ka, _sa, a) (kb, _sb, b) ->
- let c = compare_kind (ka, kb) in
- if c <> 0 then c
- else String.compare (String.lowercase_ascii a) (String.lowercase_ascii b))
- lst
-
-let li ?title l =
- let title =
- match title with None -> "" | Some s -> sprintf "title=\"%s\" " s
- in
- sprintf "<li><a %shref=\"%s\">%s</a></li>" title (Uri.to_string l)
-
-let kind_of_unix_kind =
- Unix.(
- function
- | S_DIR -> `Directory
- | S_REG -> `File
- | S_SOCK -> `Socket
- | S_BLK -> `Block
- | S_FIFO -> `Fifo
- | S_CHR -> `Char
- | S_LNK -> `Link)
-
-let human_size_of_size size =
- let size = Int64.to_float size in
- let kibi = size /. 1024. in
- if kibi < 1. then sprintf "%.0fB" size
- else
- let mibi = kibi /. 1024. in
- if mibi < 1. then sprintf "%.1fKiB" kibi
- else
- let gibi = mibi /. 1024. in
- if gibi < 1. then sprintf "%.1fMiB" mibi else sprintf "%.1fGiB" gibi
-
-let html_of_listing uri path listing info =
- let html =
- List.map
- (fun (kind, size, f) ->
- let encoded_f = Uri.pct_encode f in
- match kind with
- | Some `Directory ->
- let link = Uri.with_path uri (path / encoded_f / "") in
- li link (sprintf "<i>%s/</i>" f)
- | Some `File ->
- let link = Uri.with_path uri (path / encoded_f) in
- li ~title:(human_size_of_size size) link f
- | Some (`Socket | `Block | `Fifo | `Char | `Link) ->
- sprintf "<li><s>%s</s></li>" f
- | None -> sprintf "<li>Error with file: %s</li>" f)
- (sort listing)
- in
- let contents = String.concat "\n" html in
- sprintf
- "<html><body><h2>Directory Listing for <em>%s</em></h2><ul>%s</ul><hr \
- />%s</body></html>"
- (Uri.pct_decode path) contents info
-
-let html_of_forbidden_unnormal path info =
- sprintf
- "<html><body><h2>Forbidden</h2><p><b>%s</b>is not a normal file or \
- directory</p><hr/>%s</body></html>"
- path info
-
-let html_of_not_found path info =
- sprintf
- "<html><body><h2>Not Found</h2><p><b>%s</b>was not found on this \
- server</p><hr />%s</body></html>"
- path info
-
-let html_of_method_not_allowed meth allowed path info =
- sprintf
- "<html><body><h2>Method Not Allowed</h2><p><b>%s</b>is not an allowed \
- method on <b>%s</b></p><p>Allowed methods on <b>%s</b> are \
- <b>%s</b></p><hr />%s</body></html>"
- meth path path allowed info
+++ /dev/null
-(library
- (name cohttp_server)
- (libraries cohttp))
+++ /dev/null
-open Cohttp
-
-module type S = sig
- type 'a io
- type ic
- type oc
- type body
-
- type response_action =
- [ `Expert of Cohttp.Response.t * (ic -> oc -> unit io)
- | `Response of Cohttp.Response.t * body ]
-
- type spec = Request.t -> body -> response_action io
- type async_test = unit -> unit io
-
- val response : Response.t * body -> response_action
- val expert : ?rsp:Cohttp.Response.t -> (ic -> oc -> unit io) -> spec
- val const : (Response.t * body) io -> spec
- val response_sequence : spec list -> spec
- val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io
-
- val test_server_s :
- ?port:int ->
- ?name:string ->
- spec ->
- (Uri.t -> (string * async_test) list) ->
- OUnit.test io
-
- val run_async_tests : OUnit.test io -> OUnit.test_results io
-end
-
-let port = ref 9193
-
-let next_port () =
- let current_port = !port in
- incr port;
- current_port
-
-let response_sequence fail responses =
- let xs = ref responses in
- fun req body ->
- match !xs with
- | x :: xs' ->
- xs := xs';
- x req body
- | [] -> fail "response_sequence: Server exhausted responses"
+++ /dev/null
-open Cohttp
-
-module type S = sig
- type 'a io
- type ic
- type oc
- type body
-
- type response_action =
- [ `Expert of Cohttp.Response.t * (ic -> oc -> unit io)
- | `Response of Cohttp.Response.t * body ]
-
- type spec = Request.t -> body -> response_action io
- (** A server that is being tested must be defined by providing a spec *)
-
- type async_test = unit -> unit io
-
- val response : Response.t * body -> response_action
- val expert : ?rsp:Response.t -> (ic -> oc -> unit io) -> spec
-
- val const : (Response.t * body) io -> spec
- (** A constant handler that always returns its argument *)
-
- val response_sequence : spec list -> spec
- (** A server that process requests using the provided specs in sequence and
- crashes on further reqeusts *)
-
- val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io
- (** Create a temporary server according to spec that lives until the callback
- thread is determined. The uri provided in the callback should be the base
- uri for any requests made to the temp server *)
-
- val test_server_s :
- ?port:int ->
- ?name:string ->
- spec ->
- (Uri.t -> (string * async_test) list) ->
- OUnit.test io
- (** Create a test suite against a server defined by spec. Tests run
- sequentially. *)
-
- val run_async_tests : OUnit.test io -> OUnit.test_results io
- (** Run an async unit test and return and print the result *)
-end
-
-val next_port : unit -> int
-(** Internal API. Subject to breakage *)
-
-val response_sequence :
- (string -> 'a) -> ('b -> 'c -> 'a) list -> 'b -> 'c -> 'a
+++ /dev/null
-(library
- (name cohttp_test)
- (libraries cohttp oUnit))
--- /dev/null
+(dirs :standard \ node_modules)
-(lang dune 2.0)
+(lang dune 3.8)
+
(name cohttp)
-(version v5.0.0-25-g0bb4e19)
+(version v6.0.0)
+
+(license ISC)
+
+(using mdx 0.4)
+
+(cram enable)
+
+(maintainers "Anil Madhavapeddy <anil@recoil.org>")
+
+(authors
+ "Anil Madhavapeddy"
+ "Stefano Zacchiroli"
+ "David Sheets"
+ "Thomas Gazagnaire"
+ "David Scott"
+ "Rudi Grinberg"
+ "Andy Ray"
+ "Anurag Soni")
+
+(source
+ (github mirage/ocaml-cohttp))
+
+(documentation "https://mirage.github.io/ocaml-cohttp/")
+
+(generate_opam_files true)
+
+(package
+ (name cohttp)
+ (synopsis "An OCaml library for HTTP clients and servers")
+ (description
+ "Cohttp is an OCaml library for creating HTTP daemons. It has a portable\nHTTP parser, and implementations using various asynchronous programming\nlibraries.\n\nSee the cohttp-async, cohttp-lwt, cohttp-lwt-unix, cohttp-lwt-jsoo and\ncohttp-mirage libraries for concrete implementations for particular\ntargets.\n\nYou can implement other targets using the parser very easily. Look at the `IO`\nsignature in `lib/s.mli` and implement that in the desired backend.\n\nYou can activate some runtime debugging by setting `COHTTP_DEBUG` to any\nvalue, and all requests and responses will be written to stderr. Further\ndebugging of the connection layer can be obtained by setting `CONDUIT_DEBUG`\nto any value.\n")
+ (depends
+ (http
+ (= :version))
+ (ocaml
+ (>= 4.08))
+ (re
+ (>= 1.9.0))
+ (uri
+ (>= 2.0.0))
+ uri-sexp
+ logs
+ sexplib0
+ (ppx_sexp_conv
+ (>= v0.13.0))
+ stringext
+ (base64
+ (>= 3.1.0))
+ (fmt :with-test)
+ (alcotest (and :with-test (>= 1.7.0)))))
+
+(package
+ (name cohttp-top)
+ (synopsis "CoHTTP toplevel pretty printers for HTTP types")
+ (description
+ "This library installs toplevel prettyprinters for CoHTTP\ntypes such as the `Request`, `Response` and `Types` modules.\nOnce this library has been loaded, you can directly see the\nvalues of those types in toplevels such as `utop` or `ocaml`.\n")
+ (depends
+ (ocaml
+ (>= 4.08))
+ (cohttp
+ (= :version))))
+
+(package
+ (name cohttp-lwt)
+ (synopsis "CoHTTP implementation using the Lwt concurrency library")
+ (description
+ "This is a portable implementation of HTTP that uses the Lwt concurrency library\nto multiplex IO. It implements as much of the logic in an OS-independent way\nas possible, so that more specialised modules can be tailored for different\ntargets. For example, you can install `cohttp-lwt-unix` or `cohttp-lwt-jsoo`\nfor a Unix or JavaScript backend, or `cohttp-mirage` for the MirageOS unikernel\nversion of the library. All of these implementations share the same IO logic\nfrom this module.")
+ (depends
+ (ocaml
+ (>= 4.08))
+ (http
+ (= :version))
+ (cohttp
+ (= :version))
+ (lwt
+ (>= 5.4.0))
+ sexplib0
+ (ppx_sexp_conv
+ (>= v0.13.0))
+ logs
+ (uri
+ (>= 2.0.0))))
+
+(package
+ (name cohttp-lwt-unix)
+ (synopsis "CoHTTP implementation for Unix and Windows using Lwt")
+ (description
+ "An implementation of an HTTP client and server using the Lwt\nconcurrency library. See the `Cohttp_lwt_unix` module for information\non how to use this. The package also installs `cohttp-curl-lwt`\nand a `cohttp-server-lwt` binaries for quick uses of a HTTP(S)\nclient and server respectively.\n\nAlthough the name implies that this only works under Unix, it\nshould also be fine under Windows too.\n")
+ (depends
+ (ocaml
+ (>= 4.08))
+ (http
+ (= :version))
+ (cohttp
+ (= :version))
+ (cohttp-lwt
+ (= :version))
+ (cmdliner
+ (>= 1.1.0))
+ (lwt
+ (>= 3.0.0))
+ (conduit-lwt
+ (>= 5.0.0))
+ (conduit-lwt-unix
+ (>= 5.0.0))
+ (fmt
+ (>= 0.8.2))
+ base-unix
+ (ppx_sexp_conv
+ (>= v0.13.0))
+ magic-mime
+ logs
+ (ounit2 :with-test)))
+
+(package
+ (name cohttp-server-lwt-unix)
+ (synopsis "Lightweight Cohttp + Lwt based HTTP server")
+ (description
+ "This server implementation is faster than cohttp-lwt-unix and is independent of\nconduit.\n")
+ (depends
+ (ocaml
+ (>= 4.08))
+ (http
+ (= :version))
+ (lwt
+ (>= 5.5.0))
+ (conduit-lwt-unix :with-test)
+ (cohttp-lwt-unix
+ (and
+ :with-test
+ (= :version)))
+ (cohttp-lwt
+ (and
+ :with-test
+ (= :version)))
+ lwt))
+
+(package
+ (name cohttp-lwt-jsoo)
+ (synopsis "CoHTTP implementation for the Js_of_ocaml JavaScript compiler")
+ (description
+ "An implementation of an HTTP client for JavaScript, but using the\nCoHTTP types. This lets you build HTTP clients that can compile\nnatively (using one of the other Cohttp backends such as `cohttp-lwt-unix`)\nand also to native JavaScript via js_of_ocaml.\n")
+ (depends
+ (ocaml
+ (>= 4.08))
+ (http
+ (= :version))
+ (cohttp
+ (= :version))
+ (cohttp-lwt
+ (= :version))
+ logs
+ (lwt
+ (>= 3.0.0))
+ (lwt_ppx :with-test)
+ (conf-npm :with-test)
+ (js_of_ocaml
+ (>= 3.3.0))
+ (js_of_ocaml-ppx
+ (>= 3.3.0))
+ (js_of_ocaml-lwt
+ (>= 3.5.0))))
+
+(package
+ (name cohttp-async)
+ (synopsis "CoHTTP implementation for the Async concurrency library")
+ (description
+ "An implementation of an HTTP client and server using the Async\nconcurrency library. See the `Cohttp_async` module for information\non how to use this. The package also installs `cohttp-curl-async`\nand a `cohttp-server-async` binaries for quick uses of a HTTP(S)\nclient and server respectively.\n")
+ (depends
+ (ocaml
+ (>= 4.14))
+ (http
+ (= :version))
+ (cohttp
+ (= :version))
+ (async_kernel
+ (>= v0.16.0))
+ (async_unix
+ (>= v0.16.0))
+ (async
+ (>= v0.16.0))
+ (base
+ (>= v0.16.0))
+ (core :with-test)
+ (core_unix
+ (>= v0.14.0))
+ (conduit-async
+ (>= 1.2.0))
+ magic-mime
+ (digestif :with-test)
+ logs
+ (fmt
+ (>= 0.8.2))
+ sexplib0
+ (ppx_sexp_conv
+ (>= v0.13.0))
+ (ounit2 :with-test)
+ (uri
+ (>= 2.0.0))
+ uri-sexp
+ ipaddr))
+
+(package
+ (name cohttp-mirage)
+ (synopsis "CoHTTP implementation for the MirageOS unikernel")
+ (description
+ "This HTTP implementation uses the Cohttp portable implementation\nalong with the Lwt threading library in order to provide a\n`Cohttp_mirage` functor that can be used in MirageOS unikernels\nto build very small and efficient HTTP clients and servers\nwithout having a hard dependency on an underlying operating\nsystem.\n\nPlease see <https://mirage.io> for a self-hosted explanation\nand instructions on how to use this library.")
+ (depends
+ (ocaml
+ (>= 4.08))
+ (mirage-flow
+ (>= 2.0.0))
+ (mirage-channel
+ (>= 4.0.0))
+ (conduit
+ (>= 2.0.2))
+ (conduit-mirage
+ (>= 2.3.0))
+ (mirage-kv
+ (>= 3.0.0))
+ (lwt
+ (>= 2.4.3))
+ (cohttp-lwt
+ (= :version))
+ (cstruct
+ (>= 6.0.0))
+ (fmt
+ (>= 0.8.7))
+ astring
+ magic-mime
+ (ppx_sexp_conv
+ (>= v0.13.0))
+ (cohttp
+ (= :version))))
+
+(package
+ (name http)
+ (synopsis "Type definitions of HTTP essentials")
+ (description
+ "This package contains essential type definitions used in Cohttp. It is designed\nto have no dependencies and make it easy for other packages to easily\ninteroperate with Cohttp.")
+ (depends
+ (ocaml
+ (>= 4.08))
+ (ppx_expect (and :with-test (>= v0.17.0)))
+ (alcotest (and :with-test (>= 1.7.0)))
+ (base_quickcheck :with-test)
+ (ppx_assert :with-test)
+ (ppx_sexp_conv :with-test)
+ (ppx_compare :with-test)
+ (ppx_here :with-test)
+ (crowbar
+ (and
+ :with-test
+ (>= 0.2)))
+ (sexplib0 :with-test)))
+
+(package
+ (name cohttp-curl)
+ (synopsis "Shared code between the individual cohttp-curl clients")
+ (description "Use cohttp-curl-lwt or cohttp-curl-async")
+ (depends
+ (ocaml
+ (>= 4.08))
+ (ocurl (>= 0.9.2))
+ (http
+ (= :version))
+ stringext))
+
+(package
+ (name cohttp-curl-lwt)
+ (synopsis "Cohttp client using Curl & Lwt as the backend")
+ (description
+ "An HTTP client that relies on Curl + Lwt for the backend. Does not require\nconduit for SSL.")
+ (depends
+ (ocaml
+ (>= 4.08))
+ (ocurl (>= 0.9.2))
+ (http
+ (= :version))
+ (cohttp-curl
+ (= :version))
+ stringext
+ (lwt
+ (>= 5.3.0))
+ (uri
+ (and
+ :with-test
+ (>= 4.2.0)))
+ (alcotest (and :with-test (>= 1.7.0)))
+ (cohttp-lwt-unix
+ (and
+ :with-test
+ (= :version)))
+ (cohttp
+ (and
+ :with-test
+ (= :version)))
+ (cohttp-lwt
+ (and
+ :with-test
+ (= :version)))
+ (conduit-lwt :with-test)
+ (ounit2 :with-test)))
+
+(package
+ (name cohttp-curl-async)
+ (allow_empty)
+ (synopsis "Cohttp client using Curl & Async as the backend")
+ (description
+ "An HTTP client that relies on Curl + Async for the backend. Does not require\nconduit for SSL.")
+ (depends
+ (ocurl (>= 0.9.2))
+ (http
+ (= :version))
+ stringext
+ (cohttp-curl
+ (= :version))
+ (core
+ (>= v0.16.0))
+ (core_unix
+ (>= v0.14.0))
+ (core_kernel :with-test)
+ (async_kernel (and :with-test (>= v0.17.0)))
+ (async_unix :with-test)
+ (cohttp-async
+ (and
+ :with-test
+ (= :version)))
+ (uri
+ (and
+ :with-test
+ (>= 4.2.0)))
+ (fmt :with-test)
+ (ounit2 :with-test)
+ (alcotest (and :with-test (>= 1.7.0)))))
+
+(package
+ (name cohttp-bench)
+ (allow_empty)
+ (synopsis "Benchmarks binaries for Cohttp")
+ (description
+ "This package contains some benchmarks for http and cohttp.\nThe benchmarks for the server latency will require wrk2\n(https://github.com/giltene/wrk2) to run. The latency graphs\ncan then be generated with HdrHistogram plotter, also available\nonline at https://hdrhistogram.github.io/HdrHistogram/plotFiles.html.")
+ (depends
+ (core
+ (>= v0.13.0))
+ core_bench
+ (eio
+ (>= 0.12))
+ eio_main
+ (http
+ (= :version))
+ (cohttp
+ (= :version))
+ (cohttp-eio
+ (= :version))
+ (cohttp-lwt-unix
+ (= :version))
+ (cohttp-server-lwt-unix
+ (= :version))
+ (cohttp-async
+ (= :version))))
+
+(package
+ (name cohttp-eio)
+ (synopsis "CoHTTP implementation with eio backend")
+ (description
+ "A CoHTTP server and client implementation based on `eio` library. `cohttp-eio`features a multicore capable HTTP 1.1 server. The library promotes and is built with direct style of coding as opposed to a monadic.")
+ (depends
+ (alcotest (and :with-test (>= 1.7.0)))
+ base-domains
+ (cohttp
+ (= :version))
+ (eio
+ (>= 0.12))
+ (eio_main :with-test)
+ (mdx :with-test)
+ logs
+ uri
+ (tls-eio (and :with-test (>= 1.0.0)))
+ (mirage-crypto-rng-eio (and :with-test (>= 0.11.2)))
+ (ca-certs (and :with-test (>= "1.0.0")))
+ fmt
+ ptime
+ (http
+ (= :version))
+ (ppx_here :with-test)))
+++ /dev/null
-(executables
- (names hello_world receive_post s3_cp)
- (libraries mirage-crypto cohttp-async base async_kernel core_unix.command_unix))
-
-(alias
- (name runtest)
- (package cohttp-async)
- (deps hello_world.exe receive_post.exe))
+++ /dev/null
-(* This file is in the public domain *)
-
-open Base
-open Async_kernel
-open Cohttp_async
-
-(* given filename: hello_world.ml compile with:
- $ corebuild hello_world.native -pkg cohttp.async
-*)
-
-let handler ~body:_ _sock req =
- let uri = Cohttp.Request.uri req in
- match Uri.path uri with
- | "/test" ->
- Uri.get_query_param uri "hello"
- |> Option.map ~f:(fun v -> "hello: " ^ v)
- |> Option.value ~default:"No param hello supplied"
- |> Server.respond_string
- | _ -> Server.respond_string ~status:`Not_found "Route not found"
-
-let start_server port () =
- Stdlib.Printf.eprintf "Listening for HTTP on port %d\n" port;
- Stdlib.Printf.eprintf "Try 'curl http://localhost:%d/test?hello=xyz'\n%!" port;
- Cohttp_async.Server.create ~on_handler_error:`Raise
- (Async.Tcp.Where_to_listen.of_port port)
- handler
- >>= fun _ -> Deferred.never ()
-
-let () =
- let module Command = Async_command in
- Command.async_spec ~summary:"Start a hello world Async server"
- Command.Spec.(
- empty
- +> flag "-p"
- (optional_with_default 8080 int)
- ~doc:"int Source port to listen on")
- start_server
- |> Command_unix.run
+++ /dev/null
-(* This file is in the public domain *)
-open Base
-open Async_kernel
-open Cohttp_async
-
-(* compile with: $ corebuild receive_post.native -pkg cohttp.async *)
-
-let start_server port () =
- Stdlib.Printf.eprintf "Listening for HTTP on port %d\n" port;
- Stdlib.Printf.eprintf "Try 'curl -X POST -d 'foo bar' http://localhost:%d\n"
- port;
- Cohttp_async.Server.create ~on_handler_error:`Raise
- (Async.Tcp.Where_to_listen.of_port port) (fun ~body _ req ->
- match req |> Cohttp.Request.meth with
- | `POST ->
- Body.to_string body >>= fun body ->
- Stdlib.Printf.eprintf "Body: %s" body;
- Server.respond `OK
- | _ -> Server.respond `Method_not_allowed)
- >>= fun _ -> Deferred.never ()
-
-let () =
- let module Command = Async_command in
- Command.async_spec ~summary:"Simple http server that outputs body of POST's"
- Command.Spec.(
- empty
- +> flag "-p"
- (optional_with_default 8080 int)
- ~doc:"int Source port to listen on")
- start_server
- |> Command_unix.run
+++ /dev/null
-(*{{{ Copyright (C) 2015 Trevor Smith <trevorsummerssmith@gmail.com>
- *
- * Permission to use, copy, modify, and distribute this software for any
- * purpose with or without fee is hereby granted, provided that the above
- * copyright notice and this permission notice appear in all copies.
- *
- * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
- * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
- * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
- * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
- * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
- * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
- * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
- *
- }}}*)
-
-(** This example is here to show how to get and put to s3 using the async client
- code.
-
- This hopes to be a useful example because: 1) it is a real world use of the
- client 2) s3 auth requires a bit of fiddling with the headers hopefully this
- is illustative for anyone else doing the same
-
- The reader will want to be familiar with the S3 API Documentation found
- here: http://docs.aws.amazon.com/AmazonS3/latest/API/Welcome.html This
- example was written using the API Version 2006-03-01.
-
- There are two ways to authenticate with S3, this example uses the
- authorization header approach (p. 19 of the api reference).
-
- Downloads from S3 are done using the GET method, and uploads are done using
- the PUT method.
-
- To get this to work, you'll need an AWS access/secret key pair that has the
- "s3:GetObject" and "s3:PutObject" permissions enabled for the bucket you are
- interacting with.
-
- As this is an example, straightforwardness is prized. One should not use
- this for a production system, nor assume that it offers a good example of
- abstraction, interface design or error handling. *)
-
-open Base
-open Core
-open Async
-open Cohttp
-open Cohttp_async
-
-module Time = Time_float
-
-let ksrt (k, _) (k', _) = String.compare k k'
-
-module Compat = struct
- (** Things we need to make this happen that, ideally, we'd like other
- libraries to provide and that are orthogonal to the example here *)
-
- let encode_string s =
- (* Percent encode the path as s3 wants it. Uri doesn't
- encode $, or the other sep characters in a path.
- If upstream allows that we can nix this function *)
- let n = String.length s in
- let buf = Buffer.create (n * 3) in
- for i = 0 to n - 1 do
- let c = s.[i] in
- match c with
- | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' | '~' | '.' | '/' ->
- Buffer.add_char buf c
- | '%' ->
- (* Sigh. Annoying we're expecting already escaped strings so ignore the escapes *)
- let is_hex = function
- | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> true
- | _ -> false
- in
- if i + 2 < n then
- if is_hex s.[i + 1] && is_hex s.[i + 2] then Buffer.add_char buf c
- else Buffer.add_string buf "%25"
- | _ -> Buffer.add_string buf (Printf.sprintf "%%%X" (Char.to_int c))
- done;
- Buffer.contents buf
-
- let hexa = "0123456789abcdef"
-
- let of_char c =
- let x = Char.to_int c in
- (hexa.[x lsr 4], hexa.[x land 0xf])
-
- let cstruct_to_hex_string cs =
- let open Cstruct in
- let n = cs.len in
- let buf = Buffer.create (n * 2) in
- for i = 0 to n - 1 do
- let c = cs.buffer.{cs.off + i} in
- let x, y = of_char c in
- Buffer.add_char buf x;
- Buffer.add_char buf y
- done;
- Buffer.contents buf
-
- let encode_query_string uri =
- (* Sort and encode query string.
- Note that AWS wants null keys to have '=' for all keys.
- URI.encoded_of_query encodes [""] as ?a=, and [] as ?a.
- *)
- Uri.query uri
- |> List.sort ~compare:ksrt
- |> List.map ~f:(fun (k, v) -> (k, match v with [] -> [ "" ] | x -> x))
- |> Uri.encoded_of_query
-
- let format_time t =
- (* Core.Std.Time doesn't have a format function that takes a timezone *)
- let d, s = Time.to_date_ofday ~zone:Time.Zone.utc t in
- let open Time.Span.Parts in
- let { hr; min; sec; _ } = Time.Ofday.to_parts s in
- Printf.sprintf "%sT%.2d%.2d%.2dZ"
- (Date.to_string_iso8601_basic d)
- hr min sec
-end
-
-type region =
- [ `Ap_northeast_1 (* Asia Pacific (Tokyo) *)
- | `Ap_southeast_1 (* Asia Pacific (Singapore) *)
- | `Ap_southeast_2 (* Asia Pacific (Sydney) *)
- | `Eu_central_1 (* EU (Frankfurt) *)
- | `Eu_west_1 (* EU (Ireland) *)
- | `Sa_east_1 (* South America (Sao Paulo) *)
- | `Us_east_1 (* US East (N. Virginia) *)
- | `Us_west_1 (* US West (N. California) *)
- | `Us_west_2 (* US West (Oregon) *) ]
-[@@deriving sexp]
-
-let region_of_string = function
- | "ap-northeast-1" -> `Ap_northeast_1
- | "ap-southeast-1" -> `Ap_southeast_1
- | "ap-southeast-2" -> `Ap_southeast_2
- | "eu-central-1" -> `Eu_central_1
- | "eu-west-1" -> `Eu_west_1
- | "sa-east-1" -> `Sa_east_1
- | "us-east-1" -> `Us_east_1
- | "us-west-1" -> `Us_west_1
- | "us-west-2" -> `Us_west_2
- | s -> raise (Invalid_argument ("region_of_string: " ^ s))
-
-let string_of_region = function
- | `Ap_northeast_1 -> "ap-northeast-1"
- | `Ap_southeast_1 -> "ap-southeast-1"
- | `Ap_southeast_2 -> "ap-southeast-2"
- | `Eu_central_1 -> "eu-central-1"
- | `Eu_west_1 -> "eu-west-1"
- | `Sa_east_1 -> "sa-east-1"
- | `Us_east_1 -> "us-east-1"
- | `Us_west_1 -> "us-west-1"
- | `Us_west_2 -> "us-west-2"
-
-let region_host_string = function
- | `Ap_northeast_1 -> "s3-ap-northeast-1.amazonaws.com"
- | `Ap_southeast_1 -> "s3-ap-southeast-1.amazonaws.com"
- | `Ap_southeast_2 -> "s3-ap-southeast-2.amazonaws.com"
- | `Eu_central_1 -> "s3-eu-central-1.amazonaws.com"
- | `Eu_west_1 -> "s3-eu-west-1.amazonaws.com"
- | `Sa_east_1 -> "s3-sa-east-1.amazonaws.com"
- | `Us_east_1 -> "s3.amazonaws.com"
- | `Us_west_1 -> "s3-us-west-1.amazonaws.com"
- | `Us_west_2 -> "s3-us-west-2.amazonaws.com"
-
-type service = [ `S3 ] [@@deriving sexp]
-
-let string_of_service = function `S3 -> "s3"
-
-module Auth = struct
- (** AWS S3 Authorization *)
-
- let digest s =
- (* string -> sha256 as a hex string *)
- Mirage_crypto.Hash.(digest `SHA256 (Cstruct.of_string s))
- |> Compat.cstruct_to_hex_string
-
- let make_amz_headers ?body time =
- (* Return x-amz-date and x-amz-sha256 headers *)
- let hashed_payload =
- match body with
- | None ->
- "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
- | Some s -> digest s
- in
- ( [
- ("x-amz-content-sha256", hashed_payload);
- ("x-amz-date", Compat.format_time time);
- ],
- hashed_payload )
-
- let canonical_request hashed_payload (request : Cohttp_async.Request.t) =
- (* This corresponds to p.21 of the s3 api doc
- we're making:
- <HTTPMethod>\n
- <CanonicalURI>\n
- <CanonicalQueryString>\n
- <CanonicalHeaders>\n
- <SignedHeaders>\n
- <HashedPayload>
- *)
- let open Cohttp.Request in
- let http_method = Code.string_of_method request.meth in
- (* Nb the path will be url encoded as per spec *)
- let uri = Cohttp.Request.uri request in
- let canoncical_uri = Compat.encode_string (Uri.path uri) in
- (* Sort query string in alphabetical order by key *)
- let canonical_query = Compat.encode_query_string uri in
- let sorted_headers =
- Header.to_list request.headers |> List.sort ~compare:ksrt
- in
- let canonical_headers =
- sorted_headers
- |> List.fold ~init:"" ~f:(fun acc (k, v) ->
- acc
- ^ Printf.sprintf "%s:%s\n" (String.lowercase k) (String.strip v))
- in
- let signed_headers =
- sorted_headers |> List.map ~f:(fun (k, _) -> k) |> String.concat ~sep:";"
- in
- ( Printf.sprintf "%s\n%s\n%s\n%s\n%s\n%s" http_method canoncical_uri
- canonical_query canonical_headers signed_headers hashed_payload,
- signed_headers )
-
- let string_to_sign ?time ~scope ~service canonical_request : string =
- (* As per p. 23 of s3 api doc. The requests need current time in utc
- time parameter is there for testing. *)
- let time_str =
- match time with
- | None -> Time.to_string_abs ~zone:Time.Zone.utc (Time.now ())
- | Some t -> Compat.format_time t
- in
- let scope_date, scope_region = scope in
- let scope_str =
- Printf.sprintf "%s/%s/%s/aws4_request"
- (Date.to_string_iso8601_basic scope_date)
- (string_of_region scope_region)
- (string_of_service service)
- in
- let hashed_req = digest canonical_request in
- Printf.sprintf "AWS4-HMAC-SHA256\n%s\n%s\n%s" time_str scope_str hashed_req
-
- let make_signing_key ?date ~region ~service ~secret_access_key () =
- let mac k v =
- Mirage_crypto.Hash.(mac `SHA256 ~key:k (Cstruct.of_string v))
- in
- let date' =
- match date with None -> Date.today ~zone:Time.Zone.utc | Some d -> d
- in
- let date_str = Date.to_string_iso8601_basic date' in
- let date_key =
- mac (Cstruct.of_string ("AWS4" ^ secret_access_key)) date_str
- in
- let date_region_key = mac date_key (string_of_region region) in
- let date_region_service_key =
- mac date_region_key (string_of_service service)
- in
- let signing_key = mac date_region_service_key "aws4_request" in
- signing_key
-
- let auth_request ?now ~hashed_payload ~region ~service ~aws_access_key
- ~aws_secret_key request =
- (* Important use the same time for everything here *)
- let time = Option.value ~default:(Time.now ()) now in
- let date = Time.to_date ~zone:Time.Zone.utc time in
- let canonical_request, signed_headers =
- canonical_request hashed_payload request
- in
- let string_to_sign =
- string_to_sign ~time ~scope:(date, region) ~service canonical_request
- in
- let signing_key =
- make_signing_key ~date ~region ~service ~secret_access_key:aws_secret_key
- ()
- in
- let creds =
- Printf.sprintf "%s/%s/%s/%s/aws4_request" aws_access_key
- (Date.to_string_iso8601_basic date)
- (string_of_region region)
- (string_of_service service)
- in
- let signature =
- Mirage_crypto.Hash.(
- mac `SHA256 ~key:signing_key (Cstruct.of_string string_to_sign))
- in
- let auth_header =
- Printf.sprintf
- "AWS4-HMAC-SHA256 Credential=%s,SignedHeaders=%s,Signature=%s" creds
- signed_headers
- (Compat.cstruct_to_hex_string signature)
- in
- [ ("Authorization", auth_header) ]
-end
-
-module S3 = struct
- type conf = {
- region : region;
- aws_access_key : string;
- aws_secret_key : string;
- }
- [@@deriving sexp]
-
- let make_request ?body conf ~meth ~bucket ~objekt =
- let host_str = region_host_string conf.region in
- let uri =
- Printf.sprintf "https://%s/%s/%s" host_str bucket objekt |> Uri.of_string
- in
- let time = Time.now () in
- (* If PUT add content length *)
- let headers =
- match meth with
- | `PUT ->
- let length = Option.value_map ~f:String.length ~default:0 body in
- [ ("Content-length", Int.to_string length) ]
- | _ -> []
- in
- let headers = headers @ [ ("Host", host_str) ] in
- let amz_headers, hashed_payload = Auth.make_amz_headers time ?body in
- let headers = headers @ amz_headers in
- let request = Request.make ~meth ~headers:(Header.of_list headers) uri in
- let auth_header =
- Auth.auth_request ~now:time ~hashed_payload ~region:conf.region
- ~service:`S3 ~aws_access_key:conf.aws_access_key
- ~aws_secret_key:conf.aws_secret_key request
- in
- let headers = headers @ auth_header |> Header.of_list in
- let request = { request with Cohttp.Request.headers } in
- match meth with
- | `PUT ->
- Client.request
- ~body:(Option.value_map ~f:Body.of_string ~default:`Empty body)
- request
- | `GET -> Client.request request
- | _ -> failwith "not possible right now"
-end
-
-type s3path = { bucket : string; objekt : string }
-type cmd = S3toLocal of s3path * string | LocaltoS3 of string * s3path
-
-let determine_s3_parts s =
- (* Takes: string of the form s3://<bucket>/<object> *)
- let s = String.drop_prefix s 5 in
- let parts = String.split ~on:'/' s in
- match parts with
- | bucket :: rst -> { bucket; objekt = String.concat ~sep:"/" rst }
- | _ -> failwith "error format must be 's3://<bucket>/<object>'"
-
-let determine_paths src dst =
- let is_s3 s = String.is_prefix ~prefix:"s3://" s in
- match (is_s3 src, is_s3 dst) with
- | true, false -> S3toLocal (determine_s3_parts src, dst)
- | false, true -> LocaltoS3 (src, determine_s3_parts dst)
- | false, false -> failwith "Use cp(1) :)"
- | true, true -> failwith "Does not support copying from s3 to s3"
-
-let main region_str aws_access_key aws_secret_key src dst () =
- (* nb client does not support redirects or preflight 100 *)
- let open S3 in
- let region = region_of_string region_str in
- let conf = { region; aws_access_key; aws_secret_key } in
- match determine_paths src dst with
- | S3toLocal (src, dst) -> (
- make_request conf ~meth:`GET ~bucket:src.bucket ~objekt:src.objekt
- >>= fun (resp, body) ->
- match Cohttp.Response.(resp.status) with
- | #Code.success_status ->
- Body.to_string body >>| fun s ->
- Out_channel.with_file
- ~f:(fun oc -> Out_channel.output_string oc s)
- dst;
- Core.Printf.printf "Wrote s3://%s to %s\n" (src.bucket ^ src.objekt)
- dst
- | _ ->
- Core.Printf.printf "Error: %s\n"
- (Sexp.to_string (Response.sexp_of_t resp));
- return ())
- | LocaltoS3 (src, dst) -> (
- let body =
- In_channel.with_file src ~f:(fun ic -> In_channel.input_all ic)
- in
- make_request ~body conf ~meth:`PUT ~bucket:dst.bucket ~objekt:dst.objekt
- >>= fun (resp, body) ->
- match Cohttp.Response.status resp with
- | #Code.success_status ->
- Core.Printf.printf "Wrote %s to s3://%s\n" src
- (dst.bucket ^ dst.objekt);
- return ()
- | _ ->
- Body.to_string body >>| fun s ->
- Core.Printf.printf "Error: %s\n%s\n"
- (Sexp.to_string (Response.sexp_of_t resp))
- s)
-
-let () =
- let open Async_command in
- async_spec ~summary:"Simple command line client that copies files to/from S3"
- Spec.(
- empty
- +> flag "-r"
- (optional_with_default "us-east-1" string)
- ~doc:"string AWS Region"
- +> anon ("aws_access_key" %: string)
- +> anon ("aws_secret_key" %: string)
- +> anon ("src" %: string)
- +> anon ("dst" %: string))
- main
- |> Command_unix.run
+++ /dev/null
-open Lwt
-open Cohttp
-open Cohttp_lwt_unix
-
-let body =
- Client.get (Uri.of_string "https://www.reddit.com/") >>= fun (resp, body) ->
- let code = resp |> Response.status |> Code.code_of_status in
- Printf.printf "Response code: %d\n" code;
- Printf.printf "Headers: %s\n" (resp |> Response.headers |> Header.to_string);
- body |> Cohttp_lwt.Body.to_string >|= fun body ->
- Printf.printf "Body of length: %d\n" (String.length body);
- body
-
-let () =
- let body = Lwt_main.run body in
- print_endline ("Received body\n" ^ body)
+++ /dev/null
-open Lwt
-open Cohttp
-open Cohttp_lwt_unix
-
-let compute ~time ~f =
- Lwt.pick
- [
- (f () >|= fun v -> `Done v); (Lwt_unix.sleep time >|= fun () -> `Timeout);
- ]
-
-let body =
- let get () = Client.get (Uri.of_string "https://www.reddit.com/") in
- compute ~time:0.1 ~f:get >>= function
- | `Timeout -> Lwt.fail_with "Timeout expired"
- | `Done (resp, body) ->
- let code = resp |> Response.status |> Code.code_of_status in
- Printf.printf "Response code: %d\n" code;
- Printf.printf "Headers: %s\n"
- (resp |> Response.headers |> Header.to_string);
- body |> Cohttp_lwt.Body.to_string >|= fun body ->
- Printf.printf "Body of length: %d\n" (String.length body);
- body
-
-let () =
- let body = Lwt_main.run body in
- print_endline ("Received body\n" ^ body)
+++ /dev/null
-open Lwt.Infix
-open Cohttp_lwt_unix
-
-let ctx =
- let resolver =
- let h = Hashtbl.create 1 in
- Hashtbl.add h "docker" (`Unix_domain_socket "/var/run/docker.sock");
- Resolver_lwt_unix.static h
- in
- Cohttp_lwt_unix.Client.custom_ctx ~resolver ()
-
-let t =
- Client.get (Uri.of_string "http://docker/version") >>= fun (resp, body) ->
- let open Cohttp in
- let code = resp |> Response.status |> Code.code_of_status in
- Printf.printf "Response code: %d\n" code;
- Printf.printf "Headers: %s\n" (resp |> Response.headers |> Header.to_string);
- body |> Cohttp_lwt.Body.to_string >|= fun body ->
- Printf.printf "Body of length: %d\n" (String.length body);
- print_endline ("Received body\n" ^ body)
-
-let _ = Lwt_main.run t
+++ /dev/null
-(executables
- (names client_lwt client_lwt_timeout docker_lwt server_lwt)
- (libraries cohttp-lwt-unix))
-
-(alias
- (name runtest)
- (package cohttp-lwt-unix)
- (deps client_lwt.exe client_lwt_timeout.exe docker_lwt.exe server_lwt.exe))
+++ /dev/null
-open Lwt
-open Cohttp
-open Cohttp_lwt_unix
-
-let server =
- let callback _conn req body =
- let uri = req |> Request.uri |> Uri.to_string in
- let meth = req |> Request.meth |> Code.string_of_method in
- let headers = req |> Request.headers |> Header.to_string in
- ( body |> Cohttp_lwt.Body.to_string >|= fun body ->
- Printf.sprintf "Uri: %s\nMethod: %s\nHeaders\nHeaders: %s\nBody: %s" uri
- meth headers body )
- >>= fun body -> Server.respond_string ~status:`OK ~body ()
- in
- Server.create ~mode:(`TCP (`Port 8000)) (Server.make ~callback ())
-
-let () = ignore (Lwt_main.run server)
--- /dev/null
+{
+ "nodes": {
+ "flake-utils": {
+ "inputs": {
+ "systems": "systems"
+ },
+ "locked": {
+ "lastModified": 1710146030,
+ "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "flake-utils_2": {
+ "inputs": {
+ "systems": "systems_2"
+ },
+ "locked": {
+ "lastModified": 1710146030,
+ "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "nixpkgs": {
+ "inputs": {
+ "flake-utils": "flake-utils_2",
+ "nixpkgs": "nixpkgs_2"
+ },
+ "locked": {
+ "lastModified": 1725916231,
+ "narHash": "sha256-kaU41Z43Uv2As0Sor8FPACJfWjkbUsWnZMtbCgqicvU=",
+ "owner": "nix-ocaml",
+ "repo": "nix-overlays",
+ "rev": "d63aa7b62251c70bbf0a28a67c30555077a2b758",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-ocaml",
+ "repo": "nix-overlays",
+ "type": "github"
+ }
+ },
+ "nixpkgs_2": {
+ "locked": {
+ "lastModified": 1725857262,
+ "narHash": "sha256-m9n0PncgZepVgmjOO1rfVXMgUACDOwZbhjSRjJ/NUpM=",
+ "owner": "NixOS",
+ "repo": "nixpkgs",
+ "rev": "5af6aefbcc55670e36663fd1f8a796e1e323001a",
+ "type": "github"
+ },
+ "original": {
+ "owner": "NixOS",
+ "repo": "nixpkgs",
+ "rev": "5af6aefbcc55670e36663fd1f8a796e1e323001a",
+ "type": "github"
+ }
+ },
+ "root": {
+ "inputs": {
+ "flake-utils": "flake-utils",
+ "nixpkgs": "nixpkgs"
+ }
+ },
+ "systems": {
+ "locked": {
+ "lastModified": 1681028828,
+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+ "owner": "nix-systems",
+ "repo": "default",
+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-systems",
+ "repo": "default",
+ "type": "github"
+ }
+ },
+ "systems_2": {
+ "locked": {
+ "lastModified": 1681028828,
+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+ "owner": "nix-systems",
+ "repo": "default",
+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-systems",
+ "repo": "default",
+ "type": "github"
+ }
+ }
+ },
+ "root": "root",
+ "version": 7
+}
--- /dev/null
+{
+ description = "Cohttp Nix Flake";
+
+ inputs.flake-utils.url = "github:numtide/flake-utils";
+ inputs.nixpkgs.url = "github:nix-ocaml/nix-overlays";
+
+ outputs = { self, nixpkgs, flake-utils }:
+ flake-utils.lib.eachDefaultSystem (system:
+ let
+ pkgs = (import nixpkgs {
+ inherit system;
+ overlays = [
+ (final: prev: {
+ ocamlPackages = prev.ocamlPackages.overrideScope' (oself: osuper: {
+ ctypes-foreign = osuper.ctypes-foreign.overrideAttrs (_: { doCheck = false; });
+ ctypes = osuper.ctypes.overrideAttrs (_: { doCheck = false; });
+ mdx = osuper.mdx.override {
+ # workaround for:
+ # https://github.com/NixOS/nixpkgs/pull/241476/commits/1ed74f3536d29e5635d7f47a1d7b82a89f5a8077
+ logs = oself.logs;
+ };
+ });
+ })
+ ];
+ });
+ inherit (pkgs.ocamlPackages) buildDunePackage;
+ pkg = attrs: buildDunePackage ({
+ version = "n/a";
+ src = ./. ;
+ duneVersion = "3";
+ doCheck = true;
+ } // attrs);
+ ocamlformat = pkgs.ocamlformat_0_26_2;
+ in
+ with pkgs.ocamlPackages; rec {
+ packages = rec {
+ default = http;
+ http = pkg {
+ pname = "http";
+ checkInputs = [ alcotest base_quickcheck ppx_expect crowbar ];
+ };
+ cohttp = pkg {
+ pname = "cohttp";
+ checkInputs = [ fmt alcotest ];
+ propagatedBuildInputs = [
+ stringext http re uri uri-sexp logs sexplib0 ppx_sexp_conv
+ ];
+ };
+ cohttp-top = pkg {
+ pname = "cohttp-top";
+ propagatedBuildInputs = [ cohttp ];
+ };
+ cohttp-curl = pkg {
+ pname = "cohttp-curl";
+ propagatedBuildInputs = [ ocurl http stringext ];
+ };
+ cohttp-curl-lwt = pkg {
+ pname = "cohttp-curl-lwt";
+ checkInputs = [ cohttp-lwt-unix cohttp cohttp-lwt conduit-lwt ounit2 uri ];
+ propagatedBuildInputs = [ ocurl http stringext lwt ];
+ };
+ cohttp-curl-async = pkg {
+ pname = "cohttp-curl-async";
+ checkInputs = [ uri fmt ounit2 alcotest cohttp-async ];
+ propagatedBuildInputs = [
+ ocurl http stringext cohttp-curl core core_unix
+ async_kernel async_unix
+ ];
+ };
+ cohttp-lwt = pkg {
+ pname = "cohttp-lwt";
+ propagatedBuildInputs = [ http cohttp lwt sexplib0 ppx_sexp_conv logs uri ];
+ };
+ cohttp-lwt-jsoo = pkg {
+ pname = "cohttp-lwt-jsoo";
+ propagatedBuildInputs = [
+ http cohttp cohttp-lwt logs lwt lwt_ppx js_of_ocaml
+ js_of_ocaml-ppx js_of_ocaml-lwt
+ ];
+ };
+ cohttp-async = pkg {
+ pname = "cohttp-async";
+ checkInputs = [ mirage-crypto ounit2 ];
+ propagatedBuildInputs = [
+ http cohttp async_kernel async_unix async base core core_unix
+ conduit-async magic-mime logs fmt sexplib0 ppx_sexp_conv uri
+ uri-sexp ipaddr
+ ];
+ };
+ cohttp-lwt-unix = pkg {
+ pname = "cohttp-lwt-unix";
+ checkInputs = [ ounit2 ];
+ propagatedBuildInputs = [
+ http cohttp cohttp-lwt cmdliner lwt conduit-lwt
+ conduit-lwt-unix fmt ppx_sexp_conv magic-mime logs
+ ];
+ };
+ cohttp-server-lwt-unix = pkg {
+ pname = "cohttp-server-lwt-unix";
+ checkInputs = [ lwt conduit-lwt-unix cohttp-lwt cohttp-lwt-unix ];
+ propagatedBuildInputs = [ http lwt ];
+ };
+ cohttp-eio = pkg {
+ pname = "cohttp-eio";
+ checkInputs = [
+ alcotest eio mdx ppx_here
+ tls-eio
+ mirage-crypto-rng-eio
+ ];
+ propagatedBuildInputs = [ cohttp eio logs uri fmt ptime http ];
+ };
+ cohttp-mirage = pkg {
+ pname = "cohttp-mirage";
+ propagatedBuildInputs = [
+ mirage-flow mirage-channel conduit conduit-mirage
+ mirage-kv lwt cohttp-lwt cstruct fmt astring magic-mime ppx_sexp_conv
+ ];
+ };
+ cohttp-bench = pkg {
+ pname = "cohttp-bench";
+ buildInputs = [
+ core core_bench eio eio_main http cohttp cohttp-eio
+ cohttp-lwt-unix cohttp-server-lwt-unix cohttp-async
+ ];
+ };
+ };
+ devShells.default = pkgs.mkShell {
+ inputsFrom = pkgs.lib.attrValues packages;
+ buildInputs = [ ocamlformat ] ++ (with pkgs.ocamlPackages; [
+ ocaml-lsp
+ ]);
+ };
+ devShells.eio = pkgs.mkShell {
+ inputsFrom = [ cohttp-eio ];
+ buildInputs = [ ocamlformat ] ++ (with pkgs; [
+ ocamlPackages.ocaml-lsp gmp libev nmap curl
+ ]);
+ };
+ });
+}
--- /dev/null
+version: "6.0.0"
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Type definitions of HTTP essentials"
+description: """
+This package contains essential type definitions used in Cohttp. It is designed
+to have no dependencies and make it easy for other packages to easily
+interoperate with Cohttp."""
+maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
+authors: [
+ "Anil Madhavapeddy"
+ "Stefano Zacchiroli"
+ "David Sheets"
+ "Thomas Gazagnaire"
+ "David Scott"
+ "Rudi Grinberg"
+ "Andy Ray"
+ "Anurag Soni"
+]
+license: "ISC"
+homepage: "https://github.com/mirage/ocaml-cohttp"
+doc: "https://mirage.github.io/ocaml-cohttp/"
+bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
+depends: [
+ "dune" {>= "3.8"}
+ "ocaml" {>= "4.08"}
+ "ppx_expect" {with-test & >= "v0.17.0"}
+ "alcotest" {with-test & >= "1.7.0"}
+ "base_quickcheck" {with-test}
+ "ppx_assert" {with-test}
+ "ppx_sexp_conv" {with-test}
+ "ppx_compare" {with-test}
+ "ppx_here" {with-test}
+ "crowbar" {with-test & >= "0.2"}
+ "sexplib0" {with-test}
+ "odoc" {with-doc}
+]
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@http/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
--- /dev/null
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@http/runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
--- /dev/null
+(executable
+ (name fuzz_header)
+ (libraries crowbar http))
+
+(rule
+ (alias runtest)
+ (package http)
+ (action
+ (run ./fuzz_header.exe)))
+
+(rule
+ (alias fuzz)
+ (deps
+ (:exe fuzz_header.exe)
+ (source_tree inputs))
+ (action
+ (run afl-fuzz -i inputs -o findings -- ./%{exe} @@)))
+
+(rule
+ (alias bun-fuzz)
+ (locks %{project_root}/bun)
+ (deps
+ (:exe fuzz_me.exe)
+ (source_tree input))
+ (action
+ (run bun --input inputs --output findings -- ./%{exe})))
--- /dev/null
+(*{{{ Copyright (c) 2021 Carine Morel <carine@tarides.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *}}}*)
+
+module H = Http.Header
+
+(** Here, we test the Header module with fuzzing. Some of these tests may be
+ redundant with Alcotest tests.
+
+ The tests are launched with [dune runtest] but can also be run with [afl]
+ with the command line : [dune build @cohttp/fuzz/fuzz --no-buffer].
+
+ The tests below reflects the semantics we want for each function, however in
+ some cases, it may actually be specific to the current implementation and
+ does not necessary need to be enforced in future implementations. To make it
+ clear, tests are annotated by their categories:
+
+ - FS (Functions semantics): tests the semantics described in the
+ documentation.
+
+ - SI (Specific to current Implementation): these tests are here to check the
+ implementation is doing what we think it is doing but may change
+ accordingly to implementation changes. *)
+
+(* Generators *)
+let list_value_headers =
+ [|
+ "accept";
+ "accept-charset";
+ "accept-encoding";
+ "accept-language";
+ "accept-ranges";
+ "allow";
+ "cache-control";
+ "connection";
+ "content-encoding";
+ "content-language";
+ "expect";
+ "if-match";
+ "if-none-match";
+ "link";
+ "pragma";
+ "proxy-authenticate";
+ "te";
+ "trailer";
+ "transfer-encoding";
+ "upgrade";
+ "vary";
+ "via";
+ "warning";
+ "www-authenticate";
+ |]
+
+(** Pick a random list-value header name from a predefined array of values. *)
+let list_value_header_gen =
+ let open Crowbar in
+ let gen =
+ map
+ [ range (Array.length list_value_headers) ]
+ (fun i -> list_value_headers.(i))
+ in
+ let printer fmt str = pp fmt "%s" str in
+ with_printer printer gen
+
+(** Generate a tchar following
+ {{:https://tools.ietf.org/html/rfc7230#appendix-B} RFC 7230}.
+
+ tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" /
+ "_" / "`" / "|" / "~" / DIGIT / ALPHA *)
+let tchar_gen =
+ let tchar_code_gen =
+ let uppercased_letter = Crowbar.range ~min:65 26 in
+ let lowercased_letter = Crowbar.range ~min:97 26 in
+ let others =
+ List.map
+ (fun i -> Crowbar.const i)
+ [
+ 33 (* ! *);
+ 35 (* # *);
+ 36 (* $ *);
+ 37 (* % *);
+ 38 (* & *);
+ 42 (* * *);
+ 43 (* + *);
+ 45 (* - *);
+ 46 (* . *);
+ 94 (* ^ *);
+ 95 (* _ *);
+ 96 (* ` *);
+ 124 (* | *);
+ 126 (* ~ *);
+ ]
+ |> Crowbar.choose
+ in
+ let digit_and_others = Crowbar.(choose [ others; range ~min:48 10 ]) in
+ Crowbar.(choose [ lowercased_letter; uppercased_letter; digit_and_others ])
+ in
+ Crowbar.(map [ tchar_code_gen ] (fun i -> Char.escaped (Char.chr i)))
+
+(** Generate a non-empty word of arbitrary length (composed of tchar only). *)
+let word_gen =
+ let open Crowbar in
+ let gen =
+ fix (fun word_gen ->
+ choose
+ [
+ (* one letter word *)
+ tchar_gen;
+ (* two letters word *)
+ map [ tchar_gen; tchar_gen ] (fun l1 l2 -> l1 ^ l2);
+ (* add one letter *)
+ map [ tchar_gen; word_gen ] (fun l w -> l ^ w);
+ ])
+ in
+ let printer = pp_string in
+ with_printer printer gen
+
+(** Generate an header name: either a predefined list-value header or a random
+ word *)
+let header_name_gen =
+ let open Crowbar in
+ let gen = choose [ list_value_header_gen; word_gen ] in
+ let printer = pp_string in
+ with_printer printer gen
+
+let header_printer fmt (k, v) = Crowbar.pp fmt "%s, %s" k v
+
+(** Generate a header key/value pair *)
+let header_gen : (string * string) Crowbar.gen =
+ let open Crowbar in
+ let gen_setcookie = pair (const "Set-cookie") word_gen in
+ let gen_otherheader = pair header_name_gen word_gen in
+ let gen =
+ (* one in ten generated header is a "set-cookie" header *)
+ choose (gen_setcookie :: List.init 9 (fun _ -> gen_otherheader))
+ in
+ with_printer header_printer gen
+
+(** Generate a list of headers *)
+let header_list_gen : (string * string) list Crowbar.gen =
+ let open Crowbar in
+ let gen = list header_gen in
+ let printer = pp_list header_printer in
+ with_printer printer gen
+
+(** Generate a [Http.Header.t] headers. *)
+let headers_gen : H.t Crowbar.gen =
+ let open Crowbar in
+ let gen =
+ fix (fun headers_gen ->
+ choose
+ [
+ (* empty header *)
+ const (H.init ());
+ (* add one pair (k, v) *)
+ map [ header_gen; headers_gen ] (fun (k, v) h -> H.add h k v);
+ (* add a list of headers *)
+ map [ headers_gen; header_list_gen ] (fun h l -> H.add_list h l);
+ ])
+ in
+ let printer fmt h = Crowbar.pp fmt "\n%s@." (H.to_string h) in
+ with_printer printer gen
+
+(* Tests *)
+(* Important note : keys must be lowercased before comparison *)
+let eqssl l1 l2 =
+ List.map (fun (k, v) -> (String.lowercase_ascii k, v)) l1
+ = List.map (fun (k, v) -> (String.lowercase_ascii k, v)) l2
+
+let is_empty_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, k, v. is_empty (add h k v) = false) *)
+ add_test ~name:"[is_empty] returns false on a non empty header"
+ [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+ check_eq false H.(is_empty (add h k v))))
+
+let init_with_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall k v. to_list (init_with k v) = [k, v] *)
+ add_test ~name:"[init_list k v] is [k, v]" [ header_name_gen; word_gen ]
+ (fun k v -> check_eq H.(to_list (init_with k v)) [ (k, v) ]))
+
+let mem_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall k. mem (init ()) k = false *)
+ add_test ~name:"[mem h k] on an empty header is always false"
+ [ header_name_gen ] (fun k -> check_eq false H.(mem (init ()) k));
+ (* SI *)
+ (* forall h, k. H.mem h k = List.(mem_assoc (String.lowercase_ascii x) (List.map (fun (k, v) -> String.lowercase_ascii k, v) (H.to_list h))) *)
+ add_test ~name:"Header.mem has the same behavior than List.mem_assoc"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ check_eq
+ H.(mem h k)
+ List.(
+ mem_assoc (String.lowercase_ascii k)
+ (List.map
+ (fun (k, v) -> (String.lowercase_ascii k, v))
+ (H.to_list h)))))
+
+let add_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall k, v, h. mem (add h k v) k = true *)
+ add_test ~name:"mem (add h k v) k = true"
+ [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+ check_eq true H.(mem (add h k v) k));
+ add_test
+ (* FS *)
+ (* forall h, k, v. to_list (add h k v) = to_list h @ [lowercase k, v] *)
+ ~name:"[add] adds a value at the header end"
+ [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+ check_eq (H.to_list h @ [ (k, v) ]) H.(to_list (add h k v))))
+
+let to_list_of_list_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h. to_list (of_list h) = h (with lowercase key comparison) *)
+ add_test ~name:"to_list (of_list h) = h" [ header_list_gen ] (fun h ->
+ check_eq ~eq:eqssl H.(to_list (of_list h)) h);
+
+ (* FS and RFC *)
+ (* forall h, k1, v1, k2, v2. to_list (add (add h k1 v1) k2 v2) = to_list \
+ h @ [k1, v1; k2, v2] *)
+ add_test ~name:"checking [to_list] order after multiple [add] calls"
+ [ headers_gen; header_name_gen; word_gen; header_name_gen; word_gen ]
+ (fun h k1 v1 k2 v2 ->
+ check_eq ~eq:eqssl
+ H.(to_list (add (add h k1 v1) k2 v2))
+ H.(to_list h @ [ (k1, v1); (k2, v2) ])))
+
+let add_opt_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall hopt, k, v.
+ add_opt hopt k v = | add h k v if hopt = Some h
+ | init_with k v if hopt = None *)
+ add_test ~name:"add_opt (Some h) = add and add_opt None = init_with"
+ [ option headers_gen; header_name_gen; word_gen ]
+ (fun hopt k v ->
+ check_eq
+ H.(match hopt with None -> init_with k v | Some h -> add h k v)
+ H.(add_opt hopt k v)))
+
+let add_unless_exists_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, k, v. if mem h k = true then add_unless_exists h k v = h *)
+ add_test ~name:"[add_unless_exists h k v] does nothing if k exists"
+ [ headers_gen; header_list_gen; header_name_gen; word_gen; word_gen ]
+ (fun h l k v1 v2 ->
+ (* A random header such as mem h k = true *)
+ let h = H.(add_list (add h k v1) l) in
+ check_eq H.(add_unless_exists h k v2) h);
+ (* FS *)
+ (* forall h, k, v. if mem h k = false then add_unless_exists h k v = add \
+ h k v *)
+ add_test ~name:"add_unless_exists = add if key does not exist"
+ [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+ (* Making sure as mem h k = false *)
+ guard (not (H.mem h k));
+ check_eq H.(add_unless_exists h k v) H.(add h k v)))
+
+let add_list () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, l. to_list (add_list h l) = to_list h @ l *)
+ add_test
+ ~name:"[add_list h l] adds all headers in [l] in order at the end of [h]"
+ [ headers_gen; header_list_gen ] (fun h l ->
+ check_eq ~eq:eqssl H.(to_list (add_list h l)) H.(to_list h @ l)))
+
+let add_multi () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, k, vs. add_multi h k vs = add_list h (List.map (fun v -> k, v) vs) *)
+ add_test ~name:"[add_list] and [add_multi] have compatible semantics"
+ [ headers_gen; header_name_gen; list word_gen ]
+ (fun h k vs ->
+ check_eq
+ H.(add_multi h k vs)
+ H.(add_list h (List.map (fun v -> (k, v)) vs)));
+ (* FS *)
+ (* forall h, k, l. get_multi (add_multi h k l) k = get_multi h k @ l *)
+ add_test ~name:"get_multi (add_multi h k l) k = get_multi h k @ l"
+ [ headers_gen; header_name_gen; Crowbar.list word_gen ]
+ (fun h k l ->
+ check_eq H.(get_multi (add_multi h k l) k) H.(get_multi h k @ l)))
+
+let get_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h k, if mem h k = false then get h k = None *)
+ add_test ~name:"[get h k] returns None if k does not exists in h"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ guard H.(not (mem h k));
+ check_eq H.(get h k) None);
+ (* FS *)
+ (* forall h k, get (add h k v) = Some v *)
+ add_test ~name:"get (add h k v) = Some v"
+ [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+ check_eq H.(get (add h k v) k) (Some v)))
+
+let get_multi_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h k, if mem h k = false then get_multi h k = [] *)
+ add_test ~name:"[get_multi h k] returns [] if k does not exists in h"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ guard H.(not (mem h k));
+ check_eq H.(get_multi h k) []);
+ (* FS *)
+ (* forall l1, l2, k, v.
+ get_multi (of_list (l1 @ [ (k, v) ] @ l2)) k =
+ get_multi (of_list l1) k @ [ v ] @ get_multi (of_list l2) k *)
+ add_test ~name:"[get_multi] returns values in transmission order"
+ [ header_list_gen; header_list_gen; header_name_gen; word_gen ]
+ (fun l1 l2 k v ->
+ check_eq
+ H.(get_multi (of_list (l1 @ [ (k, v) ] @ l2)) k)
+ H.(get_multi (of_list l1) k @ [ v ] @ get_multi (of_list l2) k));
+ (* FS and RFC7230§3.2.2 *)
+ (* forall h, v1, v2, forall k in list values headers.
+ get_multi (add (add h k v1) k v2)) k = get_multi h k @ [v1; v2] *)
+ add_test ~name:"headers order is preserved"
+ [ headers_gen; list_value_header_gen; word_gen; word_gen ]
+ (fun h k v1 v2 ->
+ check_eq
+ H.(get_multi (add (add h k v1) k v2) k)
+ (H.(get_multi h k) @ [ v1; v2 ])))
+
+let remove_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, k. mem (remove h k) k = false *)
+ add_test ~name:"[remove] removes all values associated to a key"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ check_eq false H.(mem (remove h k) k));
+ (* FS *)
+ (* forall h, k. remove (remove h k) k = remove h k*)
+ add_test ~name:"(fun x -> remove x k) is idempotent"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ check_eq H.(remove (remove h k) k) H.(remove h k)))
+
+let replace_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, k, v. get_multi (replace h k v) = [ v ] *)
+ add_test ~name:"[replace] replaces the last value and remove the others"
+ [ headers_gen; header_list_gen; header_name_gen; word_gen; word_gen ]
+ (fun h l k v1 v2 ->
+ check_eq H.(get_multi (replace h k v1) k) [ v1 ];
+ (* This second check is to make sure the case where mem h k = true is tested *)
+ let h =
+ H.(add_list (add h k v1) l)
+ (* h is built such as mem h k = true *)
+ in
+ check_eq H.(get_multi (replace h k v2) k) [ v2 ]);
+ (* FS *)
+ (* forall h, k, v. if mem h k = false then replace h k v = add h k v) *)
+ add_test ~name:"replace h k v = add h k v if k does not exists in h"
+ [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+ guard H.(mem h k = false);
+ check_eq H.(replace h k v) H.(add h k v));
+ (* SI *)
+ (* forall h, l, k, v1, v2.
+ if mem (of_list l) k = false then
+ replace (add_list h ([ k, v1 ] @ l)) k v2 =
+ add_list (add (remove h k) k v2) l k) *)
+ add_test ~name:"[replace] does not change headers order"
+ [ headers_gen; header_list_gen; header_name_gen; word_gen; word_gen ]
+ (fun h l k v1 v2 ->
+ guard H.(not (mem (of_list l) k));
+ (* A random headers such as mem h k = true *)
+ let h1 = H.(add_list h ([ (k, v1) ] @ l)) in
+ let h2 = H.(add_list (remove h k) ([ (k, v2) ] @ l)) in
+ check_eq ~eq:eqssl H.(to_list (replace h1 k v2)) H.(to_list h2)))
+
+let update_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h k, update h k id = h *)
+ add_test ~name:"[update h k id] does nothing"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ check_eq H.(update h k (fun x -> x)) h);
+ (*FS*)
+ (* forall h k f, remove (update h k f) k = remove h k *)
+ add_test ~name:"[update h k _] only changes k "
+ [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+ check_eq H.(remove (update h k (fun _ -> None)) k) H.(remove h k);
+ check_eq H.(remove (update h k (fun _ -> Some w)) k) H.(remove h k));
+ (*FS*)
+ add_test ~name:"[update h k (fun _ -> None)] removes last occurrence of k."
+ [ headers_gen; header_name_gen ] (fun h k ->
+ let h1 = H.update h k (fun _ -> None) in
+ let r1 = H.get_multi h1 k in
+ let r2 =
+ match List.rev (H.get_multi h k) with
+ | [] -> []
+ | _ :: xs -> List.rev xs
+ in
+ check_eq r1 r2);
+ (*FS*)
+ add_test
+ ~name:
+ "[update h k (function Some _ -> Some w)] replaces last occurrence of \
+ k." [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+ let h1 = H.update h k (fun _ -> Some w) in
+ let r1 = H.get_multi h1 k in
+ let r2 =
+ match List.rev (H.get_multi h k) with
+ | [] -> [ w ]
+ | _ :: xs -> List.rev (w :: xs)
+ in
+ check_eq r1 r2))
+
+let update_all_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h k, update_all h k id = h *)
+ add_test ~name:"[update_all h k id] does nothing"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ check_eq H.(update_all h k (fun x -> x)) h);
+ (*FS*)
+ (* forall h k f, remove (update_all h k f) k = remove h k *)
+ add_test ~name:"[update_all h k _] only changes k "
+ [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+ check_eq H.(remove (update_all h k (fun _ -> [])) k) H.(remove h k);
+ check_eq H.(remove (update_all h k (fun _ -> [ w ])) k) H.(remove h k));
+ (*FS*)
+ add_test
+ ~name:"[update_all h k (fun _ -> [])] removes all occurrences of k."
+ [ headers_gen; header_name_gen ] (fun h k ->
+ let h1 = H.update_all h k (fun _ -> []) in
+ check_eq H.(get_multi h1 k) []);
+ (*FS*)
+ add_test
+ ~name:
+ "[update_all h k (function _ -> [w])] removes all occurrences of k and \
+ adds w." [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+ let h1 = H.update_all h k (fun _ -> [ w ]) in
+ let r1 = H.get_multi h1 k in
+ let r2 = [ w ] in
+ check_eq r1 r2))
+
+let get_multi_concat_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, k. if mem h k = false then get_multi_concat h k = None *)
+ add_test
+ ~name:"[get_multi_concat h k] returns \"\" if k does not exists in h"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ guard H.(not (mem h k));
+ check_eq H.(get_multi_concat h k) None);
+ (* FS *)
+ (* forall h, k. get_multi_concat ~list_value_only:true h k = get h k
+ if k is not a list value header *)
+ add_test ~name:"[get_multi_concat] optional argument works properly"
+ [ headers_gen; word_gen ] (fun h k ->
+ guard (not (Array.mem (String.lowercase_ascii k) list_value_headers));
+ check_eq H.(get_multi_concat ~list_value_only:true h k) H.(get h k));
+ (* FS - Very important for RFC 7230.3.2.2 *)
+ add_test ~name:"[get_multi_concat] returns values in transmission order"
+ [ header_list_gen; header_list_gen; header_name_gen; word_gen ]
+ (fun l1 l2 k v ->
+ let str_opt ?(bfr = false) ?(aft = false) s =
+ match s with
+ | None -> ""
+ | Some v -> if bfr then "," ^ v else if aft then v ^ "," else v
+ in
+ check_eq
+ H.(str_opt (get_multi_concat (of_list (l1 @ [ (k, v) ] @ l2)) k))
+ H.(
+ str_opt ~aft:true (get_multi_concat (of_list l1) k)
+ ^ v
+ ^ str_opt ~bfr:true (get_multi_concat (of_list l2) k))))
+
+(* Note : clean_dup does nothing to already concatenated headers. For
+ example, ["a", "v1,v2"] will be not be cleaned. *)
+let clean_dup_test () =
+ Crowbar.(
+ (* FS *)
+ (* Check that there is no more duplicates (except set-cookie). *)
+ add_test
+ ~name:
+ "All headers name in [h] appears strictly once in [clean_dup h] except \
+ for [set-cookie]" [ headers_gen ] (fun h ->
+ let h = H.remove h "set-cookie" in
+ let h = H.(to_list (clean_dup h)) in
+ let compare_key (k, _) (k', _) = compare k k' in
+ check_eq (List.sort_uniq compare_key h) (List.sort compare_key h));
+ (* FS *)
+ (* forall h, k in list_value_headers.
+ String.concat "," (get_multi_concat h k) = get (clean_dup h) k *)
+ add_test ~name:"[clean_dup] concatenates properly list-value headers"
+ [ headers_gen; list_value_header_gen ] (fun h k ->
+ check_eq H.(get_multi_concat h k) H.(get (clean_dup h) k));
+ (* FS *)
+ (* forall h. clean_dup (clean_dup h) = clean_dup h *)
+ add_test ~name:"[clean_dup] is idempotent" [ headers_gen ] (fun h ->
+ check_eq H.(clean_dup (clean_dup h)) H.(clean_dup h));
+ (* FS *)
+ (* forall h. get_multi (clean_dup h) "set-cookie" = get_multi h "set-cookie"*)
+ add_test ~name:"[clean_dup] does nothing to [set-cookie] headers"
+ [ headers_gen ] (fun h ->
+ check_eq
+ H.(get_multi h "set-cookie")
+ H.(get_multi (clean_dup h) "set-cookie"));
+ (* FS *)
+ (* As the generated header values are only composed of tchar (it
+ does not generate concatenated values like "gzip,chunked"), the
+ only cases where there are commas in a value is if [clean_dup]
+ concatenated multiple values.
+
+ This test checks that only one value is kept for non-list-value
+ headers and that this value is the last one. *)
+ add_test
+ ~name:"Only list-value headers can have multiple concatenated values "
+ [ headers_gen ] (fun h ->
+ (* As it is an exception, [set-cookie] is removed. *)
+ let h = H.remove h "set-cookie" in
+ let h' = H.(clean_dup h) in
+ let has_multiple_values v =
+ match String.split_on_char ',' v with
+ | [] | [ _ ] -> false
+ | _ -> true
+ in
+ check_eq true
+ H.(
+ fold
+ (fun k v b ->
+ if Array.mem k list_value_headers then b
+ else if has_multiple_values v then false
+ else b && get h k = Some v)
+ h' true)))
+
+let () =
+ init_with_test ();
+ is_empty_test ();
+ mem_test ();
+ add_test ();
+ to_list_of_list_test ();
+ add_opt_test ();
+ add_unless_exists_test ();
+ add_list ();
+ add_multi ();
+ get_test ();
+ get_multi_test ();
+ get_multi_concat_test ();
+ remove_test ();
+ replace_test ();
+ update_test ();
+ update_all_test ();
+ clean_dup_test ();
+ ()
--- /dev/null
+something
\ No newline at end of file
--- /dev/null
+module Bytes = BytesLabels
+
+(* Bytebuffer is split into three regions using two separate indices that are used
+ to support read and write operations.
+ +--------------------+---------------------------+----------------------------+
+ | Consumed Bytes | Bytes available to read | Empty space for writing |
+ +--------------------+---------------------------+----------------------------+
+ | 0 <= pos_read <= pos_fill <= capacity
+
+ Consumed Bytes: This is content that's already consumed via a get/read operation.
+ This space can be safely reclaimed.
+
+ Bytes available to read: This is the actual content that will be surfaced to users via
+ get/read operations on the bytebuffer.
+
+ Empty space for writing: This is space that will be filled by any set/write operations
+ on the bytebuffer.
+*)
+
+type t = { buf : Bytes.t; mutable pos_read : int; mutable pos_fill : int }
+
+let create size =
+ let buf = Bytes.create size in
+ { buf; pos_read = 0; pos_fill = 0 }
+
+let unsafe_buf t = t.buf
+let pos t = t.pos_read
+
+let compact t =
+ if t.pos_read > 0 then (
+ let len = t.pos_fill - t.pos_read in
+ Bytes.blit ~src:t.buf ~dst:t.buf ~src_pos:t.pos_read ~dst_pos:0 ~len;
+ t.pos_read <- 0;
+ t.pos_fill <- len)
+
+let length t = t.pos_fill - t.pos_read
+
+let drop t len =
+ if len < 0 || len > length t then
+ invalid_arg "Bytebuffer.drop: Index out of bounds";
+ t.pos_read <- t.pos_read + len
+
+let rec index_rec t ch idx len =
+ if idx = len then -1
+ else if Char.equal (Bytes.unsafe_get t.buf (t.pos_read + idx)) ch then
+ idx + t.pos_read
+ else index_rec t ch (idx + 1) len
+
+let index t ch = index_rec t ch 0 (length t)
+let to_string t = Bytes.sub_string t.buf ~pos:t.pos_read ~len:(length t)
+
+module Make (IO : sig
+ type 'a t
+
+ val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t
+ val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
+ val return : 'a -> 'a t
+end) (Refill : sig
+ type src
+
+ val refill : src -> bytes -> pos:int -> len:int -> [ `Ok of int | `Eof ] IO.t
+end) =
+struct
+ open IO
+
+ let refill t src =
+ compact t;
+ Refill.refill src t.buf ~pos:t.pos_fill
+ ~len:(Bytes.length t.buf - t.pos_fill)
+ >>| function
+ | `Eof -> `Eof
+ | `Ok count ->
+ t.pos_fill <- t.pos_fill + count;
+ `Ok
+
+ let get_line t idx =
+ let len = idx - t.pos_read in
+ if len >= 1 && Char.equal (Bytes.unsafe_get t.buf (idx - 1)) '\r' then (
+ let res =
+ let len = len - 1 in
+ Bytes.sub_string t.buf ~pos:t.pos_read ~len
+ in
+ drop t (len + 1);
+ Some res)
+ else None
+
+ let get_line_buf t buf idx =
+ let len = idx - t.pos_read in
+ Buffer.add_subbytes buf t.buf t.pos_read len;
+ drop t (len + 1)
+
+ let rec read_line_slow t reader buf =
+ if length t = 0 then
+ refill t reader >>= function
+ | `Ok -> read_line_slow t reader buf
+ | `Eof -> IO.return `Eof
+ else
+ let idx = index t '\n' in
+ if idx > -1 then (
+ get_line_buf t buf idx;
+ IO.return `Ok)
+ else
+ let len = length t in
+ Buffer.add_subbytes buf t.buf t.pos_read len;
+ drop t len;
+ read_line_slow t reader buf
+
+ let read_line t reader =
+ let idx = index t '\n' in
+ if idx = -1 then
+ let buf = Buffer.create (length t + 1) in
+ read_line_slow t reader buf >>| function
+ | `Eof -> None
+ | `Ok ->
+ let len = Buffer.length buf in
+ if len = 0 then None
+ else if len >= 2 && Buffer.nth buf (len - 1) = '\r' then
+ Some (Buffer.sub buf 0 (len - 1))
+ else None
+ else
+ let line = get_line t idx in
+ IO.return line
+
+ let rec read t reader len =
+ let length = length t in
+ if length > 0 then (
+ let to_read = min length len in
+ let buf = Bytes.sub_string t.buf ~pos:t.pos_read ~len:to_read in
+ drop t to_read;
+ IO.return buf)
+ else
+ refill t reader >>= function
+ | `Ok -> read t reader len
+ | `Eof -> IO.return ""
+end
--- /dev/null
+(* Bytebuffer is split into three regions using two separate indices that are used
+ to support read and write operations.
+ +--------------------+---------------------------+----------------------------+
+ | Consumed Bytes | Bytes available to read | Empty space for writing |
+ +--------------------+---------------------------+----------------------------+
+ | 0 <= pos_read <= pos_fill <= capacity
+
+ Consumed Bytes: This is content that's already consumed via a get/read operation.
+ This space can be safely reclaimed.
+
+ Bytes available to read: This is the actual content that will be surfaced to users via
+ get/read operations on the bytebuffer.
+
+ Empty space for writing: This is space that will be filled by any set/write operations
+ on the bytebuffer.
+*)
+type t
+
+val create : int -> t
+val unsafe_buf : t -> Bytes.t
+val pos : t -> int
+val compact : t -> unit
+val length : t -> int
+val drop : t -> int -> unit
+val to_string : t -> string
+
+module Make (IO : sig
+ type 'a t
+
+ val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t
+ val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
+ val return : 'a -> 'a t
+end) (Refill : sig
+ type src
+
+ val refill : src -> bytes -> pos:int -> len:int -> [ `Ok of int | `Eof ] IO.t
+end) : sig
+ val refill : t -> Refill.src -> [ `Ok | `Eof ] IO.t
+ val read_line : t -> Refill.src -> string option IO.t
+ val read : t -> Refill.src -> int -> string IO.t
+end
--- /dev/null
+(library
+ (name http_bytebuffer)
+ (package http))
--- /dev/null
+(library
+ (synopsis "HTTP types designed for interoperability")
+ (name http)
+ (public_name http))
--- /dev/null
+module Transfer = struct
+ type encoding = Chunked | Fixed of int64 | Unknown
+
+ let compare_encoding (x : encoding) (y : encoding) = Stdlib.compare x y
+
+ let has_body = function
+ | Fixed 0L -> `No
+ | Chunked | Fixed _ -> `Yes
+ | Unknown -> `Unknown
+
+ module Private = struct
+ let has_body = has_body
+ end
+end
+
+module Header = struct
+ module Private = struct
+ external string_unsafe_get64 : string -> int -> int64
+ = "%caml_string_get64u"
+
+ (* [caseless_equal a b] must be equivalent to
+ [String.equal (String.lowercase_ascii a) (String.lowercase_ascii b)]. *)
+ let caseless_equal a b =
+ if a == b then true
+ else
+ let len = String.length a in
+ len = String.length b
+ (* Note: at this point we know that [a] and [b] have the same length. *)
+ &&
+ (* [word_loop a b i len] compares strings [a] and [b] from
+ offsets [i] (included) to [len] (excluded), one word at a time.
+ [i] is a world-aligned index into the strings.
+ *)
+ let rec word_loop a b i len =
+ if i = len then true
+ else
+ let i' = i + 8 in
+ (* If [i' > len], what remains to be compared is strictly
+ less than a word long, use byte-per-byte comparison. *)
+ if i' > len then byte_loop a b i len
+ else if string_unsafe_get64 a i = string_unsafe_get64 b i then
+ word_loop a b i' len
+ else
+ (* If the words at [i] differ, it may due to a case
+ difference; we check the individual bytes of this
+ work, and then we continue checking the other
+ words. *)
+ byte_loop a b i i' && word_loop a b i' len
+ (* [byte_loop a b i len] compares the strings [a] and [b] from
+ offsets [i] (included) to [len] (excluded), one byte at
+ a time.
+
+ This function assumes that [i < len] holds -- its only called
+ by [word_loop] when this is known to hold. *)
+ and byte_loop a b i len =
+ let c1 = String.unsafe_get a i in
+ let c2 = String.unsafe_get b i in
+ Char.lowercase_ascii c1 = Char.lowercase_ascii c2
+ &&
+ let i' = i + 1 in
+ i' = len || byte_loop a b i' len
+ in
+ word_loop a b 0 len
+ end
+
+ let caseless_equal = Private.caseless_equal
+
+ type t = (string * string) list
+
+ let pp_hum =
+ let pp_sep fmt () = Format.fprintf fmt ";@ " in
+ let pp_kv fmt (k, v) = Format.fprintf fmt "@[%s@ =@ %S@]" k v in
+ fun fmt t ->
+ Format.fprintf fmt "Header@ {@ @[%a@]@ }"
+ (Format.pp_print_list ~pp_sep pp_kv)
+ t
+
+ let empty = []
+ let compare = Stdlib.compare
+ let init () = []
+ let is_empty = function [] -> true | _ -> false
+ let init_with k v = [ (k, v) ]
+
+ let mem h k =
+ let rec loop = function
+ | [] -> false
+ | (k', _) :: h' -> if caseless_equal k k' then true else loop h'
+ in
+ loop h
+
+ let add h k v : t = (k, v) :: h
+ let add_list h l = List.fold_left (fun h (k, v) -> add h k v) h l
+ let add_multi h k l = List.fold_left (fun h v -> add h k v) h l
+
+ let add_opt h_opt k v =
+ match h_opt with None -> init_with k v | Some h -> add h k v
+
+ let add_unless_exists h k v = if mem h k then h else add h k v
+
+ let add_opt_unless_exists h k v =
+ match h with None -> init_with k v | Some h -> add_unless_exists h k v
+
+ let get h k =
+ let rec loop h =
+ match h with
+ | [] -> None
+ | (k', v) :: h' -> if caseless_equal k k' then Some v else loop h'
+ in
+ loop h
+
+ let get_multi (h : t) (k : string) =
+ let rec loop h acc =
+ match h with
+ | [] -> acc
+ | (k', v) :: h' ->
+ if caseless_equal k k' then loop h' (v :: acc) else loop h' acc
+ in
+ loop h []
+
+ let remove h k =
+ let rec loop seen = function
+ | [] -> if seen then [] else raise_notrace Not_found
+ | (k', _) :: h when caseless_equal k k' -> loop true h
+ | x :: h -> x :: loop seen h
+ in
+ try loop false h with Not_found -> h
+
+ let remove_last h k =
+ let rec loop seen = function
+ | [] -> raise_notrace Not_found
+ | (k', _) :: h when caseless_equal k k' -> h
+ | x :: h -> x :: loop seen h
+ in
+ try loop false h with Not_found -> h
+
+ let replace_ last h k v =
+ let rec loop seen = function
+ | [] -> if seen then [] else raise_notrace Not_found
+ | (k'', _) :: h when caseless_equal k k'' ->
+ if last then (k'', v) :: h
+ else if not seen then (k, v) :: loop true h
+ else loop seen h
+ | x :: h -> x :: loop seen h
+ in
+ try loop false h with Not_found -> add h k v
+
+ let replace = replace_ false
+
+ let update h k f =
+ let vorig = get h k in
+ match (f vorig, vorig) with
+ | None, None -> h
+ | None, _ -> remove_last h k
+ | Some s, Some s' when s == s' -> h
+ | Some s, _ -> replace_ true h k s
+
+ let update_all h k f =
+ let vorig = get_multi h k in
+ match (f vorig, vorig) with
+ | [], [] -> h
+ | [], _ -> remove h k
+ | xs, xs' when xs = xs' -> h
+ | xs, _ ->
+ let h = remove h k in
+ add_multi h k xs
+
+ let map (f : string -> string -> string) (h : t) : t =
+ List.map
+ (fun (k, v) ->
+ let vs' = f k v in
+ (k, vs'))
+ h
+
+ let iter_ord (f : string -> string -> unit) (h : t) : unit =
+ List.iter (fun (k, v) -> f k v) (List.rev h)
+
+ let iter (f : string -> string -> unit) (h : t) : unit =
+ List.iter (fun (k, v) -> f k v) h
+
+ let fold (f : string -> string -> 'a -> 'a) (h : t) (init : 'a) : 'a =
+ List.fold_left (fun acc (k, v) -> f k v acc) init h
+
+ let of_list_rev h = h
+ let of_list h = List.rev h
+ let to_list h = List.rev h
+
+ let to_lines (h : t) =
+ let b = Buffer.create 128 in
+ let header_line k v =
+ Buffer.clear b;
+ Buffer.add_string b k;
+ Buffer.add_string b ": ";
+ Buffer.add_string b v;
+ Buffer.add_string b "\r\n";
+ Buffer.contents b
+ in
+ List.fold_left (fun acc (k, v) -> header_line k v :: acc) [] h
+
+ let to_frames h =
+ let to_frame k v = String.concat ": " [ k; v ] in
+ List.fold_left (fun acc (k, v) -> to_frame k v :: acc) [] h
+
+ let to_string h =
+ let b = Buffer.create 128 in
+ to_list h
+ |> List.iter (fun (k, v) ->
+ Buffer.add_string b k;
+ Buffer.add_string b ": ";
+ Buffer.add_string b v;
+ Buffer.add_string b "\r\n");
+ Buffer.add_string b "\r\n";
+ Buffer.contents b
+
+ let headers_with_list_values =
+ [|
+ "accept";
+ "accept-charset";
+ "accept-encoding";
+ "accept-language";
+ "accept-ranges";
+ "allow";
+ "cache-control";
+ "connection";
+ "content-encoding";
+ "content-language";
+ "expect";
+ "if-match";
+ "if-none-match";
+ "link";
+ "pragma";
+ "proxy-authenticate";
+ "te";
+ "trailer";
+ "transfer-encoding";
+ "upgrade";
+ "vary";
+ "via";
+ "warning";
+ "www-authenticate";
+ |]
+
+ let is_header_with_list_value =
+ let tbl = Hashtbl.create (Array.length headers_with_list_values) in
+ headers_with_list_values |> Array.iter (fun h -> Hashtbl.add tbl h ());
+ fun h -> Hashtbl.mem tbl h
+
+ let is_set_cookie k = caseless_equal k "set-cookie"
+
+ (* set-cookie is an exception according to
+ {{:https://tools.ietf.org/html/rfc7230#section-3.2.2}
+ RFC7230§3.2.2} and can appear multiple times in a response message.
+ *)
+ let clean_dup (h : t) : t =
+ let add h k v =
+ if is_set_cookie k then (k, v) :: h
+ else
+ let to_add = ref false in
+ let rec loop = function
+ | [] ->
+ to_add := true;
+ []
+ | (k', v') :: hs ->
+ if caseless_equal k k' then
+ if is_header_with_list_value k then (k, v' ^ "," ^ v) :: hs
+ else (
+ to_add := true;
+ hs)
+ else (k', v') :: loop hs
+ in
+ let h = loop h in
+ if !to_add then (k, v) :: h else h
+ in
+ List.rev h |> List.fold_left (fun acc (k, v) -> add acc k v) []
+
+ let get_multi_concat ?(list_value_only = false) h k : string option =
+ if (not list_value_only) || is_header_with_list_value k then
+ let vs = get_multi h k in
+ match vs with [] -> None | _ -> Some (String.concat "," vs)
+ else get h k
+
+ let parse_content_range s =
+ try
+ let start, fini, total =
+ Scanf.sscanf s "bytes %Ld-%Ld/%Ld" (fun start fini total ->
+ (start, fini, total))
+ in
+ Some (start, fini, total)
+ with Scanf.Scan_failure _ -> None
+
+ (* If we see a "Content-Range" header, than we should limit the
+ number of bytes we attempt to read *)
+ let get_content_range headers =
+ match get headers "content-length" with
+ | Some clen -> Int64.of_string_opt clen
+ | None -> (
+ match get headers "content-range" with
+ | Some range_s -> (
+ match parse_content_range range_s with
+ | Some (start, fini, total) ->
+ (* some sanity checking before we act on these values *)
+ if fini < total && start <= total && 0L <= start && 0L <= total
+ then
+ let num_bytes_to_read = Int64.add (Int64.sub fini start) 1L in
+ Some num_bytes_to_read
+ else None
+ | None -> None)
+ | None -> None)
+
+ let get_connection_close headers =
+ match get headers "connection" with Some "close" -> true | _ -> false
+
+ (* Parse the transfer-encoding and content-length headers to
+ * determine how to decode a body *)
+ let get_transfer_encoding headers =
+ (* It should actually be [get] as the interesting value is actually the last.*)
+ match
+ get_multi_concat ~list_value_only:true headers "transfer-encoding"
+ with
+ | Some "chunked" -> Transfer.Chunked
+ | Some _ | None -> (
+ match get_content_range headers with
+ | Some len -> Transfer.Fixed len
+ | None -> Transfer.Unknown)
+
+ let add_transfer_encoding headers (enc : Transfer.encoding) =
+ (* Only add a header if one doesn't already exist, e.g. from the app *)
+ match (get_transfer_encoding headers, enc) with
+ | Fixed _, _ (* App has supplied a content length, so use that *)
+ | Chunked, _ ->
+ headers (* TODO: this is a protocol violation *)
+ | Unknown, Chunked -> add headers "transfer-encoding" "chunked"
+ | Unknown, Fixed len -> add headers "content-length" (Int64.to_string len)
+ | Unknown, Unknown -> headers
+
+ let get_location headers =
+ match get headers "location" with None -> None | Some u -> Some u
+
+ let connection h =
+ match get h "connection" with
+ | Some v when v = "keep-alive" -> Some `Keep_alive
+ | Some v when v = "close" -> Some `Close
+ | Some x -> Some (`Unknown x)
+ | _ -> None
+end
+
+module Status = struct
+ type informational =
+ [ `Continue | `Switching_protocols | `Processing | `Checkpoint ]
+
+ type success =
+ [ `OK
+ | `Created
+ | `Accepted
+ | `Non_authoritative_information
+ | `No_content
+ | `Reset_content
+ | `Partial_content
+ | `Multi_status
+ | `Already_reported
+ | `Im_used ]
+
+ type redirection =
+ [ `Multiple_choices
+ | `Moved_permanently
+ | `Found
+ | `See_other
+ | `Not_modified
+ | `Use_proxy
+ | `Switch_proxy
+ | `Temporary_redirect
+ | `Permanent_redirect ]
+
+ type client_error =
+ [ `Bad_request
+ | `Unauthorized
+ | `Payment_required
+ | `Forbidden
+ | `Not_found
+ | `Method_not_allowed
+ | `Not_acceptable
+ | `Proxy_authentication_required
+ | `Request_timeout
+ | `Conflict
+ | `Gone
+ | `Length_required
+ | `Precondition_failed
+ | `Request_entity_too_large
+ | `Request_uri_too_long
+ | `Unsupported_media_type
+ | `Requested_range_not_satisfiable
+ | `Expectation_failed
+ | `I_m_a_teapot
+ | `Enhance_your_calm
+ | `Unprocessable_entity
+ | `Locked
+ | `Failed_dependency
+ | `Upgrade_required
+ | `Precondition_required
+ | `Too_many_requests
+ | `Request_header_fields_too_large
+ | `No_response
+ | `Retry_with
+ | `Blocked_by_windows_parental_controls
+ | `Wrong_exchange_server
+ | `Client_closed_request ]
+
+ type server_error =
+ [ `Internal_server_error
+ | `Not_implemented
+ | `Bad_gateway
+ | `Service_unavailable
+ | `Gateway_timeout
+ | `Http_version_not_supported
+ | `Variant_also_negotiates
+ | `Insufficient_storage
+ | `Loop_detected
+ | `Bandwidth_limit_exceeded
+ | `Not_extended
+ | `Network_authentication_required
+ | `Network_read_timeout_error
+ | `Network_connect_timeout_error ]
+
+ type standard =
+ [ informational | success | redirection | client_error | server_error ]
+
+ type t = [ `Code of int | standard ]
+
+ let of_int : int -> t = function
+ | 100 -> `Continue
+ | 101 -> `Switching_protocols
+ | 102 -> `Processing
+ | 103 -> `Checkpoint
+ | 200 -> `OK
+ | 201 -> `Created
+ | 202 -> `Accepted
+ | 203 -> `Non_authoritative_information
+ | 204 -> `No_content
+ | 205 -> `Reset_content
+ | 206 -> `Partial_content
+ | 207 -> `Multi_status
+ | 208 -> `Already_reported
+ | 226 -> `Im_used
+ | 300 -> `Multiple_choices
+ | 301 -> `Moved_permanently
+ | 302 -> `Found
+ | 303 -> `See_other
+ | 304 -> `Not_modified
+ | 305 -> `Use_proxy
+ | 306 -> `Switch_proxy
+ | 307 -> `Temporary_redirect
+ | 308 -> `Permanent_redirect
+ | 400 -> `Bad_request
+ | 401 -> `Unauthorized
+ | 402 -> `Payment_required
+ | 403 -> `Forbidden
+ | 404 -> `Not_found
+ | 405 -> `Method_not_allowed
+ | 406 -> `Not_acceptable
+ | 407 -> `Proxy_authentication_required
+ | 408 -> `Request_timeout
+ | 409 -> `Conflict
+ | 410 -> `Gone
+ | 411 -> `Length_required
+ | 412 -> `Precondition_failed
+ | 413 -> `Request_entity_too_large
+ | 414 -> `Request_uri_too_long
+ | 415 -> `Unsupported_media_type
+ | 416 -> `Requested_range_not_satisfiable
+ | 417 -> `Expectation_failed
+ | 418 -> `I_m_a_teapot
+ | 420 -> `Enhance_your_calm
+ | 422 -> `Unprocessable_entity
+ | 423 -> `Locked
+ | 424 -> `Failed_dependency
+ | 426 -> `Upgrade_required
+ | 428 -> `Precondition_required
+ | 429 -> `Too_many_requests
+ | 431 -> `Request_header_fields_too_large
+ | 444 -> `No_response
+ | 449 -> `Retry_with
+ | 450 -> `Blocked_by_windows_parental_controls
+ | 451 -> `Wrong_exchange_server
+ | 499 -> `Client_closed_request
+ | 500 -> `Internal_server_error
+ | 501 -> `Not_implemented
+ | 502 -> `Bad_gateway
+ | 503 -> `Service_unavailable
+ | 504 -> `Gateway_timeout
+ | 505 -> `Http_version_not_supported
+ | 506 -> `Variant_also_negotiates
+ | 507 -> `Insufficient_storage
+ | 508 -> `Loop_detected
+ | 509 -> `Bandwidth_limit_exceeded
+ | 510 -> `Not_extended
+ | 511 -> `Network_authentication_required
+ | 598 -> `Network_read_timeout_error
+ | 599 -> `Network_connect_timeout_error
+ | cod -> `Code cod
+
+ let to_int : t -> int = function
+ | `Continue -> 100
+ | `Switching_protocols -> 101
+ | `Processing -> 102
+ | `Checkpoint -> 103
+ | `OK -> 200
+ | `Created -> 201
+ | `Accepted -> 202
+ | `Non_authoritative_information -> 203
+ | `No_content -> 204
+ | `Reset_content -> 205
+ | `Partial_content -> 206
+ | `Multi_status -> 207
+ | `Already_reported -> 208
+ | `Im_used -> 226
+ | `Multiple_choices -> 300
+ | `Moved_permanently -> 301
+ | `Found -> 302
+ | `See_other -> 303
+ | `Not_modified -> 304
+ | `Use_proxy -> 305
+ | `Switch_proxy -> 306
+ | `Temporary_redirect -> 307
+ | `Permanent_redirect -> 308
+ | `Bad_request -> 400
+ | `Unauthorized -> 401
+ | `Payment_required -> 402
+ | `Forbidden -> 403
+ | `Not_found -> 404
+ | `Method_not_allowed -> 405
+ | `Not_acceptable -> 406
+ | `Proxy_authentication_required -> 407
+ | `Request_timeout -> 408
+ | `Conflict -> 409
+ | `Gone -> 410
+ | `Length_required -> 411
+ | `Precondition_failed -> 412
+ | `Request_entity_too_large -> 413
+ | `Request_uri_too_long -> 414
+ | `Unsupported_media_type -> 415
+ | `Requested_range_not_satisfiable -> 416
+ | `Expectation_failed -> 417
+ | `I_m_a_teapot -> 418
+ | `Enhance_your_calm -> 420
+ | `Unprocessable_entity -> 422
+ | `Locked -> 423
+ | `Failed_dependency -> 424
+ | `Upgrade_required -> 426
+ | `Precondition_required -> 428
+ | `Too_many_requests -> 429
+ | `Request_header_fields_too_large -> 431
+ | `No_response -> 444
+ | `Retry_with -> 449
+ | `Blocked_by_windows_parental_controls -> 450
+ | `Wrong_exchange_server -> 451
+ | `Client_closed_request -> 499
+ | `Internal_server_error -> 500
+ | `Not_implemented -> 501
+ | `Bad_gateway -> 502
+ | `Service_unavailable -> 503
+ | `Gateway_timeout -> 504
+ | `Http_version_not_supported -> 505
+ | `Variant_also_negotiates -> 506
+ | `Insufficient_storage -> 507
+ | `Loop_detected -> 508
+ | `Bandwidth_limit_exceeded -> 509
+ | `Not_extended -> 510
+ | `Network_authentication_required -> 511
+ | `Network_read_timeout_error -> 598
+ | `Network_connect_timeout_error -> 599
+ | `Code code -> code
+
+ let reason_phrase_of_code : int -> string = function
+ | 100 -> "Continue"
+ | 101 -> "Switching Protocols"
+ | 102 -> "Processing (WebDAV) (RFC 2518)"
+ | 103 -> "Checkpoint"
+ | 200 -> "OK"
+ | 201 -> "Created"
+ | 202 -> "Accepted"
+ | 203 -> "Non-Authoritative Information (since HTTP/1.1)"
+ | 204 -> "No Content"
+ | 205 -> "Reset Content"
+ | 206 -> "Partial Content"
+ | 207 -> "Multi-Status (WebDAV) (RFC 4918)"
+ | 208 -> "Already Reported (WebDAV) (RFC 5842)"
+ | 226 -> "IM Used (RFC 3229)"
+ | 300 -> "Multiple Choices"
+ | 301 -> "Moved Permanently"
+ | 302 -> "Found"
+ | 303 -> "See Other"
+ | 304 -> "Not Modified"
+ | 305 -> "Use Proxy (since HTTP/1.1)"
+ | 306 -> "Switch Proxy"
+ | 307 -> "Temporary Redirect (since HTTP/1.1)"
+ | 308 -> "Permanent Redirect"
+ | 400 -> "Bad Request"
+ | 401 -> "Unauthorized"
+ | 402 -> "Payment Required"
+ | 403 -> "Forbidden"
+ | 404 -> "Not Found"
+ | 405 -> "Method Not Allowed"
+ | 406 -> "Not Acceptable"
+ | 407 -> "Proxy Authentication Required"
+ | 408 -> "Request Timeout"
+ | 409 -> "Conflict"
+ | 410 -> "Gone"
+ | 411 -> "Length Required"
+ | 412 -> "Precondition Failed"
+ | 413 -> "Request Entity Too Large"
+ | 414 -> "Request-URI Too Long"
+ | 415 -> "Unsupported Media Type"
+ | 416 -> "Requested Range Not Satisfiable"
+ | 417 -> "Expectation Failed"
+ | 418 -> "I'm a teapot (RFC 2324)"
+ | 420 -> "Enhance Your Calm"
+ | 422 -> "Unprocessable Entity (WebDAV) (RFC 4918)"
+ | 423 -> "Locked (WebDAV) (RFC 4918)"
+ | 424 -> "Failed Dependency (WebDAV) (RFC 4918)"
+ | 426 -> "Upgrade Required (RFC 2817)"
+ | 428 -> "Precondition Required"
+ | 429 -> "Too Many Requests"
+ | 431 -> "Request Header Fields Too Large"
+ | 444 -> "No Response"
+ | 449 -> "Retry With"
+ | 450 -> "Blocked by Windows Parental Controls"
+ | 451 -> "Wrong Exchange server"
+ | 499 -> "Client Closed Request"
+ | 500 -> "Internal Server Error"
+ | 501 -> "Not Implemented"
+ | 502 -> "Bad Gateway"
+ | 503 -> "Service Unavailable"
+ | 504 -> "Gateway Timeout"
+ | 505 -> "HTTP Version Not Supported"
+ | 506 -> "Variant Also Negotiates (RFC 2295)"
+ | 507 -> "Insufficient Storage (WebDAV) (RFC 4918)"
+ | 508 -> "Loop Detected (WebDAV) (RFC 5842)"
+ | 509 -> "Bandwidth Limit Exceeded (Apache bw/limited extension)"
+ | 510 -> "Not Extended (RFC 2774)"
+ | 511 -> "Network Authentication Required"
+ | 598 -> "Network read timeout error"
+ | 599 -> "Network connect timeout error"
+ | cod -> string_of_int cod
+
+ let compare = Stdlib.compare
+
+ let to_string : t -> string = function
+ | `Code code ->
+ let code = string_of_int code in
+ code ^ " Status " ^ code
+ | #standard as s ->
+ let code = to_int s in
+ string_of_int code ^ " " ^ reason_phrase_of_code code
+
+ let pp fmt t = Format.fprintf fmt "%s" (to_string t)
+end
+
+module Method = struct
+ type t =
+ [ `GET
+ | `POST
+ | `HEAD
+ | `DELETE
+ | `PATCH
+ | `PUT
+ | `OPTIONS
+ | `TRACE
+ | `CONNECT
+ | `Other of string ]
+
+ let to_string : t -> string = function
+ | `GET -> "GET"
+ | `POST -> "POST"
+ | `HEAD -> "HEAD"
+ | `DELETE -> "DELETE"
+ | `PATCH -> "PATCH"
+ | `PUT -> "PUT"
+ | `OPTIONS -> "OPTIONS"
+ | `TRACE -> "TRACE"
+ | `CONNECT -> "CONNECT"
+ | `Other s -> s
+
+ let of_string : string -> t = function
+ | "GET" -> `GET
+ | "POST" -> `POST
+ | "HEAD" -> `HEAD
+ | "DELETE" -> `DELETE
+ | "PATCH" -> `PATCH
+ | "PUT" -> `PUT
+ | "OPTIONS" -> `OPTIONS
+ | "TRACE" -> `TRACE
+ | "CONNECT" -> `CONNECT
+ | s -> `Other s
+
+ (* Defined for method types in RFC7231 *)
+ let body_allowed = function
+ | `GET | `HEAD | `CONNECT | `TRACE -> false
+ | `DELETE | `POST | `PUT | `PATCH | `OPTIONS | `Other _ -> true
+
+ let compare (a : t) (b : t) = Stdlib.compare a b
+ let pp fmt t = Format.fprintf fmt "%s" (to_string t)
+end
+
+module Version = struct
+ type t = [ `HTTP_1_0 | `HTTP_1_1 | `Other of string ]
+
+ let to_string = function
+ | `HTTP_1_0 -> "HTTP/1.0"
+ | `HTTP_1_1 -> "HTTP/1.1"
+ | `Other s -> s
+
+ let of_string = function
+ | "HTTP/1.0" -> `HTTP_1_0
+ | "HTTP/1.1" -> `HTTP_1_1
+ | s -> `Other s
+
+ let compare (a : t) (b : t) = Stdlib.compare a b
+ let pp fmt t = Format.fprintf fmt "%s" (to_string t)
+end
+
+let is_keep_alive version headers =
+ match Header.connection headers with
+ | Some `Close -> false
+ | Some `Keep_alive -> true
+ | Some (`Unknown _) -> false
+ | None -> Version.compare version `HTTP_1_1 = 0
+
+let pp_field field_name pp_v fmt v =
+ Format.fprintf fmt "@[<1>%s:@ %a@]" field_name pp_v v
+
+let content_length requires_content_length headers =
+ let ( let* ) o f = Option.bind o f in
+ if requires_content_length then
+ let* x = Header.get headers "Content-Length" in
+ let* x = int_of_string_opt x in
+ if x >= 0 then Some x else None
+ else None
+
+module Request = struct
+ type t = {
+ headers : Header.t; (** HTTP request headers *)
+ meth : Method.t; (** HTTP request method *)
+ resource : string; (** Request path and query *)
+ version : Version.t; (** HTTP version, usually 1.1 *)
+ }
+
+ let headers t = t.headers
+ let meth t = t.meth
+ let resource t = t.resource
+ let version t = t.version
+
+ let compare { headers; meth; resource; version } y =
+ match Header.compare headers y.headers with
+ | 0 -> (
+ match Method.compare meth y.meth with
+ | 0 -> (
+ match String.compare resource y.resource with
+ | 0 -> Version.compare version y.version
+ | i -> i)
+ | i -> i)
+ | i -> i
+
+ let is_keep_alive { version; headers; _ } = is_keep_alive version headers
+
+ let requires_content_length t =
+ match t.meth with `POST | `PUT | `PATCH -> true | _ -> false
+
+ let content_length t = content_length (requires_content_length t) t.headers
+
+ let supports_chunked_trailers t =
+ Header.get_multi t.headers "TE" |> List.mem "trailers"
+
+ let add_te_trailers t =
+ let headers = Header.add t.headers "TE" "trailers" in
+ let headers = Header.add headers "Connection" "TE" in
+ { t with headers }
+
+ (* Defined for method types in RFC7231 *)
+ let has_body req =
+ if Method.body_allowed req.meth then
+ Transfer.has_body (Header.get_transfer_encoding req.headers)
+ else `No
+
+ let make ?(meth = `GET) ?(version = `HTTP_1_1) ?(headers = Header.empty)
+ resource =
+ { headers; meth; resource; version }
+
+ let pp fmt t =
+ let open Format in
+ pp_open_vbox fmt 0;
+ pp_field "meth" Method.pp fmt t.meth;
+ pp_print_cut fmt ();
+ pp_field "resource" pp_print_string fmt t.resource;
+ pp_print_cut fmt ();
+ pp_field "version" Version.pp fmt t.version;
+ pp_print_cut fmt ();
+ pp_field "headers" Header.pp_hum fmt t.headers;
+ pp_close_box fmt ()
+end
+
+module Response = struct
+ type t = {
+ headers : Header.t; (** response HTTP headers *)
+ version : Version.t; (** (** HTTP version, usually 1.1 *) *)
+ status : Status.t; (** HTTP status code of the response *)
+ }
+
+ let compare { headers; version; status } y =
+ match Header.compare headers y.headers with
+ | 0 -> (
+ match Stdlib.compare status y.status with
+ | 0 -> (
+ match Stdlib.compare status y.status with
+ | 0 -> Version.compare version y.version
+ | i -> i)
+ | i -> i)
+ | i -> i
+
+ let make ?(version = `HTTP_1_1) ?(status = `OK) ?(headers = Header.empty) () =
+ { headers; version; status }
+
+ let headers t = t.headers
+ let version t = t.version
+ let status t = t.status
+ let is_keep_alive { version; headers; _ } = is_keep_alive version headers
+
+ let requires_content_length ?request_meth t =
+ match (Status.to_int t.status, request_meth) with
+ | 204, _ -> false
+ | s, _ when s >= 100 && s < 200 -> false
+ | s, Some meth when s >= 200 && s < 300 && meth = `CONNECT -> false
+ | _, _ -> not (Header.mem t.headers "Transfer-Encoding")
+
+ let content_length t = content_length (requires_content_length t) t.headers
+
+ let pp fmt t =
+ let open Format in
+ pp_open_vbox fmt 0;
+ pp_field "version" Version.pp fmt t.version;
+ pp_print_cut fmt ();
+ pp_field "status" Status.pp fmt t.status;
+ pp_print_cut fmt ();
+ pp_field "headers" Header.pp_hum fmt t.headers;
+ pp_close_box fmt ()
+end
+
+module Parser = struct
+ let[@inline always] is_tchar = function
+ | '0' .. '9'
+ | 'a' .. 'z'
+ | 'A' .. 'Z'
+ | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '^' | '_'
+ | '`' | '|' | '~' ->
+ true
+ | _ -> false
+
+ module Source = struct
+ type t = { buffer : string; mutable pos : int; upper_bound : int }
+
+ let of_bytes ~pos ?len buffer =
+ let buf_len = String.length buffer in
+ if pos < 0 || pos > buf_len then
+ invalid_arg
+ (Printf.sprintf
+ "Http_parser.Source.of_bigstring: Invalid offset %d. Buffer \
+ length: %d"
+ pos buf_len);
+ let len = Option.value len ~default:(buf_len - pos) in
+ if len < 0 || pos + len > buf_len then
+ invalid_arg
+ (Printf.sprintf
+ "Http_parser.Source.of_bigstring: Invalid len %d. offset: %d, \
+ buffer_length: %d, requested_length: %d"
+ len pos buf_len (pos + len));
+ { buffer; pos; upper_bound = pos + len }
+
+ let[@inline always] get_unsafe t idx =
+ String.unsafe_get t.buffer (t.pos + idx)
+
+ let[@inline always] get t idx =
+ if idx < 0 || t.pos + idx >= t.upper_bound then
+ invalid_arg "Http_parser.Source.get: Index out of bounds";
+ String.unsafe_get t.buffer (t.pos + idx)
+
+ let[@inline always] advance_unsafe t count = t.pos <- t.pos + count
+
+ let[@inline always] advance t count =
+ if count < 0 || t.pos + count > t.upper_bound then
+ invalid_arg
+ (Printf.sprintf
+ "Http_parser.Source.advance: Index out of bounds. Requested \
+ count: %d"
+ count);
+ t.pos <- t.pos + count
+
+ let[@inline always] length t = t.upper_bound - t.pos
+ let[@inline always] is_empty t = t.pos = t.upper_bound
+
+ let[@inline always] to_string t ~pos ~len =
+ if
+ pos < 0
+ || t.pos + pos >= t.upper_bound
+ || len < 0
+ || t.pos + pos + len > t.upper_bound
+ then
+ invalid_arg
+ (Format.asprintf
+ "Http_parser.Source.substring: Index out of bounds., Requested \
+ off: %d, len: %d"
+ pos len);
+ String.sub t.buffer (t.pos + pos) len
+
+ let[@inline always] is_space = function
+ | ' ' | '\012' | '\n' | '\r' | '\t' -> true
+ | _ -> false
+
+ let[@inline always] to_string_trim t ~pos ~len =
+ if
+ pos < 0
+ || t.pos + pos >= t.upper_bound
+ || len < 0
+ || t.pos + pos + len > t.upper_bound
+ then
+ invalid_arg
+ (Format.asprintf
+ "Http_parser.Source.substring: Index out of bounds., Requested \
+ off: %d, len: %d"
+ pos len);
+ let last = ref (t.pos + pos + len - 1) in
+ let pos = ref (t.pos + pos) in
+ while is_space (String.unsafe_get t.buffer !pos) do
+ incr pos
+ done;
+ while is_space (String.unsafe_get t.buffer !last) do
+ decr last
+ done;
+ let len = !last - !pos + 1 in
+ if len < 0 then "" else String.sub t.buffer !pos len
+
+ let rec index_rec t ch idx len =
+ if idx = len then -1
+ else if String.unsafe_get t.buffer (t.pos + idx) = ch then idx
+ else index_rec t ch (idx + 1) len
+
+ let index t ch = index_rec t ch 0 (length t)
+
+ let for_all_is_tchar t ~pos ~len =
+ if
+ pos < 0
+ || t.pos + pos >= t.upper_bound
+ || len < 0
+ || t.pos + pos + len > t.upper_bound
+ then
+ invalid_arg
+ (Format.asprintf
+ "Http_parser.Source.substring: Index out of bounds. Requested \
+ off: %d, len: %d"
+ pos len);
+ let pos = ref (t.pos + pos) in
+ let len = t.pos + len in
+ while !pos < len && is_tchar (String.unsafe_get t.buffer !pos) do
+ incr pos
+ done;
+ !pos = len
+
+ let unsafe_memcmp t pos str =
+ let rec loop t pos str len =
+ if pos = len then true
+ else
+ Char.equal (get_unsafe t pos) (String.unsafe_get str pos)
+ && loop t (pos + 1) str len
+ in
+ loop t pos str (String.length str)
+ end
+
+ exception Msg of string
+ exception Partial
+
+ let string str source =
+ let len = String.length str in
+ if Source.length source < len then raise_notrace Partial
+ else if Source.unsafe_memcmp source 0 str then Source.advance source len
+ else raise_notrace (Msg (Printf.sprintf "Could not match: %S" str))
+
+ let any_char source =
+ if Source.is_empty source then raise_notrace Partial
+ else
+ let c = Source.get_unsafe source 0 in
+ Source.advance_unsafe source 1;
+ c
+
+ let eol = string "\r\n"
+
+ (* token = 1*tchar tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^"
+ / "_" / "`" / "|" / "~" / DIGIT / ALPHA ; any VCHAR, except delimiters *)
+
+ let token source =
+ let pos = Source.index source ' ' in
+ if pos = -1 then raise_notrace Partial
+ else
+ let res = Source.to_string source ~pos:0 ~len:pos in
+ Source.advance source (pos + 1);
+ res
+
+ let meth source =
+ let token = token source in
+ Method.of_string token
+
+ let version_source source =
+ string "HTTP/1." source;
+ any_char source
+
+ let version source =
+ let ch = version_source source in
+ match ch with
+ | '1' -> `HTTP_1_1
+ | '0' -> `HTTP_1_0
+ | _ -> raise_notrace (Msg "Invalid http version")
+
+ let header source =
+ let pos = Source.index source ':' in
+ if pos = -1 then raise_notrace Partial
+ else if pos = 0 then raise_notrace (Msg "Invalid header: Empty header key")
+ else if Source.for_all_is_tchar source ~pos:0 ~len:pos then (
+ let key = Source.to_string source ~pos:0 ~len:pos in
+ Source.advance_unsafe source (pos + 1);
+ while
+ (not (Source.is_empty source)) && Source.get_unsafe source 0 = ' '
+ do
+ Source.advance_unsafe source 1
+ done;
+ let pos = Source.index source '\r' in
+ if pos = -1 then raise_notrace Partial
+ else
+ let v = Source.to_string_trim source ~pos:0 ~len:pos in
+ Source.advance_unsafe source pos;
+ (key, v))
+ else raise_notrace (Msg "Invalid Header Key")
+
+ let headers =
+ let rec loop source acc =
+ if (not (Source.is_empty source)) && Source.get_unsafe source 0 = '\r'
+ then (
+ eol source;
+ Header.of_list (List.rev acc))
+ else
+ let v = header source in
+ eol source;
+ loop source (v :: acc)
+ in
+ fun source -> loop source []
+
+ let chunk_length source =
+ let ( lsl ) = Int64.shift_left in
+ let ( lor ) = Int64.logor in
+ let length = ref 0L in
+ let stop = ref false in
+ let state = ref `Ok in
+ let count = ref 0 in
+ let processing_chunk = ref true in
+ let in_chunk_extension = ref false in
+ while not !stop do
+ if Source.is_empty source then (
+ stop := true;
+ state := `Partial)
+ else if !count = 16 && not !in_chunk_extension then (
+ stop := true;
+ state := `Chunk_too_big)
+ else
+ let ch = Source.get source 0 in
+ Source.advance source 1;
+ incr count;
+ match ch with
+ | '0' .. '9' as ch when !processing_chunk ->
+ let curr = Int64.of_int (Char.code ch - Char.code '0') in
+ length := (!length lsl 4) lor curr
+ | 'a' .. 'f' as ch when !processing_chunk ->
+ let curr = Int64.of_int (Char.code ch - Char.code 'a' + 10) in
+ length := (!length lsl 4) lor curr
+ | 'A' .. 'F' as ch when !processing_chunk ->
+ let curr = Int64.of_int (Char.code ch - Char.code 'A' + 10) in
+ length := (!length lsl 4) lor curr
+ | ';' when not !in_chunk_extension ->
+ in_chunk_extension := true;
+ processing_chunk := false
+ | ('\t' | ' ') when !processing_chunk -> processing_chunk := false
+ | ('\t' | ' ') when (not !in_chunk_extension) && not !processing_chunk
+ ->
+ ()
+ | '\r' ->
+ if Source.is_empty source then (
+ stop := true;
+ state := `Partial)
+ else if Source.get source 0 = '\n' then (
+ Source.advance source 1;
+ stop := true)
+ else (
+ stop := true;
+ state := `Expected_newline)
+ | _ when !in_chunk_extension ->
+ (* Chunk extensions aren't very common, see:
+ https://tools.ietf.org/html/rfc7230#section-4.1.1 Chunk extensions aren't
+ pre-defined, and they are specific to invidividual connections. In the future
+ we might surface these to the user somehow, but for now we will ignore any
+ extensions. TODO: Should there be any limit on the size of chunk extensions we
+ parse? We might want to error if a request contains really large chunk
+ extensions. *)
+ ()
+ | ch ->
+ stop := true;
+ state := `Invalid_char ch
+ done;
+ match !state with
+ | `Ok -> !length
+ | `Partial -> raise_notrace Partial
+ | `Expected_newline -> raise_notrace (Msg "Expected_newline")
+ | `Chunk_too_big -> raise_notrace (Msg "Chunk size is too large")
+ | `Invalid_char ch ->
+ raise_notrace
+ (Msg (Printf.sprintf "Invalid chunk_length character %C" ch))
+
+ let version source =
+ let version = version source in
+ eol source;
+ version
+
+ let[@warning "-3"] request source =
+ let meth = meth source in
+ let path = token source in
+ let version = version source in
+ let headers = headers source in
+ { Request.headers; meth; resource = path; version }
+
+ type error = Partial | Msg of string
+
+ let run_parser ?pos ?len buf p =
+ let pos = Option.value pos ~default:0 in
+ let source = Source.of_bytes ~pos ?len buf in
+ match p source with
+ | exception Partial -> Error Partial
+ | exception Msg m -> Error (Msg m)
+ | v ->
+ let consumed = source.pos - pos in
+ Ok (v, consumed)
+
+ let parse_request ?pos ?len buf = run_parser ?pos ?len buf request
+ let parse_chunk_length ?pos ?len buf = run_parser ?pos ?len buf chunk_length
+end
+
+module Private = struct
+ module Parser = Parser
+end
--- /dev/null
+module Version : sig
+ type t = [ `HTTP_1_0 | `HTTP_1_1 | `Other of string ]
+
+ val compare : t -> t -> int
+ val of_string : string -> t
+ val to_string : t -> string
+ val pp : Format.formatter -> t -> unit
+end
+
+module Method : sig
+ type t =
+ [ `GET
+ | `POST
+ | `HEAD
+ | `DELETE
+ | `PATCH
+ | `PUT
+ | `OPTIONS
+ | `TRACE
+ | `CONNECT
+ | `Other of string ]
+
+ val compare : t -> t -> int
+
+ val body_allowed : t -> bool
+ (** [body_allowed meth] returns whether [meth] allows a payload body to be
+ present per RFC7231. *)
+
+ val of_string : string -> t
+ val to_string : t -> string
+ val pp : Format.formatter -> t -> unit
+end
+
+module Status : sig
+ type informational =
+ [ `Continue (** Client should continue with request *)
+ | `Switching_protocols (** Server is switching protocols *)
+ | `Processing (** Server has received and is processing the request *)
+ | `Checkpoint (** resume aborted PUT or POST requests *) ]
+ (** Informational *)
+
+ type success =
+ [ `OK (** standard response for successful HTTP requests *)
+ | `Created (** request has been fulfilled; new resource created *)
+ | `Accepted (** request accepted, processing pending *)
+ | `Non_authoritative_information
+ (** request processed, information may be from another source *)
+ | `No_content (** request processed, no content returned *)
+ | `Reset_content
+ (** request processed, no content returned, reset document view *)
+ | `Partial_content (** partial resource return due to request header *)
+ | `Multi_status (** XML, can contain multiple separate responses *)
+ | `Already_reported (** results previously returned *)
+ | `Im_used (** request fulfilled, response is instance-manipulations *) ]
+ (** Success *)
+
+ type redirection =
+ [ `Multiple_choices (** multiple options for the resource delivered *)
+ | `Moved_permanently
+ (** this and all future requests directed to the given URI *)
+ | `Found (** temporary response to request found via alternative URI *)
+ | `See_other (** permanent response to request found via alternative URI *)
+ | `Not_modified (** resource has not been modified since last requested *)
+ | `Use_proxy (** content located elsewhere, retrieve from there *)
+ | `Switch_proxy (** subsequent requests should use the specified proxy *)
+ | `Temporary_redirect (** connect again to different URI as provided *)
+ | `Permanent_redirect
+ (** connect again to a different URI using the same method *) ]
+ (** Redirection *)
+
+ type client_error =
+ [ `Bad_request (** request cannot be fulfilled due to bad syntax *)
+ | `Unauthorized (** authentication is possible but has failed *)
+ | `Payment_required (** payment required, reserved for future use *)
+ | `Forbidden (** server refuses to respond to request *)
+ | `Not_found (** requested resource could not be found *)
+ | `Method_not_allowed (** request method not supported by that resource *)
+ | `Not_acceptable
+ (** content not acceptable according to the Accept headers *)
+ | `Proxy_authentication_required
+ (** client must first authenticate itself with the proxy *)
+ | `Request_timeout (** server timed out waiting for the request *)
+ | `Conflict (** request could not be processed because of conflict *)
+ | `Gone
+ (** resource is no longer available and will not be available again *)
+ | `Length_required (** request did not specify the length of its content *)
+ | `Precondition_failed (** server does not meet request preconditions *)
+ | `Request_entity_too_large
+ (** request is larger than the server is willing or able to process *)
+ | `Request_uri_too_long
+ (** URI provided was too long for the server to process *)
+ | `Unsupported_media_type (** server does not support media type *)
+ | `Requested_range_not_satisfiable
+ (** client has asked for unprovidable portion of the file *)
+ | `Expectation_failed
+ (** server cannot meet requirements of Expect request-header field *)
+ | `I_m_a_teapot (** I'm a teapot *)
+ | `Enhance_your_calm (** Twitter rate limiting *)
+ | `Unprocessable_entity
+ (** request unable to be followed due to semantic errors *)
+ | `Locked (** resource that is being accessed is locked *)
+ | `Failed_dependency
+ (** request failed due to failure of a previous request *)
+ | `Upgrade_required (** client should switch to a different protocol *)
+ | `Precondition_required
+ (** origin server requires the request to be conditional *)
+ | `Too_many_requests
+ (** user has sent too many requests in a given amount of time *)
+ | `Request_header_fields_too_large
+ (** server is unwilling to process the request *)
+ | `No_response
+ (** server returns no information and closes the connection *)
+ | `Retry_with (** request should be retried after performing action *)
+ | `Blocked_by_windows_parental_controls
+ (** Windows Parental Controls blocking access to webpage *)
+ | `Wrong_exchange_server
+ (** the server cannot reach the client's mailbox *)
+ | `Client_closed_request
+ (** connection closed by client while HTTP server is processing *) ]
+ (** Client_error *)
+
+ type server_error =
+ [ `Internal_server_error (** generic error message *)
+ | `Not_implemented
+ (** server does not recognise method or lacks ability to fulfill *)
+ | `Bad_gateway
+ (** server received an invalid response from upstream server *)
+ | `Service_unavailable (** server is currently unavailable *)
+ | `Gateway_timeout
+ (** gateway did not receive response from upstream server *)
+ | `Http_version_not_supported
+ (** server does not support the HTTP protocol version *)
+ | `Variant_also_negotiates
+ (** content negotiation for the request results in a circular reference *)
+ | `Insufficient_storage (** server is unable to store the representation *)
+ | `Loop_detected
+ (** server detected an infinite loop while processing the request *)
+ | `Bandwidth_limit_exceeded (** bandwidth limit exceeded *)
+ | `Not_extended (** further extensions to the request are required *)
+ | `Network_authentication_required
+ (** client needs to authenticate to gain network access *)
+ | `Network_read_timeout_error (** network read timeout behind the proxy *)
+ | `Network_connect_timeout_error
+ (** network connect timeout behind the proxy *) ]
+ (** Server_error *)
+
+ type standard =
+ [ informational | success | redirection | client_error | server_error ]
+
+ type t = [ `Code of int | standard ]
+
+ val compare : t -> t -> int
+ val to_string : t -> string
+ val to_int : t -> int
+ val of_int : int -> t
+ val reason_phrase_of_code : int -> string
+ val pp : Format.formatter -> t -> unit
+end
+
+module Transfer : sig
+ (** Read and write the HTTP/1.1 transfer-encoding formats. Currently supported
+ are [chunked] and [content-length]. *)
+
+ (** The encoding format detected from the [transfer-encoding] and
+ [content-length] headers *)
+ type encoding =
+ | Chunked (** dynamic chunked encoding *)
+ | Fixed of int64 (** fixed size content *)
+ | Unknown (** unknown body size, which leads to best-effort *)
+
+ val compare_encoding : encoding -> encoding -> int
+
+ module Private : sig
+ val has_body : encoding -> [ `No | `Unknown | `Yes ]
+ end
+end
+
+module Header : sig
+ (** Associative list representing HTTP headers. Order of transmission is
+ preserved, which implies that headers with same name are neither removed
+ or concataned by default (see [clean_dup] to do that). *)
+ type t
+ (** The type for HTTP headers. *)
+
+ val init : unit -> t
+ (** [init ()] constructs a fresh, empty list of HTTP headers. *)
+
+ val is_empty : t -> bool
+ (** [is_empty h] tests whether HTTP headers [h] are empty or not. *)
+
+ val of_list_rev : (string * string) list -> t
+
+ val of_list : (string * string) list -> t
+ (** [of_list l] construct a fresh headers from the content of [l] and in same
+ order. [to_list] and [of_list] are defined such as
+ [to_list (of_list l) = l] is true with case insensitive comparison. *)
+
+ val to_list : t -> (string * string) list
+ (** [to_list h] converts HTTP headers [h] to a list. Order and case is
+ preserved.
+
+ {e Invariant (with case insensitive comparison):}
+ [to_list (of_list l) = l] *)
+
+ val init_with : string -> string -> t
+ (** [init_with k v] construct a fresh HTTP headers with a single header with
+ name [k] and value [v]. *)
+
+ val add : t -> string -> string -> t
+ (** [add h k v] adds the header name [k] and its associated value [v] at the
+ front of header list [h]. *)
+
+ val add_list : t -> (string * string) list -> t
+ (** [add_list h l] adds in order all header pairs contained in [l] to the
+ header list [h].
+
+ {e Invariant (with case insensitive comparison):}
+ [to_list (add_list h l) = to_list h @ l] *)
+
+ val add_multi : t -> string -> string list -> t
+ (** [add_multi h k vs] add multiple header pairs with same name [h] and values
+ contained in [vs] in [h]. The new headers are in the same order that in
+ [vs].
+
+ {e Invariant:} [get_multi (add_multi h k vs) k = (get_multi h k) @ vs] *)
+
+ val add_opt : t option -> string -> string -> t
+ (** [add_opt hopt k v] adds the header [(k, v)] to [h] if [hopt] is [Some h],
+ or constructs a fresh header list containing this single header if [hopt]
+ is [None]. *)
+
+ val add_unless_exists : t -> string -> string -> t
+ (** [add_unless_exists h k v] adds [(k, v)] to [h] unless the header name [k]
+ is already present in the header. *)
+
+ val add_opt_unless_exists : t option -> string -> string -> t
+ (** [add_opt_unless_exists h k v] adds [(k, v)] to [h] if [hopt] is [Some h]
+ unless the header name [k] is already present in the headers. If [h] is
+ [None] then a fresh header list is constructed containing the header
+ [(k, v)]. *)
+
+ val remove : t -> string -> t
+ (** [remove h k] removes every values associated to the header name [k] from
+ [h]. *)
+
+ val replace : t -> string -> string -> t
+ (** [replace h k v] replaces the last added value of [k] from [h] and removed
+ all other occurrences of [k] if it exists. Otherwise it adds [(k, v)] to
+ [h].
+
+ {e Invariant:} [forall h, k, v. get_multi (replace h k v) = [ v ]] *)
+
+ val mem : t -> string -> bool
+ (** [mem h k] returns [true] if the header name [k] appears in [h] and [false]
+ otherwise. *)
+
+ val compare : t -> t -> int
+ (** [compare h h'] is the structural comparison of two [Header] values. *)
+
+ val get : t -> string -> string option
+ (** [get h k] returns [Some v] where [v] is the last added value associated
+ with [k] in [h] if it exists and [None] otherwise *)
+
+ val get_multi : t -> string -> string list
+ (** [get_multi h k] returns a list of all values associated with [k] in [h] in
+ order they appear in it. *)
+
+ val get_multi_concat : ?list_value_only:bool -> t -> string -> string option
+ (** [get_multi_concat h k] returns [Some v] if there is at least one value
+ associated with [k] in [h] and [None] otherwise. [v] is the concatenation
+ of all values paired with [k] in [h], separated by a comma and in order
+ they appear in [h].
+
+ The optional argument [?list_value_only] is [false] by default. If it is
+ [true] and there is at least one value associated to [k], the returned
+ value is the concatenated values only if [k] is a header that can have
+ multiple values (like transfer-encoding or accept). Otherwise, the
+ returned value is the last value paired with [k] in [h].
+
+ {e Invariant:}
+ [forall h, k not a list-value header. get_multi_concat ~list-value-only:true h k = get h k] *)
+
+ val update : t -> string -> (string option -> string option) -> t
+ (** [update h k f] returns an header list containing the same headers as [h],
+ except for the header name [k]. Depending on the value of [v] where [v] is
+ [f (get h k)], the header pair [(k, v)] is added, removed or updated.
+
+ - If [v] is [None], the last occurrence of [k] in [h] is removed;
+
+ - If [v] is [Some w] then the last value paired with [k] in [h] is
+ replaced by [w] if it exists. Otherwise, the pair [(k, w)] is added;
+
+ - If [k] was already associated last in [h] to a value that is physically
+ equal to [w], [h] is returned unchanged. *)
+
+ val update_all : t -> string -> (string list -> string list) -> t
+ (** [update_all h k f] returns an header list containing the same headers as
+ [h], except for the header [k]. Depending on the list of values [vs] where
+ [vs] is [f (get_multi h k)], the values associated to the header [k] are
+ added, removed or updated.
+
+ - If [vs] is an empty list, every occurrences of the header [k] in [h] are
+ removed;
+
+ - If [vs] is a non-empty list, all values previously associated to [k] are
+ removed and all values in [vs] are added with [add_multi];
+
+ - If [k] was already associated in [h] to a list that is equal to [vs],
+ [h] is returned unchanged. *)
+
+ val iter_ord : (string -> string -> unit) -> t -> unit
+ (** [iter_ord f h] applies [f] to all the headers of [h] following the header
+ order. *)
+
+ val iter : (string -> string -> unit) -> t -> unit
+ (** [iter f h] applies [f] to all the headers of [h] following an unspecified
+ order. This function is faster than iter_ord. *)
+
+ val map : (string -> string -> string) -> t -> t
+ val fold : (string -> string -> 'a -> 'a) -> t -> 'a -> 'a
+
+ val to_lines : t -> string list
+ (** [to_lines h] returns header fields as a list of lines. Beware that each
+ line ends with "\r\n" characters. *)
+
+ val to_frames : t -> string list
+ (** [to_frames h] returns the same as {!to_lines} but lines do not end with
+ "\r\n" characters. *)
+
+ val to_string : t -> string
+
+ val clean_dup : t -> t
+ (** [clean_dup h] cleans duplicates in [h] following
+ {{:https://tools.ietf.org/html/rfc7230#section-3.2.2} RFC7230§3.2.2}; if a
+ duplicated header can not have multiple values, only the last value is
+ kept in place. Otherwise, the values are concatenated and place at the
+ first position the header is encountered in [h].
+
+ Already concatenated values (like [anhost.com, anotherhost.com] in the
+ example below) are not affected by [clean_dup]. For example,
+
+ {v
+ transfer-encoding: gzip
+ host: afirsthost.com
+ connection: keep-alive
+ host: anhost.com, anotherhost.com
+ transfer-encoding: chunked
+ v}
+
+ becomes
+
+ {v
+ transfer-encoding: gzip, chunked
+ connection: keep-alive
+ host: anhost.com, anotherhost.com
+ v}
+
+ Finally, following
+ {{:https://tools.ietf.org/html/rfc7230#section-3.2.2} RFC7230§3.2.2}, the
+ header [Set-cookie] is treated as an exception and ignored by [clean_dup]. *)
+
+ val get_content_range : t -> Int64.t option
+ val get_connection_close : t -> bool
+
+ val get_transfer_encoding : t -> Transfer.encoding
+ (** [get_transfer_encoding h] checks the "content-length", "content-range" and
+ "transfer-encoding" headers to infer the transfer encoding. Uses Unknown
+ if nothing is found.*)
+
+ val add_transfer_encoding : t -> Transfer.encoding -> t
+ val connection : t -> [ `Keep_alive | `Close | `Unknown of string ] option
+ val get_location : t -> string option
+
+ val pp_hum : Format.formatter -> t -> unit
+ (** Human-readable output, used by the toplevel printer *)
+
+ module Private : sig
+ val caseless_equal : string -> string -> bool
+ (** [caseless_equal a b] must be equivalent to
+ [String.equal (String.lowercase_ascii a) (String.lowercase_ascii b)]. *)
+ end
+end
+
+module Request : sig
+ type t = {
+ headers : Header.t; (** HTTP request headers *)
+ meth : Method.t; (** HTTP request method *)
+ resource : string; (** Request path and query *)
+ version : Version.t; (** HTTP version, usually 1.1 *)
+ }
+
+ val has_body : t -> [ `No | `Unknown | `Yes ]
+ val headers : t -> Header.t
+ val meth : t -> Method.t
+ val resource : t -> string
+ val version : t -> Version.t
+ val compare : t -> t -> int
+
+ val is_keep_alive : t -> bool
+ (** Return true whether the connection should be reused *)
+
+ val requires_content_length : t -> bool
+ (** [requires_content_length t] is [true] if [t.meth] is one of
+ [`POST, `PUT or `PATCH]. Otherwise it is [false].
+
+ A [true] value indicates that a request must include a "Content-Length"
+ header.
+
+ See https://www.rfc-editor.org/rfc/rfc7230#section-3.3.2 *)
+
+ val content_length : t -> int option
+ (** [content_length t] is [Some x] if the "Content-Length" header in [t]
+ exists and its value [x] is a non negative integer, [x>=0]
+
+ It is [None] if [requires_content_length t = false] or the value encoded
+ in "Content-Length" is not a valid integer value, i.e [>= 0].
+
+ See https://www.rfc-editor.org/rfc/rfc7230#section-3.3.2 *)
+
+ val supports_chunked_trailers : t -> bool
+ (** [supports_chunked_trailers t] is [true] if [t] contains HTTP header "TE:
+ trailers". Otherwise it is [false]. *)
+
+ val add_te_trailers : t -> t
+ (** [add_te_trailers t] adds HTTP headers, 'TE' and 'Connection' to indicate
+ that a user-agent can handle HTTP chunked trailers headers. *)
+
+ val make :
+ ?meth:Method.t -> ?version:Version.t -> ?headers:Header.t -> string -> t
+ (** [make resource] is a value of {!type:t}. The default values for the
+ response, if not specified, are as follows: [meth] is [`GET], [version] is
+ [`HTTP_1_1], [headers] is [Header.empty]. The request encoding value is
+ determined via the [Header.get_transfer_encoding] function.*)
+
+ val pp : Format.formatter -> t -> unit
+end
+
+module Response : sig
+ type t = {
+ headers : Header.t; (** response HTTP headers *)
+ version : Version.t; (** (** HTTP version, usually 1.1 *) *)
+ status : Status.t; (** HTTP status code of the response *)
+ }
+
+ val headers : t -> Header.t
+ val version : t -> Version.t
+ val status : t -> Status.t
+ val compare : t -> t -> int
+
+ val is_keep_alive : t -> bool
+ (** Return true whether the connection should be reused *)
+
+ val requires_content_length : ?request_meth:Method.t -> t -> bool
+ (** [requires_content_length ~request_meth t] is [true] if a combination of
+ [t] and [request_meth] indicates that a response message must include
+ "Content-Length" header. However, please note exceptions to this:
+
+ - Response with status code of [304] may or may not include the header.
+ - Response to request with method [HEAD] may or may not include the
+ header.
+
+ https://www.rfc-editor.org/rfc/rfc7230#section-3.3.2 *)
+
+ val content_length : t -> int option
+ (** [content_length t] is [Some x] if the "Content-Length" header in [t]
+ exists and its value [x] is a non negative integer, [x>=0]
+
+ It is [None] if [requires_content_length t = false] or the value encoded
+ in "Content-Length" is not a valid integer value, i.e [>= 0].
+
+ See https://www.rfc-editor.org/rfc/rfc7230#section-3.3.2 *)
+
+ val make :
+ ?version:Version.t -> ?status:Status.t -> ?headers:Header.t -> unit -> t
+ (** [make ()] is a value of {!type:t}. The default values for the request, if
+ not specified, are: [status] is [`Ok], [version] is [`HTTP_1_1]. The
+ request encoding value is determined via the
+ [Header.get_transfer_encoding] function. *)
+
+ val pp : Format.formatter -> t -> unit
+end
+
+module Private : sig
+ module Parser : sig
+ (** Attempts to parse a buffer into a HTTP request. If successful, it
+ returns the parsed request and an offset value that indicates the
+ starting point of unconsumed content left in the buffer. *)
+
+ type error = Partial | Msg of string
+
+ val parse_request :
+ ?pos:int -> ?len:int -> string -> (Request.t * int, error) result
+
+ val parse_chunk_length :
+ ?pos:int -> ?len:int -> string -> (int64 * int, error) result
+ end
+end
--- /dev/null
+module Bytebuffer = Http_bytebuffer.Bytebuffer
+
+module Src = struct
+ type src = { str : string; mutable pos : int; mutable reads : int }
+
+ let create str = { str; pos = 0; reads = 10 }
+
+ let refill r buf ~pos ~len =
+ if r.reads = 0 then raise Exit
+ else (
+ r.reads <- r.reads - 1;
+ let available = String.length r.str - r.pos in
+ if available = 0 then `Eof
+ else
+ let read_len = min len available in
+ BytesLabels.blit_string ~src:r.str ~src_pos:r.pos ~dst:buf ~dst_pos:pos
+ ~len:read_len;
+ r.pos <- r.pos + read_len;
+ `Ok read_len)
+end
+
+module Refill =
+ Bytebuffer.Make
+ (struct
+ type 'a t = 'a
+
+ let ( >>| ) x f = f x
+ let ( >>= ) x f = f x
+ let return x = x
+ end)
+ (Src)
+
+let%expect_test "read line" =
+ let test line buf_size =
+ let src = Src.create line in
+ let buf = Bytebuffer.create buf_size in
+ let res = Refill.read_line buf src in
+ match res with
+ | None -> print_endline "failed to read line"
+ | Some line -> Printf.printf "read line: %S\n" line
+ | exception Exit -> print_endline "failed to read - infinite loop"
+ in
+ let line = "foobar\r\n" in
+ test line (String.length line);
+ [%expect {| read line: "foobar" |}];
+ test line (String.length line - 1);
+ [%expect {| read line: "foobar" |}];
+ let line = "foobar\r\n" in
+ test line (String.length line - 1);
+ [%expect {| read line: "foobar" |}];
+ test line (String.length line);
+ [%expect {| read line: "foobar" |}];
+ let line = "foobar\r" in
+ test line (String.length line + 10);
+ [%expect {| failed to read line |}];
+ test line (String.length line - 1);
+ [%expect {| failed to read line |}]
+
+let%expect_test "read fixed" =
+ let src = "foobar" in
+ let src_len = String.length src in
+ let test buf_size =
+ let src = Src.create src in
+ let buf = Bytebuffer.create buf_size in
+ match Refill.read buf src src_len with
+ | res ->
+ Printf.printf "buf size=%d: reading %d bytes we get %d bytes\n" buf_size
+ src_len (String.length res)
+ | exception Exit -> print_endline "failed to read - infinite loop"
+ in
+ test src_len;
+ [%expect {| buf size=6: reading 6 bytes we get 6 bytes |}];
+ test (src_len - 1);
+ [%expect {| buf size=5: reading 6 bytes we get 5 bytes |}]
--- /dev/null
+(library
+ (name bytebuffer_tests)
+ (libraries http_bytebuffer)
+ (inline_tests)
+ (preprocess
+ (pps ppx_expect)))
--- /dev/null
+(executable
+ (name test_header)
+ (modules test_header)
+ (forbidden_libraries base)
+ (libraries http alcotest sexplib0))
+
+(rule
+ (alias runtest)
+ (package http)
+ (action
+ (run ./test_header.exe)))
+
+(test
+ (name test_parser)
+ (modules test_parser)
+ (package http)
+ (preprocess
+ (pps
+ base_quickcheck.ppx_quickcheck
+ ppx_assert
+ ppx_sexp_conv
+ ppx_compare
+ ppx_here))
+ (libraries http base_quickcheck alcotest))
+
+(test
+ (name test_request)
+ (modules test_request)
+ (package http)
+ (libraries http alcotest))
+
+(test
+ (name test_response)
+ (modules test_response)
+ (package http)
+ (libraries http alcotest))
--- /dev/null
+(library
+ (name http_tests)
+ (libraries http)
+ (inline_tests)
+ (preprocess
+ (pps ppx_expect)))
--- /dev/null
+module Parser = Http.Private.Parser
+
+let print_request = function
+ | Error Parser.Partial -> print_endline "partial header"
+ | Error (Msg m) -> print_endline m
+ | Ok (req, n) ->
+ Format.printf "%a@." Http.Request.pp req;
+ if n > 0 then Format.printf "leftover: %d@." n
+
+let%expect_test "line folding" =
+ let buf =
+ "GET / HTTP/1.1\r\n\
+ Host: localhost:8080\r\n\
+ Line-Folded: foo\r\n\
+ \ bar\r\n\
+ \r\n\
+ foboar"
+ in
+ print_request (Parser.parse_request buf);
+ [%expect {| partial header |}]
--- /dev/null
+(*{{{ Copyright (c) 2021 Carine Morel <carine@tarides.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *}}}*)
+
+module H = Http.Header
+(** These tests try as much as possible to tests each header functions
+ independently. *)
+
+let aei = Alcotest.check Alcotest.int
+let aes = Alcotest.check Alcotest.string
+let aeso = Alcotest.check Alcotest.(option string)
+let aesl = Alcotest.check Alcotest.(list string)
+let aessl = Alcotest.check Alcotest.(list (pair string string))
+let aeb = Alcotest.check Alcotest.bool
+
+let t_header =
+ let open Sexplib0.Sexp_conv in
+ let sexp_of_t t =
+ sexp_of_list (sexp_of_pair sexp_of_string sexp_of_string) (H.to_list t)
+ in
+ Alcotest.testable
+ (fun fmt h ->
+ let sexp = sexp_of_t h in
+ Sexplib0.Sexp.pp_hum fmt sexp)
+ (fun x y -> H.compare x y = 0)
+
+let aeh = Alcotest.check t_header
+
+let hstr =
+ [
+ ("accept", "application/xml");
+ ("transfer-encoding", "chunked");
+ ("accept", "text/html");
+ ("content-length", "100");
+ ]
+
+let prebuilt = H.of_list hstr
+
+let to_list_tests () =
+ aessl "to_list (init ())" [] H.(to_list (init ()));
+ aessl "to_list (add (init ()) k v"
+ [ ("a", "a1") ]
+ H.(to_list (add (init ()) "a" "a1"));
+ aessl "to_list (of_list h) = h" hstr H.(to_list prebuilt)
+
+let is_empty_tests () =
+ aeb "is_empty (init ())" true H.(is_empty (init ()));
+ aeb "is_empty (add (init ()) k v" false H.(is_empty (add (init ()) "a" "a1"));
+ aeb "is_empty (remove (add (init ()) k v) k)" true
+ H.(is_empty (remove (add (init ()) "a" "a1") "a"))
+
+let init_with_tests () =
+ aessl "init_with k v"
+ [ ("traNsfer-eNcoding", "chunked") ]
+ H.(to_list (init_with "traNsfer-eNcoding" "chunked"))
+
+let mem_tests () =
+ aeb "mem (init ()) k = false" false H.(mem (init ()) "a");
+ aeb "mem h k" true H.(mem prebuilt "accept");
+ aeb "mem h k" true H.(mem prebuilt "content-length");
+ aeb "mem h k" false H.(mem prebuilt "a")
+
+let add_tests () =
+ aessl "add h k v" (hstr @ [ ("a", "a1") ]) H.(to_list (add prebuilt "a" "a1"));
+ aessl "add (add h k v) k v"
+ (hstr @ [ ("a", "a1"); ("a", "a1") ])
+ H.(to_list (add (add prebuilt "a" "a1") "a" "a1"));
+ aessl "add (add h k' v') k v"
+ (hstr @ [ ("a", "a1"); ("b", "b1") ])
+ H.(to_list (add (add prebuilt "a" "a1") "b" "b1"))
+
+let get_tests () =
+ aeso "get (add (init () k v) k" (Some "a1")
+ H.(get (add (init ()) "a" "a1") "a");
+ aeso "get (add h k v) k when mem h k = false" (Some "a1")
+ H.(get (add prebuilt "a" "a1") "a");
+ aeso "get (add h k v) k when mem h k = true" (Some "text/html")
+ H.(get (add prebuilt "a" "a1") "accept");
+ aeso "get (add (add h k v') k v) k = v" (Some "a2")
+ H.(get (add (add prebuilt "a" "a1") "a" "a2") "a")
+
+let add_list_tests () =
+ let l = [ ("a", "a1"); ("b", "b1") ] in
+ aessl "add_list (init ()) []" [] H.(to_list (add_list (init ()) []));
+ aessl "add_list (init ()) l" l H.(to_list (add_list (init ()) l));
+ aessl "add_list h []" hstr H.(to_list (add_list prebuilt []));
+ aessl "add_list h [k, v]"
+ (hstr @ [ ("a", "a1") ])
+ H.(to_list (add_list prebuilt [ ("a", "a1") ]));
+ aessl "add_list h l" (hstr @ l) H.(to_list (add_list prebuilt l))
+
+let add_multi_tests () =
+ let k, vals = ("a", [ "a1"; "a2"; "a3" ]) in
+ let l = List.map (fun v -> ("a", v)) vals in
+ aessl "add_multi (init ()) k []" [] H.(to_list (add_multi (init ()) k []));
+ aessl "add_multi (init ()) k vals" l H.(to_list (add_multi (init ()) k vals));
+ aessl "add_multi h k []" hstr H.(to_list (add_multi prebuilt k []));
+ aessl "add_multi h k vals" (hstr @ l) H.(to_list (add_multi prebuilt k vals))
+
+let add_unless_exists_tests () =
+ let k, v = ("a", "a1") in
+ let k', v' = ("transfer-encoding", "chunked") in
+ let k'', v'' = ("accept", "text/*") in
+ aessl "add_unless_exists (init ()) k v"
+ [ (k, v) ]
+ H.(to_list (add_unless_exists (init ()) k v));
+ aessl "add_unless_exists h k v when mem h k = false"
+ (hstr @ [ (k, v) ])
+ H.(to_list (add_unless_exists prebuilt k v));
+ aessl "add_unless_exists h k v when mem h k = true)" hstr
+ H.(to_list (add_unless_exists prebuilt k' v'));
+ aessl "add_unless_exists h k v when mem h k = true)" hstr
+ H.(to_list (add_unless_exists prebuilt k'' v''))
+
+let remove_tests () =
+ aessl "remove (init ()) k" [] H.(to_list (remove (init ()) "accept"));
+ aessl "remove (add (add (init ()) k v) k v) k" []
+ H.(to_list (remove (add (add (init ()) "k" "v") "k" "v") "k"));
+ aessl "remove h k when mem h k = false" hstr H.(to_list (remove prebuilt "a"));
+ aessl "remove h k when mem h k = true"
+ [
+ ("accept", "application/xml");
+ ("accept", "text/html");
+ ("content-length", "100");
+ ]
+ H.(to_list (remove prebuilt "transfer-encoding"));
+ aessl "remove h k when mem h k = true"
+ [ ("transfer-encoding", "chunked"); ("content-length", "100") ]
+ H.(to_list (remove prebuilt "accept"))
+
+let replace_tests () =
+ let k, v, v' = ("a", "a1", "a2") in
+ aessl "replace (init ()) k v" [ (k, v) ] H.(to_list (replace (init ()) k v));
+ aessl "replace (add (init ()) k v) k v"
+ [ (k, v) ]
+ H.(to_list (replace (add (init ()) k v) k v));
+ aessl "replace (add (init ()) k v) k v'"
+ [ (k, v') ]
+ H.(to_list (replace (add (init ()) k v) k v'));
+ aessl "replace h k v when mem h k = false"
+ (hstr @ [ (k, v) ])
+ H.(to_list (replace prebuilt k v));
+ aessl "replace h k v when mem h k = true"
+ [
+ ("accept", "application/xml");
+ ("transfer-encoding", "gzip");
+ ("accept", "text/html");
+ ("content-length", "100");
+ ]
+ H.(to_list (replace prebuilt "transfer-encoding" "gzip"));
+ aessl "replace h k v when mem h = true"
+ [
+ ("transfer-encoding", "chunked");
+ ("accept", "text/*");
+ ("content-length", "100");
+ ]
+ H.(to_list (replace prebuilt "accept" "text/*"))
+
+let h =
+ H.init () |> fun h ->
+ H.add h "first" "1" |> fun h ->
+ H.add h "second" "2" |> fun h ->
+ H.add h "accept" "foo" |> fun h -> H.add h "accept" "bar"
+
+let update_tests () =
+ let h1 =
+ H.update h "second" (function Some _ -> Some "2a" | None -> None)
+ in
+ let h2 = H.replace h "second" "2a" in
+ aeh "update existing header" h1 h2;
+ let h1 = H.update h "second" (function Some _ -> None | None -> Some "3") in
+ let h2 = H.remove h "second" in
+ aeh "update remove header" h1 h2;
+ let h1 =
+ H.update h "accept" (function Some _ -> Some "baz" | None -> None)
+ in
+ aesl "update existing header with multiple values"
+ H.(get_multi h1 "accept")
+ [ "foo"; "baz" ];
+ let h' = H.update h "third" (function Some _ -> None | None -> Some "3") in
+ aesl "update add new header" (H.get_multi h' "third") [ "3" ];
+ let h1 = H.update h "third" (function _ -> None) in
+ aeh "update_remove_absent_header" h h1;
+ let h1 = H.update h "third" (function Some _ -> Some "3" | None -> None) in
+ aeh "update_new_header: unchanged" h h1;
+ let h1 = H.update h "accept" (function Some _ -> None | None -> None) in
+ aeso "update_existing_header_remove_multivalue: remove last" (Some "foo")
+ (H.get h1 "accept")
+
+let update_all_tests () =
+ let h1 = H.update_all h "second" (function [] -> [] | _ -> [ "2a" ]) in
+ let h2 = H.(add (remove h "second") "second" "2a") in
+ aeh "update_all existing header" h1 h2;
+ let h1 = H.update_all h "second" (function [] -> [ "3" ] | _ -> []) in
+ let h2 = H.remove h "second" in
+ aeh "update_all remove header" h1 h2;
+ let h1 = H.update_all h "accept" (function [] -> [] | _ -> [ "baz" ]) in
+ aesl "update_all existing header with multiple values"
+ H.(get_multi h1 "accept")
+ [ "baz" ];
+ let h1 =
+ H.update_all h "accept" (function [] -> [] | xs -> xs @ [ "baz" ])
+ in
+ let h2 = H.add h "accept" "baz" in
+ aeso "update_all_existing_header_multivalued"
+ (H.get_multi_concat h1 "accept")
+ (H.get_multi_concat h2 "accept");
+ let h1 = H.update_all h "accept" (function _ -> []) in
+ aeh "update_all_existing_header_multivalue : remove all" (H.remove h "accept")
+ h1;
+ let h1 = H.update_all h "third" (function [] -> [ "3"; "33" ] | _ -> []) in
+ let h2 = H.add_multi h "third" [ "3"; "33" ] in
+ aeh "update add new header" h1 h2;
+ let h1 = H.update_all h "third" (function _ -> []) in
+ aeh "update_remove_absent_header" h h1;
+ let h1 = H.update_all h "third" (function [] -> [] | _ -> [ "3" ]) in
+ aeh "update_new_header: unchanged" h h1
+
+let get_multi_tests () =
+ aesl "get_multi (init ()) k" [] H.(get_multi (init ()) "a");
+ aesl "get_multi h k when mem h k = false" [] H.(get_multi prebuilt "a");
+ aesl "get_multi h k when mem h k = true" [ "chunked" ]
+ H.(get_multi prebuilt "transfer-encoding");
+ aesl "get_multi h k when mem h k = true"
+ [ "application/xml"; "text/html" ]
+ H.(get_multi prebuilt "accept")
+
+let get_multi_concat_tests () =
+ let h1 = H.(add (add prebuilt "a" "a1") "a" "a2") in
+ aeso "get_multi_concat (init ()) k" None H.(get_multi_concat (init ()) "a");
+ aeso "get_multi_concat h k when mem h k = false" None
+ H.(get_multi_concat prebuilt "a");
+ aeso "get_multi_concat h k when mem h k = true"
+ (Some "application/xml,text/html")
+ H.(get_multi_concat prebuilt "accept");
+ aeso "get_multi_concat ~list_value_only:false h k when mem h k = true"
+ (Some "a1,a2")
+ H.(get_multi_concat h1 "a");
+ aeso "get_multi_concat ~list_value_only:true h k when mem h k = true"
+ (Some "a2")
+ H.(get_multi_concat ~list_value_only:true h1 "a")
+
+let map_tests () =
+ let a = ", a" in
+ aessl "map (fun _ v -> v) (init ())" []
+ H.(to_list (map (fun _k v -> v) (init ())));
+ aessl "map (fun _ v -> v) (init ())" (H.to_list prebuilt)
+ H.(to_list (map (fun _k v -> v) prebuilt));
+ aessl "map (fun _ v -> v ^ a ) (init ())"
+ [
+ ("accept", "application/xml, a");
+ ("transfer-encoding", "chunked, a");
+ ("accept", "text/html, a");
+ ("content-length", "100, a");
+ ]
+ H.(to_list (map (fun _k v -> v ^ a) prebuilt))
+
+let fold_tests () =
+ let rev k v acc = H.(add acc k v) in
+ let h1 = H.(fold rev prebuilt (init ())) in
+ aessl
+ "[fold (fun k v acc -> H.(add acc k v)) h (init ())] reverses the header"
+ (List.rev H.(to_list h1))
+ H.(to_list prebuilt);
+ let h1 = H.(fold rev (fold rev prebuilt (init ())) (init ())) in
+ aeh "[fold rev (fold rev h (init ())) (init ()) = h] " h1 prebuilt;
+ let count _ _ acc = acc + 1 in
+ aei "[fold (fun _ _ acc -> acc+1) h 0] returns the length of h"
+ (List.length H.(to_list prebuilt))
+ H.(fold count prebuilt 0)
+
+let iter_tests () =
+ let h = ref H.(init ()) in
+ let rev k v = h := H.(add !h k v) in
+ H.(iter rev prebuilt);
+ aessl "[iter (fun k v -> href := H.(add !href k v)) h] reverses the header"
+ (List.rev H.(to_list !h))
+ H.(to_list prebuilt);
+ let c = ref 0 in
+ let count _ _ = c := !c + 1 in
+ aei "[iter (fun _ _ -> count := !count+1) h] works fine"
+ (List.length H.(to_list prebuilt))
+ (H.(iter count prebuilt);
+ !c)
+
+let to_lines_tests () =
+ aesl "to_lines h"
+ [
+ "accept: application/xml\r\n";
+ "transfer-encoding: chunked\r\n";
+ "accept: text/html\r\n";
+ "content-length: 100\r\n";
+ ]
+ H.(to_lines prebuilt)
+
+let to_frames_tests () =
+ aesl "to_frames h"
+ [
+ "accept: application/xml";
+ "transfer-encoding: chunked";
+ "accept: text/html";
+ "content-length: 100";
+ ]
+ H.(to_frames prebuilt)
+
+let to_string_tests () =
+ aes "to_string h"
+ "accept: application/xml\r\n\
+ transfer-encoding: chunked\r\n\
+ accept: text/html\r\n\
+ content-length: 100\r\n\
+ \r\n"
+ H.(to_string prebuilt)
+
+let many_headers () =
+ let size = 1000000 in
+ let rec add_header num h =
+ match num with
+ | 0 -> h
+ | n ->
+ let k = Printf.sprintf "h%d" n in
+ let v = Printf.sprintf "v%d" n in
+ let h = H.add h k v in
+ add_header (num - 1) h
+ in
+ let h = add_header size (H.init ()) in
+ Alcotest.(check int) "many_headers" (List.length (H.to_list h)) size
+
+let transfer_encoding_tests () =
+ let h =
+ H.of_list
+ [ ("transfer-encoding", "gzip"); ("transfer-encoding", "chunked") ]
+ in
+ let sh = H.to_string h in
+ aes "transfer_encoding_string_is_ordered" sh
+ "transfer-encoding: gzip\r\ntransfer-encoding: chunked\r\n\r\n";
+ let sh = H.get_multi_concat h "transfer-encoding" in
+ aeso "transfer_encoding_get_is_ordered" (Some "gzip,chunked") sh
+
+let large_header () =
+ let sz = 1024 * 1024 * 100 in
+ let h = H.init () in
+ let v1 = String.make sz 'a' in
+ let h = H.add h "x-large" v1 in
+ let h = H.add h v1 "foo" in
+ aeso "x-large" (H.get h "x-large") (Some v1)
+
+let tests =
+ ( "Unitary Header tests",
+ [
+ ("Header.to_list", `Quick, to_list_tests);
+ ("Header.is_empty", `Quick, is_empty_tests);
+ ("Header.init_with", `Quick, init_with_tests);
+ ("Header.mem", `Quick, mem_tests);
+ ("Header.add", `Quick, add_tests);
+ ("Header.get", `Quick, get_tests);
+ ("Header.add_list", `Quick, add_list_tests);
+ ("Header.add_multi", `Quick, add_multi_tests);
+ ("Header.add_unless_exists", `Quick, add_unless_exists_tests);
+ ("Header.remove", `Quick, remove_tests);
+ ("Header.replace", `Quick, replace_tests);
+ ("Header.get_multi", `Quick, get_multi_tests);
+ ("Header.get_multi_concat", `Quick, get_multi_concat_tests);
+ ("Header.to_lines", `Quick, to_lines_tests);
+ ("Header.to_frames", `Quick, to_frames_tests);
+ ("Header.to_string", `Quick, to_string_tests);
+ ("Header.map", `Quick, map_tests);
+ ("Header.fold", `Quick, fold_tests);
+ ("Header.iter", `Quick, iter_tests);
+ ("Header.update", `Quick, update_tests);
+ ("Header.update_all", `Quick, update_all_tests);
+ ("many headers", `Slow, many_headers);
+ ("transfer encoding is in correct order", `Quick, transfer_encoding_tests);
+ ]
+ @
+ if Sys.word_size = 64 then [ ("large header", `Slow, large_header) ] else []
+ )
+
+let () = Alcotest.run "test_header" [ tests ]
--- /dev/null
+open Base
+module Parser = Http.Private.Parser
+
+let req =
+ "GET /wp-content/uploads/2010/03/hello-kitty-darth-vader-pink.jpg HTTP/1.1\r\n\
+ Host: www.kittyhell.com \r\n\
+ User-Agent: 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\r\n\
+ Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\r\n\
+ Accept-Language: ja,en-us;q=0.7,en;q=0.3\r\n\
+ Accept-Encoding: gzip,deflate\r\n\
+ Accept-Charset: Shift_JIS,utf-8;q=0.7,*;q=0.7\r\n\
+ Keep-Alive: 115\r\n\
+ Connection: keep-alive\r\n\
+ Cookie: 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\r\n\
+ Empty: \r\n\
+ \r\n"
+
+let assert_req_success ~here ~expected_req ~expected_consumed ?pos ?len buf =
+ let buf = String.subo ?pos ?len buf in
+ let req, consumed =
+ match Parser.parse_request buf with
+ | Error Parser.Partial -> failwith "Unexpected partial parse"
+ | Error (Parser.Msg msg) -> failwith msg
+ | Ok res -> res
+ in
+ [%test_result: string] ~here ~message:"HTTP Method mismatch"
+ ~expect:(Http.Method.to_string @@ Http.Request.meth expected_req)
+ (Http.Method.to_string @@ Http.Request.meth req);
+ [%test_result: string] ~here ~message:"path mismatch"
+ ~expect:(Http.Request.resource expected_req)
+ (Http.Request.resource req);
+ [%test_result: (string * string) list] ~here ~message:"header mismatch"
+ ~expect:(Http.Header.to_list @@ Http.Request.headers expected_req)
+ (Http.Header.to_list @@ Http.Request.headers req);
+ [%test_result: int] ~here ~expect:expected_consumed consumed
+
+let[@warning "-3"] make_req ~headers meth resource =
+ { Http.Request.headers; meth; resource; version = `HTTP_1_1 }
+
+let req_expected =
+ make_req
+ ~headers:
+ (Http.Header.of_list
+ [
+ ("Host", "www.kittyhell.com");
+ ( "User-Agent",
+ "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" );
+ ( "Accept",
+ "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8"
+ );
+ ("Accept-Language", "ja,en-us;q=0.7,en;q=0.3");
+ ("Accept-Encoding", "gzip,deflate");
+ ("Accept-Charset", "Shift_JIS,utf-8;q=0.7,*;q=0.7");
+ ("Keep-Alive", "115");
+ ("Connection", "keep-alive");
+ ( "Cookie",
+ "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"
+ );
+ ("Empty", "");
+ ])
+ `GET "/wp-content/uploads/2010/03/hello-kitty-darth-vader-pink.jpg"
+
+let parse_single_request () =
+ assert_req_success
+ ~here:[ [%here] ]
+ ~expected_req:req_expected ~expected_consumed:718 req
+
+let reject_headers_with_space_before_colon () =
+ let req =
+ "GET / HTTP/1.1\r\nHost : www.kittyhell.com\r\nKeep-Alive: 115\r\n\r\n"
+ in
+ match Parser.parse_request req with
+ | Error (Parser.Msg msg) ->
+ [%test_result: string] ~expect:"Invalid Header Key" msg
+ | _ -> assert false
+
+let more_requests =
+ "GET / HTTP/1.1\r\n\
+ Host: www.reddit.com\r\n\
+ User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) \r\n\
+ \ Gecko/20100101 Firefox/15.0.1\r\n\
+ Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\r\n\
+ Accept-Language: en-us,en;q=0.5\r\n\
+ Accept-Encoding: gzip, deflate\r\n\
+ Connection: keep-alive\r\n\
+ \r\n\
+ GET /reddit.v_EZwRzV-Ns.css HTTP/1.1\r\n\
+ Host: www.redditstatic.com\r\n\
+ User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) \
+ Gecko/20100101 Firefox/15.0.1\r\n\
+ Accept: text/css,*/*;q=0.1\r\n\
+ Accept-Language: en-us,en;q=0.5\r\n\
+ Accept-Encoding: gzip, deflate\r\n\
+ Connection: keep-alive\r\n\
+ Referer: http://www.reddit.com/\r\n\
+ \r\n"
+
+let parse_at_offset () =
+ let expected_req =
+ make_req
+ ~headers:
+ (Http.Header.of_list
+ [
+ ("Host", "www.redditstatic.com");
+ ( "User-Agent",
+ "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) \
+ Gecko/20100101 Firefox/15.0.1" );
+ ("Accept", "text/css,*/*;q=0.1");
+ ("Accept-Language", "en-us,en;q=0.5");
+ ("Accept-Encoding", "gzip, deflate");
+ ("Connection", "keep-alive");
+ ("Referer", "http://www.reddit.com/");
+ ])
+ `GET "/reddit.v_EZwRzV-Ns.css"
+ in
+ assert_req_success
+ ~here:[ [%here] ]
+ ~expected_req ~expected_consumed:315 ~pos:304 more_requests
+
+let report_partial_parse () =
+ let buf = req in
+ let err =
+ match Parser.parse_request ~pos:0 ~len:50 buf with
+ | Error Parser.Partial -> Some "Partial"
+ | Error (Parser.Msg msg) -> Some msg
+ | Ok _ -> None
+ in
+ [%test_result: string option] ~expect:(Some "Partial") err
+
+let validate_http_version () =
+ let req =
+ "GET / HTTP/1.4\r\nHost: www.kittyhell.com\r\nKeep-Alive: 115\r\n\r\n"
+ in
+ let buf = req in
+ let err =
+ match Parser.parse_request buf with
+ | Error (Parser.Msg msg) -> msg
+ | Error Parser.Partial -> failwith "Unexpected partial"
+ | Ok _ -> assert false
+ in
+ [%test_result: String.Caseless.t] ~expect:"Invalid http version" err
+
+let parse_result_notifies_start_of_body () =
+ let buf =
+ "POST / HTTP/1.1\r\n\
+ Host: localhost:8080\r\n\
+ User-Agent: curl/7.64.1\r\n\
+ Accept: */*\r\n\
+ Content-Length: 6\r\n\
+ Content-Type: application/x-www-form-urlencoded\r\n\
+ \r\n\
+ foobar"
+ in
+ let v = Parser.parse_request buf |> Result.ok in
+ let _req, count = Option.value_exn v in
+ [%test_result: string] ~expect:"foobar"
+ (String.sub buf ~pos:count ~len:(String.length buf - count))
+
+let parse_proxy_get () =
+ let buf =
+ "GET http://example.com/foo.html HTTP/1.1\r\n\
+ Host: example.com\r\n\
+ Proxy-Authorization: Basic dXNlcjpwYXNz\r\n\
+ \r\n\
+ foobar"
+ in
+ let expected_req =
+ make_req
+ ~headers:
+ (Http.Header.of_list
+ [
+ ("Host", "example.com");
+ ("Proxy-Authorization", "Basic dXNlcjpwYXNz");
+ ])
+ `GET "http://example.com/foo.html"
+ in
+ assert_req_success ~here:[ [%here] ] ~expected_req ~expected_consumed:104 buf
+
+open Base_quickcheck
+
+let parse_chunk_length () =
+ Test.run_exn
+ (module struct
+ type t = int64 [@@deriving quickcheck, sexp_of]
+ end)
+ ~f:(fun num ->
+ let payload =
+ let s = Printf.sprintf "%Lx\r\n" num in
+ s
+ in
+ match Parser.parse_chunk_length payload with
+ | Ok res ->
+ [%test_eq: int64 * int] res
+ (num, String.length (Printf.sprintf "%Lx" num) + 2)
+ | Error (Parser.Msg _) -> ()
+ | Error _ -> assert false)
+
+let chunk_length_parse_case_insensitive () =
+ let run_test num str =
+ let buf = str in
+ match Parser.parse_chunk_length buf with
+ | Ok res ->
+ [%test_eq: int64 * int] res
+ (num, String.length (Printf.sprintf "%Lx" num) + 2)
+ | Error (Parser.Msg _) -> ()
+ | Error _ -> assert false
+ in
+ Test.run_exn
+ (module struct
+ type t = int64 [@@deriving quickcheck, sexp_of]
+ end)
+ ~f:(fun num ->
+ let payload = Printf.sprintf "%Lx\r\n" num in
+ run_test num (String.uppercase payload);
+ run_test num (String.lowercase payload))
+
+type parse_res = [ `Ok of int64 * int | `Msg of string | `Partial ]
+[@@deriving sexp, compare]
+
+let parse_chunk_lengths () =
+ let run_parser buf =
+ match Parser.parse_chunk_length buf with
+ | Ok res -> `Ok res
+ | Error Parser.Partial -> `Partial
+ | Error (Parser.Msg msg) -> `Msg msg
+ in
+ [%test_result: parse_res] ~expect:(`Ok (2738L, 5)) (run_parser "ab2\r\n");
+ [%test_result: parse_res]
+ ~expect:(`Ok (4526507L, 8))
+ (run_parser "4511ab\r\n");
+ (* We will try to use the same chunk length, but this time with a chunk extension. This
+ should not result in any change in our output. *)
+ [%test_result: parse_res]
+ ~expect:(`Ok (4526507L, 13))
+ (run_parser "4511ab ; a\r\n");
+ [%test_result: parse_res]
+ ~expect:(`Ok (4526507L, 26))
+ (run_parser "4511ab; now in extension\r\n");
+ [%test_result: parse_res] ~expect:(`Msg "Invalid chunk_length character 'a'")
+ (run_parser "4511ab a ; now in extension\r\n");
+ [%test_result: parse_res]
+ ~expect:(`Ok (76861433640456465L, 17))
+ (run_parser "111111111111111\r\n");
+ [%test_result: parse_res] ~expect:(`Msg "Chunk size is too large")
+ (run_parser "1111111111111111\r\n");
+ [%test_result: parse_res] ~expect:(`Msg "Expected_newline")
+ (run_parser "abc\r12");
+ [%test_result: parse_res]
+ ~expect:(`Msg "Invalid chunk_length character '\\n'") (run_parser "abc\n12");
+ [%test_result: parse_res] ~expect:`Partial (run_parser "121");
+ [%test_result: parse_res] ~expect:`Partial (run_parser "121\r")
+
+let () =
+ let open Alcotest in
+ run "Parser"
+ [
+ ( "parse request",
+ [
+ test_case "single request" `Quick parse_single_request;
+ test_case "parse at offset" `Quick parse_at_offset;
+ test_case "reject headers with invalid character in key" `Quick
+ reject_headers_with_space_before_colon;
+ test_case "report partial parse" `Quick report_partial_parse;
+ test_case "validate http version" `Quick validate_http_version;
+ test_case "parse result notified offset of start of optional body"
+ `Quick parse_result_notifies_start_of_body;
+ test_case "parse a proxy GET request" `Quick parse_proxy_get;
+ ] );
+ ( "chunked encoding",
+ [
+ test_case "can parse chunk length" `Quick parse_chunk_length;
+ test_case "chunk length parsing is case insensitive" `Quick
+ chunk_length_parse_case_insensitive;
+ test_case "parse chunk lengths" `Quick parse_chunk_lengths;
+ ] );
+ ]
--- /dev/null
+open Http
+
+let aeb = Alcotest.check Alcotest.bool
+
+let requires_content_length_tests =
+ let valid_meth () =
+ [ `POST; `PUT; `PATCH ]
+ |> List.map (fun meth ->
+ Request.make ~meth "p" |> Request.requires_content_length)
+ |> List.for_all Fun.id
+ |> aeb "requires_content_length m = true, where m is `POST, `PUT or `PATCH"
+ true
+ in
+ let invalid_meth () =
+ [ `GET; `HEAD; `DELETE; `OPTIONS; `TRACE; `CONNECT; `Other "h" ]
+ |> List.map (fun meth ->
+ Request.make ~meth "p" |> Request.requires_content_length)
+ |> List.for_all not
+ |> aeb
+ {| requires_content_length m = false, where m is `GET; `HEAD;`DELETE;`OPTIONS;`TRACE; `CONNECT;`Other "h" |}
+ true
+ in
+ ( "requires_content_length",
+ [
+ ("Valid meth", `Quick, valid_meth); ("Invalid meth", `Quick, invalid_meth);
+ ] )
+
+let content_length_tests =
+ let some_x () =
+ [ (`POST, "0"); (`PUT, "233"); (`PATCH, "012345") ]
+ |> List.map (fun (meth, len) ->
+ match
+ Request.make ~meth
+ ~headers:(Header.of_list [ ("Content-Length", len) ])
+ "p"
+ |> Request.content_length
+ with
+ | Some x -> int_of_string len = x
+ | None -> false)
+ |> List.for_all Fun.id
+ |> aeb "content_length t = Some x" true
+ in
+
+ let none () =
+ [ (`POST, "-1"); (`PUT, "-233"); (`PATCH, "abc") ]
+ |> List.map (fun (meth, len) ->
+ match
+ Request.make ~meth
+ ~headers:(Header.of_list [ ("Content-Length", len) ])
+ "p"
+ |> Request.content_length
+ with
+ | Some _ -> false
+ | None -> true)
+ |> List.for_all Fun.id
+ |> aeb "content_length t = None" true
+ in
+
+ let method_ () =
+ [ `GET; `HEAD; `DELETE; `OPTIONS; `TRACE; `CONNECT; `Other "h" ]
+ |> List.map (fun meth ->
+ match Request.make ~meth "p" |> Request.content_length with
+ | Some _ -> false
+ | None -> true)
+ |> List.for_all Fun.id
+ |> aeb "content_length t = None" true
+ in
+ ( "content_length",
+ [
+ ("Some content_length", `Quick, some_x);
+ ("None : Invalid content_length integer", `Quick, none);
+ ("None : Method", `Quick, method_);
+ ] )
+
+let () =
+ Alcotest.run "test_request"
+ [ requires_content_length_tests; content_length_tests ]
--- /dev/null
+open Http
+
+let aeb = Alcotest.check Alcotest.bool
+let aeo = Alcotest.check Alcotest.(option int)
+let no_content_status = Response.make ~status:`No_content ()
+let continue_status = Response.make ~status:`Continue ()
+let ok_status = Response.make ~status:`OK ()
+
+let chunked_transport_encoding =
+ let headers =
+ let headers = Http.Header.init () in
+ Http.Header.add headers "Transfer-Encoding" "chunked"
+ in
+ Response.make ~status:`OK ~headers ()
+
+let requires_content_length_tests =
+ let no_content_status () =
+ Response.requires_content_length no_content_status
+ |> aeb "requires_content_length m = true, where s is `No_content (204)"
+ false
+ in
+ let continue_status () =
+ Response.requires_content_length continue_status
+ |> aeb "requires_content_length m = true, where s is `Continue (100)" false
+ in
+ let ok_status () =
+ Response.requires_content_length ok_status
+ |> aeb "requires_content_length s = true, where s is `OK (200" true
+ in
+ let chunked_transport_encoding () =
+ Response.requires_content_length chunked_transport_encoding
+ |> aeb "requires_content_length s = true, where s is `OK (200" false
+ in
+ ( "requires_content_length",
+ [
+ ("`No_content", `Quick, no_content_status);
+ ("`Continue", `Quick, continue_status);
+ ("`OK", `Quick, ok_status);
+ ("Transport-Encoding: chunked", `Quick, chunked_transport_encoding);
+ ] )
+
+let content_length_tests =
+ let ok_status () =
+ Response.
+ {
+ ok_status with
+ headers = Header.add ok_status.headers "Content-Length" "20";
+ }
+ |> Response.content_length
+ |> aeo "Some len" (Some 20)
+ in
+ let no_content_status () =
+ Response.content_length no_content_status |> aeo "`No_content : None" None
+ in
+
+ ( "content_length",
+ [ ("OK", `Quick, ok_status); ("`No_content", `Quick, no_content_status) ] )
+
+let () =
+ Alcotest.run "test_response"
+ [ requires_content_length_tests; content_length_tests ]
--- /dev/null
+(*{{{ Copyright (c) 2014-2015 David Sheets <sheets@alum.mit.edu>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ }}}*)
+
+(* This module contains I/O agnostic functions used by
+ Cohttp_server_lwt and Cohttp_server_async. *)
+
+open Printf
+
+let ( / ) = Filename.concat
+
+let compare_kind = function
+ | Some `Directory, Some `Directory -> 0
+ | Some `Directory, _ -> -1
+ | _, Some `Directory -> 1
+ | Some `File, Some `File -> 0
+ | Some `File, _ -> 1
+ | _, Some `File -> -1
+ | _, _ -> 0
+
+let sort lst =
+ List.sort
+ (fun (ka, _sa, a) (kb, _sb, b) ->
+ let c = compare_kind (ka, kb) in
+ if c <> 0 then c
+ else String.compare (String.lowercase_ascii a) (String.lowercase_ascii b))
+ lst
+
+let li ?title l =
+ let title =
+ match title with None -> "" | Some s -> sprintf "title=\"%s\" " s
+ in
+ sprintf "<li><a %shref=\"%s\">%s</a></li>" title (Uri.to_string l)
+
+let kind_of_unix_kind =
+ Unix.(
+ function
+ | S_DIR -> `Directory
+ | S_REG -> `File
+ | S_SOCK -> `Socket
+ | S_BLK -> `Block
+ | S_FIFO -> `Fifo
+ | S_CHR -> `Char
+ | S_LNK -> `Link)
+
+let human_size_of_size size =
+ let size = Int64.to_float size in
+ let kibi = size /. 1024. in
+ if kibi < 1. then sprintf "%.0fB" size
+ else
+ let mibi = kibi /. 1024. in
+ if mibi < 1. then sprintf "%.1fKiB" kibi
+ else
+ let gibi = mibi /. 1024. in
+ if gibi < 1. then sprintf "%.1fMiB" mibi else sprintf "%.1fGiB" gibi
+
+let html_of_listing uri path listing info =
+ let html =
+ List.map
+ (fun (kind, size, f) ->
+ let encoded_f = Uri.pct_encode f in
+ match kind with
+ | Some `Directory ->
+ let link = Uri.with_path uri (path / encoded_f / "") in
+ li link (sprintf "<i>%s/</i>" f)
+ | Some `File ->
+ let link = Uri.with_path uri (path / encoded_f) in
+ li ~title:(human_size_of_size size) link f
+ | Some (`Socket | `Block | `Fifo | `Char | `Link) ->
+ sprintf "<li><s>%s</s></li>" f
+ | None -> sprintf "<li>Error with file: %s</li>" f)
+ (sort listing)
+ in
+ let contents = String.concat "\n" html in
+ sprintf
+ "<html><body><h2>Directory Listing for <em>%s</em></h2><ul>%s</ul><hr \
+ />%s</body></html>"
+ (Uri.pct_decode path) contents info
+
+let html_of_forbidden_unnormal path info =
+ sprintf
+ "<html><body><h2>Forbidden</h2><p><b>%s</b>is not a normal file or \
+ directory</p><hr/>%s</body></html>"
+ path info
+
+let html_of_not_found path info =
+ sprintf
+ "<html><body><h2>Not Found</h2><p><b>%s</b>was not found on this \
+ server</p><hr />%s</body></html>"
+ path info
+
+let html_of_method_not_allowed meth allowed path info =
+ sprintf
+ "<html><body><h2>Method Not Allowed</h2><p><b>%s</b>is not an allowed \
+ method on <b>%s</b></p><p>Allowed methods on <b>%s</b> are \
+ <b>%s</b></p><hr />%s</body></html>"
+ meth path path allowed info
--- /dev/null
+(library
+ (name cohttp_server)
+ (libraries cohttp unix))
--- /dev/null
+module type S = sig
+ type 'a io
+ type ic
+ type oc
+ type body
+
+ type response_action =
+ [ `Expert of Http.Response.t * (ic -> oc -> unit io)
+ | `Response of Http.Response.t * body ]
+
+ type spec = Http.Request.t -> body -> response_action io
+ type async_test = unit -> unit io
+
+ val response : Http.Response.t * body -> response_action
+ val expert : ?rsp:Http.Response.t -> (ic -> oc -> unit io) -> spec
+ val const : (Http.Response.t * body) io -> spec
+ val response_sequence : spec list -> spec
+ val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io
+
+ val test_server_s :
+ ?port:int ->
+ ?name:string ->
+ spec ->
+ (Uri.t -> (string * async_test) list) ->
+ OUnit.test io
+
+ val run_async_tests : OUnit.test io -> OUnit.test_results io
+end
+
+let port =
+ Random.self_init ();
+ ref (1024 + Random.int 40000)
+
+let next_port () =
+ let current_port = !port in
+ incr port;
+ current_port
+
+let response_sequence fail responses =
+ let xs = ref responses in
+ fun req body ->
+ match !xs with
+ | x :: xs' ->
+ xs := xs';
+ x req body
+ | [] -> fail "response_sequence: Server exhausted responses"
--- /dev/null
+module type S = sig
+ type 'a io
+ type ic
+ type oc
+ type body
+
+ type response_action =
+ [ `Expert of Http.Response.t * (ic -> oc -> unit io)
+ | `Response of Http.Response.t * body ]
+
+ type spec = Http.Request.t -> body -> response_action io
+ (** A server that is being tested must be defined by providing a spec *)
+
+ type async_test = unit -> unit io
+
+ val response : Http.Response.t * body -> response_action
+ val expert : ?rsp:Http.Response.t -> (ic -> oc -> unit io) -> spec
+
+ val const : (Http.Response.t * body) io -> spec
+ (** A constant handler that always returns its argument *)
+
+ val response_sequence : spec list -> spec
+ (** A server that process requests using the provided specs in sequence and
+ crashes on further requests *)
+
+ val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io
+ (** Create a temporary server according to spec that lives until the callback
+ thread is determined. The uri provided in the callback should be the base
+ uri for any requests made to the temp server *)
+
+ val test_server_s :
+ ?port:int ->
+ ?name:string ->
+ spec ->
+ (Uri.t -> (string * async_test) list) ->
+ OUnit.test io
+ (** Create a test suite against a server defined by spec. Tests run
+ sequentially. *)
+
+ val run_async_tests : OUnit.test io -> OUnit.test_results io
+ (** Run an async unit test and return and print the result *)
+end
+
+val next_port : unit -> int
+(** Internal API. Subject to breakage *)
+
+val response_sequence :
+ (string -> 'a) -> ('b -> 'c -> 'a) list -> 'b -> 'c -> 'a
--- /dev/null
+(library
+ (name cohttp_test)
+ (libraries cohttp ounit2))
projects / ocaml-cohttp.git / commitdiff