--- /dev/null
+name: Main workflow
+
+on:
+ pull_request:
+ push:
+ schedule:
+ # Prime the caches every Monday
+ - cron: 0 1 * * MON
+
+jobs:
+ build:
+ strategy:
+ fail-fast: false
+ matrix:
+ os:
+ - macos-latest
+ - ubuntu-latest
+ ocaml-compiler:
+ - 4.08.x
+ - 4.09.x
+ - 4.10.x
+ - 4.11.x
+ - 4.12.x
+
+ runs-on: ${{ matrix.os }}
+
+ steps:
+ - name: Checkout code
+ uses: actions/checkout@v2
+
+ - name: Use OCaml ${{ matrix.ocaml-compiler }}
+ uses: ocaml/setup-ocaml@v2
+ with:
+ ocaml-compiler: ${{ matrix.ocaml-compiler }}
+ dune-cache: ${{ matrix.os == 'ubuntu-latest' }}
+
+ - run: yarn --frozen-lockfile
+ working-directory: cohttp_lwt_jsoo_test
+
+ - run: echo "PKG_CONFIG_PATH=$(brew --prefix openssl)/lib/pkgconfig" >>"$GITHUB_ENV"
+ if: ${{ matrix.os == 'macos-latest' }}
+
+ - run: opam install . --deps-only --with-test
+
+ - run: opam exec -- make build
+
+ - run: opam exec -- make test
+
+ - run: opam exec -- make js-test
--- /dev/null
+.*.swp
+_build/
+*.install
+.merlin
+_opam/
+node_modules
--- /dev/null
+version = 0.20.0
+profile = conventional
+break-infix = fit-or-vertical
+parse-docstrings = true
+## 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 chaged 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)
-- fix opam files and dependencies
-- add GitHub Actions workflow (@smorimoto #739)
-- lwt_jsoo: Forward exceptions to caller when response is null (@mefyl #738)
-- Remove wrapped false (@rgrinberg #734)
-- Use implicit executable dependency for generate.exe (@TheLortex #735)
-- cohttp: update HTTP codes (@emillon #711)
-- cohttp: add Uti.t to uri scheme (@brendanlong #707)
-- cohttp: fix chunked encoding of empty body (@mefyl #715)
-- cohttp-async: fix body not being uploaded with unchunked Async.Pipe (@mefyl #706)
-- cohttp-{async, lwt}: fix suprising behaviours of Body.is_empty (@anuragsoni #714 #712 #713)
-- cohttp-lwt-jsoo: rename Cohttp_lwt_xhr to Cohttp_lwt_jsoo for consistency (@mseri #717)
-- refactoring of tests (@mseri #709, @dinosaure #692)
-- update documentation (@dinosaure #716, @mseri #720)
-- cohttp: fix transfer-encoding ordering in headers (@mseri #721)
-- lower-level support for long-running cohttp-async connections (@brendanlong #704)
-- fix deadlock in logging (@dinosaure #722)
-- 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)
-- improve media type parsing (@seliopou #542, @dinosaure #725)
-- add comparison functions for Request.t and Response.t via ppx_compare (@msaffer-js @dinosaure #686)
-- [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. (#741, @samoht)
+- 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 suprising 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
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)
+ 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)
+ 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)
+ OCaml 4.06 (#703 mseri)
## v2.5.3 (2020-06-27)
-- cohttp-async: adapt to async >= v0.14 (#699 @copy)
+- 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)
+ 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)
+ 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)
+- 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)
+- 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)
+ 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)
+ (#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)
+ 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)
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)
+ 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)
+- 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)
+ 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)
+ (#662 hannesm)
+- Support Async v0.12.0 and higher (#661 copy)
## v2.1.0 (2019-03-01)
Compatibility breaking interface changes:
-Async: Expert response action no longer writes empty HTTP body (#647 by @andreas)
+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.
- `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)
+* 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)
+* 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)
+* 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)
+* 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).
+ 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).
+* 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)
+* 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: expose the missing IO module (#594, samoht)
* cohttp-mirage: catch exceptions when closing channels in mirage client
- (#589, @ansiwen)
+ (#589, ansiwen)
## v1.0.0 (2017-11-16)
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.
+Most of the release and packaging work here was done by rgrinberg
+and avsm.
## 0.22.0 (2017-03-09)
* 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)
+* 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
* 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.
+* 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).
-.PHONY: build clean test clean all-supported-ocaml-versions
+.PHONY: build clean test clean
build:
dune build
test:
dune runtest
+js-test:
+ dune build @runjstest
+
clean:
dune clean
-
-all-supported-ocaml-versions:
- dune build @install @runtest --workspace jbuild-workspace.dev
-## ocaml-cohttp -- an OCaml library for HTTP clients and servers
+## ocaml-cohttp -- an OCaml library for HTTP clients and servers [](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
- [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 ocamlbuild](#compile-and-execute-with-ocamlbuild-1)
* [Compile and execute with dune](#compile-and-execute-with-dune-1)
Build and execute with:
```
-$ ocamlbuild -pkg cohttp-lwt-unix client_example.native
+$ ocamlbuild -use-ocamlfind -tag thread -pkg cohttp-lwt-unix client_example.native
$ ./client_example.native
```
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
## Multipart form data
-Multipart form data is not supported out of the box, but is provided by the external library
-[`multipart-form-data`](https://github.com/cryptosense/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
[conduit's README](https://github.com/mirage/ocaml-conduit/) for examples of use and
links to up-to-date conduit documentation.
+## Dealing with redirects
+
+This examples has been adapted from a script on the [ocaml.org](https://github.com/ocaml/ocaml.org/blob/master/script/http.ml) website, and shows an explicit way to deal with redirects in `cohttp-lwt-unix`.
+
+```ocaml
+let rec http_get_and_follow ~max_redirects uri =
+ let open Lwt.Syntax in
+ let* ans = Cohttp_lwt_unix.Client.get uri in
+ follow_redirect ~max_redirects uri ans
+
+and follow_redirect ~max_redirects request_uri (response, body) =
+ let open Lwt.Syntax in
+ let status = Cohttp.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 request_uri response
+ | `Found | `Temporary_redirect ->
+ handle_redirect ~permanent:false ~max_redirects request_uri response
+ | `Not_found | `Gone -> Lwt.fail_with "Not found"
+ | status ->
+ Lwt.fail_with
+ (Printf.sprintf "Unhandled status: %s"
+ (Cohttp.Code.string_of_status status))
+
+and handle_redirect ~permanent ~max_redirects request_uri response =
+ if max_redirects <= 0 then Lwt.fail_with "Too many redirects"
+ else
+ let headers = Cohttp.Response.headers response in
+ let location = Cohttp.Header.get headers "location" in
+ match location with
+ | None -> Lwt.fail_with "Redirection without Location header"
+ | Some url ->
+ let open Lwt.Syntax in
+ let uri = Uri.of_string url in
+ let* () =
+ if permanent then
+ Logs.warn (fun m ->
+ 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
Build and execute with:
```
-$ ocamlbuild -pkg cohttp-lwt-unix server_example.native
+$ ocamlbuild -use-ocamlfind -tag thread -pkg cohttp-lwt-unix server_example.native
$ ./server_example.native
```
## Debugging
-You can activate some runtime debugging for the servers by setting `COHTTP_DEBUG` to any value different from `0` or `false`, and it will set a default debug-level logger on stdout. Note: If you turn on the debugging on the `cohttp-lwt-server` example, you need to make sure you also pass the `-vvv` option, which forces the debug level of the logger.
+You can activate some runtime debugging for the servers by setting `COHTTP_DEBUG` to any value different from `0` or `false`, and it will set a default debug-level logger on stdout.
+
+Since both Cohttp and Conduit use `Logs` for debugging output, you can enable custom debugging in your code (if needed). For example, if you intend to make use of the `COHTTP_DEBUG` env variable, you could simply use
+
+```ocaml
+let () =
+ if not @@ Debug.debug_active () then (
+ Fmt_tty.setup_std_outputs ();
+ Logs.set_level ~all:true level;
+ Logs.set_reporter Debug.default_reporter);
+```
-Since both Cohttp and Conduit use `Logs` for debugging output, you can enable custom debugging in your code (if needed) by adding something like the following to your code (courtesy of @dinosaure)
+Of course you are free to completely override it and use your own reporters, for example by adding something like the following to your code (courtesy of @dinosaure).
```ocaml
let reporter ppf =
msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in
{ Logs.report }
-let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ()
-let () = Logs.set_reporter (reporter Fmt.stderr)
-let () = Logs.set_level ~all:true (Some Logs.Debug)
+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
-version: "4.0.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: [
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
"ocaml" {>= "4.08"}
- "dune" {>= "1.1.0"}
+ "dune" {>= "2.0"}
"async_kernel" {>= "v0.14.0"}
"async_unix" {>= "v0.14.0"}
"async" {>= "v0.14.0"}
"base" {>= "v0.11.0"}
"core" {with-test}
- "cohttp" {=version}
- "conduit-async" {>="1.2.0" & <"3.0.0"}
+ "core_unix" {>= "v0.14.0"}
+ "cohttp" {= version}
+ "conduit-async" {>= "1.2.0"}
"magic-mime"
"mirage-crypto" {with-test}
"logs"
"ipaddr"
]
build: [
- ["dune" "subst"] {pinned}
+ ["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+available: arch != "s390x"
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
open Cohttp_async
let show_headers h =
- Cohttp.Header.iter
- (fun k v ->
- List.iter v ~f:(fun v_i -> Logs.info (fun m -> m "%s: %s%!" k v_i)))
- 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
(optional_with_default "" string)
~doc:" Data to send when using POST")
make_net_req
- |> run
+ |> Command_unix.run
let () =
let open Async_command in
- run
+ Command_unix.run
@@ async_spec ~summary:"Serve the local directory contents via HTTP or HTTPS"
Spec.(
empty
(package cohttp-async)
(public_names cohttp-curl-async cohttp-server-async)
(libraries cohttp-async async_kernel async.async_command async_unix base
- cohttp cohttp_server fmt.tty))
+ cohttp cohttp_server fmt.tty core_unix.command_unix))
-version: "4.0.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: [
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
"ocaml" {>= "4.08"}
- "dune" {>= "1.1.0"}
- "cohttp" {=version}
- "cohttp-lwt" {=version}
+ "dune" {>= "2.0"}
+ "cohttp" {= version}
+ "cohttp-lwt" {= version}
+ "logs"
"lwt" {>= "3.0.0"}
+ "lwt_ppx" {with-test}
+ "conf-npm" {with-test}
"js_of_ocaml" {>= "3.3.0"}
"js_of_ocaml-ppx" {>= "3.3.0"}
"js_of_ocaml-lwt" {>= "3.5.0"}
]
build: [
- ["dune" "subst"] {pinned}
+ ["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
let string_of_uint8array u8a offset len =
String.init len (fun i -> Char.chr (Typed_array.unsafe_get u8a (offset + i)))
+module String_io = Cohttp__String_io
+module IO = Cohttp_lwt__String_io
+module Header_io = Cohttp__Header_io.Make (IO)
+
module 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
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 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
(* ??? *)
end
-module String_io = Cohttp__String_io
-module IO = Cohttp_lwt__String_io
-module Header_io = Cohttp__Header_io.Make (IO)
-
module Make_client_async (P : Params) = Make_api (struct
module Response = Cohttp.Response
module Request = Cohttp.Request
(fun k v ->
(* some headers lead to errors in the javascript console, should
we filter then out here? *)
- List.iter
- (fun v -> xml ## (setRequestHeader (Js.string k) (Js.string v)))
- v)
+ xml ## (setRequestHeader (Js.string k) (Js.string v)))
headers
in
match xml##.readyState with
| XmlHttpRequest.DONE -> (
try
- (* construct body *)
- let body =
- let b =
- let respText () =
- Js.Opt.case xml##.responseText
- (fun () -> `String (Js.string ""))
- (fun s -> `String s)
- in
- if xhr_response_supported then
- Js.Opt.case
- (File.CoerceTo.arrayBuffer xml##.response)
- (fun () ->
- Firebug.console##log
- (Js.string
- "XHR Response is not an arrayBuffer; using \
- responseText");
- respText ())
- (fun ab -> `ArrayBuffer ab)
- else respText ()
- in
- Bb.get b
- in
+ 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 =
- let resp_headers = Js.to_string xml##getAllResponseHeaders in
- let channel = String_io.open_in resp_headers in
Lwt.(
Header_io.parse channel >|= fun resp_headers ->
- Response.make ~version:`HTTP_1_1
+ Cohttp.Response.make ~version:`HTTP_1_1
~status:(C.Code.status_of_code xml##.status)
~flush:false (* ??? *)
~encoding:(CLB.transfer_encoding body)
~headers:resp_headers ())
in
- (* 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! *)
Lwt.wakeup wake (response, body)
- with e -> Lwt.wakeup_exn wake e)
+ with
+ | e
+ (* If we exhaust the stack, it is possible that
+ Lwt.wakeup just aboves 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 *)
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) ->
| Some headers ->
C.Header.iter
(fun k v ->
- List.iter
- (* some headers lead to errors in the javascript console, should
- we filter then out here? *)
- (fun v ->
- xml ## (setRequestHeader (Js.string k) (Js.string v)))
- 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 *)
let bs = binary_string body in
xml ## (send (Js.Opt.return (Obj.magic bs))))
>>= fun _body ->
- (* TODO: FIXME: looks like an indenting or cut-and-pasto here. Check this - avsm *)
- (* construct body *)
- let body =
- let b =
- let respText () =
- Js.Opt.case xml##.responseText
- (fun () -> `String (Js.string ""))
- (fun s -> `String s)
- in
- if xhr_response_supported then
- Js.Opt.case
- (File.CoerceTo.arrayBuffer xml##.response)
- (fun () ->
- Firebug.console##log
- (Js.string
- "XHR Response is not an arrayBuffer; using responseText");
- respText ())
- (fun ab -> `ArrayBuffer ab)
- else respText ()
- in
- Bb.get b
- in
-
+ 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 ->
*
}}}*)
-(** HTTP client for JavaScript using XMLHttpRequest. *)
+(** {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
(synopsis "XHR/Lwt based http client")
(preprocess
(pps js_of_ocaml-ppx))
- (libraries js_of_ocaml cohttp-lwt))
+ (libraries js_of_ocaml cohttp-lwt logs))
-version: "4.0.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: [
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
"ocaml" {>= "4.08"}
- "dune" {>= "1.1.0"}
- "conduit-lwt" {>= "1.0.3" & < "3.0.0"}
- "conduit-lwt-unix" {>= "1.0.3" & < "3.0.0"}
+ "dune" {>= "2.0"}
+ "conduit-lwt" {>= "5.0.0"}
+ "conduit-lwt-unix" {>= "5.0.0"}
"cmdliner"
"magic-mime"
"logs"
"fmt" {>= "0.8.2"}
- "cohttp-lwt" {=version}
+ "cohttp-lwt" {= version}
"ppx_sexp_conv" {>= "v0.13.0"}
"lwt" {>= "3.0.0"}
"base-unix"
"ounit" {with-test}
]
build: [
- ["dune" "subst"] {pinned}
+ ["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
| None -> output_body Lwt_io.stdout
| Some fname -> Lwt_io.with_file ~mode:Lwt_io.output fname output_body)
-let run_client verbose ofile uri meth =
- Lwt_main.run
- ( (if verbose then (
- (* activate debug sets the reporter *)
- Cohttp_lwt_unix.Debug.activate_debug ();
- Log.debug (fun d -> d ">>> Debug active");
- return ())
- else return ())
- >>= fun () -> client uri ofile meth )
+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 doc = "Set http method" in
Arg.(value & opt string "GET" & info [ "X"; "request" ] ~doc)
-let verb =
- let doc = "Display additional debugging to standard error." in
- Arg.(value & flag & info [ "v"; "verbose" ] ~doc)
+let verb = Logs_cli.level ()
let ofile =
let doc = "Output filename to store the URI into." in
in
Server.create ~mode config
-let lwt_start_proxy port host verbose cert key =
- Lwt_main.run (start_proxy port host verbose cert key ())
+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 doc = "TCP port to listen on." in
Arg.(value & opt int 8080 & info [ "p" ] ~docv:"PORT" ~doc)
-let verb =
- let doc = "Logging output to console." in
- Arg.(value & flag & info [ "v"; "verbose" ] ~doc)
+let verb = Logs_cli.level ()
let ssl_cert =
let doc = "SSL certificate file." in
let ctx = Cohttp_lwt_unix.Net.init ~ctx () in
Server.create ~ctx ~mode config
-let lwt_start_server docroot port host index verbose tls =
- if verbose <> None then (
- (* activate_debug sets the reporter *)
- Cohttp_lwt_unix.Debug.activate_debug ();
- Logs.set_level verbose);
+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
(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)
+ cmdliner conduit-lwt fmt.tty)
(package cohttp-lwt-unix)
(public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt))
open Lwt.Infix
-let default_reporter (file_descr, ppf) =
+let reporter file_descr ppf =
let ppf, flush =
let buf = Buffer.create 0x100 in
( Fmt.with_buffer ~like:ppf buf,
in
{ Logs.report }
-let set_log =
+let default_reporter = reporter Lwt_unix.stderr Fmt.stderr
+
+let set_logger =
lazy
- ((* If no reporter has been set by the application, set default one
+ (if
+ (* If no reporter has been set by the application, set default one
that prints to stderr *)
- if Logs.reporter () == Logs.nop_reporter then
- Logs.set_level @@ Some Logs.Debug;
- Logs.set_reporter (default_reporter (Lwt_unix.stderr, Fmt.stderr)))
+ Logs.reporter () == Logs.nop_reporter
+ then Logs.set_reporter default_reporter)
let activate_debug () =
- Lazy.force set_log;
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 () =
(** 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 ()
+ ]} *)
*
}}}*)
+(** 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 = Lwt_io.input_channel
type ctx = { ctx : Conduit_lwt_unix.ctx; resolver : Resolver_lwt.t }
[@@deriving sexp_of]
-let init ?(ctx = Conduit_lwt_unix.default_ctx)
+let init ?(ctx = Lazy.force Conduit_lwt_unix.default_ctx)
?(resolver = Resolver_lwt_unix.system) () =
{ ctx; resolver }
let default_ctx =
- { resolver = Resolver_lwt_unix.system; ctx = Conduit_lwt_unix.default_ctx }
+ {
+ resolver = Resolver_lwt_unix.system;
+ ctx = Lazy.force Conduit_lwt_unix.default_ctx;
+ }
let connect_uri ~ctx:{ ctx; resolver } uri =
Resolver_lwt.resolve_uri ~uri resolver >>= fun endp ->
include Server_core
open Lwt.Infix
-let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server module"
+let src =
+ Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt Unix server module"
module Log = (val Logs.src_log src : Logs.LOG)
(** The [Server] module implements the full UNIX HTTP server interface,
- including the UNIX-specific functions defined in {!S}. *)
+ 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
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\
let open Cohttp in
let open Cohttp_lwt_unix in
let expected =
- "POST /foo/bar HTTP/1.1\r\n\
- foo: bar\r\n\
- host: localhost\r\n\
- transfer-encoding: chunked\r\n\
- user-agent: "
+ "POST /foo/bar HTTP/1.1\r\nFoo: bar\r\nhost: localhost\r\nuser-agent: "
^ user_agent
- ^ "\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n"
+ ^ "\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
let open Cohttp in
let open Cohttp_lwt_unix in
let expected =
- "POST /foo/bar HTTP/1.1\r\n\
- foo: bar\r\n\
- host: localhost\r\n\
- transfer-encoding: chunked\r\n\
- user-agent: "
+ "POST /foo/bar HTTP/1.1\r\nfoo: bar\r\nhost: localhost\r\nuser-agent: "
^ user_agent
- ^ "\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n"
+ ^ "\r\ntransfer-encoding: chunked\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n"
in
let req =
Request.make ~encoding:Transfer.Chunked
-version: "4.0.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: [
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
"ocaml" {>= "4.08"}
- "dune" {>= "1.1.0"}
- "cohttp" {=version}
+ "dune" {>= "2.0"}
+ "cohttp" {= version}
"lwt" {>= "2.5.0"}
"sexplib0"
"ppx_sexp_conv" {>= "v0.13.0"}
"uri" {>= "2.0.0"}
]
build: [
- ["dune" "subst"] {pinned}
+ ["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
module Response = Make.Response (IO)
module Request = Make.Request (IO)
+ let src = Logs.Src.create "cohttp.lwt.client" ~doc:"Cohttp Lwt client"
+
+ module Log = (val Logs.src_log src : Logs.LOG)
+
type ctx = Net.ctx
let read_body ~closefn ic res =
Gc.finalise_last
(fun () ->
if not !closed then
- prerr_endline "Cohttp_lwt: body not consumed - leaking stream!")
+ Log.warn (fun m ->
+ m
+ "Body not consumed, leaking stream! Refer to \
+ https://github.com/mirage/ocaml-cohttp/issues/730 for \
+ additional details"))
stream;
body
| `No ->
(** 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. *)
+ 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 (IO : S.IO) (Net : S.Net with module IO = IO) :
S.Client with type ctx = Net.ctx
interface rather than invoke this function directly. See {!head}, {!get}
and {!post} for some examples.
+ To avoid leaks, the body needs to be consumed, using the functions
+ provided in the {!Body} module and, if not necessary, should be explicitly
+ drained calling {!Body.drain_body}. Leaks are logged as debug messages by
+ the client, these can be enabled activating the debug logging. For
+ example, this can be done as follows in [cohttp-lwt-unix]
+
+ {[
+ Cohttp_lwt_unix.Debug.activate_debug ();
+ Logs.set_level (Some Logs.Warning)
+ ]}
+
Depending on [ctx], the library is able to send a simple HTTP request or
an encrypted one with a secured protocol (such as TLS). Depending on how
conduit is configured, [ctx] might initiate a secured connection with TLS
(** 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. *)
+ 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
-version: "4.0.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: ["Anil Madhavapeddy" "Thomas Gazagnaire"]
and instructions on how to use this library."""
depends: [
"ocaml" {>= "4.08"}
- "dune" {>= "1.1.0"}
+ "dune" {>= "2.0"}
"mirage-flow" {>= "2.0.0"}
"mirage-channel" {>= "4.0.0"}
- "conduit" {>= "2.0.2" & <"3.0.0"}
- "conduit-mirage" {>= "2.0.2" & <"3.0.0"}
+ "conduit" {>= "2.0.2"}
+ "conduit-mirage" {>= "2.0.2"}
"mirage-kv" {>= "3.0.0"}
"lwt" {>= "2.4.3"}
- "cohttp" {=version}
- "cohttp-lwt" {=version}
+ "cohttp" {= version}
+ "cohttp-lwt" {= version}
+ "fmt" {>= "0.8.7"}
"astring"
"magic-mime"
"ppx_sexp_conv" {>= "v0.13.0"}
]
build: [
- ["dune" "subst"] {pinned}
+ ["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v4.0.0
+ * %%NAME%% %%VERSION%%
*)
open Lwt.Infix
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v4.0.0
+ * %%NAME%% %%VERSION%%
*)
open Lwt.Infix
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v4.0.0
+ * %%NAME%% %%VERSION%%
*)
(** Cohttp IO implementation using Mirage channels. *)
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v4.0.0
+ * %%NAME%% %%VERSION%%
*)
module Key = Mirage_kv.Key
open Lwt.Infix
open Astring
- let failf fmt = Fmt.kstrf Lwt.fail_with fmt
+ let failf fmt = Fmt.kstr Lwt.fail_with fmt
let read_fs t name =
FS.get t (Key.v name) >>= function
in
S.respond_string ~status:`OK ~body ~headers ())
(fun _exn ->
- let with_index = Fmt.strf "%s/index.html" path in
+ 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 ())
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v4.0.0
+ * %%NAME%% %%VERSION%%
*)
(** Serve static HTTP sites from a Mirage key-value store. *)
-version: "4.0.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: [
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
"ocaml" {>= "4.08"}
- "dune" {>= "1.1.0"}
- "cohttp" {=version}
+ "dune" {>= "2.0"}
+ "cohttp" {= version}
]
build: [
- ["dune" "subst"] {pinned}
+ ["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
-version: "4.0.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: [
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
"ocaml" {>= "4.08"}
- "dune" {>= "2.0.0"}
+ "dune" {>= "2.0"}
"re" {>= "1.9.0"}
"uri" {>= "2.0.0"}
"uri-sexp"
"fmt" {with-test}
"jsonm" {build}
"alcotest" {with-test}
+ "crowbar" {with-test}
]
build: [
- ["dune" "subst"] {pinned}
+ ["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
-dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
\ No newline at end of file
+dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git"
--- /dev/null
+(executable
+ (name fuzz_header)
+ (libraries crowbar cohttp))
+
+(rule
+ (alias runtest)
+ (package cohttp)
+ (action
+ (run ./fuzz_header.exe)))
+
+(rule
+ (alias fuzz)
+ (deps
+ (:exe fuzz_header.exe)
+ (source_tree inputs))
+ (action
+ (run afl-fuzz -i inputs -o findings -- ./%{exe} @@)))
+
+(rule
+ (alias bun-fuzz)
+ (locks %{project_root}/bun)
+ (deps
+ (:exe fuzz_me.exe)
+ (source_tree input))
+ (action
+ (run bun --input inputs --output findings -- ./%{exe})))
--- /dev/null
+(*{{{ Copyright (c) 2021 Carine Morel <carine@tarides.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *}}}*)
+
+module H = Cohttp.Header
+
+(** Here, we test the Header module with fuzzing. Some of these tests may be
+ redundant with Alcotest tests.
+
+ The tests are launched with [dune runtest] but can also be run with [afl]
+ with the command line : [dune build @cohttp/fuzz/fuzz --no-buffer].
+
+ The tests below reflects the semantics we want for each function, however in
+ some cases, it may actually be specific to the current implementation and
+ does not necessary need to be enforced in future implementations. To make it
+ clear, tests are annoted by their categories:
+
+ - FS (Functions semantics): tests the semantics described in the
+ documentation.
+
+ - SI (Specific to current Implementation): these tests are here to check the
+ implementation is doing what we think it is doing but may change
+ accordingly to implementation changes. *)
+
+(* Generators *)
+let list_value_headers =
+ [|
+ "accept";
+ "accept-charset";
+ "accept-encoding";
+ "accept-language";
+ "accept-ranges";
+ "allow";
+ "cache-control";
+ "connection";
+ "content-encoding";
+ "content-language";
+ "expect";
+ "if-match";
+ "if-none-match";
+ "link";
+ "pragma";
+ "proxy-authenticate";
+ "te";
+ "trailer";
+ "transfer-encoding";
+ "upgrade";
+ "vary";
+ "via";
+ "warning";
+ "www-authenticate";
+ |]
+
+(** Pick a random list-value header name from a predefined array of values. *)
+let list_value_header_gen =
+ let open Crowbar in
+ let gen =
+ map
+ [ range (Array.length list_value_headers) ]
+ (fun i -> list_value_headers.(i))
+ in
+ let printer fmt str = pp fmt "%s" str in
+ with_printer printer gen
+
+(** Generate a tchar following
+ {{:https://tools.ietf.org/html/rfc7230#appendix-B} RFC 7230}.
+
+ tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" /
+ "_" / "`" / "|" / "~" / DIGIT / ALPHA *)
+let tchar_gen =
+ let tchar_code_gen =
+ let uppercased_letter = Crowbar.range ~min:65 26 in
+ let lowercased_letter = Crowbar.range ~min:97 26 in
+ let others =
+ List.map
+ (fun i -> Crowbar.const i)
+ [
+ 33 (* ! *);
+ 35 (* # *);
+ 36 (* $ *);
+ 37 (* % *);
+ 38 (* & *);
+ 42 (* * *);
+ 43 (* + *);
+ 45 (* - *);
+ 46 (* . *);
+ 94 (* ^ *);
+ 95 (* _ *);
+ 96 (* ` *);
+ 124 (* | *);
+ 126 (* ~ *);
+ ]
+ |> Crowbar.choose
+ in
+ let digit_and_others = Crowbar.(choose [ others; range ~min:48 10 ]) in
+ Crowbar.(choose [ lowercased_letter; uppercased_letter; digit_and_others ])
+ in
+ Crowbar.(map [ tchar_code_gen ] (fun i -> Char.escaped (Char.chr i)))
+
+(** Generate a non-empty word of arbitrary length (composed of tchar only). *)
+let word_gen =
+ let open Crowbar in
+ let gen =
+ fix (fun word_gen ->
+ choose
+ [
+ (* one letter word *)
+ tchar_gen;
+ (* two letters word *)
+ map [ tchar_gen; tchar_gen ] (fun l1 l2 -> l1 ^ l2);
+ (* add one letter *)
+ map [ tchar_gen; word_gen ] (fun l w -> l ^ w);
+ ])
+ in
+ let printer = pp_string in
+ with_printer printer gen
+
+(** Generate an header name: either a predefined list-value header or a random
+ word *)
+let header_name_gen =
+ let open Crowbar in
+ let gen = choose [ list_value_header_gen; word_gen ] in
+ let printer = pp_string in
+ with_printer printer gen
+
+let header_printer fmt (k, v) = Crowbar.pp fmt "%s, %s" k v
+
+(** Generate a header key/value pair *)
+let header_gen : (string * string) Crowbar.gen =
+ let open Crowbar in
+ let gen_setcookie = pair (const "Set-cookie") word_gen in
+ let gen_otherheader = pair header_name_gen word_gen in
+ let gen =
+ (* one in ten generated header is a "set-cookie" header *)
+ choose (gen_setcookie :: List.init 9 (fun _ -> gen_otherheader))
+ in
+ with_printer header_printer gen
+
+(** Generate a list of headers *)
+let header_list_gen : (string * string) list Crowbar.gen =
+ let open Crowbar in
+ let gen = list header_gen in
+ let printer = pp_list header_printer in
+ with_printer printer gen
+
+(** Generate a [Cohttp.Header.t] headers. *)
+let headers_gen : H.t Crowbar.gen =
+ let open Crowbar in
+ let gen =
+ fix (fun headers_gen ->
+ choose
+ [
+ (* empty header *)
+ const (H.init ());
+ (* add one pair (k, v) *)
+ map [ header_gen; headers_gen ] (fun (k, v) h -> H.add h k v);
+ (* add a list of headers *)
+ map [ headers_gen; header_list_gen ] (fun h l -> H.add_list h l);
+ ])
+ in
+ let printer fmt h = Crowbar.pp fmt "\n%s@." (H.to_string h) in
+ with_printer printer gen
+
+(* Tests *)
+(* Important note : keys must be lowercased before comparison *)
+let eqssl l1 l2 =
+ List.map (fun (k, v) -> (String.lowercase_ascii k, v)) l1
+ = List.map (fun (k, v) -> (String.lowercase_ascii k, v)) l2
+
+let is_empty_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, k, v. is_empty (add h k v) = false) *)
+ add_test ~name:"[is_empty] returns false on a non empty header"
+ [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+ check_eq false H.(is_empty (add h k v))))
+
+let init_with_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall k v. to_list (init_with k v) = [k, v] *)
+ add_test ~name:"[init_list k v] is [k, v]" [ header_name_gen; word_gen ]
+ (fun k v -> check_eq H.(to_list (init_with k v)) [ (k, v) ]))
+
+let mem_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall k. mem (init ()) k = false *)
+ add_test ~name:"[mem h k] on an empty header is always false"
+ [ header_name_gen ] (fun k -> check_eq false H.(mem (init ()) k));
+ (* SI *)
+ (* forall h, k. H.mem h k = List.(mem_assoc (String.lowercase_ascii x) (List.map (fun (k, v) -> String.lowercase_ascii k, v) (H.to_list h))) *)
+ add_test ~name:"Header.mem has the same behavior than List.mem_assoc"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ check_eq
+ H.(mem h k)
+ List.(
+ mem_assoc (String.lowercase_ascii k)
+ (List.map
+ (fun (k, v) -> (String.lowercase_ascii k, v))
+ (H.to_list h)))))
+
+let add_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall k, v, h. mem (add h k v) k = true *)
+ add_test ~name:"mem (add h k v) k = true"
+ [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+ check_eq true H.(mem (add h k v) k));
+ add_test
+ (* FS *)
+ (* forall h, k, v. to_list (add h k v) = to_list h @ [lowercase k, v] *)
+ ~name:"[add] adds a value at the header end"
+ [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+ check_eq (H.to_list h @ [ (k, v) ]) H.(to_list (add h k v))))
+
+let to_list_of_list_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h. to_list (of_list h) = h (with lowercase key comparison) *)
+ add_test ~name:"to_list (of_list h) = h" [ header_list_gen ] (fun h ->
+ check_eq ~eq:eqssl H.(to_list (of_list h)) h);
+
+ (* FS and RFC *)
+ (* forall h, k1, v1, k2, v2. to_list (add (add h k1 v1) k2 v2) = to_list \
+ h @ [k1, v1; k2, v2] *)
+ add_test ~name:"checking [to_list] order after multiple [add] calls"
+ [ headers_gen; header_name_gen; word_gen; header_name_gen; word_gen ]
+ (fun h k1 v1 k2 v2 ->
+ check_eq ~eq:eqssl
+ H.(to_list (add (add h k1 v1) k2 v2))
+ H.(to_list h @ [ (k1, v1); (k2, v2) ])))
+
+let add_opt_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall hopt, k, v.
+ add_opt hopt k v = | add h k v if hopt = Some h
+ | init_with k v if hopt = None *)
+ add_test ~name:"add_opt (Some h) = add and add_opt None = init_with"
+ [ option headers_gen; header_name_gen; word_gen ]
+ (fun hopt k v ->
+ check_eq
+ H.(match hopt with None -> init_with k v | Some h -> add h k v)
+ H.(add_opt hopt k v)))
+
+let add_unless_exists_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, k, v. if mem h k = true then add_unless_exists h k v = h *)
+ add_test ~name:"[add_unless_exists h k v] does nothing if k exists"
+ [ headers_gen; header_list_gen; header_name_gen; word_gen; word_gen ]
+ (fun h l k v1 v2 ->
+ (* A random header such as mem h k = true *)
+ let h = H.(add_list (add h k v1) l) in
+ check_eq H.(add_unless_exists h k v2) h);
+ (* FS *)
+ (* forall h, k, v. if mem h k = false then add_unless_exists h k v = add \
+ h k v *)
+ add_test ~name:"add_unless_exists = add if key does not exist"
+ [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+ (* Making sure as mem h k = false *)
+ guard (not (H.mem h k));
+ check_eq H.(add_unless_exists h k v) H.(add h k v)))
+
+let add_list () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, l. to_list (add_list h l) = to_list h @ l *)
+ add_test
+ ~name:"[add_list h l] adds all headers in [l] in order at the end of [h]"
+ [ headers_gen; header_list_gen ] (fun h l ->
+ check_eq ~eq:eqssl H.(to_list (add_list h l)) H.(to_list h @ l)))
+
+let add_multi () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, k, vs. add_multi h k vs = add_list h (List.map (fun v -> k, v) vs) *)
+ add_test ~name:"[add_list] and [add_multi] have compatible semantics"
+ [ headers_gen; header_name_gen; list word_gen ]
+ (fun h k vs ->
+ check_eq
+ H.(add_multi h k vs)
+ H.(add_list h (List.map (fun v -> (k, v)) vs)));
+ (* FS *)
+ (* forall h, k, l. get_multi (add_multi h k l) k = get_multi h k @ l *)
+ add_test ~name:"get_multi (add_multi h k l) k = get_multi h k @ l"
+ [ headers_gen; header_name_gen; Crowbar.list word_gen ]
+ (fun h k l ->
+ check_eq H.(get_multi (add_multi h k l) k) H.(get_multi h k @ l)))
+
+let get_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h k, if mem h k = false then get h k = None *)
+ add_test ~name:"[get h k] returns None if k does not exists in h"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ guard H.(not (mem h k));
+ check_eq H.(get h k) None);
+ (* FS *)
+ (* forall h k, get (add h k v) = Some v *)
+ add_test ~name:"get (add h k v) = Some v"
+ [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+ check_eq H.(get (add h k v) k) (Some v)))
+
+let get_multi_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h k, if mem h k = false then get_multi h k = [] *)
+ add_test ~name:"[get_multi h k] returns [] if k does not exists in h"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ guard H.(not (mem h k));
+ check_eq H.(get_multi h k) []);
+ (* FS *)
+ (* forall l1, l2, k, v.
+ get_multi (of_list (l1 @ [ (k, v) ] @ l2)) k =
+ get_multi (of_list l1) k @ [ v ] @ get_multi (of_list l2) k *)
+ add_test ~name:"[get_multi] returns values in transmission order"
+ [ header_list_gen; header_list_gen; header_name_gen; word_gen ]
+ (fun l1 l2 k v ->
+ check_eq
+ H.(get_multi (of_list (l1 @ [ (k, v) ] @ l2)) k)
+ H.(get_multi (of_list l1) k @ [ v ] @ get_multi (of_list l2) k));
+ (* FS and RFC7230§3.2.2 *)
+ (* forall h, v1, v2, forall k in list values headers.
+ get_multi (add (add h k v1) k v2)) k = get_multi h k @ [v1; v2] *)
+ add_test ~name:"headers order is preserved"
+ [ headers_gen; list_value_header_gen; word_gen; word_gen ]
+ (fun h k v1 v2 ->
+ check_eq
+ H.(get_multi (add (add h k v1) k v2) k)
+ (H.(get_multi h k) @ [ v1; v2 ])))
+
+let remove_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, k. mem (remove h k) k = false *)
+ add_test ~name:"[remove] removes all values associated to a key"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ check_eq false H.(mem (remove h k) k));
+ (* FS *)
+ (* forall h, k. remove (remove h k) k = remove h k*)
+ add_test ~name:"(fun x -> remove x k) is idempotent"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ check_eq H.(remove (remove h k) k) H.(remove h k)))
+
+let replace_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, k, v. get_multi (replace h k v) = [ v ] *)
+ add_test ~name:"[replace] replaces the last value and remove the others"
+ [ headers_gen; header_list_gen; header_name_gen; word_gen; word_gen ]
+ (fun h l k v1 v2 ->
+ check_eq H.(get_multi (replace h k v1) k) [ v1 ];
+ (* This second check is to make sure the case where mem h k = true is tested *)
+ let h =
+ H.(add_list (add h k v1) l)
+ (* h is built such as mem h k = true *)
+ in
+ check_eq H.(get_multi (replace h k v2) k) [ v2 ]);
+ (* FS *)
+ (* forall h, k, v. if mem h k = false then replace h k v = add h k v) *)
+ add_test ~name:"replace h k v = add h k v if k does not exists in h"
+ [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+ guard H.(mem h k = false);
+ check_eq H.(replace h k v) H.(add h k v));
+ (* SI *)
+ (* forall h, l, k, v1, v2.
+ if mem (of_list l) k = false then
+ replace (add_list h ([ k, v1 ] @ l)) k v2 =
+ add_list (add (remove h k) k v2) l k) *)
+ add_test ~name:"[replace] does not change headers order"
+ [ headers_gen; header_list_gen; header_name_gen; word_gen; word_gen ]
+ (fun h l k v1 v2 ->
+ guard H.(not (mem (of_list l) k));
+ (* A random headers such as mem h k = true *)
+ let h1 = H.(add_list h ([ (k, v1) ] @ l)) in
+ let h2 = H.(add_list (remove h k) ([ (k, v2) ] @ l)) in
+ check_eq ~eq:eqssl H.(to_list (replace h1 k v2)) H.(to_list h2)))
+
+let update_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h k, update h k id = h *)
+ add_test ~name:"[update h k id] does nothing"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ check_eq H.(update h k (fun x -> x)) h);
+ (*FS*)
+ (* forall h k f, remove (update h k f) k = remove h k *)
+ add_test ~name:"[update h k _] only changes k "
+ [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+ check_eq H.(remove (update h k (fun _ -> None)) k) H.(remove h k);
+ check_eq H.(remove (update h k (fun _ -> Some w)) k) H.(remove h k));
+ (*FS*)
+ add_test ~name:"[update h k (fun _ -> None)] removes last occurence of k."
+ [ headers_gen; header_name_gen ] (fun h k ->
+ let h1 = H.update h k (fun _ -> None) in
+ let r1 = H.get_multi h1 k in
+ let r2 =
+ match List.rev (H.get_multi h k) with
+ | [] -> []
+ | _ :: xs -> List.rev xs
+ in
+ check_eq r1 r2);
+ (*FS*)
+ add_test
+ ~name:
+ "[update h k (function Some _ -> Some w)] replaces last occurence of k."
+ [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+ let h1 = H.update h k (fun _ -> Some w) in
+ let r1 = H.get_multi h1 k in
+ let r2 =
+ match List.rev (H.get_multi h k) with
+ | [] -> [ w ]
+ | _ :: xs -> List.rev (w :: xs)
+ in
+ check_eq r1 r2))
+
+let update_all_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h k, update_all h k id = h *)
+ add_test ~name:"[update_all h k id] does nothing"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ check_eq H.(update_all h k (fun x -> x)) h);
+ (*FS*)
+ (* forall h k f, remove (update_all h k f) k = remove h k *)
+ add_test ~name:"[update_all h k _] only changes k "
+ [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+ check_eq H.(remove (update_all h k (fun _ -> [])) k) H.(remove h k);
+ check_eq H.(remove (update_all h k (fun _ -> [ w ])) k) H.(remove h k));
+ (*FS*)
+ add_test ~name:"[update_all h k (fun _ -> [])] removes all occurences of k."
+ [ headers_gen; header_name_gen ] (fun h k ->
+ let h1 = H.update_all h k (fun _ -> []) in
+ check_eq H.(get_multi h1 k) []);
+ (*FS*)
+ add_test
+ ~name:
+ "[update_all h k (function _ -> [w])] removes all occurences of k and \
+ adds w." [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+ let h1 = H.update_all h k (fun _ -> [ w ]) in
+ let r1 = H.get_multi h1 k in
+ let r2 = [ w ] in
+ check_eq r1 r2))
+
+let get_multi_concat_test () =
+ Crowbar.(
+ (* FS *)
+ (* forall h, k. if mem h k = false then get_multi_concat h k = None *)
+ add_test
+ ~name:"[get_multi_concat h k] returns \"\" if k does not exists in h"
+ [ headers_gen; header_name_gen ] (fun h k ->
+ guard H.(not (mem h k));
+ check_eq H.(get_multi_concat h k) None);
+ (* FS *)
+ (* forall h, k. get_multi_concat ~list_value_only:true h k = get h k
+ if k is not a list value header *)
+ add_test ~name:"[get_multi_concat] optional argument works properly"
+ [ headers_gen; word_gen ] (fun h k ->
+ guard (not (Array.mem (String.lowercase_ascii k) list_value_headers));
+ check_eq H.(get_multi_concat ~list_value_only:true h k) H.(get h k));
+ (* FS - Very important for RFC 7230.3.2.2 *)
+ add_test ~name:"[get_multi_concat] returns values in transmission order"
+ [ header_list_gen; header_list_gen; header_name_gen; word_gen ]
+ (fun l1 l2 k v ->
+ let str_opt ?(bfr = false) ?(aft = false) s =
+ match s with
+ | None -> ""
+ | Some v -> if bfr then "," ^ v else if aft then v ^ "," else v
+ in
+ check_eq
+ H.(str_opt (get_multi_concat (of_list (l1 @ [ (k, v) ] @ l2)) k))
+ H.(
+ str_opt ~aft:true (get_multi_concat (of_list l1) k)
+ ^ v
+ ^ str_opt ~bfr:true (get_multi_concat (of_list l2) k))))
+
+(* Note : clean_dup does nothing to already concatenated headers. For
+ example, ["a", "v1,v2"] will be not be cleaned. *)
+let clean_dup_test () =
+ Crowbar.(
+ (* FS *)
+ (* Check that there is no more duplicates (except set-cookie). *)
+ add_test
+ ~name:
+ "All headers name in [h] appears strictly once in [clean_dup h] except \
+ for [set-cookie]" [ headers_gen ] (fun h ->
+ let h = H.remove h "set-cookie" in
+ let h = H.(to_list (clean_dup h)) in
+ let compare_key (k, _) (k', _) = compare k k' in
+ check_eq (List.sort_uniq compare_key h) (List.sort compare_key h));
+ (* FS *)
+ (* forall h, k in list_value_headers.
+ String.concat "," (get_multi_concat h k) = get (clean_dup h) k *)
+ add_test ~name:"[clean_dup] concatenates properly list-value headers"
+ [ headers_gen; list_value_header_gen ] (fun h k ->
+ check_eq H.(get_multi_concat h k) H.(get (clean_dup h) k));
+ (* FS *)
+ (* forall h. clean_dup (clean_dup h) = clean_dup h *)
+ add_test ~name:"[clean_dup] is idempotent" [ headers_gen ] (fun h ->
+ check_eq H.(clean_dup (clean_dup h)) H.(clean_dup h));
+ (* FS *)
+ (* forall h. get_multi (clean_dup h) "set-cookie" = get_multi h "set-cookie"*)
+ add_test ~name:"[clean_dup] does nothing to [set-cookie] headers"
+ [ headers_gen ] (fun h ->
+ check_eq
+ H.(get_multi h "set-cookie")
+ H.(get_multi (clean_dup h) "set-cookie"));
+ (* FS *)
+ (* As the generated header values are only composed of tchar (it
+ does not generate concatenated values like "gzip,chunked"), the
+ only cases where there are commas in a value is if [clean_dup]
+ concatenated multiple values.
+
+ This test checks that only one value is kept for non-list-value
+ headers and that this value is the last one. *)
+ add_test
+ ~name:"Only list-value headers can have multiple concatenated values "
+ [ headers_gen ] (fun h ->
+ (* As it is an exception, [set-cookie] is removed. *)
+ let h = H.remove h "set-cookie" in
+ let h' = H.(clean_dup h) in
+ let has_multiple_values v =
+ match String.split_on_char ',' v with
+ | [] | [ _ ] -> false
+ | _ -> true
+ in
+ check_eq true
+ H.(
+ fold
+ (fun k v b ->
+ if Array.mem k list_value_headers then b
+ else if has_multiple_values v then false
+ else b && get h k = Some v)
+ h' true)))
+
+let () =
+ init_with_test ();
+ is_empty_test ();
+ mem_test ();
+ add_test ();
+ to_list_of_list_test ();
+ add_opt_test ();
+ add_unless_exists_test ();
+ add_list ();
+ add_multi ();
+ get_test ();
+ get_multi_test ();
+ get_multi_concat_test ();
+ remove_test ();
+ replace_test ();
+ update_test ();
+ update_all_test ();
+ clean_dup_test ();
+ ()
--- /dev/null
+something
\ No newline at end of file
*
}}}*)
-module LString : sig
- type t
-
- val of_string : string -> t
- val to_string : t -> string
- val compare : t -> t -> int
-end = struct
- type t = string
-
- let of_string x = String.lowercase_ascii x
- let to_string x = x
- let compare a b = String.compare a b
-end
-
-module StringMap = Map.Make (LString)
-
-type t = string list StringMap.t
-
-let user_agent = Printf.sprintf "ocaml-cohttp/%s" Conf.version
-let compare = StringMap.compare Stdlib.compare
-
-let headers_with_list_values =
- Array.map LString.of_string
- [|
- "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_transfer_encoding =
- let k = LString.of_string "transfer-encoding" in
- fun k' -> LString.compare k k' = 0
-
-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 init () = StringMap.empty
-let is_empty x = StringMap.is_empty x
-let init_with k v = StringMap.singleton (LString.of_string k) [ v ]
-
-let add h k v =
- let k = LString.of_string k in
- try
- if is_transfer_encoding k then
- StringMap.add k (StringMap.find k h @ [ v ]) h
- else StringMap.add k (v :: StringMap.find k h) h
- with Not_found -> StringMap.add k [ v ] h
-
+let caseless_equal a b =
+ if a == b then true
+ else
+ let len = String.length a in
+ len = String.length b
+ &&
+ let stop = ref false in
+ let idx = ref 0 in
+ while (not !stop) && !idx < len do
+ let c1 = String.unsafe_get a !idx in
+ let c2 = String.unsafe_get b !idx in
+ if Char.lowercase_ascii c1 <> Char.lowercase_ascii c2 then stop := true;
+ incr idx
+ done;
+ not !stop
+
+type t = (string * string) list
+
+let compare = Stdlib.compare
+let init () = []
+let is_empty = function [] -> true | _ -> false
+let init_with k v = [ (k, v) ]
+
+let mem h k =
+ let rec loop = function
+ | [] -> false
+ | (k', _) :: h' -> if caseless_equal k k' then true else loop h'
+ in
+ loop h
+
+let add h k v : t = (k, v) :: h
let add_list h l = List.fold_left (fun h (k, v) -> add h k v) h l
let add_multi h k l = List.fold_left (fun h v -> add h k v) h l
-let add_opt h k v = match h with None -> init_with k v | Some h -> add h k v
-let remove h k =
- let k = LString.of_string k in
- StringMap.remove k h
+let add_opt h_opt k v =
+ match h_opt with None -> init_with k v | Some h -> add h k v
-let replace h k v =
- let k = LString.of_string k in
- StringMap.add k [ v ] h
+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 k = LString.of_string k in
- try
- let v = StringMap.find k h in
- if is_header_with_list_value k then Some (String.concat "," v)
- else Some (List.hd v)
- with Not_found | Failure _ -> None
+ let rec loop h =
+ match h with
+ | [] -> None
+ | (k', v) :: h' -> if caseless_equal k k' then Some v else loop h'
+ in
+ loop h
+
+let get_multi (h : t) (k : string) =
+ let rec loop h acc =
+ match h with
+ | [] -> acc
+ | (k', v) :: h' ->
+ if caseless_equal k k' then loop h' (v :: acc) else loop h' acc
+ in
+ loop h []
+
+let remove h k =
+ let rec loop seen = function
+ | [] -> if seen then [] else raise Not_found
+ | (k', _) :: h when caseless_equal k k' -> loop true h
+ | x :: h -> x :: loop seen h
+ in
+ try loop false h with Not_found -> h
+
+let remove_last h k =
+ let rec loop seen = function
+ | [] -> raise Not_found
+ | (k', _) :: h when caseless_equal k k' -> h
+ | x :: h -> x :: loop seen h
+ in
+ try loop false h with Not_found -> h
+
+let replace_ last h k v =
+ let rec loop seen = function
+ | [] -> if seen then [] else raise Not_found
+ | (k'', _) :: h when caseless_equal k k'' ->
+ if last then (k'', v) :: h
+ else if not seen then (k, v) :: loop true h
+ else loop seen h
+ | x :: h -> x :: loop seen h
+ in
+ try loop false h with Not_found -> add h k v
+
+let replace = replace_ false
let update h k f =
let vorig = get h k in
- let k = LString.of_string k in
match (f vorig, vorig) with
- | None, _ -> StringMap.remove k h
+ | None, None -> h
+ | None, _ -> remove_last h k
| Some s, Some s' when s == s' -> h
- | Some s, _ ->
- let v' =
- if is_header_with_list_value k then String.split_on_char ',' s
- else [ s ]
- in
- StringMap.add k v' h
+ | Some s, _ -> replace_ true h k s
-let mem h k = StringMap.mem (LString.of_string k) h
-let add_unless_exists h k v = if mem h k then h else add h k v
+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 add_opt_unless_exists h k v =
- match h with None -> init_with k v | Some h -> add_unless_exists h k v
+let map (f : string -> string -> string) (h : t) : t =
+ List.map
+ (fun (k, v) ->
+ let vs' = f k v in
+ (k, vs'))
+ h
-let get_multi h k =
- let k = LString.of_string k in
- try StringMap.find k h with Not_found -> []
+let iter (f : string -> string -> unit) (h : t) : unit =
+ List.iter (fun (k, v) -> f k v) h
-let map fn h = StringMap.mapi (fun k v -> fn (LString.to_string k) v) h
-let iter fn h = ignore (map fn 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 fold fn h acc =
- StringMap.fold
- (fun k v acc ->
- List.fold_left (fun acc v -> fn (LString.to_string k) v acc) acc v)
- h acc
+let of_list h = List.rev h
+let to_list h = List.rev h
-let of_list l = List.fold_left (fun h (k, v) -> add h k v) (init ()) l
-let to_list h = List.rev (fold (fun k v acc -> (k, v) :: acc) h [])
-let header_line k v = Printf.sprintf "%s: %s\r\n" k v
-let to_lines h = List.rev (fold (fun k v acc -> header_line k v :: acc) h [])
+let to_lines (h : t) =
+ let header_line k v = Printf.sprintf "%s: %s\r\n" k v in
+ List.fold_left (fun acc (k, v) -> header_line k v :: acc) [] h
-let to_frames =
- let to_frame k v acc = Printf.sprintf "%s: %s" k v :: acc in
- fun h -> List.rev (fold to_frame h [])
+let to_frames h =
+ let to_frame k v = Printf.sprintf "%s: %s" k v in
+ List.fold_left (fun acc (k, v) -> to_frame k v :: acc) [] h
let to_string h =
let b = Buffer.create 128 in
- h
- |> iter (fun k v ->
- v
- |> List.iter (fun v ->
- Buffer.add_string b k;
- Buffer.add_string b ": ";
- Buffer.add_string b v;
- Buffer.add_string b "\r\n"));
+ 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 =
| None -> None
let get_acceptable_media_ranges headers =
- Accept.media_ranges (get headers "accept")
+ Accept.media_ranges (get_multi_concat ~list_value_only:true headers "accept")
let get_acceptable_charsets headers =
- Accept.charsets (get headers "accept-charset")
+ Accept.charsets
+ (get_multi_concat ~list_value_only:true headers "accept-charset")
let get_acceptable_encodings headers =
- Accept.encodings (get headers "accept-encoding")
+ Accept.encodings
+ (get_multi_concat ~list_value_only:true headers "accept-encoding")
let get_acceptable_languages headers =
- Accept.languages (get headers "accept-language")
+ Accept.languages
+ (get_multi_concat ~list_value_only:true headers "accept-language")
(* Parse the transfer-encoding and content-length headers to
* determine how to decode a body *)
let get_transfer_encoding headers =
- match get headers "transfer-encoding" with
+ (* It should actually be [get] as the interresting value is actually the last.*)
+ match get_multi_concat ~list_value_only:true headers "transfer-encoding" with
| Some "chunked" -> Transfer.Chunked
| Some _ | None -> (
match get_content_range headers with
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
*
}}}*)
-(** Map of HTTP header key and value(s) associated with them. Since HTTP headers
- can contain duplicate keys, this structure can return a list of values
- associated with a single key. *)
-
+(** Associative list representing HTTP headers. Order of transmission is
+ preserved, which implies that headers with same name are neither removed or
+ concataned by default (see [clean_dup] to do that). *)
type t [@@deriving sexp]
(** The type for HTTP headers. *)
val init : unit -> t
-(** Construct a fresh, empty map of HTTP headers. *)
+(** [init ()] constructs a fresh, empty list of HTTP headers. *)
val is_empty : t -> bool
-(** Test whether HTTP headers are empty or not. *)
+(** [is_empty h] tests whether HTTP headers [h] are empty or not. *)
+
+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
-(** Construct a fresh map of HTTP headers with a single key and value entry. *)
+(** [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 a key and value to an existing header map. *)
+(** [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 multiple key and value pairs to an existing header map. *)
+(** [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 multiple values to a key in an existing header map. *)
+(** [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
-(** Given an optional header, either update the existing one with a key and
- value, or construct a fresh header with those values if the header is
+(** [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
-(** Given a header, update it with the key and value unless the key is already
- present in the header. *)
+(** [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] updates [h] with the key [k] and value [v]
- unless the key is already present in the header. If [h] is [None] then a
- fresh header is allocated containing the key [k] and the value [v]. *)
+(** [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 a key from the header map and return a fresh header set. The original
- header parameter is not modified. *)
+(** [remove h k] removes every values associated to the header name [k] from
+ [h]. *)
val replace : t -> string -> string -> t
-(** Replace the value of a key from the header map if it exists, otherwise it
- adds it to the header map. The original header parameter is not modified. *)
+(** [replace h k v] replaces the last added value of [k] from [h] and removed
+ all other occurences of [k] if it exists. Otherwise it adds [(k, v)] to [h].
-val update : t -> string -> (string option -> string option) -> t
-(** [update h k f] returns a map containing the same headers as [h], except for
- the header [k]. Depending on the value of [v] where [v] is [f (get h k)],
- the header [k] is added, removed or updated. If [v] is [None], the header is
- removed if it exists; otherwise, if [v] is [Some z] then [k] is associated
- to [z] in the resulting headers. If [k] was already associated in [h] to a
- value that is physically equal to [z], [h] is returned unchanged. Similarly
- as for [get], if the header is one of the set of headers defined to have
- list values, then all of the values are concatenated into a single string
- separated by commas and passed to [f], while the return value of [f] is
- split on commas and associated to [k]. If it is a singleton header, then the
- first value is passed to [f] and no concatenation is performed, similarly
- for the return value. The original header parameters are not modified. *)
+ {e Invariant:} [forall h, k, v. get_multi (replace h k v) = \[ v \]] *)
val mem : t -> string -> bool
-(** Check if a key exists in the header. *)
+(** [mem h k] returns [true] if the header name [k] appears in [h] and [false]
+ otherwise. *)
val compare : t -> t -> int
-(** Structural comparison of two [Header] values. *)
+(** [compare h h'] is the structural comparison of two [Header] values. *)
val get : t -> string -> string option
-(** Retrieve a key from a header. If the header is one of the set of headers
- defined to have list values, then all of the values are concatenated into a
- single string separated by commas and returned. If it is a singleton header,
- then the first value is selected and no concatenation is performed. *)
+(** [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
-(** Retrieve all of the values associated with a key *)
+(** [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 occurence 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;
-val iter : (string -> string list -> unit) -> t -> unit
-val map : (string -> string list -> string list) -> t -> t
+ - 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 occurences 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 of_list : (string * string) list -> t
-val to_list : t -> (string * string) list
val to_lines : t -> string list
-(** Return header fieds as a list of lines. Beware that each line ends with
- "\r\n" characters. *)
+(** [to_lines h] returns header fieds as a list of lines. Beware that each line
+ ends with "\r\n" characters. *)
val to_frames : t -> string list
-(** Same as {!to_lines} but lines do not end with "\r\n" characters. *)
+(** [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
open IO
module Transfer_IO = Transfer_io.Make (IO)
- let rev _k v = List.rev v
-
let parse ic =
(* consume also trailing "^\r\n$" line *)
let rec parse_headers' headers =
read_line ic >>= function
- | Some "" | None -> return (Header.map rev headers)
+ | Some "" | None -> return headers
| Some line -> (
match split_header line with
- | [ hd; tl ] ->
- let header = String.lowercase_ascii hd in
- parse_headers' (Header.add headers header tl)
+ | [ hd; tl ] -> parse_headers' (Header.add headers hd tl)
| _ -> return headers)
in
parse_headers' (Header.init ())
(executable
(name test_header)
- (modules test_header)
+ (modules unitary_test_header test_header)
(forbidden_libraries base)
(libraries cohttp alcotest fmt))
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*}}}*)
-open Printf
module String_io = Cohttp__String_io
module StringResponse = Cohttp.Response.Make (String_io.M)
-module HIO = Cohttp__Header_io.Make (String_io.M)
module H = Cohttp.Header
let aes = Alcotest.check Alcotest.string
"media type" (Some "foo/bar")
(Cohttp.Header.get_media_type header)
-let list_valued_header () =
- let h = H.init () in
- let h = H.add h "accept" "foo" in
- let h = H.add h "accept" "bar" in
- aeso "list valued header" (H.get h "accept") (Some "bar,foo")
-
-let t_header =
- Alcotest.testable
- (fun fmt h ->
- let sexp = Cohttp.Header.sexp_of_t h in
- Sexplib0.Sexp.pp_hum fmt sexp)
- (fun x y -> Cohttp.Header.compare x y = 0)
-
-let 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 many_headers () =
- let size = 1000000 in
- let rec add_header num h =
- match num with
- | 0 -> h
- | n ->
- let k = sprintf "h%d" n in
- let v = 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
-
-module Updates = struct
- 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 replace_headers_if_exists () =
- let h = H.replace h "second" "2a" in
- Alcotest.(check (option string))
- "replace_existing_header" (Some "2a") (H.get h "second")
-
- let replace_headers_if_absent () =
- let h = H.replace h "third" "3" in
- Alcotest.(check (option string))
- "replace_new_header" (Some "3") (H.get h "third")
-
- let update_headers_if_exists () =
- let h1 =
- H.update h "second" (function Some _ -> Some "2a" | None -> None)
- in
- let h2 = H.replace h "second" "2a" in
- Alcotest.(check t_header) "update_existing_header" h1 h2
-
- let update_headers_if_exists_rm () =
- let h1 =
- H.update h "second" (function Some _ -> None | None -> Some "3")
- in
- let h2 = H.remove h "second" in
- Alcotest.(check t_header) "update_remove_header" h1 h2
-
- let update_headers_if_absent_add () =
- let h = H.update h "third" (function Some _ -> None | None -> Some "3") in
- Alcotest.(check (option string))
- "update_add_new_header" (Some "3") (H.get h "third")
-
- let update_headers_if_absent_rm () =
- let h1 = H.update h "third" (function _ -> None) in
- Alcotest.(check t_header) "update_remove_absent_header" h h1
-
- let update_headers_if_exists_multi () =
- let h1 =
- H.update h "accept" (function
- | Some v -> Some ("baz," ^ v)
- | None -> None)
- in
- let h2 = H.add h "accept" "baz" in
- Alcotest.(check (option string))
- "update_existing_header_multivalued" (H.get h1 "accept")
- (H.get h2 "accept")
-
- let update_headers_if_absent () =
- let h1 =
- H.update h "third" (function Some _ -> Some "3" | None -> None)
- in
- Alcotest.(check t_header) "update_new_header: unchanged" h h1;
- Alcotest.(check (option string))
- "update_new_header: map unchanged" None (H.get h "third")
-end
-
module Content_range = struct
let h1 = H.of_list [ ("Content-Length", "123") ]
let h2 = H.of_list [ ("Content-Range", "bytes 200-300/1000") ]
in
let h = headers_of_response "concat Cache-Control" resp in
aeso "test_cachecontrol_concat" (Some "public,max-age:86400")
- (H.get h "Cache-Control")
-
-let transfer_encoding () =
- 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 h "transfer-encoding" in
- aeso "transfer_encoding_get_is_ordered" (Some "gzip,chunked") sh
+ (H.get_multi_concat h "Cache-Control")
let () = Printexc.record_backtrace true
("content-range", `Quick, Content_range.content_range);
] );
("Cache Control", [ ("concat", `Quick, test_cachecontrol_concat) ]);
- ( "Header",
- [
- ("get list valued", `Quick, list_valued_header);
- ("trim whitespace", `Quick, trim_ws);
- ("replace existing", `Quick, Updates.replace_headers_if_exists);
- ("replace absent", `Quick, Updates.replace_headers_if_absent);
- ("update existing", `Quick, Updates.update_headers_if_exists);
- ( "update existing list",
- `Quick,
- Updates.update_headers_if_exists_multi );
- ("update add absent", `Quick, Updates.update_headers_if_absent_add);
- ("update rm existing", `Quick, Updates.update_headers_if_exists_rm);
- ("update rm absent", `Quick, Updates.update_headers_if_absent_rm);
- ("update absent", `Quick, Updates.update_headers_if_absent);
- ("many headers", `Slow, many_headers);
- ("transfer encoding is in correct order", `Quick, transfer_encoding);
- ]
- @
- if Sys.word_size = 64 then [ ("large header", `Slow, large_header) ]
- else [] );
+ Unitary_test_header.tests;
]
--- /dev/null
+(*{{{ Copyright (c) 2021 Carine Morel <carine@tarides.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *}}}*)
+
+module H = Cohttp.Header
+(** These tests try as much as possible to tests each header functions
+ independently. *)
+
+let aei = Alcotest.check Alcotest.int
+let aes = Alcotest.check Alcotest.string
+let aeso = Alcotest.check Alcotest.(option string)
+let aesl = Alcotest.check Alcotest.(list string)
+let aessl = Alcotest.check Alcotest.(list (pair string string))
+let aeb = Alcotest.check Alcotest.bool
+
+let t_header =
+ Alcotest.testable
+ (fun fmt h ->
+ let sexp = Cohttp.Header.sexp_of_t h in
+ Sexplib0.Sexp.pp_hum fmt sexp)
+ (fun x y -> Cohttp.Header.compare x y = 0)
+
+let aeh = Alcotest.check t_header
+
+let hstr =
+ [
+ ("accept", "application/xml");
+ ("transfer-encoding", "chunked");
+ ("accept", "text/html");
+ ("content-length", "100");
+ ]
+
+let prebuilt = H.of_list hstr
+let to_list_rev h = List.rev (H.to_list h)
+
+let to_list_tests () =
+ aessl "to_list (init ())" [] H.(to_list (init ()));
+ aessl "to_list (add (init ()) k v"
+ [ ("a", "a1") ]
+ H.(to_list (add (init ()) "a" "a1"));
+ aessl "to_list (of_list h) = h" hstr H.(to_list prebuilt)
+
+let is_empty_tests () =
+ aeb "is_empty (init ())" true H.(is_empty (init ()));
+ aeb "is_empty (add (init ()) k v" false H.(is_empty (add (init ()) "a" "a1"));
+ aeb "is_empty (remove (add (init ()) k v) k)" true
+ H.(is_empty (remove (add (init ()) "a" "a1") "a"))
+
+let init_with_tests () =
+ aessl "init_with k v"
+ [ ("traNsfer-eNcoding", "chunked") ]
+ H.(to_list (init_with "traNsfer-eNcoding" "chunked"))
+
+let mem_tests () =
+ aeb "mem (init ()) k = false" false H.(mem (init ()) "a");
+ aeb "mem h k" true H.(mem prebuilt "accept");
+ aeb "mem h k" true H.(mem prebuilt "content-length");
+ aeb "mem h k" false H.(mem prebuilt "a")
+
+let add_tests () =
+ aessl "add h k v" (hstr @ [ ("a", "a1") ]) H.(to_list (add prebuilt "a" "a1"));
+ aessl "add (add h k v) k v"
+ (hstr @ [ ("a", "a1"); ("a", "a1") ])
+ H.(to_list (add (add prebuilt "a" "a1") "a" "a1"));
+ aessl "add (add h k' v') k v"
+ (hstr @ [ ("a", "a1"); ("b", "b1") ])
+ H.(to_list (add (add prebuilt "a" "a1") "b" "b1"))
+
+let get_tests () =
+ aeso "get (add (init () k v) k" (Some "a1")
+ H.(get (add (init ()) "a" "a1") "a");
+ aeso "get (add h k v) k when mem h k = false" (Some "a1")
+ H.(get (add prebuilt "a" "a1") "a");
+ aeso "get (add h k v) k when mem h k = true" (Some "text/html")
+ H.(get (add prebuilt "a" "a1") "accept");
+ aeso "get (add (add h k v') k v) k = v" (Some "a2")
+ H.(get (add (add prebuilt "a" "a1") "a" "a2") "a")
+
+let add_list_tests () =
+ let l = [ ("a", "a1"); ("b", "b1") ] in
+ aessl "add_list (init ()) []" [] H.(to_list (add_list (init ()) []));
+ aessl "add_list (init ()) l" l H.(to_list (add_list (init ()) l));
+ aessl "add_list h []" hstr H.(to_list (add_list prebuilt []));
+ aessl "add_list h [k, v]"
+ (hstr @ [ ("a", "a1") ])
+ H.(to_list (add_list prebuilt [ ("a", "a1") ]));
+ aessl "add_list h l" (hstr @ l) H.(to_list (add_list prebuilt l))
+
+let add_multi_tests () =
+ let k, vals = ("a", [ "a1"; "a2"; "a3" ]) in
+ let l = List.map (fun v -> ("a", v)) vals in
+ aessl "add_multi (init ()) k []" [] H.(to_list (add_multi (init ()) k []));
+ aessl "add_multi (init ()) k vals" l H.(to_list (add_multi (init ()) k vals));
+ aessl "add_multi h k []" hstr H.(to_list (add_multi prebuilt k []));
+ aessl "add_multi h k vals" (hstr @ l) H.(to_list (add_multi prebuilt k vals))
+
+let add_unless_exists_tests () =
+ let k, v = ("a", "a1") in
+ let k', v' = ("transfer-encoding", "chunked") in
+ let k'', v'' = ("accept", "text/*") in
+ aessl "add_unless_exists (init ()) k v"
+ [ (k, v) ]
+ H.(to_list (add_unless_exists (init ()) k v));
+ aessl "add_unless_exists h k v when mem h k = false"
+ (hstr @ [ (k, v) ])
+ H.(to_list (add_unless_exists prebuilt k v));
+ aessl "add_unless_exists h k v when mem h k = true)" hstr
+ H.(to_list (add_unless_exists prebuilt k' v'));
+ aessl "add_unless_exists h k v when mem h k = true)" hstr
+ H.(to_list (add_unless_exists prebuilt k'' v''))
+
+let remove_tests () =
+ aessl "remove (init ()) k" [] H.(to_list (remove (init ()) "accept"));
+ aessl "remove (add (add (init ()) k v) k v) k" []
+ H.(to_list (remove (add (add (init ()) "k" "v") "k" "v") "k"));
+ aessl "remove h k when mem h k = false" hstr H.(to_list (remove prebuilt "a"));
+ aessl "remove h k when mem h k = true"
+ [
+ ("accept", "application/xml");
+ ("accept", "text/html");
+ ("content-length", "100");
+ ]
+ H.(to_list (remove prebuilt "transfer-encoding"));
+ aessl "remove h k when mem h k = true"
+ [ ("transfer-encoding", "chunked"); ("content-length", "100") ]
+ H.(to_list (remove prebuilt "accept"))
+
+let replace_tests () =
+ let k, v, v' = ("a", "a1", "a2") in
+ aessl "replace (init ()) k v" [ (k, v) ] H.(to_list (replace (init ()) k v));
+ aessl "replace (add (init ()) k v) k v"
+ [ (k, v) ]
+ H.(to_list (replace (add (init ()) k v) k v));
+ aessl "replace (add (init ()) k v) k v'"
+ [ (k, v') ]
+ H.(to_list (replace (add (init ()) k v) k v'));
+ aessl "replace h k v when mem h k = false"
+ (hstr @ [ (k, v) ])
+ H.(to_list (replace prebuilt k v));
+ aessl "replace h k v when mem h k = true"
+ [
+ ("accept", "application/xml");
+ ("transfer-encoding", "gzip");
+ ("accept", "text/html");
+ ("content-length", "100");
+ ]
+ H.(to_list (replace prebuilt "transfer-encoding" "gzip"));
+ aessl "replace h k v when mem h = true"
+ [
+ ("transfer-encoding", "chunked");
+ ("accept", "text/*");
+ ("content-length", "100");
+ ]
+ H.(to_list (replace prebuilt "accept" "text/*"))
+
+let h =
+ H.init () |> fun h ->
+ H.add h "first" "1" |> fun h ->
+ H.add h "second" "2" |> fun h ->
+ H.add h "accept" "foo" |> fun h -> H.add h "accept" "bar"
+
+let update_tests () =
+ let h1 =
+ H.update h "second" (function Some _ -> Some "2a" | None -> None)
+ in
+ let h2 = H.replace h "second" "2a" in
+ aeh "update existing header" h1 h2;
+ let h1 = H.update h "second" (function Some _ -> None | None -> Some "3") in
+ let h2 = H.remove h "second" in
+ aeh "update remove header" h1 h2;
+ let h1 =
+ H.update h "accept" (function Some _ -> Some "baz" | None -> None)
+ in
+ aesl "update existing header with multiple values"
+ H.(get_multi h1 "accept")
+ [ "foo"; "baz" ];
+ let h' = H.update h "third" (function Some _ -> None | None -> Some "3") in
+ aesl "update add new header" (H.get_multi h' "third") [ "3" ];
+ let h1 = H.update h "third" (function _ -> None) in
+ aeh "update_remove_absent_header" h h1;
+ let h1 = H.update h "third" (function Some _ -> Some "3" | None -> None) in
+ aeh "update_new_header: unchanged" h h1;
+ let h1 = H.update h "accept" (function Some _ -> None | None -> None) in
+ aeso "update_existing_header_remove_multivalue: remove last" (Some "foo")
+ (H.get h1 "accept")
+
+let update_all_tests () =
+ let h1 = H.update_all h "second" (function [] -> [] | _ -> [ "2a" ]) in
+ let h2 = H.(add (remove h "second") "second" "2a") in
+ aeh "update_all existing header" h1 h2;
+ let h1 = H.update_all h "second" (function [] -> [ "3" ] | _ -> []) in
+ let h2 = H.remove h "second" in
+ aeh "update_all remove header" h1 h2;
+ let h1 = H.update_all h "accept" (function [] -> [] | _ -> [ "baz" ]) in
+ aesl "update_all existing header with multiple values"
+ H.(get_multi h1 "accept")
+ [ "baz" ];
+ let h1 =
+ H.update_all h "accept" (function [] -> [] | xs -> xs @ [ "baz" ])
+ in
+ let h2 = H.add h "accept" "baz" in
+ aeso "update_all_existing_header_multivalued"
+ (H.get_multi_concat h1 "accept")
+ (H.get_multi_concat h2 "accept");
+ let h1 = H.update_all h "accept" (function _ -> []) in
+ aeh "update_all_existing_header_multivalue : remove all" (H.remove h "accept")
+ h1;
+ let h1 = H.update_all h "third" (function [] -> [ "3"; "33" ] | _ -> []) in
+ let h2 = H.add_multi h "third" [ "3"; "33" ] in
+ aeh "update add new header" h1 h2;
+ let h1 = H.update_all h "third" (function _ -> []) in
+ aeh "update_remove_absent_header" h h1;
+ let h1 = H.update_all h "third" (function [] -> [] | _ -> [ "3" ]) in
+ aeh "update_new_header: unchanged" h h1
+
+let get_multi_tests () =
+ aesl "get_multi (init ()) k" [] H.(get_multi (init ()) "a");
+ aesl "get_multi h k when mem h k = false" [] H.(get_multi prebuilt "a");
+ aesl "get_multi h k when mem h k = true" [ "chunked" ]
+ H.(get_multi prebuilt "transfer-encoding");
+ aesl "get_multi h k when mem h k = true"
+ [ "application/xml"; "text/html" ]
+ H.(get_multi prebuilt "accept")
+
+let hstr =
+ [
+ ("accept", "application/xml");
+ ("transfer-encoding", "chunked");
+ ("accept", "text/html");
+ ("content-length", "100");
+ ]
+
+let get_multi_concat_tests () =
+ let h1 = H.(add (add prebuilt "a" "a1") "a" "a2") in
+ aeso "get_multi_concat (init ()) k" None H.(get_multi_concat (init ()) "a");
+ aeso "get_multi_concat h k when mem h k = false" None
+ H.(get_multi_concat prebuilt "a");
+ aeso "get_multi_concat h k when mem h k = true"
+ (Some "application/xml,text/html")
+ H.(get_multi_concat prebuilt "accept");
+ aeso "get_multi_concat ~list_value_only:false h k when mem h k = true"
+ (Some "a1,a2")
+ H.(get_multi_concat h1 "a");
+ aeso "get_multi_concat ~list_value_only:true h k when mem h k = true"
+ (Some "a2")
+ H.(get_multi_concat ~list_value_only:true h1 "a")
+
+let map_tests () =
+ let a = ", a" in
+ aessl "map (fun _ v -> v) (init ())" []
+ H.(to_list (map (fun _k v -> v) (init ())));
+ aessl "map (fun _ v -> v) (init ())" (H.to_list prebuilt)
+ H.(to_list (map (fun _k v -> v) prebuilt));
+ aessl "map (fun _ v -> v ^ a ) (init ())"
+ [
+ ("accept", "application/xml, a");
+ ("transfer-encoding", "chunked, a");
+ ("accept", "text/html, a");
+ ("content-length", "100, a");
+ ]
+ H.(to_list (map (fun _k v -> v ^ a) prebuilt))
+
+let fold_tests () =
+ let rev k v acc = H.(add acc k v) in
+ let h1 = H.(fold rev prebuilt (init ())) in
+ aessl
+ "[fold (fun k v acc -> H.(add acc k v)) h (init ())] reverses the header"
+ (List.rev H.(to_list h1))
+ H.(to_list prebuilt);
+ let h1 = H.(fold rev (fold rev prebuilt (init ())) (init ())) in
+ aeh "[fold rev (fold rev h (init ())) (init ()) = h] " h1 prebuilt;
+ let count _ _ acc = acc + 1 in
+ aei "[fold (fun _ _ acc -> acc+1) h 0] returns the length of h"
+ (List.length H.(to_list prebuilt))
+ H.(fold count prebuilt 0)
+
+let iter_tests () =
+ let h = ref H.(init ()) in
+ let rev k v = h := H.(add !h k v) in
+ H.(iter rev prebuilt);
+ aessl "[iter (fun k v -> href := H.(add !href k v)) h] reverses the header"
+ (List.rev H.(to_list !h))
+ H.(to_list prebuilt);
+ let c = ref 0 in
+ let count _ _ = c := !c + 1 in
+ aei "[iter (fun _ _ -> count := !count+1) h] works fine"
+ (List.length H.(to_list prebuilt))
+ (H.(iter count prebuilt);
+ !c)
+
+let to_lines_tests () =
+ aesl "to_lines h"
+ [
+ "accept: application/xml\r\n";
+ "transfer-encoding: chunked\r\n";
+ "accept: text/html\r\n";
+ "content-length: 100\r\n";
+ ]
+ H.(to_lines prebuilt)
+
+let to_frames_tests () =
+ aesl "to_frames h"
+ [
+ "accept: application/xml";
+ "transfer-encoding: chunked";
+ "accept: text/html";
+ "content-length: 100";
+ ]
+ H.(to_frames prebuilt)
+
+let to_string_tests () =
+ aes "to_string h"
+ "accept: application/xml\r\n\
+ transfer-encoding: chunked\r\n\
+ accept: text/html\r\n\
+ content-length: 100\r\n\
+ \r\n"
+ H.(to_string prebuilt)
+
+let many_headers () =
+ let size = 1000000 in
+ let rec add_header num h =
+ match num with
+ | 0 -> h
+ | n ->
+ let k = Printf.sprintf "h%d" n in
+ let v = Printf.sprintf "v%d" n in
+ let h = H.add h k v in
+ add_header (num - 1) h
+ in
+ let h = add_header size (H.init ()) in
+ Alcotest.(check int) "many_headers" (List.length (H.to_list h)) size
+
+let transfer_encoding_tests () =
+ let h =
+ H.of_list
+ [ ("transfer-encoding", "gzip"); ("transfer-encoding", "chunked") ]
+ in
+ let sh = H.to_string h in
+ aes "transfer_encoding_string_is_ordered" sh
+ "transfer-encoding: gzip\r\ntransfer-encoding: chunked\r\n\r\n";
+ let sh = H.get_multi_concat h "transfer-encoding" in
+ aeso "transfer_encoding_get_is_ordered" (Some "gzip,chunked") sh
+
+module String_io = Cohttp__String_io
+module HIO = Cohttp__Header_io.Make (String_io.M)
+
+let large_header () =
+ let sz = 1024 * 1024 * 100 in
+ let h = H.init () in
+ let v1 = String.make sz 'a' in
+ let h = H.add h "x-large" v1 in
+ let h = H.add h v1 "foo" in
+ aeso "x-large" (H.get h "x-large") (Some v1);
+ let obuf = Buffer.create (sz + 1024) in
+ HIO.write h obuf;
+ let ibuf = Buffer.contents obuf in
+ let sbuf = String_io.open_in ibuf in
+ Alcotest.check t_header "large_header" (HIO.parse sbuf) h
+
+let tests =
+ ( "Unitary Header tests",
+ [
+ ("Header.to_list", `Quick, to_list_tests);
+ ("Header.is_empty", `Quick, is_empty_tests);
+ ("Header.init_with", `Quick, init_with_tests);
+ ("Header.mem", `Quick, mem_tests);
+ ("Header.add", `Quick, add_tests);
+ ("Header.get", `Quick, get_tests);
+ ("Header.add_list", `Quick, add_list_tests);
+ ("Header.add_multi", `Quick, add_multi_tests);
+ ("Header.add_unless_exists", `Quick, add_unless_exists_tests);
+ ("Header.remove", `Quick, remove_tests);
+ ("Header.replace", `Quick, replace_tests);
+ ("Header.get_multi", `Quick, get_multi_tests);
+ ("Header.get_multi_concat", `Quick, get_multi_concat_tests);
+ ("Header.to_lines", `Quick, to_lines_tests);
+ ("Header.to_frames", `Quick, to_frames_tests);
+ ("Header.to_string", `Quick, to_string_tests);
+ ("Header.map", `Quick, map_tests);
+ ("Header.fold", `Quick, fold_tests);
+ ("Header.iter", `Quick, iter_tests);
+ ("Header.update", `Quick, update_tests);
+ ("Header.update_all", `Quick, update_all_tests);
+ ("many headers", `Slow, many_headers);
+ ("transfer encoding is in correct order", `Quick, transfer_encoding_tests);
+ ]
+ @
+ if Sys.word_size = 64 then [ ("large header", `Slow, large_header) ] else []
+ )
--- /dev/null
+{
+ "name": "ocaml-cohttp",
+ "version": "4.0.0",
+ "description": "An OCaml library for HTTP clients and servers",
+ "repository": "https://github.com/mirage/ocaml-cohttp",
+ "license": "ISC",
+ "dependencies": {
+ "xmlhttprequest": "^1.8.0"
+ }
+}
--- /dev/null
+module Client = Cohttp_lwt_jsoo.Client
+module Js = Js_of_ocaml.Js
+
+let _Promise = Js.Unsafe.global##._Promise
+let ( let* ) = Lwt.( >>= )
+let ( let+ ) = Lwt.( >|= )
+
+let promise_of_lwt lwt =
+ new%js _Promise
+ (Js.wrap_callback (fun resolve reject ->
+ try%lwt
+ let+ res = lwt () in
+ Js.Unsafe.fun_call resolve [| Js.Unsafe.inject res |]
+ with e ->
+ let msg = Printexc.to_string e in
+ Js.Unsafe.fun_call reject
+ [| Js.Unsafe.inject (new%js Js.error_constr (Js.string msg)) |]))
+
+let () =
+ Js.export_all
+ (object%js
+ method request uri =
+ let f () =
+ let uri = Uri.of_string (Js.to_string uri) in
+ let* response, body = Client.get uri in
+ let+ body = Cohttp_lwt.Body.to_string body in
+ let status =
+ Cohttp.Response.status response |> Cohttp.Code.code_of_status
+ in
+ Js.array
+ [| Js.Unsafe.inject status; Js.Unsafe.inject @@ Js.string body |]
+ in
+ promise_of_lwt f
+ end)
--- /dev/null
+(executable
+ (name cohttp_lwt_jsoo_test)
+ (modes js)
+ (libraries cohttp cohttp-lwt cohttp-lwt-jsoo lwt js_of_ocaml-lwt)
+ (preprocess
+ (pps lwt_ppx js_of_ocaml-ppx)))
+
+(rule
+ (alias runjstest)
+ (deps test.js cohttp_lwt_jsoo_test.bc.js)
+ (action
+ (setenv
+ NODE_PATH
+ "%{project_root}/cohttp_lwt_jsoo_test/node_modules"
+ (run ./test.js))))
--- /dev/null
+#!/usr/bin/env node
+
+const assert = require('assert');
+
+global.XMLHttpRequest = require("xmlhttprequest").XMLHttpRequest;
+const tests = require('./cohttp_lwt_jsoo_test.bc.js')
+
+async function main() {
+ {
+ const [status, body] = await tests.request("https://mirage.io");
+ assert(status == 200);
+ }
+ {
+ const [status, body] = await tests.request("https://this.domain.does.not.exist");
+ assert(status == 0);
+ }
+}
+
+main()
--- /dev/null
+# THIS IS AN AUTOGENERATED FILE. DO NOT EDIT THIS FILE DIRECTLY.
+# yarn lockfile v1
+
+
+xmlhttprequest@^1.8.0:
+ version "1.8.0"
+ resolved "https://registry.yarnpkg.com/xmlhttprequest/-/xmlhttprequest-1.8.0.tgz#67fe075c5c24fef39f9d65f5f7b7fe75171968fc"
+ integrity sha1-Z/4HXFwk/vOfnWX197f+dRcZaPw=
(lang dune 2.0)
(name cohttp)
-(version v4.0.0)
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 make_signing_key ?date ~region ~service ~secret_access_key () =
let mac k v =
Mirage_crypto.Hash.(mac `SHA256 ~key:k (Cstruct.of_string v))
in
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
+++ /dev/null
-;; This file is used by `make all-supported-ocaml-versions`
-(context ((switch 4.03.0)))
-(context ((switch 4.04.2)))
-(context ((switch 4.05.0)))
-(context ((switch 4.06.0)))
projects / ocaml-cohttp.git / commitdiff