swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

23
unikernel/duniverse/ocaml-h2/.github/workflows/test.yml vendored Normal file
View file

@ -0,0 +1,23 @@
name: "Build"
on:
pull_request:
push:
branches:
- master
jobs:
tests:
runs-on: ubuntu-latest
strategy:
matrix:
ocamlVersion: [4_14, 5_1, 5_2]
steps:
- uses: actions/checkout@v4
with:
submodules: 'recursive'
- uses: cachix/install-nix-action@v27
with:
extra_nix_config: |
extra-substituters = https://anmonteiro.nix-cache.workers.dev
extra-trusted-public-keys = ocaml.nix-cache.com-1:/xI2h2+56rwFfKyyFVbkJSeGqSIYMC/Je+7XXqGKDIY=
- name: "Run nix-build"
run: nix-build ./nix/ci/test.nix --argstr ocamlVersion ${{ matrix.ocamlVersion }}

4
unikernel/duniverse/ocaml-h2/.gitignore vendored Normal file
View file

@ -0,0 +1,4 @@
_esy
_build
*.install
*.merlin

6
unikernel/duniverse/ocaml-h2/.gitmodules vendored Normal file
View file

@ -0,0 +1,6 @@
[submodule "hpack/test/hpack-test-case"]
path = hpack/test/hpack-test-case
url = https://github.com/http2jp/hpack-test-case.git
[submodule "lib_test/http2-frame-test-case"]
path = lib_test/http2-frame-test-case
url = https://github.com/http2jp/http2-frame-test-case.git

28
unikernel/duniverse/ocaml-h2/.ocamlformat Normal file
View file

@ -0,0 +1,28 @@
break-infix = fit-or-vertical
break-infix-before-func = false
break-fun-decl = fit-or-vertical
break-separators = before
break-sequences = true
cases-exp-indent = 2
dock-collection-brackets = false
field-space = loose
if-then-else = keyword-first
indicate-multiline-delimiters = no
infix-precedence = parens
leading-nested-match-parens = true
let-and = sparse
let-module = sparse
ocp-indent-compat = true
parens-tuple = multi-line-only
parse-docstrings = false
sequence-blank-line = preserve-one
sequence-style = terminator
single-case = sparse
space-around-arrays= true
space-around-lists= true
space-around-records= true
space-around-variants= true
type-decl = sparse
wrap-comments = true
wrap-fun-args = false

1
unikernel/duniverse/ocaml-h2/.ocamlformat-ignore Normal file
View file

@ -0,0 +1 @@
hpack/src/huffman_table.ml

289
unikernel/duniverse/ocaml-h2/CHANGES.md Normal file
View file

@ -0,0 +1,289 @@
0.13.0 2024-09-04
--------------
- h2: surface (body) write failures through `flush`
([#247](https://github.com/anmonteiro/ocaml-h2/pull/247))
- `Body.Writer.flush` now takes a callback of the type
``([ `Written | ` Closed] -> unit)``, informing the caller whether the
previous writes have been written or whether the output channel was
closed.
0.12.0 2024-06-23
--------------
- hpack: fix huffman encoding for codes > 24bit
([#229](https://github.com/anmonteiro/ocaml-h2/pull/229))
- h2-eio: don't require `Eio_unix.stream_socket_ty`, allowing the use of mock
sockets ([#236](https://github.com/anmonteiro/gluten/pull/236))
- h2: drop the dependency on `httpaf`, use
[`httpun-types`](https://ocaml.org/p/httpun-types/latest) instead
([#243](https://github.com/anmonteiro/ocaml-h2/pull/243))
- hpack: use `String.unsafe_get` when the string length is known
([#244](https://github.com/anmonteiro/ocaml-h2/pull/244))
0.11.0 2023-10-26
--------------
- h2-eio: adapt to Eio v0.12
([#225](https://github.com/anmonteiro/ocaml-h2/pull/225))
- h2-eio: track sw for gluten
([#215](https://github.com/anmonteiro/ocaml-h2/pull/215))
- h2: Add hpack {= version} constraint
([#214](https://github.com/anmonteiro/ocaml-h2/pull/214))
- h2, hpack, h2-async: Add opam constraints for angstrom and gluten-async
([#212](https://github.com/anmonteiro/ocaml-h2/pull/212))
- h2: read available `Body.Reader.t` immediately upon calling
`Body.Reader.schedule_read`
([#238](https://github.com/anmonteiro/ocaml-h2/pull/238))
0.10.0 2023-03-17
---------------
- hpack: fix a case where hpack would raise an array out of bounds exception
([#183](https://github.com/anmonteiro/ocaml-h2/pull/183))
([@jonathanjameswatson](https://github.com/jonathanjameswatson))
- h2: (client) handle multiple RST_STREAM frames
([#184](https://github.com/anmonteiro/ocaml-h2/pull/184))
([@jonathanjameswatson](https://github.com/jonathanjameswatson))
- h2: (client) Fix a race condition with `~flush_headers_immediately:false` and
empty request bodies
([#186](https://github.com/anmonteiro/ocaml-h2/pull/186))
- h2: Make `H2.Reqd.error_code` part of the public interface
([#188](https://github.com/anmonteiro/ocaml-h2/pull/188))
- h2: Add `~request_method` argument to `H2.Method.body_length`
([#190](https://github.com/anmonteiro/ocaml-h2/pull/190))
([@jonathanjameswatson](https://github.com/jonathanjameswatson))
- h2: Don't send any frames on a stream after an `RST_STREAM` frame
([#187](https://github.com/anmonteiro/ocaml-h2/pull/187),
[#194](https://github.com/anmonteiro/ocaml-h2/pull/194))
- h2: call error handler on the client if the remote peer closes the
commmunication channel
([#177](https://github.com/anmonteiro/ocaml-h2/pull/177),
[#196](https://github.com/anmonteiro/ocaml-h2/pull/194))
- h2: when reprioritizing a stream, respect its new priority (accounts for
inferred default priority when a dependent stream is not in the tree
([RFC7540§5.3.1](https://www.rfc-editor.org/rfc/rfc7540.html#section-5.3.1)))
([#200](https://github.com/anmonteiro/ocaml-h2/pull/200))
- h2: don't remove parent streams from the scheduler if they have children
([#201](https://github.com/anmonteiro/ocaml-h2/pull/201))
- h2: don't schedule streams as dependencies of others marked for removal
([#205](https://github.com/anmonteiro/ocaml-h2/pull/205))
- h2: revise scheduling algorithm to avoid starvation
([#199](https://github.com/anmonteiro/ocaml-h2/pull/199),
[#204](https://github.com/anmonteiro/ocaml-h2/pull/204), reported in
[#162](https://github.com/anmonteiro/ocaml-h2/issues/162), thanks
[@quernd](https://github.com/quernd))
- h2-eio: adapt to the next gluten-eio version
([#210](https://github.com/anmonteiro/ocaml-h2/pull/210))
0.9.0 2022-08-14
---------------
- h2: Fix tests on 32-bit platforms
([#152](https://github.com/anmonteiro/ocaml-h2/pull/152))
- h2-mirage: adapt to Conduit v4 and remove `H2_mirage.Server_with_conduit`
([#154](https://github.com/anmonteiro/ocaml-h2/pull/154))
- h2: fix memory leaks related to trailer headers in the server and client
implementations ([#159](https://github.com/anmonteiro/ocaml-h2/pull/159)
(thanks [@quernd](https://github.com/quernd)!),
[#160](https://github.com/anmonteiro/ocaml-h2/pull/160))
- h2: allow configuring `flush_headers_immediately` on the client and default
to `false`. This means that h2 will wait for the first request body bytes to
be scheduled and batch `HEADERS` and `DATA` frames when sending requests
([#163](https://github.com/anmonteiro/ocaml-h2/pull/163),
[#164](https://github.com/anmonteiro/ocaml-h2/pull/164))
- h2: Split `Body.t` into `Body.Writer.t` and `Body.Reader.t`
([#165](https://github.com/anmonteiro/ocaml-h2/pull/165))
- h2: OCaml 5.00 compatibility -- add `seeded_hash` to `scheduler.ml`
([#168](https://github.com/anmonteiro/ocaml-h2/pull/168))
- h2: Use a tail-recursive version of `Angstrom.skip_many`. Fixes a memory leak
in long-running connections e.g. gRPC
([#172](https://github.com/anmonteiro/ocaml-h2/pull/172))
- h2-async: Add an OCaml-TLS client to `h2-async`
([#174](https://github.com/anmonteiro/ocaml-h2/pull/174))
- h2: Fix a bug that caused different requests to share the same headers buffer
under concurrency ([#182](https://github.com/anmonteiro/ocaml-h2/pull/182))
0.8.0 2021-04-11
---------------
- h2: scheduler: fix bug that caused zero length DATA frames not to be sent if
there were no flow-control credits
([#142](https://github.com/anmonteiro/ocaml-h2/pull/142)) -- reported by
[@blandinw](https://github.com/blandinw)
- h2,h2-lwt,h2-lwt-unix,h2-async,h2-mirage Add `trailers_handler` to
`Connection.request` ([#146](https://github.com/anmonteiro/ocaml-h2/pull/146))
- h2: client / server: fix a security issue that allowed a malicious peer to
make h2 allocate as much as it wanted
([#149](https://github.com/anmonteiro/ocaml-h2/pull/149))
0.7.0 2020-08-09
---------------
- h2: client / server: execute request/response body reads as data frames
arrive ([#130](https://github.com/anmonteiro/ocaml-h2/pull/130))
- h2: client / server: only give back flow control tokens after surfacing reads
to the application ([#131](https://github.com/anmonteiro/ocaml-h2/pull/131))
- h2: Set a default of 128MiB for the initial receiving window size
([#132](https://github.com/anmonteiro/ocaml-h2/pull/132))
- h2: don't attempt to write frames to an encoder that has closed
([#134](https://github.com/anmonteiro/ocaml-h2/pull/134))
- h2: Handle frame size errors in a more robust manner when parsing
([#133](https://github.com/anmonteiro/ocaml-h2/pull/133))
- h2: Create push streams with the right priority (as per
[RFC7540§5.3.5](https://tools.ietf.org/html/rfc7540#section-5.3.5), pushed
streams initially depend on their associated stream)
([#136](https://github.com/anmonteiro/ocaml-h2/pull/136))
0.6.1 2020-05-16
---------------
- h2-async: add Async adapter
([#94](https://github.com/anmonteiro/ocaml-h2/pull/94))
- h2-async: Use [gluten](https://github.com/anmonteiro/gluten) to implement
h2-async ([#125](https://github.com/anmonteiro/ocaml-h2/pull/125))
- h2-mirage: Use [gluten](https://github.com/anmonteiro/gluten) to implement
h2-mirage ([#120](https://github.com/anmonteiro/ocaml-h2/pull/120))
- h2: Don't put parser in error state when force-closing
([#127](https://github.com/anmonteiro/ocaml-h2/pull/127))
0.6.0 2020-04-29
--------------
- h2-lwt: Close the communication channel after shutting down the client
([#108](https://github.com/anmonteiro/ocaml-h2/pull/108))
- h2-lwt-unix: fix premature SSL termination in the SSL / TLS runtimes
([#109](https://github.com/anmonteiro/ocaml-h2/pull/109))
- h2-lwt-unix: TLS runtime: adapt to TLS v0.11.0
([#109](https://github.com/anmonteiro/ocaml-h2/pull/109))
- h2-lwt-unix: feed EOF to the state machine if the socket has been closed --
this is especially important on the client because it allows connections to
terminate cleanly. ([#112](https://github.com/anmonteiro/ocaml-h2/pull/112))
- h2: Refactor the `Settings` module API
([#113](https://github.com/anmonteiro/ocaml-h2/pull/113))
- h2-lwt, h2-lwt-unix: Use [gluten](https://github.com/anmonteiro/gluten) to
implement the Lwt-based runtimes
([#114](https://github.com/anmonteiro/ocaml-h2/pull/114))
- h2: set a lower bound on Angstrom 0.14.0
([#118](https://github.com/anmonteiro/ocaml-h2/pull/118))
- h2: in the client implementation, don't report an error if the server has
sent an `RST_STREAM` frame after sending a complete response
([#119](https://github.com/anmonteiro/ocaml-h2/pull/119)).
- h2-lwt-unix: fix a regression that prevented the SSL / TLS runtimes to
negotiate an HTTP/2 connection over the ALPN extension of TLS, in their
default implementations
([#122](https://github.com/anmonteiro/ocaml-h2/pull/122))
0.5.0 2019-12-19
--------------
- h2, h2-lwt, h2-lwt-unix, h2-mirage: Remove support for versions of OCaml
lower than 4.06 ([#74](https://github.com/anmonteiro/ocaml-h2/pull/74))
- h2: Expose more information in client error handlers when initiating a
connection ([#80](https://github.com/anmonteiro/ocaml-h2/pull/80))
- h2: Make H2.Status.t a strict superset of Httpaf.Status.t
([#83](https://github.com/anmonteiro/ocaml-h2/pull/83))
- h2-lwt, h2-lwt-unix: split HTTPS functions in 2: one that sets up a default
secure connection and performs the TLS handshake / accept, and one that is
more "raw", i.e. leaves that responsibility to the caller. Also exposes the
`socket` type to make it easier to abstract over HTTP / HTTPS
([#84](https://github.com/anmonteiro/ocaml-h2/pull/84))
- h2-lwt, h2-lwt-unix, h2-mirage: Improve the `H2_lwt.IO` interface, don't
require a `report_exn` function, only a `state` function that returns the
socket state ([#85](https://github.com/anmonteiro/ocaml-h2/pull/85))
- h2, h2-lwt, h2-lwt-unix, h2-mirage: Add support for starting HTTP/2 for
"http" URIs. Covers [section 3.2](https://tools.ietf.org/html/rfc7540#section-3.2)
of the HTTP/2 specification
([#87](https://github.com/anmonteiro/ocaml-h2/pull/87))
- h2: Fix misinterpretation of the spec where h2 would consider a request /
response malformed if it had a non-zero `content-length` header and no DATA
frames ([#89](https://github.com/anmonteiro/ocaml-h2/pull/89))
- h2: Add `Request.body_length` and `Response.body_length`
([#90](https://github.com/anmonteiro/ocaml-h2/pull/90))
- h2: Fix a bug that caused DATA frames to be incorrectly chunked when
returning a streaming response
([#91](https://github.com/anmonteiro/ocaml-h2/pull/91))
- h2: Drain pending bytes after getting a `Close` report from the runtime
([#92](https://github.com/anmonteiro/ocaml-h2/pull/92))
- h2: Report connection errors for unknown frames that exceed the maximum
payload size -- they may not be speaking HTTP/2
([#93](https://github.com/anmonteiro/ocaml-h2/pull/93))
0.4.0 2019-11-05
--------------
- h2-mirage: depend on `mirage-conduit` instead of `conduit-mirage`,
effectively placing a lower bound of OCaml 4.07 on the next release of
h2-mirage ([#67](https://github.com/anmonteiro/ocaml-h2/pull/67))
- h2-lwt-unix: replace the `dune` file (previously written in OCaml) with a
`(select)` form to avoid depending on `ocamlfind`
([#68](https://github.com/anmonteiro/ocaml-h2/pull/68))
- h2-lwt, h2-lwt-unix, h2-mirage: Refactor interface code through common
`H2_lwt_intf` and expose less (internal) types
([#65](https://github.com/anmonteiro/ocaml-h2/pull/65))
- h2-lwt, h2-lwt-unix, h2-mirage: Expose `Client.is_closed`
([#65](https://github.com/anmonteiro/ocaml-h2/pull/65))
- h2: Don't count peer max concurrent streams based on what the endpoint
receives; the endpoint is responsible for selecting it
([#71](https://github.com/anmonteiro/ocaml-h2/pull/71))
- h2: Fix bug in `Headers.remove` that prevented removing the last header pair
([#73](https://github.com/anmonteiro/ocaml-h2/pull/73))
- h2: Fix bug in `Headers.replace` that prevented replacing the last header
pair ([#76](https://github.com/anmonteiro/ocaml-h2/pull/76))
- h2-mirage: Adapt to Mirage 3.7 interfaces. `h2_mirage` now requires
`conduit-mirage` >= 2.0.2 and `mirage-flow` >= 2.0.0
([#77](https://github.com/anmonteiro/ocaml-h2/pull/77))
0.3.0 2019-05-04
--------------
- h2-mirage: Provide `Server` and `Client` functors that take a
`Mirage_flow_lwt.S` module as an argument
([#37](https://github.com/anmonteiro/ocaml-h2/pull/37))
- h2: Fix bug in the client implementation that didn't report connection
preface errors as soon as they happened
([#38](https://github.com/anmonteiro/ocaml-h2/pull/38))
- h2: optimize the stream scheduler: previously when the writer yielded between
writes, a wake up function was registered with all the (active) streams,
which required a linear traversal of all the streams. The optimization is to
allow every stream to wake up a global writer to which they hold a reference
([#40](https://github.com/anmonteiro/ocaml-h2/pull/40))
- h2: improve handling of received frames against closed streams
([#40](https://github.com/anmonteiro/ocaml-h2/pull/40))
- h2: in the client implementation, call the stream level error handler when
receiving an `RST_STREAM` frame
([#42](https://github.com/anmonteiro/ocaml-h2/pull/42))
- h2-lwt-unix: fail earlier when setting up a SSL/TLS server without the
depopts being available
([#46](https://github.com/anmonteiro/ocaml-h2/pull/46))
- h2-lwt-unix: improve the default ALPN negotiation mechanism in the SSL
binding ([#46](https://github.com/anmonteiro/ocaml-h2/pull/46))
0.2.0 2019-04-06
--------------
- h2: Fix false negative related to receiving trailer headers with CONTINUATION
frames ([#11](https://github.com/anmonteiro/ocaml-h2/pull/11))
- hpack: Fix bug where trying to add an entry to an HPACK dynamic table with 0
capacity resulted in an out-of-bounds array access
([#13](https://github.com/anmonteiro/ocaml-h2/pull/13),
[#35](https://github.com/anmonteiro/ocaml-h2/pull/35))
- h2: Add support for the 421 (Misdirected Request) status code as per
[RFC7540§9.1.2](https://tools.ietf.org/html/rfc7540#section-9.1.2)
([#15](https://github.com/anmonteiro/ocaml-h2/pull/15))
- h2, h2-lwt, h2-lwt-unix, h2-mirage: Add an HTTP/2 client implementation
([#16](https://github.com/anmonteiro/ocaml-h2/pull/16))
- h2: Remove dependency on the `result` package
([#18](https://github.com/anmonteiro/ocaml-h2/pull/18))
- h2: Track SETTINGS frames that haven't been acknowledged by the peer
([#22](https://github.com/anmonteiro/ocaml-h2/pull/22))
- h2: Don't treat `CONNECT` requests as malformed
([#32](https://github.com/anmonteiro/ocaml-h2/pull/32),
[#34](https://github.com/anmonteiro/ocaml-h2/pull/34))
- h2: Respect the initial MAX\_FRAME\_SIZE setting when allocating the
underlying buffer for the frame writer
([#34](https://github.com/anmonteiro/ocaml-h2/pull/34))
0.1.0 2019-03-27
--------------
- Initial public release

28
unikernel/duniverse/ocaml-h2/LICENSE Normal file
View file

@ -0,0 +1,28 @@
Copyright (c) 2019 António Nuno Monteiro
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
3. Neither the name of the copyright holder nor the names of its contributors
may be used to endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

22
unikernel/duniverse/ocaml-h2/Makefile Normal file
View file

@ -0,0 +1,22 @@
.PHONY: all build clean test
build:
esy b dune build @install
all: build
test:
esy b dune runtest --no-buffer
slow-test:
esy b dune build @slowtests --no-buffer
install:
esy b dune install
uninstall:
esy b dune uninstall
clean:
rm -rf _build *.install
esy b dune clean

412
unikernel/duniverse/ocaml-h2/README.md Normal file
View file

@ -0,0 +1,412 @@
# h2
h2 is an implementation of the
[HTTP/2](https://tools.ietf.org/html/rfc7540) specification entirely in OCaml.
It is based on the concepts in
[http/af](https://github.com/inhabitedtype/httpaf), and therefore uses the
[Angstrom][angstrom] and [Faraday][faraday] libraries to implement the parsing
and serialization layers of the HTTP/2 standard. It also preserves the same API
as http/af wherever possible.
[angstrom]: https://github.com/inhabitedtype/angstrom
[faraday]: https://github.com/inhabitedtype/faraday
## Installation
Install the library and its dependencies via [OPAM][opam]:
[opam]: http://opam.ocaml.org/
```bash
opam install h2
```
## Usage
### Resources
First of all, the generated documentation lives
[here](https://ocaml.org/p/h2/latest/doc/index.html). It is recommended to browse it
and get to know the API exposed by `H2`.
There are also some examples in the [`examples`](./examples) folder. Most
notably, the [ALPN example](./examples/alpn) provides an implementation of a
common real-world use case:
It sets up a server that listens on 2 ports:
1. __port 8080__: redirects all incoming traffic to `https://localhost:9443`
2. __port 9443__: negotiates which protocol to use over the TLS
[Application-Layer Protocol Negotiation
(ALPN)](https://tools.ietf.org/html/rfc7301) extension. It supports 2
protocols (in order of preference): `h2` and `http/1.1`.
If `h2` is negotiated, the example sets up a connection handler using
`h2-lwt-unix`. Otherwise the connection handler will serve HTTP/1.1 traffic
using [httpun](https://github.com/anmonteiro/httpun).
The ALPN example also provides a unikernel implementation with the same
functionality that runs on [MirageOS](https://mirage.io).
### A server example
We present an annotated example below that responds to any `GET` request and
returns a response body containing the target of the request.
```ocaml
open H2
(* This is our request handler. H2 will invoke this function whenever the
* client send a request to our server. *)
let request_handler _client_address reqd =
(* `reqd` is a "request descriptor". Conceptually, it's just a reference to
* the request that the client sends, which allows us to do two things:
*
* 1. Get more information about the request that we're handling. In our
* case, we're inspecting the method and the target of the request, but we
* could also look at the request headers.
*
* 2. A request descriptor is also what allows us to respond to this
* particular request by passing it into one of the response functions
* that we will look at below. *)
let { Request.meth; target; _ } = Reqd.request reqd in
match meth with
| `GET ->
let response_body =
Printf.sprintf "You made a request to the following resource: %s\n" target
in
(* Specify the length of the response body. Two notes to make here:
*
* 1. Specifying the content length of a response is optional since HTTP/2
* is a binary protocol based on frames which carry information about
* whether a frame is the last for a given stream.
*
* 2. In HTTP/2, all header names are required to be lowercase. We use
* `content-length` instead of what might be commonly seen in HTTP/1.X
* (`Content-Length`). *)
let headers =
Headers.of_list
[ "content-length", string_of_int (String.length response_body) ]
in
(* Respond immediately with the response body we constructed above,
* finishing the request/response exchange (and the unerlying HTTP/2
* stream).
*
* The other functions in the `Reqd` module that allow sending a response
* to the client are `Reqd.respond_with_bigstring`, that only differs from
* `Reqd.respond_with_string` in that the response body should be a
* bigarray, and `Reqd.respond_with_streaming` (see
* http://anmonteiro.com/ocaml-h2/h2/H2/Reqd/index.html#val-respond_with_streaming)
* which starts streaming a response body which can be written to
* asynchronously to the client. *)
Reqd.respond_with_string reqd (Response.create ~headers `OK) response_body
| meth ->
let response_body =
Printf.sprintf
"This server does not respond to %s methods.\n"
(Method.to_string meth)
in
Reqd.respond_with_string
reqd
(* We don't include any headers in this case. The HTTP/2 framing layer
* knows that these will be last frames in the exchange. *)
(Response.create `Method_not_allowed)
response_body
(* This is our error handler. Everytime H2 sees a malformed request or an
* exception on a specific stream, it will invoke this function to send a
* response back to the misbehaving client. Because there might not be a
* request for the stream (handing malformed requests to the application is
* strongly discouraged), there is also no request descriptor like we saw in
* the request handler above. In this case, one of the arguments to this
* function is a function that will start the response. It has the following
* signature:
*
* val start_response : H2.headers.t -> [`write] H2.Body.t
*
* This is also where we first encounter the concept of a `Body` (which were
* briefly mentioned above) that can be written to (potentially
* asynchronously). *)
let error_handler _client_address ?request:_ _error start_response =
(* We start the error response by calling the `start_response` function. We
* get back a response body. *)
let response_body = start_response Headers.empty in
(* Once we get the response body, we can immediately start writing to it. In
* this case, it might be sufficient to say that there was an error. *)
Body.Writer.write_string
response_body
"There was an error handling your request.\n";
(* Finally, we close the streaming response body to signal to the underlying
* HTTP/2 framing layer that we have finished sending the response. *)
Body.Writer.close response_body
let () =
(* We're going to be using the `H2_lwt_unix` module from the `h2-lwt-unix`
* library to create a server that communicates over the underlying operating
* system socket abstraction. The first step is to create a connection
* handler that will accept incoming connections and let our request and
* error handlers handle the request / response exchanges in those
* connections. *)
let connection_handler =
H2_lwt_unix.Server.create_connection_handler
?config:None
~request_handler
~error_handler
in
(* We'll be listening for requests on the loopback interface (localhost), on
* port 8080. *)
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in
(* The final step is to start a server that will set up all the low-level
* networking communication for us, and let it run forever. *)
let _server =
Lwt_io.establish_server_with_client_socket listen_address connection_handler
in
let forever, _ = Lwt.wait () in
Lwt_main.run forever
```
### A client example
The following annotated client example performs a `GET` request to `example.com`
and prints the response body as it arrives.
```ocaml
open H2
module Client = H2_lwt_unix.Client
(* This is our response handler. H2 will invoke this function whenever the
* server has responded to our request. The `notify_response_received` argument
* is explained further down. *)
let response_handler notify_response_received response response_body =
(* `response` contains information about the response that we received. We're
* looking at the status to know whether our request produced a successful
* response, but we could also get the response headers, for example. *)
match response.Response.status with
| `OK ->
(* If we got a successful response, we're going to read the response body
* as it arrives, and print its fragments as we receive them. *)
let rec read_response () =
(* Scheduling a read of the response body registers two functions with
* H2:
*
* 1. `on_read`: this function will be called upon the receipt of a
* response body chunk (in HTTP/2 speak, a DATA frame). Our handling
* of these chunks is explained inline below.
*
* 2. `on_eof`: this function will be called once the entire response
* body has arrived. In our case, this is where we fulfill the promise
* that we're done handling the response.
*)
Body.Reader.schedule_read
response_body
~on_read:(fun bigstring ~off ~len ->
(* Once a response body chunk is handed to us (as a bigarray, and an
* offset and length into that bigarray), we'll copy it into a string
* and print it to stdout. *)
let response_fragment = Bytes.create len in
Bigstringaf.blit_to_bytes
bigstring
~src_off:off
response_fragment
~dst_off:0
~len;
print_string (Bytes.to_string response_fragment);
(* We need to make sure that we register another read of the response
* body after we're done handling a fragment, as it will not be
* registered for us. This is where our recursive function comes in
* handy. *)
read_response ())
~on_eof:(fun () ->
(* Signal to the caller of the HTTP/2 request that we are now done
* handling the response, and the program can continue. *)
Lwt.wakeup_later notify_response_received ())
in
read_response ()
| _ ->
(* We didn't get a successful status in the response. Just print what we
* received to stderr and bail early. *)
Format.eprintf "Unsuccessful response: %a\n%!" Response.pp_hum response;
exit 1
let error_handler _error =
(* There was an error handling the request. In this simple example, we don't
* try too hard to understand it. Just print to stderr and exit with an
* unsuccessful status code. *)
Format.eprintf "Unsuccessful request!\n%!";
exit 1
open Lwt.Infix
let () =
let host = "www.example.com" in
Lwt_main.run
( (* We start by resolving the address of the host we want to connect to. *)
Lwt_unix.getaddrinfo host "443" [ Unix.(AI_FAMILY PF_INET) ]
>>= fun addresses ->
(* Once the address for the host we want to contact has been resolved, we
* need to create the socket through which the communication with the
* remote host is going to happen. *)
let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
(* Then, we connect to the socket we just created, on the address we have
* previously obtained through name resolution. *)
Lwt_unix.connect socket (List.hd addresses).Unix.ai_addr >>= fun () ->
let request =
Request.create
`GET
"/"
(* a scheme pseudo-header is required in HTTP/2 requests, otherwise
* the request will be considered malformed. In our case, we're
* making a request over HTTPS, so we specify "https" *)
~scheme:"https"
~headers:
(* The `:authority` pseudo-header is a blurry line in the HTTP/2
* specificiation. It's not strictly required but most
* implementations treat a request with a missing `:authority`
* pseudo-header as malformed. That is the case for example.com, so
* we include it. *)
Headers.(add_list empty [ ":authority", host ])
in
(* The H2 API relies on callbacks to allow for a single, stable core to
* be used with different I/O runtimes. Because we're using Lwt in this
* example, we'll create an Lwt task that is going to help us transform
* the callback-calling style of H2 into an Lwt promise whenever we're
* done handling the response.
*
* If you're not familiar with Lwt or its `Lwt.wait` function, it's
* recommended you read at least the following bit before moving on:
* http://ocsigen.org/lwt/4.1.0/api/Lwt#VALwait. *)
let response_received, notify_response_received = Lwt.wait () in
(* Partially apply the `response_handler` function that we defined above
* to produce one that matches H2's expected signature. After this line,
* `response_handler` now has the following signature:
*
* val response_handler: Response.t -> [ `read ] Body.t -> unit
*)
let response_handler = response_handler notify_response_received in
(* HTTP/2 itself does not define that the protocol must be used with TLS.
* In practice, though, TLS is widely used in the Internet today (and
* that's a good thing!) and no serious deployments use plaintext HTTP/2.
* The following is a good read on why this is the case:
* https://http2-explained.haxx.se/content/en/part8.html#844-its-use-of-tls-makes-it-slower
*
* For us, this means that we need to make our request over TLS. H2, and
* more specifically `h2-lwt-unix`, provide a `TLS` module for both the
* client and the server implementations that rely on an optional
* dependency to ocaml-tls.
*
* We start by creating a connection handler. The `create_connection`
* function takes two arguments: a connection-level error handler (you
* can read more about the difference between connection-level and
* stream-level in H2 and HTTP/2 in general here:
* https://anmonteiro.com/ocaml-h2/h2/H2/Client_connection/index.html#val-create)
* and the file descriptor that we created above. *)
Client.TLS.create_connection_with_default ~error_handler socket
>>= fun connection ->
(* Once the connection has been created, we can initiate our request. For
* that, we call the `request` function, which will send the request that
* we created to the server, and direct its response to either the
* response handler - in case of a successful request / response exchange
* - or the (stream-level) error handler, in case our request was
* malformed. *)
let request_body =
Client.TLS.request connection request ~error_handler ~response_handler
in
(* The `request` function returns a request body that we can write to,
* but in our case just the headers are sufficient. We close the request
* body immediately to signal to the underlying HTTP/2 framing layer that
* we're done sending our request. *)
Body.Writer.close request_body;
(* Our call to `Lwt_main.run` above will wait until this promise is
* filled before exiting the program. *)
response_received )
```
## Conformance
One of h2's goals is to be 100% compliant with the HTTP/2 specification.
There are currently 3 mechanisms in place to verify such conformance:
1. Unit tests using the HPACK stories in the
[http2jp/hpack-test-case](https://github.com/http2jp/hpack-test-case)
repository
2. Unit tests using the test cases provided by the
[http2jp/http2-frame-test-case](https://github.com/http2jp/http2-frame-test-case)
repository.
3. Automated test runs (in CI) using the
[h2spec](https://github.com/summerwind/h2spec) conformance testing tool for
HTTP/2 implementations.
- These test all the `Reqd.respond_with_*` functions for conformance against
the specification.
## Performance
h2 aims to be a high-performance, memory-efficient, scalable, and easily
portable (with respect to different I/O runtimes) implementation. To achieve
that, it takes advantage of the unbuffered parsing interface in Angstrom using
off-heap buffers wherever possible, for both parsing and serialization.
Below is a plot of H2's latency profile at a sustained rate of 17000 requests
per second over 30 seconds, benchmarked using the
[vegeta](https://github.com/tsenart/vegeta) load testing tool.
![ocaml-h2](./vegeta-plot.png)
## Development
This source distribution provides a number of packages and examples. The
directory structure is as follows:
- [`examples/`](./examples): contains example applications using the various
I/O runtimes provided in this source distribution.
- [`hpack/`](./hpack): contains the implementation of
[HPACK](https://tools.ietf.org/html/rfc7541), the Header Compression
specification for HTTP/2.
- [`lib/`](./lib): contains the core implementation of this library, including
HTTP/2 frame parsing, serialization and state machine implementations.
- [`lib_test/`](./lib_test): contains various unit tests for modules in the
core h2 package.
- [`lwt/`](./lwt): contains an implementation of a Lwt runtime for h2
functorized over the specific input / output channel abstraction such that it
can work in either UNIX-like systems or MirageOS.
- [`lwt-unix/`](./lwt-unix): contains an Lwt runtime adapter for h2 that
communicates over UNIX file descriptors.
- [`mirage/`](./mirage): contains a Mirage runtime adapter for h2 that
allows using h2 to write unikernels that serve traffic over HTTP/2.
- [`spec/`](./spec): contains example implementations of servers using h2
that respond with the different provided APIs to be used for conformance
testing with the [h2spec](https://github.com/summerwind/h2spec) tool.
### Cloning the repository
```shell
# Use --recurse-submodules to get the test git submodules
$ git clone git@github.com:anmonteiro/ocaml-h2.git --recurse-submodules
```
### Using OPAM
To install development dependencies, pin the package from the root of the
repository:
```bash
$ opam pin add -n hpack .
$ opam pin add -n h2 .
$ opam install --deps-only h2
```
After this, you may install a development version of the library using the
install command as usual.
Tests can be run via dune:
```bash
dune runtest
```
## License
h2 is distributed under the 3-Clause BSD License, see [LICENSE](./LICENSE).
This source distribution includes work based on
[http/af](https://github.com/inhabitedtype/httpaf). http/af's license file is
included in [httpaf.LICENSE](./httpaf.LICENSE)

4
unikernel/duniverse/ocaml-h2/async/dune Normal file
View file

@ -0,0 +1,4 @@
(library
(name h2_async)
(public_name h2-async)
(libraries async core faraday-async gluten-async h2))

227
unikernel/duniverse/ocaml-h2/async/h2_async.ml Normal file
View file

@ -0,0 +1,227 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2018 Inhabited Type LLC.
* Copyright (c) 2019-2020 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
open Async
open H2
module Server = struct
type 'a socket = ([ `Active ], ([< Socket.Address.t ] as 'a)) Socket.t
let create_connection_handler
?(config = H2.Config.default)
~request_handler
~error_handler
client_addr
socket
=
let connection =
H2.Server_connection.create
~config
~error_handler:(error_handler client_addr)
(request_handler client_addr)
in
Gluten_async.Server.create_connection_handler
~read_buffer_size:config.read_buffer_size
~protocol:(module H2.Server_connection)
connection
client_addr
socket
module SSL = struct
let create_connection_handler
?(config = H2.Config.default)
~request_handler
~error_handler
client_addr
socket
=
let connection =
H2.Server_connection.create
~config
~error_handler:(error_handler client_addr)
(request_handler client_addr)
in
Gluten_async.Server.SSL.create_connection_handler
~read_buffer_size:config.read_buffer_size
~protocol:(module H2.Server_connection)
connection
client_addr
socket
let create_connection_handler_with_default
~certfile
~keyfile
?config
~request_handler
~error_handler
=
let make_ssl_server =
Gluten_async.Server.SSL.create_default
~alpn_protocols:[ "h2" ]
~certfile
~keyfile
in
fun client_addr socket ->
make_ssl_server client_addr socket >>= fun ssl_server ->
create_connection_handler
?config
~request_handler
~error_handler
client_addr
ssl_server
end
end
module Client = struct
module Client_runtime = Gluten_async.Client
type 'a socket = 'a Client_runtime.socket
type 'a runtime = 'a Client_runtime.t
type 'a t =
{ connection : Client_connection.t
; runtime : 'a runtime
}
let create_connection
?(config = Config.default)
?push_handler
~error_handler
socket
=
let connection =
Client_connection.create ~config ?push_handler ~error_handler ()
in
Client_runtime.create
~read_buffer_size:config.read_buffer_size
~protocol:(module Client_connection)
connection
socket
>>| fun runtime -> { runtime; connection }
let request t = Client_connection.request t.connection
let ping t = Client_connection.ping t.connection
let shutdown t = Client_runtime.shutdown t.runtime
let is_closed t = Client_runtime.is_closed t.runtime
module SSL = struct
module Client_runtime = Gluten_async.Client.SSL
type 'a socket = 'a Client_runtime.socket
type 'a runtime = 'a Client_runtime.t
type 'a t =
{ connection : Client_connection.t
; runtime : 'a runtime
}
let create_connection
?(config = Config.default)
?push_handler
~error_handler
socket
=
let connection =
Client_connection.create ~config ?push_handler ~error_handler ()
in
Client_runtime.create
~read_buffer_size:config.read_buffer_size
~protocol:(module Client_connection)
connection
socket
>>| fun runtime -> { runtime; connection }
let create_connection_with_default
?(config = Config.default)
?push_handler
~error_handler
socket
=
Client_runtime.create_default ~alpn_protocols:[ "http/1.1" ] socket
>>= fun ssl_client ->
create_connection ~config ?push_handler ~error_handler ssl_client
let request t = Client_connection.request t.connection
let ping t = Client_connection.ping t.connection
let shutdown t = Client_runtime.shutdown t.runtime
let is_closed t = Client_runtime.is_closed t.runtime
end
module TLS = struct
module Client_runtime = Gluten_async.Client.TLS
type 'a socket = 'a Client_runtime.socket
type 'a runtime = 'a Client_runtime.t
type 'a t =
{ connection : Client_connection.t
; runtime : 'a runtime
}
let create_connection
?(config = Config.default)
?push_handler
~error_handler
socket
=
let connection =
Client_connection.create ~config ?push_handler ~error_handler ()
in
Client_runtime.create
~read_buffer_size:config.read_buffer_size
~protocol:(module Client_connection)
connection
socket
>>| fun runtime -> { runtime; connection }
let create_connection_with_default
?(config = Config.default)
?push_handler
~error_handler
socket
where_to_connect
=
Client_runtime.create_default
~alpn_protocols:[ "http/1.1" ]
socket
where_to_connect
>>= fun tls_client ->
create_connection ~config ?push_handler ~error_handler tls_client
let request t = Client_connection.request t.connection
let ping t = Client_connection.ping t.connection
let shutdown t = Client_runtime.shutdown t.runtime
let is_closed t = Client_runtime.is_closed t.runtime
end
end

93
unikernel/duniverse/ocaml-h2/async/h2_async.mli Normal file
View file

@ -0,0 +1,93 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2018 Inhabited Type LLC.
* Copyright (c) 2019-2020 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
open Async
open H2
module Server : sig
include
H2_async_intf.Server
with type 'a socket = ([ `Active ], ([< Socket.Address.t ] as 'a)) Socket.t
module SSL : sig
include
H2_async_intf.Server
with type 'a socket := 'a Gluten_async.Server.SSL.socket
val create_connection_handler_with_default :
certfile:string
-> keyfile:string
-> ?config:Config.t
-> request_handler:('a -> Server_connection.request_handler)
-> error_handler:('a -> Server_connection.error_handler)
-> (Socket.Address.Inet.t as 'a)
-> ([ `Active ], 'a) Socket.t
-> unit Deferred.t
end
end
module Client : sig
include
H2_async_intf.Client
with type 'a socket = ([ `Active ], ([< Socket.Address.t ] as 'a)) Socket.t
module SSL : sig
include
H2_async_intf.Client
with type 'a socket = 'a Gluten_async.Client.SSL.socket
val create_connection_with_default :
?config:Config.t
-> ?push_handler:
(Request.t -> (Client_connection.response_handler, unit) result)
-> error_handler:Client_connection.error_handler
-> ([ `Active ], 'a) Socket.t
-> 'a t Deferred.t
end
module TLS : sig
include
H2_async_intf.Client
with type 'a socket = 'a Gluten_async.Client.TLS.socket
val create_connection_with_default :
?config:Config.t
-> ?push_handler:
(Request.t -> (Client_connection.response_handler, unit) result)
-> error_handler:Client_connection.error_handler
-> ([ `Unconnected ], 'addr) Socket.t
-> 'addr Tcp.Where_to_connect.t
-> 'addr t Deferred.t
end
end

83
unikernel/duniverse/ocaml-h2/async/h2_async_intf.ml Normal file
View file

@ -0,0 +1,83 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019-2020 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
open Async
open H2
module type Server = sig
type 'a socket constraint 'a = [< Socket.Address.t ]
val create_connection_handler :
?config:Config.t
-> request_handler:('a -> Server_connection.request_handler)
-> error_handler:('a -> Server_connection.error_handler)
-> 'a
-> 'a socket
-> unit Deferred.t
end
module type Client = sig
type 'a socket constraint 'a = [< Socket.Address.t ]
type 'a runtime constraint 'a = [< Socket.Address.t ]
type 'a t =
{ connection : Client_connection.t
; runtime : 'a runtime
}
val create_connection :
?config:Config.t
-> ?push_handler:
(Request.t -> (Client_connection.response_handler, unit) result)
-> error_handler:Client_connection.error_handler
-> 'a socket
-> 'a t Deferred.t
val request :
'a t
-> ?flush_headers_immediately:bool
-> ?trailers_handler:Client_connection.trailers_handler
-> Request.t
-> error_handler:Client_connection.error_handler
-> response_handler:Client_connection.response_handler
-> Body.Writer.t
val ping :
_ t
-> ?payload:Bigstringaf.t
-> ?off:int
-> ((unit, [ `EOF ]) result -> unit)
-> unit
val shutdown : _ t -> unit Deferred.t
val is_closed : _ t -> bool
end

28
unikernel/duniverse/ocaml-h2/certificates/server.key Normal file
View file

@ -0,0 +1,28 @@
-----BEGIN PRIVATE KEY-----
MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQC3TQ1QyQcTA0Cs
RxFu917WgEgs9M6Bb2OwiI4/fCSHJ9Fs7xIY0UncgOe9yPcGKi1qVmbgkzW68CMv
11RT9ebQUg5x6wnDWpCRREArZPY/3j44+fTD93abd/Z3E3232Q0q9csrGck7lVB1
uY0zcxnpOk0vUjF2Yl2pXhfCS7s+NmpQHB6F9s5e9o+uapY2qYHdPjwLXR1d/A1l
v16bRGzmhKQDlAf9rzxNaPTpS8pyOxCn96dOdCdHlFdwF2oTtFsdDxy7wO2KXrJ0
CKUaLk2kvk+YeRoNoSPfkbCWloy53CaFTIDwo8nSVbFQq2Y5K+5/ycDU/EfERQPF
z+YUcFfFAgMBAAECggEBAK53LldYH92e2O2g7xz5YlEz5H61u+BCz1X1g781P+dM
pO7UVhs9CNpR70EaiNRbTMLL3jueoiN98V/VyjPn93sMvyb6mV5RUwyRM6qZ/DAq
Lns4nhnv7fpoIjSQXragZwIe1PP/JSQLKHwE0jrIMT9l+JUz3FRbp95O6rpKLrw0
nkdoCKBeIrAuhiMaLCq0+K6lKWCpyQ/8CjVSgaIdJ+Ez6/pmhoaNHYJZVpKIejcC
tKP/yA6RqrJrlmRtffEmCd6UfcdBIKohFYLP4HhZAJGjfHMBdYE0IURU37SFSa9M
M9mktSNvlz9zmG6WP62s9228DWSqcSxA79vhOXnT13kCgYEA33AnimhnR5Mu3yJh
YYqgfw7/+CLs/wqQm/QAF/xYhOnEmLB6s9DPnSPglPi8RpxJWL0ihjD1Sx22KO9L
xMWICh0eC2wgyyQ7JFC9rlGo14ijgebqJlnfvGpjOaX9s3mHlUxpET34COjSCieB
mowoM63bpe+NnyvnBsRrx4ZJ648CgYEA0gN+raxxWXps5CTousd+nBvCqzTmLPH+
gWdBH3MWYftObqHUBlFZ+GK5BRofKRcFl2s6mMEAH3ooWJPORVFwosP7B9s/m73A
mc1IkfiwLBIfnwmEFRspYaUCUlvyGhFQtG1TwohfOjS+26AvXAwLXe1OVM8fn8sX
ntbzf+5RbWsCgYBH31LIwcafDmggXHXIo4f29wM9dTaY33QexkEVdhWfQ3b6yqHd
n4h4+qZuJQijCfjJ86TcV3k/3WHQDxFnTUbyQeV9NR3jWlcv2kz5esj987TsvzOI
fJZsjCg4zf0qsyf6zWZqpm1XqFSP8Z9N8FGqNf2WhdUfY0bgNWSZ/MdgXwKBgQCk
UUGzh0HkvaonU02YnnBMmlfU9v3FWs5D11MX1UdFAIjcfNfU3Z/kfPHAsTCCSNYC
JE7jp9Z9yml47KSujcrwPyDRg9Uf+PaSIBFQzOCiisec+qgSj37wPFg1smUZykR3
9zZa9bJ0a0KNuqZzgaT/J6ZrKufWceQYTpyUkxW44wKBgQDIlBVFBTbfSvlz6vGo
KtCOBcAJtMGgYb/R7rD1/ZECDKVWxf0wGdDbn55sxMg/e6/TQAEYuFVdN0B+wbGQ
mQ4YI1Aq6MEg50M89AN39B6Dl2QAMtYaudtJynKfEJ8DqcDcxx2pvhN2ntWYQZeH
UB8CCFL5ent2PIU5bEgeVexyPQ==
-----END PRIVATE KEY-----

21
unikernel/duniverse/ocaml-h2/certificates/server.pem Normal file
View file

@ -0,0 +1,21 @@
-----BEGIN CERTIFICATE-----
MIIDazCCAlOgAwIBAgIUaZzeJxtNAELAgX5ou5qkZSrLSaIwDQYJKoZIhvcNAQEL
BQAwRTELMAkGA1UEBhMCQVUxEzARBgNVBAgMClNvbWUtU3RhdGUxITAfBgNVBAoM
GEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZDAeFw0yMjA1MDcxODUyMjdaFw0yNTAx
MzExODUyMjdaMEUxCzAJBgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEw
HwYDVQQKDBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQwggEiMA0GCSqGSIb3DQEB
AQUAA4IBDwAwggEKAoIBAQC3TQ1QyQcTA0CsRxFu917WgEgs9M6Bb2OwiI4/fCSH
J9Fs7xIY0UncgOe9yPcGKi1qVmbgkzW68CMv11RT9ebQUg5x6wnDWpCRREArZPY/
3j44+fTD93abd/Z3E3232Q0q9csrGck7lVB1uY0zcxnpOk0vUjF2Yl2pXhfCS7s+
NmpQHB6F9s5e9o+uapY2qYHdPjwLXR1d/A1lv16bRGzmhKQDlAf9rzxNaPTpS8py
OxCn96dOdCdHlFdwF2oTtFsdDxy7wO2KXrJ0CKUaLk2kvk+YeRoNoSPfkbCWloy5
3CaFTIDwo8nSVbFQq2Y5K+5/ycDU/EfERQPFz+YUcFfFAgMBAAGjUzBRMB0GA1Ud
DgQWBBTexBiijUYa35eRlI9QgKqGwT+/rDAfBgNVHSMEGDAWgBTexBiijUYa35eR
lI9QgKqGwT+/rDAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQAa
97zB2uD+zUQZqDOGGbWGNqiZdCyCfjSe0M+d9B4jAbbqgSDIFaiYoC5QOdt4bTQq
GW/1XKL37BEUn2hsRBWVN8yMeT338scfSyJsJTv6ioZgUqIbYG89ZvKR+GNKi2WT
gzwJe4N9BEhJIDKXSiL6trI3b9nop3zjWpwx5rzYz7FCXnc1bi6E7oDxrOIapSB/
QeAtpKZlRtnkbdGO6vifn5yyJ03CsSh3GGeHgquo4Di2rgyR/Bb7U980mHsFEE3B
94id3OvH/7NX0dEBCE1yKIix3yjAffBFo8fwRK7rlBHTGbx+BRppGBrRwtnW7TbV
yDtb5gHvtiu9LBBzBfHN
-----END CERTIFICATE-----

138
unikernel/duniverse/ocaml-h2/dune-project Normal file
View file

@ -0,0 +1,138 @@
(lang dune 2.7)
(name h2)
(version 0.12.0-6-g49c0591)
(formatting
(enabled_for ocaml))
(generate_opam_files true)
(source
(github anmonteiro/ocaml-h2))
(authors "Antonio Nuno Monteiro <anmonteiro@gmail.com>")
(maintainers "Antonio Nuno Monteiro <anmonteiro@gmail.com>")
(homepage "https://github.com/anmonteiro/ocaml-h2")
(bug_reports "https://github.com/anmonteiro/ocaml-h2/issues")
(license "BSD-3-clause")
(package
(name hpack)
(synopsis
"An HPACK (Header Compression for HTTP/2) implementation in OCaml")
(description
"hpack is an implementation of the HPACK: Header Compression for HTTP/2 specification (RFC7541) written in OCaml. It uses Angstrom and Faraday for parsing and serialization, respectively.")
(depends
(ocaml
(>= "4.08.0"))
angstrom
(faraday
(>= "0.7.3"))
(yojson :with-test)
(hex :with-test)))
(package
(name h2)
(synopsis
"A high-performance, memory-efficient, and scalable HTTP/2 library for OCaml")
(description
"h2 is an implementation of the HTTP/2 specification entirely in OCaml. It is based on the concepts in httpun, and therefore uses the Angstrom and Faraday libraries to implement the parsing and serialization layers of the HTTP/2 standard as a state machine that is agnostic to the underlying I/O specifics. It also preserves the same API as httpun wherever possible.")
(depends
(ocaml
(>= "4.08.0"))
(base64
(>= "3.0.0"))
(angstrom
(>= "0.14.0"))
(faraday
(>= "0.7.3"))
(bigstringaf
(>= "0.5.0"))
psq
(hpack
(= :version))
httpun-types
(alcotest :with-test)
(yojson :with-test)
(hex :with-test)))
(package
(name h2-lwt)
(synopsis "Lwt support for h2")
(description
"h2 is an implementation of the HTTP/2 specification entirely in OCaml. h2-lwt provides an Lwt runtime implementation for h2.")
(depends
(ocaml
(>= "4.08.0"))
(h2
(= :version))
(lwt
(>= "5.1.1"))
(gluten-lwt
(>= "0.2.1"))))
(package
(name h2-mirage)
(synopsis "Lwt support for h2")
(description
"h2 is an implementation of the HTTP/2 specification entirely in OCaml. h2-mirage provides an Lwt runtime implementation for h2 that targets MirageOS unikernels.")
(depends
(ocaml
(>= "4.08.0"))
(h2-lwt
(= :version))
faraday-lwt
lwt
(gluten-mirage
(>= "0.3.0"))
(mirage-flow
(>= "2.0.0"))
cstruct))
(package
(name h2-lwt-unix)
(synopsis "Lwt + UNIX support for h2")
(description
"h2 is an implementation of the HTTP/2 specification entirely in OCaml. h2-lwt-unix provides an Lwt runtime implementation for h2 that targets UNIX binaries.")
(depends
(ocaml
(>= "4.08.0"))
(h2-lwt
(= :version))
faraday-lwt-unix
(gluten-lwt-unix
(>= "0.2.1")))
(depopts tls-lwt lwt_ssl))
(package
(name h2-async)
(synopsis "Async support for h2")
(description
"h2 is an implementation of the HTTP/2 specification entirely in OCaml. h2-async provides an Async runtime implementation for h2.")
(depends
(ocaml
(>= "4.08.0"))
(h2
(= :version))
faraday-async
(gluten-async
(>= "0.4.0")))
(depopts async_ssl tls-async))
(package
(name h2-eio)
(synopsis "EIO support for h2")
(description
"h2 is an implementation of the HTTP/2 specification entirely in OCaml. h2-eio provides an EIO runtime implementation for h2.")
(depends
(ocaml
(>= "4.08.0"))
(h2
(= :version))
(gluten-eio
(>= "0.5.0"))))

4
unikernel/duniverse/ocaml-h2/eio/dune Normal file
View file

@ -0,0 +1,4 @@
(library
(public_name h2-eio)
(name h2_eio)
(libraries h2 eio gluten-eio))

92
unikernel/duniverse/ocaml-h2/eio/h2_eio.ml Normal file
View file

@ -0,0 +1,92 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2022 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
module Server = struct
let create_connection_handler
?(config = H2.Config.default)
~request_handler
~error_handler
~sw
client_addr
socket
=
let connection =
H2.Server_connection.create
~config
~error_handler:(error_handler client_addr)
(request_handler client_addr)
in
Gluten_eio.Server.create_connection_handler
~read_buffer_size:config.read_buffer_size
~protocol:(module H2.Server_connection)
~sw
connection
client_addr
socket
end
module Client = struct
type t =
{ connection : H2.Client_connection.t
; runtime : Gluten_eio.Client.t
}
let create_connection
?(config = H2.Config.default)
?push_handler
~sw
~error_handler
socket
=
let connection =
H2.Client_connection.create ~config ?push_handler ~error_handler ()
in
let runtime =
Gluten_eio.Client.create
~read_buffer_size:config.read_buffer_size
~sw
~protocol:(module H2.Client_connection)
connection
socket
in
{ runtime; connection }
let request t = H2.Client_connection.request t.connection
let ping ?payload ?off t =
let p, u = Eio.Promise.create () in
H2.Client_connection.ping ?payload ?off t.connection (Eio.Promise.resolve u);
p
let shutdown t = Gluten_eio.Client.shutdown t.runtime
let is_closed t = Gluten_eio.Client.is_closed t.runtime
end

77
unikernel/duniverse/ocaml-h2/eio/h2_eio.mli Normal file
View file

@ -0,0 +1,77 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2022 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
module Server : sig
val create_connection_handler :
?config:H2.Config.t
-> request_handler:(Eio.Net.Sockaddr.stream -> H2.Reqd.t -> unit)
-> error_handler:
(Eio.Net.Sockaddr.stream -> H2.Server_connection.error_handler)
-> sw:Eio.Switch.t
-> Eio.Net.Sockaddr.stream
-> _ Eio.Net.stream_socket
-> unit
end
module Client : sig
type t =
{ connection : H2.Client_connection.t
; runtime : Gluten_eio.Client.t
}
val create_connection :
?config:H2.Config.t
-> ?push_handler:
(H2.Request.t -> (H2.Client_connection.response_handler, unit) result)
-> sw:Eio.Switch.t
-> error_handler:H2.Client_connection.error_handler
-> _ Eio.Net.stream_socket
-> t
val request :
t
-> ?flush_headers_immediately:bool
-> ?trailers_handler:H2.Client_connection.trailers_handler
-> H2.Request.t
-> error_handler:H2.Client_connection.error_handler
-> response_handler:H2.Client_connection.response_handler
-> H2.Body.Writer.t
val ping :
?payload:Bigstringaf.t
-> ?off:int
-> t
-> (unit, [ `EOF ]) result Eio.Promise.t
val shutdown : t -> unit Eio.Promise.t
val is_closed : t -> bool
end

4
unikernel/duniverse/ocaml-h2/examples/alpn/lib/dune Normal file
View file

@ -0,0 +1,4 @@
(library
(name alpn_lib)
(modules h2_handler http1_handler)
(libraries h2 httpun httpun-lwt-unix h2-lwt-unix lwt))

30
unikernel/duniverse/ocaml-h2/examples/alpn/lib/h2_handler.ml Normal file
View file

@ -0,0 +1,30 @@
open H2
let request_handler : Unix.sockaddr -> Reqd.t -> unit =
fun _client_address request_descriptor ->
let request = Reqd.request request_descriptor in
let response_content_type =
match Headers.get request.headers "Content-Type" with
| Some request_content_type -> request_content_type
| None -> "text/plain"
in
let response =
Response.create
~headers:(Headers.of_list [ "content-type", response_content_type ])
`OK
in
Reqd.respond_with_string
request_descriptor
response
"Welcome to an ALPN-negotiated HTTP/2 connection"
let error_handler :
Unix.sockaddr
-> ?request:H2.Request.t
-> _
-> (Headers.t -> Body.Writer.t)
-> unit
=
fun _client_address ?request:_ _error start_response ->
let response_body = start_response Headers.empty in
Body.Writer.close response_body

54
unikernel/duniverse/ocaml-h2/examples/alpn/lib/http1_handler.ml Normal file
View file

@ -0,0 +1,54 @@
open Httpun
let redirect_handler : Unix.sockaddr -> Reqd.t Gluten.reqd -> unit =
fun _client_address { Gluten.reqd; _ } ->
let response =
Response.create
~headers:
(Headers.of_list
[ "Location", "https://localhost:9443"; "Connection", "close" ])
`Moved_permanently
in
Reqd.respond_with_string reqd response ""
let redirect_error_handler :
Unix.sockaddr
-> ?request:Request.t
-> _
-> (Headers.t -> Body.Writer.t)
-> unit
=
fun _client_address ?request:_ _error start_response ->
let response_body = start_response Headers.empty in
Body.Writer.close response_body
let request_handler : Unix.sockaddr -> Reqd.t Gluten.reqd -> unit =
fun _client_address { Gluten.reqd; _ } ->
let request = Reqd.request reqd in
let response_content_type =
match Headers.get request.headers "Content-Type" with
| Some request_content_type -> request_content_type
| None -> "text/plain"
in
let response_body = "Welcome to an ALPN-negotiated HTTP/1.1 connection" in
let response =
Response.create
~headers:
(Headers.of_list
[ "content-type", response_content_type
; "Content-Length", String.length response_body |> string_of_int
])
`OK
in
Reqd.respond_with_string reqd response response_body
let error_handler :
Unix.sockaddr
-> ?request:Request.t
-> _
-> (Headers.t -> Body.Writer.t)
-> unit
=
fun _client_address ?request:_ _error start_response ->
let response_body = start_response Headers.empty in
Body.Writer.close response_body

42
unikernel/duniverse/ocaml-h2/examples/alpn/mirage/config.ml Normal file
View file

@ -0,0 +1,42 @@
open Mirage
(* Network configuration *)
let stack = generic_stackv4 default_network
(* Certificates *)
let secrets = generic_kv_ro "../../../certificates"
(* Dependencies *)
let server =
let packages =
[ package "tls-mirage"
; package ~pin:"git+https://github.com/anmonteiro/httpun#master" "httpun"
; package
~pin:"git+https://github.com/anmonteiro/httpun#master"
"httpun-lwt"
; package
~pin:"git+https://github.com/anmonteiro/httpun#master"
"httpun-mirage"
; package ~pin:"file://../../.." "h2"
; package ~pin:"file://../../.." "h2-lwt"
; package ~pin:"file://../../.." "h2-mirage"
]
in
foreign
~packages
"Unikernel.Make"
(random @-> stackv4 @-> kv_ro @-> console @-> pclock @-> job)
let () =
register
"alpn_unikernel"
[ server
$ default_random
$ stack
$ secrets
$ default_console
$ default_posix_clock
]

26
unikernel/duniverse/ocaml-h2/examples/alpn/mirage/h2_handler.ml Normal file
View file

@ -0,0 +1,26 @@
open H2
let request_handler : Reqd.t -> unit =
fun request_descriptor ->
let { Request.headers; _ } = Reqd.request request_descriptor in
let response_content_type =
match Headers.get headers "Content-Type" with
| Some request_content_type -> request_content_type
| None -> "text/plain"
in
let response =
Response.create
~headers:(Headers.of_list [ "content-type", response_content_type ])
`OK
in
Reqd.respond_with_string
request_descriptor
response
"Welcome to an ALPN-negotiated HTTP/2 connection"
let error_handler :
?request:H2.Request.t -> _ -> (Headers.t -> Body.Writer.t) -> unit
=
fun ?request:_ _error start_response ->
let response_body = start_response Headers.empty in
Body.Writer.close response_body

46
unikernel/duniverse/ocaml-h2/examples/alpn/mirage/http1_handler.ml Normal file
View file

@ -0,0 +1,46 @@
open Httpun
let redirect_handler : Reqd.t Gluten.reqd -> unit =
fun { Gluten.reqd; _ } ->
let response =
Response.create
~headers:
(Headers.of_list
[ "Location", "https://localhost:9443"; "Connection", "close" ])
`Moved_permanently
in
Reqd.respond_with_string reqd response ""
let redirect_error_handler :
?request:Request.t -> _ -> (Headers.t -> Body.Writer.t) -> unit
=
fun ?request:_ _error start_response ->
let response_body = start_response Headers.empty in
Body.Writer.close response_body
let request_handler : Reqd.t Gluten.reqd -> unit =
fun { Gluten.reqd; _ } ->
let { Request.headers; _ } = Reqd.request reqd in
let response_content_type =
match Headers.get headers "Content-Type" with
| Some request_content_type -> request_content_type
| None -> "text/plain"
in
let response_body = "Welcome to an ALPN-negotiated HTTP/1.1 connection" in
let response =
Response.create
~headers:
(Headers.of_list
[ "content-type", response_content_type
; "Content-Length", String.length response_body |> string_of_int
])
`OK
in
Reqd.respond_with_string reqd response response_body
let error_handler :
?request:Request.t -> _ -> (Headers.t -> Body.Writer.t) -> unit
=
fun ?request:_ _error start_response ->
let response_body = start_response Headers.empty in
Body.Writer.close response_body

111
unikernel/duniverse/ocaml-h2/examples/alpn/mirage/unikernel.ml Normal file
View file

@ -0,0 +1,111 @@
(*
* This code was adapted from
* https://github.com/mirage/mirage-www/blob/master/src/dispatch_tls.ml.
*
* Its copyright header is retained below.
*
* Copyright (c) 2015 Thomas Gazagnaire <thomas@gazagnaire.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt.Infix
module type HTTP = Httpun_mirage.Server
module type HTTP2 = H2_mirage.Server
module Dispatch (Http : HTTP) (Https : HTTP) (Http2 : HTTP2) = struct
let redirect =
Http.create_connection_handler
?config:None
~request_handler:Http1_handler.redirect_handler
~error_handler:Http1_handler.redirect_error_handler
let http1_handler =
Https.create_connection_handler
?config:None
~request_handler:Http1_handler.request_handler
~error_handler:Http1_handler.error_handler
let h2_handler =
Http2.create_connection_handler
?config:None
~request_handler:H2_handler.request_handler
~error_handler:H2_handler.error_handler
end
module Make
(Random : Mirage_random.S)
(S : Mirage_stack.V4)
(KEYS : Mirage_kv.RO)
(C : Mirage_console.S)
(Clock : Mirage_clock.PCLOCK) =
struct
module X509 = Tls_mirage.X509 (KEYS) (Clock)
module TCP = S.TCPV4
module TLS = Tls_mirage.Make (TCP)
module Http = Httpun_mirage.Server (TCP)
module Https = Httpun_mirage.Server (TLS)
module Http2 = H2_mirage.Server (TLS)
module D = Dispatch (Http) (Https) (Http2)
let log_src = Logs.Src.create "dispatch_tls" ~doc:"web-over-tls server"
module Log = (val Logs.src_log log_src : Logs.LOG)
let log c fmt = Printf.ksprintf (C.log c) fmt
let with_tls cfg tcp ~f =
let peer, port = TCP.dst tcp in
let log str =
Log.debug (fun f -> f "[%s:%d] %s" (Ipaddr.V4.to_string peer) port str)
in
TLS.server_of_flow cfg tcp >>= function
| Error _ ->
log "TLS failed";
TCP.close tcp
| Ok tls_server ->
log "TLS ok";
f tls_server >>= fun () -> TLS.close tls_server
let tls_init kv =
X509.certificate kv `Default >|= fun certificate ->
Tls.Config.server
~alpn_protocols:[ "h2"; "http/1.1" ] (* accept h2 before http/1.1 *)
~certificates:(`Single certificate)
()
let start _random stack keys c _clock =
tls_init keys >>= fun tls_config ->
log c "started unikernel listen (http: 8080, https: 9443)" >>= fun () ->
S.listen_tcpv4 stack ~port:8080 D.redirect;
S.listen_tcpv4 stack ~port:9443 (fun flow ->
with_tls tls_config flow ~f:(fun flow ->
match TLS.epoch flow with
| Error () ->
Lwt_io.eprintlf
"Unable to fetch session data. Did the handshake fail?"
| Ok { Tls.Core.alpn_protocol; _ } ->
(match alpn_protocol with
| None ->
(* Unable to negotiate a protocol *)
Lwt.return_unit
| Some "http/1.1" -> D.http1_handler flow
| Some "h2" -> D.h2_handler flow
| _ ->
(* Can't really happen - would mean that TLS negotiated a
* protocol that we didn't specify. *)
assert false)));
S.listen stack >>= fun () ->
let forever, _ = Lwt.wait () in
forever
end

77
unikernel/duniverse/ocaml-h2/examples/alpn/unix/alpn_server_ssl.ml Normal file
View file

@ -0,0 +1,77 @@
open Alpn_lib
let http1_handler =
Httpun_lwt_unix.Server.SSL.create_connection_handler
?config:None
~request_handler:Http1_handler.request_handler
~error_handler:Http1_handler.error_handler
let h2_handler =
H2_lwt_unix.Server.SSL.create_connection_handler
~request_handler:H2_handler.request_handler
~error_handler:H2_handler.error_handler
let start_http_server () =
let open Lwt.Infix in
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in
Lwt.async (fun () ->
Lwt_io.establish_server_with_client_socket
listen_address
(Httpun_lwt_unix.Server.create_connection_handler
?config:None
~request_handler:Http1_handler.redirect_handler
~error_handler:Http1_handler.redirect_error_handler)
>>= fun _server -> Lwt.return_unit);
let forever, _ = Lwt.wait () in
forever
let rec first_match l1 = function
| [] -> None
| x :: _ when List.mem x l1 -> Some x
| _ :: xs -> first_match l1 xs
let start_https_server () =
let open Lwt.Infix in
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 9443)) in
let cert = "./certificates/server.pem" in
let priv_key = "./certificates/server.key" in
Lwt.async (fun () ->
Lwt_io.establish_server_with_client_socket
listen_address
(fun client_addr fd ->
Lwt.catch
(fun () ->
let server_ctx =
Ssl.create_context Ssl.TLSv1_3 Ssl.Server_context
in
Ssl.disable_protocols
server_ctx
([ Ssl.SSLv23; Ssl.TLSv1_1 ] [@ocaml.alert "-deprecated"]);
Ssl.use_certificate server_ctx cert priv_key;
let protos = [ "h2"; "http/1.1" ] in
Ssl.set_context_alpn_protos server_ctx protos;
Ssl.set_context_alpn_select_callback
server_ctx
(fun client_protos -> first_match client_protos protos);
Lwt_ssl.ssl_accept fd server_ctx >>= fun ssl_server ->
match Lwt_ssl.ssl_socket ssl_server with
| None -> assert false
| Some ssl_socket ->
(match Ssl.get_negotiated_alpn_protocol ssl_socket with
| None ->
(* Unable to negotiate a protocol *)
Lwt.return_unit
| Some "http/1.1" -> http1_handler client_addr ssl_server
| Some "h2" -> h2_handler client_addr ssl_server
| Some _ ->
(* Can't really happen - would mean that TLS negotiated a
* protocol that we didn't specify. *)
assert false))
(fun exn -> Lwt_io.eprintlf "EXN: %s" (Printexc.to_string exn)))
>>= fun _server -> Lwt.return_unit);
let forever, _ = Lwt.wait () in
forever
let () =
Sys.(set_signal sigpipe Signal_ignore);
Lwt_main.run (Lwt.join [ start_http_server (); start_https_server () ])

72
unikernel/duniverse/ocaml-h2/examples/alpn/unix/alpn_server_tls.ml Normal file
View file

@ -0,0 +1,72 @@
open Alpn_lib
let http1_handler =
Httpun_lwt_unix.Server.TLS.create_connection_handler
?config:None
~request_handler:Http1_handler.request_handler
~error_handler:Http1_handler.error_handler
let h2_handler =
H2_lwt_unix.Server.TLS.create_connection_handler
?config:None
~request_handler:H2_handler.request_handler
~error_handler:H2_handler.error_handler
let start_http_server () =
let open Lwt.Infix in
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in
Lwt.async (fun () ->
Lwt_io.establish_server_with_client_socket
listen_address
(Httpun_lwt_unix.Server.create_connection_handler
?config:None
~request_handler:Http1_handler.redirect_handler
~error_handler:Http1_handler.redirect_error_handler)
>>= fun _server -> Lwt.return_unit);
let forever, _ = Lwt.wait () in
forever
let start_https_server () =
let open Lwt.Infix in
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 9443)) in
let cert = "./certificates/server.pem" in
let priv_key = "./certificates/server.key" in
Lwt.async (fun () ->
Lwt_io.establish_server_with_client_socket
listen_address
(fun client_addr fd ->
Lwt.catch
(fun () ->
X509_lwt.private_of_pems ~cert ~priv_key >>= fun certificate ->
let config =
Tls.Config.server
~alpn_protocols:[ "h2"; "http/1.1" ]
(* accept h2 before http/1.1 *)
~certificates:(`Single certificate)
()
|> Result.get_ok
in
Tls_lwt.Unix.server_of_fd config fd >>= fun tls_server ->
match Tls_lwt.Unix.epoch tls_server with
| Error () ->
Lwt_io.eprintlf
"Unable to fetch session data. Did the handshake fail?"
| Ok { alpn_protocol; _ } ->
(match alpn_protocol with
| None ->
(* Unable to negotiate a protocol *)
Lwt.return_unit
| Some "http/1.1" -> http1_handler client_addr tls_server
| Some "h2" -> h2_handler client_addr tls_server
| _ ->
(* Can't really happen - would mean that TLS negotiated a
* protocol that we didn't specify. *)
assert false))
(fun exn -> Lwt_io.eprintlf "EXN: %s" (Printexc.to_string exn)))
>>= fun _server -> Lwt.return_unit);
let forever, _ = Lwt.wait () in
forever
let () =
Sys.(set_signal sigpipe Signal_ignore);
Lwt_main.run (Lwt.join [ start_http_server (); start_https_server () ])

9
unikernel/duniverse/ocaml-h2/examples/alpn/unix/dune Normal file
View file

@ -0,0 +1,9 @@
(executable
(name alpn_server_tls)
(modules alpn_server_tls)
(libraries tls tls-lwt lwt lwt.unix alpn_lib))
(executable
(name alpn_server_ssl)
(modules alpn_server_ssl)
(libraries lwt lwt.unix lwt_ssl alpn_lib))

76
unikernel/duniverse/ocaml-h2/examples/async/async_ssl_https_echo_server_post.ml Normal file
View file

@ -0,0 +1,76 @@
open Core
open Async
open H2
open H2_async
let error_handler _ ?request:_ error start_response =
let response_body = start_response Headers.empty in
(match error with
| `Exn exn ->
Body.Writer.write_string response_body (Exn.to_string exn);
Body.Writer.write_string response_body "\n"
| #Status.standard as error ->
Body.Writer.write_string response_body (Status.default_reason_phrase error));
Body.Writer.close response_body
let request_handler sock reqd =
eprintf "Received request from %s\n%!" (Socket.Address.Inet.to_string sock);
match Reqd.request reqd with
| { Request.meth = `POST; headers; _ } ->
let response =
let content_type =
match Headers.get headers "content-type" with
| None -> "application/octet-stream"
| Some x -> x
in
Response.create
~headers:(Headers.of_list [ "content-type", content_type ])
`OK
in
let request_body = Reqd.request_body reqd in
let response_body = Reqd.respond_with_streaming reqd response in
let rec on_read buffer ~off ~len =
Body.Writer.write_bigstring response_body buffer ~off ~len;
Body.Reader.schedule_read request_body ~on_eof ~on_read
and on_eof () =
print_endline "eof";
Body.Writer.close response_body
in
Body.Reader.schedule_read (Reqd.request_body reqd) ~on_eof ~on_read
| _ -> Reqd.respond_with_string reqd (Response.create `Method_not_allowed) ""
let main port max_accepts_per_batch () =
let where_to_listen =
Tcp.Where_to_listen.bind_to
Tcp.Bind_to_address.Localhost
(Tcp.Bind_to_port.On_port port)
in
Tcp.(
Server.create_sock
~on_handler_error:`Ignore
~backlog:10_000
~max_connections:10_000
~max_accepts_per_batch
where_to_listen)
(Server.SSL.create_connection_handler_with_default
~certfile:"./certificates/server.pem"
~keyfile:"./certificates/server.key"
~request_handler
~error_handler)
>>= fun _server -> Deferred.never ()
let () =
Command.async_spec
~summary:"Start a hello world async_ssl server"
Command.Spec.(
empty
+> flag
"-port"
(optional_with_default 8080 int)
~doc:"int Source port to listen on"
+> flag
"-a"
(optional_with_default 1 int)
~doc:"int Maximum accepts per batch")
main
|> Command_unix.run

85
unikernel/duniverse/ocaml-h2/examples/async/async_tls_https_echo_client_post.ml Normal file
View file

@ -0,0 +1,85 @@
open Core
open Async
open H2
open H2_async
let error_handler = function
| `Invalid_response_body_length _resp ->
printf "invalid response body length\n%!"
| `Exn _exn -> printf "exception!\n%!"
| `Malformed_response s -> printf "malformed response: %s\n%!" s
| `Protocol_error (code, s) ->
printf "protocol error: %s, %s\n%!" (H2.Error_code.to_string code) s
let response_handler response_received_ivar response response_body =
match Response.(response.status) with
| `OK ->
let rec read_response () =
Body.Reader.schedule_read
response_body
~on_eof:(fun () ->
(Ivar.fill [@ocaml.alert "-deprecated"]) response_received_ivar ())
~on_read:(fun response_fragment ~off ~len ->
printf
"Server response: %s\n%!"
(Bigstringaf.substring ~off ~len response_fragment);
read_response ())
in
read_response ()
| _ ->
Format.fprintf Format.err_formatter "%a\n%!" Response.pp_hum response;
Shutdown.shutdown 1
let main port host () =
printf "Type in your text to send, then hit EOF:\n%!";
Reader.contents (Lazy.force Reader.stdin) >>= fun text_to_send ->
let socket = Unix.Socket.create Unix.Socket.Type.tcp in
let where_to_connect =
let hnp = Host_and_port.create ~host ~port in
Tcp.Where_to_connect.of_host_and_port hnp
in
Client.TLS.create_connection_with_default
~error_handler
socket
where_to_connect
>>= fun tls_conn ->
let request_headers =
Request.create
`POST
"/"
~scheme:"http"
~headers:
Headers.(
of_list
[ ":authority", host
; "content-length", string_of_int (String.length text_to_send)
])
in
let response_received_ivar = Ivar.create () in
let response_handler = response_handler response_received_ivar in
let request_body =
H2_async.Client.TLS.request
tls_conn
request_headers
~error_handler
~response_handler
in
Body.Writer.write_string request_body text_to_send;
Body.Writer.close request_body;
Ivar.read response_received_ivar
let () =
Command.async_spec
~summary:"Start a hello world tls-async client"
Command.Spec.(
empty
+> flag
"-port"
(optional_with_default 8080 int)
~doc:"int Source port to listen on"
+> flag
"-host"
(optional_with_default "localhost" string)
~doc:"HOST to connect to")
main
|> Command_unix.run

8
unikernel/duniverse/ocaml-h2/examples/async/dune Normal file
View file

@ -0,0 +1,8 @@
(executables
(libraries h2 h2-async async core core_unix.command_unix)
(names async_ssl_https_echo_server_post async_tls_https_echo_client_post))
(alias
(name examples)
(deps
(glob_files *.exe)))

8
unikernel/duniverse/ocaml-h2/examples/eio/dune Normal file
View file

@ -0,0 +1,8 @@
(executable
(name eio_get)
(libraries h2 h2-eio eio-ssl eio_main eio.unix))
(alias
(name examples)
(deps
(glob_files *.exe)))

118
unikernel/duniverse/ocaml-h2/examples/eio/eio_get.ml Normal file
View file

@ -0,0 +1,118 @@
open H2
module Client = H2_eio.Client
let response_handler ~on_eof response response_body =
Format.eprintf "Response: %a@." Response.pp_hum response;
let rec read_response () =
Body.Reader.schedule_read
response_body
~on_eof
~on_read:(fun bigstring ~off ~len ->
Format.eprintf "heh nice %d@." len;
let response_fragment = Bytes.create len in
Bigstringaf.blit_to_bytes
bigstring
~src_off:off
response_fragment
~dst_off:0
~len;
print_string (Bytes.to_string response_fragment);
read_response ())
in
read_response ()
let error_handler u err =
(match err with
| `Exn exn -> Format.eprintf "wut %S@." (Printexc.to_string exn)
| `Invalid_response_body_length res ->
Format.eprintf "invalid res: %a@." Response.pp_hum res
| `Malformed_response str -> Format.eprintf "malformed %S@." str
| `Protocol_error (err, s) ->
Format.eprintf "wut %a %S@." H2.Error_code.pp_hum err s);
Eio.Promise.resolve u ()
let[@ocaml.alert "-deprecated"] () =
Ssl_threads.init ();
Ssl.init ~thread_safe:true ();
let host = ref None in
let port = ref 443 in
Arg.parse
[ "-p", Set_int port, " Port number (443 by default)" ]
(fun host_argument -> host := Some host_argument)
"eio_get.exe [-p N] HOST";
let host =
match !host with
| None -> failwith "No hostname provided"
| Some host -> host
in
Eio_main.run (fun env ->
let network = Eio.Stdenv.net env in
Eio.Switch.run (fun sw ->
let addrs =
let addrs =
Eio_unix.run_in_systhread (fun () ->
Unix.getaddrinfo
host
(string_of_int !port)
[ Unix.(AI_FAMILY PF_INET) ])
in
List.filter_map
(fun (addr : Unix.addr_info) ->
match addr.ai_addr with
| Unix.ADDR_UNIX _ -> None
| ADDR_INET (addr, port) -> Some (addr, port))
addrs
in
let addr =
let inet, port = List.hd addrs in
`Tcp (Eio_unix.Net.Ipaddr.of_unix inet, port)
in
let socket = Eio.Net.connect ~sw network addr in
let request =
Request.create
`GET
"/"
~scheme:"https"
~headers:
Headers.(
add_list
empty
[ "user-agent", "carl/0.0.0-experimental"; ":authority", host ])
in
let ctx = Ssl.create_context Ssl.SSLv23 Ssl.Client_context in
(* Ssl.disable_protocols ctx [ Ssl.SSLv23 ]; *)
Ssl.honor_cipher_order ctx;
Ssl.set_context_alpn_protos ctx [ "h2" ];
Ssl.set_min_protocol_version ctx TLSv1_3;
Ssl.set_max_protocol_version ctx TLSv1_3;
let ssl_ctx = Eio_ssl.Context.create ~ctx socket in
let ssl_sock = Eio_ssl.Context.ssl_socket ssl_ctx in
Ssl.set_client_SNI_hostname ssl_sock host;
Ssl.set_hostflags ssl_sock [ No_partial_wildcards ];
Ssl.set_host ssl_sock host;
let ssl_sock = Eio_ssl.connect ssl_ctx in
let shut_p, shut_u = Eio.Promise.create () in
let error_handler = error_handler shut_u in
let connection = Client.create_connection ~sw ~error_handler ssl_sock in
let response_handler =
response_handler ~on_eof:(fun () ->
Format.eprintf "eof@.";
Eio.Promise.resolve shut_u ())
in
let request_body =
Client.request
connection
request
~error_handler
~response_handler
~flush_headers_immediately:true
in
Body.Writer.close request_body;
Eio.Promise.await shut_p;
Eio.Promise.await (Client.shutdown connection)))

14
unikernel/duniverse/ocaml-h2/examples/lwt/dune Normal file
View file

@ -0,0 +1,14 @@
(executables
(names lwt_echo_server2 lwt_https_server lwt_get lwt_post)
(modules lwt_echo_server2 lwt_https_server lwt_get lwt_post)
(libraries h2 h2-lwt-unix lwt.unix))
(executable
(name lwt_h2c)
(libraries h2 httpun-lwt-unix h2-lwt-unix lwt.unix)
(modules lwt_h2c))
(alias
(name examples)
(deps
(glob_files *.exe)))

155
unikernel/duniverse/ocaml-h2/examples/lwt/lwt_echo_server2.ml Normal file
View file

@ -0,0 +1,155 @@
let set_interval s f destroy =
let rec set_interval_loop s f n =
let timeout =
Lwt_timeout.create s (fun () ->
if n > 0
then (if f () then set_interval_loop s f (n - 1))
else destroy ())
in
Lwt_timeout.start timeout
in
set_interval_loop s f 2
let connection_handler : Unix.sockaddr -> Lwt_unix.file_descr -> unit Lwt.t =
let open H2 in
let request_handler : Unix.sockaddr -> Reqd.t -> unit =
fun _client_address request_descriptor ->
let request = Reqd.request request_descriptor in
match request.meth, request.target with
| `GET, "/" | `POST, "/" ->
let request_body = Reqd.request_body request_descriptor in
let response_content_type =
match Headers.get request.headers "content-type" with
| Some request_content_type -> request_content_type
| None -> "application/octet-stream"
in
let rec respond () =
Body.Reader.schedule_read
request_body
~on_eof:(fun () ->
let response =
Response.create
~headers:
(Headers.of_list [ "content-type", response_content_type ])
`OK
in
Reqd.respond_with_string
request_descriptor
response
"non-empty data.")
~on_read:(fun _request_data ~off:_ ~len:_ -> respond ())
in
respond ()
| `POST, "/other" ->
let request_body = Reqd.request_body request_descriptor in
let response_content_type =
match Headers.get request.headers "content-type" with
| Some request_content_type -> request_content_type
| None -> "application/octet-stream"
in
let response =
Response.create
~headers:(Headers.of_list [ "content-type", response_content_type ])
`OK
in
let response_body =
Reqd.respond_with_streaming request_descriptor response
in
let rec respond () =
Body.Reader.schedule_read
request_body
~on_eof:(fun () ->
set_interval
1
(fun () ->
Body.Writer.write_string response_body "FOO";
(* Body.flush response_body ignore; *)
true)
(* Body.flush response_body ignore; *)
(fun () -> Body.Writer.close response_body))
~on_read:(fun request_data ~off ~len ->
Body.Writer.write_bigstring response_body request_data ~off ~len;
respond ())
in
respond ()
| `POST, "/foo" ->
let response =
Response.create
`OK
~headers:(Headers.of_list [ "content-type", "text/event-stream" ])
in
let request_body = Reqd.request_body request_descriptor in
let response_body =
Reqd.respond_with_streaming request_descriptor response
in
(* let (finished, notify) = Lwt.wait () in *)
let rec on_read _request_data ~off:_ ~len:_ =
Body.Writer.flush response_body (fun _ ->
Body.Reader.schedule_read request_body ~on_eof ~on_read)
and on_eof () =
set_interval
2
(fun () ->
let _ =
Body.Writer.write_string response_body "data: some data\n\n"
in
Body.Writer.flush response_body ignore;
true)
(fun () ->
let _ =
Body.Writer.write_string response_body "event: end\ndata: 1\n\n"
in
Body.Writer.flush response_body (fun _ ->
Body.Writer.close response_body))
in
Body.Reader.schedule_read ~on_read ~on_eof request_body;
()
| _ ->
Reqd.respond_with_string
request_descriptor
(Response.create `Method_not_allowed)
"Hello, Sean."
in
let error_handler :
Unix.sockaddr
-> ?request:H2.Request.t
-> _
-> (Headers.t -> Body.Writer.t)
-> unit
=
fun _client_address ?request:_ error start_response ->
let response_body = start_response Headers.empty in
(match error with
| `Exn exn ->
Body.Writer.write_string response_body (Printexc.to_string exn);
Body.Writer.write_string response_body "\n"
| #Status.standard as error ->
Body.Writer.write_string
response_body
(Status.default_reason_phrase error));
Body.Writer.close response_body
in
H2_lwt_unix.Server.create_connection_handler
?config:None
~request_handler
~error_handler
let () =
let open Lwt.Infix in
Sys.(set_signal sigpipe Signal_ignore);
let port = ref 8080 in
Arg.parse
[ "-p", Arg.Set_int port, " Listening port number (8080 by default)" ]
ignore
"Echoes POST requests. Runs forever.";
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, !port)) in
Lwt.async (fun () ->
Lwt_io.establish_server_with_client_socket listen_address connection_handler
>>= fun _server ->
Printf.printf "Listening on port %i and echoing POST requests.\n" !port;
print_string "To send a POST request, try\n\n";
print_string " echo foo | dune exec examples/lwt/lwt_post.exe\n\n";
flush stdout;
Lwt.return_unit);
let forever, _ = Lwt.wait () in
Lwt_main.run forever

61
unikernel/duniverse/ocaml-h2/examples/lwt/lwt_get.ml Normal file
View file

@ -0,0 +1,61 @@
open H2
module Client = H2_lwt_unix.Client
let response_handler notify_response_received _response response_body =
let rec read_response () =
Body.Reader.schedule_read
response_body
~on_eof:(fun () -> Lwt.wakeup_later notify_response_received ())
~on_read:(fun bigstring ~off ~len ->
let response_fragment = Bytes.create len in
Bigstringaf.blit_to_bytes
bigstring
~src_off:off
response_fragment
~dst_off:0
~len;
print_string (Bytes.to_string response_fragment);
read_response ())
in
read_response ()
let error_handler _ = assert false
open Lwt.Infix
let () =
let host = ref None in
let port = ref 443 in
Arg.parse
[ "-p", Set_int port, " Port number (443 by default)" ]
(fun host_argument -> host := Some host_argument)
"lwt_get.exe [-p N] HOST";
let host =
match !host with
| None -> failwith "No hostname provided"
| Some host -> host
in
Lwt_main.run
( Lwt_unix.getaddrinfo
host
(string_of_int !port)
[ Unix.(AI_FAMILY PF_INET) ]
>>= fun addresses ->
let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Lwt_unix.connect socket (List.hd addresses).Unix.ai_addr >>= fun () ->
let request =
Request.create
`GET
"/"
~scheme:"https"
~headers:Headers.(add_list empty [ ":authority", host ])
in
let response_received, notify_response_received = Lwt.wait () in
let response_handler = response_handler notify_response_received in
Client.SSL.create_connection_with_default ~error_handler socket
>>= fun connection ->
let request_body =
Client.SSL.request connection request ~error_handler ~response_handler
in
Body.Writer.close request_body;
response_received )

142
unikernel/duniverse/ocaml-h2/examples/lwt/lwt_h2c.ml Normal file
View file

@ -0,0 +1,142 @@
open Lwt.Infix
module Http2 = struct
open H2
let connection_handler :
Httpun.Request.t
-> Bigstringaf.t H2.IOVec.t list
-> (Server_connection.t, string) result
=
let request_handler : H2.Server_connection.request_handler =
fun request_descriptor ->
let request = Reqd.request request_descriptor in
match request.meth, request.target with
| `GET, "/" | `POST, "/" ->
(* This set of routes waits until the entire request body has been read
* to produce a response. *)
let request_body = Reqd.request_body request_descriptor in
let response_content_type =
match Headers.get request.headers "content-type" with
| Some request_content_type -> request_content_type
| None -> "application/octet-stream"
in
let buf = Buffer.create 10 in
let rec respond () =
Body.Reader.schedule_read
request_body
~on_eof:(fun () ->
let response =
Response.create
~headers:
(Headers.of_list [ "content-type", response_content_type ])
`OK
in
Reqd.respond_with_string
request_descriptor
response
(Buffer.contents buf))
~on_read:(fun request_data ~off ~len ->
let bytes = Bytes.create len in
Bigstringaf.blit_to_bytes
request_data
~src_off:off
~dst_off:0
~len
bytes;
Buffer.add_bytes buf bytes;
respond ())
in
respond ()
| _ ->
Reqd.respond_with_string
request_descriptor
(Response.create `Method_not_allowed)
""
in
let error_handler ?request:_ error start_response =
let response_body = start_response Headers.empty in
(match error with
| `Exn exn ->
Body.Writer.write_string response_body (Printexc.to_string exn);
Body.Writer.write_string response_body "\n"
| #Status.standard as error ->
Body.Writer.write_string
response_body
(Status.default_reason_phrase error));
Body.Writer.close response_body
in
fun http_request request_body ->
let { Httpun.Request.headers; target; meth; _ } = http_request in
H2.Server_connection.create_h2c
?config:None
~headers
~target
~meth
~request_body
~error_handler
request_handler
end
let connection_handler =
let module Body = Httpun.Body in
let module Headers = Httpun.Headers in
let module Reqd = Httpun.Reqd in
let module Response = Httpun.Response in
let module Status = Httpun.Status in
let upgrade_handler request upgrade () =
let off = 0 in
let len = 3 in
let body =
[ { H2.IOVec.buffer = Bigstringaf.of_string ~off ~len "foo"; off; len }
; { buffer = Bigstringaf.of_string ~off ~len "bar"; off; len }
; { buffer = Bigstringaf.of_string ~off ~len "baz"; off; len }
]
in
let connection =
Stdlib.Result.get_ok (Http2.connection_handler request body)
in
upgrade (Gluten.make (module H2.Server_connection) connection)
in
let http_error_handler _client_address ?request:_ error handle =
let message =
match error with
| `Exn exn -> Printexc.to_string exn
| (#Status.client_error | #Status.server_error) as error ->
Status.to_string error
in
let body = handle Headers.empty in
Body.Writer.write_string body message;
Body.Writer.close body
in
let request_handler _addr (reqd : Httpun.Reqd.t Gluten.reqd) =
let { Gluten.reqd; upgrade } = reqd in
let headers =
Headers.of_list [ "Connection", "Upgrade"; "Upgrade", "h2c" ]
in
let request = Reqd.request reqd in
Reqd.respond_with_upgrade reqd headers (upgrade_handler request upgrade)
in
Httpun_lwt_unix.Server.create_connection_handler
?config:None
~request_handler
~error_handler:http_error_handler
let () =
Sys.(set_signal sigpipe Signal_ignore);
let port = ref 8080 in
Arg.parse
[ "-p", Arg.Set_int port, " Listening port number (8080 by default)" ]
ignore
"Echoes POST requests. Runs forever.";
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, !port)) in
Lwt.async (fun () ->
Lwt_io.establish_server_with_client_socket listen_address connection_handler
>>= fun _server ->
Printf.printf "Listening on port %i and echoing POST requests.\n" !port;
print_string "To send a POST request, try\n\n";
print_string " echo foo | dune exec examples/lwt/lwt_post.exe\n\n";
flush stdout;
Lwt.return_unit);
let forever, _ = Lwt.wait () in
Lwt_main.run forever

120
unikernel/duniverse/ocaml-h2/examples/lwt/lwt_https_server.ml Normal file
View file

@ -0,0 +1,120 @@
let set_interval ?(times = 5) s f destroy =
let rec set_interval_loop s f n =
let timeout =
Lwt_timeout.create s (fun () ->
if n > 0
then (if f () then set_interval_loop s f (n - 1))
else destroy ())
in
Lwt_timeout.start timeout
in
set_interval_loop s f times
let connection_handler : Unix.sockaddr -> Lwt_unix.file_descr -> unit Lwt.t =
let open H2 in
let request_handler : Unix.sockaddr -> Reqd.t -> unit =
fun _client_address request_descriptor ->
let request = Reqd.request request_descriptor in
match request.meth, request.target with
| `POST, "/" ->
(* let request_body = Reqd.request_body request_descriptor in *)
let response_content_type =
match Headers.get request.headers "Content-Type" with
| Some request_content_type -> request_content_type
| None -> "application/octet-stream"
in
let response =
Response.create
~headers:
(Headers.of_list
[ "content-type", response_content_type
(* "Connection", "close"; *)
])
`OK
in
(* let response_body = Reqd.respond_with_streaming request_descriptor
response in *)
(* let rec respond () = Body.schedule_read request_body ~on_eof:(fun () ->
Body.close_writer response_body) ~on_read:(fun request_data ~off ~len
-> Body.write_bigstring response_body request_data ~off ~len; respond
()) in respond () *)
Reqd.respond_with_string request_descriptor response "ANTOINO"
| `POST, "/foo" ->
set_interval
~times:1
2
(fun () ->
let response_content_type =
match Headers.get request.headers "Content-Type" with
| Some request_content_type -> request_content_type
| None -> "application/octet-stream"
in
let response =
Response.create
~headers:
(Headers.of_list
[ "content-type", response_content_type
(* "Connection", "close"; *)
])
`OK
in
Reqd.respond_with_string request_descriptor response "ANTOINO";
true)
ignore
| `GET, _ ->
Reqd.respond_with_string
request_descriptor
(Response.create `OK)
"Welcome to ocaml-h2"
| _ ->
Reqd.respond_with_string
request_descriptor
(Response.create `Method_not_allowed)
""
in
let error_handler :
Unix.sockaddr
-> ?request:H2.Request.t
-> _
-> (Headers.t -> Body.Writer.t)
-> unit
=
fun _client_address ?request:_ _error start_response ->
let response_body = start_response Headers.empty in
(* begin match error with | `Exn exn -> Body.write_string response_body
(Printexc.to_string exn); Body.write_string response_body "\n";
| #Status.standard as error -> Body.write_string response_body
(Status.default_reason_phrase error) end; *)
Body.Writer.close response_body
in
let certfile = "./certificates/server.pem" in
let keyfile = "./certificates/server.key" in
H2_lwt_unix.Server.SSL.create_connection_handler_with_default
~certfile
~keyfile
?config:None
~request_handler
~error_handler
let () =
let open Lwt.Infix in
Sys.(set_signal sigpipe Signal_ignore);
let port = ref 8080 in
Arg.parse
[ "-p", Arg.Set_int port, " Listening port number (8080 by default)" ]
ignore
"Echoes POST requests. Runs forever.";
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, !port)) in
Lwt.async (fun () ->
Lwt_io.establish_server_with_client_socket listen_address connection_handler
>>= fun _server ->
Printf.printf "Listening on port %i and echoing POST requests.\n" !port;
print_string "To send a POST request, try\n\n";
print_string " curl https://localhost:8080 -k -X POST -d foo\n\n";
flush stdout;
Lwt.return_unit);
let forever, _ = Lwt.wait () in
Lwt_main.run forever

78
unikernel/duniverse/ocaml-h2/examples/lwt/lwt_post.ml Normal file
View file

@ -0,0 +1,78 @@
open H2
let response_handler notify_response_received response response_body =
match Response.(response.status) with
| `OK ->
let rec read_response () =
Body.Reader.schedule_read
response_body
~on_eof:(fun () -> Lwt.wakeup_later notify_response_received ())
~on_read:(fun response_fragment ~off ~len ->
let response_fragment_string = Bytes.create len in
Lwt_bytes.blit_to_bytes
response_fragment
off
response_fragment_string
0
len;
print_string (Bytes.unsafe_to_string response_fragment_string);
read_response ())
in
read_response ()
| _ ->
Format.fprintf Format.err_formatter "%a\n%!" Response.pp_hum response;
exit 1
let error_handler = function
| `Invalid_response_body_length _resp ->
Printf.printf "invalid response body length\n%!"
| `Exn _exn -> Printf.printf "exception!\n%!"
| `Malformed_response s -> Printf.printf "malformed response: %s\n%!" s
| `Protocol_error (code, s) ->
Printf.printf "protocol error: %s, %s\n%!" (H2.Error_code.to_string code) s
open Lwt.Infix
let () =
let host = ref "127.0.0.1" in
let port = ref 8080 in
Arg.parse
[ "-h", Set_string host, " Hostname (127.0.0.1 by default)"
; "-p", Set_int port, " Port number (8080 by default)"
]
ignore
"lwt_get.exe [-h HOST] [-p N]";
Lwt_main.run
( Lwt_io.(read stdin) >>= fun text_to_send ->
Lwt_unix.getaddrinfo
!host
(string_of_int !port)
[ Unix.(AI_FAMILY PF_INET) ]
>>= fun addresses ->
let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Lwt_unix.connect socket (List.hd addresses).Unix.ai_addr >>= fun () ->
let request_headers =
Request.create
`POST
"/"
~scheme:"http"
~headers:
Headers.(
of_list
[ ":authority", !host
; "content-length", string_of_int (String.length text_to_send)
])
in
let response_received, notify_response_received = Lwt.wait () in
let response_handler = response_handler notify_response_received in
H2_lwt_unix.Client.create_connection ~error_handler socket >>= fun conn ->
let request_body =
H2_lwt_unix.Client.request
conn
request_headers
~error_handler
~response_handler
in
Body.Writer.write_string request_body text_to_send;
Body.Writer.close request_body;
response_received )

22
unikernel/duniverse/ocaml-h2/examples/mirage/config.ml Normal file
View file

@ -0,0 +1,22 @@
open Mirage
(* Network configuration *)
let stack = generic_stackv4 default_network
(* Dependencies *)
let server =
let packages =
[ package ~pin:"file://../../" "h2-lwt"
; package ~pin:"file://../../" "h2-mirage"
]
in
foreign "Unikernel.Make" ~packages (console @-> pclock @-> http2 @-> job)
let app = http2_server @@ conduit_direct stack
let () =
register
"h2_unikernel"
[ server $ default_console $ default_posix_clock $ app ]

54
unikernel/duniverse/ocaml-h2/examples/mirage/unikernel.ml Normal file
View file

@ -0,0 +1,54 @@
open Lwt.Infix
open H2
module type HTTP2 = H2_mirage.Server
module Dispatch (C : Mirage_console.S) (Http2 : HTTP2) = struct
let log c fmt = Printf.ksprintf (C.log c) fmt
let get_content c path =
log c "Replying: %s" path >|= fun () -> "Hello from the h2 unikernel"
let dispatcher c reqd =
let { Request.target; _ } = Reqd.request reqd in
Lwt.catch
(fun () ->
get_content c target >|= fun body ->
let response =
Response.create
~headers:
(Headers.of_list
[ "content-length", body |> String.length |> string_of_int ])
`OK
in
Reqd.respond_with_string reqd response body)
(fun exn ->
let response = Response.create `Internal_server_error in
Lwt.return
(Reqd.respond_with_string reqd response (Printexc.to_string exn)))
|> ignore
let serve c dispatch =
let error_handler ?request:_ _error mk_response =
let response_body = mk_response Headers.empty in
Body.Writer.write_string response_body "Error handled";
Body.Writer.flush response_body (fun () ->
Body.Writer.close response_body)
in
Http2.create_connection_handler
?config:None
~request_handler:(dispatch c)
~error_handler
end
(** Server boilerplate *)
module Make (C : Mirage_console.S) (Clock : Mirage_clock.PCLOCK) (Http2 : HTTP2) =
struct
module D = Dispatch (C) (Http2)
let log c fmt = Printf.ksprintf (C.log c) fmt
let start c _clock http2 =
log c "started unikernel listen on port 8001" >>= fun () ->
http2 (`TCP 8001) @@ D.serve c D.dispatcher
end

98
unikernel/duniverse/ocaml-h2/flake.lock generated Normal file
View file

@ -0,0 +1,98 @@
{
"nodes": {
"flake-utils": {
"inputs": {
"systems": "systems"
},
"locked": {
"lastModified": 1710146030,
"narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"nix-filter": {
"locked": {
"lastModified": 1710156097,
"narHash": "sha256-1Wvk8UP7PXdf8bCCaEoMnOT1qe5/Duqgj+rL8sRQsSM=",
"owner": "numtide",
"repo": "nix-filter",
"rev": "3342559a24e85fc164b295c3444e8a139924675b",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "nix-filter",
"type": "github"
}
},
"nixpkgs": {
"inputs": {
"flake-utils": [
"flake-utils"
],
"nixpkgs": "nixpkgs_2"
},
"locked": {
"lastModified": 1725474362,
"narHash": "sha256-Tnw+AO0eHSnYTyvKx5Frj4RY2sBKWsFhRRhoEfds1ZU=",
"owner": "anmonteiro",
"repo": "nix-overlays",
"rev": "056b77e5c9aa3155a0b843f7007b924e9adb8bab",
"type": "github"
},
"original": {
"owner": "anmonteiro",
"repo": "nix-overlays",
"type": "github"
}
},
"nixpkgs_2": {
"locked": {
"lastModified": 1725448034,
"narHash": "sha256-YWbVeDERbIHAEQCtDtUunHYUNH31ReIdJIP8juXfdpM=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "9b40840066f93767bb528810ea7dc9caacd8997f",
"type": "github"
},
"original": {
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "9b40840066f93767bb528810ea7dc9caacd8997f",
"type": "github"
}
},
"root": {
"inputs": {
"flake-utils": "flake-utils",
"nix-filter": "nix-filter",
"nixpkgs": "nixpkgs"
}
},
"systems": {
"locked": {
"lastModified": 1681028828,
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
"owner": "nix-systems",
"repo": "default",
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
"type": "github"
},
"original": {
"owner": "nix-systems",
"repo": "default",
"type": "github"
}
}
},
"root": "root",
"version": 7
}

29
unikernel/duniverse/ocaml-h2/flake.nix Normal file
View file

@ -0,0 +1,29 @@
{
description = "H2 Nix Flake";
inputs.nix-filter.url = "github:numtide/nix-filter";
inputs.flake-utils.url = "github:numtide/flake-utils";
inputs.nixpkgs.url = "github:anmonteiro/nix-overlays";
inputs.nixpkgs.inputs.flake-utils.follows = "flake-utils";
outputs = { self, nixpkgs, flake-utils, nix-filter }:
flake-utils.lib.eachDefaultSystem (system:
let
pkgs = nixpkgs.legacyPackages."${system}".extend (self: super: {
ocamlPackages = super.ocaml-ng.ocamlPackages_5_2.overrideScope (oself: osuper: {
gluten-lwt-unix = osuper.gluten-lwt-unix.overrideAttrs (o: {
propagatedBuildInputs = o.propagatedBuildInputs ++ [ oself.tls-lwt ];
});
});
});
packages = pkgs.callPackage ./nix { nix-filter = nix-filter.lib; };
in
{
packages = packages // { default = packages.h2; };
defaultPackage = packages.h2;
devShells = {
default = pkgs.callPackage ./nix/shell.nix { inherit packages; };
release = self.devShells.${system}.default.override { release-mode = true; };
};
});
}

35
unikernel/duniverse/ocaml-h2/h2-async.opam Normal file
View file

@ -0,0 +1,35 @@
version: "0.13.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Async support for h2"
description:
"h2 is an implementation of the HTTP/2 specification entirely in OCaml. h2-async provides an Async runtime implementation for h2."
maintainer: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
authors: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
license: "BSD-3-clause"
homepage: "https://github.com/anmonteiro/ocaml-h2"
bug-reports: "https://github.com/anmonteiro/ocaml-h2/issues"
depends: [
"dune" {>= "2.7"}
"ocaml" {>= "4.08.0"}
"h2" {= version}
"faraday-async"
"gluten-async" {>= "0.4.0"}
"odoc" {with-doc}
]
depopts: ["async_ssl" "tls-async"]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/anmonteiro/ocaml-h2.git"

33
unikernel/duniverse/ocaml-h2/h2-eio.opam Normal file
View file

@ -0,0 +1,33 @@
version: "0.13.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "EIO support for h2"
description:
"h2 is an implementation of the HTTP/2 specification entirely in OCaml. h2-eio provides an EIO runtime implementation for h2."
maintainer: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
authors: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
license: "BSD-3-clause"
homepage: "https://github.com/anmonteiro/ocaml-h2"
bug-reports: "https://github.com/anmonteiro/ocaml-h2/issues"
depends: [
"dune" {>= "2.7"}
"ocaml" {>= "4.08.0"}
"h2" {= version}
"gluten-eio" {>= "0.5.0"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/anmonteiro/ocaml-h2.git"

35
unikernel/duniverse/ocaml-h2/h2-lwt-unix.opam Normal file
View file

@ -0,0 +1,35 @@
version: "0.13.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Lwt + UNIX support for h2"
description:
"h2 is an implementation of the HTTP/2 specification entirely in OCaml. h2-lwt-unix provides an Lwt runtime implementation for h2 that targets UNIX binaries."
maintainer: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
authors: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
license: "BSD-3-clause"
homepage: "https://github.com/anmonteiro/ocaml-h2"
bug-reports: "https://github.com/anmonteiro/ocaml-h2/issues"
depends: [
"dune" {>= "2.7"}
"ocaml" {>= "4.08.0"}
"h2-lwt" {= version}
"faraday-lwt-unix"
"gluten-lwt-unix" {>= "0.2.1"}
"odoc" {with-doc}
]
depopts: ["tls-lwt" "lwt_ssl"]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/anmonteiro/ocaml-h2.git"

34
unikernel/duniverse/ocaml-h2/h2-lwt.opam Normal file
View file

@ -0,0 +1,34 @@
version: "0.13.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Lwt support for h2"
description:
"h2 is an implementation of the HTTP/2 specification entirely in OCaml. h2-lwt provides an Lwt runtime implementation for h2."
maintainer: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
authors: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
license: "BSD-3-clause"
homepage: "https://github.com/anmonteiro/ocaml-h2"
bug-reports: "https://github.com/anmonteiro/ocaml-h2/issues"
depends: [
"dune" {>= "2.7"}
"ocaml" {>= "4.08.0"}
"h2" {= version}
"lwt" {>= "5.1.1"}
"gluten-lwt" {>= "0.2.1"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/anmonteiro/ocaml-h2.git"

37
unikernel/duniverse/ocaml-h2/h2-mirage.opam Normal file
View file

@ -0,0 +1,37 @@
version: "0.13.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Lwt support for h2"
description:
"h2 is an implementation of the HTTP/2 specification entirely in OCaml. h2-mirage provides an Lwt runtime implementation for h2 that targets MirageOS unikernels."
maintainer: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
authors: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
license: "BSD-3-clause"
homepage: "https://github.com/anmonteiro/ocaml-h2"
bug-reports: "https://github.com/anmonteiro/ocaml-h2/issues"
depends: [
"dune" {>= "2.7"}
"ocaml" {>= "4.08.0"}
"h2-lwt" {= version}
"faraday-lwt"
"lwt"
"gluten-mirage" {>= "0.3.0"}
"mirage-flow" {>= "2.0.0"}
"cstruct"
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/anmonteiro/ocaml-h2.git"

42
unikernel/duniverse/ocaml-h2/h2.opam Normal file
View file

@ -0,0 +1,42 @@
version: "0.13.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis:
"A high-performance, memory-efficient, and scalable HTTP/2 library for OCaml"
description:
"h2 is an implementation of the HTTP/2 specification entirely in OCaml. It is based on the concepts in httpun, and therefore uses the Angstrom and Faraday libraries to implement the parsing and serialization layers of the HTTP/2 standard as a state machine that is agnostic to the underlying I/O specifics. It also preserves the same API as httpun wherever possible."
maintainer: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
authors: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
license: "BSD-3-clause"
homepage: "https://github.com/anmonteiro/ocaml-h2"
bug-reports: "https://github.com/anmonteiro/ocaml-h2/issues"
depends: [
"dune" {>= "2.7"}
"ocaml" {>= "4.08.0"}
"base64" {>= "3.0.0"}
"angstrom" {>= "0.14.0"}
"faraday" {>= "0.7.3"}
"bigstringaf" {>= "0.5.0"}
"psq"
"hpack" {= version}
"httpun-types"
"alcotest" {with-test}
"yojson" {with-test}
"hex" {with-test}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/anmonteiro/ocaml-h2.git"

35
unikernel/duniverse/ocaml-h2/hpack.opam Normal file
View file

@ -0,0 +1,35 @@
version: "0.13.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "An HPACK (Header Compression for HTTP/2) implementation in OCaml"
description:
"hpack is an implementation of the HPACK: Header Compression for HTTP/2 specification (RFC7541) written in OCaml. It uses Angstrom and Faraday for parsing and serialization, respectively."
maintainer: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
authors: ["Antonio Nuno Monteiro <anmonteiro@gmail.com>"]
license: "BSD-3-clause"
homepage: "https://github.com/anmonteiro/ocaml-h2"
bug-reports: "https://github.com/anmonteiro/ocaml-h2/issues"
depends: [
"dune" {>= "2.7"}
"ocaml" {>= "4.08.0"}
"angstrom"
"faraday" {>= "0.7.3"}
"yojson" {with-test}
"hex" {with-test}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/anmonteiro/ocaml-h2.git"

22
unikernel/duniverse/ocaml-h2/hpack/original.LICENSE Normal file
View file

@ -0,0 +1,22 @@
This HPACK library is based on some initial work by Pieter Goetschalckx. The
original license is reproduced below.
Copyright (C) 2018 Pieter Goetschalckx
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.

217
unikernel/duniverse/ocaml-h2/hpack/src/decoder.ml Normal file
View file

@ -0,0 +1,217 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
open Types
open Angstrom
type t =
{ table : Dynamic_table.t
; max_capacity : int
}
let create max_capacity =
{ table = Dynamic_table.create max_capacity; max_capacity }
let set_capacity { table; max_capacity } capacity =
if capacity > max_capacity
then
(* From RFC7541§6.3:
* The new maximum size MUST be lower than or equal to the limit
* determined by the protocol using HPACK. A value that exceeds this
* limit MUST be treated as a decoding error. *)
Error Decoding_error
else (
Dynamic_table.set_capacity table capacity;
Ok ())
let decode_headers =
let decoding_error = return (Error Decoding_error) in
(* From RFC7541§5.1:
* decode I from the next N bits. *)
let decode_int prefix n =
let max_prefix = (1 lsl n) - 1 in
let i = prefix land max_prefix in
if i < max_prefix
then return i
else
let rec loop i m =
any_uint8 >>= fun b ->
let i = i + ((b land 127) lsl m) in
if b land 0b1000_0000 == 0b1000_0000 then loop i (m + 7) else return i
in
loop i 0
in
let get_indexed_field table index =
let static_table_size = Static_table.table_size in
let dynamic_table_size = Dynamic_table.table_size table in
(* From RFC7541§6.1:
* The index value of 0 is not used. It MUST be treated as a decoding
* error if found in an indexed header field representation. *)
if index == 0
|| (* From RFC7541§2.3.3:
* Indices strictly greater than the sum of the lengths of both
* tables MUST be treated as a decoding error. *)
index > static_table_size + dynamic_table_size
then Error Decoding_error
else if index <= static_table_size
then
(* From RFC7541§2.3.3:
* Indices between 1 and the length of the static table (inclusive) refer
* to elements in the static table (see Section 2.3.1). *)
Ok Static_table.table.(index - 1)
else
(* From RFC7541§2.3.3:
* Indices strictly greater than the length of the static table refer to
* elements in the dynamic table (see Section 2.3.2). The length of the
* static table is subtracted to find the index into the dynamic
* table. *)
Ok (Dynamic_table.get table (index - static_table_size - 1))
in
let decode_header_field =
let decode_string =
any_uint8 >>= fun h ->
(* From RFC7541§5.2:
* The number of octets used to encode the string literal, encoded as an
* integer with a 7-bit prefix (see Section 5.1). *)
decode_int h 7 >>= fun string_length ->
lift
(fun string_data ->
(* From RFC7541§5.2:
* A one-bit flag, H, indicating whether or not the octets of the
* string are Huffman encoded. *)
if h land 0b1000_0000 == 0
then Ok string_data
else Huffman.decode string_data)
(take string_length)
in
fun table prefix prefix_length ->
decode_int prefix prefix_length >>= fun index ->
lift2
(fun name value ->
match name, value with
| Ok name, Ok value -> Ok (name, value)
| Error e, _ | _, Error e -> Error e)
(* From RFC7541§6.2.1:
* If the header field name matches the header field name of an entry
* stored in the static table or the dynamic table, the header field
* name can be represented using the index of that entry. In this case,
* [...] This value is always non-zero.
*
* Otherwise, the header field name is represented as a string literal
* (see Section 5.2). A value 0 is used in place [...], followed by the
* header field name. *)
(if index == 0
then decode_string
else
match get_indexed_field table index with
| Ok (name, _) -> return (Ok name)
| Error _ as e -> return e)
decode_string
in
fun ({ table; _ } as t) ->
let rec loop acc saw_first_header =
at_end_of_input >>= fun is_eof ->
if is_eof
then return (Ok acc)
else
any_uint8 >>= fun b ->
if b land 0b1000_0000 != 0
then
(* From RFC7541§6.1: Indexed Header Field Representation
* An indexed header field starts with the '1' 1-bit pattern,
* followed by the index of the matching header field, represented as
* an integer with a 7-bit prefix (see Section 5.1). *)
decode_int b 7 >>= fun index ->
match get_indexed_field table index with
| Ok (name, value) ->
loop ({ name; value; sensitive = false } :: acc) true
| Error _ as e -> return e
else if b land 0b1100_0000 == 0b0100_0000
then
(* From RFC7541§6.2.1: Literal Header Field with Incremental Indexing
* A literal header field with incremental indexing representation
* starts with the '01' 2-bit pattern. In this case, the index of the
* entry is represented as an integer with a 6-bit prefix (see
* Section 5.1). *)
decode_header_field table b 6 >>= function
| Ok (name, value) ->
(* From RFC7541§6.2.1: Literal Header Field with Incremental Indexing
* A literal header field with incremental indexing representation
* results in appending a header field to the decoded header list
* and inserting it as a new entry into the dynamic table. *)
Dynamic_table.add table (name, value);
loop ({ name; value; sensitive = false } :: acc) true
| Error _ as e -> return e
else if b land 0b1111_0000 == 0
then
(* From RFC7541§6.2.2: Literal Header Field without Indexing
* A literal header field without indexing representation starts with
* the '0000' 4-bit pattern. In this case, the index of the entry is
* represented as an integer with a 4-bit prefix (see Section
* 5.1). *)
decode_header_field table b 4 >>= function
| Ok (name, value) ->
loop ({ name; value; sensitive = false } :: acc) true
| Error _ as e -> return e
else if b land 0b1111_0000 == 0b0001_0000
then
(* From RFC7541§6.2.3: Literal Header Field Never Indexed
* A literal header field without indexing representation starts with
* the '0001' 4-bit pattern.
* The encoding of the representation is identical to the literal
* header field without indexing (see Section 6.2.2). *)
decode_header_field table b 4 >>= function
| Ok (name, value) ->
loop ({ name; value; sensitive = true } :: acc) true
| Error _ as e -> return e
else if b land 0b1110_0000 == 0b0010_0000
then
if (* From RFC7541§6.3: Dynamic Table Size Update
* A dynamic table size update signals a change to the size of
* the dynamic table. A dynamic table size update starts with
* the '001' 3-bit pattern *)
saw_first_header
then
(* From RFC7541§4.2: Maximum Table Size
* A change in the maximum size of the dynamic table is signaled
* via a dynamic table size update (see Section 6.3). This dynamic
* table size update MUST occur at the beginning of the first
* header block following the change to the dynamic table size. *)
decoding_error
else
decode_int b 5 >>= fun capacity ->
match set_capacity t capacity with
| Ok () -> loop acc saw_first_header
| Error _ as e -> return e
else decoding_error
in
loop [] false

12
unikernel/duniverse/ocaml-h2/hpack/src/dune Normal file
View file

@ -0,0 +1,12 @@
(library
(public_name hpack)
(libraries angstrom faraday))
(rule
(targets huffman_table.ml)
(deps ../util/huffman_table.txt)
(action
(with-stdout-to
%{targets}
(run ../util/gen_huffman.exe %{deps})))
(mode fallback))

139
unikernel/duniverse/ocaml-h2/hpack/src/dynamic_table.ml Normal file
View file

@ -0,0 +1,139 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
type t =
{ mutable entries : (string * string * int) array
; mutable length : int
; mutable offset : int
; mutable capacity : int
(* `length` above is the number of entries in the dynamic table. We
* track the HPACK size in `size`.
*
* From RFC7541§4.1:
* The size of the dynamic table is the sum of the size of its
* entries.
*
* The size of an entry is the sum of its name's length in octets (as
* defined in Section 5.2), its value's length in octets, and 32. *)
; mutable size : int
(* From RFC7541§4.2:
* Protocols that use HPACK determine the maximum size that the
* encoder is permitted to use for the dynamic table. In HTTP/2, this
* value is determined by the SETTINGS_HEADER_TABLE_SIZE setting (see
* Section 6.5.2 of [HTTP2]). *)
; mutable max_size : int
; on_evict : string * string -> unit
}
(* From RFC7541§4.1:
* The size of an entry is the sum of its name's length in octets (as defined
* in Section 5.2), its value's length in octets, and 32. *)
let default_entry = "", "", 32
let default_evict = Sys.opaque_identity (fun _ -> ())
let create ?(on_evict = default_evict) max_size =
let capacity = max 256 max_size in
{ entries = Array.make capacity default_entry
; length = 0
; offset = 0
; capacity
; size = 0
; max_size
; on_evict
}
let[@inline] _get table i =
table.entries.((table.offset + i) mod table.capacity)
let[@inline] get table i =
let name, value, _ = _get table i in
name, value
let[@inline] entry_size name value =
(* From RFC7541§4.1:
* The size of an entry is the sum of its name's length in octets (as
* defined in Section 5.2), its value's length in octets, and 32. *)
String.length name + String.length value + 32
(* Note: Assumes table.size is positive. Doesn't perform any checking. *)
let evict_one ({ capacity; entries; on_evict; _ } as table) =
table.length <- table.length - 1;
let i = (table.offset + table.length) mod capacity in
let name, value, entry_size = entries.(i) in
entries.(i) <- default_entry;
table.size <- table.size - entry_size;
(* Don't bother calling if the eviction callback is not meaningful. *)
if on_evict != default_evict then on_evict (name, value)
let increase_capacity table =
let new_capacity = 2 * table.capacity in
let new_entries =
Array.init new_capacity (fun i ->
if i < table.length then _get table i else default_entry)
in
table.entries <- new_entries;
table.offset <- 0;
table.capacity <- new_capacity
let add ({ max_size; _ } as table) (name, value) =
let entry_size = entry_size name value in
(* From RFC7541§4.4:
* Before a new entry is added to the dynamic table, entries are evicted
* from the end of the dynamic table until the size of the dynamic table is
* less than or equal to (maximum size - new entry size) or until the table
* is empty. *)
while table.size > 0 && table.size + entry_size > max_size do
evict_one table
done;
(* From RFC7541§4.4:
* If the size of the new entry is less than or equal to the maximum size,
* that entry is added to the table. *)
if table.size + entry_size <= max_size
then (
if table.length = table.capacity then increase_capacity table;
table.length <- table.length + 1;
table.size <- table.size + entry_size;
let new_offset = (table.offset + table.capacity - 1) mod table.capacity in
table.entries.(new_offset) <- name, value, entry_size;
table.offset <- new_offset)
let[@inline] table_size table = table.length
let set_capacity table max_size =
table.max_size <- max_size;
(* From RFC7541§4.3:
* Whenever the maximum size for the dynamic table is reduced, entries are
* evicted from the end of the dynamic table until the size of the dynamic
* table is less than or equal to the maximum size. *)
while table.size > max_size do
evict_one table
done

340
unikernel/duniverse/ocaml-h2/hpack/src/encoder.ml Normal file
View file

@ -0,0 +1,340 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
open Types
module HeaderFieldsTbl = Hashtbl.Make (struct
type t = string
let equal = String.equal
let hash s = Hashtbl.hash s
end)
module ValueMap = Map.Make (String)
type t =
{ table : Dynamic_table.t
(* We maintain a lookup table of header fields to their indexes in the
* dynamic table. The format is name -> (value -> index) *)
; lookup_table : int ValueMap.t HeaderFieldsTbl.t
; mutable next_seq : int
}
module BinaryFormat = struct
(* From RFC7541§6.2.3. Literal Header Field Never Indexed
* A literal header field never-indexed representation starts with the
* '0001' 4-bit pattern. *)
let never_indexed = 0b0001_0000, 4
(* From RFC7541§6.2.2: Literal Header Field without Indexing
* A literal header field without indexing representation starts with the
* '0000' 4-bit pattern. *)
let without_indexing = 0b0000_0000, 4
(* From RFC7541§6.2.1: Literal Header Field with Incremental Indexing
* A literal header field with incremental indexing representation starts
* with the '01' 2-bit pattern. *)
let incremental_indexing = 0b0100_0000, 6
(* From RFC7541§6.1: Indexed Header Field Representation
* An indexed header field starts with the '1' 1-bit pattern, followed by
* the index of the matching header field, represented as an integer with
* a 7-bit prefix (see Section 5.1). *)
let indexed = 0b1000_0000, 7
let[@inline] is_indexed = function 128 -> true | _ -> false
end
let create =
let on_evict lookup_table (name, value) =
let map = HeaderFieldsTbl.find lookup_table name in
if ValueMap.cardinal map = 1
then HeaderFieldsTbl.remove lookup_table name
else
let map = ValueMap.remove value map in
HeaderFieldsTbl.replace lookup_table name map
in
fun capacity ->
let lookup_table = HeaderFieldsTbl.create capacity in
{ table = Dynamic_table.create ~on_evict:(on_evict lookup_table) capacity
; lookup_table
; next_seq = 0
}
let add ({ table; lookup_table; next_seq } as encoder) entry =
let name, value = entry in
Dynamic_table.add table entry;
let map =
match HeaderFieldsTbl.find_opt lookup_table name with
| Some map -> ValueMap.add value next_seq map
| None -> ValueMap.singleton value next_seq
in
encoder.next_seq <- next_seq + 1;
HeaderFieldsTbl.replace lookup_table name map
let encode =
let find_token =
let encode_missing_value encoder without_indexing token name value =
(* This is a header field whose value we didn't find in the static
* table after looping. We ended up here (name <> name') because we
* looped to check whether the value was indexed in the static table.
* We can still use the token index to encode the header name. *)
let index = token + 1 in
if without_indexing
then
(* From RFC7541§6.2.2: Literal Header Field without Indexing
* If the header field name matches the header field name of an entry
* stored in the static table or the dynamic table, the header field
* name can be represented using the index of that entry. *)
BinaryFormat.without_indexing, index
else (
(* From RFC7541§6.2.1: Literal Header Field with Incremental Indexing
* A literal header field with incremental indexing representation
* results in appending a header field to the decoded header list and
* inserting it as a new entry into the dynamic table. *)
add encoder (name, value);
BinaryFormat.incremental_indexing, index)
in
fun encoder without_indexing token name value ->
let rec loop i =
if i >= Static_table.table_size
then encode_missing_value encoder without_indexing token name value
else
let name', value' = Static_table.table.(i) in
if name = name'
then
if value' = value
then
(* From RFC7541§6.1: Indexed Header Field Representation
* An indexed header field starts with the '1' 1-bit pattern,
* followed by the index of the matching header field. *)
BinaryFormat.indexed, i + 1
else
(* Advance one token in the static table, as the next entry might have
* a value that can fall into the above branch. We're guaranteed to
* always get the first token (index) in the static table for `name`,
* because that's what `Static_table.lookup_token` returns. *)
loop (i + 1)
else encode_missing_value encoder without_indexing token name value
in
loop token
in
let[@inline] seq_to_index next_seq seq =
Static_table.table_size + next_seq - seq
in
let is_without_indexing =
let module IntSet = Set.Make (Int) in
let tokens_without_indexing =
(* From RFC7541§6.2.2: Never-Indexed Literals
* Either form of header field name representation is followed by the
* header field value represented as a string literal (see Section 5.2).
*
* Note: we choose not to index the values of these fields as they would
* vary immensely. This way, we save some additions / evictions from the
* dynamic table. *)
IntSet.of_list
Static_table.TokenIndices.
[ path
; age
; content_length
; etag
; if_modified_since
; if_none_match
; location
; set_cookie
]
in
fun [@inline] token ->
token <> -1 && IntSet.mem token tokens_without_indexing
in
let[@inline] is_sensitive token value =
token <> -1
&& (* From RFC7541§7.1.3: Never-Indexed Literals
* An encoder might also choose not to index values for header fields
* that are considered to be highly valuable or sensitive to recovery,
* such as the Cookie or Authorization header fields. *)
Static_table.TokenIndices.(
token == authorization || (token == cookie && String.length value < 20))
in
fun ({ lookup_table; next_seq; _ } as encoder) { name; value; sensitive } ->
let token = Static_table.lookup_token_index name in
let token_found_in_static_table = token <> -1 in
if sensitive || is_sensitive token value
then
(* never indexed literal header field, find the index *)
let index =
if token_found_in_static_table
then
(* From RFC7541§6.2.2: Literal Header Field without Indexing
* If the header field name matches the header field name of an entry
* stored in the static table or the dynamic table, the header field
* name can be represented using the index of that entry. *)
token + 1
else
match HeaderFieldsTbl.find_opt lookup_table name with
| Some map ->
let _, any_entry = ValueMap.choose map in
seq_to_index next_seq any_entry
| None ->
(* From RFC7541§6.2.2: Literal Header Field without Indexing
* Otherwise, the header field name is represented as a string
* literal (see Section 5.2). A value 0 is used in place of the
* 4-bit index, followed by the header field name. *)
0
in
BinaryFormat.never_indexed, index
else if token_found_in_static_table
then
(* Header name is represented in the static table. *)
match HeaderFieldsTbl.find_opt lookup_table name with
| Some map ->
(* Header value is indexed in the dynamic table. *)
(match ValueMap.find_opt value map with
| Some seq ->
(* From RFC7541§6.1: Indexed Header Field Representation
* An indexed header field representation identifies an entry in
* either the static table or the dynamic table (see Section 2.3). *)
BinaryFormat.indexed, seq_to_index next_seq seq
| None ->
(* Header value is not indexed in the dynamic table. Check if it's an
* entry in the static table or if we need to encode its value, (and
* potentially name if the field is requested to be encoded without
* indexing). *)
let without_indexing = is_without_indexing token in
find_token encoder without_indexing token name value)
| None ->
let without_indexing = is_without_indexing token in
find_token encoder without_indexing token name value
else
match HeaderFieldsTbl.find_opt lookup_table name with
| Some map ->
(match ValueMap.find_opt value map with
| Some seq -> BinaryFormat.indexed, seq_to_index next_seq seq
| None ->
let index = seq_to_index next_seq (snd (ValueMap.choose map)) in
if is_without_indexing token
then BinaryFormat.without_indexing, index
else (
(* From RFC7541§6.2.1
* A literal header field with incremental indexing representation
* results in appending a header field to the decoded header list
* and inserting it as a new entry into the dynamic table. *)
add encoder (name, value);
BinaryFormat.incremental_indexing, index))
| None ->
if is_without_indexing token
then BinaryFormat.without_indexing, 0
else (
(* From RFC7541§6.2.1
* A literal header field with incremental indexing representation
* results in appending a header field to the decoded header list and
* inserting it as a new entry into the dynamic table. *)
add encoder (name, value);
BinaryFormat.incremental_indexing, 0)
let encode_int t prefix n i =
let max_prefix = (1 lsl n) - 1 in
if i < max_prefix
then
(* From RFC7541§5.1:
* If the integer value is small enough, i.e., strictly less than 2^N-1,
* it is encoded within the N-bit prefix. *)
Faraday.write_uint8 t (prefix lor i)
else
(* From RFC7541§5.1:
* Otherwise, all the bits of the prefix are set to 1, and the value,
* decreased by 2^N-1, is encoded using a list of one or more octets. The
* most significant bit of each octet is used as a continuation flag: its
* value is set to 1 except for the last octet in the list. The remaining
* bits of the octets are used to encode the decreased value. *)
let i = i - max_prefix in
Faraday.write_uint8 t (prefix lor max_prefix);
let rec loop i =
if i >= 128
then (
Faraday.write_uint8 t (i land 127 lor 128);
loop (i lsr 7))
else Faraday.write_uint8 t i
in
loop i
let encode_header =
let encode_string t s =
let string_length = String.length s in
let huffman_length = Huffman.encoded_length s in
if huffman_length > string_length
then (
(* From RFC7541§5.2:
* The number of octets used to encode the string literal, encoded as an
* integer with a 7-bit prefix (see Section 5.1). *)
encode_int t 0 7 string_length;
(* From RFC7541§5.2:
* The encoded data of the string literal. If H is '0', then the encoded
* data is the raw octets of the string literal. If H is '1', then the
* encoded data is the Huffman encoding of the string literal. *)
Faraday.write_string t s)
else (
(* From RFC7541§5.2:
* The number of octets used to encode the string literal, encoded as an
* integer with a 7-bit prefix (see Section 5.1). *)
encode_int t 128 7 huffman_length;
(* From RFC7541§5.2:
* The encoded data of the string literal. If H is '0', then the encoded
* data is the raw octets of the string literal. If H is '1', then the
* encoded data is the Huffman encoding of the string literal. *)
Huffman.encode t s)
in
fun encoder t ({ name; value; _ } as header) ->
let (prefix, prefix_length), index = encode encoder header in
encode_int t prefix prefix_length index;
match BinaryFormat.is_indexed prefix with
| true -> ()
| false ->
if index == 0
then
(* From RFC7541§6.2.2: Literal Header Field without Indexing * If the
header field name matches the header field name of an entry * stored
in the static table or the dynamic table, the header field * name can
be represented using the index of that entry. In this case, * the
index of the entry is represented as an integer with a 4-bit * prefix
(see Section 5.1). This value is always non-zero. * * Otherwise, the
header field name is represented as a string literal * (see Section
5.2). A value 0 is used in place of the 4-bit index, * followed by
the header field name. *)
encode_string t name;
(* From RFC7541§6.2.2: Literal Header Field without Indexing
* Either form of header field name representation is followed by the
* header field value represented as a string literal (see
* Section 5.2). *)
encode_string t value
let set_capacity { table; _ } new_capacity =
Dynamic_table.set_capacity table new_capacity

35
unikernel/duniverse/ocaml-h2/hpack/src/hpack.ml Normal file
View file

@ -0,0 +1,35 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
include Types
module Encoder = Encoder
module Decoder = Decoder

93
unikernel/duniverse/ocaml-h2/hpack/src/hpack.mli Normal file
View file

@ -0,0 +1,93 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
type header =
{ name : string
; value : string
(* From RFC7541§7.1.3:
* Implementations can also choose to protect sensitive header fields
* by not compressing them and instead encoding their value as
* literals. *)
; sensitive : bool
}
type error = Decoding_error
module Encoder : sig
type t
val create : int -> t
(** [create capacity] initializes an encoder with a dynamic table with maximum
size [capacity]. This size is an approximation of the memory overhead in
bytes.
See {{:https://tools.ietf.org/html/rfc7541#section-4.1} RFC7541§4.1} for
more details. *)
val encode_header : t -> Faraday.t -> header -> unit
(** [encode_header encoder f header] writes an encoded header to the Faraday
buffer [f]. *)
val set_capacity : t -> int -> unit
(** [set_capacity encoder capacity] sets [encoder]'s dynamic table size to
maximum size [capacity]. This size is an approximation of the memory
overhead in bytes.
See {{:https://tools.ietf.org/html/rfc7540#section-6.5.2} RFC7540§6.5.2}
and {{:https://tools.ietf.org/html/rfc7541#section-4.1} RFC7541§4.1} for
more details. *)
end
module Decoder : sig
type t
val create : int -> t
(** [create capacity] initializes a decoder with a dynamic table with maximum
size [capacity]. This size is an approximation of the memory usage in
bytes.
See {{:https://tools.ietf.org/html/rfc7541#section-4.1} RFC7541§4.1} for
more details. *)
val set_capacity : t -> int -> (unit, error) result
(** [set_capacity decoder capacity] sets [decoder]'s dynamic table size to
maximum size [capacity]. This size is an approximation of the memory
overhead in bytes.
See {{:https://tools.ietf.org/html/rfc7540#section-6.5.2} RFC7540§6.5.2}
and {{:https://tools.ietf.org/html/rfc7541#section-4.1} RFC7541§4.1} for
more details. *)
val decode_headers : t -> (header list, error) result Angstrom.t
(** [decode_headers decoder] creates an Angstrom parser that will decode a
header block and return a list of the decoded headers *)
end

100
unikernel/duniverse/ocaml-h2/hpack/src/huffman.ml Normal file
View file

@ -0,0 +1,100 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
open Types
let encoded_length s =
let len = String.length s in
let rec loop bits i =
if i < len
then
let input = Char.code s.[i] in
let _, len_in_bits = Huffman_table.encode_table.(input) in
loop (bits + len_in_bits) (i + 1)
else
(* From RFC7541§5.2:
* As the Huffman-encoded data doesn't always end at an octet boundary,
* some padding is inserted after it, up to the next octet boundary. *)
(bits + 7) / 8
in
loop 0 0
let encode t s =
let bits = ref 0 in
let bits_left = ref 40 in
for i = 0 to String.length s - 1 do
let code, code_len = Huffman_table.encode_table.(Char.code s.[i]) in
bits_left := !bits_left - code_len;
bits := !bits lor (code lsl !bits_left);
while !bits_left <= 32 do
Faraday.write_uint8 t (!bits lsr 32);
bits := !bits lsl 8;
bits_left := !bits_left + 8
done
done;
if !bits_left < 40
then (
bits := !bits lor ((1 lsl !bits_left) - 1);
(* add EOS and padding *)
Faraday.write_uint8 t (!bits lsr 32))
let decode =
let[@inline] add_output buffer c =
if c <> '\000' then Buffer.add_char buffer c
in
let[@inline] exists_in_huffman_table token = token <> -1 in
fun s ->
let len = String.length s in
let buffer = Buffer.create len in
let rec loop id accept i =
if i < len
then (
let input = Char.code s.[i] in
let index = (id lsl 4) + (input lsr 4) in
let id, _, output = Huffman_table.decode_table.(index) in
add_output buffer output;
if exists_in_huffman_table id
then (
let index = (id lsl 4) + (input land 0x0f) in
let id, accept, output = Huffman_table.decode_table.(index) in
add_output buffer output;
if exists_in_huffman_table id
then loop id accept (i + 1)
else Error Decoding_error)
else Error Decoding_error)
else if not accept
then Error Decoding_error
else Ok ()
in
match loop 0 true 0 with
| Ok _ -> Ok (Buffer.contents buffer)
| Error e -> Error e

1847
unikernel/duniverse/ocaml-h2/hpack/src/huffman_table.ml Normal file
View file

File diff suppressed because it is too large Load diff

264
unikernel/duniverse/ocaml-h2/hpack/src/static_table.ml Normal file
View file

@ -0,0 +1,264 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
(* (partially) generated by util/gen_static.ml *)
module TokenIndices = struct
let authority = 0
let _method = 1
let path = 3
let scheme = 5
let status = 7
let accept_charset = 14
let accept_encoding = 15
let accept_language = 16
let accept_ranges = 17
let accept = 18
let access_control_allow_origin = 19
let age = 20
let allow = 21
let authorization = 22
let cache_control = 23
let content_disposition = 24
let content_encoding = 25
let content_language = 26
let content_length = 27
let content_location = 28
let content_range = 29
let content_type = 30
let cookie = 31
let date = 32
let etag = 33
let expect = 34
let expires = 35
let from = 36
let host = 37
let if_match = 38
let if_modified_since = 39
let if_none_match = 40
let if_range = 41
let if_unmodified_since = 42
let last_modified = 43
let link = 44
let location = 45
let max_forwards = 46
let proxy_authenticate = 47
let proxy_authorization = 48
let range = 49
let referer = 50
let refresh = 51
let retry_after = 52
let server = 53
let set_cookie = 54
let strict_transport_security = 55
let transfer_encoding = 56
let user_agent = 57
let vary = 58
let via = 59
let www_authenticate = 60
end
let table_size = 61
let table =
[| ":authority", ""
; ":method", "GET"
; ":method", "POST"
; ":path", "/"
; ":path", "/index.html"
; ":scheme", "http"
; ":scheme", "https"
; ":status", "200"
; ":status", "204"
; ":status", "206"
; ":status", "304"
; ":status", "400"
; ":status", "404"
; ":status", "500"
; "accept-charset", ""
; "accept-encoding", "gzip, deflate"
; "accept-language", ""
; "accept-ranges", ""
; "accept", ""
; "access-control-allow-origin", ""
; "age", ""
; "allow", ""
; "authorization", ""
; "cache-control", ""
; "content-disposition", ""
; "content-encoding", ""
; "content-language", ""
; "content-length", ""
; "content-location", ""
; "content-range", ""
; "content-type", ""
; "cookie", ""
; "date", ""
; "etag", ""
; "expect", ""
; "expires", ""
; "from", ""
; "host", ""
; "if-match", ""
; "if-modified-since", ""
; "if-none-match", ""
; "if-range", ""
; "if-unmodified-since", ""
; "last-modified", ""
; "link", ""
; "location", ""
; "max-forwards", ""
; "proxy-authenticate", ""
; "proxy-authorization", ""
; "range", ""
; "referer", ""
; "refresh", ""
; "retry-after", ""
; "server", ""
; "set-cookie", ""
; "strict-transport-security", ""
; "transfer-encoding", ""
; "user-agent", ""
; "vary", ""
; "via", ""
; "www-authenticate", ""
|]
let lookup_token_index name =
match String.length name with
| 3 ->
(match String.unsafe_get name 0 with
| 'a' when name = "age" -> 20
| 'v' when name = "via" -> 59
| _ -> -1)
| 4 ->
(match String.unsafe_get name 0 with
| 'd' when name = "date" -> 32
| 'e' when name = "etag" -> 33
| 'f' when name = "from" -> 36
| 'h' when name = "host" -> 37
| 'l' when name = "link" -> 44
| 'v' when name = "vary" -> 58
| _ -> -1)
| 5 ->
(match String.unsafe_get name 0 with
| ':' when name = ":path" -> 3
| 'a' when name = "allow" -> 21
| 'r' when name = "range" -> 49
| _ -> -1)
| 6 ->
(match String.unsafe_get name 0 with
| 'a' when name = "accept" -> 18
| 'c' when name = "cookie" -> 31
| 'e' when name = "expect" -> 34
| 's' when name = "server" -> 53
| _ -> -1)
| 7 ->
(match name.[3] with
| 't' when name = ":method" -> 1
| 'h' when name = ":scheme" -> 5
| 'a' when name = ":status" -> 7
| 'i' when name = "expires" -> 35
| 'e' when name = "referer" -> 50
| 'r' when name = "refresh" -> 51
| _ -> -1)
| 8 ->
(match name.[3] with
| 'm' when name = "if-match" -> 38
| 'r' when name = "if-range" -> 41
| 'a' when name = "location" -> 45
| _ -> -1)
| 10 ->
(match String.unsafe_get name 0 with
| ':' when name = ":authority" -> 0
| 's' when name = "set-cookie" -> 54
| 'u' when name = "user-agent" -> 57
| _ -> -1)
| 11 ->
(match String.unsafe_get name 0 with
| 'r' when name = "retry-after" -> 52
| _ -> -1)
| 12 ->
(match String.unsafe_get name 0 with
| 'c' when name = "content-type" -> 30
| 'm' when name = "max-forwards" -> 46
| _ -> -1)
| 13 ->
(match name.[6] with
| '-' when name = "accept-ranges" -> 17
| 'i' when name = "authorization" -> 22
| 'c' when name = "cache-control" -> 23
| 't' when name = "content-range" -> 29
| 'e' when name = "if-none-match" -> 40
| 'o' when name = "last-modified" -> 43
| _ -> -1)
| 14 ->
(match String.unsafe_get name 0 with
| 'a' when name = "accept-charset" -> 14
| 'c' when name = "content-length" -> 27
| _ -> -1)
| 15 ->
(match name.[7] with
| 'e' when name = "accept-encoding" -> 15
| 'l' when name = "accept-language" -> 16
| _ -> -1)
| 16 ->
(match name.[11] with
| 'o' when name = "content-encoding" -> 25
| 'g' when name = "content-language" -> 26
| 'a' when name = "content-location" -> 28
| 'i' when name = "www-authenticate" -> 60
| _ -> -1)
| 17 ->
(match String.unsafe_get name 0 with
| 'i' when name = "if-modified-since" -> 39
| 't' when name = "transfer-encoding" -> 56
| _ -> -1)
| 18 ->
(match String.unsafe_get name 0 with
| 'p' when name = "proxy-authenticate" -> 47
| _ -> -1)
| 19 ->
(match String.unsafe_get name 0 with
| 'c' when name = "content-disposition" -> 24
| 'i' when name = "if-unmodified-since" -> 42
| 'p' when name = "proxy-authorization" -> 48
| _ -> -1)
| 25 ->
(match String.unsafe_get name 0 with
| 's' when name = "strict-transport-security" -> 55
| _ -> -1)
| 27 ->
(match String.unsafe_get name 0 with
| 'a' when name = "access-control-allow-origin" -> 19
| _ -> -1)
| _ -> -1

39
unikernel/duniverse/ocaml-h2/hpack/src/types.ml Normal file
View file

@ -0,0 +1,39 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
type header =
{ name : string
; value : string
; sensitive : bool
}
type error = Decoding_error

13
unikernel/duniverse/ocaml-h2/hpack/test/dune Normal file
View file

@ -0,0 +1,13 @@
(executable
(name test)
(libraries hpack yojson hex alcotest))
(include_subdirs unqualified)
(rule
(alias slowtests)
(deps
(:test_exe test.exe)
(source_tree "hpack-test-case/"))
(action
(run %{test_exe})))

347
unikernel/duniverse/ocaml-h2/hpack/test/test.ml Normal file
View file

@ -0,0 +1,347 @@
open Hpack
module Json = Yojson.Basic.Util
let parse_file file =
let json = Yojson.Basic.from_file file in
let description =
match Json.(json |> member "description" |> to_string_option) with
| Some x -> x
| None -> file
in
let cases =
List.map
(fun case ->
let header_table_size =
match Json.(case |> member "header_table_size" |> to_int_option) with
| Some size -> size
| None -> 4096
in
let wire =
match Json.(case |> member "wire" |> to_string_option) with
| Some hex -> Hex.to_string (`Hex hex)
| None -> ""
in
let headers =
List.map
(function
| `Assoc [ (name, `String value) ] ->
{ Hpack.name; value; sensitive = false }
| _ -> assert false)
Json.(case |> member "headers" |> to_list)
in
header_table_size, wire, headers)
Json.(json |> member "cases" |> to_list)
in
description, cases
let h x = Hex.to_string (`Hex x)
let hex_of_string s = s |> Hex.of_string |> Hex.show
let encode_headers encoder headers =
let faraday = Faraday.create 0x1000 in
List.iter (Encoder.encode_header encoder faraday) headers;
Faraday.serialize_to_string faraday
let encode cases =
let encoder = Hpack.Encoder.create 4096 in
List.mapi
(fun seq (_nosize, _nowire, headers) ->
let wire = encode_headers encoder headers in
seq, hex_of_string wire, headers)
cases
let encode_file fixtures_dir (story, file) =
let _, cases = parse_file file in
let result = encode cases in
let json =
`Assoc
[ "description", `String "Encoded by h2's HPACK implementation"
; ( "cases"
, `List
(result
|> List.map @@ fun (seq, wire, headers) ->
`Assoc
[ "seqno", `Int seq
; "wire", `String wire
; ( "headers"
, `List
(headers
|> List.map @@ fun { name; value; _ } ->
`Assoc [ name, `String value ]) )
]) )
]
in
let channel =
open_out Filename.(concat fixtures_dir (concat "ocaml-hpack" story))
in
Yojson.pretty_to_channel channel json;
close_out channel
let encode_raw_data fixtures_dir files =
List.iter (encode_file fixtures_dir) files
let header_equal { name; value; _ } { name = name'; value = value'; _ } =
name = name' && value = value'
let header_testable =
(module struct
type t = header
let pp formatter { name; value; _ } = Fmt.pf formatter "%s: %s" name value
let _pp_with_index formatter { name; value; sensitive } =
Fmt.pf formatter "%s: %s (%B)" name value sensitive
let equal h1 h2 = header_equal h1 h2
end : Alcotest.TESTABLE
with type t = header)
let headers_list_pp =
let (module Headers) = header_testable in
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.pp_print_string fmt ";\n")
Headers.pp
let decode_headers decoder size wire =
let parser = Angstrom.Buffered.parse (Decoder.decode_headers decoder) in
match Decoder.set_capacity decoder size with
| Error _ -> assert false
| Ok () ->
let state = Angstrom.Buffered.feed parser (`String wire) in
let state' = Angstrom.Buffered.feed state `Eof in
(match Angstrom.Buffered.state_to_option state' with
| Some (Ok headers) -> List.rev headers
| Some _ | None -> assert false)
let decode cases =
let encoder = Encoder.create 4096 in
(* Note: Encoders and decoders are stateful. To check rountripping we need to
use 2 decoders. Here's why: We initially decode the headers we parsed from
JSON and assert that they're the same as the JSON we got.
We then want to: 1. Encode the resulting headers 2. Decode them again 3.
Check they are indeed the same
The reason why we need 2 decoders is because of `1.` above. Since
compression / decompression state is stateful, and we don't have access to
the first encoder (which may have state about indexed fields that
`decoder1` has computed in the meantime), using `decoder1` would produce
wrong headers (given wrong expectations about indexed header fields).
From then on, we can feel free to use the `encoder` / `decoder2` pair, as
that effectively mimics the same "connection". In fact, encoding and
decoding the same headers multiple times will make the compressed payload
smaller. We check that too. *)
let decoder1 = Decoder.create 65536 in
let decoder2 = Decoder.create 65536 in
List.iter
(fun (size, wire, headers) ->
Encoder.set_capacity encoder size;
let decoded_headers = decode_headers decoder1 size wire in
Alcotest.(check int)
"same length"
(List.length headers)
(List.length decoded_headers);
List.iter2
(fun h1 h2 ->
Alcotest.(
check header_testable "Headers are decoded correctly" h1 h2))
headers
decoded_headers;
(* roundtripping *)
let encoded = encode_headers encoder decoded_headers in
let decoded_headers' = decode_headers decoder2 size encoded in
Alcotest.(check int)
"same length"
(List.length headers)
(List.length decoded_headers);
List.iter2
(fun h1 h2 ->
Alcotest.(
check header_testable "Headers are decoded correctly" h1 h2))
decoded_headers'
decoded_headers;
(* Now check that the `encoded_again` payload is smaller than the `encoded`
* payload. Indexing has happened! *)
let enc', dec' =
Array.fold_left
(fun (_, decoded_headers) _ ->
let encoded_again = encode_headers encoder decoded_headers in
let decoded_again = decode_headers decoder2 size encoded_again in
encoded_again, decoded_again)
("", decoded_headers')
(Array.make 5 0)
in
Alcotest.(check bool)
"encoded_again payload is smaller or equal than encoded"
true
(String.length enc' <= String.length encoded);
(* And check roundtripping again for good measure. *)
List.iter2
(fun h1 h2 ->
Alcotest.(
check header_testable "Headers are decoded correctly" h1 h2))
dec'
headers)
cases
let rec take_n acc i ys =
match i, ys with
| 0, _ -> acc
| _, [] -> acc
| _, x :: xs when i > 0 -> take_n (x :: acc) (i - 1) xs
| _ -> acc
let gen_suites fixtures =
let gen_suite filename =
let test_case_name, fixture = parse_file filename in
test_case_name, `Slow, fun () -> decode fixture
in
List.map
(fun (suite_name, files) ->
let suite = List.map gen_suite files in
suite_name, suite)
fixtures
let files_in_dir dir = dir |> Sys.readdir |> Array.to_list
let read_fixtures fixtures_dir =
fixtures_dir
|> files_in_dir
|> List.map (fun dir -> dir, Filename.concat fixtures_dir dir)
(* don't need to decode raw-data, it's already in ocaml-hpack. *)
|> List.filter (fun (dir, fullpath) ->
Sys.is_directory fullpath && dir <> "raw-data")
|> List.map (fun (dir, fullpath) ->
let files_in_dir =
fullpath
|> files_in_dir
|> List.map (fun file -> Filename.concat fullpath file)
|> List.filter (fun file ->
(not (Sys.is_directory file)) && Filename.extension file = ".json")
in
dir, files_in_dir)
let test_evicting_table_size_0 () =
let hs =
[ { name = ":method"; value = "GET"; sensitive = false }
; { name = "field_not_indexed"; value = "foo"; sensitive = false }
]
in
let encoder = Encoder.create 0 in
let encoded_headers = encode_headers encoder hs in
Alcotest.(check bool)
"Encodes to non-zero hex"
true
(String.length encoded_headers > 0);
(* From RFC7541§6.3: Dynamic Table Size Update
* A dynamic table size update signals a change to the size of the dynamic
* table.
* A dynamic table size update starts with the '001' 3-bit pattern
*
* Note: we add 0x20 at the beginning of the following wire to signal a
* dynamic table size update of 0 before the remaining headers are
* decoded. *)
let wire = h ("20" ^ hex_of_string encoded_headers) in
let decoder = Decoder.create 4096 in
let decoded_headers = decode_headers decoder 4096 wire in
List.iter2
(fun h1 h2 ->
Alcotest.(check header_testable "Decoded headers are roundtripped" h1 h2))
hs
decoded_headers
let test_evicting_table_size_0_followup () =
let hs =
[ { name = ":method"; value = "GET"; sensitive = false }
; { name = "field_not_indexed"; value = "foo"; sensitive = false }
; { name = "yet_another_field_not_indexed"
; value = "baz"
; sensitive = false
}
]
in
let encoder = Encoder.create 60 in
let encoded_headers = encode_headers encoder hs in
Alcotest.(check bool)
"Encodes to non-zero hex"
true
(String.length encoded_headers > 0);
let decoder = Decoder.create 60 in
let decoded_headers = decode_headers decoder 60 encoded_headers in
List.iter2
(fun h1 h2 ->
Alcotest.(check header_testable "Decoded headers are roundtripped" h1 h2))
hs
decoded_headers
let test_end_of_table () =
let hs =
[ { name = ":method"; value = "GET"; sensitive = false }
; { name = "www-authenticate"; value = "Basic"; sensitive = false }
]
in
let encoder = Encoder.create 60 in
let encoded_headers = encode_headers encoder hs in
Alcotest.(check bool)
"Encodes to non-zero hex"
true
(String.length encoded_headers > 0);
let decoder = Decoder.create 60 in
let decoded_headers = decode_headers decoder 60 encoded_headers in
List.iter2
(fun h1 h2 ->
Alcotest.(check header_testable "Decoded headers are roundtripped" h1 h2))
hs
decoded_headers
let test_encode_newline () =
let hs =
[ { name = "authorization"; value = "helloworld\na"; sensitive = true } ]
in
let encoder = Encoder.create 4096 in
let encoded_headers = encode_headers encoder hs in
Alcotest.(check bool)
"Encodes to non-zero hex"
true
(String.length encoded_headers > 0);
let decoder = Decoder.create 4096 in
let decoded_headers = decode_headers decoder 4096 encoded_headers in
List.iter2
(fun h1 h2 ->
Alcotest.(check header_testable "Decoded headers are roundtripped" h1 h2))
hs
decoded_headers
let () =
let fixtures_dir = "hpack-test-case" in
let raw_data_dir = Filename.concat fixtures_dir "raw-data" in
let raw_data =
raw_data_dir
|> files_in_dir
|> List.map (fun file -> file, Filename.concat raw_data_dir file)
|> List.sort (fun (file, _) (file2, _) -> compare file file2)
in
(try Unix.mkdir (Filename.concat fixtures_dir "ocaml-hpack") 0o755 with
| Unix.Unix_error (Unix.EEXIST, _, _) -> ());
encode_raw_data fixtures_dir raw_data;
(* Now, test decoding what we just encoded + roundtripping *)
let fixtures = read_fixtures fixtures_dir in
let suites = gen_suites fixtures in
Alcotest.run
"HPACK"
(( "Handcrafted HPACK tests"
, [ ( "Evictions from the dynamic table with 0 capacity"
, `Quick
, test_evicting_table_size_0 )
; ( "Evictions from the dynamic table with 0 capacity (followup test)"
, `Quick
, test_evicting_table_size_0_followup )
; ( "Encoding the header from the end of the static table"
, `Quick
, test_end_of_table )
; ( "Encode huffman chars with bit length > 24"
, `Quick
, test_encode_newline )
] )
:: suites)

11
unikernel/duniverse/ocaml-h2/hpack/util/dune Normal file
View file

@ -0,0 +1,11 @@
(executable
(name gen_huffman)
(modules gen_huffman)
(libraries compiler-libs.common))
(executable
(name gen_static)
(libraries compiler-libs.common)
(modules gen_static)
(enabled_if
(< %{ocaml_version} 5.2)))

194
unikernel/duniverse/ocaml-h2/hpack/util/gen_huffman.ml Normal file
View file

@ -0,0 +1,194 @@
(*----------------------------------------------------------------------------
Copyright (c) 2019 António Nuno Monteiro
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
3. Neither the name of the copyright holder nor the names of its contributors
may be used to endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
----------------------------------------------------------------------------*)
open Parsetree
open Ast_helper
open Asttypes
let let_ name body =
Str.value
Nonrecursive
[ Vb.mk (Pat.var { txt = name; loc = !default_loc }) body ]
type node =
{ mutable id : int
; mutable accept : bool
; left : child
; right : child
; transitions : (int option * bool * char option) array
}
and child =
| Node of node
| Symbol of char
| Missing
let make_node ?(left = Missing) ?(right = Missing) () =
{ id = 0
; accept = false
; left
; right
; transitions = Array.make 16 (None, false, None)
}
let rec add_symbol tree symbol = function
| [] -> Symbol symbol
| false :: bits ->
(match tree with
| Missing -> Node (make_node ~left:(add_symbol tree symbol bits) ())
| Node node -> Node { node with left = add_symbol node.left symbol bits }
| Symbol _ -> failwith "add_symbol")
| true :: bits ->
(match tree with
| Missing -> Node (make_node ~right:(add_symbol tree symbol bits) ())
| Node node -> Node { node with right = add_symbol node.right symbol bits }
| Symbol _ -> failwith "add_symbol")
let rec set_ids tree eos next_id =
match tree with
| Node node ->
node.id <- next_id;
if eos < 8 then node.accept <- true;
next_id + 1 |> set_ids node.left 8 |> set_ids node.right (eos + 1)
| _ -> next_id
let rec traverse root transitions failed symbol node remaining i =
let failed, node, symbol =
match node with
| Symbol symbol -> failed, root, Some symbol
| Node node -> failed, node, symbol
| Missing -> true, root, None
in
if remaining = 0
then (
transitions.(i) <-
(if failed then None, false, None else Some node.id, node.accept, symbol);
i + 1)
else
traverse root transitions failed symbol node.left (remaining - 1) i
|> traverse root transitions failed symbol node.right (remaining - 1)
let rec make_transitions root = function
| Node node ->
let i = traverse root node.transitions false None (Node node) 4 0 in
assert (i = 16);
make_transitions root node.left;
make_transitions root node.right
| _ -> ()
let mk_encode_table encode_table =
let items =
Array.fold_left
(fun acc (code, length) ->
let tup =
Exp.tuple
[ Exp.constant (Pconst_integer (string_of_int code, None))
; Exp.constant (Pconst_integer (string_of_int length, None))
]
in
tup :: acc)
[]
encode_table
in
let_ "encode_table" (Exp.array (List.rev items))
let output_transition (id, accept, symbol) =
let output_int = function
| Some i -> Exp.constant (Pconst_integer (string_of_int i, None))
| None -> Exp.constant (Pconst_integer ("-1", None))
in
let output_bool b =
Exp.construct
{ txt = Longident.Lident (if b then "true" else "false")
; loc = !default_loc
}
None
in
let output_char = function
| Some c -> Exp.constant (Pconst_char c)
| None -> Exp.constant (Pconst_char '\000')
in
Exp.tuple [ output_int id; output_bool accept; output_char symbol ]
let mk_decode_table tree =
let rec loop tree (i, acc) =
match tree with
| Node node ->
assert (node.id = i);
let acc' =
Array.fold_left
(fun acc transition -> output_transition transition :: acc)
acc
node.transitions
in
(i + 1, acc') |> loop node.left |> loop node.right
| _ -> i, acc
in
let i, items = loop tree (0, []) in
assert (i = 256);
let_ "decode_table" (Exp.array (List.rev items))
let bits_of_string s =
let rec aux i =
if i < String.length s
then
match s.[i] with
| '|' -> aux (i + 1)
| '0' -> false :: aux (i + 1)
| '1' -> true :: aux (i + 1)
| _ -> failwith "bits_of_string"
else []
in
aux 0
let () =
let ic = Scanf.Scanning.from_file Sys.argv.(1) in
let encode_table = Array.make 256 (0, 0) in
let rec loop tree i =
if i < 256
then (
Scanf.bscanf ic "%_c%_c%_c ( %d ) %s %x [ %d ]\n"
@@ fun _i s code length ->
assert (i = _i);
encode_table.(i) <- code, length;
let tree = add_symbol tree (char_of_int i) (bits_of_string s) in
loop tree (i + 1))
else
let ids = set_ids tree 0 0 in
assert (ids = 256);
tree
in
let tree = loop Missing 0 in
let root = match tree with Node node -> node | _ -> failwith "empty tree" in
make_transitions root tree;
let ppf = Format.std_formatter in
Format.fprintf ppf "(* generated by util/gen_huffman.ml *)\n\n";
Pprintast.structure ppf [ mk_encode_table encode_table; mk_decode_table tree ]

217
unikernel/duniverse/ocaml-h2/hpack/util/gen_static.ml Normal file
View file

@ -0,0 +1,217 @@
(*----------------------------------------------------------------------------
Copyright (c) 2019 António Nuno Monteiro
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
3. Neither the name of the copyright holder nor the names of its contributors
may be used to endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
----------------------------------------------------------------------------*)
open Parsetree
open Ast_helper
open Asttypes
let ghloc = !default_loc
let let_ name body =
Str.value Nonrecursive [ Vb.mk (Pat.var { txt = name; loc = ghloc }) body ]
module CharSet = Set.Make (Char)
module Hashtbl = struct
include Hashtbl
let[@inline] find_opt h key = try Some (find h key) with Not_found -> None
end
let token_of_name =
String.map @@ function ('a' .. 'z' | 'A' .. 'Z') as c -> c | _ -> '_'
let mk_tokens static_table =
let _, tokens =
Array.fold_left
(fun (prev_token, acc) (i, name, _) ->
if name <> prev_token
then
let token =
let_
(Printf.sprintf "token_%s" (token_of_name name))
(Exp.constant (Pconst_integer (string_of_int i, None)))
in
name, token :: acc
else name, acc)
("", [])
static_table
in
List.rev tokens
let add_name name i names =
let new_val =
match Hashtbl.find_opt names name with Some i' -> min i i' | None -> i
in
Hashtbl.replace names name new_val
let find_pos names =
let n = Hashtbl.length names in
let names = Hashtbl.fold (fun k _ lst -> k :: lst) names [] in
let rec loop pos =
if List.map (fun name -> name.[pos]) names
|> CharSet.of_list
|> CharSet.cardinal
|> ( = ) n
then pos
else loop (pos + 1)
in
loop 0
let make_token_map static_table =
let tbl = Hashtbl.create (Array.length static_table) in
Array.iter
(fun (i, name, _) ->
let length = String.length name in
let string_tbl =
match Hashtbl.find_opt tbl length with
| Some string_tbl -> string_tbl
| None -> Hashtbl.create 10
in
add_name name i string_tbl;
Hashtbl.replace tbl length string_tbl)
static_table;
Hashtbl.fold
(fun length names ret ->
let bindings = Hashtbl.to_seq names |> List.of_seq in
(length, find_pos names, bindings) :: ret)
tbl
[]
let mk_static_table static_table =
let items =
Array.fold_left
(fun acc (_, name, value) ->
let tup =
Exp.tuple
[ Exp.constant (Pconst_string (name, ghloc, None))
; Exp.constant (Pconst_string (value, ghloc, None))
]
in
tup :: acc)
[]
static_table
in
let_ "table" (Exp.array (List.rev items))
let mk_lookup_token token_map =
let_
"lookup_token"
(Exp.fun_
Nolabel
None
(Pat.var { txt = "name"; loc = !default_loc })
(Exp.match_
(Exp.apply
(Exp.ident
{ txt = Longident.(Ldot (Lident "String", "length"))
; loc = !default_loc
})
[ ( Nolabel
, Exp.ident { txt = Longident.Lident "name"; loc = !default_loc }
)
])
(List.concat
[ List.map
(fun (length, pos, names) ->
Exp.case
(Pat.constant
(Pconst_integer (string_of_int length, None)))
(Exp.match_
(Exp.apply
(Exp.ident
{ txt = Ldot (Lident "String", "unsafe_get")
; loc = !default_loc
})
[ ( Nolabel
, Exp.ident
{ txt = Lident "name"; loc = !default_loc } )
; ( Nolabel
, Exp.constant
(Pconst_integer (string_of_int pos, None)) )
])
(List.concat
[ List.map
(fun (name, i) ->
Exp.case
(Pat.constant (Pconst_char name.[pos]))
~guard:
(Exp.apply
(Exp.ident
{ txt = Lident "="
; loc = !default_loc
})
[ ( Nolabel
, Exp.ident
{ txt = Lident "name"
; loc = !default_loc
} )
; ( Nolabel
, Exp.constant
(Pconst_string
(name, ghloc, None)) )
])
(Exp.constant
(Pconst_integer (string_of_int i, None))))
names
; [ Exp.case
(Pat.any ())
(Exp.constant (Pconst_integer ("-1", None)))
]
])))
token_map
; [ Exp.case
(Pat.any ())
(Exp.constant (Pconst_integer ("-1", None)))
]
])))
let () =
let ic = open_in Sys.argv.(1) in
let static_table =
Array.init 61 @@ fun i ->
let line = input_line ic in
match String.split_on_char '\t' line with
| [ s; name ] when int_of_string s == i + 1 -> i, name, ""
| [ s; name; value ] when int_of_string s == i + 1 -> i, name, value
| _ -> assert false
in
let token_map = make_token_map static_table in
let ppf = Format.std_formatter in
Format.fprintf ppf "(* generated by util/gen_static.ml *)\n\n";
let size = let_ "size" (Exp.constant (Pconst_integer ("61", None))) in
Pprintast.structure
ppf
(List.concat
[ size :: mk_tokens static_table
; [ mk_static_table static_table ]
; [ mk_lookup_token token_map ]
])

257
unikernel/duniverse/ocaml-h2/hpack/util/huffman_table.txt Normal file
View file

@ -0,0 +1,257 @@
( 0) |11111111|11000 1ff8 [13]
( 1) |11111111|11111111|1011000 7fffd8 [23]
( 2) |11111111|11111111|11111110|0010 fffffe2 [28]
( 3) |11111111|11111111|11111110|0011 fffffe3 [28]
( 4) |11111111|11111111|11111110|0100 fffffe4 [28]
( 5) |11111111|11111111|11111110|0101 fffffe5 [28]
( 6) |11111111|11111111|11111110|0110 fffffe6 [28]
( 7) |11111111|11111111|11111110|0111 fffffe7 [28]
( 8) |11111111|11111111|11111110|1000 fffffe8 [28]
( 9) |11111111|11111111|11101010 ffffea [24]
( 10) |11111111|11111111|11111111|111100 3ffffffc [30]
( 11) |11111111|11111111|11111110|1001 fffffe9 [28]
( 12) |11111111|11111111|11111110|1010 fffffea [28]
( 13) |11111111|11111111|11111111|111101 3ffffffd [30]
( 14) |11111111|11111111|11111110|1011 fffffeb [28]
( 15) |11111111|11111111|11111110|1100 fffffec [28]
( 16) |11111111|11111111|11111110|1101 fffffed [28]
( 17) |11111111|11111111|11111110|1110 fffffee [28]
( 18) |11111111|11111111|11111110|1111 fffffef [28]
( 19) |11111111|11111111|11111111|0000 ffffff0 [28]
( 20) |11111111|11111111|11111111|0001 ffffff1 [28]
( 21) |11111111|11111111|11111111|0010 ffffff2 [28]
( 22) |11111111|11111111|11111111|111110 3ffffffe [30]
( 23) |11111111|11111111|11111111|0011 ffffff3 [28]
( 24) |11111111|11111111|11111111|0100 ffffff4 [28]
( 25) |11111111|11111111|11111111|0101 ffffff5 [28]
( 26) |11111111|11111111|11111111|0110 ffffff6 [28]
( 27) |11111111|11111111|11111111|0111 ffffff7 [28]
( 28) |11111111|11111111|11111111|1000 ffffff8 [28]
( 29) |11111111|11111111|11111111|1001 ffffff9 [28]
( 30) |11111111|11111111|11111111|1010 ffffffa [28]
( 31) |11111111|11111111|11111111|1011 ffffffb [28]
' ' ( 32) |010100 14 [ 6]
'!' ( 33) |11111110|00 3f8 [10]
'"' ( 34) |11111110|01 3f9 [10]
'#' ( 35) |11111111|1010 ffa [12]
'$' ( 36) |11111111|11001 1ff9 [13]
'%' ( 37) |010101 15 [ 6]
'&' ( 38) |11111000 f8 [ 8]
''' ( 39) |11111111|010 7fa [11]
'(' ( 40) |11111110|10 3fa [10]
')' ( 41) |11111110|11 3fb [10]
'*' ( 42) |11111001 f9 [ 8]
'+' ( 43) |11111111|011 7fb [11]
',' ( 44) |11111010 fa [ 8]
'-' ( 45) |010110 16 [ 6]
'.' ( 46) |010111 17 [ 6]
'/' ( 47) |011000 18 [ 6]
'0' ( 48) |00000 0 [ 5]
'1' ( 49) |00001 1 [ 5]
'2' ( 50) |00010 2 [ 5]
'3' ( 51) |011001 19 [ 6]
'4' ( 52) |011010 1a [ 6]
'5' ( 53) |011011 1b [ 6]
'6' ( 54) |011100 1c [ 6]
'7' ( 55) |011101 1d [ 6]
'8' ( 56) |011110 1e [ 6]
'9' ( 57) |011111 1f [ 6]
':' ( 58) |1011100 5c [ 7]
';' ( 59) |11111011 fb [ 8]
'<' ( 60) |11111111|1111100 7ffc [15]
'=' ( 61) |100000 20 [ 6]
'>' ( 62) |11111111|1011 ffb [12]
'?' ( 63) |11111111|00 3fc [10]
'@' ( 64) |11111111|11010 1ffa [13]
'A' ( 65) |100001 21 [ 6]
'B' ( 66) |1011101 5d [ 7]
'C' ( 67) |1011110 5e [ 7]
'D' ( 68) |1011111 5f [ 7]
'E' ( 69) |1100000 60 [ 7]
'F' ( 70) |1100001 61 [ 7]
'G' ( 71) |1100010 62 [ 7]
'H' ( 72) |1100011 63 [ 7]
'I' ( 73) |1100100 64 [ 7]
'J' ( 74) |1100101 65 [ 7]
'K' ( 75) |1100110 66 [ 7]
'L' ( 76) |1100111 67 [ 7]
'M' ( 77) |1101000 68 [ 7]
'N' ( 78) |1101001 69 [ 7]
'O' ( 79) |1101010 6a [ 7]
'P' ( 80) |1101011 6b [ 7]
'Q' ( 81) |1101100 6c [ 7]
'R' ( 82) |1101101 6d [ 7]
'S' ( 83) |1101110 6e [ 7]
'T' ( 84) |1101111 6f [ 7]
'U' ( 85) |1110000 70 [ 7]
'V' ( 86) |1110001 71 [ 7]
'W' ( 87) |1110010 72 [ 7]
'X' ( 88) |11111100 fc [ 8]
'Y' ( 89) |1110011 73 [ 7]
'Z' ( 90) |11111101 fd [ 8]
'[' ( 91) |11111111|11011 1ffb [13]
'\' ( 92) |11111111|11111110|000 7fff0 [19]
']' ( 93) |11111111|11100 1ffc [13]
'^' ( 94) |11111111|111100 3ffc [14]
'_' ( 95) |100010 22 [ 6]
'`' ( 96) |11111111|1111101 7ffd [15]
'a' ( 97) |00011 3 [ 5]
'b' ( 98) |100011 23 [ 6]
'c' ( 99) |00100 4 [ 5]
'd' (100) |100100 24 [ 6]
'e' (101) |00101 5 [ 5]
'f' (102) |100101 25 [ 6]
'g' (103) |100110 26 [ 6]
'h' (104) |100111 27 [ 6]
'i' (105) |00110 6 [ 5]
'j' (106) |1110100 74 [ 7]
'k' (107) |1110101 75 [ 7]
'l' (108) |101000 28 [ 6]
'm' (109) |101001 29 [ 6]
'n' (110) |101010 2a [ 6]
'o' (111) |00111 7 [ 5]
'p' (112) |101011 2b [ 6]
'q' (113) |1110110 76 [ 7]
'r' (114) |101100 2c [ 6]
's' (115) |01000 8 [ 5]
't' (116) |01001 9 [ 5]
'u' (117) |101101 2d [ 6]
'v' (118) |1110111 77 [ 7]
'w' (119) |1111000 78 [ 7]
'x' (120) |1111001 79 [ 7]
'y' (121) |1111010 7a [ 7]
'z' (122) |1111011 7b [ 7]
'{' (123) |11111111|1111110 7ffe [15]
'|' (124) |11111111|100 7fc [11]
'}' (125) |11111111|111101 3ffd [14]
'~' (126) |11111111|11101 1ffd [13]
(127) |11111111|11111111|11111111|1100 ffffffc [28]
(128) |11111111|11111110|0110 fffe6 [20]
(129) |11111111|11111111|010010 3fffd2 [22]
(130) |11111111|11111110|0111 fffe7 [20]
(131) |11111111|11111110|1000 fffe8 [20]
(132) |11111111|11111111|010011 3fffd3 [22]
(133) |11111111|11111111|010100 3fffd4 [22]
(134) |11111111|11111111|010101 3fffd5 [22]
(135) |11111111|11111111|1011001 7fffd9 [23]
(136) |11111111|11111111|010110 3fffd6 [22]
(137) |11111111|11111111|1011010 7fffda [23]
(138) |11111111|11111111|1011011 7fffdb [23]
(139) |11111111|11111111|1011100 7fffdc [23]
(140) |11111111|11111111|1011101 7fffdd [23]
(141) |11111111|11111111|1011110 7fffde [23]
(142) |11111111|11111111|11101011 ffffeb [24]
(143) |11111111|11111111|1011111 7fffdf [23]
(144) |11111111|11111111|11101100 ffffec [24]
(145) |11111111|11111111|11101101 ffffed [24]
(146) |11111111|11111111|010111 3fffd7 [22]
(147) |11111111|11111111|1100000 7fffe0 [23]
(148) |11111111|11111111|11101110 ffffee [24]
(149) |11111111|11111111|1100001 7fffe1 [23]
(150) |11111111|11111111|1100010 7fffe2 [23]
(151) |11111111|11111111|1100011 7fffe3 [23]
(152) |11111111|11111111|1100100 7fffe4 [23]
(153) |11111111|11111110|11100 1fffdc [21]
(154) |11111111|11111111|011000 3fffd8 [22]
(155) |11111111|11111111|1100101 7fffe5 [23]
(156) |11111111|11111111|011001 3fffd9 [22]
(157) |11111111|11111111|1100110 7fffe6 [23]
(158) |11111111|11111111|1100111 7fffe7 [23]
(159) |11111111|11111111|11101111 ffffef [24]
(160) |11111111|11111111|011010 3fffda [22]
(161) |11111111|11111110|11101 1fffdd [21]
(162) |11111111|11111110|1001 fffe9 [20]
(163) |11111111|11111111|011011 3fffdb [22]
(164) |11111111|11111111|011100 3fffdc [22]
(165) |11111111|11111111|1101000 7fffe8 [23]
(166) |11111111|11111111|1101001 7fffe9 [23]
(167) |11111111|11111110|11110 1fffde [21]
(168) |11111111|11111111|1101010 7fffea [23]
(169) |11111111|11111111|011101 3fffdd [22]
(170) |11111111|11111111|011110 3fffde [22]
(171) |11111111|11111111|11110000 fffff0 [24]
(172) |11111111|11111110|11111 1fffdf [21]
(173) |11111111|11111111|011111 3fffdf [22]
(174) |11111111|11111111|1101011 7fffeb [23]
(175) |11111111|11111111|1101100 7fffec [23]
(176) |11111111|11111111|00000 1fffe0 [21]
(177) |11111111|11111111|00001 1fffe1 [21]
(178) |11111111|11111111|100000 3fffe0 [22]
(179) |11111111|11111111|00010 1fffe2 [21]
(180) |11111111|11111111|1101101 7fffed [23]
(181) |11111111|11111111|100001 3fffe1 [22]
(182) |11111111|11111111|1101110 7fffee [23]
(183) |11111111|11111111|1101111 7fffef [23]
(184) |11111111|11111110|1010 fffea [20]
(185) |11111111|11111111|100010 3fffe2 [22]
(186) |11111111|11111111|100011 3fffe3 [22]
(187) |11111111|11111111|100100 3fffe4 [22]
(188) |11111111|11111111|1110000 7ffff0 [23]
(189) |11111111|11111111|100101 3fffe5 [22]
(190) |11111111|11111111|100110 3fffe6 [22]
(191) |11111111|11111111|1110001 7ffff1 [23]
(192) |11111111|11111111|11111000|00 3ffffe0 [26]
(193) |11111111|11111111|11111000|01 3ffffe1 [26]
(194) |11111111|11111110|1011 fffeb [20]
(195) |11111111|11111110|001 7fff1 [19]
(196) |11111111|11111111|100111 3fffe7 [22]
(197) |11111111|11111111|1110010 7ffff2 [23]
(198) |11111111|11111111|101000 3fffe8 [22]
(199) |11111111|11111111|11110110|0 1ffffec [25]
(200) |11111111|11111111|11111000|10 3ffffe2 [26]
(201) |11111111|11111111|11111000|11 3ffffe3 [26]
(202) |11111111|11111111|11111001|00 3ffffe4 [26]
(203) |11111111|11111111|11111011|110 7ffffde [27]
(204) |11111111|11111111|11111011|111 7ffffdf [27]
(205) |11111111|11111111|11111001|01 3ffffe5 [26]
(206) |11111111|11111111|11110001 fffff1 [24]
(207) |11111111|11111111|11110110|1 1ffffed [25]
(208) |11111111|11111110|010 7fff2 [19]
(209) |11111111|11111111|00011 1fffe3 [21]
(210) |11111111|11111111|11111001|10 3ffffe6 [26]
(211) |11111111|11111111|11111100|000 7ffffe0 [27]
(212) |11111111|11111111|11111100|001 7ffffe1 [27]
(213) |11111111|11111111|11111001|11 3ffffe7 [26]
(214) |11111111|11111111|11111100|010 7ffffe2 [27]
(215) |11111111|11111111|11110010 fffff2 [24]
(216) |11111111|11111111|00100 1fffe4 [21]
(217) |11111111|11111111|00101 1fffe5 [21]
(218) |11111111|11111111|11111010|00 3ffffe8 [26]
(219) |11111111|11111111|11111010|01 3ffffe9 [26]
(220) |11111111|11111111|11111111|1101 ffffffd [28]
(221) |11111111|11111111|11111100|011 7ffffe3 [27]
(222) |11111111|11111111|11111100|100 7ffffe4 [27]
(223) |11111111|11111111|11111100|101 7ffffe5 [27]
(224) |11111111|11111110|1100 fffec [20]
(225) |11111111|11111111|11110011 fffff3 [24]
(226) |11111111|11111110|1101 fffed [20]
(227) |11111111|11111111|00110 1fffe6 [21]
(228) |11111111|11111111|101001 3fffe9 [22]
(229) |11111111|11111111|00111 1fffe7 [21]
(230) |11111111|11111111|01000 1fffe8 [21]
(231) |11111111|11111111|1110011 7ffff3 [23]
(232) |11111111|11111111|101010 3fffea [22]
(233) |11111111|11111111|101011 3fffeb [22]
(234) |11111111|11111111|11110111|0 1ffffee [25]
(235) |11111111|11111111|11110111|1 1ffffef [25]
(236) |11111111|11111111|11110100 fffff4 [24]
(237) |11111111|11111111|11110101 fffff5 [24]
(238) |11111111|11111111|11111010|10 3ffffea [26]
(239) |11111111|11111111|1110100 7ffff4 [23]
(240) |11111111|11111111|11111010|11 3ffffeb [26]
(241) |11111111|11111111|11111100|110 7ffffe6 [27]
(242) |11111111|11111111|11111011|00 3ffffec [26]
(243) |11111111|11111111|11111011|01 3ffffed [26]
(244) |11111111|11111111|11111100|111 7ffffe7 [27]
(245) |11111111|11111111|11111101|000 7ffffe8 [27]
(246) |11111111|11111111|11111101|001 7ffffe9 [27]
(247) |11111111|11111111|11111101|010 7ffffea [27]
(248) |11111111|11111111|11111101|011 7ffffeb [27]
(249) |11111111|11111111|11111111|1110 ffffffe [28]
(250) |11111111|11111111|11111101|100 7ffffec [27]
(251) |11111111|11111111|11111101|101 7ffffed [27]
(252) |11111111|11111111|11111101|110 7ffffee [27]
(253) |11111111|11111111|11111101|111 7ffffef [27]
(254) |11111111|11111111|11111110|000 7fffff0 [27]
(255) |11111111|11111111|11111011|10 3ffffee [26]
EOS (256) |11111111|11111111|11111111|111111 3fffffff [30]

61
unikernel/duniverse/ocaml-h2/hpack/util/static_table.txt Normal file
View file

@ -0,0 +1,61 @@
1 :authority
2 :method GET
3 :method POST
4 :path /
5 :path /index.html
6 :scheme http
7 :scheme https
8 :status 200
9 :status 204
10 :status 206
11 :status 304
12 :status 400
13 :status 404
14 :status 500
15 accept-charset
16 accept-encoding gzip, deflate
17 accept-language
18 accept-ranges
19 accept
20 access-control-allow-origin
21 age
22 allow
23 authorization
24 cache-control
25 content-disposition
26 content-encoding
27 content-language
28 content-length
29 content-location
30 content-range
31 content-type
32 cookie
33 date
34 etag
35 expect
36 expires
37 from
38 host
39 if-match
40 if-modified-since
41 if-none-match
42 if-range
43 if-unmodified-since
44 last-modified
45 link
46 location
47 max-forwards
48 proxy-authenticate
49 proxy-authorization
50 range
51 referer
52 refresh
53 retry-after
54 server
55 set-cookie
56 strict-transport-security
57 transfer-encoding
58 user-agent
59 vary
60 via
61 www-authenticate

30
unikernel/duniverse/ocaml-h2/httpaf.LICENSE Normal file
View file

@ -0,0 +1,30 @@
Copyright (c) 2016, Inhabited Type LLC
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

190
unikernel/duniverse/ocaml-h2/lib/body.ml Normal file
View file

@ -0,0 +1,190 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2017 Inhabited Type LLC.
* Copyright (c) 2019 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
module Reader = struct
type t =
{ faraday : Faraday.t
; mutable read_scheduled : bool
; mutable on_eof : unit -> unit
; mutable on_read : Bigstringaf.t -> off:int -> len:int -> unit
; done_reading : int -> unit
}
let default_done_reading = Sys.opaque_identity (fun _ -> ())
let default_on_eof = Sys.opaque_identity (fun () -> ())
let default_on_read = Sys.opaque_identity (fun _ ~off:_ ~len:_ -> ())
let create buffer ~done_reading =
{ faraday = Faraday.of_bigstring buffer
; read_scheduled = false
; on_eof = default_on_eof
; on_read = default_on_read
; done_reading
}
let create_empty () =
let t = create Bigstringaf.empty ~done_reading:default_done_reading in
Faraday.close t.faraday;
t
let empty = create_empty ()
let is_closed t = Faraday.is_closed t.faraday
let unsafe_faraday t = t.faraday
let rec do_execute_read t on_eof on_read =
match Faraday.operation t.faraday with
| `Yield -> ()
| `Close ->
t.read_scheduled <- false;
t.on_eof <- default_on_eof;
t.on_read <- default_on_read;
on_eof ()
| `Writev [] -> assert false
| `Writev (iovec :: _) ->
t.read_scheduled <- false;
t.on_eof <- default_on_eof;
t.on_read <- default_on_read;
let { Httpun_types.IOVec.buffer; off; len } = iovec in
Faraday.shift t.faraday len;
on_read buffer ~off ~len;
(* Application is done reading, we can give flow control tokens back to
the peer. *)
t.done_reading len;
execute_read t
and execute_read t =
if t.read_scheduled then do_execute_read t t.on_eof t.on_read
let schedule_read t ~on_eof ~on_read =
if t.read_scheduled
then failwith "Body.schedule_read: reader already scheduled";
if not (is_closed t)
then (
t.read_scheduled <- true;
t.on_eof <- on_eof;
t.on_read <- on_read);
do_execute_read t on_eof on_read
let close t =
Faraday.close t.faraday;
execute_read t
let has_pending_output t = Faraday.has_pending_output t.faraday
end
module Writer = struct
module Writer = Serialize.Writer
type t =
{ faraday : Faraday.t
; mutable buffered_bytes : int
; writer : Serialize.Writer.t
}
let create buffer ~writer =
{ faraday = Faraday.of_bigstring buffer; buffered_bytes = 0; writer }
let create_empty ~writer =
let t = create Bigstringaf.empty ~writer in
Faraday.close t.faraday;
t
let ready_to_write t = Serialize.Writer.wakeup t.writer
let write_char t c =
if not (Faraday.is_closed t.faraday) then Faraday.write_char t.faraday c;
ready_to_write t
let write_string t ?off ?len s =
if not (Faraday.is_closed t.faraday)
then Faraday.write_string ?off ?len t.faraday s;
ready_to_write t
let write_bigstring t ?off ?len b =
if not (Faraday.is_closed t.faraday)
then Faraday.write_bigstring ?off ?len t.faraday b;
ready_to_write t
let schedule_bigstring t ?off ?len (b : Bigstringaf.t) =
if not (Faraday.is_closed t.faraday)
then Faraday.schedule_bigstring ?off ?len t.faraday b;
ready_to_write t
let flush t kontinue =
if Serialize.Writer.is_closed t.writer
then kontinue `Closed
else (
Faraday.flush_with_reason t.faraday (function
| Drain -> kontinue `Closed
| Nothing_pending | Shift -> kontinue `Written);
ready_to_write t)
let is_closed t = Faraday.is_closed t.faraday
let has_pending_output t = Faraday.has_pending_output t.faraday
let close_and_drain t =
Faraday.close t.faraday;
(* Resolve all pending flushes *)
ignore (Faraday.drain t.faraday : int)
let close t =
Serialize.Writer.unyield t.writer;
Faraday.close t.faraday;
ready_to_write t
let unsafe_faraday t = t.faraday
let transfer_to_writer t writer ~max_frame_size ~max_bytes stream_id =
let faraday = t.faraday in
if Serialize.Writer.is_closed t.writer
then (
close_and_drain t;
0)
else
match Faraday.operation faraday with
| `Yield | `Close -> 0
| `Writev iovecs ->
let iovecs = Httpun_types.IOVec.shiftv iovecs t.buffered_bytes in
let lengthv = Httpun_types.IOVec.lengthv iovecs in
let writev_len = if max_bytes < lengthv then max_bytes else lengthv in
t.buffered_bytes <- t.buffered_bytes + writev_len;
let frame_info = Writer.make_frame_info ~max_frame_size stream_id in
Writer.schedule_iovecs writer frame_info ~len:writev_len iovecs;
Writer.flush t.writer (function
| `Closed -> close_and_drain t
| `Written ->
Faraday.shift faraday writev_len;
t.buffered_bytes <- t.buffered_bytes - writev_len);
writev_len
end

1492
unikernel/duniverse/ocaml-h2/lib/client_connection.ml Normal file
View file

File diff suppressed because it is too large Load diff

91
unikernel/duniverse/ocaml-h2/lib/config.ml Normal file
View file

@ -0,0 +1,91 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2017 Inhabited Type LLC.
* Copyright (c) 2019 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
(* TODO: add a config option for `Reqd` to flush max bytes at a time? *)
type t =
{ read_buffer_size : int
; request_body_buffer_size : int
; response_body_buffer_size : int
; enable_server_push : bool
; max_concurrent_streams : int32
; initial_window_size : int32
}
let default =
{ (* This is effectively MAX_FRAME_SIZE, because the parser commits the frame
* header to prevent backtracking, therefore the entire payload can fit the
* read buffer. The default is 16384, and can't be lower than that.
*
* Note: h2 does not check that MAX_FRAME_SIZE is lower than 16384
* octets. In the case that a lower value than permitted is set, peers will
* reject the setting and close the connection with a PROTOCOL_ERROR.
*
* From RFC7540§6.5.2:
* SETTINGS_MAX_FRAME_SIZE (0x5): Indicates the size of the largest frame
* payload that the sender is willing to receive, in octets.
* The initial value is 2^14 (16,384) octets. The value advertised by an
* endpoint MUST be between this initial value and the maximum allowed
* frame size (2^24-1 or 16,777,215 octets), inclusive. *)
read_buffer_size = Settings.default.max_frame_size
; (* Buffer size for request bodies *) request_body_buffer_size = 0x1000
; (* Buffer size for response bodies *) response_body_buffer_size = 0x1000
; enable_server_push = true
; (* From RFC7540§6.5.2:
* Indicates the maximum number of concurrent streams that the sender
* will allow. This limit is directional: it applies to the number of
* streams that the sender permits the receiver to create. *)
max_concurrent_streams = Settings.default.max_concurrent_streams
; (* Indicates the initial window size when receiving data from remote
* streams. In other words, represents the amount of octets that the H2
* endpoint is willing to receive from the peer. Cannot be lower than
* 65535 (the default as per the spec). The default in H2 is 2^27, or
* 128 MiB. *)
(* TODO(anmonteiro): validate the default somewhere. *)
initial_window_size = Int32.shift_left 1l 27
}
let to_settings
{ read_buffer_size
; max_concurrent_streams
; initial_window_size
; enable_server_push
; _
}
=
{ Settings.default with
max_frame_size = read_buffer_size
; max_concurrent_streams
; initial_window_size
; enable_push = enable_server_push
}

4
unikernel/duniverse/ocaml-h2/lib/dune Normal file
View file

@ -0,0 +1,4 @@
(library
(name h2)
(public_name h2)
(libraries angstrom base64 faraday bigstringaf httpun-types psq hpack))

43
unikernel/duniverse/ocaml-h2/lib/error.ml Normal file
View file

@ -0,0 +1,43 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
(* From RFC7540§5.4:
* HTTP/2 framing permits two classes of error:
*
* - An error condition that renders the entire connection unusable is a
* connection error.
* - An error in an individual stream is a stream error. *)
type t =
| ConnectionError of Error_code.t * string
| StreamError of Stream_identifier.t * Error_code.t
let message = function ConnectionError (_, msg) -> msg | StreamError _ -> ""

152
unikernel/duniverse/ocaml-h2/lib/error_code.ml Normal file
View file

@ -0,0 +1,152 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
type t =
(* From RFC7540§7:
* NO_ERROR (0x0): The associated condition is not a result of an
* error. *)
| NoError
(* From RFC7540§7:
* PROTOCOL_ERROR (0x1): The endpoint detected an unspecific protocol
* error. This error is for use when a more specific error code is not
* available. *)
| ProtocolError
(* From RFC7540§7:
* INTERNAL_ERROR (0x2): The endpoint encountered an unexpected internal
* error. *)
| InternalError
(* From RFC7540§7:
* FLOW_CONTROL_ERROR (0x3): The endpoint detected that its peer violated
* the flow-control protocol. *)
| FlowControlError
(* From RFC7540§7:
* SETTINGS_TIMEOUT (0x4): The endpoint sent a SETTINGS frame but did not
* receive a response in a timely manner. *)
| SettingsTimeout
(* From RFC7540§7:
* STREAM_CLOSED (0x5): The endpoint received a frame after a stream was
* half-closed. *)
| StreamClosed
(* From RFC7540§7:
* FRAME_SIZE_ERROR (0x6): The endpoint received a frame with an invalid
* size. *)
| FrameSizeError
(* From RFC7540§7:
* REFUSED_STREAM (0x7): The endpoint refused the stream prior to
* performing any application processing (see Section 8.1.4 for
* details). *)
| RefusedStream
(* From RFC7540§7:
* CANCEL (0x8): Used by the endpoint to indicate that the stream is no
* longer needed. *)
| Cancel
(* From RFC7540§7:
* COMPRESSION_ERROR (0x9): The endpoint is unable to maintain the header
* compression context for the connection. *)
| CompressionError
(* From RFC7540§7:
* CONNECT_ERROR (0xa): The connection established in response to a
* CONNECT request (Section 8.3) was reset or abnormally closed. *)
| ConnectError
(* From RFC7540§7:
* ENHANCE_YOUR_CALM (0xb): The endpoint detected that its peer is
* exhibiting a behavior that might be generating excessive load. *)
| EnhanceYourCalm
(* From RFC7540§7:
* INADEQUATE_SECURITY (0xc): The underlying transport has properties
* that do not meet minimum security requirements (see Section 9.2). *)
| InadequateSecurity
(* From RFC7540§7:
* HTTP_1_1_REQUIRED (0xd): The endpoint requires that HTTP/1.1 be used
* instead of HTTP/2. *)
| HTTP_1_1_Required
(* From RFC7540§7:
* Unknown or unsupported error codes MUST NOT trigger any special
* behavior. These MAY be treated by an implementation as being
* equivalent to INTERNAL_ERROR. *)
| UnknownError_code of int32
(* From RFC7540§7:
* Error codes are 32-bit fields that are used in RST_STREAM and GOAWAY
* frames to convey the reasons for the stream or connection error. *)
let serialize = function
| NoError -> 0x0l
| ProtocolError -> 0x1l
| InternalError -> 0x2l
| FlowControlError -> 0x3l
| SettingsTimeout -> 0x4l
| StreamClosed -> 0x5l
| FrameSizeError -> 0x6l
| RefusedStream -> 0x7l
| Cancel -> 0x8l
| CompressionError -> 0x9l
| ConnectError -> 0xal
| EnhanceYourCalm -> 0xbl
| InadequateSecurity -> 0xcl
| HTTP_1_1_Required -> 0xdl
| UnknownError_code id -> id
let parse = function
| 0x0l -> NoError
| 0x1l -> ProtocolError
| 0x2l -> InternalError
| 0x3l -> FlowControlError
| 0x4l -> SettingsTimeout
| 0x5l -> StreamClosed
| 0x6l -> FrameSizeError
| 0x7l -> RefusedStream
| 0x8l -> Cancel
| 0x9l -> CompressionError
| 0xal -> ConnectError
| 0xbl -> EnhanceYourCalm
| 0xcl -> InadequateSecurity
| 0xdl -> HTTP_1_1_Required
| id -> UnknownError_code id
let to_string = function
| NoError -> "NO_ERROR (0x0)"
| ProtocolError -> "PROTOCOL_ERROR (0x1)"
| InternalError -> "INTERNAL_ERROR (0x2)"
| FlowControlError -> "FLOW_CONTROL_ERROR (0x3)"
| SettingsTimeout -> "SETTINGS_TIMEOUT (0x4)"
| StreamClosed -> "STREAM_CLOSED (0x5)"
| FrameSizeError -> "FRAME_SIZE_ERROR (0x6)"
| RefusedStream -> "REFUSED_STREAM (0x7)"
| Cancel -> "CANCEL (0x8)"
| CompressionError -> "COMPRESSION_ERROR (0x9)"
| ConnectError -> "CONNECT_ERROR (0xa)"
| EnhanceYourCalm -> "ENHANCE_YOUR_CALM (0xb)"
| InadequateSecurity -> "INADEQUATE_SECURITY (0xc)"
| HTTP_1_1_Required -> "HTTP_1_1_REQUIRED (0xd)"
| UnknownError_code id -> Format.asprintf "UNKNOWN_ERROR (0x%lx)" id
let pp_hum formatter t = Format.fprintf formatter "%s" (to_string t)

72
unikernel/duniverse/ocaml-h2/lib/flags.ml Normal file
View file

@ -0,0 +1,72 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
open Util
type t = int
(* From RFC7540§6.2:
* Flags that have no defined semantics for a particular frame type MUST be
* ignored and MUST be left unset (0x0) when sending. *)
let default_flags = 0x0
(* From RFC7540§6.2:
* END_STREAM (0x1): When set, bit 0 indicates that the header block (Section
* 4.3) is the last that the endpoint will send for the identified stream. *)
let test_end_stream x = test_bit x 0
let set_end_stream x = set_bit x 0
let clear_end_stream x = clear_bit x 0
(* From RFC7540§6.7:
* ACK (0x1): When set, bit 0 indicates that this PING frame is a PING
* response. *)
let test_ack x = test_bit x 0
let set_ack x = set_bit x 0
(* From RFC7540§6.2:
* END_HEADERS (0x4): When set, bit 2 indicates that this frame contains an
* entire header block (Section 4.3) and is not followed by any CONTINUATION
* frames. *)
let test_end_header x = test_bit x 2
let set_end_header x = set_bit x 2
(* From RFC7540§6.2:
* PADDED (0x8): When set, bit 3 indicates that the Pad Length field and any
* padding that it describes are present. *)
let test_padded x = test_bit x 3
let set_padded x = set_bit x 3
(* From RFC7540§6.2:
* PRIORITY (0x20): When set, bit 5 indicates that the Exclusive Flag (E),
* Stream Dependency, and Weight fields are present; see Section 5.3. *)
let test_priority x = test_bit x 5
let set_priority x = set_bit x 5

218
unikernel/duniverse/ocaml-h2/lib/frame.ml Normal file
View file

@ -0,0 +1,218 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
let connection_preface = "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n"
module FrameType = struct
type t =
(* From RFC7540§6.1:
* DATA frames (type=0x0) convey arbitrary, variable-length sequences
* of octets associated with a stream. *)
| Data
(* From RFC7540§6.2:
* The HEADERS frame (type=0x1) is used to open a stream (Section 5.1),
* and additionally carries a header block fragment. *)
| Headers
(* From RFC7540§6.3:
* The PRIORITY frame (type=0x2) specifies the sender-advised priority
* of a stream (Section 5.3). *)
| Priority
(* From RFC7540§6.4:
* The RST_STREAM frame (type=0x3) allows for immediate termination of
* a stream. *)
| RSTStream
(* From RFC7540§6.5:
* The SETTINGS frame (type=0x4) conveys configuration parameters that
* affect how endpoints communicate, such as preferences and
* constraints on peer behavior. *)
| Settings
(* From RFC7540§6.6:
* The PUSH_PROMISE frame (type=0x5) is used to notify the peer
* endpoint in advance of streams the sender intends to initiate. *)
| PushPromise
(* From RFC7540§6.7:
* The PING frame (type=0x6) is a mechanism for measuring a minimal
* round-trip time from the sender, as well as determining whether an
* idle connection is still functional. *)
| Ping
(* From RFC7540§6.8:
* The GOAWAY frame (type=0x7) is used to initiate shutdown of a
* connection or to signal serious error conditions. *)
| GoAway
(* From RFC7540§6.9:
* The WINDOW_UPDATE frame (type=0x8) is used to implement flow
* control; [...]. *)
| WindowUpdate
(* From RFC7540§6.10:
* The CONTINUATION frame (type=0x9) is used to continue a sequence of
* header block fragments (Section 4.3). *)
| Continuation
(* From RFC7540§5.1:
* Frames of unknown types are ignored. *)
| Unknown of int
let serialize = function
| Data -> 0
| Headers -> 1
| Priority -> 2
| RSTStream -> 3
| Settings -> 4
| PushPromise -> 5
| Ping -> 6
| GoAway -> 7
| WindowUpdate -> 8
| Continuation -> 9
| Unknown x -> x
let parse = function
| 0 -> Data
| 1 -> Headers
| 2 -> Priority
| 3 -> RSTStream
| 4 -> Settings
| 5 -> PushPromise
| 6 -> Ping
| 7 -> GoAway
| 8 -> WindowUpdate
| 9 -> Continuation
| x -> Unknown x
end
(* From RFC7540§4.1:
* The fields of the frame header are defined as:
*
* Length: The length of the frame payload expressed as an unsigned 24-bit
* integer. [...]
*
* Type: The 8-bit type of the frame. [...]
*
* Flags: An 8-bit field reserved for boolean flags specific to the frame
* type. [...]
*
* Stream Identifier: A stream identifier (see Section 5.1.1) expressed as
* an unsigned 31-bit integer. [...] *)
type frame_header =
{ payload_length : int
; flags : Flags.t
; stream_id : Stream_identifier.t
; frame_type : FrameType.t
}
(* From RFC7540§4.1:
* The structure and content of the frame payload is dependent entirely on
* the frame type. *)
type frame_payload =
(* From RFC7540§6.1:
* The DATA frame contains the following fields:
*
* [...]
*
* Data: Application data. The amount of data is the remainder of the
* frame payload after subtracting the length of the other fields
* that are present. *)
| Data of Bigstringaf.t
(* From RFC7540§6.2:
* The HEADERS frame payload has the following fields:
*
* E: A single-bit flag indicating that the stream dependency is
* exclusive (see Section 5.3). [...]
*
* Stream Dependency: A 31-bit stream identifier for the stream that
* this stream depends on (see Section 5.3). [...]
*
* Weight: An unsigned 8-bit integer representing a priority weight for
* the stream (see Section 5.3). [...] This field is only
* present if the PRIORITY flag is set.
*
* Header Block Fragment: A header block fragment (Section 4.3). *)
| Headers of Priority.t * Bigstringaf.t
(* From RFC7540§6.3:
* The payload of a PRIORITY frame contains the following fields:
*
* E: A single-bit flag indicating that the stream dependency is
* exclusive (see Section 5.3).
*
* Stream Dependency: A 31-bit stream identifier for the stream that this
* stream depends on (see Section 5.3).
*
* Weight: An unsigned 8-bit integer representing a priority weight for
* the stream (see Section 5.3). [...] *)
| Priority of Priority.t
(* From RFC7540§6.4:
* The RST_STREAM frame contains a single unsigned, 32-bit integer
* identifying the error code (Section 7). [...] *)
| RSTStream of Error_code.t
(* From RFC7540§6.5:
* The payload of a SETTINGS frame consists of zero or more parameters,
* each consisting of an unsigned 16-bit setting identifier and an
* unsigned 32-bit value. *)
| Settings of Settings.settings_list
(* From RFC7540§6.6:
* The PUSH_PROMISE frame includes the unsigned 31-bit identifier of the
* stream the endpoint plans to create along with a set of headers that
* provide additional context for the stream. *)
| PushPromise of Stream_identifier.t * Bigstringaf.t
(* From RFC7540§6.7:
* In addition to the frame header, PING frames MUST contain 8 octets of
* opaque data in the payload. A sender can include any value it chooses
* and use those octets in any fashion. *)
| Ping of Bigstringaf.t
(* From RFC7540§6.8:
* The last stream identifier in the GOAWAY frame contains the
* highest-numbered stream identifier for which the sender of the GOAWAY
* frame might have taken some action on or might yet take action on.
*
* [...] The GOAWAY frame also contains a 32-bit error code (Section 7)
* that contains the reason for closing the connection.
*
* [...] Endpoints MAY append opaque data to the payload of any GOAWAY
* frame. *)
| GoAway of Stream_identifier.t * Error_code.t * Bigstringaf.t
(* From RFC7540§6.9:
* The payload of a WINDOW_UPDATE frame is one reserved bit plus an
* unsigned 31-bit integer indicating the number of octets that the
* sender can transmit in addition to the existing flow-control
* window. *)
| WindowUpdate of Settings.WindowSize.t
(* From RFC7540§6.10:
* The CONTINUATION frame payload contains a header block fragment
* (Section 4.3). *)
| Continuation of Bigstringaf.t
| Unknown of int * Bigstringaf.t
(* From RFC7540§4.1:
* All frames begin with a fixed 9-octet header followed by a variable-length
* payload. *)
type t =
{ frame_header : frame_header
; frame_payload : frame_payload
}

47
unikernel/duniverse/ocaml-h2/lib/h2.ml Normal file
View file

@ -0,0 +1,47 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2017 Inhabited Type LLC.
* Copyright (c) 2019 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
module Headers = Headers
module IOVec = Httpun_types.IOVec
module Method = Httpun_types.Method
module Reqd = Reqd
module Request = Request
module Response = Response
module Status = Status
module Body = Body
module Error_code = Error_code
module Config = Config
module Server_connection = Server_connection
module Client_connection = Client_connection
module Settings = Settings

956
unikernel/duniverse/ocaml-h2/lib/h2.mli Normal file
View file

@ -0,0 +1,956 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2017 Inhabited Type LLC.
* Copyright (c) 2019 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
(** H2 is a high-performance, memory-efficient, and scalable HTTP/2
implementation for OCaml. It is based on the concepts introduced http/af,
and therefore uses the Angstrom and Faraday libraries to implement the
parsing and serialization layers of the HTTP/2 standard. It preserves the
same API as httpun wherever possible.
Not unlike httpun, the user should be familiar with HTTP, and the basic
principles of memory management and vectorized IO in order to use this
library. *)
(** {2 Basic HTTP Types} *)
module Method : module type of Httpun_types.Method
(** Request Method
The request method token is the primary source of request semantics; it
indicates the purpose for which the client has made this request and what is
expected by the client as a successful result.
See {{:https://tools.ietf.org/html/rfc7231#section-4} RFC7231§4} for more
details.
This module is a proxy to [Httpun_types.Method] and is included in h2 for
convenience. *)
(** Response Status Codes
The status-code element is a three-digit integer code giving the result of
the attempt to understand and satisfy the request.
See {{:https://tools.ietf.org/html/rfc7231#section-6} RFC7231§6} for more
details.
This module is a strict superset of [Httpun_types.Status]. Even though the
HTTP/2 specification removes support for the [Switching_protocols] status
code, h2 keeps it for the sake of higher level interaction between OCaml
libraries that support both HTTP/1 and HTTP/2.
See {{:https://tools.ietf.org/html/rfc7540#section-8.1.1} RFC7540§8.1.1} for
more details. *)
module Status : sig
include
module type of Httpun_types.Status
with type client_error := Httpun_types.Status.client_error
and type standard := Httpun_types.Status.standard
and type t := Httpun_types.Status.t
type client_error =
[ Httpun_types.Status.client_error
| `Misdirected_request
]
(** The 4xx (Client Error) class of status code indicates that the client
seems to have erred.
See {{:https://tools.ietf.org/html/rfc7231#section-6.5} RFC7231§6.5} for
more details.
In addition to httpun, this type also includes the 421 (Misdirected
Request) tag. See
{{:https://tools.ietf.org/html/rfc7540#section-9.1.2} RFC7540§9.1.2} for
more details. *)
type standard =
[ Httpun_types.Status.standard
| client_error
]
(** The status codes defined in the HTTP/1.1 RFCs, excluding the
[Switching Protocols] status and including the [Misdirected Request] as
per the HTTP/2 RFC.
See {{:https://tools.ietf.org/html/rfc7540#section-8.1.1} RFC7540§8.1.1}
and {{:https://tools.ietf.org/html/rfc7540#section-9.1.2} RFC7540§9.1.2}
for more details. *)
type t =
[ standard
| `Code of int
]
(** The standard codes along with support for custom codes. *)
val default_reason_phrase : standard -> string
(** [default_reason_phrase standard] is the example reason phrase provided by
RFC7231 for the [standard] status code. The RFC allows servers to use
reason phrases besides these in responses. *)
val to_code : t -> int
(** [to_code t] is the integer representation of [t]. *)
val of_code : int -> t
(** [of_code i] is the [t] representation of [i]. [of_code] raises [Failure]
if [i] is not a positive three-digit number. *)
val unsafe_of_code : int -> t
(** [unsafe_of_code i] is equivalent to [of_code i], except it accepts any
positive code, regardless of the number of digits it has. On negative
codes, it will still raise [Failure]. *)
val is_informational : t -> bool
(** [is_informational t] is [true] iff [t] belongs to the Informational class
of status codes. *)
val is_successful : t -> bool
(** [is_successful t] is [true] iff [t] belongs to the Successful class of
status codes. *)
val is_redirection : t -> bool
(** [is_redirection t] is [true] iff [t] belongs to the Redirection class of
status codes. *)
val is_client_error : t -> bool
(** [is_client_error t] is [true] iff [t] belongs to the Client Error class of
status codes. *)
val is_server_error : t -> bool
(** [is_server_error t] is [true] iff [t] belongs to the Server Error class of
status codes. *)
val is_error : t -> bool
(** [is_server_error t] is [true] iff [t] belongs to the Client Error or
Server Error class of status codes. *)
val to_string : t -> string
val of_string : string -> t
val pp_hum : Format.formatter -> t -> unit
end
(** Header Fields
Each header field consists of a lowercase {b field name} and a
{b field value}. Per the HTTP/2 specification, header field names {b must}
be converted to lowercase prior to their encoding in HTTP/2 (see
{{:https://tools.ietf.org/html/rfc7540#section-8.1.2} RFC7540§8.1.2} for
more details). h2 does {b not} convert field names to lowercase; it is
therefore the responsibility of the caller of the functions contained in
this module to use lowercase names for header fields.
The order in which header fields {i with differing field names} are received
is not significant, except for pseudo-header fields, which {b must} appear
in header blocks before regular fields (see
{{:https://tools.ietf.org/html/rfc7540#section-8.1.2.1} RFC7540§8.1.2.1} for
more details).
A sender MUST NOT generate multiple header fields with the same field name
in a message unless either the entire field value for that header field is
defined as a comma-separated list or the header field is a well-known
exception, e.g., [Set-Cookie].
A recipient MAY combine multiple header fields with the same field name into
one "field-name: field-value" pair, without changing the semantics of the
message, by appending each subsequent field value to the combined field
value in order, separated by a comma.
{i The order in which header fields with the same field name are received is
therefore significant to the interpretation of the combined field value};
a proxy MUST NOT change the order of these field values when forwarding a
message.
{i Note.} Unless otherwise specified, all operations preserve header field
order and all reference to equality on names is assumed to be
case-insensitive.
See {{:https://tools.ietf.org/html/rfc7230#section-3.2} RFC7230§3.2} for
more details. *)
module Headers : sig
type t
(** The type of a group of header fields. *)
type name = string
(** The type of a lowercase header name. *)
type value = string
(** The type of a header value. *)
(** {3 Constructor} *)
val empty : t
(** [empty] is the empty collection of header fields. *)
val of_list : (name * value) list -> t
(** [of_list assoc] is a collection of header fields defined by the
association list [assoc]. [of_list] assumes the order of header fields in
[assoc] is the intended transmission order. The following equations should
hold:
- [to_list (of_list lst) = lst]
- [get (of_list [("k", "v1"); ("k", "v2")]) "k" = Some "v2"]. *)
val of_rev_list : (name * value) list -> t
(** [of_list assoc] is a collection of header fields defined by the
association list [assoc]. [of_list] assumes the order of header fields in
[assoc] is the {i reverse} of the intended trasmission order. The
following equations should hold:
- [to_list (of_rev_list lst) = List.rev lst]
- [get (of_rev_list [("k", "v1"); ("k", "v2")]) "k" = Some "v1"]. *)
val to_list : t -> (name * value) list
(** [to_list t] is the association list of header fields contained in [t] in
transmission order. *)
val to_rev_list : t -> (name * value) list
(** [to_rev_list t] is the association list of header fields contained in [t]
in {i reverse} transmission order. *)
val add : t -> ?sensitive:bool -> name -> value -> t
(** [add t ?sensitive name value] is a collection of header fields that is the
same as [t] except with [(name, value)] added at the end of the
trasmission order. Additionally, [sensitive] specifies whether this header
field should not be compressed by HPACK and instead encoded as a
never-indexed literal (see
{{:https://tools.ietf.org/html/rfc7541#section-7.1.3} RFC7541§7.1.3} for
more details).
The following equations should hold:
- [get (add t name value) name = Some value] *)
val add_unless_exists : t -> ?sensitive:bool -> name -> value -> t
(** [add_unless_exists t ?sensitive name value] is a collection of header
fields that is the same as [t] if [t] already inclues [name], and
otherwise is equivalent to [add t ?sensitive name value]. *)
val add_list : t -> (name * value) list -> t
(** [add_list t assoc] is a collection of header fields that is the same as
[t] except with all the header fields in [assoc] added to the end of the
transmission order, in reverse order. *)
val add_multi : t -> (name * value list) list -> t
(** [add_multi t assoc] is the same as
{[
add_list
t
(List.concat_map assoc ~f:(fun (name, values) ->
List.map values ~f:(fun value -> name, value)))
]}
but is implemented more efficiently. For example,
{[
add_multi t [ "name1", [ "x", "y" ]; "name2", [ "p", "q" ] ]
= add_list [ "name1", "x"; "name1", "y"; "name2", "p"; "name2", "q" ]
]} *)
val remove : t -> name -> t
(** [remove t name] is a collection of header fields that contains all the
header fields of [t] except those that have a header-field name that are
equal to [name]. If [t] contains multiple header fields whose name is
[name], they will all be removed. *)
val replace : t -> ?sensitive:bool -> name -> value -> t
(** [replace t ?sensitive name value] is a collection of header fields that is
the same as [t] except with all header fields with a name equal to [name]
removed and replaced with a single header field whose name is [name] and
whose value is [value]. This new header field will appear in the
transmission order where the first occurrence of a header field with a
name matching [name] was found.
If no header field with a name equal to [name] is present in [t], then the
result is simply [t], unchanged. *)
(** {3 Destructors} *)
val mem : t -> name -> bool
(** [mem t name] is [true] iff [t] includes a header field with a name that is
equal to [name]. *)
val get : t -> name -> value option
(** [get t name] returns the last header from [t] with name [name], or [None]
if no such header is present. *)
val get_exn : t -> name -> value
(** [get t name] returns the last header from [t] with name [name], or raises
[Not_found] if no such header is present. *)
val get_multi : t -> name -> value list
(** [get_multi t name] is the list of header values in [t] whose names are
equal to [name]. The returned list is in transmission order. *)
(** {3 Iteration} *)
val iter : f:(name -> value -> unit) -> t -> unit
val fold : f:(name -> value -> 'a -> 'a) -> init:'a -> t -> 'a
(** {3 Utilities} *)
val to_string : t -> string
val pp_hum : Format.formatter -> t -> unit
end
(** {2 Message Body} *)
module Body : sig
module Reader : sig
type t
val schedule_read :
t
-> on_eof:(unit -> unit)
-> on_read:(Bigstringaf.t -> off:int -> len:int -> unit)
-> unit
(** [schedule_read t ~on_eof ~on_read] will setup [on_read] and [on_eof] as
callbacks for when bytes are available in [t] for the application to
consume, or when the input channel has been closed and no further bytes
will be received by the application.
Once either of these callbacks have been called, they become inactive.
The application is responsible for scheduling subsequent reads, either
within the [on_read] callback or by some other mechanism. *)
val close : t -> unit
(** [close t] closes [t], indicating that any subsequent input received
should be discarded. *)
val is_closed : t -> bool
(** [is_closed t] is [true] if {!close} has been called on [t] and [false]
otherwise. A closed [t] may still have pending output. *)
end
module Writer : sig
type t
val write_char : t -> char -> unit
(** [write_char w char] copies [char] into an internal buffer. If possible,
this write will be combined with previous and/or subsequent writes
before transmission. *)
val write_string : t -> ?off:int -> ?len:int -> string -> unit
(** [write_string w ?off ?len str] copies [str] into an internal buffer. If
possible, this write will be combined with previous and/or subsequent
writes before transmission. *)
val write_bigstring : t -> ?off:int -> ?len:int -> Bigstringaf.t -> unit
(** [write_bigstring w ?off ?len bs] copies [bs] into an internal buffer. If
possible, this write will be combined with previous and/or subsequent
writes before transmission. *)
val schedule_bigstring : t -> ?off:int -> ?len:int -> Bigstringaf.t -> unit
(** [schedule_bigstring w ?off ?len bs] schedules [bs] to be transmitted at
the next opportunity without performing a copy. [bs] should not be
modified until a subsequent call to {!flush} has successfully completed. *)
val flush : t -> ([ `Written | `Closed ] -> unit) -> unit
(** [flush t f] makes all bytes in [t] available for writing to the awaiting
output channel. Once those bytes have reached that output channel, [f]
will be called.
The type of the output channel is runtime-dependent, as are guarantees
about whether those packets have been queued for delivery or have
actually been received by the intended recipient. *)
val close : t -> unit
(** [close t] closes [t], causing subsequent write calls to raise. If [t] is
writable, this will cause any pending output to become available to the
output channel. *)
val is_closed : t -> bool
(** [is_closed t] is [true] if {!close} has been called on [t] and [false]
otherwise. A closed [t] may still have pending output. *)
end
end
(** {2 Message Types} *)
(** Request
A client-initiated HTTP message. *)
module Request : sig
type t =
{ meth : Method.t
; target : string
; scheme : string
; headers : Headers.t
}
val create :
?headers:Headers.t (** default is {!Headers.empty} *)
-> scheme:string
-> Method.t
-> string
-> t
(** [create ?headers ~scheme meth target] creates an HTTP request with the
given parameters. In HTTP/2, the [:scheme] pseudo-header field is required
and includes the scheme portion of the target URI. The [headers] parameter
is optional, however clients will want to include the [:authority]
pseudo-header field in most cases. The [:authority] pseudo-header field
includes the authority portion of the target URI, and should be used
instead of the [Host] header field in HTTP/2.
See
{{:https://tools.ietf.org/html/rfc7540#section-8.1.2.3} RFC7540§8.1.2.4}
for more details. *)
val body_length :
t
-> [ `Error of [ `Bad_request ] | `Fixed of int64 | `Unknown ]
(** [body_length t] is the length of the message body accompanying [t].
See {{:https://tools.ietf.org/html/rfc7230#section-3.3.3} RFC7230§3.3.3}
for more details. *)
val pp_hum : Format.formatter -> t -> unit
end
(** Response
A server-generated message to a {!Request.t}. *)
module Response : sig
type t =
{ status : Status.t
; headers : Headers.t
}
val create :
?headers:Headers.t (** default is {!Headers.empty} *)
-> Status.t
-> t
(** [create ?headers status] creates an HTTP response with the given
parameters. Unlike the [Response] type in httpun, h2 does not define a way
for responses to carry reason phrases or protocol version.
See
{{:https://tools.ietf.org/html/rfc7540#section-8.1.2.4} RFC7540§8.1.2.4}
for more details. *)
val body_length :
request_method:Method.standard
-> t
-> [ `Error of [ `Bad_request ] | `Fixed of int64 | `Unknown ]
(** [body_length ~request_method t] is the length of the message body
accompanying [t] assuming it is a response to a request whose method was
[request_method].
See {{:https://tools.ietf.org/html/rfc7230#section-3.3.3} RFC7230§3.3.3}
for more details. *)
val pp_hum : Format.formatter -> t -> unit
end
module IOVec : module type of Httpun_types.IOVec
(** IOVec *)
(** {2 Request Descriptor} *)
module Reqd : sig
type error =
[ `Bad_request
| `Internal_server_error
| `Exn of exn
]
type t
val request : t -> Request.t
val request_body : t -> Body.Reader.t
val response : t -> Response.t option
val response_exn : t -> Response.t
(** {3 Responding}
The following functions will initiate a response for the corresponding
request in [t]. When the response is fully transmitted to the wire, the
stream completes.
From {{:https://tools.ietf.org/html/rfc7540#section-8.1} RFC7540§8.1}: An
HTTP request/response exchange fully consumes a single stream. *)
val respond_with_string : t -> Response.t -> string -> unit
val respond_with_bigstring : t -> Response.t -> Bigstringaf.t -> unit
val respond_with_streaming :
t
-> ?flush_headers_immediately:bool
-> Response.t
-> Body.Writer.t
val schedule_trailers : t -> Headers.t -> unit
(** [schedule_trailers reqd trailers] schedules a list of trailers to be sent
before the stream is closed, concluding the HTTP message. Should only be
used after {!respond_with_streaming}. Raises [Failure] if trailers have
already been scheduled. See
{{:https://tools.ietf.org/html/rfc7540#section-8.1} RFC7540§8.1} for more
information *)
(** {3 Pushing}
HTTP/2 allows a server to pre-emptively send (or "push") responses (along
with corresponding "promised" requests) to a client in association with a
previous client-initiated request. This can be useful when the server
knows the client will need to have those responses available in order to
fully process the response to the original request.
{4 {b An additional note regarding server push:}}
In HTTP/2, PUSH_PROMISE frames must only be sent in the open or
half-closed ("remote") stream states. In practice, this means that calling
{!Reqd.push} must happen before the entire response body for the
associated client-initiated request has been written to the wire. As such,
it is dangerous to start a server pushed response in association with
either {!Reqd.respond_with_string} or {!Reqd.respond_with_bigstring}, as
the entire body for the response that they produce is sent to the output
channel immediately, causing the corresponding stream to enter the closed
state.
See {{:https://tools.ietf.org/html/rfc7540#section-8.2} RFC7540§8.2} for
more details. *)
val push :
t
-> Request.t
-> ( t
, [ `Push_disabled | `Stream_cant_push | `Stream_ids_exhausted ] )
result
(** [push reqd request] creates a new ("pushed") request descriptor that
allows responding to the "promised" [request]. As per the HTTP/2
specification, [request] must be cacheable, safe, and must not include a
request body (see
{{:https://tools.ietf.org/html/rfc7540.html#section-8.2} RFC7540§8.2} for
more details). {b Note}: h2 will not validate [request] against these
assumptions.
This function returns [Error `Push_disabled] when the value of
[SETTINGS_ENABLE_PUSH] is set to [0] (see
{{:https://tools.ietf.org/html/rfc7540.html#section-6.5.2} RFC7540§8.2}
for more details), [Error `Stream_cant_push] when trying to initiate a
push stream from a stream that has been obtained from pushing, or
[Error `Stream_ids_exhausted] when the connection has exhausted the range
of identifiers available for pushed streams and cannot push on that
connection anymore. *)
(** {3 Exception Handling} *)
val error_code : t -> error option
val report_exn : t -> exn -> unit
val try_with : t -> (unit -> unit) -> (unit, exn) result
end
(** {2 Errors} *)
module Error_code : sig
type t =
(* From RFC7540§7:
* NO_ERROR (0x0): The associated condition is not a result of an
* error. *)
| NoError
(* From RFC7540§7:
* PROTOCOL_ERROR (0x1): The endpoint detected an unspecific protocol
* error. This error is for use when a more specific error code is not
* available. *)
| ProtocolError
(* From RFC7540§7:
* INTERNAL_ERROR (0x2): The endpoint encountered an unexpected internal
* error. *)
| InternalError
(* From RFC7540§7:
* FLOW_CONTROL_ERROR (0x3): The endpoint detected that its peer violated
* the flow-control protocol. *)
| FlowControlError
(* From RFC7540§7:
* SETTINGS_TIMEOUT (0x4): The endpoint sent a SETTINGS frame but did not
* receive a response in a timely manner. *)
| SettingsTimeout
(* From RFC7540§7:
* STREAM_CLOSED (0x5): The endpoint received a frame after a stream was
* half-closed. *)
| StreamClosed
(* From RFC7540§7:
* FRAME_SIZE_ERROR (0x6): The endpoint received a frame with an invalid
* size. *)
| FrameSizeError
(* From RFC7540§7:
* REFUSED_STREAM (0x7): The endpoint refused the stream prior to
* performing any application processing (see Section 8.1.4 for
* details). *)
| RefusedStream
(* From RFC7540§7:
* CANCEL (0x8): Used by the endpoint to indicate that the stream is no
* longer needed. *)
| Cancel
(* From RFC7540§7:
* COMPRESSION_ERROR (0x9): The endpoint is unable to maintain the header
* compression context for the connection. *)
| CompressionError
(* From RFC7540§7:
* CONNECT_ERROR (0xa): The connection established in response to a
* CONNECT request (Section 8.3) was reset or abnormally closed. *)
| ConnectError
(* From RFC7540§7:
* ENHANCE_YOUR_CALM (0xb): The endpoint detected that its peer is
* exhibiting a behavior that might be generating excessive load. *)
| EnhanceYourCalm
(* From RFC7540§7:
* INADEQUATE_SECURITY (0xc): The underlying transport has properties
* that do not meet minimum security requirements (see Section 9.2). *)
| InadequateSecurity
(* From RFC7540§7:
* HTTP_1_1_REQUIRED (0xd): The endpoint requires that HTTP/1.1 be used
* instead of HTTP/2. *)
| HTTP_1_1_Required
(* From RFC7540§7:
* Unknown or unsupported error codes MUST NOT trigger any special
* behavior. These MAY be treated by an implementation as being
* equivalent to INTERNAL_ERROR. *)
| UnknownError_code of int32
val to_string : t -> string
val pp_hum : Format.formatter -> t -> unit
end
(* TODO: needs docs *)
module Settings : sig
type t =
{ header_table_size : int
; enable_push : bool
; max_concurrent_streams : int32
; initial_window_size : int32
; max_frame_size : int
; max_header_list_size : int option
}
val default : t
val of_base64 : string -> (t, string) result
(** {{:https://tools.ietf.org/html/rfc7540#section-3.2.1} RFC7540§3.2.1} *)
val to_base64 : t -> (string, string) result
(** {{:https://tools.ietf.org/html/rfc7540#section-3.2.1} RFC7540§3.2.1} *)
val pp_hum : Format.formatter -> t -> unit
end
(** {2 HTTP/2 Configuration} *)
module Config : sig
type t =
{ read_buffer_size : int
(** [read_buffer_size] specifies the size of the largest frame payload that
the sender is willing to receive, in octets. Defaults to [16384] *)
; request_body_buffer_size : int (** Defaults to [4096] *)
; response_body_buffer_size : int (** Defaults to [4096] *)
; enable_server_push : bool (** Defaults to [true] *)
; max_concurrent_streams : int32
(** [max_concurrent_streams] specifies the maximum number of streams that
the sender will allow the peer to initiate. Defaults to [2^31 - 1] *)
; initial_window_size : int32
(** [initial_window_size] specifies the initial window size for flow control
tokens. Defaults to [65535] *)
}
val default : t
(** [default] is a configuration record with all parameters set to their
default values. *)
val to_settings : t -> Settings.t
end
(** {2 Server Connection} *)
module Server_connection : sig
type t
type error =
[ `Bad_request
| `Internal_server_error
| `Exn of exn
]
type request_handler = Reqd.t -> unit
type error_handler =
?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit
val create :
?config:Config.t
-> ?error_handler:error_handler
-> request_handler
-> t
(** [create ?config ?error_handler ~request_handler] creates a connection
handler that will service individual requests with [request_handler]. *)
val create_h2c :
?config:Config.t
-> ?error_handler:error_handler
-> headers:Httpun_types.Headers.t
-> target:string
-> meth:Httpun_types.Method.t
-> ?request_body:Bigstringaf.t IOVec.t list
-> request_handler
-> (t, string) result
(** [create ?config ?error_handler ~http_request ~request_handler] creates a
connection handler that will take over the communication channel from a
HTTP/1.1 connection, and service individual HTTP/2.0 requests with
[request_handler]. Upon successful creation, it returns the connection,
otherwise an error message is returned with an explanation of the failure
that caused the connection setup to not succeed.
This function is intended to be used in HTTP/1.1 upgrade handlers to set
up a new [h2c] (HTTP/2.0 over TCP) connection without prior knowledge.
See {{:https://tools.ietf.org/html/rfc7540#section-3.2} RFC7540§3.2} for
more details. *)
val next_read_operation : t -> [> `Read | `Close ]
(** [next_read_operation t] returns a value describing the next operation that
the caller should conduct on behalf of the connection. *)
val read : t -> Bigstringaf.t -> off:int -> len:int -> int
(** [read t bigstring ~off ~len] reads bytes of input from the provided range
of [bigstring] and returns the number of bytes consumed by the connection.
{!read} should be called after {!next_read_operation} returns a [`Read]
value and additional input is available for the connection to consume. *)
val read_eof : t -> Bigstringaf.t -> off:int -> len:int -> int
(** [read t bigstring ~off ~len] reads bytes of input from the provided range
of [bigstring] and returns the number of bytes consumed by the connection.
{!read} should be called after {!next_read_operation} returns a [`Read]
and an EOF has been received from the communication channel. The
connection will attempt to consume any buffered input and then shutdown
the HTTP parser for the connection. *)
val next_write_operation :
t
-> [ `Write of Bigstringaf.t IOVec.t list | `Yield | `Close of int ]
(** [next_write_operation t] returns a value describing the next operation
that the caller should conduct on behalf of the connection. *)
val report_write_result : t -> [ `Ok of int | `Closed ] -> unit
(** [report_write_result t result] reports the result of the latest write
attempt to the connection. {!report_write_result} should be called after a
call to {!next_write_operation} that returns a [`Write buffer] value.
- [`Ok n] indicates that the caller successfully wrote [n] bytes of output
from the buffer that the caller was provided by {!next_write_operation}.
- [`Closed] indicates that the output destination will no longer accept
bytes from the write processor. *)
val yield_writer : t -> (unit -> unit) -> unit
(** [yield_writer t continue] registers with the connection to call [continue]
when writing should resume. {!yield_writer} should be called after
{!next_write_operation} returns a [`Yield] value. *)
val yield_reader : t -> (unit -> unit) -> unit
(** [yield_reader t continue] immediately calls [continue]. This function *
shouldn't generally be called and it's only here to simplify adhering * to
the Gluten [RUNTIME] module type. *)
val report_exn : t -> exn -> unit
(** [report_exn t exn] reports that an error [exn] has been caught and that it
has been attributed to [t]. Calling this function will switch [t] into an
error state. Depending on the state [t] is transitioning from, it may call
its error handler before terminating the connection. *)
val is_closed : t -> bool
(** [is_closed t] is [true] if both the read and write processors have been
shutdown. When this is the case {!next_read_operation} will return
[`Close _] and {!next_write_operation} will do the same will return a
[`Write _] until all buffered output has been flushed, at which point it
will return [`Close]. *)
(* val error_code : t -> error option *)
(** [error_code t] returns the [error_code] that caused the connection to
close, if one exists. *)
(**/**)
val shutdown : t -> unit
(**/**)
end
(** {2 Client Connection} *)
module Client_connection : sig
type t
type error =
[ `Malformed_response of string
| `Invalid_response_body_length of Response.t
| `Protocol_error of Error_code.t * string
| `Exn of exn
]
type trailers_handler = Headers.t -> unit
type response_handler = Response.t -> Body.Reader.t -> unit
type error_handler = error -> unit
val create :
?config:Config.t
-> ?push_handler:(Request.t -> (response_handler, unit) result)
-> error_handler:error_handler
-> unit
-> t
(** [create ?config ?push_handler ~error_handler] creates a connection that
can be used to interact with servers over the HTTP/2 protocol.
[error_handler] will be called for {e connection-level} errors. HTTP/2 is
multiplexed over a single TCP connection and distinguishes
connection-level errors from stream-level errors. See See
{{:https://tools.ietf.org/html/rfc7540#section-5.4} RFC7540§5.4} for more
details.
If present, [push_handler] will be called upon the receipt of PUSH_PROMISE
frames with the request promised by the server. This function should
return [Ok response_handler] if the client wishes to accept the pushed
request. In this case, [response_handler] will be called once the server
respondes to the pushed request. Returning [Error ()] will signal to h2
that the client is choosing to reject the request that the server is
pushing, and its stream will be closed, as per the following excerpt from
the HTTP/2 specification:
From RFC7540§6.6: Recipients of PUSH_PROMISE frames can choose to reject
promised streams by returning a RST_STREAM referencing the promised stream
identifier back to the sender of the PUSH_PROMISE. *)
val create_h2c :
?config:Config.t
-> ?push_handler:(Request.t -> (response_handler, unit) result)
-> headers:Httpun_types.Headers.t
-> target:string
-> meth:Httpun_types.Method.t
-> error_handler:error_handler
-> response_handler * error_handler
-> (t, string) result
val request :
t
-> ?flush_headers_immediately:bool
-> ?trailers_handler:trailers_handler
-> Request.t
-> error_handler:error_handler
-> response_handler:response_handler
-> Body.Writer.t
(** [request connection ?trailers_handler req ~error_handler
~response_handler]
opens a new HTTP/2 stream with [req] and returns a request body that can
be written to. Once a response arrives, [response_handler] will be called
with its headers and body. [error_handler] will be called for
{e stream-level} errors. If there are any trailers they will be parsed and
passed to [trailers_handler].
HTTP/2 is multiplexed over a single TCP connection and distinguishes
connection-level errors from stream-level errors. See
{{:https://tools.ietf.org/html/rfc7540#section-5.4} RFC7540§5.4} for more
details. *)
val ping :
t
-> ?payload:Bigstringaf.t
-> ?off:int
-> ((unit, [ `EOF ]) result -> unit)
-> unit
(** [ping connection ?payload ?off f] sends an HTTP/2 PING frame and registers
[f] to be called when the server has sent an acknowledgement for it. A
custom [payload] (and offset into that payload) for the PING frame may
also be provided. If not, a payload with all bytes set to zero will be
used. Note that a PING frame's payload {b must} be 8 octets in length.
In HTTP/2, the PING frame is a mechanism for measuring a minimal
round-trip time from the sender, as well as determining whether an idle
connection is still functional. See
{{:https://tools.ietf.org/html/rfc7540#section-5.4} RFC7540§5.4} for more
details. *)
val shutdown : t -> unit
(** [shutdown connection] initiates the graceful shutdown of [connection], and
sends an HTTP/2 GOAWAY frame with NO_ERROR on the output channel (See
{{:https://tools.ietf.org/html/rfc7540#section-6.8} RFC7540§6.8} for more
details). *)
val next_read_operation : t -> [> `Read | `Close ]
(** [next_read_operation t] returns a value describing the next operation that
the caller should conduct on behalf of the connection. *)
val read : t -> Bigstringaf.t -> off:int -> len:int -> int
(** [read t bigstring ~off ~len] reads bytes of input from the provided range
of [bigstring] and returns the number of bytes consumed by the connection.
{!read} should be called after {!next_read_operation} returns a [`Read]
value and additional input is available for the connection to consume. *)
val read_eof : t -> Bigstringaf.t -> off:int -> len:int -> int
(** [read t bigstring ~off ~len] reads bytes of input from the provided range
of [bigstring] and returns the number of bytes consumed by the connection.
{!read} should be called after {!next_read_operation} returns a [`Read]
and an EOF has been received from the communication channel. The
connection will attempt to consume any buffered input and then shutdown
the HTTP parser for the connection. *)
val next_write_operation :
t
-> [ `Write of Bigstringaf.t IOVec.t list | `Yield | `Close of int ]
(** [next_write_operation t] returns a value describing the next operation
that the caller should conduct on behalf of the connection. *)
val report_write_result : t -> [ `Ok of int | `Closed ] -> unit
(** [report_write_result t result] reports the result of the latest write
attempt to the connection. {!report_write_result} should be called after a
call to {!next_write_operation} that returns a [`Write buffer] value.
- [`Ok n] indicates that the caller successfully wrote [n] bytes of output
from the buffer that the caller was provided by {!next_write_operation}.
- [`Closed] indicates that the output destination will no longer accept
bytes from the write processor. *)
val yield_writer : t -> (unit -> unit) -> unit
(** [yield_writer t continue] registers with the connection to call [continue]
when writing should resume. {!yield_writer} should be called after
{!next_write_operation} returns a [`Yield] value. *)
val yield_reader : t -> (unit -> unit) -> unit
(** [yield_reader t continue] immediately calls [continue]. This function *
shouldn't generally be called and it's only here to simplify adhering * to
the Gluten [RUNTIME] module type. *)
val report_exn : t -> exn -> unit
(** [report_exn t exn] reports that an error [exn] has been caught and that it
has been attributed to [t]. Calling this function will switch [t] into an
error state. Depending on the state [t] is transitioning from, it may call
its (connection-level) error handler before terminating the connection. *)
val is_closed : t -> bool
(** [is_closed t] is [true] if both the read and write processors have been
shutdown. When this is the case {!next_read_operation} will return
[`Close _] and {!next_write_operation} will do the same will return a
[`Write _] until all buffered output has been flushed, at which point it
will return [`Close]. *)
end

363
unikernel/duniverse/ocaml-h2/lib/headers.ml Normal file
View file

@ -0,0 +1,363 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2017 Inhabited Type LLC.
* Copyright (c) 2019 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
type name = string
type value = string
type header = Hpack.header =
{ name : name
; value : value
; sensitive : bool
}
type t = header list
let empty : t = []
let of_rev_list hs =
List.map (fun (name, value) -> { name; value; sensitive = false }) hs
let of_list t = of_rev_list (List.rev t)
let to_rev_list t = List.map (fun { name; value; _ } -> name, value) t
let to_list t = List.rev (to_rev_list t)
let to_hpack_list t = List.rev t
exception Local
module CI = struct
let char_is_upper c = c >= 0x41 && c <= 0x5a
let lower c = if char_is_upper c then c + 32 else c
let equal x y =
let len = String.length x in
len = String.length y
&&
match
for i = 0 to len - 1 do
let c1 = Char.code (String.unsafe_get x i) in
let c2 = Char.code (String.unsafe_get y i) in
if c1 = c2 then () else if lower c1 <> lower c2 then raise Local
done
with
| () -> true
| exception Local -> false
let is_lowercase x =
let len = String.length x in
match
for i = 0 to len - 1 do
let c1 = Char.code (String.unsafe_get x i) in
if char_is_upper c1 then raise Local else ()
done
with
| () -> true
| exception Local -> false
end
let rec mem t name =
match t with
| { name = name'; _ } :: t' -> CI.equal name name' || mem t' name
| _ -> false
(* TODO: do we need to keep a list of never indexed fields? *)
let add t ?(sensitive = false) name value = { name; value; sensitive } :: t
let add_list t ls = of_rev_list ls @ t (* XXX(seliopou): do better here *)
let add_multi =
let rec loop_outer t lss =
match lss with [] -> t | (n, vs) :: lss' -> loop_inner t n vs lss'
and loop_inner t n vs lss =
match vs with
| [] -> loop_outer t lss
| v :: vs' ->
loop_inner ({ name = n; value = v; sensitive = false } :: t) n vs' lss
in
loop_outer
let add_unless_exists t ?(sensitive = false) name value =
if mem t name then t else { name; value; sensitive } :: t
let replace t ?(sensitive = false) name value =
let rec loop t n nv seen =
match t with
| [] -> if not seen then raise Local else []
| ({ name = n'; _ } as nv') :: t ->
if CI.equal n n'
then if seen then loop t n nv true else nv :: loop t n nv true
else nv' :: loop t n nv seen
in
try loop t name { name; value; sensitive } false with Local -> t
let remove t name =
let rec loop s n seen =
match s with
| [] -> if not seen then raise Local else []
| ({ name = n'; _ } as nv') :: s' ->
if CI.equal n n' then loop s' n true else nv' :: loop s' n seen
in
try loop t name false with Local -> t
let get t name =
let rec loop t n =
match t with
| [] -> None
| { name = n'; value; _ } :: t' ->
if CI.equal n n' then Some value else loop t' n
in
loop t name
let get_exn t name =
let rec loop t =
match t with
| [] -> raise Not_found
| { name = n; value; _ } :: t' -> if CI.equal name n then value else loop t'
in
loop t
let get_pseudo t name = get t (":" ^ name)
let get_pseudo_exn t name = get_exn t (":" ^ name)
let get_multi t name =
let rec loop t acc =
match t with
| [] -> acc
| { name = n; value; _ } :: t' ->
if CI.equal name n then loop t' (value :: acc) else loop t' acc
in
loop t []
let get_multi_pseudo t name = get_multi t (":" ^ name)
module Pseudo = struct
let reserved_request = [ ":method"; ":scheme"; ":authority"; ":path" ]
let reserved_response = [ ":status" ]
(* 0x3A is the char code for `:` *)
let is_pseudo name = Char.code (String.unsafe_get name 0) = 0x3A
end
let iter ~f t = List.iter (fun { name; value; _ } -> f name value) t
let fold ~f ~init t =
List.fold_left (fun acc { name; value; _ } -> f name value acc) init t
let exists ~f t = List.exists (fun { name; value; _ } -> f name value) t
let valid_headers ?(is_request = true) t =
match get t "connection", get t "TE" with
| Some _, _ ->
(* From RFC7540§8.1.2.2:
* HTTP/2 does not use the Connection header field to indicate
* connection-specific header fields; in this protocol,
* connection-specific metadata is conveyed by other means. An endpoint
* MUST NOT generate an HTTP/2 message containing connection-specific
* header fields; any message containing connection-specific header
* fields MUST be treated as malformed (Section 8.1.2.6). *)
false
| _, Some value when value <> "trailers" ->
(* From RFC7540§8.1.2.2:
* The only exception to this is the TE header field, which MAY be
* present in an HTTP/2 request; when it is, it MUST NOT contain any
* value other than "trailers". *)
false
| _ ->
let pseudo_ended = ref false in
let invalid =
exists
~f:(fun name _ ->
let is_pseudo = Pseudo.is_pseudo name in
let pseudo_did_end = !pseudo_ended in
if (not is_pseudo) && not pseudo_did_end then pseudo_ended := true;
(* From RFC7540§8.1.2:
* [...] header field names MUST be converted to lowercase
* prior to their encoding in HTTP/2. A request or response
* containing uppercase header field names MUST be treated as
* malformed (Section 8.1.2.6). *)
(not CI.(is_lowercase name))
(* From RFC7540§8.1.2.1:
* Pseudo-header fields are only valid in the context in
* which they are defined. [...] pseudo-header fields defined
* for responses MUST NOT appear in requests. [...] Endpoints
* MUST treat a request or response that contains undefined
* or invalid pseudo-header fields as malformed (Section
* 8.1.2.6). *)
|| (is_pseudo
&& not
(List.mem
name
(if is_request
then Pseudo.reserved_request
else Pseudo.reserved_response)))
|| (* From RFC7540§8.1.2.1:
* All pseudo-header fields MUST appear in the header block before
* regular header fields. Any request or response that contains a
* pseudo-header field that appears in a header block after a
* regular header field MUST be treated as malformed (Section
* 8.1.2.6). *)
(is_pseudo && pseudo_did_end))
(to_hpack_list t)
in
not invalid
let valid_request_headers t = valid_headers t
let valid_response_headers t = valid_headers ~is_request:false t
let method_path_and_scheme_or_malformed t =
match
( get_multi_pseudo t "method"
, get_multi_pseudo t "scheme"
, get_multi_pseudo t "path" )
with
| _, [ ("http" | "https") ], [ path ] when String.length path = 0 ->
(* From RFC7540§8.1.2.6:
* This pseudo-header field MUST NOT be empty for http or https URIs;
* http or https URIs that do not contain a path component MUST include a
* value of '/'. *)
`Malformed
(* From RFC7540§8.1.2.3:
* All HTTP/2 requests MUST include exactly one valid value for the
* :method, :scheme, and :path pseudo-header fields, unless it is a
* CONNECT request (Section 8.3). *)
| [ ("CONNECT" as meth) ], [], [] ->
(* From RFC7540§8.3:
* The HTTP header field mapping works as defined in Section 8.1.2.3
* ("Request Pseudo-Header Fields"), with a few differences.
* Specifically:
*
* - The :method pseudo-header field is set to CONNECT.
* - The :scheme and :path pseudo-header fields MUST be omitted.
* - The :authority pseudo-header field contains the host and port to
* connect to (equivalent to the authority-form of the request-target
* of CONNECT requests (see [RFC7230], Section 5.3)).
*
* A CONNECT request that does not conform to these restrictions is
* malformed (Section 8.1.2.6). *)
if mem t ":authority" then `Valid (meth, "", "") else `Malformed
| [ "CONNECT" ], _, _ -> `Malformed
| [ meth ], [ scheme ], [ path ] ->
if valid_request_headers t then `Valid (meth, path, scheme) else `Malformed
| _ -> `Malformed
let trailers_valid t =
let invalid =
exists
~f:(fun name _ ->
(* From RFC7540§8.1.2:
* [...] header field names MUST be converted to lowercase prior to
* their encoding in HTTP/2. A request or response containing
* uppercase header field names MUST be treated as malformed
* (Section 8.1.2.6). *)
(not (CI.is_lowercase name))
|| (* From RFC7540§8.1.2.1:
* Pseudo-header fields MUST NOT appear in trailers. Endpoints MUST
* treat a request or response that contains undefined or invalid
* pseudo-header fields as malformed (Section 8.1.2.6). *)
Pseudo.is_pseudo name)
t
in
not invalid
let is_valid_h2c_connection connection =
let values = String.split_on_char ',' connection in
let values = List.map String.trim values in
(* From RFC7540§3.2.1:
* [...] Since the upgrade is only intended to apply to the immediate
* connection, a client sending the HTTP2-Settings header field MUST also
* send HTTP2-Settings as a connection option in the Connection header
* field to prevent it from being forwarded (see Section 6.1 of [RFC7230]).
*)
match
( List.find_opt (fun x -> CI.equal x "upgrade") values
, List.find_opt (fun x -> CI.equal x "http2-settings") values )
with
| Some _, Some _ -> true
| _ -> false
let of_http1 ~headers ~meth ~target =
let module Headers = Httpun_types.Headers in
match Headers.get headers "host" with
| Some host ->
(* From RFC7540§8.1.2.3:
* Clients that generate HTTP/2 requests directly SHOULD use the
* :authority pseudo-header field instead of the Host header field. *)
let headers =
Headers.fold
~f:(fun name value acc ->
if CI.equal name "host" || CI.equal name "connection"
then
(* From RFC7540§8.1.2.2:
* HTTP/2 does not use the Connection header field to indicate
* connection-specific header fields; in this protocol,
* connection-specific metadata is conveyed by other means. An
* endpoint MUST NOT generate an HTTP/2 message containing
* connection-specific header fields; any message containing
* connection-specific header fields MUST be treated as malformed
* (Section 8.1.2.6). *)
acc
else
let name =
(* From RFC7540§8.1.2:
* header field names MUST be converted to lowercase prior to
* their encoding in HTTP/2. *)
if CI.is_lowercase name then name else String.lowercase_ascii name
in
(name, value) :: acc)
~init:
[ ":authority", host
; ":method", Httpun_types.Method.to_string meth
; ":path", target
; ":scheme", "https"
]
headers
in
Ok (of_rev_list headers)
| None -> Error "Missing `Host` header field"
let to_string t =
let b = Buffer.create 128 in
List.iter
(fun (name, value) ->
Buffer.add_string b name;
Buffer.add_string b ": ";
Buffer.add_string b value;
Buffer.add_string b "\r\n")
(to_list t);
Buffer.add_string b "\r\n";
Buffer.contents b
let pp_hum fmt t =
let pp_elem fmt (name, value) = Format.fprintf fmt "@[(%S %S)@]" name value in
Format.fprintf fmt "@[(";
Format.pp_print_list pp_elem fmt (to_list t);
Format.fprintf fmt ")@]"

53
unikernel/duniverse/ocaml-h2/lib/message.ml Normal file
View file

@ -0,0 +1,53 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2017 Inhabited Type LLC.
* Copyright (c) 2019 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
(* This module contains functionality that applies to both requests and
* responses, which are collectively referred to in the HTTP 1.1 specifications
* as 'messages'. *)
let content_length_of_string s =
match Int64.of_string s with
| len when Int64.compare len 0L >= 0 -> `Fixed len
| _ | (exception _) -> `Error `Bad_request
let body_length headers =
match Headers.get_multi headers "content-length" with
| [] -> `Unknown
| [ x ] -> content_length_of_string x
| hd :: tl ->
(* if there are multiple content-length headers we require them all to be
* exactly equal. *)
if List.for_all (String.equal hd) tl
then content_length_of_string hd
else `Unknown

49
unikernel/duniverse/ocaml-h2/lib/optional_thunk.ml Normal file
View file

@ -0,0 +1,49 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2020 Inhabited Type LLC.
* Copyright (c) 2020 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
type t = unit -> unit
let none = Sys.opaque_identity (fun () -> ())
let some f =
if f == none
then
failwith
"Optional_thunk: this function is not representable as a some value";
f
let is_none t = t == none
let is_some t = not (is_none t)
let call_if_some t = t ()
let unchecked_value t = t

42
unikernel/duniverse/ocaml-h2/lib/optional_thunk.mli Normal file
View file

@ -0,0 +1,42 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2020 Inhabited Type LLC.
* Copyright (c) 2020 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
type t
val none : t
val some : (unit -> unit) -> t
val is_none : t -> bool
val is_some : t -> bool
val call_if_some : t -> unit
val unchecked_value : t -> unit -> unit

711
unikernel/duniverse/ocaml-h2/lib/parse.ml Normal file
View file

@ -0,0 +1,711 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2017 Inhabited Type LLC.
* Copyright (c) 2019 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
open Angstrom
(* We use the tail-recursive variant of `skip_many` from
* https://github.com/inhabitedtype/angstrom/pull/219 to avoid memory leaks in
* long-running connections. The original `skip_many` can build up a list of
* error handlers that may never be released. *)
let skip_many p =
fix (fun m ->
p >>| (fun _ -> true) <|> return false >>= function
| true -> m
| false -> return ())
let default_frame_header =
{ Frame.payload_length = 0
; flags = Flags.default_flags
; stream_id = -1l
; frame_type = Unknown (-1)
}
type parse_context =
{ mutable frame_header : Frame.frame_header
; mutable remaining_bytes_to_skip : int
; mutable did_report_stream_error : bool
; (* TODO: This should change as new settings frames arrive, but we don't yet
* resize the read buffer. *)
max_frame_size : int
}
let connection_error error_code msg =
Error Error.(ConnectionError (error_code, msg))
let stream_error error_code stream_id =
Error Error.(StreamError (stream_id, error_code))
let parse_uint24 o1 o2 o3 = (o1 lsl 16) lor (o2 lsl 8) lor o3
let frame_length =
(* From RFC7540§4.1:
* Length: The length of the frame payload expressed as an unsigned 24-bit
* integer. *)
lift3 parse_uint24 any_uint8 any_uint8 any_uint8
let frame_type =
(* From RFC7540§4.1:
* Type: The 8-bit type of the frame. The frame type determines the format
* and semantics of the frame. Implementations MUST ignore and discard any
* frame that has a type that is unknown. *)
lift Frame.FrameType.parse any_uint8
let flags =
(* From RFC7540§4.1:
* Flags: An 8-bit field reserved for boolean flags specific to the frame
* type. *)
any_uint8
let parse_stream_identifier n =
(* From RFC7540§4.1:
* Stream Identifier: A stream identifier (see Section 5.1.1) expressed as
* an unsigned 31-bit integer. The value 0x0 is reserved for frames that
* are associated with the connection as a whole as opposed to an
* individual stream. *)
Int32.(logand n (sub (shift_left 1l 31) 1l))
let stream_identifier = lift parse_stream_identifier BE.any_int32
let parse_frame_header =
lift4
(fun payload_length frame_type flags stream_id ->
{ Frame.flags; payload_length; stream_id; frame_type })
frame_length
frame_type
flags
stream_identifier
<?> "frame_header"
(* The parser commits after parsing the frame header so that the entire
* underlying buffer can be used to store the payload length. This matters
* because the size of the buffer that gets allocated is the maximum frame
* payload negotiated by the HTTP/2 settings synchronization. The 9 octets
* that make up the frame header are, therefore, very important in order for
* h2 not to return a FRAME_SIZE_ERROR. *)
<* commit
let parse_padded_payload { Frame.payload_length; flags; _ } parser =
if Flags.test_padded flags
then
any_uint8 >>= fun pad_length ->
(* From RFC7540§6.1:
* Pad Length: An 8-bit field containing the length of the frame
* padding in units of octets.
*
* Data: Application data. The amount of data is the remainder of the
* frame payload after subtracting the length of the other fields that
* are present.
*
* Padding: Padding octets that contain no application semantic
* value. *)
if pad_length >= payload_length
then
(* From RFC7540§6.1:
* If the length of the padding is the length of the frame payload or
* greater, the recipient MUST treat this as a connection error
* (Section 5.4.1) of type PROTOCOL_ERROR. *)
advance (payload_length - 1) >>| fun () ->
connection_error ProtocolError "Padding size exceeds payload size"
else
(* Subtract the octet that contains the length of padding, and the
* padding octets. *)
let relevant_length = payload_length - 1 - pad_length in
parser relevant_length <* advance pad_length
else parser payload_length
let parse_data_frame ({ Frame.stream_id; payload_length; _ } as frame_header) =
if Stream_identifier.is_connection stream_id
then
(* From RFC7540§6.1:
* DATA frames MUST be associated with a stream. If a DATA frame is
* received whose stream identifier field is 0x0, the recipient MUST
* respond with a connection error (Section 5.4.1) of type
* PROTOCOL_ERROR. *)
advance payload_length >>| fun () ->
connection_error
ProtocolError
"Data frames must be associated with a stream"
else
let parse_data length =
lift (fun bs -> Ok (Frame.Data bs)) (take_bigstring length)
in
parse_padded_payload frame_header parse_data
let parse_priority =
lift2
(fun stream_dependency weight ->
let e = Priority.test_exclusive stream_dependency in
{ Priority.exclusive =
e
(* From RFC7540§6.3:
* An unsigned 8-bit integer representing a priority weight for the
* stream (see Section 5.3). Add one to the value to obtain a
* weight between 1 and 256. *)
; weight = weight + 1
; stream_dependency = parse_stream_identifier stream_dependency
})
BE.any_int32
any_uint8
let parse_headers_frame frame_header =
let { Frame.payload_length; stream_id; flags; _ } = frame_header in
if Stream_identifier.is_connection stream_id
then
(* From RFC7540§6.2:
* HEADERS frames MUST be associated with a stream. If a HEADERS frame is
* received whose stream identifier field is 0x0, the recipient MUST
* respond with a connection error (Section 5.4.1) of type
* PROTOCOL_ERROR. *)
advance payload_length >>| fun () ->
connection_error ProtocolError "HEADERS must be associated with a stream"
else
let parse_headers length =
if Flags.test_priority flags
then
lift2
(fun priority headers -> Ok (Frame.Headers (priority, headers)))
parse_priority
(* See RFC7540§6.3:
* Stream Dependency (4 octets) + Weight (1 octet). *)
(take_bigstring (length - 5))
else
lift
(fun headers_block ->
Ok (Frame.Headers (Priority.default_priority, headers_block)))
(take_bigstring length)
in
parse_padded_payload frame_header parse_headers
let parse_priority_frame { Frame.payload_length; stream_id; _ } =
if Stream_identifier.is_connection stream_id
then
(* From RFC7540§6.3:
* The PRIORITY frame always identifies a stream. If a PRIORITY frame is
* received with a stream identifier of 0x0, the recipient MUST respond
* with a connection error (Section 5.4.1) of type PROTOCOL_ERROR. *)
advance payload_length >>| fun () ->
connection_error ProtocolError "PRIORITY must be associated with a stream"
else if payload_length <> 5
then
(* From RFC7540§6.3:
* A PRIORITY frame with a length other than 5 octets MUST be treated as
* a stream error (Section 5.4.2) of type FRAME_SIZE_ERROR. *)
advance payload_length >>| fun () -> stream_error FrameSizeError stream_id
else lift (fun priority -> Ok (Frame.Priority priority)) parse_priority
let parse_error_code = lift Error_code.parse BE.any_int32
let parse_rst_stream_frame { Frame.payload_length; stream_id; _ } =
if Stream_identifier.is_connection stream_id
then
(* From RFC7540§6.4:
* RST_STREAM frames MUST be associated with a stream. If a RST_STREAM
* frame is received with a stream identifier of 0x0, the recipient MUST
* treat this as a connection error (Section 5.4.1) of type
* PROTOCOL_ERROR. *)
advance payload_length >>| fun () ->
connection_error ProtocolError "RST_STREAM must be associated with a stream"
else if payload_length <> 4
then
(* From RFC7540§6.4:
* A RST_STREAM frame with a length other than 4 octets MUST be treated
* as a connection error (Section 5.4.1) of type FRAME_SIZE_ERROR. *)
advance payload_length >>| fun () ->
connection_error
FrameSizeError
"RST_STREAM payload must be 4 octets in length"
else lift (fun error_code -> Ok (Frame.RSTStream error_code)) parse_error_code
let parse_settings_frame { Frame.payload_length; stream_id; flags; _ } =
if not (Stream_identifier.is_connection stream_id)
then
(* From RFC7540§6.5:
* If an endpoint receives a SETTINGS frame whose stream identifier field
* is anything other than 0x0, the endpoint MUST respond with a
* connection error (Section 5.4.1) of type PROTOCOL_ERROR. *)
advance payload_length >>| fun () ->
connection_error
ProtocolError
"SETTINGS must be associated with stream id 0x0"
else if payload_length mod 6 <> 0
then
(* From RFC7540§6.5:
* A SETTINGS frame with a length other than a multiple of 6 octets MUST
* be treated as a connection error (Section 5.4.1) of type
* FRAME_SIZE_ERROR. *)
advance payload_length >>| fun () ->
connection_error
FrameSizeError
"SETTINGS payload size must be a multiple of 6"
else if Flags.test_ack flags && payload_length <> 0
then
(* From RFC7540§6.5:
* Receipt of a SETTINGS frame with the ACK flag set and a length field
* value other than 0 MUST be treated as a connection error
* (Section 5.4.1) of type FRAME_SIZE_ERROR. *)
advance payload_length >>| fun () ->
connection_error FrameSizeError "SETTINGS with ACK must be empty"
else
let num_settings = payload_length / Settings.octets_per_setting in
Settings.parse_settings_payload num_settings >>| fun xs ->
Ok (Frame.Settings xs)
let parse_push_promise_frame frame_header =
let { Frame.payload_length; stream_id; _ } = frame_header in
if Stream_identifier.is_connection stream_id
then
(* From RFC7540§6.6:
* The stream identifier of a PUSH_PROMISE frame indicates the
* stream it is associated with. If the stream identifier field
* specifies the value 0x0, a recipient MUST respond with a
* connection error (Section 5.4.1) of type PROTOCOL_ERROR. *)
advance payload_length >>| fun () ->
connection_error ProtocolError "PUSH must be associated with a stream"
else
let parse_push_promise length =
lift2
(fun promised_stream_id fragment ->
if Stream_identifier.is_connection promised_stream_id
then
(* From RFC7540§6.6:
* A receiver MUST treat the receipt of a PUSH_PROMISE that
* promises an illegal stream identifier (Section 5.1.1) as a
* connection error (Section 5.4.1) of type PROTOCOL_ERROR. *)
connection_error
ProtocolError
"PUSH must not promise stream id 0x0"
else if Stream_identifier.is_request promised_stream_id
then
(* From RFC7540§6.6:
* A receiver MUST treat the receipt of a PUSH_PROMISE that
* promises an illegal stream identifier (Section 5.1.1) as a
* connection error (Section 5.4.1) of type PROTOCOL_ERROR.
*
* Note: An odd-numbered stream is an invalid stream identifier for
* the server, and only the server can send PUSH_PROMISE frames:
*
* From RFC7540§8.2.1:
* PUSH_PROMISE frames MUST NOT be sent by the client. *)
connection_error
ProtocolError
"PUSH must be associated with an even-numbered stream id"
else Ok Frame.(PushPromise (promised_stream_id, fragment)))
stream_identifier
(* From RFC7540§6.6:
* The PUSH_PROMISE frame includes the unsigned 31-bit identifier of
* the stream the endpoint plans to create along with a set of
* headers that provide additional context for the stream. *)
(take_bigstring (length - 4))
in
parse_padded_payload frame_header parse_push_promise
let parse_ping_frame { Frame.payload_length; stream_id; _ } =
if not (Stream_identifier.is_connection stream_id)
then
(* From RFC7540§6.7:
* PING frames are not associated with any individual stream. If a PING
* frame is received with a stream identifier field value other than
* 0x0, the recipient MUST respond with a connection error
* (Section 5.4.1) of type PROTOCOL_ERROR. *)
advance payload_length >>| fun () ->
connection_error ProtocolError "PING must be associated with stream id 0x0"
else if payload_length <> 8
then
(* From RFC7540§6.7:
* Receipt of a PING frame with a length field value other than 8 MUST
* be treated as a connection error (Section 5.4.1) of type
* FRAME_SIZE_ERROR. *)
advance payload_length >>| fun () ->
connection_error FrameSizeError "PING payload must be 8 octets in length"
else lift (fun bs -> Ok (Frame.Ping bs)) (take_bigstring payload_length)
let parse_go_away_frame { Frame.payload_length; stream_id; _ } =
if not (Stream_identifier.is_connection stream_id)
then
(* From RFC7540§6.8:
* The GOAWAY frame applies to the connection, not a specific stream. An
* endpoint MUST treat a GOAWAY frame with a stream identifier other than
* 0x0 as a connection error (Section 5.4.1) of type PROTOCOL_ERROR. *)
advance payload_length >>| fun () ->
connection_error
ProtocolError
"GOAWAY must be associated with stream id 0x0"
else
lift3
(fun last_stream_id err debug_data ->
Ok (Frame.GoAway (last_stream_id, err, debug_data)))
stream_identifier
parse_error_code
(take_bigstring (payload_length - 8))
let parse_window_update_frame { Frame.stream_id; payload_length; _ } =
(* From RFC7540§6.9:
* A WINDOW_UPDATE frame with a length other than 4 octets MUST be treated
* as a connection error (Section 5.4.1) of type FRAME_SIZE_ERROR. *)
if payload_length <> 4
then
advance payload_length >>| fun () ->
connection_error
FrameSizeError
"WINDOW_UPDATE payload must be 4 octets in length"
else
lift
(fun uint ->
(* From RFC7540§6.9:
* The frame payload of a WINDOW_UPDATE frame is one reserved bit
* plus an unsigned 31-bit integer indicating the number of octets
* that the sender can transmit in addition to the existing
* flow-control window. *)
let window_size_increment = Util.clear_bit_int32 uint 31 in
if Int32.equal window_size_increment 0l
then
if (* From RFC7540§6.9:
* A receiver MUST treat the receipt of a WINDOW_UPDATE frame
* with an flow-control window increment of 0 as a stream error
* (Section 5.4.2) of type PROTOCOL_ERROR; errors on the
* connection flow-control window MUST be treated as a connection
* error (Section 5.4.1). *)
Stream_identifier.is_connection stream_id
then connection_error ProtocolError "Window update must not be 0"
else stream_error ProtocolError stream_id
else Ok (Frame.WindowUpdate window_size_increment))
BE.any_int32
let parse_continuation_frame { Frame.payload_length; stream_id; _ } =
if Stream_identifier.is_connection stream_id
then
(* From RFC7540§6.10:
* CONTINUATION frames MUST be associated with a stream. If a
* CONTINUATION frame is received whose stream identifier field is 0x0,
* the recipient MUST respond with a connection error (Section 5.4.1) of
* type PROTOCOL_ERROR. *)
advance payload_length >>| fun () ->
connection_error
ProtocolError
"CONTINUATION must be associated with a stream"
else
lift
(fun block_fragment -> Ok (Frame.Continuation block_fragment))
(take_bigstring payload_length)
let parse_unknown_frame typ { Frame.payload_length; _ } =
lift
(fun bigstring -> Ok (Frame.Unknown (typ, bigstring)))
(take_bigstring payload_length)
let parse_frame_payload ({ Frame.frame_type; _ } as frame_header) =
(match frame_type with
| Frame.FrameType.Data -> parse_data_frame frame_header
| Headers -> parse_headers_frame frame_header
| Priority -> parse_priority_frame frame_header
| RSTStream -> parse_rst_stream_frame frame_header
| Settings -> parse_settings_frame frame_header
| PushPromise -> parse_push_promise_frame frame_header
| Ping -> parse_ping_frame frame_header
| GoAway -> parse_go_away_frame frame_header
| WindowUpdate -> parse_window_update_frame frame_header
| Continuation -> parse_continuation_frame frame_header
| Unknown typ -> parse_unknown_frame typ frame_header)
<?> "frame_payload"
let parse_frame parse_context =
parse_frame_header >>= fun ({ Frame.payload_length; _ } as frame_header) ->
(* If we're parsing a new frame, we didn't yet send a stream error on it *)
parse_context.did_report_stream_error <- false;
parse_context.frame_header <- frame_header;
(* h2 does unbuffered parsing and the bigarray we read input from is
* allocated based on the maximum frame payload negotiated by HTTP/2
* communication. If the underlying buffer is smaller than what
* the frame can fit, we want to skip the remaining input and skip to the
* next frame.
*
* From RFC7540§5.4.2:
* A stream error is an error related to a specific stream that does
* not affect processing of other streams. *)
let is_frame_size_error = payload_length > parse_context.max_frame_size in
if is_frame_size_error
then
parse_context.remaining_bytes_to_skip <-
parse_context.remaining_bytes_to_skip + payload_length;
lift
(function
| Ok frame_payload -> Ok { Frame.frame_header; frame_payload }
| Error e -> Error e)
(parse_frame_payload frame_header)
(* This is the client connection preface. *)
let connection_preface =
(* From RFC7540§3.5:
* In HTTP/2, each endpoint is required to send a connection preface as a
* final confirmation of the protocol in use and to establish the initial
* settings for the HTTP/2 connection. *)
string Frame.connection_preface <?> "connection preface"
module Reader = struct
module AU = Angstrom.Unbuffered
type parse_error =
(* Parse error reported by Angstrom *)
[ `Parse of string list * string
| (* Full error information *)
`Error of Error.t
| (* Just the error code, need to puzzle back connection or stream info *)
`Error_code of
Error_code.t
]
type 'error parse_state =
| Initial
| Fail of 'error
| Partial of
(Bigstringaf.t
-> off:int
-> len:int
-> AU.more
-> (unit, 'error) result AU.state)
type 'error t =
{ parser : (unit, 'error) result Angstrom.t
; mutable parse_state : 'error parse_state
(* The state of the parse for the current request *)
; mutable closed : bool
(* Whether the input source has left the building, indicating that no
further input will be received. *)
; parse_context : parse_context
(* The current stream identifier being processed, in order to discern
whether the error that needs to be assembled is a stream or connection
error. *)
}
type frame = parse_error t
let create parser parse_context =
{ parser; parse_state = Initial; closed = false; parse_context }
let create_parse_context max_frame_size =
{ frame_header = default_frame_header
; remaining_bytes_to_skip = 0
; did_report_stream_error = false
; max_frame_size
}
let settings_preface parse_context =
(* From RFC7540§3.5:
* [...] the connection preface starts with the string
* PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n). This sequence MUST be followed by
* a SETTINGS frame (Section 6.5), which MAY be empty. *)
parse_frame parse_context >>| function
| Ok ({ frame_payload = Frame.Settings settings_list; _ } as frame) ->
Ok (frame, settings_list)
| Ok { frame_payload = Frame.GoAway (_, error_code, debug_data); _ } ->
(* From RFC7540§9.2.1:
* An endpoint MAY immediately terminate an HTTP/2 connection that does
* not meet these TLS requirements with a connection error (Section
* 5.4.1) of type INADEQUATE_SECURITY.
*
* Note: we are liberal on purpose in this branch instead of only
* accepting an error of type `INADEQUATE_SECURITY`. If an endpoint is
* sending us a `GOAWAY` frame we probably did something wrong and
* deserve to know what that is. *)
Error
(`Error
Error.(ConnectionError (error_code, Bigstringaf.to_string debug_data)))
| Ok _ ->
(* From RFC7540§3.5:
* Clients and servers MUST treat an invalid connection preface as a
* connection error (Section 5.4.1) of type PROTOCOL_ERROR. A GOAWAY
* frame (Section 6.8) MAY be omitted in this case, since an invalid
* preface indicates that the peer is not using HTTP/2. *)
Error
(`Error
Error.(ConnectionError (ProtocolError, "Invalid connection preface")))
| Error e -> Error (`Error e)
let connection_preface_and_frames
~max_frame_size
preface_parser
preface_handler
frame_handler
=
let parse_context = create_parse_context max_frame_size in
let parser =
preface_parser parse_context <* commit >>= function
| Ok (frame, settings_list) ->
preface_handler frame settings_list;
(* After having received a valid connection preface, we can start
* reading other frames now. *)
skip_many (parse_frame parse_context <* commit >>| frame_handler)
>>| fun () -> Ok ()
| Error _ as error -> return error
in
create parser parse_context
let client_frames preface_handler frame_handler =
connection_preface_and_frames
(* From RFC7540§3.5:
* The server connection preface consists of a potentially empty
* SETTINGS frame (Section 6.5) that MUST be the first frame the server
* sends in the HTTP/2 connection. *)
settings_preface
preface_handler
frame_handler
let server_frames ~max_frame_size preface_handler frame_handler =
connection_preface_and_frames
~max_frame_size
(fun parse_context ->
(* From RFC7540§3.5:
* The client connection preface starts with a sequence of 24 octets,
* which in hex notation is:
*
* 0x505249202a20485454502f322e300d0a0d0a534d0d0a0d0a
* That is, the connection preface starts with the string
* PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n). This sequence MUST be followed
* by a SETTINGS frame (Section 6.5), which MAY be empty. *)
connection_preface *> settings_preface parse_context)
preface_handler
frame_handler
let is_closed t = t.closed
let transition t state =
match state with
| AU.Done (consumed, Ok ()) ->
t.parse_state <- Initial;
consumed
| Done (consumed, Error error) ->
t.parse_state <- Fail error;
consumed
| Fail (consumed, marks, msg) ->
t.parse_state <- Fail (`Parse (marks, msg));
consumed
| Partial { committed; continue } ->
(* If we have bytes to skip over then it means we've spotted a
* FRAME_SIZE_ERROR, a case where, due to our unbuffered parsing, the
* payload length declared in a frame header is larger than the
* underlying buffer can fit. *)
if t.parse_context.remaining_bytes_to_skip > 0
then t.parse_state <- Fail (`Error_code Error_code.FrameSizeError)
else t.parse_state <- Partial continue;
committed
let start t state =
match state with
| AU.Done _ -> failwith "h2.Parse.Reader.unable to start parser"
| Fail (0, marks, msg) -> t.parse_state <- Fail (`Parse (marks, msg))
| Partial { committed = 0; continue } -> t.parse_state <- Partial continue
| Partial _ | Fail _ -> assert false
let rec read_with_more t bs ~off ~len more =
let consumed =
match t.parse_state with
| Fail _ ->
let parser_ctx = t.parse_context in
let remaining_bytes = parser_ctx.remaining_bytes_to_skip in
(* Just skip input if we need to *)
if remaining_bytes > 0
then (
assert (remaining_bytes >= len);
let remaining_bytes' = remaining_bytes - len in
parser_ctx.remaining_bytes_to_skip <- remaining_bytes';
assert (remaining_bytes' >= 0);
if remaining_bytes' = 0
then
(* Reset the parser state to `Done` so that we can read the next
* frame (after skipping through the bad input) *)
t.parse_state <- Initial;
len)
else 0
| Initial ->
start t (AU.parse t.parser);
read_with_more t bs ~off ~len more
| Partial continue -> transition t (continue bs more ~off ~len)
in
(match more with Complete -> t.closed <- true | Incomplete -> ());
consumed
let force_close t = t.closed <- true
let fail_to_string marks err = String.concat " > " marks ^ ": " ^ err
let next_from_error t ?(msg = "") error_code =
if t.parse_context.frame_header == default_frame_header
then `Error Error.(ConnectionError (error_code, msg))
else
match t.parse_context, error_code with
| ( { frame_header =
{ frame_type =
Headers | PushPromise | Continuation | Settings | Unknown _
; _
}
; _
}
, Error_code.FrameSizeError )
| { frame_header = { Frame.stream_id = 0x0l; _ }; _ }, _ ->
(* From RFC7540§4.2:
* A frame size error in a frame that could alter the state of the
* entire connection MUST be treated as a connection error (Section
* 5.4.1); this includes any frame carrying a header block (Section
* 4.3) (that is, HEADERS, PUSH_PROMISE, and CONTINUATION), SETTINGS,
* and any frame with a stream identifier of 0. *)
`Error Error.(ConnectionError (error_code, msg))
| { did_report_stream_error = true; _ }, _ ->
(* If the parser is in a `Fail` state and would report a stream error,
* just issue a `Read` operation if we've already reported that error. *)
if t.closed then `Close else `Read
| { frame_header = { Frame.stream_id; _ }; _ }, _ ->
t.parse_context.did_report_stream_error <- true;
`Error Error.(StreamError (stream_id, error_code))
let next t =
match t.parse_state with
| Fail error ->
(match error with
| `Error e -> `Error e
| `Error_code error_code -> next_from_error t error_code
| `Parse (marks, msg) ->
let error_code =
match marks, msg with
| [ "frame_payload" ], "not enough input" ->
(* From RFC7540§4.2:
* An endpoint MUST send an error code of FRAME_SIZE_ERROR if a
* frame exceeds the size defined in SETTINGS_MAX_FRAME_SIZE,
* exceeds any limit defined for the frame type, or is too small
* to contain mandatory frame data. *)
Error_code.FrameSizeError
| _ -> Error_code.ProtocolError
in
next_from_error t ~msg:(fail_to_string marks msg) error_code)
| _ when t.closed -> `Close
| Partial _ -> `Read
| Initial -> if t.closed then `Close else `Read
end

71
unikernel/duniverse/ocaml-h2/lib/priority.ml Normal file
View file

@ -0,0 +1,71 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
open Util
type t =
{ exclusive : bool
; stream_dependency : Stream_identifier.t
; weight : int
}
(* From RFC7540§5.3.5:
* All streams are initially assigned a non-exclusive dependency on stream
* 0x0. Pushed streams (Section 8.2) initially depend on their associated
* stream. In both cases, streams are assigned a default weight of 16. *)
let default_priority =
{ exclusive = false; stream_dependency = 0l; weight = 16 }
(* From RFC7540§5.4.1:
* All dependent streams are allocated an integer weight between 1 and 256
* (inclusive). *)
let highest_priority =
{ exclusive = false; stream_dependency = 0l; weight = 256 }
(* --- Exclusive flag ---
*
* From RFC7540§5.4.1:
* +-+-------------------------------------------------------------+
* |E| Stream Dependency (31) |
* +-+-------------+-----------------------------------------------+
* | Weight (8) |
* +-+-------------+
*)
let test_exclusive n = test_bit_int32 n 31
let set_exclusive n = set_bit_int32 n 31
let clear_exclusive n = clear_bit_int32 n 31
let equal p1 p2 =
p1.weight = p2.weight
&& Int32.equal p1.stream_dependency p2.stream_dependency
&& p1.exclusive = p2.exclusive

523
unikernel/duniverse/ocaml-h2/lib/reqd.ml Normal file
View file

@ -0,0 +1,523 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2017 Inhabited Type LLC.
* Copyright (c) 2019 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
module Writer = Serialize.Writer
type error =
[ `Bad_request
| `Internal_server_error
| `Exn of exn
]
type error_handler =
?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit
type response_state =
| Waiting
| Fixed of
{ response : Response.t
; mutable iovec :
[ `String of string | `Bigstring of Bigstringaf.t ]
Httpun_types.IOVec.t
}
| Streaming of
{ response : Response.t
; response_body : Body.Writer.t
; trailers : Headers.t
}
| Complete of Response.t
type request_info =
{ request : Request.t
; request_body : Body.Reader.t
; mutable request_body_bytes : int64
}
type active_state = (request_info, request_info) Stream.active_state
type active_stream =
{ body_buffer_size : int
; encoder : Hpack.Encoder.t
; mutable response_state : response_state
(* We're not doing anything with these yet, we could probably have a
* `Reqd.schedule_read_trailers` function that would be called once
* trailer headers are emitted. *)
; mutable trailers_parser : Stream.partial_headers option
; mutable trailers : Headers.t option
; create_push_stream :
Stream_identifier.t
-> (t, [ `Push_disabled | `Stream_ids_exhausted ]) result
}
and state =
(active_state, active_stream, request_info * active_stream) Stream.state
and t = (state, error, error_handler) Stream.t
let create_active_request request request_body =
{ request; request_body; request_body_bytes = Int64.zero }
let create_active_stream encoder body_buffer_size create_push_stream =
{ body_buffer_size
; encoder
; response_state = Waiting
; trailers_parser = None
; trailers = None
; create_push_stream
}
let request (t : t) =
match t.state with
| Idle | Active (Open (WaitingForPeer | PartialHeaders _ | FullHeaders), _) ->
assert false
| Active ((Open (ActiveMessage { request; _ }) | HalfClosed { request; _ }), _)
| Reserved ({ request; _ }, _) ->
request
| Closed _ -> assert false
let request_body (t : t) =
match t.state with
| Idle | Active (Open (WaitingForPeer | PartialHeaders _ | FullHeaders), _) ->
assert false
| Active
( ( Open (ActiveMessage { request_body; _ })
| HalfClosed { request_body; _ } )
, _ ) ->
request_body
| Reserved _ ->
(* From RFC7540§8.1:
* Promised requests MUST NOT include a request body. *)
failwith
"h2.Reqd.request_body: Promised requests must not include a request body"
| Closed _ -> failwith "h2.Reqd.request_body: Stream already closed"
let response (t : t) =
match t.state with
| Idle | Active (Open (WaitingForPeer | PartialHeaders _), _) -> None
| Active
( (Open (FullHeaders | ActiveMessage _) | HalfClosed _)
, { response_state; _ } )
| Reserved (_, { response_state; _ }) ->
(match response_state with
| Waiting -> None
| Streaming { response; _ } | Fixed { response; _ } | Complete response ->
Some response)
| Closed _ -> None
let response_exn (t : t) =
match t.state with
| Idle | Active (Open (WaitingForPeer | PartialHeaders _), _) ->
failwith "h2.Reqd.response_exn: response has not started"
| Active
( (Open (FullHeaders | ActiveMessage _) | HalfClosed _)
, { response_state; _ } )
| Reserved (_, { response_state; _ }) ->
(match response_state with
| Waiting -> failwith "h2.Reqd.response_exn: response has not started"
| Streaming { response; _ } | Fixed { response; _ } | Complete response ->
response)
| Closed _ -> assert false
let send_fixed_response (t : t) s response data =
match s.response_state with
| Waiting ->
let iovec, length =
match data with
| `String s ->
let len = String.length s in
let iovec = { Httpun_types.IOVec.buffer = `String s; off = 0; len } in
iovec, len
| `Bigstring b ->
let len = Bigstringaf.length b in
let iovec =
{ Httpun_types.IOVec.buffer = `Bigstring b; off = 0; len }
in
iovec, len
in
let should_send_data = length <> 0 in
let frame_info =
Writer.make_frame_info
~max_frame_size:t.max_frame_size
~flags:
(if should_send_data
then Flags.default_flags
else Flags.(set_end_stream default_flags))
t.id
in
Writer.write_response_headers t.writer s.encoder frame_info response;
(* From RFC7540§8.1:
* An HTTP request/response exchange fully consumes a single stream.
* [...] A response starts with a HEADERS frame and ends with a frame
* bearing END_STREAM, which places the stream in the "closed" state. *)
if should_send_data
then s.response_state <- Fixed { response; iovec }
else s.response_state <- Complete response;
Writer.wakeup t.writer
| Streaming _ -> failwith "h2.Reqd.respond_with_*: response already started"
| Fixed _ -> failwith "h2.Reqd.respond_with_*: response already sent"
| Complete _ -> failwith "h2.Reqd.respond_with_*: response already complete"
let schedule_trailers (t : t) new_trailers =
match t.state with
| Idle | Active (Open (WaitingForPeer | PartialHeaders _), _) -> assert false
| Closed _ -> failwith "h2.Reqd.schedule_trailers: stream already closed"
| Reserved _ -> failwith "h2.Reqd.schedule_trailers: response not started"
| Active ((Open (FullHeaders | ActiveMessage _) | HalfClosed _), stream) ->
(match stream.response_state with
| Streaming { response; response_body; trailers = old_trailers } ->
if old_trailers <> Headers.empty
then failwith "h2.Reqd.schedule_trailers: trailers already scheduled";
stream.response_state <-
Streaming { response; response_body; trailers = new_trailers }
| _ ->
failwith
"h2.Reqd.schedule_trailers: can only send trailers in Streaming mode")
let unsafe_respond_with_data (t : t) response data =
match t.state with
| Idle | Active (Open (WaitingForPeer | PartialHeaders _), _) -> assert false
| Active ((Open (FullHeaders | ActiveMessage _) | HalfClosed _), stream) ->
send_fixed_response t stream response data
| Reserved (request_info, stream) ->
send_fixed_response t stream response data;
(* From RFC7540§8.1:
* reserved (local): [...] In this state, only the following transitions
* are possible: The endpoint can send a HEADERS frame. This causes the
* stream to open in a "half-closed (remote)" state. *)
Writer.flush t.writer (fun _reason ->
(* TODO(anmonteiro): different if closed? *)
t.state <- Active (HalfClosed request_info, stream))
| Closed _ -> assert false
let respond_with_string (t : t) response str =
match t.error_code with
| No_error -> unsafe_respond_with_data t response (`String str)
| _ ->
failwith
"h2.Reqd.respond_with_string: invalid state, currently handling error"
let respond_with_bigstring (t : t) response bstr =
match t.error_code with
| No_error -> unsafe_respond_with_data t response (`Bigstring bstr)
| _ ->
failwith
"h2.Reqd.respond_with_bigstring: invalid state, currently handling error"
let send_streaming_response ~flush_headers_immediately (t : t) s response =
let wait_for_first_flush = not flush_headers_immediately in
match s.response_state with
| Waiting ->
let frame_info =
Writer.make_frame_info ~max_frame_size:t.max_frame_size t.id
in
let response_body_buffer = Bigstringaf.create s.body_buffer_size in
let response_body =
Body.Writer.create response_body_buffer ~writer:t.writer
in
Writer.write_response_headers t.writer s.encoder frame_info response;
if wait_for_first_flush then Writer.yield t.writer;
s.response_state <-
Streaming { response; response_body; trailers = Headers.empty };
Writer.wakeup t.writer;
response_body
| Streaming _ ->
failwith "h2.Reqd.respond_with_streaming: response already started"
| Fixed _ | Complete _ ->
failwith "h2.Reqd.respond_with_streaming: response already complete"
let unsafe_respond_with_streaming (t : t) ~flush_headers_immediately response =
match t.state with
| Idle | Active (Open (WaitingForPeer | PartialHeaders _), _) -> assert false
| Active ((Open (FullHeaders | ActiveMessage _) | HalfClosed _), stream) ->
send_streaming_response ~flush_headers_immediately t stream response
| Reserved (request_info, stream) ->
let response_body =
send_streaming_response ~flush_headers_immediately t stream response
in
(* From RFC7540§8.1:
* reserved (local): [...] In this state, only the following transitions
* are possible: The endpoint can send a HEADERS frame. This causes the
* stream to open in a "half-closed (remote)" state. *)
Writer.flush t.writer (fun _reason ->
(* TODO(anmonteiro): different if closed? *)
t.state <- Active (HalfClosed request_info, stream));
response_body
| Closed _ -> assert false
let respond_with_streaming (t : t) ?(flush_headers_immediately = false) response
=
match t.error_code with
| No_error ->
unsafe_respond_with_streaming ~flush_headers_immediately t response
| _ ->
failwith
"h2.Reqd.respond_with_streaming: invalid state, currently handling error"
let start_push_stream (t : t) s request =
match s.create_push_stream t.id with
| Ok promised_reqd ->
let frame_info =
Writer.make_frame_info ~max_frame_size:t.max_frame_size t.id
in
Writer.write_push_promise
t.writer
s.encoder
frame_info
~promised_id:promised_reqd.id
request;
let { encoder; body_buffer_size; create_push_stream; _ } = s in
(* From RFC7540§8.2:
* Promised requests [...] MUST NOT include a request body. *)
let request_info = create_active_request request Body.Reader.empty in
let active_stream =
create_active_stream encoder body_buffer_size create_push_stream
in
(* From RFC7540§8.2.1:
* Sending a PUSH_PROMISE frame creates a new stream and puts the stream
* into the "reserved (local)" state for the server and the "reserved
* (remote)" state for the client.
*
* Note: we do this before flushing the writer because request handlers
* might immediately call one of the `respond_with` functions and expect
* the stream to be in the `Reserved` state. *)
promised_reqd.state <- Reserved (request_info, active_stream);
Writer.wakeup t.writer;
Ok promised_reqd
| Error e ->
Error (e :> [ `Push_disabled | `Stream_cant_push | `Stream_ids_exhausted ])
(* TODO: We could easily allow the priority of the PUSH request to be
* configurable. We should allow users of this API to define the weight (maybe
* not strictly), dependency on the current Reqd, and exclusivity *)
let unsafe_push (t : t) request =
match t.state with
| Idle | Active (Open (WaitingForPeer | PartialHeaders _), _) -> assert false
| Active ((Open (FullHeaders | ActiveMessage _) | HalfClosed _), stream) ->
start_push_stream t stream request
(* Already checked in `push` *)
| Reserved _ | Closed _ -> assert false
let push (t : t) request =
match t.error_code with
| No_error ->
if Stream_identifier.is_pushed t.id
then
(* From RFC7540§6.6:
* PUSH_PROMISE frames MUST only be sent on a peer-initiated stream that
* is in either the "open" or "half-closed (remote)" state. *)
Error `Stream_cant_push
else unsafe_push t request
| _ -> failwith "h2.Reqd.push: invalid state, currently handling error"
let _report_error ?request (t : t) s (error : error) error_code =
match s.response_state, t.error_code with
| Waiting, No_error ->
t.error_code <- Stream.error_to_code error error_code;
let status =
match (error :> [ error | Status.standard ]) with
| `Exn _ -> `Internal_server_error
| #Status.standard as status -> status
in
t.error_handler ?request error (fun headers ->
let response = Response.create ~headers status in
unsafe_respond_with_streaming ~flush_headers_immediately:true t response)
| Streaming { response_body; _ }, No_error ->
Body.Writer.close response_body;
t.error_code <- Stream.error_to_code error error_code;
Stream.reset_stream t error_code
| Fixed _, No_error ->
(* Still need to send an RST_STREAM frame. Set t.error_code with
* `error_code` and `flush_response_body` below will reset the stream after
* flushing any remaining body bytes. *)
t.error_code <- Stream.error_to_code error error_code;
Stream.reset_stream t error_code
| (Waiting | Fixed _ | Streaming _), Exn _ ->
(* XXX(seliopou): Decide what to do in this unlikely case. There is an
* outstanding call to the [error_handler], but an intervening exception
* has been reported as well. *)
failwith "h2.Reqd.report_exn: NYI"
| (Waiting | Streaming _ | Fixed _ | Complete _), _ -> ()
let report_error (t : t) exn error_code =
match t.state with
| Idle | Reserved _ | Active (Open (WaitingForPeer | PartialHeaders _), _) ->
assert false
| Active (Open FullHeaders, stream) -> _report_error t stream exn error_code
| Active
( ( Open (ActiveMessage { request; request_body; _ })
| HalfClosed { request; request_body; _ } )
, stream ) ->
Body.Reader.close request_body;
_report_error t stream ~request exn error_code
| Closed _ -> ()
let report_exn t exn = report_error t (`Exn exn) Error_code.InternalError
let try_with t f : (unit, exn) result =
try
f ();
Ok ()
with
| exn ->
report_exn t exn;
Error exn
let error_code = Stream.error_code
(* Private API, not exposed to the user through h2.mli *)
let requires_output (t : t) =
match t.state with
| Idle -> false
| Reserved _ -> true
| Active (Open (WaitingForPeer | PartialHeaders _), _) -> false
| Active
( (Open (FullHeaders | ActiveMessage _) | HalfClosed _)
, { response_state; _ } ) ->
(* From RFC7540§8.1:
* A server can send a complete response prior to the client sending an
* entire request if the response does not depend on any portion of the
* request that has not been sent and received. *)
(match response_state with
| Complete _ -> false
| Fixed { iovec = { len; _ }; _ } -> len > 0
| Streaming _ -> true
| Waiting -> true)
| Closed _ -> false
let flush_request_body (t : t) =
match t.state with
| Active
( ( Open (ActiveMessage { request_body; _ })
| HalfClosed { request_body; _ } )
, _ ) ->
if Body.Reader.has_pending_output request_body
then (
try Body.Reader.execute_read request_body with exn -> report_exn t exn)
| _ -> ()
let write_buffer_data writer ~off ~len frame_info buffer =
match buffer with
| `String str -> Writer.write_data writer ~off ~len frame_info str
| `Bigstring bstr -> Writer.schedule_data writer ~off ~len frame_info bstr
let close_stream (t : t) =
match t.error_code with
| No_error ->
(match t.state with
| Active (Open (FullHeaders | ActiveMessage _), _) ->
(* From RFC7540§8.1:
* A server can send a complete response prior to the client sending an
* entire request if the response does not depend on any portion of the
* request that has not been sent and received. When this is true, a
* server MAY request that the client abort transmission of a request
* without error by sending a RST_STREAM with an error code of NO_ERROR
* after sending a complete response (i.e., a frame with the END_STREAM
* flag). *)
Stream.reset_stream t Error_code.NoError
| Active (HalfClosed _, _) ->
Writer.flush t.writer (fun _reason -> Stream.finish_stream t Finished)
| _ -> assert false)
| Exn _ -> Stream.reset_stream t InternalError
| Other { code; _ } -> Stream.reset_stream t code
let flush_response_body (t : t) ~max_bytes =
match t.state with
| Active ((Open _ | HalfClosed _), stream) ->
(match stream.response_state with
| Streaming { response; response_body; trailers } ->
if Body.Writer.has_pending_output response_body && max_bytes > 0
then
Body.Writer.transfer_to_writer
response_body
t.writer
~max_frame_size:t.max_frame_size
~max_bytes
t.id
else if Body.Writer.is_closed response_body
then (
(* no pending output and closed, we can finalize the message and close
the stream *)
let frame_info =
Writer.make_frame_info
~max_frame_size:t.max_frame_size
~flags:Flags.(set_end_stream default_flags)
t.id
in
match trailers with
| _ :: _ ->
Writer.write_response_trailers
t.writer
stream.encoder
frame_info
trailers;
close_stream t;
stream.response_state <- Complete response;
0
| [] ->
(* From RFC7540§6.9.1:
* Frames with zero length with the END_STREAM flag set (that is,
* an empty DATA frame) MAY be sent if there is no available space
* in either flow-control window. *)
Writer.schedule_data t.writer frame_info ~len:0 Bigstringaf.empty;
close_stream t;
stream.response_state <- Complete response;
0)
else (* no pending output but Body is still open *)
0
| Fixed ({ iovec = { buffer; off; len } as iovec; _ } as r)
when max_bytes > 0 ->
let is_partial_flush = max_bytes < len in
let frame_info =
let flags =
if is_partial_flush
then Flags.default_flags
else Flags.(set_end_stream default_flags)
in
Writer.make_frame_info ~max_frame_size:t.max_frame_size ~flags t.id
in
let len_to_write = if is_partial_flush then max_bytes else len in
write_buffer_data t.writer ~off ~len:len_to_write frame_info buffer;
r.iovec <- Httpun_types.IOVec.shift iovec len_to_write;
if not is_partial_flush then close_stream t;
len_to_write
| Fixed _ | Waiting | Complete _ -> 0)
| _ -> 0
let deliver_trailer_headers (t : t) headers =
match t.state with
| Active (Open (PartialHeaders _ | FullHeaders), _) -> assert false
| Active ((Open (ActiveMessage _) | HalfClosed _), stream) ->
(* TODO: call the schedule_trailers callback *)
stream.trailers <- Some headers
| _ -> assert false

57
unikernel/duniverse/ocaml-h2/lib/request.ml Normal file
View file

@ -0,0 +1,57 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2017 Inhabited Type LLC.
* Copyright (c) 2019 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
type t =
{ meth : Httpun_types.Method.t
; target : string
; scheme : string
; headers : Headers.t
}
(* TODO: `:authority` pseudo-header? *)
let create ?(headers = Headers.empty) ~scheme meth target =
{ meth; target; scheme; headers }
let body_length { headers; _ } = Message.body_length headers
let pp_hum fmt { meth; target; scheme; headers } =
Format.fprintf
fmt
"((method \"%a\") (target %S) (scheme %S) (headers %a))"
Httpun_types.Method.pp_hum
meth
target
scheme
Headers.pp_hum
headers

200
unikernel/duniverse/ocaml-h2/lib/respd.ml Normal file
View file

@ -0,0 +1,200 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
(* TODO(anmonteiro): think about whether we wanna expose this module. it might
* be helpful to expose a way to reset streams, and I think we'd need a
* reference to the Respd *)
module Writer = Serialize.Writer
type error =
[ `Malformed_response of string
| `Invalid_response_body_length of Response.t
| `Protocol_error of Error_code.t * string
| `Exn of exn
]
type error_handler = error -> unit
type response_handler = Response.t -> Body.Reader.t -> unit
type response_info =
{ response : Response.t
; response_body : Body.Reader.t
; mutable response_body_bytes : int64
; mutable trailers_parser : Stream.partial_headers option
}
type trailers_handler = Headers.t -> unit
type active_request =
{ request : Request.t
; request_body : Body.Writer.t
; response_handler : response_handler
; trailers_handler : trailers_handler
}
type active_state =
(response_info, response_info Stream.remote_state) Stream.active_state
type state =
( active_state
, active_request
, active_request Stream.remote_state )
Stream.state
type t = (state, error, error_handler) Stream.t
let create_active_response response response_body =
Stream.ActiveMessage
{ response
; response_body
; response_body_bytes = Int64.zero
; trailers_parser = None
}
let response_body_exn (t : t) =
match t.state with
| Idle | Reserved _ ->
failwith "h2.Respd.response_exn: response has not arrived"
| Active
( ( Open (ActiveMessage { response_body; _ })
| HalfClosed (ActiveMessage { response_body; _ }) )
, _ ) ->
response_body
| Active ((Open _ | HalfClosed _), _) ->
failwith "h2.Respd.response_exn: response has not arrived"
| Closed _ -> failwith "h2.Respd.response_exn: stream already closed"
let close_stream (t : t) =
(* TODO: reserved *)
match t.state with
| Active (HalfClosed _, _) ->
(* easy case, just transition to the closed state. *)
Stream.finish_stream t Finished
| Active (Open _, _) ->
(* Still not done sending, reset stream with no error? *)
(* TODO: *)
()
| _ -> ()
let _report_error (t : t) ?response_body (error : error) error_code =
match t.error_code with
| No_error ->
(match response_body with
| Some response_body -> Body.Reader.close response_body
| None -> ());
t.error_code <- Stream.error_to_code error error_code;
t.error_handler error
| Exn _ | Other _ ->
(* Already handling error.
* TODO(anmonteiro): Log a message when we add Logs support *)
()
let report_error (t : t) error error_code =
match t.state with
| Active
( ( Open (ActiveMessage { response_body; _ })
| HalfClosed (ActiveMessage { response_body; _ }) )
, s ) ->
Body.Writer.close s.request_body;
_report_error t ~response_body error error_code;
Stream.reset_stream t error_code
| Reserved (ActiveMessage s) | Active (_, s) ->
Body.Writer.close s.request_body;
_report_error t error error_code;
Stream.reset_stream t error_code
| Reserved _ ->
(* Streams in the reserved state don't yet have a stream-level error
* handler registered with them *)
()
| Idle | Closed _ ->
(* Not allowed to send RST_STREAM frames in these states *)
ignore (_report_error t error error_code)
let requires_output (t : t) =
match t.state with
| Idle -> true
| Reserved _ -> false
| Active (Open _, _) -> true
| Active (HalfClosed _, _) -> false
| Closed _ -> false
let flush_request_body (t : t) ~max_bytes =
match t.state with
| Active (Open active_state, ({ request_body; _ } as s)) ->
if Body.Writer.has_pending_output request_body && max_bytes > 0
then
Body.Writer.transfer_to_writer
request_body
t.writer
~max_frame_size:t.max_frame_size
~max_bytes
t.id
else if Body.Writer.is_closed request_body
then (
(* closed and no pending output *)
(* From RFC7540§6.9.1:
* Frames with zero length with the END_STREAM flag set (that is, an
* empty DATA frame) MAY be sent if there is no available space in
* either flow-control window. *)
let frame_info =
Writer.make_frame_info
~max_frame_size:t.max_frame_size
~flags:Flags.(set_end_stream default_flags)
t.id
in
Writer.schedule_data t.writer frame_info ~len:0 Bigstringaf.empty;
t.state <- Active (HalfClosed active_state, s);
0)
else (* not closed and no pending output *)
0
| _ -> 0
let deliver_trailer_headers (t : t) headers =
match t.state with
| Active
( (Open (ActiveMessage _) | HalfClosed (ActiveMessage _))
, { trailers_handler; _ } ) ->
trailers_handler headers
| _ -> assert false
let flush_response_body (t : t) =
match t.state with
| Active
( ( Open (ActiveMessage { response_body; _ })
| HalfClosed (ActiveMessage { response_body; _ }) )
, _ ) ->
if Body.Reader.has_pending_output response_body
then (
try Body.Reader.execute_read response_body with
| exn -> report_error t (`Exn exn) InternalError)
| _ -> ()

63
unikernel/duniverse/ocaml-h2/lib/response.ml Normal file
View file

@ -0,0 +1,63 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2017 Inhabited Type LLC.
* Copyright (c) 2019 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
type t =
{ status : Status.t
; headers : Headers.t
}
(* From RFC7540§8.1.2.4:
* HTTP/2 does not define a way to carry the version or reason phrase that
* is included in an HTTP/1.1 status line. *)
let create ?(headers = Headers.empty) status = { status; headers }
let body_length ~request_method { headers; _ } =
match request_method with
| `HEAD -> `Fixed 0L
| #Httpun_types.Method.standard -> Message.body_length headers
let pp_hum fmt { status; headers } =
let reason =
match status with
| #Status.standard as status -> Status.default_reason_phrase status
| `Code _ -> "Non-standard status code"
in
Format.fprintf
fmt
"((status %a) (reason %S) (headers %a))"
Status.pp_hum
status
reason
Headers.pp_hum
headers

571
unikernel/duniverse/ocaml-h2/lib/scheduler.ml Normal file
View file

@ -0,0 +1,571 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
module StreamsTbl = struct
include Hashtbl.MakeSeeded (struct
type t = Stream_identifier.t
let equal = Stream_identifier.( === )
let hash i k = Hashtbl.seeded_hash i k
(* Required for OCaml >= 5.0.0, but causes errors for older compilers
because it is an unused value declaration. *)
let[@warning "-32"] seeded_hash = hash
end)
let[@inline] find_opt h key = try Some (find h key) with Not_found -> None
end
module type StreamDescriptor = sig
type t
val id : t -> Stream_identifier.t
val requires_output : t -> bool
val flush_write_body : t -> max_bytes:int -> int
val finish_stream : t -> Stream.closed_reason -> unit
val is_idle : t -> bool
end
module Make (Streamd : StreamDescriptor) = struct
module rec PriorityTreeNode : sig
type root = Root
type nonroot = NonRoot
type stream = nonroot node
and parent = Parent : _ node -> parent
and _ node =
(* From RFC7540§5.3.1:
* A stream that is not dependent on any other stream is given a stream
* dependency of 0x0. In other words, the non-existent stream 0 forms
* the root of the tree.
*
* Note:
* We use a GADT because the root of the tree doesn't have an
* associated request descriptor. It has the added advantage of
* allowing us to enforce that all (other) streams in the tree are
* associated with a request descriptor. *)
| Connection :
{ all_streams : stream StreamsTbl.t
; mutable t_last : int
; mutable children : PriorityQueue.t
; (* Connection-level flow control window.
* outbound flow control, what we're allowed to send.
*
* From RFC7540§6.9.1:
* Two flow-control windows are applicable: the stream
* flow-control window and the connection flow-control window. *)
mutable flow : Settings.WindowSize.t
; (* inbound flow control, what the client is allowed to send. *)
mutable inflow : Settings.WindowSize.t
; mutable marked_for_removal : Stream.closed StreamsTbl.t
}
-> root node
| Stream :
{ descriptor : Streamd.t
; mutable t_last : int
; mutable t : int
; mutable priority : Priority.t
; mutable parent : parent
; mutable children : PriorityQueue.t
; (* Stream-level flow control window. See connection-level above.
*
* From RFC7540§6.9.1:
* Two flow-control windows are applicable: the stream
* flow-control window and the connection flow-control window. *)
mutable flow : Settings.WindowSize.t
; mutable inflow : Settings.WindowSize.t
}
-> nonroot node
end =
PriorityTreeNode
and PriorityQueue :
(Psq.S with type k = Int32.t and type p = PriorityTreeNode.stream) =
Psq.Make
(Int32)
(struct
include PriorityTreeNode
type t = stream
let compare (Stream { t = t1; _ }) (Stream { t = t2; _ }) =
compare t1 t2
end)
include PriorityTreeNode
type t = root node
(* TODO(anmonteiro): change according to SETTINGS_MAX_CONCURRENT_STREAMS? *)
let make_root ?(capacity = 65536) () =
Connection
{ t_last = 0
; children = PriorityQueue.empty
; all_streams = StreamsTbl.create ~random:true capacity
; flow = Settings.WindowSize.default_initial_window_size
; inflow = Settings.WindowSize.default_initial_window_size
; marked_for_removal = StreamsTbl.create ~random:true 256
}
let create
~parent
~initial_send_window_size
~initial_recv_window_size
descriptor
=
Stream
{ descriptor
; t_last = 0
; t = 0
; (* From RFC7540§5.3.5:
* All streams are initially assigned a non-exclusive dependency on
* stream 0x0. Pushed streams (Section 8.2) initially depend on their
* associated stream. In both cases, streams are assigned a default
* weight of 16. *)
priority = Priority.default_priority
; parent
; children = PriorityQueue.empty
; flow = initial_send_window_size
; inflow = initial_recv_window_size
}
let stream_id : type a. a node -> int32 = function
| Connection _ -> Stream_identifier.connection
| Stream { descriptor; _ } -> Streamd.id descriptor
let children : type a. a node -> PriorityQueue.t = function
| Stream { children; _ } -> children
| Connection { children; _ } -> children
let remove_child : type a. a node -> int32 -> unit =
fun parent id ->
match parent with
| Connection ({ children; _ } as node) ->
(* From RFC7540§5.3.1:
* A stream that is not dependent on any other stream is given a stream
* dependency of 0x0. In other words, the non-existent stream 0 forms
* the root of the tree. *)
node.children <- PriorityQueue.remove id children
| Stream ({ children; _ } as node) ->
node.children <- PriorityQueue.remove id children
let update_children : type a. a node -> PriorityQueue.t -> unit =
fun parent updated_children ->
match parent with
| Connection s -> s.children <- updated_children
| Stream s -> s.children <- updated_children
let set_parent stream_node ~exclusive (Parent new_parent_node as new_parent) =
let (Stream ({ descriptor; parent = Parent old_parent_node; _ } as stream)) =
stream_node
in
let stream_id = Streamd.id descriptor in
remove_child old_parent_node stream_id;
stream.parent <- new_parent;
let new_children =
let new_children = children new_parent_node in
if exclusive
then (
(* From RFC7540§5.3.3:
* Dependent streams move with their parent stream if the parent is
* reprioritized. Setting a dependency with the exclusive flag for a
* reprioritized stream causes all the dependencies of the new parent
* stream to become dependent on the reprioritized stream. *)
stream.children <-
PriorityQueue.fold
(fun k (Stream p as p_node) pq ->
p.parent <- Parent stream_node;
PriorityQueue.add k p_node pq)
stream.children
new_children;
(* From RFC7540§5.3.1:
* An exclusive flag allows for the insertion of a new level of
* dependencies. The exclusive flag causes the stream to become the
* sole dependency of its parent stream, causing other dependencies
* to become dependent on the exclusive stream. *)
PriorityQueue.sg stream_id stream_node)
else PriorityQueue.add stream_id stream_node new_children
in
update_children new_parent_node new_children
let would_create_cycle ~new_parent (Stream { descriptor; _ }) =
let rec inner : type a. a node -> bool = function
| Connection _ -> false
| Stream { parent = Parent parent; _ }
when Stream_identifier.(stream_id parent === Streamd.id descriptor) ->
true
| Stream { parent = Parent parent; _ } -> inner parent
in
let (Parent parent_node) = new_parent in
inner parent_node
let reprioritize_stream (Connection root as t) ~priority stream_node =
let (Stream stream) = stream_node in
let new_parent, new_priority =
if Stream_identifier.is_connection priority.Priority.stream_dependency
then Parent t, priority
else
match
StreamsTbl.find_opt root.all_streams priority.stream_dependency
with
| Some parent_stream ->
(match
StreamsTbl.mem root.marked_for_removal priority.stream_dependency
with
| true ->
(* A stream that is marked for removal is also not present in the
tree *)
Parent t, Priority.default_priority
| false -> Parent parent_stream, priority)
| None ->
(* From RFC7540§5.3.1:
* A dependency on a stream that is not currently in the tree —
* such as a stream in the "idle" state — results in that stream
* being given a default priority (Section 5.3.5). *)
Parent t, Priority.default_priority
in
(* bail early if trying to set the same priority *)
if not (Priority.equal stream.priority new_priority)
then (
let { Priority.stream_dependency; exclusive; _ } = new_priority in
let (Parent current_parent_node) = stream.parent in
let current_parent_id = stream_id current_parent_node in
(* only need to set a different parent if the parent or exclusive status
* changed *)
if (not Stream_identifier.(stream_dependency === current_parent_id))
|| exclusive <> stream.priority.exclusive
then (
let (Parent new_parent_node) = new_parent in
(match new_parent_node with
| Stream new_parent_stream ->
if would_create_cycle ~new_parent stream_node
then (
(* From RFC7540§5.3.3:
* If a stream is made dependent on one of its own dependencies,
* the formerly dependent stream is first moved to be dependent
* on the reprioritized stream's previous parent. The moved
* dependency retains its weight. *)
set_parent new_parent_node ~exclusive:false stream.parent;
new_parent_stream.priority <-
{ new_parent_stream.priority with
stream_dependency = current_parent_id
})
| Connection _ ->
(* The root node cannot be dependent on any other streams, so we
* don't need to worry about it creating cycles. *)
());
(* From RFC7540§5.3.1:
* When assigning a dependency on another stream, the stream is added
* as a new dependency of the parent stream. *)
set_parent stream_node ~exclusive new_parent);
stream.priority <- new_priority)
let update_t node n =
let (Stream ({ parent = Parent parent; descriptor; _ } as stream)) = node in
let tlast_p =
match parent with
| Connection { t_last; _ } -> t_last
| Stream { t_last; _ } -> t_last
in
stream.t <- tlast_p + (n * 256 / stream.priority.weight);
let id = Streamd.id descriptor in
remove_child parent id;
let updated_children = PriorityQueue.add id node (children parent) in
update_children parent updated_children
let update_t_last : type a. a node -> int -> unit =
fun p_node t_last ->
match p_node with
| Connection p -> p.t_last <- t_last
| Stream p -> p.t_last <- t_last
let add
(Connection root as t)
~priority
~initial_send_window_size
~initial_recv_window_size
descriptor
=
let stream =
create
~parent:(Parent t)
~initial_send_window_size
~initial_recv_window_size
descriptor
in
let stream_id = Streamd.id descriptor in
StreamsTbl.add root.all_streams stream_id stream;
root.children <- PriorityQueue.add stream_id stream root.children;
if priority != Priority.default_priority
then reprioritize_stream t ~priority stream;
update_t stream 0;
stream
let get_node (Connection root) stream_id =
StreamsTbl.find_opt root.all_streams stream_id
let find t stream_id =
match get_node t stream_id with
| Some (Stream { descriptor; _ }) -> Some descriptor
| None -> None
let iter (Connection { all_streams; _ }) ~f =
StreamsTbl.iter (fun _id stream -> f stream) all_streams
let allowed_to_transmit (Connection root) (Stream stream) =
Int32.compare root.flow 0l > 0 && Int32.compare stream.flow 0l > 0
let allowed_to_receive (Connection root) (Stream stream) size =
size <= root.inflow && size <= stream.inflow
let write (Connection root as t) stream_node =
let (Stream ({ descriptor; _ } as stream)) = stream_node in
(* From RFC7540§6.9.1:
* Two flow-control windows are applicable: the stream flow-control
* window and the connection flow-control window. The sender MUST NOT
* send a flow-controlled frame with a length that exceeds the space
* available in either of the flow-control windows advertised by the
* receiver. *)
let allowed_bytes =
if allowed_to_transmit t stream_node
then min root.flow stream.flow
else
(* There might be a zero-length DATA frame (with the end stream flag
set) waiting to be sent. *)
0l
in
let written =
Streamd.flush_write_body
~max_bytes:(Int32.to_int allowed_bytes)
descriptor
in
let written32 = Int32.of_int written in
(* From RFC7540§6.9.1:
* After sending a flow-controlled frame, the sender reduces the space
* available in both windows by the length of the transmitted frame. *)
root.flow <- Int32.sub root.flow written32;
stream.flow <- Int32.sub stream.flow written32;
written
let mark_for_removal (Connection root) id closed =
StreamsTbl.replace root.marked_for_removal id closed
let implicitly_close_idle_stream descriptor max_seen_ids =
let implicitly_close_stream descriptor =
if Streamd.is_idle descriptor
then
(* From RFC7540§5.1.1:
* The first use of a new stream identifier implicitly closes all
* streams in the "idle" state that might have been initiated by
* that peer with a lower-valued stream identifier. *)
Streamd.finish_stream descriptor Finished
in
let max_client_stream_id, max_pushed_stream_id = max_seen_ids in
let stream_id = Streamd.id descriptor in
if Stream_identifier.is_request stream_id
then (
if stream_id < max_client_stream_id
then implicitly_close_stream descriptor)
else if stream_id < max_pushed_stream_id
then implicitly_close_stream descriptor
(* Scheduling algorithm from https://goo.gl/3sSHXJ (based on nghttp2):
*
* 1 def schedule(p):
* 2 if stream #p has data to send:
* 3 send data for #p, update nsent[p]
* 4 return
* 5 if #p's queue is empty:
* 6 return
* 7 pop #i from queue
* 8 update t_last[p] = t[i]
* 9 schedule(i)
* 10 if #i or its descendant is "active":
* 11 update t[i] and push it into queue again
* 12
* 13 schedule(0)
*)
let flush t max_seen_ids =
let rec schedule : type a. a node -> int * bool = function
| Connection _ as p_node ->
(* The root can never send data. *)
traverse p_node
| Stream ({ descriptor; _ } as stream) as p_node ->
let written =
if Streamd.requires_output descriptor
then
(* In this branch, flow-control has no bearing on activity, otherwise
* a flow-controlled stream would be considered inactive (because it
* can't make progress at the moment) and removed from the priority
* tree altogether. *)
write t p_node
else 0
in
if written > 0
then
(* We check for activity again, because the stream may have gone
* inactive after the call to `write` above. *)
let subtree_is_active =
Streamd.requires_output descriptor
|| not (PriorityQueue.is_empty stream.children)
in
written, subtree_is_active
else
(* If we haven't written anything, check if any of our children
have. *)
let written, subtree_is_active' = traverse p_node in
let subtree_is_active =
Streamd.requires_output descriptor || subtree_is_active'
in
(match written with
| 0 -> written, subtree_is_active
| written ->
(* If there's still more to write, put the node back in the tree. *)
if subtree_is_active then update_t p_node written;
written, subtree_is_active)
and traverse : type a. a node -> int * bool =
fun p_node ->
let rec loop remaining_children =
match PriorityQueue.pop remaining_children with
| Some ((id, (Stream i as i_node)), remaining_children') ->
update_t_last p_node i.t;
let written, subtree_is_active = schedule i_node in
if not subtree_is_active
then (
implicitly_close_idle_stream i.descriptor max_seen_ids;
(* XXX(anmonteiro): we may not want to remove from the tree right
* away. *)
remove_child p_node id);
(match written with
| 0 ->
(* If this subtree didn't write anything, check the other children
in the priority queue. *)
loop remaining_children'
| written ->
(* If there's still more to write, put the node back in the tree. *)
if subtree_is_active then update_t i_node written;
written, subtree_is_active)
| None ->
(* No data written, but queue was not originally empty.
* Therefore, we can't determine the subtree is inactive. *)
0, true
in
let children = children p_node in
match PriorityQueue.is_empty children with
| true ->
(* Queue is empty, see line 6 above. *)
0, false
| false -> loop children
in
let (Connection root) = t in
ignore (schedule t);
StreamsTbl.iter
(fun id closed ->
(* When a stream completes, i.e. doesn't require more output and
* enters the `Closed` state, we set a TTL value which represents the
* number of writer yields that the stream has before it is removed
* from the connection Hash Table. By doing this we avoid losing some
* potentially useful information regarding the stream's state at the
* cost of keeping it around for a little while longer. *)
if closed.Stream.ttl = 0
then (
StreamsTbl.remove root.marked_for_removal id;
StreamsTbl.remove root.all_streams id)
else closed.ttl <- closed.ttl - 1)
root.marked_for_removal
(* XXX(anmonteiro): Consider using `optint` for this?
* https://github.com/mirage/optint
*)
let check_flow flow growth flow' =
(* Check for overflow on 32-bit systems. *)
Int32.compare flow' growth > 0 = (Int32.compare flow 0l > 0)
&& Int32.compare flow' Settings.WindowSize.max_window_size <= 0
let add_flow : type a. a node -> int32 -> bool =
fun t growth ->
match t with
| Connection ({ flow; _ } as root) ->
let flow' = Int32.add flow growth in
let valid_flow = check_flow flow growth flow' in
if valid_flow then root.flow <- flow';
valid_flow
| Stream ({ flow; _ } as stream) ->
let flow' = Int32.add flow growth in
let valid_flow = check_flow flow growth flow' in
if valid_flow then stream.flow <- flow';
valid_flow
let add_inflow : type a. a node -> int32 -> bool =
fun t growth ->
match t with
| Connection ({ inflow; _ } as root) ->
let inflow' = Int32.add inflow growth in
let valid_inflow = check_flow inflow growth inflow' in
if valid_inflow then root.inflow <- inflow';
valid_inflow
| Stream ({ inflow; _ } as stream) ->
let inflow' = Int32.add inflow growth in
let valid_inflow = check_flow inflow growth inflow' in
if valid_inflow then stream.inflow <- inflow';
valid_inflow
let deduct_inflow : type a. a node -> int32 -> unit =
fun t size ->
match t with
| Connection ({ inflow; _ } as root) ->
(* no need to check, we verify that the peer is allowed to send. *)
root.inflow <- Int32.sub inflow size
| Stream ({ inflow; _ } as stream) -> stream.inflow <- Int32.sub inflow size
let pp_hum fmt t =
let rec pp_hum_inner level fmt t =
let pp_binding fmt (id, Stream { children; t; _ }) =
Format.fprintf
fmt
"\n%s%ld, %d -> [%a]"
(String.make (level * 2) ' ')
id
t
(pp_hum_inner (level + 1))
children
in
PriorityQueue.pp pp_binding fmt t
in
pp_hum_inner 0 fmt t
let pp_hum fmt (Connection { children; _ }) = pp_hum fmt children
end

627
unikernel/duniverse/ocaml-h2/lib/serialize.ml Normal file
View file

@ -0,0 +1,627 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2017 Inhabited Type LLC.
* Copyright (c) 2019 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
open Faraday
module IOVec = Httpun_types.IOVec
type frame_info =
{ flags : Flags.t
; stream_id : Stream_identifier.t
; padding : Bigstringaf.t
; max_frame_payload : int
}
let write_uint24 t n =
let write_octet t o = write_uint8 t (o land 0xff) in
write_octet t (n lsr 16);
write_octet t (n lsr 8);
write_octet t n
let write_frame_header t frame_header =
let { Frame.payload_length; flags; stream_id; frame_type } = frame_header in
write_uint24 t payload_length;
write_uint8 t (Frame.FrameType.serialize frame_type);
write_uint8 t flags;
BE.write_uint32 t stream_id
let write_frame_with_padding t info frame_type length writer =
let header, writer =
if Bigstringaf.length info.padding = 0
then
let header =
{ Frame.payload_length = length
; flags = info.flags
; stream_id = info.stream_id
; frame_type
}
in
header, writer
else
let pad_length = Bigstringaf.length info.padding in
let writer' t =
write_uint8 t pad_length;
writer t;
schedule_bigstring ~off:0 ~len:pad_length t info.padding
in
let header =
{ Frame.payload_length = length + pad_length + 1
; flags = Flags.set_padded info.flags
; stream_id = info.stream_id
; frame_type
}
in
header, writer'
in
write_frame_header t header;
writer t
let write_data_frame t ?off ?len info body =
let writer t = write_string t ?off ?len body in
let length = match len with Some len -> len | None -> String.length body in
write_frame_with_padding t info Data length writer
let schedule_data_frame t info ?off ?len bstr =
let writer t = schedule_bigstring t ?off ?len bstr in
let length =
match len with Some len -> len | None -> Bigstringaf.length bstr
in
write_frame_with_padding t info Data length writer
let write_priority t { Priority.exclusive; stream_dependency; weight } =
let stream_dependency_id =
if exclusive
then Priority.set_exclusive stream_dependency
else stream_dependency
in
BE.write_uint32 t stream_dependency_id;
(* From RFC7540§6.3:
* An unsigned 8-bit integer representing a priority weight for the stream
* (see Section 5.3). Add one to the value to obtain a weight between 1 and
* 256.
*
* Note: we store priority with values from 1 to 256, so decrement here. *)
write_uint8 t (weight - 1)
let bounded_schedule_iovecs t ~len iovecs =
let rec loop t remaining iovecs =
match remaining, iovecs with
| 0, _ | _, [] -> ()
| remaining, { IOVec.buffer; off; len } :: xs ->
if remaining < len
then schedule_bigstring t ~off ~len:remaining buffer
else (
schedule_bigstring t ~off ~len buffer;
loop t (remaining - len) xs)
in
loop t len iovecs
let write_headers_frame t info ~priority ?len iovecs =
let len = match len with Some len -> len | None -> IOVec.lengthv iovecs in
if priority == Priority.default_priority
then
(* See RFC7540§6.3:
* Just the Header Block Fragment length if no priority. *)
let writer t = bounded_schedule_iovecs t ~len iovecs in
write_frame_with_padding t info Headers len writer
else
(* See RFC7540§6.2:
* Exclusive Bit & Stream Dependency (4 octets) + Weight (1 octet) +
* Header Block Fragment length. *)
let payload_length = len + 5 in
let info' = { info with flags = Flags.set_priority info.flags } in
let writer t =
write_priority t priority;
bounded_schedule_iovecs t ~len iovecs
in
write_frame_with_padding t info' Headers payload_length writer
let write_priority_frame t info priority =
let header =
{ Frame.flags = info.flags
; stream_id =
info.stream_id
(* See RFC7540§6.3:
* Stream Dependency (4 octets) + Weight (1 octet). *)
; payload_length = 5
; frame_type = Priority
}
in
write_frame_header t header;
write_priority t priority
let write_rst_stream_frame t info e =
let header =
{ Frame.flags = info.flags
; stream_id =
info.stream_id
(* From RFC7540§6.4:
* The RST_STREAM frame contains a single unsigned, 32-bit integer
* identifying the error code (Section 7). *)
; payload_length = 4
; frame_type = RSTStream
}
in
write_frame_header t header;
BE.write_uint32 t (Error_code.serialize e)
let write_settings_frame t info settings =
let header =
{ Frame.flags = info.flags
; stream_id =
info.stream_id
(* From RFC7540§6.5.1:
* The payload of a SETTINGS frame consists of zero or more
* parameters, each consisting of an unsigned 16-bit setting
* identifier and an unsigned 32-bit value. *)
; payload_length = List.length settings * 6
; frame_type = Settings
}
in
write_frame_header t header;
Settings.write_settings_payload t settings
let write_push_promise_frame t info ~promised_id ?len iovecs =
let len = match len with Some len -> len | None -> IOVec.lengthv iovecs in
let payload_length =
(* From RFC7540§6.6:
* The PUSH_PROMISE frame includes the unsigned 31-bit identifier of the
* stream the endpoint plans to create along with a set of headers that
* provide additional context for the stream. *)
4 + len
in
let writer t =
BE.write_uint32 t promised_id;
bounded_schedule_iovecs t ~len iovecs
in
write_frame_with_padding t info PushPromise payload_length writer
let default_ping_payload =
(* From RFC7540§6.7:
* In addition to the frame header, PING frames MUST contain 8 octets of
* opaque data in the payload. *)
let bstr = Bigstringaf.create 8 in
for i = 0 to 7 do
Bigstringaf.unsafe_set bstr i '\000'
done;
bstr
let write_ping_frame t info ?(off = 0) payload =
(* From RFC7540§6.7:
* In addition to the frame header, PING frames MUST contain 8 octets of
* opaque data in the payload. *)
let payload_length = 8 in
let header =
{ Frame.flags = info.flags
; stream_id = info.stream_id
; payload_length
; frame_type = Ping
}
in
write_frame_header t header;
schedule_bigstring ~off ~len:payload_length t payload
let write_go_away_frame t info stream_id error_code debug_data =
let debug_data_len = Bigstringaf.length debug_data in
let header =
{ Frame.flags = info.flags
; stream_id =
info.stream_id
(* See RFC7540§6.8:
* Last-Stream-ID (4 octets) + Error Code (4 octets) + Additional
* Debug Data (opaque) *)
; payload_length = 8 + debug_data_len
; frame_type = GoAway
}
in
write_frame_header t header;
BE.write_uint32 t stream_id;
BE.write_uint32 t (Error_code.serialize error_code);
schedule_bigstring t ~off:0 ~len:debug_data_len debug_data
let write_window_update_frame t info window_size =
let header =
{ Frame.flags = info.flags
; stream_id =
info.stream_id
(* From RFC7540§6.9:
* The payload of a WINDOW_UPDATE frame is one reserved bit plus an
* unsigned 31-bit integer indicating the number of octets that the
* sender can transmit in addition to the existing flow-control
* window. *)
; payload_length = 4
; frame_type = WindowUpdate
}
in
write_frame_header t header;
BE.write_uint32 t window_size
let write_continuation_frame t info ?len iovecs =
let len = match len with Some len -> len | None -> IOVec.lengthv iovecs in
let header =
{ Frame.flags = info.flags
; stream_id = info.stream_id
; payload_length = len
; frame_type = Continuation
}
in
write_frame_header t header;
bounded_schedule_iovecs t ~len iovecs
let write_unknown_frame t ~code info payload =
let payload_length = Bigstringaf.length payload in
let header =
{ Frame.flags = info.flags
; stream_id = info.stream_id
; payload_length
; frame_type = Unknown code
}
in
write_frame_header t header;
schedule_bigstring t ~off:0 ~len:payload_length payload
let write_connection_preface t =
(* From RFC7540§3.5:
* In HTTP/2, each endpoint is required to send a connection preface as a
* final confirmation of the protocol in use and to establish the initial
* settings for the HTTP/2 connection. [...] The client connection preface
* starts with a sequence of 24 octets, [...] the string
* PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n. *)
write_string t Frame.connection_preface
module Writer = struct
type t =
{ buffer : Bigstringaf.t
(* The buffer that the encoder uses for buffered writes. Managed by
* the control module for the encoder. *)
; encoder : Faraday.t
(* The encoder that handles encoding for writes. Uses the [buffer]
* referenced above internally. *)
; mutable drained_bytes : int
(* The number of bytes that were not written due to the output stream
* being closed before all buffered output could be written. Useful
* for detecting error cases. *)
; mutable wakeup : Optional_thunk.t
}
let create buffer_size =
let buffer = Bigstringaf.create buffer_size in
let encoder = Faraday.of_bigstring buffer in
{ buffer; encoder; drained_bytes = 0; wakeup = Optional_thunk.none }
let faraday t = t.encoder
let make_frame_info
?(padding = Bigstringaf.empty)
?(flags = Flags.default_flags)
?(max_frame_size = Config.default.read_buffer_size)
stream_id
=
{ flags; stream_id; padding; max_frame_payload = max_frame_size }
let write_connection_preface t settings_list =
write_connection_preface t.encoder;
let frame_info = make_frame_info Stream_identifier.connection in
(* From RFC7540§3.5:
* This sequence MUST be followed by a SETTINGS frame (Section 6.5),
* which MAY be empty. *)
write_settings_frame t.encoder frame_info settings_list
let chunk_data_frames ?(off = 0) ~f frame_info total_length =
let { max_frame_payload; _ } = frame_info in
if max_frame_payload < total_length
then
let rec loop ~off remaining =
if max_frame_payload < remaining
then (
(* Note: If we're splitting data into several frames, only the last
* one should contain the END_STREAM flag, so unset it here if it's
* set. *)
let frame_info =
{ frame_info with flags = Flags.clear_end_stream frame_info.flags }
in
f ~off ~len:max_frame_payload frame_info;
loop ~off:(off + max_frame_payload) (remaining - max_frame_payload))
else f ~off ~len:remaining frame_info
in
loop ~off total_length
else f ~off ~len:total_length frame_info
let write_data t frame_info ?off ?len str =
if not (is_closed t.encoder)
then
let total_length =
match len with Some len -> len | None -> String.length str
in
chunk_data_frames
frame_info
?off
total_length
~f:(fun ~off ~len frame_info ->
write_data_frame t.encoder frame_info ~off ~len str)
let schedule_data t frame_info ?off ?len bstr =
if not (is_closed t.encoder)
then
let total_length =
match len with Some len -> len | None -> Bigstringaf.length bstr
in
chunk_data_frames
frame_info
?off
total_length
~f:(fun ~off ~len frame_info ->
schedule_data_frame t.encoder frame_info ~off ~len bstr)
(* Chunk header block fragments into HEADERS|PUSH_PROMISE + CONTINUATION
* frames. *)
let chunk_header_block_fragments
t
frame_info
?(has_priority = false)
~(write_frame :
Faraday.t -> frame_info -> ?len:int -> Bigstringaf.t iovec list -> unit)
faraday
=
let block_size = Faraday.pending_bytes faraday in
let total_length =
if has_priority
then
(* See RFC7540§6.2: Exclusive Bit & Stream Dependency (4 octets) +
Weight (1 octet) + Header Block Fragment length. *)
block_size + 5
else block_size
in
let { max_frame_payload; _ } = frame_info in
if max_frame_payload < total_length
then (
let headers_block_len =
if has_priority then max_frame_payload - 5 else max_frame_payload
in
ignore
(Faraday.serialize faraday (fun iovecs ->
write_frame t.encoder frame_info ~len:headers_block_len iovecs;
`Ok headers_block_len));
let rec loop remaining =
if max_frame_payload < remaining
then (
(* Note: Don't reuse flags from frame info as CONTINUATION frames
* only define END_HEADERS.
*
* From RFC7540§6.10:
* The CONTINUATION frame defines the following flag:
*
* END_HEADERS (0x4): When set, bit 2 indicates that this frame
* ends a header block (Section 4.3). *)
let frame_info = { frame_info with flags = Flags.default_flags } in
ignore
(Faraday.serialize faraday (fun iovecs ->
write_continuation_frame
t.encoder
frame_info
~len:max_frame_payload
iovecs;
`Ok max_frame_payload));
loop (remaining - max_frame_payload))
else
let frame_info =
{ frame_info with flags = Flags.(set_end_header default_flags) }
in
ignore
(Faraday.serialize faraday (fun iovecs ->
write_continuation_frame
t.encoder
frame_info
~len:remaining
iovecs;
`Ok remaining))
in
loop (block_size - headers_block_len))
else
let frame_info =
{ frame_info with flags = Flags.set_end_header frame_info.flags }
in
ignore
(Faraday.serialize faraday (fun iovecs ->
let len = IOVec.lengthv iovecs in
write_frame t.encoder frame_info ~len iovecs;
`Ok len))
let encode_headers hpack_encoder faraday headers =
List.iter
(fun header -> Hpack.Encoder.encode_header hpack_encoder faraday header)
(Headers.to_hpack_list headers)
let write_request_like_frame t hpack_encoder ~write_frame frame_info request =
let { Request.meth; target; scheme; headers } = request in
let faraday = Faraday.create 0x1000 in
Hpack.Encoder.encode_header
hpack_encoder
faraday
{ Headers.name = ":method"
; value = Httpun_types.Method.to_string meth
; sensitive = false
};
if meth <> `CONNECT
then (
(* From RFC7540§8.3:
* The :scheme and :path pseudo-header fields MUST be omitted. *)
Hpack.Encoder.encode_header
hpack_encoder
faraday
{ Headers.name = ":path"; value = target; sensitive = false };
Hpack.Encoder.encode_header
hpack_encoder
faraday
{ Headers.name = ":scheme"; value = scheme; sensitive = false });
encode_headers hpack_encoder faraday headers;
chunk_header_block_fragments t frame_info ~write_frame faraday
let write_request_headers t hpack_encoder ~priority frame_info request =
if not (is_closed t.encoder)
then
let write_frame = write_headers_frame ~priority in
write_request_like_frame t hpack_encoder ~write_frame frame_info request
let write_push_promise t hpack_encoder frame_info ~promised_id request =
if not (is_closed t.encoder)
then
let write_frame = write_push_promise_frame ~promised_id in
write_request_like_frame t hpack_encoder ~write_frame frame_info request
let write_response_headers t hpack_encoder frame_info response =
if not (is_closed t.encoder)
then (
let { Response.status; headers; _ } = response in
let faraday = Faraday.create 0x1000 in
(* From RFC7540§8.1.2.4:
* For HTTP/2 responses, a single :status pseudo-header field is defined
* that carries the HTTP status code field (see [RFC7231], Section 6).
* This pseudo-header field MUST be included in all responses; otherwise,
* the response is malformed (Section 8.1.2.6). *)
Hpack.Encoder.encode_header
hpack_encoder
faraday
{ Headers.name = ":status"
; value = Status.to_string status
; sensitive = false
};
encode_headers hpack_encoder faraday headers;
chunk_header_block_fragments
t
frame_info
~write_frame:(write_headers_frame ~priority:Priority.default_priority)
~has_priority:false
faraday)
let write_response_trailers t hpack_encoder frame_info trailers =
if not (is_closed t.encoder)
then (
let faraday = Faraday.create 0x1000 in
(* From RFC7540§8.1:
* optionally, one HEADERS frame, followed by zero or more
* CONTINUATION frames containing the trailer-part, if present (see
* [RFC7230], Section 4.1.2). *)
encode_headers hpack_encoder faraday trailers;
chunk_header_block_fragments
t
frame_info
~write_frame:(write_headers_frame ~priority:Priority.default_priority)
~has_priority:false
faraday)
let write_rst_stream t frame_info e =
if not (is_closed t.encoder)
then write_rst_stream_frame t.encoder frame_info e
let write_window_update t frame_info n =
if not (is_closed t.encoder)
then write_window_update_frame t.encoder frame_info n
let schedule_iovecs t ~len frame_info iovecs =
if not (is_closed t.encoder)
then
let writer t ~len ~iovecs = bounded_schedule_iovecs t ~len iovecs in
chunk_data_frames frame_info len ~f:(fun ~off ~len frame_info ->
write_frame_with_padding
t.encoder
frame_info
Data
len
(writer ~iovecs:(IOVec.shiftv iovecs off) ~len))
let write_priority t frame_info priority =
if not (is_closed t.encoder)
then write_priority_frame t.encoder frame_info priority
let write_settings t frame_info settings =
if not (is_closed t.encoder)
then write_settings_frame t.encoder frame_info settings
let write_ping t frame_info ?off payload =
if not (is_closed t.encoder)
then write_ping_frame t.encoder frame_info ?off payload
let write_go_away t frame_info ~debug_data ~last_stream_id error =
if not (is_closed t.encoder)
then
write_go_away_frame t.encoder frame_info last_stream_id error debug_data
let on_wakeup_writer t k =
if Faraday.is_closed t.encoder
then failwith "on_wakeup_writer on closed conn"
else if Optional_thunk.is_some t.wakeup
then failwith "on_wakeup: only one callback can be registered at a time"
else t.wakeup <- Optional_thunk.some k
let wakeup t =
let f = t.wakeup in
t.wakeup <- Optional_thunk.none;
Optional_thunk.call_if_some f
let flush t f =
flush_with_reason t.encoder (fun reason ->
let result =
match reason with
| Nothing_pending | Shift -> `Written
| Drain -> `Closed
in
f result)
let unyield t =
(* Faraday doesn't have a function to take the serializer out of a yield
state. In the meantime, `flush` does it. *)
flush t (fun _reason -> ())
let yield t = Faraday.yield t.encoder
let close t = Faraday.close t.encoder
let close_and_drain t =
Faraday.close t.encoder;
let drained = Faraday.drain t.encoder in
t.drained_bytes <- t.drained_bytes + drained
let is_closed t = Faraday.is_closed t.encoder
let drained_bytes t = t.drained_bytes
let report_result t result =
match result with
| `Closed -> close_and_drain t
| `Ok len -> shift t.encoder len
let next t =
match Faraday.operation t.encoder with
| `Close -> `Close (drained_bytes t)
| `Yield -> `Yield
| `Writev iovecs -> `Write iovecs
end

1418
unikernel/duniverse/ocaml-h2/lib/server_connection.ml Normal file
View file

File diff suppressed because it is too large Load diff

291
unikernel/duniverse/ocaml-h2/lib/settings.ml Normal file
View file

@ -0,0 +1,291 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019-2020 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
module WindowSize = struct
type t = int32
(* From RFC7540§6.9.2:
* When an HTTP/2 connection is first established, new streams are created
* with an initial flow-control window size of 65,535 octets. *)
let default_initial_window_size = 65535l
(* From RFC7540§6.9:
* The legal range for the increment to the flow-control window is 1 to
* 2^31-1 (2,147,483,647) octets. *)
let max_window_size = Int32.max_int
(* Ideally `n` here would be an unsigned 32-bit integer, but OCaml doesn't
* support them. We avoid introducing a new dependency on an unsigned integer
* library by letting it overflow at parse time and checking if bit 31 is set
* here, since * `Window.max_window_size` is never allowed to be above
* 2^31-1 (see `max_window_size` above).
* See http://caml.inria.fr/pub/ml-archives/caml-list/2004/07/f1c483068cc62075c916f7ad7d640ce0.fr.html
* for more info. *)
let is_window_overflow n = Util.test_bit_int32 n 31
end
type setting =
| HeaderTableSize of int
| EnablePush of int
| MaxConcurrentStreams of int32
| InitialWindowSize of int32
| MaxFrameSize (* this means payload size *) of int
| MaxHeaderListSize of int
type settings_list = setting list
(* From RFC7540§6.5.1:
* The payload of a SETTINGS frame consists of zero or more parameters,
* each consisting of an unsigned 16-bit setting identifier and an
* unsigned 32-bit value. *)
let octets_per_setting = 6
let serialize_key = function
| HeaderTableSize _ -> 0x1
| EnablePush _ -> 0x2
| MaxConcurrentStreams _ -> 0x3
| InitialWindowSize _ -> 0x4
| MaxFrameSize _ -> 0x5
| MaxHeaderListSize _ -> 0x6
let check_value ~is_client = function
| EnablePush v ->
if v <> 0 && v <> 1
then
(* From RFC7540§6.5.2
* The initial value is 1, which indicates that server push is
* permitted. Any value other than 0 or 1 MUST be treated as a
* connection error (Section 5.4.1) of type PROTOCOL_ERROR. *)
Error
Error.(
ConnectionError (ProtocolError, "SETTINGS_ENABLE_PUSH must be 0 or 1"))
else if is_client && v = 1
then
(* From RFC7540§8.2:
* Clients MUST reject any attempt to change the
* SETTINGS_ENABLE_PUSH setting to a value other than 0 by
* treating the message as a connection error (Section 5.4.1) of
* type PROTOCOL_ERROR. *)
Error
Error.(
ConnectionError
(ProtocolError, "Server must not try to enable SETTINGS_ENABLE_PUSH"))
else Ok ()
| InitialWindowSize v when WindowSize.is_window_overflow v ->
(* From RFC7540§6.5.2
* Values above the maximum flow-control window size of 2^31-1 MUST be
* treated as a connection error (Section 5.4.1) of type
* FLOW_CONTROL_ERROR. *)
Error
Error.(
ConnectionError
( FlowControlError
, Format.sprintf
"Window size must be less than or equal to %ld"
WindowSize.max_window_size ))
| MaxFrameSize v when v < 16384 || v > 16777215 ->
(* From RFC7540§6.5.2
* The initial value is 214 (16,384) octets. The value advertised by an
* endpoint MUST be between this initial value and the maximum allowed
* frame size (224-1 or 16,777,215 octets), inclusive. Values outside
* this range MUST be treated as a connection error (Section 5.4.1) of
* type PROTOCOL_ERROR. *)
Error
Error.(
ConnectionError
(ProtocolError, "Max frame size must be in the 16384 - 16777215 range"))
| _ -> Ok ()
(* Check incoming settings and report an error if any. *)
let check_settings_list ?(is_client = false) settings =
let rec loop = function
| [] -> Ok ()
| x :: xs ->
(match check_value ~is_client x with
| Ok () -> loop xs
| Error _ as err -> err)
in
loop settings
type t =
{ header_table_size : int
; enable_push : bool
; max_concurrent_streams : int32
; (* Indicates the amount tokens the peer allows an H2 endpoint to send. *)
initial_window_size : WindowSize.t
; max_frame_size : int
; max_header_list_size : int option
}
(* From RFC7540§11.3 *)
let default =
{ header_table_size = 0x1000
; enable_push =
true
(* From RFC7540§6.5.2:
* SETTINGS_MAX_CONCURRENT_STREAMS (0x3): [...] Initially, there is no
* limit to this value. *)
; max_concurrent_streams = Int32.max_int
; initial_window_size = WindowSize.default_initial_window_size
; max_frame_size = 0x4000
; max_header_list_size = None
}
let settings_for_the_connection settings =
let settings_list =
if settings.max_frame_size <> default.max_frame_size
then [ MaxFrameSize settings.max_frame_size ]
else []
in
let settings_list =
if settings.max_concurrent_streams <> default.max_concurrent_streams
then MaxConcurrentStreams settings.max_concurrent_streams :: settings_list
else settings_list
in
let settings_list =
if settings.initial_window_size <> default.initial_window_size
then
(* FIXME: don't convert *)
InitialWindowSize settings.initial_window_size :: settings_list
else settings_list
in
let settings_list =
if settings.enable_push <> default.enable_push
then EnablePush (if settings.enable_push then 1 else 0) :: settings_list
else settings_list
in
settings_list
let parse_settings_payload num_settings =
let open Angstrom in
let rec parse_inner acc remaining =
(* From RFC7540§6.5.3:
* The values in the SETTINGS frame MUST be processed in the order
* they appear, with no other frame processing between values. *)
if remaining <= 0
then return (List.rev acc)
else
lift2
(fun k (v : int32) ->
match k with
| 0x1 -> HeaderTableSize (Int32.to_int v) :: acc
| 0x2 -> EnablePush (Int32.to_int v) :: acc
| 0x3 -> MaxConcurrentStreams v :: acc
| 0x4 -> InitialWindowSize v :: acc
| 0x5 -> MaxFrameSize (Int32.to_int v) :: acc
| 0x6 -> MaxHeaderListSize (Int32.to_int v) :: acc
| _ ->
(* Note: This ignores unknown settings.
*
* From RFC7540§6.5.3:
* Unsupported parameters MUST be ignored.
*)
acc)
BE.any_uint16
BE.any_int32
>>= fun acc' -> parse_inner acc' (remaining - 1)
in
parse_inner [] num_settings
let write_settings_payload t settings_list =
let open Faraday in
List.iter
(fun setting ->
(* From RFC7540§6.5.1:
* The payload of a SETTINGS frame consists of zero or more parameters,
* each consisting of an unsigned 16-bit setting identifier and an
* unsigned 32-bit value. *)
BE.write_uint16 t (serialize_key setting);
match setting with
| MaxConcurrentStreams value | InitialWindowSize value ->
BE.write_uint32 t value
| HeaderTableSize value
| EnablePush value
| MaxFrameSize value
| MaxHeaderListSize value ->
BE.write_uint32 t (Int32.of_int value))
settings_list
let of_settings_list settings =
List.fold_left
(fun (acc : t) item ->
match item with
| HeaderTableSize x -> { acc with header_table_size = x }
| EnablePush x -> { acc with enable_push = x = 1 }
| MaxConcurrentStreams x -> { acc with max_concurrent_streams = x }
| InitialWindowSize new_val -> { acc with initial_window_size = new_val }
| MaxFrameSize x -> { acc with max_frame_size = x }
| MaxHeaderListSize x -> { acc with max_header_list_size = Some x })
default
settings
let of_base64 encoded =
match Base64.decode ~alphabet:Base64.uri_safe_alphabet encoded with
| Ok settings_payload ->
let settings_payload_length =
String.length settings_payload / octets_per_setting
in
(match
Angstrom.parse_string
~consume:All
(parse_settings_payload settings_payload_length)
settings_payload
with
| Ok settings -> Ok (of_settings_list settings)
| Error _ as e -> e)
| Error (`Msg msg) -> Error msg
let to_base64 t =
let settings = settings_for_the_connection t in
let faraday = Faraday.create (List.length settings * 6) in
write_settings_payload faraday settings;
let settings_hex = Faraday.serialize_to_string faraday in
match Base64.encode ~alphabet:Base64.uri_safe_alphabet settings_hex with
| Ok r -> Ok r
| Error (`Msg msg) -> Error msg
let pp_hum formatter t =
let pp_elem formatter setting =
let key, value =
match setting with
| HeaderTableSize v -> "HEADER_TABLE_SIZE", Int64.of_int v
| EnablePush v -> "ENABLE_PUSH", Int64.of_int v
| MaxConcurrentStreams v -> "MAX_CONCURRENT_STREAMS", Int64.of_int32 v
| InitialWindowSize v -> "INITIAL_WINDOW_SIZE", Int64.of_int32 v
| MaxFrameSize v -> "MAX_FRAME_SIZE", Int64.of_int v
| MaxHeaderListSize v -> "MAX_HEADER_LIST_SIZE", Int64.of_int v
in
Format.fprintf formatter "@[(%S %Ld)@]" key value
in
Format.fprintf formatter "@[(";
Format.pp_print_list pp_elem formatter (settings_for_the_connection t);
Format.fprintf formatter ")@]"

123
unikernel/duniverse/ocaml-h2/lib/status.ml Normal file
View file

@ -0,0 +1,123 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2017 Inhabited Type LLC.
* Copyright (c) 2019 Antonio N. Monteiro.
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the author nor the names of his contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
(* From RFC7540§8.1.1:
* HTTP/2 removes support for the 101 (Switching Protocols) informational
* status code ([RFC7231], Section 6.2.2).
*
* Note: While the above is true, we don't enforce in this library, as it
* makes unifying types with httpun much easier. `H2.Status.t` is, thus, a
* strict superset of `Httpun_types.Status.t`. *)
include (
Httpun_types.Status :
module type of Httpun_types.Status
with type client_error := Httpun_types.Status.client_error
and type standard := Httpun_types.Status.standard
and type t := Httpun_types.Status.t)
type client_error =
[ Httpun_types.Status.client_error
| (* From RFC7540§9.1.2:
* The 421 (Misdirected Request) status code indicates that the request
* was directed at a server that is not able to produce a response. This
* can be sent by a server that is not configured to produce responses
* for the combination of scheme and authority that are included in the
* request URI. *)
`Misdirected_request
]
type standard =
[ Httpun_types.Status.standard
| client_error
]
type t =
[ standard
| `Code of int
]
(* Note: The value for reason phrases is never actually serialized to the
* input or output channels.
*
* From RFC7540§8.1.2.4:
* HTTP/2 does not define a way to carry the version or reason phrase that is
* included in an HTTP/1.1 status line. *)
let default_reason_phrase = function
| `Misdirected_request -> "Misdirected Request"
| #Httpun_types.Status.standard as t ->
Httpun_types.Status.default_reason_phrase t
let to_code = function
| `Misdirected_request -> 421
| #Httpun_types.Status.t as t -> Httpun_types.Status.to_code t
let unsafe_of_code = function
| 421 -> `Misdirected_request
| c -> (Httpun_types.Status.unsafe_of_code c :> t)
let of_code = function
| 421 -> `Misdirected_request
| c -> (Httpun_types.Status.of_code c :> t)
let is_informational = function
| `Misdirected_request -> false
| #Httpun_types.Status.t as t -> Httpun_types.Status.is_informational t
let is_successful = function
| `Misdirected_request -> false
| #Httpun_types.Status.t as t -> Httpun_types.Status.is_successful t
let is_redirection = function
| `Misdirected_request -> false
| #Httpun_types.Status.t as t -> Httpun_types.Status.is_redirection t
let is_client_error = function
| `Misdirected_request -> true
| #Httpun_types.Status.t as t -> Httpun_types.Status.is_client_error t
let is_server_error = function
| `Misdirected_request -> false
| #Httpun_types.Status.t as t -> Httpun_types.Status.is_server_error t
let is_error = function
| `Misdirected_request -> true
| #Httpun_types.Status.t as t -> Httpun_types.Status.is_error t
let to_string = function
| `Misdirected_request -> "421"
| #Httpun_types.Status.t as t -> Httpun_types.Status.to_string t
let of_string x = of_code (int_of_string x)
let pp_hum fmt t = Format.fprintf fmt "%u" (to_code t)

157
unikernel/duniverse/ocaml-h2/lib/stream.ml Normal file
View file

@ -0,0 +1,157 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
module AB = Angstrom.Buffered
module Writer = Serialize.Writer
type partial_headers =
{ mutable parse_state : (Headers.t, Hpack.error) result AB.state
; end_stream : bool
}
type 'active_peer remote_state =
(* A stream is in this state when it's waiting for the peer to initiate a
* response. In practice, it only matters for the client implementation, when
* a client has opened a stream but is still waiting on the server to send
* the first bytes of the response. *)
| WaitingForPeer
(* A PartialHeaders state is entered when the endpoint sees the first HEADERS
* frame from the peer for a given stream. Its payload is an
* Angstrom.Buffered parse state. *)
| PartialHeaders of partial_headers
(* A stream transitions from the PartialHeaders state to the FullHeaders
* state when the endpoint has finished parsing all the bytes in a group of
* HEADER / CONTINUATION frames that the peer has sent.
* This state doesn't carry any payload because the stream will immediately
* transition to the ActiveMessage state once the message has been validated
* according to RFC7540§8.1.2. *)
| FullHeaders
(* The ActiveMessage state carries information about the current remote
* message being processed by the endpoint. *)
| ActiveMessage of 'active_peer
type closed_reason =
| Finished
(* TODO: we could abide by the following by either 1) having I/O runtime
* support for timers or 2) by simply counting the number of frames received
* after we've sent an RST_STREAM?
*
* From RFC7540§5.4.2:
* Normally, an endpoint SHOULD NOT send more than one RST_STREAM frame for
* any stream. However, an endpoint MAY send additional RST_STREAM frames
* if it receives frames on a closed stream after more than a round-trip
* time. This behavior is permitted to deal with misbehaving
* implementations. *)
| ResetByUs of Error_code.t
(* Received an RST_STREAM frame from the peer. *)
| ResetByThem of Error_code.t
type closed =
{ reason : closed_reason
(* When a stream is closed, we may want to keep it around in the hash
* table for a while (e.g. to know whether this stream was reset by the
* peer - some error handling code depends on that). We start with a
* default value, and on every writer yield we decrement it. If it
* reaches 0, the stream is finally removed from the hash table. *)
; mutable ttl : int
}
type ('opn, 'half_closed) active_state =
| Open of 'opn remote_state
| HalfClosed of 'half_closed
type ('active_state, 'active, 'reserved) state =
| Idle
| Reserved of 'reserved
| Active of 'active_state * 'active
| Closed of closed
constraint 'active_state = (_, _) active_state
type 'a error_status =
| No_error
| Exn of exn
| Other of
{ error : 'a
; code : Error_code.t
}
type ('state, 'error, 'error_handler) t =
{ id : Stream_identifier.t
; writer : Serialize.Writer.t
; error_handler : 'error_handler
; mutable error_code : 'error error_status
; mutable state : 'state
(* The largest frame payload we're allowed to write. *)
; mutable max_frame_size : int
; on_close : active:bool -> closed -> unit
}
constraint 'state = (_, _, _) state
let initial_ttl = 10
let create id ~max_frame_size writer error_handler on_close =
{ id
; writer
; error_handler
(* From RFC7540§5.1:
* idle: All streams start in the "idle" state. *)
; state = Idle
; error_code = No_error
; max_frame_size
; on_close
}
let id { id; _ } = id
let is_idle t = match t.state with Idle -> true | _ -> false
let is_open t = match t.state with Active (Open _, _) -> true | _ -> false
let finish_stream t reason =
let active = match t.state with Active _ -> true | _ -> false in
let closed = { reason; ttl = initial_ttl } in
t.on_close ~active closed;
t.state <- Closed closed
let error_code t =
match t.error_code with
| Exn exn -> Some (`Exn exn)
| Other { error; _ } -> Some error
| No_error -> None
let error_to_code error error_code =
match error with
| `Exn exn -> Exn exn
| other -> Other { error = other; code = error_code }
let reset_stream t error_code =
let frame_info = Writer.make_frame_info t.id in
Writer.write_rst_stream t.writer frame_info error_code;
finish_stream t (ResetByUs error_code)

65
unikernel/duniverse/ocaml-h2/lib/stream_identifier.ml Normal file
View file

@ -0,0 +1,65 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
(* From RFC7540§5.1.1:
* Streams are identified with an unsigned 31-bit integer. *)
type t = int32
let ( === ) = Int32.equal
let[@inline] ( <= ) s1 s2 = Int32.compare s1 s2 <= 0
let[@inline] ( > ) s1 s2 = Int32.compare s1 s2 > 0
let[@inline] ( >= ) s1 s2 = Int32.compare s1 s2 >= 0
(* From RFC7540§5.1.1:
* A stream identifier of zero (0x0) is used for connection control messages;
* the stream identifier of zero cannot be used to establish a new stream. *)
let connection = Int32.zero
(* From RFC7540§5.1.1:
* A stream identifier of zero (0x0) is used for connection control messages;
* the stream identifier of zero cannot be used to establish a new stream. *)
let[@inline] is_connection id = Int32.equal id connection
(* From RFC7540§5.1.1:
* Streams initiated by a client MUST use odd-numbered stream
* identifiers [...]. *)
let[@inline] is_request id = Int32.rem id 2l === 1l
(* From RFC7540§5.1.1:
* Streams initiated by [...] the server MUST use even-numbered stream
* identifiers. A stream identifier of zero (0x0) is used for connection
* control messages [...]. *)
let[@inline] is_pushed = function 0l -> false | n -> Int32.rem n 2l === 0l
(* From RFC7540§5.1.1:
* Streams are identified with an unsigned 31-bit integer. *)
let max_stream_id = Int32.max_int

48
unikernel/duniverse/ocaml-h2/lib/util.ml Normal file
View file

@ -0,0 +1,48 @@
(*----------------------------------------------------------------------------
* Copyright (c) 2019 António Nuno Monteiro
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. Neither the name of the copyright holder nor the names of its
* contributors may be used to endorse or promote products derived from this
* software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
let[@inline] test_bit_int32 x i =
let open Int32 in
not (equal (logand x (shift_left 1l i)) 0l)
let[@inline] test_bit x i = x land (1 lsl i) <> 0
let[@inline] set_bit x i = x lor (1 lsl i)
let[@inline] set_bit_int32 x i =
let open Int32 in
logor x (shift_left 1l i)
let[@inline] clear_bit x i = x land lnot (1 lsl i)
let[@inline] clear_bit_int32 x i =
let open Int32 in
logand x (lognot (shift_left 1l i))

22
unikernel/duniverse/ocaml-h2/lib_test/dune Normal file
View file

@ -0,0 +1,22 @@
(tests
(libraries bigstringaf h2 alcotest test_common)
(modules test_h2 test_h2_client test_h2_server test_priority)
(names test_h2 test_h2_client test_h2_server test_priority))
(library
(name test_common)
(libraries base64 bigstringaf hex h2 alcotest)
(modules test_common))
(executable
(name test_frames)
(libraries h2 alcotest yojson hex angstrom test_common)
(modules test_frames))
(rule
(alias runtest)
(deps
(:test_exe test_frames.exe)
(source_tree "http2-frame-test-case/"))
(action
(run %{test_exe})))

122
unikernel/duniverse/ocaml-h2/lib_test/test_common.ml Normal file
View file

@ -0,0 +1,122 @@
open H2__
module Option = struct
let get = function Some x -> x | None -> failwith "Option.get: None"
let map f = function Some x -> Some (f x) | None -> None
end
let read_all path =
let file = open_in path in
try really_input_string file (in_channel_length file) with
| exn ->
close_in file;
raise exn
let bs_to_string bs =
let off = 0 in
let len = Bigstringaf.length bs in
Bigstringaf.substring ~off ~len bs
let bs_of_string s = Bigstringaf.of_string ~off:0 ~len:(String.length s) s
let string_of_hex s = Hex.to_string (`Hex s)
let hex_of_string s =
let (`Hex hex) = Hex.of_string s in
String.uppercase_ascii hex
let make_iovecs bs =
[ { Httpun_types.IOVec.buffer = bs; off = 0; len = Bigstringaf.length bs } ]
let write_frame ?padding t { Frame.frame_header; frame_payload } =
let open Serialize in
let { Frame.flags; stream_id; _ } = frame_header in
let info = Writer.make_frame_info ~flags ?padding stream_id in
match frame_payload with
| Data body -> Writer.schedule_data t info body
| Headers (priority, headers_block) ->
(* Block already HPACK-encoded. *)
write_headers_frame t.encoder info ~priority (make_iovecs headers_block)
| Priority p -> Writer.write_priority t info p
| RSTStream e -> Writer.write_rst_stream t info e
| Settings settings -> Writer.write_settings t info settings
| PushPromise (promised_id, header_block) ->
write_push_promise_frame
t.encoder
info
~promised_id
(make_iovecs header_block)
| Ping payload -> Writer.write_ping t info payload
| GoAway (last_stream_id, error, debug_data) ->
Writer.write_go_away t info ~debug_data ~last_stream_id error
| WindowUpdate window_size -> Writer.write_window_update t info window_size
| Continuation header_block ->
write_continuation_frame t.encoder info (make_iovecs header_block)
| Unknown (code, payload) -> write_unknown_frame t.encoder ~code info payload
let serialize_frame ?padding frame =
let open Serialize in
let { Frame.payload_length; _ } = frame.Frame.frame_header in
let writer = Writer.create payload_length in
write_frame ?padding writer frame;
Faraday.serialize_to_bigstring (Writer.faraday writer)
let serialize_frame_string ?padding frame =
let bs = serialize_frame ?padding frame in
bs_to_string bs
let opt_exn = function Some x -> x | None -> failwith "opt_exn: None"
let encode_headers hpack_encoder headers =
let f = Faraday.create 0x1000 in
Serialize.Writer.encode_headers hpack_encoder f headers;
Faraday.serialize_to_bigstring f
let decode_headers decoder bigstring =
let parser = Angstrom.Buffered.parse (Hpack.Decoder.decode_headers decoder) in
let state = Angstrom.Buffered.feed parser (`Bigstring bigstring) in
let state' = Angstrom.Buffered.feed state `Eof in
match Angstrom.Buffered.state_to_option state' with
| Some (Ok headers) -> headers
| Some _ | None -> assert false
let preface =
let writer = Serialize.Writer.create 0x400 in
Serialize.Writer.write_connection_preface writer [];
Faraday.serialize_to_string (Serialize.Writer.faraday writer)
let handle_preface t =
let open Parse in
let preface_len = String.length preface in
ignore
@@ Reader.read_with_more
t
(bs_of_string preface)
~off:0
~len:preface_len
Incomplete
let parse_frames_bigstring wire =
let open Parse in
let frames = ref [] in
let handler = function
| Ok frame -> frames := frame :: !frames
| _ -> Alcotest.fail "Expected frame to parse successfully."
in
let reader =
Reader.server_frames
~max_frame_size:H2.Settings.default.max_frame_size
(fun _ -> ignore)
handler
in
handle_preface reader;
let _read =
Reader.read_with_more
reader
wire
~off:0
~len:(Bigstringaf.length wire)
Incomplete
in
List.rev !frames
let parse_frames wire = parse_frames_bigstring (bs_of_string wire)

Some files were not shown because too many files have changed in this diff Show more