From: Stéphane Glondu Date: Sat, 14 Mar 2026 08:44:01 +0000 (+0100) Subject: Import ocaml-cohttp_6.2.1.orig.tar.bz2 X-Git-Tag: archive/raspbian/6.2.2-1+rpi1~4 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=97ce9567f2d152113ebdc59157cac30305038e6b;p=ocaml-cohttp.git Import ocaml-cohttp_6.2.1.orig.tar.bz2 [dgit import orig ocaml-cohttp_6.2.1.orig.tar.bz2] --- 97ce9567f2d152113ebdc59157cac30305038e6b diff --git a/.github/dependabot.yml b/.github/dependabot.yml new file mode 100644 index 0000000..ca79ca5 --- /dev/null +++ b/.github/dependabot.yml @@ -0,0 +1,6 @@ +version: 2 +updates: + - package-ecosystem: github-actions + directory: / + schedule: + interval: weekly diff --git a/.github/workflows/changelog.yml b/.github/workflows/changelog.yml new file mode 100644 index 0000000..d453ff8 --- /dev/null +++ b/.github/workflows/changelog.yml @@ -0,0 +1,13 @@ +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 diff --git a/.github/workflows/nix.yml b/.github/workflows/nix.yml new file mode 100644 index 0000000..a4ca2ef --- /dev/null +++ b/.github/workflows/nix.yml @@ -0,0 +1,18 @@ +name: "Nix" +on: + pull_request: + push: +jobs: + tests: + runs-on: ubuntu-latest + steps: + - name: Checkout tree + uses: actions/checkout@v5 + with: + submodules: true + - uses: cachix/install-nix-action@v30 + with: + extra_nix_config: | + extra-substituters = https://anmonteiro.nix-cache.workers.dev + extra-trusted-public-keys = ocaml.nix-cache.com-1:/xI2h2+56rwFfKyyFVbkJSeGqSIYMC/Je+7XXqGKDIY= + - run: nix develop -L .# -c dune build @runtest @check diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml new file mode 100644 index 0000000..12a78b8 --- /dev/null +++ b/.github/workflows/workflow.yml @@ -0,0 +1,177 @@ +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-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@v5 + + - 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: + - "5.2" + 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 tree + uses: actions/checkout@v5 + + - 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: 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-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 + + 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 + + runs-on: ${{ matrix.os }} + + steps: + - name: Checkout tree + uses: actions/checkout@v5 + + - 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.2" + local-packages: + - | + *.opam + + runs-on: ${{ matrix.os }} + + steps: + - name: Checkout tree + uses: actions/checkout@v5 + + - 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-bench + - run: opam exec -- dune build cohttp-bench + - run: opam exec -- dune runtest cohttp-bench diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c9f495d --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +.*.swp +_build/ +*.install +.merlin +_opam/ +node_modules +dune.lock/ diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..e69de29 diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..291f8a0 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,4 @@ +version=0.27.0 +profile=conventional +break-infix=fit-or-vertical +parse-docstrings=true diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..3c386bc --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,866 @@ +## v6.2.1 (2025-12-16) + +- cohttp: Fix syntax in forward proxy tests to recover compatibility with OCaml + 4.08 to 4.12, fixing a regression introduced in v6.2.0. (@shonfeder, #1135) + +## v6.2.0 (2025-12-02) + +- cohttp-eio: Add support for forward proxies to the client (@shonfeder, #1126) +- cohttp-lwt: Expose the IO module, allowing IO errors to be handled (@mefyl, #1118) + +## v6.1.1 (2025-05-28) + +- cohttp-mirage: make client usable again -- this fixes a regression introduced + by #1080 (@Firobe, review by @edwintorok, #1110) +- rename main function on README example (@Unn4m3DD, #1097) + +## v6.1.0 (2025-03-03) + +- cohttp-lwt-unix: Add http/https proxy support for client requests (@art-w @MisterDA, #1080) +- cohttp-mirage: Support conduit 8.0.0 (@hannesm, #1104) + +## 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) + +- Cohttp.Header: new implementation (lyrm #747) + + + New implementation of Header modules using an associative list instead of a map, with one major semantic change (function ```get```, see below), and some new functions (```clean_dup```, ```get_multi_concat```) + + More Alcotest tests as well as fuzzing tests for this particular module. + + ### Purpose + + The new header implementation uses an associative list instead of a map to represent headers and is focused on predictability and intuitivity: except for some specific and documented functions, the headers are always kept in transmission order, which makes debugging easier and is also important for [RFC7230§3.2.2](https://tools.ietf.org/html/rfc7230#section-3.2.2) that states that multiple values of a header must be kept in order. + + Also, to get an intuitive function behaviour, no extra work to enforce RFCs is done by the basic functions. For example, RFC7230§3.2.2 requires that a sender does not send multiple values for a non list-value header. This particular rule could require the ```Header.add``` function to remove previous values of non-list-value headers, which means some changes of the headers would be out of control of the user. With the current implementation, an user has to actively call dedicated functions to enforce such RFCs (here ```Header.clean_dup```). + + ### Semantic changes + Two functions have a semantic change : ```get``` and ```update```. + + #### get + ```get``` was previously doing more than just returns the value associated to a key; it was also checking if the searched header could have multiple values: if not, the last value associated to the header was returned; otherwise, all the associated values were concatenated and returned. This semantics does not match the global idea behind the new header implementation, and would also be very inefficient. + + + The new ```get``` function only returns the last value associated to the searched header. + + ```get_multi_concat``` function has been added to get a result similar to the previous ```get``` function. + + #### update + ```update``` is a pretty new function (#703) and changes are minor and related to ```get``` semantic changes. + + + ```update h k f``` is now modifying only the last occurrences of the header ```k``` instead of all its occurrences. + + a new function ```update_all``` function has been added and work on all the occurrences of the updated header. + + ### New functions : + + + ```clean_dup``` enables the user to clean headers that follows the {{:https://tools.ietf.org/html/rfc7230#section-3.2.2} RFC7230§3.2.2} (no duplicate, except ```set-cookie```) + + ```get_multi_concat``` has been added to get a result similar to the previous ```get``` function. + +- Cohttp.Header: performance improvement (mseri, anuragsoni #778) + **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 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) +- lwt: Use logs to warn users about leaked bodies and document it (mseri #771) +- lwt, lwt_unix: Improve use of logs and the documentation, fix bug in the Debug.enable_debug function (mseri #772) +- lwt_jsoo: Fix exception on connection errors in chrome (mefyl #761) +- lwt_jsoo: Fix `Lwt.wakeup_exn` `Invalid_arg` exception when a js + stack overflow happens in the XHR completion handler (mefyl #762). +- lwt_jsoo: Add test suite (mefyl #764). + +## v4.0.0 (2021-03-24) + +- cohttp.response: fix malformed status header for custom status codes (mseri aalekseyev #752) +- remove dependency to base (samoht #745) +- add GitHub Actions workflow (smorimoto #739) +- `cohttp-lwt-jsoo`: Forward exceptions to caller when response is null (mefyl #738) +- 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 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) +- improve media type parsing (seliopou #542, dinosaure #725) +- [reverted] breaking changes to client and server API to use conduit 3.0.0 (dinosaure #692). However, as the design discussion did not reach consensus, these changes were reverted to preserve better compatibility with existing cohttp users. (samoht #741) + +**Potentially breaking changes** + +- remove `wrapped false` from the codebase (rgrinberg #734) +- cohttp: add Uri.scheme to Request.t (brendanlong #707) +- cohttp: update HTTP codes (emillon #711) +- cohttp-lwt-jsoo: rename Cohttp_lwt_xhr to Cohttp_lwt_jsoo for consistency (mseri #717) +- cohttp: fix transfer-encoding ordering in headers (mseri #721) +- lower-level support for long-running cohttp-async connections (brendanlong #704) +- add of_form and to_form functions to body (seliopou #440, mseri #723) +- cohttp-lwt: partly inline read_response, fix body stream leak (madroach dinosaure #696). + Note: there is a new warning that may show up in your logs when bodies are leaked, see also [#730](https://github.com/mirage/ocaml-cohttp/issues/730). +- add comparison functions for Request.t and Response.t via ppx_compare (msaffer-js dinosaure #686) + +## v3.0.0 - aborted + +## v2.5.5 (2021-03-15) + +- `Cohttp_async.resolve_local_file`, `Cohttp_lwt.resolve_local_file` and `Cohttp_lwt_unix.resolve_file` + are now the same code under the hood (`Cohttp.Path.resolve_local_file`). The old names + have been preserved for compatibility, but will be marked as deprecated in the next release. This + changes the behavior of `Cohttp_lwt_unix.resolve_file`: it now percent-decodes the paths and blocks + escaping from the docroot correctly. This also fixes and tests the corner cases in these methods + when the docroot is empty. (ewanmellor #755) + +## v2.5.4 (2020-07-21) + +- cohttp: a change in #694 modified the semantics of Header.replace. + The semantics change is reverted, and a new Header.update function + is introduced, following the semantics of Map.update. (#702 mseri) +- cohttp: reimplement update to support compilers that are older than + OCaml 4.06 (#703 mseri) + +## v2.5.3 (2020-06-27) + +- cohttp-async: adapt to async >= v0.14 (#699 copy) + +## v2.5.2 (2020-06-27) + +- cohttp, cohttp-async: correctly set host header for unix domain sockets, + implement Unix domain socket support for cohttp-async (#698 Leonidas-from-XIV) +- cohttp: better body encoding management when creating request and + response, and correction of Header.replace function (#694 lyrm) + +## v2.5.1 (2020-02-18) + +- cohttp-lwt: pass ctx through HEAD client requests (#689 hannesm) + +## v2.5.0 (2019-12-17) + +- cohttp-async: support async v0.13.0 (#680 copy) +- cohttp-lwt-jsoo: support js_of_ocaml 3.5.0 and higher (avsm) + +## v2.4.0 (2019-11-08) + +- mirage: adapt to new mirage interfaces: mirage-flow 2.0.0, + mirage-channel 4.0.0, mirage-kv 3.0.0 (#678 hannesm) +- async: use Pipe.singleton instead of Pipe.of_list as it is more efficient + (#677 smuenzel-js) + +## v2.3.0 (2019-08-18) + +- use conduit-mirage instead of mirage-conduit, which was renamed + upstream in conduit. The minimum OCaml version supported for + conduit-mirage is now OCaml 4.07 and higher. (#672 avsm) +- remove deprecation warnings in OCaml 4.08.0 using stdlib-shims (#672 avsm) +- async: do not read body if none is present (#671 emillon) + +## v2.2.0 (2019-07-20) + +- Previously if the client closed the connection while cohttp was + handling a request, the server would crash (by default, unless the + user overrode that using `on_exn` or changing Lwt's async exception + handler). Now, cohttp will just log this at `info` level and + continue. Exceptions produced by user code are logged as errors, + while other exceptions generated by cohttp call back to the conduit + exception handler, as before. (#669 talex5) + +## v2.1.3 (2019-07-12) + +- support uri.3.0.0 that has optional sexp support (#668 avsm) +- use re.1.9.0 api to remove deprecation warnings (#664 vbmithr) + +## v2.1.2 (2019-04-09) + +- cohttp: handle empty cookie components gracefully without raising + an exception (#663 martinslota) + +## v2.1.1 (2019-04-05) + +- `cohttp-mirage`: remove dependency on the `result` module + (#662 hannesm) +- Support Async v0.12.0 and higher (#661 copy) + +## v2.1.0 (2019-03-01) + +- `cohttp-mirage`: update to the newest `Mirage_kv.RO` API + +## v2.0.0 (2019-02-04) + +Compatibility breaking interface changes: + +Async: Expert response action no longer writes empty HTTP body (#647 by andreas) + +In cohttp.0.99, a number of subpackages were turned into explicit +opam packages to simplify dependency management. +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: +- `cohttp.lwt-core` -> `cohttp-lwt` +- `cohttp.lwt` -> `cohttp-lwt-unix` +- `cohttp.js` -> `cohttp-lwt-jsoo` +- `cohttp.async` -> `cohttp-async` +- `cohttp.top` -> `cohttp-top` + +Other changes and bugfixes: +* Lwt, Mirage: Add log warnings for uncaught exceptions (#592 by ansiwen) +* Log invalid client input and do not catch out of memory exceptions (#652 hannesm) +* Port opam files to opam2 and add local synopsis and descriptions. +* Lwt: Add Expert response action for servers (#647 by andreas) +* Use the namespaced `js_of_ocaml` interfaces from 3.3.0 onwards (#654 avsm) +* Use Base64 3.1.0 interfaces (#655 avsm) +* Clean up redundant conflicts in the `opam` files (avsm) + +## v1.2.0 (2018-10-19) + +* Support more than a single chunk extension for RFC7320 compliance (#618 by djs55) +* Lwt-unix: add a `?backlog` argument to the serve function (samoht) +* Use the uri.2.0.0 interfaces for sexpression generation of types (avsm) +* Switch to `sexplib0` for a more lightweight s-expression library (mseri) +* Minimum OCaml compiler version requirement is now 4.04.1 (mseri) +* Add an example of using custom resolvers to the README (mseri) + +## v1.1.1 (2018-08-13) + +* Update to be compatible with new async/core (#607 by rgrinberg) +* Remove use of deprecated `Lwt_logs` (#609 by raphael-proust) +* Do not rely on locale for printing qvalues (#611 by vbmithr) +* Ppx dependencies aren't just build time dependencies (#625 by rgrinberg) + +## v1.1.0 (2018-03-28) + +* Add an "expert mode" to hand off raw responses to a custom handler, + which in turns makes protocols like Websockets easier (#488 by msaffer). +* Set the user-agent by default if one is not provided (#586 by TheCBaH). +* Fix typo in the `cohttp.js` META file. +* Refresh use of the Re library to the latest version (#602 by rgrinberg). +* Rearrange the ppx dependencies to be more specific (#596 by yomimono). +* Explicitly depend on sexplib in the Async backend (#605 by kevinqiu). + +## v1.0.2 (2018-01-06) + +* Support Async v0.10.0 and OCaml 4.06.0 (#588 via vbmithr) +* Require `ppx_type_conv`>=v0.9.1` due to a bug with duplicate modules + present in earlier versions. + +## v1.0.1 (2018-01-03) + +* cohttp-mirage: expose the missing IO module (#594, samoht) +* cohttp-mirage: catch exceptions when closing channels in mirage client + (#589, ansiwen) + +## v1.0.0 (2017-11-16) + +* opam: rename `mirage-http` to `cohttp`-mirage` (#572) +* cohttp-lwt{,-unix}: wrap the libraries in top-level modules (#568) +* opam: improve dependencies (#574, #566, #575) +* cohttp: add the convenience function `Header.is_empty` (#576) +* fix compatibility with OCaml 4.06 and `-safe-string` (#580, #581) + +## v0.99.0 (2017-07-12) + +Port build to jbuilder, and break up OPAM packages into multiple +independent packages instead of being optional dependencies against +the main `cohttp` package. This makes it significantly easier to +depend on precisely the libraries you need, but requires porting +applications to use the new `ocamlfind` and `opam` scheme. + +The new package layout is: + +- `cohttp`: the main `Cohttp` module +- `cohttp-lwt`: the portable Lwt implementation +- `cohttp-lwt-unix`: the Lwt/Unix implementation +- `cohttp-lwt-jsoo`: the js-of-ocaml JavaScript implementation +- `cohttp-async`: the Jane Street Async implementation +- `mirage-http`: the MirageOS compatible implementation +- `cohttp-top`: a toplevel printer for the Cohttp types. + +In each of these packages, the `opam` and `ocamlfind` package +names are now _the same_, so you will need to rename the former +subpackages such as `cohttp.async` to `cohttp-async`. The +implementation is otherwise the same, so no other code changes +should be required. + +In return for these breaking changes to the packaging, it is +now significantly easier to depend on a particular backend, +also for us to rev the interfaces towards a stable 1.0 release. +Jbuilder also builds the source tree around 4x faster than it +did previously. + +A number of deprecation warnings have been added to the source +tree as well to mark the interfaces that will be removed in 1.0. +These are `Cohttp_lwt.{Client,Server,Net}`, and a `Cohttp_lwt.Body` +alias was added to deprecate the direct use of `Cohttp_lwt_body`. +This will let us unify the namespaces of all the packages to use +a single top-level module for each package in the future. + +Most of the release and packaging work here was done by rgrinberg +and avsm. + +## 0.22.0 (2017-03-09) + +* Lwt: ensure conn_closed is closed once client goes away (#528) +* Use the Logs library for logging. (#532) + +## 0.21.1 (2017-02-18) +* Remove -principal from type checking temporarily, to workaround + a bug in the OCaml 4.03 type checker that causes compilation + hangs (http://caml.inria.fr/mantis/view.php?id=7305). +* Improve documentation in the `test_xhr.ml` js_of_ocaml test. +* XHR: Allow setting withCredentials +* Async: pass along ?ssl_config when connecting to Uri's (#510) +* Lwt: Add on ?on_exn to Server.create (#518) +* Add Header.to_frames + +## 0.21.0 (2016-05-22) +* Allow to request paths as strings (#470, #478) + +## 0.20.2 (2016-04-04) +* Update META version (#473) +* uri.services is only required by cohttp.async + +0.20.1 (2016-04-01) +* Switch cohttp to use ppx (#457) +* Lwt: Fix leak on HEAD client requests (#467) + +0.20.0 (2016-03-25) +* Switch to pa_fields_conv and pa_sexp_conv for camlp4 extensions (#465) +* Compatibility with latest async (#468) +* Async: Add support for SSL parameters in client (#466) +* Lwt: ignore Sig.sigpipe under Windows (#456) +* Lwt: Fix FD leak (#447) +* Lwt: Log uncaught user exceptions +* Async: Close non-persistent async connections (#442) + +0.19.3 (2015-09-28): +* Support Async 113.00 by explicitly using the blocking Core `printf` (#431) +* cohttp_curl_async: add `-data-binary` to send POST data. (#425) + +0.19.2 (2015-08-20): + +* Improve Cohttp_async.Client error handling. When a Uri.t fails to resolve it is + now included in the error. (#420) + +0.19.1 (2015-08-08): + +* Bring make_body_writer and write_header in Cohttp.S.Http_io. Needed by + ocaml-git + +0.19.0 (2015-08-05): +Compatibility breaking interface changes: +* Remove `read_form` from the `Request/Response/Header` interfaces + as this should be done in `Body` handling instead (#401). + +New features and bug fixes: +* Remove `IO.write_line` as it was unused in any interfaces. +* Do not use the `lwt` camlp4 extension. No observable external difference. +* Do not return a code stacktrace in the default 500 handler. +* Add `Cohttp.Header.compare` (#411) +* Fix typos in CLI documentation (#413 via moonlightdrive) +* Use the Lwt 2.5.0 buffer API. +* `Cohttp_lwt.read_response` now has a non-optional `closefn` parameter (#400). +* Add a `Cohttp_lwt_s` module that contains all the Lwt module types + in one convenient place (#397). + +0.18.3 (2015-07-12): +* Allow `DELETE` requests to have request bodies (#383). +* Improve the Lwt client `callv` for HTTP/1.1 pipelined + requests (#379 via Török Edwin). + +0.18.2 (2015-06-19): +* Do not add content encoding for 204's (#375) + +0.18.1 (2015-06-05): +* Remove trailing whitespace from headers (#372) +* Don't reverse order of list valued headers (#372) + +0.18.0 (2015-06-02): +* Add Cohttp_async.Client.callv. Allows for making requests while reusing an + HTTP connection (#344) +* Responses of status 1xx/204/304 have no bodies and cohttp should not attempt + to read them (#355) +* Add top level printers. See cohttp.top findlib package (#363) +* Add `Header.to_string` (#362) +* Fix chunk truncation in chunked transfer encoding (#360) + +Compatibility breaking interface changes: +* Remove `Request`/`Response` modules outside of Cohttp pack (#349) + +0.17.2 (2015-05-24): +* Remove dependency on the Lwt Camlp4 syntax extension (#334). +* Add `make github` target to push documentation to GitHub Pages + (#338 from Jyotsna Prakash). +* Add Async integration tests and consolidate Lwt tests using the + new framework (#337). +* Fix allocation of massive buffer when handling fixed size http bodies (#345) + +0.17.1 (2015-04-24): +* [async] Limit buffer size to a maximum of 32K in the Async backend + (#330 from Stanislav Artemkin). +* Add `Cohttp.Conf.version` with the library version number included. +* Remove debug output from `cohttp-curl-async`. +* Add the beginning of a `DESIGN.md` document to explain the library structure. + +0.17.0 (2015-04-17): + +Compatibility breaking interface changes: +* `CONNECT` and `TRACE` methods added to `Code`.Exhaustive matches will need updating. + +New features and bug fixes: +* `Link` header parsing has been added as `Cohttp.Link`, `Header.get_links` and `Header.add_links` +* `cohttp_server_*` now obeys `HEAD` requests and responds 405 to unknown methods +* `Cohttp_async.Server.response` type is now exposed as a `response * body` pair +* Failure to read a body in a pipelined response no longer terminates the stream +* Fix `cohttp_curl_lwt -X HEAD` sending empty chunked body (#313) +* Fix a bug which left extra `\r\n` in buffer at end of chunked reads +* Fix handling of request URI for query strings and `CONNECT` proxies (#308, #318) +* Fix precedence of `Host` header when request-URI is absolute URI +* Fix request URI path to be non-empty except for * requests (e.g. `OPTIONS *`) + +0.16.1 (2015-04-09): +New features and bug fixes: +* Fix handling of request paths starting with multiple slashes (#308) + +0.16.0 (2015-03-23): + +Compatibility breaking interface changes: +* Response.t and Request.t fields are no longer mutable +* [lwt] Fix types in `post_form` to be a `string * string list` instead + of a `Header.t` (#257) +* Simplify the `Net` signature which needs to be provided for Lwt servers + to not be required. Only the Lwt client needs a `Net` functor argument + to make outgoing connections. (#274) +* The `Request` and `Response` records are no longer mutable, so use + functional updates instead via `Fieldslib.Field.fset Request.Fields.`. (#296) +* `Request.has_body` does not permit a body to be set for methods that + RFC7231 forbids from having one (`HEAD`, `GET` and `DELETE`). + +New features and bug fixes: +* Fix linking problem caused by sub-libraries using cohttp modules outside the + cohttp pack. +* Added async client for S3. (#304) +* Fix String_io.read_line to trim '\r' from end of string (#300) +* Fix `cohttp-server-lwt` to correctly bind to a specific interface (#298). +* Add `Cohttp_async.request` to send raw, unmodified requests. +* Supplying a `content-range` or `content-range` header in any client + request will always override any other encoding preference (#281). +* Add a `cohttp-lwt-proxy` to act as an HTTP proxy. (#248) +* Extend `cohttp-server-async` file server to work with HTTPS (#277). +* Copy basic auth from `Uri.userinfo` into the Authorization header + for HTTP requests. (#255) +* Install binaries via an OPAM `.install` file to ensure that they are + reliably uninstalled. (#252) +* Use the `magic-mime` library to add a MIME type by probing filename + during static serving in the Lwt/Async backends. (#260) +* Add `Cohttp.Header.add_opt_unless_exists` to set a header only if + an override wasn't supplied, and to initialise a fresh Header value + if none is present. +* Do not override user-supplied headers in `post_form` or `redirect`. +* `Request.make` does not inject a `transfer-encoding` header if there + is no body present in the request (#246). +* `Server.respond` no longer overrides user-supplied headers that + specify the `content-length` or `transfer-encoding` headers (#268). +* `cohttp_server_lwt` and `cohttp_server_async` now include sizes in + directory listing titles +* Add `Header.add_multi` to initialise a header structure with multiple + fields more efficiently (#272). +* Expose `IO.ic` and `IO.oc` types for `Cohttp_async` (#271). +* Skip empty body chunks in `Transfer_io.write` (#270). +* With the Lwt backend, `read` hangs if trying to fetch more than + `Sys.max_string_length` (which can be triggered on 32-bit platforms). + Read only a maximum that fits into a string (#282). +* `cohttp-curl-lwt` now takes http method as parameter (#288) +* Fix installation of server binaries in OPAM metadata. (#295) + +0.15.2 (2015-02-15): +* When transfer encoding is unknown, read until EOF when body size is unknown. (#241) +* Add some missing documentation to `Cohttp.S.IO` signature. (#233) +* Add `Cohttp.Header.mem` to check if a header exists. +* Add `Cohttp.Conf` module to expose the library version number. (#259) +* Add `Cohttp.Header.add_unless_exists` to update a key if it doesn't already exist. (#244) +* Add `Cohttp.Header.get_location` to retrieve redirection information. (#254) +* [async] Clean up the `Net.lookup` function to use `Or_error.t` instead of raising. (#247) +* [tests] Add more tests for `content-range` handling. (#249) + +0.15.1 (2015-01-10): +* Lwt 2.4.7 renamed `blit_bytes_string` to `blit_to_bytes`, so depend + on the newer API now. (#230) +* Use `cmdliner` in all of the Lwt client and server binaries. This gives + `cohttp-lwt-server` a nice Unix-like command-line interface now that + can be viewed with the `--help` option. (#218 via Runhang Li) +* Improve `oasis` constraints and regenerate `opam` file (#229 via + Christophe Troestler). + +0.15.0 (2014-12-24): + +Compatibility breaking interface changes: +* Change `Cohttp_lwt_body.map` to use a non-labelled type to fit the Lwt + style better (#200). +* Depend on Base64 version 2, which uses `B64` as the toplevel module name (#220). + +New features and bug fixes: +* Remove use of deprecated `Lwt_unix.run` and replace it with `Lwt_main.run`. + Should be no observable external change (#217). +* Improve ocamldoc of `Cohttp.S` signature (#221). + +0.14.0 (2014-12-18): + +Compatibility breaking interface changes: +* Simplify the Lwt server signature, so that manual construction of + a `callback` is no longer required (#210). + Code that previous looked like: + +``` + let conn_closed (_,conn_id) () = <...> + let config = { Server.callback; conn_closed } in +``` + +should now be: + +``` + let conn_closed (_,conn_id) = <...> + let config = Server.make ~callback ~conn_closed () in +``` + +* Remove the `Cohttp.Base64` module in favour of the external `base64` + library (which is now a new dependency). + +New features and bug fixes: +* Lwt `respond_error` now defaults to an internal server error if no + status code is specified (#212). +* Modernise the `opam` file using the OPAM 1.2 workflow (#211). +* Flush the response body to the network by default, rather than + buffering by default. The `?flush` optional parameter can still + be explicitly set to false if flushing is not desired (#205). + +0.13.0 (2014-12-05): + +Compatibility breaking interface changes: + +* Add sexp converters for Conduit contexts and `Lwt` client and server + modules and module types. + +New features and bug fixes: +* Can use the Conduit 0.7+ `CONDUIT_TLS=native` environment variable to + make HTTPS requests using the pure OCaml TLS stack instead of depending + on OpenSSL bindings. All of the installed binaries (client and server) + can work in this mode. +* Add `Cohttp_lwt_unix_debug` which lets libraries control the debugging + output from Cohttp. Previously the only way to do this was to set the + `COHTTP_DEBUG` environment variable at the program start. +* Add `cohttp-curl-lwt` as a lightweight URI fetcher from the command-line. + It uses the `cmdliner` as a new dependency. +* Remove build dependency check on `lwt.ssl` for `cohttp.lwt`. + This has been moved to conduit, so only `lwt.unix` is needed here now. + +0.12.0 (2014-11-07): + +Compatibility breaking interface changes: + +* Rename `Cohttp.Auth.t` to `Cohttp.Auth.credential` and `Cohttp.Auth.req` + to `Cohttp.Auth.challenge`. Also expose an `Other` variant + to make it more extensible for unknown authentication types. The + `Cohttp.Auth` functions using these types have also been renamed accordingly. +* Rename `Cohttp.Transfer.encoding_to_string` to `string_of_encoding` + for consistency with the rest of Cohttp's APIs. +* The `has_body` function in the Request and Response modules now + explicitly signals when the body size is unknown. +* Move all the module type signatures into `Cohttp.S`. +* If users have percent-encoded file names, their resolution is changed: + `resolve_local_file` in `Cohttp_async` and `Cohttp_lwt` now always + percent-decode paths (#157) +* Remove the `Cohttp_lwt.Server.server` type synonym to `t`. +* When reading data from a HTTP body stream using the `Fixed` encoding, + we need to maintain state (bytes remaining) so we know when to finish. + The `Cohttp.Request` and `Cohttp.Response` interfaces now expose a + `reader` and `writer` types to track this safely. +* Add `is_empty` function to the `Cohttp.S.Body` module type. +* Add `Strings` representation to `Cohttp.Body` to efficiently hold a + list of body chunks. +* Move flushing logic for HTTP bodies into the portable `Request` and + `Response` modules instead of individual Lwt and Async backends. +* Port module interfaces to the latest Conduit (0.6.0+) API. +* Cohttp requires OCaml 4.01.0 or higher now. + +New features and bugfixes: + +* Add a `Cohttp_lwt_xhr` JavaScript backend that enables Cohttp logic to be + mapped to `XMLHTTPRequest` in browsers via `js_of_ocaml` (via Andy Ray). +* Add a `Cohttp.String_io` and `String_io_lwt` module that uses OCaml + `string` or `Buffer.t` to read and write HTTP requests and responses + instead of network connections. +* `cohttp_server_lwt` and `cohttp_server_async` now return better errors (#158) +* `cohttp_server_lwt` and `cohttp_server_async` now serve indexes directly (#162) +* [lwt] Add `stop` thread to terminate a running server if it finishes (#147). +* Add `Cohttp.Connection.compare` to make ordering of connections possible. +* Add `Body.map` and `Body.as_pipe` to work with HTTP bodies more easily. +* Remove link-time dependency on camlp4 via META fixes (#127). +* Support HTTP methods and versions other than the standard ones. (#142). +* Improve `cohttp_server_lwt` and `cohttp_server_async` directory listings (#158) +* Fix `Cohttp_async.resolve_local_file` directory traversal vulnerability (#158) +* [async] In the Async server, do not close the Reader too early. +* [async] Close file descriptors more eagerly in the HTTP client (#167). +* Reduce thread allocation by replacing `return ` with `return_none`, + `return_unit` or `return_nil`. + +0.11.2 (2014-04-21) +* Fix build by add a missing build-deps in _oasis. + +0.11.1 (2014-04-17): +* Remove an errant async_ssl reference left in the _oasis file that is + now handled by the Conduit library (#116). +* Add an Lwt-based SimpleHTTPServer equivalent as `cohttp-server-lwt` (#108). +* `Cohttp.Connection.t` now exposes sexp accessor functions (#117). + +0.11.0 (2014-04-01): +* Remove dependency on `ocaml-re` in order to make library POSIX thread-safe. +* Shift most of the connection handling logic out to a Conduit library that + worries about which SSL library to use, and fails if SSL is not available. +* Add Async-SSL support for both client and server (#102). +* Add Lwt-SSL support for the server side (the client side existed before). +* Fix buggy Async chunked POST handling. + +0.10.0 (2014-03-02): +* Interface change: The `Request` and `Response` module types now explicitly + signal `Eof` and `Invalid` (for errors), to help the backend distinguish them. +* Interface change: Unify HTTP body handling across backends into a `Cohttp.Body` + module. This is extended by Async/Lwt implementations with their specific + ways of handling bodies (Pipes for Async, or Lwt_stream for Lwt). +* [lwt] Interface change: HTTP client calls now raise Lwt exceptions rather + than return an option type. This permits better error handling in Lwt. +* [lwt] Interface change: The `Server` callback now always provides a `body` + argument, since `Cohttp_lwt_body` now explicitly supports empty bodys. +* Add `Cohttp.Header.is_keep_alive` to test if a connection should be reused. +* [lwt] Respect the `keep-alive` header in the server request handling. +* [async] Add a `Body` that takes a `Pipe` or a `string`, similarly to Lwt. +* Install `cohttp-server` binary even if tests are disabled. +* Begin an `examples` directory with some simple uses of the library. + +0.9.16 (2014-01-30): +* Add some module type equalities in `Cohttp_lwt_unix` so that + `Cohttp_lwt_unix.Server.Request.IO.ic` can be equivalen to `Lwt_io.input_channel`. +* Add sexp converters to most Cohttp types (#83). +* Improve Travis tests to cover more upstream users of Cohttp. +* Refactor build flags to let the portable Lwt-core be built independently of Lwt.unix. + +0.9.15 (2014-01-11): +* Remove `Cohttp_mirage` libraries, which have now moved to `mirage/mirage-http-*` on GitHub. +* Add an "HTTP only" `Cookie` attribute (#69). +* Fix parsing of cookies with `=` in the values (#71). +* Add `Max-age` support for cookies (#70). +* Make the `Response` record fields mutable to match the `Request` (#67). +* Fix compilation with Async 109.58.00 (#77). +* Make Header handling case-insensitive (by forcing lowercase) (#75). +* Remove the `>>` operator as it was unused and had incorrect precedence (#79). + +0.9.14 (2013-12-15): +* Install a `cohttp-server` binary that serves local directory contents via a web server (#54). +* Add a `flush` function to the `IO` module type and implement in Lwt/Async/Mirage. +* Add option `flush` support in the Async and Lwt responders (#52). +* Autogenerate HTTP codes from citricsquid's JSON representation of the HTTP RFCs. +* Always set `TCP_NODELAY` for Lwt/Unix server sockets for low-latency responses (#58). +* Added a Server-Side Events test-case from the HTML5 Doctor. See `lib_test/README.md`. +* Async.Server response now takes an optional `body` rather than a mandatory `body option` (#62). +* Regenerate build system using OASIS 0.4.0. + +0.9.13 (2013-12-10): +* The `cohttp.lwt-core` is now installed as an OS-independent Lwt library. +* Add support for Mirage 1.0, via `cohttp.mirage-unix` and `cohttp.mirage-xen`. +* Add a new `Cohttp.Connection` module to manage server's connections identifiers. +* Share the same configuration type for the different server implementations. +* Add `Accept_types` module to the `Cohttp` pack. + +0.9.12 (2013-11-28): +* Improve documentation for `Cohttp.Header`. +* Expose Fieldslib setters and getters for most of the `Cohttp` types (#38). +* `Cohttp.Set_cookie.t` is no longer an abstract type to make it easier to update (#38). +* [Lwt] ignore SIGPIPE unconditionally if using the Lwt/Unix module (#37). +* Rename `Cookie` creation parameters for consistency (interface breaking, see #44). +* Fix transfer-length detection (regression from 0.9.11 in #42). +* Add Merin editor file (#41). + +0.9.11 (2013-10-27): +* Request module: When sending a request, add the port information in the host header field if available. +* Request module: When parsing a request, add scheme, host and port information in the uri. +* TCP server: When creating the socket for the server, do not force PF_INET6 but take the sockaddr value. +* Add HTTP OPTIONS method. +* Use getaddrinfo instead of gethostbyname for DNS resolution. +* Async: improve HTTP/1.0 support (#35). +* Build with debug symbols, binary annotations by default. +* Add Travis CI test scripts. + +0.9.10 (2013-06-21): +* Add `set-cookie` header extraction functions for clients that read cookies. +* Explicitly flush the debug output when the `COHTTP_DEBUG` env variable is set. +* [async] Add client head/post/patch/delete methods. +* [lwt] Client.head no longer returns a response body, just the metadata. +* [lwt] Do not send chunked encoding headers with GET/DELETE requests that have no body. + +0.9.9 (2013-06-12): +* Disable the mirage executable test as it was building too aggressively and breaking builds. + +0.9.8 (2013-05-24): +* Lwt interface change: Rewrite Lwt backends to share code, and remove duplicate function calls from Uri. +* Depend on `Uri` 1.3.8+ as it exposes the parameter query functions now removed from `Request`. +* Do not depend on Cstruct in core library, as only Mirage needs it. +* Remove `Cohttp_async.body` type alias and just use `string Pipe.Reader.t` for more explicit types. + +0.9.7 (2013-05-10): +* Attach a GC finaliser to the Lwt client to ensure that even an HTTP body isn't consumed, the socket will eventually be closed (#11). +* Add an Async.Server interface, and revise the Client interface to be more in line with Core standards. +* Add 422 Unprocessable Entity code. +* Refactor modules better across Lwt/Async, but incompatible with earlier releases for Async (Lwt is unchanged at present). +* Add user agent string and User-Agent header helper function +* The git history of this release is full of adventures in parameterised monads and refactoring, but this isn't in the actual release. Yet. + +0.9.6 (2013-03-18): +* Depend on Async (>= 109.12.00), which has an incompatible API with earlier versions. +* Rearrange core library files for `obuild` support. + +0.9.5 (2012-12-29): +* Fix cookie parsing to retrieve the correct header. +* Update to `mirage-net` 0.5.0 API (based on cstruct 0.6.0). + +0.9.4 (2012-12-19): +* Add Lwt `respond_redirect` and `respond_need_auth` helpers. +* Add enough Basic authorization support to serve a password-protected website. +* Fix Lwt file serving to not throw exception on trying to serve a directory. +* Port Async interface to 108.07.00 or higher (incompatible + with earlier versions). + +0.9.3 (2012-10-27): +* Add basic cookie support back to the portable library. +* `Cohttp_lwt.Client.post_form` now uses non-chunked encoding for + the POST instead of chunked. +* Various improvements and tests for the pipelined Lwt Client.callv +* If an Lwt callback does not consume a body, ensure it has + been drained by the API to prevent future pipelines from stalls. +* Fix handling of Lwt server non-empty POST bodies. +* Map the `put` functions to HTTP PUT instead of POST. + +0.9.2 (2012-09-20): +* Add Request.get_param to extract a singleton key from queries. +* Fix chunked encoding handling when short reads occur. +* Install HTML documentation for all enabled drivers. +* Use ocaml-uri-1.3.2 interface for query parsing. +* Lwt: Add Server.respond_file and resolve_file for the Unix + library to make it easier to serve static files. +* Lwt: Server.respond_not_found takes an optional Uri.t now. + +0.9.1 (2012-09-11): +* Functorise for Async, Lwt_unix and Mirage. +* Use URI and Re libraries to not need Str any more. +* More robust parsing for various HTTP headers. + +0.9.0 (2012-08-01): +* Initial public release. diff --git a/DESIGN.md b/DESIGN.md new file mode 100644 index 0000000..03b4df4 --- /dev/null +++ b/DESIGN.md @@ -0,0 +1,71 @@ +Cohttp is designed to be an HTTP implementation that is an "onion", with the +portable parsing core progressively introducing I/O, and then higher-level +abstractions for various HTTP operations. Here's a description of each layer: + +- The very first layer (in `lib/`) is a pure OCaml, non-blocking layer that + handles simple parts of the HTTP protocol such as parsing requests and + responses, various header parsers (e.g. cookies) and codes. + +- Some layers of HTTP need some notion of I/O, and so there is a set of + signatures in `lib/s.mli` that defines some common module types that can be + used to build parameterised modules (also known as functors). The first one + used in the `lib/` layer is the IO module type, which defines the minimal + collection of functions used by cooperative threading libraries. The pure HTTP + core uses this IO module to capture IO-based operations, such as Transfer_IO + (for transfer encoding). + +- There are three implementations that satisfy the IO module in the tree: Lwt, + Async and String. The first two are full cooperative threading libraries, + and the latter is used by the js_of_ocaml backend to read/write between + Strings. + +- Now that IO has been handled, we can send HTTP requests and responses from + Lwt or Async. However, at this point some differences appear in the + implementations of Async and Lwt, notably in how they handle cancellation of + threads and also higher-level iterators (e.g. Async has Pipes, and Lwt has + Lwt_stream -- both quite different). Therefore, we build backend-specific + Client and Server modules that use their respective threading libraries in as + native a style as possible, but still reusing the core HTTP library from + `lib/`. These can be found in `Cohttp_lwt` and `Cohttp_async` respectively. + Dave Scott also wrote an (as yet not merged) POSIX blocking version that they + use in the XenAPI daemon. + +- Lwt comes with an additional twist -- it is portable to both Unix *and* the + MirageOS, which has no Unix at all! Lwt makes it possible to define a "Lwt + core" that uses the portable Lwt thread abstractions, but doesn't use any + OS-specific functionality. Thus we can define an HTTP Client and Server in + Cohttp_lwt, but still not tie ourself to one particular OS. This Cohttp_lwt is + then used by the Cohttp_lwt_unix and Cohttp_mirage backends to hook it into the + operating system. + +- There's no commonality at present between Cohttp_async and Cohttp_lwt, but + that's the topic of a design discussion at the moment. It should be possible + to build a common signature between the two. (TODO add issue) + +- Andy Ray did something interesting with the Lwt backend: he ported it to + _javascript_ by implementing an IO backend that marshals the requests to and + from strings. This allows REST API users built over Cohttp (such as + ocaml-github) to compile to pure _javascript_ as well. + +Drawbacks: + +- The heavy use of functors does make it hard to navigate the 'end user' API, + even though those interfaces never expose any functors (for instance, you + just use Cohttp_lwt_unix directly in most cases). This is a drawback of current + OCaml tooling, and Merlin (for IDEs) and Codoc (for cross-referenced + documentation) will fix this soon. + +- A bigger problem that needs to be addressed in Cohttp2 is body handling, + which we basically got wrong in this iteration. The Body module is not + idempotent, so to_string does not always return the same value if called + multiple times. The caller can currently be careful, but this is just an awful + part of the API. There are enough users of Cohttp that we'll leave it for 1.0, + but hopefully fix it quite rapidly for 2.0. + +- Cohttp is not a complete HTTP client, and doesn't implement the full logic + for redirections, loop detection and so on. That's the job of a library + built over it, and there is some nascent code in + [opam-mirror](http://github.com/avsm/opam-mirror) that can do this. Before + building this, David Sheets and I want to look at some of the more larger API + clients built using it (such as Vincent Bernardoff's BitStamp API) + and take a shot at a portable client API that will work with both Lwt and Async. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..bd737f6 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,18 @@ +(* + * ISC License + * + * Copyright (c) 2009-2018 + * + * 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. + * + *) diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..5a296b8 --- /dev/null +++ b/Makefile @@ -0,0 +1,25 @@ +.PHONY: build clean test clean eio eio-shell eio-test fmt js-test + +build: + dune build + +test: + dune runtest + +js-test: + dune build @runjstest + +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 diff --git a/README.md b/README.md new file mode 100644 index 0000000..2436d5a --- /dev/null +++ b/README.md @@ -0,0 +1,495 @@ +## ocaml-cohttp -- an OCaml library for HTTP clients and servers [![Main workflow](https://github.com/mirage/ocaml-cohttp/actions/workflows/workflow.yml/badge.svg)](https://github.com/mirage/ocaml-cohttp/actions/workflows/workflow.yml) + +Cohttp is an OCaml library for creating HTTP daemons. It has a portable +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_async` uses the [Async](https://realworldocaml.org/v1/en/html/concurrent-programming-with-async.html) + library and `async_ssl` to handle HTTPS connections. +* `Cohttp_lwt` exposes an OS-independent Lwt interface, which is used + by the [Mirage](https://mirage.io/) interface to generate standalone + microkernels (use the cohttp-mirage subpackage). +* `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. + +You can find help from cohttp users and maintainers at the +[discuss.ocaml.org](https://discuss.ocaml.org) forum or on the +[OCaml discord server](https://discord.gg/cCYQbqN). + +## Table of contents + +- [Installation](#installation) +- [Client Tutorial](#client-tutorial) + * [Compile and execute with dune](#compile-and-execute-with-dune) +- [Dealing with timeouts](#dealing-with-timeouts) +- [Managing sessions](#managing-sessions) +- [Multipart form data](#multipart-form-data) +- [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 dune](#compile-and-execute-with-dune-1) +- [Installed Binaries](#installed-binaries) +- [Debugging](#debugging) +- [Important Links](#important-links) + + +## Installation + +Latest stable version should be obtained from `opam`. Make sure to install the +specific backends you want as well. E.g. + +``` +$ opam install cohttp-lwt-unix cohttp-async +``` + +You can also obtain the development release: + +``` +$ opam pin add cohttp --dev-repo +``` + +## Client Tutorial + +Cohttp provides clients for Async, Lwt, and Js_of_ocaml (Lwt based). In this tutorial, +we will use the lwt client but the example should be easily translatable to Async. + +To create a simple request, use one of the methods in `Cohttp_lwt_unix.Client`. +`call` is the most general, there are also http method specialized such as +`get`, `post`, etc. + +For example downloading the reddit frontpage: + +```ocaml +open Lwt +open Cohttp +open Cohttp_lwt_unix + +let main = + 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 main in + print_endline ("Received body\n" ^ body) +``` + +There are a few things to notice: + +* We open 2 modules. `Cohttp` contains the backend independent modules and + `Cohttp_lwt_unix` the lwt + unix specific ones. +* `Client.get` accepts a `Uri.t` and makes an http request. `Client.get` also + accepts optional arguments for things like header information. +* The http response is returned in a tuple. The first element of the tuple + contains the response's status code, headers, http version, etc. The second + element contains the body. +* The body is then converted to a string and is returned (after the length is + printed). Note that `Cohttp_lwt.Body.to_string` hence it's up to us to keep + a reference to the result. +* We must trigger lwt's event loop for the request to run. `Lwt_main.run` will + 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` 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: + +* [Cohttp_lwt.Client](https://github.com/mirage/ocaml-cohttp/blob/master/cohttp-lwt/src/s.ml) +* [Cohttp_async.Client](https://github.com/mirage/ocaml-cohttp/blob/master/cohttp-async/src/client.mli) + +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 dune + +Create this `dune` file +``` +cat - > dune <|= 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) -> Lwt.return (resp, body) +``` + +Executing the code, which you can actually try by calling +``` +$ dune exec examples/lwt_unix_doc/client_lwt_timeout.exe +``` +the call will most likely fail with the following output +``` +Fatal error: exception (Failure "Timeout expired") +``` + +Similarly, in the case of `cohttp-async` you can directly use Async's +[`with_timeout`](https://ocaml.janestreet.com/ocaml-core/latest/doc/async_unix/Async_unix/Clock/index.html#val-with_timeout) function. +For example, + +```ocaml +let get_body ~uri ~timeout = + let%bind _, body = Cohttp_async.Client.get ~interrupt:(after (sec timeout)) uri in + Body.to_string body + +let body = + let uri = Uri.of_string "https://www.reddit.com/" in + let timeout = 0.1 in + Clock.with_timeout (sec timeout) (get_body ~uri ~timeout) + >>| function + | `Result body -> Log.debug logger "body: %s" body + | `Timeout -> Log.debug logger "Timeout with url:%s" url +``` + +## Managing sessions + +Managing sessions and saving cookies across requests is not directly supported by +`cohttp`. It is not hard to roll out a custom solution, but an alternative is +to use the [`session`](https://github.com/inhabitedtype/ocaml-session) library, +which is compatible with `cohttp`. + +## Multipart form data + +Multipart form data is not supported out of the box but is provided by external libraries: +- [`multipart_form`](https://github.com/dinosaure/multipart_form) which has bounded memory consumption even when transferring large amount of data +- [`multipart-form-data`](https://github.com/cryptosense/multipart-form-data) +- [`http-multipart-formdata`](https://github.com/lemaetech/http-multipart-formdata) which however does not support streaming + +## Creating custom resolver: a Docker Socket Client example + +Cohttp provides a lot of utilities out of the box, but does not prevent the users +to dig in and customise it for their needs. The following is an example of a +[unix socket client to communicate with Docker](https://discuss.ocaml.org/t/how-to-write-a-simple-socket-based-web-client-for-docker/1760/3). + +```ocaml +open Lwt.Infix +open Cohttp + +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 +``` + +The main issue there is there no way to resolve a socket address, so you need to +create a custom resolver to map a hostname to the Unix domain socket. + +To build and execute with `dune`, first create the following `dune` file +``` +$ cat - > dune < `OK then Cohttp_lwt.Body.drain_body body else Lwt.return_unit + in + match status with + | `OK -> Lwt.return (response, body) + | `Permanent_redirect | `Moved_permanently -> + handle_redirect ~permanent:true ~max_redirects request_uri response + | `Found | `Temporary_redirect -> + handle_redirect ~permanent:false ~max_redirects request_uri response + | `Not_found | `Gone -> failwith "Not found" + | 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 failwith "Too many redirects" + else + let headers = Http.Response.headers response in + let location = Http.Header.get headers "location" in + match location with + | 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_lwt.warn (fun m -> + m "Permanent redirection from %s to %s" + (Uri.to_string request_uri) + url) + else Lwt.return_unit + in + http_get_and_follow uri ~max_redirects:(max_redirects - 1) +``` + +The following example, adapted from [blue-http](https://github.com/brendanlong/blue-http/blob/master/src/redirect.ml), does a similar thing with `cohttp-async` (and [ppx_let](https://github.com/janestreet/ppx_let)). + +```ocaml +open Core_kernel +open Async_kernel + +let with_redirects ~max_redirects uri f = + let seen_uris = Hash_set.create (module String) in + let rec loop ~max_redirects uri = + Hash_set.add seen_uris (Uri.to_string uri); + let%bind ((response, response_body) as res) = f uri in + let status_code = + Cohttp.(Response.status response |> Code.code_of_status) + in + if Cohttp.Code.is_redirection status_code then ( + match Cohttp.(Response.headers response |> Header.get_location) with + | Some new_uri when Uri.to_string new_uri |> Hash_set.mem seen_uris -> + return res + | Some new_uri -> + if max_redirects > 0 then + (* Cohttp leaks connections if we don't drain the response body *) + Cohttp_async.Body.drain response_body >>= fun () -> + loop ~max_redirects:(max_redirects - 1) new_uri + else ( + Log.Global.debug ~tags:[] + "Ignoring %d redirect from %s to %s: redirect limit exceeded" + status_code (Uri.to_string uri) (Uri.to_string new_uri); + return res) + | None -> + Log.Global.debug ~tags:[] + "Ignoring %d redirect from %s: there is no Location header" + status_code (Uri.to_string uri); + return res) + else return res + in + loop ~max_redirects uri +``` + +You can read a bit more on the rationale behind the absence of this functionality in the API [here](https://github.com/mirage/ocaml-cohttp/issues/76). + +## Basic Server Tutorial + +Implementing a server in cohttp using the Lwt backend (for Async is very similar) +is mostly equivalent to implementing a function of type : + +``` +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 +* `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. + +Here's an example of a simple cohttp server that outputs back request +information. + +```ocaml +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) +``` + +### Compile and execute with dune + +Create this `dune` file +``` +cat - > dune < with_metadata header tags k ppf fmt in + { Logs.report } + +let () = + Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true (); + Logs.set_reporter (reporter Fmt.stderr); + Logs.set_level ~all:true (Some Logs.Debug) +``` + +Note that you can selectively filter out the logs produced by `cohttp-lwt` and `cohttp-lwt-unix` internals as follows. + +```ocaml +let () = + (* Set log level v for all loggers, this does also affect cohttp internal loggers *) + Logs.set_level ~all:true level; + (* Disable all cohttp-lwt and cohttp-lwt-unix logs *) + List.iter (fun src -> + match Logs.Src.name src with + | "cohttp.lwt.io" | "cohttp.lwt.server" -> Logs.Src.set_level src None + | _ -> ()) + @@ Logs.Src.list () +``` + +## Important Links + +- [Cohttp API Documentation](https://mirage.github.io/ocaml-cohttp/) +- [Conduit API Documentation](https://mirage.github.io/ocaml-conduit/) diff --git a/cohttp-async.opam b/cohttp-async.opam new file mode 100644 index 0000000..f419fb6 --- /dev/null +++ b/cohttp-async.opam @@ -0,0 +1,67 @@ +version: "6.2.1" +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +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 "] +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.14" & < "5.3.0"} + "http" {= version} + "cohttp" {= version} + "async_kernel" {>= "v0.17.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" + "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-async/runtest" {with-test} + "@doc" {with-doc} + ] +] +available: arch != "s390x" +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp-async.opam.template b/cohttp-async.opam.template new file mode 100644 index 0000000..84c651e --- /dev/null +++ b/cohttp-async.opam.template @@ -0,0 +1,16 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp-async/runtest" {with-test} + "@doc" {with-doc} + ] +] +available: arch != "s390x" +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp-async/bin/cohttp_curl_async.ml b/cohttp-async/bin/cohttp_curl_async.ml new file mode 100644 index 0000000..b0903ab --- /dev/null +++ b/cohttp-async/bin/cohttp_curl_async.ml @@ -0,0 +1,53 @@ +(*{{{ Copyright (c) 2014 Anil Madhavapeddy + * + * 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 Base +open Async_kernel +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 make_net_req uri meth' body () = + let meth = Cohttp.Code.method_of_string meth' in + let uri = Uri.of_string uri in + let headers = Cohttp.Header.of_list [ ("connection", "close") ] in + Client.call meth ~headers ~body:Body.(of_string body) uri + >>= fun (res, body) -> + show_headers (Http.Response.headers res); + body + |> Body.to_pipe + |> Pipe.iter ~f:(fun b -> + Stdlib.print_string b; + return ()) + +let _ = + (* enable logging to stdout *) + Fmt_tty.setup_std_outputs (); + Logs.set_level @@ Some Logs.Debug; + Logs.set_reporter (Logs_fmt.reporter ()); + 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" + +> flag "data-binary" + (optional_with_default "" string) + ~doc:" Data to send when using POST") + make_net_req + |> Command_unix.run diff --git a/cohttp-async/bin/cohttp_server_async.ml b/cohttp-async/bin/cohttp_server_async.ml new file mode 100644 index 0000000..5ecaa22 --- /dev/null +++ b/cohttp-async/bin/cohttp_server_async.ml @@ -0,0 +1,144 @@ +(*{{{ Copyright (c) 2013 Anil Madhavapeddy + * Copyright (c) 2014 David Sheets + * + * 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 Base +open Async_kernel +open Async_unix +module Server = Cohttp_async.Server +open Cohttp_server + +let method_filter meth (res, body) = + match meth with `HEAD -> return (res, `Empty) | _ -> return (res, body) + +let serve_file ~docroot ~uri = + Cohttp.Path.resolve_local_file ~docroot ~uri |> Server.respond_with_file + +let serve ~info ~docroot ~index uri path = + (* Get a canonical filename from the URL and docroot *) + let file_name = Cohttp.Path.resolve_local_file ~docroot ~uri in + try_with (fun () -> + Unix.stat file_name >>= fun stat -> + Logs.debug (fun f -> + f "%s" (Sexp.to_string_hum (Unix.Stats.sexp_of_t stat))); + match stat.Unix.Stats.kind with + (* Get a list of current files and map to HTML *) + | `Directory -> ( + let path_len = String.length path in + if Int.(path_len <> 0) && Char.(path.[path_len - 1] <> '/') then + Server.respond_with_redirect (Uri.with_path uri (path ^ "/")) + (* Check if the index file exists *) + else + Sys.file_exists (file_name / index) >>= function + | `Yes -> + (* Serve the index file directly *) + let uri = Uri.with_path uri (path / index) in + serve_file ~docroot ~uri + | `No | `Unknown -> + (* Do a directory listing *) + Sys.ls_dir file_name + >>= Deferred.List.map ~how:`Parallel ~f:(fun f -> + let file_name = file_name / f in + try_with (fun () -> + Unix.stat file_name >>| fun stat -> + (Some stat.Unix.Stats.kind, stat.Unix.Stats.size, f)) + >>| function + | Ok v -> v + | Error _ -> (None, 0L, f)) + >>= fun listing -> + html_of_listing uri path + (sort ((Some `Directory, 0L, "..") :: listing)) + info + |> Server.respond_string) + (* Serve the local file contents *) + | `File -> serve_file ~docroot ~uri + (* Any other file type is simply forbidden *) + | `Socket | `Block | `Fifo | `Char | `Link -> + Server.respond_string ~status:`Forbidden + (html_of_forbidden_unnormal path info)) + >>= function + | Ok res -> return res + | Error exn -> ( + match Monitor.extract_exn exn with + | Unix.Unix_error (Unix.Error.ENOENT, "stat", p) -> + if String.equal p ("((filename " ^ file_name ^ "))") (* Really? *) + then + Server.respond_string ~status:`Not_found + (html_of_not_found path info) + else raise exn + | _ -> raise exn) + +(** HTTP handler *) +let handler ~info ~docroot ~index ~body:_ _sock req = + let uri = Cohttp.Request.uri req in + let path = Uri.path uri in + (* Log the request to the console *) + 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 = Http.Method.to_string meth in + let allowed = "GET, HEAD" 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) + +let determine_mode cert_file_path key_file_path = + (* Determines if the server runs in http or https *) + match (cert_file_path, key_file_path) with + | Some c, Some k -> `OpenSSL (`Crt_file_path c, `Key_file_path k) + | None, None -> `TCP + | _ -> failwith "Error: must specify both certificate and key for HTTPS" + +let start_server docroot port index cert_file key_file verbose () = + (* enable logging to stdout *) + Fmt_tty.setup_std_outputs (); + Logs.set_level @@ if verbose then Some Logs.Debug else Some Logs.Info; + Logs.set_reporter (Logs_fmt.reporter ()); + let mode = determine_mode cert_file key_file in + let mode_str = match mode with `OpenSSL _ -> "HTTPS" | `TCP -> "HTTP" in + Logs.info (fun f -> f "Listening for %s requests on %d" mode_str port); + let info = Printf.sprintf "Served by Cohttp/Async listening on %d" port in + Server.create + ~on_handler_error: + (`Call + (fun addr exn -> + Logs.err (fun f -> f "Error from %s" (Socket.Address.to_string addr)); + Logs.err (fun f -> f "%s" @@ Exn.to_string exn))) + ~mode + (Tcp.Where_to_listen.of_port port) + (handler ~info ~docroot ~index) + >>= fun _serv -> Deferred.never () + +let () = + let open Async_command in + Command_unix.run + @@ async_spec ~summary:"Serve the local directory contents via HTTP or HTTPS" + Spec.( + empty + +> anon (maybe_with_default "." ("docroot" %: string)) + +> flag "-p" + (optional_with_default 8080 int) + ~doc:"port TCP port to listen on" + +> flag "-i" + (optional_with_default "index.html" string) + ~doc:"file Name of index file in directory" + +> flag "-cert-file" (optional string) ~doc:"File of cert for https" + +> flag "-key-file" (optional string) + ~doc:"File of private key for https" + +> flag "-v" no_arg ~doc:" Verbose logging output to console") + start_server diff --git a/cohttp-async/bin/dune b/cohttp-async/bin/dune new file mode 100644 index 0000000..f125173 --- /dev/null +++ b/cohttp-async/bin/dune @@ -0,0 +1,12 @@ +(executables + (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)) diff --git a/cohttp-async/examples/dune b/cohttp-async/examples/dune new file mode 100644 index 0000000..5978614 --- /dev/null +++ b/cohttp-async/examples/dune @@ -0,0 +1,14 @@ +(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)) diff --git a/cohttp-async/examples/hello_world.ml b/cohttp-async/examples/hello_world.ml new file mode 100644 index 0000000..9005012 --- /dev/null +++ b/cohttp-async/examples/hello_world.ml @@ -0,0 +1,42 @@ +(* 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 diff --git a/cohttp-async/examples/receive_post.ml b/cohttp-async/examples/receive_post.ml new file mode 100644 index 0000000..88636b0 --- /dev/null +++ b/cohttp-async/examples/receive_post.ml @@ -0,0 +1,32 @@ +(* 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 diff --git a/cohttp-async/examples/s3_cp.ml b/cohttp-async/examples/s3_cp.ml new file mode 100644 index 0000000..6c5cdbb --- /dev/null +++ b/cohttp-async/examples/s3_cp.ml @@ -0,0 +1,400 @@ +(*{{{ Copyright (C) 2015 Trevor Smith + * + * 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: + \n + \n + \n + \n + \n + + *) + 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:/// *) + 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:///'" + +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 diff --git a/cohttp-async/src/body.ml b/cohttp-async/src/body.ml new file mode 100644 index 0000000..c4885e0 --- /dev/null +++ b/cohttp-async/src/body.ml @@ -0,0 +1,88 @@ +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 diff --git a/cohttp-async/src/body.mli b/cohttp-async/src/body.mli new file mode 100644 index 0000000..d1fd79f --- /dev/null +++ b/cohttp-async/src/body.mli @@ -0,0 +1,26 @@ +open! Base +open! Async_kernel + +type t = [ Cohttp.Body.t | `Pipe of string Pipe.Reader.t ] [@@deriving sexp_of] + +include Cohttp.S.Body with type t := 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 of_pipe : string Pipe.Reader.t -> 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 diff --git a/cohttp-async/src/client.ml b/cohttp-async/src/client.ml new file mode 100644 index 0000000..b8f805b --- /dev/null +++ b/cohttp-async/src/client.ml @@ -0,0 +1,182 @@ +open Base +open Async_kernel +open Async_unix + +module Net = struct + let lookup uri = + let host = Uri.host_with_default ~default:"localhost" uri in + match Uri_services.tcp_port_of_uri ~default:"http" uri with + | None -> + Deferred.Or_error.error_string + "Net.lookup: failed to get TCP port form Uri" + | Some port -> ( + let open Unix in + Addr_info.get ~host + [ Addr_info.AI_FAMILY PF_INET; Addr_info.AI_SOCKTYPE SOCK_STREAM ] + >>| function + | { Addr_info.ai_addr = ADDR_INET (addr, _); _ } :: _ -> + Or_error.return (host, Ipaddr_unix.of_inet_addr addr, port) + | _ -> Or_error.error "Failed to resolve Uri" uri Uri_sexp.sexp_of_t) + + let connect_uri ?interrupt ?ssl_config uri = + (match Uri.scheme uri with + | Some "httpunix" -> + let host = Uri.host_with_default ~default:"localhost" uri in + return @@ `Unix_domain_socket host + | _ -> ( + lookup uri |> Deferred.Or_error.ok_exn >>= fun (host, addr, port) -> + return + @@ + match (Uri.scheme uri, ssl_config) with + | Some "https", Some config -> `OpenSSL (addr, port, config) + | Some "https", None -> + 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 (r, w) -> + (Input_channel.create r, w) +end + +let read_response ic = + Io.Response.read ic >>| function + | `Eof -> failwith "Connection closed by remote host" + | `Invalid reason -> failwith reason + | `Ok res -> ( + match Cohttp.Response.has_body res with + | `Yes | `Unknown -> + (* Build a response pipe for the body *) + 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 + (res, pipe)) + +let request ?interrupt ?ssl_config ?uri ?(body = `Empty) req = + (* Connect to the remote side *) + 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 () -> + 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 [ Input_channel.close ic; Writer.close oc ] ); + (resp, `Pipe body)) + >>= function + | Ok res -> return res + | Error e -> + don't_wait_for (Input_channel.close ic); + don't_wait_for (Writer.close oc); + raise e + +module Connection = struct + type t' = { ic : Input_channel.t; oc : Writer.t } + + (* we can't send concurrent requests over HTTP/1 *) + type t = t' Sequencer.t + + let connect ?interrupt ?ssl_config uri = + 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) (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 + + let close 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 } -> + 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_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; + Ivar.read res +end + +let callv ?interrupt ?ssl_config uri reqs = + Connection.connect ?interrupt ?ssl_config uri >>| fun connection -> + let responses = + Pipe.map' ~max_queue_length:1 reqs ~f:(fun reqs -> + Deferred.Queue.map ~how:`Sequential reqs ~f:(fun (req, body) -> + Connection.request ~body connection req)) + in + Pipe.closed responses + >>= (fun () -> Connection.close connection) + |> don't_wait_for; + responses + +let call ?interrupt ?ssl_config ?headers ?(chunked = false) ?(body = `Empty) + meth uri = + (* Create a request, then make the request. Figure out an appropriate + transfer encoding *) + (match chunked with + | false -> + 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 = + call ?interrupt ?ssl_config ?headers ~chunked:false `GET uri + +let head ?interrupt ?ssl_config ?headers uri = + call ?interrupt ?ssl_config ?headers ~chunked:false `HEAD uri + >>| fun (res, body) -> + (match body with `Pipe p -> Pipe.close_read p | _ -> ()); + res + +let post ?interrupt ?ssl_config ?headers ?(chunked = false) ?body uri = + call ?interrupt ?ssl_config ?headers ~chunked ?body `POST uri + +let post_form ?interrupt ?ssl_config ?headers ~params uri = + let headers = + Cohttp.Header.add_opt_unless_exists headers "content-type" + "application/x-www-form-urlencoded" + in + let body = Body.of_string (Uri.encoded_of_query params) in + post ?interrupt ?ssl_config ~headers ~chunked:false ~body uri + +let put ?interrupt ?ssl_config ?headers ?(chunked = false) ?body uri = + call ?interrupt ?ssl_config ?headers ~chunked ?body `PUT uri + +let patch ?interrupt ?ssl_config ?headers ?(chunked = false) ?body uri = + call ?interrupt ?ssl_config ?headers ~chunked ?body `PATCH uri + +let delete ?interrupt ?ssl_config ?headers ?(chunked = false) ?body uri = + call ?interrupt ?ssl_config ?headers ~chunked ?body `DELETE uri diff --git a/cohttp-async/src/client.mli b/cohttp-async/src/client.mli new file mode 100644 index 0000000..4c424e4 --- /dev/null +++ b/cohttp-async/src/client.mli @@ -0,0 +1,123 @@ +val request : + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> + ?uri:Uri.t -> + ?body:Body.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:Http.Header.t -> + ?chunked:bool -> + ?body:Body.t -> + Http.Method.t -> + Uri.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: + + - If the scheme is [https], we try to initiate an SSL connection with the + given [ssl_ctx] or a default one on the default port ([*:443]) or the + specified one. + - If the scheme is [httpunix], we use a UNIX domain socket. + - If the scheme ie [http], we try an usual TCP/IP connection on the default + port ([*:80]) or the specified one. *) + +module Connection : sig + type t + + val connect : + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> + Uri.t -> + 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 -> + 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 -> + (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:Http.Header.t -> + Uri.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:Http.Header.t -> + Uri.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:Http.Header.t -> + ?chunked:bool -> + ?body:Body.t -> + Uri.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:Http.Header.t -> + ?chunked:bool -> + ?body:Body.t -> + Uri.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:Http.Header.t -> + ?chunked:bool -> + ?body:Body.t -> + Uri.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:Http.Header.t -> + ?chunked:bool -> + ?body:Body.t -> + Uri.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:Http.Header.t -> + params:(string * string list) list -> + Uri.t -> + (Http.Response.t * Body.t) Async_kernel.Deferred.t +(** Send an HTTP POST request in form format *) diff --git a/cohttp-async/src/cohttp_async.ml b/cohttp-async/src/cohttp_async.ml new file mode 100644 index 0000000..6fcef07 --- /dev/null +++ b/cohttp-async/src/cohttp_async.ml @@ -0,0 +1,7 @@ +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 diff --git a/cohttp-async/src/dune b/cohttp-async/src/dune new file mode 100644 index 0000000..c8e29f7 --- /dev/null +++ b/cohttp-async/src/dune @@ -0,0 +1,21 @@ +(library + (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 + http + http_bytebuffer + cohttp) + (preprocess + (pps ppx_sexp_conv))) diff --git a/cohttp-async/src/input_channel.ml b/cohttp-async/src/input_channel.ml new file mode 100644 index 0000000..a57852f --- /dev/null +++ b/cohttp-async/src/input_channel.ml @@ -0,0 +1,61 @@ +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 diff --git a/cohttp-async/src/input_channel.mli b/cohttp-async/src/input_channel.mli new file mode 100644 index 0000000..816b5dd --- /dev/null +++ b/cohttp-async/src/input_channel.mli @@ -0,0 +1,13 @@ +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 diff --git a/cohttp-async/src/io.ml b/cohttp-async/src/io.ml new file mode 100644 index 0000000..60769ea --- /dev/null +++ b/cohttp-async/src/io.ml @@ -0,0 +1,106 @@ +(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy + * + * 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 Base +open Async_kernel + +module IO = struct + 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 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 + { 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 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 + + let ( >>= ) = Deferred.( >>= ) + let return = Deferred.return + + type ic = Input_channel.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 "<< + 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 + +module Request = Cohttp.Request.Private.Make (IO) +module Response = Cohttp.Response.Private.Make (IO) diff --git a/cohttp-async/src/io.mli b/cohttp-async/src/io.mli new file mode 100644 index 0000000..2d1a854 --- /dev/null +++ b/cohttp-async/src/io.mli @@ -0,0 +1,26 @@ +(*{{{ Copyright (c) 2013 Anil Madhavapeddy + * + * 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 IO : + Cohttp.S.IO + with type 'a t = 'a Async_kernel.Deferred.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 diff --git a/cohttp-async/src/server.ml b/cohttp-async/src/server.ml new file mode 100644 index 0000000..6a21ee5 --- /dev/null +++ b/cohttp-async/src/server.ml @@ -0,0 +1,171 @@ +open Base +open Async_kernel +open Async_unix + +type ('address, 'listening_on) t = { + server : ('address, 'listening_on) Tcp.Server.t; [@sexp.opaque] +} +[@@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 Http.Response.t * (Reader.t -> Writer.t -> unit Deferred.t) + | `Response of response ] + +type 'r respond_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 is_closed t = Tcp.Server.is_closed t.server +let listening_on t = Tcp.Server.listening_on t.server + +let read_body req rd = + match Http.Request.has_body req with + (* TODO maybe attempt to read body *) + | `No | `Unknown -> `Empty + | `Yes -> + (* Create a Pipe for the body *) + 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 + (* don't propagate errors up, we handle them here *) + Monitor.detach_and_get_error_stream monitor |> (ignore : exn Stream.t -> unit); + choose + [ + choice (Monitor.get_next_error monitor) (fun e -> + Error (Exn.Reraised ("Cohttp_async.Server.collect_errors", e))); + 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 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 + 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 = Cohttp.Response.make ~status ~encoding ~headers () in + return (resp, body) + +let respond_with_pipe ?headers ?(code = `OK) body = + respond ?headers ~body:(`Pipe body) code + +let respond_string ?headers ?(status = `OK) body = + respond ?headers ~body:(`String body) status + +let respond_with_redirect ?headers uri = + let headers = + Http.Header.add_opt_unless_exists headers "location" (Uri.to_string uri) + in + respond ~headers `Found + +let resolve_local_file ~docroot ~uri = + Cohttp.Path.resolve_local_file ~docroot ~uri + +let error_body_default = "

404 Not Found

" + +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 = + Http.Header.add_opt_unless_exists headers "content-type" mime_type + in + respond ~headers ~body `OK) + >>= function + | Ok res -> return res + | Error _exn -> respond_string ~status:`Not_found error_body + +type mode = Conduit_async.server + +let create_raw ?max_connections ?backlog ?buffer_age_limit ?(mode = `TCP) + ~on_handler_error where_to_listen handle_request = + Conduit_async.serve ?max_connections ?backlog ?buffer_age_limit + ~on_handler_error mode where_to_listen + (handle_client handle_request) + >>| fun server -> { server } + +let create_expert ?max_connections ?backlog ?buffer_age_limit ?(mode = `TCP) + ~on_handler_error where_to_listen handle_request = + create_raw ?max_connections ?backlog ?buffer_age_limit ~on_handler_error ~mode + where_to_listen handle_request + +let create ?max_connections ?backlog ?buffer_age_limit ?(mode = `TCP) + ~on_handler_error where_to_listen handle_request = + let handle_request ~body address request = + handle_request ~body address request >>| fun r -> `Response r + 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 diff --git a/cohttp-async/src/server.mli b/cohttp-async/src/server.mli new file mode 100644 index 0000000..cbe9429 --- /dev/null +++ b/cohttp-async/src/server.mli @@ -0,0 +1,130 @@ +type ('address, 'listening_on) t + constraint 'address = [< Async_unix.Socket.Address.t ] +[@@deriving sexp_of] + +val close : (_, _) t -> unit Async_kernel.Deferred.t +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 = Http.Response.t * Body.t [@@deriving sexp_of] + +type 'r respond_t = + ?headers:Http.Header.t -> + ?body:Body.t -> + Http.Status.t -> + 'r Async_kernel.Deferred.t + +type response_action = + [ `Expert of + 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 {!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 +[@@deprecated "Please use Cohttp.Path.resolve_local_file. "] +(** Resolve a URI and a docroot into a concrete local filename. *) + +val respond_with_pipe : + ?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 + Pipe.Reader.t. + + @param code Default is HTTP 200 `OK *) + +val respond_string : + ?headers:Http.Header.t -> + ?status:Http.Status.t -> + string -> + response Async_kernel.Deferred.t + +val respond_with_redirect : + ?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 : + ?headers:Http.Header.t -> + ?error_body:string -> + string -> + response Async_kernel.Deferred.t +(** Respond with file contents, and [error_string Pipe.Async_unix.Reader.t] if + the file isn't found *) + +type mode = Conduit_async.server + +val create_expert : + ?max_connections:int -> + ?backlog:int -> + ?buffer_age_limit:Async_unix.Writer.buffer_age_limit -> + ?mode:mode -> + on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ] -> + ('address, 'listening_on) Async.Tcp.Where_to_listen.t -> + (body:Body.t -> + 'address -> + 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 + [Tcp.Server] interface. *) + +val create : + ?max_connections:int -> + ?backlog:int -> + ?buffer_age_limit:Async_unix.Writer.buffer_age_limit -> + ?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 -> + 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 diff --git a/cohttp-async/test/cohttp_async_test/src/cohttp_async_test.ml b/cohttp-async/test/cohttp_async_test/src/cohttp_async_test.ml new file mode 100644 index 0000000..7215983 --- /dev/null +++ b/cohttp-async/test/cohttp_async_test/src/cohttp_async_test.ml @@ -0,0 +1,74 @@ +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 diff --git a/cohttp-async/test/cohttp_async_test/src/cohttp_async_test.mli b/cohttp-async/test/cohttp_async_test/src/cohttp_async_test.mli new file mode 100644 index 0000000..302d047 --- /dev/null +++ b/cohttp-async/test/cohttp_async_test/src/cohttp_async_test.mli @@ -0,0 +1,10 @@ +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 diff --git a/cohttp-async/test/cohttp_async_test/src/dune b/cohttp-async/test/cohttp_async_test/src/dune new file mode 100644 index 0000000..265dcfc --- /dev/null +++ b/cohttp-async/test/cohttp_async_test/src/dune @@ -0,0 +1,3 @@ +(library + (name cohttp_async_test) + (libraries fmt.tty uri.services async_kernel cohttp_test cohttp-async)) diff --git a/cohttp-async/test/dune b/cohttp-async/test/dune new file mode 100644 index 0000000..25cf8c4 --- /dev/null +++ b/cohttp-async/test/dune @@ -0,0 +1,16 @@ +(executable + (name test_async_integration) + (libraries + cohttp_async_test + async_unix + base + core + async_kernel + ounit2 + cohttp-async)) + +(rule + (alias runtest) + (package cohttp-async) + (action + (run ./test_async_integration.exe))) diff --git a/cohttp-async/test/test_async_integration.ml b/cohttp-async/test/test_async_integration.ml new file mode 100644 index 0000000..a2cfb9a --- /dev/null +++ b/cohttp-async/test/test_async_integration.ml @@ -0,0 +1,118 @@ +open Base +open Async_kernel +open OUnit +open Cohttp +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' +let response_bodies = [ "Testing"; "Foo bar" ] +let ok s = Server.respond `OK ~body:(Body.of_string s) +let chunk size = String.init ~f:(Fn.const 'X') size +let chunk_size = 33_000 +let chunks = 3 + +let server = + [ + (* empty_chunk *) + const @@ Server.respond `OK ~body:(Body.of_string_list chunk_body); + (* large response *) + const @@ Server.respond_string large_string; + (* large request *) + (fun _ body -> + body |> Body.to_string >>| String.length >>= fun len -> + Server.respond_string (Int.to_string len) >>| response); + ] + (* pipelined_chunk *) + @ (response_bodies |> List.map ~f:(Fn.compose const ok)) + (* large response chunked *) + @ [ + (fun _ _ -> + let body = + let r, w = Pipe.create () in + let chunk = chunk chunk_size in + for _ = 0 to chunks - 1 do + Pipe.write_without_pushback w chunk + done; + Pipe.close w; + r + in + Server.respond_with_pipe ~code:`OK body >>| response); + (* pipelined_expert *) + expert (fun _ic oc -> + Async_unix.Writer.write oc "8\r\nexpert 1\r\n0\r\n\r\n"; + Async_unix.Writer.flushed oc); + expert (fun ic oc -> + Async_unix.Writer.write oc "8\r\nexpert 2\r\n0\r\n\r\n"; + Async_unix.Writer.flushed oc >>= fun () -> Async_unix.Reader.close ic); + ] + |> response_sequence + +let ts = + test_server_s server (fun uri -> + let headers = Header.init_with "connection" "close" in + let empty_chunk () = + Client.get ~headers uri >>= fun (_, body) -> + body |> Body.to_string >>| fun body -> + assert_equal body (String.concat ~sep:"" chunk_body) + in + let large_response () = + Client.get ~headers uri >>= fun (_, body) -> + body |> Body.to_string >>| fun body -> assert_equal body large_string + in + let large_request () = + Client.post ~headers ~body:(Body.of_string large_string) uri + >>= fun (_, body) -> + body |> Body.to_string >>| fun s -> + assert_equal (String.length large_string) (Int.of_string s) + in + let pipelined_chunk () = + let printer x = x in + let reqs = + [ + (Request.make ~meth:`POST uri, Body.of_string "foo"); + (Request.make ~meth:`POST uri, Body.of_string "bar"); + ] + in + let body_q = response_bodies |> Queue.of_list in + reqs |> Pipe.of_list |> Client.callv uri >>= fun responses -> + responses |> Pipe.to_list >>= fun resps -> + resps + |> Deferred.List.iter ~how:`Sequential ~f:(fun (_resp, body) -> + let expected_body = body_q |> Queue.dequeue_exn in + body |> Body.to_string >>| fun body -> + assert_equal ~printer expected_body body) + in + let large_chunked_response () = + Client.get ~headers uri >>= fun (resp, body) -> + assert_equal Cohttp.Transfer.Chunked (Response.encoding resp); + body |> Body.to_string >>| String.length >>| fun len -> + assert_equal ~printer:Int.to_string (chunk_size * chunks) len + in + let expert_pipelined () = + let printer x = x in + Client.get uri >>= fun (_rsp, body) -> + Body.to_string body >>= fun body -> + assert_equal ~printer "expert 1" body; + Client.get ~headers uri >>= fun (_rsp, body) -> + Body.to_string body >>| fun body -> + assert_equal ~printer "expert 2" body + in + [ + ("empty chunk test", empty_chunk); + ("large response", large_response); + ("large request", large_request); + ("pipelined chunk test", pipelined_chunk); + ("large chunked response", large_chunked_response); + ("expert response", expert_pipelined); + ]) + +let () = + ts + |> run_async_tests + >>= (fun _ -> Async_unix.Shutdown.exit 0) + |> don't_wait_for; + Core.never_returns (Async_unix.Scheduler.go ()) diff --git a/cohttp-bench.opam b/cohttp-bench.opam new file mode 100644 index 0000000..69bab1e --- /dev/null +++ b/cohttp-bench.opam @@ -0,0 +1,55 @@ +version: "6.2.1" +# 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 "] +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} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp-bench.opam.template b/cohttp-bench.opam.template new file mode 100644 index 0000000..8c3e513 --- /dev/null +++ b/cohttp-bench.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp-bench/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp-bench/async_server.ml b/cohttp-bench/async_server.ml new file mode 100644 index 0000000..632e731 --- /dev/null +++ b/cohttp-bench/async_server.ml @@ -0,0 +1,29 @@ +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 diff --git a/cohttp-bench/bench.ml b/cohttp-bench/bench.ml new file mode 100644 index 0000000..9b0d5dc --- /dev/null +++ b/cohttp-bench/bench.ml @@ -0,0 +1,29 @@ +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 ] diff --git a/cohttp-bench/dune b/cohttp-bench/dune new file mode 100644 index 0000000..3990311 --- /dev/null +++ b/cohttp-bench/dune @@ -0,0 +1,38 @@ +(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)) diff --git a/cohttp-bench/eio_server.ml b/cohttp-bench/eio_server.ml new file mode 100644 index 0000000..77575d8 --- /dev/null +++ b/cohttp-bench/eio_server.ml @@ -0,0 +1,21 @@ +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 diff --git a/cohttp-bench/latency.sh b/cohttp-bench/latency.sh new file mode 100755 index 0000000..9e9f145 --- /dev/null +++ b/cohttp-bench/latency.sh @@ -0,0 +1,21 @@ +#! /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" diff --git a/cohttp-bench/lwt_unix_server.ml b/cohttp-bench/lwt_unix_server.ml new file mode 100644 index 0000000..65ce77f --- /dev/null +++ b/cohttp-bench/lwt_unix_server.ml @@ -0,0 +1,17 @@ +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 ())) diff --git a/cohttp-bench/lwt_unix_server_new.ml b/cohttp-bench/lwt_unix_server_new.ml new file mode 100644 index 0000000..507faa2 --- /dev/null +++ b/cohttp-bench/lwt_unix_server_new.ml @@ -0,0 +1,31 @@ +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 ())) diff --git a/cohttp-bench/lwt_unix_server_new.mli b/cohttp-bench/lwt_unix_server_new.mli new file mode 100644 index 0000000..e69de29 diff --git a/cohttp-curl-async.opam b/cohttp-curl-async.opam new file mode 100644 index 0000000..50f608b --- /dev/null +++ b/cohttp-curl-async.opam @@ -0,0 +1,56 @@ +version: "6.2.1" +# 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 "] +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} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp-curl-async.opam.template b/cohttp-curl-async.opam.template new file mode 100644 index 0000000..3b4adae --- /dev/null +++ b/cohttp-curl-async.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp-curl-async/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp-curl-async/bin/curl.ml b/cohttp-curl-async/bin/curl.ml new file mode 100644 index 0000000..0089d6b --- /dev/null +++ b/cohttp-curl-async/bin/curl.ml @@ -0,0 +1,47 @@ +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 diff --git a/cohttp-curl-async/bin/dune b/cohttp-curl-async/bin/dune new file mode 100644 index 0000000..06a96ab --- /dev/null +++ b/cohttp-curl-async/bin/dune @@ -0,0 +1,11 @@ +(executable + (name curl) + (libraries + sexplib0 + cohttp + cohttp_curl_async + core_kernel + async_unix + async_kernel + async.async_command + core_unix.command_unix)) diff --git a/cohttp-curl-async/src/cohttp_curl_async.ml b/cohttp-curl-async/src/cohttp_curl_async.ml new file mode 100644 index 0000000..ef41336 --- /dev/null +++ b/cohttp-curl-async/src/cohttp_curl_async.ml @@ -0,0 +1,189 @@ +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 } diff --git a/cohttp-curl-async/src/cohttp_curl_async.mli b/cohttp-curl-async/src/cohttp_curl_async.mli new file mode 100644 index 0000000..560dd7f --- /dev/null +++ b/cohttp-curl-async/src/cohttp_curl_async.mli @@ -0,0 +1,78 @@ +(** 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. *) diff --git a/cohttp-curl-async/src/dune b/cohttp-curl-async/src/dune new file mode 100644 index 0000000..8cf82f9 --- /dev/null +++ b/cohttp-curl-async/src/dune @@ -0,0 +1,3 @@ +(library + (name cohttp_curl_async) + (libraries http cohttp-curl core curl stringext async_kernel async_unix)) diff --git a/cohttp-curl-async/test/cohttp_curl_async_tests.ml b/cohttp-curl-async/test/cohttp_curl_async_tests.ml new file mode 100644 index 0000000..21e7fa8 --- /dev/null +++ b/cohttp-curl-async/test/cohttp_curl_async_tests.ml @@ -0,0 +1,44 @@ +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 ()) diff --git a/cohttp-curl-async/test/dune b/cohttp-curl-async/test/dune new file mode 100644 index 0000000..5ca3661 --- /dev/null +++ b/cohttp-curl-async/test/dune @@ -0,0 +1,12 @@ +(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)) diff --git a/cohttp-curl-lwt.opam b/cohttp-curl-lwt.opam new file mode 100644 index 0000000..a28ecf7 --- /dev/null +++ b/cohttp-curl-lwt.opam @@ -0,0 +1,56 @@ +version: "6.2.1" +# 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 "] +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"} + "cmdliner" {with-dev-setup & >= "2.0.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} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp-curl-lwt.opam.template b/cohttp-curl-lwt.opam.template new file mode 100644 index 0000000..ced5cee --- /dev/null +++ b/cohttp-curl-lwt.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp-curl-lwt/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp-curl-lwt/bin/curl.ml b/cohttp-curl-lwt/bin/curl.ml new file mode 100644 index 0000000..12c3b40 --- /dev/null +++ b/cohttp-curl-lwt/bin/curl.ml @@ -0,0 +1,112 @@ +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 = + let parser s = + match Uri.of_string s with + | uri -> Ok uri + | exception Failure _ -> Error "unable to parse URI" + in + let pp ppf u = Format.fprintf ppf "%s" (Uri.to_string u) in + Cmdliner.Arg.Conv.make ~parser ~pp ~docv:"URI" () + 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 , or \ + on the issue tracker at \ + "; + `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 diff --git a/cohttp-curl-lwt/bin/curl.mli b/cohttp-curl-lwt/bin/curl.mli new file mode 100644 index 0000000..e69de29 diff --git a/cohttp-curl-lwt/bin/dune b/cohttp-curl-lwt/bin/dune new file mode 100644 index 0000000..9cf274e --- /dev/null +++ b/cohttp-curl-lwt/bin/dune @@ -0,0 +1,13 @@ +(executable + (name curl) + (libraries + sexplib0 + cohttp + cohttp_curl_lwt + lwt.unix + lwt + logs + logs.cli + uri + fmt.tty + cmdliner)) diff --git a/cohttp-curl-lwt/src/cohttp_curl_lwt.ml b/cohttp-curl-lwt/src/cohttp_curl_lwt.ml new file mode 100644 index 0000000..e856024 --- /dev/null +++ b/cohttp-curl-lwt/src/cohttp_curl_lwt.ml @@ -0,0 +1,195 @@ +(* {[ + Copyright (c) 2003, Lars Nilsson, + Copyright (c) 2009, ygrek, + + 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 } diff --git a/cohttp-curl-lwt/src/cohttp_curl_lwt.mli b/cohttp-curl-lwt/src/cohttp_curl_lwt.mli new file mode 100644 index 0000000..4082a8b --- /dev/null +++ b/cohttp-curl-lwt/src/cohttp_curl_lwt.mli @@ -0,0 +1,75 @@ +(** 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. *) diff --git a/cohttp-curl-lwt/src/dune b/cohttp-curl-lwt/src/dune new file mode 100644 index 0000000..e00831f --- /dev/null +++ b/cohttp-curl-lwt/src/dune @@ -0,0 +1,4 @@ +(library + (name cohttp_curl_lwt) + (public_name cohttp-curl-lwt) + (libraries http cohttp-curl stringext lwt lwt.unix curl)) diff --git a/cohttp-curl-lwt/test/cohttp_curl_lwt_tests.ml b/cohttp-curl-lwt/test/cohttp_curl_lwt_tests.ml new file mode 100644 index 0000000..6673dc4 --- /dev/null +++ b/cohttp-curl-lwt/test/cohttp_curl_lwt_tests.ml @@ -0,0 +1,47 @@ +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 diff --git a/cohttp-curl-lwt/test/dune b/cohttp-curl-lwt/test/dune new file mode 100644 index 0000000..5823ffe --- /dev/null +++ b/cohttp-curl-lwt/test/dune @@ -0,0 +1,4 @@ +(test + (name cohttp_curl_lwt_tests) + (libraries http alcotest uri cohttp_lwt_unix_test cohttp_curl_lwt) + (package cohttp-curl-lwt)) diff --git a/cohttp-curl.opam b/cohttp-curl.opam new file mode 100644 index 0000000..df4c2f5 --- /dev/null +++ b/cohttp-curl.opam @@ -0,0 +1,44 @@ +version: "6.2.1" +# 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 "] +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} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp-curl.opam.template b/cohttp-curl.opam.template new file mode 100644 index 0000000..09c9873 --- /dev/null +++ b/cohttp-curl.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp-curl/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp-curl/src/cohttp_curl.ml b/cohttp-curl/src/cohttp_curl.ml new file mode 100644 index 0000000..e726b64 --- /dev/null +++ b/cohttp-curl/src/cohttp_curl.ml @@ -0,0 +1,150 @@ +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 diff --git a/cohttp-curl/src/cohttp_curl.mli b/cohttp-curl/src/cohttp_curl.mli new file mode 100644 index 0000000..e30c7a8 --- /dev/null +++ b/cohttp-curl/src/cohttp_curl.mli @@ -0,0 +1,43 @@ +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 diff --git a/cohttp-curl/src/dune b/cohttp-curl/src/dune new file mode 100644 index 0000000..77c610d --- /dev/null +++ b/cohttp-curl/src/dune @@ -0,0 +1,4 @@ +(library + (name cohttp_curl) + (public_name cohttp-curl) + (libraries http curl stringext)) diff --git a/cohttp-eio.opam b/cohttp-eio.opam new file mode 100644 index 0000000..4d8af49 --- /dev/null +++ b/cohttp-eio.opam @@ -0,0 +1,57 @@ +version: "6.2.1" +# 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 "] +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} + "ipaddr" {>= "5.6.0"} + "logs" + "uri" + "tls-eio" {with-test & >= "1.0.0"} + "mirage-crypto-rng" {with-test & >= "1.2.0"} + "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} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp-eio.opam.template b/cohttp-eio.opam.template new file mode 100644 index 0000000..2d9bf65 --- /dev/null +++ b/cohttp-eio.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp-eio/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp-eio/examples/README.md b/cohttp-eio/examples/README.md new file mode 100644 index 0000000..6c467e1 --- /dev/null +++ b/cohttp-eio/examples/README.md @@ -0,0 +1,55 @@ +# Cohttp-eio Examples + +This directory contains examples illustrating different modes of use of the +cohttp-eio package. + +## [`client_proxy.ml`](./client_proxy.ml) + +This executable shows an example of how to set up proxying for client requests. + +## Prerequisites + +The following usage examples assumes + +- you are working in root directory of this project, +- you have installed [mitmproxy](https://github.com/mitmproxy/mitmproxy), +- and that you have launched `mitmdump` on port `8888` in a separate terminal, with + + ``` sh + mitmdum -p 8888 + ``` + +NOTE: We use mitmproxy because it allows us to test the https connection to the +proxy locally. However, it also requires using its own cacert for these use +cases. This example executable can also be exercised with +[tinyproxy](https://github.com/tinyproxy/tinyproxy), excluding https connections +to the proxy. + +### Direct proxy for http requests + +``` sh +dune exec cohttp-eio/examples/client_proxy.exe -- \ + --all-proxy=http://127.0.0.1:8888 \ + http://httpbin.io/hostname +``` + + +### Tunnelling proxy for https requests to the remote host + +``` sh +dune exec cohttp-eio/examples/client_proxy.exe -- \ + --cacert=$HOME/.mitmproxy/mitmproxy-ca-cert.pem \ + --all-proxy=http://127.0.0.1:8888 \ + https://httpbin.io/hostname +``` + +### Using an https connection to the proxy + +This exercises our support for TLS over TLS. + +``` sh +dune exec cohttp-eio/examples/client_proxy.exe -- \ + --cacert=$HOME/.mitmproxy/mitmproxy-ca-cert.pem \ + --all-proxy=https://127.0.0.1:8888 \ + https://httpbin.io/hostname +``` diff --git a/cohttp-eio/examples/client1.ml b/cohttp-eio/examples/client1.ml new file mode 100644 index 0000000..905f529 --- /dev/null +++ b/cohttp-eio/examples/client1.ml @@ -0,0 +1,18 @@ +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 diff --git a/cohttp-eio/examples/client_proxy.ml b/cohttp-eio/examples/client_proxy.ml new file mode 100644 index 0000000..7da7134 --- /dev/null +++ b/cohttp-eio/examples/client_proxy.ml @@ -0,0 +1,196 @@ +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 socket -> + let host = + Option.bind (Uri.host uri) (fun x -> + Domain_name.(host (of_string_exn x)) |> Result.to_option) + in + Tls_eio.client_of_flow ?host tls_config socket + +let get_request_exn ~sw client url = + let resp, body = Client.get ~sw client url in + match resp.status with + | `OK -> + Eio.traceln "%s" + @@ Eio.Buf_read.(parse_exn take_all) body ~max_size:max_int + | otherwise -> Fmt.epr "Unexpected HTTP status: %a\n" Http.Status.pp otherwise + +let run_client url cacert all_proxy no_proxy http_proxy https_proxy proxy_auth = + let scheme_proxy = + List.filter_map Fun.id + [ + Option.map (fun p -> ("http", p)) http_proxy; + Option.map (fun p -> ("https", p)) https_proxy; + ] + in + let proxy_headers = + Option.map + (fun credential -> + Http.Header.init_with "Proxy-Authorization" + (Cohttp.Auth.string_of_credential credential)) + proxy_auth + in + + Eio_main.run @@ fun env -> + Mirage_crypto_rng_unix.use_default (); + + let net = env#net in + + let authenticator = + match cacert with + | None -> authenticator + | Some pem -> + (* Load a custom cacert from a file *) + let fs = Eio.Stdenv.fs env in + X509_eio.authenticator (`Ca_file Eio.Path.(fs / pem)) + in + + Client.set_proxies ?proxy_headers ?default_proxy:all_proxy + ?no_proxy_patterns:no_proxy ~scheme_proxies:scheme_proxy (); + + let client = Client.make ~https:(Some (https ~authenticator)) net in + + Eio.traceln ">>> Make calls in sequence"; + Eio.Switch.run (fun sw -> + get_request_exn ~sw client url; + get_request_exn ~sw client url; + get_request_exn ~sw client url); + + Eio.traceln ">>> Make calls concurrently"; + Eio.Switch.run (fun sw -> + for _ = 0 to 5 do + Eio.Fiber.fork ~sw (fun () -> get_request_exn ~sw client url) + done); + + Eio.traceln ">>> Make calls in parallel"; + let dm = Eio.Stdenv.domain_mgr env in + Eio.Fiber.all + [ + (fun () -> + Eio.Domain_manager.run dm (fun () -> + Eio.Switch.run (fun sw -> get_request_exn ~sw client url))); + (fun () -> + Eio.Domain_manager.run dm (fun () -> + Eio.Switch.run (fun sw -> get_request_exn ~sw client url))); + (fun () -> + Eio.Domain_manager.run dm (fun () -> + Eio.Switch.run (fun sw -> get_request_exn ~sw client url))); + (fun () -> + Eio.Domain_manager.run dm (fun () -> + Eio.Switch.run (fun sw -> get_request_exn ~sw client url))); + (fun () -> + Eio.Domain_manager.run dm (fun () -> + Eio.Switch.run (fun sw -> get_request_exn ~sw client url))); + ] + +(* CLI Interface *) + +let uri_conv = + let parser s = + match Uri.of_string s with + | uri -> Ok uri + | exception Failure _ -> Error "unable to parse URI" + in + + let pp ppf u = Fmt.pf ppf "%s" (Uri.to_string u) in + Cmdliner.Arg.Conv.make ~parser ~pp ~docv:"URI" () + +let credential_conv = + let parser s = + match Base64.encode s with + | Ok s -> + s |> Fmt.str "Basic %s" |> Cohttp.Auth.credential_of_string |> Result.ok + | Error (`Msg m) -> Error m + in + let pp ppf c = Fmt.pf ppf "%s" (Cohttp.Auth.string_of_credential c) in + Cmdliner.Arg.Conv.make ~parser ~pp ~docv:"CREDENTIAL" () + +let uri = + Cmdliner.Arg.( + required + & pos 0 (some uri_conv) None + & info [] ~docv:"URI" + ~doc:"string of the remote address (e.g. https://ocaml.org)") + +let all_proxy = + let env = Cmdliner.Cmd.Env.info "ALL_PROXY" in + Cmdliner.Arg.( + value + & opt (some uri_conv) None + & info [ "all-proxy" ] ~env ~docv:"ALL_PROXY" ~doc:"Default proxy server") + +let no_proxy = + let env = Cmdliner.Cmd.Env.info "NO_PROXY" in + Cmdliner.Arg.( + value + & opt (some string) None + & info [ "no-proxy" ] ~env ~docv:"NO_PROXY" + ~doc:"Exclude matching hosts from proxying") + +let http_proxy = + let env = Cmdliner.Cmd.Env.info "HTTP_PROXY" in + Cmdliner.Arg.( + value + & opt (some uri_conv) None + & info [ "http-proxy" ] ~env ~docv:"HTTP_PROXY" + ~doc:"Proxy to use for requests using http") + +let https_proxy = + let env = Cmdliner.Cmd.Env.info "HTTPS_PROXY" in + Cmdliner.Arg.( + value + & opt (some uri_conv) None + & info [ "https-proxy" ] ~env ~docv:"HTTPS_PROXY" + ~doc:"Proxy to use for requests using https") + +let proxy_auth = + Cmdliner.Arg.( + value + & opt (some credential_conv) None + & info [ "proxy-auth" ] ~docv:"CREDENTIAL" ~doc:"Proxy credentials") + +let cacert = + Cmdliner.Arg.( + value + & opt (some string) None + & info [ "cacert" ] ~docv:"PEM_FILE" + ~doc:"Custom cert file for https authentication") + +let cmd = + let info = + let version = Cohttp.Conf.version in + let doc = "retrieve a remote URI contents" in + Cmdliner.Cmd.info "client_proxy" ~version ~doc + in + + let term = + Cmdliner.Term.( + const run_client + $ uri + $ cacert + $ all_proxy + $ no_proxy + $ http_proxy + $ https_proxy + $ proxy_auth) + in + Cmdliner.Cmd.v info term + +let () = exit @@ Cmdliner.Cmd.eval cmd diff --git a/cohttp-eio/examples/client_timeout.ml b/cohttp-eio/examples/client_timeout.ml new file mode 100644 index 0000000..305a12e --- /dev/null +++ b/cohttp-eio/examples/client_timeout.ml @@ -0,0 +1,17 @@ +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@." diff --git a/cohttp-eio/examples/client_tls.ml b/cohttp-eio/examples/client_tls.ml new file mode 100644 index 0000000..dc32986 --- /dev/null +++ b/cohttp-eio/examples/client_tls.ml @@ -0,0 +1,37 @@ +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_unix.use_default (); + 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 diff --git a/cohttp-eio/examples/docker_client.ml b/cohttp-eio/examples/docker_client.ml new file mode 100644 index 0000000..e711e10 --- /dev/null +++ b/cohttp-eio/examples/docker_client.ml @@ -0,0 +1,26 @@ +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) diff --git a/cohttp-eio/examples/dune b/cohttp-eio/examples/dune new file mode 100644 index 0000000..4619b06 --- /dev/null +++ b/cohttp-eio/examples/dune @@ -0,0 +1,26 @@ +(executables + (names + server1 + server2 + client1 + docker_client + client_timeout + client_tls + client_proxy) + (libraries + cohttp-eio + cmdliner + eio_main + eio.unix + fmt + unix + logs.fmt + logs.threaded + tls-eio + ca-certs + mirage-crypto-rng.unix)) + +(alias + (name runtest) + (package cohttp-eio) + (deps server1.exe)) diff --git a/cohttp-eio/examples/server1.ml b/cohttp-eio/examples/server1.ml new file mode 100644 index 0000000..7368da9 --- /dev/null +++ b/cohttp-eio/examples/server1.ml @@ -0,0 +1,58 @@ +let text = + "CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of \ + sitting by her sister on the bank, and of having nothing to do: once or \ + twice she had peeped into the book her sister was reading, but it had no \ + pictures or conversations in it, thought \ + Alice So she was considering in her \ + own mind (as well as she could, for the hot day made her feel very sleepy \ + and stupid), whether the pleasure of making a daisy-chain would be worth \ + the trouble of getting up and picking the daisies, when suddenly a White \ + Rabbit with pink eyes ran close by her. There was nothing so very \ + remarkable in that; nor did Alice think it so very much out of the way to \ + hear the Rabbit say to itself, (when \ + she thought it over afterwards, it occurred to her that she ought to have \ + wondered at this, but at the time it all seemed quite natural); but when \ + the Rabbit actually took a watch out of its waistcoat-pocket, and looked at \ + it, and then hurried on, Alice started to her feet, for it flashed across \ + her mind that she had never before seen a rabbit with either a \ + waistcoat-pocket, or a watch to take out of it, and burning with curiosity, \ + she ran across the field after it, and fortunately was just in time to see \ + it pop down a large rabbit-hole under the hedge. In another moment down \ + went Alice after it, never once considering how in the world she was to get \ + out again. The rabbit-hole went straight on like a tunnel for some way, and \ + then dipped suddenly down, so suddenly that Alice had not a moment to think \ + about stopping herself before she found herself falling down a very deep \ + well. Either the well was very deep, or she fell very slowly, for she had \ + plenty of time as she went down to look about her and to wonder what was \ + going to happen next. First, she tried to look down and make out what she \ + was coming to, but it was too dark to see anything; then she looked at the \ + sides of the well, and noticed that they were filled with cupboards......" + +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 diff --git a/cohttp-eio/examples/server2.ml b/cohttp-eio/examples/server2.ml new file mode 100644 index 0000000..7019f4a --- /dev/null +++ b/cohttp-eio/examples/server2.ml @@ -0,0 +1,37 @@ +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 diff --git a/cohttp-eio/src/body.ml b/cohttp-eio/src/body.ml new file mode 100644 index 0000000..5e11f26 --- /dev/null +++ b/cohttp-eio/src/body.ml @@ -0,0 +1,21 @@ +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) diff --git a/cohttp-eio/src/client.ml b/cohttp-eio/src/client.ml new file mode 100644 index 0000000..a36e0e9 --- /dev/null +++ b/cohttp-eio/src/client.ml @@ -0,0 +1,158 @@ +open Eio.Std +open Utils +module Proxy = Cohttp.Proxy.Forward + +type connection = [ Eio.Flow.two_way_ty | Eio.Resource.close_ty ] r +type t = sw:Switch.t -> Uri.t -> connection +type proxies = (Uri.t, Uri.t) Proxy.servers + +let proxies : (Http.Header.t option * proxies) option Atomic.t = + Atomic.make None + +let set_proxies ?no_proxy_patterns ?default_proxy ?(scheme_proxies = []) + ?proxy_headers () = + let servers = + Proxy.make_servers ~no_proxy_patterns ~default_proxy ~scheme_proxies + ~direct:Fun.id ~tunnel:Fun.id + in + Atomic.set proxies (Some (proxy_headers, servers)) + +let get_proxy uri = + match Atomic.get proxies with + | None -> None + | Some (headers, proxies) -> ( + match Proxy.get proxies uri with + | None -> None + | Some (Proxy.Direct _) as proxy -> proxy + | Some (Proxy.Tunnel p) -> Some (Proxy.Tunnel (headers, p))) + +let call_on_socket ~sw ?headers ?body ?(chunked = false) meth uri socket = + 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)) + +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 + call_on_socket ~sw ?headers ?body ~chunked meth uri socket + 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" + +(* Create a socket for the uri, and signal whether it requires https *) +let scheme_conn_of_uri ~sw net uri = + match Uri.scheme uri with + | Some "httpunix" -> + (* FIXME: while there is no standard, http+unix seems more widespread *) + `Plain (Eio.Net.connect ~sw net (unix_address uri) :> connection) + | Some "http" -> + `Plain (Eio.Net.connect ~sw net (tcp_address ~net uri) :> connection) + | Some "https" -> + `Https (Eio.Net.connect ~sw net (tcp_address ~net uri) :> connection) + | x -> + Fmt.failwith "Unknown scheme %a" + Fmt.(option ~none:(any "None") Dump.string) + x + +(* Create a tunnel to the proxy at [proxy_uri] *) +let make_tunnel ~sw ~headers proxy_uri socket = + let resp, _ = call_on_socket ~sw ?headers `CONNECT proxy_uri socket in + match Http.Response.status resp with + | #Http.Status.success -> Ok () + | _ -> Error (Http.Response.status resp) + +(* Apply the https wrapper, if provided, or else fail with an error *) +let apply_https https uri conn = + match https with + | None -> Fmt.failwith "HTTPS not enabled (for %a)" Uri.pp uri + | Some wrap -> (wrap uri conn :> connection) + +let make ~https net : t = + fun ~sw uri -> + let scheme_conn = + match get_proxy uri with + | None -> scheme_conn_of_uri ~sw net uri + | Some (Proxy.Direct proxy_uri) -> scheme_conn_of_uri ~sw net proxy_uri + | Some (Proxy.Tunnel (proxy_headers, proxy_uri)) -> ( + let conn = + match scheme_conn_of_uri ~sw net proxy_uri with + | `Plain socket -> socket + | `Https socket -> apply_https https proxy_uri socket + in + match make_tunnel ~sw ~headers:proxy_headers uri conn with + | Ok () -> + (* we know its an https connection, because we have selected a tunnelling proxy *) + `Https conn + | Error status -> + Fmt.failwith + "Proxy could not form tunnel to %a for host %a; status %a" Uri.pp + proxy_uri Uri.pp uri Http.Status.pp status) + in + match scheme_conn with + | `Plain conn -> conn + | `Https conn -> apply_https https uri conn diff --git a/cohttp-eio/src/client.mli b/cohttp-eio/src/client.mli new file mode 100644 index 0000000..f90ea4e --- /dev/null +++ b/cohttp-eio/src/client.mli @@ -0,0 +1,45 @@ +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 -> + [ Eio.Flow.two_way_ty | Eio.Resource.close_ty ] Eio.Std.r -> + [> Eio.Resource.close_ty ] 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.Resource.close_ty ] 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. *) + +val set_proxies : + ?no_proxy_patterns:string -> + ?default_proxy:Uri.t -> + ?scheme_proxies:(string * Uri.t) list -> + ?proxy_headers:Http.Header.t -> + unit -> + unit +(** [set_proxies ~default_proxy ()] configures the proxies used by clients + created via {!val:make}. + + See {!val:Cohttp.Proxy.Forward.make_servers} for the meaning of the + parameters. *) diff --git a/cohttp-eio/src/cohttp_eio.ml b/cohttp-eio/src/cohttp_eio.ml new file mode 100644 index 0000000..4f02df4 --- /dev/null +++ b/cohttp-eio/src/cohttp_eio.ml @@ -0,0 +1,9 @@ +module Body = Body +module Client = Client +module Server = Server + +module Private = struct + module IO = Io.IO +end + +let src = Utils.src diff --git a/cohttp-eio/src/dune b/cohttp-eio/src/dune new file mode 100644 index 0000000..7353ea3 --- /dev/null +++ b/cohttp-eio/src/dune @@ -0,0 +1,4 @@ +(library + (name cohttp_eio) + (public_name cohttp-eio) + (libraries cohttp eio fmt http logs ptime uri uri.services ipaddr)) diff --git a/cohttp-eio/src/io.ml b/cohttp-eio/src/io.ml new file mode 100644 index 0000000..373f5d0 --- /dev/null +++ b/cohttp-eio/src/io.ml @@ -0,0 +1,58 @@ +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) diff --git a/cohttp-eio/src/io.mli b/cohttp-eio/src/io.mli new file mode 100644 index 0000000..f7de344 --- /dev/null +++ b/cohttp-eio/src/io.mli @@ -0,0 +1,14 @@ +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) *) diff --git a/cohttp-eio/src/server.ml b/cohttp-eio/src/server.ml new file mode 100644 index 0000000..b1b2fe6 --- /dev/null +++ b/cohttp-eio/src/server.ml @@ -0,0 +1,164 @@ +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)) diff --git a/cohttp-eio/src/server.mli b/cohttp-eio/src/server.mli new file mode 100644 index 0000000..6fd79ad --- /dev/null +++ b/cohttp-eio/src/server.mli @@ -0,0 +1,23 @@ +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 diff --git a/cohttp-eio/src/utils.ml b/cohttp-eio/src/utils.ml new file mode 100644 index 0000000..8478eac --- /dev/null +++ b/cohttp-eio/src/utils.ml @@ -0,0 +1,63 @@ +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 + () diff --git a/cohttp-eio/tests/dune b/cohttp-eio/tests/dune new file mode 100644 index 0000000..23b57e7 --- /dev/null +++ b/cohttp-eio/tests/dune @@ -0,0 +1,13 @@ +(test + (name test) + (modules test) + (libraries alcotest cohttp-eio eio eio.mock eio_main logs.fmt) + (package cohttp-eio) + (preprocess + (pps ppx_here))) + +(test + (name test_forward_proxy) + (modules test_forward_proxy) + (libraries alcotest cohttp-eio eio eio.mock eio_main logs.fmt) + (package cohttp-eio)) diff --git a/cohttp-eio/tests/test.ml b/cohttp-eio/tests/test.ml new file mode 100644 index 0000000..17ec71d --- /dev/null +++ b/cohttp-eio/tests/test.ml @@ -0,0 +1,112 @@ +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; + ] ); + ] diff --git a/cohttp-eio/tests/test_forward_proxy.ml b/cohttp-eio/tests/test_forward_proxy.ml new file mode 100644 index 0000000..d425543 --- /dev/null +++ b/cohttp-eio/tests/test_forward_proxy.ml @@ -0,0 +1,128 @@ +(* Tests the core behaviour if the forward proxy *) + +let () = + Logs.set_level ~all:true @@ Some Logs.Debug; + Logs.set_reporter (Logs_fmt.reporter ()) + +(* Used to pass data out of the server *) +module Req_data = struct + let side_channel : Http.Request.t Eio.Stream.t = Eio.Stream.create 1 + let send t = Eio.Stream.add side_channel t + + let get () = + if Eio.Stream.is_empty side_channel then failwith "no requests pending"; + Eio.Stream.take side_channel +end + +let t_meth : Http.Method.t Alcotest.testable = + Alcotest.testable Http.Method.pp (fun a b -> Http.Method.compare a b = 0) + +(* The proxy server sends every request to the `Req_data` side channel and + always responds with 200. *) +let run_proxy_server server_port net sw = + let handler ~sw _conn request body = + let _ = Eio.Buf_read.(of_flow ~max_size:max_int body |> take_all) in + Eio.Fiber.fork ~sw (fun () -> Req_data.send request); + Cohttp_eio.Server.respond_string ~status:`OK ~body:"" () + in + let socket = + Eio.Net.listen net ~sw ~backlog:128 ~reuse_addr:true ~reuse_port:true + (`Tcp (Eio.Net.Ipaddr.V4.loopback, server_port)) + and server = Cohttp_eio.Server.make ~callback:(handler ~sw) () in + Eio.Fiber.fork_daemon ~sw @@ fun () -> + let () = Cohttp_eio.Server.run socket server ~on_error:raise in + `Stop_daemon + +let () = + (* Different tests run in parallel, so the port should be unique among + tests *) + let server_port = 4243 in + let () = + Cohttp_eio.Client.set_proxies + ~default_proxy: + (Uri.of_string @@ Printf.sprintf "http://127.0.0.1:%d" server_port) + () + in + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + let () = run_proxy_server server_port env#net sw in + let client = + let noop_https_wrapper = Some (fun _ f -> f) in + Cohttp_eio.Client.make ~https:noop_https_wrapper env#net + in + let get_success uri = + let resp, _ = Cohttp_eio.Client.get ~sw client uri in + match Http.Response.status resp with + | `OK -> () + | unexpected -> + Alcotest.failf "unexpected response from test_forward_proxy server %a" + Http.Status.pp unexpected + in + + (* TESTS CASES *) + let direct_proxied_request () = + (* When the remote host is over HTTP *) + let uri = Uri.of_string "http://foo.org" in + get_success uri; + let req = Req_data.get () in + let meth = Http.Request.meth req in + Alcotest.(check' t_meth) + ~msg:"should be a GET request" ~actual:meth ~expected:`GET; + let host = + let headers = Http.Request.headers req in + Http.Header.get headers "host" + in + Alcotest.(check' (option string)) + ~msg:"should request from remote host" ~actual:host + ~expected:(Some "foo.org") + and tunnelled_proxied_request () = + (* When the remote host is over HTTPS *) + let uri = Uri.of_string "https://foo.org" in + get_success uri; + let req = Req_data.get () in + let meth = Http.Request.meth req in + Alcotest.(check' t_meth) + ~msg:"should first initiate a CONNECT request" ~actual:meth + ~expected:`CONNECT; + let host = + let headers = Http.Request.headers req in + Http.Header.get headers "host" + in + Alcotest.(check' (option string)) + ~msg:"should request from remote host (with port)" ~actual:host + ~expected:(Some "foo.org:443"); + + let req' = Req_data.get () in + let meth' = Http.Request.meth req' in + Alcotest.(check' t_meth) + ~msg:"should then send a GET request" ~actual:meth' ~expected:`GET; + let host = + let headers = Http.Request.headers req in + Http.Header.get headers "host" + in + Alcotest.(check' (option string)) + ~msg:"should request from remote host (with port)" ~actual:host + ~expected:(Some "foo.org:443") + and unset_proxy () = + let () = Cohttp_eio.Client.set_proxies ?default_proxy:None () in + (* .invalid domains are guaranteed to not have hosts: + https://www.rfc-editor.org/rfc/rfc2606 *) + let uri = Uri.of_string "http://foo.invalid" in + match Cohttp_eio.Client.get ~sw client uri with + | exception Failure _ -> + (* This should fail, since we are not using the proxy *) + () + | unexepcted_resp, _ -> + Alcotest.failf + "Resolution of uri should have failed, but succeeded with %a" + Http.Response.pp unexepcted_resp + in + Alcotest.run "cohttp-eio client" + [ + ( "cohttp-eio forward proxy", + [ + ("direct get", `Quick, direct_proxied_request); + ("tunnelled proxied request", `Quick, tunnelled_proxied_request); + ("unessting the proxy config", `Quick, unset_proxy); + ] ); + ] diff --git a/cohttp-lwt-jsoo.opam b/cohttp-lwt-jsoo.opam new file mode 100644 index 0000000..d4cff34 --- /dev/null +++ b/cohttp-lwt-jsoo.opam @@ -0,0 +1,56 @@ +version: "6.2.1" +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +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 "] +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} + "cohttp" {= version} + "cohttp-lwt" {= version} + "logs" + "lwt" {>= "5.7.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"} + "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-lwt-jsoo/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp-lwt-jsoo.opam.template b/cohttp-lwt-jsoo.opam.template new file mode 100644 index 0000000..d37c3d1 --- /dev/null +++ b/cohttp-lwt-jsoo.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp-lwt-jsoo/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml new file mode 100644 index 0000000..8f1644f --- /dev/null +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml @@ -0,0 +1,356 @@ +(*{{{ Copyright (c) 2014 Andy Ray + * Copyright (c) 2014 Anil Madhavapeddy + * + * 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 Js_of_ocaml +module C = Cohttp +module CLB = Cohttp_lwt.Body + +let ( >>= ) = Lwt.( >>= ) +let ( >|= ) = Lwt.( >|= ) + +module type Params = sig + val chunked_response : bool + val chunk_size : int + val convert_body_string : Js.js_string Js.t -> string + val with_credentials : bool +end + +let xhr_response_supported = + (* from http://stackoverflow.com/questions/8926505/how-to-feature-detect-if-xmlhttprequest-supports-responsetype-arraybuffer *) + 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 a = new%js Typed_array.uint8Array len in + for i = 0 to len - 1 do + Typed_array.set a i (Char.code str.[i]) + done; + a + +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.Private.String_io + +module IO = struct + include Cohttp_lwt.Private.String_io + + type error = | + + let catch f = Lwt.map (fun v -> Result.Ok v) @@ f () + let pp_error _ (e : error) = match e with _ -> . +end + +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" + + module Log = (val Logs.src_log src : Logs.LOG) + + (* perform the body transfer in chunks from string. *) + let chunked_body_str text = + let body_len = text##.length in + let pos = ref 0 in + let chunkerizer () = + if !pos = body_len then Lwt.return C.Transfer.Done + else if !pos + P.chunk_size >= body_len then ( + let str = text##(substring_toEnd !pos) in + pos := body_len; + Lwt.return (C.Transfer.Final_chunk (P.convert_body_string str))) + else + let str = text##(substring !pos (!pos + P.chunk_size)) in + pos := !pos + P.chunk_size; + Lwt.return (C.Transfer.Chunk (P.convert_body_string str)) + in + if body_len = 0 then CLB.empty + else CLB.of_stream (CLB.create_stream chunkerizer ()) + + (* perform the body transfer in chunks from arrayBuffer. *) + let chunked_body_binary (ab : Typed_array.arrayBuffer Js.t) = + let body_len = ab##.byteLength in + let u8a = new%js Typed_array.uint8Array_fromBuffer ab in + let pos = ref 0 in + let chunkerizer () = + if !pos = body_len then Lwt.return C.Transfer.Done + else if !pos + P.chunk_size >= body_len then ( + let str = string_of_uint8array u8a !pos (body_len - !pos) in + pos := body_len; + Lwt.return (C.Transfer.Final_chunk str)) + else + let str = string_of_uint8array u8a !pos P.chunk_size in + pos := !pos + P.chunk_size; + Lwt.return (C.Transfer.Chunk str) + in + if body_len = 0 then CLB.empty + else CLB.of_stream (CLB.create_stream chunkerizer ()) + + (* choose between chunked and direct transfer *) + let get = function + | `String js_str -> + if P.chunked_response then chunked_body_str js_str + else CLB.of_string (P.convert_body_string js_str) + | `ArrayBuffer ab -> + if P.chunked_response then chunked_body_binary ab + else + let u8a = new%js Typed_array.uint8Array_fromBuffer ab in + CLB.of_string (string_of_uint8array u8a 0 ab##.byteLength) + + let construct_body xml = + (* construct body *) + let b = + let respText () = + Js.Opt.case xml##.responseText + (fun () -> `String (Js.string "")) + (fun s -> `String s) + in + 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 "") + | true -> + Js.Opt.case + (File.CoerceTo.arrayBuffer xml##.response) + (fun () -> + Log.warn (fun m -> + m "XHR Response is not an arrayBuffer; using responseText"); + respText ()) + (fun ab -> `ArrayBuffer ab) + | false -> respText () + in + get b +end + +module Make_api (X : sig + module Request : Cohttp.S.Request + module Response : Cohttp.S.Response + + val call : + ?headers:Http.Header.t -> + ?body:Cohttp_lwt.Body.t -> + Http.Method.t -> + Uri.t -> + (Response.t * Cohttp_lwt.Body.t) Lwt.t +end) = +struct + module IO = IO + 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 + + (* The HEAD should not have a response body *) + let head ?ctx ?headers uri = + let open Lwt in + call ?ctx ?headers ~chunked:false `HEAD uri >|= fst + + let get ?ctx ?headers uri = call ?ctx ?headers ~chunked:false `GET uri + + let delete ?ctx ?body ?chunked ?headers uri = + call ?ctx ?headers ?body ?chunked `DELETE uri + + 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 post_form ?ctx ?headers ~params uri = + let headers = + C.Header.add_opt headers "content-type" + "application/x-www-form-urlencoded" + in + 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 = raise Cohttp_lwt_xhr_callv_not_implemented + + (* ??? *) +end + +module Make_client_async (P : Params) = Make_api (struct + module Response = Cohttp.Response + module Request = Cohttp.Request + module Bb = Body_builder (P) + + let call ?headers ?body meth uri = + let xml = XmlHttpRequest.create () in + xml##.withCredentials := Js.bool P.with_credentials; + 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 + (Js.string (C.Code.string_of_method meth)) + (Js.string (Uri.to_string uri)) + Js._true) + (* asynchronous call *) + in + (* set request headers *) + let () = + match headers with + | None -> () + | Some headers -> + C.Header.iter + (fun k v -> + (* some headers lead to errors in the javascript console, should + we filter then out here? *) + xml##(setRequestHeader (Js.string k) (Js.string v))) + headers + in + + xml##.onreadystatechange := + Js.wrap_callback (fun _ -> + match xml##.readyState with + | XmlHttpRequest.DONE -> ( + try + let body = Bb.construct_body xml in + (* Note; a type checker subversion seems to be possible here (4.01.0). + * Remove the type constraint on Lwt.task above and return any old + * guff here. It'll compile and crash in the browser! *) + (* (re-)construct the response *) + let resp_headers = Js.to_string xml##getAllResponseHeaders in + let channel = String_io.open_in resp_headers in + let response = + Lwt.( + Header_io.parse channel >|= fun resp_headers -> + Cohttp.Response.make ~version:`HTTP_1_1 + ~status:(C.Code.status_of_code xml##.status) + ~encoding:(CLB.transfer_encoding body) + ~headers:resp_headers ()) + in + Lwt.wakeup wake (response, body) + with + | e + (* If we exhaust the stack, it is possible that + 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 + completed promise would raise an Invalid_arg + exception, so although the promise is in a + really bad state we may as well let the actual + Stack_overflow exception go through. *) + when Lwt.state res = Lwt.Sleep + -> + Lwt.wakeup_exn wake e) + | _ -> ()); + + (* perform call *) + (match body with + | None -> Lwt.return xml##(send Js.null) + | Some body -> + CLB.to_string body >>= fun body -> + let bs = binary_string body in + (*Js.Opt.case (File.CoerceTo.blob (Obj.magic 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)))) + >>= fun () -> + Lwt.on_cancel res (fun () -> xml##abort); + (* unwrap the response *) + Lwt.( + res >>= fun (r, b) -> + r >>= fun r -> Lwt.return (r, b)) +end) + +module Make_client_sync (P : Params) = Make_api (struct + module Response = Cohttp.Response + module Request = Cohttp.Request + module Bb = Body_builder (P) + + let call ?headers ?body meth uri = + let xml = XmlHttpRequest.create () in + xml##.withCredentials := Js.bool P.with_credentials; + if Lazy.force xhr_response_supported then + xml##.responseType := Js.string "arraybuffer"; + let () = + xml##(_open + (Js.string (C.Code.string_of_method meth)) + (Js.string (Uri.to_string uri)) + Js._false) + (* synchronous call *) + in + (* set request headers *) + let () = + match headers with + | None -> () + | Some headers -> + C.Header.iter + (fun k v -> + (* some headers lead to errors in the javascript console, should + we filter then out here? *) + xml##(setRequestHeader (Js.string k) (Js.string v))) + headers + in + (* perform call *) + (match body with + | None -> Lwt.return xml##(send Js.null) + | Some body -> + CLB.to_string body >|= fun body -> + let bs = binary_string body in + xml##(send (Js.Opt.return (Obj.magic bs)))) + >>= fun _body -> + let body = Bb.construct_body xml in + (* (re-)construct the response *) + let resp_headers = Js.to_string xml##getAllResponseHeaders in + Header_io.parse (String_io.open_in resp_headers) >>= fun resp_headers -> + let response = + Response.make ~version:`HTTP_1_1 + ~status:(Cohttp.Code.status_of_code xml##.status) + ~encoding:(CLB.transfer_encoding body) + ~headers:resp_headers () + in + + Lwt.return (response, body) +end) + +module Client = Make_client_async (struct + let chunked_response = true + let chunk_size = 128 * 1024 + let convert_body_string = Js.to_bytestring + let with_credentials = false +end) + +module Client_sync = Make_client_sync (struct + let chunked_response = false + let chunk_size = 0 + let convert_body_string = Js.to_bytestring + let with_credentials = false +end) diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli new file mode 100644 index 0000000..0abfc09 --- /dev/null +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli @@ -0,0 +1,62 @@ +(*{{{ Copyright (c) 2014 Andy Ray + * Copyright (c) 2012-2013 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(** {1 HTTP client for JavaScript using XMLHttpRequest.} + + The {!Logs} source name for this module's logger is ["cohttp.lwt.jsoo"]. To + log the current warnings using the browser's console log, you can write a + custom reporter or use: + + {[ + let reporter = Logs_browser.console_reporter () in + Logs.set_reporter reporter + ]} *) + +(** Configuration parameters for the XmlHttpRequest engines *) +module type Params = sig + val chunked_response : bool + (** Should the response body data be chunked? *) + + val chunk_size : int + (** Size of chunks *) + + val convert_body_string : Js_of_ocaml.Js.js_string Js_of_ocaml.Js.t -> string + (** JavaScript string to OCaml conversion. [Js.to_bytestring] or + [Js.to_string] *) + + val with_credentials : bool + (** Whether withCredentials property of XHR is set. *) +end + +(** Build an asynchronous engine with chunked/unchucked response data treated as + raw bytes or UTF *) +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 (_ : Params) : Cohttp_lwt.S.Client + +module Client : Cohttp_lwt.S.Client +(** The [Client] module implements an HTTP client interface using asynchronous + XmlHttpRequests. The response body is returned in chucked form with 128Kb / + chunk. Body data is treated as raw bytes. withCredentials property of XHR is + set to false. *) + +module Client_sync : Cohttp_lwt.S.Client +(** The [Client_sync] module implements an HTTP client interface using + synchronous XmlHttpRequests. The response is not chunked and treated as raw + bytes. withCredentials property of XHR is set to false. *) diff --git a/cohttp-lwt-jsoo/src/dune b/cohttp-lwt-jsoo/src/dune new file mode 100644 index 0000000..18a372c --- /dev/null +++ b/cohttp-lwt-jsoo/src/dune @@ -0,0 +1,7 @@ +(library + (name cohttp_lwt_jsoo) + (public_name cohttp-lwt-jsoo) + (synopsis "XHR/Lwt based http client") + (preprocess + (pps js_of_ocaml-ppx)) + (libraries js_of_ocaml cohttp-lwt logs)) diff --git a/cohttp-lwt-jsoo/test/package.json b/cohttp-lwt-jsoo/test/package.json new file mode 100644 index 0000000..c830db5 --- /dev/null +++ b/cohttp-lwt-jsoo/test/package.json @@ -0,0 +1,6 @@ +{ + "license": "ISC", + "dependencies": { + "xmlhttprequest": "1.8.0" + } +} diff --git a/cohttp-lwt-jsoo/test/src/cohttp_lwt_jsoo_test.ml b/cohttp-lwt-jsoo/test/src/cohttp_lwt_jsoo_test.ml new file mode 100644 index 0000000..e99b72a --- /dev/null +++ b/cohttp-lwt-jsoo/test/src/cohttp_lwt_jsoo_test.ml @@ -0,0 +1,34 @@ +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) diff --git a/cohttp-lwt-jsoo/test/src/dune b/cohttp-lwt-jsoo/test/src/dune new file mode 100644 index 0000000..fed9b39 --- /dev/null +++ b/cohttp-lwt-jsoo/test/src/dune @@ -0,0 +1,15 @@ +(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)))) diff --git a/cohttp-lwt-jsoo/test/src/test.js b/cohttp-lwt-jsoo/test/src/test.js new file mode 100755 index 0000000..a5f1627 --- /dev/null +++ b/cohttp-lwt-jsoo/test/src/test.js @@ -0,0 +1,23 @@ +#!/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(); diff --git a/cohttp-lwt-jsoo/test/yarn.lock b/cohttp-lwt-jsoo/test/yarn.lock new file mode 100644 index 0000000..ce60ce4 --- /dev/null +++ b/cohttp-lwt-jsoo/test/yarn.lock @@ -0,0 +1,8 @@ +# 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= diff --git a/cohttp-lwt-unix.opam b/cohttp-lwt-unix.opam new file mode 100644 index 0000000..ab53b2c --- /dev/null +++ b/cohttp-lwt-unix.opam @@ -0,0 +1,63 @@ +version: "6.2.1" +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "CoHTTP implementation for Unix and Windows using Lwt" +description: """ +An implementation of an HTTP client and server using the Lwt +concurrency library. See the `Cohttp_lwt_unix` module for information +on how to use this. The package also installs `cohttp-curl-lwt` +and a `cohttp-server-lwt` binaries for quick uses of a HTTP(S) +client and server respectively. + +Although the name implies that this only works under Unix, it +should also be fine under Windows too. +""" +maintainer: ["Anil Madhavapeddy "] +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} + "cohttp" {= version} + "cohttp-lwt" {= version} + "cmdliner" {>= "2.0.0"} + "lwt" {>= "3.0.0"} + "conduit-lwt" {>= "7.1.0"} + "conduit-lwt-unix" {>= "7.1.0"} + "fmt" {>= "0.8.2"} + "base-unix" + "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 + "@install" + "@cohttp-lwt-unix/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp-lwt-unix.opam.template b/cohttp-lwt-unix.opam.template new file mode 100644 index 0000000..8b5d336 --- /dev/null +++ b/cohttp-lwt-unix.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp-lwt-unix/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp-lwt-unix/bin/cohttp_curl_lwt.ml b/cohttp-lwt-unix/bin/cohttp_curl_lwt.ml new file mode 100644 index 0000000..7bfcbf0 --- /dev/null +++ b/cohttp-lwt-unix/bin/cohttp_curl_lwt.ml @@ -0,0 +1,112 @@ +(*{{{ Copyright (c) 2014 Hannes Mehnert + * Copyright (c) 2014 Anil Madhavapeddy + * + * 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 +open Cohttp +open Cohttp_lwt_unix + +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'); + Client.call meth uri >>= fun (resp, body) -> + let status = Response.status resp in + Log.debug (fun d -> + d "Client %s returned: %s" meth' (Code.string_of_status status)); + (* TODO follow redirects *) + match Code.is_success (Code.code_of_status status) with + | false -> + prerr_endline (Code.string_of_status status); + exit 1 + | true -> ( + Cohttp_lwt.Body.length body >>= fun (len, body) -> + Log.debug (fun d -> d "Client body length: %Ld" len); + Cohttp_lwt.Body.to_string body >>= fun _s -> + let output_body c = + Lwt_stream.iter_s (Lwt_io.fprint c) (Cohttp_lwt.Body.to_stream 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 run_client level ofile uri meth = + if not @@ Debug.debug_active () then ( + Fmt_tty.setup_std_outputs (); + Logs.set_level ~all:true level; + Logs.set_reporter Debug.default_reporter); + Lwt_main.run (client uri ofile meth) + +open Cmdliner + +let uri = + let loc = + let parser s = + match Uri.of_string s with + | uri -> Ok uri + | exception Failure _ -> Error "unable to parse URI" + in + let pp ppf u = Format.fprintf ppf "%s" (Uri.to_string u) in + Cmdliner.Arg.Conv.make ~parser ~pp ~docv:"URI" () + 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 , or \ + on the issue tracker at \ + "; + `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 diff --git a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml new file mode 100644 index 0000000..d088075 --- /dev/null +++ b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml @@ -0,0 +1,121 @@ +(*{{{ Copyright (c) 2014-2015 Anil Madhavapeddy + * Copyright (c) 2014 Romain Calascibetta + * Copyright (c) 2014 David Sheets + * + * 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 Printf +open Lwt +open Cohttp +open Cohttp_lwt_unix + +let handler ~verbose _ req body = + let uri = Cohttp.Request.uri req in + (* Log the request to the console *) + if verbose then + eprintf "--> %s %s %s\n%!" + Cohttp.(Code.string_of_method (Request.meth req)) + (Uri.to_string uri) + (Sexplib0.Sexp.to_string_hum (Request.sexp_of_t req)); + (* Strip out hop-by-hop connection headers *) + let headers = + Request.headers req |> fun h -> + Header.remove h "accept-encoding" |> fun h -> + Header.remove h "content-length" |> fun h -> + Header.remove h "transfer-encoding" |> fun h -> + Header.remove h "connection" |> fun h -> + Header.add h "accept-encoding" "identity" + in + (* Fetch the remote URI *) + let meth = Request.meth req in + Client.call ~headers ~body meth uri >>= fun (resp, body) -> + if verbose then + eprintf "<-- %s %s\n%!" + (Uri.to_string (Request.uri req)) + (Sexplib0.Sexp.to_string_hum (Response.sexp_of_t resp)); + let status = Response.status resp in + let headers = + Response.headers resp |> fun h -> + Header.remove h "transfer-encoding" |> fun h -> + Header.remove h "content-length" |> fun h -> Header.remove h "connection" + in + Server.respond ~headers ~status ~body () + +let start_proxy port host verbose cert key () = + printf "Listening for HTTP request on: %s %d\n%!" host port; + let conn_closed (ch, _conn) = + printf "Connection %s closed\n%!" + (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch)) + in + let callback = handler ~verbose in + let config = Server.make ~callback ~conn_closed () in + let mode = + match (cert, key) with + | Some c, Some k -> + `TLS (`Crt_file_path c, `Key_file_path k, `No_password, `Port port) + | _ -> `TCP (`Port port) + in + Server.create ~mode config + +let lwt_start_proxy port host level cert key = + if not @@ Debug.debug_active () then ( + Fmt_tty.setup_std_outputs (); + Logs.set_level ~all:true level; + Logs.set_reporter Debug.default_reporter); + Lwt_main.run (start_proxy port host (level <> None) cert key ()) + +open Cmdliner + +let host = + let doc = "IP address to listen on." in + Arg.(value & opt string "0.0.0.0" & info [ "s" ] ~docv:"HOST" ~doc) + +let port = + let doc = "TCP port to listen on." in + Arg.(value & opt int 8080 & info [ "p" ] ~docv:"PORT" ~doc) + +let verb = Logs_cli.level () + +let ssl_cert = + let doc = "SSL certificate file." in + Arg.(value & opt (some string) None & info [ "c" ] ~docv:"SSL_CERT" ~doc) + +let ssl_key = + let doc = "SSL key file." in + Arg.(value & opt (some string) None & info [ "k" ] ~docv:"SSL_KEY" ~doc) + +let cmd = + let info = + let version = Cohttp.Conf.version in + let doc = "a simple http proxy" in + let man = + [ + `S "DESCRIPTION"; + `P "$(tname) sets up a simple http proxy with lwt as backend"; + `S "BUGS"; + `P + "Report them via e-mail to , or \ + on the issue tracker at \ + "; + ] + in + Cmd.info "cohttp-proxy" ~version ~doc ~man + in + let term = + Term.(const lwt_start_proxy $ port $ host $ verb $ ssl_cert $ ssl_key) + in + Cmd.v info term + +let () = exit @@ Cmd.eval cmd diff --git a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml new file mode 100644 index 0000000..72cadaf --- /dev/null +++ b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml @@ -0,0 +1,187 @@ +(*{{{ Copyright (c) 2014 Romain Calascibetta + * Copyright (c) 2014 Anil Madhavapeddy + * Copyright (c) 2014 David Sheets + * + * 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.Infix +open Cohttp_lwt_unix +open Cohttp_server + +let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server" + +module Log = (val Logs.src_log src : Logs.LOG) + +let method_filter meth (res, body) = + match meth with + | `HEAD -> Lwt.return (res, `Empty) + | _ -> Lwt.return (res, body) + +let serve_file ~docroot ~uri = + let fname = Cohttp.Path.resolve_local_file ~docroot ~uri in + Server.respond_file ~fname () + +let ls_dir dir = + Lwt_stream.to_list + (Lwt_stream.filter (( <> ) ".") (Lwt_unix.files_of_directory dir)) + +let serve ~info ~docroot ~index uri path = + let file_name = Cohttp.Path.resolve_local_file ~docroot ~uri in + Lwt.catch + (fun () -> + Lwt_unix.stat file_name >>= fun stat -> + match kind_of_unix_kind stat.Unix.st_kind with + | `Directory -> ( + let path_len = String.length path in + if path_len <> 0 && path.[path_len - 1] <> '/' then + Server.respond_redirect ~uri:(Uri.with_path uri (path ^ "/")) () + else + match Sys.file_exists (file_name / index) with + | true -> + let uri = Uri.with_path uri (path / index) in + serve_file ~docroot ~uri + | false -> + ls_dir file_name + >>= Lwt_list.map_s (fun f -> + let file_name = file_name / f in + Lwt.try_bind + (fun () -> Lwt_unix.LargeFile.stat file_name) + (fun stat -> + Lwt.return + ( Some + (kind_of_unix_kind stat.Unix.LargeFile.st_kind), + stat.Unix.LargeFile.st_size, + f )) + (fun _exn -> Lwt.return (None, 0L, f))) + >>= fun listing -> + let body = html_of_listing uri path (sort listing) info in + Server.respond_string ~status:`OK ~body ()) + | `File -> serve_file ~docroot ~uri + | _ -> + Server.respond_string ~status:`Forbidden + ~body:(html_of_forbidden_unnormal path info) + ()) + (function + | Unix.Unix_error (Unix.ENOENT, "stat", p) as e -> + if p = file_name then + Server.respond_string ~status:`Not_found + ~body:(html_of_not_found path info) + () + else Lwt.reraise e + | e -> Lwt.reraise e) + +let handler ~info ~docroot ~index (ch, _conn) req _body = + let uri = Cohttp.Request.uri req in + let path = Uri.path uri in + (* Log the request to the console *) + Log.debug (fun m -> + m "%s %s %s" + Cohttp.(Code.string_of_method (Request.meth req)) + path + (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))); + (* Get a canonical filename from the URL and docroot *) + match 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 allowed = [ "GET"; "HEAD" ] in + let headers = Cohttp.Header.(add_multi (init ()) "allow" allowed) in + Server.respond_string ~headers ~status:`Method_not_allowed + ~body: + (html_of_method_not_allowed meth + (String.concat "," allowed) + path info) + () + +let start_server docroot port host index tls () = + Log.info (fun m -> m "Listening for HTTP request on: %s %d" host port); + let info = + Printf.sprintf "Served by Cohttp/Lwt listening on %s:%d" host port + in + let conn_closed (ch, _conn) = + Log.debug (fun m -> + m "connection %s closed" + (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))) + in + let callback = handler ~info ~docroot ~index in + let config = Server.make ~callback ~conn_closed () in + let mode = + match tls with + | Some (c, k) -> + `TLS (`Crt_file_path c, `Key_file_path k, `No_password, `Port port) + | None -> `TCP (`Port port) + in + Conduit_lwt_unix.init ~src:host () >>= fun ctx -> + let ctx = Cohttp_lwt_unix.Net.init ~ctx () in + Server.create ~ctx ~mode config + +let lwt_start_server docroot port host index level tls = + if not @@ Debug.debug_active () then ( + Fmt_tty.setup_std_outputs (); + Logs.set_level ~all:true level; + Logs.set_reporter Debug.default_reporter); + Lwt_main.run (start_server docroot port host index tls ()) + +open Cmdliner + +let host = + let doc = "IP address to listen on." in + Arg.(value & opt string "::" & info [ "s" ] ~docv:"HOST" ~doc) + +let port = + let doc = "TCP port to listen on." in + Arg.(value & opt int 8080 & info [ "p" ] ~docv:"PORT" ~doc) + +let index = + let doc = "Name of index file in directory." in + Arg.(value & opt string "index.html" & info [ "i" ] ~docv:"INDEX" ~doc) + +let verb = Logs_cli.level () + +let tls = + let doc = "TLS certificate files." in + Arg.( + value + & opt (some (pair string string)) None + & info [ "tls" ] ~docv:"CERT,KEY" ~doc) + +let doc_root = + let doc = "Serving directory." in + Arg.(value & pos 0 dir "." & info [] ~docv:"DOCROOT" ~doc) + +let cmd = + let info = + let version = Cohttp.Conf.version in + let doc = "a simple http server" in + let man = + [ + `S "DESCRIPTION"; + `P "$(tname) sets up a simple http server with lwt as backend"; + `S "BUGS"; + `P + "Report them via e-mail to , or \ + on the issue tracker at \ + "; + ] + in + Cmd.info "cohttp-server" ~version ~doc ~man + in + let term = + Term.(const lwt_start_server $ doc_root $ port $ host $ index $ verb $ tls) + in + Cmd.v info term + +let () = exit @@ Cmd.eval cmd diff --git a/cohttp-lwt-unix/bin/dune b/cohttp-lwt-unix/bin/dune new file mode 100644 index 0000000..a80d747 --- /dev/null +++ b/cohttp-lwt-unix/bin/dune @@ -0,0 +1,12 @@ +(executables + (names cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt) + (libraries + cohttp-lwt-unix + cohttp_server + logs + logs.lwt + logs.fmt + logs.cli + cmdliner + conduit-lwt + fmt.tty)) diff --git a/cohttp-lwt-unix/examples/client_lwt.ml b/cohttp-lwt-unix/examples/client_lwt.ml new file mode 100644 index 0000000..cbc8bb5 --- /dev/null +++ b/cohttp-lwt-unix/examples/client_lwt.ml @@ -0,0 +1,16 @@ +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) diff --git a/cohttp-lwt-unix/examples/client_lwt_proxy.ml b/cohttp-lwt-unix/examples/client_lwt_proxy.ml new file mode 100644 index 0000000..0293003 --- /dev/null +++ b/cohttp-lwt-unix/examples/client_lwt_proxy.ml @@ -0,0 +1,145 @@ +open Lwt +open Cohttp +open Cohttp_lwt_unix + +let () = + if not @@ Debug.debug_active () then ( + Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true (); + Logs.set_level ~all:true (Some Logs.Debug); + Logs.set_reporter Debug.default_reporter) + +let proxy_uri = ref None +let uri = ref [] +let proxy_authorization = ref None +let set_proxy_uri uri = proxy_uri := Some (Uri.of_string uri) + +let set_proxy_authorization auth = + proxy_authorization := + Some (Cohttp.Auth.credential_of_string ("Basic " ^ Base64.encode_exn auth)) + +let usage_msg = + {|Usage: test_client_proxy -proxy +Examples: +$ test_client_proxy -proxy http://localhost:8080 http://example.com +$ test_client_proxy -proxy https://localhost:8080 https://example.com +Options:|} + +let anon_fun args = uri := !uri @ [ args ] + +let speclist = + [ + ("-proxy", Arg.String set_proxy_uri, " Proxy uri"); + ("-proxyauth", Arg.String set_proxy_authorization, " Proxy authorization"); + ] + +(* Boilerplate code to handle redirects *) + +let rec http_get_and_follow ~max_redirects ?headers uri = + let open Lwt.Syntax in + let* ans = Cohttp_lwt_unix.Client.get ?headers uri in + follow_redirect ~max_redirects ?headers uri ans + +and follow_redirect ~max_redirects ?headers request_uri (response, body) = + let open Lwt.Syntax 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 + in + match status with + | `OK -> Lwt.return (response, body) + | `Permanent_redirect | `Moved_permanently -> + handle_redirect ~permanent:true ~max_redirects ?headers request_uri + response + | `Found | `Temporary_redirect -> + handle_redirect ~permanent:false ~max_redirects ?headers request_uri + response + | `Not_found | `Gone -> failwith "Not found" + | status -> + Printf.ksprintf failwith "Unhandled status: %s" + (Cohttp.Code.string_of_status status) + +and handle_redirect ~permanent ~max_redirects ?headers request_uri response = + if max_redirects <= 0 then failwith "Too many redirects" + else + let headers' = Http.Response.headers response in + let location = Http.Header.get headers' "location" in + match location with + | 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_lwt.warn (fun m -> + m "Permanent redirection from %s to %s" + (Uri.to_string request_uri) + url) + else Lwt.return_unit + in + http_get_and_follow ?headers uri ~max_redirects:(max_redirects - 1) + +(* Interesting stuff *) + +let getenv_opt k = + match Sys.getenv_opt k with + | Some v -> Some (k, Uri.of_string v) + | None -> None + +let getenv_opt_case k = + match getenv_opt (String.lowercase_ascii k) with + | None -> getenv_opt (String.uppercase_ascii k) + | v -> v + +let main ~proxy ~uri ~credential () = + let all_proxy, no_proxy, scheme_proxy = + match proxy with + | None -> + ( Option.map Uri.of_string (Sys.getenv_opt "ALL_PROXY"), + Sys.getenv_opt "NO_PROXY", + [ + getenv_opt_case "httpunix_proxy"; + getenv_opt_case "https_proxy"; + getenv_opt "http_proxy"; + ] + |> List.filter_map (function + | Some (k, v) -> Some (String.(sub k 0 (rindex k '_')), v) + | n -> n) ) + | v -> (v, None, []) + in + + let proxy_headers = + Option.map + (fun credential -> + Http.Header.init_with "Proxy-Authorization" + (Cohttp.Auth.string_of_credential credential)) + credential + in + + let module Cache = Cohttp_lwt_unix.Connection_proxy in + let cache = + Cache.create ?all_proxy ~scheme_proxy ?no_proxy ?proxy_headers () + in + Client.set_cache (Cache.call cache); + + http_get_and_follow ~max_redirects:2 (Uri.of_string uri) + >>= 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); + print_endline ("Received body\n" ^ body) + +(* Argument parsing *) + +let () = + Arg.parse speclist anon_fun usage_msg; + if List.length !uri <> 1 then ( + prerr_endline "Expected a single resource uri."; + prerr_endline usage_msg; + exit 1); + let proxy = !proxy_uri + and uri = List.hd !uri + and credential = !proxy_authorization in + Lwt_main.run (main ~proxy ~uri ~credential ()) diff --git a/cohttp-lwt-unix/examples/client_lwt_timeout.ml b/cohttp-lwt-unix/examples/client_lwt_timeout.ml new file mode 100644 index 0000000..6c953f5 --- /dev/null +++ b/cohttp-lwt-unix/examples/client_lwt_timeout.ml @@ -0,0 +1,26 @@ +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) diff --git a/cohttp-lwt-unix/examples/docker_lwt.ml b/cohttp-lwt-unix/examples/docker_lwt.ml new file mode 100644 index 0000000..0608cc4 --- /dev/null +++ b/cohttp-lwt-unix/examples/docker_lwt.ml @@ -0,0 +1,22 @@ +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 diff --git a/cohttp-lwt-unix/examples/dune b/cohttp-lwt-unix/examples/dune new file mode 100644 index 0000000..b596cd6 --- /dev/null +++ b/cohttp-lwt-unix/examples/dune @@ -0,0 +1,13 @@ +(executables + (names client_lwt client_lwt_timeout docker_lwt server_lwt client_lwt_proxy) + (libraries cohttp-lwt-unix fmt.tty)) + +(alias + (name runtest) + (package cohttp-lwt-unix) + (deps + client_lwt.exe + client_lwt_timeout.exe + docker_lwt.exe + server_lwt.exe + client_lwt_proxy.exe)) diff --git a/cohttp-lwt-unix/examples/server_lwt.ml b/cohttp-lwt-unix/examples/server_lwt.ml new file mode 100644 index 0000000..60b30f3 --- /dev/null +++ b/cohttp-lwt-unix/examples/server_lwt.ml @@ -0,0 +1,17 @@ +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) diff --git a/cohttp-lwt-unix/src/cohttp_lwt_unix.ml b/cohttp-lwt-unix/src/cohttp_lwt_unix.ml new file mode 100644 index 0000000..db82391 --- /dev/null +++ b/cohttp-lwt-unix/src/cohttp_lwt_unix.ml @@ -0,0 +1,77 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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 Request = struct + include Cohttp.Request + + include ( + Private.Make (Io) : module type of Private.Make (Io) with type t := t) + end + +module Response = struct + include Cohttp.Response + + include ( + Private.Make (Io) : module type of Private.Make (Io) with type t := t) + end + +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 Connection_proxy = + Cohttp_lwt.Connection_cache.Make_proxy + (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 [@@deprecated "This module is not for public consumption"] + +module Private = struct + module Input_channel = Input_channel + module IO = Io +end diff --git a/cohttp-lwt-unix/src/debug.ml b/cohttp-lwt-unix/src/debug.ml new file mode 100644 index 0000000..fd2152a --- /dev/null +++ b/cohttp-lwt-unix/src/debug.ml @@ -0,0 +1,87 @@ +(*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy + * + * 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. + * + }}}*) + +let _debug_active = ref false +let debug_active () = !_debug_active + +open Lwt.Infix + +let reporter file_descr ppf = + let ppf, flush = + let buf = Buffer.create 0x100 in + ( Fmt.with_buffer ~like:ppf buf, + fun () -> + let str = Buffer.contents buf in + Buffer.reset buf; + str ) + in + let report src level ~over k msgf = + let k _ = + let write () = + let buf = Bytes.unsafe_of_string (flush ()) in + let rec go off len = + Lwt_unix.write file_descr buf off len >>= fun len' -> + if len' = len then Lwt.return_unit else go (off + len') (len - len') + in + go 0 (Bytes.length buf) + in + let clean () = + over (); + Lwt.return_unit + in + Lwt.async (fun () -> + Lwt.catch + (fun () -> Lwt.finalize write clean) + (fun exn -> + Logs.warn (fun m -> + m "Flushing error: %s." (Printexc.to_string exn)); + Lwt.return_unit)); + k () + in + let with_metadata header _tags k ppf fmt = + Format.kfprintf k ppf + ("%a[%a]: " ^^ fmt ^^ "\n%!") + Logs_fmt.pp_header (level, header) + Fmt.(styled `Magenta string) + (Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt + in + { Logs.report } + +let default_reporter = reporter Lwt_unix.stderr Fmt.stderr + +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) + +let activate_debug () = + if not !_debug_active then ( + _debug_active := true; + Lazy.force set_logger; + Logs.set_level ~all:true (Some Logs.Debug); + Logs.debug (fun f -> f "Cohttp debugging output is active")) + +let () = + try + match Sys.getenv "COHTTP_DEBUG" with + | "false" | "0" -> () + | _ -> activate_debug () + with Not_found -> () diff --git a/cohttp-lwt-unix/src/debug.mli b/cohttp-lwt-unix/src/debug.mli new file mode 100644 index 0000000..d14e712 --- /dev/null +++ b/cohttp-lwt-unix/src/debug.mli @@ -0,0 +1,52 @@ +(*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(** Debugging output for Cohttp Unix *) + +val default_reporter : Logs.reporter +(** [default_reporter] provides a simple reporter that sends the logging output + to stderr. For example, the code below enables logging at level [level] to + stderr, using coloured output if possible. + + {[ + Fmt_tty.setup_std_outputs (); + Logs.set_level ~all:true (Some level); + Logs.set_reporter Debug.default_reporter + ]} *) + +val activate_debug : unit -> unit +(** [activate_debug] enables debugging output that will be sent to standard + error. *) + +val debug_active : unit -> bool +(** [debug_active] returns true if [activate_debug] has been called and false + otherwise *) + +(** {2 Selectively disable cohttp logging} *) + +(** It is possible to selectively disable cohttp internal logginb by filtering + over the various modules logs names as follows. + + {[ + (* Set log level v for all loggers, this does also affect cohttp internal loggers *) + Logs.set_level ~all:true level; + (* Disable all cohttp-lwt and cohttp-lwt-unix logs *) + List.iter (fun src -> + match Logs.Src.name src with + | "cohttp.lwt.io" | "cohttp.lwt.server" -> Logs.Src.set_level src None + | _ -> ()) + @@ Logs.Src.list () + ]} *) diff --git a/cohttp-lwt-unix/src/dune b/cohttp-lwt-unix/src/dune new file mode 100644 index 0000000..67b837e --- /dev/null +++ b/cohttp-lwt-unix/src/dune @@ -0,0 +1,18 @@ +(library + (name cohttp_lwt_unix) + (public_name cohttp-lwt-unix) + (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 + http + cohttp + cohttp-lwt + logs.fmt)) diff --git a/cohttp-lwt-unix/src/input_channel.ml b/cohttp-lwt-unix/src/input_channel.ml new file mode 100644 index 0000000..131cefb --- /dev/null +++ b/cohttp-lwt-unix/src/input_channel.ml @@ -0,0 +1,25 @@ +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 diff --git a/cohttp-lwt-unix/src/io.ml b/cohttp-lwt-unix/src/io.ml new file mode 100644 index 0000000..0fd496d --- /dev/null +++ b/cohttp-lwt-unix/src/io.ml @@ -0,0 +1,85 @@ +(*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy + * + * 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. + * + }}}*) + +exception IO_error of exn + +let () = + Printexc.register_printer (function + | IO_error e -> Some ("IO error: " ^ Printexc.to_string e) + | _ -> None); + if Sys.os_type <> "Win32" then Sys.(set_signal sigpipe Signal_ignore) + +type 'a t = 'a Lwt.t + +let ( >>= ) = Lwt.bind +let return = Lwt.return + +type ic = Input_channel.t +type oc = Lwt_io.output_channel +type conn = Conduit_lwt_unix.flow + +let src = Logs.Src.create "cohttp.lwt.io" ~doc:"Cohttp Lwt IO module" + +module Log = (val Logs.src_log src : Logs.LOG) + +let wrap_read f ~if_closed = + (* TODO Use [Lwt_io.is_closed] when available: + https://github.com/ocsigen/lwt/pull/635 *) + Lwt.catch f (function + | Lwt_io.Channel_closed _ -> Lwt.return if_closed + | 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 -> raise (IO_error e) + | exn -> raise exn) + +let read_line ic = + wrap_read ~if_closed:None (fun () -> + Input_channel.read_line_opt ic >>= function + | None -> + Log.debug (fun f -> f "<<< EOF"); + Lwt.return_none + | Some l as x -> + Log.debug (fun f -> f "<<< %s" l); + Lwt.return x) + +let read ic count = + let count = min count Sys.max_string_length in + wrap_read ~if_closed:"" (fun () -> + 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)); + Lwt_io.write oc buf + +let flush oc = wrap_write @@ fun () -> Lwt_io.flush oc + +type error = exn + +let catch f = + Lwt.try_bind f Lwt.return_ok (function + | IO_error e -> Lwt.return_error e + | ex -> Lwt.reraise ex) + +let pp_error = Fmt.exn diff --git a/cohttp-lwt-unix/src/io.mli b/cohttp-lwt-unix/src/io.mli new file mode 100644 index 0000000..2638ffe --- /dev/null +++ b/cohttp-lwt-unix/src/io.mli @@ -0,0 +1,27 @@ +(*{{{ Copyright (c) 2013 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(** The [Io] module contains the IO implementation for [cohttp-lwt-unix]. + + The {!Logs} source name for this module logger is ["cohttp.lwt.io"]. Refer + to the {!Debug} module for further details.*) + +include + Cohttp_lwt.S.IO + with type ic = Input_channel.t + and type oc = Lwt_io.output_channel + and type conn = Conduit_lwt_unix.flow + and type error = exn diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml new file mode 100644 index 0000000..6a49c8e --- /dev/null +++ b/cohttp-lwt-unix/src/net.ml @@ -0,0 +1,71 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(* Miscellaneous net-helpers used by Cohttp. Ideally, these will disappear + * into some connection-management framework such as andrenth/release *) + +open Lwt.Infix +module IO = Io + +type ctx = { ctx : Conduit_lwt_unix.ctx; resolver : Resolver_lwt.t } +[@@deriving sexp_of] + +let init ?(ctx = Lazy.force Conduit_lwt_unix.default_ctx) + ?(resolver = Resolver_lwt_unix.system) () = + { ctx; resolver } + +let default_ctx = + lazy + { + resolver = Resolver_lwt_unix.system; + ctx = Lazy.force Conduit_lwt_unix.default_ctx; + } + +type endp = Conduit.endp +type client = Conduit_lwt_unix.client + +let resolve ~ctx uri = Resolver_lwt.resolve_uri ~uri ctx.resolver + +let tunnel hostname (channels : IO.ic * IO.oc) : client = + `TLS_tunnel (`Hostname hostname, (fst channels).chan, snd channels) + +let connect_client ~ctx:{ ctx; _ } client = + Conduit_lwt_unix.connect ~ctx client >|= fun (flow, ic, oc) -> + let ic = Input_channel.create ic in + (flow, ic, oc) + +let connect_endp ~ctx endp = + Conduit_lwt_unix.endp_to_client ~ctx:ctx.ctx endp >>= connect_client ~ctx + +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 -> + Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e)); + Lwt.return_unit) + +let close_in ic = Lwt.ignore_result (close ic) +let close_out oc = Lwt.ignore_result (close_oc oc) +let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close_oc oc) diff --git a/cohttp-lwt-unix/src/net.mli b/cohttp-lwt-unix/src/net.mli new file mode 100644 index 0000000..42c09fd --- /dev/null +++ b/cohttp-lwt-unix/src/net.mli @@ -0,0 +1,35 @@ +(*{{{ Copyright (c) 2015 David Sheets + * + * 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. + * + }}}*) + +(** Basic satisfaction of {!Cohttp_lwt.Net} *) + +type ctx = { ctx : Conduit_lwt_unix.ctx; resolver : Resolver_lwt.t } +[@@deriving sexp_of] + +include + Cohttp_lwt.S.Net + with module IO = Io + and type ctx := ctx + and type endp = Conduit.endp + and type client = Conduit_lwt_unix.client + +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 + {!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.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). *) diff --git a/cohttp-lwt-unix/src/server.ml b/cohttp-lwt-unix/src/server.ml new file mode 100644 index 0000000..6aa5ccd --- /dev/null +++ b/cohttp-lwt-unix/src/server.ml @@ -0,0 +1,72 @@ +module Server_core = Cohttp_lwt.Make_server (Io) +include Server_core +open Lwt.Infix + +let src = + Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt Unix server module" + +module Log = (val Logs.src_log src : Logs.LOG) + +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 isn't a directory first *) + ( fname |> Lwt_unix.stat >>= fun s -> + 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 = Http.Transfer.Fixed len in + let stream = + Lwt_stream.from (fun () -> + Lwt.catch + (fun () -> + Lwt_io.read ~count ic >|= function + | "" -> None + | buf -> Some buf) + (fun exn -> + Log.warn (fun m -> + m "Error resolving file %s (%s)" fname + (Printexc.to_string exn)); + Lwt.return_none)) + in + Lwt.on_success (Lwt_stream.closed stream) (fun () -> + Lwt.ignore_result + @@ Lwt.catch + (fun () -> Lwt_io.close ic) + (fun e -> + Log.warn (fun f -> + f "Closing channel failed: %s" (Printexc.to_string e)); + Lwt.return_unit)); + let body = Cohttp_lwt.Body.of_stream stream in + let mime_type = Magic_mime.lookup fname in + let headers = + 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.reraise exn) + +let log_on_exn = function + | Unix.Unix_error (error, func, arg) -> + Log.warn (fun m -> + m "Client connection error %s: %s(%S)" (Unix.error_message 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 = Lazy.force Net.default_ctx) ?(mode = `TCP (`Port 8080)) spec = + Conduit_lwt_unix.serve ?backlog ?timeout ?stop ~on_exn ~ctx:ctx.Net.ctx ~mode + (fun flow ic oc -> + let ic = Input_channel.create ic in + callback spec flow ic oc) diff --git a/cohttp-lwt-unix/src/server.mli b/cohttp-lwt-unix/src/server.mli new file mode 100644 index 0000000..e3643e5 --- /dev/null +++ b/cohttp-lwt-unix/src/server.mli @@ -0,0 +1,47 @@ +(** The [Server] module implements the full UNIX HTTP server interface, + including the UNIX-specific functions defined in {!S}. + + The {!Logs} source name for this module logger is ["cohttp.lwt.server"]. + Refer to the {!Debug} module for further details. *) + +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. "] + +val respond_file : + ?headers:Http.Header.t -> + fname:string -> + unit -> + (Http.Response.t * Cohttp_lwt.Body.t) Lwt.t + +val create : + ?timeout:int -> + ?backlog:int -> + ?stop:unit Lwt.t -> + ?on_exn:(exn -> unit) -> + ?ctx:Net.ctx -> + ?mode:Conduit_lwt_unix.server -> + t -> + unit Lwt.t +(** [create ?timeout ?backlog ?stop ?on_exn ?mode t] is a new HTTP server. + + The user can decide to start a simple HTTP server (without encryption) or + one with TLS encryption. It depends on what the user gives as [mode] and how + [conduit-unix] is configured. + + To create a simple HTTP server listening on port 8089: + + {[ + let run = create (`TCP 8080) + ]} + + When provided, the [stop] thread will terminate the server if it ever + becomes determined. + + When provided, [backlog] will limit the number of open connections. + + Every connection will be served in a new lightweight thread that is invoked + via the callback defined in [t]. If the callback raises an exception, it is + passed to [on_exn] (by default, to a function that logs the exception using + the {!Logs} library). *) diff --git a/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml b/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml new file mode 100644 index 0000000..d399ea1 --- /dev/null +++ b/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml @@ -0,0 +1,71 @@ +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 diff --git a/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.mli b/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.mli new file mode 100644 index 0000000..cd683e1 --- /dev/null +++ b/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.mli @@ -0,0 +1,6 @@ +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 diff --git a/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/dune b/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/dune new file mode 100644 index 0000000..1314886 --- /dev/null +++ b/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/dune @@ -0,0 +1,3 @@ +(library + (name cohttp_lwt_unix_test) + (libraries conduit-lwt cohttp-lwt-unix cohttp_test ounit2)) diff --git a/cohttp-lwt-unix/test/dune b/cohttp-lwt-unix/test/dune new file mode 100644 index 0000000..529a652 --- /dev/null +++ b/cohttp-lwt-unix/test/dune @@ -0,0 +1,54 @@ +(executable + (name test_parser) + (modules test_parser) + (libraries cohttp-lwt-unix ounit2 lwt.unix)) + +(rule + (alias runtest) + (package cohttp-lwt-unix) + (action + (run ./test_parser.exe))) + +(executable + (modules test_sanity) + (name test_sanity) + (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) + +(executable + (modules test_sanity_noisy) + (name test_sanity_noisy) + (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) + +(rule + (alias runtest) + (package cohttp-lwt-unix) + (action + (run ./test_sanity.exe))) + +(rule + (alias runtest) + (package cohttp-lwt-unix) + (action + (run ./test_sanity_noisy.exe))) + +(executable + (modules test_body) + (name test_body) + (libraries cohttp_lwt_unix_test cohttp-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))) diff --git a/cohttp-lwt-unix/test/test_body.ml b/cohttp-lwt-unix/test/test_body.ml new file mode 100644 index 0000000..7a51ed2 --- /dev/null +++ b/cohttp-lwt-unix/test/test_body.ml @@ -0,0 +1,48 @@ +open Lwt +open Lwt.Infix +open OUnit +module Body = Cohttp_lwt.Body + +let run_test f = + Lwt.try_bind f (fun () -> return `Ok) (fun exn -> return (`Exn exn)) + +let test_empty_body () = + Body.is_empty (`Stream (Lwt_stream.of_list [])) >|= fun res -> + assert_equal true res + +let test_non_empty_stream () = + Body.is_empty (`Stream (Lwt_stream.of_list [ "foo"; "bar" ])) >|= fun res -> + assert_equal false res + +let test_stream_with_leading_empty_strings () = + let s = Lwt_stream.of_list [ ""; ""; "foo"; ""; "bar" ] in + Body.is_empty (`Stream s) >>= fun res -> + assert_equal false res; + Lwt_stream.to_list s >|= fun res -> + assert_equal ~msg:"is_empty should consume leading spaces" + [ "foo"; ""; "bar" ] res + +let test_stream_empty_strings () = + Body.is_empty (`Stream (Lwt_stream.of_list [ ""; ""; "" ])) >|= fun res -> + assert_equal true res + +let tests = + [ + ("Empty stream", test_empty_body); + ("Non empty stream", test_non_empty_stream); + ("Stream with leading empty strings", test_stream_with_leading_empty_strings); + ("Stream with empty strings", test_stream_empty_strings); + ] + +let test_suite = + Lwt_list.map_s + (fun (title, test) -> run_test test >|= fun res -> (title, res)) + tests + >|= fun results -> + let tests = + ListLabels.map results ~f:(fun (title, res) -> + title >:: fun () -> match res with `Ok -> () | `Exn exn -> raise exn) + in + "Cohttp_Lwt.Body" >::: tests + +let _ = test_suite |> Cohttp_lwt_unix_test.run_async_tests |> Lwt_main.run diff --git a/cohttp-lwt-unix/test/test_client.ml b/cohttp-lwt-unix/test/test_client.ml new file mode 100644 index 0000000..47d7f6e --- /dev/null +++ b/cohttp-lwt-unix/test/test_client.ml @@ -0,0 +1,216 @@ +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 ?absolute_form meth uri = + ignore absolute_form; + 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 ?absolute_form meth uri = + ignore absolute_form; + 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 ?absolute_form meth uri = + ignore absolute_form; + 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 diff --git a/cohttp-lwt-unix/test/test_parser.ml b/cohttp-lwt-unix/test/test_parser.ml new file mode 100644 index 0000000..5208290 --- /dev/null +++ b/cohttp-lwt-unix/test/test_parser.ml @@ -0,0 +1,370 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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 OUnit + +let basic_req = "GET /index.html HTTP/1.1\r\nHost: www.example.com\r\n\r\n" + +let basic_res = + "HTTP/1.1 200 OK\r\n\ + Date: Mon, 23 May 2005 22:38:34 GMT\r\n\ + Server: Apache/1.3.3.7 (Unix) (Red-Hat/Linux)\r\n\ + Last-Modified: Wed, 08 Jan 2003 23:11:55 GMT\r\n\ + Etag: \"3f80f-1b6-3e1cb03b\"\r\n\ + Accept: text/*\r\n\ + Accept: application/xml\r\n\ + Accept-Ranges: none\r\n\ + Content-Length: 0\r\n\ + Connection: close\r\n\ + Content-Type: text/html; charset=UTF-8\r\n\ + \r\n" + +let basic_res_content = + "HTTP/1.1 200 OK\r\n\ + Date: Mon, 23 May 2005 22:38:34 GMT\r\n\ + Server: Apache/1.3.3.7 (Unix) (Red-Hat/Linux)\r\n\ + Last-Modified: Wed, 08 Jan 2003 23:11:55 GMT\r\n\ + Etag: \"3f80f-1b6-3e1cb03b\"\r\n\ + Accept-Ranges: none\r\n\ + Content-Length: 32\r\n\ + Connection: close\r\n\ + Content-Type: text/html; charset=UTF-8\r\n\ + \r\n\ + home=Cosby&favorite+flavor=flies" + +let post_req = + "POST /path/script.cgi HTTP/1.0\r\n\ + From: frog@jmarshall.com\r\n\ + User-Agent: HTTPTool/1.0\r\n\ + Content-Type: application/x-www-form-urlencoded\r\n\ + Content-Length: 32\r\n\ + \r\n\ + home=Cosby&favorite+flavor=flies" + +let post_data_req = + "POST /path/script.cgi HTTP/1.0\r\n\ + From: frog@jmarshall.com\r\n\ + User-Agent: HTTPTool/1.0\r\n\ + Content-Length: 32\r\n\ + \r\n\ + home=Cosby&favorite+flavor=flies" + +let post_chunked_req = + "POST /foo HTTP/1.1\r\n\ + Date: Fri, 31 Dec 1999 23:59:59 GMT\r\n\ + Content-Type: text/plain\r\n\ + Transfer-Encoding: chunked\r\n\ + \r\n\ + 1a; ignore-stuff-here\r\n\ + abcdefghijklmnopqrstuvwxyz\r\n\ + 10\r\n\ + 1234567890abcdef\r\n\ + 0\r\n\ + some-footer: some-value\r\n\ + another-footer: another-value\r\n\ + \r\n" + +let chunked_res = + "HTTP/1.1 200 OK\r\n\ + Date: Fri, 31 Dec 1999 23:59:59 GMT\r\n\ + Content-Type: text/plain\r\n\ + Transfer-Encoding: chunked\r\n\ + \r\n\ + 1a; ignore-stuff-here\r\n\ + abcdefghijklmnopqrstuvwxyz\r\n\ + 10\r\n\ + 1234567890abcdef\r\n\ + 0\r\n\ + some-footer: some-value\r\n\ + another-footer: another-value\r\n\ + \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 = + 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 pp_diff fmt (a, b) = + Format.pp_print_string fmt "Expected:"; + Format.pp_print_newline fmt (); + Format.pp_print_string fmt a; + Format.pp_print_string fmt "Result:"; + Format.pp_print_newline fmt (); + Format.pp_print_string fmt b + +let p_sexp f x = x |> f |> Sexplib0.Sexp.to_string + +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 + let ic = ic_of_buffer (Lwt_bytes.of_string basic_req) in + Req_io.read ic >>= function + | `Ok req -> + assert_equal (Cohttp.Request.version req) `HTTP_1_1; + assert_equal (CU.Request.meth req) `GET; + assert_equal + ~printer:(fun x -> x) + "//www.example.com/index.html" + (Uri.to_string (CU.Request.uri req)); + return () + | _ -> assert false + +let basic_res_parse res () = + let open Cohttp in + let open Cohttp_lwt_unix in + let ic = ic_of_buffer (Lwt_bytes.of_string res) in + Rep_io.read ic >>= function + | `Ok res -> + (* Parse first line *) + assert_equal (Response.version res) `HTTP_1_1; + assert_equal (Response.status res) `OK; + let headers = Response.headers res in + assert_equal (Header.get headers "connection") (Some "close"); + assert_equal (Header.get headers "Accept-ranges") (Some "none"); + assert_equal + (Header.get headers "content-type") + (Some "text/html; charset=UTF-8"); + return () + | _ -> assert false + +let req_parse () = + let open Cohttp_lwt_unix in + let ic = ic_of_buffer (Lwt_bytes.of_string basic_req) in + Req_io.read ic >>= function + | `Ok req -> + assert_equal `GET (Request.meth req); + assert_equal "/index.html" (Uri.path (Request.uri req)); + assert_equal `HTTP_1_1 (Request.version req); + 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 + 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_chunked_parse () = + let open Cohttp in + let open Cohttp_lwt_unix in + let ic = ic_of_buffer (Lwt_bytes.of_string post_chunked_req) in + Req_io.read ic >>= function + | `Ok req -> + assert_equal + (Transfer.string_of_encoding (Request.encoding req)) + "chunked"; + let reader = Req_io.make_body_reader req ic in + Req_io.read_body_chunk reader >>= fun chunk -> + assert_equal chunk (Transfer.Chunk "abcdefghijklmnopqrstuvwxyz"); + Req_io.read_body_chunk reader >>= fun chunk -> + assert_equal chunk (Transfer.Chunk "1234567890abcdef"); + return () + | _ -> assert false + +let res_content_parse () = + let open Cohttp in + let open Cohttp_lwt_unix in + let ic = ic_of_buffer (Lwt_bytes.of_string basic_res_content) in + Rep_io.read ic >>= function + | `Ok 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 + ~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 res_chunked_parse () = + let open Cohttp in + let open Cohttp_lwt_unix in + let ic = ic_of_buffer (Lwt_bytes.of_string chunked_res) in + Rep_io.read ic >>= function + | `Ok res -> + assert_equal `HTTP_1_1 (Response.version res); + assert_equal `OK (Response.status res); + let reader = Rep_io.make_body_reader res ic in + Rep_io.read_body_chunk reader >>= fun chunk -> + assert_equal chunk (Transfer.Chunk "abcdefghijklmnopqrstuvwxyz"); + Rep_io.read_body_chunk reader >>= fun chunk -> + assert_equal chunk (Transfer.Chunk "1234567890abcdef"); + return () + | _ -> assert false + +(* Extract the substring of the byte buffer that has been written to *) +let get_substring oc buf = + let len = Int64.to_int (Lwt_io.position oc) in + let b = Bytes.create len in + Lwt_bytes.blit_to_bytes buf 0 b 0 len; + b |> Bytes.to_string + +let write_req expected req = + (* Use the low-level write_header/footer API *) + 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 ~flush:false + (fun writer -> Cohttp_lwt.Body.write_body (Req_io.write_body writer) body) + req oc + >>= fun () -> + assert_equal ~pp_diff expected (get_substring oc buf); + (* Use the high-level write API. This also tests that req is immutable + * by re-using it *) + let buf = Lwt_bytes.create 4096 in + let oc = oc_of_buffer buf in + 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 open Cohttp in + let open Cohttp_lwt_unix in + let expected = + "POST /foo/bar HTTP/1.1\r\nFoo: bar\r\nhost: localhost\r\nuser-agent: " + ^ user_agent + ^ "\r\ntransfer-encoding: chunked\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n" + in + let req = + Request.make ~encoding:Transfer.Chunked ~meth:`POST + ~headers:(Header.init_with "Foo" "bar") + (Uri.of_string "/foo/bar") + in + write_req expected req + +let mutate_simple_req () = + let open Cohttp in + let open Cohttp_lwt_unix in + let expected = + "POST /foo/bar HTTP/1.1\r\nfoo: bar\r\nhost: localhost\r\nuser-agent: " + ^ user_agent + ^ "\r\ntransfer-encoding: chunked\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n" + in + let req = + Request.make ~encoding:Transfer.Chunked + ~headers:(Header.init_with "foo" "bar") + (Uri.of_string "/foo/bar") + in + let req = { req with Request.meth = `POST } in + write_req expected req + +let make_simple_res () = + let open Cohttp in + let open Cohttp_lwt_unix in + let expected = + "HTTP/1.1 200 OK\r\n\ + foo: bar\r\n\ + transfer-encoding: chunked\r\n\ + \r\n\ + 6\r\n\ + foobar\r\n\ + 0\r\n\ + \r\n" + in + (* Use the low-level write_header/footer API *) + let buf = Lwt_bytes.create 4096 in + 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 ~flush:false + (fun writer -> Cohttp_lwt.Body.write_body (Rep_io.write_body writer) body) + res oc + >>= fun () -> + assert_equal expected (get_substring oc buf); + (* Use the high-level write API. This also tests that req is immutable + * by re-using it *) + let buf = Lwt_bytes.create 4096 in + let oc = oc_of_buffer buf in + Rep_io.write ~flush:false + (fun writer -> Rep_io.write_body writer "foobar") + res oc + >>= fun () -> + assert_equal expected (get_substring oc buf); + return () + +let test_cases = + let tests = + [ + ("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); + ] + in + List.map (fun (n, x) -> n >:: fun () -> Lwt_main.run (x ())) tests + +(* Returns true if the result list contains successes only. + 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 + | RFailure _ :: _ | RError _ :: _ | RTodo _ :: _ -> false + +let _ = + let suite = "Parser" >::: test_cases in + let verbose = ref false in + let set_verbose _ = verbose := true in + Arg.parse + [ ("-verbose", Arg.Unit set_verbose, "Run the test in verbose mode.") ] + (fun x -> raise (Arg.Bad ("Bad argument : " ^ x))) + ("Usage: " ^ Sys.argv.(0) ^ " [-verbose]"); + if not (was_successful (run_test_tt ~verbose:!verbose suite)) then exit 1 diff --git a/cohttp-lwt-unix/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml new file mode 100644 index 0000000..5c8202f --- /dev/null +++ b/cohttp-lwt-unix/test/test_sanity.ml @@ -0,0 +1,173 @@ +open Lwt.Infix +open OUnit +open Cohttp_lwt_unix +open Cohttp_lwt_unix_test +module Body = Cohttp_lwt.Body +module IO = Cohttp_lwt_unix.Private.IO + +let message = "Hello sanity!" +let chunk_body = [ "one"; ""; " "; "bar"; "" ] +let leak_repeat = 1024 +let () = Debug.activate_debug () +let () = Logs.set_level (Some Warning) + +let server = + List.map const + [ + (* t *) + Server.respond_string ~status:`OK ~body:message (); + (* pipelined_chunk *) + Server.respond ~status:`OK ~body:(Body.of_string "") (); + Server.respond ~status:`OK ~body:(Body.of_string_list chunk_body) (); + Server.respond ~status:`OK ~body:(Body.of_string "") (); + (* pipelined_interleave *) + Server.respond_string ~status:`OK ~body:"one" (); + Server.respond_string ~status:`OK ~body:"two" (); + Server.respond_string ~status:`OK ~body:"three" (); + (* Massive chunked *) + Server.respond ~status:`OK + ~body: + (let count = ref 0 in + let chunk = String.make 64 '0' in + `Stream + (Lwt_stream.from_direct (fun () -> + if !count < 1000 then ( + incr count; + Some chunk) + else None))) + (); + ] + @ 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 + (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 + ( (* 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 () -> + Cohttp_lwt_unix.Private.Input_channel.close ic ))); + ] + |> response_sequence + +let check_logs test () = + let old = Logs.(warn_count () + err_count ()) in + test () >|= fun () -> + let new_errs = Logs.(warn_count () + err_count ()) - old in + if new_errs > 0 then + Fmt.failwith "Test produced %d log messages at level >= warn" new_errs + +let ts = + Cohttp_lwt_unix_test.test_server_s server (fun uri -> + 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 + in + let pipelined_chunk () = + let printer x = x in + let body = String.concat "" chunk_body in + let reqs = + [ + (Request.make ~meth:`HEAD uri, `Empty); + (Request.make ~meth:`GET uri, `Empty); + (Request.make ~meth:`HEAD uri, `Empty); + ] + in + let counter = ref 0 in + Client.callv ~ctx uri (Lwt_stream.of_list reqs) >>= fun resps -> + Lwt_stream.iter_s + (fun (_, rbody) -> + rbody |> Body.to_string >|= fun rbody -> + (match !counter with + | 0 | 2 -> assert_equal ~printer "" rbody + | _ -> assert_equal ~printer body rbody); + incr counter) + resps + >>= fun () -> + assert_equal ~printer:string_of_int 3 !counter; + Lwt.return_unit + in + let pipelined_interleave () = + let r n = + let uri = Uri.with_query' uri [ ("test", string_of_int n) ] in + (Request.make uri, Body.empty) + in + let reqs, push = Lwt_stream.create () in + push (Some (r 1)); + push (Some (r 2)); + Client.callv ~ctx uri reqs >>= fun resps -> + let resps = Lwt_stream.map_s (fun (_, b) -> Body.to_string b) resps in + Lwt_stream.fold + (fun b i -> + Logs.info (fun f -> f "Request %i\n" i); + (match i with + | 0 -> assert_equal b "one" + | 1 -> + assert_equal b "two"; + Logs.info (fun f -> f "Sending extra request"); + push (Some (r 3)) + | 2 -> + assert_equal b "three"; + push None + | x -> assert_failure ("Test failed with " ^ string_of_int x)); + succ i) + resps 0 + >|= fun l -> assert_equal l 3 + in + let massive_chunked () = + Client.get ~ctx uri >>= fun (_resp, body) -> + Body.to_string body >|= fun body -> + assert_equal ~printer:string_of_int (1000 * 64) (String.length body) + in + let test_no_leak () = + let stream = + Array.init leak_repeat (fun _ -> uri) |> Lwt_stream.of_array + in + Lwt_stream.fold_s + (fun uri () -> + Client.head ~ctx uri >>= fun resp_head -> + assert_equal (Response.status resp_head) `OK; + Client.get ~ctx uri >>= fun (resp_get, body) -> + assert_equal (Response.status resp_get) `OK; + Body.drain_body body) + stream () + in + let expert_pipelined () = + let printer x = x in + Client.get ~ctx uri >>= fun (_rsp, body) -> + Body.to_string body >>= fun body -> + assert_equal ~printer "expert 1" body; + Client.get ~ctx uri >>= fun (_rsp, body) -> + Body.to_string body >|= fun body -> + assert_equal ~printer "expert 2" body + in + [ + ("sanity test", check_logs t); + ("pipelined chunk test", check_logs pipelined_chunk); + ("pipelined with interleaving requests", check_logs pipelined_interleave); + ("massive chunked", check_logs massive_chunked); + ("no leaks on requests", check_logs test_no_leak); + ("expert response", check_logs expert_pipelined); + ]) + +let _ = ts |> run_async_tests |> Lwt_main.run diff --git a/cohttp-lwt-unix/test/test_sanity_noisy.ml b/cohttp-lwt-unix/test/test_sanity_noisy.ml new file mode 100644 index 0000000..e54b83c --- /dev/null +++ b/cohttp-lwt-unix/test/test_sanity_noisy.ml @@ -0,0 +1,81 @@ +open Lwt.Infix +open OUnit +open Cohttp +open Cohttp_lwt_unix +open Cohttp_lwt_unix_test +module Body = Cohttp_lwt.Body +module IO = Cohttp_lwt_unix.Private.IO + +let chunk_body = [ "one"; ""; " "; "bar"; "" ] +let () = Logs.set_level (Some Info) +let () = Logs.set_reporter Logs.nop_reporter + +let check_logs test () = + let old = Logs.(warn_count () + err_count ()) in + test () >|= fun () -> + let new_errs = Logs.(warn_count () + err_count ()) - old in + if new_errs > 0 then + Fmt.failwith "Test produced %d log messages at level >= warn" new_errs + +let server_noisy = + List.map const + [ + (* empty_chunk *) + Server.respond ~status:`OK ~body:(Body.of_string_list chunk_body) (); + (* not modified *) + Server.respond ~status:`Not_modified ~body:Body.empty (); + ] + @ [ + (fun _ body -> + (* Returns 500 on bad file *) + Body.to_string body >>= fun fname -> + Server.respond_file ~fname () >|= fun rsp -> `Response rsp); + ] + |> response_sequence + +let ts_noisy = + Cohttp_lwt_unix_test.test_server_s ~port:10193 server_noisy (fun uri -> + 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 -> + assert_equal body (String.concat "" chunk_body) + in + let not_modified_has_no_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.(Fixed 0L) + (Header.get_transfer_encoding headers); + body |> Body.is_empty >|= fun is_empty -> + assert_bool "No body returned when not modified" is_empty + in + let unreadable_file_500 () = + let fname = "unreadable500" in + Lwt.finalize + (fun () -> + Lwt_io.open_file ~flags:[ Lwt_unix.O_CREAT ] ~perm:0o006 + ~mode:Lwt_io.Output fname + >>= fun oc -> + Lwt_io.write_line oc "never read" >>= fun () -> + Lwt_io.close oc >>= fun () -> + ( Client.post ~ctx uri ~body:(Body.of_string fname) + >>= fun (resp, body) -> + assert_equal ~printer:Code.string_of_status (Response.status resp) + `Internal_server_error; + Body.to_string body ) + >|= fun body -> + assert_equal + ~printer:(fun x -> "'" ^ x ^ "'") + body "Error: Internal Server Error") + (fun () -> Lwt_unix.unlink fname) + in + [ + ("empty chunk test", check_logs empty_chunk); + ( "no body when response is not modified", + check_logs not_modified_has_no_body ); + ("unreadable file returns 500", unreadable_file_500); + ]) + +let _ = ts_noisy |> run_async_tests |> Lwt_main.run diff --git a/cohttp-lwt.opam b/cohttp-lwt.opam new file mode 100644 index 0000000..604ffbb --- /dev/null +++ b/cohttp-lwt.opam @@ -0,0 +1,56 @@ +version: "6.2.1" +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +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 "] +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} + "cohttp" {= version} + "lwt" {>= "5.7.0"} + "sexplib0" + "ipaddr" {>= "5.6.0"} + "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 + "@install" + "@cohttp-lwt/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp-lwt.opam.template b/cohttp-lwt.opam.template new file mode 100644 index 0000000..d737510 --- /dev/null +++ b/cohttp-lwt.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp-lwt/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp-lwt/src/body.ml b/cohttp-lwt/src/body.ml new file mode 100644 index 0000000..82a722f --- /dev/null +++ b/cohttp-lwt/src/body.ml @@ -0,0 +1,102 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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 Body = Cohttp.Body +module Transfer = Cohttp.Transfer +open Lwt + +type t = [ Body.t | `Stream of (string Lwt_stream.t[@sexp.opaque]) ] +[@@deriving sexp] + +let empty = (Body.empty :> t) + +let create_stream fn arg = + let fin = ref false in + Lwt_stream.from (fun () -> + match !fin with + | true -> return_none + | false -> ( + fn arg >>= function + | Transfer.Done -> return_none + | Final_chunk c -> + fin := true; + return (Some c) + | Chunk c -> return (Some c))) + +let is_empty (body : t) = + match body with + | #Body.t as body -> return (Body.is_empty body) + | `Stream s -> + Lwt_stream.get_while (fun x -> x = "") s >>= fun _ -> + Lwt_stream.is_empty s + +let to_string (body : t) = + match body with + | #Body.t as body -> return (Body.to_string body) + | `Stream s -> + let b = Buffer.create 1024 in + Lwt_stream.iter (Buffer.add_string b) s >>= fun () -> + return (Buffer.contents b) + +let to_string_list (body : t) = + match body with + | #Body.t as body -> return (Body.to_string_list body) + | `Stream s -> Lwt_stream.to_list s + +let of_string s = (Body.of_string s :> t) + +let to_stream (body : t) = + match body with + | `Empty -> Lwt_stream.of_list [] + | `Stream s -> s + | `String s -> Lwt_stream.of_list [ s ] + | `Strings sl -> Lwt_stream.of_list sl + +let drain_body (body : t) = + match body with + | `Empty | `String _ | `Strings _ -> return_unit + | `Stream s -> Lwt_stream.junk_while (fun _ -> true) s + +let of_string_list l = `Strings l +let of_stream s = `Stream s + +let transfer_encoding = function + | #Body.t as t -> Body.transfer_encoding t + | `Stream _ -> Transfer.Chunked + +(* This will consume the body and return a length, and a + * new body that should be used instead of the input *) +let length (body : t) : (int64 * t) Lwt.t = + match body with + | #Body.t as body -> return (Body.length body, body) + | `Stream _ -> + to_string body >>= fun buf -> + let len = Int64.of_int (String.length buf) in + return (len, `String buf) + +let write_body fn = function + | `Empty -> return_unit + | `Stream st -> Lwt_stream.iter_s fn st + | `String s -> fn s + | `Strings sl -> Lwt_list.iter_s fn sl + +let map f t = + match t with + | #Body.t as t -> (Body.map f t :> t) + | `Stream s -> `Stream (Lwt_stream.map f s) + +let to_form (body : t) = to_string body >|= Uri.query_of_encoded +let of_form ?scheme f = Uri.encoded_of_query ?scheme f |> of_string diff --git a/cohttp-lwt/src/body.mli b/cohttp-lwt/src/body.mli new file mode 100644 index 0000000..e4535e0 --- /dev/null +++ b/cohttp-lwt/src/body.mli @@ -0,0 +1,33 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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. + * + }}}*) + +type t = [ Cohttp.Body.t | `Stream of string Lwt_stream.t ] [@@deriving sexp] + +include Cohttp.S.Body with type t := t + +val is_empty : t -> bool Lwt.t +val to_string : t -> string Lwt.t +val to_string_list : t -> string list Lwt.t +val to_stream : t -> string Lwt_stream.t +val of_stream : string Lwt_stream.t -> t +val to_form : t -> (string * string list) list Lwt.t + +val create_stream : + ('a -> Cohttp.Transfer.chunk Lwt.t) -> 'a -> string Lwt_stream.t + +val length : t -> (int64 * t) Lwt.t +val write_body : (string -> unit Lwt.t) -> t -> unit Lwt.t +val drain_body : t -> unit Lwt.t diff --git a/cohttp-lwt/src/bytebuffer.ml b/cohttp-lwt/src/bytebuffer.ml new file mode 100644 index 0000000..040f046 --- /dev/null +++ b/cohttp-lwt/src/bytebuffer.ml @@ -0,0 +1,14 @@ +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) diff --git a/cohttp-lwt/src/client.ml b/cohttp-lwt/src/client.ml new file mode 100644 index 0000000..cb0c81f --- /dev/null +++ b/cohttp-lwt/src/client.ml @@ -0,0 +1,72 @@ +open Lwt.Infix +module Header = Cohttp.Header + +module Make (Connection : S.Connection) = struct + module Net = Connection.Net + module IO = Net.IO + module No_cache = Connection_cache.Make_no_cache (Connection) + module Request = Make.Request (Net.IO) + + let cache = ref No_cache.(call (create ())) + let set_cache c = cache := c + + type ctx = Net.ctx + + let cache ?ctx = + match ctx with + | None -> !cache + | Some ctx -> No_cache.(call (create ~ctx ())) + + include + Cohttp.Generic.Client.Make + (struct + type 'a io = 'a Lwt.t + type body = Body.t + type 'a with_context = ?ctx:ctx -> 'a + + let map_context v f ?ctx = f (v ?ctx) + + 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 = + Header.add_opt_unless_exists headers "content-type" + "application/x-www-form-urlencoded" + in + let body = Body.of_string (Uri.encoded_of_query params) in + post ?ctx ~chunked:false ~headers ~body uri + + 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 diff --git a/cohttp-lwt/src/client.mli b/cohttp-lwt/src/client.mli new file mode 100644 index 0000000..6d8398e --- /dev/null +++ b/cohttp-lwt/src/client.mli @@ -0,0 +1,10 @@ +(** The [Make] functor glues together a {!Cohttp.S.IO} implementation to send + requests down a connection that is established by the {!Net} module. The + resulting module satisfies the {!Client} module type. + + The {!Logs} source name for this module's logger is ["cohttp.lwt.client"]. + When logging is enabled (at least {b warning} level), eventual body leaks + will be logged and easier to track. *) + +module Make (Connection : S.Connection) : + S.Client with type ctx = Connection.Net.ctx diff --git a/cohttp-lwt/src/cohttp_lwt.ml b/cohttp-lwt/src/cohttp_lwt.ml new file mode 100644 index 0000000..68e8fbd --- /dev/null +++ b/cohttp-lwt/src/cohttp_lwt.ml @@ -0,0 +1,39 @@ +(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy + * + * 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 type IO = S.IO + +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 diff --git a/cohttp-lwt/src/connection.ml b/cohttp-lwt/src/connection.ml new file mode 100644 index 0000000..0c454a7 --- /dev/null +++ b/cohttp-lwt/src/connection.ml @@ -0,0 +1,333 @@ +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 = { + absolute_form : bool; + 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) ?(absolute_form = false) 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 + { absolute_form; 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 ({ absolute_form; 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 ~absolute_form 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 create_tunnel ?(finalise = fun _ -> Lwt.return_unit) + ?(ctx = Lazy.force Net.default_ctx) proxy remote_host = + match proxy.state with + | Full (ic, oc) -> + let client = Net.tunnel remote_host (ic, oc) in + let channels = + Net.connect_client ~ctx client >>= 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 = `True; + } + 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 + | _ -> failwith "Proxy connection wasn't in right state." + + 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 diff --git a/cohttp-lwt/src/connection_cache.ml b/cohttp-lwt/src/connection_cache.ml new file mode 100644 index 0000000..09c803d --- /dev/null +++ b/cohttp-lwt/src/connection_cache.ml @@ -0,0 +1,361 @@ +exception Retry = Connection.Retry + +module Make_no_cache (Connection : S.Connection) = 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 + ?absolute_form 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 ?absolute_form 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 + +module Make (Connection : S.Connection) (Sleep : S.Sleep) = 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; + proxy : Uri.t option; + } + + let create ?(ctx = Lazy.force Net.default_ctx) ?(keep = 60_000_000_000L) + ?(retry = 2) ?(parallel = 4) ?(depth = 100) ?proxy () = + { + cache = Hashtbl.create ~random:true 10; + ctx; + keep; + retry; + parallel; + depth; + proxy; + } + + 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 ~persistent:true ~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 prepare self ?headers ?absolute_form meth uri = + match self.proxy with + | None -> + let absolute_form = Option.value ~default:false absolute_form in + Net.resolve ~ctx:self.ctx uri >>= fun endp -> + Lwt.return (endp, absolute_form, headers) + | Some proxy_uri -> + let absolute_form = + Option.value + ~default: + (not + (meth = `CONNECT + || (meth = `OPTIONS && Uri.path_and_query uri = "*"))) + absolute_form + in + Net.resolve ~ctx:self.ctx proxy_uri >>= fun endp -> + Lwt.return (endp, absolute_form, headers) + + let call self ?headers ?body ?absolute_form meth uri = + prepare self ?headers ?absolute_form meth uri + >>= fun (endp, absolute_form, headers) -> + let rec request retry = + get_connection self endp >>= fun conn -> + Lwt.catch + (fun () -> Connection.call conn ?headers ?body ~absolute_form 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 + +module Make_tunnel (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 -> + ?proxy_headers:Http.Header.t -> + Uri.t -> + unit -> + t +end = struct + module Net = Connection.Net + module IO = Net.IO + open IO + + type ctx = Net.ctx + type tunnel = { proxy : Connection.t; remote : Connection.t } + + type t = { + cache : (string, tunnel) Hashtbl.t; (* remote host * tunnel *) + proxy_uri : Uri.t; + mutable proxy_endp : Net.endp option; + proxy_headers : Http.Header.t; + ctx : ctx; + keep : int64; + retry : int; + parallel : int; + depth : int; + } + + let proxy_default_scheme uri = + match Uri.scheme uri with + | None -> Uri.with_scheme uri (Some "http") + | _ -> uri + + let create ?(ctx = Lazy.force Net.default_ctx) ?(keep = 60_000_000_000L) + ?(retry = 2) ?(parallel = 4) ?(depth = 100) + ?(proxy_headers = Http.Header.init ()) proxy_uri () = + if Uri.host proxy_uri = None then + Printf.ksprintf invalid_arg "No host was provided in URI %s." + (Uri.to_string proxy_uri); + { + cache = Hashtbl.create ~random:true 10; + proxy_uri = proxy_default_scheme proxy_uri; + proxy_endp = None; + proxy_headers; + ctx; + keep; + retry; + parallel; + depth; + } + + let rec request conn ?headers ?body ?absolute_form meth uri retry = + Lwt.catch + (fun () -> Connection.call conn ?headers ?body ?absolute_form meth uri) + (function + | Retry -> ( + match body with + | Some (`Stream _) -> Lwt.fail Retry + | None | Some `Empty | Some (`String _) | Some (`Strings _) -> + if retry <= 0 then Lwt.fail Retry + else + request conn ?headers ?body ?absolute_form meth uri (retry - 1) + ) + | e -> Lwt.fail e) + + let rec get_connection self ~proxy_endp ~remote ~remote_host ~remote_uri = + let finalise connection = + let rec remove keep = + let current = Hashtbl.find self.cache remote in + Hashtbl.remove self.cache remote; + if current.proxy == connection || current.remote == connection then + List.iter (Hashtbl.add self.cache remote) keep + else remove (current :: keep) + in + remove []; + Lwt.return_unit + in + let create () = + let proxy = + Connection.create ~persistent:true ~finalise ~ctx:self.ctx proxy_endp + in + request proxy ~headers:self.proxy_headers `CONNECT remote_uri self.retry + >>= fun (resp, _body) -> + let code = resp |> Http.Response.status |> Cohttp.Code.code_of_status in + if not (Cohttp.Code.is_success code) then + Printf.ksprintf failwith "Could not setup tunnel. Response code: %d\n" + code; + let remote = + Connection.create_tunnel ~finalise ~ctx:self.ctx proxy remote_host + and timeout = ref Lwt.return_unit in + let rec busy () = + Lwt.cancel !timeout; + if Connection.length remote = 0 then ( + timeout := + Sleep.sleep_ns self.keep >>= fun () -> + Connection.close remote; + Connection.close proxy; + (* failure is ignored *) + Lwt.return_unit); + Lwt.on_termination (Connection.notify remote) busy + in + busy (); + Lwt.return { proxy; remote } + in + match Hashtbl.find_all self.cache remote with + | [] -> + create () >>= fun tunnel -> + Hashtbl.add self.cache remote tunnel; + Lwt.return tunnel + | tunnels -> ( + let rec search length = function + | [ a ] -> (a, length + 1) + | a :: b :: tl + when Connection.length a.remote < Connection.length b.remote -> + search (length + 1) (a :: tl) + | _ :: tl -> search (length + 1) tl + | [] -> assert false + in + match search 0 tunnels with + | shallowest, _ when Connection.length shallowest.remote = 0 -> + Lwt.return shallowest + | _, length when length < self.parallel -> + create () >>= fun tunnel -> + Hashtbl.add self.cache remote tunnel; + Lwt.return tunnel + | shallowest, _ when Connection.length shallowest.remote < self.depth -> + Lwt.return shallowest + | _ -> + Lwt.try_bind + (fun () -> + Lwt.choose + (List.map + (fun { remote; _ } -> Connection.notify remote) + tunnels)) + (fun _ -> + get_connection self ~proxy_endp ~remote ~remote_host ~remote_uri) + (fun _ -> + get_connection self ~proxy_endp ~remote ~remote_host ~remote_uri) + ) + + let call self ?headers ?body ?absolute_form meth uri = + (match self.proxy_endp with + | None -> + Net.resolve ~ctx:self.ctx self.proxy_uri >>= fun proxy_endp -> + self.proxy_endp <- Some proxy_endp; + Lwt.return proxy_endp + | Some proxy_endp -> Lwt.return proxy_endp) + >>= fun proxy_endp -> + let remote_port = + match Uri_services.tcp_port_of_uri uri with + | Some p -> p + | None -> failwith "A port is required for the CONNECT method." + in + let remote_host = Option.get (Uri.host uri) in + let remote = remote_host ^ ":" ^ string_of_int remote_port + and remote_uri = Uri.with_port uri (Some remote_port) in + get_connection self ~proxy_endp ~remote ~remote_host ~remote_uri + >>= fun tunnel -> + request tunnel.remote ?headers ?body ?absolute_form meth uri self.retry +end + +module Proxy = Cohttp.Proxy.Forward + +module Make_proxy (Connection : S.Connection) (Sleep : S.Sleep) = struct + module Connection_cache = Make (Connection) (Sleep) + module Connection_tunnel = Make_tunnel (Connection) (Sleep) + + type t = { + proxies : (Connection_cache.t, Connection_tunnel.t) Proxy.servers; + no_proxy : Connection_cache.t; + } + + let create ?ctx ?keep ?retry ?parallel ?depth ?(scheme_proxy = []) ?all_proxy + ?no_proxy ?proxy_headers () = + let create_default () = + Connection_cache.create ?ctx ?keep ?retry ?parallel ?depth () + and create_direct proxy = + Connection_cache.create ?ctx ?keep ?retry ?parallel ?depth ~proxy () + and create_tunnel proxy_uri = + Connection_tunnel.create ?ctx ?keep ?retry ?parallel ?depth ?proxy_headers + proxy_uri () + in + let proxies = + Proxy.make_servers ~no_proxy_patterns:no_proxy ~default_proxy:all_proxy + ~scheme_proxies:scheme_proxy ~direct:create_direct ~tunnel:create_tunnel + in + let no_proxy = create_default () in + { no_proxy; proxies } + + let call self ?headers ?body ?absolute_form meth uri = + let proxy = Proxy.get self.proxies uri in + match proxy with + | None -> + Connection_cache.call self.no_proxy ?headers ?body ?absolute_form meth + uri + | Some (Tunnel proxy) -> + Connection_tunnel.call proxy ?headers ?body ?absolute_form meth uri + | Some (Direct proxy) -> + Connection_cache.call proxy ?headers ?body ?absolute_form meth uri +end diff --git a/cohttp-lwt/src/connection_cache.mli b/cohttp-lwt/src/connection_cache.mli new file mode 100644 index 0000000..60708df --- /dev/null +++ b/cohttp-lwt/src/connection_cache.mli @@ -0,0 +1,96 @@ +(** 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 + +(** 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 -> + ?proxy:Uri.t -> + 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. + @param proxy A direct (non-tunneling) proxy to use. *) +end +[@@warning "-unused-functor-parameter"] + +(** This functor keeps a cache of connections for reuse. Connections are reused + based on their remote {!type:Conduit.endp} (effectively IP / port). It also + supports automatically connecting and reconnecting to direct and tunneling + proxies, based on the remote URI scheme (HTTP will select direct proxies, + HTTPS tunneling proxies). *) +module Make_proxy (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 -> + ?scheme_proxy:(string * Uri.t) list -> + ?all_proxy:Uri.t -> + ?no_proxy:string -> + ?proxy_headers:Http.Header.t -> + unit -> + t + (** Create a new connection cache. The outer connections to the proxy and the + inner connections share the same parameters. + + @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. + @param scheme_proxy The proxy URI associated to each (remote) scheme. + @param all_proxy + The default proxy to use. Proxy for specific schemes have precedence + over this. + @param no_proxy + Disable proxies for specific hosts, specified as curl's [NO_PROXY]. + @see + @param proxy_headers Headers to pass to the proxy. *) +end +[@@warning "-unused-functor-parameter"] diff --git a/cohttp-lwt/src/dune b/cohttp-lwt/src/dune new file mode 100644 index 0000000..d2d0621 --- /dev/null +++ b/cohttp-lwt/src/dune @@ -0,0 +1,7 @@ +(library + (name cohttp_lwt) + (public_name cohttp-lwt) + (synopsis "Lwt backend") + (preprocess + (pps ppx_sexp_conv)) + (libraries lwt uri uri.services http_bytebuffer cohttp logs logs.lwt ipaddr)) diff --git a/cohttp-lwt/src/make.ml b/cohttp-lwt/src/make.ml new file mode 100644 index 0000000..09ef5c1 --- /dev/null +++ b/cohttp-lwt/src/make.ml @@ -0,0 +1,13 @@ +module Request (IO : S.IO) = struct + include Cohttp.Request + + 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 ( + Private.Make (IO) : module type of Private.Make (IO) with type t := t) + end diff --git a/cohttp-lwt/src/s.ml b/cohttp-lwt/src/s.ml new file mode 100644 index 0000000..55d7199 --- /dev/null +++ b/cohttp-lwt/src/s.ml @@ -0,0 +1,263 @@ +(** Portable Lwt implementation of HTTP client and server, without depending on + a particular I/O implementation. The various [Make] functors must be + instantiated by an implementation that provides a concrete IO monad. *) + +(** The IO module is specialized for the [Lwt] monad. *) +module type IO = sig + include Cohttp.S.IO with type 'a t = 'a Lwt.t + + type error + + val catch : (unit -> 'a t) -> ('a, error) result t + (** [catch f] is [f () >|= Result.ok], unless [f] fails with an IO error, in + which case it returns the error. *) + + val pp_error : Format.formatter -> error -> unit +end + +(** The [Net] module type defines how to connect to a remote node and close the + resulting channels to clean up. *) +module type Net = sig + module IO : IO + + type client + 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 tunnel : string -> IO.ic * IO.oc -> client + + 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 connect_client : ctx:ctx -> client -> (IO.conn * IO.ic * IO.oc) IO.t + val close_in : IO.ic -> unit + val close_out : IO.oc -> unit + val close : IO.ic -> IO.oc -> unit +end + +(** 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 + +type call = + ?headers:Http.Header.t -> + ?body:Body.t -> + ?absolute_form:bool -> + 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) + ]} + + @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. *) + +(** The [Connection] module handles a single, possibly pipelined, http + connection. *) +module type Connection = sig + module Net : Net + + exception Retry + + type 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 create_tunnel : + ?finalise:(t -> unit Net.IO.t) -> ?ctx:Net.ctx -> t -> string -> t + + 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 + +(** A [Connection_cache] handles http requests. It not necessarily caches + connections. *) +module type Connection_cache = sig + type 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 + + module IO : IO with type 'a t = 'a Lwt.t + + (** @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:Http.Header.t -> + params:(string * string list) list -> + Uri.t -> + (Http.Response.t * Body.t) Lwt.t + + val callv : + ?ctx:ctx -> + Uri.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 + + 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 + [@@deprecated "Please use Cohttp.Path.resolve_local_file. "] + (** Resolve a URI and a docroot into a concrete local filename. *) + + val respond_error : + ?headers:Http.Header.t -> + ?status:Http.Status.t -> + body:string -> + unit -> + (Http.Response.t * body) IO.t + + val respond_redirect : + ?headers:Http.Header.t -> uri:Uri.t -> unit -> (Http.Response.t * body) IO.t + + val respond_need_auth : + ?headers:Http.Header.t -> + auth:Cohttp.Auth.challenge -> + unit -> + (Http.Response.t * body) IO.t + + val respond_not_found : ?uri:Uri.t -> unit -> (Http.Response.t * body) IO.t +end diff --git a/cohttp-lwt/src/server.ml b/cohttp-lwt/src/server.ml new file mode 100644 index 0000000..397b80e --- /dev/null +++ b/cohttp-lwt/src/server.ml @@ -0,0 +1,181 @@ +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 * Connection.t + + type response_action = + [ `Expert of Http.Response.t * (IO.ic -> IO.oc -> unit Lwt.t) + | `Response of Http.Response.t * Body.t ] + + type t = { + callback : conn -> Http.Request.t -> Body.t -> response_action Lwt.t; + conn_closed : conn -> unit; + } + + let make_response_action ?(conn_closed = ignore) ~callback () = + { conn_closed; callback } + + let make ?conn_closed ~callback () = + let callback conn req body = + callback conn req body >|= fun rsp -> `Response rsp + in + make_response_action ?conn_closed ~callback () + + let make_expert ?conn_closed ~callback () = + let callback conn req body = + callback conn req body >|= fun rsp -> `Expert rsp + in + make_response_action ?conn_closed ~callback () + + module Transfer_IO = Cohttp.Private.Transfer_io.Make (IO) + + let resolve_local_file ~docroot ~uri = + Cohttp.Path.resolve_local_file ~docroot ~uri + + let respond ?headers ~status ~body () = + let encoding = + match headers with + | None -> Body.transfer_encoding body + | Some headers -> ( + match Header.get_transfer_encoding headers with + | Http.Transfer.Unknown -> Body.transfer_encoding body + | t -> t) + in + let res = Response.make ~status ~encoding ?headers () in + Lwt.return (res, body) + + let respond_string ?headers ~status ~body () = + let res = + Response.make ~status + ~encoding:(Http.Transfer.Fixed (Int64.of_int (String.length body))) + ?headers () + in + let body = Body.of_string body in + Lwt.return (res, body) + + let respond_error ?headers ?(status = `Internal_server_error) ~body () = + respond_string ?headers ~status ~body:("Error: " ^ body) () + + let respond_redirect ?headers ~uri () = + let headers = + match headers with + | None -> Header.init_with "location" (Uri.to_string uri) + | Some h -> Header.add_unless_exists h "location" (Uri.to_string uri) + in + respond ~headers ~status:`Found ~body:`Empty () + + let respond_need_auth ?headers ~auth () = + let headers = match headers with None -> Header.init () | Some h -> h in + let headers = Header.add_authorization_req headers auth in + respond ~headers ~status:`Unauthorized ~body:`Empty () + + let respond_not_found ?uri () = + let body = + match uri with + | None -> "Not found" + | Some uri -> "Not found: " ^ Uri.to_string uri + in + respond_string ~status:`Not_found ~body () + + let read_body ic req = + 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 + Body.of_stream body_stream + | `No | `Unknown -> `Empty + + let handle_request callback conn req body = + Log.debug (fun m -> m "Handle request: %a." Request.pp_hum req); + Lwt.finalize + (fun () -> + Lwt.catch + (fun () -> callback conn req body) + (function + | Out_of_memory -> Lwt.reraise Out_of_memory + | exn -> + Log.err (fun f -> + f "Error handling %a: %s" Request.pp_hum req + (Printexc.to_string exn)); + respond_error ~body:"Internal Server Error" () >|= fun rsp -> + `Response rsp)) + (fun () -> Body.drain_body body) + + let handle_response ~keep_alive oc res body conn_closed handle_client = + IO.catch (fun () -> + Response.write ~flush:false + (fun writer -> Body.write_body (Response.write_body writer) body) + res oc) + >>= function + | Ok () -> + if keep_alive then handle_client oc + else + let () = conn_closed () in + Lwt.return_unit + | Error e -> + Log.info (fun m -> m "IO error while writing body: %a" IO.pp_error e); + conn_closed (); + Body.drain_body body + + let rec handle_client ic oc conn spec = + Request.read ic >>= function + | `Eof -> + spec.conn_closed conn; + Lwt.return_unit + | `Invalid data -> + Log.err (fun m -> m "invalid input %s while handling client" data); + spec.conn_closed conn; + Lwt.return_unit + | `Ok req -> ( + let body = read_body ic req in + handle_request spec.callback conn req body >>= function + | `Response (res, body) -> + 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) + | `Expert (res, io_handler) -> + Response.write_header res oc >>= fun () -> + io_handler ic oc >>= fun () -> handle_client ic oc conn spec) + + let callback spec io_id ic oc = + let conn_id = Connection.create () in + let conn_closed () = spec.conn_closed (io_id, conn_id) in + Lwt.catch + (fun () -> + IO.catch (fun () -> handle_client ic oc (io_id, conn_id) spec) + >>= function + | Ok () -> Lwt.return_unit + | Error e -> + Log.info (fun m -> + m "IO error while handling client: %a" IO.pp_error e); + conn_closed (); + Lwt.return_unit) + (fun e -> + conn_closed (); + Lwt.reraise e) +end diff --git a/cohttp-lwt/src/server.mli b/cohttp-lwt/src/server.mli new file mode 100644 index 0000000..fb0dccc --- /dev/null +++ b/cohttp-lwt/src/server.mli @@ -0,0 +1,7 @@ +(** The [Make] functor glues together a {!Cohttp.S.IO} implementation to send + requests down a connection that is established by the user. The resulting + module satisfies the {!Server} module type. + + The {!Logs} source name for this module's logger is ["cohttp.lwt.server"].*) + +module Make (IO : S.IO) : S.Server with module IO = IO diff --git a/cohttp-lwt/src/string_io.ml b/cohttp-lwt/src/string_io.ml new file mode 100644 index 0000000..dc58843 --- /dev/null +++ b/cohttp-lwt/src/string_io.ml @@ -0,0 +1,34 @@ +(*{{{ Copyright (c) 2014 Andy Ray + * Copyright (c) 2014 Anil Madhavapeddy + * + * 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. + * + }}}*) + +type 'a t = 'a Lwt.t + +let return = Lwt.return +let ( >>= ) = Lwt.bind + +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) +let flush oc = return (Sio.M.flush oc) diff --git a/cohttp-lwt/src/string_io.mli b/cohttp-lwt/src/string_io.mli new file mode 100644 index 0000000..b508d95 --- /dev/null +++ b/cohttp-lwt/src/string_io.mli @@ -0,0 +1,27 @@ +(*{{{ Copyright (c) 2014 Andy Ray + * Copyright (c) 2014 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(** Lwt IO implementation that uses strings to marshal and unmarshal HTTP *) + +(** 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.Private.String_io.buf + and type oc = Buffer.t diff --git a/cohttp-lwt/test/bytebuffer_tests.ml b/cohttp-lwt/test/bytebuffer_tests.ml new file mode 100644 index 0000000..05392a4 --- /dev/null +++ b/cohttp-lwt/test/bytebuffer_tests.ml @@ -0,0 +1,37 @@ +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" |}] diff --git a/cohttp-mirage-CHANGES.md b/cohttp-mirage-CHANGES.md new file mode 100644 index 0000000..0e07d1b --- /dev/null +++ b/cohttp-mirage-CHANGES.md @@ -0,0 +1,77 @@ +### 3.2.0 + +* Port to jbuilder + +### 3.1.0 + +* Add `Cohttp_mirage_static` module for serving static files from a + read-only key-value store. Includes magic mime detection. +* Improve the ocamldoc strings for the modules. +* Constrain supported OCaml version to 4.03.0+ or higher, as with Mirage 3.0. + +### 3.0.0 + +* Port to MirageOS 3 CHANNEL interface. +* Use Travis Docker for more multidistro testing. + +### 2.5.3 (13-06-2016) + +* Switch to topkg (#25, @samoht) +* Fix memory leak in the callback when an exception is raised (#24, @hannesm) + +### 2.5.2 (13-04-2016) + +* Fix memory leak by closing channel when callback is executed + (#23 via @hannesm) + +### 2.5.1 (15-09-2015) + +* Add a preapplied server with conduit (#20, by @Drup) + +### 2.5.0 (05-07-2015) + +* Depends on `channel` instead of the full `tcpip` stack + +### 2.4.0 (10-06-2015) + +* Support cohttp 0.18 (#13, by @rgrinberg) + +### 2.3.0 (29-05-2015) + +* Simplify the `Client` signature to be a simple module. It is not + a functor depending on `Conduit` anymore and the context is now + more explicit. +* Expose type equalities for `IO.conn` in the `Server` functor +* Adapt to conduit 0.8.4 + +### 2.2.0: (08-04-2015) + +* Do not user `lwt.syntax` +* Rename `HTTP` to `Cohttp_Mirage` (#9) +* Expose `Cohttp_mirage_io` +* Expose a `Server` functor which depends only on mirage's `FLOW` (no dependency + to `Conduit` anymore in this case) +* Modernize Travis CI scripts + +### 2.1.0 (05-12-2014): + +* Use the Conduit 0.7+ resolver API (provide `of_sexp` for context). +* Do not link against `camlp4` in the `META` file and only use it during build. + +### 2.0.0 (07-11-2014): + +* Use the Conduit 0.6+ resolver API. +* Add a local `opam` file for the OPAM 1.2.0 workflow. + +### 1.2.0 (03-05-2014): + +* Use the Cohttp.0.12.0 interface. + +### 1.1.0 (05-02-2014): + +* Functorize the HTTP Mirage layer, so that the library is now + OS-independent and compatible with Mirage 1.1.x signatures. + +### 1.0.0 (18-01-2013): + +* Initial public release. diff --git a/cohttp-mirage.opam b/cohttp-mirage.opam new file mode 100644 index 0000000..e60dfea --- /dev/null +++ b/cohttp-mirage.opam @@ -0,0 +1,63 @@ +version: "6.2.1" +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "CoHTTP implementation for the MirageOS unikernel" +description: """ +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 +without having a hard dependency on an underlying operating +system. + +Please see for a self-hosted explanation +and instructions on how to use this library.""" +maintainer: ["Anil Madhavapeddy "] +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"} + "mirage-flow" {>= "2.0.0"} + "mirage-channel" {>= "4.0.0"} + "conduit" {>= "8.0.0"} + "conduit-mirage" {>= "8.0.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} + "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-mirage/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp-mirage.opam.template b/cohttp-mirage.opam.template new file mode 100644 index 0000000..e887f36 --- /dev/null +++ b/cohttp-mirage.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp-mirage/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp-mirage/src/client.ml b/cohttp-mirage/src/client.ml new file mode 100644 index 0000000..c9475f3 --- /dev/null +++ b/cohttp-mirage/src/client.ml @@ -0,0 +1,29 @@ +(* + * Copyright (c) 2012-2015 Anil Madhavapeddy + * Copyright (c) 2013-2015 Thomas Gazagnaire + * + * 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. + * + * cohttp v6.2.1 + *) + +module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) = struct + module Net = Net.Make (R) (S) + module Connection = Cohttp_lwt.Connection.Make (Net) + include Cohttp_lwt.Client.Make (Connection) + + let ctx ?authenticator resolver conduit = + { Net.resolver; conduit = Some conduit; authenticator } + + let with_authenticator a ctx = { ctx with Net.authenticator = Some a } +end diff --git a/cohttp-mirage/src/client.mli b/cohttp-mirage/src/client.mli new file mode 100644 index 0000000..b4d1d9e --- /dev/null +++ b/cohttp-mirage/src/client.mli @@ -0,0 +1,7 @@ +module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) : sig + 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 +end diff --git a/cohttp-mirage/src/cohttp_mirage.ml b/cohttp-mirage/src/cohttp_mirage.ml new file mode 100644 index 0000000..75871cb --- /dev/null +++ b/cohttp-mirage/src/cohttp_mirage.ml @@ -0,0 +1,21 @@ +(** 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 diff --git a/cohttp-mirage/src/dune b/cohttp-mirage/src/dune new file mode 100644 index 0000000..a318811 --- /dev/null +++ b/cohttp-mirage/src/dune @@ -0,0 +1,14 @@ +(library + (name cohttp_mirage) + (public_name cohttp-mirage) + (synopsis "Mirage backend for cohttp") + (preprocess + (pps ppx_sexp_conv)) + (libraries + conduit-mirage + cohttp-lwt + mirage-channel + mirage-kv + mirage-flow + magic-mime + astring)) diff --git a/cohttp-mirage/src/input_channel.ml b/cohttp-mirage/src/input_channel.ml new file mode 100644 index 0000000..7b1b1f3 --- /dev/null +++ b/cohttp-mirage/src/input_channel.ml @@ -0,0 +1,34 @@ +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 diff --git a/cohttp-mirage/src/io.ml b/cohttp-mirage/src/io.ml new file mode 100644 index 0000000..13f74dc --- /dev/null +++ b/cohttp-mirage/src/io.ml @@ -0,0 +1,72 @@ +(* + * Copyright (c) 2012-2015 Anil Madhavapeddy + * Copyright (c) 2013-2015 Thomas Gazagnaire + * + * 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. + * + * cohttp v6.2.1 + *) + +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 + + let pp_error f = function + | Read_error e -> Channel.pp_error f e + | Write_error e -> Channel.pp_write_error f e + + type 'a t = 'a Lwt.t + type ic = Input_channel.t + type oc = Channel.t + type conn = Channel.flow + + exception Write_exn of Channel.write_error + + let () = + Printexc.register_printer (function + | 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 = 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 -> 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 *) + Lwt.return_unit + + let ( >>= ) = Lwt.( >>= ) + let return = Lwt.return + + let catch f = + Lwt.try_bind f Lwt.return_ok (function + | Input_channel.Read_exn e -> Lwt.return_error (Read_error e) + | Write_exn e -> Lwt.return_error (Write_error e) + | ex -> Lwt.reraise ex) +end diff --git a/cohttp-mirage/src/io.mli b/cohttp-mirage/src/io.mli new file mode 100644 index 0000000..07e4127 --- /dev/null +++ b/cohttp-mirage/src/io.mli @@ -0,0 +1,26 @@ +(* + * Copyright (c) 2012-2015 Anil Madhavapeddy + * Copyright (c) 2013-2015 Thomas Gazagnaire + * + * 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. + * + * cohttp v6.2.1 + *) + +(** Cohttp IO implementation using Mirage channels. *) + +module Make (Channel : Mirage_channel.S) : + Cohttp_lwt.S.IO + with type ic = Input_channel.Make(Channel).t + and type oc = Channel.t + and type conn = Channel.flow diff --git a/cohttp-mirage/src/make.ml b/cohttp-mirage/src/make.ml new file mode 100644 index 0000000..ecaa69a --- /dev/null +++ b/cohttp-mirage/src/make.ml @@ -0,0 +1,14 @@ +open Lwt.Infix + +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 (Input_channel.create ch) ch) + (fun () -> Channel.close ch >|= fun _ -> ()) +end diff --git a/cohttp-mirage/src/make.mli b/cohttp-mirage/src/make.mli new file mode 100644 index 0000000..920bcf6 --- /dev/null +++ b/cohttp-mirage/src/make.mli @@ -0,0 +1,6 @@ +(** HTTP server. *) +module Server (Flow : Mirage_flow.S) : sig + include Cohttp_lwt.S.Server with type IO.conn = Flow.flow + + val listen : t -> IO.conn -> unit Lwt.t +end diff --git a/cohttp-mirage/src/net.ml b/cohttp-mirage/src/net.ml new file mode 100644 index 0000000..249363a --- /dev/null +++ b/cohttp-mirage/src/net.ml @@ -0,0 +1,47 @@ +module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) = struct + module Channel = Mirage_channel.Make (S.Flow) + module Input_channel = Input_channel.Make (Channel) + 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 + type client + + let tunnel _ _ = failwith "Unimplemented" + let connect_client ~ctx:_ _ = failwith "Unimplemented" + let resolve ~ctx uri = R.resolve_uri ~uri ctx.resolver + + let connect_endp ~ctx endp = + Conduit_mirage.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 diff --git a/cohttp-mirage/src/net.mli b/cohttp-mirage/src/net.mli new file mode 100644 index 0000000..ee48f2f --- /dev/null +++ b/cohttp-mirage/src/net.mli @@ -0,0 +1,9 @@ +module Make (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 diff --git a/cohttp-mirage/src/server.ml b/cohttp-mirage/src/server.ml new file mode 100644 index 0000000..0359167 --- /dev/null +++ b/cohttp-mirage/src/server.ml @@ -0,0 +1,26 @@ +open Lwt.Infix + +module type S = sig + include Cohttp_lwt.S.Server + + val callback : t -> IO.conn -> unit Lwt.t +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 (Input_channel.create ch) ch) + (fun () -> Channel.close ch >|= fun _ -> ()) +end + +module Make (S : Conduit_mirage.S) = struct + include Flow (S.Flow) + + let listen s conf t = S.listen s conf (callback t) +end diff --git a/cohttp-mirage/src/server.mli b/cohttp-mirage/src/server.mli new file mode 100644 index 0000000..c3cd1af --- /dev/null +++ b/cohttp-mirage/src/server.mli @@ -0,0 +1,16 @@ +(** HTTP server with conduit. *) + +module type S = sig + include Cohttp_lwt.S.Server + + val callback : t -> IO.conn -> unit Lwt.t +end + +module Flow (F : Mirage_flow.S) : S with type IO.conn = F.flow + +module Make (S : Conduit_mirage.S) : sig + include S with type IO.conn = S.flow + + val callback : t -> S.flow -> unit Lwt.t + val listen : S.t -> Conduit_mirage.server -> t -> unit Lwt.t +end diff --git a/cohttp-mirage/src/static.ml b/cohttp-mirage/src/static.ml new file mode 100644 index 0000000..4de1b2c --- /dev/null +++ b/cohttp-mirage/src/static.ml @@ -0,0 +1,83 @@ +(* + * Copyright (c) 2012-2017 Anil Madhavapeddy + * Copyright (c) 2013-2015 Thomas Gazagnaire + * + * 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. + * + * cohttp v6.2.1 + *) + +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.failwith fmt + + let read_fs t name = + FS.get t (Key.v name) >>= function + | Error e -> failf "read %a" FS.pp_error e + | Ok buf -> Lwt.return buf + + let exists t name = + FS.exists t (Key.v name) >|= function + | Ok (Some `Value) -> true + | Ok (Some _ | None) -> false + | Error e -> Fmt.failwith "exists %a" FS.pp_error e + + let dispatcher request_fn = + let rec fn fs uri = + match Uri.path uri with + | ("" | "/") as path -> + Logs.info (fun f -> f "request for '%s'" path); + fn fs (Uri.with_path uri "index.html") + | path when String.is_suffix ~affix:"/" path -> + Logs.info (fun f -> f "request for '%s'" path); + fn fs (Uri.with_path uri "index.html") + | path -> + Logs.info (fun f -> f "request for '%s'" path); + Lwt.catch + (fun () -> + read_fs fs path >>= fun body -> + let mime_type = Magic_mime.lookup path in + let headers = Cohttp.Header.init_with "content-type" mime_type in + let headers = + match request_fn with + | None -> headers + | Some fn -> fn uri headers + in + S.respond_string ~status:`OK ~body ~headers ()) + (fun _exn -> + let with_index = Fmt.str "%s/index.html" path in + exists fs with_index >>= function + | true -> fn fs (Uri.with_path uri with_index) + | false -> S.respond_not_found ()) + in + fn + + let start ~http_port ?request_fn fs http = + let callback (_, cid) request _body = + let uri = Cohttp.Request.uri request 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 = 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); + http (`TCP http_port) (S.make ~conn_closed ~callback ()) +end diff --git a/cohttp-mirage/src/static.mli b/cohttp-mirage/src/static.mli new file mode 100644 index 0000000..f443f3d --- /dev/null +++ b/cohttp-mirage/src/static.mli @@ -0,0 +1,38 @@ +(* + * Copyright (c) 2012-2017 Anil Madhavapeddy + * Copyright (c) 2013-2015 Thomas Gazagnaire + * + * 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. + * + * cohttp v6.2.1 + *) + +(** Serve static HTTP sites from a Mirage key-value store. *) + +(** Plain HTTP file serving from a read-only key-value store. *) +module HTTP (FS : Mirage_kv.RO) (S : Cohttp_lwt.S.Server) : sig + (** [start http_port ?request_fn fs http] will start a static HTTP server + listening on [http_port]. The files to serve will be looked up from the + [fs] key-value store. + + If [request_fn] is supplied, the URI and default header set (including the + MIME content-type header) will be passed to it and the response used as + the response header set instead. *) + + val start : + http_port:int -> + ?request_fn:(Uri.t -> Http.Header.t -> Http.Header.t) -> + FS.t -> + ([> `TCP of int ] -> S.t -> 'a) -> + 'a +end diff --git a/cohttp-server-lwt-unix.opam b/cohttp-server-lwt-unix.opam new file mode 100644 index 0000000..24dba0c --- /dev/null +++ b/cohttp-server-lwt-unix.opam @@ -0,0 +1,50 @@ +version: "6.2.1" +# 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 "] +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} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp-server-lwt-unix.opam.template b/cohttp-server-lwt-unix.opam.template new file mode 100644 index 0000000..8b29608 --- /dev/null +++ b/cohttp-server-lwt-unix.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp-server-lwt-unix/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.ml b/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.ml new file mode 100644 index 0000000..054ac93 --- /dev/null +++ b/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.ml @@ -0,0 +1,357 @@ +(*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy + * + * 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 diff --git a/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.mli b/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.mli new file mode 100644 index 0000000..4eb6809 --- /dev/null +++ b/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.mli @@ -0,0 +1,104 @@ +(** 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. *) diff --git a/cohttp-server-lwt-unix/src/dune b/cohttp-server-lwt-unix/src/dune new file mode 100644 index 0000000..d475f10 --- /dev/null +++ b/cohttp-server-lwt-unix/src/dune @@ -0,0 +1,4 @@ +(library + (name cohttp_server_lwt_unix) + (public_name cohttp-server-lwt-unix) + (libraries lwt lwt.unix http http_bytebuffer)) diff --git a/cohttp-server-lwt-unix/test/dune b/cohttp-server-lwt-unix/test/dune new file mode 100644 index 0000000..5b49216 --- /dev/null +++ b/cohttp-server-lwt-unix/test/dune @@ -0,0 +1,11 @@ +(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)) diff --git a/cohttp-server-lwt-unix/test/test.ml b/cohttp-server-lwt-unix/test/test.ml new file mode 100644 index 0000000..762b28f --- /dev/null +++ b/cohttp-server-lwt-unix/test/test.ml @@ -0,0 +1,48 @@ +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) diff --git a/cohttp-top.opam b/cohttp-top.opam new file mode 100644 index 0000000..3006517 --- /dev/null +++ b/cohttp-top.opam @@ -0,0 +1,47 @@ +version: "6.2.1" +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +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 "] +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"} + "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 + "@install" + "@cohttp-top/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp-top.opam.template b/cohttp-top.opam.template new file mode 100644 index 0000000..a9e1f00 --- /dev/null +++ b/cohttp-top.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp-top/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp-top/src/cohttp_top.ml b/cohttp-top/src/cohttp_top.ml new file mode 100644 index 0000000..461b675 --- /dev/null +++ b/cohttp-top/src/cohttp_top.ml @@ -0,0 +1,18 @@ +let printers = + [ "Cohttp.Header.pp_hum"; "Cohttp.Request.pp_hum"; "Cohttp.Response.pp_hum" ] + +let eval_string ?(print_outcome = false) ?(err_formatter = Format.err_formatter) + str = + let lexbuf = Lexing.from_string str in + let phrase = !Toploop.parse_toplevel_phrase lexbuf in + Toploop.execute_phrase print_outcome err_formatter phrase + +let rec install_printers = function + | [] -> true + | printer :: printers -> + let cmd = Printf.sprintf "#install_printer %s;;" printer in + eval_string cmd && install_printers printers + +let () = + if not (install_printers printers) then + Format.eprintf "Problem installing Cohttp-printers@." diff --git a/cohttp-top/src/dune b/cohttp-top/src/dune new file mode 100644 index 0000000..e81b71c --- /dev/null +++ b/cohttp-top/src/dune @@ -0,0 +1,4 @@ +(library + (name cohttp_top) + (public_name cohttp-top) + (libraries cohttp compiler-libs.toplevel)) diff --git a/cohttp.opam b/cohttp.opam new file mode 100644 index 0000000..bded151 --- /dev/null +++ b/cohttp.opam @@ -0,0 +1,69 @@ +version: "6.2.1" +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "An OCaml library for HTTP clients and servers" +description: """ +Cohttp is an OCaml library for creating HTTP daemons. It has a portable +HTTP parser, and implementations using various asynchronous programming +libraries. + +See the cohttp-async, cohttp-lwt, cohttp-lwt-unix, cohttp-lwt-jsoo and +cohttp-mirage libraries for concrete implementations for particular +targets. + +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. + +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. +""" +maintainer: ["Anil Madhavapeddy "] +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"} + "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} + "ipaddr" {>= "5.6.0"} + "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/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/cohttp.opam.template b/cohttp.opam.template new file mode 100644 index 0000000..eb9d8fa --- /dev/null +++ b/cohttp.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@cohttp/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/cohttp/src/accept.ml b/cohttp/src/accept.ml new file mode 100644 index 0000000..f65bbe8 --- /dev/null +++ b/cohttp/src/accept.ml @@ -0,0 +1,97 @@ +(*{{{opyright (C) 2012, David Sheets + + Permission to use, copy, modify, and/or 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. + }}}*) +(* TODO: handle exceptions better *) + +open Printf +include Accept_types +module Parser = Accept_parser +module Lexer = Accept_lexer + +let qsort l = + let compare ((i : int), _) (i', _) = + (* The inversion is on purpose, we sort the biggest quality first. *) + compare i' i + in + List.stable_sort compare l + +let parse_using p s = p Lexer.header_value (Lexing.from_string s) + +let media_ranges = function + | Some s -> parse_using Parser.media_ranges s + | None -> [ (1000, (AnyMedia, [])) ] + +let charsets = function + | Some s -> parse_using Parser.charsets s + | None -> [ (1000, AnyCharset) ] + +let encodings = function + | Some s -> parse_using Parser.encodings s + | None -> [ (1000, AnyEncoding) ] + +let languages = function + | Some s -> parse_using Parser.languages s + | None -> [ (1000, AnyLanguage) ] + +let rec string_of_pl = function + | [] -> "" + | (k, v) :: r -> + let e = Stringext.quote v in + if v = e then sprintf ";%s=%s%s" k v (string_of_pl r) + else sprintf ";%s=\"%s\"%s" k e (string_of_pl r) + +let string_of_q = function + | q when q < 0 -> invalid_arg (Printf.sprintf "qvalue %d must be positive" q) + | q when q > 1000 -> + invalid_arg (Printf.sprintf "qvalue %d must be less than 1000" q) + | 1000 -> "1" + | q -> Printf.sprintf "0.%03d" q + +let accept_el el pl q = sprintf "%s;q=%s%s" el (string_of_q q) (string_of_pl pl) + +let string_of_media_range = function + | MediaType (t, st), pl -> accept_el (sprintf "%s/%s" t st) pl + | AnyMediaSubtype t, pl -> accept_el (sprintf "%s/*" t) pl + | AnyMedia, pl -> accept_el "*/*" pl + +let string_of_charset = function + | Charset c -> accept_el c [] + | AnyCharset -> accept_el "*" [] + +let string_of_encoding = function + | Encoding e -> accept_el e [] + | Gzip -> accept_el "gzip" [] + | Compress -> accept_el "compress" [] + | Deflate -> accept_el "deflate" [] + | Identity -> accept_el "identity" [] + | AnyEncoding -> accept_el "*" [] + +let string_of_language = function + | Language langl -> accept_el (String.concat "-" langl) [] + | AnyLanguage -> accept_el "*" [] + +let string_of_list s_of_el = + let rec aux s = function + | [ (q, el) ] -> s ^ s_of_el el q + | [] -> s + | (q, el) :: r -> aux (s ^ s_of_el el q ^ ",") r + in + aux "" + +let string_of_media_ranges = string_of_list string_of_media_range +let string_of_charsets = string_of_list string_of_charset +let string_of_encodings = string_of_list string_of_encoding +let string_of_languages = string_of_list string_of_language diff --git a/cohttp/src/accept.mli b/cohttp/src/accept.mli new file mode 100644 index 0000000..585502a --- /dev/null +++ b/cohttp/src/accept.mli @@ -0,0 +1,69 @@ +(*{{{ Copyright (C) 2012, David Sheets + + Permission to use, copy, modify, and/or 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. + }}}*) + +(** Accept-Encoding HTTP header parsing and generation *) + +type q = int [@@deriving sexp] +(** Qualities are integers between 0 and 1000. A header with ["q=0.7"] + corresponds to a quality of [700]. *) + +type 'a qlist = (q * 'a) list [@@deriving sexp] +(** Lists, annotated with qualities. *) + +val qsort : 'a qlist -> 'a qlist +(** Sort by quality, biggest first. Respect the initial ordering. *) + +type p = string * string [@@deriving sexp] + +type media_range = Accept_types.media_range = + | MediaType of string * string + | AnyMediaSubtype of string + | AnyMedia +[@@deriving sexp] + +type charset = Accept_types.charset = Charset of string | AnyCharset +[@@deriving sexp] + +type encoding = Accept_types.encoding = + | Encoding of string + | Gzip + | Compress + | Deflate + | Identity + | AnyEncoding +[@@deriving sexp] + +(** Basic language range tag. ["en-gb"] is represented as + [Language ["en"; "gb"]]. + + @see the specification. +*) +type language = Accept_types.language = Language of string list | AnyLanguage +[@@deriving sexp] + +val media_ranges : string option -> (media_range * p list) qlist +val charsets : string option -> charset qlist +val encodings : string option -> encoding qlist +val languages : string option -> language qlist +val string_of_media_range : media_range * p list -> q -> string +val string_of_charset : charset -> q -> string +val string_of_encoding : encoding -> q -> string +val string_of_language : language -> q -> string +val string_of_media_ranges : (media_range * p list) qlist -> string +val string_of_charsets : charset qlist -> string +val string_of_encodings : encoding qlist -> string +val string_of_languages : language qlist -> string diff --git a/cohttp/src/accept_lexer.mll b/cohttp/src/accept_lexer.mll new file mode 100644 index 0000000..47d1e18 --- /dev/null +++ b/cohttp/src/accept_lexer.mll @@ -0,0 +1,37 @@ +(*{{{ Copyright (C) 2012, David Sheets + + Permission to use, copy, modify, and/or 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 Accept_parser +} + +(* *) +let token = [^'('')''<''>''@'','';'':''\\''"''/''['']''?''=''{''}'' ''\t'] + +rule header_value = parse + | '*' { STAR } + | '/' { SLASH } + | ';' { SEMI } + | ',' { COMMA } + | '=' { EQUAL } + | '\"' { QS (List.fold_right (^) (qs [] lexbuf) "") } + | (token)+ as tok { TOK tok } + | ' ' { header_value lexbuf } + | eof { EOI } +and qs sl = parse + | "\\\"" { qs ("\""::sl) lexbuf } + | "\"" { sl } + | [^'"']+ as s { qs (s::sl) lexbuf } diff --git a/cohttp/src/accept_parser.mly b/cohttp/src/accept_parser.mly new file mode 100644 index 0000000..26fa8da --- /dev/null +++ b/cohttp/src/accept_parser.mly @@ -0,0 +1,105 @@ +/* + Copyright (C) 2012, David Sheets + + Permission to use, copy, modify, and/or 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 Accept_types + + type param = Q of int | Kv of p + + let rec get_q = function + | (Q q)::_ -> q + | _::r -> get_q r + | [] -> 1000 + + let get_rest pl = List.fold_right + (function Kv p -> fun l -> p::l | Q _ -> fun l -> l) pl [] +%} + +%token STAR SLASH SEMI COMMA EQUAL EOI +%token TOK QS +%start media_ranges charsets encodings languages +%type <(Accept_types.media_range * Accept_types.p list) Accept_types.qlist> media_ranges +%type charsets +%type encodings +%type languages +%% + +param : +| SEMI TOK EQUAL QS { Kv ($2, $4) } +| SEMI TOK EQUAL TOK { + if $2="q" then try Q (truncate (1000.*.(float_of_string $4))) + with Failure _ -> raise Parsing.Parse_error + else Kv ($2, $4) +} + +params : +| param params { $1::$2 } +| { [] } + +media_range : +| STAR SLASH STAR params { + (get_q $4, (AnyMedia, get_rest $4)) +} +| TOK SLASH STAR params { + (get_q $4, (AnyMediaSubtype (String.lowercase_ascii $1), get_rest $4)) +} +| TOK SLASH TOK params { + (get_q $4, (MediaType (String.lowercase_ascii $1, String.lowercase_ascii $3), get_rest $4)) +} + +media_ranges : +| media_range EOI { [$1] } +| media_range COMMA media_ranges { $1::$3 } +| EOI { [] } + +charset : +| TOK params { (get_q $2, Charset (String.lowercase_ascii $1)) } +| STAR params { (get_q $2, AnyCharset) } + +charsets : +| charset EOI { [$1] } +| charset COMMA charsets { $1::$3 } + +encoding : +| TOK params { + (get_q $2, match (String.lowercase_ascii $1) with + | "gzip" -> Gzip + | "compress" -> Compress + | "deflate" -> Deflate + | "identity" -> Identity + | enc -> Encoding enc + ) +} +| STAR params { (get_q $2, AnyEncoding) } + +encodings : +| encoding EOI { [$1] } +| encoding COMMA encodings { $1::$3 } +| EOI { [] } + +language : +| TOK params { + (get_q $2, Language (String.split_on_char '-' (String.lowercase_ascii $1))) +} +| STAR params { (get_q $2, AnyLanguage) } + +languages : +| language EOI { [$1] } +| language COMMA languages { $1::$3 } + +%% diff --git a/cohttp/src/accept_types.ml b/cohttp/src/accept_types.ml new file mode 100644 index 0000000..5692815 --- /dev/null +++ b/cohttp/src/accept_types.ml @@ -0,0 +1,43 @@ +(*{{{ Copyright (C) 2012, David Sheets + + Permission to use, copy, modify, and/or 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. + }}}*) + +(** Type definitions for the {!Accept} module *) + +open Sexplib0.Sexp_conv + +type p = string * string [@@deriving sexp] + +type media_range = + | MediaType of string * string + | AnyMediaSubtype of string + | AnyMedia +[@@deriving sexp] + +type charset = Charset of string | AnyCharset [@@deriving sexp] + +type encoding = + | Encoding of string + | Gzip + | Compress + | Deflate + | Identity + | AnyEncoding +[@@deriving sexp] + +type language = Language of string list | AnyLanguage [@@deriving sexp] +type q = int [@@deriving sexp] +type 'a qlist = (q * 'a) list [@@deriving sexp] diff --git a/cohttp/src/auth.ml b/cohttp/src/auth.ml new file mode 100644 index 0000000..545f3fe --- /dev/null +++ b/cohttp/src/auth.ml @@ -0,0 +1,41 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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 Sexplib0.Sexp_conv +open Printf + +type challenge = [ `Basic of string (* realm *) ] [@@deriving sexp] + +type credential = + [ `Basic of string * string (* username, password *) | `Other of string ] +[@@deriving sexp] + +let string_of_credential (cred : credential) = + match cred with + | `Basic (user, pass) -> + "Basic " ^ Base64.encode_string (sprintf "%s:%s" user pass) + | `Other buf -> buf + +let credential_of_string (buf : string) : credential = + try + let b64 = Scanf.sscanf buf "Basic %s" (fun b -> b) in + match Stringext.split ~on:':' (Base64.decode_exn b64) ~max:2 with + | [ user; pass ] -> `Basic (user, pass) + | _ -> `Other buf + with _ -> `Other buf + +let string_of_challenge (ty : challenge) = + match ty with `Basic realm -> sprintf "Basic realm=\"%s\"" realm diff --git a/cohttp/src/auth.mli b/cohttp/src/auth.mli new file mode 100644 index 0000000..19f1c3a --- /dev/null +++ b/cohttp/src/auth.mli @@ -0,0 +1,48 @@ +(*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(** HTTP Authentication and Authorization header parsing and generation *) + +type challenge = [ `Basic of string (** Basic authentication within a realm *) ] +[@@deriving sexp] +(** HTTP authentication challenge types *) + +type credential = + [ `Basic of string * string + (** Basic authorization with a username and password *) + | `Other of string + (** An unknown credential type that will be passed straight through to the + application layer *) ] +[@@deriving sexp] +(** HTTP authorization credential types *) + +val string_of_credential : credential -> string +(** [string_of_credential] converts the {!credential} to a string compatible + with the HTTP/1.1 wire format for authorization credentials ("responses") *) + +val credential_of_string : string -> credential +(** [credential_of_string cred_s] converts an HTTP response to an authentication + challenge into a {!credential}. If the credential is not recognized, + [`Other cred_s] is returned. *) + +val string_of_challenge : challenge -> string +(** [string_of_challenge challenge] converts the {!challenge} to a string + compatible with the HTTP/1.1 wire format for authentication challenges. + + For example, a [`Basic] challenge with realm ["foo"] will be marshalled to + ["Basic realm=foo"], which can then be combined with a [www-authenticate] + HTTP header and sent back to the client. There is a helper function + {!Header.add_authorization_req} that does just this. *) diff --git a/cohttp/src/body.ml b/cohttp/src/body.ml new file mode 100644 index 0000000..23c32c4 --- /dev/null +++ b/cohttp/src/body.ml @@ -0,0 +1,65 @@ +(*{{{ Copyright (c) 2014 Rudi Grinberg + * + * 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 Sexplib0.Sexp_conv + +type t = [ `Empty | `String of string | `Strings of string list ] +[@@deriving sexp] + +let empty = `Empty + +let is_empty = function + | `Empty | `String "" -> true + | `String _ -> false + | `Strings xs -> ( + match List.filter (fun s -> s <> "") xs with [] -> true | _ -> false) + +let to_string = function + | `Empty -> "" + | `String s -> s + | `Strings sl -> String.concat "" sl + +let to_string_list = function + | `Empty -> [] + | `String s -> [ s ] + | `Strings sl -> sl + +let of_string s = `String s +let of_string_list s = `Strings s + +let transfer_encoding = function + | `Empty -> Transfer.Fixed 0L + | `String s -> Transfer.Fixed (Int64.of_int (String.length s)) + | `Strings _ -> Transfer.Chunked + +let length = function + | `Empty -> 0L + | `String s -> Int64.of_int (String.length s) + | `Strings sl -> + sl + |> List.fold_left + (fun a b -> b |> String.length |> Int64.of_int |> Int64.add a) + 0L + +let map f = function + | `Empty -> `Empty + | `String s -> `String (f s) + | `Strings sl -> `Strings (List.map f sl) + +let to_form t = Uri.query_of_encoded (to_string t) +let of_form ?scheme f = Uri.encoded_of_query ?scheme f |> of_string + +(* TODO: maybe add a functor here that uses IO.S *) diff --git a/cohttp/src/body.mli b/cohttp/src/body.mli new file mode 100644 index 0000000..5a721af --- /dev/null +++ b/cohttp/src/body.mli @@ -0,0 +1,29 @@ +(*{{{ Copyright (c) 2014 Rudi Grinberg + * Copyright (c) 2014 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(** HTTP request and response body handling *) + +type t = [ `Empty | `String of string | `Strings of string list ] +[@@deriving sexp] +(** Every HTTP body can at least be an empty value or a [string] *) + +include S.Body with type t := t +(** Signature for the core of HTTP body handling. Implementations will extend + this signature to add more functions for streaming responses via + backend-specific functionality. *) + +val length : t -> int64 diff --git a/cohttp/src/client.ml b/cohttp/src/client.ml new file mode 100644 index 0000000..8b37c72 --- /dev/null +++ b/cohttp/src/client.ml @@ -0,0 +1,105 @@ +let src = Logs.Src.create "cohttp.client" ~doc:"Cohttp Client module" + +module Log = (val Logs.src_log src) + +(** 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 () = Log.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 diff --git a/cohttp/src/code.ml b/cohttp/src/code.ml new file mode 100644 index 0000000..066ca67 --- /dev/null +++ b/cohttp/src/code.ml @@ -0,0 +1,141 @@ +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 diff --git a/cohttp/src/code.mli b/cohttp/src/code.mli new file mode 100644 index 0000000..d6d9792 --- /dev/null +++ b/cohttp/src/code.mli @@ -0,0 +1,190 @@ +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. *) diff --git a/cohttp/src/cohttp.ml b/cohttp/src/cohttp.ml new file mode 100644 index 0000000..76f7486 --- /dev/null +++ b/cohttp/src/cohttp.ml @@ -0,0 +1,26 @@ +module Accept = Accept +module Auth = Auth +module Body = Body +module Conf = Conf +module Connection = Connection [@@deprecated "Connection.t values are useless."] +module Code = Code +module Cookie = Cookie +module Header = Header +module Link = Link +module Proxy = Proxy +module Request = Request +module Response = Response +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 diff --git a/cohttp/src/conf.mli b/cohttp/src/conf.mli new file mode 100644 index 0000000..e8e75a5 --- /dev/null +++ b/cohttp/src/conf.mli @@ -0,0 +1,21 @@ +(*{{{ Copyright (c) 2015 Christophe Troestler + * Copyright (c) 2015 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(** Compile-time configuration variables *) + +val version : string +(** The version number of this library. *) diff --git a/cohttp/src/connection.ml b/cohttp/src/connection.ml new file mode 100644 index 0000000..7aebaa7 --- /dev/null +++ b/cohttp/src/connection.ml @@ -0,0 +1,28 @@ +(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy + * Copyright (c) 2013 Thomas Gazagnaire + * + * 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 Sexplib0.Sexp_conv + +type t = int [@@deriving sexp] + +let to_string = string_of_int +let count = ref 0 + +let create () = + incr count; + !count + +let compare (a : t) (b : t) = Stdlib.compare a b diff --git a/cohttp/src/connection.mli b/cohttp/src/connection.mli new file mode 100644 index 0000000..eb2ee66 --- /dev/null +++ b/cohttp/src/connection.mli @@ -0,0 +1,31 @@ +(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy + * Copyright (c) 2013 Thomas Gazagnaire + * + * 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. + * + }}}*) + +(** Connection identifiers. *) + +type t [@@deriving sexp] +(** Abstract type for connection identifiers. *) + +val create : unit -> t +(** Create a fresh connection identifier. *) + +val to_string : t -> string +(** Pretty-print a connection identifier. *) + +val compare : t -> t -> int +(** Comparison function for two identifiers. More recently constructed + identifiers will be greater than older ones. *) diff --git a/cohttp/src/cookie.ml b/cohttp/src/cookie.ml new file mode 100644 index 0000000..1ae47cc --- /dev/null +++ b/cohttp/src/cookie.ml @@ -0,0 +1,182 @@ +(*{{{ Copyright (C) <2012> Anil Madhavapeddy + * Copyright (C) <2009> David Sheets + * + * 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 Sexplib0.Sexp_conv + +type expiration = [ `Session | `Max_age of int64 ] [@@deriving sexp] +type cookie = string * string [@@deriving sexp] + +module Set_cookie_hdr = struct + type t = { + cookie : cookie; + expiration : expiration; + domain : string option; + path : string option; + secure : bool; + http_only : bool; + } + [@@deriving sexp] + + let cookie t = t.cookie + let expiration t = t.expiration + let domain t = t.domain + let path t = t.path + let secure t = t.secure + let http_only t = t.http_only + + (* Does not check the contents of name or value for ';', ',', '\s', or name[0]='$' *) + let make ?(expiration = `Session) ?path ?domain ?(secure = false) + ?(http_only = false) cookie = + { cookie; expiration; domain; path; secure; http_only } + + (* TODO: deprecated by RFC 6265 and almost certainly buggy without + reference to cookie field *) + let serialize_1_1 c = + let attrs = [ "Version=1" ] in + let attrs = if c.secure then "Secure" :: attrs else attrs in + let attrs = + match c.path with None -> attrs | Some p -> ("Path=" ^ p) :: attrs + in + let attrs = + match c.expiration with + | `Session -> "Discard" :: attrs + | `Max_age age -> ("Max-Age=" ^ Int64.to_string age) :: attrs + in + let attrs = + match c.domain with None -> attrs | Some d -> ("Domain=" ^ d) :: attrs + in + ("Set-Cookie2", String.concat "; " attrs) + + let serialize_1_0 c = + let attrs = if c.http_only then [ "httponly" ] else [] in + let attrs = if c.secure then "secure" :: attrs else attrs in + let attrs = + match c.path with None -> attrs | Some p -> ("path=" ^ p) :: attrs + in + let attrs = + match c.domain with None -> attrs | Some d -> ("domain=" ^ d) :: attrs + in + let attrs = + match c.expiration with + | `Session -> attrs + | `Max_age age -> ("Max-Age=" ^ Int64.to_string age) :: attrs + in + let n, c = c.cookie in + (* TODO: may be buggy, some UAs will ignore cookie-strings without '='*) + let attrs = (n ^ match c with "" -> "" | v -> "=" ^ v) :: attrs in + ("Set-Cookie", String.concat "; " attrs) + + let serialize ?(version = `HTTP_1_0) c = + match version with + | `HTTP_1_0 -> serialize_1_0 c + | `HTTP_1_1 -> serialize_1_1 c + + (* TODO: implement *) + let extract_1_1 _cstr alist = alist + + let extract_1_0 cstr alist = + let attrs = Stringext.split_trim_left cstr ~on:",;" ~trim:" \t" in + let attrs = + List.map + (fun attr -> + match String.split_on_char '=' attr with + | [] -> ("", "") + | n :: v -> (n, String.concat "=" v)) + attrs + in + try + let cookie = List.hd attrs in + let attrs = + List.map (fun (n, v) -> (String.lowercase_ascii n, v)) (List.tl attrs) + in + let path = + try + let v = List.assoc "path" attrs in + if v = "" || v.[0] <> '/' then raise Not_found else Some v + with Not_found -> None + in + let domain = + try + let v = List.assoc "domain" attrs in + if v = "" then raise Not_found + else + Some + (String.lowercase_ascii + (if v.[0] = '.' then Stringext.string_after v 1 else v)) + with Not_found -> None + in + (* TODO: trim wsp *) + ( fst cookie, + { + cookie; + (* TODO: respect expires attribute *) + expiration = `Session; + domain; + path; + http_only = List.mem_assoc "httponly" attrs; + secure = List.mem_assoc "secure" attrs; + } ) + :: alist + with Failure _ -> alist + + (* 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 + else if caseless_equal k "set-cookie2" then extract_1_1 c a + else a) + hdr [] + + let value { cookie = _, v; _ } = v +end + +module Cookie_hdr = struct + (* RFC 2965 has + cookie = "Cookie:" cookie-version 1*((";" | ",") cookie-value) + cookie-value = NAME "=" VALUE [";" path] [";" domain] [";" port] + cookie-version = "$Version" "=" value + NAME = attr + VALUE = value + path = "$Path" "=" value + domain = "$Domain" "=" value + port = "$Port" [ "=" <"> value <"> ] + *) + + let extract hdr = + List.fold_left + (fun acc header -> + let comps = Stringext.split_trim_left ~on:";" ~trim:" \t" header in + (* We don't handle $Path, $Domain, $Port, $Version (or $anything + $else) *) + let cookies = + List.filter (fun s -> String.length s > 0 && s.[0] != '$') comps + in + let split_pair nvp = + match Stringext.split ~on:'=' nvp ~max:2 with + | [] -> ("", "") + | [ n ] -> (n, "") + | n :: v :: _ -> (n, v) + in + List.map split_pair cookies @ acc) + [] + (Header.get_multi hdr "cookie") + + let serialize cookies = + ("cookie", String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) cookies)) +end diff --git a/cohttp/src/cookie.mli b/cohttp/src/cookie.mli new file mode 100644 index 0000000..70a0a8e --- /dev/null +++ b/cohttp/src/cookie.mli @@ -0,0 +1,93 @@ +(*{{{ Copyright (C) <2012> Anil Madhavapeddy + * Copyright (C) <2009> David Sheets + * + * 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. + * + }}}*) + +(** Functions for the HTTP Cookie and Set-Cookie header fields. Using the + Set-Cookie header field, an HTTP server can pass name/value pairs and + associated metadata (called cookies) to a user agent. When the user agent + makes subsequent requests to the server, the user agent uses the metadata + and other information to determine whether to return the name/value pairs in + the Cookie header. *) + +type expiration = + [ `Session + (** Instructs the user agent to discard the cookie unconditionally when the + user agent terminates. *) + | `Max_age of int64 + (** The value of the Max-Age attribute is delta-seconds, the lifetime of the + cookie in seconds, a decimal non-negative integer. *) ] +[@@deriving sexp] +(** Lifetime of the cookie after which the user agent discards it *) + +type cookie = string * string +(** A cookie is simply a key/value pair send from the client to the server *) + +module Set_cookie_hdr : sig + type t = { + cookie : cookie; + expiration : expiration; + domain : string option; + path : string option; + secure : bool; + http_only : bool; + } + [@@deriving sexp] + (** A header which a server sends to a client to request that the client + returns the cookie in future requests, under certain conditions. *) + + val make : + ?expiration:expiration -> + ?path:string -> + ?domain:string -> + ?secure:bool -> + ?http_only:bool -> + cookie -> + t + + val serialize : ?version:[ `HTTP_1_0 | `HTTP_1_1 ] -> t -> string * string + (** Return an HTTP header *) + + val extract : Header.t -> (string * t) list + (** Return the list of cookies sent by the server *) + + val cookie : t -> cookie + (** The name-value binding *) + + val value : t -> string + (** The value *) + + val expiration : t -> expiration + (** The expiration *) + + val domain : t -> string option + (** The domain for which the cookie is valid, if any *) + + val path : t -> string option + (** The path for which the cookie is valid, if any *) + + val secure : t -> bool + (** Has the cookie's secure attribute been set? *) + + val http_only : t -> bool +end + +module Cookie_hdr : sig + val extract : Header.t -> cookie list + (** Return the list of cookies sent by the client *) + + val serialize : cookie list -> string * string + (** [serialize cookies] returns an HTTP header containing [cookies] *) +end diff --git a/cohttp/src/dune b/cohttp/src/dune new file mode 100644 index 0000000..836e379 --- /dev/null +++ b/cohttp/src/dune @@ -0,0 +1,26 @@ +(rule + (with-stdout-to + conf.ml + (echo "let version = \"%{version:cohttp}\""))) + +(library + (name cohttp) + (public_name cohttp) + (synopsis "Co-operative Client/Server HTTP library.") + (preprocess + (pps ppx_sexp_conv)) + (libraries + base64 + ipaddr + logs + (re_export http) + re + sexplib0 + stringext + uri + uri-sexp + uri.services)) + +(ocamllex accept_lexer) + +(ocamlyacc accept_parser) diff --git a/cohttp/src/header.ml b/cohttp/src/header.ml new file mode 100644 index 0000000..9f9b3ca --- /dev/null +++ b/cohttp/src/header.ml @@ -0,0 +1,98 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * Copyright (c) 2011-2012 Martin Jambon + * Copyright (c) 2010 Mika Illouz + * + * 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. + * + }}}*) + +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 s = + try + let subs = Re.exec ~pos:0 media_type_re s in + let start, stop = Re.Group.offset subs 1 in + Some (String.sub s start (stop - start)) + with Not_found -> None + +(* 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 s + | None -> None + +let get_acceptable_media_ranges headers = + Accept.media_ranges (get_multi_concat ~list_value_only:true headers "accept") + +let get_acceptable_charsets headers = + Accept.charsets + (get_multi_concat ~list_value_only:true headers "accept-charset") + +let get_acceptable_encodings headers = + Accept.encodings + (get_multi_concat ~list_value_only:true headers "accept-encoding") + +let get_acceptable_languages headers = + Accept.languages + (get_multi_concat ~list_value_only:true headers "accept-language") + +let add_authorization_req headers challenge = + add headers "www-authenticate" (Auth.string_of_challenge challenge) + +let add_authorization headers cred = + add headers "authorization" (Auth.string_of_credential cred) + +let get_authorization headers = + match get headers "authorization" with + | None -> None + | Some v -> Some (Auth.credential_of_string v) + +let is_form headers = + get_media_type headers = Some "application/x-www-form-urlencoded" + +let get_location headers = + match get_location headers with + | None -> None + | Some u -> Some (Uri.of_string u) + +let get_links headers = + List.rev + (List.fold_left + (fun list link_s -> List.rev_append (Link.of_string link_s) list) + [] (get_multi headers "link")) + +let add_links headers links = + add_multi headers "link" (List.map Link.to_string links) + +let user_agent = Printf.sprintf "ocaml-cohttp/%s" Conf.version + +let prepend_user_agent headers user_agent = + let k = "user-agent" in + match get headers k with + | Some ua -> replace headers k (user_agent ^ " " ^ ua) + | None -> add headers k user_agent + +open Sexplib0.Sexp_conv + +let sexp_of_t t = + sexp_of_list (sexp_of_pair sexp_of_string sexp_of_string) (to_list t) + +let t_of_sexp s = + of_list (list_of_sexp (pair_of_sexp string_of_sexp string_of_sexp) s) + +let pp_hum ppf h = + Format.fprintf ppf "%s" (h |> sexp_of_t |> Sexplib0.Sexp.to_string_hum) diff --git a/cohttp/src/header.mli b/cohttp/src/header.mli new file mode 100644 index 0000000..0405e2d --- /dev/null +++ b/cohttp/src/header.mli @@ -0,0 +1,229 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(** 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). *) +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] + 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 it associated value [v] at the end + 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 : (string -> string -> unit) -> t -> unit +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_media_type : t -> string option +val get_connection_close : t -> bool + +val get_acceptable_media_ranges : + t -> (Accept.media_range * Accept.p list) Accept.qlist + +val get_acceptable_charsets : t -> Accept.charset Accept.qlist +val get_acceptable_encodings : t -> Accept.encoding Accept.qlist +val get_acceptable_languages : t -> Accept.language Accept.qlist +val get_transfer_encoding : t -> Transfer.encoding +val add_transfer_encoding : t -> Transfer.encoding -> t +val add_authorization : t -> Auth.credential -> t +val get_authorization : t -> Auth.credential option +val add_authorization_req : t -> Auth.challenge -> t +val is_form : t -> bool +val get_location : t -> Uri.t option +val add_links : t -> Link.t list -> t +val get_links : t -> Link.t list + +val user_agent : string +(** The User-Agent header used by this library, including the version of cohttp. +*) + +val prepend_user_agent : t -> string -> t +(** Prepend [user_agent] to the product token already declared in the + "User-Agent" field (if any). *) + +val connection : t -> [ `Keep_alive | `Close | `Unknown of string ] option + +val pp_hum : Format.formatter -> t -> unit +(** Human-readable output, used by the toplevel printer *) diff --git a/cohttp/src/header_io.ml b/cohttp/src/header_io.ml new file mode 100644 index 0000000..eb12ae9 --- /dev/null +++ b/cohttp/src/header_io.ml @@ -0,0 +1,41 @@ +(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy + * Copyright (c) 2011-2012 Martin Jambon + * Copyright (c) 2010 Mika Illouz + * + * 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. + * + }}}*) + +let split_header str = + match Stringext.split ~max:2 ~on:':' str with + | [ x; y ] -> [ x; String.trim y ] + | x -> x + +module Make (IO : S.IO) = struct + open IO + module Transfer_IO = Transfer_io.Make (IO) + + let parse ic = + (* consume also trailing "^\r\n$" line *) + let rec parse_headers' headers = + read_line ic >>= function + | Some "" | None -> return headers + | Some line -> ( + match split_header line with + | [ hd; tl ] -> parse_headers' (Header.add headers hd tl) + | _ -> return headers) + in + parse_headers' (Header.init ()) + + let write headers oc = IO.write oc (Header.to_string headers) +end diff --git a/cohttp/src/header_io.mli b/cohttp/src/header_io.mli new file mode 100644 index 0000000..0274fc9 --- /dev/null +++ b/cohttp/src/header_io.mli @@ -0,0 +1,20 @@ +(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy + * + * 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 Make (IO : S.IO) : sig + val parse : IO.ic -> Header.t IO.t + val write : Header.t -> IO.oc -> unit IO.t +end diff --git a/cohttp/src/link.ml b/cohttp/src/link.ml new file mode 100644 index 0000000..0fd676b --- /dev/null +++ b/cohttp/src/link.ml @@ -0,0 +1,536 @@ +(*{{{ Copyright (c) 2015 David Sheets + * + * 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 Sexplib0.Sexp_conv + +(* From *) +module Rel = struct + type t = + | Extension of Uri_sexp.t + | Alternate + | Appendix + | Bookmark + | Chapter + | Contents + | Copyright + | Current + | Described_by + | Edit + | Edit_media + | Enclosure + | First + | Glossary + | Help + | Hub + | Index + | Last + | Latest_version + | License + | Next + | Next_archive + | Payment + | Predecessor_version + | Prev + | Prev_archive + | Related + | Replies + | Section + | Self + | Service + | Start + | Stylesheet + | Subsection + | Successor_version + | Up + | Version_history + | Via + | Working_copy + | Working_copy_of + [@@deriving sexp] + + let extension uri = Extension uri + let alternate = Alternate + let appendix = Appendix + let bookmark = Bookmark + let chapter = Chapter + let contents = Contents + let copyright = Copyright + let current = Current + let described_by = Described_by + let edit = Edit + let edit_media = Edit_media + let enclosure = Enclosure + let first = First + let glossary = Glossary + let help = Help + let hub = Hub + let index = Index + let last = Last + let latest_version = Latest_version + let license = License + let next = Next + let next_archive = Next_archive + let payment = Payment + let predecessor_version = Predecessor_version + let prev = Prev + let prev_archive = Prev_archive + let related = Related + let replies = Replies + let section = Section + let self = Self + let service = Service + let start = Start + let stylesheet = Stylesheet + let subsection = Subsection + let successor_version = Successor_version + let up = Up + let version_history = Version_history + let via = Via + let working_copy = Working_copy + let working_copy_of = Working_copy_of +end + +module Language = struct + type t = string [@@deriving sexp] + + let to_string x = x + let of_string x = x +end + +module Charset = struct + type t = string [@@deriving sexp] + + let to_string x = x + let of_string x = x +end + +module Ext = struct + type 'a t = { charset : Charset.t; language : Language.t; value : 'a } + [@@deriving sexp] + + let charset t = t.charset + let language t = t.language + let value t = t.value + let make ?(charset = "") ?(language = "") value = { charset; language; value } + let map f x = { x with value = f x.value } +end + +module Arc = struct + type t = { + reverse : bool; + relation : Rel.t list; + hreflang : string option; + media : string option; + title : string option; + title_ext : string Ext.t option; + media_type : (string * string) option; + extensions : (string * string) list; + extension_exts : (string * string Ext.t) list; + } + [@@deriving sexp] + + let empty = + { + reverse = false; + relation = []; + hreflang = None; + media = None; + title = None; + title_ext = None; + media_type = None; + extensions = []; + extension_exts = []; + } +end + +type t = { context : Uri_sexp.t; arc : Arc.t; target : Uri_sexp.t } +[@@deriving sexp] + +(* TODO: this could be replaced with empty t/arc fupdate *) +type param = + | Rel of Rel.t list + | Anchor of Uri.t + | Rev of Rel.t list + | Hreflang of Language.t + | Media of string + | Title of string + | Star of param Ext.t + | Type of (string * string) + | Link_extension of string * string + +let until s start cl = + let nextl = + List.map + (fun c -> + let pattern = String.make 1 c in + Stringext.find_from ~start s ~pattern) + cl + in + let min = + List.fold_left + (fun min_opt i_opt -> + match (min_opt, i_opt) with + | None, None -> None + | Some i, None | None, Some i -> Some i + | Some i, Some j -> Some (min i j)) + None nextl + in + match min with + | None -> (Stringext.string_after s start, String.length s) + | Some i -> (String.sub s start (i - start), i) + +let string_of_rel = + Rel.( + function + | Alternate -> "alternate" + | Appendix -> "appendix" + | Bookmark -> "bookmark" + | Chapter -> "chapter" + | Contents -> "contents" + | Copyright -> "copyright" + | Current -> "current" + | Described_by -> "describedby" + | Edit -> "edit" + | Edit_media -> "edit-media" + | Enclosure -> "enclosure" + | First -> "first" + | Glossary -> "glossary" + | Help -> "help" + | Hub -> "hub" + | Index -> "index" + | Last -> "last" + | Latest_version -> "latest-version" + | License -> "license" + | Next -> "next" + | Next_archive -> "next-archive" + | Payment -> "payment" + | Predecessor_version -> "predecessor-version" + | Prev -> "prev" + | Prev_archive -> "prev-archive" + | Related -> "related" + | Replies -> "replies" + | Section -> "section" + | Self -> "self" + | Service -> "service" + | Start -> "start" + | Stylesheet -> "stylesheet" + | Subsection -> "subsection" + | Successor_version -> "successor-version" + | Up -> "up" + | Version_history -> "version-history" + | Via -> "via" + | Working_copy -> "working-copy" + | Working_copy_of -> "working-copy-of" + | Extension uri -> Uri.to_string uri) + +let rel_of_string s = + Rel.( + try + ignore (String.index s ':'); + Extension (Uri.of_string s) + with Not_found -> ( + match s with + | "alternate" -> Alternate + | "appendix" -> Appendix + | "bookmark" -> Bookmark + | "chapter" -> Chapter + | "contents" -> Contents + | "copyright" -> Copyright + | "current" -> Current + | "describedby" -> Described_by + | "edit" -> Edit + | "edit-media" -> Edit_media + | "enclosure" -> Enclosure + | "first" -> First + | "glossary" -> Glossary + | "help" -> Help + | "hub" -> Hub + | "index" -> Index + | "last" -> Last + | "latest-version" -> Latest_version + | "license" -> License + | "next" -> Next + | "next-archive" -> Next_archive + | "payment" -> Payment + | "predecessor-version" -> Predecessor_version + | "prev" | "previous" -> Prev + | "prev-archive" -> Prev_archive + | "related" -> Related + | "replies" -> Replies + | "section" -> Section + | "self" -> Self + | "service" -> Service + | "start" -> Start + | "stylesheet" -> Stylesheet + | "subsection" -> Subsection + | "successor-version" -> Successor_version + | "up" -> Up + | "version-history" -> Version_history + | "via" -> Via + | "working-copy" -> Working_copy + | "working-copy-of" -> Working_copy_of + | _ -> Extension (Uri.of_string s))) + +let quoted_string_of_string s q = + let rec first_quote q = + match s.[q] with + | ' ' -> first_quote (q + 1) + | '"' -> ( + let q = q + 1 in + match Stringext.find_from ~start:q s ~pattern:"\"" with + | None -> (Stringext.string_after s q, String.length s) + | Some q' -> (String.sub s q (q' - q), q' + 1)) + | _ -> until s q [ ';'; ',' ] + in + first_quote q + +let rels_of_string_ s q = + let qs, i = quoted_string_of_string s q 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 = + match + (Stringext.find_from ~start:i s ~pattern:"\"", until s i [ ';'; ',' ]) + with + | Some q, (_, d) when q < d -> rels_of_string_ s q + | _, (s, d) -> ([ rel_of_string s ], d) + +let anchor_of_string s i = + let qs, i = quoted_string_of_string s i in + (Uri.of_string qs, i) + +let star_of_string s i = + match Stringext.find_from ~start:i s ~pattern:"'" with + | None -> + let s, i = quoted_string_of_string s i in + ("", "", s, i) + | Some a -> ( + let charset = String.sub s i (a - i) in + let i = a + 1 in + match Stringext.find_from ~start:i s ~pattern:"'" with + | None -> + let s, i = quoted_string_of_string s i in + (charset, "", s, i) + | Some a -> + let language = String.sub s i (a - i) in + let i = a + 1 in + let s, i = quoted_string_of_string s i in + (charset, language, s, i)) + +let media_type_of_string s i = + let mt, i = quoted_string_of_string s i in + match Stringext.split ~max:2 mt ~on:'/' with + | [] -> (("", ""), i) + | [ t ] -> ((t, ""), i) + | t :: st :: _ -> ((t, st), i) + +let rec params_of_string s i ps = + let _, d = until s i [ ';'; ',' ] in + if d = String.length s then (ps, None) + else if s.[d] = ',' then (ps, Some d) + else + let i = d + 1 in + let param, i = until s i [ '=' ] in + let i = i + 1 in + match String.trim param with + | "rel" -> + let rels, i = rels_of_string s i in + params_of_string s i (Rel rels :: ps) + | "anchor" -> + let uri, i = anchor_of_string s i in + params_of_string s i (Anchor uri :: ps) + | "rev" -> + let rels, i = rels_of_string s i in + params_of_string s i (Rev rels :: ps) + | "hreflang" -> + let hreflang, i = until s i [ ','; ';' ] in + params_of_string s i (Hreflang hreflang :: ps) + | "media" -> + let media, i = quoted_string_of_string s i in + params_of_string s i (Media media :: ps) + | "title" -> + let title, i = quoted_string_of_string s i in + params_of_string s i (Title title :: ps) + | "title*" -> + let charset, language, v, i = star_of_string s i in + params_of_string s i + (Star { Ext.charset; language; value = Title v } :: ps) + | "type" -> + let media_type, i = media_type_of_string s i in + params_of_string s i (Type media_type :: ps) + | other when String.length other = 0 -> + let s, i = quoted_string_of_string s i in + params_of_string s i (Link_extension ("", s) :: ps) + | other -> + let last = String.length other - 1 in + if other.[last] = '*' then + let main = String.sub other 0 last in + let charset, language, v, i = star_of_string s i in + params_of_string s i + (Star { Ext.charset; language; value = Link_extension (main, v) } + :: ps) + else + let v, i = quoted_string_of_string s i in + params_of_string s i (Link_extension (other, v) :: ps) + +let rec find_or_default f d = function + | [] -> d + | h :: t -> ( match f h with None -> find_or_default f d t | Some v -> v) + +let arc_of_relation_params ?(reverse = false) relation params = + let extensions, extension_exts = + List.fold_left + (fun (x, xx) -> function + | Link_extension (k, v) -> ((k, v) :: x, xx) + | Star { Ext.charset; language; value = Link_extension (k, value) } -> + (x, (k, { Ext.charset; language; value }) :: xx) + | _ -> (x, xx)) + ([], []) params + in + { + Arc.reverse; + relation; + hreflang = + find_or_default + (function Hreflang l -> Some (Some l) | _ -> None) + None params; + media = + find_or_default + (function Media m -> Some (Some m) | _ -> None) + None params; + title = + find_or_default + (function Title t -> Some (Some t) | _ -> None) + None params; + title_ext = + find_or_default + (function + | Star { Ext.charset; language; value = Title t } -> + Some (Some { Ext.charset; language; value = t }) + | _ -> None) + None params; + media_type = + find_or_default + (function Type mt -> Some (Some mt) | _ -> None) + None params; + extensions; + extension_exts; + } + +let empty = + { context = Uri.of_string ""; arc = Arc.empty; target = Uri.of_string "" } + +let rec unfold s list start = + match Stringext.find_from ~start s ~pattern:"<" with + | None -> list + | Some i -> ( + let uri_ref, i = until s (i + 1) [ '>' ] in + let i = i + 1 in + let target = Uri.of_string uri_ref in + let params, c_opt = params_of_string s i [] in + let params = List.rev params in + let context = + find_or_default + (function Anchor uri -> Some uri | _ -> None) + (Uri.of_string "") params + in + let link = + match + find_or_default + (function Rel rels -> Some rels | _ -> None) + [] params + with + | _ :: _ as relation -> + let arc = arc_of_relation_params relation params in + { context; arc; target } + | [] -> ( + match + find_or_default + (function Rev rels -> Some rels | _ -> None) + [] params + with + | [] -> + let arc = arc_of_relation_params [] params in + { context; arc; target } + | rev -> + let arc = arc_of_relation_params ~reverse:true rev params in + { context = target; arc; target = context }) + in + let list = link :: list in + match c_opt with None -> list | Some c -> unfold s list c) + +let of_string s = List.rev (unfold s [] 0) + +open Printf + +let arc_to_string context arc = + Arc.( + let attrs = + match arc.relation with + | [] -> [] + | rels -> + [ + sprintf "%s=\"%s\"" + (if arc.reverse then "rev" else "rel") + (String.concat " " (List.map string_of_rel rels)); + ] + in + let attrs = + match arc.hreflang with + | None -> attrs + | Some s -> ("hreflang=" ^ s) :: attrs + in + let attrs = + match arc.media with + | None -> attrs + | Some s -> sprintf "media=\"%s\"" s :: attrs + in + let attrs = + match arc.title with + | None -> attrs + | Some s -> sprintf "title=%S" s :: attrs + (* TODO: this isn't quite right...*) + in + let attrs = + match arc.title_ext with + | None -> attrs + | Some { Ext.charset; language; value } -> + sprintf "title*=%s'%s'%s" charset language value :: attrs + in + let attrs = + match arc.media_type with + | None -> attrs + | Some (typ, sub) -> sprintf "type=%s/%s" typ sub :: attrs + in + let attrs = + List.map (fun (k, v) -> sprintf "%s=%S" k v) arc.extensions @ attrs + in + let attrs = + List.map + (fun (k, { Ext.charset; language; value }) -> + sprintf "%s=%s'%s'%s" k charset language value) + arc.extension_exts + @ attrs + in + let attrs = + if context = Uri.of_string "" then attrs + else sprintf "anchor=\"%s\"" (Uri.to_string context) :: attrs + in + String.concat "; " attrs) + +let to_string { context; arc; target } = + sprintf "<%s>; %s" (Uri.to_string target) (arc_to_string context arc) diff --git a/cohttp/src/link.mli b/cohttp/src/link.mli new file mode 100644 index 0000000..8f32cda --- /dev/null +++ b/cohttp/src/link.mli @@ -0,0 +1,109 @@ +(*{{{ Copyright (c) 2015 David Sheets + * + * 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. + * + }}}*) + +(** RFC 5988 ("Web Linking") and RFC 5987 ("Character Set and Language Encoding + for Hypertext Transfer Protocol (HTTP) Header Field Parameters") *) + +module Rel : sig + type t [@@deriving sexp] + + val extension : Uri.t -> t + val alternate : t + val appendix : t + val bookmark : t + val chapter : t + val contents : t + val copyright : t + val current : t + val described_by : t + val edit : t + val edit_media : t + val enclosure : t + val first : t + val glossary : t + val help : t + val hub : t + val index : t + val last : t + val latest_version : t + val license : t + val next : t + val next_archive : t + val payment : t + val predecessor_version : t + val prev : t + val prev_archive : t + val related : t + val replies : t + val section : t + val self : t + val service : t + val start : t + val stylesheet : t + val subsection : t + val successor_version : t + val up : t + val version_history : t + val via : t + val working_copy : t + val working_copy_of : t +end + +module Language : sig + type t = private string [@@deriving sexp] + + val to_string : t -> string + val of_string : string -> t +end + +module Charset : sig + type t = private string [@@deriving sexp] + + val to_string : t -> string + val of_string : string -> t +end + +module Ext : sig + type 'a t [@@deriving sexp] + + val charset : 'a t -> Charset.t + val language : 'a t -> Language.t + val value : 'a t -> 'a + val make : ?charset:Charset.t -> ?language:Language.t -> 'a -> 'a t + val map : ('a -> 'b) -> 'a t -> 'b t +end + +module Arc : sig + type t = { + reverse : bool; + relation : Rel.t list; + hreflang : string option; + media : string option; + title : string option; + title_ext : string Ext.t option; + media_type : (string * string) option; + extensions : (string * string) list; + extension_exts : (string * string Ext.t) list; + } + + val empty : t +end + +type t = { context : Uri.t; arc : Arc.t; target : Uri.t } [@@deriving sexp] + +val empty : t +val of_string : string -> t list +val to_string : t -> string diff --git a/cohttp/src/path.ml b/cohttp/src/path.ml new file mode 100644 index 0000000..cd614ce --- /dev/null +++ b/cohttp/src/path.ml @@ -0,0 +1,7 @@ +let resolve_local_file ~docroot ~uri = + let path = Uri.(pct_decode (path (resolve "http" (of_string "/") uri))) in + let rel_path = + if String.length path > 0 then String.sub path 1 (String.length path - 1) + else "" + in + Filename.concat docroot rel_path diff --git a/cohttp/src/path.mli b/cohttp/src/path.mli new file mode 100644 index 0000000..6019015 --- /dev/null +++ b/cohttp/src/path.mli @@ -0,0 +1,6 @@ +val resolve_local_file : docroot:string -> uri:Uri.t -> string +(** Resolve the given URI to a local file in the given docroot. + + This decodes and normalises the Uri. It strips out .. characters so that the + request will not escape the docroot. The returned filepath is fully + qualified iff the given docroot is fully qualified. *) diff --git a/cohttp/src/proxy.ml b/cohttp/src/proxy.ml new file mode 100644 index 0000000..5f5251b --- /dev/null +++ b/cohttp/src/proxy.ml @@ -0,0 +1,130 @@ +module Forward = struct + type pattern = Name of string | Ipaddr_prefix of Ipaddr.Prefix.t + type no_proxy_patterns = Wildcard | Patterns of pattern list + + (* Used to ignore trailing dots in hostnames, as per + https://github.com/curl/curl/blob/49ef2f8d1ef78e702c73f5d72242301cc2a0157e/lib/noproxy.c#L170-L172 + + When [first_leading = true], it also trims the first leading dot, as per + https://github.com/curl/curl/blob/49ef2f8d1ef78e702c73f5d72242301cc2a0157e/lib/noproxy.c#L198-L201 *) + let trim_dots ~first_leading s = + let len = String.length s in + let i = ref 0 in + if first_leading && !i < len && String.unsafe_get s !i = '.' then incr i; + let j = ref (len - 1) in + while !j >= !i && String.unsafe_get s !j = '.' do + decr j + done; + if !j >= !i then String.sub s !i (!j - !i + 1) else "" + + let strncasecompare a b n = + let a = String.(sub a 0 (min (length a) n) |> lowercase_ascii) + and b = String.(sub b 0 (min (length b) n) |> lowercase_ascii) in + String.equal a b + + let no_proxy_from_env_value no_proxy = + match no_proxy with + | None -> Patterns [] + | Some no_proxy -> + if no_proxy = "*" then Wildcard + else + let patterns = + no_proxy + |> String.split_on_char ',' + |> List.filter_map (fun pattern -> + if pattern = "" then None else Some (String.trim pattern)) + |> List.map (fun pattern -> + match Ipaddr.of_string pattern with + | Ok addr -> Ipaddr_prefix (Ipaddr.Prefix.of_addr addr) + | Error _ -> ( + match Ipaddr.Prefix.of_string pattern with + | Ok prefix -> Ipaddr_prefix prefix + | Error _ -> Name (trim_dots ~first_leading:true pattern) + )) + in + Patterns patterns + + let check_no_proxy uri pattern = + let host = Uri.host_with_default ~default:"" uri in + if String.length host = 0 then true + else + match pattern with + | Wildcard -> true + | Patterns patterns -> ( + match Ipaddr.of_string host with + | Ok hostip -> + List.exists + (function + | Name _ -> false + | Ipaddr_prefix network -> Ipaddr.Prefix.mem hostip network) + patterns + | Error _ -> + let name = trim_dots ~first_leading:false host in + List.exists + (function + | Ipaddr_prefix _ -> false + | Name pattern -> + let patternlen = String.length pattern + and namelen = String.length name in + if patternlen = namelen then + (* An exact (case-insensitive) match *) + strncasecompare pattern name namelen + else if patternlen < namelen then + (* pattern is a (case-insensitive) suffix of the host, + starting after any subdomain prefix. + + E.g., [example.com] is a suffix of [www.example.com] and + [home.example.com], but not of [nonexample.com]. *) + let match_start = namelen - patternlen in + let host_suffix = + String.sub name match_start patternlen + in + name.[match_start - 1] = '.' + && strncasecompare pattern host_suffix patternlen + else false) + patterns) + + type ('direct, 'tunnel) t = Direct of 'direct | Tunnel of 'tunnel + + type ('direct, 'tunnel) servers = { + by_scheme : (string * ('direct, 'tunnel) t) list; + no_proxy_patterns : no_proxy_patterns; + default_tunnel : ('direct, 'tunnel) t option; + default_direct : ('direct, 'tunnel) t option; + } + + (* Uri schemes that should be used with tunnelled proxies *) + let is_tunnel_scheme = function "https" -> true | _ -> false + + let make_servers ~no_proxy_patterns ~(default_proxy : Uri.t option) + ~(scheme_proxies : (string * Uri.t) list) ~(direct : Uri.t -> 'direct) + ~(tunnel : Uri.t -> 'tunnel) : ('direct, 'tunnel) servers = + let by_scheme = + List.map + (fun (scheme, uri) -> + let proxy = + if is_tunnel_scheme scheme then Tunnel (tunnel uri) + else Direct (direct uri) + in + (scheme, proxy)) + scheme_proxies + in + let no_proxy_patterns = no_proxy_from_env_value no_proxy_patterns in + let default_tunnel, default_direct = + match default_proxy with + | None -> (None, None) + | Some uri -> (Some (Tunnel (tunnel uri)), Some (Direct (direct uri))) + in + { by_scheme; no_proxy_patterns; default_tunnel; default_direct } + + let get (servers : ('direct, 'tunnel) servers) (uri : Uri.t) : + ('direct, 'tunnel) t option = + if check_no_proxy uri servers.no_proxy_patterns then None + else + let scheme = Option.value ~default:"" (Uri.scheme uri) in + match List.assoc scheme servers.by_scheme with + | proxy -> Some proxy + | exception Not_found -> + if is_tunnel_scheme scheme then servers.default_tunnel + else servers.default_direct +end diff --git a/cohttp/src/proxy.mli b/cohttp/src/proxy.mli new file mode 100644 index 0000000..ba4a43d --- /dev/null +++ b/cohttp/src/proxy.mli @@ -0,0 +1,46 @@ +(** Utilities for configuring and reasoning about forward proxies for client + requests *) +module Forward : sig + type ('direct, 'tunnel) servers + (** A configuration for forward proxy servers *) + + (** A forward proxying connection *) + type ('direct, 'tunnel) t = + | Direct of 'direct (** A proxy providing direct forwarding *) + | Tunnel of 'tunnel + (** A proxy using a tunnel (i.e. for https connections)) *) + + val make_servers : + no_proxy_patterns:string option -> + default_proxy:Uri.t option -> + scheme_proxies:(string * Uri.t) list -> + direct:(Uri.t -> 'direct) -> + tunnel:(Uri.t -> 'tunnel) -> + ('direct, 'tunnel) servers + (** Create a new configuration of proxy servers + + @param no_proxy_patterns + Disable proxies for specific hosts, specified as curl's [NO_PROXY]. + @see + + @param default_proxy + The default proxy to use. Proxy for specific schemes have precedence + over this. + + @param scheme_proxies + A mapping of (remote) scheme's to the desired proxy URI to user for + calls with that scheme. + + @param direct + A function to create ['direct] connections for the given proxy URI. + + @param tunnel + A function to create ['tunnel] connections for the given proxy URI. *) + + val get : ('direct, 'tunnel) servers -> Uri.t -> ('direct, 'tunnel) t option + (** [get proxies uri] finds the proxy configured for the [uri], if there is + one given [proxies]. + + @param servers The configured proxy servers + @param uri The URI to find a proxy server for *) +end diff --git a/cohttp/src/request.ml b/cohttp/src/request.ml new file mode 100644 index 0000000..cd5f937 --- /dev/null +++ b/cohttp/src/request.ml @@ -0,0 +1,227 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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 Sexplib0.Sexp_conv + +type t = Http.Request.t = { + headers : Header.t; + meth : Code.meth; + resource : string; + version : Code.version; +} +[@@deriving sexp] + +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 resource t = t.resource +let version t = t.version +let encoding t = Header.get_transfer_encoding t.headers + +let make ?(meth = `GET) ?(version = `HTTP_1_1) ?encoding + ?(headers = Header.init ()) ?(absolute_form = false) uri = + let port () = + match Uri.port uri with + | Some p -> ":" ^ string_of_int p + | None when meth = `CONNECT -> ( + match Uri_services.tcp_port_of_uri uri with + | None -> failwith "A port is required for the CONNECT method." + | Some p -> ":" ^ string_of_int p) + | None -> "" + in + let host = + match Header.get headers "host" with + | None -> ( + match Uri.scheme uri with + | Some "httpunix" -> "" + | _ -> Uri.host_with_default ~default:"localhost" uri ^ port ()) + | Some host -> if String.contains host ':' then host else host ^ port () + in + + let headers = Header.replace headers "host" host in + let headers = + Header.add_unless_exists headers "user-agent" Header.user_agent + in + let headers = + (* Add user:password auth to headers from uri + * if headers don't already have auth *) + match + (Header.get_authorization headers, Uri.user uri, Uri.password uri) + with + | None, Some user, Some pass -> + let auth = `Basic (user, pass) in + Header.add_authorization headers auth + | _, _, _ -> headers + in + let resource = + if absolute_form then Uri.to_string uri else 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 ?body_length ?absolute_form meth uri = + let encoding = + 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 ?absolute_form uri + +let pp_hum ppf r = + Format.fprintf ppf "%s" (r |> sexp_of_t |> Sexplib0.Sexp.to_string_hum) + +(* Validate path when reading URI. Implemented for compatibility with old + implementation rather than efficiency *) +let is_valid_uri path meth = + path = "*" + || meth = `CONNECT + || + match Uri.scheme (Uri.of_string path) with + | Some _ -> true + | None -> not (String.length path > 0 && path.[0] <> '/') + +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 *) + 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) + 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 + +module Make (IO : S.IO) = struct + type t = tt + + module IO = IO + module Header_IO = Header_io.Make (IO) + module Transfer_IO = Transfer_io.Make (IO) + + type reader = Transfer_IO.reader + type writer = Transfer_IO.writer + + open IO + + 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) + + let make_body_reader req ic = + Transfer_IO.make_reader (Header.get_transfer_encoding req.headers) ic + + let read_body_chunk = Transfer_IO.read + + let write_header req oc = + let fst_line = + Printf.sprintf "%s %s %s\r\n" + (Http.Method.to_string req.meth) + (if req.meth = `CONNECT then Option.get (Header.get req.headers "host") + else if req.resource = "" then "/" + else req.resource) + (Http.Version.to_string req.version) + in + IO.write oc fst_line >>= fun _ -> Header_IO.write req.headers 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 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 = + write_header req oc >>= fun () -> + 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 diff --git a/cohttp/src/request.mli b/cohttp/src/request.mli new file mode 100644 index 0000000..525a594 --- /dev/null +++ b/cohttp/src/request.mli @@ -0,0 +1,39 @@ +(*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(** HTTP/1.1 request handling *) + +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 *) + +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 diff --git a/cohttp/src/response.ml b/cohttp/src/response.ml new file mode 100644 index 0000000..bfc532d --- /dev/null +++ b/cohttp/src/response.ml @@ -0,0 +1,139 @@ +(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy + * + * 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. + * + }}}*) + +type t = Http.Response.t = { + headers : Header.t; + version : Code.version; + status : Code.status_code; +} +[@@deriving sexp] + +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 = Header.get_transfer_encoding t.headers +let version t = t.version +let status t = t.status + +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 + { 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 + type t = tt + + module IO = IO + module Header_IO = Header_io.Make (IO) + module Transfer_IO = Transfer_io.Make (IO) + + type reader = Transfer_IO.reader + type writer = Transfer_IO.writer + + open IO + + let parse_response_fst_line ic = + let open Code in + read_line ic >>= function + | Some response_line -> ( + 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 -> + return (`Ok (v, status_of_code (int_of_string code_raw))) + | `Other _ -> + return (`Invalid ("Malformed response version: " ^ version_raw)) + ) + | _ -> + return + (`Invalid ("Malformed response first line: " ^ response_line))) + | None -> return `Eof + + let read ic = + parse_response_fst_line ic >>= function + | `Eof -> return `Eof + | `Invalid _reason as r -> return r + | `Ok (version, status) -> + Header_IO.parse ic >>= fun headers -> + return (`Ok { headers; version; status }) + + 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 = + write oc + (Printf.sprintf "%s %s\r\n" + (Code.string_of_version res.version) + (Code.string_of_status res.status)) + >>= fun () -> + let headers = + if allowed_body res then + Header.add_transfer_encoding res.headers (encoding res) + else res.headers + in + Header_IO.write headers 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 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 = + write_header req oc >>= fun () -> + let writer = make_body_writer ~flush req oc in + fn writer >>= fun () -> write_footer req oc +end + +module Private = struct + module Make = Make +end diff --git a/cohttp/src/response.mli b/cohttp/src/response.mli new file mode 100644 index 0000000..2330522 --- /dev/null +++ b/cohttp/src/response.mli @@ -0,0 +1,41 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(** HTTP/1.1 response handling *) + +include S.Response with type t = Http.Response.t +(** This contains the metadata for a HTTP/1.1 response header, including the + {!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 *) + +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 diff --git a/cohttp/src/s.ml b/cohttp/src/s.ml new file mode 100644 index 0000000..8daf316 --- /dev/null +++ b/cohttp/src/s.ml @@ -0,0 +1,170 @@ +(*{{{ Copyright (C) 2012-2014 Anil Madhavapeddy + * Copyright (c) 2014 Rudi Grinberg + * + * 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 type signatures for Cohttp components *) + +(** The [IO] module defines the blocking interface for reading and writing to + Cohttp streams *) +module type IO = sig + type +'a t + (** ['a t] represents a blocking monad state *) + + val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t + (** [a >>= b] will pass the result of [a] to the [b] function. This is a + monadic [bind]. *) + + val return : 'a -> 'a t + (** [return a] will construct a constant IO value. *) + + type ic + (** [ic] represents an input channel *) + + type oc + (** [oc] represents an output channel *) + + 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 + reached. *) + + val read : ic -> int -> string t + (** [read ic len] will block until a maximum of [len] characters are read from + the input channel [ic]. It returns an empty string if EOF or some other + error condition occurs on the input channel, and can also return fewer + than [len] characters if input buffering is not sufficient to satisfy the + request. *) + + val write : oc -> string -> unit t + (** [write oc s] will block until the complete [s] string is written to the + output channel [oc]. *) + + val flush : oc -> unit t + (** [flush oc] will return when all previously buffered content from calling + {!write} have been written to the output channel [oc]. *) +end + +module type Http_io = sig + type t + type reader + type writer + + module IO : IO + + val read : IO.ic -> [ `Eof | `Invalid of string | `Ok of t ] IO.t + 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 +end + +module type Request = sig + type t = { + headers : Header.t; (** HTTP request headers *) + meth : Code.meth; (** HTTP request method *) + resource : string; (** Request path and query *) + version : Code.version; (** HTTP version, usually 1.1 *) + } + [@@deriving sexp] + + val headers : t -> Header.t + val meth : t -> Code.meth + val resource : t -> string + val version : t -> Code.version + val encoding : t -> Transfer.encoding + val compare : t -> t -> int + + val make : + ?meth:Code.meth -> + ?version:Code.version -> + ?encoding:Transfer.encoding -> + ?headers:Header.t -> + ?absolute_form:bool -> + 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 *) + + val uri : t -> Uri.t + + val make_for_client : + ?headers:Header.t -> + ?chunked:bool -> + ?body_length:int64 -> + ?absolute_form:bool -> + Code.meth -> + Uri.t -> + t +end + +module type Response = sig + type t = { + headers : Header.t; (** response HTTP headers *) + version : Code.version; (** (** HTTP version, usually 1.1 *) *) + status : Code.status_code; (** HTTP status code of the response *) + } + [@@deriving sexp] + + val encoding : t -> Transfer.encoding + val headers : t -> Header.t + val version : t -> Code.version + val status : t -> Code.status_code + val compare : t -> t -> int + + val make : + ?version:Code.version -> + ?status:Code.status_code -> + ?encoding:Transfer.encoding -> + ?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], [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 + type t + + val to_string : t -> string + val to_string_list : t -> string list + val to_form : t -> (string * string list) list + val empty : t + val is_empty : t -> bool + val of_string : string -> t + val of_string_list : string list -> t + val of_form : ?scheme:string -> (string * string list) list -> t + val map : (string -> string) -> t -> t + val transfer_encoding : t -> Transfer.encoding +end diff --git a/cohttp/src/server.ml b/cohttp/src/server.ml new file mode 100644 index 0000000..0c26753 --- /dev/null +++ b/cohttp/src/server.ml @@ -0,0 +1,67 @@ +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 diff --git a/cohttp/src/string_io.ml b/cohttp/src/string_io.ml new file mode 100644 index 0000000..f58f4bc --- /dev/null +++ b/cohttp/src/string_io.ml @@ -0,0 +1,87 @@ +(*{{{ Copyright (c) 2014 Andy Ray + * Copyright (c) 2014 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(* input channel type - a string with a (file) position and length *) +type buf = { str : string; mutable pos : int; len : int } + +let open_in str = { str; pos = 0; len = String.length str } + +module M = struct + type 'a t = 'a + + let return a = a + + type conn = buf + + let ( >>= ) = ( |> ) + + type ic = buf + + (* output channels are just buffers *) + type oc = Buffer.t + + (* the following read/write logic has only been lightly tested... *) + let read_rest x = + let s = String.sub x.str x.pos (x.len - x.pos) in + x.pos <- x.len; + s + + let read_line' x = + if x.pos < x.len then + let start = x.pos in + try + while x.str.[x.pos] != '\n' do + x.pos <- x.pos + 1 + done; + let l = + if x.pos > 0 && x.str.[x.pos - 1] = '\r' then x.pos - start - 1 + else x.pos - start + in + let s = String.sub x.str start l in + x.pos <- x.pos + 1; + Some s + with _ -> Some (read_rest x) + else None + + let read_line x = return (read_line' x) + + let read_exactly' x n = + if x.len - x.pos < n then None + else + let s = String.sub x.str x.pos n in + 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 + | None -> return (read_rest x) + | Some x -> return x + + let write x s = + Buffer.add_string x s; + return () + + let flush _x = return () +end diff --git a/cohttp/src/string_io.mli b/cohttp/src/string_io.mli new file mode 100644 index 0000000..65988b8 --- /dev/null +++ b/cohttp/src/string_io.mli @@ -0,0 +1,30 @@ +(*{{{ Copyright (c) 2014 Andy Ray + * Copyright (c) 2014 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(** IO implementation that uses strings to marshal and unmarshal HTTP *) + +type buf = { str : string; mutable pos : int; len : int } +(** The buffer structured used to keep track of where in the string the library + is currently reading from *) + +val open_in : string -> buf +(** [open_in s] will make the string [s] available as a [buf] that can be parsed + via Cohttp *) + +(** IO interface that uses {!buf} for input data and queues output data into a + {!Buffer.t} *) +module M : S.IO with type 'a t = 'a and type ic = buf and type oc = Buffer.t diff --git a/cohttp/src/transfer.ml b/cohttp/src/transfer.ml new file mode 100644 index 0000000..26f1f52 --- /dev/null +++ b/cohttp/src/transfer.ml @@ -0,0 +1,34 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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 Sexplib0.Sexp_conv + +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 + | Chunked -> "chunked" + | Fixed i -> Printf.sprintf "fixed[%Ld]" i + | Unknown -> "unknown" + +let has_body = Http.Transfer.Private.has_body diff --git a/cohttp/src/transfer.mli b/cohttp/src/transfer.mli new file mode 100644 index 0000000..8514a00 --- /dev/null +++ b/cohttp/src/transfer.mli @@ -0,0 +1,45 @@ +(*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy + * + * 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. + * + }}}*) + +(** 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 = 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 *) + | Final_chunk of string + (** the last chunk of data, so no more should be read *) + | Done (** no more body data is present *) +[@@deriving sexp] + +val string_of_encoding : encoding -> string +(** Convert the encoding format to a human-readable string *) + +val has_body : encoding -> [ `No | `Unknown | `Yes ] +(** [has_body encoding] returns the appropriate variant that indicates whether + the HTTP request or response has an associated body. It does not guess: + instead [Unknown] is returned if there is no explicit association. *) diff --git a/cohttp/src/transfer_io.ml b/cohttp/src/transfer_io.ml new file mode 100644 index 0000000..7baa279 --- /dev/null +++ b/cohttp/src/transfer_io.ml @@ -0,0 +1,139 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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 Transfer + +module Make (IO : S.IO) = struct + open IO + + type reader = unit -> Transfer.chunk IO.t + type writer = string -> unit IO.t + + module Chunked = struct + let remaining_length chunk remaining = + let read_len = Int64.of_int (String.length chunk) in + Int64.sub remaining read_len + + let read_chunk ic size = + let max_read_len = Int64.of_int 0x8000 in + let len = min size max_read_len in + read ic (Int64.to_int len) + + let rec junk_until_empty_line ic = + read_line ic >>= function + | None | Some "" -> return Done + | Some _trailer -> junk_until_empty_line ic + + let read ~remaining ic () = + (* read between 0 and 32Kbytes of a chunk *) + let read_chunk_fragment () = + 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) + >>= fun _ -> return chunk + in + if !remaining = 0L then + (* Beginning of a chunk: read chunk size, read up to 32K bytes *) + read_line ic >>= function + | None -> return Done + | Some chunk_size_hex -> ( + 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 + | Ok (count, _consumed) -> ( + remaining := count; + read_chunk_fragment () >>= function + | "" -> return Done (* 0 bytes read means EOF *) + | buf -> return (Chunk buf))) + else + (* Middle of a chunk, read up to 32K bytes *) + read_chunk_fragment () >>= function + | "" -> return Done (* 0 bytes read means EOF *) + | buf -> return (Chunk buf) + + let write oc buf = + let len = String.length buf in + (* do NOT send empty chunks, as it signals the end of the + chunked body *) + if len <> 0 then + write oc (Printf.sprintf "%x\r\n" len) >>= fun () -> + write oc buf >>= fun () -> write oc "\r\n" + else return () + end + + module Fixed = struct + let read ~remaining ic () = + (* TODO functorise string to a bigbuffer *) + match !remaining with + | 0L -> return Done + | len -> ( + let max_read_len = Int64.of_int 0x8000 in + let read_len = Int64.to_int (min len max_read_len) in + read ic read_len >>= function + | "" -> return Done + | buf -> + remaining := + Int64.sub !remaining (Int64.of_int (String.length buf)); + return + (match !remaining with 0L -> Final_chunk buf | _ -> Chunk buf)) + + (* TODO enforce that the correct length is written? *) + let write = write + end + + module Unknown = struct + (* If we have no idea, then read until EOF (connection shutdown by + the remote party). *) + let read ic () = + read ic 4096 >>= fun buf -> + if buf = "" then return Done else return (Chunk buf) + + let write = write + end + + let write_and_flush fn oc buf = fn oc buf >>= fun () -> IO.flush oc + + let make_reader = function + | Chunked -> Chunked.read ~remaining:(ref 0L) + | Fixed len -> Fixed.read ~remaining:(ref len) + | Unknown -> Unknown.read + + let write_ignore_blank writer io s = + if String.length s = 0 then return () else writer io s + + let make_writer ~flush mode = + let write = + match mode with + | Chunked -> Chunked.write + | Fixed _ -> Fixed.write + | Unknown -> Unknown.write + in + match flush with + | false -> write + | true -> write_and_flush write |> write_ignore_blank + + let read reader = reader () + let write writer buf = writer buf +end diff --git a/cohttp/src/transfer_io.mli b/cohttp/src/transfer_io.mli new file mode 100644 index 0000000..2a821f8 --- /dev/null +++ b/cohttp/src/transfer_io.mli @@ -0,0 +1,27 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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 Transfer + +module Make (IO : S.IO) : sig + type reader + type writer + + val make_reader : encoding -> IO.ic -> reader + val make_writer : flush:bool -> encoding -> IO.oc -> writer + val read : reader -> chunk IO.t + val write : writer -> string -> unit IO.t +end diff --git a/cohttp/test/dune b/cohttp/test/dune new file mode 100644 index 0000000..090b786 --- /dev/null +++ b/cohttp/test/dune @@ -0,0 +1,71 @@ +(executable + (name test_accept) + (modules test_accept) + (forbidden_libraries base) + (libraries cohttp alcotest fmt)) + +(rule + (alias runtest) + (package cohttp) + (action + (run ./test_accept.exe))) + +(executable + (name test_header) + (modules test_header) + (forbidden_libraries base) + (libraries cohttp alcotest sexplib0)) + +(rule + (alias runtest) + (package cohttp) + (action + (run ./test_header.exe))) + +(executable + (name test_request) + (modules test_request) + (forbidden_libraries base) + (libraries alcotest cohttp fmt http_bytebuffer)) + +(rule + (alias runtest) + (package cohttp) + (action + (run ./test_request.exe))) + +(executable + (name test_body) + (modules test_body) + (forbidden_libraries base) + (libraries cohttp alcotest fmt)) + +(rule + (alias runtest) + (package cohttp) + (action + (run ./test_body.exe))) + +(executable + (name test_path) + (modules test_path) + (forbidden_libraries base) + (libraries cohttp alcotest fmt)) + +(rule + (alias runtest) + (package cohttp) + (action + (run ./test_path.exe))) + +(executable + (name test_proxy) + (modules test_proxy) + (forbidden_libraries base) + (libraries cohttp alcotest fmt ipaddr)) + +(rule + (alias runtest) + (package cohttp) + (action + (run ./test_proxy.exe))) diff --git a/cohttp/test/test_accept.ml b/cohttp/test/test_accept.ml new file mode 100644 index 0000000..1f33928 --- /dev/null +++ b/cohttp/test/test_accept.ml @@ -0,0 +1,185 @@ +(*{{{ Copyright (c) 2012 David Sheets + * + * 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 A = Cohttp.Accept + +let suite_of : type a. + (string option -> a) -> a Alcotest.testable -> (string * a) list -> _ list = + fun pf t -> + List.map (fun (s, expected) -> + let test () = Alcotest.check t s (pf (Some s)) expected in + (s, `Quick, test)) + +let suite_of_fail : type a. + (string option -> a) -> a Alcotest.testable -> (string * exn) list -> _ list + = + fun pf _ -> + List.map (fun (s, e) -> + let test () = + Alcotest.check_raises s e (fun () -> ignore (pf (Some s))) + in + (s, `Quick, test)) + +let suite_to_string_of : type a. (a -> string) -> (a * string) list -> _ list = + fun pf -> + List.map (fun (v, expected_str) -> + let test () = Alcotest.(check string expected_str expected_str (pf v)) in + (expected_str, `Quick, test)) + +let suite_to_string_of_fail : type a. + (a -> string) -> (a * string * exn) list -> _ list = + fun pf -> + List.map (fun (v, descr, e) -> + let test () = Alcotest.(check_raises descr e (fun () -> ignore (pf v))) in + ("", `Quick, test)) + +let valid_media_ranges = + [ + ("text/plain", [ (1000, (A.MediaType ("text", "plain"), [])) ]); + ("text/*", [ (1000, (A.AnyMediaSubtype "text", [])) ]); + ("*/*", [ (1000, (A.AnyMedia, [])) ]); + ("*/*;q=1", [ (1000, (A.AnyMedia, [])) ]); + ("*/*;q=0", [ (0, (A.AnyMedia, [])) ]); + ("*/*;q=1.", [ (1000, (A.AnyMedia, [])) ]); + ("*/*;q=1.0", [ (1000, (A.AnyMedia, [])) ]); + ("*/*;q=.0", [ (0, (A.AnyMedia, [])) ]); + ("*/*;q=0.", [ (0, (A.AnyMedia, [])) ]); + ("*/*;q=0.1", [ (100, (A.AnyMedia, [])) ]); + ( "image/*,text/*", + [ + (1000, (A.AnyMediaSubtype "image", [])); + (1000, (A.AnyMediaSubtype "text", [])); + ] ); + ( "text/plain; q=0.8; charset=utf-8,text/HTML;charset=utf-8;q=0.9", + [ + (800, (A.MediaType ("text", "plain"), [ ("charset", "utf-8") ])); + (900, (A.MediaType ("text", "html"), [ ("charset", "utf-8") ])); + ] ); + ( "text/*;foo=\"bar\"", + [ (1000, (A.AnyMediaSubtype "text", [ ("foo", "bar") ])) ] ); + ("*/*;qu=\"\\\"\"", [ (1000, (A.AnyMedia, [ ("qu", "\"") ])) ]); + ( "*/*;f=\";q=0,text/plain\"", + [ (1000, (A.AnyMedia, [ ("f", ";q=0,text/plain") ])) ] ); + ] + +let invalid_media_ranges = [ ("*/*;q=.", Parsing.Parse_error) ] + +let valid_media_ranges_suite = + let t_media_ranges = + Alcotest.testable (Fmt.of_to_string A.string_of_media_ranges) ( = ) + in + suite_of A.media_ranges t_media_ranges valid_media_ranges + +let invalid_media_ranges_suite = + let t_media_ranges = + Alcotest.testable (Fmt.of_to_string A.string_of_media_ranges) ( = ) + in + suite_of_fail A.media_ranges t_media_ranges invalid_media_ranges + +let valid_qualities = + [ + ((1000, (A.AnyMedia, [])), "*/*;q=1"); + ((0, (A.AnyMedia, [])), "*/*;q=0.000"); + ((353, (A.AnyMedia, [])), "*/*;q=0.353"); + ((25, (A.AnyMedia, [])), "*/*;q=0.025"); + ((1, (A.AnyMedia, [])), "*/*;q=0.001"); + ] + +let invalid_qualities = + [ + ( (-3, (A.AnyMedia, [])), + "negative", + Invalid_argument "qvalue -3 must be positive" ); + ( (1001, (A.AnyMedia, [])), + "bigger than 1000", + Invalid_argument "qvalue 1001 must be less than 1000" ); + ] + +let valid_qualities_suite = + suite_to_string_of (fun (q, a) -> A.string_of_media_range a q) valid_qualities + +let invalid_qualities_suite = + suite_to_string_of_fail + (fun (q, a) -> A.string_of_media_range a q) + invalid_qualities + +let valid_charsets = + [ + ("utf-8", [ (1000, A.Charset "utf-8") ]); + ("UTF-8", [ (1000, A.Charset "utf-8") ]); + ("iso-8859-1", [ (1000, A.Charset "iso-8859-1") ]); + ( "ISO-8859-1; q = 0.8, *; q=0.7", + [ (800, A.Charset "iso-8859-1"); (700, A.AnyCharset) ] ); + ] + +let valid_charsets_suite = + let t_charsets = + Alcotest.testable (Fmt.of_to_string A.string_of_charsets) ( = ) + in + suite_of A.charsets t_charsets valid_charsets + +let valid_encodings = + [ + ("compress, gzip", [ (1000, A.Compress); (1000, A.Gzip) ]); + ("", []); + ("*", [ (1000, A.AnyEncoding) ]); + ("compress;q=0.5, gzip;q=1.0", [ (500, A.Compress); (1000, A.Gzip) ]); + ( "Gzip;q=1.0, identity; q=0.5, *;q=0", + [ (1000, A.Gzip); (500, A.Identity); (0, A.AnyEncoding) ] ); + ] + +let valid_encodings_suite = + let t_encodings = + Alcotest.testable (Fmt.of_to_string A.string_of_encodings) ( = ) + in + suite_of A.encodings t_encodings valid_encodings + +let valid_languages = + [ + ("en", [ (1000, A.Language [ "en" ]) ]); + ("en-US", [ (1000, A.Language [ "en"; "us" ]) ]); + ("en-cockney", [ (1000, A.Language [ "en"; "cockney" ]) ]); + ("i-cherokee", [ (1000, A.Language [ "i"; "cherokee" ]) ]); + ("x-pig-latin", [ (1000, A.Language [ "x"; "pig"; "latin" ]) ]); + ( "da, en-gb;q=0.8, en;q=0.7", + [ + (1000, A.Language [ "da" ]); + (800, A.Language [ "en"; "gb" ]); + (700, A.Language [ "en" ]); + ] ); + ( "en-US, *;q=0.9", + [ (1000, A.Language [ "en"; "us" ]); (900, A.AnyLanguage) ] ); + ] + +let valid_languages_suite = + let t_languages = + Alcotest.testable (Fmt.of_to_string A.string_of_languages) ( = ) + in + suite_of A.languages t_languages valid_languages + +let () = Printexc.record_backtrace true + +let () = + Alcotest.run "test_accept" + [ + ("valid string to media range", valid_media_ranges_suite); + ("invalid string to media range", invalid_media_ranges_suite); + ("valid media range to string", valid_qualities_suite); + ("invalid media range to string", invalid_qualities_suite); + ("valid string to charset", valid_charsets_suite); + ("valid string to encoding", valid_encodings_suite); + ("valid string to language", valid_languages_suite); + ] diff --git a/cohttp/test/test_body.ml b/cohttp/test/test_body.ml new file mode 100644 index 0000000..f328d30 --- /dev/null +++ b/cohttp/test/test_body.ml @@ -0,0 +1,23 @@ +let test_if_body_empty () = + let tests = + Cohttp.Body. + [ + ("empty string", of_string "", true); + ("empty list of strings", of_string_list [], true); + ("list of strings with empty bytes", of_string_list [ ""; ""; "" ], true); + ("non empty list of strings", of_string_list [ ""; "foo"; "bar" ], false); + ] + in + List.iter + (fun (name, body, expected) -> + Alcotest.(check bool) name (Cohttp.Body.is_empty body) expected) + tests + +let () = Printexc.record_backtrace true + +let () = + Alcotest.run "test_body" + [ + ( "Query body information", + [ ("Check if body is empty", `Quick, test_if_body_empty) ] ); + ] diff --git a/cohttp/test/test_header.ml b/cohttp/test/test_header.ml new file mode 100644 index 0000000..c9d08cc --- /dev/null +++ b/cohttp/test/test_header.ml @@ -0,0 +1,512 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * 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 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 +let aeso = Alcotest.check Alcotest.(option string) + +let t_credentials = + Alcotest.testable + (fun fmt c -> + let sexp = Cohttp.Auth.sexp_of_credential c in + Sexplib0.Sexp.pp_hum fmt sexp) + ( = ) + +let valid_auth () = + let auth = `Basic ("Aladdin", "open sesame") in + let h = H.add_authorization (H.init ()) auth in + let digest = H.get h "authorization" in + aeso "valid_auth 1" digest (Some "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ=="); + Alcotest.check + (Alcotest.option t_credentials) + "valid_auth 2" (H.get_authorization h) (Some auth) + +let valid_set_cookie () = + let c = + Cohttp.Cookie.Set_cookie_hdr.make ~expiration:`Session ~path:"/foo/bar" + ~domain:"ocaml.org" ~secure:true ~http_only:true ("key", "value") + in + let k, v = Cohttp.Cookie.Set_cookie_hdr.serialize ~version:`HTTP_1_0 c in + aes "header key" "Set-Cookie" k; + aes "header value" + "key=value; domain=ocaml.org; path=/foo/bar; secure; httponly" v; + let c = + Cohttp.Cookie.Set_cookie_hdr.make ~expiration:(`Max_age 100L) + ~path:"/foo/bar" ~domain:"ocaml.org" ("key", "value") + in + let k, v = Cohttp.Cookie.Set_cookie_hdr.serialize ~version:`HTTP_1_0 c in + aes "header key2" "Set-Cookie" k; + aes "header value2" "key=value; Max-Age=100; domain=ocaml.org; path=/foo/bar" + v; + let k, v = Cohttp.Cookie.Set_cookie_hdr.serialize ~version:`HTTP_1_1 c in + aes "header key 1.1" "Set-Cookie2" k; + aes "header value 1.1" + "Domain=ocaml.org; Max-Age=100; Path=/foo/bar; Version=1" v + +let t_cookies = Alcotest.(list (pair string string)) + +let cookie_with_eq_val () = + let cookies = [ ("test", "me=") ] in + let k, v = Cohttp.Cookie.Cookie_hdr.serialize cookies in + let h = Cohttp.Header.of_list [ (k, v) ] in + let cookies = Cohttp.Cookie.Cookie_hdr.extract h in + Alcotest.check t_cookies "cookie_with_eq_val" cookies [ ("test", "me=") ] + +let ignores_empty_cookie () = + let cookies = [ ("foo", "bar") ] in + let k, v = Cohttp.Cookie.Cookie_hdr.serialize cookies in + (* prepend an invalid empty component *) + let v = "; " ^ v in + let h = Cohttp.Header.of_list [ (k, v) ] in + let cookies = Cohttp.Cookie.Cookie_hdr.extract h in + Alcotest.check t_cookies "cookie" cookies [ ("foo", "bar") ] + +let valid_cookie () = + let cookies = [ ("foo", "bar"); ("a", "b") ] in + let k, v = Cohttp.Cookie.Cookie_hdr.serialize cookies in + aes "key" "cookie" k; + aes "value" "foo=bar; a=b" v; + let h = Cohttp.Header.of_list [ (k, v) ] in + let cookies = Cohttp.Cookie.Cookie_hdr.extract h in + Alcotest.check t_cookies "headers" [ ("foo", "bar"); ("a", "b") ] cookies + +let get_media_type () = + let mt = " foo/bar ; charset=UTF-8" in + let header = Cohttp.Header.init_with "content-type" mt in + Alcotest.check + Alcotest.(option string) + "media type" (Some "foo/bar") + (Cohttp.Header.get_media_type header) + +module Content_range = struct + let h1 = H.of_list [ ("Content-Length", "123") ] + let h2 = H.of_list [ ("Content-Range", "bytes 200-300/1000") ] + let aeio = Alcotest.(check (option int64)) + let none () = aeio "none" None (H.init () |> H.get_content_range) + + let content_length () = + aeio "content_length" (Some 123L) (H.get_content_range h1) + + let content_range () = + aeio "content_range" (Some 101L) (H.get_content_range h2) +end + +module Link = Cohttp.Link + +let t_links = + Alcotest.testable + (fun fmt links -> + Format.pp_print_list ~pp_sep:Format.pp_print_newline + (fun fmt l -> Format.fprintf fmt "%s" (Link.to_string l)) + fmt links) + ( = ) + +let headers_of_response test_name response_string = + String_io.M.( + StringResponse.read (String_io.open_in response_string) >>= function + | `Ok resp -> Http.Response.headers resp + | _ -> failwith (test_name ^ " response parse failed")) + +let get_resp lines = + "HTTP/1.1 200 OK\r\n" ^ String.concat "\r\n" lines ^ "\r\n\r\n" + +let empty_uri = Uri.of_string "" + +let link_simple () = + let next_tgt = "/page/2" in + let resp = get_resp [ "Link: <" ^ next_tgt ^ ">; rel=next" ] in + let headers = headers_of_response "link_simple" resp in + Alcotest.check t_links "link_simple" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ next ] }; + target = Uri.of_string next_tgt; + }; + ] + (H.get_links headers) + +let link_multi_rel () = + let next_tgt = "/page/2" in + let resp = get_resp [ "Link: <" ^ next_tgt ^ ">; rel=\"next last\"" ] in + let headers = headers_of_response "link_multi_rel" resp in + Alcotest.check t_links "link_multi_rel" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ next; last ] }; + target = Uri.of_string next_tgt; + }; + ] + (H.get_links headers) + +let link_multi_line () = + let self_tgt = "/page/1" in + let next_tgt = "/page/2" in + let resp = + get_resp + [ + "Link: <" ^ next_tgt ^ ">; rel=\"next\""; + "Link: <" ^ self_tgt ^ ">; rel=self"; + ] + in + let headers = headers_of_response "link_multi_line" resp in + Alcotest.check t_links "link_multi_line" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ next ] }; + target = Uri.of_string next_tgt; + }; + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ self ] }; + target = Uri.of_string self_tgt; + }; + ] + (H.get_links headers) + +let link_multi_multi () = + let next_tgt = "/page/2" in + let last_tgt = "/page/3" in + let resp = + get_resp + [ "Link: <" ^ next_tgt ^ ">; rel=\"next\", <" ^ last_tgt ^ ">; rel=last" ] + in + let headers = headers_of_response "link_multi_multi" resp in + Alcotest.check t_links "link_multi_multi" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ next ] }; + target = Uri.of_string next_tgt; + }; + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ last ] }; + target = Uri.of_string last_tgt; + }; + ] + (H.get_links headers) + +let link_rel_uri () = + let uri_tgt = "/page/2" in + let uri_s = "http://example.com/a,valid;uri" in + let resp = + get_resp + [ "Link: <" ^ uri_tgt ^ ">; rel=\"next " ^ uri_s ^ "\"; hreflang=en" ] + in + let headers = headers_of_response "link_rel_uri" resp in + Alcotest.check t_links "link_rel_uri" + Link. + [ + { + context = empty_uri; + arc = + Arc. + { + empty with + relation = Rel.[ next; extension (Uri.of_string uri_s) ]; + hreflang = Some "en"; + }; + target = Uri.of_string uri_tgt; + }; + ] + (H.get_links headers) + +let link_anchor () = + let anchor = "/page/2" in + let target = "/page/1" in + let resp = + get_resp [ "Link: <" ^ target ^ ">; anchor=\"" ^ anchor ^ "\"; rel=prev" ] + in + let headers = headers_of_response "link_rel_uri" resp in + Alcotest.check t_links "link_anchor" + Link. + [ + { + context = Uri.of_string anchor; + arc = Arc.{ empty with relation = Rel.[ prev ] }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) + +let link_rev () = + let anchor = "/page/2" in + let resp = get_resp [ "Link: <" ^ anchor ^ ">; rev=prev" ] in + let headers = headers_of_response "link_rev" resp in + Alcotest.check t_links "link_multi_line" + Link. + [ + { + context = Uri.of_string anchor; + arc = Arc.{ empty with reverse = true; relation = Rel.[ prev ] }; + target = empty_uri; + }; + ] + (H.get_links headers) + +let link_media () = + let target = "/page/2" in + let resp = get_resp [ "Link: <" ^ target ^ ">; media=screen" ] in + let headers = headers_of_response "link_media" resp in + Alcotest.check t_links "link_media" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with media = Some "screen" }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) + +let link_media_complex () = + let target = "/page/2" in + let resp = + get_resp [ "Link: <" ^ target ^ ">; media=\"screen, print and dpi < 200\"" ] + in + let headers = headers_of_response "link_media_complex" resp in + Alcotest.check t_links "t_links" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with media = Some "screen, print and dpi < 200" }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) + +let link_title () = + let target = "/page/2" in + let resp = get_resp [ "Link: <" ^ target ^ ">; title=\"Next!\"; rel=next" ] in + let headers = headers_of_response "link_title" resp in + Alcotest.check t_links "link_title" + Link. + [ + { + context = empty_uri; + arc = Arc.{ empty with relation = Rel.[ next ]; title = Some "Next!" }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) + +let link_title_star () = + let target = "/page/2" in + let resp = + get_resp [ "Link: <" ^ target ^ ">; title*=UTF-8'en'Next!; rel=next" ] + in + let headers = headers_of_response "link_title_star" resp in + Alcotest.check t_links "link_title_star" + Link. + [ + { + context = empty_uri; + arc = + Arc. + { + empty with + relation = Rel.[ next ]; + title_ext = + Some + (Ext.make + ~charset:(Charset.of_string "UTF-8") + ~language:(Language.of_string "en") "Next!"); + }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) + +let link_type_token () = + let target = "/page/2" in + let resp = get_resp [ "Link: <" ^ target ^ ">; type=text/html; rel=next" ] in + let headers = headers_of_response "link_type_token" resp in + Alcotest.check t_links "link_type_token" + Link. + [ + { + context = empty_uri; + arc = + Arc. + { + empty with + relation = Rel.[ next ]; + media_type = Some ("text", "html"); + }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) + +let link_type_quoted () = + let target = "/page/2" in + let resp = + get_resp [ "Link: <" ^ target ^ ">; type=\"text/html\"; rel=next" ] + in + let headers = headers_of_response "link_type_quoted" resp in + Alcotest.check t_links "link_type_quoted" + Link. + [ + { + context = empty_uri; + arc = + Arc. + { + empty with + relation = Rel.[ next ]; + media_type = Some ("text", "html"); + }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) + +let link_ext () = + let target = "/page/2" in + let resp = get_resp [ "Link: <" ^ target ^ ">; see=saw; rel=next" ] in + let headers = headers_of_response "link_ext" resp in + Alcotest.check t_links "link_ext" + Link. + [ + { + context = empty_uri; + arc = + Arc. + { + empty with + relation = Rel.[ next ]; + extensions = [ ("see", "saw") ]; + }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) + +let link_ext_star () = + let target = "/page/2" in + let resp = get_resp [ "Link: <" ^ target ^ ">; zig*=''zag; rel=next" ] in + let headers = headers_of_response "link_ext" resp in + Alcotest.check t_links "link_ext_star" + Link. + [ + { + context = empty_uri; + arc = + Arc. + { + empty with + relation = Rel.[ next ]; + extension_exts = + [ + ( "zig", + Ext.make ~charset:(Charset.of_string "") + ~language:(Language.of_string "") "zag" ); + ]; + }; + target = Uri.of_string target; + }; + ] + (H.get_links headers) + +let trim_ws () = + let resp = get_resp [ "Age: 281 " ] in + let headers = headers_of_response "trim whitespace" resp in + aeso "trim_ws" (H.get headers "age") (Some "281") + +let test_cachecontrol_concat () = + let resp = + get_resp [ "Cache-Control: public"; "Cache-Control: max-age:86400" ] + in + let h = headers_of_response "concat Cache-Control" resp in + 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 () = + Alcotest.run "test_header" + [ + ( "Link", + [ + ("simple", `Quick, link_simple); + ("multiple rels", `Quick, link_multi_rel); + ("multiple lines", `Quick, link_multi_line); + ("multiheader", `Quick, link_multi_multi); + ("rel uri", `Quick, link_rel_uri); + ("anchor", `Quick, link_anchor); + ("rev", `Quick, link_rev); + ("media", `Quick, link_media); + ("media complex", `Quick, link_media_complex); + ("title", `Quick, link_title); + ("title star", `Quick, link_title_star); + ("type token", `Quick, link_type_token); + ("type quoted", `Quick, link_type_quoted); + ("extension", `Quick, link_ext); + ("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", + [ + ("Valid Set-Cookie", `Quick, valid_set_cookie); + ("Valid Cookie", `Quick, valid_cookie); + ("Cookie with =", `Quick, cookie_with_eq_val); + ("Ignores empty cookie", `Quick, ignores_empty_cookie); + ] ); + ( "Content Range", + [ + ("none", `Quick, Content_range.none); + ("content-length", `Quick, Content_range.content_length); + ("content-range", `Quick, Content_range.content_range); + ] ); + ("Cache Control", [ ("concat", `Quick, test_cachecontrol_concat) ]); + ( "Serialization/Deserialization", + if Sys.word_size = 64 then [ ("large header", `Slow, large_header) ] + else [] ); + ] diff --git a/cohttp/test/test_path.ml b/cohttp/test/test_path.ml new file mode 100644 index 0000000..1feabe0 --- /dev/null +++ b/cohttp/test/test_path.ml @@ -0,0 +1,88 @@ +let test_resolve_local_file () = + let tests = + [ + ( "full URL simple", + "/foo/bar/baz", + "https://example.com/images/buzz", + "/foo/bar/baz/images/buzz" ); + ( "full URL cwd", + "/foo/bar/baz", + "https://example.com/./buzz", + "/foo/bar/baz/buzz" ); + ( "full URL parent blocked", + "/foo/bar/baz", + "https://example.com/../buzz", + "/foo/bar/baz/buzz" ); + ( "full URL grandparent blocked", + "/foo/bar/baz", + "https://example.com/../../buzz", + "/foo/bar/baz/buzz" ); + ( "trailing-slash-docroot full URL simple", + "/foo/bar/baz/", + "https://example.com/images/buzz", + "/foo/bar/baz/images/buzz" ); + ( "trailing-slash-docroot full URL cwd", + "/foo/bar/baz/", + "https://example.com/./buzz", + "/foo/bar/baz/buzz" ); + ( "trailing-slash-docroot full URL parent blocked", + "/foo/bar/baz/", + "https://example.com/../buzz", + "/foo/bar/baz/buzz" ); + ( "trailing-slash-docroot full URL grandparent blocked", + "/foo/bar/baz/", + "https://example.com/../../buzz", + "/foo/bar/baz/buzz" ); + ( "filepath simple", + "/foo/bar/baz", + "/images/buzz", + "/foo/bar/baz/images/buzz" ); + ("filepath cwd", "/foo/bar/baz", "./buzz", "/foo/bar/baz/buzz"); + ("filepath parent blocked", "/foo/bar/baz", "../buzz", "/foo/bar/baz/buzz"); + ( "filepath grandparent blocked", + "/foo/bar/baz", + "../../buzz", + "/foo/bar/baz/buzz" ); + ( "trailing-slash-docroot filepath simple", + "/foo/bar/baz/", + "/images/buzz", + "/foo/bar/baz/images/buzz" ); + ( "trailing-slash-docroot filepath cwd", + "/foo/bar/baz/", + "./buzz", + "/foo/bar/baz/buzz" ); + ( "trailing-slash-docroot filepath parent blocked", + "/foo/bar/baz/", + "../buzz", + "/foo/bar/baz/buzz" ); + ( "trailing-slash-docroot filepath grandparent blocked", + "/foo/bar/baz/", + "../../buzz", + "/foo/bar/baz/buzz" ); + ("root-docroot simple", "/", "/images/buzz", "/images/buzz"); + ("root-docroot cwd", "/", "./buzz", "/buzz"); + ("root-docroot grandparent blocked", "/", "../../buzz", "/buzz"); + ("blank-docroot simple", "", "/images/buzz", "images/buzz"); + ("blank-docroot cwd", "", "./buzz", "buzz"); + ("blank-docroot blank-path", "", "https://example.com", ""); + ("blank-docroot blank-uri", "", "", ""); + ("cwd-docroot simple", ".", "/images/buzz", "./images/buzz"); + ("cwd-docroot cwd", ".", "./buzz", "./buzz"); + ("cwd-docroot blank-path", ".", "https://example.com", "./"); + ("cwd-docroot blank-uri", ".", "", "./"); + ] + in + List.iter + (fun (name, docroot, uri, expected) -> + Alcotest.(check string) + name expected + (Cohttp.Path.resolve_local_file ~docroot ~uri:(Uri.of_string uri))) + tests + +let () = Printexc.record_backtrace true + +let () = + Alcotest.run "test_path" + [ + ("Path", [ ("Check resolve_local_file", `Quick, test_resolve_local_file) ]); + ] diff --git a/cohttp/test/test_proxy.ml b/cohttp/test/test_proxy.ml new file mode 100644 index 0000000..2d796be --- /dev/null +++ b/cohttp/test/test_proxy.ml @@ -0,0 +1,111 @@ +module Proxy = Cohttp.Proxy.Forward + +let http_proxy = "http://proxy.com" +let https_proxy = "http://https-proxy.com" +let fallback_proxy = "http://fallback-proxy.com" + +let proxies ~no_proxy_patterns = + Proxy.make_servers ~no_proxy_patterns + ~default_proxy:(Some (Uri.of_string fallback_proxy)) + ~scheme_proxies: + [ + ("http", Uri.of_string http_proxy); ("https", Uri.of_string https_proxy); + ] + ~direct:Uri.to_string ~tunnel:Uri.to_string + +let proxy = + let pp fmt = function + | Proxy.Direct s -> Format.fprintf fmt "Direct(%S)" s + | Proxy.Tunnel s -> Format.fprintf fmt "Tunnel(%S)" s + in + Alcotest.testable pp ( = ) + +let select_http_proxy () = + let proxies = proxies ~no_proxy_patterns:None in + let expected = Some (Proxy.Direct http_proxy) in + let actual = Proxy.get proxies @@ Uri.of_string "http://example.com" in + Alcotest.check' (Alcotest.option proxy) + ~msg:"should select configured http proxy as Direct" ~actual ~expected + +let select_https_proxy () = + let proxies = proxies ~no_proxy_patterns:None in + let expected = Some (Proxy.Tunnel https_proxy) in + let actual = Proxy.get proxies @@ Uri.of_string "https://example.com" in + Alcotest.check' (Alcotest.option proxy) + ~msg:"should select configured https proxy as Tunnel" ~actual ~expected + +let select_default_proxy () = + let proxies = proxies ~no_proxy_patterns:None in + let expected = Some (Proxy.Direct fallback_proxy) in + let actual = Proxy.get proxies @@ Uri.of_string "ftp://example.com" in + Alcotest.check' (Alcotest.option proxy) + ~msg:"should select fallback proxy for unconfigured scheme" ~actual + ~expected + +let no_proxy_wildcard () = + let proxies = proxies ~no_proxy_patterns:(Some "*") in + let expected = None in + let actual = Proxy.get proxies @@ Uri.of_string "http://example.com" in + Alcotest.check' (Alcotest.option proxy) + ~msg:"should ensure no proxy is selected" ~actual ~expected + +let no_proxy_literal_pattern () = + let proxies = proxies ~no_proxy_patterns:(Some "example.com") in + let expected = None in + let actual = Proxy.get proxies @@ Uri.of_string "http://example.com" in + Alcotest.check' (Alcotest.option proxy) + ~msg:"should ensure example.com is not proxied" ~actual ~expected + +let no_proxy_list_of_patterns () = + let proxies = proxies ~no_proxy_patterns:(Some "foo.com,example.com") in + + let msg = "should ensure example.com is not proxied" in + let actual = Proxy.get proxies @@ Uri.of_string "http://example.com" in + Alcotest.check' (Alcotest.option proxy) ~msg ~actual ~expected:None; + + let msg = "should ensure foo.com is not proxied" in + let actual = Proxy.get proxies @@ Uri.of_string "http://foo.com" in + Alcotest.check' (Alcotest.option proxy) ~msg ~actual ~expected:None + +let no_proxy_subdomain_patterns () = + (* As per https://everything.curl.dev/usingcurl/proxies/env.html#no-proxy + + > If a name in the exclusion list starts with a dot (.), then the name matches + that entire domain. For example .example.com matches both www.example.com and + home.example.com but not nonexample.com. *) + let proxies = proxies ~no_proxy_patterns:(Some ".example.com") in + + let msg = "should ensure www.example.com is not proxied" in + let actual = Proxy.get proxies @@ Uri.of_string "http://www.example.com" in + Alcotest.check' (Alcotest.option proxy) ~msg ~actual ~expected:None; + + let msg = "should ensure home.example.com is not proxied" in + let actual = Proxy.get proxies @@ Uri.of_string "http://home.example.com" in + Alcotest.check' (Alcotest.option proxy) ~msg ~actual ~expected:None; + + let msg = "should ensure example.com is proxied" in + let actual = Proxy.get proxies @@ Uri.of_string "http://example.com" in + Alcotest.check' (Alcotest.option proxy) ~msg ~actual ~expected:None; + + let msg = "nonexample.com should be proxied" in + let actual = Proxy.get proxies @@ Uri.of_string "http://nonexample.com" in + Alcotest.check' (Alcotest.option proxy) ~msg ~actual + ~expected:(Some (Direct http_proxy)) + +let () = + Alcotest.run "test_proxy" + [ + ( "NO_PROXY", + [ + ("wildcard pattern", `Quick, no_proxy_wildcard); + ("literal pattern", `Quick, no_proxy_literal_pattern); + ("list of patterns", `Quick, no_proxy_list_of_patterns); + ("subdomain patterns", `Quick, no_proxy_subdomain_patterns); + ] ); + ( "scheme proxies", + [ + ("selects http proxy", `Quick, select_http_proxy); + ("selects https proxy", `Quick, select_https_proxy); + ("selects default proxy", `Quick, select_default_proxy); + ] ); + ] diff --git a/cohttp/test/test_request.ml b/cohttp/test/test_request.ml new file mode 100644 index 0000000..d3a2cfb --- /dev/null +++ b/cohttp/test/test_request.ml @@ -0,0 +1,417 @@ +open Cohttp +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 = + let h = Header.init () in + let h = Header.add_authorization h (`Basic ("qux", "qwerty")) in + h + +let is_some = function None -> false | Some _ -> true + +let header_has_auth _ = + Alcotest.check Alcotest.bool "Test header has auth" + (header_auth |> Header.get_authorization |> is_some) + true + +let uri_has_userinfo _ = + Alcotest.check Alcotest.bool "Uri has user info" + (uri_userinfo |> Uri.userinfo |> is_some) + true + +let t_credentials = + Alcotest.testable + (fun fmt c -> + let sexp = Cohttp.Auth.sexp_of_credential c in + Sexplib0.Sexp.pp_hum fmt sexp) + ( = ) + +let auth_uri_no_override _ = + let r = Request.make ~headers:header_auth uri_userinfo in + Alcotest.check + (Alcotest.option t_credentials) + "auth uri no override" + (r |> Request.headers |> Header.get_authorization) + (Header.get_authorization header_auth) + +let auth_uri _ = + let r = Request.make uri_userinfo in + Alcotest.check + (Alcotest.option t_credentials) + "auth_uri" + (r |> Request.headers |> Header.get_authorization) + (Some (`Basic ("foo", "bar%25"))) + +let t_encoding = + Alcotest.testable + (fun fmt e -> + let sexp = Cohttp.Transfer.sexp_of_encoding e in + Sexplib0.Sexp.pp fmt sexp) + ( = ) + +let encoding_content_length_header () = + let r = + Request.make + ~headers:(Cohttp.Header.of_list [ ("content-length", "100") ]) + (Uri.of_string "http://someuri.com") + in + Alcotest.check t_encoding "body encoding determined by content-length header" + (r |> Request.encoding) (Fixed 100L) + +let encoding_transfer_encoding_header () = + let r = + Request.make + ~headers:(Cohttp.Header.of_list [ ("transfer-encoding", "chunked") ]) + (Uri.of_string "http://someuri.com") + in + Alcotest.check t_encoding + "body encoding determined by transfer-encoding header" + (r |> Request.encoding) Chunked + +let encoding_both_headers () = + let r = + Request.make + ~headers: + (Cohttp.Header.of_list + [ ("transfer-encoding", "chunked"); ("content-length", "100") ]) + (Uri.of_string "http://someuri.com") + in + Alcotest.check t_encoding + "body encoding with content-length and transfer-encoding headers." + (r |> Request.encoding) Chunked + +let encoding_header_opt_argument () = + let r = + Request.make ~encoding:Chunked + ~headers:(Cohttp.Header.of_list [ ("content-length", "100") ]) + (Uri.of_string "http://someuri.com") + in + Alcotest.check t_encoding + "body encoding with content-length and transfer-encoding headers." + (r |> Request.encoding) (Fixed 100L) + +module Parse_result = struct + type 'a t = [ `Ok of 'a | `Invalid of string | `Eof ] + + let map t ~f = + match t with `Ok x -> `Ok (f x) | (`Invalid _ | `Eof) as e -> e +end + +let uri_testable : Uri.t Alcotest.testable = + Alcotest.testable Uri.pp_hum Uri.equal + +let t_parse_result_uri : Uri.t Parse_result.t Alcotest.testable = + Alcotest.testable + (fun fmt -> function + | `Invalid s -> Format.fprintf fmt "`Invalid %s" s + | `Eof -> Format.fprintf fmt "`Eof" + | `Ok u -> Uri.pp_hum fmt u) + (fun x y -> + match (x, y) with `Ok x, `Ok y -> Uri.equal x y | x, y -> x = y) + +let parse_request_uri_ r (expected : Uri.t Parse_result.t) name = + String_io.M.( + StringRequest.read (String_io.open_in r) + >>= 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) + +let bad_request = `Invalid "bad request URI" + +let parse_request_uri _ = + let r = "GET / HTTP/1.1\r\n\r\n" in + let uri = `Ok (Uri.of_string "/") in + parse_request_uri_ r uri "parse_request_uri" + +let parse_request_uri_host _ = + let r = "GET / HTTP/1.1\r\nHost: example.com\r\n\r\n" in + let uri = `Ok (Uri.of_string "//example.com/") in + parse_request_uri_ r uri "parse_request_uri_host" + +let parse_request_uri_host_port _ = + let r = "GET / HTTP/1.1\r\nHost: example.com:8080\r\n\r\n" in + let uri = `Ok (Uri.of_string "//example.com:8080/") in + parse_request_uri_ r uri "parse_request_uri_host_port" + +let parse_request_uri_double_slash _ = + let r = "GET // HTTP/1.1\r\n\r\n" in + let uri = `Ok (Uri.with_path (Uri.of_string "") "//") in + parse_request_uri_ r uri "parse_request_uri_double_slash" + +let parse_request_uri_host_double_slash _ = + let r = "GET // HTTP/1.1\r\nHost: example.com\r\n\r\n" in + let uri = `Ok (Uri.of_string "//example.com//") in + parse_request_uri_ r uri "parse_request_uri_host_double_slash" + +let parse_request_uri_triple_slash _ = + let r = "GET /// HTTP/1.1\r\n\r\n" in + let uri = `Ok (Uri.with_path (Uri.of_string "") "///") in + parse_request_uri_ r uri "parse_request_uri_triple_slash" + +let parse_request_uri_host_triple_slash _ = + let r = "GET /// HTTP/1.1\r\nHost: example.com\r\n\r\n" in + let uri = `Ok (Uri.of_string "//example.com///") in + parse_request_uri_ r uri "parse_request_uri_host_triple_slash" + +let parse_request_uri_no_slash _ = + let r = "GET foo HTTP/1.1\r\n\r\n" in + parse_request_uri_ r bad_request "parse_request_uri_no_slash" + +let parse_request_uri_host_no_slash _ = + let r = "GET foo HTTP/1.1\r\nHost: example.com\r\n\r\n" in + parse_request_uri_ r bad_request "parse_request_uri_host_no_slash" + +let parse_request_uri_empty _ = + let r = "GET HTTP/1.1\r\n\r\n" in + let uri = `Ok (Uri.of_string "/") in + parse_request_uri_ r uri "parse_request_uri_empty" + +let parse_request_uri_host_empty _ = + let r = "GET HTTP/1.1\r\nHost: example.com\r\n\r\n" in + let uri = `Ok (Uri.of_string "//example.com/") in + parse_request_uri_ r uri "parse_request_uri_host_empty" + +let parse_request_uri_path_like_scheme _ = + let r = "GET http://example.net HTTP/1.1\r\n\r\n" in + let uri = `Ok (Uri.of_string "http://example.net/") in + parse_request_uri_ r uri "parse_request_uri_path_like_scheme" + +let parse_request_uri_host_path_like_scheme _ = + let r = "GET http://example.net HTTP/1.1\r\nHost: example.com\r\n\r\n" in + let uri = `Ok (Uri.of_string "http://example.net/") in + parse_request_uri_ r uri "parse_request_uri_host_path_like_scheme" + +let parse_request_uri_path_like_host_port _ = + let path = "//example.net:8080" in + let r = "GET " ^ path ^ " HTTP/1.1\r\n\r\n" in + let uri = `Ok (Uri.with_path (Uri.of_string "") path) in + parse_request_uri_ r uri "parse_request_uri_path_like_host_port" + +let parse_request_uri_host_path_like_host_port _ = + let path = "//example.net:8080" in + let r = "GET " ^ path ^ " HTTP/1.1\r\nHost: example.com\r\n\r\n" in + let uri = `Ok (Uri.with_path (Uri.of_string "//example.com") path) in + parse_request_uri_ r uri "parse_request_uri_host_path_like_host_port" + +let parse_request_uri_query _ = + let pqs = "/?foo" in + let r = "GET " ^ pqs ^ " HTTP/1.1\r\n\r\n" in + let uri = `Ok (Uri.of_string pqs) in + parse_request_uri_ r uri "parse_request_uri_query" + +let parse_request_uri_host_query _ = + let pqs = "/?foo" in + let r = "GET " ^ pqs ^ " HTTP/1.1\r\nHost: example.com\r\n\r\n" in + let uri = `Ok (Uri.of_string ("//example.com" ^ pqs)) in + parse_request_uri_ r uri "parse_request_uri_host_query" + +let parse_request_uri_query_no_slash _ = + let r = "GET ?foo HTTP/1.1\r\n\r\n" in + parse_request_uri_ r bad_request "parse_request_uri_query_no_slash" + +let parse_request_uri_host_query_no_slash _ = + let r = "GET ?foo HTTP/1.1\r\nHost: example.com\r\n\r\n" in + 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\r\n" in + let uri = `Ok (Uri.of_string "//vpn.example.net:443") in + parse_request_uri_ r uri "parse_request_connect" + +let parse_request_connect_host _ = + let r = + "CONNECT vpn.example.net:443 HTTP/1.1\r\nHost: vpn.example.com:443\r\n\r\n" + in + let uri = `Ok (Uri.of_string "//vpn.example.net:443") in + parse_request_uri_ r uri "parse_request_connect_host" + +let parse_request_options _ = + let r = "OPTIONS * HTTP/1.1\r\n\r\n" in + let uri = `Ok (Uri.of_string "") in + parse_request_uri_ r uri "parse_request_options" + +let parse_request_options_host _ = + let r = "OPTIONS * HTTP/1.1\r\nHost: example.com:443\r\n\r\n" in + let uri = `Ok (Uri.of_string "//example.com:443") in + parse_request_uri_ r uri "parse_request_options_host" + +let parse_request_uri_traversal _ = + let r = "GET /../../../../etc/shadow HTTP/1.1\r\n\r\n" in + let uri = `Ok (Uri.of_string "/etc/shadow") in + parse_request_uri_ r uri "parse_request_uri_traversal" + +let parse_request_uri_host_traversal _ = + let r = "GET /../../../../etc/shadow HTTP/1.1\r\nHost: example.com\r\n\r\n" in + let uri = `Ok (Uri.of_string "//example.com/etc/shadow") in + parse_request_uri_ r uri "parse_request_uri_host_traversal" + +let uri_round_trip _ = + 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" + [ + ( "Auth", + [ + ("header has auth", `Quick, header_has_auth); + ("URI has user info", `Quick, uri_has_userinfo); + ("from URI - do not override", `Quick, auth_uri_no_override); + ("from URI", `Quick, auth_uri); + ] ); + ( "Encoding", + [ + ("from content-length header", `Quick, encoding_content_length_header); + ( "from transfer-encoding header", + `Quick, + encoding_transfer_encoding_header ); + ("with both headers", `Quick, encoding_both_headers); + ( "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", + [ + ("simple", `Quick, parse_request_uri); + ("with host", `Quick, parse_request_uri_host); + ("with host and port", `Quick, parse_request_uri_host_port); + ("double slash", `Quick, parse_request_uri_double_slash); + ("double slash with host", `Quick, parse_request_uri_host_double_slash); + ("triple slash", `Quick, parse_request_uri_triple_slash); + ("triple slash with host", `Quick, parse_request_uri_host_triple_slash); + ("no slash", `Quick, parse_request_uri_no_slash); + ("no slash with host", `Quick, parse_request_uri_host_no_slash); + ("empty", `Quick, parse_request_uri_empty); + ("empty with host", `Quick, parse_request_uri_host_empty); + ("path like scheme", `Quick, parse_request_uri_path_like_scheme); + ( "path like scheme with host", + `Quick, + parse_request_uri_host_path_like_scheme ); + ("path like host:port", `Quick, parse_request_uri_path_like_host_port); + ( "path like host:port with host", + `Quick, + parse_request_uri_host_path_like_host_port ); + ("with query string", `Quick, parse_request_uri_query); + ("with query with host", `Quick, parse_request_uri_host_query); + ( "no slash with query string", + `Quick, + parse_request_uri_query_no_slash ); + ( "no slash with query with host", + `Quick, + parse_request_uri_host_query_no_slash ); + ("CONNECT", `Quick, parse_request_connect); + ("CONNECT with host", `Quick, parse_request_connect_host); + ("OPTIONS", `Quick, parse_request_options); + ("OPTIONS with host", `Quick, parse_request_options_host); + ("parent traversal", `Quick, parse_request_uri_traversal); + ( "parent traversal with host", + `Quick, + parse_request_uri_host_traversal ); + ("uri round-trip", `Quick, uri_round_trip); + ] ); + ] diff --git a/dune b/dune new file mode 100644 index 0000000..8765da5 --- /dev/null +++ b/dune @@ -0,0 +1 @@ +(dirs :standard \ node_modules) diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..c71b0c4 --- /dev/null +++ b/dune-project @@ -0,0 +1,398 @@ +(lang dune 3.8) + +(name cohttp) +(version v6.2.1) + +(license ISC) + +(using mdx 0.4) + +(cram enable) + +(maintainers "Anil Madhavapeddy ") + +(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) + (ipaddr (>= 5.6.0)) + (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.7.0)) + sexplib0 + (ipaddr + (>= 5.6.0)) + (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 + (>= 2.0.0)) + (lwt + (>= 3.0.0)) + (conduit-lwt + (>= 7.1.0)) + (conduit-lwt-unix + (>= 7.1.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 + (>= 5.7.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 + (and (>= 4.14) (< 5.3.0))) + (http + (= :version)) + (cohttp + (= :version)) + (async_kernel + (>= v0.17.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 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 + (>= 8.0.0)) + (conduit-mirage + (>= 8.0.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)) + (cmdliner + (and + :with-dev-setup + (>= 2.0.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) + (ipaddr (>= 5.6.0)) + logs + uri + (tls-eio (and :with-test (>= 1.0.0))) + (mirage-crypto-rng (and :with-test (>= 1.2.0))) + (ca-certs (and :with-test (>= "1.0.0"))) + fmt + ptime + (http + (= :version)) + (ppx_here :with-test))) diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..1f3e96a --- /dev/null +++ b/flake.lock @@ -0,0 +1,79 @@ +{ + "nodes": { + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "inputs": { + "nixpkgs": "nixpkgs_2" + }, + "locked": { + "lastModified": 1762899092, + "narHash": "sha256-Nl6547Q+Hw+RDV7cQnPmP6OTS7kncj9aN2Zx+HTlIeg=", + "owner": "nix-ocaml", + "repo": "nix-overlays", + "rev": "ccbb9339d0c245d3e406516c1da5bbd76568d278", + "type": "github" + }, + "original": { + "owner": "nix-ocaml", + "repo": "nix-overlays", + "type": "github" + } + }, + "nixpkgs_2": { + "locked": { + "lastModified": 1762808364, + "narHash": "sha256-nwxa9s+cjXZyFuTdFSKP5enPmhLfVOnNLlMhF25Uyf4=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "e1ce86c3e40327779390e98edab843d4a1cc9224", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "e1ce86c3e40327779390e98edab843d4a1cc9224", + "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" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..0dd9327 --- /dev/null +++ b/flake.nix @@ -0,0 +1,146 @@ +{ + 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; }; + ocamlPackages = pkgs.ocaml-ng.ocamlPackages_5_4.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; + }).overrideAttrs (_: { doCheck = false; }); + cmdliner = osuper.cmdliner.overrideAttrs (old: rec { + version = "2.1.0"; + src = pkgs.fetchFromGitHub { + owner = "dbuenzli"; + repo = "cmdliner"; + rev = "v${version}"; + sha256 = "sha256-ebe5I77zEKoehJ55ZszV0dQP4ZDfVpGXqDsEb2qEE24="; + }; + }); + }); + inherit (ocamlPackages) buildDunePackage; + pkg = attrs: buildDunePackage ({ + version = "n/a"; + src = ./. ; + duneVersion = "3"; + doCheck = true; + } // attrs); + ocamlformat = pkgs.ocamlformat_0_27_0; + in + with ocamlPackages; rec { + packages = rec { + default = http; + http = pkg { + pname = "http"; + propagatedBuildInputs = [ ppx_expect ]; + checkInputs = [ alcotest base_quickcheck ppx_expect crowbar ]; + }; + cohttp = pkg { + pname = "cohttp"; + checkInputs = [ fmt alcotest ]; + propagatedBuildInputs = [ + base64 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 = [ alcotest cohttp-lwt-unix cohttp cohttp-lwt conduit-lwt ounit2 uri ]; + propagatedBuildInputs = [ ocurl cohttp-curl http stringext lwt ]; + __darwinAllowLocalNetworking = true; + }; + 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 + ]; + __darwinAllowLocalNetworking = true; + }; + 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 + ]; + 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 ocamlPackages; [ + ocaml-lsp + ]); + }; + devShells.eio = pkgs.mkShell { + inputsFrom = [ cohttp-eio ]; + buildInputs = [ ocamlformat ocamlPackages.ocaml-lsp ] ++ (with pkgs; [ + gmp libev nmap curl + ]); + }; + }); +} diff --git a/http.opam b/http.opam new file mode 100644 index 0000000..9998981 --- /dev/null +++ b/http.opam @@ -0,0 +1,53 @@ +version: "6.2.1" +# 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 "] +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} + ] +] +x-maintenance-intent: [ "(latest)" ] \ No newline at end of file diff --git a/http.opam.template b/http.opam.template new file mode 100644 index 0000000..c20f934 --- /dev/null +++ b/http.opam.template @@ -0,0 +1,15 @@ +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@http/runtest" {with-test} + "@doc" {with-doc} + ] +] +x-maintenance-intent: [ "(latest)" ] diff --git a/http/fuzz/dune b/http/fuzz/dune new file mode 100644 index 0000000..50aae54 --- /dev/null +++ b/http/fuzz/dune @@ -0,0 +1,26 @@ +(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}))) diff --git a/http/fuzz/fuzz_header.ml b/http/fuzz/fuzz_header.ml new file mode 100644 index 0000000..e8e503e --- /dev/null +++ b/http/fuzz/fuzz_header.ml @@ -0,0 +1,568 @@ +(*{{{ Copyright (c) 2021 Carine Morel + * + * 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 (); + () diff --git a/http/fuzz/inputs/input b/http/fuzz/inputs/input new file mode 100644 index 0000000..a459bc2 --- /dev/null +++ b/http/fuzz/inputs/input @@ -0,0 +1 @@ +something \ No newline at end of file diff --git a/http/src/bytebuffer/bytebuffer.ml b/http/src/bytebuffer/bytebuffer.ml new file mode 100644 index 0000000..eb5e933 --- /dev/null +++ b/http/src/bytebuffer/bytebuffer.ml @@ -0,0 +1,135 @@ +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 diff --git a/http/src/bytebuffer/bytebuffer.mli b/http/src/bytebuffer/bytebuffer.mli new file mode 100644 index 0000000..9f54329 --- /dev/null +++ b/http/src/bytebuffer/bytebuffer.mli @@ -0,0 +1,41 @@ +(* 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 diff --git a/http/src/bytebuffer/dune b/http/src/bytebuffer/dune new file mode 100644 index 0000000..3d8cf2c --- /dev/null +++ b/http/src/bytebuffer/dune @@ -0,0 +1,3 @@ +(library + (name http_bytebuffer) + (package http)) diff --git a/http/src/dune b/http/src/dune new file mode 100644 index 0000000..d1caf4c --- /dev/null +++ b/http/src/dune @@ -0,0 +1,4 @@ +(library + (synopsis "HTTP types designed for interoperability") + (name http) + (public_name http)) diff --git a/http/src/http.ml b/http/src/http.ml new file mode 100644 index 0000000..b90e11b --- /dev/null +++ b/http/src/http.ml @@ -0,0 +1,1151 @@ +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 diff --git a/http/src/http.mli b/http/src/http.mli new file mode 100644 index 0000000..32713cf --- /dev/null +++ b/http/src/http.mli @@ -0,0 +1,499 @@ +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 diff --git a/http/test/bytebuffer/bytebuffer_tests.ml b/http/test/bytebuffer/bytebuffer_tests.ml new file mode 100644 index 0000000..6e33881 --- /dev/null +++ b/http/test/bytebuffer/bytebuffer_tests.ml @@ -0,0 +1,74 @@ +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 |}] diff --git a/http/test/bytebuffer/dune b/http/test/bytebuffer/dune new file mode 100644 index 0000000..c89fd56 --- /dev/null +++ b/http/test/bytebuffer/dune @@ -0,0 +1,6 @@ +(library + (name bytebuffer_tests) + (libraries http_bytebuffer) + (inline_tests) + (preprocess + (pps ppx_expect))) diff --git a/http/test/dune b/http/test/dune new file mode 100644 index 0000000..8201ba4 --- /dev/null +++ b/http/test/dune @@ -0,0 +1,36 @@ +(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)) diff --git a/http/test/expect/dune b/http/test/expect/dune new file mode 100644 index 0000000..af39820 --- /dev/null +++ b/http/test/expect/dune @@ -0,0 +1,6 @@ +(library + (name http_tests) + (libraries http) + (inline_tests) + (preprocess + (pps ppx_expect))) diff --git a/http/test/expect/http_tests.ml b/http/test/expect/http_tests.ml new file mode 100644 index 0000000..1de8cc1 --- /dev/null +++ b/http/test/expect/http_tests.ml @@ -0,0 +1,20 @@ +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 |}] diff --git a/http/test/test_header.ml b/http/test/test_header.ml new file mode 100644 index 0000000..7b164df --- /dev/null +++ b/http/test/test_header.ml @@ -0,0 +1,390 @@ +(*{{{ Copyright (c) 2021 Carine Morel + * + * 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 ] diff --git a/http/test/test_parser.ml b/http/test/test_parser.ml new file mode 100644 index 0000000..1970758 --- /dev/null +++ b/http/test/test_parser.ml @@ -0,0 +1,282 @@ +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; + ] ); + ] diff --git a/http/test/test_request.ml b/http/test/test_request.ml new file mode 100644 index 0000000..e380394 --- /dev/null +++ b/http/test/test_request.ml @@ -0,0 +1,77 @@ +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 ] diff --git a/http/test/test_response.ml b/http/test/test_response.ml new file mode 100644 index 0000000..26154fe --- /dev/null +++ b/http/test/test_response.ml @@ -0,0 +1,61 @@ +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 ] diff --git a/test_helpers/cohttp_server/cohttp_server.ml b/test_helpers/cohttp_server/cohttp_server.ml new file mode 100644 index 0000000..008f475 --- /dev/null +++ b/test_helpers/cohttp_server/cohttp_server.ml @@ -0,0 +1,109 @@ +(*{{{ Copyright (c) 2014-2015 David Sheets + * + * 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 "
  • %s
    • " 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 "%s/" 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 "
  • %s
    • " f + | None -> sprintf "
  • Error with file: %s
    • " f) + (sort listing) + in + let contents = String.concat "\n" html in + sprintf + "

    Directory Listing for %s

      %s
    %s" + (Uri.pct_decode path) contents info + +let html_of_forbidden_unnormal path info = + sprintf + "

    Forbidden

    %sis not a normal file or \ + directory

    %s" + path info + +let html_of_not_found path info = + sprintf + "

    Not Found

    %swas not found on this \ + server

    %s" + path info + +let html_of_method_not_allowed meth allowed path info = + sprintf + "

    Method Not Allowed

    %sis not an allowed \ + method on %s

    Allowed methods on %s are \ + %s

    %s" + meth path path allowed info diff --git a/test_helpers/cohttp_server/dune b/test_helpers/cohttp_server/dune new file mode 100644 index 0000000..a1c0c1d --- /dev/null +++ b/test_helpers/cohttp_server/dune @@ -0,0 +1,3 @@ +(library + (name cohttp_server) + (libraries cohttp unix)) diff --git a/test_helpers/cohttp_test/src/cohttp_test.ml b/test_helpers/cohttp_test/src/cohttp_test.ml new file mode 100644 index 0000000..50b80e3 --- /dev/null +++ b/test_helpers/cohttp_test/src/cohttp_test.ml @@ -0,0 +1,46 @@ +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" diff --git a/test_helpers/cohttp_test/src/cohttp_test.mli b/test_helpers/cohttp_test/src/cohttp_test.mli new file mode 100644 index 0000000..79fef83 --- /dev/null +++ b/test_helpers/cohttp_test/src/cohttp_test.mli @@ -0,0 +1,48 @@ +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 diff --git a/test_helpers/cohttp_test/src/dune b/test_helpers/cohttp_test/src/dune new file mode 100644 index 0000000..bcc36bc --- /dev/null +++ b/test_helpers/cohttp_test/src/dune @@ -0,0 +1,3 @@ +(library + (name cohttp_test) + (libraries cohttp ounit2))