diff --git a/cohttp/CHANGES.md b/cohttp/CHANGES.md deleted file mode 100644 index 0fa3b6a591fe628a9e5092528fdb6ae203b6e7b4..0000000000000000000000000000000000000000 --- a/cohttp/CHANGES.md +++ /dev/null @@ -1,747 +0,0 @@ -## v5.3.1 (2023-12-13) - -- cohttp: case-insensitive check of set-cookies (chomosuke, #1008) - -## v5.3.0 (2023-07-21) - -- cohttp-async: support for base/async v0.16 - -## v5.2.0 (2023-07-07) - -- cohttp-lwt server: call conn_closed before drainig the body of response on error (pirbo) - -## v5.1.0 (2023-04-04) - -- cohttp,cohttp-async server: correctly close broken streams (reported by Stéphane Glondu, fix by samhot and anuragsoni) - -## 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) -- 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 - -## v2.5.5 (2021-03-15) - -- `Cohttp_async.resolve_local_file`, `Cohttp_lwt.resolve_local_file` and `Cohttp_lwt_unix.resolve_file` - are now the same code under the hood (`Cohttp.Path.resolve_local_file`). The old names - have been preserved for compatibility, but will be marked as deprecated in the next release. This - changes the behavior of `Cohttp_lwt_unix.resolve_file`: it now percent-decodes the paths and blocks - escaping from the docroot correctly. This also fixes and tests the corner cases in these methods - when the docroot is empty. (ewanmellor #755) - -## v2.5.4 (2020-07-21) - -- cohttp: a change in #694 modified the semantics of Header.replace. - The semantics change is reverted, and a new Header.update function - is introduced, following the semantics of Map.update. (#702 mseri) -- cohttp: reimplement update to support compilers that are older than - OCaml 4.06 (#703 mseri) - -## v2.5.3 (2020-06-27) - -- cohttp-async: adapt to async >= v0.14 (#699 copy) - -## v2.5.2 (2020-06-27) - -- cohttp, cohttp-async: correctly set host header for unix domain sockets, - implement Unix domain socket support for cohttp-async (#698 Leonidas-from-XIV) -- cohttp: better body encoding management when creating request and - response, and correction of Header.replace function (#694 lyrm) - -## v2.5.1 (2020-02-18) - -- cohttp-lwt: pass ctx through HEAD client requests (#689 hannesm) - -## v2.5.0 (2019-12-17) - -- cohttp-async: support async v0.13.0 (#680 copy) -- cohttp-lwt-jsoo: support js_of_ocaml 3.5.0 and higher (avsm) - -## v2.4.0 (2019-11-08) - -- mirage: adapt to new mirage interfaces: mirage-flow 2.0.0, - mirage-channel 4.0.0, mirage-kv 3.0.0 (#678 hannesm) -- async: use Pipe.singleton instead of Pipe.of_list as it is more efficient - (#677 smuenzel-js) - -## v2.3.0 (2019-08-18) - -- use conduit-mirage instead of mirage-conduit, which was renamed - upstream in conduit. The minimum OCaml version supported for - conduit-mirage is now OCaml 4.07 and higher. (#672 avsm) -- remove deprecation warnings in OCaml 4.08.0 using stdlib-shims (#672 avsm) -- async: do not read body if none is present (#671 emillon) - -## v2.2.0 (2019-07-20) - -- Previously if the client closed the connection while cohttp was - handling a request, the server would crash (by default, unless the - user overrode that using `on_exn` or changing Lwt's async exception - handler). Now, cohttp will just log this at `info` level and - continue. Exceptions produced by user code are logged as errors, - while other exceptions generated by cohttp call back to the conduit - exception handler, as before. (#669 talex5) - -## v2.1.3 (2019-07-12) - -- support uri.3.0.0 that has optional sexp support (#668 avsm) -- use re.1.9.0 api to remove deprecation warnings (#664 vbmithr) - -## v2.1.2 (2019-04-09) - -- cohttp: handle empty cookie components gracefully without raising - an exception (#663 martinslota) - -## v2.1.1 (2019-04-05) - -- `cohttp-mirage`: remove dependency on the `result` module - (#662 hannesm) -- Support Async v0.12.0 and higher (#661 copy) - -## v2.1.0 (2019-03-01) - -- `cohttp-mirage`: update to the newest `Mirage_kv.RO` API - -## v2.0.0 (2019-02-04) - -Compatibility breaking interface changes: - -Async: Expert response action no longer writes empty HTTP body (#647 by andreas) - -In cohttp.0.99, a number of subpackages were turned into explicit -opam packages to simplify dependency management. -To aid migration, some compatability shims were left in place so that -the old findlib names would continue to work. They have now been removed -as of this release. If you were still using them, then please rename -them as follows: -- `cohttp.lwt-core` -> `cohttp-lwt` -- `cohttp.lwt` -> `cohttp-lwt-unix` -- `cohttp.js` -> `cohttp-lwt-jsoo` -- `cohttp.async` -> `cohttp-async` -- `cohttp.top` -> `cohttp-top` - -Other changes and bugfixes: -* Lwt, Mirage: Add log warnings for uncaught exceptions (#592 by ansiwen) -* Log invalid client input and do not catch out of memory exceptions (#652 hannesm) -* Port opam files to opam2 and add local synopsis and descriptions. -* Lwt: Add Expert response action for servers (#647 by andreas) -* Use the namespaced `js_of_ocaml` interfaces from 3.3.0 onwards (#654 avsm) -* Use Base64 3.1.0 interfaces (#655 avsm) -* Clean up redundant conflicts in the `opam` files (avsm) - -## v1.2.0 (2018-10-19) - -* Support more than a single chunk extension for RFC7320 compliance (#618 by djs55) -* Lwt-unix: add a `?backlog` argument to the serve function (samoht) -* Use the uri.2.0.0 interfaces for sexpression generation of types (avsm) -* Switch to `sexplib0` for a more lightweight s-expression library (mseri) -* Minimum OCaml compiler version requirement is now 4.04.1 (mseri) -* Add an example of using custom resolvers to the README (mseri) - -## v1.1.1 (2018-08-13) - -* Update to be compatible with new async/core (#607 by rgrinberg) -* Remove use of deprecated `Lwt_logs` (#609 by raphael-proust) -* Do not rely on locale for printing qvalues (#611 by vbmithr) -* Ppx dependencies aren't just build time dependencies (#625 by rgrinberg) - -## v1.1.0 (2018-03-28) - -* Add an "expert mode" to hand off raw responses to a custom handler, - which in turns makes protocols like Websockets easier (#488 by msaffer). -* Set the user-agent by default if one is not provided (#586 by TheCBaH). -* Fix typo in the `cohttp.js` META file. -* Refresh use of the Re library to the latest version (#602 by rgrinberg). -* Rearrange the ppx dependencies to be more specific (#596 by yomimono). -* Explicitly depend on sexplib in the Async backend (#605 by kevinqiu). - -## v1.0.2 (2018-01-06) - -* Support Async v0.10.0 and OCaml 4.06.0 (#588 via vbmithr) -* Require `ppx_type_conv`>=v0.9.1` due to a bug with duplicate modules - present in earlier versions. - -## v1.0.1 (2018-01-03) - -* cohttp-mirage: expose the missing IO module (#594, samoht) -* cohttp-mirage: catch exceptions when closing channels in mirage client - (#589, ansiwen) - -## v1.0.0 (2017-11-16) - -* opam: rename `mirage-http` to `cohttp`-mirage` (#572) -* cohttp-lwt{,-unix}: wrap the libraries in top-level modules (#568) -* opam: improve dependencies (#574, #566, #575) -* cohttp: add the convenience function `Header.is_empty` (#576) -* fix compatibility with OCaml 4.06 and `-safe-string` (#580, #581) - -## v0.99.0 (2017-07-12) - -Port build to jbuilder, and break up OPAM packages into multiple -independent packages instead of being optional dependencies against -the main `cohttp` package. This makes it significantly easier to -depend on precisely the libraries you need, but requires porting -applications to use the new `ocamlfind` and `opam` scheme. - -The new package layout is: - -- `cohttp`: the main `Cohttp` module -- `cohttp-lwt`: the portable Lwt implementation -- `cohttp-lwt-unix`: the Lwt/Unix implementation -- `cohttp-lwt-jsoo`: the js-of-ocaml JavaScript implementation -- `cohttp-async`: the Jane Street Async implementation -- `mirage-http`: the MirageOS compatible implementation -- `cohttp-top`: a toplevel printer for the Cohttp types. - -In each of these packages, the `opam` and `ocamlfind` package -names are now _the same_, so you will need to rename the former -subpackages such as `cohttp.async` to `cohttp-async`. The -implementation is otherwise the same, so no other code changes -should be required. - -In return for these breaking changes to the packaging, it is -now significantly easier to depend on a particular backend, -also for us to rev the interfaces towards a stable 1.0 release. -Jbuilder also builds the source tree around 4x faster than it -did previously. - -A number of deprecation warnings have been added to the source -tree as well to mark the interfaces that will be removed in 1.0. -These are `Cohttp_lwt.{Client,Server,Net}`, and a `Cohttp_lwt.Body` -alias was added to deprecate the direct use of `Cohttp_lwt_body`. -This will let us unify the namespaces of all the packages to use -a single top-level module for each package in the future. - -Most of the release and packaging work here was done by rgrinberg -and avsm. - -## 0.22.0 (2017-03-09) - -* Lwt: ensure conn_closed is cosed once client goes away (#528) -* Use the Logs library for logging. (#532) - -## 0.21.1 (2017-02-18) -* Remove -principal from type checking temporarily, to workaround - a bug in the OCaml 4.03 type checker that causes compilation - hangs (http://caml.inria.fr/mantis/view.php?id=7305). -* Improve documentation in the `test_xhr.ml` js_of_ocaml test. -* XHR: Allow setting withCredentials -* Async: pass along ?ssl_config when connecting to Uri's (#510) -* Lwt: Add on ?on_exn to Server.create (#518) -* Add Header.to_frames - -## 0.21.0 (2016-05-22) -* Allow to request paths as strings (#470, #478) - -## 0.20.2 (2016-04-04) -* Update META version (#473) -* uri.services is only required by cohttp.async - -0.20.1 (2016-04-01) -* Switch cohttp to use ppx (#457) -* Lwt: Fix leak on HEAD client requests (#467) - -0.20.0 (2016-03-25) -* Switch to pa_fields_conv and pa_sexp_conv for camlp4 extensions (#465) -* Compatibility with latest async (#468) -* Async: Add support for SSL parameters in client (#466) -* Lwt: ignore Sig.sigpipe under Windows (#456) -* Lwt: Fix FD leak (#447) -* Lwt: Log uncaught user exceptions -* Async: Close non-persistent async connections (#442) - -0.19.3 (2015-09-28): -* Support Async 113.00 by explicitly using the blocking Core `printf` (#431) -* cohttp_curl_async: add `-data-binary` to send POST data. (#425) - -0.19.2 (2015-08-20): - -* Improve Cohttp_async.Client error handling. When a Uri.t fails to resolve it is - now included in the error. (#420) - -0.19.1 (2015-08-08): - -* Bring make_body_writer and write_header in Cohttp.S.Http_io. Needed by - ocaml-git - -0.19.0 (2015-08-05): -Compatibility breaking interface changes: -* Remove `read_form` from the `Request/Response/Header` interfaces - as this should be done in `Body` handling instead (#401). - -New features and bug fixes: -* Remove `IO.write_line` as it was unused in any interfaces. -* Do not use the `lwt` camlp4 extension. No observable external difference. -* Do not return a code stacktrace in the default 500 handler. -* Add `Cohttp.Header.compare` (#411) -* Fix typos in CLI documentation (#413 via moonlightdrive) -* Use the Lwt 2.5.0 buffer API. -* `Cohttp_lwt.read_response` now has a non-optional `closefn` parameter (#400). -* Add a `Cohttp_lwt_s` module that contains all the Lwt module types - in one convenient place (#397). - -0.18.3 (2015-07-12): -* Allow `DELETE` requests to have request bodies (#383). -* Improve the Lwt client `callv` for HTTP/1.1 pipelined - requests (#379 via Török Edwin). - -0.18.2 (2015-06-19): -* Do not add content encoding for 204's (#375) - -0.18.1 (2015-06-05): -* Remove trailing whitespace from headers (#372) -* Don't reverse order of list valued headers (#372) - -0.18.0 (2015-06-02): -* Add Cohttp_async.Client.callv. Allows for making requests while reusing an - HTTP connection (#344) -* Responses of status 1xx/204/304 have no bodies and cohttp should not attempt - to read them (#355) -* Add top level printers. See cohttp.top findlib package (#363) -* Add `Header.to_string` (#362) -* Fix chunk truncation in chunked transfer encoding (#360) - -Compatibility breaking interface changes: -* Remove `Request`/`Response` modules outside of Cohttp pack (#349) - -0.17.2 (2015-05-24): -* Remove dependency on the Lwt Camlp4 syntax extension (#334). -* Add `make github` target to push documentation to GitHub Pages - (#338 from Jyotsna Prakash). -* Add Async integration tests and consolidate Lwt tests using the - new framework (#337). -* Fix allocation of massive buffer when handling fixed size http bodies (#345) - -0.17.1 (2015-04-24): -* [async] Limit buffer size to a maximum of 32K in the Async backend - (#330 from Stanislav Artemkin). -* Add `Cohttp.Conf.version` with the library version number included. -* Remove debug output from `cohttp-curl-async`. -* Add the beginning of a `DESIGN.md` document to explain the library structure. - -0.17.0 (2015-04-17): - -Compatibility breaking interface changes: -* `CONNECT` and `TRACE` methods added to `Code`.Exhaustive matches will need updating. - -New features and bug fixes: -* `Link` header parsing has been added as `Cohttp.Link`, `Header.get_links` and `Header.add_links` -* `cohttp_server_*` now obeys `HEAD` requests and responds 405 to unknown methods -* `Cohttp_async.Server.response` type is now exposed as a `response * body` pair -* Failure to read a body in a pipelined response no longer terminates the stream -* Fix `cohttp_curl_lwt -X HEAD` sending empty chunked body (#313) -* Fix a bug which left extra `\r\n` in buffer at end of chunked reads -* Fix handling of request URI for query strings and `CONNECT` proxies (#308, #318) -* Fix precedence of `Host` header when request-URI is absolute URI -* Fix request URI path to be non-empty except for * requests (e.g. `OPTIONS *`) - -0.16.1 (2015-04-09): -New features and bug fixes: -* Fix handling of request paths starting with multiple slashes (#308) - -0.16.0 (2015-03-23): - -Compatibility breaking interface changes: -* Response.t and Request.t fields are no longer mutable -* [lwt] Fix types in `post_form` to be a `string * string list` instead - of a `Header.t` (#257) -* Simplify the `Net` signature which needs to be provided for Lwt servers - to not be required. Only the Lwt client needs a `Net` functor argument - to make outgoing connections. (#274) -* The `Request` and `Response` records are no longer mutable, so use - functional updates instead via `Fieldslib.Field.fset Request.Fields.`. (#296) -* `Request.has_body` does not permit a body to be set for methods that - RFC7231 forbids from having one (`HEAD`, `GET` and `DELETE`). - -New features and bug fixes: -* Fix linking problem caused by sub-libraries using cohttp modules outside the - cohttp pack. -* Added async client for S3. (#304) -* Fix String_io.read_line to trim '\r' from end of string (#300) -* Fix `cohttp-server-lwt` to correctly bind to a specific interface (#298). -* Add `Cohttp_async.request` to send raw, unmodified requests. -* Supplying a `content-range` or `content-range` header in any client - request will always override any other encoding preference (#281). -* Add a `cohttp-lwt-proxy` to act as an HTTP proxy. (#248) -* Extend `cohttp-server-async` file server to work with HTTPS (#277). -* Copy basic auth from `Uri.userinfo` into the Authorization header - for HTTP requests. (#255) -* Install binaries via an OPAM `.install` file to ensure that they are - reliably uninstalled. (#252) -* Use the `magic-mime` library to add a MIME type by probing filename - during static serving in the Lwt/Async backends. (#260) -* Add `Cohttp.Header.add_opt_unless_exists` to set a header only if - an override wasn't supplied, and to initialise a fresh Header value - if none is present. -* Do not override user-supplied headers in `post_form` or `redirect`. -* `Request.make` does not inject a `transfer-encoding` header if there - is no body present in the request (#246). -* `Server.respond` no longer overrides user-supplied headers that - specify the `content-length` or `transfer-encoding` headers (#268). -* `cohttp_server_lwt` and `cohttp_server_async` now include sizes in - directory listing titles -* Add `Header.add_multi` to initialise a header structure with multiple - fields more efficiently (#272). -* Expose `IO.ic` and `IO.oc` types for `Cohttp_async` (#271). -* Skip empty body chunks in `Transfer_io.write` (#270). -* With the Lwt backend, `read` hangs if trying to fetch more than - `Sys.max_string_length` (which can be triggered on 32-bit platforms). - Read only a maximum that fits into a string (#282). -* `cohttp-curl-lwt` now takes http method as parameter (#288) -* Fix installation of server binaries in OPAM metadata. (#295) - -0.15.2 (2015-02-15): -* When transfer encoding is unknown, read until EOF when body size is unknown. (#241) -* Add some missing documentation to `Cohttp.S.IO` signature. (#233) -* Add `Cohttp.Header.mem` to check if a header exists. -* Add `Cohttp.Conf` module to expose the library version number. (#259) -* Add `Cohttp.Header.add_unless_exists` to update a key if it doesn't already exist. (#244) -* Add `Cohttp.Header.get_location` to retrieve redirection information. (#254) -* [async] Clean up the `Net.lookup` function to use `Or_error.t` instead of raising. (#247) -* [tests] Add more tests for `content-range` handling. (#249) - -0.15.1 (2015-01-10): -* Lwt 2.4.7 renamed `blit_bytes_string` to `blit_to_bytes`, so depend - on the newer API now. (#230) -* Use `cmdliner` in all of the Lwt client and server binaries. This gives - `cohttp-lwt-server` a nice Unix-like command-line interface now that - can be viewed with the `--help` option. (#218 via Runhang Li) -* Improve `oasis` constraints and regenerate `opam` file (#229 via - Christophe Troestler). - -0.15.0 (2014-12-24): - -Compatibility breaking interface changes: -* Change `Cohttp_lwt_body.map` to use a non-labelled type to fit the Lwt - style better (#200). -* Depend on Base64 version 2, which uses `B64` as the toplevel module name (#220). - -New features and bug fixes: -* Remove use of deprecated `Lwt_unix.run` and replace it with `Lwt_main.run`. - Should be no observable external change (#217). -* Improve ocamldoc of `Cohttp.S` signature (#221). - -0.14.0 (2014-12-18): - -Compatibility breaking interface changes: -* Simplify the Lwt server signature, so that manual construction of - a `callback` is no longer required (#210). - Code that previous looked like: - -``` - let conn_closed (_,conn_id) () = <...> - let config = { Server.callback; conn_closed } in -``` - -should now be: - -``` - let conn_closed (_,conn_id) = <...> - let config = Server.make ~callback ~conn_closed () in -``` - -* Remove the `Cohttp.Base64` module in favour of the external `base64` - library (which is now a new dependency). - -New features and bug fixes: -* Lwt `respond_error` now defaults to an internal server error if no - status code is specified (#212). -* Modernise the `opam` file using the OPAM 1.2 workflow (#211). -* Flush the response body to the network by default, rather than - buffering by default. The `?flush` optional parameter can still - be explicitly set to false if flushing is not desired (#205). - -0.13.0 (2014-12-05): - -Compatibility breaking interface changes: - -* Add sexp converters for Conduit contexts and `Lwt` client and server - modules and module types. - -New features and bug fixes: -* Can use the Conduit 0.7+ `CONDUIT_TLS=native` environment variable to - make HTTPS requests using the pure OCaml TLS stack instead of depending - on OpenSSL bindings. All of the installed binaries (client and server) - can work in this mode. -* Add `Cohttp_lwt_unix_debug` which lets libraries control the debugging - output from Cohttp. Previously the only way to do this was to set the - `COHTTP_DEBUG` environment variable at the program start. -* Add `cohttp-curl-lwt` as a lightweight URI fetcher from the command-line. - It uses the `cmdliner` as a new dependency. -* Remove build dependency check on `lwt.ssl` for `cohttp.lwt`. - This has been moved to conduit, so only `lwt.unix` is needed here now. - -0.12.0 (2014-11-07): - -Compatibility breaking interface changes: - -* Rename `Cohttp.Auth.t` to `Cohttp.Auth.credential` and `Cohttp.Auth.req` - to `Cohttp.Auth.challenge`. Also expose an `Other` variant - to make it more extensible for unknown authentication types. The - `Cohttp.Auth` functions using these types have also been renamed accordingly. -* Rename `Cohttp.Transfer.encoding_to_string` to `string_of_encoding` - for consistency with the rest of Cohttp's APIs. -* The `has_body` function in the Request and Response modules now - explicitly signals when the body size is unknown. -* Move all the module type signatures into `Cohttp.S`. -* If users have percent-encoded file names, their resolution is changed: - `resolve_local_file` in `Cohttp_async` and `Cohttp_lwt` now always - percent-decode paths (#157) -* Remove the `Cohttp_lwt.Server.server` type synonym to `t`. -* When reading data from a HTTP body stream using the `Fixed` encoding, - we need to maintain state (bytes remaining) so we know when to finish. - The `Cohttp.Request` and `Cohttp.Response` interfaces now expose a - `reader` and `writer` types to track this safely. -* Add `is_empty` function to the `Cohttp.S.Body` module type. -* Add `Strings` representation to `Cohttp.Body` to efficiently hold a - list of body chunks. -* Move flushing logic for HTTP bodies into the portable `Request` and - `Response` modules instead of individual Lwt and Async backends. -* Port module interfaces to the latest Conduit (0.6.0+) API. -* Cohttp requires OCaml 4.01.0 or higher now. - -New features and bugfixes: - -* Add a `Cohttp_lwt_xhr` JavaScript backend that enables Cohttp logic to be - mapped to `XMLHTTPRequest` in browsers via `js_of_ocaml` (via Andy Ray). -* Add a `Cohttp.String_io` and `String_io_lwt` module that uses OCaml - `string` or `Buffer.t` to read and write HTTP requests and responses - instead of network connections. -* `cohttp_server_lwt` and `cohttp_server_async` now return better errors (#158) -* `cohttp_server_lwt` and `cohttp_server_async` now serve indexes directly (#162) -* [lwt] Add `stop` thread to terminate a running server if it finishes (#147). -* Add `Cohttp.Connection.compare` to make ordering of connections possible. -* Add `Body.map` and `Body.as_pipe` to work with HTTP bodies more easily. -* Remove link-time dependency on camlp4 via META fixes (#127). -* Support HTTP methods and versions other than the standard ones. (#142). -* Improve `cohttp_server_lwt` and `cohttp_server_async` directory listings (#158) -* Fix `Cohttp_async.resolve_local_file` directory traversal vulnerability (#158) -* [async] In the Async server, do not close the Reader too early. -* [async] Close file descriptors more eagerly in the HTTP client (#167). -* Reduce thread allocation by replacing `return ` with `return_none`, - `return_unit` or `return_nil`. - -0.11.2 (2014-04-21) -* Fix build by add a missing build-deps in _oasis. - -0.11.1 (2014-04-17): -* Remove an errant async_ssl reference left in the _oasis file that is - now handled by the Conduit library (#116). -* Add an Lwt-based SimpleHTTPServer equivalent as `cohttp-server-lwt` (#108). -* `Cohttp.Connection.t` now exposes sexp accessor functions (#117). - -0.11.0 (2014-04-01): -* Remove dependency on `ocaml-re` in order to make library POSIX thread-safe. -* Shift most of the connection handling logic out to a Conduit library that - worries about which SSL library to use, and fails if SSL is not available. -* Add Async-SSL support for both client and server (#102). -* Add Lwt-SSL support for the server side (the client side existed before). -* Fix buggy Async chunked POST handling. - -0.10.0 (2014-03-02): -* Interface change: The `Request` and `Response` module types now explicitly - signal `Eof` and `Invalid` (for errors), to help the backend distinguish them. -* Interface change: Unify HTTP body handling across backends into a `Cohttp.Body` - module. This is extended by Async/Lwt implementations with their specific - ways of handling bodies (Pipes for Async, or Lwt_stream for Lwt). -* [lwt] Interface change: HTTP client calls now raise Lwt exceptions rather - than return an option type. This permits better error handling in Lwt. -* [lwt] Interface change: The `Server` callback now always provides a `body` - argument, since `Cohttp_lwt_body` now explicitly supports empty bodys. -* Add `Cohttp.Header.is_keep_alive` to test if a connection should be reused. -* [lwt] Respect the `keep-alive` header in the server request handling. -* [async] Add a `Body` that takes a `Pipe` or a `string`, similarly to Lwt. -* Install `cohttp-server` binary even if tests are disabled. -* Begin an `examples` directory with some simple uses of the library. - -0.9.16 (2014-01-30): -* Add some module type equalities in `Cohttp_lwt_unix` so that - `Cohttp_lwt_unix.Server.Request.IO.ic` can be equivalen to `Lwt_io.input_channel`. -* Add sexp converters to most Cohttp types (#83). -* Improve Travis tests to cover more upstream users of Cohttp. -* Refactor build flags to let the portable Lwt-core be built independently of Lwt.unix. - -0.9.15 (2014-01-11): -* Remove `Cohttp_mirage` libraries, which have now moved to `mirage/mirage-http-*` on GitHub. -* Add an "HTTP only" `Cookie` attribute (#69). -* Fix parsing of cookies with `=` in the values (#71). -* Add `Max-age` support for cookies (#70). -* Make the `Response` record fields mutable to match the `Request` (#67). -* Fix compilation with Async 109.58.00 (#77). -* Make Header handling case-insensitive (by forcing lowercase) (#75). -* Remove the `>>` operator as it was unused and had incorrect precedence (#79). - -0.9.14 (2013-12-15): -* Install a `cohttp-server` binary that serves local directory contents via a web server (#54). -* Add a `flush` function to the `IO` module type and implement in Lwt/Async/Mirage. -* Add option `flush` support in the Async and Lwt responders (#52). -* Autogenerate HTTP codes from citricsquid's JSON representation of the HTTP RFCs. -* Always set `TCP_NODELAY` for Lwt/Unix server sockets for low-latency responses (#58). -* Added a Server-Side Events test-case from the HTML5 Doctor. See `lib_test/README.md`. -* Async.Server response now takes an optional `body` rather than a mandatory `body option` (#62). -* Regenerate build system using OASIS 0.4.0. - -0.9.13 (2013-12-10): -* The `cohttp.lwt-core` is now installed as an OS-independent Lwt library. -* Add support for Mirage 1.0, via `cohttp.mirage-unix` and `cohttp.mirage-xen`. -* Add a new `Cohttp.Connection` module to manage server's connections identifiers. -* Share the same configuration type for the different server implementations. -* Add `Accept_types` module to the `Cohttp` pack. - -0.9.12 (2013-11-28): -* Improve documentation for `Cohttp.Header`. -* Expose Fieldslib setters and getters for most of the `Cohttp` types (#38). -* `Cohttp.Set_cookie.t` is no longer an abstract type to make it easier to update (#38). -* [Lwt] ignore SIGPIPE unconditionally if using the Lwt/Unix module (#37). -* Rename `Cookie` creation parameters for consistency (interface breaking, see #44). -* Fix transfer-length detection (regression from 0.9.11 in #42). -* Add Merin editor file (#41). - -0.9.11 (2013-10-27): -* Request module: When sending a request, add the port information in the host header field if available. -* Request module: When parsing a request, add scheme, host and port information in the uri. -* TCP server: When creating the socket for the server, do not force PF_INET6 but take the sockaddr value. -* Add HTTP OPTIONS method. -* Use getaddrinfo instead of gethostbyname for DNS resolution. -* Async: improve HTTP/1.0 support (#35). -* Build with debug symbols, binary annotations by default. -* Add Travis CI test scripts. - -0.9.10 (2013-06-21): -* Add `set-cookie` header extraction functions for clients that read cookies. -* Explicitly flush the debug output when the `COHTTP_DEBUG` env variable is set. -* [async] Add client head/post/patch/delete methods. -* [lwt] Client.head no longer returns a response body, just the metadata. -* [lwt] Do not send chunked encoding headers with GET/DELETE requests that have no body. - -0.9.9 (2013-06-12): -* Disable the mirage executable test as it was building too aggressively and breaking builds. - -0.9.8 (2013-05-24): -* Lwt interface change: Rewrite Lwt backends to share code, and remove duplicate function calls from Uri. -* Depend on `Uri` 1.3.8+ as it exposes the parameter query functions now removed from `Request`. -* Do not depend on Cstruct in core library, as only Mirage needs it. -* Remove `Cohttp_async.body` type alias and just use `string Pipe.Reader.t` for more explicit types. - -0.9.7 (2013-05-10): -* Attach a GC finaliser to the Lwt client to ensure that even an HTTP body isn't consumed, the socket will eventually be closed (#11). -* Add an Async.Server interface, and revise the Client interface to be more in line with Core standards. -* Add 422 Unprocessable Entity code. -* Refactor modules better across Lwt/Async, but incompatible with earlier releases for Async (Lwt is unchanged at present). -* Add user agent string and User-Agent header helper function -* The git history of this release is full of adventures in parameterised monads and refactoring, but this isn't in the actual release. Yet. - -0.9.6 (2013-03-18): -* Depend on Async (>= 109.12.00), which has an incompatible API with earlier versions. -* Rearrange core library files for `obuild` support. - -0.9.5 (2012-12-29): -* Fix cookie parsing to retrieve the correct header. -* Update to `mirage-net` 0.5.0 API (based on cstruct 0.6.0). - -0.9.4 (2012-12-19): -* Add Lwt `respond_redirect` and `respond_need_auth` helpers. -* Add enough Basic authorization support to serve a password-protected website. -* Fix Lwt file serving to not throw exception on trying to serve a directory. -* Port Async interface to 108.07.00 or higher (incompatible - with earlier versions). - -0.9.3 (2012-10-27): -* Add basic cookie support back to the portable library. -* `Cohttp_lwt.Client.post_form` now uses non-chunked encoding for - the POST instead of chunked. -* Various improvements and tests for the pipelined Lwt Client.callv -* If an Lwt callback does not consume a body, ensure it has - been drained by the API to prevent future pipelines from stalls. -* Fix handling of Lwt server non-empty POST bodies. -* Map the `put` functions to HTTP PUT instead of POST. - -0.9.2 (2012-09-20): -* Add Request.get_param to extract a singleton key from queries. -* Fix chunked encoding handling when short reads occur. -* Install HTML documentation for all enabled drivers. -* Use ocaml-uri-1.3.2 interface for query parsing. -* Lwt: Add Server.respond_file and resolve_file for the Unix - library to make it easier to serve static files. -* Lwt: Server.respond_not_found takes an optional Uri.t now. - -0.9.1 (2012-09-11): -* Functorise for Async, Lwt_unix and Mirage. -* Use URI and Re libraries to not need Str any more. -* More robust parsing for various HTTP headers. - -0.9.0 (2012-08-01): -* Initial public release. diff --git a/cohttp/Makefile b/cohttp/Makefile deleted file mode 100644 index 286104546ce03556d33c90bb4e86866b8a4c3733..0000000000000000000000000000000000000000 --- a/cohttp/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -.PHONY: build clean test clean - -build: - dune build - -test: - dune runtest - -js-test: - dune build @runjstest - -clean: - dune clean diff --git a/cohttp/TODO.md b/cohttp/TODO.md deleted file mode 100644 index 4e673b7688ea54e34f1bd3247a79a38682b13b9c..0000000000000000000000000000000000000000 --- a/cohttp/TODO.md +++ /dev/null @@ -1,23 +0,0 @@ -Planned changes for 1.0: - -* Make the Lwt response stream bounded (new in lwt-2.4+) - -Planned changes for 2.0: - -* Make the Header.t header parsing more efficient by only lazily parsing them - instead of copying into a Map as we do now. - -Better HTTP support: - -- Range requests need to be fully implemented (206) -- 100 Continue should be a noop -- Awwww crap, so much to do : http://www.and.org/texts/server-http -- A client interface that deals with redirects -- Proxy support (manual means a full URI in the request) - -Tests: - -- Test the lib_test server scripts via external invocations of - curl and httperf, so that the tests terminate. - -- Test the HTTP timeout support diff --git a/cohttp/cohttp-async.opam b/cohttp/cohttp-async.opam deleted file mode 100644 index 99e950b4ed86d13d019445ea27a3400d85aec0b7..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async.opam +++ /dev/null @@ -1,53 +0,0 @@ -opam-version: "2.0" -maintainer: "anil@recoil.org" -authors: [ - "Anil Madhavapeddy" - "Stefano Zacchiroli" - "David Sheets" - "Thomas Gazagnaire" - "David Scott" - "Rudi Grinberg" - "Andy Ray" -] -synopsis: "CoHTTP implementation for the Async concurrency library" -description: """ -An implementation of an HTTP client and server using the Async -concurrency library. See the `Cohttp_async` module for information -on how to use this. The package also installs `cohttp-curl-async` -and a `cohttp-server-async` binaries for quick uses of a HTTP(S) -client and server respectively. -""" -license: "ISC" -tags: ["org:mirage" "org:xapi-project"] -homepage: "https://github.com/mirage/ocaml-cohttp" -doc: "https://mirage.github.io/ocaml-cohttp/" -bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" -depends: [ - "ocaml" {>= "4.14"} - "dune" {>= "2.0"} - "async_kernel" {>= "v0.16.0"} - "async_unix" {>= "v0.16.0"} - "async" {>= "v0.16.0"} - "base" {>= "v0.16.0"} - "core" {with-test} - "core_unix" {>= "v0.16.0"} - "cohttp" {= version} - "conduit-async" {>= "1.2.0"} - "magic-mime" - "mirage-crypto" {with-test} - "logs" - "fmt" {>= "0.8.2"} - "sexplib0" - "ppx_sexp_conv" {>= "v0.13.0"} - "ounit" {with-test} - "uri" {>= "2.0.0"} - "uri-sexp" - "ipaddr" -] -build: [ - ["dune" "subst"] {dev} - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -available: arch != "s390x" -dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" diff --git a/cohttp/cohttp-async/bin/cohttp_curl_async.ml b/cohttp/cohttp-async/bin/cohttp_curl_async.ml deleted file mode 100644 index 32dc641854ef43f672bfe75a0855ffeaba946ae0..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/bin/cohttp_curl_async.ml +++ /dev/null @@ -1,52 +0,0 @@ -(*{{{ Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Base -open Async_kernel -open Cohttp_async - -let show_headers h = - Cohttp.Header.iter (fun k v -> Logs.info (fun m -> m "%s: %s%!" k v)) h - -let make_net_req uri meth' body () = - let meth = Cohttp.Code.method_of_string meth' in - let uri = Uri.of_string uri in - let headers = Cohttp.Header.of_list [ ("connection", "close") ] in - Client.call meth ~headers ~body:Body.(of_string body) uri - >>= fun (res, body) -> - show_headers (Cohttp.Response.headers res); - body - |> Body.to_pipe - |> Pipe.iter ~f:(fun b -> - Stdlib.print_string b; - return ()) - -let _ = - (* enable logging to stdout *) - Fmt_tty.setup_std_outputs (); - Logs.set_level @@ Some Logs.Debug; - Logs.set_reporter (Logs_fmt.reporter ()); - let open Async_command in - async_spec ~summary:"Fetch URL and print it" - Spec.( - empty - +> anon ("url" %: string) - +> flag "-X" (optional_with_default "GET" string) ~doc:" Set HTTP method" - +> flag "data-binary" - (optional_with_default "" string) - ~doc:" Data to send when using POST") - make_net_req - |> Command_unix.run diff --git a/cohttp/cohttp-async/bin/cohttp_server_async.ml b/cohttp/cohttp-async/bin/cohttp_server_async.ml deleted file mode 100644 index 494b9360b9329cc231e218cc5fc1f3dfedb317b3..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/bin/cohttp_server_async.ml +++ /dev/null @@ -1,144 +0,0 @@ -(*{{{ Copyright (c) 2013 Anil Madhavapeddy - * Copyright (c) 2014 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Base -open Async_kernel -open Async_unix -open Cohttp_async -open Cohttp_server - -let method_filter meth (res, body) = - match meth with `HEAD -> return (res, `Empty) | _ -> return (res, body) - -let serve_file ~docroot ~uri = - Cohttp.Path.resolve_local_file ~docroot ~uri |> Server.respond_with_file - -let serve ~info ~docroot ~index uri path = - (* Get a canonical filename from the URL and docroot *) - let file_name = Cohttp.Path.resolve_local_file ~docroot ~uri in - try_with (fun () -> - Unix.stat file_name >>= fun stat -> - Logs.debug (fun f -> - f "%s" (Sexp.to_string_hum (Unix.Stats.sexp_of_t stat))); - match stat.Unix.Stats.kind with - (* Get a list of current files and map to HTML *) - | `Directory -> ( - let path_len = String.length path in - if Int.(path_len <> 0) && Char.(path.[path_len - 1] <> '/') then - Server.respond_with_redirect (Uri.with_path uri (path ^ "/")) - (* Check if the index file exists *) - else - Sys.file_exists (file_name / index) >>= function - | `Yes -> - (* Serve the index file directly *) - let uri = Uri.with_path uri (path / index) in - serve_file ~docroot ~uri - | `No | `Unknown -> - (* Do a directory listing *) - Sys.ls_dir file_name - >>= Deferred.List.map ~how:`Parallel ~f:(fun f -> - let file_name = file_name / f in - try_with (fun () -> - Unix.stat file_name >>| fun stat -> - (Some stat.Unix.Stats.kind, stat.Unix.Stats.size, f)) - >>| function - | Ok v -> v - | Error _ -> (None, 0L, f)) - >>= fun listing -> - html_of_listing uri path - (sort ((Some `Directory, 0L, "..") :: listing)) - info - |> Server.respond_string) - (* Serve the local file contents *) - | `File -> serve_file ~docroot ~uri - (* Any other file type is simply forbidden *) - | `Socket | `Block | `Fifo | `Char | `Link -> - Server.respond_string ~status:`Forbidden - (html_of_forbidden_unnormal path info)) - >>= function - | Ok res -> return res - | Error exn -> ( - match Monitor.extract_exn exn with - | Unix.Unix_error (Unix.Error.ENOENT, "stat", p) -> - if String.equal p ("((filename " ^ file_name ^ "))") (* Really? *) - then - Server.respond_string ~status:`Not_found - (html_of_not_found path info) - else raise exn - | _ -> raise exn) - -(** HTTP handler *) -let handler ~info ~docroot ~index ~body:_ _sock req = - let uri = Cohttp.Request.uri req in - let path = Uri.path uri in - (* Log the request to the console *) - printf "%s %s%!" Cohttp.(Code.string_of_method (Request.meth req)) path; - match Request.meth req with - | (`GET | `HEAD) as meth -> - serve ~info ~docroot ~index uri path >>= method_filter meth - | meth -> - let meth = Cohttp.Code.string_of_method meth in - let allowed = "GET, HEAD" in - let headers = Cohttp.Header.of_list [ ("allow", allowed) ] in - Server.respond_string ~headers ~status:`Method_not_allowed - (html_of_method_not_allowed meth allowed path info) - -let determine_mode cert_file_path key_file_path = - (* Determines if the server runs in http or https *) - match (cert_file_path, key_file_path) with - | Some c, Some k -> `OpenSSL (`Crt_file_path c, `Key_file_path k) - | None, None -> `TCP - | _ -> failwith "Error: must specify both certificate and key for HTTPS" - -let start_server docroot port index cert_file key_file verbose () = - (* enable logging to stdout *) - Fmt_tty.setup_std_outputs (); - Logs.set_level @@ if verbose then Some Logs.Debug else Some Logs.Info; - Logs.set_reporter (Logs_fmt.reporter ()); - let mode = determine_mode cert_file key_file in - let mode_str = match mode with `OpenSSL _ -> "HTTPS" | `TCP -> "HTTP" in - Logs.info (fun f -> f "Listening for %s requests on %d" mode_str port); - let info = Printf.sprintf "Served by Cohttp/Async listening on %d" port in - Server.create - ~on_handler_error: - (`Call - (fun addr exn -> - Logs.err (fun f -> f "Error from %s" (Socket.Address.to_string addr)); - Logs.err (fun f -> f "%s" @@ Exn.to_string exn))) - ~mode - (Tcp.Where_to_listen.of_port port) - (handler ~info ~docroot ~index) - >>= fun _serv -> Deferred.never () - -let () = - let open Async_command in - Command_unix.run - @@ async_spec ~summary:"Serve the local directory contents via HTTP or HTTPS" - Spec.( - empty - +> anon (maybe_with_default "." ("docroot" %: string)) - +> flag "-p" - (optional_with_default 8080 int) - ~doc:"port TCP port to listen on" - +> flag "-i" - (optional_with_default "index.html" string) - ~doc:"file Name of index file in directory" - +> flag "-cert-file" (optional string) ~doc:"File of cert for https" - +> flag "-key-file" (optional string) - ~doc:"File of private key for https" - +> flag "-v" no_arg ~doc:" Verbose logging output to console") - start_server diff --git a/cohttp/cohttp-async/bin/dune b/cohttp/cohttp-async/bin/dune deleted file mode 100644 index 47dc0935afea357d6b1efc7115b9c47a01e0e306..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/bin/dune +++ /dev/null @@ -1,6 +0,0 @@ -(executables - (names cohttp_curl_async cohttp_server_async) - (package cohttp-async) - (public_names cohttp-curl-async cohttp-server-async) - (libraries cohttp-async async_kernel async.async_command async_unix base - cohttp cohttp_server fmt.tty core_unix.command_unix)) diff --git a/cohttp/cohttp-async/src/body.ml b/cohttp/cohttp-async/src/body.ml deleted file mode 100644 index c3d501549ce63ddad2c454502cfe081f7e1aa476..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/body.ml +++ /dev/null @@ -1 +0,0 @@ -include Body_raw diff --git a/cohttp/cohttp-async/src/body.mli b/cohttp/cohttp-async/src/body.mli deleted file mode 100644 index 154dc202bed3b8e0b4161b32fe1c9e10cccba7f4..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/body.mli +++ /dev/null @@ -1,17 +0,0 @@ -open! Base -open! Async_kernel -open! Cohttp - -type t = [ Cohttp.Body.t | `Pipe of string Pipe.Reader.t ] [@@deriving sexp_of] - -include Cohttp.S.Body with type t := t - -val drain : t -> unit Deferred.t -val is_empty : t -> bool Deferred.t -val to_string : t -> string Deferred.t -val to_string_list : t -> string list Deferred.t -val to_pipe : t -> string Pipe.Reader.t -val of_pipe : string Pipe.Reader.t -> t -val map : t -> f:(string -> string) -> t -val as_pipe : t -> f:(string Pipe.Reader.t -> string Pipe.Reader.t) -> t -val to_form : t -> (string * string list) list Deferred.t diff --git a/cohttp/cohttp-async/src/body_raw.ml b/cohttp/cohttp-async/src/body_raw.ml deleted file mode 100644 index 919b1cca1da2c1382cb62381db751324ca0a079e..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/body_raw.ml +++ /dev/null @@ -1,93 +0,0 @@ -open Base -open Async_kernel -module B = Cohttp.Body - -type t = [ B.t | `Pipe of string Pipe.Reader.t ] [@@deriving sexp_of] - -let empty = `Empty -let of_string s = (B.of_string s :> t) -let of_pipe p = `Pipe p - -let to_string = function - | #B.t as body -> return (B.to_string body) - | `Pipe s -> Pipe.to_list s >>| String.concat - -let to_string_list = function - | #B.t as body -> return (B.to_string_list body) - | `Pipe s -> Pipe.to_list s - -let drain = function #B.t -> return () | `Pipe p -> Pipe.drain p - -let is_empty (body : t) = - match body with - | #B.t as body -> return (B.is_empty body) - | `Pipe pipe -> ( - Deferred.repeat_until_finished () @@ fun () -> - Pipe.values_available pipe >>= function - | `Eof -> return (`Finished true) - | `Ok -> ( - match Pipe.peek pipe with - | None -> return (`Finished true) - | Some "" -> ( - Pipe.read pipe >>| function - | `Eof -> `Finished true - | `Ok _ -> `Repeat ()) - | Some _ -> return (`Finished false))) - -let to_pipe = function - | `Empty -> Pipe.of_list [] - | `String s -> Pipe.singleton s - | `Strings sl -> Pipe.of_list sl - | `Pipe p -> p - -let disable_chunked_encoding = function - | #B.t as body -> return (body, B.length body) - | `Pipe s -> - Pipe.to_list s >>| fun l -> - let body = `Strings l in - let len = B.length body in - (body, len) - -let transfer_encoding = function - | #B.t as t -> B.transfer_encoding t - | `Pipe _ -> Cohttp.Transfer.Chunked - -let of_string_list strings = `Pipe (Pipe.of_list strings) - -let map t ~f = - match t with - | #B.t as t -> (B.map f t :> t) - | `Pipe p -> `Pipe (Pipe.map p ~f) - -let as_pipe t ~f = `Pipe (t |> to_pipe |> f) -let to_form t = to_string t >>| Uri.query_of_encoded -let of_form ?scheme f = Uri.encoded_of_query ?scheme f |> of_string - -let write_body write_body (body : t) writer = - match body with - | `Empty -> return () - | `String s -> write_body writer s - | `Strings sl -> Deferred.List.iter ~how:`Sequential sl ~f:(write_body writer) - | `Pipe p -> Pipe.iter p ~f:(write_body writer) - -let pipe_of_body read_chunk ic = - let open Cohttp.Transfer in - Pipe.create_reader ~close_on_exception:false (fun writer -> - Deferred.repeat_until_finished () (fun () -> - read_chunk ic >>= function - | Chunk buf -> - (* Even if [writer] has been closed, the loop must continue reading - * from the input channel to ensure that it is left in a proper state - * for the next request to be processed (in the case of keep-alive). - * - * The only case where [writer] will be closed is when - * [Pipe.close_read] has been called on its read end. This could be - * done by a request handler to signal that it does not need to - * inspect the remainder of the body to fulfill the request. - *) - Pipe.write_when_ready writer ~f:(fun write -> write buf) - >>| fun _ -> `Repeat () - | Final_chunk buf -> - Pipe.write_when_ready writer ~f:(fun write -> write buf) - >>| fun _ -> `Finished () - | Done -> return (`Finished ()))) diff --git a/cohttp/cohttp-async/src/client.ml b/cohttp/cohttp-async/src/client.ml deleted file mode 100644 index ba0089ad1a260d55250d9eb44c5b46618506e23b..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/client.ml +++ /dev/null @@ -1,181 +0,0 @@ -open Base -open Async_kernel -open Async_unix - -module Request = struct - include Cohttp.Request - include (Make (Io) : module type of Make (Io) with type t := t) - end - -module Response = struct - include Cohttp.Response - include (Make (Io) : module type of Make (Io) with type t := t) - end - -module Net = struct - let lookup uri = - let host = Uri.host_with_default ~default:"localhost" uri in - match Uri_services.tcp_port_of_uri ~default:"http" uri with - | None -> - Deferred.Or_error.error_string - "Net.lookup: failed to get TCP port form Uri" - | Some port -> ( - let open Unix in - Addr_info.get ~host - [ Addr_info.AI_FAMILY PF_INET; Addr_info.AI_SOCKTYPE SOCK_STREAM ] - >>| function - | { Addr_info.ai_addr = ADDR_INET (addr, _); _ } :: _ -> - Or_error.return (host, Ipaddr_unix.of_inet_addr addr, port) - | _ -> Or_error.error "Failed to resolve Uri" uri Uri_sexp.sexp_of_t) - - let connect_uri ?interrupt ?ssl_config uri = - (match Uri.scheme uri with - | Some "httpunix" -> - let host = Uri.host_with_default ~default:"localhost" uri in - return @@ `Unix_domain_socket host - | _ -> ( - lookup uri |> Deferred.Or_error.ok_exn >>= fun (host, addr, port) -> - return - @@ - match (Uri.scheme uri, ssl_config) with - | Some "https", Some config -> `OpenSSL (addr, port, config) - | Some "https", None -> - let config = Conduit_async.V2.Ssl.Config.create ~hostname:host () in - `OpenSSL (addr, port, config) - | _ -> `TCP (addr, port))) - >>= fun mode -> Conduit_async.V2.connect ?interrupt mode -end - -let read_response ic = - Response.read ic >>| function - | `Eof -> failwith "Connection closed by remote host" - | `Invalid reason -> failwith reason - | `Ok res -> ( - match Response.has_body res with - | `Yes | `Unknown -> - (* Build a response pipe for the body *) - let reader = Response.make_body_reader res ic in - let pipe = Body_raw.pipe_of_body Response.read_body_chunk reader in - (res, pipe) - | `No -> - let pipe = Pipe.of_list [] in - (res, pipe)) - -let request ?interrupt ?ssl_config ?uri ?(body = `Empty) req = - (* Connect to the remote side *) - let uri = match uri with Some t -> t | None -> Request.uri req in - Net.connect_uri ?interrupt ?ssl_config uri >>= fun (ic, oc) -> - try_with (fun () -> - Request.write - (fun writer -> Body_raw.write_body Request.write_body body writer) - req oc - >>= fun () -> - read_response ic >>| fun (resp, body) -> - don't_wait_for - ( Pipe.closed body >>= fun () -> - Deferred.all_unit [ Reader.close ic; Writer.close oc ] ); - (resp, `Pipe body)) - >>= function - | Ok res -> return res - | Error e -> - don't_wait_for (Reader.close ic); - don't_wait_for (Writer.close oc); - raise e - -module Connection = struct - type t' = { ic : Reader.t; oc : Writer.t } - - (* we can't send concurrent requests over HTTP/1 *) - type t = t' Sequencer.t - - let connect ?interrupt ?ssl_config uri = - Net.connect_uri ?interrupt ?ssl_config uri >>| fun (ic, oc) -> - let t = { ic; oc } |> Sequencer.create ~continue_on_error:false in - Throttle.at_kill t (fun { ic; oc } -> - Deferred.both (Writer.close oc) (Reader.close ic) >>| fun ((), ()) -> ()); - Deferred.any [ Writer.consumer_left oc; Reader.close_finished ic ] - >>| (fun () -> Throttle.kill t) - |> don't_wait_for; - t - - let close t = - Throttle.kill t; - Throttle.cleaned t - - let is_closed t = Throttle.is_dead t - - let request ?(body = Body.empty) t req = - let res = Ivar.create () in - Throttle.enqueue t (fun { ic; oc } -> - Request.write - (fun writer -> Body_raw.write_body Request.write_body body writer) - req oc - >>= fun () -> - read_response ic >>= fun (resp, body) -> - Ivar.fill res (resp, `Pipe body); - (* block starting any more requests until the consumer has finished reading this request *) - Pipe.closed body) - |> don't_wait_for; - Ivar.read res -end - -let callv ?interrupt ?ssl_config uri reqs = - Connection.connect ?interrupt ?ssl_config uri >>| fun connection -> - let responses = - Pipe.map' ~max_queue_length:1 reqs ~f:(fun reqs -> - Deferred.Queue.map ~how:`Sequential reqs ~f:(fun (req, body) -> - Connection.request ~body connection req)) - in - Pipe.closed responses - >>= (fun () -> Connection.close connection) - |> don't_wait_for; - responses - -let call ?interrupt ?ssl_config ?headers ?(chunked = false) ?(body = `Empty) - meth uri = - (* Create a request, then make the request. Figure out an appropriate - transfer encoding *) - (match chunked with - | false -> - Body_raw.disable_chunked_encoding body >>| fun (body, body_length) -> - (Request.make_for_client ?headers ~chunked ~body_length meth uri, body) - | true -> ( - Body.is_empty body >>| function - | true -> - (* Don't used chunked encoding with an empty body *) - ( Request.make_for_client ?headers ~chunked:false ~body_length:0L meth - uri, - body ) - | false -> - (* Use chunked encoding if there is a body *) - (Request.make_for_client ?headers ~chunked:true meth uri, body))) - >>= fun (req, body) -> request ?interrupt ?ssl_config ~body ~uri req - -let get ?interrupt ?ssl_config ?headers uri = - call ?interrupt ?ssl_config ?headers ~chunked:false `GET uri - -let head ?interrupt ?ssl_config ?headers uri = - call ?interrupt ?ssl_config ?headers ~chunked:false `HEAD uri - >>| fun (res, body) -> - (match body with `Pipe p -> Pipe.close_read p | _ -> ()); - res - -let post ?interrupt ?ssl_config ?headers ?(chunked = false) ?body uri = - call ?interrupt ?ssl_config ?headers ~chunked ?body `POST uri - -let post_form ?interrupt ?ssl_config ?headers ~params uri = - let headers = - Cohttp.Header.add_opt_unless_exists headers "content-type" - "application/x-www-form-urlencoded" - in - let body = Body.of_string (Uri.encoded_of_query params) in - post ?interrupt ?ssl_config ~headers ~chunked:false ~body uri - -let put ?interrupt ?ssl_config ?headers ?(chunked = false) ?body uri = - call ?interrupt ?ssl_config ?headers ~chunked ?body `PUT uri - -let patch ?interrupt ?ssl_config ?headers ?(chunked = false) ?body uri = - call ?interrupt ?ssl_config ?headers ~chunked ?body `PATCH uri - -let delete ?interrupt ?ssl_config ?headers ?(chunked = false) ?body uri = - call ?interrupt ?ssl_config ?headers ~chunked ?body `DELETE uri diff --git a/cohttp/cohttp-async/src/client.mli b/cohttp/cohttp-async/src/client.mli deleted file mode 100644 index fd3d7143d543f1d04eab6da227aabcfcbd73a434..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/client.mli +++ /dev/null @@ -1,123 +0,0 @@ -val request : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> - ?uri:Uri.t -> - ?body:Body.t -> - Cohttp.Request.t -> - (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t -(** Send an HTTP request with an arbitrary body The request is sent as-is. *) - -val call : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> - ?headers:Cohttp.Header.t -> - ?chunked:bool -> - ?body:Body.t -> - Cohttp.Code.meth -> - Uri.t -> - (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t -(** Send an HTTP request with arbitrary method and a body Infers the transfer - encoding. Depending on the given [uri], we choose a way to start a - communication such as: - - - If the scheme is [https], we try to initiate an SSL connection with the - given [ssl_ctx] or a default one on the default port ([*:443]) or the - specified one. - - If the scheme is [httpunix], we use a UNIX domain socket. - - If the scheme ie [http], we try an usual TCP/IP connection on the default - port ([*:80]) or the specified one. *) - -module Connection : sig - type t - - val connect : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> - Uri.t -> - t Async_kernel.Deferred.t - - val close : t -> unit Async_kernel.Deferred.t - val is_closed : t -> bool - - val request : - ?body:Body.t -> - t -> - Cohttp.Request.t -> - (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t -end - -val callv : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> - Uri.t -> - (Cohttp.Request.t * Body.t) Async_kernel.Pipe.Reader.t -> - (Cohttp.Response.t * Body.t) Async_kernel.Pipe.Reader.t - Async_kernel.Deferred.t - -val get : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> - ?headers:Cohttp.Header.t -> - Uri.t -> - (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t -(** Send an HTTP GET request *) - -val head : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> - ?headers:Cohttp.Header.t -> - Uri.t -> - Cohttp.Response.t Async_kernel.Deferred.t -(** Send an HTTP HEAD request *) - -val delete : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> - ?headers:Cohttp.Header.t -> - ?chunked:bool -> - ?body:Body.t -> - Uri.t -> - (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t -(** Send an HTTP DELETE request *) - -val post : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> - ?headers:Cohttp.Header.t -> - ?chunked:bool -> - ?body:Body.t -> - Uri.t -> - (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t -(** Send an HTTP POST request. [chunked] encoding is off by default as not many - servers support it *) - -val put : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> - ?headers:Cohttp.Header.t -> - ?chunked:bool -> - ?body:Body.t -> - Uri.t -> - (Response.t * Body.t) Async_kernel.Deferred.t -(** Send an HTTP PUT request. [chunked] encoding is off by default as not many - servers support it *) - -val patch : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> - ?headers:Cohttp.Header.t -> - ?chunked:bool -> - ?body:Body.t -> - Uri.t -> - (Response.t * Body.t) Async_kernel.Deferred.t -(** Send an HTTP PATCH request. [chunked] encoding is off by default as not many - servers support it *) - -val post_form : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> - ?headers:Cohttp.Header.t -> - params:(string * string list) list -> - Uri.t -> - (Response.t * Body.t) Async_kernel.Deferred.t -(** Send an HTTP POST request in form format *) diff --git a/cohttp/cohttp-async/src/dune b/cohttp/cohttp-async/src/dune deleted file mode 100644 index 35820bdab83eba5f06cd0c1f2c5c51756645e89d..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/dune +++ /dev/null @@ -1,8 +0,0 @@ -(library - (name cohttp_async) - (synopsis "Async backend") - (public_name cohttp-async) - (libraries logs.fmt base fmt async_unix async_kernel uri uri.services - uri-sexp ipaddr.unix conduit-async magic-mime cohttp) - (preprocess - (pps ppx_sexp_conv))) diff --git a/cohttp/cohttp-async/src/io.ml b/cohttp/cohttp-async/src/io.ml deleted file mode 100644 index cb0ad69b9c7add53efed3fb9550f15aa46b220e3..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/io.ml +++ /dev/null @@ -1,103 +0,0 @@ -(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Base -open Async_kernel -module Writer = Async_unix.Writer -module Reader = Async_unix.Reader -module Format = Stdlib.Format - -let log_src_name = "cohttp.async.io" -let src = Logs.Src.create log_src_name ~doc:"Cohttp Async IO module" - -module Log = (val Logs.src_log src : Logs.LOG) - -let default_reporter () = - let fmtr, fmtr_flush = - let b = Buffer.create 512 in - ( Fmt.with_buffer ~like:Fmt.stderr b, - fun () -> - let m = Buffer.contents b in - Buffer.reset b; - m ) - in - let report src _level ~over k msgf = - let k _ = - if String.equal (Logs.Src.name src) log_src_name then - Writer.write (Lazy.force Writer.stderr) (fmtr_flush ()); - over (); - k () - in - msgf @@ fun ?header:_ ?tags:_ fmt -> - Format.kfprintf k fmtr Stdlib.("@[" ^^ fmt ^^ "@]@.") - in - { Logs.report } - -let set_log = - lazy - ((* If no reporter has been set by the application, set default one - that prints to stderr. This way a user will see logs when the debug - flag is set without adding a reporter. *) - if phys_equal (Logs.reporter ()) Logs.nop_reporter then - Logs.set_level @@ Some Logs.Debug; - Logs.set_reporter (default_reporter ())) - -let check_debug norm_fn debug_fn = - match Stdlib.Sys.getenv "COHTTP_DEBUG" with - | _ -> - Lazy.force set_log; - debug_fn - | exception Stdlib.Not_found -> norm_fn - -type 'a t = 'a Deferred.t - -let ( >>= ) = Deferred.( >>= ) -let return = Deferred.return - -type ic = Reader.t -type oc = Writer.t -type conn = unit - -let read_line = - check_debug - (fun ic -> - Reader.read_line ic >>| function `Ok s -> Some s | `Eof -> None) - (fun ic -> - Reader.read_line ic >>| function - | `Ok s -> - Log.debug (fun fmt -> fmt "<<< %s" s); - Some s - | `Eof -> - Log.debug (fun fmt -> fmt "<<>| function - | `Ok len' -> Bytes.To_string.sub buf ~pos:0 ~len:len' - | `Eof -> "" - -let write = - check_debug - (fun oc buf -> - Writer.write oc buf; - return ()) - (fun oc buf -> - Log.debug (fun fmt -> fmt "%4d >>> %s" (Unix.getpid ()) buf); - Writer.write oc buf; - return ()) - -let flush = Writer.flushed diff --git a/cohttp/cohttp-async/src/io.mli b/cohttp/cohttp-async/src/io.mli deleted file mode 100644 index 97dbe0acbf6cee9fce1918fc0b3557c6bfdbd756..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/io.mli +++ /dev/null @@ -1,20 +0,0 @@ -(*{{{ Copyright (c) 2013 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for - * any purpose with or without fee is hereby granted, provided that the - * above copyright notice and this permission notice appear in all - * copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS - * ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE - * AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL - * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA - * OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER - * TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR - * PERFORMANCE OF THIS SOFTWARE. - }}}*) - -include - Cohttp.S.IO - with type 'a t = 'a Async_kernel.Deferred.t - and type ic = Async_unix.Reader.t - and type oc = Async_unix.Writer.t diff --git a/cohttp/cohttp-async/src/request.ml b/cohttp/cohttp-async/src/request.ml deleted file mode 100644 index 97539b2a87d19fe1e537ad073c603165d0c62083..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/request.ml +++ /dev/null @@ -1 +0,0 @@ -include Cohttp.Request diff --git a/cohttp/cohttp-async/src/request.mli b/cohttp/cohttp-async/src/request.mli deleted file mode 100644 index 7362f57cd5679a1be2bdb76f553c5aafc77902c3..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/request.mli +++ /dev/null @@ -1 +0,0 @@ -include Cohttp.S.Request with type t = Cohttp.Request.t diff --git a/cohttp/cohttp-async/src/response.ml b/cohttp/cohttp-async/src/response.ml deleted file mode 100644 index 1753fa74bcebf6a8df93b384b5188c4a70f672dc..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/response.ml +++ /dev/null @@ -1 +0,0 @@ -include Cohttp.Response diff --git a/cohttp/cohttp-async/src/response.mli b/cohttp/cohttp-async/src/response.mli deleted file mode 100644 index e5ecbefefb7e7c9917b9310dfcd00346e9677447..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/response.mli +++ /dev/null @@ -1 +0,0 @@ -include Cohttp.S.Response with type t = Cohttp.Response.t diff --git a/cohttp/cohttp-async/src/server.ml b/cohttp/cohttp-async/src/server.ml deleted file mode 100644 index d269641c95359b73b14d8842b862779b5cdb7229..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/server.ml +++ /dev/null @@ -1,183 +0,0 @@ -open Base -open Async_kernel -open Async_unix - -module Request = struct - include Cohttp.Request - include (Make (Io) : module type of Make (Io) with type t := t) - end - -module Response = struct - include Cohttp.Response - include (Make (Io) : module type of Make (Io) with type t := t) - end - -type ('address, 'listening_on) t = { - server : ('address, 'listening_on) Tcp.Server.t; [@sexp.opaque] -} -[@@deriving sexp_of] - -type response = Response.t * Body.t [@@deriving sexp_of] - -type response_action = - [ `Expert of Cohttp.Response.t * (Io.ic -> Io.oc -> unit Deferred.t) - | `Response of response ] - -type 'r respond_t = - ?flush:bool -> - ?headers:Cohttp.Header.t -> - ?body:Body.t -> - Cohttp.Code.status_code -> - 'r Deferred.t - -let close t = Tcp.Server.close t.server -let close_finished t = Tcp.Server.close_finished t.server -let is_closed t = Tcp.Server.is_closed t.server -let listening_on t = Tcp.Server.listening_on t.server - -let read_body req rd = - match Request.has_body req with - (* TODO maybe attempt to read body *) - | `No | `Unknown -> (`Empty, Deferred.unit) - | `Yes -> - (* Create a Pipe for the body *) - let reader = Request.make_body_reader req rd in - let pipe = Body_raw.pipe_of_body Request.read_body_chunk reader in - (`Pipe pipe, Pipe.closed pipe) - -let collect_errors writer ~f = - let monitor = Writer.monitor writer in - (* don't propagate errors up, we handle them here *) - Monitor.detach_and_get_error_stream monitor |> (ignore : exn Stream.t -> unit); - choose - [ - choice (Monitor.get_next_error monitor) (fun e -> - Error (Exn.Reraised ("Cohttp_async.Server.collect_errors", e))); - choice (try_with ~name:"Cohttp_async.Server.collect_errors" f) Fn.id; - ] - -let handle_client handle_request sock rd wr = - collect_errors wr ~f:(fun () -> - let last_body_pipe_drained = ref Deferred.unit in - let requests_pipe = - Reader.read_all rd (fun rd -> - !last_body_pipe_drained >>= fun () -> - (* [`Expert] responses may close the [Reader.t] *) - if Reader.is_closed rd then return `Eof - else - Request.read rd >>= function - | `Eof | `Invalid _ -> return `Eof - | `Ok req -> ( - let body, finished = read_body req rd in - handle_request ~body sock req >>| function - | `Expert (headers, io_handler) -> - let expert_finished = Ivar.create () in - last_body_pipe_drained := - Deferred.all_unit - [ Ivar.read expert_finished; finished ]; - `Ok (`Expert (headers, io_handler, body, expert_finished)) - | `Response r -> - last_body_pipe_drained := finished; - `Ok (`Response (req, body, r)))) - in - Pipe.iter ~continue_on_error:false requests_pipe ~f:(function - | `Expert (response, io_handler, body, finished) -> - Response.write_header response wr >>= fun () -> - io_handler rd wr >>= fun () -> - Body.drain body >>| fun () -> Ivar.fill_if_empty finished () - | `Response (req, body, (res, res_body)) -> - (* There are scenarios if a client leaves before consuming the full response, - we might have a reference to an async Pipe that doesn't get drained. - - Not draining or closing a pipe can lead to issues if its holding a resource like - a file handle as those resources will never be closed, leading to a leak. - - Async writers have a promise that's fulfilled whenever they are closed, - so we can use it to schedule a close operation on the stream to ensure that we - don't leave a stream open if the underlying channels are closed. *) - (match res_body with - | `Empty | `String _ | `Strings _ -> () - | `Pipe stream -> - Deferred.any_unit - [ Writer.close_finished wr; Writer.consumer_left wr ] - >>> fun () -> Pipe.close_read stream); - let keep_alive = Request.is_keep_alive req in - let flush = Response.flush res in - let res = - let headers = - Cohttp.Header.add_unless_exists - (Cohttp.Response.headers res) - "connection" - (if keep_alive then "keep-alive" else "close") - in - { res with Response.headers } - in - Response.write ~flush - (Body_raw.write_body Response.write_body res_body) - res wr - >>= fun () -> - Writer.(if keep_alive then flushed else close ?force_close:None) wr - >>= fun () -> Body.drain body)) - >>= fun res -> - Writer.close wr >>= fun () -> - Reader.close rd >>| fun () -> Result.ok_exn res - -let respond ?(flush = true) ?(headers = Cohttp.Header.init ()) ?(body = `Empty) - status : response Deferred.t = - let encoding = Body.transfer_encoding body in - let resp = Response.make ~status ~flush ~encoding ~headers () in - return (resp, body) - -let respond_with_pipe ?flush ?headers ?(code = `OK) body = - respond ?flush ?headers ~body:(`Pipe body) code - -let respond_string ?flush ?headers ?(status = `OK) body = - respond ?flush ?headers ~body:(`String body) status - -let respond_with_redirect ?headers uri = - let headers = - Cohttp.Header.add_opt_unless_exists headers "location" (Uri.to_string uri) - in - respond ~flush:false ~headers `Found - -(* Deprecated *) -let resolve_local_file ~docroot ~uri = - Cohttp.Path.resolve_local_file ~docroot ~uri - -let error_body_default = "

404 Not Found

" - -let respond_with_file ?flush ?headers ?(error_body = error_body_default) - filename = - Monitor.try_with ~run:`Now (fun () -> - Reader.open_file filename >>= fun rd -> - let body = `Pipe (Reader.pipe rd) in - let mime_type = Magic_mime.lookup filename in - let headers = - Cohttp.Header.add_opt_unless_exists headers "content-type" mime_type - in - respond ?flush ~headers ~body `OK) - >>= function - | Ok res -> return res - | Error _exn -> respond_string ~status:`Not_found error_body - -type mode = Conduit_async.server - -let create_raw ?max_connections ?backlog ?buffer_age_limit ?(mode = `TCP) - ~on_handler_error where_to_listen handle_request = - Conduit_async.serve ?max_connections ?backlog ?buffer_age_limit - ~on_handler_error mode where_to_listen - (handle_client handle_request) - >>| fun server -> { server } - -let create_expert ?max_connections ?backlog ?buffer_age_limit ?(mode = `TCP) - ~on_handler_error where_to_listen handle_request = - create_raw ?max_connections ?backlog ?buffer_age_limit ~on_handler_error ~mode - where_to_listen handle_request - -let create ?max_connections ?backlog ?buffer_age_limit ?(mode = `TCP) - ~on_handler_error where_to_listen handle_request = - let handle_request ~body address request = - handle_request ~body address request >>| fun r -> `Response r - in - create_raw ?max_connections ?backlog ?buffer_age_limit ~on_handler_error ~mode - where_to_listen handle_request diff --git a/cohttp/cohttp-async/src/server.mli b/cohttp/cohttp-async/src/server.mli deleted file mode 100644 index 24b993b388a0e1c3bc9db0518a1170ae64aee386..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/src/server.mli +++ /dev/null @@ -1,103 +0,0 @@ -type ('address, 'listening_on) t - constraint 'address = [< Async_unix.Socket.Address.t ] -[@@deriving sexp_of] - -val close : (_, _) t -> unit Async_kernel.Deferred.t -val close_finished : (_, _) t -> unit Async_kernel.Deferred.t -val is_closed : (_, _) t -> bool -val listening_on : (_, 'listening_on) t -> 'listening_on - -type response = Response.t * Body.t [@@deriving sexp_of] - -type 'r respond_t = - ?flush:bool -> - ?headers:Cohttp.Header.t -> - ?body:Body.t -> - Cohttp.Code.status_code -> - 'r Async_kernel.Deferred.t - -type response_action = - [ `Expert of - Cohttp.Response.t - * (Async_unix.Reader.t -> - Async_unix.Writer.t -> - unit Async_kernel.Deferred.t) - | `Response of response ] -(** A request handler can respond in two ways: - - - Using [`Response], with a {!Response.t} and a {!Body.t}. - - Using [`Expert], with a {!Response.t} and an IO function that is expected - to write the response body. The IO function has access to the underlying - {!Async_unix.Reader.t} and {!Async_unix.Writer.t}, which allows writing a - response body more efficiently, stream a response or to switch protocols - entirely (e.g. websockets). Processing of pipelined requests continue - after the {!unit Async_kernel.Deferred.t} is resolved. The connection can - be closed by closing the {!Async_unix.Reader.t}. *) - -val respond : response respond_t - -val resolve_local_file : docroot:string -> uri:Uri.t -> string -(** Resolve a URI and a docroot into a concrete local filename. - - Deprecated. Please use Cohttp.Path.resolve_local_file. *) - -val respond_with_pipe : - ?flush:bool -> - ?headers:Cohttp.Header.t -> - ?code:Cohttp.Code.status_code -> - string Async_kernel.Pipe.Reader.t -> - response Async_kernel.Deferred.t -(** Respond with a [string] Pipe that provides the response string - Pipe.Reader.t. - - @param code Default is HTTP 200 `OK *) - -val respond_string : - ?flush:bool -> - ?headers:Cohttp.Header.t -> - ?status:Cohttp.Code.status_code -> - string -> - response Async_kernel.Deferred.t - -val respond_with_redirect : - ?headers:Cohttp.Header.t -> Uri.t -> response Async_kernel.Deferred.t -(** Respond with a redirect to an absolute [uri] - - @param uri Absolute URI to redirect the client to *) - -val respond_with_file : - ?flush:bool -> - ?headers:Cohttp.Header.t -> - ?error_body:string -> - string -> - response Async_kernel.Deferred.t -(** Respond with file contents, and [error_string Pipe.Async_unix.Reader.t] if - the file isn't found *) - -type mode = Conduit_async.server - -val create_expert : - ?max_connections:int -> - ?backlog:int -> - ?buffer_age_limit:Async_unix.Writer.buffer_age_limit -> - ?mode:mode -> - on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ] -> - ('address, 'listening_on) Async.Tcp.Where_to_listen.t -> - (body:Body.t -> - 'address -> - Request.t -> - response_action Async_kernel.Deferred.t) -> - ('address, 'listening_on) t Async_kernel.Deferred.t -(** Build a HTTP server and expose the [IO.ic] and [IO.oc]s, based on the - [Tcp.Server] interface. *) - -val create : - ?max_connections:int -> - ?backlog:int -> - ?buffer_age_limit:Async_unix.Writer.buffer_age_limit -> - ?mode:Conduit_async.server -> - on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ] -> - ('address, 'listening_on) Async.Tcp.Where_to_listen.t -> - (body:Body.t -> 'address -> Request.t -> response Async_kernel.Deferred.t) -> - ('address, 'listening_on) t Async_kernel.Deferred.t -(** Build a HTTP server, based on the [Tcp.Server] interface *) diff --git a/cohttp/cohttp-async/test/dune b/cohttp/cohttp-async/test/dune deleted file mode 100644 index 085cf34eb37d5a9d0191d4d3dd5bc4c66b8bbaad..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/test/dune +++ /dev/null @@ -1,10 +0,0 @@ -(executable - (name test_async_integration) - (libraries cohttp_async_test async_unix base core async_kernel oUnit - cohttp-async)) - -(rule - (alias runtest) - (package cohttp-async) - (action - (run ./test_async_integration.exe))) diff --git a/cohttp/cohttp-async/test/test_async_integration.ml b/cohttp/cohttp-async/test/test_async_integration.ml deleted file mode 100644 index 32a2a6aa794d20b511805c8d0b9b1e90776ad041..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-async/test/test_async_integration.ml +++ /dev/null @@ -1,141 +0,0 @@ -open Base -open Async_kernel -open OUnit -open Cohttp -open Cohttp_async -open Cohttp_async_test - -let chunk_body = [ "one"; ""; " "; "bar"; "" ] -let large_string = String.make (Int.pow 2 16) 'A' -let response_bodies = [ "Testing"; "Foo bar" ] -let ok s = Server.respond `OK ~body:(Body.of_string s) -let chunk size = String.init ~f:(Fn.const 'X') size -let chunk_size = 33_000 -let chunks = 3 - -let server = - [ - (* empty_chunk *) - const @@ Server.respond `OK ~body:(Body.of_string_list chunk_body); - (* large response *) - const @@ Server.respond_string large_string; - (* large request *) - (fun _ body -> - body |> Body.to_string >>| String.length >>= fun len -> - Server.respond_string (Int.to_string len) >>| response); - ] - (* pipelined_chunk *) - @ (response_bodies |> List.map ~f:(Fn.compose const ok)) - @ (* large response chunked *) - [ - (fun _ _ -> - let body = - let r, w = Pipe.create () in - let chunk = chunk chunk_size in - for _ = 0 to chunks - 1 do - Pipe.write_without_pushback w chunk - done; - Pipe.close w; - r - in - Server.respond_with_pipe ~code:`OK body >>| response); - (* pipelined_expert *) - expert (fun _ic oc -> - Async_unix.Writer.write oc "8\r\nexpert 1\r\n0\r\n\r\n"; - Async_unix.Writer.flushed oc); - expert (fun ic oc -> - Async_unix.Writer.write oc "8\r\nexpert 2\r\n0\r\n\r\n"; - Async_unix.Writer.flushed oc >>= fun () -> Async_unix.Reader.close ic); - ] - |> response_sequence - -let ts = - test_server_s server (fun uri -> - let headers = Header.init_with "connection" "close" in - let empty_chunk () = - Client.get ~headers uri >>= fun (_, body) -> - body |> Body.to_string >>| fun body -> - assert_equal body (String.concat ~sep:"" chunk_body) - in - let large_response () = - Client.get ~headers uri >>= fun (_, body) -> - body |> Body.to_string >>| fun body -> assert_equal body large_string - in - let large_request () = - Client.post ~headers ~body:(Body.of_string large_string) uri - >>= fun (_, body) -> - body |> Body.to_string >>| fun s -> - assert_equal (String.length large_string) (Int.of_string s) - in - let pipelined_chunk () = - let printer x = x in - let reqs = - [ - (Request.make ~meth:`POST uri, Body.of_string "foo"); - (Request.make ~meth:`POST uri, Body.of_string "bar"); - ] - in - let body_q = response_bodies |> Queue.of_list in - reqs |> Pipe.of_list |> Client.callv uri >>= fun responses -> - responses |> Pipe.to_list >>= fun resps -> - resps - |> Deferred.List.iter ~how:`Sequential ~f:(fun (_resp, body) -> - let expected_body = body_q |> Queue.dequeue_exn in - body |> Body.to_string >>| fun body -> - assert_equal ~printer expected_body body) - in - let large_chunked_response () = - Client.get ~headers uri >>= fun (resp, body) -> - assert_equal Cohttp.Transfer.Chunked (Response.encoding resp); - body |> Body.to_string >>| String.length >>| fun len -> - assert_equal ~printer:Int.to_string (chunk_size * chunks) len - in - let expert_pipelined () = - let printer x = x in - Client.get uri >>= fun (_rsp, body) -> - Body.to_string body >>= fun body -> - assert_equal ~printer "expert 1" body; - Client.get ~headers uri >>= fun (_rsp, body) -> - Body.to_string body >>| fun body -> - assert_equal ~printer "expert 2" body - in - let check_body_empty_status () = - let is_empty = Cohttp_async.Body.is_empty in - let tests = - [ - ("empty pipe", Pipe.of_list [], true); - ("pipe with elements", Pipe.of_list [ "foo"; "bar" ], false); - ( "pipe with empty items at the beginning", - Pipe.of_list [ ""; "baz" ], - false ); - ("Pipe with empty strings", Pipe.of_list [ ""; ""; "" ], true); - ] - in - Deferred.List.iter ~how:`Sequential tests ~f:(fun (msg, pipe, expected) -> - is_empty (`Pipe pipe) >>| fun real -> - assert_equal ~msg expected real) - >>= fun () -> - let b = Pipe.of_list [ ""; ""; "foo"; "bar" ] in - is_empty (`Pipe b) >>= fun _ -> - Pipe.to_list b >>| fun real -> - let msg = - "Checking if pipe is empty consumes all leading empty strings" - in - assert_equal ~msg [ "foo"; "bar" ] real - in - [ - ("empty chunk test", empty_chunk); - ("large response", large_response); - ("large request", large_request); - ("pipelined chunk test", pipelined_chunk); - ("large chunked response", large_chunked_response); - ("expert response", expert_pipelined); - ("check body is_empty status for pipes", check_body_empty_status); - ]) - -let () = - ts - |> run_async_tests - >>= (fun _ -> Async_unix.Shutdown.exit 0) - |> don't_wait_for; - Core.never_returns (Async_unix.Scheduler.go ()) diff --git a/cohttp/cohttp-lwt-jsoo.opam b/cohttp/cohttp-lwt-jsoo.opam deleted file mode 100644 index 24c7fbd200548e39b79d094f199b3c2757e66e45..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-jsoo.opam +++ /dev/null @@ -1,42 +0,0 @@ -opam-version: "2.0" -maintainer: "anil@recoil.org" -authors: [ - "Anil Madhavapeddy" - "Stefano Zacchiroli" - "David Sheets" - "Thomas Gazagnaire" - "David Scott" - "Rudi Grinberg" - "Andy Ray" -] -synopsis: "CoHTTP implementation for the Js_of_ocaml JavaScript compiler" -description: """ -An implementation of an HTTP client for JavaScript, but using the -CoHTTP types. This lets you build HTTP clients that can compile -natively (using one of the other Cohttp backends such as `cohttp-lwt-unix`) -and also to native JavaScript via js_of_ocaml. -""" -license: "ISC" -tags: ["org:mirage" "org:xapi-project"] -homepage: "https://github.com/mirage/ocaml-cohttp" -doc: "https://mirage.github.io/ocaml-cohttp/" -bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" -depends: [ - "ocaml" {>= "4.08"} - "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"] {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" diff --git a/cohttp/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml b/cohttp/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml deleted file mode 100644 index a638de23f9a5f35578e9d6becb134a7ab807b1de..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml +++ /dev/null @@ -1,338 +0,0 @@ -(*{{{ Copyright (c) 2014 Andy Ray - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Js_of_ocaml -module C = Cohttp -module CLB = Cohttp_lwt.Body - -let ( >>= ) = Lwt.( >>= ) -let ( >|= ) = Lwt.( >|= ) - -module type Params = sig - val chunked_response : bool - val chunk_size : int - val convert_body_string : Js.js_string Js.t -> string - val with_credentials : bool -end - -let xhr_response_supported = - (* from http://stackoverflow.com/questions/8926505/how-to-feature-detect-if-xmlhttprequest-supports-responsetype-arraybuffer *) - let xhr = XmlHttpRequest.create () in - let rt = xhr##.responseType in - Js.to_string (Js.typeof rt) = "string" - -let binary_string str = - let len = String.length str in - let a = new%js Typed_array.uint8Array len in - for i = 0 to len - 1 do - Typed_array.set a i (Char.code str.[i]) - done; - a - -let string_of_uint8array u8a offset len = - String.init len (fun i -> Char.chr (Typed_array.unsafe_get u8a (offset + i))) - -module String_io = Cohttp__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 - let pos = ref 0 in - let chunkerizer () = - if !pos = body_len then Lwt.return C.Transfer.Done - else if !pos + P.chunk_size >= body_len then ( - let str = text ## (substring_toEnd !pos) in - pos := body_len; - Lwt.return (C.Transfer.Final_chunk (P.convert_body_string str))) - else - let str = text ## (substring !pos (!pos + P.chunk_size)) in - pos := !pos + P.chunk_size; - Lwt.return (C.Transfer.Chunk (P.convert_body_string str)) - in - if body_len = 0 then CLB.empty - else CLB.of_stream (CLB.create_stream chunkerizer ()) - - (* perform the body transfer in chunks from arrayBuffer. *) - let chunked_body_binary (ab : Typed_array.arrayBuffer Js.t) = - let body_len = ab##.byteLength in - let u8a = new%js Typed_array.uint8Array_fromBuffer ab in - let pos = ref 0 in - let chunkerizer () = - if !pos = body_len then Lwt.return C.Transfer.Done - else if !pos + P.chunk_size >= body_len then ( - let str = string_of_uint8array u8a !pos (body_len - !pos) in - pos := body_len; - Lwt.return (C.Transfer.Final_chunk str)) - else - let str = string_of_uint8array u8a !pos P.chunk_size in - pos := !pos + P.chunk_size; - Lwt.return (C.Transfer.Chunk str) - in - if body_len = 0 then CLB.empty - else CLB.of_stream (CLB.create_stream chunkerizer ()) - - (* choose between chunked and direct transfer *) - let get = function - | `String js_str -> - if P.chunked_response then chunked_body_str js_str - else CLB.of_string (P.convert_body_string js_str) - | `ArrayBuffer ab -> - if P.chunked_response then chunked_body_binary ab - else - let u8a = new%js Typed_array.uint8Array_fromBuffer ab in - CLB.of_string (string_of_uint8array u8a 0 ab##.byteLength) - - let construct_body xml = - (* construct body *) - let b = - let respText () = - Js.Opt.case xml##.responseText - (fun () -> `String (Js.string "")) - (fun s -> `String s) - in - match xhr_response_supported with - | true when Js.Opt.return xml##.response == Js.null -> - Log.warn (fun m -> m "XHR Response is null; using empty string"); - `String (Js.string "") - | true -> - Js.Opt.case - (File.CoerceTo.arrayBuffer xml##.response) - (fun () -> - Log.warn (fun m -> - m "XHR Response is not an arrayBuffer; using responseText"); - respText ()) - (fun ab -> `ArrayBuffer ab) - | false -> respText () - in - get b -end - -module Make_api (X : sig - module Request : Cohttp.S.Request - module Response : Cohttp.S.Response - - val call : - ?headers:Cohttp.Header.t -> - ?body:Cohttp_lwt.Body.t -> - Cohttp.Code.meth -> - Uri.t -> - (Response.t * Cohttp_lwt.Body.t) Lwt.t -end) = -struct - module Request = X.Request - module Response = X.Response - - type ctx = unit - - let call ?ctx:_ ?headers ?body ?chunked:_ meth uri = - X.call ?headers ?body meth uri - - (* The HEAD should not have a response body *) - let head ?ctx ?headers uri = - let open Lwt in - call ?ctx ?headers ~chunked:false `HEAD uri >|= fst - - let get ?ctx ?headers uri = call ?ctx ?headers ~chunked:false `GET uri - - let delete ?ctx ?body ?chunked ?headers uri = - call ?ctx ?headers ?body ?chunked `DELETE uri - - let post ?ctx ?body ?chunked ?headers uri = - call ?ctx ?headers ?body ?chunked `POST uri - - let put ?ctx ?body ?chunked ?headers uri = - call ?ctx ?headers ?body ?chunked `PUT uri - - let patch ?ctx ?body ?chunked ?headers uri = - call ?ctx ?headers ?body ?chunked `PATCH uri - - let post_form ?ctx ?headers ~params uri = - let headers = - C.Header.add_opt headers "content-type" - "application/x-www-form-urlencoded" - in - let body = Cohttp_lwt.Body.of_string (Uri.encoded_of_query params) in - post ?ctx ~chunked:false ~headers ~body uri - - (* No implementation (can it be done?). What should the failure exception be? *) - exception Cohttp_lwt_xhr_callv_not_implemented - - let callv ?ctx:_ _uri _reqs = Lwt.fail Cohttp_lwt_xhr_callv_not_implemented - - (* ??? *) -end - -module Make_client_async (P : Params) = Make_api (struct - module Response = Cohttp.Response - module Request = Cohttp.Request - module Bb = Body_builder (P) - - let call ?headers ?body meth uri = - let xml = XmlHttpRequest.create () in - xml##.withCredentials := Js.bool P.with_credentials; - if xhr_response_supported then xml##.responseType := Js.string "arraybuffer"; - let (res : (Response.t Lwt.t * CLB.t) Lwt.t), wake = Lwt.task () in - let () = - xml - ## (_open - (Js.string (C.Code.string_of_method meth)) - (Js.string (Uri.to_string uri)) - Js._true) - (* asynchronous call *) - in - (* set request headers *) - let () = - match headers with - | None -> () - | Some headers -> - C.Header.iter - (fun k v -> - (* some headers lead to errors in the javascript console, should - we filter then out here? *) - xml ## (setRequestHeader (Js.string k) (Js.string v))) - headers - in - - xml##.onreadystatechange := - Js.wrap_callback (fun _ -> - match xml##.readyState with - | XmlHttpRequest.DONE -> ( - try - let body = Bb.construct_body xml in - (* Note; a type checker subversion seems to be possible here (4.01.0). - * Remove the type constraint on Lwt.task above and return any old - * guff here. It'll compile and crash in the browser! *) - (* (re-)construct the response *) - let resp_headers = Js.to_string xml##getAllResponseHeaders in - let channel = String_io.open_in resp_headers in - let response = - Lwt.( - Header_io.parse channel >|= fun resp_headers -> - Cohttp.Response.make ~version:`HTTP_1_1 - ~status:(C.Code.status_of_code xml##.status) - ~flush:false (* ??? *) - ~encoding:(CLB.transfer_encoding body) - ~headers:resp_headers ()) - in - Lwt.wakeup wake (response, body) - with - | e - (* If we exhaust the stack, it is possible that - Lwt.wakeup just 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 *) - (match body with - | None -> Lwt.return xml ## (send Js.null) - | Some body -> - CLB.to_string body >>= fun body -> - let bs = binary_string body in - (*Js.Opt.case (File.CoerceTo.blob (Obj.magic blob)) - (fun () -> Lwt.fail_with "could not coerce to blob") - (fun blob -> Lwt.return (xml##(send_blob blob)))*) - (*Lwt.return (xml##send (Js.Opt.return bs)) *) - Lwt.return (xml##send (Js.Opt.return (Obj.magic bs)))) - >>= fun () -> - Lwt.on_cancel res (fun () -> xml##abort); - (* unwrap the response *) - Lwt.( - res >>= fun (r, b) -> - r >>= fun r -> Lwt.return (r, b)) -end) - -module Make_client_sync (P : Params) = Make_api (struct - module Response = Cohttp.Response - module Request = Cohttp.Request - module Bb = Body_builder (P) - - let call ?headers ?body meth uri = - let xml = XmlHttpRequest.create () in - xml##.withCredentials := Js.bool P.with_credentials; - if xhr_response_supported then xml##.responseType := Js.string "arraybuffer"; - let () = - xml - ## (_open - (Js.string (C.Code.string_of_method meth)) - (Js.string (Uri.to_string uri)) - Js._false) - (* synchronous call *) - in - (* set request headers *) - let () = - match headers with - | None -> () - | Some headers -> - C.Header.iter - (fun k v -> - (* some headers lead to errors in the javascript console, should - we filter then out here? *) - xml ## (setRequestHeader (Js.string k) (Js.string v))) - headers - in - (* perform call *) - (match body with - | None -> Lwt.return xml ## (send Js.null) - | Some body -> - CLB.to_string body >|= fun body -> - let bs = binary_string body in - xml ## (send (Js.Opt.return (Obj.magic bs)))) - >>= fun _body -> - let body = Bb.construct_body xml in - (* (re-)construct the response *) - let resp_headers = Js.to_string xml##getAllResponseHeaders in - Header_io.parse (String_io.open_in resp_headers) >>= fun resp_headers -> - let response = - Response.make ~version:`HTTP_1_1 - ~status:(Cohttp.Code.status_of_code xml##.status) - ~flush:false - ~encoding:(CLB.transfer_encoding body) - ~headers:resp_headers () - in - - Lwt.return (response, body) -end) - -module Client = Make_client_async (struct - let chunked_response = true - let chunk_size = 128 * 1024 - let convert_body_string = Js.to_bytestring - let with_credentials = false -end) - -module Client_sync = Make_client_sync (struct - let chunked_response = false - let chunk_size = 0 - let convert_body_string = Js.to_bytestring - let with_credentials = false -end) diff --git a/cohttp/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli b/cohttp/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli deleted file mode 100644 index e1b330e7f15bb21491fddaa1f666fc4b31ce8f14..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli +++ /dev/null @@ -1,62 +0,0 @@ -(*{{{ Copyright (c) 2014 Andy Ray - * Copyright (c) 2012-2013 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** {1 HTTP client for JavaScript using XMLHttpRequest.} - - The {!Logs} source name for this module's logger is ["cohttp.lwt.jsoo"]. To - log the current warnings using the browser's console log, you can write a - custom reporter or use: - - {[ - let reporter = Logs_browser.console_reporter () in - Logs.set_reporter reporter - ]} *) - -(** Configuration parameters for the XmlHttpRequest engines *) -module type Params = sig - val chunked_response : bool - (** Should the response body data be chunked? *) - - val chunk_size : int - (** Size of chunks *) - - val convert_body_string : Js_of_ocaml.Js.js_string Js_of_ocaml.Js.t -> string - (** JavaScript string to OCaml conversion. [Js.to_bytestring] or - [Js.to_string] *) - - val with_credentials : bool - (** Whether withCredentials property of XHR is set. *) -end - -(** Build an asynchronous engine with chunked/unchucked response data treated as - raw bytes or UTF *) -module Make_client_async (P : Params) : Cohttp_lwt.S.Client - -(** Build a synchronous engine with chunked/unchucked response data treated as - raw bytes or UTF *) -module Make_client_sync (P : Params) : Cohttp_lwt.S.Client - -module Client : Cohttp_lwt.S.Client -(** The [Client] module implements an HTTP client interface using asynchronous - XmlHttpRequests. The response body is returned in chucked form with 128Kb / - chunk. Body data is treated as raw bytes. withCredentials property of XHR is - set to false. *) - -module Client_sync : Cohttp_lwt.S.Client -(** The [Client_sync] module implements an HTTP client interface using - synchronous XmlHttpRequests. The response is not chunked and treated as raw - bytes. withCredentials property of XHR is set to false. *) diff --git a/cohttp/cohttp-lwt-jsoo/src/dune b/cohttp/cohttp-lwt-jsoo/src/dune deleted file mode 100644 index 18a372c53a2ce4ab02e4b203cfc92a20ff75b033..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-jsoo/src/dune +++ /dev/null @@ -1,7 +0,0 @@ -(library - (name cohttp_lwt_jsoo) - (public_name cohttp-lwt-jsoo) - (synopsis "XHR/Lwt based http client") - (preprocess - (pps js_of_ocaml-ppx)) - (libraries js_of_ocaml cohttp-lwt logs)) diff --git a/cohttp/cohttp-lwt-unix.opam b/cohttp/cohttp-lwt-unix.opam deleted file mode 100644 index e09968144ad6794db15050c2389eaca9a4ca3c05..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-unix.opam +++ /dev/null @@ -1,47 +0,0 @@ -opam-version: "2.0" -maintainer: "anil@recoil.org" -authors: [ - "Anil Madhavapeddy" - "Stefano Zacchiroli" - "David Sheets" - "Thomas Gazagnaire" - "David Scott" - "Rudi Grinberg" - "Andy Ray" -] -synopsis: "CoHTTP implementation for Unix and Windows using Lwt" -description: """ -An implementation of an HTTP client and server using the Lwt -concurrency library. See the `Cohttp_lwt_unix` module for information -on how to use this. The package also installs `cohttp-curl-lwt` -and a `cohttp-server-lwt` binaries for quick uses of a HTTP(S) -client and server respectively. - -Although the name implies that this only works under Unix, it -should also be fine under Windows too.""" -license: "ISC" -tags: ["org:mirage" "org:xapi-project"] -homepage: "https://github.com/mirage/ocaml-cohttp" -doc: "https://mirage.github.io/ocaml-cohttp/" -bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" -depends: [ - "ocaml" {>= "4.08"} - "dune" {>= "2.0"} - "conduit-lwt" {>= "5.0.0"} - "conduit-lwt-unix" {>= "5.0.0"} - "cmdliner" {>= "1.1.0"} - "magic-mime" - "logs" - "fmt" {>= "0.8.2"} - "cohttp-lwt" {= version} - "ppx_sexp_conv" {>= "v0.13.0"} - "lwt" {>= "3.0.0"} - "base-unix" - "ounit" {with-test} -] -build: [ - ["dune" "subst"] {dev} - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" diff --git a/cohttp/cohttp-lwt-unix/bin/cohttp_curl_lwt.ml b/cohttp/cohttp-lwt-unix/bin/cohttp_curl_lwt.ml deleted file mode 100644 index 4adc748a4d6cb0b1ee9bf17bcd1cd97c6713ffe8..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-unix/bin/cohttp_curl_lwt.ml +++ /dev/null @@ -1,109 +0,0 @@ -(*{{{ Copyright (c) 2014 Hannes Mehnert - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Lwt -open Cohttp -open Cohttp_lwt_unix - -let src = - Logs.Src.create "cohttp.lwt.curl" ~doc:"Cohttp Lwt curl implementation" - -module Log = (val Logs.src_log src : Logs.LOG) - -let client uri ofile meth' = - Log.debug (fun d -> d "Client with URI %s" (Uri.to_string uri)); - let meth = Cohttp.Code.method_of_string meth' in - Log.debug (fun d -> d "Client %s issued" meth'); - Client.call meth uri >>= fun (resp, body) -> - let status = Response.status resp in - Log.debug (fun d -> - d "Client %s returned: %s" meth' (Code.string_of_status status)); - (* TODO follow redirects *) - match Code.is_success (Code.code_of_status status) with - | false -> - prerr_endline (Code.string_of_status status); - exit 1 - | true -> ( - Cohttp_lwt.Body.length body >>= fun (len, body) -> - Log.debug (fun d -> d "Client body length: %Ld" len); - Cohttp_lwt.Body.to_string body >>= fun _s -> - let output_body c = - Lwt_stream.iter_s (Lwt_io.fprint c) (Cohttp_lwt.Body.to_stream body) - in - match ofile with - | None -> output_body Lwt_io.stdout - | Some fname -> Lwt_io.with_file ~mode:Lwt_io.output fname output_body) - -let run_client level ofile uri meth = - if not @@ Debug.debug_active () then ( - Fmt_tty.setup_std_outputs (); - Logs.set_level ~all:true level; - Logs.set_reporter Debug.default_reporter); - Lwt_main.run (client uri ofile meth) - -open Cmdliner - -let uri = - let loc : Uri.t Arg.conv = - let parse s = - try `Ok (Uri.of_string s) with Failure _ -> `Error "unable to parse URI" - in - (parse, fun ppf p -> Format.fprintf ppf "%s" (Uri.to_string p)) - in - Arg.( - required - & pos 0 (some loc) None - & info [] ~docv:"URI" - ~doc:"string of the remote address (e.g. https://google.com)") - -let meth = - let doc = "Set http method" in - Arg.(value & opt string "GET" & info [ "X"; "request" ] ~doc) - -let verb = Logs_cli.level () - -let ofile = - let doc = "Output filename to store the URI into." in - Arg.(value & opt (some string) None & info [ "o" ] ~docv:"FILE" ~doc) - -let cmd = - let info = - let version = Cohttp.Conf.version in - let doc = "retrieve a remote URI contents" in - let man = - [ - `S "DESCRIPTION"; - `P - "$(tname) fetches the remote $(i,URI) and prints it to standard \ - output. The output file can also be specified with the $(b,-o) \ - option, and more verbose debugging out obtained via the $(b,-v) \ - option."; - `S "BUGS"; - `P - "Report them via e-mail to , or \ - on the issue tracker at \ - "; - `S "SEE ALSO"; - `P "$(b,curl)(1), $(b,wget)(1)"; - ] - in - Cmd.info "cohttp-curl" ~version ~doc ~man - in - let term = Term.(const run_client $ verb $ ofile $ uri $ meth) in - Cmd.v info term - -let () = exit @@ Cmd.eval cmd diff --git a/cohttp/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml b/cohttp/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml deleted file mode 100644 index 1f698016310edf80470a7b1ffbde61f3fb0859fc..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml +++ /dev/null @@ -1,125 +0,0 @@ -(*{{{ Copyright (c) 2014-2015 Anil Madhavapeddy - * Copyright (c) 2014 Romain Calascibetta - * Copyright (c) 2014 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Printf -open Lwt -open Cohttp -open Cohttp_lwt_unix - -let handler ~verbose _ req body = - let uri = Cohttp.Request.uri req in - (* Log the request to the console *) - if verbose then - eprintf "--> %s %s %s\n%!" - Cohttp.(Code.string_of_method (Request.meth req)) - (Uri.to_string uri) - (Sexplib0.Sexp.to_string_hum (Request.sexp_of_t req)); - (* Strip out hop-by-hop connection headers *) - let headers = - Request.headers req |> fun h -> - Header.remove h "accept-encoding" |> fun h -> - Header.remove h "content-length" |> fun h -> - Header.remove h "transfer-encoding" |> fun h -> - Header.remove h "connection" |> fun h -> - Header.add h "accept-encoding" "identity" - in - (* Fetch the remote URI *) - let meth = Request.meth req in - Client.call ~headers ~body meth uri >>= fun (resp, body) -> - if verbose then - eprintf "<-- %s %s\n%!" - (Uri.to_string (Request.uri req)) - (Sexplib0.Sexp.to_string_hum (Response.sexp_of_t resp)); - let status = Response.status resp in - let headers = - Response.headers resp |> fun h -> - Header.remove h "transfer-encoding" |> fun h -> - Header.remove h "content-length" |> fun h -> Header.remove h "connection" - in - Server.respond ~headers ~status ~body () - -let sockaddr_of_host_and_port host port = - let inet_addr = Unix.inet_addr_of_string host in - Unix.ADDR_INET (inet_addr, port) - -let start_proxy port host verbose cert key () = - printf "Listening for HTTP request on: %s %d\n%!" host port; - let conn_closed (ch, _conn) = - printf "Connection %s closed\n%!" - (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch)) - in - let callback = handler ~verbose in - let config = Server.make ~callback ~conn_closed () in - let mode = - match (cert, key) with - | Some c, Some k -> - `TLS (`Crt_file_path c, `Key_file_path k, `No_password, `Port port) - | _ -> `TCP (`Port port) - in - Server.create ~mode config - -let lwt_start_proxy port host level cert key = - if not @@ Debug.debug_active () then ( - Fmt_tty.setup_std_outputs (); - Logs.set_level ~all:true level; - Logs.set_reporter Debug.default_reporter); - Lwt_main.run (start_proxy port host (level <> None) cert key ()) - -open Cmdliner - -let host = - let doc = "IP address to listen on." in - Arg.(value & opt string "0.0.0.0" & info [ "s" ] ~docv:"HOST" ~doc) - -let port = - let doc = "TCP port to listen on." in - Arg.(value & opt int 8080 & info [ "p" ] ~docv:"PORT" ~doc) - -let verb = Logs_cli.level () - -let ssl_cert = - let doc = "SSL certificate file." in - Arg.(value & opt (some string) None & info [ "c" ] ~docv:"SSL_CERT" ~doc) - -let ssl_key = - let doc = "SSL key file." in - Arg.(value & opt (some string) None & info [ "k" ] ~docv:"SSL_KEY" ~doc) - -let cmd = - let info = - let version = Cohttp.Conf.version in - let doc = "a simple http proxy" in - let man = - [ - `S "DESCRIPTION"; - `P "$(tname) sets up a simple http proxy with lwt as backend"; - `S "BUGS"; - `P - "Report them via e-mail to , or \ - on the issue tracker at \ - "; - ] - in - Cmd.info "cohttp-proxy" ~version ~doc ~man - in - let term = - Term.(const lwt_start_proxy $ port $ host $ verb $ ssl_cert $ ssl_key) - in - Cmd.v info term - -let () = exit @@ Cmd.eval cmd diff --git a/cohttp/cohttp-lwt-unix/bin/cohttp_server_lwt.ml b/cohttp/cohttp-lwt-unix/bin/cohttp_server_lwt.ml deleted file mode 100644 index 57b0f6d268a4d7f16bc70e19bea506fb7ce01204..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-unix/bin/cohttp_server_lwt.ml +++ /dev/null @@ -1,187 +0,0 @@ -(*{{{ Copyright (c) 2014 Romain Calascibetta - * Copyright (c) 2014 Anil Madhavapeddy - * Copyright (c) 2014 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Lwt.Infix -open Cohttp_lwt_unix -open Cohttp_server - -let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server" - -module Log = (val Logs.src_log src : Logs.LOG) - -let method_filter meth (res, body) = - match meth with - | `HEAD -> Lwt.return (res, `Empty) - | _ -> Lwt.return (res, body) - -let serve_file ~docroot ~uri = - let fname = Cohttp.Path.resolve_local_file ~docroot ~uri in - Server.respond_file ~fname () - -let ls_dir dir = - Lwt_stream.to_list - (Lwt_stream.filter (( <> ) ".") (Lwt_unix.files_of_directory dir)) - -let serve ~info ~docroot ~index uri path = - let file_name = Cohttp.Path.resolve_local_file ~docroot ~uri in - Lwt.catch - (fun () -> - Lwt_unix.stat file_name >>= fun stat -> - match kind_of_unix_kind stat.Unix.st_kind with - | `Directory -> ( - let path_len = String.length path in - if path_len <> 0 && path.[path_len - 1] <> '/' then - Server.respond_redirect ~uri:(Uri.with_path uri (path ^ "/")) () - else - match Sys.file_exists (file_name / index) with - | true -> - let uri = Uri.with_path uri (path / index) in - serve_file ~docroot ~uri - | false -> - ls_dir file_name - >>= Lwt_list.map_s (fun f -> - let file_name = file_name / f in - Lwt.try_bind - (fun () -> Lwt_unix.LargeFile.stat file_name) - (fun stat -> - Lwt.return - ( Some - (kind_of_unix_kind stat.Unix.LargeFile.st_kind), - stat.Unix.LargeFile.st_size, - f )) - (fun _exn -> Lwt.return (None, 0L, f))) - >>= fun listing -> - let body = html_of_listing uri path (sort listing) info in - Server.respond_string ~status:`OK ~body ()) - | `File -> serve_file ~docroot ~uri - | _ -> - Server.respond_string ~status:`Forbidden - ~body:(html_of_forbidden_unnormal path info) - ()) - (function - | Unix.Unix_error (Unix.ENOENT, "stat", p) as e -> - if p = file_name then - Server.respond_string ~status:`Not_found - ~body:(html_of_not_found path info) - () - else Lwt.fail e - | e -> Lwt.fail e) - -let handler ~info ~docroot ~index (ch, _conn) req _body = - let uri = Cohttp.Request.uri req in - let path = Uri.path uri in - (* Log the request to the console *) - Log.debug (fun m -> - m "%s %s %s" - Cohttp.(Code.string_of_method (Request.meth req)) - path - (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))); - (* Get a canonical filename from the URL and docroot *) - match Request.meth req with - | (`GET | `HEAD) as meth -> - serve ~info ~docroot ~index uri path >>= method_filter meth - | meth -> - let meth = Cohttp.Code.string_of_method meth in - let allowed = [ "GET"; "HEAD" ] in - let headers = Cohttp.Header.(add_multi (init ()) "allow" allowed) in - Server.respond_string ~headers ~status:`Method_not_allowed - ~body: - (html_of_method_not_allowed meth - (String.concat "," allowed) - path info) - () - -let start_server docroot port host index tls () = - Log.info (fun m -> m "Listening for HTTP request on: %s %d" host port); - let info = - Printf.sprintf "Served by Cohttp/Lwt listening on %s:%d" host port - in - let conn_closed (ch, _conn) = - Log.debug (fun m -> - m "connection %s closed" - (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))) - in - let callback = handler ~info ~docroot ~index in - let config = Server.make ~callback ~conn_closed () in - let mode = - match tls with - | Some (c, k) -> - `TLS (`Crt_file_path c, `Key_file_path k, `No_password, `Port port) - | None -> `TCP (`Port port) - in - Conduit_lwt_unix.init ~src:host () >>= fun ctx -> - let ctx = Cohttp_lwt_unix.Net.init ~ctx () in - Server.create ~ctx ~mode config - -let lwt_start_server docroot port host index level tls = - if not @@ Debug.debug_active () then ( - Fmt_tty.setup_std_outputs (); - Logs.set_level ~all:true level; - Logs.set_reporter Debug.default_reporter); - Lwt_main.run (start_server docroot port host index tls ()) - -open Cmdliner - -let host = - let doc = "IP address to listen on." in - Arg.(value & opt string "::" & info [ "s" ] ~docv:"HOST" ~doc) - -let port = - let doc = "TCP port to listen on." in - Arg.(value & opt int 8080 & info [ "p" ] ~docv:"PORT" ~doc) - -let index = - let doc = "Name of index file in directory." in - Arg.(value & opt string "index.html" & info [ "i" ] ~docv:"INDEX" ~doc) - -let verb = Logs_cli.level () - -let tls = - let doc = "TLS certificate files." in - Arg.( - value - & opt (some (pair string string)) None - & info [ "tls" ] ~docv:"CERT,KEY" ~doc) - -let doc_root = - let doc = "Serving directory." in - Arg.(value & pos 0 dir "." & info [] ~docv:"DOCROOT" ~doc) - -let cmd = - let info = - let version = Cohttp.Conf.version in - let doc = "a simple http server" in - let man = - [ - `S "DESCRIPTION"; - `P "$(tname) sets up a simple http server with lwt as backend"; - `S "BUGS"; - `P - "Report them via e-mail to , or \ - on the issue tracker at \ - "; - ] - in - Cmd.info "cohttp-server" ~version ~doc ~man - in - let term = - Term.(const lwt_start_server $ doc_root $ port $ host $ index $ verb $ tls) - in - Cmd.v info term - -let () = exit @@ Cmd.eval cmd diff --git a/cohttp/cohttp-lwt-unix/bin/dune b/cohttp/cohttp-lwt-unix/bin/dune deleted file mode 100644 index b8ae61a03e7992cd34c23c63dc52abde1e56b1ce..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-unix/bin/dune +++ /dev/null @@ -1,14 +0,0 @@ -(executables - (names cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt) - (libraries - cohttp-lwt-unix - cohttp_server - logs - logs.lwt - logs.fmt - logs.cli - cmdliner - conduit-lwt - fmt.tty) - (package cohttp-lwt-unix) - (public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt)) diff --git a/cohttp/cohttp-lwt-unix/test/dune b/cohttp/cohttp-lwt-unix/test/dune deleted file mode 100644 index 163c21cdcf3e0c1fef3e7424c81ce9758531d137..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-unix/test/dune +++ /dev/null @@ -1,43 +0,0 @@ -(executable - (name test_parser) - (modules test_parser) - (libraries cohttp-lwt-unix oUnit lwt.unix)) - -(rule - (alias runtest) - (package cohttp-lwt-unix) - (action - (run ./test_parser.exe))) - -(executable - (modules test_sanity) - (name test_sanity) - (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) - -(executable - (modules test_sanity_noisy) - (name test_sanity_noisy) - (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) - -(rule - (alias runtest) - (package cohttp-lwt-unix) - (action - (run ./test_sanity.exe))) - -(rule - (alias runtest) - (package cohttp-lwt-unix) - (action - (run ./test_sanity_noisy.exe))) - -(executable - (modules test_body) - (name test_body) - (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) - -(rule - (alias runtest) - (package cohttp-lwt-unix) - (action - (run ./test_body.exe))) diff --git a/cohttp/cohttp-lwt-unix/test/test_body.ml b/cohttp/cohttp-lwt-unix/test/test_body.ml deleted file mode 100644 index 7a51ed2d46cdc722dbdb77e1da598529b15e1342..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-unix/test/test_body.ml +++ /dev/null @@ -1,48 +0,0 @@ -open Lwt -open Lwt.Infix -open OUnit -module Body = Cohttp_lwt.Body - -let run_test f = - Lwt.try_bind f (fun () -> return `Ok) (fun exn -> return (`Exn exn)) - -let test_empty_body () = - Body.is_empty (`Stream (Lwt_stream.of_list [])) >|= fun res -> - assert_equal true res - -let test_non_empty_stream () = - Body.is_empty (`Stream (Lwt_stream.of_list [ "foo"; "bar" ])) >|= fun res -> - assert_equal false res - -let test_stream_with_leading_empty_strings () = - let s = Lwt_stream.of_list [ ""; ""; "foo"; ""; "bar" ] in - Body.is_empty (`Stream s) >>= fun res -> - assert_equal false res; - Lwt_stream.to_list s >|= fun res -> - assert_equal ~msg:"is_empty should consume leading spaces" - [ "foo"; ""; "bar" ] res - -let test_stream_empty_strings () = - Body.is_empty (`Stream (Lwt_stream.of_list [ ""; ""; "" ])) >|= fun res -> - assert_equal true res - -let tests = - [ - ("Empty stream", test_empty_body); - ("Non empty stream", test_non_empty_stream); - ("Stream with leading empty strings", test_stream_with_leading_empty_strings); - ("Stream with empty strings", test_stream_empty_strings); - ] - -let test_suite = - Lwt_list.map_s - (fun (title, test) -> run_test test >|= fun res -> (title, res)) - tests - >|= fun results -> - let tests = - ListLabels.map results ~f:(fun (title, res) -> - title >:: fun () -> match res with `Ok -> () | `Exn exn -> raise exn) - in - "Cohttp_Lwt.Body" >::: tests - -let _ = test_suite |> Cohttp_lwt_unix_test.run_async_tests |> Lwt_main.run diff --git a/cohttp/cohttp-lwt-unix/test/test_parser.ml b/cohttp/cohttp-lwt-unix/test/test_parser.ml deleted file mode 100644 index 3bf2692f785fcfd8f6855b8a00b9303af66d47bd..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-unix/test/test_parser.ml +++ /dev/null @@ -1,340 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open OUnit - -let basic_req = "GET /index.html HTTP/1.1\r\nHost: www.example.com\r\n\r\n" - -let basic_res = - "HTTP/1.1 200 OK\r\n\ - Date: Mon, 23 May 2005 22:38:34 GMT\r\n\ - Server: Apache/1.3.3.7 (Unix) (Red-Hat/Linux)\r\n\ - Last-Modified: Wed, 08 Jan 2003 23:11:55 GMT\r\n\ - Etag: \"3f80f-1b6-3e1cb03b\"\r\n\ - Accept: text/*\r\n\ - Accept: application/xml\r\n\ - Accept-Ranges: none\r\n\ - Content-Length: 0\r\n\ - Connection: close\r\n\ - Content-Type: text/html; charset=UTF-8" - -let basic_res_content = - "HTTP/1.1 200 OK\r\n\ - Date: Mon, 23 May 2005 22:38:34 GMT\r\n\ - Server: Apache/1.3.3.7 (Unix) (Red-Hat/Linux)\r\n\ - Last-Modified: Wed, 08 Jan 2003 23:11:55 GMT\r\n\ - Etag: \"3f80f-1b6-3e1cb03b\"\r\n\ - Accept-Ranges: none\r\n\ - Content-Length: 32\r\n\ - Connection: close\r\n\ - Content-Type: text/html; charset=UTF-8\r\n\ - \r\n\ - home=Cosby&favorite+flavor=flies" - -let post_req = - "POST /path/script.cgi HTTP/1.0\r\n\ - From: frog@jmarshall.com\r\n\ - User-Agent: HTTPTool/1.0\r\n\ - Content-Type: application/x-www-form-urlencoded\r\n\ - Content-Length: 32\r\n\ - \r\n\ - home=Cosby&favorite+flavor=flies" - -let post_data_req = - "POST /path/script.cgi HTTP/1.0\r\n\ - From: frog@jmarshall.com\r\n\ - User-Agent: HTTPTool/1.0\r\n\ - Content-Length: 32\r\n\ - \r\n\ - home=Cosby&favorite+flavor=flies" - -let post_chunked_req = - "POST /foo HTTP/1.1\r\n\ - Date: Fri, 31 Dec 1999 23:59:59 GMT\r\n\ - Content-Type: text/plain\r\n\ - Transfer-Encoding: chunked\r\n\ - \r\n\ - 1a; ignore-stuff-here\r\n\ - abcdefghijklmnopqrstuvwxyz\r\n\ - 10\r\n\ - 1234567890abcdef\r\n\ - 0\r\n\ - some-footer: some-value\r\n\ - another-footer: another-value\r\n\ - \r\n" - -let chunked_res = - "HTTP/1.1 200 OK\r\n\ - Date: Fri, 31 Dec 1999 23:59:59 GMT\r\n\ - Content-Type: text/plain\r\n\ - Transfer-Encoding: chunked\r\n\ - \r\n\ - 1a; ignore-stuff-here\r\n\ - abcdefghijklmnopqrstuvwxyz\r\n\ - 10\r\n\ - 1234567890abcdef\r\n\ - 0\r\n\ - some-footer: some-value\r\n\ - another-footer: another-value\r\n\ - \r\n" - -let user_agent = Cohttp.Header.user_agent -let basic_res_plus_crlf = basic_res ^ "\r\n\r\n" -let ic_of_buffer buf = Lwt_io.of_bytes ~mode:Lwt_io.input buf -let oc_of_buffer buf = Lwt_io.of_bytes ~mode:Lwt_io.output buf - -open Lwt - -let pp_diff fmt (a, b) = - Format.pp_print_string fmt "Expected:"; - Format.pp_print_newline fmt (); - Format.pp_print_string fmt a; - Format.pp_print_string fmt "Result:"; - Format.pp_print_newline fmt (); - Format.pp_print_string fmt b - -let p_sexp f x = x |> f |> Sexplib0.Sexp.to_string - -module Req_io = Cohttp.Request.Make (Cohttp_lwt_unix.IO) -module Rep_io = Cohttp.Response.Make (Cohttp_lwt_unix.IO) - -let basic_req_parse () = - let module CU = Cohttp_lwt_unix in - let ic = ic_of_buffer (Lwt_bytes.of_string basic_req) in - Req_io.read ic >>= function - | `Ok req -> - assert_equal (Cohttp.Request.version req) `HTTP_1_1; - assert_equal (CU.Request.meth req) `GET; - assert_equal - ~printer:(fun x -> x) - "//www.example.com/index.html" - (Uri.to_string (CU.Request.uri req)); - return () - | _ -> assert false - -let basic_res_parse res () = - let open Cohttp in - let open Cohttp_lwt_unix in - let ic = ic_of_buffer (Lwt_bytes.of_string res) in - Rep_io.read ic >>= function - | `Ok res -> - (* Parse first line *) - assert_equal (Response.version res) `HTTP_1_1; - assert_equal (Response.status res) `OK; - let headers = Response.headers res in - assert_equal (Header.get headers "connection") (Some "close"); - assert_equal (Header.get headers "Accept-ranges") (Some "none"); - assert_equal - (Header.get headers "content-type") - (Some "text/html; charset=UTF-8"); - return () - | _ -> assert false - -let req_parse () = - let open Cohttp_lwt_unix in - let ic = ic_of_buffer (Lwt_bytes.of_string basic_req) in - Req_io.read ic >>= function - | `Ok req -> - assert_equal `GET (Request.meth req); - assert_equal "/index.html" (Uri.path (Request.uri req)); - assert_equal `HTTP_1_1 (Request.version req); - return () - | _ -> assert false - -let post_data_parse () = - let open Cohttp in - let ic = ic_of_buffer (Lwt_bytes.of_string post_data_req) in - Req_io.read ic >>= function - | `Ok req -> - let printer = p_sexp Transfer.sexp_of_chunk in - let reader = Req_io.make_body_reader req ic in - Req_io.read_body_chunk reader >>= fun body -> - assert_equal ~printer - (Transfer.Final_chunk "home=Cosby&favorite+flavor=flies") body; - (* A subsequent request for the body will have consumed it, therefore None *) - Req_io.read_body_chunk reader >>= fun body -> - assert_equal ~printer Transfer.Done body; - return () - | _ -> assert false - -let post_chunked_parse () = - let open Cohttp in - let open Cohttp_lwt_unix in - let ic = ic_of_buffer (Lwt_bytes.of_string post_chunked_req) in - Req_io.read ic >>= function - | `Ok req -> - assert_equal - (Transfer.string_of_encoding (Request.encoding req)) - "chunked"; - let reader = Req_io.make_body_reader req ic in - Req_io.read_body_chunk reader >>= fun chunk -> - assert_equal chunk (Transfer.Chunk "abcdefghijklmnopqrstuvwxyz"); - Req_io.read_body_chunk reader >>= fun chunk -> - assert_equal chunk (Transfer.Chunk "1234567890abcdef"); - return () - | _ -> assert false - -let res_content_parse () = - let open Cohttp in - let open Cohttp_lwt_unix in - let ic = ic_of_buffer (Lwt_bytes.of_string basic_res_content) in - Rep_io.read ic >>= function - | `Ok res -> - assert_equal `HTTP_1_1 (Response.version res); - assert_equal `OK (Response.status res); - let reader = Rep_io.make_body_reader res ic in - Rep_io.read_body_chunk reader >>= fun body -> - assert_equal (Transfer.Final_chunk "home=Cosby&favorite+flavor=flies") - body; - return () - | _ -> assert false - -let res_chunked_parse () = - let open Cohttp in - let open Cohttp_lwt_unix in - let ic = ic_of_buffer (Lwt_bytes.of_string chunked_res) in - Rep_io.read ic >>= function - | `Ok res -> - assert_equal `HTTP_1_1 (Response.version res); - assert_equal `OK (Response.status res); - let reader = Rep_io.make_body_reader res ic in - Rep_io.read_body_chunk reader >>= fun chunk -> - assert_equal chunk (Transfer.Chunk "abcdefghijklmnopqrstuvwxyz"); - Rep_io.read_body_chunk reader >>= fun chunk -> - assert_equal chunk (Transfer.Chunk "1234567890abcdef"); - return () - | _ -> assert false - -(* Extract the substring of the byte buffer that has been written to *) -let get_substring oc buf = - let len = Int64.to_int (Lwt_io.position oc) in - let b = Bytes.create len in - Lwt_bytes.blit_to_bytes buf 0 b 0 len; - b |> Bytes.to_string - -let write_req expected req = - (* Use the low-level write_header/footer API *) - let buf = Lwt_bytes.create 4096 in - let oc = oc_of_buffer buf in - let body = Cohttp_lwt.Body.of_string "foobar" in - Req_io.write - (fun writer -> Cohttp_lwt.Body.write_body (Req_io.write_body writer) body) - req oc - >>= fun () -> - assert_equal ~pp_diff expected (get_substring oc buf); - (* Use the high-level write API. This also tests that req is immutable - * by re-using it *) - let buf = Lwt_bytes.create 4096 in - let oc = oc_of_buffer buf in - Req_io.write (fun writer -> Req_io.write_body writer "foobar") req oc - >|= fun () -> assert_equal expected (get_substring oc buf) - -let make_simple_req () = - let open Cohttp in - let open Cohttp_lwt_unix in - let expected = - "POST /foo/bar HTTP/1.1\r\nFoo: bar\r\nhost: localhost\r\nuser-agent: " - ^ user_agent - ^ "\r\ntransfer-encoding: chunked\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n" - in - let req = - Request.make ~encoding:Transfer.Chunked ~meth:`POST - ~headers:(Header.init_with "Foo" "bar") - (Uri.of_string "/foo/bar") - in - write_req expected req - -let mutate_simple_req () = - let open Cohttp in - let open Cohttp_lwt_unix in - let expected = - "POST /foo/bar HTTP/1.1\r\nfoo: bar\r\nhost: localhost\r\nuser-agent: " - ^ user_agent - ^ "\r\ntransfer-encoding: chunked\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n" - in - let req = - Request.make ~encoding:Transfer.Chunked - ~headers:(Header.init_with "foo" "bar") - (Uri.of_string "/foo/bar") - in - let req = { req with Request.meth = `POST } in - write_req expected req - -let make_simple_res () = - let open Cohttp in - let open Cohttp_lwt_unix in - let expected = - "HTTP/1.1 200 OK\r\n\ - foo: bar\r\n\ - transfer-encoding: chunked\r\n\ - \r\n\ - 6\r\n\ - foobar\r\n\ - 0\r\n\ - \r\n" - in - (* Use the low-level write_header/footer API *) - let buf = Lwt_bytes.create 4096 in - let oc = oc_of_buffer buf in - let res = Response.make ~headers:(Header.of_list [ ("foo", "bar") ]) () in - let body = Cohttp_lwt.Body.of_string "foobar" in - Rep_io.write - (fun writer -> Cohttp_lwt.Body.write_body (Rep_io.write_body writer) body) - res oc - >>= fun () -> - assert_equal expected (get_substring oc buf); - (* Use the high-level write API. This also tests that req is immutable - * by re-using it *) - let buf = Lwt_bytes.create 4096 in - let oc = oc_of_buffer buf in - Rep_io.write (fun writer -> Rep_io.write_body writer "foobar") res oc - >>= fun () -> - assert_equal expected (get_substring oc buf); - return () - -let test_cases = - let tests = - [ - ("basic_req_parse", basic_req_parse); - ("req_parse", req_parse); - ("post_data_parse", post_data_parse); - ("post_chunked_parse", post_chunked_parse); - ("basic_res_parse 1", basic_res_parse basic_res); - ("basic_res_parse 2", basic_res_parse basic_res_plus_crlf); - ("res_content_parse", res_content_parse); - ("make_simple_req", make_simple_req); - ("mutate_simple_req", mutate_simple_req); - ("make_simple_res", make_simple_res); - ] - in - List.map (fun (n, x) -> n >:: fun () -> Lwt_main.run (x ())) tests - -(* Returns true if the result list contains successes only. - Copied from oUnit source as it isnt exposed by the mli *) -let rec was_successful = function - | [] -> true - | RSuccess _ :: t | RSkip _ :: t -> was_successful t - | RFailure _ :: _ | RError _ :: _ | RTodo _ :: _ -> false - -let _ = - let suite = "Parser" >::: test_cases in - let verbose = ref false in - let set_verbose _ = verbose := true in - Arg.parse - [ ("-verbose", Arg.Unit set_verbose, "Run the test in verbose mode.") ] - (fun x -> raise (Arg.Bad ("Bad argument : " ^ x))) - ("Usage: " ^ Sys.argv.(0) ^ " [-verbose]"); - if not (was_successful (run_test_tt ~verbose:!verbose suite)) then exit 1 diff --git a/cohttp/cohttp-lwt-unix/test/test_sanity.ml b/cohttp/cohttp-lwt-unix/test/test_sanity.ml deleted file mode 100644 index 22c9420cb4bf559cc630434fe643b7ef85880ce4..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-unix/test/test_sanity.ml +++ /dev/null @@ -1,168 +0,0 @@ -open Lwt.Infix -open OUnit -open Cohttp_lwt_unix -open Cohttp_lwt_unix_test -module Body = Cohttp_lwt.Body -module IO = Cohttp_lwt_unix.IO - -module Request = struct - include Cohttp.Request - include (Make (IO) : module type of Make (IO) with type t := t) - end - -let message = "Hello sanity!" -let chunk_body = [ "one"; ""; " "; "bar"; "" ] -let leak_repeat = 1024 -let () = Debug.activate_debug () -let () = Logs.set_level (Some Warning) - -let server = - List.map const - [ - (* t *) - Server.respond_string ~status:`OK ~body:message (); - (* pipelined_chunk *) - Server.respond ~status:`OK ~body:(Body.of_string "") (); - Server.respond ~status:`OK ~body:(Body.of_string_list chunk_body) (); - Server.respond ~status:`OK ~body:(Body.of_string "") (); - (* pipelined_interleave *) - Server.respond_string ~status:`OK ~body:"one" (); - Server.respond_string ~status:`OK ~body:"two" (); - Server.respond_string ~status:`OK ~body:"three" (); - (* Massive chunked *) - Server.respond ~status:`OK - ~body: - (let count = ref 0 in - let chunk = String.make 64 '0' in - `Stream - (Lwt_stream.from_direct (fun () -> - if !count < 1000 then ( - incr count; - Some chunk) - else None))) - (); - ] - @ (Array.init (leak_repeat * 2) (fun _ _ _ -> - (* no leaks *) - Server.respond_string ~status:`OK ~body:"no leak" () >|= fun rsp -> - `Response rsp) - |> Array.to_list) - (* pipelined_expert *) - @ [ - (fun _ _ -> - Lwt.return - (`Expert - ( Cohttp.Response.make (), - fun _ic oc -> Lwt_io.write oc "8\r\nexpert 1\r\n0\r\n\r\n" ))); - (fun _ _ -> - Lwt.return - (`Expert - ( Cohttp.Response.make (), - fun ic oc -> - Lwt_io.write oc "8\r\nexpert 2\r\n0\r\n\r\n" >>= fun () -> - Lwt_io.flush oc >>= fun () -> Lwt_io.close ic ))); - ] - |> response_sequence - -let check_logs test () = - let old = Logs.(warn_count () + err_count ()) in - test () >|= fun () -> - let new_errs = Logs.(warn_count () + err_count ()) - old in - if new_errs > 0 then - Fmt.failwith "Test produced %d log messages at level >= warn" new_errs - -let ts = - Cohttp_lwt_unix_test.test_server_s server (fun uri -> - let ctx = Cohttp_lwt_unix.Net.default_ctx in - let t () = - Client.get ~ctx uri >>= fun (_, body) -> - body |> Body.to_string >|= fun body -> assert_equal body message - in - let pipelined_chunk () = - let printer x = x in - let body = String.concat "" chunk_body in - let reqs = - [ - (Request.make ~meth:`HEAD uri, `Empty); - (Request.make ~meth:`GET uri, `Empty); - (Request.make ~meth:`HEAD uri, `Empty); - ] - in - let counter = ref 0 in - Client.callv ~ctx uri (Lwt_stream.of_list reqs) >>= fun resps -> - Lwt_stream.iter_s - (fun (_, rbody) -> - rbody |> Body.to_string >|= fun rbody -> - (match !counter with - | 0 | 2 -> assert_equal ~printer "" rbody - | _ -> assert_equal ~printer body rbody); - incr counter) - resps - >>= fun () -> - assert_equal ~printer:string_of_int 3 !counter; - Lwt.return_unit - in - let pipelined_interleave () = - let r n = - let uri = Uri.with_query' uri [ ("test", string_of_int n) ] in - (Request.make uri, Body.empty) - in - let reqs, push = Lwt_stream.create () in - push (Some (r 1)); - push (Some (r 2)); - Client.callv ~ctx uri reqs >>= fun resps -> - let resps = Lwt_stream.map_s (fun (_, b) -> Body.to_string b) resps in - Lwt_stream.fold - (fun b i -> - Logs.info (fun f -> f "Request %i\n" i); - (match i with - | 0 -> assert_equal b "one" - | 1 -> - assert_equal b "two"; - Logs.info (fun f -> f "Sending extra request"); - push (Some (r 3)) - | 2 -> - assert_equal b "three"; - push None - | x -> assert_failure ("Test failed with " ^ string_of_int x)); - succ i) - resps 0 - >|= fun l -> assert_equal l 3 - in - let massive_chunked () = - Client.get ~ctx uri >>= fun (_resp, body) -> - Body.to_string body >|= fun body -> - assert_equal ~printer:string_of_int (1000 * 64) (String.length body) - in - let test_no_leak () = - let stream = - Array.init leak_repeat (fun _ -> uri) |> Lwt_stream.of_array - in - Lwt_stream.fold_s - (fun uri () -> - Client.head ~ctx uri >>= fun resp_head -> - assert_equal (Response.status resp_head) `OK; - Client.get ~ctx uri >>= fun (resp_get, body) -> - assert_equal (Response.status resp_get) `OK; - Body.drain_body body) - stream () - in - let expert_pipelined () = - let printer x = x in - Client.get ~ctx uri >>= fun (_rsp, body) -> - Body.to_string body >>= fun body -> - assert_equal ~printer "expert 1" body; - Client.get ~ctx uri >>= fun (_rsp, body) -> - Body.to_string body >|= fun body -> - assert_equal ~printer "expert 2" body - in - [ - ("sanity test", check_logs t); - ("pipelined chunk test", check_logs pipelined_chunk); - ("pipelined with interleaving requests", check_logs pipelined_interleave); - ("massive chunked", check_logs massive_chunked); - ("no leaks on requests", check_logs test_no_leak); - ("expert response", check_logs expert_pipelined); - ]) - -let _ = ts |> run_async_tests |> Lwt_main.run diff --git a/cohttp/cohttp-lwt-unix/test/test_sanity_noisy.ml b/cohttp/cohttp-lwt-unix/test/test_sanity_noisy.ml deleted file mode 100644 index 3368861fad0328c251c63cdcb925e61e5c4b793b..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt-unix/test/test_sanity_noisy.ml +++ /dev/null @@ -1,87 +0,0 @@ -open Lwt.Infix -open OUnit -open Cohttp -open Cohttp_lwt_unix -open Cohttp_lwt_unix_test -module Body = Cohttp_lwt.Body -module IO = Cohttp_lwt_unix.IO - -module Request = struct - include Cohttp.Request - include (Make (IO) : module type of Make (IO) with type t := t) - end - -let message = "Hello sanity!" -let chunk_body = [ "one"; ""; " "; "bar"; "" ] -let leak_repeat = 1024 -let () = Logs.set_level (Some Info) -let () = Logs.set_reporter Logs.nop_reporter - -let check_logs test () = - let old = Logs.(warn_count () + err_count ()) in - test () >|= fun () -> - let new_errs = Logs.(warn_count () + err_count ()) - old in - if new_errs > 0 then - Fmt.failwith "Test produced %d log messages at level >= warn" new_errs - -let server_noisy = - List.map const - [ - (* empty_chunk *) - Server.respond ~status:`OK ~body:(Body.of_string_list chunk_body) (); - (* not modified *) - Server.respond ~status:`Not_modified ~body:Body.empty (); - ] - @ [ - (fun _ body -> - (* Returns 500 on bad file *) - Body.to_string body >>= fun fname -> - Server.respond_file ~fname () >|= fun rsp -> `Response rsp); - ] - |> response_sequence - -let ts_noisy = - Cohttp_lwt_unix_test.test_server_s ~port:10193 server_noisy (fun uri -> - let ctx = Cohttp_lwt_unix.Net.default_ctx in - let empty_chunk () = - Client.get ~ctx uri >>= fun (_, body) -> - body |> Body.to_string >|= fun body -> - assert_equal body (String.concat "" chunk_body) - in - let not_modified_has_no_body () = - Client.get ~ctx uri >>= fun (resp, body) -> - assert_equal (Response.status resp) `Not_modified; - let headers = Response.headers resp in - assert_equal ~printer:Transfer.string_of_encoding Transfer.Unknown - (Header.get_transfer_encoding headers); - body |> Body.is_empty >|= fun is_empty -> - assert_bool "No body returned when not modified" is_empty - in - let unreadable_file_500 () = - let fname = "unreadable500" in - Lwt.finalize - (fun () -> - Lwt_io.open_file ~flags:[ Lwt_unix.O_CREAT ] ~perm:0o006 - ~mode:Lwt_io.Output fname - >>= fun oc -> - Lwt_io.write_line oc "never read" >>= fun () -> - Lwt_io.close oc >>= fun () -> - ( Client.post ~ctx uri ~body:(Body.of_string fname) - >>= fun (resp, body) -> - assert_equal ~printer:Code.string_of_status (Response.status resp) - `Internal_server_error; - Body.to_string body ) - >|= fun body -> - assert_equal - ~printer:(fun x -> "'" ^ x ^ "'") - body "Error: Internal Server Error") - (fun () -> Lwt_unix.unlink fname) - in - [ - ("empty chunk test", check_logs empty_chunk); - ( "no body when response is not modified", - check_logs not_modified_has_no_body ); - ("unreadable file returns 500", unreadable_file_500); - ]) - -let _ = ts_noisy |> run_async_tests |> Lwt_main.run diff --git a/cohttp/cohttp-lwt.opam b/cohttp/cohttp-lwt.opam deleted file mode 100644 index bd1bd54dab89221e0c384aa86ef8034df584883b..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-lwt.opam +++ /dev/null @@ -1,42 +0,0 @@ -opam-version: "2.0" -maintainer: "anil@recoil.org" -authors: [ - "Anil Madhavapeddy" - "Stefano Zacchiroli" - "David Sheets" - "Thomas Gazagnaire" - "David Scott" - "Rudi Grinberg" - "Andy Ray" -] -synopsis: "CoHTTP implementation using the Lwt concurrency library" -description: """ -This is a portable implementation of HTTP that uses the Lwt -concurrency library to multiplex IO. It implements as much of the -logic in an OS-independent way as possible, so that more specialised -modules can be tailored for different targets. For example, you -can install `cohttp-lwt-unix` or `cohttp-lwt-jsoo` for a Unix or -JavaScript backend, or `cohttp-mirage` for the MirageOS unikernel -version of the library. All of these implementations share the same -IO logic from this module.""" -license: "ISC" -tags: ["org:mirage" "org:xapi-project"] -homepage: "https://github.com/mirage/ocaml-cohttp" -doc: "https://mirage.github.io/ocaml-cohttp/" -bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" -depends: [ - "ocaml" {>= "4.08"} - "dune" {>= "2.0"} - "cohttp" {= version} - "lwt" {>= "2.5.0"} - "sexplib0" - "ppx_sexp_conv" {>= "v0.13.0"} - "logs" - "uri" {>= "2.0.0"} -] -build: [ - ["dune" "subst"] {dev} - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" diff --git a/cohttp/cohttp-mirage-CHANGES.md b/cohttp/cohttp-mirage-CHANGES.md deleted file mode 100644 index 0e07d1b1f3be23ae9a6baa32d32666f42f13ace6..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage-CHANGES.md +++ /dev/null @@ -1,77 +0,0 @@ -### 3.2.0 - -* Port to jbuilder - -### 3.1.0 - -* Add `Cohttp_mirage_static` module for serving static files from a - read-only key-value store. Includes magic mime detection. -* Improve the ocamldoc strings for the modules. -* Constrain supported OCaml version to 4.03.0+ or higher, as with Mirage 3.0. - -### 3.0.0 - -* Port to MirageOS 3 CHANNEL interface. -* Use Travis Docker for more multidistro testing. - -### 2.5.3 (13-06-2016) - -* Switch to topkg (#25, @samoht) -* Fix memory leak in the callback when an exception is raised (#24, @hannesm) - -### 2.5.2 (13-04-2016) - -* Fix memory leak by closing channel when callback is executed - (#23 via @hannesm) - -### 2.5.1 (15-09-2015) - -* Add a preapplied server with conduit (#20, by @Drup) - -### 2.5.0 (05-07-2015) - -* Depends on `channel` instead of the full `tcpip` stack - -### 2.4.0 (10-06-2015) - -* Support cohttp 0.18 (#13, by @rgrinberg) - -### 2.3.0 (29-05-2015) - -* Simplify the `Client` signature to be a simple module. It is not - a functor depending on `Conduit` anymore and the context is now - more explicit. -* Expose type equalities for `IO.conn` in the `Server` functor -* Adapt to conduit 0.8.4 - -### 2.2.0: (08-04-2015) - -* Do not user `lwt.syntax` -* Rename `HTTP` to `Cohttp_Mirage` (#9) -* Expose `Cohttp_mirage_io` -* Expose a `Server` functor which depends only on mirage's `FLOW` (no dependency - to `Conduit` anymore in this case) -* Modernize Travis CI scripts - -### 2.1.0 (05-12-2014): - -* Use the Conduit 0.7+ resolver API (provide `of_sexp` for context). -* Do not link against `camlp4` in the `META` file and only use it during build. - -### 2.0.0 (07-11-2014): - -* Use the Conduit 0.6+ resolver API. -* Add a local `opam` file for the OPAM 1.2.0 workflow. - -### 1.2.0 (03-05-2014): - -* Use the Cohttp.0.12.0 interface. - -### 1.1.0 (05-02-2014): - -* Functorize the HTTP Mirage layer, so that the library is now - OS-independent and compatible with Mirage 1.1.x signatures. - -### 1.0.0 (18-01-2013): - -* Initial public release. diff --git a/cohttp/cohttp-mirage.opam b/cohttp/cohttp-mirage.opam deleted file mode 100644 index 2e713279c4c6757475c62325ecb9a8cb8bbb9447..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage.opam +++ /dev/null @@ -1,41 +0,0 @@ -opam-version: "2.0" -maintainer: "anil@recoil.org" -authors: ["Anil Madhavapeddy" "Thomas Gazagnaire"] -license: "ISC" -tags: ["org:mirage" "org:xapi-project"] -homepage: "https://github.com/mirage/ocaml-cohttp" -doc: "https://mirage.github.io/ocaml-cohttp/" -bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" -synopsis: "CoHTTP implementation for the MirageOS unikernel" -description: """ -This HTTP implementation uses the Cohttp portable implementaiton -along with the Lwt threading library in order to provide a -`Cohttp_mirage` functor that can be used in MirageOS unikernels -to build very small and efficient HTTP clients and servers -without having a hard dependency on an underlying operating -system. - -Please see for a self-hosted explanation -and instructions on how to use this library.""" -depends: [ - "ocaml" {>= "4.08"} - "dune" {>= "2.0"} - "mirage-flow" {>= "2.0.0"} - "mirage-channel" {>= "4.0.0"} - "conduit" {>= "2.0.2"} - "conduit-mirage" {>= "2.3.0"} - "mirage-kv" {>= "3.0.0"} - "lwt" {>= "2.4.3"} - "cohttp" {= version} - "cohttp-lwt" {= version} - "fmt" {>= "0.8.7"} - "astring" - "magic-mime" - "ppx_sexp_conv" {>= "v0.13.0"} -] -build: [ - ["dune" "subst"] {dev} - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" diff --git a/cohttp/cohttp-mirage/src/client.ml b/cohttp/cohttp-mirage/src/client.ml deleted file mode 100644 index bd65b06b13426f3f0433bac883d6eddb1562af8b..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage/src/client.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* - * Copyright (c) 2012-2015 Anil Madhavapeddy - * Copyright (c) 2013-2015 Thomas Gazagnaire - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - * %%NAME%% %%VERSION%% - *) - -open Lwt.Infix - -module Make - (P : Mirage_clock.PCLOCK) - (R : Resolver_mirage.S) - (S : Conduit_mirage.S) = -struct - module Channel = Mirage_channel.Make (S.Flow) - module HTTP_IO = Io.Make (Channel) - module Endpoint = Conduit_mirage.Endpoint (P) - - module Net_IO = struct - module IO = HTTP_IO - - type ctx = { - resolver : R.t; - conduit : S.t option; - authenticator : X509.Authenticator.t option; - } - - let sexp_of_ctx { resolver; _ } = R.sexp_of_t resolver - - let default_ctx = - { resolver = R.localhost; conduit = None; authenticator = None } - - let connect_uri ~ctx:{ resolver; conduit; authenticator } uri = - R.resolve_uri ~uri resolver >>= fun endp -> - Endpoint.client ?tls_authenticator:authenticator endp >>= fun client -> - match conduit with - | None -> failwith "conduit not initialised" - | Some c -> - S.connect c client >>= fun flow -> - let ch = Channel.create flow in - Lwt.return (flow, ch, ch) - - let close_in _ = () - let close_out _ = () - - let close ic _oc = - Lwt.ignore_result - @@ Lwt.catch - (fun () -> Channel.close ic) - (fun e -> - Logs.warn (fun f -> - f "Closing channel failed: %s" (Printexc.to_string e)); - Lwt.return @@ Ok ()) - end - - let ctx ?authenticator resolver conduit = - { Net_IO.resolver; conduit = Some conduit; authenticator } - - let with_authenticator a ctx = { ctx with Net_IO.authenticator = Some a } - - (* Build all the core modules from the [Cohttp_lwt] functors *) - include Cohttp_lwt.Make_client (HTTP_IO) (Net_IO) -end diff --git a/cohttp/cohttp-mirage/src/client.mli b/cohttp/cohttp-mirage/src/client.mli deleted file mode 100644 index 8e847cd76aeff0b0bffc660f453e75c1eca02ad9..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage/src/client.mli +++ /dev/null @@ -1,9 +0,0 @@ -module Make - (P : Mirage_clock.PCLOCK) - (R : Resolver_mirage.S) - (S : Conduit_mirage.S) : sig - include Cohttp_lwt.S.Client - - val ctx : ?authenticator:X509.Authenticator.t -> R.t -> S.t -> ctx - val with_authenticator : X509.Authenticator.t -> ctx -> ctx -end diff --git a/cohttp/cohttp-mirage/src/cohttp_mirage.ml b/cohttp/cohttp-mirage/src/cohttp_mirage.ml deleted file mode 100644 index 0b565182062674b49e7d135355c010d1c7bad365..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage/src/cohttp_mirage.ml +++ /dev/null @@ -1,4 +0,0 @@ -module Static = Static -module Client = Client -module Server = Server -module IO = Io.Make diff --git a/cohttp/cohttp-mirage/src/dune b/cohttp/cohttp-mirage/src/dune deleted file mode 100644 index cc00817565cd98354340e12569411e42c072ab47..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage/src/dune +++ /dev/null @@ -1,8 +0,0 @@ -(library - (name cohttp_mirage) - (public_name cohttp-mirage) - (synopsis "Mirage backend for cohttp") - (preprocess - (pps ppx_sexp_conv)) - (libraries conduit-mirage cohttp-lwt mirage-channel mirage-kv mirage-flow - magic-mime astring)) diff --git a/cohttp/cohttp-mirage/src/io.ml b/cohttp/cohttp-mirage/src/io.ml deleted file mode 100644 index fe2f9d7668f5d25a93cd132efe3b8b0b03f5ebb1..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage/src/io.ml +++ /dev/null @@ -1,79 +0,0 @@ -(* - * Copyright (c) 2012-2015 Anil Madhavapeddy - * Copyright (c) 2013-2015 Thomas Gazagnaire - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - * %%NAME%% %%VERSION%% - *) - -open Lwt.Infix - -module Make (Channel : Mirage_channel.S) = struct - type error = - | Read_error of Channel.error - | Write_error of Channel.write_error - - let pp_error f = function - | Read_error e -> Channel.pp_error f e - | Write_error e -> Channel.pp_write_error f e - - type 'a t = 'a Lwt.t - type ic = Channel.t - type oc = Channel.t - type conn = Channel.flow - - exception Read_exn of Channel.error - exception Write_exn of Channel.write_error - - let () = - Printexc.register_printer (function - | Read_exn e -> - Some (Format.asprintf "IO read error: %a" Channel.pp_error e) - | Write_exn e -> - Some (Format.asprintf "IO write error: %a" Channel.pp_write_error e) - | _ -> None) - - let read_line ic = - Channel.read_line ic >>= function - | Ok (`Data []) -> Lwt.return_none - | Ok `Eof -> Lwt.return_none - | Ok (`Data bufs) -> Lwt.return_some (Cstruct.copyv bufs) - | Error e -> Lwt.fail (Read_exn e) - - let read ic len = - Channel.read_some ~len ic >>= function - | Ok (`Data buf) -> Lwt.return (Cstruct.to_string buf) - | Ok `Eof -> Lwt.return "" - | Error e -> Lwt.fail (Read_exn e) - - let write oc buf = - Channel.write_string oc buf 0 (String.length buf); - Channel.flush oc >>= function - | Ok () -> Lwt.return_unit - | Error `Closed -> Lwt.fail_with "Trying to write on closed channel" - | Error e -> Lwt.fail (Write_exn e) - - let flush _ = - (* NOOP since we flush in the normal writer functions above *) - Lwt.return_unit - - let ( >>= ) = Lwt.( >>= ) - let return = Lwt.return - - let catch f = - Lwt.try_bind f Lwt.return_ok (function - | Read_exn e -> Lwt.return_error (Read_error e) - | Write_exn e -> Lwt.return_error (Write_error e) - | ex -> Lwt.fail ex) -end diff --git a/cohttp/cohttp-mirage/src/io.mli b/cohttp/cohttp-mirage/src/io.mli deleted file mode 100644 index 23e9792f90fdc0107d8eb79a5acec2599fac6b02..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage/src/io.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* - * Copyright (c) 2012-2015 Anil Madhavapeddy - * Copyright (c) 2013-2015 Thomas Gazagnaire - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - * %%NAME%% %%VERSION%% - *) - -(** Cohttp IO implementation using Mirage channels. *) - -module Make (Channel : Mirage_channel.S) : - Cohttp_lwt.S.IO - with type ic = Channel.t - and type oc = Channel.t - and type conn = Channel.flow diff --git a/cohttp/cohttp-mirage/src/make.ml b/cohttp/cohttp-mirage/src/make.ml deleted file mode 100644 index 0a4d5f20b94024eac6e790c70e86e1336a0f7f68..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage/src/make.ml +++ /dev/null @@ -1,13 +0,0 @@ -open Lwt.Infix - -module Server (Flow : Mirage_flow.S) = struct - module Channel = Mirage_channel.Make (Flow) - module HTTP_IO = Io.Make (Channel) - include Cohttp_lwt.Make_server (HTTP_IO) - - let listen spec flow = - let ch = Channel.create flow in - Lwt.finalize - (fun () -> callback spec flow ch ch) - (fun () -> Channel.close ch >|= fun _ -> ()) -end diff --git a/cohttp/cohttp-mirage/src/make.mli b/cohttp/cohttp-mirage/src/make.mli deleted file mode 100644 index 920bcf6fe95de50f4b6b2bb655fe7dace05af3a2..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage/src/make.mli +++ /dev/null @@ -1,6 +0,0 @@ -(** HTTP server. *) -module Server (Flow : Mirage_flow.S) : sig - include Cohttp_lwt.S.Server with type IO.conn = Flow.flow - - val listen : t -> IO.conn -> unit Lwt.t -end diff --git a/cohttp/cohttp-mirage/src/server.ml b/cohttp/cohttp-mirage/src/server.ml deleted file mode 100644 index 7aeb27eb6d7dd42b1560f553df9edfc816330f67..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage/src/server.ml +++ /dev/null @@ -1,25 +0,0 @@ -open Lwt.Infix - -module type S = sig - include Cohttp_lwt.S.Server - - val callback : t -> IO.conn -> unit Lwt.t -end - -module Flow (F : Mirage_flow.S) = struct - module Channel = Mirage_channel.Make (F) - module HTTP_IO = Io.Make (Channel) - include Cohttp_lwt.Make_server (HTTP_IO) - - let callback spec flow = - let ch = Channel.create flow in - Lwt.finalize - (fun () -> callback spec flow ch ch) - (fun () -> Channel.close ch >|= fun _ -> ()) -end - -module Make (S : Conduit_mirage.S) = struct - include Flow (S.Flow) - - let listen s conf t = S.listen s conf (callback t) -end diff --git a/cohttp/cohttp-mirage/src/server.mli b/cohttp/cohttp-mirage/src/server.mli deleted file mode 100644 index c3cd1af56e280e6e8c05755b224e913384fb047d..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage/src/server.mli +++ /dev/null @@ -1,16 +0,0 @@ -(** HTTP server with conduit. *) - -module type S = sig - include Cohttp_lwt.S.Server - - val callback : t -> IO.conn -> unit Lwt.t -end - -module Flow (F : Mirage_flow.S) : S with type IO.conn = F.flow - -module Make (S : Conduit_mirage.S) : sig - include S with type IO.conn = S.flow - - val callback : t -> S.flow -> unit Lwt.t - val listen : S.t -> Conduit_mirage.server -> t -> unit Lwt.t -end diff --git a/cohttp/cohttp-mirage/src/static.ml b/cohttp/cohttp-mirage/src/static.ml deleted file mode 100644 index 6ca5b56fd7db593ab704e6eb5ab3324781382ad6..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage/src/static.ml +++ /dev/null @@ -1,82 +0,0 @@ -(* - * Copyright (c) 2012-2017 Anil Madhavapeddy - * Copyright (c) 2013-2015 Thomas Gazagnaire - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - * %%NAME%% %%VERSION%% - *) - -module Key = Mirage_kv.Key - -module HTTP (FS : Mirage_kv.RO) (S : Cohttp_lwt.S.Server) = struct - open Lwt.Infix - open Astring - - let failf fmt = Fmt.kstr Lwt.fail_with fmt - - let read_fs t name = - FS.get t (Key.v name) >>= function - | Error e -> failf "read %a" FS.pp_error e - | Ok buf -> Lwt.return buf - - let exists t name = - FS.exists t (Key.v name) >|= function - | Ok (Some `Value) -> true - | Ok (Some _ | None) -> false - | Error e -> Fmt.failwith "exists %a" FS.pp_error e - - let dispatcher request_fn = - let rec fn fs uri = - match Uri.path uri with - | ("" | "/") as path -> - Logs.info (fun f -> f "request for '%s'" path); - fn fs (Uri.with_path uri "index.html") - | path when String.is_suffix ~affix:"/" path -> - Logs.info (fun f -> f "request for '%s'" path); - fn fs (Uri.with_path uri "index.html") - | path -> - Logs.info (fun f -> f "request for '%s'" path); - Lwt.catch - (fun () -> - read_fs fs path >>= fun body -> - let mime_type = Magic_mime.lookup path in - let headers = Cohttp.Header.init_with "content-type" mime_type in - let headers = - match request_fn with - | None -> headers - | Some fn -> fn uri headers - in - S.respond_string ~status:`OK ~body ~headers ()) - (fun _exn -> - let with_index = Fmt.str "%s/index.html" path in - exists fs with_index >>= function - | true -> fn fs (Uri.with_path uri with_index) - | false -> S.respond_not_found ()) - in - fn - - let start ~http_port ?request_fn fs http = - let callback (_, cid) request _body = - let uri = Cohttp.Request.uri request in - let cid = Cohttp.Connection.to_string cid in - Logs.info (fun f -> f "[%s] serving %s" cid (Uri.to_string uri)); - dispatcher request_fn fs uri - in - let conn_closed (_, cid) = - let cid = Cohttp.Connection.to_string cid in - Logs.info (fun f -> f "[%s] closing" cid) - in - Logs.info (fun f -> f "listening on %d/TCP" http_port); - http (`TCP http_port) (S.make ~conn_closed ~callback ()) -end diff --git a/cohttp/cohttp-mirage/src/static.mli b/cohttp/cohttp-mirage/src/static.mli deleted file mode 100644 index 8f73c992c373bbfaab2e270f4b89fd3c25b3c55c..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-mirage/src/static.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* - * Copyright (c) 2012-2017 Anil Madhavapeddy - * Copyright (c) 2013-2015 Thomas Gazagnaire - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - * %%NAME%% %%VERSION%% - *) - -(** Serve static HTTP sites from a Mirage key-value store. *) - -(** Plain HTTP file serving from a read-only key-value store. *) -module HTTP (FS : Mirage_kv.RO) (S : Cohttp_lwt.S.Server) : sig - (** [start http_port ?request_fn fs http] will start a static HTTP server - listening on [http_port]. The files to serve will be looked up from the - [fs] key-value store. - - If [request_fn] is supplied, the URI and default header set (including the - MIME content-type header) will be passed to it and the response used as - the response header set instead. *) - - val start : - http_port:int -> - ?request_fn:(Uri.t -> Cohttp.Header.t -> Cohttp.Header.t) -> - FS.t -> - ([> `TCP of int ] -> S.t -> 'a) -> - 'a -end diff --git a/cohttp/cohttp-top.opam b/cohttp/cohttp-top.opam deleted file mode 100644 index 9b21332b863b388e8f8a1cf90f50deb537e2bd3f..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-top.opam +++ /dev/null @@ -1,33 +0,0 @@ -opam-version: "2.0" -maintainer: "anil@recoil.org" -authors: [ - "Anil Madhavapeddy" - "Stefano Zacchiroli" - "David Sheets" - "Thomas Gazagnaire" - "David Scott" - "Rudi Grinberg" - "Andy Ray" -] -synopsis: "CoHTTP toplevel pretty printers for HTTP types" -description: """ -This library installs toplevel prettyprinters for CoHTTP -types such as the `Request`, `Response` and `Types` modules. -Once this library has been loaded, you can directly see the -values of those types in toplevels such as `utop` or `ocaml`.""" -license: "ISC" -tags: ["org:mirage" "org:xapi-project"] -homepage: "https://github.com/mirage/ocaml-cohttp" -doc: "https://mirage.github.io/ocaml-cohttp/" -bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" -depends: [ - "ocaml" {>= "4.08"} - "dune" {>= "2.0"} - "cohttp" {= version} -] -build: [ - ["dune" "subst"] {dev} - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" diff --git a/cohttp/cohttp-top/src/cohttp_top.ml b/cohttp/cohttp-top/src/cohttp_top.ml deleted file mode 100644 index 461b67515f3f1030e0d3a63209b24cc2b397f210..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-top/src/cohttp_top.ml +++ /dev/null @@ -1,18 +0,0 @@ -let printers = - [ "Cohttp.Header.pp_hum"; "Cohttp.Request.pp_hum"; "Cohttp.Response.pp_hum" ] - -let eval_string ?(print_outcome = false) ?(err_formatter = Format.err_formatter) - str = - let lexbuf = Lexing.from_string str in - let phrase = !Toploop.parse_toplevel_phrase lexbuf in - Toploop.execute_phrase print_outcome err_formatter phrase - -let rec install_printers = function - | [] -> true - | printer :: printers -> - let cmd = Printf.sprintf "#install_printer %s;;" printer in - eval_string cmd && install_printers printers - -let () = - if not (install_printers printers) then - Format.eprintf "Problem installing Cohttp-printers@." diff --git a/cohttp/cohttp-top/src/dune b/cohttp/cohttp-top/src/dune deleted file mode 100644 index e81b71ccb9fcc7cd62b76d8788f2399d9d9115cb..0000000000000000000000000000000000000000 --- a/cohttp/cohttp-top/src/dune +++ /dev/null @@ -1,4 +0,0 @@ -(library - (name cohttp_top) - (public_name cohttp-top) - (libraries cohttp compiler-libs.toplevel)) diff --git a/cohttp/cohttp.opam b/cohttp/cohttp.opam deleted file mode 100644 index 9e6a95ac607dc1ccd4289567f002410d179da046..0000000000000000000000000000000000000000 --- a/cohttp/cohttp.opam +++ /dev/null @@ -1,54 +0,0 @@ -opam-version: "2.0" -maintainer: "anil@recoil.org" -authors: [ - "Anil Madhavapeddy" - "Stefano Zacchiroli" - "David Sheets" - "Thomas Gazagnaire" - "David Scott" - "Rudi Grinberg" - "Andy Ray" -] -synopsis: "An OCaml library for HTTP clients and servers" -description: """ -Cohttp is an OCaml library for creating HTTP daemons. It has a portable -HTTP parser, and implementations using various asynchronous programming -libraries. - -See the cohttp-async, cohttp-lwt, cohttp-lwt-unix, cohttp-lwt-jsoo and -cohttp-mirage libraries for concrete implementations for particular -targets. - -You can implement other targets using the parser very easily. Look at the `IO` -signature in `lib/s.mli` and implement that in the desired backend. - -You can activate some runtime debugging by setting `COHTTP_DEBUG` to any -value, and all requests and responses will be written to stderr. Further -debugging of the connection layer can be obtained by setting `CONDUIT_DEBUG` -to any value.""" -license: "ISC" -tags: ["org:mirage" "org:xapi-project"] -homepage: "https://github.com/mirage/ocaml-cohttp" -doc: "https://mirage.github.io/ocaml-cohttp/" -bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" -depends: [ - "ocaml" {>= "4.08"} - "dune" {>= "2.0"} - "re" {>= "1.9.0"} - "uri" {>= "2.0.0"} - "uri-sexp" - "sexplib0" - "ppx_sexp_conv" {>= "v0.13.0"} - "stringext" - "base64" {>= "3.1.0"} - "fmt" {with-test} - "jsonm" {build} - "alcotest" {with-test} - "crowbar" {with-test & >= "0.2"} -] -build: [ - ["dune" "subst"] {dev} - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" diff --git a/cohttp/cohttp/fuzz/dune b/cohttp/cohttp/fuzz/dune deleted file mode 100644 index 88906b3c736069bf443e02d70520f392bd12f437..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/fuzz/dune +++ /dev/null @@ -1,26 +0,0 @@ -(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}))) diff --git a/cohttp/cohttp/fuzz/fuzz_header.ml b/cohttp/cohttp/fuzz/fuzz_header.ml deleted file mode 100644 index 3602e99380a4e852432c58bd619d9e52584f2154..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/fuzz/fuzz_header.ml +++ /dev/null @@ -1,567 +0,0 @@ -(*{{{ Copyright (c) 2021 Carine Morel - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *}}}*) - -module H = 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 (); - () diff --git a/cohttp/cohttp/fuzz/inputs/input b/cohttp/cohttp/fuzz/inputs/input deleted file mode 100644 index a459bc245bdbc45e1bca99e7fe61731da5c48da4..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/fuzz/inputs/input +++ /dev/null @@ -1 +0,0 @@ -something \ No newline at end of file diff --git a/cohttp/cohttp/scripts/codes/1.json b/cohttp/cohttp/scripts/codes/1.json deleted file mode 100644 index 1cad150a009ccbdfa11a2092234212ebe51b82a3..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/scripts/codes/1.json +++ /dev/null @@ -1,89 +0,0 @@ -{ - "class":{ - "title":"Informational", - "class":"1" - }, - "codes":{ - "100":{ - "code":"100", - "title":"Continue", - "summary":"Client should continue with request", - "descriptions":{ - "wikipedia":{ - "body":"This means that the server has received the request headers, and that the client should proceed to send the request body (in the case of a request for which a body needs to be sent; for example, a POST request). If the request body is large, sending it to a server when a request has already been rejected based upon inappropriate headers is inefficient. To have a server check if the request could be accepted based on the request's headers alone, a client must send Expect: 100-continue as a header in its initial request and check if a 100 Continue status code is received in response before continuing (or receive 417 Expectation Failed and not continue).", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#100" - }, - "ietf":{ - "body":"The client SHOULD continue with its request. This interim response is used to inform the client that the initial part of the request has been received and has not yet been rejected by the server. The client SHOULD continue by sending the remainder of the request or, if the request has already been completed, ignore this response. The server MUST send a final response after the request has been completed.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":continue" - } - } - }, - "101":{ - "code":"101", - "title":"Switching Protocols", - "summary":"Server is switching protocols", - "descriptions":{ - "wikipedia":{ - "body":"This means the requester has asked the server to switch protocols and the server is acknowledging that it will do so.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#101" - }, - "ietf":{ - "body":"The server understands and is willing to comply with the client's request, via the Upgrade message header field, for a change in the application protocol being used on this connection. The server will switch protocols to those defined by the response's Upgrade header field immediately after the empty line which terminates the 101 response. \r\nThe protocol SHOULD be switched only when it is advantageous to do so. For example, switching to a newer version of HTTP is advantageous over older versions, and switching to a real-time, synchronous protocol might be advantageous when delivering resources that use such features.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":switching_protocols" - } - } - }, - "102":{ - "code":"102", - "title":"Processing (WebDAV) (RFC 2518)", - "summary":"Server has received and is processing the request", - "descriptions":{ - "wikipedia":{ - "body":"As a WebDAV request may contain many sub-requests involving file operations, it may take a long time to complete the request. This code indicates that the server has received and is processing the request, but no response is available yet. This prevents the client from timing out and assuming the request was lost.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#102" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":processing" - } - } - }, - "103":{ - "code":"103", - "title":"Checkpoint", - "summary":"resume aborted PUT or POST requests", - "descriptions":{ - "wikipedia":{ - "body":"This code is used in the Resumable HTTP Requests Proposal to resume aborted PUT or POST requests.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#103" - } - } - }, - "122":{ - "code":"122", - "title":"Request-URI too long", - "summary":"URI is longer than a maximum of 2083 characters", - "descriptions":{ - "wikipedia":{ - "body":"This is a non-standard IE7-only code which means the URI is longer than a maximum of 2083 characters.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#122" - } - } - } - } -} \ No newline at end of file diff --git a/cohttp/cohttp/scripts/codes/2.json b/cohttp/cohttp/scripts/codes/2.json deleted file mode 100644 index 59ba4a1e0d424be595a30ab6aa6be0496dd41e61..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/scripts/codes/2.json +++ /dev/null @@ -1,200 +0,0 @@ -{ - "class":{ - "title":"Success", - "class":"2" - }, - "codes":{ - "200":{ - "code":"200", - "title":"OK", - "summary":"standard response for successful HTTP requests", - "descriptions":{ - "wikipedia":{ - "body":"Standard response for successful HTTP requests. The actual response will depend on the request method used. In a GET request, the response will contain an entity corresponding to the requested resource. In a POST request the response will contain an entity describing or containing the result of the action.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#200" - }, - "ietf":{ - "body":"The request has succeeded. The information returned with the response is dependent on the method used in the request, for example: GET an entity corresponding to the requested resource is sent in the response; HEAD the entity-header fields corresponding to the requested resource are sent in the response without any message-body; POST an entity describing or containing the result of the action;", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":ok" - } - } - }, - "201":{ - "code":"201", - "title":"Created", - "summary":"request has been fulfilled; new resource created", - "descriptions":{ - "wikipedia":{ - "body":"The request has been fulfilled and resulted in a new resource being created.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#201" - }, - "ietf":{ - "body":"The request has been fulfilled and resulted in a new resource being created. The newly created resource can be referenced by the URI(s) returned in the entity of the response, with the most specific URI for the resource given by a Location header field. The response SHOULD include an entity containing a list of resource characteristics and location(s) from which the user or user agent can choose the one most appropriate. The entity format is specified by the media type given in the Content-Type header field. The origin server MUST create the resource before returning the 201 status code. If the action cannot be carried out immediately, the server SHOULD respond with 202 (Accepted) response instead.\r\n A 201 response MAY contain an ETag response header field indicating the current value of the entity tag for the requested variant just created.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":created" - } - } - }, - "202":{ - "code":"202", - "title":"Accepted", - "summary":"request accepted, processing pending", - "descriptions":{ - "wikipedia":{ - "body":"The request has been accepted for processing, but the processing has not been completed. The request might or might not eventually be acted upon, as it might be disallowed when processing actually takes place.[2]", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#202" - }, - "ietf":{ - "body":"The request has been accepted for processing, but the processing has not been completed. The request might or might not eventually be acted upon, as it might be disallowed when processing actually takes place. There is no facility for re-sending a status code from an asynchronous operation such as this. \r\nThe 202 response is intentionally non-committal. Its purpose is to allow a server to accept a request for some other process (perhaps a batch-oriented process that is only run once per day) without requiring that the user agent's connection to the server persist until the process is completed. The entity returned with this response SHOULD include an indication of the request's current status and either a pointer to a status monitor or some estimate of when the user can expect the request to be fulfilled.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":accepted" - } - } - }, - "203":{ - "code":"203", - "title":"Non-Authoritative Information (since HTTP\/1.1)", - "summary":"request processed, information may be from another source", - "descriptions":{ - "wikipedia":{ - "body":"The server successfully processed the request, but is returning information that may be from another source.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#203" - }, - "ietf":{ - "body":"The returned metainformation in the entity-header is not the definitive set as available from the origin server, but is gathered from a local or a third-party copy. The set presented MAY be a subset or superset of the original version. For example, including local annotation information about the resource might result in a superset of the metainformation known by the origin server. Use of this response code is not required and is only appropriate when the response would otherwise be 200 (OK).", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":non_authoritative_information" - } - } - }, - "204":{ - "code":"204", - "title":"No Content", - "summary":"request processed, no content returned", - "descriptions":{ - "wikipedia":{ - "body":"The server successfully processed the request, but is not returning any content.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#204" - }, - "ietf":{ - "body":"The server has fulfilled the request but does not need to return an entity-body, and might want to return updated metainformation. The response MAY include new or updated metainformation in the form of entity-headers, which if present SHOULD be associated with the requested variant.\r\nIf the client is a user agent, it SHOULD NOT change its document view from that which caused the request to be sent. This response is primarily intended to allow input for actions to take place without causing a change to the user agent's active document view, although any new or updated metainformation SHOULD be applied to the document currently in the user agent's active view.\r\nThe 204 response MUST NOT include a message-body, and thus is always terminated by the first empty line after the header fields.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":no_content" - } - } - }, - "205":{ - "code":"205", - "title":"Reset Content", - "summary":"request processed, no content returned, reset document view", - "descriptions":{ - "wikipedia":{ - "body":"The server successfully processed the request, but is not returning any content. Unlike a 204 response, this response requires that the requester reset the document view.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#205" - }, - "ietf":{ - "body":"The server has fulfilled the request and the user agent SHOULD reset the document view which caused the request to be sent. This response is primarily intended to allow input for actions to take place via user input, followed by a clearing of the form in which the input is given so that the user can easily initiate another input action. The response MUST NOT include an entity.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":reset_content" - } - } - }, - "206":{ - "code":"206", - "title":"Partial Content", - "summary":"partial resource return due to request header", - "descriptions":{ - "wikipedia":{ - "body":"The server is delivering only part of the resource due to a range header sent by the client. The range header is used by tools like wget to enable resuming of interrupted downloads, or split a download into multiple simultaneous streams.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#206" - }, - "ietf":{ - "body":"The server has fulfilled the partial GET request for the resource. The request MUST have included a Range header field indicating the desired range, and MAY have included an If-Range header field to make the request conditional.\r\nThe response MUST include the following header fields:\r\nEither a Content-Range header field (section 14.16) indicating the range included with this response, or a multipart\/byteranges Content-Type including Content-Range fields for each part. If a Content-Length header field is present in the response, its value MUST match the actual number of OCTETs transmitted in the message-body.\r\nDate\r\nETag and\/or Content-Location, if the header would have been sent in a 200 response to the same request\r\nExpires, Cache-Control, and\/or Vary, if the field-value might differ from that sent in any previous response for the same variant\r\nIf the 206 response is the result of an If-Range request that used a strong cache validator, the response SHOULD NOT include other entity-headers. If the response is the result of an If-Range request that used a weak validator, the response MUST NOT include other entity-headers; this prevents inconsistencies between cached entity-bodies and updated headers. Otherwise, the response MUST include all of the entity-headers that would have been returned with a 200 (OK) response to the same request.\r\nA cache MUST NOT combine a 206 response with other previously cached content if the ETag or Last-Modified headers do not match exactly.\r\nA cache that does not support the Range and Content-Range headers MUST NOT cache 206 (Partial) responses.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":partial_content" - } - } - }, - "207":{ - "code":"207", - "title":"Multi-Status (WebDAV) (RFC 4918)", - "summary":"XML, can contain multiple separate responses", - "descriptions":{ - "wikipedia":{ - "body":"The message body that follows is an XML message and can contain a number of separate response codes, depending on how many sub-requests were made.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#207" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":multi_status" - } - } - }, - "208":{ - "code":"208", - "title":"Already Reported (WebDAV) (RFC 5842)", - "summary":"results previously returned ", - "descriptions":{ - "wikipedia":{ - "body":"The members of a DAV binding have already been enumerated in a previous reply to this request, and are not being included again.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#208" - } - } - }, - "226":{ - "code":"226", - "title":"IM Used (RFC 3229)", - "summary":"request fulfilled, reponse is instance-manipulations", - "descriptions":{ - "wikipedia":{ - "body":"The server has fulfilled a GET request for the resource, and the response is a representation of the result of one or more instance-manipulations applied to the current instance.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#226" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":im_used" - } - } - } - } -} diff --git a/cohttp/cohttp/scripts/codes/3.json b/cohttp/cohttp/scripts/codes/3.json deleted file mode 100644 index e30df30c7ef39b4e1f5e3315114846ee33155b1f..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/scripts/codes/3.json +++ /dev/null @@ -1,187 +0,0 @@ -{ - "class":{ - "title":"Redirection", - "class":"3" - }, - "codes":{ - "300":{ - "code":"300", - "title":"Multiple Choices", - "summary":"multiple options for the resource delivered", - "descriptions":{ - "wikipedia":{ - "body":"Indicates multiple options for the resource that the client may follow. It, for instance, could be used to present different format options for video, list files with different extensions, or word sense disambiguation.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#300" - }, - "ietf":{ - "body":"The requested resource corresponds to any one of a set of representations, each with its own specific location, and agent- driven negotiation information is being provided so that the user (or user agent) can select a preferred representation and redirect its request to that location.\r\nUnless it was a HEAD request, the response SHOULD include an entity containing a list of resource characteristics and location(s) from which the user or user agent can choose the one most appropriate. The entity format is specified by the media type given in the Content- Type header field. Depending upon the format and the capabilities of the user agent, selection of the most appropriate choice MAY be performed automatically. However, this specification does not define any standard for such automatic selection.\r\nIf the server has a preferred choice of representation, it SHOULD include the specific URI for that representation in the Location field; user agents MAY use the Location field value for automatic redirection. This response is cacheable unless indicated otherwise.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":multiple_choices" - } - } - }, - "301":{ - "code":"301", - "title":"Moved Permanently", - "summary":"this and all future requests directed to the given URI", - "descriptions":{ - "wikipedia":{ - "body":"This and all future requests should be directed to the given URI.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#301" - }, - "ietf":{ - "body":"The requested resource has been assigned a new permanent URI and any future references to this resource SHOULD use one of the returned URIs. Clients with link editing capabilities ought to automatically re-link references to the Request-URI to one or more of the new references returned by the server, where possible. This response is cacheable unless indicated otherwise.\r\nThe new permanent URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).\r\nIf the 301 status code is received in response to a request other than GET or HEAD, the user agent MUST NOT automatically redirect the request unless it can be confirmed by the user, since this might change the conditions under which the request was issued.\r\nNote: When automatically redirecting a POST request after receiving a 301 status code, some existing HTTP\/1.0 user agents will erroneously change it into a GET request.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":moved_permanently" - } - } - }, - "302":{ - "code":"302", - "title":"Found", - "summary":"temporary response to request found via alternative URI", - "descriptions":{ - "wikipedia":{ - "body":"This is an example of industrial practice contradicting the standard. HTTP\/1.0 specification (RFC 1945) required the client to perform a temporary redirect (the original describing phrase was \"Moved Temporarily\"), but popular browsers implemented 302 with the functionality of a 303 See Other. Therefore, HTTP\/1.1 added status codes 303 and 307 to distinguish between the two behaviours. However, some Web applications and frameworks use the 302 status code as if it were the 303.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#302" - }, - "ietf":{ - "body":"The requested resource resides temporarily under a different URI. Since the redirection might be altered on occasion, the client SHOULD continue to use the Request-URI for future requests. This response is only cacheable if indicated by a Cache-Control or Expires header field.\r\nThe temporary URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).\r\nIf the 302 status code is received in response to a request other than GET or HEAD, the user agent MUST NOT automatically redirect the request unless it can be confirmed by the user, since this might change the conditions under which the request was issued.\r\nNote: RFC 1945 and RFC 2068 specify that the client is not allowed to change the method on the redirected request. However, most existing user agent implementations treat 302 as if it were a 303 response, performing a GET on the Location field-value regardless of the original request method. The status codes 303 and 307 have been added for servers that wish to make unambiguously clear which kind of reaction is expected of the client.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":found" - } - } - }, - "303":{ - "code":"303", - "title":"See Other", - "summary":"permanent response to request found via alternative URI", - "descriptions":{ - "wikipedia":{ - "body":"The response to the request can be found under another URI using a GET method. When received in response to a POST (or PUT\/DELETE), it should be assumed that the server has received the data and the redirect should be issued with a separate GET message.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#303" - }, - "ietf":{ - "body":"The response to the request can be found under a different URI and SHOULD be retrieved using a GET method on that resource. This method exists primarily to allow the output of a POST-activated script to redirect the user agent to a selected resource. The new URI is not a substitute reference for the originally requested resource. The 303 response MUST NOT be cached, but the response to the second (redirected) request might be cacheable.\r\nThe different URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).\r\nNote: Many pre-HTTP\/1.1 user agents do not understand the 303 status. When interoperability with such clients is a concern, the 302 status code may be used instead, since most user agents react to a 302 response as described here for 303.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":see_other" - } - } - }, - "304":{ - "code":"304", - "title":"Not Modified", - "summary":"resource has not been modified since last requested", - "descriptions":{ - "wikipedia":{ - "body":"Indicates the resource has not been modified since last requested. Typically, the HTTP client provides a header like the If-Modified-Since header to provide a time against which to compare. Using this saves bandwidth and reprocessing on both the server and client, as only the header data must be sent and received in comparison to the entirety of the page being re-processed by the server, then sent again using more bandwidth of the server and client.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#304" - }, - "ietf":{ - "body":"If the client has performed a conditional GET request and access is allowed, but the document has not been modified, the server SHOULD respond with this status code. The 304 response MUST NOT contain a message-body, and thus is always terminated by the first empty line after the header fields.\r\nThe response MUST include the following header fields:\r\nDate, unless its omission is required\r\nIf a clockless origin server obeys these rules, and proxies and clients add their own Date to any response received without one (as already specified by RFC 2068), caches will operate correctly.\r\nETag and\/or Content-Location, if the header would have been sent in a 200 response to the same request\r\nExpires, Cache-Control, and\/or Vary, if the field-value might differ from that sent in any previous response for the same variant\r\nIf the conditional GET used a strong cache validator, the response SHOULD NOT include other entity-headers. Otherwise (i.e., the conditional GET used a weak validator), the response MUST NOT include other entity-headers; this prevents inconsistencies between cached entity-bodies and updated headers.\r\nIf a 304 response indicates an entity not currently cached, then the cache MUST disregard the response and repeat the request without the conditional.\r\nIf a cache uses a received 304 response to update a cache entry, the cache MUST update the entry to reflect any new field values given in the response.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":not_modified" - } - } - }, - "305":{ - "code":"305", - "title":"Use Proxy (since HTTP\/1.1)", - "summary":"content located elsewhere, retrieve from there", - "descriptions":{ - "wikipedia":{ - "body":"Many HTTP clients (such as Mozilla and Internet Explorer) do not correctly handle responses with this status code, primarily for security reasons.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#305" - }, - "ietf":{ - "body":"The requested resource MUST be accessed through the proxy given by the Location field. The Location field gives the URI of the proxy. The recipient is expected to repeat this single request via the proxy. 305 responses MUST only be generated by origin servers.\r\nNote: RFC 2068 was not clear that 305 was intended to redirect a single request, and to be generated by origin servers only. Not observing these limitations has significant security consequences.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":use_proxy" - } - } - }, - "306":{ - "code":"306", - "title":"Switch Proxy", - "summary":"subsequent requests should use the specified proxy", - "descriptions":{ - "wikipedia":{ - "body":"No longer used. Originally meant \"Subsequent requests should use the specified proxy.\"", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#306" - }, - "ietf":{ - "body":"The 306 status code was used in a previous version of the specification, is no longer used, and the code is reserved.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - } - }, - "307":{ - "code":"307", - "title":"Temporary Redirect (since HTTP\/1.1)", - "summary":"connect again to different URI as provided", - "descriptions":{ - "wikipedia":{ - "body":"In this occasion, the request should be repeated with another URI, but future requests can still use the original URI. In contrast to 303, the request method should not be changed when reissuing the original request. For instance, a POST request must be repeated using another POST request.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#307" - }, - "ietf":{ - "body":"The requested resource resides temporarily under a different URI. Since the redirection MAY be altered on occasion, the client SHOULD continue to use the Request-URI for future requests. This response is only cacheable if indicated by a Cache-Control or Expires header field.\r\nThe temporary URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s) , since many pre-HTTP\/1.1 user agents do not understand the 307 status. Therefore, the note SHOULD contain the information necessary for a user to repeat the original request on the new URI.\r\nIf the 307 status code is received in response to a request other than GET or HEAD, the user agent MUST NOT automatically redirect the request unless it can be confirmed by the user, since this might change the conditions under which the request was issued.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":temporary_redirect" - } - } - }, - "308":{ - "code":"308", - "title":"Permanent Redirect", - "summary":"connect again to a different URI using the same method", - "descriptions":{ - "wikipedia":{ - "body":"The request, and all future requests should be repeated using another URI. 307 and 308 (as proposed) parallel the behaviours of 302 and 301, but do not allow the HTTP method to change. So, for example, submitting a form to a permanently redirected resource may continue smoothly.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#308" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":no_content" - } - } - } - } -} diff --git a/cohttp/cohttp/scripts/codes/4.json b/cohttp/cohttp/scripts/codes/4.json deleted file mode 100644 index 2ffdd961813524ee85005c5ac8621b8dad2b7031..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/scripts/codes/4.json +++ /dev/null @@ -1,570 +0,0 @@ -{ - "class":{ - "title":"Client Error", - "class":"4" - }, - "codes":{ - "400":{ - "code":"400", - "title":"Bad Request", - "summary":"request cannot be fulfilled due to bad syntax", - "descriptions":{ - "wikipedia":{ - "body":"The request cannot be fulfilled due to bad syntax.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#400" - }, - "ietf":{ - "body":"The request could not be understood by the server due to malformed syntax. The client SHOULD NOT repeat the request without modifications.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":bad_request" - } - } - }, - "401":{ - "code":"401", - "title":"Unauthorized", - "summary":"authentication is possible but has failed ", - "descriptions":{ - "wikipedia":{ - "body":"Similar to 403 Forbidden, but specifically for use when authentication is possible but has failed or not yet been provided. The response must include a WWW-Authenticate header field containing a challenge applicable to the requested resource. See Basic access authentication and Digest access authentication.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#401" - }, - "ietf":{ - "body":"The request requires user authentication. The response MUST include a WWW-Authenticate header field containing a challenge applicable to the requested resource. The client MAY repeat the request with a suitable Authorization header field. If the request already included Authorization credentials, then the 401 response indicates that authorization has been refused for those credentials. If the 401 response contains the same challenge as the prior response, and the user agent has already attempted authentication at least once, then the user SHOULD be presented the entity that was given in the response, since that entity might include relevant diagnostic information. HTTP access authentication is explained in \"HTTP Authentication: Basic and Digest Access Authentication\".", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":unauthorized" - } - } - }, - "402":{ - "code":"402", - "title":"Payment Required", - "summary":"payment required, reserved for future use", - "descriptions":{ - "wikipedia":{ - "body":"Reserved for future use. The original intention was that this code might be used as part of some form of digital cash or micropayment scheme, but that has not happened, and this code is not usually used. As an example of its use, however, Apple's MobileMe service generates a 402 error (\"httpStatusCode:402\" in the Mac OS X Console log) if the MobileMe account is delinquent.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#402" - }, - "ietf":{ - "body":"This code is reserved for future use.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":payment_required" - } - } - }, - "403":{ - "code":"403", - "title":"Forbidden", - "summary":"server refuses to respond to request", - "descriptions":{ - "wikipedia":{ - "body":"The request was a legal request, but the server is refusing to respond to it. Unlike a 401 Unauthorized response, authenticating will make no difference.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#403" - }, - "ietf":{ - "body":"The server understood the request, but is refusing to fulfill it. Authorization will not help and the request SHOULD NOT be repeated. If the request method was not HEAD and the server wishes to make public why the request has not been fulfilled, it SHOULD describe the reason for the refusal in the entity. If the server does not wish to make this information available to the client, the status code 404 (Not Found) can be used instead.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":forbidden" - } - } - }, - "404":{ - "code":"404", - "title":"Not Found", - "summary":"requested resource could not be found", - "descriptions":{ - "wikipedia":{ - "body":"The requested resource could not be found but may be available again in the future. Subsequent requests by the client are permissible.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#404" - }, - "ietf":{ - "body":"The server has not found anything matching the Request-URI. No indication is given of whether the condition is temporary or permanent. The 410 (Gone) status code SHOULD be used if the server knows, through some internally configurable mechanism, that an old resource is permanently unavailable and has no forwarding address. This status code is commonly used when the server does not wish to reveal exactly why the request has been refused, or when no other response is applicable.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":not_found" - } - } - }, - "405":{ - "code":"405", - "title":"Method Not Allowed", - "summary":"request method not supported by that resource", - "descriptions":{ - "wikipedia":{ - "body":"A request was made of a resource using a request method not supported by that resource; for example, using GET on a form which requires data to be presented via POST, or using PUT on a read-only resource.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#405" - }, - "ietf":{ - "body":"The method specified in the Request-Line is not allowed for the resource identified by the Request-URI. The response MUST include an Allow header containing a list of valid methods for the requested resource.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":method_not_allowed" - } - } - }, - "406":{ - "code":"406", - "title":"Not Acceptable", - "summary":"content not acceptable according to the Accept headers", - "descriptions":{ - "wikipedia":{ - "body":"The requested resource is only capable of generating content not acceptable according to the Accept headers sent in the request.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#406" - }, - "ietf":{ - "body":"The resource identified by the request is only capable of generating response entities which have content characteristics not acceptable according to the accept headers sent in the request.\r\nUnless it was a HEAD request, the response SHOULD include an entity containing a list of available entity characteristics and location(s) from which the user or user agent can choose the one most appropriate. The entity format is specified by the media type given in the Content-Type header field. Depending upon the format and the capabilities of the user agent, selection of the most appropriate choice MAY be performed automatically. However, this specification does not define any standard for such automatic selection.\r\nNote: HTTP\/1.1 servers are allowed to return responses which are not acceptable according to the accept headers sent in the request. In some cases, this may even be preferable to sending a 406 response. User agents are encouraged to inspect the headers of an incoming response to determine if it is acceptable.\r\nIf the response could be unacceptable, a user agent SHOULD temporarily stop receipt of more data and query the user for a decision on further actions.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":not_acceptable" - } - } - }, - "407":{ - "code":"407", - "title":"Proxy Authentication Required", - "summary":"client must first authenticate itself with the proxy", - "descriptions":{ - "wikipedia":{ - "body":"The client must first authenticate itself with the proxy.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#407" - }, - "ietf":{ - "body":"This code is similar to 401 (Unauthorized), but indicates that the client must first authenticate itself with the proxy. The proxy MUST return a Proxy-Authenticate header field containing a challenge applicable to the proxy for the requested resource. The client MAY repeat the request with a suitable Proxy-Authorization header field. HTTP access authentication is explained in \"HTTP Authentication: Basic and Digest Access Authentication\".", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":proxy_authentication_required" - } - } - }, - "408":{ - "code":"408", - "title":"Request Timeout", - "summary":"server timed out waiting for the request", - "descriptions":{ - "wikipedia":{ - "body":"The server timed out waiting for the request. According to W3 HTTP specifications: \"The client did not produce a request within the time that the server was prepared to wait. The client MAY repeat the request without modifications at any later time.\"", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#408" - }, - "ietf":{ - "body":"The client did not produce a request within the time that the server was prepared to wait. The client MAY repeat the request without modifications at any later time.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":request_timeout" - } - } - }, - "409":{ - "code":"409", - "title":"Conflict", - "summary":"request could not be processed because of conflict", - "descriptions":{ - "wikipedia":{ - "body":"Indicates that the request could not be processed because of conflict in the request, such as an edit conflict.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#409" - }, - "ietf":{ - "body":"The request could not be completed due to a conflict with the current state of the resource. This code is only allowed in situations where it is expected that the user might be able to resolve the conflict and resubmit the request. The response body SHOULD include enough information for the user to recognize the source of the conflict. Ideally, the response entity would include enough information for the user or user agent to fix the problem; however, that might not be possible and is not required.\r\nConflicts are most likely to occur in response to a PUT request. For example, if versioning were being used and the entity being PUT included changes to a resource which conflict with those made by an earlier (third-party) request, the server might use the 409 response to indicate that it can't complete the request. In this case, the response entity would likely contain a list of the differences between the two versions in a format defined by the response Content-Type.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":conflict" - } - } - }, - "410":{ - "code":"410", - "title":"Gone", - "summary":"resource is no longer available and will not be available again", - "descriptions":{ - "wikipedia":{ - "body":"Indicates that the resource requested is no longer available and will not be available again. This should be used when a resource has been intentionally removed and the resource should be purged. Upon receiving a 410 status code, the client should not request the resource again in the future. Clients such as search engines should remove the resource from their indices. Most use cases do not require clients and search engines to purge the resource, and a \"404 Not Found\" may be used instead.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#410" - }, - "ietf":{ - "body":"The requested resource is no longer available at the server and no forwarding address is known. This condition is expected to be considered permanent. Clients with link editing capabilities SHOULD delete references to the Request-URI after user approval. If the server does not know, or has no facility to determine, whether or not the condition is permanent, the status code 404 (Not Found) SHOULD be used instead. This response is cacheable unless indicated otherwise.\r\nThe 410 response is primarily intended to assist the task of web maintenance by notifying the recipient that the resource is intentionally unavailable and that the server owners desire that remote links to that resource be removed. Such an event is common for limited-time, promotional services and for resources belonging to individuals no longer working at the server's site. It is not necessary to mark all permanently unavailable resources as \"gone\" or to keep the mark for any length of time -- that is left to the discretion of the server owner.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":gone" - } - } - }, - "411":{ - "code":"411", - "title":"Length Required", - "summary":"request did not specify the length of its content", - "descriptions":{ - "wikipedia":{ - "body":"The request did not specify the length of its content, which is required by the requested resource.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#411" - }, - "ietf":{ - "body":"The server refuses to accept the request without a defined Content- Length. The client MAY repeat the request if it adds a valid Content-Length header field containing the length of the message-body in the request message.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":length_required" - } - } - }, - "412":{ - "code":"412", - "title":"Precondition Failed", - "summary":"server does not meet request preconditions", - "descriptions":{ - "wikipedia":{ - "body":"The server does not meet one of the preconditions that the requester put on the request.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#412" - }, - "ietf":{ - "body":"The precondition given in one or more of the request-header fields evaluated to false when it was tested on the server. This response code allows the client to place preconditions on the current resource metainformation (header field data) and thus prevent the requested method from being applied to a resource other than the one intended.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":precondition_failed" - } - } - }, - "413":{ - "code":"413", - "title":"Request Entity Too Large", - "summary":"request is larger than the server is willing or able to process", - "descriptions":{ - "wikipedia":{ - "body":"The request is larger than the server is willing or able to process.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#413" - }, - "ietf":{ - "body":"The server is refusing to process a request because the request entity is larger than the server is willing or able to process. The server MAY close the connection to prevent the client from continuing the request.\r\nIf the condition is temporary, the server SHOULD include a Retry- After header field to indicate that it is temporary and after what time the client MAY try again.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":request_entity_too_large" - } - } - }, - "414":{ - "code":"414", - "title":"Request-URI Too Long", - "summary":"URI provided was too long for the server to process", - "descriptions":{ - "wikipedia":{ - "body":"The URI provided was too long for the server to process.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#414" - }, - "ietf":{ - "body":"The server is refusing to service the request because the Request-URI is longer than the server is willing to interpret. This rare condition is only likely to occur when a client has improperly converted a POST request to a GET request with long query information, when the client has descended into a URI \"black hole\" of redirection (e.g., a redirected URI prefix that points to a suffix of itself), or when the server is under attack by a client attempting to exploit security holes present in some servers using fixed-length buffers for reading or manipulating the Request-URI.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":request_uri_too_long" - } - } - }, - "415":{ - "code":"415", - "title":"Unsupported Media Type", - "summary":"server does not support media type", - "descriptions":{ - "wikipedia":{ - "body":"The request entity has a media type which the server or resource does not support. For example, the client uploads an image as image\/svg+xml, but the server requires that images use a different format.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#415" - }, - "ietf":{ - "body":"The server is refusing to service the request because the entity of the request is in a format not supported by the requested resource for the requested method.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":unsupported_media_type" - } - } - }, - "416":{ - "code":"416", - "title":"Requested Range Not Satisfiable", - "summary":"client has asked for unprovidable portion of the file", - "descriptions":{ - "wikipedia":{ - "body":"The client has asked for a portion of the file, but the server cannot supply that portion. For example, if the client asked for a part of the file that lies beyond the end of the file.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#416" - }, - "ietf":{ - "body":"A server SHOULD return a response with this status code if a request included a Range request-header field, and none of the range-specifier values in this field overlap the current extent of the selected resource, and the request did not include an If-Range request-header field. (For byte-ranges, this means that the first- byte-pos of all of the byte-range-spec values were greater than the current length of the selected resource.)\r\nWhen this status code is returned for a byte-range request, the response SHOULD include a Content-Range entity-header field specifying the current length of the selected resource. This response MUST NOT use the multipart\/byteranges content- type.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":requested_range_not_satisfiable" - } - } - }, - "417":{ - "code":"417", - "title":"Expectation Failed", - "summary":"server cannot meet requirements of Expect request-header field", - "descriptions":{ - "wikipedia":{ - "body":"The server cannot meet the requirements of the Expect request-header field.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#417" - }, - "ietf":{ - "body":"The expectation given in an Expect request-header field could not be met by this server, or, if the server is a proxy, the server has unambiguous evidence that the request could not be met by the next-hop server.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":expectation_failed" - } - } - }, - "418":{ - "code":"418", - "title":"I'm a teapot (RFC 2324)", - "summary":"I'm a teapot", - "descriptions":{ - "wikipedia":{ - "body":"This code was defined in 1998 as one of the traditional IETF April Fools' jokes, in RFC 2324, Hyper Text Coffee Pot Control Protocol, and is not expected to be implemented by actual HTTP servers. However, known implementations do exist. An Nginx HTTP server uses this code to simulate goto-like behaviour in its configuration.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#418" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":\"i'm_a_teapot\" (explanation<\/a> gist.github.com<\/sup>)<\/small>" - } - } - }, - "420":{ - "code":"420", - "title":"Enhance Your Calm", - "summary":"Twitter rate limiting", - "descriptions":{ - "wikipedia":{ - "body":"Returned by the Twitter Search and Trends API when the client is being rate limited.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#420" - } - } - }, - "422":{ - "code":"422", - "title":"Unprocessable Entity (WebDAV) (RFC 4918)", - "summary":"request unable to be followed due to semantic errors", - "descriptions":{ - "wikipedia":{ - "body":"The request was well-formed but was unable to be followed due to semantic errors.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#422" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":unprocessable_entity" - } - } - }, - "423":{ - "code":"423", - "title":"Locked (WebDAV) (RFC 4918)", - "summary":"resource that is being accessed is locked", - "descriptions":{ - "wikipedia":{ - "body":"The resource that is being accessed is locked.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#423" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":locked" - } - } - }, - "424":{ - "code":"424", - "title":"Failed Dependency (WebDAV) (RFC 4918)", - "summary":"request failed due to failure of a previous request", - "descriptions":{ - "wikipedia":{ - "body":"The request failed due to failure of a previous request (e.g. a PROPPATCH).", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#424" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":failed_dependency" - } - } - }, - "426":{ - "code":"426", - "title":"Upgrade Required (RFC 2817)", - "summary":"client should switch to a different protocol", - "descriptions":{ - "wikipedia":{ - "body":"The client should switch to a different protocol such as TLS\/1.0.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#426" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":upgrade_required" - } - } - }, - "428":{ - "code":"428", - "title":"Precondition Required", - "summary":"origin server requires the request to be conditional", - "descriptions":{ - "wikipedia":{ - "body":"The origin server requires the request to be conditional. Intended to prevent \"the 'lost update' problem, where a client GETs a resource's state, modifies it, and PUTs it back to the server, when meanwhile a third party has modified the state on the server, leading to a conflict.\" Proposed in an Internet-Draft.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#428" - } - } - }, - "429":{ - "code":"429", - "title":"Too Many Requests", - "summary":"user has sent too many requests in a given amount of time", - "descriptions":{ - "wikipedia":{ - "body":"The user has sent too many requests in a given amount of time. Intended for use with rate limiting schemes. Proposed in an Internet-Draft.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#429" - } - } - }, - "431":{ - "code":"431", - "title":"Request Header Fields Too Large", - "summary":"server is unwilling to process the request", - "descriptions":{ - "wikipedia":{ - "body":"The server is unwilling to process the request because either an individual header field, or all the header fields collectively, are too large. Proposed in an Internet-Draft.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#431" - } - } - }, - "444":{ - "code":"444", - "title":"No Response", - "summary":"server returns no information and closes the connection", - "descriptions":{ - "wikipedia":{ - "body":"An nginx HTTP server extension. The server returns no information to the client and closes the connection (useful as a deterrent for malware).", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#444" - } - } - }, - "449":{ - "code":"449", - "title":"Retry With", - "summary":"request should be retried after performing action", - "descriptions":{ - "wikipedia":{ - "body":"A Microsoft extension. The request should be retried after performing the appropriate action.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#449" - } - } - }, - "450":{ - "code":"450", - "title":"Blocked by Windows Parental Controls", - "summary":"Windows Parental Controls blocking access to webpage", - "descriptions":{ - "wikipedia":{ - "body":"A Microsoft extension. This error is given when Windows Parental Controls are turned on and are blocking access to the given webpage.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#450" - } - } - }, - "451":{ - "code":"451", - "title":"Wrong Exchange server", - "summary":"the server cannot reach the client's mailbox", - "descriptions":{ - "MS-ASHTTP":{ - "body":"If the client is attempting to connect to the wrong server (that is, a server that cannot access the user's mailbox), or if there is a more efficient server to use to reach the user's mailbox, then a 451 Redirect error is returned.", - "link":"http://msdn.microsoft.com/en-us/library/gg651019" - } - } - }, - "499":{ - "code":"499", - "title":"Client Closed Request", - "summary":"connection closed by client while HTTP server is processing", - "descriptions":{ - "wikipedia":{ - "body":"An Nginx HTTP server extension. This code is introduced to log the case when the connection is closed by client while HTTP server is processing its request, making server unable to send the HTTP header back.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#499" - } - } - } - } -} diff --git a/cohttp/cohttp/scripts/codes/5.json b/cohttp/cohttp/scripts/codes/5.json deleted file mode 100644 index 96efbffff77f3dab6d7633c73126dbd81c3b3e14..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/scripts/codes/5.json +++ /dev/null @@ -1,234 +0,0 @@ -{ - "class":{ - "title":"Server Error", - "class":"5" - }, - "codes":{ - "500":{ - "code":"500", - "title":"Internal Server Error", - "summary":"generic error message", - "descriptions":{ - "wikipedia":{ - "body":"A generic error message, given when no more specific message is suitable.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#500" - }, - "ietf":{ - "body":"The server encountered an unexpected condition which prevented it from fulfilling the request.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":internal_server_error" - } - } - }, - "501":{ - "code":"501", - "title":"Not Implemented", - "summary":"server does not recognise method or lacks ability to fulfill", - "descriptions":{ - "wikipedia":{ - "body":"The server either does not recognise the request method, or it lacks the ability to fulfill the request.[2]", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#501" - }, - "ietf":{ - "body":"The server does not support the functionality required to fulfill the request. This is the appropriate response when the server does not recognize the request method and is not capable of supporting it for any resource.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":not_implemented" - } - } - }, - "502":{ - "code":"502", - "title":"Bad Gateway", - "summary":"server received an invalid response from upstream server", - "descriptions":{ - "wikipedia":{ - "body":"The server was acting as a gateway or proxy and received an invalid response from the upstream server.[2]", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#502" - }, - "ietf":{ - "body":"The server, while acting as a gateway or proxy, received an invalid response from the upstream server it accessed in attempting to fulfill the request.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":bad_gateway" - } - } - }, - "503":{ - "code":"503", - "title":"Service Unavailable", - "summary":"server is currently unavailable", - "descriptions":{ - "wikipedia":{ - "body":"The server is currently unavailable (because it is overloaded or down for maintenance).[2] Generally, this is a temporary state.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#503" - }, - "ietf":{ - "body":"The server is currently unable to handle the request due to a temporary overloading or maintenance of the server. The implication is that this is a temporary condition which will be alleviated after some delay. If known, the length of the delay MAY be indicated in a Retry-After header. If no Retry-After is given, the client SHOULD handle the response as it would for a 500 response.\r\nNote: The existence of the 503 status code does not imply that a server must use it when becoming overloaded. Some servers may wish to simply refuse the connection.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":service_unavailable" - } - } - }, - "504":{ - "code":"504", - "title":"Gateway Timeout", - "summary":"gateway did not receive response from upstream server", - "descriptions":{ - "wikipedia":{ - "body":"The server was acting as a gateway or proxy and did not receive a timely response from the upstream server.[2]", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#504" - }, - "ietf":{ - "body":"The server, while acting as a gateway or proxy, did not receive a timely response from the upstream server specified by the URI (e.g. HTTP, FTP, LDAP) or some other auxiliary server (e.g. DNS) it needed to access in attempting to complete the request.\r\nNote: Note to implementors: some deployed proxies are known to return 400 or 500 when DNS lookups time out.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":gateway_timeout" - } - } - }, - "505":{ - "code":"505", - "title":"HTTP Version Not Supported", - "summary":"server does not support the HTTP protocol version", - "descriptions":{ - "wikipedia":{ - "body":"The server does not support the HTTP protocol version used in the request.[2]", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#505" - }, - "ietf":{ - "body":"The server does not support, or refuses to support, the HTTP protocol version that was used in the request message. The server is indicating that it is unable or unwilling to complete the request using the same major version as the client. The response SHOULD contain an entity describing why that version is not supported and what other protocols are supported by that server.", - "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":http_version_not_supported" - } - } - }, - "506":{ - "code":"506", - "title":"Variant Also Negotiates (RFC 2295)", - "summary":"content negotiation for the request results in a circular reference", - "descriptions":{ - "wikipedia":{ - "body":"Transparent content negotiation for the request results in a circular reference.[23]", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#506" - } - } - }, - "507":{ - "code":"507", - "title":"Insufficient Storage (WebDAV) (RFC 4918)", - "summary":"server is unable to store the representation", - "descriptions":{ - "wikipedia":{ - "body":"The server is unable to store the representation needed to complete the request.[7]", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#507" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":insufficient_storage" - } - } - }, - "508":{ - "code":"508", - "title":"Loop Detected (WebDAV) (RFC 5842)", - "summary":"server detected an infinite loop while processing the request", - "descriptions":{ - "wikipedia":{ - "body":"The server detected an infinite loop while processing the request (sent in lieu of 208).", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#508" - } - } - }, - "509":{ - "code":"509", - "title":"Bandwidth Limit Exceeded (Apache bw\/limited extension)", - "summary":"bandwidth limit exceeded", - "descriptions":{ - "wikipedia":{ - "body":"This status code, while used by many servers, is not specified in any RFCs.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#509" - } - } - }, - "510":{ - "code":"510", - "title":"Not Extended (RFC 2774)", - "summary":"further extensions to the request are required", - "descriptions":{ - "wikipedia":{ - "body":"Further extensions to the request are required for the server to fulfill it.[24]", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#510" - } - }, - "references":{ - "rails":{ - "title":"Rails HTTP Status Symbol", - "value":":not_extended" - } - } - }, - "511":{ - "code":"511", - "title":"Network Authentication Required", - "summary":"client needs to authenticate to gain network access", - "descriptions":{ - "wikipedia":{ - "body":"The client needs to authenticate to gain network access. Intended for use by intercepting proxies used to control access to the network (e.g. \"captive portals\" used to require agreement to Terms of Service before granting full Internet access via a Wi-Fi hotspot). Proposed in an Internet-Draft.[19]", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#511" - } - } - }, - "598":{ - "code":"598", - "title":"Network read timeout error", - "summary":"network read timeout behind the proxy ", - "descriptions":{ - "wikipedia":{ - "body":"This status code is not specified in any RFCs, but is used by some HTTP proxies to signal a network read timeout behind the proxy to a client in front of the proxy.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#598" - } - } - }, - "599":{ - "code":"599", - "title":"Network connect timeout error", - "summary":"network connect timeout behind the proxy", - "descriptions":{ - "wikipedia":{ - "body":"This status code is not specified in any RFCs, but is used by some HTTP proxies to signal a network connect timeout behind the proxy to a client in front of the proxy.", - "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#599" - } - } - } - } -} \ No newline at end of file diff --git a/cohttp/cohttp/scripts/codes/LICENSE b/cohttp/cohttp/scripts/codes/LICENSE deleted file mode 100644 index 040932d5fac7b4a9e85eee358dd740529087069d..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/scripts/codes/LICENSE +++ /dev/null @@ -1,18 +0,0 @@ -Copyright (C) 2012 - 2013 Samuel Ryan (citricsquid) - -Permission is hereby granted, free of charge, to any person obtaining a copy of -this software and associated documentation files (the "Software"), to deal in -the Software without restriction, including without limitation the rights to use, -copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the -Software, and to permit persons to whom the Software is furnished to do so, -subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, -WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. \ No newline at end of file diff --git a/cohttp/cohttp/scripts/dune b/cohttp/cohttp/scripts/dune deleted file mode 100644 index c5afa948c23caf7a23fd525ee0ff7abfc9440ee0..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/scripts/dune +++ /dev/null @@ -1,3 +0,0 @@ -(executable - (name generate) - (libraries jsonm)) diff --git a/cohttp/cohttp/scripts/generate.ml b/cohttp/cohttp/scripts/generate.ml deleted file mode 100644 index 160e9907456ac43f86b39c2efb696d8cb109075b..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/scripts/generate.ml +++ /dev/null @@ -1,366 +0,0 @@ -(*{{{ Copyright (c) 2013 Thomas Gazagnaire - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - }}}*) - -(* From http://erratique.ch/software/jsonm/doc/Jsonm.html#datamodel *) -type t = - [ `Null - | `Bool of bool - | `Float of float - | `String of string - | `A of t list - | `O of (string * t) list ] - -exception Escape of ((int * int) * (int * int)) * Jsonm.error - -let json_of_src src = - let d = Jsonm.decoder src in - let dec () = - match Jsonm.decode d with - | `Lexeme l -> l - | `Error e -> raise (Escape (Jsonm.decoded_range d, e)) - | `End | `Await -> assert false - in - let rec value v k = - match v with - | `Os -> obj [] k - | `As -> arr [] k - | (`Null | `Bool _ | `String _ | `Float _) as v -> k v - | _ -> assert false - and arr vs k = - match dec () with - | `Ae -> k (`A (List.rev vs)) - | v -> value v (fun v -> arr (v :: vs) k) - and obj ms k = - match dec () with - | `Oe -> k (`O (List.rev ms)) - | `Name n -> value (dec ()) (fun v -> obj ((n, v) :: ms) k) - | _ -> assert false - in - try `JSON (value (dec ()) (fun v -> v)) with Escape (r, e) -> `Error (r, e) - -let json_to_dst ~minify dst (json : t) = - let enc e l = ignore (Jsonm.encode e (`Lexeme l)) in - let rec value v k e = - match v with - | `A vs -> arr vs k e - | `O ms -> obj ms k e - | (`Null | `Bool _ | `Float _ | `String _) as v -> - enc e v; - k e - and arr vs k e = - enc e `As; - arr_vs vs k e - and arr_vs vs k e = - match vs with - | v :: vs' -> value v (arr_vs vs' k) e - | [] -> - enc e `Ae; - k e - and obj ms k e = - enc e `Os; - obj_ms ms k e - and obj_ms ms k e = - match ms with - | (n, v) :: ms -> - enc e (`Name n); - value v (obj_ms ms k) e - | [] -> - enc e `Oe; - k e - in - let e = Jsonm.encoder ~minify dst in - let finish e = ignore (Jsonm.encode e `End) in - match json with - | (`A _ | `O _) as json -> value json finish e - | _ -> invalid_arg "invalid json text" - -let to_buffer buf (json : t) = json_to_dst ~minify:true (`Buffer buf) json - -let output t = - let buf = Buffer.create 1024 in - to_buffer buf t; - Buffer.contents buf - -let parse_error fmt = - Printf.ksprintf - (fun msg -> - Printf.eprintf "parse error: %s\n" msg; - exit 1) - fmt - -let string_of_error error = - Jsonm.pp_error Format.str_formatter error; - Format.flush_str_formatter () - -let of_buffer buf : t = - let str = Buffer.contents buf in - match json_of_src (`String str) with - | `JSON j -> j - | `Error (_, e) -> parse_error "JSON.of_buffer %s" (string_of_error e) - -let of_channel ic = - match json_of_src (`Channel ic) with - | `JSON j -> j - | `Error (_, e) -> parse_error "JSON.of_buffer %s" (string_of_error e) - -let input str : t = - match json_of_src (`String str) with - | `JSON j -> j - | `Error (_, e) -> - Jsonm.pp_error Format.str_formatter e; - parse_error "JSON.input %s" (string_of_error e) - -(* string *) -let of_string s = `String s - -let to_string = function - | `String s -> s - | j -> parse_error "JSON.to_string: %s" (output j) - -type code = { code : int; constr : string; descr : string; doc : string } -type section = { section : string; codes : code list } - -let normalize s = - let b = Bytes.of_string s in - Bytes.iteri - (fun i -> function - | 'A' .. 'Z' as c -> if i > 1 then Bytes.set b i (Char.lowercase_ascii c) - | ' ' | '-' | '\'' -> Bytes.set b i '_' - | _ -> ()) - (Bytes.of_string s); - Bytes.to_string b - -let read ic = - let json = of_channel ic in - match json with - | `O o -> - let section = - match List.assoc "class" o with - | `O o -> - let s = - String.uncapitalize_ascii (to_string (List.assoc "title" o)) - in - normalize s - | _ -> assert false - in - - let codes = - match List.assoc "codes" o with - | `O o -> - List.fold_left - (fun codes (code, o) -> - let code = int_of_string code in - if code = 122 then (* Same as 414 but for IE7 ??? *) - codes - else - let o = match o with `O o -> o | _ -> assert false in - let descr = to_string (List.assoc "title" o) in - let constr = - "`" - ^ - try - let i = String.index descr '(' in - String.sub descr 0 (i - 1) - with Not_found -> descr - in - let constr = normalize constr in - (* XXX: dirty hack *) - let constr = if constr = "`Ok" then "`OK" else constr in - let doc = to_string (List.assoc "summary" o) in - { constr; descr; code; doc } :: codes) - [] o - | _ -> assert false - in - { section; codes = List.rev codes } - | _ -> assert false - -let append oc fmt = Printf.fprintf oc (fmt ^^ "\n") - -let output_type oc ~mli t = - append oc "type %s_status =" t.section; - List.iteri - (fun i c -> - let doc = if mli then Printf.sprintf " (** %s *)" c.doc else "" in - if i = 0 then append oc " [ %s%s" c.constr doc - else append oc " | %s%s" c.constr doc) - t.codes; - append oc " ] [@@deriving sexp]"; - if mli then append oc "(** %s *)" (String.capitalize_ascii t.section); - append oc "" - -let output_status_types oc ~mli t = - List.iter (output_type oc ~mli) t; - append oc "type status = ["; - List.iter (fun t -> append oc " | %s_status" t.section) t; - append oc "] [@@deriving sexp]"; - append oc ""; - append oc "type status_code = [`Code of int | status ] [@@deriving sexp]"; - append oc "" - -let iter fn s = List.iter (fun s -> List.iter fn s.codes) s - -let output_status_of_code oc ~mli s = - if mli then ( - append oc "val status_of_code: int -> status_code"; - append oc "(** Generate status values from int codes. *)") - else ( - append oc "let status_of_code: int -> status_code = function"; - iter (fun c -> append oc " | %d -> %s" c.code c.constr) s; - append oc " | cod -> `Code cod"); - append oc "" - -let output_code_of_status oc ~mli s = - if mli then ( - append oc "val code_of_status: status_code -> int"; - append oc "(** Generate an int code from a status value. *)") - else ( - append oc "let code_of_status: status_code -> int = function"; - iter (fun c -> append oc " | %s -> %d" c.constr c.code) s; - append oc " | `Code cod -> cod"); - append oc "" - -let output_string_of_status oc ~mli s = - if mli then ( - append oc "val string_of_status: status_code -> string"; - append oc "(** Give a description of the given status value. *)") - else ( - append oc "let string_of_status: status_code -> string = function"; - iter (fun c -> append oc " | %s -> \"%d %s\"" c.constr c.code c.descr) s; - (* the response status must include an extra space even if no description is present, cf. #752 *) - append oc " | `Code cod ->"; - append oc " let code = string_of_int cod in"; - append oc " code ^ \" Status \" ^ code"); - append oc "" - -let output_reason_phrase_of_code oc ~mli s = - if mli then ( - append oc "val reason_phrase_of_code: int -> string"; - append oc "(** Give a description of the given int code. *)") - else ( - append oc "let reason_phrase_of_code: int -> string = function"; - iter (fun c -> append oc " | %d -> %S" c.code c.descr) s; - append oc " | cod -> string_of_int cod"); - append oc "" - -let output_is_code oc ~mli t = - List.iter - (fun t -> - if mli then ( - append oc "val is_%s: int -> bool" t.section; - append oc - "(** Is the given int code belong to the class of %S return code ? *)" - t.section) - else ( - append oc "let is_%s code =" t.section; - append oc " match status_of_code code with"; - append oc " | #%s_status -> true" t.section; - append oc " | _ -> false"); - append oc "") - t; - append oc ""; - if mli then ( - append oc "val is_error: int -> bool"; - append oc "(** Return true for client and server error status codes. *)") - else - append oc "let is_error code = is_client_error code || is_server_error code"; - append oc "" - -type gen = { constr : string; string : string } - -let g constr string = { constr; string } - -let output_gen_types oc (_name, typ, gens) = - append oc "type %s = [" typ; - List.iter (fun { constr; _ } -> append oc " | %s" constr) gens; - append oc " | `Other of string"; - append oc "] [@@deriving sexp]"; - append oc "" - -let output_gen_convert oc ~mli (name, typ, gens) = - if mli then ( - append oc "val string_of_%s: %s -> string" name typ; - append oc "(** Convert a %s to a string. *)" name; - append oc ""; - append oc "val %s_of_string: string -> %s" name typ; - append oc "(** Convert a string to a %s. *)" name; - append oc ""; - append oc "val compare_%s: %s -> %s -> int" name typ typ; - append oc "(** Comparison function for [%s] values *)" name; - append oc "") - else ( - append oc "let string_of_%s: %s -> string = function" name typ; - List.iter (fun g -> append oc " | %s -> %S" g.constr g.string) gens; - append oc " | `Other s -> s"; - append oc ""; - append oc "let %s_of_string: string -> %s = function" name typ; - List.iter (fun g -> append oc " | %S -> %s" g.string g.constr) gens; - append oc " | s -> `Other s"; - append oc ""; - append oc "let compare_%s a b =" name; - append oc " String.compare (string_of_%s a) (string_of_%s b)" name name; - append oc ""); - append oc "" - -let t = - List.map - (fun f -> read (open_in f)) - [ - "codes/1.json"; - "codes/2.json"; - "codes/3.json"; - "codes/4.json"; - "codes/5.json"; - ] - -let version = - ("version", "version", [ g "`HTTP_1_0" "HTTP/1.0"; g "`HTTP_1_1" "HTTP/1.1" ]) - -let known_methods = - [ - g "`GET" "GET"; - g "`POST" "POST"; - g "`HEAD" "HEAD"; - g "`DELETE" "DELETE"; - g "`PATCH" "PATCH"; - g "`PUT" "PUT"; - g "`OPTIONS" "OPTIONS"; - g "`TRACE" "TRACE"; - g "`CONNECT" "CONNECT"; - ] - -let meth = ("method", "meth", known_methods) - -let gen oc ~mli = - append oc "(* Auto-Generated by 'ocaml generate.ml' *)"; - append oc "open! Sexplib0.Sexp_conv"; - append oc ""; - output_gen_types oc version; - output_gen_types oc meth; - output_status_types oc ~mli t; - output_gen_convert oc ~mli version; - output_gen_convert oc ~mli meth; - output_status_of_code oc ~mli t; - output_code_of_status oc ~mli t; - output_string_of_status oc ~mli t; - output_reason_phrase_of_code oc ~mli t; - output_is_code oc ~mli t - -let () = - let ml = open_out "../src/code.ml" in - let mli = open_out "../src/code.mli" in - gen ml ~mli:false; - gen mli ~mli:true; - close_out ml; - close_out mli diff --git a/cohttp/cohttp/src/accept.ml b/cohttp/cohttp/src/accept.ml deleted file mode 100644 index f65bbe8f127b2dfcd53726942b3de94ce31c3b7e..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/accept.ml +++ /dev/null @@ -1,97 +0,0 @@ -(*{{{opyright (C) 2012, David Sheets - - Permission to use, copy, modify, and/or distribute this software for - any purpose with or without fee is hereby granted, provided that the - above copyright notice and this permission notice appear in all - copies. - - THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL - WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE - AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL - DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA - OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER - TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR - PERFORMANCE OF THIS SOFTWARE. - }}}*) -(* TODO: handle exceptions better *) - -open Printf -include Accept_types -module Parser = Accept_parser -module Lexer = Accept_lexer - -let qsort l = - let compare ((i : int), _) (i', _) = - (* The inversion is on purpose, we sort the biggest quality first. *) - compare i' i - in - List.stable_sort compare l - -let parse_using p s = p Lexer.header_value (Lexing.from_string s) - -let media_ranges = function - | Some s -> parse_using Parser.media_ranges s - | None -> [ (1000, (AnyMedia, [])) ] - -let charsets = function - | Some s -> parse_using Parser.charsets s - | None -> [ (1000, AnyCharset) ] - -let encodings = function - | Some s -> parse_using Parser.encodings s - | None -> [ (1000, AnyEncoding) ] - -let languages = function - | Some s -> parse_using Parser.languages s - | None -> [ (1000, AnyLanguage) ] - -let rec string_of_pl = function - | [] -> "" - | (k, v) :: r -> - let e = Stringext.quote v in - if v = e then sprintf ";%s=%s%s" k v (string_of_pl r) - else sprintf ";%s=\"%s\"%s" k e (string_of_pl r) - -let string_of_q = function - | q when q < 0 -> invalid_arg (Printf.sprintf "qvalue %d must be positive" q) - | q when q > 1000 -> - invalid_arg (Printf.sprintf "qvalue %d must be less than 1000" q) - | 1000 -> "1" - | q -> Printf.sprintf "0.%03d" q - -let accept_el el pl q = sprintf "%s;q=%s%s" el (string_of_q q) (string_of_pl pl) - -let string_of_media_range = function - | MediaType (t, st), pl -> accept_el (sprintf "%s/%s" t st) pl - | AnyMediaSubtype t, pl -> accept_el (sprintf "%s/*" t) pl - | AnyMedia, pl -> accept_el "*/*" pl - -let string_of_charset = function - | Charset c -> accept_el c [] - | AnyCharset -> accept_el "*" [] - -let string_of_encoding = function - | Encoding e -> accept_el e [] - | Gzip -> accept_el "gzip" [] - | Compress -> accept_el "compress" [] - | Deflate -> accept_el "deflate" [] - | Identity -> accept_el "identity" [] - | AnyEncoding -> accept_el "*" [] - -let string_of_language = function - | Language langl -> accept_el (String.concat "-" langl) [] - | AnyLanguage -> accept_el "*" [] - -let string_of_list s_of_el = - let rec aux s = function - | [ (q, el) ] -> s ^ s_of_el el q - | [] -> s - | (q, el) :: r -> aux (s ^ s_of_el el q ^ ",") r - in - aux "" - -let string_of_media_ranges = string_of_list string_of_media_range -let string_of_charsets = string_of_list string_of_charset -let string_of_encodings = string_of_list string_of_encoding -let string_of_languages = string_of_list string_of_language diff --git a/cohttp/cohttp/src/accept.mli b/cohttp/cohttp/src/accept.mli deleted file mode 100644 index 6cddf1a8ee9e99253c888f464480b325f5410002..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/accept.mli +++ /dev/null @@ -1,68 +0,0 @@ -(*{{{ Copyright (C) 2012, David Sheets - - Permission to use, copy, modify, and/or distribute this software for - any purpose with or without fee is hereby granted, provided that the - above copyright notice and this permission notice appear in all - copies. - - THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL - WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE - AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL - DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA - OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER - TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR - PERFORMANCE OF THIS SOFTWARE. - }}}*) - -(** Accept-Encoding HTTP header parsing and generation *) - -type q = int [@@deriving sexp] -(** Qualities are integers between 0 and 1000. A header with ["q=0.7"] - corresponds to a quality of [700]. *) - -type 'a qlist = (q * 'a) list [@@deriving sexp] -(** Lists, annotated with qualities. *) - -val qsort : 'a qlist -> 'a qlist -(** Sort by quality, biggest first. Respect the initial ordering. *) - -type p = string * string [@@deriving sexp] - -type media_range = Accept_types.media_range = - | MediaType of string * string - | AnyMediaSubtype of string - | AnyMedia -[@@deriving sexp] - -type charset = Accept_types.charset = Charset of string | AnyCharset -[@@deriving sexp] - -type encoding = Accept_types.encoding = - | Encoding of string - | Gzip - | Compress - | Deflate - | Identity - | AnyEncoding -[@@deriving sexp] - -(** Basic language range tag. ["en-gb"] is represented as - [Language \["en"; "gb"\]]. - - @see the specification. *) -type language = Accept_types.language = Language of string list | AnyLanguage -[@@deriving sexp] - -val media_ranges : string option -> (media_range * p list) qlist -val charsets : string option -> charset qlist -val encodings : string option -> encoding qlist -val languages : string option -> language qlist -val string_of_media_range : media_range * p list -> q -> string -val string_of_charset : charset -> q -> string -val string_of_encoding : encoding -> q -> string -val string_of_language : language -> q -> string -val string_of_media_ranges : (media_range * p list) qlist -> string -val string_of_charsets : charset qlist -> string -val string_of_encodings : encoding qlist -> string -val string_of_languages : language qlist -> string diff --git a/cohttp/cohttp/src/accept_lexer.mll b/cohttp/cohttp/src/accept_lexer.mll deleted file mode 100644 index 47d1e183ecdf77380aea641cc21d41ea1d42d0c2..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/accept_lexer.mll +++ /dev/null @@ -1,37 +0,0 @@ -(*{{{ Copyright (C) 2012, David Sheets - - Permission to use, copy, modify, and/or distribute this software for - any purpose with or without fee is hereby granted, provided that the - above copyright notice and this permission notice appear in all - copies. - - THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL - WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE - AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL - DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA - OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER - TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR - PERFORMANCE OF THIS SOFTWARE. -}}}*) -{ - open Accept_parser -} - -(* *) -let token = [^'('')''<''>''@'','';'':''\\''"''/''['']''?''=''{''}'' ''\t'] - -rule header_value = parse - | '*' { STAR } - | '/' { SLASH } - | ';' { SEMI } - | ',' { COMMA } - | '=' { EQUAL } - | '\"' { QS (List.fold_right (^) (qs [] lexbuf) "") } - | (token)+ as tok { TOK tok } - | ' ' { header_value lexbuf } - | eof { EOI } -and qs sl = parse - | "\\\"" { qs ("\""::sl) lexbuf } - | "\"" { sl } - | [^'"']+ as s { qs (s::sl) lexbuf } diff --git a/cohttp/cohttp/src/accept_parser.mly b/cohttp/cohttp/src/accept_parser.mly deleted file mode 100644 index 2d0c729d2b5c6047fb0b1893bc17ce71b703bcc4..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/accept_parser.mly +++ /dev/null @@ -1,105 +0,0 @@ -/* - Copyright (C) 2012, David Sheets - - Permission to use, copy, modify, and/or distribute this software for - any purpose with or without fee is hereby granted, provided that the - above copyright notice and this permission notice appear in all - copies. - - THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL - WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE - AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL - DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA - OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER - TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR - PERFORMANCE OF THIS SOFTWARE. -*/ - -%{ - open Accept_types - - type param = Q of int | Kv of p - - let rec get_q = function - | (Q q)::_ -> q - | _::r -> get_q r - | [] -> 1000 - - let get_rest pl = List.fold_right - (function Kv p -> fun l -> p::l | Q _ -> fun l -> l) pl [] -%} - -%token STAR SLASH SEMI COMMA EQUAL EOI -%token TOK QS -%start media_ranges charsets encodings languages -%type <(Accept_types.media_range * Accept_types.p list) Accept_types.qlist> media_ranges -%type charsets -%type encodings -%type languages -%% - -param : -| SEMI TOK EQUAL QS { Kv ($2, $4) } -| SEMI TOK EQUAL TOK { - if $2="q" then try Q (truncate (1000.*.(float_of_string $4))) - with Failure _ -> raise Parsing.Parse_error - else Kv ($2, $4) -} - -params : -| param params { $1::$2 } -| { [] } - -media_range : -| STAR SLASH STAR params { - (get_q $4, (AnyMedia, get_rest $4)) -} -| TOK SLASH STAR params { - (get_q $4, (AnyMediaSubtype (String.lowercase_ascii $1), get_rest $4)) -} -| TOK SLASH TOK params { - (get_q $4, (MediaType (String.lowercase_ascii $1, String.lowercase_ascii $3), get_rest $4)) -} - -media_ranges : -| media_range EOI { [$1] } -| media_range COMMA media_ranges { $1::$3 } -| EOI { [] } - -charset : -| TOK params { (get_q $2, Charset (String.lowercase_ascii $1)) } -| STAR params { (get_q $2, AnyCharset) } - -charsets : -| charset EOI { [$1] } -| charset COMMA charsets { $1::$3 } - -encoding : -| TOK params { - (get_q $2, match (String.lowercase_ascii $1) with - | "gzip" -> Gzip - | "compress" -> Compress - | "deflate" -> Deflate - | "identity" -> Identity - | enc -> Encoding enc - ) -} -| STAR params { (get_q $2, AnyEncoding) } - -encodings : -| encoding EOI { [$1] } -| encoding COMMA encodings { $1::$3 } -| EOI { [] } - -language : -| TOK params { - (get_q $2, Language (Stringext.split ~on:'-' (String.lowercase_ascii $1))) -} -| STAR params { (get_q $2, AnyLanguage) } - -languages : -| language EOI { [$1] } -| language COMMA languages { $1::$3 } - -%% diff --git a/cohttp/cohttp/src/accept_types.ml b/cohttp/cohttp/src/accept_types.ml deleted file mode 100644 index 56928155502a5029b30ca01d37a366d0b54070d4..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/accept_types.ml +++ /dev/null @@ -1,43 +0,0 @@ -(*{{{ Copyright (C) 2012, David Sheets - - Permission to use, copy, modify, and/or distribute this software for - any purpose with or without fee is hereby granted, provided that the - above copyright notice and this permission notice appear in all - copies. - - THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL - WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE - AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL - DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA - OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER - TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR - PERFORMANCE OF THIS SOFTWARE. - }}}*) - -(** Type definitions for the {!Accept} module *) - -open Sexplib0.Sexp_conv - -type p = string * string [@@deriving sexp] - -type media_range = - | MediaType of string * string - | AnyMediaSubtype of string - | AnyMedia -[@@deriving sexp] - -type charset = Charset of string | AnyCharset [@@deriving sexp] - -type encoding = - | Encoding of string - | Gzip - | Compress - | Deflate - | Identity - | AnyEncoding -[@@deriving sexp] - -type language = Language of string list | AnyLanguage [@@deriving sexp] -type q = int [@@deriving sexp] -type 'a qlist = (q * 'a) list [@@deriving sexp] diff --git a/cohttp/cohttp/src/auth.ml b/cohttp/cohttp/src/auth.ml deleted file mode 100644 index 545f3fe7157b27c47f24ffda752150f5510026b4..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/auth.ml +++ /dev/null @@ -1,41 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Sexplib0.Sexp_conv -open Printf - -type challenge = [ `Basic of string (* realm *) ] [@@deriving sexp] - -type credential = - [ `Basic of string * string (* username, password *) | `Other of string ] -[@@deriving sexp] - -let string_of_credential (cred : credential) = - match cred with - | `Basic (user, pass) -> - "Basic " ^ Base64.encode_string (sprintf "%s:%s" user pass) - | `Other buf -> buf - -let credential_of_string (buf : string) : credential = - try - let b64 = Scanf.sscanf buf "Basic %s" (fun b -> b) in - match Stringext.split ~on:':' (Base64.decode_exn b64) ~max:2 with - | [ user; pass ] -> `Basic (user, pass) - | _ -> `Other buf - with _ -> `Other buf - -let string_of_challenge (ty : challenge) = - match ty with `Basic realm -> sprintf "Basic realm=\"%s\"" realm diff --git a/cohttp/cohttp/src/auth.mli b/cohttp/cohttp/src/auth.mli deleted file mode 100644 index 19f1c3a1d903c961f8ffe6be83fec3b9fe58fe57..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/auth.mli +++ /dev/null @@ -1,48 +0,0 @@ -(*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** HTTP Authentication and Authorization header parsing and generation *) - -type challenge = [ `Basic of string (** Basic authentication within a realm *) ] -[@@deriving sexp] -(** HTTP authentication challenge types *) - -type credential = - [ `Basic of string * string - (** Basic authorization with a username and password *) - | `Other of string - (** An unknown credential type that will be passed straight through to the - application layer *) ] -[@@deriving sexp] -(** HTTP authorization credential types *) - -val string_of_credential : credential -> string -(** [string_of_credential] converts the {!credential} to a string compatible - with the HTTP/1.1 wire format for authorization credentials ("responses") *) - -val credential_of_string : string -> credential -(** [credential_of_string cred_s] converts an HTTP response to an authentication - challenge into a {!credential}. If the credential is not recognized, - [`Other cred_s] is returned. *) - -val string_of_challenge : challenge -> string -(** [string_of_challenge challenge] converts the {!challenge} to a string - compatible with the HTTP/1.1 wire format for authentication challenges. - - For example, a [`Basic] challenge with realm ["foo"] will be marshalled to - ["Basic realm=foo"], which can then be combined with a [www-authenticate] - HTTP header and sent back to the client. There is a helper function - {!Header.add_authorization_req} that does just this. *) diff --git a/cohttp/cohttp/src/body.ml b/cohttp/cohttp/src/body.ml deleted file mode 100644 index 23c32c4f9f8f4c58f9257460054819d4994b6f80..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/body.ml +++ /dev/null @@ -1,65 +0,0 @@ -(*{{{ Copyright (c) 2014 Rudi Grinberg - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Sexplib0.Sexp_conv - -type t = [ `Empty | `String of string | `Strings of string list ] -[@@deriving sexp] - -let empty = `Empty - -let is_empty = function - | `Empty | `String "" -> true - | `String _ -> false - | `Strings xs -> ( - match List.filter (fun s -> s <> "") xs with [] -> true | _ -> false) - -let to_string = function - | `Empty -> "" - | `String s -> s - | `Strings sl -> String.concat "" sl - -let to_string_list = function - | `Empty -> [] - | `String s -> [ s ] - | `Strings sl -> sl - -let of_string s = `String s -let of_string_list s = `Strings s - -let transfer_encoding = function - | `Empty -> Transfer.Fixed 0L - | `String s -> Transfer.Fixed (Int64.of_int (String.length s)) - | `Strings _ -> Transfer.Chunked - -let length = function - | `Empty -> 0L - | `String s -> Int64.of_int (String.length s) - | `Strings sl -> - sl - |> List.fold_left - (fun a b -> b |> String.length |> Int64.of_int |> Int64.add a) - 0L - -let map f = function - | `Empty -> `Empty - | `String s -> `String (f s) - | `Strings sl -> `Strings (List.map f sl) - -let to_form t = Uri.query_of_encoded (to_string t) -let of_form ?scheme f = Uri.encoded_of_query ?scheme f |> of_string - -(* TODO: maybe add a functor here that uses IO.S *) diff --git a/cohttp/cohttp/src/body.mli b/cohttp/cohttp/src/body.mli deleted file mode 100644 index 5a721afeb065a89e9e8da4c445cc939937a3e4b5..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/body.mli +++ /dev/null @@ -1,29 +0,0 @@ -(*{{{ Copyright (c) 2014 Rudi Grinberg - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** HTTP request and response body handling *) - -type t = [ `Empty | `String of string | `Strings of string list ] -[@@deriving sexp] -(** Every HTTP body can at least be an empty value or a [string] *) - -include S.Body with type t := t -(** Signature for the core of HTTP body handling. Implementations will extend - this signature to add more functions for streaming responses via - backend-specific functionality. *) - -val length : t -> int64 diff --git a/cohttp/cohttp/src/cohttp.ml b/cohttp/cohttp/src/cohttp.ml deleted file mode 100644 index 8b1909e9f9677cd2de51b7b18cb200bc800e2aed..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/cohttp.ml +++ /dev/null @@ -1,14 +0,0 @@ -module Accept = Accept -module Auth = Auth -module Body = Body -module Conf = Conf -module Connection = Connection -module Code = Code -module Cookie = Cookie -module Header = Header -module Link = Link -module Request = Request -module Response = Response -module S = S -module Path = Path -module Transfer = Transfer diff --git a/cohttp/cohttp/src/conf.mli b/cohttp/cohttp/src/conf.mli deleted file mode 100644 index e8e75a5243aa85f7947600527d04d94284b39151..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/conf.mli +++ /dev/null @@ -1,21 +0,0 @@ -(*{{{ Copyright (c) 2015 Christophe Troestler - * Copyright (c) 2015 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** Compile-time configuration variables *) - -val version : string -(** The version number of this library. *) diff --git a/cohttp/cohttp/src/connection.ml b/cohttp/cohttp/src/connection.ml deleted file mode 100644 index 7aebaa7e7a3d40c8336e1fd3e2c8e700cbd70988..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/connection.ml +++ /dev/null @@ -1,28 +0,0 @@ -(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy - * Copyright (c) 2013 Thomas Gazagnaire - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) -open Sexplib0.Sexp_conv - -type t = int [@@deriving sexp] - -let to_string = string_of_int -let count = ref 0 - -let create () = - incr count; - !count - -let compare (a : t) (b : t) = Stdlib.compare a b diff --git a/cohttp/cohttp/src/connection.mli b/cohttp/cohttp/src/connection.mli deleted file mode 100644 index 9d703a90fb781a73e268932852f613e29cd9ab6c..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/connection.mli +++ /dev/null @@ -1,31 +0,0 @@ -(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy - * Copyright (c) 2013 Thomas Gazagnaire - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** Connection identifiers. *) - -type t [@@deriving sexp] -(** Abstract type for connection identifiers. *) - -val create : unit -> t -(** Create a fresh connection identifier. *) - -val to_string : t -> string -(** Pretty-print a connection identifer. *) - -val compare : t -> t -> int -(** Comparison function for two identifiers. More recently constructed - identifiers will be greater than older ones. *) diff --git a/cohttp/cohttp/src/cookie.ml b/cohttp/cohttp/src/cookie.ml deleted file mode 100644 index 8b6777d58c371b07b1f507c454ad3944f1abba6b..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/cookie.ml +++ /dev/null @@ -1,197 +0,0 @@ -(*{{{ Copyright (C) <2012> Anil Madhavapeddy - * Copyright (C) <2009> David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Sexplib0.Sexp_conv - -type expiration = [ `Session | `Max_age of int64 ] [@@deriving sexp] -type cookie = string * string [@@deriving sexp] - -module Set_cookie_hdr = struct - type t = { - cookie : cookie; - expiration : expiration; - domain : string option; - path : string option; - secure : bool; - http_only : bool; - } - [@@deriving sexp] - - let cookie t = t.cookie - let expiration t = t.expiration - let domain t = t.domain - let path t = t.path - let secure t = t.secure - let http_only t = t.http_only - - (* Does not check the contents of name or value for ';', ',', '\s', or name[0]='$' *) - let make ?(expiration = `Session) ?path ?domain ?(secure = false) - ?(http_only = false) cookie = - { cookie; expiration; domain; path; secure; http_only } - - (* TODO: deprecated by RFC 6265 and almost certainly buggy without - reference to cookie field *) - let serialize_1_1 c = - let attrs = [ "Version=1" ] in - let attrs = if c.secure then "Secure" :: attrs else attrs in - let attrs = - match c.path with None -> attrs | Some p -> ("Path=" ^ p) :: attrs - in - let attrs = - match c.expiration with - | `Session -> "Discard" :: attrs - | `Max_age age -> ("Max-Age=" ^ Int64.to_string age) :: attrs - in - let attrs = - match c.domain with None -> attrs | Some d -> ("Domain=" ^ d) :: attrs - in - ("Set-Cookie2", String.concat "; " attrs) - - let serialize_1_0 c = - let attrs = if c.http_only then [ "httponly" ] else [] in - let attrs = if c.secure then "secure" :: attrs else attrs in - let attrs = - match c.path with None -> attrs | Some p -> ("path=" ^ p) :: attrs - in - let attrs = - match c.domain with None -> attrs | Some d -> ("domain=" ^ d) :: attrs - in - let attrs = - match c.expiration with - | `Session -> attrs - | `Max_age age -> ("Max-Age=" ^ Int64.to_string age) :: attrs - in - let n, c = c.cookie in - (* TODO: may be buggy, some UAs will ignore cookie-strings without '='*) - let attrs = (n ^ match c with "" -> "" | v -> "=" ^ v) :: attrs in - ("Set-Cookie", String.concat "; " attrs) - - let serialize ?(version = `HTTP_1_0) c = - match version with - | `HTTP_1_0 -> serialize_1_0 c - | `HTTP_1_1 -> serialize_1_1 c - - (* TODO: implement *) - let extract_1_1 _cstr alist = alist - - let extract_1_0 cstr alist = - let attrs = Stringext.split_trim_left cstr ~on:",;" ~trim:" \t" in - let attrs = - List.map - (fun attr -> - match Stringext.split ~on:'=' attr with - | [] -> ("", "") - | n :: v -> (n, String.concat "=" v)) - attrs - in - try - let cookie = List.hd attrs in - let attrs = - List.map (fun (n, v) -> (String.lowercase_ascii n, v)) (List.tl attrs) - in - let path = - try - let v = List.assoc "path" attrs in - if v = "" || v.[0] <> '/' then raise Not_found else Some v - with Not_found -> None - in - let domain = - try - let v = List.assoc "domain" attrs in - if v = "" then raise Not_found - else - Some - (String.lowercase_ascii - (if v.[0] = '.' then Stringext.string_after v 1 else v)) - with Not_found -> None - in - (* TODO: trim wsp *) - ( fst cookie, - { - cookie; - (* TODO: respect expires attribute *) - expiration = `Session; - domain; - path; - http_only = List.mem_assoc "httponly" attrs; - secure = List.mem_assoc "secure" attrs; - } ) - :: alist - with Failure _ -> alist - - let caseless_equal a b = - if a == b then true - else - let len = String.length a in - len = String.length b - && - let stop = ref false in - let idx = ref 0 in - while (not !stop) && !idx < len do - let c1 = String.unsafe_get a !idx in - let c2 = String.unsafe_get b !idx in - if Char.lowercase_ascii c1 <> Char.lowercase_ascii c2 then stop := true; - incr idx - done; - not !stop - - (* TODO: check dupes+order *) - let extract hdr = - Header.fold - (fun k c a -> - if caseless_equal k "set-cookie" then extract_1_0 c a - else if caseless_equal k "set-cookie2" then extract_1_1 c a - else a) - hdr [] - - let value { cookie = _, v; _ } = v -end - -module Cookie_hdr = struct - (* RFC 2965 has - cookie = "Cookie:" cookie-version 1*((";" | ",") cookie-value) - cookie-value = NAME "=" VALUE [";" path] [";" domain] [";" port] - cookie-version = "$Version" "=" value - NAME = attr - VALUE = value - path = "$Path" "=" value - domain = "$Domain" "=" value - port = "$Port" [ "=" <"> value <"> ] - *) - - let extract hdr = - List.fold_left - (fun acc header -> - let comps = Stringext.split_trim_left ~on:";" ~trim:" \t" header in - (* We don't handle $Path, $Domain, $Port, $Version (or $anything - $else) *) - let cookies = - List.filter (fun s -> String.length s > 0 && s.[0] != '$') comps - in - let split_pair nvp = - match Stringext.split ~on:'=' nvp ~max:2 with - | [] -> ("", "") - | [ n ] -> (n, "") - | n :: v :: _ -> (n, v) - in - List.map split_pair cookies @ acc) - [] - (Header.get_multi hdr "cookie") - - let serialize cookies = - ("cookie", String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) cookies)) -end diff --git a/cohttp/cohttp/src/cookie.mli b/cohttp/cohttp/src/cookie.mli deleted file mode 100644 index 70a0a8ef62cf8da1e079392d41be4e33e019fceb..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/cookie.mli +++ /dev/null @@ -1,93 +0,0 @@ -(*{{{ Copyright (C) <2012> Anil Madhavapeddy - * Copyright (C) <2009> David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** Functions for the HTTP Cookie and Set-Cookie header fields. Using the - Set-Cookie header field, an HTTP server can pass name/value pairs and - associated metadata (called cookies) to a user agent. When the user agent - makes subsequent requests to the server, the user agent uses the metadata - and other information to determine whether to return the name/value pairs in - the Cookie header. *) - -type expiration = - [ `Session - (** Instructs the user agent to discard the cookie unconditionally when the - user agent terminates. *) - | `Max_age of int64 - (** The value of the Max-Age attribute is delta-seconds, the lifetime of the - cookie in seconds, a decimal non-negative integer. *) ] -[@@deriving sexp] -(** Lifetime of the cookie after which the user agent discards it *) - -type cookie = string * string -(** A cookie is simply a key/value pair send from the client to the server *) - -module Set_cookie_hdr : sig - type t = { - cookie : cookie; - expiration : expiration; - domain : string option; - path : string option; - secure : bool; - http_only : bool; - } - [@@deriving sexp] - (** A header which a server sends to a client to request that the client - returns the cookie in future requests, under certain conditions. *) - - val make : - ?expiration:expiration -> - ?path:string -> - ?domain:string -> - ?secure:bool -> - ?http_only:bool -> - cookie -> - t - - val serialize : ?version:[ `HTTP_1_0 | `HTTP_1_1 ] -> t -> string * string - (** Return an HTTP header *) - - val extract : Header.t -> (string * t) list - (** Return the list of cookies sent by the server *) - - val cookie : t -> cookie - (** The name-value binding *) - - val value : t -> string - (** The value *) - - val expiration : t -> expiration - (** The expiration *) - - val domain : t -> string option - (** The domain for which the cookie is valid, if any *) - - val path : t -> string option - (** The path for which the cookie is valid, if any *) - - val secure : t -> bool - (** Has the cookie's secure attribute been set? *) - - val http_only : t -> bool -end - -module Cookie_hdr : sig - val extract : Header.t -> cookie list - (** Return the list of cookies sent by the client *) - - val serialize : cookie list -> string * string - (** [serialize cookies] returns an HTTP header containing [cookies] *) -end diff --git a/cohttp/cohttp/src/dune b/cohttp/cohttp/src/dune deleted file mode 100644 index c115ca1e613335b63311e9c4eaf6b7a0f97b8da5..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/dune +++ /dev/null @@ -1,25 +0,0 @@ -(rule - (with-stdout-to - conf.ml - (echo "let version = \"%{version:cohttp}\""))) - -(rule - (targets code.ml code.mli) - (deps - (source_tree "../scripts/codes")) - (action - (chdir - "../scripts" - (run ./generate.exe)))) - -(library - (name cohttp) - (public_name cohttp) - (synopsis "Co-operative Client/Server HTTP library.") - (preprocess - (pps ppx_sexp_conv)) - (libraries re stringext uri uri-sexp sexplib0 bytes base64)) - -(ocamllex accept_lexer) - -(ocamlyacc accept_parser) diff --git a/cohttp/cohttp/src/header.ml b/cohttp/cohttp/src/header.ml deleted file mode 100644 index f4995c07ed55fe4ac03a17ee50a51cefe044c71d..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/header.ml +++ /dev/null @@ -1,364 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * Copyright (c) 2011-2012 Martin Jambon - * Copyright (c) 2010 Mika Illouz - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -let caseless_equal a b = - if a == b then true - else - let len = String.length a in - len = String.length b - && - let stop = ref false in - let idx = ref 0 in - while (not !stop) && !idx < len do - let c1 = String.unsafe_get a !idx in - let c2 = String.unsafe_get b !idx in - if Char.lowercase_ascii c1 <> Char.lowercase_ascii c2 then stop := true; - incr idx - done; - not !stop - -type t = (string * string) list - -let compare = Stdlib.compare -let init () = [] -let is_empty = function [] -> true | _ -> false -let init_with k v = [ (k, v) ] - -let mem h k = - let rec loop = function - | [] -> false - | (k', _) :: h' -> if caseless_equal k k' then true else loop h' - in - loop h - -let add h k v : t = (k, v) :: h -let add_list h l = List.fold_left (fun h (k, v) -> add h k v) h l -let add_multi h k l = List.fold_left (fun h v -> add h k v) h l - -let add_opt h_opt k v = - match h_opt with None -> init_with k v | Some h -> add h k v - -let add_unless_exists h k v = if mem h k then h else add h k v - -let add_opt_unless_exists h k v = - match h with None -> init_with k v | Some h -> add_unless_exists h k v - -let get h k = - let rec loop h = - match h with - | [] -> None - | (k', v) :: h' -> if caseless_equal k k' then Some v else loop h' - in - loop h - -let get_multi (h : t) (k : string) = - let rec loop h acc = - match h with - | [] -> acc - | (k', v) :: h' -> - if caseless_equal k k' then loop h' (v :: acc) else loop h' acc - in - loop h [] - -let remove h k = - let rec loop seen = function - | [] -> if seen then [] else raise Not_found - | (k', _) :: h when caseless_equal k k' -> loop true h - | x :: h -> x :: loop seen h - in - try loop false h with Not_found -> h - -let remove_last h k = - let rec loop seen = function - | [] -> raise Not_found - | (k', _) :: h when caseless_equal k k' -> h - | x :: h -> x :: loop seen h - in - try loop false h with Not_found -> h - -let replace_ last h k v = - let rec loop seen = function - | [] -> if seen then [] else raise Not_found - | (k'', _) :: h when caseless_equal k k'' -> - if last then (k'', v) :: h - else if not seen then (k, v) :: loop true h - else loop seen h - | x :: h -> x :: loop seen h - in - try loop false h with Not_found -> add h k v - -let replace = replace_ false - -let update h k f = - let vorig = get h k in - match (f vorig, vorig) with - | None, None -> h - | None, _ -> remove_last h k - | Some s, Some s' when s == s' -> h - | Some s, _ -> replace_ true h k s - -let update_all h k f = - let vorig = get_multi h k in - match (f vorig, vorig) with - | [], [] -> h - | [], _ -> remove h k - | xs, xs' when xs = xs' -> h - | xs, _ -> - let h = remove h k in - add_multi h k xs - -let map (f : string -> string -> string) (h : t) : t = - List.map - (fun (k, v) -> - let vs' = f k v in - (k, vs')) - h - -let iter (f : string -> string -> unit) (h : t) : unit = - List.iter (fun (k, v) -> f k v) h - -let fold (f : string -> string -> 'a -> 'a) (h : t) (init : 'a) : 'a = - List.fold_left (fun acc (k, v) -> f k v acc) init h - -let of_list h = List.rev h -let to_list h = List.rev h - -let to_lines (h : t) = - let header_line k v = Printf.sprintf "%s: %s\r\n" k v in - List.fold_left (fun acc (k, v) -> header_line k v :: acc) [] h - -let to_frames h = - let to_frame k v = Printf.sprintf "%s: %s" k v in - List.fold_left (fun acc (k, v) -> to_frame k v :: acc) [] h - -let to_string h = - let b = Buffer.create 128 in - to_list h - |> List.iter (fun (k, v) -> - Buffer.add_string b k; - Buffer.add_string b ": "; - Buffer.add_string b v; - Buffer.add_string b "\r\n"); - Buffer.add_string b "\r\n"; - Buffer.contents b - -let headers_with_list_values = - [| - "accept"; - "accept-charset"; - "accept-encoding"; - "accept-language"; - "accept-ranges"; - "allow"; - "cache-control"; - "connection"; - "content-encoding"; - "content-language"; - "expect"; - "if-match"; - "if-none-match"; - "link"; - "pragma"; - "proxy-authenticate"; - "te"; - "trailer"; - "transfer-encoding"; - "upgrade"; - "vary"; - "via"; - "warning"; - "www-authenticate"; - |] - -let is_header_with_list_value = - let tbl = Hashtbl.create (Array.length headers_with_list_values) in - headers_with_list_values |> Array.iter (fun h -> Hashtbl.add tbl h ()); - fun h -> Hashtbl.mem tbl h - -let is_set_cookie k = caseless_equal k "set-cookie" - -(* set-cookie is an exception according to - {{:https://tools.ietf.org/html/rfc7230#section-3.2.2} - RFC7230§3.2.2} and can appear multiple times in a response message. -*) -let clean_dup (h : t) : t = - let add h k v = - if is_set_cookie k then (k, v) :: h - else - let to_add = ref false in - let rec loop = function - | [] -> - to_add := true; - [] - | (k', v') :: hs -> - if caseless_equal k k' then - if is_header_with_list_value k then (k, v' ^ "," ^ v) :: hs - else ( - to_add := true; - hs) - else (k', v') :: loop hs - in - let h = loop h in - if !to_add then (k, v) :: h else h - in - List.rev h |> List.fold_left (fun acc (k, v) -> add acc k v) [] - -let get_multi_concat ?(list_value_only = false) h k : string option = - if (not list_value_only) || is_header_with_list_value k then - let vs = get_multi h k in - match vs with [] -> None | _ -> Some (String.concat "," vs) - else get h k - -let parse_content_range s = - try - let start, fini, total = - Scanf.sscanf s "bytes %Ld-%Ld/%Ld" (fun start fini total -> - (start, fini, total)) - in - Some (start, fini, total) - with Scanf.Scan_failure _ -> None - -(* If we see a "Content-Range" header, than we should limit the - number of bytes we attempt to read *) -let get_content_range headers = - match get headers "content-length" with - | Some clen -> ( try Some (Int64.of_string clen) with _ -> None) - | None -> ( - match get headers "content-range" with - | Some range_s -> ( - match parse_content_range range_s with - | Some (start, fini, total) -> - (* some sanity checking before we act on these values *) - if fini < total && start <= total && 0L <= start && 0L <= total - then - let num_bytes_to_read = Int64.add (Int64.sub fini start) 1L in - Some num_bytes_to_read - else None - | None -> None) - | None -> None) - -let get_connection_close headers = - match get headers "connection" with Some "close" -> true | _ -> false - -let media_type_re = - let re = Re.Emacs.re ~case:true "[ \t]*\\([^ \t;]+\\)" in - Re.(compile (seq [ start; re ])) - -let get_first_match _re s = - try - let subs = Re.exec ~pos:0 media_type_re s in - let start, stop = Re.Group.offset subs 1 in - Some (String.sub s start (stop - start)) - with Not_found -> None - -(* Grab "foo/bar" from " foo/bar ; charset=UTF-8" *) -let get_media_type headers = - match get headers "content-type" with - | Some s -> get_first_match media_type_re s - | None -> None - -let get_acceptable_media_ranges headers = - Accept.media_ranges (get_multi_concat ~list_value_only:true headers "accept") - -let get_acceptable_charsets headers = - Accept.charsets - (get_multi_concat ~list_value_only:true headers "accept-charset") - -let get_acceptable_encodings headers = - Accept.encodings - (get_multi_concat ~list_value_only:true headers "accept-encoding") - -let get_acceptable_languages headers = - Accept.languages - (get_multi_concat ~list_value_only:true headers "accept-language") - -(* Parse the transfer-encoding and content-length headers to - * determine how to decode a body *) -let get_transfer_encoding headers = - (* It should actually be [get] as the interresting value is actually the last.*) - match get_multi_concat ~list_value_only:true headers "transfer-encoding" with - | Some "chunked" -> Transfer.Chunked - | Some _ | None -> ( - match get_content_range headers with - | Some len -> Transfer.Fixed len - | None -> Transfer.Unknown) - -let add_transfer_encoding headers enc = - let open Transfer in - (* Only add a header if one doesnt already exist, e.g. from the app *) - match (get_transfer_encoding headers, enc) with - | Fixed _, _ (* App has supplied a content length, so use that *) | Chunked, _ - -> - headers (* TODO: this is a protocol violation *) - | Unknown, Chunked -> add headers "transfer-encoding" "chunked" - | Unknown, Fixed len -> add headers "content-length" (Int64.to_string len) - | Unknown, Unknown -> headers - -let add_authorization_req headers challenge = - add headers "www-authenticate" (Auth.string_of_challenge challenge) - -let add_authorization headers cred = - add headers "authorization" (Auth.string_of_credential cred) - -let get_authorization headers = - match get headers "authorization" with - | None -> None - | Some v -> Some (Auth.credential_of_string v) - -let is_form headers = - get_media_type headers = Some "application/x-www-form-urlencoded" - -let get_location headers = - match get headers "location" with - | None -> None - | Some u -> Some (Uri.of_string u) - -let get_links headers = - List.rev - (List.fold_left - (fun list link_s -> List.rev_append (Link.of_string link_s) list) - [] (get_multi headers "link")) - -let add_links headers links = - add_multi headers "link" (List.map Link.to_string links) - -let user_agent = Printf.sprintf "ocaml-cohttp/%s" Conf.version - -let prepend_user_agent headers user_agent = - let k = "user-agent" in - match get headers k with - | Some ua -> replace headers k (user_agent ^ " " ^ ua) - | None -> add headers k user_agent - -let connection h = - match get h "connection" with - | Some v when v = "keep-alive" -> Some `Keep_alive - | Some v when v = "close" -> Some `Close - | Some x -> Some (`Unknown x) - | _ -> None - -open Sexplib0.Sexp_conv - -let sexp_of_t t = - sexp_of_list (sexp_of_pair sexp_of_string sexp_of_string) (to_list t) - -let t_of_sexp s = - of_list (list_of_sexp (pair_of_sexp string_of_sexp string_of_sexp) s) - -let pp_hum ppf h = - Format.fprintf ppf "%s" (h |> sexp_of_t |> Sexplib0.Sexp.to_string_hum) diff --git a/cohttp/cohttp/src/header.mli b/cohttp/cohttp/src/header.mli deleted file mode 100644 index 38d6823c991faa9fd7ba58e5a64ab5ddb91154c4..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/header.mli +++ /dev/null @@ -1,219 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** Associative list representing HTTP headers. Order of transmission is - preserved, which implies that headers with same name are neither removed or - concataned by default (see [clean_dup] to do that). *) -type t [@@deriving sexp] -(** The type for HTTP headers. *) - -val init : unit -> t -(** [init ()] constructs a fresh, empty list of HTTP headers. *) - -val is_empty : t -> bool -(** [is_empty h] tests whether HTTP headers [h] are empty or not. *) - -val of_list : (string * string) list -> t -(** [of_list l] construct a fresh headers from the content of [l] and in same - order. [to_list] and [of_list] are defined such as [to_list (of_list l) = l] - is true with case insensitive comparison. *) - -val to_list : t -> (string * string) list -(** [to_list h] converts HTTP headers [h] to a list. Order and case is - preserved. - - {e Invariant (with case insensitive comparison):} [to_list (of_list l) = l] *) - -val init_with : string -> string -> t -(** [init_with k v] construct a fresh HTTP headers with a single header with - name [k] and value [v]. *) - -val add : t -> string -> string -> t -(** [add h k v] adds the header name [k] and it associated value [v] at the end - of header list [h]. *) - -val add_list : t -> (string * string) list -> t -(** [add_list h l] adds in order all header pairs contained in [l] to the header - list [h]. - - {e Invariant (with case insensitive comparison):} - [to_list (add_list h l) = to_list h @ l] *) - -val add_multi : t -> string -> string list -> t -(** [add_multi h k vs] add multiple header pairs with same name [h] and values - contained in [vs] in [h]. The new headers are in the same order that in - [vs]. - - {e Invariant:} [get_multi (add_multi h k vs) k = (get_multi h k) @ vs] *) - -val add_opt : t option -> string -> string -> t -(** [add_opt hopt k v] adds the header [(k, v)] to [h] if [hopt] is [Some h], or - constructs a fresh header list containing this single header if [hopt] is - [None]. *) - -val add_unless_exists : t -> string -> string -> t -(** [add_unless_exists h k v] adds [(k, v)] to [h] unless the header name [k] is - already present in the header. *) - -val add_opt_unless_exists : t option -> string -> string -> t -(** [add_opt_unless_exists h k v] adds [(k, v)] to [h] if [hopt] is [Some h] - unless the header name [k] is already present in the headers. If [h] is - [None] then a fresh header list is constructed containing the header - [(k, v)]. *) - -val remove : t -> string -> t -(** [remove h k] removes every values associated to the header name [k] from - [h]. *) - -val replace : t -> string -> string -> t -(** [replace h k v] replaces the last added value of [k] from [h] and removed - all other occurences of [k] if it exists. Otherwise it adds [(k, v)] to [h]. - - {e Invariant:} [forall h, k, v. get_multi (replace h k v) = \[ v \]] *) - -val mem : t -> string -> bool -(** [mem h k] returns [true] if the header name [k] appears in [h] and [false] - otherwise. *) - -val compare : t -> t -> int -(** [compare h h'] is the structural comparison of two [Header] values. *) - -val get : t -> string -> string option -(** [get h k] returns [Some v] where [v] is the last added value associated with - [k] in [h] if it exists and [None] otherwise *) - -val get_multi : t -> string -> string list -(** [get_multi h k] returns a list of all values associated with [k] in [h] in - order they appear in it. *) - -val get_multi_concat : ?list_value_only:bool -> t -> string -> string option -(** [get_multi_concat h k] returns [Some v] if there is at least one value - associated with [k] in [h] and [None] otherwise. [v] is the concatenation of - all values paired with [k] in [h], separated by a comma and in order they - appear in [h]. - - The optional argument [?list_value_only] is [false] by default. If it is - [true] and there is at least one value associated to [k], the returned value - is the concatenated values only if [k] is a header that can have multiple - values (like transfer-encoding or accept). Otherwise, the returned value is - the last value paired with [k] in [h]. - - {e Invariant:} - [forall h, k not a list-value header. get_multi_concat ~list-value-only:true h k = get h k] *) - -val update : t -> string -> (string option -> string option) -> t -(** [update h k f] returns an header list containing the same headers as [h], - except for the header name [k]. Depending on the value of [v] where [v] is - [f (get h k)], the header pair [(k, v)] is added, removed or updated. - - - If [v] is [None], the last 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; - - - 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 to_lines : t -> string list -(** [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 -(** [to_frames h] returns the same as {!to_lines} but lines do not end with - "\r\n" characters. *) - -val to_string : t -> string - -val clean_dup : t -> t -(** [clean_dup h] cleans duplicates in [h] following - {{:https://tools.ietf.org/html/rfc7230#section-3.2.2} RFC7230§3.2.2}; if a - duplicated header can not have multiple values, only the last value is kept - in place. Otherwise, the values are concatenated and place at the first - position the header is encountered in [h]. - - Already concatenated values (like [anhost.com, anotherhost.com] in the - example below) are not affected by [clean_dup]. For example, - - {v - transfer-encoding: gzip - host: afirsthost.com - connection: keep-alive - host: anhost.com, anotherhost.com - transfer-encoding: chunked - v} - - becomes - - {v - transfer-encoding: gzip, chunked - connection: keep-alive - host: anhost.com, anotherhost.com - v} - - Finally, following {{:https://tools.ietf.org/html/rfc7230#section-3.2.2} - RFC7230§3.2.2}, the header [Set-cookie] is treated as an exception and - ignored by [clean_dup]. *) - -val get_content_range : t -> Int64.t option -val get_media_type : t -> string option -val get_connection_close : t -> bool - -val get_acceptable_media_ranges : - t -> (Accept.media_range * Accept.p list) Accept.qlist - -val get_acceptable_charsets : t -> Accept.charset Accept.qlist -val get_acceptable_encodings : t -> Accept.encoding Accept.qlist -val get_acceptable_languages : t -> Accept.language Accept.qlist -val get_transfer_encoding : t -> Transfer.encoding -val add_transfer_encoding : t -> Transfer.encoding -> t -val add_authorization : t -> Auth.credential -> t -val get_authorization : t -> Auth.credential option -val add_authorization_req : t -> Auth.challenge -> t -val is_form : t -> bool -val get_location : t -> Uri.t option -val add_links : t -> Link.t list -> t -val get_links : t -> Link.t list - -val user_agent : string -(** The User-Agent header used by this library, including the version of cohttp. *) - -val prepend_user_agent : t -> string -> t -(** Prepend [user_agent] to the product token already declared in the - "User-Agent" field (if any). *) - -val connection : t -> [ `Keep_alive | `Close | `Unknown of string ] option - -val pp_hum : Format.formatter -> t -> unit -(** Human-readable output, used by the toplevel printer *) diff --git a/cohttp/cohttp/src/header_io.ml b/cohttp/cohttp/src/header_io.ml deleted file mode 100644 index eb12ae962c0122827252ef618aceb649a372aa35..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/header_io.ml +++ /dev/null @@ -1,41 +0,0 @@ -(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy - * Copyright (c) 2011-2012 Martin Jambon - * Copyright (c) 2010 Mika Illouz - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -let split_header str = - match Stringext.split ~max:2 ~on:':' str with - | [ x; y ] -> [ x; String.trim y ] - | x -> x - -module Make (IO : S.IO) = struct - open IO - module Transfer_IO = Transfer_io.Make (IO) - - let parse ic = - (* consume also trailing "^\r\n$" line *) - let rec parse_headers' headers = - read_line ic >>= function - | Some "" | None -> return headers - | Some line -> ( - match split_header line with - | [ hd; tl ] -> parse_headers' (Header.add headers hd tl) - | _ -> return headers) - in - parse_headers' (Header.init ()) - - let write headers oc = IO.write oc (Header.to_string headers) -end diff --git a/cohttp/cohttp/src/header_io.mli b/cohttp/cohttp/src/header_io.mli deleted file mode 100644 index 0274fc953413a62b4719526691ec6a7b83c8a2cd..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/header_io.mli +++ /dev/null @@ -1,20 +0,0 @@ -(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -module Make (IO : S.IO) : sig - val parse : IO.ic -> Header.t IO.t - val write : Header.t -> IO.oc -> unit IO.t -end diff --git a/cohttp/cohttp/src/link.ml b/cohttp/cohttp/src/link.ml deleted file mode 100644 index 0343df62d76b615e7debfd271b0ec7b53d99710a..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/link.ml +++ /dev/null @@ -1,536 +0,0 @@ -(*{{{ Copyright (c) 2015 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Sexplib0.Sexp_conv - -(* From *) -module Rel = struct - type t = - | Extension of Uri_sexp.t - | Alternate - | Appendix - | Bookmark - | Chapter - | Contents - | Copyright - | Current - | Described_by - | Edit - | Edit_media - | Enclosure - | First - | Glossary - | Help - | Hub - | Index - | Last - | Latest_version - | License - | Next - | Next_archive - | Payment - | Predecessor_version - | Prev - | Prev_archive - | Related - | Replies - | Section - | Self - | Service - | Start - | Stylesheet - | Subsection - | Successor_version - | Up - | Version_history - | Via - | Working_copy - | Working_copy_of - [@@deriving sexp] - - let extension uri = Extension uri - let alternate = Alternate - let appendix = Appendix - let bookmark = Bookmark - let chapter = Chapter - let contents = Contents - let copyright = Copyright - let current = Current - let described_by = Described_by - let edit = Edit - let edit_media = Edit_media - let enclosure = Enclosure - let first = First - let glossary = Glossary - let help = Help - let hub = Hub - let index = Index - let last = Last - let latest_version = Latest_version - let license = License - let next = Next - let next_archive = Next_archive - let payment = Payment - let predecessor_version = Predecessor_version - let prev = Prev - let prev_archive = Prev_archive - let related = Related - let replies = Replies - let section = Section - let self = Self - let service = Service - let start = Start - let stylesheet = Stylesheet - let subsection = Subsection - let successor_version = Successor_version - let up = Up - let version_history = Version_history - let via = Via - let working_copy = Working_copy - let working_copy_of = Working_copy_of -end - -module Language = struct - type t = string [@@deriving sexp] - - let to_string x = x - let of_string x = x -end - -module Charset = struct - type t = string [@@deriving sexp] - - let to_string x = x - let of_string x = x -end - -module Ext = struct - type 'a t = { charset : Charset.t; language : Language.t; value : 'a } - [@@deriving sexp] - - let charset t = t.charset - let language t = t.language - let value t = t.value - let make ?(charset = "") ?(language = "") value = { charset; language; value } - let map f x = { x with value = f x.value } -end - -module Arc = struct - type t = { - reverse : bool; - relation : Rel.t list; - hreflang : string option; - media : string option; - title : string option; - title_ext : string Ext.t option; - media_type : (string * string) option; - extensions : (string * string) list; - extension_exts : (string * string Ext.t) list; - } - [@@deriving sexp] - - let empty = - { - reverse = false; - relation = []; - hreflang = None; - media = None; - title = None; - title_ext = None; - media_type = None; - extensions = []; - extension_exts = []; - } -end - -type t = { context : Uri_sexp.t; arc : Arc.t; target : Uri_sexp.t } -[@@deriving sexp] - -(* TODO: this could be replaced with empty t/arc fupdate *) -type param = - | Rel of Rel.t list - | Anchor of Uri.t - | Rev of Rel.t list - | Hreflang of Language.t - | Media of string - | Title of string - | Star of param Ext.t - | Type of (string * string) - | Link_extension of string * string - -let until s start cl = - let nextl = - List.map - (fun c -> - let pattern = String.make 1 c in - Stringext.find_from ~start s ~pattern) - cl - in - let min = - List.fold_left - (fun min_opt i_opt -> - match (min_opt, i_opt) with - | None, None -> None - | Some i, None | None, Some i -> Some i - | Some i, Some j -> Some (min i j)) - None nextl - in - match min with - | None -> (Stringext.string_after s start, String.length s) - | Some i -> (String.sub s start (i - start), i) - -let string_of_rel = - Rel.( - function - | Alternate -> "alternate" - | Appendix -> "appendix" - | Bookmark -> "bookmark" - | Chapter -> "chapter" - | Contents -> "contents" - | Copyright -> "copyright" - | Current -> "current" - | Described_by -> "describedby" - | Edit -> "edit" - | Edit_media -> "edit-media" - | Enclosure -> "enclosure" - | First -> "first" - | Glossary -> "glossary" - | Help -> "help" - | Hub -> "hub" - | Index -> "index" - | Last -> "last" - | Latest_version -> "latest-version" - | License -> "license" - | Next -> "next" - | Next_archive -> "next-archive" - | Payment -> "payment" - | Predecessor_version -> "predecessor-version" - | Prev -> "prev" - | Prev_archive -> "prev-archive" - | Related -> "related" - | Replies -> "replies" - | Section -> "section" - | Self -> "self" - | Service -> "service" - | Start -> "start" - | Stylesheet -> "stylesheet" - | Subsection -> "subsection" - | Successor_version -> "successor-version" - | Up -> "up" - | Version_history -> "version-history" - | Via -> "via" - | Working_copy -> "working-copy" - | Working_copy_of -> "working-copy-of" - | Extension uri -> Uri.to_string uri) - -let rel_of_string s = - Rel.( - try - ignore (String.index s ':'); - Extension (Uri.of_string s) - with Not_found -> ( - match s with - | "alternate" -> Alternate - | "appendix" -> Appendix - | "bookmark" -> Bookmark - | "chapter" -> Chapter - | "contents" -> Contents - | "copyright" -> Copyright - | "current" -> Current - | "describedby" -> Described_by - | "edit" -> Edit - | "edit-media" -> Edit_media - | "enclosure" -> Enclosure - | "first" -> First - | "glossary" -> Glossary - | "help" -> Help - | "hub" -> Hub - | "index" -> Index - | "last" -> Last - | "latest-version" -> Latest_version - | "license" -> License - | "next" -> Next - | "next-archive" -> Next_archive - | "payment" -> Payment - | "predecessor-version" -> Predecessor_version - | "prev" | "previous" -> Prev - | "prev-archive" -> Prev_archive - | "related" -> Related - | "replies" -> Replies - | "section" -> Section - | "self" -> Self - | "service" -> Service - | "start" -> Start - | "stylesheet" -> Stylesheet - | "subsection" -> Subsection - | "successor-version" -> Successor_version - | "up" -> Up - | "version-history" -> Version_history - | "via" -> Via - | "working-copy" -> Working_copy - | "working-copy-of" -> Working_copy_of - | _ -> Extension (Uri.of_string s))) - -let quoted_string_of_string s q = - let rec first_quote q = - match s.[q] with - | ' ' -> first_quote (q + 1) - | '"' -> ( - let q = q + 1 in - match Stringext.find_from ~start:q s ~pattern:"\"" with - | None -> (Stringext.string_after s q, String.length s) - | Some q' -> (String.sub s q (q' - q), q' + 1)) - | _ -> until s q [ ';'; ',' ] - in - first_quote q - -let rels_of_string_ s q = - let qs, i = quoted_string_of_string s q in - let rels = Stringext.split qs ~on:' ' in - (List.map rel_of_string (List.filter (fun s -> String.length s > 0) rels), i) - -let rels_of_string s i = - match - (Stringext.find_from ~start:i s ~pattern:"\"", until s i [ ';'; ',' ]) - with - | Some q, (_, d) when q < d -> rels_of_string_ s q - | _, (s, d) -> ([ rel_of_string s ], d) - -let anchor_of_string s i = - let qs, i = quoted_string_of_string s i in - (Uri.of_string qs, i) - -let star_of_string s i = - match Stringext.find_from ~start:i s ~pattern:"'" with - | None -> - let s, i = quoted_string_of_string s i in - ("", "", s, i) - | Some a -> ( - let charset = String.sub s i (a - i) in - let i = a + 1 in - match Stringext.find_from ~start:i s ~pattern:"'" with - | None -> - let s, i = quoted_string_of_string s i in - (charset, "", s, i) - | Some a -> - let language = String.sub s i (a - i) in - let i = a + 1 in - let s, i = quoted_string_of_string s i in - (charset, language, s, i)) - -let media_type_of_string s i = - let mt, i = quoted_string_of_string s i in - match Stringext.split ~max:2 mt ~on:'/' with - | [] -> (("", ""), i) - | [ t ] -> ((t, ""), i) - | t :: st :: _ -> ((t, st), i) - -let rec params_of_string s i ps = - let _, d = until s i [ ';'; ',' ] in - if d = String.length s then (ps, None) - else if s.[d] = ',' then (ps, Some d) - else - let i = d + 1 in - let param, i = until s i [ '=' ] in - let i = i + 1 in - match String.trim param with - | "rel" -> - let rels, i = rels_of_string s i in - params_of_string s i (Rel rels :: ps) - | "anchor" -> - let uri, i = anchor_of_string s i in - params_of_string s i (Anchor uri :: ps) - | "rev" -> - let rels, i = rels_of_string s i in - params_of_string s i (Rev rels :: ps) - | "hreflang" -> - let hreflang, i = until s i [ ','; ';' ] in - params_of_string s i (Hreflang hreflang :: ps) - | "media" -> - let media, i = quoted_string_of_string s i in - params_of_string s i (Media media :: ps) - | "title" -> - let title, i = quoted_string_of_string s i in - params_of_string s i (Title title :: ps) - | "title*" -> - let charset, language, v, i = star_of_string s i in - params_of_string s i - (Star { Ext.charset; language; value = Title v } :: ps) - | "type" -> - let media_type, i = media_type_of_string s i in - params_of_string s i (Type media_type :: ps) - | other when String.length other = 0 -> - let s, i = quoted_string_of_string s i in - params_of_string s i (Link_extension ("", s) :: ps) - | other -> - let last = String.length other - 1 in - if other.[last] = '*' then - let main = String.sub other 0 last in - let charset, language, v, i = star_of_string s i in - params_of_string s i - (Star { Ext.charset; language; value = Link_extension (main, v) } - :: ps) - else - let v, i = quoted_string_of_string s i in - params_of_string s i (Link_extension (other, v) :: ps) - -let rec find_or_default f d = function - | [] -> d - | h :: t -> ( match f h with None -> find_or_default f d t | Some v -> v) - -let arc_of_relation_params ?(reverse = false) relation params = - let extensions, extension_exts = - List.fold_left - (fun (x, xx) -> function - | Link_extension (k, v) -> ((k, v) :: x, xx) - | Star { Ext.charset; language; value = Link_extension (k, value) } -> - (x, (k, { Ext.charset; language; value }) :: xx) - | _ -> (x, xx)) - ([], []) params - in - { - Arc.reverse; - relation; - hreflang = - find_or_default - (function Hreflang l -> Some (Some l) | _ -> None) - None params; - media = - find_or_default - (function Media m -> Some (Some m) | _ -> None) - None params; - title = - find_or_default - (function Title t -> Some (Some t) | _ -> None) - None params; - title_ext = - find_or_default - (function - | Star { Ext.charset; language; value = Title t } -> - Some (Some { Ext.charset; language; value = t }) - | _ -> None) - None params; - media_type = - find_or_default - (function Type mt -> Some (Some mt) | _ -> None) - None params; - extensions; - extension_exts; - } - -let empty = - { context = Uri.of_string ""; arc = Arc.empty; target = Uri.of_string "" } - -let rec unfold s list start = - match Stringext.find_from ~start s ~pattern:"<" with - | None -> list - | Some i -> ( - let uri_ref, i = until s (i + 1) [ '>' ] in - let i = i + 1 in - let target = Uri.of_string uri_ref in - let params, c_opt = params_of_string s i [] in - let params = List.rev params in - let context = - find_or_default - (function Anchor uri -> Some uri | _ -> None) - (Uri.of_string "") params - in - let link = - match - find_or_default - (function Rel rels -> Some rels | _ -> None) - [] params - with - | _ :: _ as relation -> - let arc = arc_of_relation_params relation params in - { context; arc; target } - | [] -> ( - match - find_or_default - (function Rev rels -> Some rels | _ -> None) - [] params - with - | [] -> - let arc = arc_of_relation_params [] params in - { context; arc; target } - | rev -> - let arc = arc_of_relation_params ~reverse:true rev params in - { context = target; arc; target = context }) - in - let list = link :: list in - match c_opt with None -> list | Some c -> unfold s list c) - -let of_string s = List.rev (unfold s [] 0) - -open Printf - -let arc_to_string context arc = - Arc.( - let attrs = - match arc.relation with - | [] -> [] - | rels -> - [ - sprintf "%s=\"%s\"" - (if arc.reverse then "rev" else "rel") - (String.concat " " (List.map string_of_rel rels)); - ] - in - let attrs = - match arc.hreflang with - | None -> attrs - | Some s -> ("hreflang=" ^ s) :: attrs - in - let attrs = - match arc.media with - | None -> attrs - | Some s -> sprintf "media=\"%s\"" s :: attrs - in - let attrs = - match arc.title with - | None -> attrs - | Some s -> sprintf "title=%S" s :: attrs - (* TODO: this isn't quite right...*) - in - let attrs = - match arc.title_ext with - | None -> attrs - | Some { Ext.charset; language; value } -> - sprintf "title*=%s'%s'%s" charset language value :: attrs - in - let attrs = - match arc.media_type with - | None -> attrs - | Some (typ, sub) -> sprintf "type=%s/%s" typ sub :: attrs - in - let attrs = - List.map (fun (k, v) -> sprintf "%s=%S" k v) arc.extensions @ attrs - in - let attrs = - List.map - (fun (k, { Ext.charset; language; value }) -> - sprintf "%s=%s'%s'%s" k charset language value) - arc.extension_exts - @ attrs - in - let attrs = - if context = Uri.of_string "" then attrs - else sprintf "anchor=\"%s\"" (Uri.to_string context) :: attrs - in - String.concat "; " attrs) - -let to_string { context; arc; target } = - sprintf "<%s>; %s" (Uri.to_string target) (arc_to_string context arc) diff --git a/cohttp/cohttp/src/link.mli b/cohttp/cohttp/src/link.mli deleted file mode 100644 index 8f32cda922222ca59e7f787d337bbc6162882249..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/link.mli +++ /dev/null @@ -1,109 +0,0 @@ -(*{{{ Copyright (c) 2015 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** RFC 5988 ("Web Linking") and RFC 5987 ("Character Set and Language Encoding - for Hypertext Transfer Protocol (HTTP) Header Field Parameters") *) - -module Rel : sig - type t [@@deriving sexp] - - val extension : Uri.t -> t - val alternate : t - val appendix : t - val bookmark : t - val chapter : t - val contents : t - val copyright : t - val current : t - val described_by : t - val edit : t - val edit_media : t - val enclosure : t - val first : t - val glossary : t - val help : t - val hub : t - val index : t - val last : t - val latest_version : t - val license : t - val next : t - val next_archive : t - val payment : t - val predecessor_version : t - val prev : t - val prev_archive : t - val related : t - val replies : t - val section : t - val self : t - val service : t - val start : t - val stylesheet : t - val subsection : t - val successor_version : t - val up : t - val version_history : t - val via : t - val working_copy : t - val working_copy_of : t -end - -module Language : sig - type t = private string [@@deriving sexp] - - val to_string : t -> string - val of_string : string -> t -end - -module Charset : sig - type t = private string [@@deriving sexp] - - val to_string : t -> string - val of_string : string -> t -end - -module Ext : sig - type 'a t [@@deriving sexp] - - val charset : 'a t -> Charset.t - val language : 'a t -> Language.t - val value : 'a t -> 'a - val make : ?charset:Charset.t -> ?language:Language.t -> 'a -> 'a t - val map : ('a -> 'b) -> 'a t -> 'b t -end - -module Arc : sig - type t = { - reverse : bool; - relation : Rel.t list; - hreflang : string option; - media : string option; - title : string option; - title_ext : string Ext.t option; - media_type : (string * string) option; - extensions : (string * string) list; - extension_exts : (string * string Ext.t) list; - } - - val empty : t -end - -type t = { context : Uri.t; arc : Arc.t; target : Uri.t } [@@deriving sexp] - -val empty : t -val of_string : string -> t list -val to_string : t -> string diff --git a/cohttp/cohttp/src/path.ml b/cohttp/cohttp/src/path.ml deleted file mode 100644 index cd614ce4c81c34ca4a47cb5df61a95de776ce55e..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/path.ml +++ /dev/null @@ -1,7 +0,0 @@ -let resolve_local_file ~docroot ~uri = - let path = Uri.(pct_decode (path (resolve "http" (of_string "/") uri))) in - let rel_path = - if String.length path > 0 then String.sub path 1 (String.length path - 1) - else "" - in - Filename.concat docroot rel_path diff --git a/cohttp/cohttp/src/path.mli b/cohttp/cohttp/src/path.mli deleted file mode 100644 index 601901553379ab492a1fdaf3f616427489691fa9..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/path.mli +++ /dev/null @@ -1,6 +0,0 @@ -val resolve_local_file : docroot:string -> uri:Uri.t -> string -(** Resolve the given URI to a local file in the given docroot. - - This decodes and normalises the Uri. It strips out .. characters so that the - request will not escape the docroot. The returned filepath is fully - qualified iff the given docroot is fully qualified. *) diff --git a/cohttp/cohttp/src/request.ml b/cohttp/cohttp/src/request.ml deleted file mode 100644 index 215086a090e371f8b2749482ad4a23aa0426c71c..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/request.ml +++ /dev/null @@ -1,242 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Sexplib0.Sexp_conv - -type t = { - headers : Header.t; - meth : Code.meth; - scheme : string option; - resource : string; - version : Code.version; - encoding : Transfer.encoding; -} -[@@deriving sexp] - -let compare x y = - match Header.compare x.headers y.headers with - | 0 -> - let headers = Header.init () in - Stdlib.compare { x with headers } { y with headers } - | i -> i - -let headers t = t.headers -let meth t = t.meth -let scheme t = t.scheme -let resource t = t.resource -let version t = t.version -let encoding t = t.encoding -let fixed_zero = Transfer.Fixed Int64.zero - -let guess_encoding ?(encoding = fixed_zero) headers = - match Header.get_transfer_encoding headers with - | Transfer.(Chunked | Fixed _) as enc -> enc - | Unknown -> encoding - -let make ?(meth = `GET) ?(version = `HTTP_1_1) ?encoding ?headers uri = - let headers = match headers with None -> Header.init () | Some h -> h in - let headers = - Header.add_unless_exists headers "host" - (match Uri.scheme uri with - | Some "httpunix" -> "" - | _ -> ( - Uri.host_with_default ~default:"localhost" uri - ^ - match Uri.port uri with Some p -> ":" ^ string_of_int p | None -> "")) - in - let headers = - Header.add_unless_exists headers "user-agent" Header.user_agent - in - let headers = - (* Add user:password auth to headers from uri - * if headers don't already have auth *) - match - (Header.get_authorization headers, Uri.user uri, Uri.password uri) - with - | None, Some user, Some pass -> - let auth = `Basic (user, pass) in - Header.add_authorization headers auth - | _, _, _ -> headers - in - let encoding = guess_encoding ?encoding headers in - { - meth; - version; - headers; - scheme = Uri.scheme uri; - resource = Uri.path_and_query uri; - encoding; - } - -let is_keep_alive { version; headers; _ } = - not - (version = `HTTP_1_0 - || match Header.connection headers with Some `Close -> true | _ -> false) - -(* Make a client request, which involves guessing encoding and - adding content headers if appropriate. - @param chunked Forces chunked encoding -*) -let make_for_client ?headers ?(chunked = true) ?(body_length = Int64.zero) meth - uri = - let encoding = - match chunked with - | true -> Transfer.Chunked - | false -> Transfer.Fixed body_length - in - make ~meth ~encoding ?headers uri - -let pp_hum ppf r = - Format.fprintf ppf "%s" (r |> sexp_of_t |> Sexplib0.Sexp.to_string_hum) - -(* Validate path when reading URI. Implemented for compatibility with old - implementation rather than efficiency *) -let is_valid_uri path meth = - path = "*" - || meth = `CONNECT - || - match Uri.scheme (Uri.of_string path) with - | Some _ -> true - | None -> not (String.length path > 0 && path.[0] <> '/') - -let uri { scheme; resource; headers; meth; _ } = - let uri = - match resource with - | "*" -> ( - match Header.get headers "host" with - | None -> Uri.of_string "" - | Some host -> - let host_uri = Uri.of_string ("//" ^ host) in - Uri.(make ?host:(host host_uri) ?port:(port host_uri) ())) - | authority when meth = `CONNECT -> Uri.of_string ("//" ^ authority) - | path -> ( - let uri = Uri.of_string path in - match Uri.scheme uri with - | Some _ -> ( - (* we have an absoluteURI *) - Uri.( - match path uri with "" -> with_path uri "/" | _ -> uri)) - | None -> - let empty = Uri.of_string "" in - let empty_base = Uri.of_string "///" in - let pqs = - match Stringext.split ~max:2 path ~on:'?' with - | [] -> empty_base - | [ path ] -> - Uri.resolve "http" empty_base (Uri.with_path empty path) - | path :: qs :: _ -> - let path_base = - Uri.resolve "http" empty_base (Uri.with_path empty path) - in - Uri.with_query path_base (Uri.query_of_encoded qs) - in - let uri = - match Header.get headers "host" with - | None -> Uri.(with_scheme (with_host pqs None) None) - | Some host -> - let host_uri = Uri.of_string ("//" ^ host) in - let uri = Uri.with_host pqs (Uri.host host_uri) in - Uri.with_port uri (Uri.port host_uri) - in - uri) - in - (* Only set the scheme if it's not already part of the URI *) - match Uri.scheme uri with Some _ -> uri | None -> Uri.with_scheme uri scheme - -type tt = t - -module Make (IO : S.IO) = struct - type t = tt - - module IO = IO - module Header_IO = Header_io.Make (IO) - module Transfer_IO = Transfer_io.Make (IO) - - type reader = Transfer_IO.reader - type writer = Transfer_IO.writer - - open IO - - let parse_request_fst_line ic = - let open Code in - read_line ic >>= function - | Some request_line -> ( - match Stringext.split request_line ~on:' ' with - | [ meth_raw; path; http_ver_raw ] -> ( - let m = method_of_string meth_raw in - match version_of_string http_ver_raw with - | (`HTTP_1_1 | `HTTP_1_0) as v -> return (`Ok (m, path, v)) - | `Other _ -> - return - (`Invalid ("Malformed request HTTP version: " ^ http_ver_raw)) - ) - | _ -> return (`Invalid ("Malformed request header: " ^ request_line))) - | None -> return `Eof - - let read ic = - parse_request_fst_line ic >>= function - | `Eof -> return `Eof - | `Invalid _reason as r -> return r - | `Ok (meth, resource, version) -> - if is_valid_uri resource meth then - Header_IO.parse ic >>= fun headers -> - let encoding = Header.get_transfer_encoding headers in - return - (`Ok { headers; meth; scheme = None; resource; version; encoding }) - else return (`Invalid "bad request URI") - - (* Defined for method types in RFC7231 *) - let has_body req = - match req.meth with - | `GET | `HEAD | `CONNECT | `TRACE -> `No - | `DELETE | `POST | `PUT | `PATCH | `OPTIONS | `Other _ -> - Transfer.has_body req.encoding - - let make_body_reader req ic = Transfer_IO.make_reader req.encoding ic - let read_body_chunk = Transfer_IO.read - - let write_header req oc = - let fst_line = - Printf.sprintf "%s %s %s\r\n" - (Code.string_of_method req.meth) - (if req.resource = "" then "/" else req.resource) - (Code.string_of_version req.version) - in - let headers = req.headers in - let headers = - match has_body req with - | `Yes | `Unknown -> Header.add_transfer_encoding headers req.encoding - | `No -> headers - in - IO.write oc fst_line >>= fun _ -> Header_IO.write headers oc - - let make_body_writer ?flush req oc = - Transfer_IO.make_writer ?flush req.encoding oc - - let write_body = Transfer_IO.write - - let write_footer req oc = - match req.encoding with - | Transfer.Chunked -> - (* TODO Trailer header support *) - IO.write oc "0\r\n\r\n" - | Transfer.Fixed _ | Transfer.Unknown -> return () - - let write ?flush write_body req oc = - write_header req oc >>= fun () -> - let writer = make_body_writer ?flush req oc in - write_body writer >>= fun () -> write_footer req oc -end diff --git a/cohttp/cohttp/src/request.mli b/cohttp/cohttp/src/request.mli deleted file mode 100644 index 2c14bb02ee697beab3de52fb5f9f61a9bbcb8be5..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/request.mli +++ /dev/null @@ -1,32 +0,0 @@ -(*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** HTTP/1.1 request handling *) - -include S.Request -(** This contains the metadata for a HTTP/1.1 request header, including the - {!headers}, {!version}, {!meth} and {!uri}. The body is handled by the - separate {!S} module type, as it is dependent on the IO implementation. - - The interface exposes a [fieldslib] interface which provides individual - accessor functions for each of the records below. It also provides [sexp] - serializers to convert to-and-from an {!Core.Std.Sexp.t}. *) - -val pp_hum : Format.formatter -> t -> unit -(** Human-readable output, used by the toplevel printer *) - -(** Functor to construct the IO-specific HTTP request handling functions *) -module Make (IO : S.IO) : S.Http_io with type t = t and module IO = IO diff --git a/cohttp/cohttp/src/response.ml b/cohttp/cohttp/src/response.ml deleted file mode 100644 index b168ea7198b79ff58970bdab2b4acef4b3680d45..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/response.ml +++ /dev/null @@ -1,135 +0,0 @@ -(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Sexplib0.Sexp_conv - -type t = { - encoding : Transfer.encoding; - headers : Header.t; - version : Code.version; - status : Code.status_code; - flush : bool; -} -[@@deriving sexp] - -let compare x y = - match Header.compare x.headers y.headers with - | 0 -> - let headers = Header.init () in - Stdlib.compare { x with headers } { y with headers } - | i -> i - -let headers t = t.headers -let encoding t = t.encoding -let version t = t.version -let status t = t.status -let flush t = t.flush - -let make ?(version = `HTTP_1_1) ?(status = `OK) ?(flush = false) - ?(encoding = Transfer.Chunked) ?(headers = Header.init ()) () = - let encoding = - match Header.get_transfer_encoding headers with - | Transfer.(Chunked | Fixed _) as enc -> enc - | Unknown -> encoding - in - { encoding; headers; version; flush; status } - -let pp_hum ppf r = - Format.fprintf ppf "%s" (r |> sexp_of_t |> Sexplib0.Sexp.to_string_hum) - -type tt = t - -module Make (IO : S.IO) = struct - type t = tt - - module IO = IO - module Header_IO = Header_io.Make (IO) - module Transfer_IO = Transfer_io.Make (IO) - - type reader = Transfer_IO.reader - type writer = Transfer_IO.writer - - open IO - - let parse_response_fst_line ic = - let open Code in - read_line ic >>= function - | Some response_line -> ( - match Stringext.split response_line ~on:' ' with - | version_raw :: code_raw :: _ -> ( - match version_of_string version_raw with - | (`HTTP_1_0 | `HTTP_1_1) as v -> - return (`Ok (v, status_of_code (int_of_string code_raw))) - | `Other _ -> - return (`Invalid ("Malformed response version: " ^ version_raw)) - ) - | _ -> - return - (`Invalid ("Malformed response first line: " ^ response_line))) - | None -> return `Eof - - let read ic = - parse_response_fst_line ic >>= function - | `Eof -> return `Eof - | `Invalid _reason as r -> return r - | `Ok (version, status) -> - Header_IO.parse ic >>= fun headers -> - let encoding = Header.get_transfer_encoding headers in - let flush = false in - return (`Ok { encoding; headers; version; status; flush }) - - let allowed_body response = - (* rfc7230#section-5.7.1 *) - match status response with - | #Code.informational_status | `No_content | `Not_modified -> false - | #Code.status_code -> true - - let has_body response = - if allowed_body response then Transfer.has_body (encoding response) else `No - - let make_body_reader { encoding; _ } ic = Transfer_IO.make_reader encoding ic - let read_body_chunk = Transfer_IO.read - - let write_header res oc = - write oc - (Printf.sprintf "%s %s\r\n" - (Code.string_of_version res.version) - (Code.string_of_status res.status)) - >>= fun () -> - let headers = - if allowed_body res then - Header.add_transfer_encoding res.headers res.encoding - else res.headers - in - Header_IO.write headers oc - - let make_body_writer ?flush { encoding; _ } oc = - Transfer_IO.make_writer ?flush encoding oc - - let write_body = Transfer_IO.write - - let write_footer { encoding; _ } oc = - match encoding with - | Transfer.Chunked -> - (* TODO Trailer header support *) - IO.write oc "0\r\n\r\n" - | Transfer.Fixed _ | Transfer.Unknown -> return () - - let write ?flush fn req oc = - write_header req oc >>= fun () -> - let writer = make_body_writer ?flush req oc in - fn writer >>= fun () -> write_footer req oc -end diff --git a/cohttp/cohttp/src/response.mli b/cohttp/cohttp/src/response.mli deleted file mode 100644 index 81902d82ca7412ab4169eebdf270771e986d2ddc..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/response.mli +++ /dev/null @@ -1,34 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** HTTP/1.1 response handling *) - -include S.Response -(** This contains the metadata for a HTTP/1.1 response header, including the - {!encoding}, {!headers}, {!version}, {!status} code and whether to {!flush} - the connection after every body chunk (useful for server-side events and - other long-lived connection protocols). The body is handled by the separate - {!S} module type, as it is dependent on the IO implementation. - - The interface exposes a [fieldslib] interface which provides individual - accessor functions for each of the records below. It also provides [sexp] - serializers to convert to-and-from an {!Core.Std.Sexp.t}. *) - -val pp_hum : Format.formatter -> t -> unit -(** Human-readable output, used by the toplevel printer *) - -(** Functor to construct the IO-specific response handling function *) -module Make (IO : S.IO) : S.Http_io with type t = t and module IO = IO diff --git a/cohttp/cohttp/src/s.ml b/cohttp/cohttp/src/s.ml deleted file mode 100644 index da224f857a7334405d728976ffbaeae3d9c4f1b6..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/s.ml +++ /dev/null @@ -1,167 +0,0 @@ -(*{{{ Copyright (C) 2012-2014 Anil Madhavapeddy - * Copyright (c) 2014 Rudi Grinberg - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** Module type signatures for Cohttp components *) - -(** The [IO] module defines the blocking interface for reading and writing to - Cohttp streams *) -module type IO = sig - type +'a t - (** ['a t] represents a blocking monad state *) - - val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t - (** [a >>= b] will pass the result of [a] to the [b] function. This is a - monadic [bind]. *) - - val return : 'a -> 'a t - (** [return a] will construct a constant IO value. *) - - type ic - (** [ic] represents an input channel *) - - type oc - (** [oc] represents an output channel *) - - type conn - (** [conn] represents the underlying network flow *) - - val read_line : ic -> string option t - (** [read_line ic] will read a single line terminated by CR or CRLF from the - input channel [ic]. It returns {!None} if EOF or other error condition is - reached. *) - - val read : ic -> int -> string t - (** [read ic len] will block until a maximum of [len] characters are read from - the input channel [ic]. It returns an empty string if EOF or some other - error condition occurs on the input channel, and can also return fewer - than [len] characters if input buffering is not sufficient to satisfy the - request. *) - - val write : oc -> string -> unit t - (** [write oc s] will block until the complete [s] string is written to the - output channel [oc]. *) - - val flush : oc -> unit t - (** [flush oc] will return when all previously buffered content from calling - {!write} have been written to the output channel [oc]. *) -end - -module type Http_io = sig - type t - type reader - type writer - - module IO : IO - - val read : IO.ic -> [ `Eof | `Invalid of string | `Ok of t ] IO.t - val has_body : t -> [ `No | `Unknown | `Yes ] - val make_body_writer : ?flush:bool -> t -> IO.oc -> writer - val make_body_reader : t -> IO.ic -> reader - val read_body_chunk : reader -> Transfer.chunk IO.t - val write_header : t -> IO.oc -> unit IO.t - val write_body : writer -> string -> unit IO.t - val write : ?flush:bool -> (writer -> unit IO.t) -> t -> IO.oc -> unit IO.t -end - -module type Request = sig - type t = { - headers : Header.t; (** HTTP request headers *) - meth : Code.meth; (** HTTP request method *) - scheme : string option; (** URI scheme (http or https) *) - resource : string; (** Request path and query *) - version : Code.version; (** HTTP version, usually 1.1 *) - encoding : Transfer.encoding; (** transfer encoding of this HTTP request *) - } - [@@deriving sexp] - - val headers : t -> Header.t - val meth : t -> Code.meth - val scheme : t -> string option - val resource : t -> string - val version : t -> Code.version - val encoding : t -> Transfer.encoding - val compare : t -> t -> int - - val make : - ?meth:Code.meth -> - ?version:Code.version -> - ?encoding:Transfer.encoding -> - ?headers:Header.t -> - Uri.t -> - t - - val is_keep_alive : t -> bool - (** Return true whether the connection should be reused *) - - val uri : t -> Uri.t - - val make_for_client : - ?headers:Header.t -> - ?chunked:bool -> - ?body_length:int64 -> - Code.meth -> - Uri.t -> - t -end - -module type Response = sig - type t = { - encoding : Transfer.encoding; - (** Transfer encoding of this HTTP response *) - headers : Header.t; (** response HTTP headers *) - version : Code.version; (** (** HTTP version, usually 1.1 *) *) - status : Code.status_code; (** HTTP status code of the response *) - flush : bool; - } - [@@deriving sexp] - - val encoding : t -> Transfer.encoding - val headers : t -> Header.t - val version : t -> Code.version - val status : t -> Code.status_code - val flush : t -> bool - val compare : t -> t -> int - - val make : - ?version:Code.version -> - ?status:Code.status_code -> - ?flush:bool -> - ?encoding:Transfer.encoding -> - ?headers:Header.t -> - unit -> - t - (** The response creates by [make ~encoding ~headers ()] has an encoding value - determined from the content of [headers] or if no proper header is - present, using the value of [encoding]. Checked headers are - "content-length", "content-range" and "transfer-encoding". The default - value of [encoding] is chunked. *) -end - -module type Body = sig - type t - - val to_string : t -> string - val to_string_list : t -> string list - val to_form : t -> (string * string list) list - val empty : t - val is_empty : t -> bool - val of_string : string -> t - val of_string_list : string list -> t - val of_form : ?scheme:string -> (string * string list) list -> t - val map : (string -> string) -> t -> t - val transfer_encoding : t -> Transfer.encoding -end diff --git a/cohttp/cohttp/src/string_io.ml b/cohttp/cohttp/src/string_io.ml deleted file mode 100644 index ca84c31b017b536e7375ba312781244fbd2b2f1f..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/string_io.ml +++ /dev/null @@ -1,80 +0,0 @@ -(*{{{ Copyright (c) 2014 Andy Ray - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(* input channel type - a string with a (file) position and length *) -type buf = { str : string; mutable pos : int; len : int } - -let open_in str = { str; pos = 0; len = String.length str } - -module M = struct - type 'a t = 'a - - let return a = a - - type conn = buf - - let ( >>= ) = ( |> ) - - type ic = buf - - (* output channels are just buffers *) - type oc = Buffer.t - - (* the following read/write logic has only been lightly tested... *) - let read_rest x = - let s = String.sub x.str x.pos (x.len - x.pos) in - x.pos <- x.len; - s - - let read_line' x = - if x.pos < x.len then - let start = x.pos in - try - while x.str.[x.pos] != '\n' do - x.pos <- x.pos + 1 - done; - let l = - if x.pos > 0 && x.str.[x.pos - 1] = '\r' then x.pos - start - 1 - else x.pos - start - in - let s = String.sub x.str start l in - x.pos <- x.pos + 1; - Some s - with _ -> Some (read_rest x) - else None - - let read_line x = return (read_line' x) - - let read_exactly' x n = - if x.len - x.pos < n then None - else - let s = String.sub x.str x.pos n in - x.pos <- x.pos + n; - Some s - - let read x n = - match read_exactly' x n with - | None when x.pos >= x.len -> raise End_of_file - | None -> return (read_rest x) - | Some x -> return x - - let write x s = - Buffer.add_string x s; - return () - - let flush _x = return () -end diff --git a/cohttp/cohttp/src/string_io.mli b/cohttp/cohttp/src/string_io.mli deleted file mode 100644 index 65988b8fda7c5bad3d29d05bdc04ce483fad6256..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/string_io.mli +++ /dev/null @@ -1,30 +0,0 @@ -(*{{{ Copyright (c) 2014 Andy Ray - * Copyright (c) 2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** IO implementation that uses strings to marshal and unmarshal HTTP *) - -type buf = { str : string; mutable pos : int; len : int } -(** The buffer structured used to keep track of where in the string the library - is currently reading from *) - -val open_in : string -> buf -(** [open_in s] will make the string [s] available as a [buf] that can be parsed - via Cohttp *) - -(** IO interface that uses {!buf} for input data and queues output data into a - {!Buffer.t} *) -module M : S.IO with type 'a t = 'a and type ic = buf and type oc = Buffer.t diff --git a/cohttp/cohttp/src/transfer.ml b/cohttp/cohttp/src/transfer.ml deleted file mode 100644 index d31a30f74bf9abeb0fcd2d0a243e2cdc242cef79..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/transfer.ml +++ /dev/null @@ -1,30 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Sexplib0.Sexp_conv - -type encoding = Chunked | Fixed of int64 | Unknown [@@deriving sexp] -type chunk = Chunk of string | Final_chunk of string | Done [@@deriving sexp] - -let string_of_encoding = function - | Chunked -> "chunked" - | Fixed i -> Printf.sprintf "fixed[%Ld]" i - | Unknown -> "unknown" - -let has_body = function - | Fixed 0L -> `No - | Chunked | Fixed _ -> `Yes - | Unknown -> `Unknown diff --git a/cohttp/cohttp/src/transfer.mli b/cohttp/cohttp/src/transfer.mli deleted file mode 100644 index 63fda6c0b7a5168a3de394d6b449c96e9426bc2e..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/transfer.mli +++ /dev/null @@ -1,42 +0,0 @@ -(*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** Read and write the HTTP/1.1 transfer-encoding formats. Currently supported - are [chunked] and [content-length]. *) - -(** The encoding format detected from the [transfer-encoding] and - [content-length] headers *) -type encoding = - | Chunked (** dynamic chunked encoding *) - | Fixed of int64 (** fixed size content *) - | Unknown (** unknown body size, which leads to best-effort *) -[@@deriving sexp] - -(** A chunk of body that also signals if there to more to arrive *) -type chunk = - | Chunk of string (** chunk of data and not the end of stream *) - | Final_chunk of string - (** the last chunk of data, so no more should be read *) - | Done (** no more body data is present *) -[@@deriving sexp] - -val string_of_encoding : encoding -> string -(** Convert the encoding format to a human-readable string *) - -val has_body : encoding -> [ `No | `Unknown | `Yes ] -(** [has_body encoding] returns the appropriate variant that indicates whether - the HTTP request or response has an associated body. It does not guess: - instead [Unknown] is returned if there is no explicit association. *) diff --git a/cohttp/cohttp/src/transfer_io.ml b/cohttp/cohttp/src/transfer_io.ml deleted file mode 100644 index 25d28e15aa7a0fe80a18827aca5071b1d78063fb..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/transfer_io.ml +++ /dev/null @@ -1,148 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Transfer - -module Make (IO : S.IO) = struct - open IO - - type reader = unit -> Transfer.chunk IO.t - type writer = string -> unit IO.t - - module Chunked = struct - let remaining_length chunk remaining = - let read_len = Int64.of_int (String.length chunk) in - Int64.sub remaining read_len - - let read_chunk ic size = - let max_read_len = Int64.of_int 0x8000 in - let len = min size max_read_len in - read ic (Int64.to_int len) - - let parse_chunksize chunk_size_hex = - let hex = - (* From https://tools.ietf.org/html/rfc7230#section-4.1.1 - > The chunked encoding allows each chunk to include zero or - > more chunk extensions, immediately following the chunk-size - *) - try String.sub chunk_size_hex 0 (String.index chunk_size_hex ';') - with _ -> chunk_size_hex - in - try Some (Int64.of_string ("0x" ^ hex)) with _ -> None - - let rec junk_until_empty_line ic = - read_line ic >>= function - | None | Some "" -> return Done - | Some _trailer -> junk_until_empty_line ic - - let read ~remaining ic () = - (* read between 0 and 32Kbytes of a chunk *) - let read_chunk_fragment () = - read_chunk ic !remaining >>= fun chunk -> - remaining := remaining_length chunk !remaining; - (if !remaining = 0L (* End_of_chunk *) then read_line ic - (* Junk the CRLF at end of chunk *) - else return None) - >>= fun _ -> return chunk - in - if !remaining = 0L then - (* Beginning of a chunk: read chunk size, read up to 32K bytes *) - read_line ic >>= function - | None -> return Done - | Some chunk_size_hex -> ( - match parse_chunksize chunk_size_hex with - | None -> return Done - | Some 0L -> - (* TODO: Trailer header support *) - junk_until_empty_line ic - | Some count -> ( - remaining := count; - read_chunk_fragment () >>= function - | "" -> return Done (* 0 bytes read means EOF *) - | buf -> return (Chunk buf))) - else - (* Middle of a chunk, read up to 32K bytes *) - read_chunk_fragment () >>= function - | "" -> return Done (* 0 bytes read means EOF *) - | buf -> return (Chunk buf) - - let write oc buf = - let len = String.length buf in - (* do NOT send empty chunks, as it signals the end of the - chunked body *) - if len <> 0 then - write oc (Printf.sprintf "%x\r\n" len) >>= fun () -> - write oc buf >>= fun () -> write oc "\r\n" - else return () - end - - module Fixed = struct - let read ~remaining ic () = - (* TODO functorise string to a bigbuffer *) - match !remaining with - | 0L -> return Done - | len -> ( - let max_read_len = Int64.of_int 0x8000 in - let read_len = Int64.to_int (min len max_read_len) in - read ic read_len >>= function - | "" -> return Done - | buf -> - remaining := - Int64.sub !remaining (Int64.of_int (String.length buf)); - return - (match !remaining with 0L -> Final_chunk buf | _ -> Chunk buf)) - - (* TODO enforce that the correct length is written? *) - let write = write - end - - module Unknown = struct - (* If we have no idea, then read until EOF (connection shutdown by - the remote party). *) - let read ic () = - read ic 4096 >>= fun buf -> - if buf = "" then return Done else return (Chunk buf) - - let write = write - end - - let write_and_flush fn oc buf = fn oc buf >>= fun () -> IO.flush oc - - let make_reader = function - | Chunked -> Chunked.read ~remaining:(ref 0L) - | Fixed len -> Fixed.read ~remaining:(ref len) - | Unknown -> Unknown.read - - let write_ignore_blank writer io s = - if String.length s = 0 then return () else writer io s - - let make_writer ?(flush = false) mode = - match flush with - | false -> ( - match mode with - | Chunked -> Chunked.write - | Fixed _ -> Fixed.write - | Unknown -> Unknown.write) - | true -> - (match mode with - | Chunked -> write_and_flush Chunked.write - | Fixed _ -> write_and_flush Fixed.write - | Unknown -> write_and_flush Unknown.write) - |> write_ignore_blank - - let read reader = reader () - let write writer buf = writer buf -end diff --git a/cohttp/cohttp/src/transfer_io.mli b/cohttp/cohttp/src/transfer_io.mli deleted file mode 100644 index d06a47ccf682f5468453b2fa0f23255186d96050..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/src/transfer_io.mli +++ /dev/null @@ -1,27 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -open Transfer - -module Make (IO : S.IO) : sig - type reader - type writer - - val make_reader : encoding -> IO.ic -> reader - val make_writer : ?flush:bool -> encoding -> IO.oc -> writer - val read : reader -> chunk IO.t - val write : writer -> string -> unit IO.t -end diff --git a/cohttp/cohttp/test/dune b/cohttp/cohttp/test/dune deleted file mode 100644 index dde8072f7b9b4562141080b7e4f096cad6ce6732..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/test/dune +++ /dev/null @@ -1,59 +0,0 @@ -(executable - (name test_accept) - (modules test_accept) - (forbidden_libraries base) - (libraries cohttp alcotest fmt)) - -(rule - (alias runtest) - (package cohttp) - (action - (run ./test_accept.exe))) - -(executable - (name test_header) - (modules unitary_test_header test_header) - (forbidden_libraries base) - (libraries cohttp alcotest fmt)) - -(rule - (alias runtest) - (package cohttp) - (action - (run ./test_header.exe))) - -(executable - (name test_request) - (modules test_request) - (forbidden_libraries base) - (libraries cohttp alcotest fmt)) - -(rule - (alias runtest) - (package cohttp) - (action - (run ./test_request.exe))) - -(executable - (name test_body) - (modules test_body) - (forbidden_libraries base) - (libraries cohttp alcotest fmt)) - -(rule - (alias runtest) - (package cohttp) - (action - (run ./test_body.exe))) - -(executable - (name test_path) - (modules test_path) - (forbidden_libraries base) - (libraries cohttp alcotest fmt)) - -(rule - (alias runtest) - (package cohttp) - (action - (run ./test_path.exe))) diff --git a/cohttp/cohttp/test/test_accept.ml b/cohttp/cohttp/test/test_accept.ml deleted file mode 100644 index 914830073f7eb970ab755dd0b79abf4e1798de46..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/test/test_accept.ml +++ /dev/null @@ -1,187 +0,0 @@ -(*{{{ Copyright (c) 2012 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -module A = Cohttp.Accept - -let suite_of : - type a. - (string option -> a) -> a Alcotest.testable -> (string * a) list -> _ list = - fun pf t -> - List.map (fun (s, expected) -> - let test () = Alcotest.check t s (pf (Some s)) expected in - (s, `Quick, test)) - -let suite_of_fail : - type a. - (string option -> a) -> a Alcotest.testable -> (string * exn) list -> _ list - = - fun pf _ -> - List.map (fun (s, e) -> - let test () = - Alcotest.check_raises s e (fun () -> ignore (pf (Some s))) - in - (s, `Quick, test)) - -let suite_to_string_of : type a. (a -> string) -> (a * string) list -> _ list = - fun pf -> - List.map (fun (v, expected_str) -> - let test () = Alcotest.(check string expected_str expected_str (pf v)) in - (expected_str, `Quick, test)) - -let suite_to_string_of_fail : - type a. (a -> string) -> (a * string * exn) list -> _ list = - fun pf -> - List.map (fun (v, descr, e) -> - let test () = Alcotest.(check_raises descr e (fun () -> ignore (pf v))) in - ("", `Quick, test)) - -let valid_media_ranges = - [ - ("text/plain", [ (1000, (A.MediaType ("text", "plain"), [])) ]); - ("text/*", [ (1000, (A.AnyMediaSubtype "text", [])) ]); - ("*/*", [ (1000, (A.AnyMedia, [])) ]); - ("*/*;q=1", [ (1000, (A.AnyMedia, [])) ]); - ("*/*;q=0", [ (0, (A.AnyMedia, [])) ]); - ("*/*;q=1.", [ (1000, (A.AnyMedia, [])) ]); - ("*/*;q=1.0", [ (1000, (A.AnyMedia, [])) ]); - ("*/*;q=.0", [ (0, (A.AnyMedia, [])) ]); - ("*/*;q=0.", [ (0, (A.AnyMedia, [])) ]); - ("*/*;q=0.1", [ (100, (A.AnyMedia, [])) ]); - ( "image/*,text/*", - [ - (1000, (A.AnyMediaSubtype "image", [])); - (1000, (A.AnyMediaSubtype "text", [])); - ] ); - ( "text/plain; q=0.8; charset=utf-8,text/HTML;charset=utf-8;q=0.9", - [ - (800, (A.MediaType ("text", "plain"), [ ("charset", "utf-8") ])); - (900, (A.MediaType ("text", "html"), [ ("charset", "utf-8") ])); - ] ); - ( "text/*;foo=\"bar\"", - [ (1000, (A.AnyMediaSubtype "text", [ ("foo", "bar") ])) ] ); - ("*/*;qu=\"\\\"\"", [ (1000, (A.AnyMedia, [ ("qu", "\"") ])) ]); - ( "*/*;f=\";q=0,text/plain\"", - [ (1000, (A.AnyMedia, [ ("f", ";q=0,text/plain") ])) ] ); - ] - -let invalid_media_ranges = [ ("*/*;q=.", Parsing.Parse_error) ] - -let valid_media_ranges_suite = - let t_media_ranges = - Alcotest.testable (Fmt.of_to_string A.string_of_media_ranges) ( = ) - in - suite_of A.media_ranges t_media_ranges valid_media_ranges - -let invalid_media_ranges_suite = - let t_media_ranges = - Alcotest.testable (Fmt.of_to_string A.string_of_media_ranges) ( = ) - in - suite_of_fail A.media_ranges t_media_ranges invalid_media_ranges - -let valid_qualities = - [ - ((1000, (A.AnyMedia, [])), "*/*;q=1"); - ((0, (A.AnyMedia, [])), "*/*;q=0.000"); - ((353, (A.AnyMedia, [])), "*/*;q=0.353"); - ((25, (A.AnyMedia, [])), "*/*;q=0.025"); - ((1, (A.AnyMedia, [])), "*/*;q=0.001"); - ] - -let invalid_qualities = - [ - ( (-3, (A.AnyMedia, [])), - "negative", - Invalid_argument "qvalue -3 must be positive" ); - ( (1001, (A.AnyMedia, [])), - "bigger than 1000", - Invalid_argument "qvalue 1001 must be less than 1000" ); - ] - -let valid_qualities_suite = - suite_to_string_of (fun (q, a) -> A.string_of_media_range a q) valid_qualities - -let invalid_qualities_suite = - suite_to_string_of_fail - (fun (q, a) -> A.string_of_media_range a q) - invalid_qualities - -let valid_charsets = - [ - ("utf-8", [ (1000, A.Charset "utf-8") ]); - ("UTF-8", [ (1000, A.Charset "utf-8") ]); - ("iso-8859-1", [ (1000, A.Charset "iso-8859-1") ]); - ( "ISO-8859-1; q = 0.8, *; q=0.7", - [ (800, A.Charset "iso-8859-1"); (700, A.AnyCharset) ] ); - ] - -let valid_charsets_suite = - let t_charsets = - Alcotest.testable (Fmt.of_to_string A.string_of_charsets) ( = ) - in - suite_of A.charsets t_charsets valid_charsets - -let valid_encodings = - [ - ("compress, gzip", [ (1000, A.Compress); (1000, A.Gzip) ]); - ("", []); - ("*", [ (1000, A.AnyEncoding) ]); - ("compress;q=0.5, gzip;q=1.0", [ (500, A.Compress); (1000, A.Gzip) ]); - ( "Gzip;q=1.0, identity; q=0.5, *;q=0", - [ (1000, A.Gzip); (500, A.Identity); (0, A.AnyEncoding) ] ); - ] - -let valid_encodings_suite = - let t_encodings = - Alcotest.testable (Fmt.of_to_string A.string_of_encodings) ( = ) - in - suite_of A.encodings t_encodings valid_encodings - -let valid_languages = - [ - ("en", [ (1000, A.Language [ "en" ]) ]); - ("en-US", [ (1000, A.Language [ "en"; "us" ]) ]); - ("en-cockney", [ (1000, A.Language [ "en"; "cockney" ]) ]); - ("i-cherokee", [ (1000, A.Language [ "i"; "cherokee" ]) ]); - ("x-pig-latin", [ (1000, A.Language [ "x"; "pig"; "latin" ]) ]); - ( "da, en-gb;q=0.8, en;q=0.7", - [ - (1000, A.Language [ "da" ]); - (800, A.Language [ "en"; "gb" ]); - (700, A.Language [ "en" ]); - ] ); - ( "en-US, *;q=0.9", - [ (1000, A.Language [ "en"; "us" ]); (900, A.AnyLanguage) ] ); - ] - -let valid_languages_suite = - let t_languages = - Alcotest.testable (Fmt.of_to_string A.string_of_languages) ( = ) - in - suite_of A.languages t_languages valid_languages - -let () = Printexc.record_backtrace true - -let () = - Alcotest.run "test_accept" - [ - ("valid string to media range", valid_media_ranges_suite); - ("invalid string to media range", invalid_media_ranges_suite); - ("valid media range to string", valid_qualities_suite); - ("invalid media range to string", invalid_qualities_suite); - ("valid string to charset", valid_charsets_suite); - ("valid string to encoding", valid_encodings_suite); - ("valid string to language", valid_languages_suite); - ] diff --git a/cohttp/cohttp/test/test_body.ml b/cohttp/cohttp/test/test_body.ml deleted file mode 100644 index f328d306f07fe3bd8067d6b0fff9b2779981ec80..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/test/test_body.ml +++ /dev/null @@ -1,23 +0,0 @@ -let test_if_body_empty () = - let tests = - Cohttp.Body. - [ - ("empty string", of_string "", true); - ("empty list of strings", of_string_list [], true); - ("list of strings with empty bytes", of_string_list [ ""; ""; "" ], true); - ("non empty list of strings", of_string_list [ ""; "foo"; "bar" ], false); - ] - in - List.iter - (fun (name, body, expected) -> - Alcotest.(check bool) name (Cohttp.Body.is_empty body) expected) - tests - -let () = Printexc.record_backtrace true - -let () = - Alcotest.run "test_body" - [ - ( "Query body information", - [ ("Check if body is empty", `Quick, test_if_body_empty) ] ); - ] diff --git a/cohttp/cohttp/test/test_header.ml b/cohttp/cohttp/test/test_header.ml deleted file mode 100644 index 3ffee01589e417f33f1a6946eb93fcc1a15bede1..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/test/test_header.ml +++ /dev/null @@ -1,494 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *}}}*) - -module String_io = Cohttp__String_io -module StringResponse = Cohttp.Response.Make (String_io.M) -module H = Cohttp.Header - -let aes = Alcotest.check Alcotest.string -let aeso = Alcotest.check Alcotest.(option string) - -let t_credentials = - Alcotest.testable - (fun fmt c -> - let sexp = Cohttp.Auth.sexp_of_credential c in - Sexplib0.Sexp.pp_hum fmt sexp) - ( = ) - -let valid_auth () = - let auth = `Basic ("Aladdin", "open sesame") in - let h = H.add_authorization (H.init ()) auth in - let digest = H.get h "authorization" in - aeso "valid_auth 1" digest (Some "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ=="); - Alcotest.check - (Alcotest.option t_credentials) - "valid_auth 2" (H.get_authorization h) (Some auth) - -let valid_set_cookie () = - let c = - Cohttp.Cookie.Set_cookie_hdr.make ~expiration:`Session ~path:"/foo/bar" - ~domain:"ocaml.org" ~secure:true ~http_only:true ("key", "value") - in - let k, v = Cohttp.Cookie.Set_cookie_hdr.serialize ~version:`HTTP_1_0 c in - aes "header key" "Set-Cookie" k; - aes "header value" - "key=value; domain=ocaml.org; path=/foo/bar; secure; httponly" v; - let c = - Cohttp.Cookie.Set_cookie_hdr.make ~expiration:(`Max_age 100L) - ~path:"/foo/bar" ~domain:"ocaml.org" ("key", "value") - in - let k, v = Cohttp.Cookie.Set_cookie_hdr.serialize ~version:`HTTP_1_0 c in - aes "header key2" "Set-Cookie" k; - aes "header value2" "key=value; Max-Age=100; domain=ocaml.org; path=/foo/bar" - v; - let k, v = Cohttp.Cookie.Set_cookie_hdr.serialize ~version:`HTTP_1_1 c in - aes "header key 1.1" "Set-Cookie2" k; - aes "header value 1.1" - "Domain=ocaml.org; Max-Age=100; Path=/foo/bar; Version=1" v - -let cookie_printer x = - String.concat "; " (List.map (fun (x, y) -> x ^ ":" ^ y) x) - -let t_cookies = Alcotest.(list (pair string string)) - -let cookie_with_eq_val () = - let cookies = [ ("test", "me=") ] in - let k, v = Cohttp.Cookie.Cookie_hdr.serialize cookies in - let h = Cohttp.Header.of_list [ (k, v) ] in - let cookies = Cohttp.Cookie.Cookie_hdr.extract h in - Alcotest.check t_cookies "cookie_with_eq_val" cookies [ ("test", "me=") ] - -let ignores_empty_cookie () = - let cookies = [ ("foo", "bar") ] in - let k, v = Cohttp.Cookie.Cookie_hdr.serialize cookies in - (* prepend an invalid empty component *) - let v = "; " ^ v in - let h = Cohttp.Header.of_list [ (k, v) ] in - let cookies = Cohttp.Cookie.Cookie_hdr.extract h in - Alcotest.check t_cookies "cookie" cookies [ ("foo", "bar") ] - -let valid_cookie () = - let cookies = [ ("foo", "bar"); ("a", "b") ] in - let k, v = Cohttp.Cookie.Cookie_hdr.serialize cookies in - aes "key" "cookie" k; - aes "value" "foo=bar; a=b" v; - let h = Cohttp.Header.of_list [ (k, v) ] in - let cookies = Cohttp.Cookie.Cookie_hdr.extract h in - Alcotest.check t_cookies "headers" [ ("foo", "bar"); ("a", "b") ] cookies - -let opt_printer f = function - | None -> "nothing" - | Some x -> Printf.sprintf "'%s'" (f x) - -let get_media_type () = - let mt = " foo/bar ; charset=UTF-8" in - let header = Cohttp.Header.init_with "content-type" mt in - Alcotest.check - Alcotest.(option string) - "media type" (Some "foo/bar") - (Cohttp.Header.get_media_type header) - -module Content_range = struct - let h1 = H.of_list [ ("Content-Length", "123") ] - let h2 = H.of_list [ ("Content-Range", "bytes 200-300/1000") ] - let aeio = Alcotest.(check (option int64)) - let none () = aeio "none" None (H.init () |> H.get_content_range) - - let content_length () = - aeio "content_length" (Some 123L) (H.get_content_range h1) - - let content_range () = - aeio "content_range" (Some 101L) (H.get_content_range h2) -end - -module Link = Cohttp.Link - -let t_links = - Alcotest.testable - (fun fmt links -> - Format.pp_print_list ~pp_sep:Format.pp_print_newline - (fun fmt l -> Format.fprintf fmt "%s" (Link.to_string l)) - fmt links) - ( = ) - -let headers_of_response test_name response_string = - String_io.M.( - StringResponse.read (String_io.open_in response_string) >>= function - | `Ok resp -> Cohttp.Response.headers resp - | _ -> failwith (test_name ^ " response parse failed")) - -let get_resp lines = - "HTTP/1.1 200 OK\r\n" ^ String.concat "\r\n" lines ^ "\r\n\r\n" - -let empty_uri = Uri.of_string "" - -let link_simple () = - let next_tgt = "/page/2" in - let resp = get_resp [ "Link: <" ^ next_tgt ^ ">; rel=next" ] in - let headers = headers_of_response "link_simple" resp in - Alcotest.check t_links "link_simple" - Link. - [ - { - context = empty_uri; - arc = Arc.{ empty with relation = Rel.[ next ] }; - target = Uri.of_string next_tgt; - }; - ] - (H.get_links headers) - -let link_multi_rel () = - let next_tgt = "/page/2" in - let resp = get_resp [ "Link: <" ^ next_tgt ^ ">; rel=\"next last\"" ] in - let headers = headers_of_response "link_multi_rel" resp in - Alcotest.check t_links "link_multi_rel" - Link. - [ - { - context = empty_uri; - arc = Arc.{ empty with relation = Rel.[ next; last ] }; - target = Uri.of_string next_tgt; - }; - ] - (H.get_links headers) - -let link_multi_line () = - let self_tgt = "/page/1" in - let next_tgt = "/page/2" in - let resp = - get_resp - [ - "Link: <" ^ next_tgt ^ ">; rel=\"next\""; - "Link: <" ^ self_tgt ^ ">; rel=self"; - ] - in - let headers = headers_of_response "link_multi_line" resp in - Alcotest.check t_links "link_multi_line" - Link. - [ - { - context = empty_uri; - arc = Arc.{ empty with relation = Rel.[ next ] }; - target = Uri.of_string next_tgt; - }; - { - context = empty_uri; - arc = Arc.{ empty with relation = Rel.[ self ] }; - target = Uri.of_string self_tgt; - }; - ] - (H.get_links headers) - -let link_multi_multi () = - let next_tgt = "/page/2" in - let last_tgt = "/page/3" in - let resp = - get_resp - [ "Link: <" ^ next_tgt ^ ">; rel=\"next\", <" ^ last_tgt ^ ">; rel=last" ] - in - let headers = headers_of_response "link_multi_multi" resp in - Alcotest.check t_links "link_multi_multi" - Link. - [ - { - context = empty_uri; - arc = Arc.{ empty with relation = Rel.[ next ] }; - target = Uri.of_string next_tgt; - }; - { - context = empty_uri; - arc = Arc.{ empty with relation = Rel.[ last ] }; - target = Uri.of_string last_tgt; - }; - ] - (H.get_links headers) - -let link_rel_uri () = - let uri_tgt = "/page/2" in - let uri_s = "http://example.com/a,valid;uri" in - let resp = - get_resp - [ "Link: <" ^ uri_tgt ^ ">; rel=\"next " ^ uri_s ^ "\"; hreflang=en" ] - in - let headers = headers_of_response "link_rel_uri" resp in - Alcotest.check t_links "link_rel_uri" - Link. - [ - { - context = empty_uri; - arc = - Arc. - { - empty with - relation = Rel.[ next; extension (Uri.of_string uri_s) ]; - hreflang = Some "en"; - }; - target = Uri.of_string uri_tgt; - }; - ] - (H.get_links headers) - -let link_anchor () = - let anchor = "/page/2" in - let target = "/page/1" in - let resp = - get_resp [ "Link: <" ^ target ^ ">; anchor=\"" ^ anchor ^ "\"; rel=prev" ] - in - let headers = headers_of_response "link_rel_uri" resp in - Alcotest.check t_links "link_anchor" - Link. - [ - { - context = Uri.of_string anchor; - arc = Arc.{ empty with relation = Rel.[ prev ] }; - target = Uri.of_string target; - }; - ] - (H.get_links headers) - -let link_rev () = - let anchor = "/page/2" in - let resp = get_resp [ "Link: <" ^ anchor ^ ">; rev=prev" ] in - let headers = headers_of_response "link_rev" resp in - Alcotest.check t_links "link_multi_line" - Link. - [ - { - context = Uri.of_string anchor; - arc = Arc.{ empty with reverse = true; relation = Rel.[ prev ] }; - target = empty_uri; - }; - ] - (H.get_links headers) - -let link_media () = - let target = "/page/2" in - let resp = get_resp [ "Link: <" ^ target ^ ">; media=screen" ] in - let headers = headers_of_response "link_media" resp in - Alcotest.check t_links "link_media" - Link. - [ - { - context = empty_uri; - arc = Arc.{ empty with media = Some "screen" }; - target = Uri.of_string target; - }; - ] - (H.get_links headers) - -let link_media_complex () = - let target = "/page/2" in - let resp = - get_resp [ "Link: <" ^ target ^ ">; media=\"screen, print and dpi < 200\"" ] - in - let headers = headers_of_response "link_media_complex" resp in - Alcotest.check t_links "t_links" - Link. - [ - { - context = empty_uri; - arc = Arc.{ empty with media = Some "screen, print and dpi < 200" }; - target = Uri.of_string target; - }; - ] - (H.get_links headers) - -let link_title () = - let target = "/page/2" in - let resp = get_resp [ "Link: <" ^ target ^ ">; title=\"Next!\"; rel=next" ] in - let headers = headers_of_response "link_title" resp in - Alcotest.check t_links "link_title" - Link. - [ - { - context = empty_uri; - arc = Arc.{ empty with relation = Rel.[ next ]; title = Some "Next!" }; - target = Uri.of_string target; - }; - ] - (H.get_links headers) - -let link_title_star () = - let target = "/page/2" in - let resp = - get_resp [ "Link: <" ^ target ^ ">; title*=UTF-8'en'Next!; rel=next" ] - in - let headers = headers_of_response "link_title_star" resp in - Alcotest.check t_links "link_title_star" - Link. - [ - { - context = empty_uri; - arc = - Arc. - { - empty with - relation = Rel.[ next ]; - title_ext = - Some - (Ext.make - ~charset:(Charset.of_string "UTF-8") - ~language:(Language.of_string "en") "Next!"); - }; - target = Uri.of_string target; - }; - ] - (H.get_links headers) - -let link_type_token () = - let target = "/page/2" in - let resp = get_resp [ "Link: <" ^ target ^ ">; type=text/html; rel=next" ] in - let headers = headers_of_response "link_type_token" resp in - Alcotest.check t_links "link_type_token" - Link. - [ - { - context = empty_uri; - arc = - Arc. - { - empty with - relation = Rel.[ next ]; - media_type = Some ("text", "html"); - }; - target = Uri.of_string target; - }; - ] - (H.get_links headers) - -let link_type_quoted () = - let target = "/page/2" in - let resp = - get_resp [ "Link: <" ^ target ^ ">; type=\"text/html\"; rel=next" ] - in - let headers = headers_of_response "link_type_quoted" resp in - Alcotest.check t_links "link_type_quoted" - Link. - [ - { - context = empty_uri; - arc = - Arc. - { - empty with - relation = Rel.[ next ]; - media_type = Some ("text", "html"); - }; - target = Uri.of_string target; - }; - ] - (H.get_links headers) - -let link_ext () = - let target = "/page/2" in - let resp = get_resp [ "Link: <" ^ target ^ ">; see=saw; rel=next" ] in - let headers = headers_of_response "link_ext" resp in - Alcotest.check t_links "link_ext" - Link. - [ - { - context = empty_uri; - arc = - Arc. - { - empty with - relation = Rel.[ next ]; - extensions = [ ("see", "saw") ]; - }; - target = Uri.of_string target; - }; - ] - (H.get_links headers) - -let link_ext_star () = - let target = "/page/2" in - let resp = get_resp [ "Link: <" ^ target ^ ">; zig*=''zag; rel=next" ] in - let headers = headers_of_response "link_ext" resp in - Alcotest.check t_links "link_ext_star" - Link. - [ - { - context = empty_uri; - arc = - Arc. - { - empty with - relation = Rel.[ next ]; - extension_exts = - [ - ( "zig", - Ext.make ~charset:(Charset.of_string "") - ~language:(Language.of_string "") "zag" ); - ]; - }; - target = Uri.of_string target; - }; - ] - (H.get_links headers) - -let trim_ws () = - let resp = get_resp [ "Age: 281 " ] in - let headers = headers_of_response "trim whitespace" resp in - aeso "trim_ws" (H.get headers "age") (Some "281") - -let test_cachecontrol_concat () = - let resp = - get_resp [ "Cache-Control: public"; "Cache-Control: max-age:86400" ] - in - let h = headers_of_response "concat Cache-Control" resp in - aeso "test_cachecontrol_concat" (Some "public,max-age:86400") - (H.get_multi_concat h "Cache-Control") - -let () = Printexc.record_backtrace true - -let () = - Alcotest.run "test_header" - [ - ( "Link", - [ - ("simple", `Quick, link_simple); - ("multiple rels", `Quick, link_multi_rel); - ("multiple lines", `Quick, link_multi_line); - ("multiheader", `Quick, link_multi_multi); - ("rel uri", `Quick, link_rel_uri); - ("anchor", `Quick, link_anchor); - ("rev", `Quick, link_rev); - ("media", `Quick, link_media); - ("media complex", `Quick, link_media_complex); - ("title", `Quick, link_title); - ("title star", `Quick, link_title_star); - ("type token", `Quick, link_type_token); - ("type quoted", `Quick, link_type_quoted); - ("extension", `Quick, link_ext); - ("extension star", `Quick, link_ext_star); - ] ); - ("Media Type", [ ("Media Type", `Quick, get_media_type) ]); - ("Auth", [ ("Valid Auth", `Quick, valid_auth) ]); - ( "Cookie", - [ - ("Valid Set-Cookie", `Quick, valid_set_cookie); - ("Valid Cookie", `Quick, valid_cookie); - ("Cookie with =", `Quick, cookie_with_eq_val); - ("Ignores empty cookie", `Quick, ignores_empty_cookie); - ] ); - ( "Content Range", - [ - ("none", `Quick, Content_range.none); - ("content-length", `Quick, Content_range.content_length); - ("content-range", `Quick, Content_range.content_range); - ] ); - ("Cache Control", [ ("concat", `Quick, test_cachecontrol_concat) ]); - Unitary_test_header.tests; - ] diff --git a/cohttp/cohttp/test/test_path.ml b/cohttp/cohttp/test/test_path.ml deleted file mode 100644 index 1feabe0fd20a6744edd59b0fd2b8e952373c8ab4..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/test/test_path.ml +++ /dev/null @@ -1,88 +0,0 @@ -let test_resolve_local_file () = - let tests = - [ - ( "full URL simple", - "/foo/bar/baz", - "https://example.com/images/buzz", - "/foo/bar/baz/images/buzz" ); - ( "full URL cwd", - "/foo/bar/baz", - "https://example.com/./buzz", - "/foo/bar/baz/buzz" ); - ( "full URL parent blocked", - "/foo/bar/baz", - "https://example.com/../buzz", - "/foo/bar/baz/buzz" ); - ( "full URL grandparent blocked", - "/foo/bar/baz", - "https://example.com/../../buzz", - "/foo/bar/baz/buzz" ); - ( "trailing-slash-docroot full URL simple", - "/foo/bar/baz/", - "https://example.com/images/buzz", - "/foo/bar/baz/images/buzz" ); - ( "trailing-slash-docroot full URL cwd", - "/foo/bar/baz/", - "https://example.com/./buzz", - "/foo/bar/baz/buzz" ); - ( "trailing-slash-docroot full URL parent blocked", - "/foo/bar/baz/", - "https://example.com/../buzz", - "/foo/bar/baz/buzz" ); - ( "trailing-slash-docroot full URL grandparent blocked", - "/foo/bar/baz/", - "https://example.com/../../buzz", - "/foo/bar/baz/buzz" ); - ( "filepath simple", - "/foo/bar/baz", - "/images/buzz", - "/foo/bar/baz/images/buzz" ); - ("filepath cwd", "/foo/bar/baz", "./buzz", "/foo/bar/baz/buzz"); - ("filepath parent blocked", "/foo/bar/baz", "../buzz", "/foo/bar/baz/buzz"); - ( "filepath grandparent blocked", - "/foo/bar/baz", - "../../buzz", - "/foo/bar/baz/buzz" ); - ( "trailing-slash-docroot filepath simple", - "/foo/bar/baz/", - "/images/buzz", - "/foo/bar/baz/images/buzz" ); - ( "trailing-slash-docroot filepath cwd", - "/foo/bar/baz/", - "./buzz", - "/foo/bar/baz/buzz" ); - ( "trailing-slash-docroot filepath parent blocked", - "/foo/bar/baz/", - "../buzz", - "/foo/bar/baz/buzz" ); - ( "trailing-slash-docroot filepath grandparent blocked", - "/foo/bar/baz/", - "../../buzz", - "/foo/bar/baz/buzz" ); - ("root-docroot simple", "/", "/images/buzz", "/images/buzz"); - ("root-docroot cwd", "/", "./buzz", "/buzz"); - ("root-docroot grandparent blocked", "/", "../../buzz", "/buzz"); - ("blank-docroot simple", "", "/images/buzz", "images/buzz"); - ("blank-docroot cwd", "", "./buzz", "buzz"); - ("blank-docroot blank-path", "", "https://example.com", ""); - ("blank-docroot blank-uri", "", "", ""); - ("cwd-docroot simple", ".", "/images/buzz", "./images/buzz"); - ("cwd-docroot cwd", ".", "./buzz", "./buzz"); - ("cwd-docroot blank-path", ".", "https://example.com", "./"); - ("cwd-docroot blank-uri", ".", "", "./"); - ] - in - List.iter - (fun (name, docroot, uri, expected) -> - Alcotest.(check string) - name expected - (Cohttp.Path.resolve_local_file ~docroot ~uri:(Uri.of_string uri))) - tests - -let () = Printexc.record_backtrace true - -let () = - Alcotest.run "test_path" - [ - ("Path", [ ("Check resolve_local_file", `Quick, test_resolve_local_file) ]); - ] diff --git a/cohttp/cohttp/test/test_request.ml b/cohttp/cohttp/test/test_request.ml deleted file mode 100644 index daded6c1b07e6bf06b8878b25d15b87d39e23206..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/test/test_request.ml +++ /dev/null @@ -1,320 +0,0 @@ -open Cohttp -module String_io = Cohttp__String_io -module StringRequest = Request.Make (String_io.M) - -let uri_userinfo = Uri.of_string "http://foo:bar%2525@ocaml.org" - -let header_auth = - let h = Header.init () in - let h = Header.add_authorization h (`Basic ("qux", "qwerty")) in - h - -let is_some = function None -> false | Some _ -> true - -let header_has_auth _ = - Alcotest.check Alcotest.bool "Test header has auth" - (header_auth |> Header.get_authorization |> is_some) - true - -let uri_has_userinfo _ = - Alcotest.check Alcotest.bool "Uri has user info" - (uri_userinfo |> Uri.userinfo |> is_some) - true - -let t_credentials = - Alcotest.testable - (fun fmt c -> - let sexp = Cohttp.Auth.sexp_of_credential c in - Sexplib0.Sexp.pp_hum fmt sexp) - ( = ) - -let auth_uri_no_override _ = - let r = Request.make ~headers:header_auth uri_userinfo in - Alcotest.check - (Alcotest.option t_credentials) - "auth uri no override" - (r |> Request.headers |> Header.get_authorization) - (Header.get_authorization header_auth) - -let auth_uri _ = - let r = Request.make uri_userinfo in - Alcotest.check - (Alcotest.option t_credentials) - "auth_uri" - (r |> Request.headers |> Header.get_authorization) - (Some (`Basic ("foo", "bar%25"))) - -let t_encoding = - Alcotest.testable - (fun fmt e -> - let sexp = Cohttp.Transfer.sexp_of_encoding e in - Sexplib0.Sexp.pp fmt sexp) - ( = ) - -let encoding_content_length_header () = - let r = - Request.make - ~headers:(Cohttp.Header.of_list [ ("content-length", "100") ]) - (Uri.of_string "http://someuri.com") - in - Alcotest.check t_encoding "body encoding determined by content-length header" - (r |> Request.encoding) (Fixed 100L) - -let encoding_transfer_encoding_header () = - let r = - Request.make - ~headers:(Cohttp.Header.of_list [ ("transfer-encoding", "chunked") ]) - (Uri.of_string "http://someuri.com") - in - Alcotest.check t_encoding - "body encoding determined by transfer-encoding header" - (r |> Request.encoding) Chunked - -let encoding_both_headers () = - let r = - Request.make - ~headers: - (Cohttp.Header.of_list - [ ("transfer-encoding", "chunked"); ("content-length", "100") ]) - (Uri.of_string "http://someuri.com") - in - Alcotest.check t_encoding - "body encoding with content-length and transfer-encoding headers." - (r |> Request.encoding) Chunked - -let encoding_header_opt_argument () = - let r = - Request.make ~encoding:Chunked - ~headers:(Cohttp.Header.of_list [ ("content-length", "100") ]) - (Uri.of_string "http://someuri.com") - in - Alcotest.check t_encoding - "body encoding with content-length and transfer-encoding headers." - (r |> Request.encoding) (Fixed 100L) - -let opt_default default = function None -> default | Some v -> v - -module Parse_result = struct - type 'a t = [ `Ok of 'a | `Invalid of string | `Eof ] - - let map t ~f = - match t with `Ok x -> `Ok (f x) | (`Invalid _ | `Eof) as e -> e -end - -let uri_testable : Uri.t Alcotest.testable = - Alcotest.testable Uri.pp_hum Uri.equal - -let t_parse_result_uri : Uri.t Parse_result.t Alcotest.testable = - Alcotest.testable - (fun fmt -> function - | `Invalid s -> Format.fprintf fmt "`Invalid %s" s - | `Eof -> Format.fprintf fmt "`Eof" - | `Ok u -> Uri.pp_hum fmt u) - (fun x y -> - match (x, y) with `Ok x, `Ok y -> Uri.equal x y | x, y -> x = y) - -let parse_request_uri_ r (expected : Uri.t Parse_result.t) name = - String_io.M.( - StringRequest.read (String_io.open_in r) - >>= fun (result : Cohttp.Request.t Parse_result.t) -> - let uri = Parse_result.map result ~f:Request.uri in - return @@ Alcotest.check t_parse_result_uri name uri expected) - -let bad_request = `Invalid "bad request URI" - -let parse_request_uri _ = - let r = "GET / HTTP/1.1\r\n\r\n" in - let uri = `Ok (Uri.of_string "/") in - parse_request_uri_ r uri "parse_request_uri" - -let parse_request_uri_host _ = - let r = "GET / HTTP/1.1\r\nHost: example.com\r\n\r\n" in - let uri = `Ok (Uri.of_string "//example.com/") in - parse_request_uri_ r uri "parse_request_uri_host" - -let parse_request_uri_host_port _ = - let r = "GET / HTTP/1.1\r\nHost: example.com:8080\r\n\r\n" in - let uri = `Ok (Uri.of_string "//example.com:8080/") in - parse_request_uri_ r uri "parse_request_uri_host_port" - -let parse_request_uri_double_slash _ = - let r = "GET // HTTP/1.1\r\n\r\n" in - let uri = `Ok (Uri.with_path (Uri.of_string "") "//") in - parse_request_uri_ r uri "parse_request_uri_double_slash" - -let parse_request_uri_host_double_slash _ = - let r = "GET // HTTP/1.1\r\nHost: example.com\r\n\r\n" in - let uri = `Ok (Uri.of_string "//example.com//") in - parse_request_uri_ r uri "parse_request_uri_host_double_slash" - -let parse_request_uri_triple_slash _ = - let r = "GET /// HTTP/1.1\r\n\r\n" in - let uri = `Ok (Uri.with_path (Uri.of_string "") "///") in - parse_request_uri_ r uri "parse_request_uri_triple_slash" - -let parse_request_uri_host_triple_slash _ = - let r = "GET /// HTTP/1.1\r\nHost: example.com\r\n\r\n" in - let uri = `Ok (Uri.of_string "//example.com///") in - parse_request_uri_ r uri "parse_request_uri_host_triple_slash" - -let parse_request_uri_no_slash _ = - let r = "GET foo HTTP/1.1\r\n\r\n" in - parse_request_uri_ r bad_request "parse_request_uri_no_slash" - -let parse_request_uri_host_no_slash _ = - let r = "GET foo HTTP/1.1\r\nHost: example.com\r\n\r\n" in - parse_request_uri_ r bad_request "parse_request_uri_host_no_slash" - -let parse_request_uri_empty _ = - let r = "GET HTTP/1.1\r\n\r\n" in - let uri = `Ok (Uri.of_string "/") in - parse_request_uri_ r uri "parse_request_uri_empty" - -let parse_request_uri_host_empty _ = - let r = "GET HTTP/1.1\r\nHost: example.com\r\n\r\n" in - let uri = `Ok (Uri.of_string "//example.com/") in - parse_request_uri_ r uri "parse_request_uri_host_empty" - -let parse_request_uri_path_like_scheme _ = - let r = "GET http://example.net HTTP/1.1\r\n\r\n" in - let uri = `Ok (Uri.of_string "http://example.net/") in - parse_request_uri_ r uri "parse_request_uri_path_like_scheme" - -let parse_request_uri_host_path_like_scheme _ = - let r = "GET http://example.net HTTP/1.1\r\nHost: example.com\r\n\r\n" in - let uri = `Ok (Uri.of_string "http://example.net/") in - parse_request_uri_ r uri "parse_request_uri_host_path_like_scheme" - -let parse_request_uri_path_like_host_port _ = - let path = "//example.net:8080" in - let r = "GET " ^ path ^ " HTTP/1.1\r\n\r\n" in - let uri = `Ok (Uri.with_path (Uri.of_string "") path) in - parse_request_uri_ r uri "parse_request_uri_path_like_host_port" - -let parse_request_uri_host_path_like_host_port _ = - let path = "//example.net:8080" in - let r = "GET " ^ path ^ " HTTP/1.1\r\nHost: example.com\r\n\r\n" in - let uri = `Ok (Uri.with_path (Uri.of_string "//example.com") path) in - parse_request_uri_ r uri "parse_request_uri_host_path_like_host_port" - -let parse_request_uri_query _ = - let pqs = "/?foo" in - let r = "GET " ^ pqs ^ " HTTP/1.1\r\n\r\n" in - let uri = `Ok (Uri.of_string pqs) in - parse_request_uri_ r uri "parse_request_uri_query" - -let parse_request_uri_host_query _ = - let pqs = "/?foo" in - let r = "GET " ^ pqs ^ " HTTP/1.1\r\nHost: example.com\r\n\r\n" in - let uri = `Ok (Uri.of_string ("//example.com" ^ pqs)) in - parse_request_uri_ r uri "parse_request_uri_host_query" - -let parse_request_uri_query_no_slash _ = - let r = "GET ?foo HTTP/1.1\r\n\r\n" in - parse_request_uri_ r bad_request "parse_request_uri_query_no_slash" - -let parse_request_uri_host_query_no_slash _ = - let r = "GET ?foo HTTP/1.1\r\nHost: example.com\r\n\r\n" in - parse_request_uri_ r bad_request "parse_request_uri_host_query_no_slash" - -let parse_request_connect _ = - let r = "CONNECT vpn.example.net:443 HTTP/1.1\r\n" in - let uri = `Ok (Uri.of_string "//vpn.example.net:443") in - parse_request_uri_ r uri "parse_request_connect" - -let parse_request_connect_host _ = - let r = - "CONNECT vpn.example.net:443 HTTP/1.1\r\nHost: vpn.example.com:443\r\n\r\n" - in - let uri = `Ok (Uri.of_string "//vpn.example.net:443") in - parse_request_uri_ r uri "parse_request_connect_host" - -let parse_request_options _ = - let r = "OPTIONS * HTTP/1.1\r\n\r\n" in - let uri = `Ok (Uri.of_string "") in - parse_request_uri_ r uri "parse_request_options" - -let parse_request_options_host _ = - let r = "OPTIONS * HTTP/1.1\r\nHost: example.com:443\r\n\r\n" in - let uri = `Ok (Uri.of_string "//example.com:443") in - parse_request_uri_ r uri "parse_request_options_host" - -let parse_request_uri_traversal _ = - let r = "GET /../../../../etc/shadow HTTP/1.1\r\n\r\n" in - let uri = `Ok (Uri.of_string "/etc/shadow") in - parse_request_uri_ r uri "parse_request_uri_traversal" - -let parse_request_uri_host_traversal _ = - let r = "GET /../../../../etc/shadow HTTP/1.1\r\nHost: example.com\r\n\r\n" in - let uri = `Ok (Uri.of_string "//example.com/etc/shadow") in - parse_request_uri_ r uri "parse_request_uri_host_traversal" - -let uri_round_trip _ = - let expected_uri = Uri.of_string "https://www.example.com/test" in - let actual_uri = Request.make expected_uri |> Request.uri in - Alcotest.check uri_testable "Request.make uri round-trip" actual_uri - expected_uri - -let () = Printexc.record_backtrace true - -let () = - Alcotest.run "test_request" - [ - ( "Auth", - [ - ("header has auth", `Quick, header_has_auth); - ("URI has user info", `Quick, uri_has_userinfo); - ("from URI - do not override", `Quick, auth_uri_no_override); - ("from URI", `Quick, auth_uri); - ] ); - ( "Encoding", - [ - ("from content-length header", `Quick, encoding_content_length_header); - ( "from transfer-encoding header", - `Quick, - encoding_transfer_encoding_header ); - ("with both headers", `Quick, encoding_both_headers); - ( "from both optional argument and headers", - `Quick, - encoding_header_opt_argument ); - ] ); - ( "Parse URI", - [ - ("simple", `Quick, parse_request_uri); - ("with host", `Quick, parse_request_uri_host); - ("with host and port", `Quick, parse_request_uri_host_port); - ("double slash", `Quick, parse_request_uri_double_slash); - ("double slash with host", `Quick, parse_request_uri_host_double_slash); - ("triple slash", `Quick, parse_request_uri_triple_slash); - ("triple slash with host", `Quick, parse_request_uri_host_triple_slash); - ("no slash", `Quick, parse_request_uri_no_slash); - ("no slash with host", `Quick, parse_request_uri_host_no_slash); - ("empty", `Quick, parse_request_uri_empty); - ("empty with host", `Quick, parse_request_uri_host_empty); - ("path like scheme", `Quick, parse_request_uri_path_like_scheme); - ( "path like scheme with host", - `Quick, - parse_request_uri_host_path_like_scheme ); - ("path like host:port", `Quick, parse_request_uri_path_like_host_port); - ( "path like host:port with host", - `Quick, - parse_request_uri_host_path_like_host_port ); - ("with query string", `Quick, parse_request_uri_query); - ("with query with host", `Quick, parse_request_uri_host_query); - ( "no slash with query string", - `Quick, - parse_request_uri_query_no_slash ); - ( "no slash with query with host", - `Quick, - parse_request_uri_host_query_no_slash ); - ("CONNECT", `Quick, parse_request_connect); - ("CONNECT with host", `Quick, parse_request_connect_host); - ("OPTIONS", `Quick, parse_request_options); - ("OPTIONS with host", `Quick, parse_request_options_host); - ("parent traversal", `Quick, parse_request_uri_traversal); - ( "parent traversal with host", - `Quick, - parse_request_uri_host_traversal ); - ("uri round-trip", `Quick, uri_round_trip); - ] ); - ] diff --git a/cohttp/cohttp/test/unitary_test_header.ml b/cohttp/cohttp/test/unitary_test_header.ml deleted file mode 100644 index 4eca8617f3920f108326058e0d7962b26b346436..0000000000000000000000000000000000000000 --- a/cohttp/cohttp/test/unitary_test_header.ml +++ /dev/null @@ -1,401 +0,0 @@ -(*{{{ Copyright (c) 2021 Carine Morel - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *}}}*) - -module H = 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 [] - ) diff --git a/cohttp/cohttp_async_test/src/cohttp_async_test.ml b/cohttp/cohttp_async_test/src/cohttp_async_test.ml deleted file mode 100644 index 3212bb4cac1a43630589e3e4e229904baade4b5a..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_async_test/src/cohttp_async_test.ml +++ /dev/null @@ -1,73 +0,0 @@ -open Base -open Async_kernel -open OUnit -open Cohttp_async - -type 'a io = 'a Deferred.t -type ic = Async_unix.Reader.t -type oc = Async_unix.Writer.t -type body = Body.t - -type response_action = - [ `Expert of Cohttp.Response.t * (ic -> oc -> unit io) - | `Response of Cohttp.Response.t * body ] - -type spec = Request.t -> body -> response_action io -type async_test = unit -> unit io - -let response rsp = `Response rsp - -let expert ?(rsp = Cohttp.Response.make ()) f _req _body = - return (`Expert (rsp, f)) - -let const rsp _req _body = rsp >>| response -let response_sequence = Cohttp_test.response_sequence failwith - -let get_port = - let port = ref 10_080 in - fun () -> - let v = !port in - Int.incr port; - v - -let temp_server ?port spec callback = - let port = match port with None -> get_port () | Some p -> p in - let uri = Uri.of_string ("http://0.0.0.0:" ^ Int.to_string port) in - let server = - Server.create_expert ~on_handler_error:`Raise - (Async.Tcp.Where_to_listen.of_port port) (fun ~body _sock req -> - spec req body) - in - server >>= fun server -> - callback uri >>= fun res -> - Server.close server >>| fun () -> res - -let test_server_s ?port ?(name = "Cohttp Server Test") spec f = - temp_server ?port spec (fun uri -> - Logs.info (fun m -> m "Test %s running on %s" name (Uri.to_string uri)); - let tests = f uri in - let results = - tests - |> Deferred.List.map ~how:`Sequential ~f:(fun (name, test) -> - Logs.debug (fun m -> m "Running %s" name); - let res = - try_with test >>| function - | Ok () -> `Ok - | Error exn -> `Exn exn - in - res >>| fun res -> (name, res)) - in - results >>| fun results -> - let ounit_tests = - results - |> List.map ~f:(fun (name, res) -> - name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x) - in - name >::: ounit_tests) - -let run_async_tests test = - (* enable logging to stdout *) - Fmt_tty.setup_std_outputs (); - Logs.set_level @@ Some Logs.Debug; - Logs.set_reporter (Logs_fmt.reporter ()); - test >>| fun a -> a |> OUnit.run_test_tt_main diff --git a/cohttp/cohttp_async_test/src/cohttp_async_test.mli b/cohttp/cohttp_async_test/src/cohttp_async_test.mli deleted file mode 100644 index 302d047806c2bafb04bce4e9717ecf1f07870968..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_async_test/src/cohttp_async_test.mli +++ /dev/null @@ -1,10 +0,0 @@ -open Async_kernel - -include - Cohttp_test.S - with type 'a io = 'a Deferred.t - and type body = Cohttp_async.Body.t - and type ic = Async_unix.Reader.t - and type oc = Async_unix.Writer.t - -val run_async_tests : OUnit.test io -> OUnit.test_result list Deferred.t diff --git a/cohttp/cohttp_async_test/src/dune b/cohttp/cohttp_async_test/src/dune deleted file mode 100644 index 265dcfceb88eb387efd81d33b96dee63720c0a41..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_async_test/src/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name cohttp_async_test) - (libraries fmt.tty uri.services async_kernel cohttp_test cohttp-async)) diff --git a/cohttp/cohttp_lwt_jsoo_test/package.json b/cohttp/cohttp_lwt_jsoo_test/package.json deleted file mode 100644 index 9f034adf3ca0369744c926e239ac5aa91a87c3e5..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_lwt_jsoo_test/package.json +++ /dev/null @@ -1,10 +0,0 @@ -{ - "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" - } -} diff --git a/cohttp/cohttp_lwt_jsoo_test/src/cohttp_lwt_jsoo_test.ml b/cohttp/cohttp_lwt_jsoo_test/src/cohttp_lwt_jsoo_test.ml deleted file mode 100644 index ed57301baed7072072b2985d4c6ac31462c8b5ff..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_lwt_jsoo_test/src/cohttp_lwt_jsoo_test.ml +++ /dev/null @@ -1,34 +0,0 @@ -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) diff --git a/cohttp/cohttp_lwt_jsoo_test/src/dune b/cohttp/cohttp_lwt_jsoo_test/src/dune deleted file mode 100644 index d627919509c1f04366e2841f569e131e2948df4c..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_lwt_jsoo_test/src/dune +++ /dev/null @@ -1,15 +0,0 @@ -(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)))) diff --git a/cohttp/cohttp_lwt_jsoo_test/src/test.js b/cohttp/cohttp_lwt_jsoo_test/src/test.js deleted file mode 100755 index 49e744cdb64f47b014547261d204e6c57690c8da..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_lwt_jsoo_test/src/test.js +++ /dev/null @@ -1,19 +0,0 @@ -#!/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() diff --git a/cohttp/cohttp_lwt_jsoo_test/yarn.lock b/cohttp/cohttp_lwt_jsoo_test/yarn.lock deleted file mode 100644 index e80db41966fa9b1b9194b50e84ff1e35645b61c3..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_lwt_jsoo_test/yarn.lock +++ /dev/null @@ -1,8 +0,0 @@ -# THIS IS AN AUTOGENERATED FILE. DO NOT EDIT THIS FILE DIRECTLY. -# yarn lockfile v1 - - -xmlhttprequest@^1.8.0: - version "1.8.0" - resolved "https://registry.yarnpkg.com/xmlhttprequest/-/xmlhttprequest-1.8.0.tgz#67fe075c5c24fef39f9d65f5f7b7fe75171968fc" - integrity sha1-Z/4HXFwk/vOfnWX197f+dRcZaPw= diff --git a/cohttp/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml b/cohttp/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml deleted file mode 100644 index f2c7493b3343beed2ef70f94fdf55275b78d8870..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml +++ /dev/null @@ -1,70 +0,0 @@ -open Lwt -open OUnit -open Cohttp_lwt_unix - -type 'a io = 'a Lwt.t -type ic = Lwt_io.input_channel -type oc = Lwt_io.output_channel -type body = Cohttp_lwt.Body.t - -type response_action = - [ `Expert of Cohttp.Response.t * (ic -> oc -> unit io) - | `Response of Cohttp.Response.t * body ] - -type spec = Request.t -> body -> response_action io -type async_test = unit -> unit Lwt.t - -let response rsp = `Response rsp - -let expert ?(rsp = Cohttp.Response.make ()) f _req _body = - return (`Expert (rsp, f)) - -let const rsp _req _body = rsp >|= response -let response_sequence = Cohttp_test.response_sequence Lwt.fail_with -let () = Debug.activate_debug () -let () = Logs.set_level (Some Info) - -let temp_server ?port spec callback = - let port = match port with None -> Cohttp_test.next_port () | Some p -> p in - let server = - Server.make_response_action ~callback:(fun _ req body -> spec req body) () - in - let uri = Uri.of_string ("http://0.0.0.0:" ^ string_of_int port) in - let server_failed, server_failed_wake = Lwt.task () in - let server = - Lwt.catch - (fun () -> Server.create ~backlog:40 ~mode:(`TCP (`Port port)) server) - (function - | Lwt.Canceled -> Lwt.return_unit - | x -> - Lwt.wakeup_exn server_failed_wake x; - Lwt.fail x) - in - Lwt.pick [ callback uri; server_failed ] >|= fun res -> - Lwt.cancel server; - res - -let test_server_s ?port ?(name = "Cohttp Server Test") spec f = - temp_server ?port spec (fun uri -> - Logs.info (fun f -> f "Test %s running on %s" name (Uri.to_string uri)); - let tests = f uri in - let results = - tests - |> Lwt_list.map_s (fun (name, test) -> - Logs.info (fun f -> f "Running %s" name); - let res = - Lwt.try_bind test - (fun () -> return `Ok) - (fun exn -> return (`Exn exn)) - in - res >|= fun res -> (name, res)) - in - results >|= fun results -> - let ounit_tests = - results - |> List.map (fun (name, res) -> - name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x) - in - name >::: ounit_tests) - -let run_async_tests test = test >|= OUnit.run_test_tt_main diff --git a/cohttp/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.mli b/cohttp/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.mli deleted file mode 100644 index e1529acc0d371a0b99c364c4d2d075a01d4b16f3..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.mli +++ /dev/null @@ -1,6 +0,0 @@ -include - Cohttp_test.S - with type 'a io = 'a Lwt.t - and type body = Cohttp_lwt.Body.t - and type ic = Lwt_io.input_channel - and type oc = Lwt_io.output_channel diff --git a/cohttp/cohttp_lwt_unix_test/src/dune b/cohttp/cohttp_lwt_unix_test/src/dune deleted file mode 100644 index a0e42106aca1e252c761ca8072c1244f19582865..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_lwt_unix_test/src/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name cohttp_lwt_unix_test) - (libraries conduit-lwt cohttp-lwt-unix cohttp_test oUnit)) diff --git a/cohttp/cohttp_server/cohttp_server.ml b/cohttp/cohttp_server/cohttp_server.ml deleted file mode 100644 index 008f475dc21001db5c5cc210abfa196289da0b2c..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_server/cohttp_server.ml +++ /dev/null @@ -1,109 +0,0 @@ -(*{{{ Copyright (c) 2014-2015 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(* This module contains I/O agnostic functions used by - Cohttp_server_lwt and Cohttp_server_async. *) - -open Printf - -let ( / ) = Filename.concat - -let compare_kind = function - | Some `Directory, Some `Directory -> 0 - | Some `Directory, _ -> -1 - | _, Some `Directory -> 1 - | Some `File, Some `File -> 0 - | Some `File, _ -> 1 - | _, Some `File -> -1 - | _, _ -> 0 - -let sort lst = - List.sort - (fun (ka, _sa, a) (kb, _sb, b) -> - let c = compare_kind (ka, kb) in - if c <> 0 then c - else String.compare (String.lowercase_ascii a) (String.lowercase_ascii b)) - lst - -let li ?title l = - let title = - match title with None -> "" | Some s -> sprintf "title=\"%s\" " s - in - sprintf "
  • %s
    • " title (Uri.to_string l) - -let kind_of_unix_kind = - Unix.( - function - | S_DIR -> `Directory - | S_REG -> `File - | S_SOCK -> `Socket - | S_BLK -> `Block - | S_FIFO -> `Fifo - | S_CHR -> `Char - | S_LNK -> `Link) - -let human_size_of_size size = - let size = Int64.to_float size in - let kibi = size /. 1024. in - if kibi < 1. then sprintf "%.0fB" size - else - let mibi = kibi /. 1024. in - if mibi < 1. then sprintf "%.1fKiB" kibi - else - let gibi = mibi /. 1024. in - if gibi < 1. then sprintf "%.1fMiB" mibi else sprintf "%.1fGiB" gibi - -let html_of_listing uri path listing info = - let html = - List.map - (fun (kind, size, f) -> - let encoded_f = Uri.pct_encode f in - match kind with - | Some `Directory -> - let link = Uri.with_path uri (path / encoded_f / "") in - li link (sprintf "%s/" f) - | Some `File -> - let link = Uri.with_path uri (path / encoded_f) in - li ~title:(human_size_of_size size) link f - | Some (`Socket | `Block | `Fifo | `Char | `Link) -> - sprintf "
  • %s
    • " f - | None -> sprintf "
  • Error with file: %s
    • " f) - (sort listing) - in - let contents = String.concat "\n" html in - sprintf - "

    Directory Listing for %s

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

    Forbidden

    %sis not a normal file or \ - directory

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

    Not Found

    %swas not found on this \ - server

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

    Method Not Allowed

    %sis not an allowed \ - method on %s

    Allowed methods on %s are \ - %s

    %s" - meth path path allowed info diff --git a/cohttp/cohttp_server/dune b/cohttp/cohttp_server/dune deleted file mode 100644 index 2f533d63737903f71e7d33065d7d5eea52aef962..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_server/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name cohttp_server) - (libraries cohttp)) diff --git a/cohttp/cohttp_test/src/cohttp_test.ml b/cohttp/cohttp_test/src/cohttp_test.ml deleted file mode 100644 index df96d73a6123727badfc58665a2d7ccb9d934555..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_test/src/cohttp_test.ml +++ /dev/null @@ -1,46 +0,0 @@ -open Cohttp - -module type S = sig - type 'a io - type ic - type oc - type body - - type response_action = - [ `Expert of Cohttp.Response.t * (ic -> oc -> unit io) - | `Response of Cohttp.Response.t * body ] - - type spec = Request.t -> body -> response_action io - type async_test = unit -> unit io - - val response : Response.t * body -> response_action - val expert : ?rsp:Cohttp.Response.t -> (ic -> oc -> unit io) -> spec - val const : (Response.t * body) io -> spec - val response_sequence : spec list -> spec - val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io - - val test_server_s : - ?port:int -> - ?name:string -> - spec -> - (Uri.t -> (string * async_test) list) -> - OUnit.test io - - val run_async_tests : OUnit.test io -> OUnit.test_results io -end - -let port = ref 9193 - -let next_port () = - let current_port = !port in - incr port; - current_port - -let response_sequence fail responses = - let xs = ref responses in - fun req body -> - match !xs with - | x :: xs' -> - xs := xs'; - x req body - | [] -> fail "response_sequence: Server exhausted responses" diff --git a/cohttp/cohttp_test/src/cohttp_test.mli b/cohttp/cohttp_test/src/cohttp_test.mli deleted file mode 100644 index 6e605c43b71eff579d9f51a58ec9585d87135174..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_test/src/cohttp_test.mli +++ /dev/null @@ -1,50 +0,0 @@ -open Cohttp - -module type S = sig - type 'a io - type ic - type oc - type body - - type response_action = - [ `Expert of Cohttp.Response.t * (ic -> oc -> unit io) - | `Response of Cohttp.Response.t * body ] - - type spec = Request.t -> body -> response_action io - (** A server that is being tested must be defined by providing a spec *) - - type async_test = unit -> unit io - - val response : Response.t * body -> response_action - val expert : ?rsp:Response.t -> (ic -> oc -> unit io) -> spec - - val const : (Response.t * body) io -> spec - (** A constant handler that always returns its argument *) - - val response_sequence : spec list -> spec - (** A server that process requests using the provided specs in sequence and - crashes on further reqeusts *) - - val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io - (** Create a temporary server according to spec that lives until the callback - thread is determined. The uri provided in the callback should be the base - uri for any requests made to the temp server *) - - val test_server_s : - ?port:int -> - ?name:string -> - spec -> - (Uri.t -> (string * async_test) list) -> - OUnit.test io - (** Create a test suite against a server defined by spec. Tests run - sequentially. *) - - val run_async_tests : OUnit.test io -> OUnit.test_results io - (** Run an async unit test and return and print the result *) -end - -val next_port : unit -> int -(** Internal API. Subject to breakage *) - -val response_sequence : - (string -> 'a) -> ('b -> 'c -> 'a) list -> 'b -> 'c -> 'a diff --git a/cohttp/cohttp_test/src/dune b/cohttp/cohttp_test/src/dune deleted file mode 100644 index 44686094b488788731223e874b2efd5a10e8d673..0000000000000000000000000000000000000000 --- a/cohttp/cohttp_test/src/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name cohttp_test) - (libraries cohttp oUnit)) diff --git a/cohttp/dune-project b/cohttp/dune-project deleted file mode 100644 index ad62607fd3a32b5183920b06713657a13799b12e..0000000000000000000000000000000000000000 --- a/cohttp/dune-project +++ /dev/null @@ -1,2 +0,0 @@ -(lang dune 2.0) -(name cohttp) diff --git a/cohttp/examples/async/dune b/cohttp/examples/async/dune deleted file mode 100644 index 8d875ddcbdd940fedcf589642d575a332cec1bfb..0000000000000000000000000000000000000000 --- a/cohttp/examples/async/dune +++ /dev/null @@ -1,8 +0,0 @@ -(executables - (names hello_world receive_post s3_cp) - (libraries mirage-crypto cohttp-async base async_kernel core_unix.command_unix)) - -(alias - (name runtest) - (package cohttp-async) - (deps hello_world.exe receive_post.exe)) diff --git a/cohttp/examples/async/hello_world.ml b/cohttp/examples/async/hello_world.ml deleted file mode 100644 index 1af93cf48cae8522160ad15adec64ef898c46a1f..0000000000000000000000000000000000000000 --- a/cohttp/examples/async/hello_world.ml +++ /dev/null @@ -1,38 +0,0 @@ -(* This file is in the public domain *) - -open Base -open Async_kernel -open Cohttp_async - -(* given filename: hello_world.ml compile with: - $ corebuild hello_world.native -pkg cohttp.async -*) - -let handler ~body:_ _sock req = - let uri = Cohttp.Request.uri req in - match Uri.path uri with - | "/test" -> - Uri.get_query_param uri "hello" - |> Option.map ~f:(fun v -> "hello: " ^ v) - |> Option.value ~default:"No param hello supplied" - |> Server.respond_string - | _ -> Server.respond_string ~status:`Not_found "Route not found" - -let start_server port () = - Stdlib.Printf.eprintf "Listening for HTTP on port %d\n" port; - Stdlib.Printf.eprintf "Try 'curl http://localhost:%d/test?hello=xyz'\n%!" port; - Cohttp_async.Server.create ~on_handler_error:`Raise - (Async.Tcp.Where_to_listen.of_port port) - handler - >>= fun _ -> Deferred.never () - -let () = - let module Command = Async_command in - Command.async_spec ~summary:"Start a hello world Async server" - Command.Spec.( - empty - +> flag "-p" - (optional_with_default 8080 int) - ~doc:"int Source port to listen on") - start_server - |> Command_unix.run diff --git a/cohttp/examples/async/receive_post.ml b/cohttp/examples/async/receive_post.ml deleted file mode 100644 index 34ea2c183f5ca683c104c97191c9aa4e2a4f1ec6..0000000000000000000000000000000000000000 --- a/cohttp/examples/async/receive_post.ml +++ /dev/null @@ -1,31 +0,0 @@ -(* This file is in the public domain *) -open Base -open Async_kernel -open Cohttp_async - -(* compile with: $ corebuild receive_post.native -pkg cohttp.async *) - -let start_server port () = - Stdlib.Printf.eprintf "Listening for HTTP on port %d\n" port; - Stdlib.Printf.eprintf "Try 'curl -X POST -d 'foo bar' http://localhost:%d\n" - port; - Cohttp_async.Server.create ~on_handler_error:`Raise - (Async.Tcp.Where_to_listen.of_port port) (fun ~body _ req -> - match req |> Cohttp.Request.meth with - | `POST -> - Body.to_string body >>= fun body -> - Stdlib.Printf.eprintf "Body: %s" body; - Server.respond `OK - | _ -> Server.respond `Method_not_allowed) - >>= fun _ -> Deferred.never () - -let () = - let module Command = Async_command in - Command.async_spec ~summary:"Simple http server that outputs body of POST's" - Command.Spec.( - empty - +> flag "-p" - (optional_with_default 8080 int) - ~doc:"int Source port to listen on") - start_server - |> Command_unix.run diff --git a/cohttp/examples/async/s3_cp.ml b/cohttp/examples/async/s3_cp.ml deleted file mode 100644 index 48a6f6482a2bf35a85618a9df8a8ea0d3732da32..0000000000000000000000000000000000000000 --- a/cohttp/examples/async/s3_cp.ml +++ /dev/null @@ -1,405 +0,0 @@ -(*{{{ Copyright (C) 2015 Trevor Smith - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** This example is here to show how to get and put to s3 using the async client - code. - - This hopes to be a useful example because: 1) it is a real world use of the - client 2) s3 auth requires a bit of fiddling with the headers hopefully this - is illustative for anyone else doing the same - - The reader will want to be familiar with the S3 API Documentation found - here: http://docs.aws.amazon.com/AmazonS3/latest/API/Welcome.html This - example was written using the API Version 2006-03-01. - - There are two ways to authenticate with S3, this example uses the - authorization header approach (p. 19 of the api reference). - - Downloads from S3 are done using the GET method, and uploads are done using - the PUT method. - - To get this to work, you'll need an AWS access/secret key pair that has the - "s3:GetObject" and "s3:PutObject" permissions enabled for the bucket you are - interacting with. - - As this is an example, straightforwardness is prized. One should not use - this for a production system, nor assume that it offers a good example of - abstraction, interface design or error handling. *) - -open Base -open Core -open Async -open Cohttp -open Cohttp_async - -module Time = Time_float - -let ksrt (k, _) (k', _) = String.compare k k' - -module Compat = struct - (** Things we need to make this happen that, ideally, we'd like other - libraries to provide and that are orthogonal to the example here *) - - let encode_string s = - (* Percent encode the path as s3 wants it. Uri doesn't - encode $, or the other sep characters in a path. - If upstream allows that we can nix this function *) - let n = String.length s in - let buf = Buffer.create (n * 3) in - for i = 0 to n - 1 do - let c = s.[i] in - match c with - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' | '~' | '.' | '/' -> - Buffer.add_char buf c - | '%' -> - (* Sigh. Annoying we're expecting already escaped strings so ignore the escapes *) - let is_hex = function - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> true - | _ -> false - in - if i + 2 < n then - if is_hex s.[i + 1] && is_hex s.[i + 2] then Buffer.add_char buf c - else Buffer.add_string buf "%25" - | _ -> Buffer.add_string buf (Printf.sprintf "%%%X" (Char.to_int c)) - done; - Buffer.contents buf - - let hexa = "0123456789abcdef" - - let of_char c = - let x = Char.to_int c in - (hexa.[x lsr 4], hexa.[x land 0xf]) - - let cstruct_to_hex_string cs = - let open Cstruct in - let n = cs.len in - let buf = Buffer.create (n * 2) in - for i = 0 to n - 1 do - let c = cs.buffer.{cs.off + i} in - let x, y = of_char c in - Buffer.add_char buf x; - Buffer.add_char buf y - done; - Buffer.contents buf - - let encode_query_string uri = - (* Sort and encode query string. - Note that AWS wants null keys to have '=' for all keys. - URI.encoded_of_query encodes [""] as ?a=, and [] as ?a. - *) - Uri.query uri - |> List.sort ~compare:ksrt - |> List.map ~f:(fun (k, v) -> (k, match v with [] -> [ "" ] | x -> x)) - |> Uri.encoded_of_query - - let format_time t = - (* Core.Std.Time doesn't have a format function that takes a timezone *) - let d, s = Time.to_date_ofday ~zone:Time.Zone.utc t in - let open Time.Span.Parts in - let { hr; min; sec; _ } = Time.Ofday.to_parts s in - Printf.sprintf "%sT%.2d%.2d%.2dZ" - (Date.to_string_iso8601_basic d) - hr min sec -end - -type region = - [ `Ap_northeast_1 (* Asia Pacific (Tokyo) *) - | `Ap_southeast_1 (* Asia Pacific (Singapore) *) - | `Ap_southeast_2 (* Asia Pacific (Sydney) *) - | `Eu_central_1 (* EU (Frankfurt) *) - | `Eu_west_1 (* EU (Ireland) *) - | `Sa_east_1 (* South America (Sao Paulo) *) - | `Us_east_1 (* US East (N. Virginia) *) - | `Us_west_1 (* US West (N. California) *) - | `Us_west_2 (* US West (Oregon) *) ] -[@@deriving sexp] - -let region_of_string = function - | "ap-northeast-1" -> `Ap_northeast_1 - | "ap-southeast-1" -> `Ap_southeast_1 - | "ap-southeast-2" -> `Ap_southeast_2 - | "eu-central-1" -> `Eu_central_1 - | "eu-west-1" -> `Eu_west_1 - | "sa-east-1" -> `Sa_east_1 - | "us-east-1" -> `Us_east_1 - | "us-west-1" -> `Us_west_1 - | "us-west-2" -> `Us_west_2 - | s -> raise (Invalid_argument ("region_of_string: " ^ s)) - -let string_of_region = function - | `Ap_northeast_1 -> "ap-northeast-1" - | `Ap_southeast_1 -> "ap-southeast-1" - | `Ap_southeast_2 -> "ap-southeast-2" - | `Eu_central_1 -> "eu-central-1" - | `Eu_west_1 -> "eu-west-1" - | `Sa_east_1 -> "sa-east-1" - | `Us_east_1 -> "us-east-1" - | `Us_west_1 -> "us-west-1" - | `Us_west_2 -> "us-west-2" - -let region_host_string = function - | `Ap_northeast_1 -> "s3-ap-northeast-1.amazonaws.com" - | `Ap_southeast_1 -> "s3-ap-southeast-1.amazonaws.com" - | `Ap_southeast_2 -> "s3-ap-southeast-2.amazonaws.com" - | `Eu_central_1 -> "s3-eu-central-1.amazonaws.com" - | `Eu_west_1 -> "s3-eu-west-1.amazonaws.com" - | `Sa_east_1 -> "s3-sa-east-1.amazonaws.com" - | `Us_east_1 -> "s3.amazonaws.com" - | `Us_west_1 -> "s3-us-west-1.amazonaws.com" - | `Us_west_2 -> "s3-us-west-2.amazonaws.com" - -type service = [ `S3 ] [@@deriving sexp] - -let string_of_service = function `S3 -> "s3" - -module Auth = struct - (** AWS S3 Authorization *) - - let digest s = - (* string -> sha256 as a hex string *) - Mirage_crypto.Hash.(digest `SHA256 (Cstruct.of_string s)) - |> Compat.cstruct_to_hex_string - - let make_amz_headers ?body time = - (* Return x-amz-date and x-amz-sha256 headers *) - let hashed_payload = - match body with - | None -> - "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" - | Some s -> digest s - in - ( [ - ("x-amz-content-sha256", hashed_payload); - ("x-amz-date", Compat.format_time time); - ], - hashed_payload ) - - let canonical_request hashed_payload (request : Cohttp_async.Request.t) = - (* This corresponds to p.21 of the s3 api doc - we're making: - \n - \n - \n - \n - \n - - *) - let open Cohttp.Request in - let http_method = Code.string_of_method request.meth in - (* Nb the path will be url encoded as per spec *) - let uri = Cohttp.Request.uri request in - let canoncical_uri = Compat.encode_string (Uri.path uri) in - (* Sort query string in alphabetical order by key *) - let canonical_query = Compat.encode_query_string uri in - let sorted_headers = - Header.to_list request.headers |> List.sort ~compare:ksrt - in - let canonical_headers = - sorted_headers - |> List.fold ~init:"" ~f:(fun acc (k, v) -> - acc - ^ Printf.sprintf "%s:%s\n" (String.lowercase k) (String.strip v)) - in - let signed_headers = - sorted_headers |> List.map ~f:(fun (k, _) -> k) |> String.concat ~sep:";" - in - ( Printf.sprintf "%s\n%s\n%s\n%s\n%s\n%s" http_method canoncical_uri - canonical_query canonical_headers signed_headers hashed_payload, - signed_headers ) - - let string_to_sign ?time ~scope ~service canonical_request : string = - (* As per p. 23 of s3 api doc. The requests need current time in utc - time parameter is there for testing. *) - let time_str = - match time with - | None -> Time.to_string_abs ~zone:Time.Zone.utc (Time.now ()) - | Some t -> Compat.format_time t - in - let scope_date, scope_region = scope in - let scope_str = - Printf.sprintf "%s/%s/%s/aws4_request" - (Date.to_string_iso8601_basic scope_date) - (string_of_region scope_region) - (string_of_service service) - in - let hashed_req = digest canonical_request in - Printf.sprintf "AWS4-HMAC-SHA256\n%s\n%s\n%s" time_str scope_str hashed_req - - let make_signing_key ?date ~region ~service ~secret_access_key () = - let mac k v = - Mirage_crypto.Hash.(mac `SHA256 ~key:k (Cstruct.of_string v)) - in - let date' = - match date with None -> Date.today ~zone:Time.Zone.utc | Some d -> d - in - let date_str = Date.to_string_iso8601_basic date' in - let date_key = - mac (Cstruct.of_string ("AWS4" ^ secret_access_key)) date_str - in - let date_region_key = mac date_key (string_of_region region) in - let date_region_service_key = - mac date_region_key (string_of_service service) - in - let signing_key = mac date_region_service_key "aws4_request" in - signing_key - - let auth_request ?now ~hashed_payload ~region ~service ~aws_access_key - ~aws_secret_key request = - (* Important use the same time for everything here *) - let time = Option.value ~default:(Time.now ()) now in - let date = Time.to_date ~zone:Time.Zone.utc time in - let canonical_request, signed_headers = - canonical_request hashed_payload request - in - let string_to_sign = - string_to_sign ~time ~scope:(date, region) ~service canonical_request - in - let signing_key = - make_signing_key ~date ~region ~service ~secret_access_key:aws_secret_key - () - in - let creds = - Printf.sprintf "%s/%s/%s/%s/aws4_request" aws_access_key - (Date.to_string_iso8601_basic date) - (string_of_region region) - (string_of_service service) - in - let signature = - Mirage_crypto.Hash.( - mac `SHA256 ~key:signing_key (Cstruct.of_string string_to_sign)) - in - let auth_header = - Printf.sprintf - "AWS4-HMAC-SHA256 Credential=%s,SignedHeaders=%s,Signature=%s" creds - signed_headers - (Compat.cstruct_to_hex_string signature) - in - [ ("Authorization", auth_header) ] -end - -module S3 = struct - type conf = { - region : region; - aws_access_key : string; - aws_secret_key : string; - } - [@@deriving sexp] - - let make_request ?body conf ~meth ~bucket ~objekt = - let host_str = region_host_string conf.region in - let uri = - Printf.sprintf "https://%s/%s/%s" host_str bucket objekt |> Uri.of_string - in - let time = Time.now () in - (* If PUT add content length *) - let headers = - match meth with - | `PUT -> - let length = Option.value_map ~f:String.length ~default:0 body in - [ ("Content-length", Int.to_string length) ] - | _ -> [] - in - let headers = headers @ [ ("Host", host_str) ] in - let amz_headers, hashed_payload = Auth.make_amz_headers time ?body in - let headers = headers @ amz_headers in - let request = Request.make ~meth ~headers:(Header.of_list headers) uri in - let auth_header = - Auth.auth_request ~now:time ~hashed_payload ~region:conf.region - ~service:`S3 ~aws_access_key:conf.aws_access_key - ~aws_secret_key:conf.aws_secret_key request - in - let headers = headers @ auth_header |> Header.of_list in - let request = { request with Cohttp.Request.headers } in - match meth with - | `PUT -> - Client.request - ~body:(Option.value_map ~f:Body.of_string ~default:`Empty body) - request - | `GET -> Client.request request - | _ -> failwith "not possible right now" -end - -type s3path = { bucket : string; objekt : string } -type cmd = S3toLocal of s3path * string | LocaltoS3 of string * s3path - -let determine_s3_parts s = - (* Takes: string of the form s3:/// *) - let s = String.drop_prefix s 5 in - let parts = String.split ~on:'/' s in - match parts with - | bucket :: rst -> { bucket; objekt = String.concat ~sep:"/" rst } - | _ -> failwith "error format must be 's3:///'" - -let determine_paths src dst = - let is_s3 s = String.is_prefix ~prefix:"s3://" s in - match (is_s3 src, is_s3 dst) with - | true, false -> S3toLocal (determine_s3_parts src, dst) - | false, true -> LocaltoS3 (src, determine_s3_parts dst) - | false, false -> failwith "Use cp(1) :)" - | true, true -> failwith "Does not support copying from s3 to s3" - -let main region_str aws_access_key aws_secret_key src dst () = - (* nb client does not support redirects or preflight 100 *) - let open S3 in - let region = region_of_string region_str in - let conf = { region; aws_access_key; aws_secret_key } in - match determine_paths src dst with - | S3toLocal (src, dst) -> ( - make_request conf ~meth:`GET ~bucket:src.bucket ~objekt:src.objekt - >>= fun (resp, body) -> - match Cohttp.Response.(resp.status) with - | #Code.success_status -> - Body.to_string body >>| fun s -> - Out_channel.with_file - ~f:(fun oc -> Out_channel.output_string oc s) - dst; - Core.Printf.printf "Wrote s3://%s to %s\n" (src.bucket ^ src.objekt) - dst - | _ -> - Core.Printf.printf "Error: %s\n" - (Sexp.to_string (Response.sexp_of_t resp)); - return ()) - | LocaltoS3 (src, dst) -> ( - let body = - In_channel.with_file src ~f:(fun ic -> In_channel.input_all ic) - in - make_request ~body conf ~meth:`PUT ~bucket:dst.bucket ~objekt:dst.objekt - >>= fun (resp, body) -> - match Cohttp.Response.status resp with - | #Code.success_status -> - Core.Printf.printf "Wrote %s to s3://%s\n" src - (dst.bucket ^ dst.objekt); - return () - | _ -> - Body.to_string body >>| fun s -> - Core.Printf.printf "Error: %s\n%s\n" - (Sexp.to_string (Response.sexp_of_t resp)) - s) - -let () = - let open Async_command in - async_spec ~summary:"Simple command line client that copies files to/from S3" - Spec.( - empty - +> flag "-r" - (optional_with_default "us-east-1" string) - ~doc:"string AWS Region" - +> anon ("aws_access_key" %: string) - +> anon ("aws_secret_key" %: string) - +> anon ("src" %: string) - +> anon ("dst" %: string)) - main - |> Command_unix.run diff --git a/cohttp/examples/lwt_unix_doc/client_lwt.ml b/cohttp/examples/lwt_unix_doc/client_lwt.ml deleted file mode 100644 index cbc8bb56e3abd16cab5b3a24acb685b29e287263..0000000000000000000000000000000000000000 --- a/cohttp/examples/lwt_unix_doc/client_lwt.ml +++ /dev/null @@ -1,16 +0,0 @@ -open Lwt -open Cohttp -open Cohttp_lwt_unix - -let body = - Client.get (Uri.of_string "https://www.reddit.com/") >>= fun (resp, body) -> - let code = resp |> Response.status |> Code.code_of_status in - Printf.printf "Response code: %d\n" code; - Printf.printf "Headers: %s\n" (resp |> Response.headers |> Header.to_string); - body |> Cohttp_lwt.Body.to_string >|= fun body -> - Printf.printf "Body of length: %d\n" (String.length body); - body - -let () = - let body = Lwt_main.run body in - print_endline ("Received body\n" ^ body) diff --git a/cohttp/examples/lwt_unix_doc/client_lwt_timeout.ml b/cohttp/examples/lwt_unix_doc/client_lwt_timeout.ml deleted file mode 100644 index 399cc850f3a70a838a66f757a9dbbcd85900dbdc..0000000000000000000000000000000000000000 --- a/cohttp/examples/lwt_unix_doc/client_lwt_timeout.ml +++ /dev/null @@ -1,26 +0,0 @@ -open Lwt -open Cohttp -open Cohttp_lwt_unix - -let compute ~time ~f = - Lwt.pick - [ - (f () >|= fun v -> `Done v); (Lwt_unix.sleep time >|= fun () -> `Timeout); - ] - -let body = - let get () = Client.get (Uri.of_string "https://www.reddit.com/") in - compute ~time:0.1 ~f:get >>= function - | `Timeout -> Lwt.fail_with "Timeout expired" - | `Done (resp, body) -> - let code = resp |> Response.status |> Code.code_of_status in - Printf.printf "Response code: %d\n" code; - Printf.printf "Headers: %s\n" - (resp |> Response.headers |> Header.to_string); - body |> Cohttp_lwt.Body.to_string >|= fun body -> - Printf.printf "Body of length: %d\n" (String.length body); - body - -let () = - let body = Lwt_main.run body in - print_endline ("Received body\n" ^ body) diff --git a/cohttp/examples/lwt_unix_doc/docker_lwt.ml b/cohttp/examples/lwt_unix_doc/docker_lwt.ml deleted file mode 100644 index 3357fed083bd35e8f12f0675a0581855803c6365..0000000000000000000000000000000000000000 --- a/cohttp/examples/lwt_unix_doc/docker_lwt.ml +++ /dev/null @@ -1,22 +0,0 @@ -open Lwt.Infix -open Cohttp_lwt_unix - -let ctx = - let resolver = - let h = Hashtbl.create 1 in - Hashtbl.add h "docker" (`Unix_domain_socket "/var/run/docker.sock"); - Resolver_lwt_unix.static h - in - Cohttp_lwt_unix.Client.custom_ctx ~resolver () - -let t = - Client.get (Uri.of_string "http://docker/version") >>= fun (resp, body) -> - let open Cohttp in - let code = resp |> Response.status |> Code.code_of_status in - Printf.printf "Response code: %d\n" code; - Printf.printf "Headers: %s\n" (resp |> Response.headers |> Header.to_string); - body |> Cohttp_lwt.Body.to_string >|= fun body -> - Printf.printf "Body of length: %d\n" (String.length body); - print_endline ("Received body\n" ^ body) - -let _ = Lwt_main.run t diff --git a/cohttp/examples/lwt_unix_doc/dune b/cohttp/examples/lwt_unix_doc/dune deleted file mode 100644 index c323e76d54293c97946bb95a9af6f0f18b5b2172..0000000000000000000000000000000000000000 --- a/cohttp/examples/lwt_unix_doc/dune +++ /dev/null @@ -1,8 +0,0 @@ -(executables - (names client_lwt client_lwt_timeout docker_lwt server_lwt) - (libraries cohttp-lwt-unix)) - -(alias - (name runtest) - (package cohttp-lwt-unix) - (deps client_lwt.exe client_lwt_timeout.exe docker_lwt.exe server_lwt.exe)) diff --git a/cohttp/examples/lwt_unix_doc/server_lwt.ml b/cohttp/examples/lwt_unix_doc/server_lwt.ml deleted file mode 100644 index 60b30f3e609feb1ec2b782161da18f5f0081706e..0000000000000000000000000000000000000000 --- a/cohttp/examples/lwt_unix_doc/server_lwt.ml +++ /dev/null @@ -1,17 +0,0 @@ -open Lwt -open Cohttp -open Cohttp_lwt_unix - -let server = - let callback _conn req body = - let uri = req |> Request.uri |> Uri.to_string in - let meth = req |> Request.meth |> Code.string_of_method in - let headers = req |> Request.headers |> Header.to_string in - ( body |> Cohttp_lwt.Body.to_string >|= fun body -> - Printf.sprintf "Uri: %s\nMethod: %s\nHeaders\nHeaders: %s\nBody: %s" uri - meth headers body ) - >>= fun body -> Server.respond_string ~status:`OK ~body () - in - Server.create ~mode:(`TCP (`Port 8000)) (Server.make ~callback ()) - -let () = ignore (Lwt_main.run server) diff --git a/manifest/Makefile b/manifest/Makefile index cb5cf83f5fe1721b14bde1ca9473a1ccc555f525..5b0f20d488b7157c94815be60b079f7b8ec8312d 100644 --- a/manifest/Makefile +++ b/manifest/Makefile @@ -6,6 +6,7 @@ SOURCE=JSON_AST.ml JSON_parser.mli JSON_parser.ml JSON_lexer.ml tezos_protocol.m externals.ml \ internals.ml \ product_data_encoding.mli product_data_encoding.ml \ + product_cohttp.mli product_cohttp.ml \ product_prometheus.mli product_prometheus.ml \ product_resto.mli product_resto.ml \ product_octez.mli product_octez.ml \ diff --git a/manifest/externals.ml b/manifest/externals.ml index 65baa9b03a554dd14c4e001383573245641d0b59..8e358b2f66c71deaa6fe1f6ecaf5e8de7d0a1cac 100644 --- a/manifest/externals.ml +++ b/manifest/externals.ml @@ -70,10 +70,6 @@ let cmdliner = external_lib "cmdliner" V.(at_least "1.1.0") let conduit_lwt_unix = external_lib "conduit-lwt-unix" V.(exactly "6.2.2") -let cohttp_lwt = external_lib "cohttp-lwt" V.(at_least "5.2.0") - -let cohttp_lwt_unix = external_lib "cohttp-lwt-unix" V.(at_least "5.2.0") - let compiler_libs_common = external_lib "compiler-libs.common" V.True ~opam:"" let compiler_libs_optcomp = external_lib "compiler-libs.optcomp" V.True ~opam:"" diff --git a/manifest/product_cohttp.ml b/manifest/product_cohttp.ml new file mode 100644 index 0000000000000000000000000000000000000000..6fccd6454109c3b4b0c2229de7e6a2d8a77537aa --- /dev/null +++ b/manifest/product_cohttp.ml @@ -0,0 +1,17 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* SPDX-FileCopyrightText: 2024 Trili Tech *) +(* *) +(*****************************************************************************) + +open Manifest +open Externals + +(* Ultimately, cohttp will use the local sources from `cohttp/`. + For now we still use the opam package (see below, uses of + `external_lib`). This temporary state is to minimise disruptions + for other developers and reducing the size of MRs. *) +let cohttp_lwt = external_lib "cohttp-lwt" V.(exactly "5.3.0") + +let cohttp_lwt_unix = external_lib "cohttp-lwt-unix" V.(exactly "5.3.0") diff --git a/manifest/product_cohttp.mli b/manifest/product_cohttp.mli new file mode 100644 index 0000000000000000000000000000000000000000..1849bebb5f7cdb2296a327e2563a99247dc151c0 --- /dev/null +++ b/manifest/product_cohttp.mli @@ -0,0 +1,10 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* SPDX-FileCopyrightText: 2024 Trili Tech *) +(* *) +(*****************************************************************************) + +val cohttp_lwt : Manifest.target + +val cohttp_lwt_unix : Manifest.target diff --git a/manifest/product_octez.ml b/manifest/product_octez.ml index 7e1d0c23bddf58a312e0367f32566228068d921d..a55881a7bb401e04af04d5a0af566d077e71544a 100644 --- a/manifest/product_octez.ml +++ b/manifest/product_octez.ml @@ -13,6 +13,7 @@ open Internals open Product_data_encoding open Product_prometheus open Product_resto +open Product_cohttp include Product (struct let name = "octez" diff --git a/manifest/product_prometheus.ml b/manifest/product_prometheus.ml index 314f9ceea55a59d093b7b64e1eee9956f0b19ee3..4d40ddb483bc6212d957475fa7515b9cc3dadf02 100644 --- a/manifest/product_prometheus.ml +++ b/manifest/product_prometheus.ml @@ -7,6 +7,7 @@ open Manifest open Externals +open Product_cohttp let product_source = ["prometheus/"] diff --git a/manifest/product_resto.ml b/manifest/product_resto.ml index b74e445cbfd263a918a6ae9f87845e2e6cf8286e..365abe6751698a006640ec0628c1953c2bdb8289 100644 --- a/manifest/product_resto.ml +++ b/manifest/product_resto.ml @@ -8,6 +8,7 @@ open Manifest open Externals open Product_data_encoding +open Product_cohttp let product_source = ["resto/"] diff --git a/opam/RPC-toy.opam b/opam/RPC-toy.opam index 09345292ef7d423f69b5996a0d736ec72f3f6873..5415c7d6087aede33e2b45d2a40162f3b8d157e3 100644 --- a/opam/RPC-toy.opam +++ b/opam/RPC-toy.opam @@ -11,7 +11,7 @@ depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } "octez-libs" { = version } - "cohttp-lwt-unix" { >= "5.2.0" } + "cohttp-lwt-unix" { = "5.3.0" } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/octez-libs.opam b/opam/octez-libs.opam index 3b74f533b5d7ed0ef5edf6d2db2c32477ec1e384..98db7bf5fcf1e001ba8392b063f955bb87716e19 100644 --- a/opam/octez-libs.opam +++ b/opam/octez-libs.opam @@ -24,10 +24,10 @@ depends: [ "astring" "asetmap" { >= "0.8.1" } "re" { >= "1.10.0" } - "cohttp-lwt" { >= "5.2.0" } + "cohttp-lwt" { = "5.3.0" } "fmt" { >= "0.8.7" } "cmdliner" { >= "1.1.0" } - "cohttp-lwt-unix" { >= "5.2.0" } + "cohttp-lwt-unix" { = "5.3.0" } "logs" "alcotest-lwt" { >= "1.5.0" } "conduit-lwt-unix" { = "6.2.2" } diff --git a/opam/octez-smart-rollup-node-lib.opam b/opam/octez-smart-rollup-node-lib.opam index cbf286c21b4efd1967e12ae28bb28b0df4a3f493..9873049828194e9a9dce07c85852ce04fb28c34e 100644 --- a/opam/octez-smart-rollup-node-lib.opam +++ b/opam/octez-smart-rollup-node-lib.opam @@ -12,7 +12,7 @@ depends: [ "ocaml" { >= "4.14" } "octez-libs" { = version } "octez-shell-libs" { = version } - "cohttp-lwt-unix" { >= "5.2.0" } + "cohttp-lwt-unix" { = "5.3.0" } "tezos-openapi" { = version } "octez-node-config" { = version } "camlzip" { >= "1.11" & < "1.12" } diff --git a/opam/octez-smart-rollup-wasm-debugger-lib.opam b/opam/octez-smart-rollup-wasm-debugger-lib.opam index 8aef23f9c0e8aa801b2c46b8995db5952a277cb5..1f3a45602cec317ed70fd9a5da6ad44dcc062b51 100644 --- a/opam/octez-smart-rollup-wasm-debugger-lib.opam +++ b/opam/octez-smart-rollup-wasm-debugger-lib.opam @@ -12,7 +12,7 @@ depends: [ "ocaml" { >= "4.14" } "octez-libs" { = version } "octez-protocol-alpha-libs" { = version } - "cohttp-lwt-unix" { >= "5.2.0" } + "cohttp-lwt-unix" { = "5.3.0" } "octez-l2-libs" { = version } "octez-version" { = version } "octez-smart-rollup-wasm-debugger-plugin" { = version } diff --git a/opam/tezt-tezos.opam b/opam/tezt-tezos.opam index bd2d08e5ad21ecf8f18dfbd3c0caaf8fd67ed21e..e1e1f37a62be2944abce0891f8b4f5ed384468fc 100644 --- a/opam/tezt-tezos.opam +++ b/opam/tezt-tezos.opam @@ -12,7 +12,7 @@ depends: [ "ocaml" { >= "4.14" } "octez-libs" { = version } "uri" { >= "3.1.0" } - "cohttp-lwt-unix" { >= "5.2.0" } + "cohttp-lwt-unix" { = "5.3.0" } "tezt" { >= "4.1.0" & < "5.0.0" } "hex" { >= "1.3.0" } ] diff --git a/opam/virtual/octez-deps.opam b/opam/virtual/octez-deps.opam index eaf1f50bf6a9adce35ac4920300b20d58b0add1f..95c1da8bc2630d5b826d2bcf69a5aac438d1571b 100644 --- a/opam/virtual/octez-deps.opam +++ b/opam/virtual/octez-deps.opam @@ -29,8 +29,8 @@ depends: [ "checkseum" { != "0.5.0" } "class_group_vdf" { >= "0.0.4" } "cmdliner" { >= "1.1.0" } - "cohttp-lwt" { >= "5.2.0" } - "cohttp-lwt-unix" { >= "5.2.0" } + "cohttp-lwt" { = "5.3.0" } + "cohttp-lwt-unix" { = "5.3.0" } "conduit-lwt-unix" { = "6.2.2" } "conf-libev" "conf-rust"