This commit is contained in:
parent
aa2ff7b2f0
commit
2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
28
unikernel/duniverse/httpun/.github/workflows/test.yml
vendored
Normal file
28
unikernel/duniverse/httpun/.github/workflows/test.yml
vendored
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
name: "Build"
|
||||
on:
|
||||
pull_request:
|
||||
push:
|
||||
branches:
|
||||
- master
|
||||
- fork
|
||||
|
||||
concurrency:
|
||||
group: ${{ github.workflow }}-${{ github.ref }}
|
||||
cancel-in-progress: true
|
||||
|
||||
jobs:
|
||||
tests:
|
||||
runs-on: ubuntu-latest
|
||||
strategy:
|
||||
matrix:
|
||||
ocamlVersion: [4_14, 5_1, 5_2]
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
- 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 }}
|
||||
|
||||
9
unikernel/duniverse/httpun/.gitignore
vendored
Normal file
9
unikernel/duniverse/httpun/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
.*.sw[po]
|
||||
_build/
|
||||
_tests/
|
||||
lib_test/tests_
|
||||
*.native
|
||||
*.byte
|
||||
*.docdir
|
||||
.merlin
|
||||
*.install
|
||||
18
unikernel/duniverse/httpun/CHANGES.md
Normal file
18
unikernel/duniverse/httpun/CHANGES.md
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
0.2.0 2024-09-04
|
||||
--------------
|
||||
|
||||
- client: report exceptions before closing the response body
|
||||
([#135](https://github.com/anmonteiro/httpun/pull/135))
|
||||
- server: process requests after EOF
|
||||
([#136](https://github.com/anmonteiro/httpun/pull/136))
|
||||
- surface (body) write errors through `flush`
|
||||
([#138](https://github.com/anmonteiro/httpun/pull/138))
|
||||
- `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.1.0 2024-06-08
|
||||
--------------
|
||||
|
||||
- Initial public release
|
||||
84
unikernel/duniverse/httpun/FORK.md
Normal file
84
unikernel/duniverse/httpun/FORK.md
Normal file
|
|
@ -0,0 +1,84 @@
|
|||
Unreleased
|
||||
--------------
|
||||
|
||||
- httpaf-lwt-unix: add support for HTTPS in the Lwt runtime, either via OpenSSL
|
||||
or `ocaml-tls` ([#2](https://github.com/anmonteiro/httpaf/pull/2))
|
||||
- httpaf, httpaf-lwt, httpaf-lwt-unix, httpaf-mirage: Add a Mirage adapter
|
||||
([#3](https://github.com/anmonteiro/httpaf/pull/3))
|
||||
- Add an `esy.json` file ([#6](https://github.com/anmonteiro/httpaf/pull/6))
|
||||
- httpaf: Catch parsing errors and hand them to `error_handler` in
|
||||
`Server_connection` ([#4](https://github.com/anmonteiro/httpaf/pull/4))
|
||||
- httpaf, httpaf-lwt, httpaf-lwt-unix, httpaf-async, httpaf-mirage: add support
|
||||
for persistent connections and pipelining in the client implementations
|
||||
([#5](https://github.com/anmonteiro/httpaf/pull/5))
|
||||
- httpaf, httpaf-lwt, httpaf-lwt-unix, httpaf-async, httpaf-mirage: add support
|
||||
for switching protocols, e.g. to a WebSocket connection, via a new function
|
||||
`Reqd.respond_with_upgrade`
|
||||
([#8](https://github.com/anmonteiro/httpaf/pull/8))
|
||||
- httpaf-lwt, httpaf-lwt-unix, httpaf-mirage: deduplicate interface code via a
|
||||
common `Httpaf_lwt_intf` interface
|
||||
([#13](https://github.com/anmonteiro/httpaf/pull/13))
|
||||
- httpaf-mirage: depend on `mirage-conduit` instead of `conduit-mirage`,
|
||||
effectively placing a lower bound of OCaml 4.07 on httpaf-mirage
|
||||
([#16](https://github.com/anmonteiro/httpaf/pull/16))
|
||||
- httpaf-lwt-unix: replace the `dune` file (previously written in OCaml) with a
|
||||
`(select)` form to avoid depending on `ocamlfind`
|
||||
([#18](https://github.com/anmonteiro/httpaf/pull/18))
|
||||
- httpaf: Shutdown the writer after closing a non chunk-encoded request body on
|
||||
the client ([#23](https://github.com/anmonteiro/httpaf/pull/23))
|
||||
- httpaf-mirage: Adapt to Mirage 3.7 interfaces. `httpaf_mirage` now requires
|
||||
`conduit-mirage` >= 2.0.2 and `mirage-flow` >= 2.0.0
|
||||
([#24](https://github.com/anmonteiro/httpaf/pull/24))
|
||||
- httpaf, httpaf-lwt, httpaf-lwt-unix, httpaf-async, httpaf-mirage: after
|
||||
switching protocols, close the connection / file descriptors when the upgrade
|
||||
handler's returned promise resolves
|
||||
([#26](https://github.com/anmonteiro/httpaf/pull/26))
|
||||
- httpaf-lwt, httpaf-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
|
||||
([#28](https://github.com/anmonteiro/httpaf/pull/28))
|
||||
- httpaf-lwt, httpaf-lwt-unix, httpaf-mirage: Improve the `Httpaf_lwt.IO`
|
||||
interface, don't require a `report_exn` function, only a `state` function
|
||||
that returns the socket state
|
||||
([#30](https://github.com/anmonteiro/httpaf/pull/30))
|
||||
- httpaf, httpaf-lwt, httpaf-async: Add support for upgrading connections on
|
||||
the client. ([#31](https://github.com/anmonteiro/httpaf/pull/31))
|
||||
- httpaf: Fix the order of parsed request / response headers to match what it's
|
||||
advertised in the interface file. They are now served to the respective
|
||||
handlers in the original transmission order
|
||||
([#32](https://github.com/anmonteiro/httpaf/pull/32))
|
||||
- httpaf: Fix persistent connections getting stuck (reader never waking up)
|
||||
when using `~flush_headers_immediately:true` in combination with an empty
|
||||
response body ([#34](https://github.com/anmonteiro/httpaf/pull/34)). This is
|
||||
a fix for an issue opened in the upstream repo:
|
||||
[inhabitedtype/httpaf#162](https://github.com/inhabitedtype/httpaf/issues/162)
|
||||
- httpaf-async: Add HTTPS support for the Async bindings
|
||||
([#35](https://github.com/anmonteiro/httpaf/pull/35)).
|
||||
- httpaf: Fix upstream regression introduced in
|
||||
[inhabitedtype/httpaf#161](https://github.com/inhabitedtype/httpaf/pull/161)
|
||||
that caused `wake_up_writer` callback bookkeeping to be slightly wrong due to
|
||||
physical equality, producing runtime errors in cases where it shouldn't
|
||||
([#37](https://github.com/anmonteiro/httpaf/pull/37)).
|
||||
- httpaf-lwt: Close the communication channel after shutting down the client
|
||||
([#45](https://github.com/anmonteiro/httpaf/pull/45))
|
||||
- httpaf: Fix sending streaming error responses; in particular, allow sending
|
||||
chunk-encoded responses ([#56](https://github.com/anmonteiro/httpaf/pull/56))
|
||||
- httpaf: handle read backpressure in server and client implementations
|
||||
([#59](https://github.com/anmonteiro/httpaf/pull/59))
|
||||
- httpaf-lwt, httpaf-lwt-unix: Use
|
||||
[gluten](https://github.com/anmonteiro/gluten) to implement the Lwt-based
|
||||
runtimes ([#63](https://github.com/anmonteiro/httpaf/pull/63))
|
||||
- httpaf-async: Use [gluten](https://github.com/anmonteiro/gluten) to implement
|
||||
the Async runtimes ([#69](https://github.com/anmonteiro/httpaf/pull/69))
|
||||
- httpaf: call error handler on read EOF if the entire body hasn't been
|
||||
received ([#75](https://github.com/anmonteiro/httpaf/pull/75))
|
||||
- httpaf: Abort (chunked) responses correctly if an error is reported
|
||||
([#84](https://github.com/anmonteiro/httpaf/pull/84),
|
||||
[#86](https://github.com/anmonteiro/httpaf/pull/86))
|
||||
|
||||
httpaf (upstream) 0.6.6
|
||||
--------------
|
||||
|
||||
- Initial fork point
|
||||
[7de2d4ea](https://github.com/anmonteiro/httpaf/commit/6aefc835552010ce8f8466c8695a7b106b49ec35)
|
||||
31
unikernel/duniverse/httpun/LICENSE
Normal file
31
unikernel/duniverse/httpun/LICENSE
Normal file
|
|
@ -0,0 +1,31 @@
|
|||
Copyright (c) 2016, Inhabited Type LLC
|
||||
Copyright (c) 2019, Antonio 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 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.
|
||||
24
unikernel/duniverse/httpun/Makefile
Normal file
24
unikernel/duniverse/httpun/Makefile
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
.PHONY: all build clean test examples
|
||||
|
||||
build:
|
||||
dune build @install
|
||||
|
||||
all: build
|
||||
|
||||
test:
|
||||
dune runtest --no-buffer
|
||||
|
||||
examples:
|
||||
dune build @examples
|
||||
|
||||
watch:
|
||||
dune build {httpun,httpun-async,httpun-lwt-unix}.install @runtest --watch
|
||||
|
||||
install:
|
||||
dune install
|
||||
|
||||
uninstall:
|
||||
dune uninstall
|
||||
|
||||
clean:
|
||||
rm -rf _build *.install
|
||||
28
unikernel/duniverse/httpun/README.md
Normal file
28
unikernel/duniverse/httpun/README.md
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
# http/un
|
||||
|
||||
http/un is a high-performance, memory-efficient, scalable and web library for
|
||||
OCaml. It uses the [Angstrom][angstrom] and [Faraday][faraday]
|
||||
libraries for parsing and serialization.
|
||||
|
||||
[angstrom]: https://github.com/inhabitedtype/angstrom
|
||||
[faraday]: https://github.com/inhabitedtype/faraday
|
||||
|
||||
httpun is a fork of [httpaf](https://github.com/inhabitedtype/httpaf) that
|
||||
fixes bugs in the original work and adds additional features. See
|
||||
[FORK.md](./FORK.md) for more details on those changes.
|
||||
|
||||
## Installation
|
||||
|
||||
```bash
|
||||
opam install httpun
|
||||
```
|
||||
|
||||
## Usage
|
||||
|
||||
Check the [`examples`][examples] folder.
|
||||
|
||||
[examples]: https://github.com/anmonteiro/httpun/tree/master/examples
|
||||
|
||||
## License
|
||||
|
||||
BSD3, see [LICENSE](./LICENSE) files for its text.
|
||||
4
unikernel/duniverse/httpun/async/dune
Normal file
4
unikernel/duniverse/httpun/async/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(library
|
||||
(name httpun_async)
|
||||
(public_name httpun-async)
|
||||
(libraries async core httpun gluten-async))
|
||||
167
unikernel/duniverse/httpun/async/httpun_async.ml
Normal file
167
unikernel/duniverse/httpun/async/httpun_async.ml
Normal file
|
|
@ -0,0 +1,167 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2018 Inhabited Type LLC.
|
||||
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 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
|
||||
|
||||
module Server = struct
|
||||
type 'a socket = ([`Active], [< Socket.Address.t] as 'a) Socket.t
|
||||
|
||||
let create_connection_handler
|
||||
?(config=Httpun.Config.default)
|
||||
~request_handler
|
||||
~error_handler =
|
||||
fun client_addr socket ->
|
||||
let create_connection =
|
||||
Httpun.Server_connection.create
|
||||
~config
|
||||
~error_handler:(error_handler client_addr)
|
||||
in
|
||||
Gluten_async.Server.create_upgradable_connection_handler
|
||||
~read_buffer_size:config.read_buffer_size
|
||||
~protocol:(module Httpun.Server_connection)
|
||||
~create_protocol:create_connection
|
||||
~request_handler
|
||||
client_addr
|
||||
socket
|
||||
|
||||
module SSL = struct
|
||||
let create_connection_handler
|
||||
?(config=Httpun.Config.default)
|
||||
~request_handler
|
||||
~error_handler =
|
||||
fun client_addr socket ->
|
||||
let create_connection =
|
||||
Httpun.Server_connection.create
|
||||
~config
|
||||
~error_handler:(error_handler client_addr)
|
||||
in
|
||||
Gluten_async.Server.SSL.create_upgradable_connection_handler
|
||||
~read_buffer_size:config.read_buffer_size
|
||||
~protocol:(module Httpun.Server_connection)
|
||||
~create_protocol:create_connection
|
||||
~request_handler
|
||||
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:["http/1.1"]
|
||||
~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: Httpun.Client_connection.t
|
||||
; runtime: 'a runtime
|
||||
}
|
||||
|
||||
let create_connection ?(config=Httpun.Config.default) socket =
|
||||
let connection = Httpun.Client_connection.create ~config () in
|
||||
Client_runtime.create
|
||||
~read_buffer_size:config.read_buffer_size
|
||||
~protocol:(module Httpun.Client_connection)
|
||||
connection
|
||||
socket
|
||||
>>| fun runtime ->
|
||||
{ runtime; connection }
|
||||
|
||||
let request t = Httpun.Client_connection.request t.connection
|
||||
|
||||
let shutdown t = Client_runtime.shutdown t.runtime
|
||||
|
||||
let is_closed t = Client_runtime.is_closed t.runtime
|
||||
|
||||
let upgrade t protocol = Client_runtime.upgrade t.runtime protocol
|
||||
|
||||
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: Httpun.Client_connection.t
|
||||
; runtime: 'a runtime
|
||||
}
|
||||
|
||||
let create_connection ?(config=Httpun.Config.default) socket =
|
||||
let connection = Httpun.Client_connection.create ~config () in
|
||||
Client_runtime.create
|
||||
~read_buffer_size:config.read_buffer_size
|
||||
~protocol:(module Httpun.Client_connection)
|
||||
connection
|
||||
socket
|
||||
>>| fun runtime ->
|
||||
{ runtime; connection }
|
||||
|
||||
let request t = Httpun.Client_connection.request t.connection
|
||||
|
||||
let shutdown t = Client_runtime.shutdown t.runtime
|
||||
|
||||
let is_closed t = Client_runtime.is_closed t.runtime
|
||||
|
||||
let upgrade t protocol = Client_runtime.upgrade t.runtime protocol
|
||||
|
||||
let create_connection_with_default ?config socket =
|
||||
Client_runtime.create_default
|
||||
~alpn_protocols:["http/1.1"]
|
||||
socket
|
||||
>>= fun ssl_client ->
|
||||
create_connection ?config ssl_client
|
||||
end
|
||||
end
|
||||
72
unikernel/duniverse/httpun/async/httpun_async.mli
Normal file
72
unikernel/duniverse/httpun/async/httpun_async.mli
Normal file
|
|
@ -0,0 +1,72 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2018 Inhabited Type LLC.
|
||||
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 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 Httpun
|
||||
|
||||
module Server : sig
|
||||
include Httpun_async_intf.Server
|
||||
with type 'a socket = ([`Active], [< Socket.Address.t] as 'a) Socket.t
|
||||
|
||||
module SSL : sig
|
||||
include Httpun_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 -> Httpun.Reqd.t Gluten.Server.request_handler)
|
||||
-> error_handler : ('a -> Server_connection.error_handler)
|
||||
-> 'a
|
||||
-> ([`Active], 'a) Socket.t
|
||||
-> unit Deferred.t
|
||||
end
|
||||
end
|
||||
|
||||
module Client : sig
|
||||
include Httpun_async_intf.Client
|
||||
with type 'a socket = ([`Active], [< Socket.Address.t] as 'a) Socket.t
|
||||
|
||||
module SSL : sig
|
||||
include Httpun_async_intf.Client
|
||||
with type 'a socket = 'a Gluten_async.Client.SSL.socket
|
||||
|
||||
val create_connection_with_default
|
||||
: ?config : Config.t
|
||||
-> ([`Active], [< Socket.Address.t] as 'a) Socket.t
|
||||
-> 'a t Deferred.t
|
||||
end
|
||||
end
|
||||
76
unikernel/duniverse/httpun/async/httpun_async_intf.ml
Normal file
76
unikernel/duniverse/httpun/async/httpun_async_intf.ml
Normal file
|
|
@ -0,0 +1,76 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
* 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 Async
|
||||
open Httpun
|
||||
|
||||
module type Server = sig
|
||||
type 'a socket constraint 'a = [< Socket.Address.t]
|
||||
|
||||
val create_connection_handler
|
||||
: ?config : Config.t
|
||||
-> request_handler : ('a -> Httpun.Reqd.t Gluten.Server.request_handler)
|
||||
-> error_handler : ('a -> Server_connection.error_handler)
|
||||
-> 'a
|
||||
-> ([< Socket.Address.t] as '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: Httpun.Client_connection.t
|
||||
; runtime: 'a runtime
|
||||
}
|
||||
|
||||
val create_connection
|
||||
: ?config: Config.t
|
||||
-> 'a socket
|
||||
-> 'a t Deferred.t
|
||||
|
||||
val request
|
||||
: 'a t
|
||||
-> ?flush_headers_immediately: bool
|
||||
-> Request.t
|
||||
-> error_handler : Client_connection.error_handler
|
||||
-> response_handler : Client_connection.response_handler
|
||||
-> Body.Writer.t
|
||||
|
||||
val shutdown: 'a t -> unit Deferred.t
|
||||
|
||||
val is_closed : 'a t -> bool
|
||||
|
||||
val upgrade : 'a t -> Gluten.impl -> unit
|
||||
end
|
||||
20
unikernel/duniverse/httpun/benchmarks/dune
Normal file
20
unikernel/duniverse/httpun/benchmarks/dune
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
(executable
|
||||
(name wrk_async_benchmark)
|
||||
(modules wrk_async_benchmark)
|
||||
(libraries
|
||||
httpun
|
||||
httpun_examples
|
||||
httpun-async
|
||||
async
|
||||
core
|
||||
core_unix.command_unix))
|
||||
|
||||
(executable
|
||||
(name wrk_lwt_benchmark)
|
||||
(modules Wrk_lwt_benchmark)
|
||||
(libraries httpun httpun_examples httpun-lwt-unix lwt.unix base))
|
||||
|
||||
(alias
|
||||
(name benchmarks)
|
||||
(deps
|
||||
(glob_files *.exe)))
|
||||
29
unikernel/duniverse/httpun/benchmarks/wrk_async_benchmark.ml
Normal file
29
unikernel/duniverse/httpun/benchmarks/wrk_async_benchmark.ml
Normal file
|
|
@ -0,0 +1,29 @@
|
|||
open Core
|
||||
open Async
|
||||
open Httpun_async
|
||||
|
||||
let main port max_accepts_per_batch () =
|
||||
let where_to_listen = Tcp.Where_to_listen.of_port port in
|
||||
let request_handler _ = Httpun_examples.Server.benchmark in
|
||||
let error_handler _ = Httpun_examples.Server.error_handler in
|
||||
Tcp.(Server.create_sock ~on_handler_error:`Ignore
|
||||
~backlog:11_000 ~max_connections:10_000 ~max_accepts_per_batch where_to_listen)
|
||||
(Server.create_connection_handler ~request_handler ~error_handler)
|
||||
>>= fun server ->
|
||||
Deferred.forever () (fun () ->
|
||||
Clock.after Time_float.Span.(of_sec 0.5) >>| fun () ->
|
||||
Log.Global.printf "conns: %d" (Tcp.Server.num_connections server));
|
||||
Deferred.never ()
|
||||
|
||||
let () =
|
||||
Command.async
|
||||
~summary:"Start a hello world Async server"
|
||||
Command.Param.(
|
||||
map (both
|
||||
(flag "-p" (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"))
|
||||
~f:(fun (port, accepts) ->
|
||||
(fun () -> main port accepts ())))
|
||||
|> Command_unix.run
|
||||
28
unikernel/duniverse/httpun/benchmarks/wrk_lwt_benchmark.ml
Normal file
28
unikernel/duniverse/httpun/benchmarks/wrk_lwt_benchmark.ml
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
open Base
|
||||
open Httpun_lwt_unix
|
||||
module Arg = Stdlib.Arg
|
||||
|
||||
let main port =
|
||||
let open Lwt.Infix in
|
||||
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in
|
||||
let request_handler _ = Httpun_examples.Server.benchmark in
|
||||
let error_handler _ = Httpun_examples.Server.error_handler in
|
||||
Lwt.async begin fun () ->
|
||||
Lwt_io.establish_server_with_client_socket
|
||||
~backlog:11_000
|
||||
listen_address
|
||||
(Server.create_connection_handler ~request_handler ~error_handler)
|
||||
>>= fun _server -> Lwt.return_unit
|
||||
end;
|
||||
let forever, _ = Lwt.wait () in
|
||||
Lwt_main.run forever
|
||||
;;
|
||||
|
||||
let () =
|
||||
let port = ref 8080 in
|
||||
Arg.parse
|
||||
["-p", Arg.Set_int port, " Listening port number (8080 by default)"]
|
||||
ignore
|
||||
"Responds to requests with a fixed string for benchmarking purposes.";
|
||||
main !port
|
||||
;;
|
||||
15
unikernel/duniverse/httpun/certificates/server.key
Normal file
15
unikernel/duniverse/httpun/certificates/server.key
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
-----BEGIN RSA PRIVATE KEY-----
|
||||
MIICXQIBAAKBgQC2QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJv
|
||||
K+aOANKIsOOr9v4RiEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTRE
|
||||
BE/t1soVT3a/vVJWCLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQAB
|
||||
AoGAd/CShG8g/JBMh9Nz/8KAuKHRHc2BvysIM1C62cSosgaFmdRrazJfBrEv3Nlc
|
||||
2/0uc2dVYIxuvm8bIFqi2TWOdX9jWJf6oXwEPXCD0SaDbJTaoh0b+wjyHuaGlttY
|
||||
Ztvmf8mK1BOhyl3vNMxh/8Re0dGvGgPZHpn8zanaqfGVz+ECQQDngieUpwzxA0QZ
|
||||
GZKRYhHoLEaPiQzBaXphqWcCLLN7oAKxZlUCUckxRRe0tKINf0cB3Kr9gGQjPpm0
|
||||
YoqXo8mNAkEAyYgdd+JDi9FH3Cz6ijvPU0hYkriwTii0V09+Ar5DvYQNzNEIEJu8
|
||||
Q3Yte/TPRuK8zhnp97Bsy9v/Ji/LSWbtZQJBAJe9y8u3otfmWCBLjrIUIcCYJLe4
|
||||
ENBFHp4ctxPJ0Ora+mjkthuLF+BfdSZQr1dBcX1a8giuuvQO+Bgv7r9t75ECQC7F
|
||||
omEyaA7JEW5uGe9/Fgz0G2ph5rkdBU3GKy6jzcDsJu/EC6UfH8Bgawn7tSd0c/E5
|
||||
Xm2Xyog9lKfeK8XrV2kCQQCTico5lQPjfIwjhvn45ALc/0OrkaK0hQNpXgUNFJFQ
|
||||
tuX2WMD5flMyA5PCx5XBU8gEMHYa8Kr5d6uoixnbS0cZ
|
||||
-----END RSA PRIVATE KEY-----
|
||||
15
unikernel/duniverse/httpun/certificates/server.pem
Normal file
15
unikernel/duniverse/httpun/certificates/server.pem
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
-----BEGIN CERTIFICATE-----
|
||||
MIICYzCCAcwCCQDLbE6ES1ih1DANBgkqhkiG9w0BAQUFADB2MQswCQYDVQQGEwJB
|
||||
VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0
|
||||
cyBQdHkgTHRkMRUwEwYDVQQDDAxZT1VSIE5BTUUhISExGDAWBgkqhkiG9w0BCQEW
|
||||
CW1lQGJhci5kZTAeFw0xNDAyMTcyMjA4NDVaFw0xNTAyMTcyMjA4NDVaMHYxCzAJ
|
||||
BgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l
|
||||
dCBXaWRnaXRzIFB0eSBMdGQxFTATBgNVBAMMDFlPVVIgTkFNRSEhITEYMBYGCSqG
|
||||
SIb3DQEJARYJbWVAYmFyLmRlMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC2
|
||||
QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJvK+aOANKIsOOr9v4R
|
||||
iEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTREBE/t1soVT3a/vVJW
|
||||
CLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQABMA0GCSqGSIb3DQEB
|
||||
BQUAA4GBAIo4ZppIlp3JRyltRC1/AyCC0tsh5TdM3W7258wdoP3lEe08UlLwpnPc
|
||||
aJ/cX8rMG4Xf4it77yrbVrU3MumBEGN5TW4jn4+iZyFbp6TT3OUF55nsXDjNHBbu
|
||||
deDVpGuPTI6CZQVhU5qEMF3xmlokG+VV+HCDTglNQc+fdLM0LoNF
|
||||
-----END CERTIFICATE-----
|
||||
4
unikernel/duniverse/httpun/dune-project
Normal file
4
unikernel/duniverse/httpun/dune-project
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(lang dune 3.0)
|
||||
|
||||
(name httpun)
|
||||
(version 0.2.0)
|
||||
4
unikernel/duniverse/httpun/eio/dune
Normal file
4
unikernel/duniverse/httpun/eio/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(library
|
||||
(name httpun_eio)
|
||||
(public_name httpun-eio)
|
||||
(libraries httpun eio gluten gluten-eio))
|
||||
82
unikernel/duniverse/httpun/eio/httpun_eio.ml
Normal file
82
unikernel/duniverse/httpun/eio/httpun_eio.ml
Normal file
|
|
@ -0,0 +1,82 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2018 Inhabited Type LLC.
|
||||
Copyright (c) 2018 Anton Bachin
|
||||
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 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 Server = struct
|
||||
let create_connection_handler
|
||||
?(config=Httpun.Config.default)
|
||||
~request_handler
|
||||
~error_handler
|
||||
~sw =
|
||||
fun client_addr socket ->
|
||||
let create_connection =
|
||||
Httpun.Server_connection.create
|
||||
~config
|
||||
~error_handler:(error_handler client_addr)
|
||||
in
|
||||
Gluten_eio.Server.create_upgradable_connection_handler
|
||||
~read_buffer_size:config.read_buffer_size
|
||||
~protocol:(module Httpun.Server_connection)
|
||||
~sw
|
||||
~create_protocol:create_connection
|
||||
~request_handler
|
||||
client_addr
|
||||
socket
|
||||
end
|
||||
|
||||
module Client = struct
|
||||
type t =
|
||||
{ connection: Httpun.Client_connection.t
|
||||
; runtime : Gluten_eio.Client.t
|
||||
}
|
||||
|
||||
let create_connection ?(config=Httpun.Config.default) ~sw socket =
|
||||
let connection = Httpun.Client_connection.create ~config () in
|
||||
let runtime = Gluten_eio.Client.create
|
||||
~sw
|
||||
~read_buffer_size:config.read_buffer_size
|
||||
~protocol:(module Httpun.Client_connection)
|
||||
connection
|
||||
socket
|
||||
in
|
||||
{ runtime; connection }
|
||||
|
||||
let request t = Httpun.Client_connection.request t.connection
|
||||
|
||||
let shutdown t = Gluten_eio.Client.shutdown t.runtime
|
||||
|
||||
let is_closed t = Gluten_eio.Client.is_closed t.runtime
|
||||
|
||||
let upgrade t protocol = Gluten_eio.Client.upgrade t.runtime protocol
|
||||
end
|
||||
72
unikernel/duniverse/httpun/eio/httpun_eio.mli
Normal file
72
unikernel/duniverse/httpun/eio/httpun_eio.mli
Normal file
|
|
@ -0,0 +1,72 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2018 Inhabited Type LLC.
|
||||
Copyright (c) 2018 Anton Bachin
|
||||
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 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 Server : sig
|
||||
val create_connection_handler
|
||||
: ?config : Httpun.Config.t
|
||||
-> request_handler : (Eio.Net.Sockaddr.stream -> Httpun.Reqd.t Gluten.reqd -> unit)
|
||||
-> error_handler : (Eio.Net.Sockaddr.stream -> Httpun.Server_connection.error_handler)
|
||||
-> sw:Eio.Switch.t
|
||||
-> Eio.Net.Sockaddr.stream
|
||||
-> _ Eio.Net.stream_socket
|
||||
-> unit
|
||||
end
|
||||
|
||||
module Client : sig
|
||||
type t =
|
||||
{ connection: Httpun.Client_connection.t
|
||||
; runtime: Gluten_eio.Client.t
|
||||
}
|
||||
|
||||
val create_connection
|
||||
: ?config:Httpun.Config.t
|
||||
-> sw:Eio.Switch.t
|
||||
-> _ Eio.Net.stream_socket
|
||||
-> t
|
||||
|
||||
val request
|
||||
: t
|
||||
-> ?flush_headers_immediately:bool
|
||||
-> Httpun.Request.t
|
||||
-> error_handler : Httpun.Client_connection.error_handler
|
||||
-> response_handler : Httpun.Client_connection.response_handler
|
||||
-> Httpun.Body.Writer.t
|
||||
|
||||
val shutdown: t -> unit Eio.Promise.t
|
||||
|
||||
val is_closed : t -> bool
|
||||
|
||||
val upgrade : t -> Gluten.impl -> unit
|
||||
end
|
||||
36
unikernel/duniverse/httpun/examples/async/async_echo_post.ml
Normal file
36
unikernel/duniverse/httpun/examples/async/async_echo_post.ml
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
open Core
|
||||
open Async
|
||||
|
||||
open Httpun_async
|
||||
|
||||
let request_handler (_ : [< Socket.Address.t]) = Httpun_examples.Server.echo_post
|
||||
let error_handler (_ : [< Socket.Address.t]) = Httpun_examples.Server.error_handler
|
||||
|
||||
let main port max_accepts_per_batch () =
|
||||
let where_to_listen = Tcp.Where_to_listen.of_port port in
|
||||
Tcp.(Server.create_sock ~on_handler_error:`Raise
|
||||
~backlog:10_000 ~max_connections:10_000 ~max_accepts_per_batch where_to_listen)
|
||||
(Server.create_connection_handler ~request_handler ~error_handler)
|
||||
|
||||
>>= fun _server ->
|
||||
Stdio.printf "Listening on port %i and echoing POST requests.\n" port;
|
||||
Stdio.printf "To send a POST request, try one of the following\n\n";
|
||||
Stdio.printf " echo \"Testing echo POST\" | dune exec examples/async/async_post.exe\n";
|
||||
Stdio.printf " echo \"Testing echo POST\" | dune exec examples/lwt/lwt_post.exe\n";
|
||||
Stdio.printf " echo \"Testing echo POST\" | curl -XPOST --data @- http://localhost:%d\n\n%!" port;
|
||||
Deferred.never ()
|
||||
;;
|
||||
|
||||
let () =
|
||||
Command.async
|
||||
~summary:"Echo POST requests"
|
||||
Command.Param.(
|
||||
map (both
|
||||
(flag "-p" (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"))
|
||||
~f:(fun (port, accepts) ->
|
||||
(fun () -> main port accepts ())))
|
||||
|> Command_unix.run
|
||||
;;
|
||||
38
unikernel/duniverse/httpun/examples/async/async_get.ml
Normal file
38
unikernel/duniverse/httpun/examples/async/async_get.ml
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
open! Core
|
||||
open Async
|
||||
|
||||
open Httpun
|
||||
open Httpun_async
|
||||
|
||||
let main port host () =
|
||||
let where_to_connect = Tcp.Where_to_connect.of_host_and_port { host; port } in
|
||||
Tcp.connect_sock where_to_connect
|
||||
>>= fun socket ->
|
||||
let finished = Ivar.create () in
|
||||
let response_handler =
|
||||
Httpun_examples.Client.print
|
||||
~on_eof:((Ivar.fill [@ocaml.alert "-deprecated"]) finished) in
|
||||
let headers = Headers.of_list [ "host", host ] in
|
||||
Client.create_connection socket >>= fun connection ->
|
||||
let request_body =
|
||||
Client.request
|
||||
connection
|
||||
~error_handler:Httpun_examples.Client.error_handler
|
||||
~response_handler
|
||||
(Request.create ~headers `GET "/")
|
||||
in
|
||||
Body.Writer.close request_body;
|
||||
Ivar.read finished
|
||||
;;
|
||||
|
||||
let () =
|
||||
Command.async
|
||||
~summary:"Start a hello world Async client"
|
||||
Command.Param.(
|
||||
map (both
|
||||
(flag "-p" (optional_with_default 80 int)
|
||||
~doc:"int destination port")
|
||||
(anon ("host" %: string)))
|
||||
~f:(fun (port, host) ->
|
||||
(fun () -> main port host ())))
|
||||
|> Command_unix.run
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
open! Core
|
||||
open Async
|
||||
|
||||
open Httpun
|
||||
open Httpun_async
|
||||
|
||||
let error_handler _ = assert false
|
||||
|
||||
let main port host () =
|
||||
let where_to_connect = Tcp.Where_to_connect.of_host_and_port { host; port } in
|
||||
Tcp.connect_sock where_to_connect
|
||||
>>= fun socket ->
|
||||
let finished = Ivar.create () in
|
||||
let response_handler =
|
||||
Httpun_examples.Client.print
|
||||
~on_eof:((Ivar.fill [@ocaml.alert "-deprecated"]) finished) in
|
||||
let request_headers =
|
||||
Request.create ~headers:(Headers.of_list [ "host", host ]) `GET "/"
|
||||
in
|
||||
Client.create_connection socket >>= fun connection ->
|
||||
let request_body =
|
||||
Client.request
|
||||
connection
|
||||
~response_handler
|
||||
~error_handler
|
||||
request_headers
|
||||
in
|
||||
let finished' = Ivar.create () in
|
||||
let response_handler' =
|
||||
Httpun_examples.Client.print ~on_eof:((Ivar.fill [@ocaml.alert "-deprecated"]) finished')
|
||||
in
|
||||
let request_body' =
|
||||
Client.request
|
||||
connection
|
||||
~response_handler:response_handler'
|
||||
~error_handler
|
||||
request_headers
|
||||
in
|
||||
Body.Writer.close request_body';
|
||||
Body.Writer.close request_body;
|
||||
Async.Deferred.all_unit [Ivar.read finished; Ivar.read finished'] >>= fun () ->
|
||||
Client.shutdown connection
|
||||
;;
|
||||
|
||||
let () =
|
||||
Command.async
|
||||
~summary:"Start a hello world Async client"
|
||||
Command.Param.(
|
||||
map (both
|
||||
(flag "-p" (optional_with_default 80 int)
|
||||
~doc:"int destination port")
|
||||
(anon ("host" %: string)))
|
||||
~f:(fun (port, host) ->
|
||||
(fun () -> main port host ())))
|
||||
|> Command_unix.run
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
open Core
|
||||
open Async
|
||||
|
||||
open Httpun
|
||||
open Httpun_async
|
||||
|
||||
|
||||
let error_handler _ ?request:_ error start_response =
|
||||
let response_body = start_response Headers.empty in
|
||||
begin 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)
|
||||
end;
|
||||
Body.Writer.close response_body
|
||||
;;
|
||||
|
||||
let request_handler _ { Gluten.reqd; _ } =
|
||||
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; "connection", "close"]) `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 server"
|
||||
Command.Spec.(empty +>
|
||||
flag "-p" (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
|
||||
50
unikernel/duniverse/httpun/examples/async/async_https_get.ml
Normal file
50
unikernel/duniverse/httpun/examples/async/async_https_get.ml
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
open Core
|
||||
open Async
|
||||
|
||||
open Httpun
|
||||
open Httpun_async
|
||||
|
||||
let response_handler finished response response_body =
|
||||
match response with
|
||||
| { Response.status = `OK; _ } ->
|
||||
let rec on_read bs ~off ~len =
|
||||
Bigstring.to_string ~pos:off ~len bs |> print_endline;
|
||||
Body.Reader.schedule_read response_body ~on_read ~on_eof
|
||||
and on_eof () = (Ivar.fill [@ocaml.alert "-deprecated"]) finished () in
|
||||
Body.Reader.schedule_read response_body ~on_read ~on_eof;
|
||||
| response ->
|
||||
Format.fprintf Format.std_formatter "%a\n%!" Response.pp_hum response;
|
||||
Core.exit 1
|
||||
;;
|
||||
|
||||
let error_handler _ = assert false
|
||||
|
||||
let main port host () =
|
||||
let where_to_connect = Tcp.Where_to_connect.of_host_and_port { host; port } in
|
||||
let finished = Ivar.create () in
|
||||
Tcp.connect_sock where_to_connect
|
||||
>>= fun socket ->
|
||||
Client.SSL.create_connection_with_default socket >>= fun conn ->
|
||||
let headers = Headers.of_list [ "host", host ] in
|
||||
let request_body =
|
||||
Client.SSL.request
|
||||
~error_handler
|
||||
~response_handler:(response_handler finished)
|
||||
conn
|
||||
(Request.create ~headers `GET "/")
|
||||
in
|
||||
Body.Writer.close request_body;
|
||||
Ivar.read finished
|
||||
;;
|
||||
|
||||
let () =
|
||||
Command.async_spec
|
||||
~summary:"Start a hello world Async server"
|
||||
Command.Spec.(empty +>
|
||||
flag "-p" (optional_with_default 443 int)
|
||||
~doc:"int destination port"
|
||||
+>
|
||||
flag "-h" (required string)
|
||||
~doc:"string destination host"
|
||||
) main
|
||||
|> Command_unix.run
|
||||
54
unikernel/duniverse/httpun/examples/async/async_post.ml
Normal file
54
unikernel/duniverse/httpun/examples/async/async_post.ml
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
open Core
|
||||
open Async
|
||||
|
||||
open Httpun
|
||||
open Httpun_async
|
||||
|
||||
let main port host () =
|
||||
let where_to_connect = Tcp.Where_to_connect.of_host_and_port { host; port } in
|
||||
Tcp.connect_sock where_to_connect
|
||||
>>= fun socket ->
|
||||
let finished = Ivar.create () in
|
||||
let response_handler =
|
||||
Httpun_examples.Client.print
|
||||
~on_eof:((Ivar.fill [@alert "-deprecated"]) finished) in
|
||||
let headers =
|
||||
Headers.of_list
|
||||
[ "transfer-encoding", "chunked"
|
||||
; "connection" , "close"
|
||||
; "host" , host
|
||||
]
|
||||
in
|
||||
Client.create_connection socket >>= fun connection ->
|
||||
let request_body =
|
||||
Client.request
|
||||
connection
|
||||
~error_handler:Httpun_examples.Client.error_handler
|
||||
~response_handler
|
||||
(Request.create ~headers `POST "/")
|
||||
in
|
||||
let stdin = Lazy.force Reader.stdin in
|
||||
don't_wait_for (
|
||||
Reader.read_one_chunk_at_a_time stdin ~handle_chunk:(fun bs ~pos:off ~len ->
|
||||
Body.Writer.write_bigstring request_body bs ~off ~len;
|
||||
Body.Writer.flush request_body (fun _reason -> ());
|
||||
return (`Consumed(len, `Need_unknown)))
|
||||
>>| function
|
||||
| `Eof_with_unconsumed_data s -> Body.Writer.write_string request_body s;
|
||||
Body.Writer.close request_body
|
||||
| `Eof -> Body.Writer.close request_body
|
||||
| `Stopped () -> assert false);
|
||||
Ivar.read finished
|
||||
;;
|
||||
|
||||
let () =
|
||||
Command.async
|
||||
~summary:"Start a hello world Async client"
|
||||
Command.Param.(
|
||||
map (both
|
||||
(flag "-p" (optional_with_default 80 int)
|
||||
~doc:"int destination port")
|
||||
(anon ("host" %: string)))
|
||||
~f:(fun (port, host) ->
|
||||
(fun () -> main port host ())))
|
||||
|> Command_unix.run
|
||||
22
unikernel/duniverse/httpun/examples/async/dune
Normal file
22
unikernel/duniverse/httpun/examples/async/dune
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
(executables
|
||||
(libraries
|
||||
httpun
|
||||
httpun-async
|
||||
httpun_examples
|
||||
async
|
||||
core
|
||||
core_unix.command_unix)
|
||||
(names
|
||||
async_echo_post
|
||||
async_get
|
||||
async_get_pipelined
|
||||
async_post
|
||||
async_https_get
|
||||
async_https_echo_post)
|
||||
(flags
|
||||
(:standard -w -9)))
|
||||
|
||||
(alias
|
||||
(name examples)
|
||||
(deps
|
||||
(glob_files *.exe)))
|
||||
9
unikernel/duniverse/httpun/examples/eio/dune
Normal file
9
unikernel/duniverse/httpun/examples/eio/dune
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
(executables
|
||||
(libraries httpun httpun-eio httpun_examples base stdio eio_main eio-ssl)
|
||||
(names eio_echo_post eio_get eio_ssl_get)
|
||||
(flags :standard -warn-error -A))
|
||||
|
||||
(alias
|
||||
(name examples)
|
||||
(deps
|
||||
(glob_files *.exe)))
|
||||
87
unikernel/duniverse/httpun/examples/eio/eio_echo_post.ml
Normal file
87
unikernel/duniverse/httpun/examples/eio/eio_echo_post.ml
Normal file
|
|
@ -0,0 +1,87 @@
|
|||
open Base
|
||||
module Arg = Stdlib.Arg
|
||||
|
||||
open Httpun_eio
|
||||
open Httpun
|
||||
|
||||
let error_handler (_ : Eio.Net.Sockaddr.stream) = Httpun_examples.Server.error_handler
|
||||
|
||||
let request_handler ~u (_ : Eio.Net.Sockaddr.stream) { Gluten.reqd; _ } =
|
||||
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;
|
||||
"transfer-encoding", "chunked"
|
||||
(* ; "connection", "close" *)
|
||||
]) `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 () =
|
||||
Stdlib.Format.eprintf "EOF@.";
|
||||
Body.Writer.close response_body;
|
||||
Eio.Promise.resolve_ok u ()
|
||||
in
|
||||
Body.Reader.schedule_read (Reqd.request_body reqd) ~on_eof ~on_read
|
||||
| _ ->
|
||||
let headers = Headers.of_list [ "connection", "close" ] in
|
||||
Reqd.respond_with_string reqd (Response.create ~headers `Method_not_allowed) ""
|
||||
;;
|
||||
|
||||
|
||||
let log_connection_error ex =
|
||||
Eio.traceln "Uncaught exception handling client: %a" Fmt.exn ex
|
||||
|
||||
let main port =
|
||||
Eio_main.run (fun env ->
|
||||
let listen_address = (`Tcp (Eio.Net.Ipaddr.V4.loopback, port)) in
|
||||
let network = Eio.Stdenv.net env in
|
||||
let handler ~u =
|
||||
Server.create_connection_handler ~request_handler:(request_handler ~u) ~error_handler in
|
||||
Eio.Switch.run (fun sw ->
|
||||
let socket =
|
||||
Eio.Net.listen ~reuse_addr:true ~reuse_port:true ~backlog:5 ~sw
|
||||
network
|
||||
listen_address
|
||||
in
|
||||
Stdio.printf "Listening on port %i and echoing POST requests.\n" port;
|
||||
Stdio.printf "To send a POST request, try one of the following\n\n";
|
||||
Stdio.printf " echo \"Testing echo POST\" | dune exec examples/async/async_post.exe\n";
|
||||
Stdio.printf " echo \"Testing echo POST\" | dune exec examples/lwt/lwt_post.exe\n";
|
||||
Stdio.printf " echo \"Testing echo POST\" | curl -XPOST --data @- http://localhost:%d\n\n%!" port;
|
||||
let domain_mgr = Eio.Stdenv.domain_mgr env in
|
||||
let p, _ = Eio.Promise.create () in
|
||||
for _i = 1 to Stdlib.Domain.recommended_domain_count () do
|
||||
Eio.Fiber.fork_daemon ~sw (fun () ->
|
||||
Eio.Domain_manager.run domain_mgr (fun () ->
|
||||
Eio.Switch.run (fun sw ->
|
||||
while true do
|
||||
Eio.Net.accept_fork socket ~sw ~on_error:log_connection_error (fun client_sock client_addr ->
|
||||
let p, u = Eio.Promise.create () in
|
||||
handler ~sw ~u client_addr client_sock;
|
||||
Eio.Promise.await_exn p)
|
||||
done;
|
||||
`Stop_daemon)))
|
||||
done;
|
||||
Eio.Promise.await p));
|
||||
|
||||
;;
|
||||
|
||||
let () =
|
||||
let port = ref 8080 in
|
||||
Arg.parse
|
||||
["-p", Arg.Set_int port, " Listening port number (8080 by default)"]
|
||||
ignore
|
||||
"Echoes POST requests. Runs forever.";
|
||||
main !port
|
||||
;;
|
||||
70
unikernel/duniverse/httpun/examples/eio/eio_get.ml
Normal file
70
unikernel/duniverse/httpun/examples/eio/eio_get.ml
Normal file
|
|
@ -0,0 +1,70 @@
|
|||
module Arg = Stdlib.Arg
|
||||
|
||||
open Httpun
|
||||
|
||||
let handler ~on_eof response response_body =
|
||||
match response with
|
||||
| { Response.status = `OK; _ } as response ->
|
||||
Format.fprintf Format.std_formatter "%a\n%!" Response.pp_hum response;
|
||||
let rec on_read bs ~off ~len =
|
||||
Bigstringaf.substring ~off ~len bs |> print_string;
|
||||
flush stdout;
|
||||
Body.Reader.schedule_read response_body ~on_read ~on_eof
|
||||
in
|
||||
Body.Reader.schedule_read response_body ~on_read ~on_eof;
|
||||
| response ->
|
||||
Format.fprintf Format.err_formatter "%a\n%!" Response.pp_hum response;
|
||||
Stdlib.exit 124
|
||||
;;
|
||||
|
||||
let main port host =
|
||||
Eio_main.run (fun _env ->
|
||||
Eio.Switch.run (fun sw ->
|
||||
let fd = Unix.socket ~cloexec:true Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||
let addrs =
|
||||
Eio_unix.run_in_systhread (fun () ->
|
||||
Unix.getaddrinfo
|
||||
host
|
||||
(Int.to_string port)
|
||||
[ Unix.(AI_FAMILY PF_INET) ])
|
||||
in
|
||||
Eio_unix.run_in_systhread (fun () ->
|
||||
Unix.connect fd (List.hd addrs).ai_addr);
|
||||
let socket = Eio_unix.Net.import_socket_stream ~sw ~close_unix:true fd in
|
||||
let headers = Headers.of_list [ "host", host ] in
|
||||
let connection =
|
||||
Httpun_eio.Client.create_connection ~sw socket
|
||||
in
|
||||
|
||||
let exit_cond = Eio.Condition.create () in
|
||||
let response_handler =
|
||||
handler ~on_eof:(fun () ->
|
||||
Stdlib.Format.eprintf "eof@.";
|
||||
Eio.Condition.broadcast exit_cond)
|
||||
in
|
||||
let request_body =
|
||||
Httpun_eio.Client.request
|
||||
(* ~flush_headers_immediately:true *)
|
||||
~error_handler:Httpun_examples.Client.error_handler
|
||||
~response_handler
|
||||
connection
|
||||
(Request.create ~headers `GET "/")
|
||||
in
|
||||
Body.Writer.close request_body;
|
||||
Eio.Condition.await_no_mutex exit_cond;
|
||||
Httpun_eio.Client.shutdown connection |> Eio.Promise.await))
|
||||
|
||||
let () =
|
||||
let host = ref None in
|
||||
let port = ref 80 in
|
||||
Arg.parse
|
||||
["-p", Set_int port, " Port number (80 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
|
||||
main !port host
|
||||
;;
|
||||
89
unikernel/duniverse/httpun/examples/eio/eio_ssl_get.ml
Normal file
89
unikernel/duniverse/httpun/examples/eio/eio_ssl_get.ml
Normal file
|
|
@ -0,0 +1,89 @@
|
|||
module Arg = Stdlib.Arg
|
||||
|
||||
open Httpun
|
||||
|
||||
module Client = Httpun_eio.Client
|
||||
|
||||
let () =
|
||||
Ssl.init ~thread_safe:true ()
|
||||
|
||||
let handler ~on_eof response response_body =
|
||||
match response with
|
||||
| { Response.status = `OK; _ } as response ->
|
||||
Format.fprintf Format.std_formatter "%a\n%!" Response.pp_hum response;
|
||||
let rec on_read _bs ~off:_ ~len:_ =
|
||||
(* Bigstringaf.substring ~off ~len bs |> print_string; *)
|
||||
Body.Reader.schedule_read response_body ~on_read ~on_eof
|
||||
in
|
||||
Body.Reader.schedule_read response_body ~on_read ~on_eof;
|
||||
| response ->
|
||||
Format.fprintf Format.err_formatter "%a\n%!" Response.pp_hum response;
|
||||
Stdlib.exit 124
|
||||
;;
|
||||
|
||||
let main port host =
|
||||
Eio_main.run (fun env ->
|
||||
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 (Eio.Stdenv.net env) addr in
|
||||
let ctx = Ssl.create_context (Ssl.SSLv23 [@ocaml.warning "-3"]) Ssl.Client_context in
|
||||
Ssl.disable_protocols ctx [ (Ssl.SSLv23 [@ocaml.warning "-3"]) ];
|
||||
Ssl.honor_cipher_order ctx;
|
||||
Ssl.set_context_alpn_protos ctx [ "h2" ];
|
||||
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 headers = Headers.of_list [ "host", host ] in
|
||||
let connection = Client.create_connection ~sw ssl_sock in
|
||||
let response_handler =
|
||||
handler ~on_eof:(fun () ->
|
||||
Stdlib.Format.eprintf "eof@.";
|
||||
Client.shutdown connection |> Eio.Promise.await)
|
||||
in
|
||||
let request_body =
|
||||
Client.request
|
||||
connection
|
||||
~flush_headers_immediately:true
|
||||
~error_handler:Httpun_examples.Client.error_handler
|
||||
~response_handler
|
||||
(Request.create ~headers `GET "/")
|
||||
in
|
||||
Body.Writer.close request_body));
|
||||
;;
|
||||
|
||||
let () =
|
||||
let host = ref None in
|
||||
let port = ref 443 in
|
||||
Arg.parse
|
||||
["-p", Set_int port, " Port number (80 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
|
||||
main !port host
|
||||
;;
|
||||
3
unikernel/duniverse/httpun/examples/lib/dune
Normal file
3
unikernel/duniverse/httpun/examples/lib/dune
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
(library
|
||||
(name httpun_examples)
|
||||
(libraries httpun base stdio gluten))
|
||||
89
unikernel/duniverse/httpun/examples/lib/httpun_examples.ml
Normal file
89
unikernel/duniverse/httpun/examples/lib/httpun_examples.ml
Normal file
|
|
@ -0,0 +1,89 @@
|
|||
open Base
|
||||
open Httpun
|
||||
module Format = Stdlib.Format
|
||||
|
||||
let print_string = Stdio.(Out_channel.output_string stdout)
|
||||
|
||||
let text = "CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of sitting by her sister on the bank, and of having nothing to do: once or twice she had peeped into the book her sister was reading, but it had no pictures or conversations in it, <and what is the use of a book,> thought Alice <without pictures or conversations?> So she was considering in her own mind (as well as she could, for the hot day made her feel very sleepy and stupid), whether the pleasure of making a daisy-chain would be worth the trouble of getting up and picking the daisies, when suddenly a White Rabbit with pink eyes ran close by her. There was nothing so very remarkable in that; nor did Alice think it so very much out of the way to hear the Rabbit say to itself, <Oh dear! Oh dear! I shall be late!> (when she thought it over afterwards, it occurred to her that she ought to have wondered at this, but at the time it all seemed quite natural); but when the Rabbit actually took a watch out of its waistcoat-pocket, and looked at it, and then hurried on, Alice started to her feet, for it flashed across her mind that she had never before seen a rabbit with either a waistcoat-pocket, or a watch to take out of it, and burning with curiosity, she ran across the field after it, and fortunately was just in time to see it pop down a large rabbit-hole under the hedge. In another moment down went Alice after it, never once considering how in the world she was to get out again. The rabbit-hole went straight on like a tunnel for some way, and then dipped suddenly down, so suddenly that Alice had not a moment to think about stopping herself before she found herself falling down a very deep well. Either the well was very deep, or she fell very slowly, for she had plenty of time as she went down to look about her and to wonder what was going to happen next. First, she tried to look down and make out what she was coming to, but it was too dark to see anything; then she looked at the sides of the well, and noticed that they were filled with cupboards......"
|
||||
|
||||
let text = Bigstringaf.of_string ~off:0 ~len:(String.length text) text
|
||||
|
||||
module Client = struct
|
||||
exception Response_error
|
||||
|
||||
let error_handler error =
|
||||
let error =
|
||||
match error with
|
||||
| `Malformed_response err -> Format.sprintf "Malformed response: %s" err
|
||||
| `Invalid_response_body_length _ -> "Invalid body length"
|
||||
| `Exn exn -> Format.sprintf "Exn raised: %s" (Exn.to_string exn)
|
||||
in
|
||||
Format.eprintf "Error handling response: %s\n%!" error;
|
||||
;;
|
||||
|
||||
let print ~on_eof response response_body =
|
||||
match response with
|
||||
| { Response.status = `OK; _ } as response ->
|
||||
Format.fprintf Format.std_formatter "%a\n%!" Response.pp_hum response;
|
||||
let rec on_read bs ~off ~len =
|
||||
Bigstringaf.substring ~off ~len bs |> print_string;
|
||||
Body.Reader.schedule_read response_body ~on_read ~on_eof
|
||||
in
|
||||
Body.Reader.schedule_read response_body ~on_read ~on_eof;
|
||||
| response ->
|
||||
Format.fprintf Format.err_formatter "%a\n%!" Response.pp_hum response;
|
||||
Stdlib.exit 1
|
||||
;;
|
||||
end
|
||||
|
||||
module Server = struct
|
||||
let echo_post { Gluten.reqd; _ } =
|
||||
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; "connection", "close"]) `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 () =
|
||||
Body.Writer.close response_body
|
||||
in
|
||||
Body.Reader.schedule_read (Reqd.request_body reqd) ~on_eof ~on_read
|
||||
| _ ->
|
||||
let headers = Headers.of_list [ "connection", "close" ] in
|
||||
Reqd.respond_with_string reqd (Response.create ~headers `Method_not_allowed) ""
|
||||
;;
|
||||
|
||||
let benchmark =
|
||||
let headers = Headers.of_list ["content-length", Int.to_string (Bigstringaf.length text)] in
|
||||
let handler { Gluten.reqd; _ } =
|
||||
let { Request.target; _ } = Reqd.request reqd in
|
||||
let request_body = Reqd.request_body reqd in
|
||||
Body.Reader.close request_body;
|
||||
match target with
|
||||
| "/" -> Reqd.respond_with_bigstring reqd (Response.create ~headers `OK) text;
|
||||
| _ -> Reqd.respond_with_string reqd (Response.create `Not_found) "Route not found"
|
||||
in
|
||||
handler
|
||||
;;
|
||||
|
||||
let error_handler ?request:_ error start_response =
|
||||
let response_body = start_response Headers.empty in
|
||||
begin 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)
|
||||
end;
|
||||
Body.Writer.close response_body
|
||||
;;
|
||||
end
|
||||
9
unikernel/duniverse/httpun/examples/lwt/dune
Normal file
9
unikernel/duniverse/httpun/examples/lwt/dune
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
(executables
|
||||
(libraries httpun httpun-lwt-unix httpun_examples base stdio lwt lwt.unix)
|
||||
(names lwt_get lwt_get_pipelined lwt_post lwt_echo_post lwt_https_get
|
||||
lwt_https_server))
|
||||
|
||||
(alias
|
||||
(name examples)
|
||||
(deps
|
||||
(glob_files *.exe)))
|
||||
34
unikernel/duniverse/httpun/examples/lwt/lwt_echo_post.ml
Normal file
34
unikernel/duniverse/httpun/examples/lwt/lwt_echo_post.ml
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
open Base
|
||||
open Lwt.Infix
|
||||
module Arg = Stdlib.Arg
|
||||
|
||||
open Httpun_lwt_unix
|
||||
|
||||
let error_handler (_ : Unix.sockaddr) = Httpun_examples.Server.error_handler
|
||||
let request_handler (_ : Unix.sockaddr) =
|
||||
Httpun_examples.Server.echo_post
|
||||
|
||||
let main port =
|
||||
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in
|
||||
Lwt.async (fun () ->
|
||||
Lwt_io.establish_server_with_client_socket
|
||||
listen_address
|
||||
(Server.create_connection_handler ~request_handler ~error_handler)
|
||||
>|= fun _server ->
|
||||
Stdio.printf "Listening on port %i and echoing POST requests.\n" port;
|
||||
Stdio.printf "To send a POST request, try one of the following\n\n";
|
||||
Stdio.printf " echo \"Testing echo POST\" | dune exec examples/async/async_post.exe\n";
|
||||
Stdio.printf " echo \"Testing echo POST\" | dune exec examples/lwt/lwt_post.exe\n";
|
||||
Stdio.printf " echo \"Testing echo POST\" | curl -XPOST --data @- http://localhost:%d\n\n%!" port);
|
||||
let forever, _ = Lwt.wait () in
|
||||
Lwt_main.run forever
|
||||
;;
|
||||
|
||||
let () =
|
||||
let port = ref 8080 in
|
||||
Arg.parse
|
||||
["-p", Arg.Set_int port, " Listening port number (8080 by default)"]
|
||||
ignore
|
||||
"Echoes POST requests. Runs forever.";
|
||||
main !port
|
||||
;;
|
||||
45
unikernel/duniverse/httpun/examples/lwt/lwt_get.ml
Normal file
45
unikernel/duniverse/httpun/examples/lwt/lwt_get.ml
Normal file
|
|
@ -0,0 +1,45 @@
|
|||
open Base
|
||||
open Lwt.Infix
|
||||
module Arg = Stdlib.Arg
|
||||
|
||||
open Httpun
|
||||
open Httpun_lwt_unix
|
||||
|
||||
let main port host =
|
||||
Lwt_unix.getaddrinfo host (Int.to_string 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_exn addresses).Unix.ai_addr
|
||||
>>= fun () ->
|
||||
let finished, notify_finished = Lwt.wait () in
|
||||
let response_handler =
|
||||
Httpun_examples.Client.print ~on_eof:(Lwt.wakeup_later notify_finished)
|
||||
in
|
||||
let headers = Headers.of_list [ "host", host ] in
|
||||
Client.create_connection socket >>= fun connection ->
|
||||
let request_body =
|
||||
Client.request
|
||||
connection
|
||||
~error_handler:Httpun_examples.Client.error_handler
|
||||
~response_handler
|
||||
(Request.create ~headers `GET "/")
|
||||
in
|
||||
Body.Writer.close request_body;
|
||||
finished >>= fun () ->
|
||||
Client.shutdown connection
|
||||
;;
|
||||
|
||||
let () =
|
||||
let host = ref None in
|
||||
let port = ref 80 in
|
||||
Arg.parse
|
||||
["-p", Set_int port, " Port number (80 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 (main !port host)
|
||||
;;
|
||||
61
unikernel/duniverse/httpun/examples/lwt/lwt_get_pipelined.ml
Normal file
61
unikernel/duniverse/httpun/examples/lwt/lwt_get_pipelined.ml
Normal file
|
|
@ -0,0 +1,61 @@
|
|||
open Base
|
||||
open Lwt.Infix
|
||||
module Arg = Stdlib.Arg
|
||||
|
||||
open Httpun
|
||||
open Httpun_lwt_unix
|
||||
|
||||
let error_handler _ = assert false
|
||||
|
||||
let main port host =
|
||||
Lwt_unix.getaddrinfo host (Int.to_string 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_exn addresses).Unix.ai_addr
|
||||
>>= fun () ->
|
||||
let finished, notify_finished = Lwt.wait () in
|
||||
let response_handler =
|
||||
Httpun_examples.Client.print ~on_eof:(Lwt.wakeup_later notify_finished)
|
||||
in
|
||||
let request_headers =
|
||||
Request.create ~headers:(Headers.of_list [ "host", host ]) `GET "/"
|
||||
in
|
||||
Client.create_connection socket >>= fun connection ->
|
||||
let request_body =
|
||||
Client.request
|
||||
connection
|
||||
~response_handler
|
||||
~error_handler
|
||||
request_headers
|
||||
in
|
||||
let finished', notify_finished' = Lwt.wait () in
|
||||
let response_handler' =
|
||||
Httpun_examples.Client.print ~on_eof:(Lwt.wakeup_later notify_finished')
|
||||
in
|
||||
let request_body' =
|
||||
Client.request
|
||||
connection
|
||||
~response_handler:response_handler'
|
||||
~error_handler
|
||||
request_headers
|
||||
in
|
||||
Body.Writer.close request_body';
|
||||
Body.Writer.close request_body;
|
||||
Lwt.join [finished; finished'] >>= fun () ->
|
||||
Client.shutdown connection
|
||||
;;
|
||||
|
||||
let () =
|
||||
let host = ref None in
|
||||
let port = ref 80 in
|
||||
Arg.parse
|
||||
["-p", Set_int port, " Port number (80 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 (main !port host)
|
||||
;;
|
||||
45
unikernel/duniverse/httpun/examples/lwt/lwt_https_get.ml
Normal file
45
unikernel/duniverse/httpun/examples/lwt/lwt_https_get.ml
Normal file
|
|
@ -0,0 +1,45 @@
|
|||
open Base
|
||||
open Lwt.Infix
|
||||
module Arg = Stdlib.Arg
|
||||
|
||||
open Httpun
|
||||
open Httpun_lwt_unix
|
||||
|
||||
let error_handler _ = assert false
|
||||
|
||||
let main port host =
|
||||
Lwt_unix.getaddrinfo host (Int.to_string 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_exn addresses).Unix.ai_addr
|
||||
>>= fun () ->
|
||||
let finished, notify_finished = Lwt.wait () in
|
||||
let response_handler =
|
||||
Httpun_examples.Client.print ~on_eof:(Lwt.wakeup_later notify_finished)
|
||||
in
|
||||
let headers = Headers.of_list [ "host", host ] in
|
||||
Client.TLS.create_connection_with_default socket >>= fun connection ->
|
||||
let request_body = Client.TLS.request
|
||||
connection
|
||||
~error_handler
|
||||
~response_handler
|
||||
(Request.create ~headers `GET "/")
|
||||
in
|
||||
Body.Writer.close request_body;
|
||||
finished
|
||||
;;
|
||||
|
||||
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_https_get.exe [-p N] HOST";
|
||||
let host =
|
||||
match !host with
|
||||
| None -> failwith "No hostname provided"
|
||||
| Some host -> host
|
||||
in
|
||||
Lwt_main.run (main !port host)
|
||||
;;
|
||||
39
unikernel/duniverse/httpun/examples/lwt/lwt_https_server.ml
Normal file
39
unikernel/duniverse/httpun/examples/lwt/lwt_https_server.ml
Normal file
|
|
@ -0,0 +1,39 @@
|
|||
open Base
|
||||
open Lwt.Infix
|
||||
module Arg = Stdlib.Arg
|
||||
|
||||
open Httpun_lwt_unix
|
||||
|
||||
let request_handler (_ : Unix.sockaddr) = Httpun_examples.Server.echo_post
|
||||
let error_handler (_ : Unix.sockaddr) = Httpun_examples.Server.error_handler
|
||||
|
||||
let main port =
|
||||
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in
|
||||
let certfile = "./certificates/server.pem" in
|
||||
let keyfile = "./certificates/server.key" in
|
||||
Lwt.async (fun () ->
|
||||
Lwt_io.establish_server_with_client_socket
|
||||
listen_address
|
||||
(Server.TLS.create_connection_handler_with_default
|
||||
~certfile
|
||||
~keyfile
|
||||
~request_handler
|
||||
~error_handler)
|
||||
>|= fun _server ->
|
||||
Stdio.printf "Listening on port %i and echoing POST requests.\n" port;
|
||||
Stdio.printf "To send a POST request, try one of the following\n\n";
|
||||
Stdio.printf " echo \"Testing echo POST\" | dune exec examples/async/async_post.exe\n";
|
||||
Stdio.printf " echo \"Testing echo POST\" | dune exec examples/lwt/lwt_post.exe\n";
|
||||
Stdio.printf " echo \"Testing echo POST\" | curl -XPOST --data @- http://localhost:8080\n\n%!");
|
||||
let forever, _ = Lwt.wait () in
|
||||
Lwt_main.run forever
|
||||
;;
|
||||
|
||||
let () =
|
||||
let port = ref 8080 in
|
||||
Arg.parse
|
||||
["-p", Arg.Set_int port, " Listening port number (8080 by default)"]
|
||||
ignore
|
||||
"Echoes POST requests. Runs forever.";
|
||||
main !port
|
||||
;;
|
||||
54
unikernel/duniverse/httpun/examples/lwt/lwt_post.ml
Normal file
54
unikernel/duniverse/httpun/examples/lwt/lwt_post.ml
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
open Base
|
||||
open Lwt.Infix
|
||||
module Arg = Stdlib.Arg
|
||||
|
||||
open Httpun
|
||||
open Httpun_lwt_unix
|
||||
|
||||
let main port host =
|
||||
Lwt_io.(read stdin)
|
||||
>>= fun body ->
|
||||
Lwt_unix.getaddrinfo host (Int.to_string 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_exn addresses).Unix.ai_addr
|
||||
>>= fun () ->
|
||||
let finished, notify_finished = Lwt.wait () in
|
||||
let response_handler =
|
||||
Httpun_examples.Client.print ~on_eof:(Lwt.wakeup_later notify_finished)
|
||||
in
|
||||
let headers =
|
||||
Headers.of_list
|
||||
[ "content-length" , (Int.to_string (String.length body))
|
||||
; "connection" , "close"
|
||||
; "host" , host
|
||||
]
|
||||
in
|
||||
Client.create_connection socket >>= fun connection ->
|
||||
let request_body =
|
||||
Client.request
|
||||
connection
|
||||
~error_handler:Httpun_examples.Client.error_handler
|
||||
~response_handler
|
||||
(Request.create ~headers `POST "/")
|
||||
in
|
||||
Body.Writer.write_string request_body body;
|
||||
Body.Writer.close request_body;
|
||||
finished
|
||||
;;
|
||||
|
||||
let () =
|
||||
let host = ref None in
|
||||
let port = ref 8080 in
|
||||
|
||||
Arg.parse
|
||||
["-p", Set_int port, " Port number (8080 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 (main !port host)
|
||||
;;
|
||||
24
unikernel/duniverse/httpun/examples/mirage/config.ml
Normal file
24
unikernel/duniverse/httpun/examples/mirage/config.ml
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
open Mirage
|
||||
|
||||
(* Network configuration *)
|
||||
|
||||
let stack = generic_stackv4 default_network
|
||||
|
||||
(* Dependencies *)
|
||||
|
||||
let server =
|
||||
let packages =
|
||||
[ package ~pin:"file://../../" "httpun-lwt"
|
||||
; package ~pin:"file://../../" "httpun-mirage"
|
||||
]
|
||||
in
|
||||
foreign "Unikernel.Make"
|
||||
~packages
|
||||
(console @-> pclock @-> http @-> job)
|
||||
|
||||
let app =
|
||||
httpun_server @@ conduit_direct stack
|
||||
|
||||
let () =
|
||||
register "httpun_unikernel"
|
||||
[ server $ default_console $ default_posix_clock $ app ]
|
||||
52
unikernel/duniverse/httpun/examples/mirage/unikernel.ml
Normal file
52
unikernel/duniverse/httpun/examples/mirage/unikernel.ml
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
open Lwt.Infix
|
||||
open Httpun
|
||||
|
||||
module type HTTP = httpun_mirage.Server
|
||||
|
||||
module Dispatch (C: Mirage_console.S) (Http: HTTP) = 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 httpun unikernel"
|
||||
|
||||
let dispatcher c { Gluten.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.write_string response_body "Error handled";
|
||||
Body.flush response_body (fun () -> Body.close_writer response_body)
|
||||
in
|
||||
Http.create_connection_handler
|
||||
?config:None
|
||||
~request_handler:(dispatch c)
|
||||
~error_handler
|
||||
end
|
||||
|
||||
(** Server boilerplate *)
|
||||
module Make (C : Mirage_console.S) (Clock : Mirage_clock.PCLOCK) (Http: HTTP) = struct
|
||||
|
||||
module D = Dispatch (C) (Http)
|
||||
|
||||
let log c fmt = Printf.ksprintf (C.log c) fmt
|
||||
let start c _clock http =
|
||||
log c "started unikernel listen on port 8001" >>= fun () ->
|
||||
http (`TCP 8001) @@ D.serve c D.dispatcher
|
||||
end
|
||||
98
unikernel/duniverse/httpun/flake.lock
generated
Normal file
98
unikernel/duniverse/httpun/flake.lock
generated
Normal 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": 1725467364,
|
||||
"narHash": "sha256-w458OK4nT+tVBKTnAOSyTliCmscetXL+QP08qJtiok0=",
|
||||
"owner": "anmonteiro",
|
||||
"repo": "nix-overlays",
|
||||
"rev": "24f8a36880c6b340adfefee2f06a99f91bb6089b",
|
||||
"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
|
||||
}
|
||||
27
unikernel/duniverse/httpun/flake.nix
Normal file
27
unikernel/duniverse/httpun/flake.nix
Normal file
|
|
@ -0,0 +1,27 @@
|
|||
{
|
||||
description = "HTTP/un Nix Flake";
|
||||
|
||||
inputs.nix-filter.url = "github:numtide/nix-filter";
|
||||
inputs.flake-utils.url = "github:numtide/flake-utils";
|
||||
inputs.nixpkgs.inputs.flake-utils.follows = "flake-utils";
|
||||
inputs.nixpkgs.url = "github:anmonteiro/nix-overlays";
|
||||
|
||||
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_1;
|
||||
});
|
||||
in
|
||||
rec {
|
||||
packages = pkgs.callPackage ./nix { nix-filter = nix-filter.lib; };
|
||||
defaultPackage = packages.httpun;
|
||||
devShells = {
|
||||
default = pkgs.callPackage ./nix/shell.nix { inherit packages; };
|
||||
release = pkgs.callPackage ./nix/shell.nix {
|
||||
inherit packages;
|
||||
release-mode = true;
|
||||
};
|
||||
};
|
||||
});
|
||||
}
|
||||
24
unikernel/duniverse/httpun/httpun-async.opam
Normal file
24
unikernel/duniverse/httpun/httpun-async.opam
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
version: "0.2.0"
|
||||
opam-version: "2.0"
|
||||
maintainer: "Antonio Nuno Monteiro <anmonteiro@gmail.com>"
|
||||
authors: [
|
||||
"Spiros Eliopoulos <spiros@inhabitedtype.com>"
|
||||
"Antonio Nuno Monteiro <anmonteiro@gmail.com>"
|
||||
]
|
||||
license: "BSD-3-clause"
|
||||
homepage: "https://github.com/anmonteiro/httpun"
|
||||
bug-reports: "https://github.com/anmonteiro/httpun/issues"
|
||||
dev-repo: "git+https://github.com/anmonteiro/httpun.git"
|
||||
build: [
|
||||
["dune" "build" "-p" name "-j" jobs]
|
||||
["dune" "runtest" "-p" name] {with-test}
|
||||
]
|
||||
depends: [
|
||||
"ocaml" {>= "4.08.0"}
|
||||
"dune" {>= "3.0.0"}
|
||||
"async" {>= "v0.16.0"}
|
||||
"httpun" {= version}
|
||||
"gluten-async" {>= "0.5.0"}
|
||||
]
|
||||
depopts: ["async_ssl"]
|
||||
synopsis: "Async support for httpun"
|
||||
18
unikernel/duniverse/httpun/httpun-eio.opam
Normal file
18
unikernel/duniverse/httpun/httpun-eio.opam
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
version: "0.2.0"
|
||||
opam-version: "2.0"
|
||||
maintainer: "Antonio Monteiro <anmonteiro@gmail.com>"
|
||||
authors: [ "Antonio Monteiro <anmonteiro@gmail.com>" ]
|
||||
license: "BSD-3-clause"
|
||||
homepage: "https://github.com/anmonteiro/httpun"
|
||||
bug-reports: "https://github.com/anmonteiro/httpun/issues"
|
||||
dev-repo: "git+https://github.com/anmonteiro/httpun.git"
|
||||
build: [
|
||||
["dune" "build" "-p" name]
|
||||
]
|
||||
depends: [
|
||||
"ocaml" {>= "5.0"}
|
||||
"dune" {>= "3.0.0"}
|
||||
"httpun" {= version}
|
||||
"gluten-eio" {>= "0.5.1"}
|
||||
]
|
||||
synopsis: "EIO support for httpun"
|
||||
23
unikernel/duniverse/httpun/httpun-lwt-unix.opam
Normal file
23
unikernel/duniverse/httpun/httpun-lwt-unix.opam
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
version: "0.2.0"
|
||||
opam-version: "2.0"
|
||||
maintainer: "Antonio Nuno Monteiro <anmonteiro@gmail.com>"
|
||||
authors: [
|
||||
"Anton Bachin <antonbachin@yahoo.com>"
|
||||
"Spiros Eliopoulos <spiros@inhabitedtype.com>"
|
||||
"Antonio Nuno Monteiro <anmonteiro@gmail.com>"
|
||||
]
|
||||
license: "BSD-3-clause"
|
||||
homepage: "https://github.com/anmonteiro/httpun"
|
||||
bug-reports: "https://github.com/anmonteiro/httpun/issues"
|
||||
dev-repo: "git+https://github.com/anmonteiro/httpun.git"
|
||||
build: [
|
||||
["dune" "build" "-p" name]
|
||||
]
|
||||
depends: [
|
||||
"ocaml" {>= "4.08.0"}
|
||||
"httpun" {= version}
|
||||
"httpun-lwt" {= version}
|
||||
"dune" {>= "3.0.0"}
|
||||
"gluten-lwt-unix" {>= "0.5.0"}
|
||||
]
|
||||
synopsis: "Lwt + Unix support for httpun"
|
||||
23
unikernel/duniverse/httpun/httpun-lwt.opam
Normal file
23
unikernel/duniverse/httpun/httpun-lwt.opam
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
version: "0.2.0"
|
||||
opam-version: "2.0"
|
||||
maintainer: "Antonio Nuno Monteiro <anmonteiro@gmail.com>"
|
||||
authors: [
|
||||
"Anton Bachin <antonbachin@yahoo.com>"
|
||||
"Spiros Eliopoulos <spiros@inhabitedtype.com>"
|
||||
"Antonio Nuno Monteiro <anmonteiro@gmail.com>"
|
||||
]
|
||||
license: "BSD-3-clause"
|
||||
homepage: "https://github.com/anmonteiro/httpun"
|
||||
bug-reports: "https://github.com/anmonteiro/httpun/issues"
|
||||
dev-repo: "git+https://github.com/anmonteiro/httpun.git"
|
||||
build: [
|
||||
["dune" "build" "-p" name "-j" jobs]
|
||||
]
|
||||
depends: [
|
||||
"ocaml" {>= "4.08.0"}
|
||||
"dune" {>= "3.0.0"}
|
||||
"httpun" {= version}
|
||||
"lwt"
|
||||
"gluten-lwt" {>= "0.5.0"}
|
||||
]
|
||||
synopsis: "Lwt support for httpun"
|
||||
22
unikernel/duniverse/httpun/httpun-mirage.opam
Normal file
22
unikernel/duniverse/httpun/httpun-mirage.opam
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
version: "0.2.0"
|
||||
opam-version: "2.0"
|
||||
name: "httpun-mirage"
|
||||
maintainer: "Antonio Nuno Monteiro <anmonteiro@gmail.com>"
|
||||
authors: [ "Antonio Nuno Monteiro <anmonteiro@gmail.com>" ]
|
||||
license: "BSD-3-clause"
|
||||
homepage: "https://github.com/anmonteiro/httpun"
|
||||
bug-reports: "https://github.com/anmonteiro/httpun/issues"
|
||||
dev-repo: "git+https://github.com/anmonteiro/httpun.git"
|
||||
build: [
|
||||
["dune" "build" "-p" name]
|
||||
]
|
||||
depends: [
|
||||
"ocaml" {>= "4.08.0"}
|
||||
"dune" {>= "3.0.0"}
|
||||
"httpun-lwt" {= version}
|
||||
"gluten-mirage" {>= "0.5.0"}
|
||||
"mirage-flow" {>= "2.0.0"}
|
||||
"cstruct"
|
||||
"lwt"
|
||||
]
|
||||
synopsis: "Mirage support for httpun"
|
||||
22
unikernel/duniverse/httpun/httpun-types.opam
Normal file
22
unikernel/duniverse/httpun/httpun-types.opam
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
version: "0.2.0"
|
||||
opam-version: "2.0"
|
||||
maintainer: "Antonio Nuno Monteiro <anmonteiro@gmail.com>"
|
||||
authors: [
|
||||
"Spiros Eliopoulos <spiros@inhabitedtype.com>"
|
||||
"Antonio Nuno Monteiro <anmonteiro@gmail.com>"
|
||||
]
|
||||
license: "BSD-3-clause"
|
||||
homepage: "https://github.com/anmonteiro/httpun"
|
||||
bug-reports: "https://github.com/anmonteiro/httpun/issues"
|
||||
dev-repo: "git+https://github.com/anmonteiro/httpun.git"
|
||||
build: [
|
||||
["dune" "build" "-p" name "-j" jobs]
|
||||
["dune" "runtest" "-p" name] {with-test}
|
||||
]
|
||||
depends: [
|
||||
"ocaml" {>= "4.08.0"}
|
||||
"dune" {>= "3.0.0"}
|
||||
"faraday" {>= "0.8.0"}
|
||||
]
|
||||
synopsis:
|
||||
"Common HTTP/1.x types"
|
||||
26
unikernel/duniverse/httpun/httpun.opam
Normal file
26
unikernel/duniverse/httpun/httpun.opam
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
version: "0.2.0"
|
||||
opam-version: "2.0"
|
||||
maintainer: "Antonio Nuno Monteiro <anmonteiro@gmail.com>"
|
||||
authors: [
|
||||
"Spiros Eliopoulos <spiros@inhabitedtype.com>"
|
||||
"Antonio Nuno Monteiro <anmonteiro@gmail.com>"
|
||||
]
|
||||
license: "BSD-3-clause"
|
||||
homepage: "https://github.com/anmonteiro/httpun"
|
||||
bug-reports: "https://github.com/anmonteiro/httpun/issues"
|
||||
dev-repo: "git+https://github.com/anmonteiro/httpun.git"
|
||||
build: [
|
||||
["dune" "build" "-p" name "-j" jobs]
|
||||
["dune" "runtest" "-p" name] {with-test}
|
||||
]
|
||||
depends: [
|
||||
"ocaml" {>= "4.08.0"}
|
||||
"dune" {>= "3.0.0"}
|
||||
"alcotest" {with-test}
|
||||
"httpun-types" {= version}
|
||||
"bigstringaf" {>= "0.9.0"}
|
||||
"angstrom" {>= "0.15.0"}
|
||||
"faraday" {>= "0.8.0"}
|
||||
]
|
||||
synopsis:
|
||||
"A high-performance, memory-efficient, and scalable HTTP library for OCaml"
|
||||
BIN
unikernel/duniverse/httpun/images/httpaf-comparison.png
Normal file
BIN
unikernel/duniverse/httpun/images/httpaf-comparison.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 171 KiB |
249
unikernel/duniverse/httpun/lib/body.ml
Normal file
249
unikernel/duniverse/httpun/lib/body.ml
Normal file
|
|
@ -0,0 +1,249 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2018 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
module Reader = struct
|
||||
type t =
|
||||
{ faraday : Faraday.t
|
||||
; mutable read_scheduled : bool
|
||||
; mutable on_eof : unit -> unit
|
||||
; mutable eof_has_been_called : bool
|
||||
; mutable on_read : Bigstringaf.t -> off:int -> len:int -> unit
|
||||
; when_ready_to_read : Optional_thunk.t
|
||||
}
|
||||
|
||||
let default_on_eof = Sys.opaque_identity (fun () -> ())
|
||||
let default_on_read = Sys.opaque_identity (fun _ ~off:_ ~len:_ -> ())
|
||||
|
||||
let create buffer ~when_ready_to_read =
|
||||
{ faraday = Faraday.of_bigstring buffer
|
||||
; read_scheduled = false
|
||||
; eof_has_been_called = false
|
||||
; on_eof = default_on_eof
|
||||
; on_read = default_on_read
|
||||
; when_ready_to_read
|
||||
}
|
||||
|
||||
let create_empty () =
|
||||
let t = create Bigstringaf.empty ~when_ready_to_read:Optional_thunk.none in
|
||||
Faraday.close t.faraday;
|
||||
t
|
||||
|
||||
let is_closed t =
|
||||
Faraday.is_closed t.faraday
|
||||
|
||||
let unsafe_faraday t =
|
||||
t.faraday
|
||||
|
||||
let ready_to_read t = Optional_thunk.call_if_some t.when_ready_to_read
|
||||
|
||||
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;
|
||||
if not t.eof_has_been_called then begin
|
||||
t.eof_has_been_called <- true;
|
||||
on_eof ()
|
||||
end
|
||||
(* [Faraday.operation] never returns an empty list of iovecs *)
|
||||
| `Writev [] -> assert false
|
||||
| `Writev (iovec::_) ->
|
||||
t.read_scheduled <- false;
|
||||
t.on_eof <- default_on_eof;
|
||||
t.on_read <- default_on_read;
|
||||
let { IOVec.buffer; off; len } = iovec in
|
||||
Faraday.shift t.faraday len;
|
||||
on_read buffer ~off ~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 begin
|
||||
t.read_scheduled <- true;
|
||||
t.on_eof <- on_eof;
|
||||
t.on_read <- on_read;
|
||||
end;
|
||||
do_execute_read t on_eof on_read;
|
||||
ready_to_read t
|
||||
|
||||
let close t =
|
||||
Faraday.close t.faraday;
|
||||
execute_read t;
|
||||
ready_to_read t
|
||||
;;
|
||||
|
||||
let has_pending_output t = Faraday.has_pending_output t.faraday
|
||||
|
||||
let is_read_scheduled t = t.read_scheduled
|
||||
end
|
||||
|
||||
module Writer = struct
|
||||
type encoding =
|
||||
| Identity
|
||||
| Chunked of { mutable written_final_chunk : bool }
|
||||
|
||||
type t =
|
||||
{ faraday : Faraday.t
|
||||
; encoding : encoding
|
||||
; writer : Serialize.Writer.t
|
||||
; mutable buffered_bytes : int
|
||||
}
|
||||
|
||||
let of_faraday faraday ~encoding ~writer =
|
||||
let encoding =
|
||||
match encoding with
|
||||
| `Fixed _ | `Close_delimited -> Identity
|
||||
| `Chunked -> Chunked { written_final_chunk = false }
|
||||
in
|
||||
{ faraday
|
||||
; encoding
|
||||
; writer
|
||||
; buffered_bytes = 0
|
||||
}
|
||||
|
||||
let create buffer ~encoding =
|
||||
of_faraday (Faraday.of_bigstring buffer) ~encoding
|
||||
|
||||
let create_empty ~writer =
|
||||
let t =
|
||||
create
|
||||
Bigstringaf.empty
|
||||
~encoding:(`Fixed 0)
|
||||
~writer
|
||||
in
|
||||
Faraday.close t.faraday;
|
||||
t
|
||||
|
||||
let write_char t c =
|
||||
if not (Faraday.is_closed t.faraday) then
|
||||
Faraday.write_char t.faraday c
|
||||
|
||||
let write_string t ?off ?len s =
|
||||
if not (Faraday.is_closed t.faraday) then
|
||||
Faraday.write_string ?off ?len t.faraday s
|
||||
|
||||
let write_bigstring t ?off ?len b =
|
||||
if not (Faraday.is_closed t.faraday) then
|
||||
Faraday.write_bigstring ?off ?len t.faraday b
|
||||
|
||||
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
|
||||
|
||||
let ready_to_write t = Serialize.Writer.wakeup t.writer
|
||||
|
||||
let flush t kontinue =
|
||||
if Serialize.Writer.is_closed t.writer then
|
||||
kontinue `Closed
|
||||
else begin
|
||||
Faraday.flush_with_reason t.faraday (function
|
||||
| Drain -> kontinue `Closed
|
||||
| Nothing_pending | Shift -> Serialize.Writer.flush t.writer kontinue);
|
||||
ready_to_write t
|
||||
end
|
||||
|
||||
let is_closed t =
|
||||
Faraday.is_closed 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 force_close t =
|
||||
begin match t.encoding with
|
||||
| Chunked t -> t.written_final_chunk <- true
|
||||
| Identity -> ()
|
||||
end;
|
||||
close t
|
||||
|
||||
let has_pending_output t =
|
||||
(* Force another write poll to make sure that the final chunk is emitted for
|
||||
chunk-encoded bodies. *)
|
||||
let faraday_has_output = Faraday.has_pending_output t.faraday in
|
||||
let additional_encoding_output =
|
||||
match t.encoding with
|
||||
| Identity -> false
|
||||
| Chunked { written_final_chunk } ->
|
||||
Faraday.is_closed t.faraday && not written_final_chunk
|
||||
in
|
||||
faraday_has_output || additional_encoding_output
|
||||
|
||||
let requires_output t =
|
||||
not (is_closed t) || has_pending_output t
|
||||
|
||||
let transfer_to_writer t =
|
||||
let faraday = t.faraday in
|
||||
if Serialize.Writer.is_closed t.writer then
|
||||
close_and_drain t
|
||||
else
|
||||
begin match Faraday.operation faraday with
|
||||
| `Yield -> ()
|
||||
| `Close ->
|
||||
(match t.encoding with
|
||||
| Identity -> ()
|
||||
| Chunked ({ written_final_chunk } as chunked) ->
|
||||
if not written_final_chunk then begin
|
||||
chunked.written_final_chunk <- true;
|
||||
Serialize.Writer.schedule_chunk t.writer [];
|
||||
end);
|
||||
| `Writev iovecs ->
|
||||
begin match IOVec.shiftv iovecs t.buffered_bytes with
|
||||
| [] -> ()
|
||||
| iovecs ->
|
||||
let lengthv = IOVec.lengthv iovecs in
|
||||
t.buffered_bytes <- t.buffered_bytes + lengthv;
|
||||
begin match t.encoding with
|
||||
| Identity -> Serialize.Writer.schedule_fixed t.writer iovecs
|
||||
| Chunked _ -> Serialize.Writer.schedule_chunk t.writer iovecs
|
||||
end;
|
||||
Serialize.Writer.flush t.writer (function
|
||||
| `Closed -> close_and_drain t
|
||||
| `Written ->
|
||||
Faraday.shift faraday lengthv;
|
||||
t.buffered_bytes <- t.buffered_bytes - lengthv)
|
||||
end
|
||||
end
|
||||
end
|
||||
308
unikernel/duniverse/httpun/lib/client_connection.ml
Normal file
308
unikernel/duniverse/httpun/lib/client_connection.ml
Normal file
|
|
@ -0,0 +1,308 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2017-2019 Inhabited Type LLC.
|
||||
Copyright (c) 2019 Antonio 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 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 = Parse.Reader
|
||||
module Writer = Serialize.Writer
|
||||
|
||||
type error =
|
||||
[ `Malformed_response of string | `Invalid_response_body_length of Response.t | `Exn of exn ]
|
||||
|
||||
type response_handler = Response.t -> Body.Reader.t -> unit
|
||||
type error_handler = error -> unit
|
||||
|
||||
type t =
|
||||
{ config : Config.t
|
||||
; reader : Reader.response
|
||||
; writer : Writer.t
|
||||
; request_queue : Respd.t Queue.t
|
||||
(* invariant: If [request_queue] is not empty, then the head of the queue
|
||||
has already written the request headers to the wire. *)
|
||||
}
|
||||
|
||||
let is_closed t =
|
||||
Reader.is_closed t.reader && Writer.is_closed t.writer
|
||||
|
||||
let is_waiting t =
|
||||
not (is_closed t) && Queue.is_empty t.request_queue
|
||||
|
||||
let is_active t =
|
||||
not (Queue.is_empty t.request_queue)
|
||||
|
||||
let current_respd_exn t =
|
||||
Queue.peek t.request_queue
|
||||
|
||||
let yield_reader t k = Reader.on_wakeup t.reader k
|
||||
|
||||
let wakeup_reader t = Reader.wakeup t.reader
|
||||
|
||||
let yield_writer t k = Writer.on_wakeup t.writer k
|
||||
|
||||
let wakeup_writer t = Writer.wakeup t.writer
|
||||
|
||||
let create ?(config=Config.default) () =
|
||||
let request_queue = Queue.create () in
|
||||
{ config
|
||||
; reader = Reader.response request_queue
|
||||
; writer = Writer.create ()
|
||||
; request_queue
|
||||
}
|
||||
|
||||
let create_request_body ~request t =
|
||||
match Request.body_length request with
|
||||
| `Fixed 0L -> Body.Writer.create_empty ~writer:t.writer
|
||||
| `Fixed _ | `Chunked as encoding ->
|
||||
Body.Writer.create
|
||||
(Bigstringaf.create t.config.request_body_buffer_size)
|
||||
~encoding
|
||||
~writer:t.writer
|
||||
| `Error `Bad_request ->
|
||||
failwith "httpun.Client_connection.request: invalid body length"
|
||||
|
||||
let request t ?(flush_headers_immediately=false) request ~error_handler ~response_handler =
|
||||
let request_body = create_request_body ~request t in
|
||||
let respd =
|
||||
Respd.create error_handler request request_body t.writer response_handler in
|
||||
let handle_now = Queue.is_empty t.request_queue in
|
||||
Queue.push respd t.request_queue;
|
||||
if handle_now then
|
||||
Respd.write_request respd;
|
||||
|
||||
if not flush_headers_immediately
|
||||
then Writer.yield t.writer;
|
||||
|
||||
(* Not handling the request now means it may be pipelined.
|
||||
* `advance_request_queue_if_necessary` will take care of it, but we still
|
||||
* wanna wake up the writer so that the function gets called. *)
|
||||
wakeup_writer t;
|
||||
request_body
|
||||
;;
|
||||
|
||||
let shutdown_reader t =
|
||||
if is_active t
|
||||
then Respd.close_response_body (current_respd_exn t);
|
||||
Reader.force_close t.reader;
|
||||
wakeup_reader t
|
||||
|
||||
let shutdown_writer t =
|
||||
if is_active t
|
||||
then Respd.close_request_body (current_respd_exn t);
|
||||
Writer.close t.writer;
|
||||
wakeup_writer t
|
||||
|
||||
let shutdown t =
|
||||
shutdown_reader t;
|
||||
shutdown_writer t
|
||||
|
||||
let set_error_and_handle t error =
|
||||
Queue.iter (fun respd ->
|
||||
match Respd.input_state respd with
|
||||
| Wait | Ready ->
|
||||
Respd.report_error respd error
|
||||
| Complete ->
|
||||
match Reader.next t.reader with
|
||||
| `Error _ | `Read ->
|
||||
Respd.report_error respd error
|
||||
| _ ->
|
||||
(* Don't bother reporting errors to responses that have already
|
||||
* completed. *)
|
||||
())
|
||||
t.request_queue;
|
||||
(* From RFC7230§6.5:
|
||||
* A client sending a message body SHOULD monitor the network connection
|
||||
* for an error response while it is transmitting the request. If the
|
||||
* client sees a response that indicates the server does not wish to
|
||||
* receive the message body and is closing the connection, the client
|
||||
* SHOULD immediately cease transmitting the body and close its side of the
|
||||
* connection. *)
|
||||
shutdown t;
|
||||
;;
|
||||
|
||||
let unexpected_eof t =
|
||||
set_error_and_handle t (`Malformed_response "unexpected eof");
|
||||
;;
|
||||
|
||||
let report_exn t exn =
|
||||
set_error_and_handle t (`Exn exn)
|
||||
;;
|
||||
|
||||
exception Local
|
||||
|
||||
let maybe_pipeline_queued_requests t =
|
||||
(* Don't bother trying to pipeline if there aren't multiple requests in the
|
||||
* queue. *)
|
||||
if Queue.length t.request_queue > 1 then
|
||||
try
|
||||
let _ = Queue.fold (fun prev respd ->
|
||||
begin match prev with
|
||||
| None -> ()
|
||||
| Some prev ->
|
||||
match respd.Respd.state, Respd.output_state prev with
|
||||
| Uninitialized, Complete ->
|
||||
Respd.write_request respd;
|
||||
Respd.flush_request_body respd
|
||||
| _ ->
|
||||
(* bail early. If we can't pipeline this request, we can't write
|
||||
* next ones either. *)
|
||||
raise Local
|
||||
end;
|
||||
Some respd)
|
||||
None
|
||||
t.request_queue
|
||||
in ()
|
||||
with
|
||||
| _ -> ()
|
||||
|
||||
let advance_request_queue t =
|
||||
ignore (Queue.take t.request_queue);
|
||||
if not (Queue.is_empty t.request_queue) then begin
|
||||
(* write request to the wire *)
|
||||
let respd = current_respd_exn t in
|
||||
match respd.state with
|
||||
| Uninitialized ->
|
||||
(* Only write request if it hasn't been written to the wire yet (e.g. via
|
||||
* pipelining). *)
|
||||
Respd.write_request respd;
|
||||
wakeup_writer t
|
||||
| _ -> ()
|
||||
end
|
||||
|
||||
let rec _next_read_operation t =
|
||||
if not (is_active t) then (
|
||||
if Reader.is_closed t.reader
|
||||
then shutdown t;
|
||||
Reader.next t.reader
|
||||
) else (
|
||||
let respd = current_respd_exn t in
|
||||
match Respd.input_state respd with
|
||||
| Wait -> `Yield
|
||||
| Ready -> Reader.next t.reader
|
||||
| Complete -> _final_read_operation_for t respd
|
||||
)
|
||||
|
||||
and _final_read_operation_for t respd =
|
||||
let next =
|
||||
if not (Respd.persistent_connection respd) then (
|
||||
shutdown_reader t;
|
||||
Reader.next t.reader;
|
||||
) else (
|
||||
match Respd.output_state respd with
|
||||
| Waiting | Ready -> `Yield
|
||||
| Complete ->
|
||||
match Reader.next t.reader with
|
||||
| `Error _ | `Read as operation ->
|
||||
(* Keep reading when in a "partial" state (`Read).
|
||||
* Don't advance the request queue if in an error state. *)
|
||||
operation
|
||||
| _ ->
|
||||
advance_request_queue t;
|
||||
_next_read_operation t;
|
||||
)
|
||||
in
|
||||
wakeup_writer t;
|
||||
next
|
||||
;;
|
||||
|
||||
let next_read_operation t =
|
||||
match _next_read_operation t with
|
||||
| `Error (`Parse(marks, message)) ->
|
||||
let message = String.concat "" [ String.concat ">" marks; ": "; message] in
|
||||
set_error_and_handle t (`Malformed_response message);
|
||||
`Close
|
||||
| `Error (`Invalid_response_body_length _ as error) ->
|
||||
set_error_and_handle t error;
|
||||
`Close
|
||||
| `Start -> `Read
|
||||
| (`Read | `Yield | `Close) as operation -> operation
|
||||
;;
|
||||
|
||||
let read_with_more t bs ~off ~len more =
|
||||
let consumed = Reader.read_with_more t.reader bs ~off ~len more in
|
||||
if is_active t then
|
||||
Respd.flush_response_body (current_respd_exn t);
|
||||
consumed
|
||||
;;
|
||||
|
||||
let read t bs ~off ~len =
|
||||
read_with_more t bs ~off ~len Incomplete
|
||||
|
||||
let read_eof t bs ~off ~len =
|
||||
let bytes_read = read_with_more t bs ~off ~len Complete in
|
||||
if is_active t
|
||||
then unexpected_eof t;
|
||||
bytes_read
|
||||
;;
|
||||
|
||||
let rec _next_write_operation t =
|
||||
if not (is_active t) then (
|
||||
if Reader.is_closed t.reader
|
||||
then shutdown t;
|
||||
Writer.next t.writer
|
||||
) else (
|
||||
let respd = current_respd_exn t in
|
||||
match Respd.output_state respd with
|
||||
| Waiting -> `Yield
|
||||
| Ready ->
|
||||
Respd.flush_request_body respd;
|
||||
Writer.next t.writer
|
||||
| Complete -> _final_write_operation_for t respd
|
||||
)
|
||||
|
||||
and _final_write_operation_for t respd =
|
||||
if not (Respd.persistent_connection respd) then (
|
||||
shutdown_writer t;
|
||||
Writer.next t.writer;
|
||||
) else (
|
||||
(* From RFC7230§6.3.2:
|
||||
* A client that supports persistent connections MAY "pipeline" its
|
||||
* requests (i.e., send multiple requests without waiting for each
|
||||
* response). *)
|
||||
maybe_pipeline_queued_requests t;
|
||||
match Respd.input_state respd with
|
||||
| Wait | Ready ->
|
||||
wakeup_reader t;
|
||||
Writer.next t.writer;
|
||||
| Complete ->
|
||||
match Reader.next t.reader with
|
||||
| `Error _ -> Writer.next t.writer
|
||||
| _ ->
|
||||
advance_request_queue t;
|
||||
wakeup_reader t;
|
||||
_next_write_operation t
|
||||
)
|
||||
;;
|
||||
|
||||
let next_write_operation t = _next_write_operation t
|
||||
|
||||
let report_write_result t result =
|
||||
Writer.report_result t.writer result
|
||||
11
unikernel/duniverse/httpun/lib/config.ml
Normal file
11
unikernel/duniverse/httpun/lib/config.ml
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
type t =
|
||||
{ read_buffer_size : int
|
||||
; request_body_buffer_size : int
|
||||
; response_buffer_size : int
|
||||
; response_body_buffer_size : int }
|
||||
|
||||
let default =
|
||||
{ read_buffer_size = 0x1000
|
||||
; request_body_buffer_size = 0x1000
|
||||
; response_buffer_size = 0x400
|
||||
; response_body_buffer_size = 0x1000 }
|
||||
6
unikernel/duniverse/httpun/lib/dune
Normal file
6
unikernel/duniverse/httpun/lib/dune
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
(library
|
||||
(name httpun)
|
||||
(public_name httpun)
|
||||
(libraries
|
||||
angstrom faraday bigstringaf httpun-types)
|
||||
(flags :standard -open Httpun_types))
|
||||
18
unikernel/duniverse/httpun/lib/httpun.ml
Normal file
18
unikernel/duniverse/httpun/lib/httpun.ml
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
module Headers = Httpun_types.Headers
|
||||
module IOVec = Httpun_types.IOVec
|
||||
module Method = Httpun_types.Method
|
||||
module Reqd = Reqd
|
||||
module Request = Request
|
||||
module Response = Response
|
||||
module Status = Httpun_types.Status
|
||||
module Version = Httpun_types.Version
|
||||
module Body = Body
|
||||
module Config = Config
|
||||
|
||||
module Server_connection = Server_connection
|
||||
module Client_connection = Client_connection
|
||||
|
||||
module Httpun_private = struct
|
||||
module Parse = Parse
|
||||
module Serialize = Serialize
|
||||
end
|
||||
462
unikernel/duniverse/httpun/lib/httpun.mli
Normal file
462
unikernel/duniverse/httpun/lib/httpun.mli
Normal file
|
|
@ -0,0 +1,462 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2017 Inhabited Type LLC.
|
||||
Copyright (c) 2019 Antonio 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 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
(** httpun is a high-performance, memory-efficient, and scalable HTTP/1.x
|
||||
library for OCaml. It implements the HTTP 1.1 specification with respect to
|
||||
parsing, serialization, and pipelining. *)
|
||||
|
||||
(** {2 Basic HTTP Types} *)
|
||||
|
||||
module IOVec : module type of Httpun_types.IOVec
|
||||
module Version : module type of Httpun_types.Version
|
||||
module Method : module type of Httpun_types.Method
|
||||
module Status : module type of Httpun_types.Status
|
||||
module Headers : module type of Httpun_types.Headers
|
||||
|
||||
(** {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 bytes available for reading. *)
|
||||
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 `Written] will be called. If instead, the output channel is
|
||||
closed before all of those bytes are successfully written, [f `Closed]
|
||||
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], or if the
|
||||
attached output channel is closed (e.g. because [report_write_result
|
||||
`Closed] has been called). 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
|
||||
; version : Version.t
|
||||
; headers : Headers.t }
|
||||
|
||||
val create
|
||||
: ?version:Version.t (** default is HTTP 1.1 *)
|
||||
-> ?headers:Headers.t (** default is {!Headers.empty} *)
|
||||
-> Method.t
|
||||
-> string
|
||||
-> t
|
||||
|
||||
module Body_length : sig
|
||||
type t = [
|
||||
| `Fixed of Int64.t
|
||||
| `Chunked
|
||||
| `Error of [`Bad_request]
|
||||
]
|
||||
|
||||
val pp_hum : Format.formatter -> t -> unit
|
||||
end
|
||||
|
||||
val body_length : t -> Body_length.t
|
||||
(** [body_length t] is the length of the message body accompanying [t]. It is
|
||||
an error to generate a request with a close-delimited message body.
|
||||
|
||||
See {{:https://tools.ietf.org/html/rfc7230#section-3.3.3} RFC7230§3.3.3}
|
||||
for more details. *)
|
||||
|
||||
val persistent_connection : ?proxy:bool -> t -> bool
|
||||
(** [persistent_connection ?proxy t] indicates whether the connection for [t]
|
||||
can be reused for multiple requests and responses. If the calling code
|
||||
is acting as a proxy, it should pass [~proxy:true].
|
||||
|
||||
See {{:https://tools.ietf.org/html/rfc7230#section-6.3} RFC7230§6.3 for
|
||||
more details. *)
|
||||
|
||||
val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer]
|
||||
end
|
||||
|
||||
|
||||
(** Response
|
||||
|
||||
A server-generated message to a {Request}. *)
|
||||
module Response : sig
|
||||
type t =
|
||||
{ version : Version.t
|
||||
; status : Status.t
|
||||
; reason : string
|
||||
; headers : Headers.t }
|
||||
|
||||
val create
|
||||
: ?reason:string (** default is determined by {!Status.default_reason_phrase} *)
|
||||
-> ?version:Version.t (** default is HTTP 1.1 *)
|
||||
-> ?headers:Headers.t (** default is {!Headers.empty} *)
|
||||
-> Status.t
|
||||
-> t
|
||||
(** [create ?reason ?version ?headers status] creates an HTTP response with
|
||||
the given parameters. For typical use cases, it's sufficient to provide
|
||||
values for [headers] and [status]. *)
|
||||
|
||||
module Body_length : sig
|
||||
type t = [
|
||||
| `Fixed of Int64.t
|
||||
| `Chunked
|
||||
| `Close_delimited
|
||||
| `Error of [ `Bad_gateway | `Internal_server_error ]
|
||||
]
|
||||
|
||||
val pp_hum : Format.formatter -> t -> unit
|
||||
end
|
||||
|
||||
val body_length : ?proxy:bool -> request_method:Method.standard -> t -> Body_length.t
|
||||
(** [body_length ?proxy ~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]. If the calling code is acting as a proxy, it should
|
||||
pass [~proxy:true]. This optional parameter only affects error reporting.
|
||||
|
||||
See {{:https://tools.ietf.org/html/rfc7230#section-3.3.3} RFC7230§3.3.3}
|
||||
for more details. *)
|
||||
|
||||
val persistent_connection : ?proxy:bool -> t -> bool
|
||||
(** [persistent_connection ?proxy t] indicates whether the connection for [t]
|
||||
can be reused for multiple requests and responses. If the calling code
|
||||
is acting as a proxy, it should pass [~proxy:true].
|
||||
|
||||
See {{:https://tools.ietf.org/html/rfc7230#section-6.3} RFC7230§6.3 for
|
||||
more details. *)
|
||||
|
||||
val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer]
|
||||
end
|
||||
|
||||
|
||||
|
||||
(** {2 Request Descriptor} *)
|
||||
module Reqd : sig
|
||||
type t
|
||||
|
||||
type error =
|
||||
[ `Bad_request | `Bad_gateway | `Internal_server_error | `Exn of exn ]
|
||||
|
||||
val request : t -> Request.t
|
||||
val request_body : t -> Body.Reader.t
|
||||
|
||||
val response : t -> Response.t option
|
||||
val response_exn : t -> Response.t
|
||||
|
||||
(** Responding
|
||||
|
||||
The following functions will initiate a response for the corresponding
|
||||
request in [t]. Depending on the state of the current connection, and the
|
||||
header values of the response, this may cause the connection to close or
|
||||
to persist for reuse by the client.
|
||||
|
||||
See {{:https://tools.ietf.org/html/rfc7230#section-6.3} RFC7230§6.3} for
|
||||
more details. *)
|
||||
|
||||
val respond_with_string : t -> Response.t -> string -> unit
|
||||
val respond_with_bigstring : t -> Response.t -> Bigstringaf.t -> unit
|
||||
val respond_with_streaming : ?flush_headers_immediately:bool -> t -> Response.t -> Body.Writer.t
|
||||
val respond_with_upgrade : t -> Headers.t -> (unit -> unit) -> unit
|
||||
|
||||
(** {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 Buffer Size Configuration} *)
|
||||
module Config : sig
|
||||
type t =
|
||||
{ read_buffer_size : int (** Default is [4096] *)
|
||||
; request_body_buffer_size : int (** Default is [4096] *)
|
||||
; response_buffer_size : int (** Default is [1024] *)
|
||||
; response_body_buffer_size : int (** Default is [4096] *)
|
||||
}
|
||||
|
||||
val default : t
|
||||
(** [default] is a configuration record with all parameters set to their
|
||||
default values. *)
|
||||
end
|
||||
|
||||
(** {2 Server Connection} *)
|
||||
|
||||
module Server_connection : sig
|
||||
type t
|
||||
|
||||
type error = Reqd.error
|
||||
|
||||
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 next_read_operation : t -> [ `Read | `Yield | `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_eof 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_eof} 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 yield_reader : t -> (unit -> unit) -> unit
|
||||
(** [yield_reader t continue] registers with the connection to call
|
||||
[continue] when reading should resume. {!yield_reader} should be called
|
||||
after {next_read_operation} returns a [`Yield] value. *)
|
||||
|
||||
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.
|
||||
|
||||
{ul
|
||||
{- [`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 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 return [`Write _] until all
|
||||
buffered output has been flushed. *)
|
||||
|
||||
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 | `Exn of exn ]
|
||||
|
||||
type response_handler = Response.t -> Body.Reader.t -> unit
|
||||
|
||||
type error_handler = error -> unit
|
||||
|
||||
val create : ?config:Config.t -> unit -> t
|
||||
|
||||
val request
|
||||
: t
|
||||
-> ?flush_headers_immediately:bool
|
||||
-> Request.t
|
||||
-> error_handler:error_handler
|
||||
-> response_handler:response_handler
|
||||
-> Body.Writer.t
|
||||
|
||||
val next_read_operation : t -> [ `Read | `Yield | `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_eof 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_eof} 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.
|
||||
|
||||
{ul
|
||||
{- [`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_reader : t -> (unit -> unit) -> unit
|
||||
|
||||
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 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 return [`Write _] until all
|
||||
buffered output has been flushed, at which point it will also return
|
||||
`Close. *)
|
||||
|
||||
val shutdown : t -> unit
|
||||
(** [shutdown connection] closes the underlying input and output channels of
|
||||
the connection, rendering it unusable for any further communication. *)
|
||||
end
|
||||
|
||||
(**/**)
|
||||
|
||||
module Httpun_private : sig
|
||||
module Parse : sig
|
||||
val request : Request.t Angstrom.t
|
||||
val response : Response.t Angstrom.t
|
||||
end
|
||||
|
||||
module Serialize : sig
|
||||
val write_request : Faraday.t -> Request.t -> unit
|
||||
val write_response : Faraday.t -> Response.t -> unit
|
||||
end
|
||||
end
|
||||
4
unikernel/duniverse/httpun/lib/input_state.ml
Normal file
4
unikernel/duniverse/httpun/lib/input_state.ml
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
type t =
|
||||
| Ready
|
||||
| Wait
|
||||
| Complete
|
||||
62
unikernel/duniverse/httpun/lib/message.ml
Normal file
62
unikernel/duniverse/httpun/lib/message.ml
Normal file
|
|
@ -0,0 +1,62 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2017 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
|
||||
(* 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 persistent_connection ?(proxy=false) version headers =
|
||||
let _ = proxy in
|
||||
(* XXX(seliopou): use proxy argument in the case of HTTP/1.0 as per
|
||||
https://tools.ietf.org/html/rfc7230#section-6.3 *)
|
||||
match Headers.get headers "connection" with
|
||||
| Some "close" -> false
|
||||
| Some "keep-alive" -> Version.(compare version v1_0) >= 0
|
||||
| _ -> Version.(compare version v1_1) >= 0
|
||||
|
||||
let sort_uniq xs =
|
||||
(* Though {!List.sort_uniq} performs a check on the input length and returns
|
||||
* immediately for lists of length less than [2], it still allocates closures
|
||||
* before it does that check! To avoid that just do our own checking here to
|
||||
* avoid the allocations in the common case. *)
|
||||
match xs with
|
||||
| [] | [ _ ] -> xs
|
||||
| _ -> List.sort_uniq String.compare xs
|
||||
|
||||
let unique_content_length_values headers =
|
||||
(* XXX(seliopou): perform proper content-length parsing *)
|
||||
sort_uniq (Headers.get_multi headers "content-length")
|
||||
|
||||
let content_length_of_string s =
|
||||
try Int64.of_string s with _ -> -1L
|
||||
12
unikernel/duniverse/httpun/lib/optional_thunk.ml
Normal file
12
unikernel/duniverse/httpun/lib/optional_thunk.ml
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
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
|
||||
10
unikernel/duniverse/httpun/lib/optional_thunk.mli
Normal file
10
unikernel/duniverse/httpun/lib/optional_thunk.mli
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
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
|
||||
4
unikernel/duniverse/httpun/lib/output_state.ml
Normal file
4
unikernel/duniverse/httpun/lib/output_state.ml
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
type t =
|
||||
| Waiting
|
||||
| Ready
|
||||
| Complete
|
||||
382
unikernel/duniverse/httpun/lib/parse.ml
Normal file
382
unikernel/duniverse/httpun/lib/parse.ml
Normal file
|
|
@ -0,0 +1,382 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
|
||||
include Angstrom
|
||||
|
||||
module P = struct
|
||||
let is_space =
|
||||
function | ' ' | '\t' -> true | _ -> false
|
||||
|
||||
let is_cr =
|
||||
function | '\r' -> true | _ -> false
|
||||
|
||||
let is_space_or_colon =
|
||||
function | ' ' | '\t' | ':' -> true | _ -> false
|
||||
|
||||
let is_hex =
|
||||
function | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false
|
||||
|
||||
let is_digit =
|
||||
function '0' .. '9' -> true | _ -> false
|
||||
|
||||
let is_separator =
|
||||
function
|
||||
| ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"'
|
||||
| '/' | '[' | ']' | '?' | '=' | '{' | '}' | ' ' | '\t' -> true
|
||||
| _ -> false
|
||||
|
||||
let is_token =
|
||||
(* The commented-out ' ' and '\t' are not necessary because of the range at
|
||||
* the top of the match. *)
|
||||
function
|
||||
| '\000' .. '\031' | '\127'
|
||||
| ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"'
|
||||
| '/' | '[' | ']' | '?' | '=' | '{' | '}' (* | ' ' | '\t' *) -> false
|
||||
| _ -> true
|
||||
end
|
||||
|
||||
let unit = return ()
|
||||
let token = take_while1 P.is_token
|
||||
let spaces = skip_while P.is_space
|
||||
|
||||
let digit =
|
||||
satisfy P.is_digit
|
||||
>>| function
|
||||
| '0' -> 0 | '1' -> 1 | '2' -> 2 | '3' -> 3 | '4' -> 4 | '5' -> 5
|
||||
| '6' -> 6 | '7' -> 7 | '8' -> 8 | '9' -> 9 | _ -> assert false
|
||||
|
||||
let eol = string "\r\n" <?> "eol"
|
||||
let hex str =
|
||||
try return (Int64.of_string ("0x" ^ str)) with _ -> fail "hex"
|
||||
let skip_line = take_till P.is_cr *> eol
|
||||
|
||||
let version =
|
||||
string "HTTP/" *>
|
||||
lift2 (fun major minor -> { Version.major; minor })
|
||||
(digit <* char '.')
|
||||
digit
|
||||
|
||||
let header =
|
||||
(* From RFC7230§3.2.4:
|
||||
|
||||
"No whitespace is allowed between the header field-name and colon. In
|
||||
the past, differences in the handling of such whitespace have led to
|
||||
security vulnerabilities in request routing and response handling. A
|
||||
server MUST reject any received request message that contains whitespace
|
||||
between a header field-name and colon with a response code of 400 (Bad
|
||||
Request). A proxy MUST remove any such whitespace from a response
|
||||
message before forwarding the message downstream."
|
||||
|
||||
This can be detected by checking the message and marks in a parse failure,
|
||||
which should look like this when serialized "... > header > :". *)
|
||||
lift2 (fun key value -> (key, value))
|
||||
(take_till P.is_space_or_colon <* char ':' <* spaces)
|
||||
(take_till P.is_cr <* eol >>| String.trim)
|
||||
<* commit
|
||||
<?> "header"
|
||||
|
||||
let headers =
|
||||
let cons x xs = x :: xs in
|
||||
fix (fun headers ->
|
||||
let _emp = return [] in
|
||||
let _rec = lift2 cons header headers in
|
||||
peek_char_fail
|
||||
>>= function
|
||||
| '\r' -> _emp
|
||||
| _ -> _rec)
|
||||
>>| Headers.of_list
|
||||
|
||||
let request =
|
||||
let meth = take_till P.is_space >>| Method.of_string in
|
||||
lift4 (fun meth target version headers ->
|
||||
Request.create ~version ~headers meth target)
|
||||
(meth <* char ' ')
|
||||
(take_till P.is_space <* char ' ')
|
||||
(version <* eol <* commit)
|
||||
(headers <* eol)
|
||||
|
||||
let response =
|
||||
let status =
|
||||
take_while P.is_digit
|
||||
>>= fun str ->
|
||||
if String.length str = 0
|
||||
then fail "status-code empty"
|
||||
else (
|
||||
if String.length str > 3
|
||||
then fail (Printf.sprintf "status-code too long: %S" str)
|
||||
else return (Status.of_string str))
|
||||
in
|
||||
lift4 (fun version status reason headers ->
|
||||
Response.create ~reason ~version ~headers status)
|
||||
(version <* char ' ')
|
||||
(status <* char ' ')
|
||||
(take_till P.is_cr <* eol <* commit)
|
||||
(headers <* eol)
|
||||
|
||||
let finish body =
|
||||
Body.Reader.close body;
|
||||
commit
|
||||
|
||||
let schedule_size body n =
|
||||
let faraday = Body.Reader.unsafe_faraday body in
|
||||
(* XXX(seliopou): performance regression due to switching to a single output
|
||||
* format in Farady. Once a specialized operation is exposed to avoid the
|
||||
* intemediate copy, this should be back to the original performance. *)
|
||||
begin if Faraday.is_closed faraday
|
||||
then advance n
|
||||
else take_bigstring n >>| fun s -> Faraday.schedule_bigstring faraday s
|
||||
end *> commit
|
||||
|
||||
let body ~encoding body =
|
||||
let rec fixed n ~unexpected =
|
||||
if n = 0L
|
||||
then unit
|
||||
else
|
||||
at_end_of_input
|
||||
>>= function
|
||||
| true -> commit *> fail unexpected
|
||||
| false ->
|
||||
available >>= fun m ->
|
||||
let m' = Int64.(min (of_int m) n) in
|
||||
let n' = Int64.sub n m' in
|
||||
schedule_size body (Int64.to_int m') >>= fun () -> fixed n' ~unexpected
|
||||
in
|
||||
match encoding with
|
||||
| `Fixed n ->
|
||||
fixed n ~unexpected:"expected more from fixed body"
|
||||
>>= fun () -> finish body
|
||||
| `Chunked ->
|
||||
(* XXX(seliopou): The [eol] in this parser should really parse a collection
|
||||
* of "chunk extensions", as defined in RFC7230§4.1. These do not show up
|
||||
* in the wild very frequently, and the httpun API has no way of exposing
|
||||
* them to the suer, so for now the parser does not attempt to recognize
|
||||
* them. This means that any chunked messages that contain chunk extensions
|
||||
* will fail to parse. *)
|
||||
fix (fun p ->
|
||||
let _hex =
|
||||
(take_while1 P.is_hex >>= fun size -> hex size)
|
||||
(* swallows chunk-ext, if present, and CRLF *)
|
||||
<* (eol *> commit)
|
||||
in
|
||||
_hex >>= fun size ->
|
||||
if size = 0L
|
||||
then eol >>= fun _eol -> finish body
|
||||
else fixed size ~unexpected:"expected more from body chunk" *> eol *> p)
|
||||
| `Close_delimited ->
|
||||
fix (fun p ->
|
||||
let _rec = (available >>= fun n -> schedule_size body n) *> p in
|
||||
at_end_of_input
|
||||
>>= function
|
||||
| true -> finish body
|
||||
| false -> _rec)
|
||||
|
||||
module Reader = struct
|
||||
module AU = Angstrom.Unbuffered
|
||||
|
||||
type request_error = [
|
||||
| `Bad_request of Request.t
|
||||
| `Parse of string list * string ]
|
||||
|
||||
type response_error = [
|
||||
| `Invalid_response_body_length of Response.t
|
||||
| `Parse of string list * string ]
|
||||
|
||||
type 'error parse_state =
|
||||
| Done
|
||||
| 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. *)
|
||||
; mutable wakeup : Optional_thunk.t
|
||||
}
|
||||
|
||||
type request = request_error t
|
||||
type response = response_error t
|
||||
|
||||
let create parser =
|
||||
{ parser
|
||||
; parse_state = Done
|
||||
; closed = false
|
||||
; wakeup = Optional_thunk.none
|
||||
}
|
||||
|
||||
let ok = return (Ok ())
|
||||
|
||||
let is_closed t =
|
||||
t.closed
|
||||
|
||||
let on_wakeup t k =
|
||||
if is_closed t
|
||||
then failwith "on_wakeup on closed reader"
|
||||
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 request handler =
|
||||
let rec parser t handler =
|
||||
request <* commit >>= fun request ->
|
||||
match Request.body_length request with
|
||||
| `Error `Bad_request -> return (Error (`Bad_request request))
|
||||
| `Fixed 0L ->
|
||||
handler request (Body.Reader.create_empty ());
|
||||
ok
|
||||
| `Fixed _ | `Chunked as encoding ->
|
||||
let request_body =
|
||||
Body.Reader.create
|
||||
Bigstringaf.empty
|
||||
~when_ready_to_read:(Optional_thunk.some (fun () -> wakeup (Lazy.force t)))
|
||||
in
|
||||
handler request request_body;
|
||||
body ~encoding request_body *> ok
|
||||
and
|
||||
t = lazy (create (parser t handler))
|
||||
in
|
||||
Lazy.force t
|
||||
|
||||
let response request_queue =
|
||||
let parser t request_queue =
|
||||
response <* commit >>= fun response ->
|
||||
assert (not (Queue.is_empty request_queue));
|
||||
let exception Local of Respd.t in
|
||||
let respd = match
|
||||
(Queue.iter (fun respd ->
|
||||
if respd.Respd.state = Awaiting_response then
|
||||
raise (Local respd)) request_queue)
|
||||
with
|
||||
| exception Local respd -> respd
|
||||
| () -> assert false
|
||||
in
|
||||
let request = Respd.request respd in
|
||||
let proxy = false in
|
||||
match Response.body_length ~request_method:request.meth response with
|
||||
| `Error `Bad_gateway -> assert (not proxy); assert false
|
||||
| `Error `Internal_server_error -> return (Error (`Invalid_response_body_length response))
|
||||
| `Fixed 0L ->
|
||||
respd.response_handler response (Body.Reader.create_empty ());
|
||||
ok
|
||||
| `Fixed _ | `Chunked | `Close_delimited as encoding ->
|
||||
(* We do not trust the length provided in the [`Fixed] case, as the
|
||||
client could DOS easily. *)
|
||||
let response_body =
|
||||
Body.Reader.create Bigstringaf.empty ~when_ready_to_read:(Optional_thunk.some (fun () ->
|
||||
wakeup (Lazy.force t)))
|
||||
in
|
||||
respd.response_handler response response_body;
|
||||
body ~encoding response_body *> ok
|
||||
in
|
||||
let rec t = lazy (create (parser t request_queue)) in
|
||||
Lazy.force t
|
||||
;;
|
||||
|
||||
|
||||
let transition t state =
|
||||
match state with
|
||||
| AU.Done(consumed, Ok ()) ->
|
||||
t.parse_state <- Done;
|
||||
consumed
|
||||
| AU.Done(consumed, Error error) ->
|
||||
t.parse_state <- Fail error;
|
||||
consumed
|
||||
| AU.Fail(consumed, marks, msg) ->
|
||||
t.parse_state <- Fail (`Parse(marks, msg));
|
||||
consumed
|
||||
| AU.Partial { committed; continue } ->
|
||||
t.parse_state <- Partial continue;
|
||||
committed
|
||||
and start t state =
|
||||
match state with
|
||||
| AU.Done _ -> failwith "httpun.Parse.unable to start parser"
|
||||
| AU.Fail(0, marks, msg) ->
|
||||
t.parse_state <- Fail (`Parse(marks, msg))
|
||||
| AU.Partial { committed = 0; continue } ->
|
||||
t.parse_state <- Partial continue
|
||||
| _ -> assert false
|
||||
;;
|
||||
|
||||
let rec _read_with_more t bs ~off ~len more =
|
||||
let initial = match t.parse_state with Done -> true | _ -> false in
|
||||
let consumed =
|
||||
match t.parse_state with
|
||||
| Fail _ -> 0
|
||||
(* Don't feed empty input when we're at a request boundary *)
|
||||
| Done when len = 0 -> 0
|
||||
| Done ->
|
||||
start t (AU.parse t.parser);
|
||||
_read_with_more t bs ~off ~len more;
|
||||
| Partial continue ->
|
||||
transition t (continue bs more ~off ~len)
|
||||
in
|
||||
(* Special case where the parser just started and was fed a zero-length
|
||||
* bigstring. Avoid putting them parser in an error state in this scenario.
|
||||
* If we were already in a `Partial` state, return the error. *)
|
||||
if initial && len = 0 then t.parse_state <- Done;
|
||||
match t.parse_state with
|
||||
| Done when consumed < len ->
|
||||
let off = off + consumed
|
||||
and len = len - consumed in
|
||||
consumed + _read_with_more t bs ~off ~len more
|
||||
| _ -> consumed
|
||||
;;
|
||||
|
||||
let read_with_more t bs ~off ~len more =
|
||||
let consumed = _read_with_more t bs ~off ~len more in
|
||||
(match more with
|
||||
| Complete ->
|
||||
t.closed <- true
|
||||
| Incomplete -> ());
|
||||
consumed
|
||||
|
||||
let force_close t =
|
||||
t.closed <- true;
|
||||
;;
|
||||
|
||||
let next t =
|
||||
match t.parse_state with
|
||||
| Fail failure -> `Error failure
|
||||
| _ when t.closed -> `Close
|
||||
| Done -> `Start
|
||||
| Partial _ -> `Read
|
||||
;;
|
||||
end
|
||||
278
unikernel/duniverse/httpun/lib/reqd.ml
Normal file
278
unikernel/duniverse/httpun/lib/reqd.ml
Normal file
|
|
@ -0,0 +1,278 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2017 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
type error =
|
||||
[ `Bad_request | `Bad_gateway | `Internal_server_error | `Exn of exn ]
|
||||
|
||||
type error_handler =
|
||||
?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit
|
||||
|
||||
module Reader = Parse.Reader
|
||||
module Writer = Serialize.Writer
|
||||
|
||||
(* XXX(seliopou): The current design assumes that a new [Reqd.t] will be
|
||||
* allocated for each new request/response on a connection. This is wasteful,
|
||||
* as it creates garbage on persistent connections. A better approach would be
|
||||
* to allocate a single [Reqd.t] per connection and reuse it across
|
||||
* request/responses. This would allow a single [Faraday.t] to be allocated for
|
||||
* the body and reused. The [response_state] type could then be inlined into
|
||||
* the [Reqd.t] record, with dummy values occuping the fields for [response].
|
||||
* Something like this:
|
||||
*
|
||||
* {[
|
||||
* type 'handle t =
|
||||
* { mutable request : Request.t
|
||||
* ; mutable request_body : Response.Body.Reader.t
|
||||
* ; mutable response : Response.t (* Starts off as a dummy value,
|
||||
* * using [(==)] to identify it when
|
||||
* * necessary *)
|
||||
* ; mutable response_body : Response.Body.Writer.t
|
||||
* ; mutable persistent : bool
|
||||
* ; mutable response_state : [ `Waiting | `Started | `Streaming ]
|
||||
* }
|
||||
* ]}
|
||||
*
|
||||
* *)
|
||||
type t =
|
||||
{ request : Request.t
|
||||
; request_body : Body.Reader.t
|
||||
; reader : Reader.request
|
||||
; writer : Writer.t
|
||||
; response_body_buffer : Bigstringaf.t
|
||||
; error_handler : error_handler
|
||||
; mutable persistent : bool
|
||||
; mutable response_state : Response_state.t
|
||||
; mutable error_code : [`Ok | error ]
|
||||
}
|
||||
|
||||
let create error_handler request request_body reader writer response_body_buffer =
|
||||
{ request
|
||||
; request_body
|
||||
; reader
|
||||
; writer
|
||||
; response_body_buffer
|
||||
; error_handler
|
||||
; persistent = Request.persistent_connection request
|
||||
; response_state = Waiting
|
||||
; error_code = `Ok
|
||||
}
|
||||
|
||||
let request { request; _ } = request
|
||||
let request_body { request_body; _ } = request_body
|
||||
|
||||
let response { response_state; _ } =
|
||||
match response_state with
|
||||
| Waiting -> None
|
||||
| Streaming (response, _)
|
||||
| Fixed response
|
||||
| Upgrade (response, _) -> Some response
|
||||
|
||||
let response_exn { response_state; _ } =
|
||||
match response_state with
|
||||
| Waiting -> failwith "httpun.Reqd.response_exn: response has not started"
|
||||
| Streaming(response, _)
|
||||
| Fixed response
|
||||
| Upgrade (response, _) -> response
|
||||
|
||||
let respond_with_string t response str =
|
||||
if t.error_code <> `Ok then
|
||||
failwith "httpun.Reqd.respond_with_string: invalid state, currently handling error";
|
||||
match t.response_state with
|
||||
| Waiting ->
|
||||
(* XXX(seliopou): check response body length *)
|
||||
Writer.write_response t.writer response;
|
||||
Writer.write_string t.writer str;
|
||||
if t.persistent then
|
||||
t.persistent <- Response.persistent_connection response;
|
||||
t.response_state <- Fixed response;
|
||||
Writer.wakeup t.writer;
|
||||
| Streaming _ | Upgrade _ ->
|
||||
failwith "httpun.Reqd.respond_with_string: response already started"
|
||||
| Fixed _ ->
|
||||
failwith "httpun.Reqd.respond_with_string: response already complete"
|
||||
|
||||
let respond_with_bigstring t response (bstr:Bigstringaf.t) =
|
||||
if t.error_code <> `Ok then
|
||||
failwith "httpun.Reqd.respond_with_bigstring: invalid state, currently handling error";
|
||||
match t.response_state with
|
||||
| Waiting ->
|
||||
(* XXX(seliopou): check response body length *)
|
||||
Writer.write_response t.writer response;
|
||||
Writer.schedule_bigstring t.writer bstr;
|
||||
if t.persistent then
|
||||
t.persistent <- Response.persistent_connection response;
|
||||
t.response_state <- Fixed response;
|
||||
Writer.wakeup t.writer;
|
||||
| Streaming _ | Upgrade _ ->
|
||||
failwith "httpun.Reqd.respond_with_bigstring: response already started"
|
||||
| Fixed _ ->
|
||||
failwith "httpun.Reqd.respond_with_bigstring: response already complete"
|
||||
|
||||
let unsafe_respond_with_streaming ~flush_headers_immediately t response =
|
||||
match t.response_state with
|
||||
| Waiting ->
|
||||
let encoding =
|
||||
match Response.body_length ~request_method:t.request.meth response with
|
||||
| `Fixed _ | `Close_delimited | `Chunked as encoding -> encoding
|
||||
| `Error (`Bad_gateway | `Internal_server_error) ->
|
||||
failwith "httpun.Reqd.respond_with_streaming: invalid response body length"
|
||||
in
|
||||
let response_body =
|
||||
Body.Writer.create
|
||||
t.response_body_buffer
|
||||
~encoding
|
||||
~writer:t.writer
|
||||
in
|
||||
Writer.write_response t.writer response;
|
||||
if t.persistent then
|
||||
t.persistent <- Response.persistent_connection response;
|
||||
t.response_state <- Streaming (response, response_body);
|
||||
if flush_headers_immediately
|
||||
then Writer.wakeup t.writer;
|
||||
response_body
|
||||
| Streaming _ | Upgrade _ ->
|
||||
failwith "httpun.Reqd.respond_with_streaming: response already started"
|
||||
| Fixed _ ->
|
||||
failwith "httpun.Reqd.respond_with_streaming: response already complete"
|
||||
|
||||
let respond_with_streaming ?(flush_headers_immediately=false) t response =
|
||||
if t.error_code <> `Ok then
|
||||
failwith "httpun.Reqd.respond_with_streaming: invalid state, currently handling error";
|
||||
unsafe_respond_with_streaming ~flush_headers_immediately t response
|
||||
|
||||
let unsafe_respond_with_upgrade t headers upgrade_handler =
|
||||
match t.response_state with
|
||||
| Waiting ->
|
||||
let response = Response.create ~headers `Switching_protocols in
|
||||
Writer.write_response t.writer response;
|
||||
if t.persistent then
|
||||
t.persistent <- Response.persistent_connection response;
|
||||
t.response_state <- Upgrade (response, upgrade_handler);
|
||||
Writer.flush t.writer (fun _reason ->
|
||||
(* TODO(anmonteiro): probably need to check `Closed here? *)
|
||||
upgrade_handler ());
|
||||
Body.Reader.close t.request_body;
|
||||
Writer.wakeup t.writer
|
||||
| Streaming _ | Upgrade _ ->
|
||||
failwith "httpun.Reqd.unsafe_respond_with_upgrade: response already started"
|
||||
| Fixed _ ->
|
||||
failwith "httpun.Reqd.unsafe_respond_with_upgrade: response already complete"
|
||||
|
||||
let respond_with_upgrade t response upgrade_handler =
|
||||
if t.error_code <> `Ok then
|
||||
failwith "httpun.Reqd.respond_with_streaming: invalid state, currently handling error";
|
||||
unsafe_respond_with_upgrade t response upgrade_handler
|
||||
|
||||
let report_error t error =
|
||||
t.persistent <- false;
|
||||
match t.response_state, t.error_code with
|
||||
| Waiting, `Ok ->
|
||||
t.error_code <- (error :> [`Ok | error]);
|
||||
let status =
|
||||
match (error :> [error | Status.standard]) with
|
||||
| `Exn _ -> `Internal_server_error
|
||||
| #Status.standard as status -> status
|
||||
in
|
||||
t.error_handler ~request:t.request error (fun headers ->
|
||||
let response_body =
|
||||
unsafe_respond_with_streaming
|
||||
t
|
||||
~flush_headers_immediately:true
|
||||
(Response.create ~headers status)
|
||||
in
|
||||
(* NOTE(anmonteiro): When reporting an error that calls the error
|
||||
handler, we can only deliver an EOF to the request body once the error
|
||||
response has started. Otherwise, the request body `on_eof` handler
|
||||
could erroneously send a successful response instead of letting us
|
||||
handle the error. *)
|
||||
Body.Reader.close t.request_body;
|
||||
response_body)
|
||||
| other ->
|
||||
Body.Reader.close t.request_body;
|
||||
match other with
|
||||
| Waiting, `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 "httpun.Reqd.report_exn: NYI"
|
||||
| Streaming (_response, response_body), `Ok ->
|
||||
Body.Writer.force_close response_body;
|
||||
Reader.wakeup t.reader;
|
||||
| Streaming (_response, response_body), `Exn _ ->
|
||||
Body.Writer.close response_body;
|
||||
Writer.close_and_drain t.writer;
|
||||
Reader.wakeup t.reader;
|
||||
| (Fixed _ | Streaming _ | Upgrade _ | Waiting) , _ ->
|
||||
(* XXX(seliopou): Once additional logging support is added, log the error
|
||||
* in case it is not spurious. *)
|
||||
()
|
||||
|
||||
let report_exn t exn =
|
||||
report_error t (`Exn exn)
|
||||
|
||||
let try_with t f : (unit, exn) result =
|
||||
try f (); Ok () with exn -> report_exn t exn; Error exn
|
||||
|
||||
(* Private API, not exposed to the user through httpun.mli *)
|
||||
|
||||
let close_request_body { request_body; _ } =
|
||||
Body.Reader.close request_body
|
||||
|
||||
let error_code t =
|
||||
match t.error_code with
|
||||
| #error as error -> Some error
|
||||
| `Ok -> None
|
||||
|
||||
let persistent_connection t =
|
||||
t.persistent
|
||||
|
||||
let input_state t : Input_state.t =
|
||||
match t.response_state with
|
||||
| Upgrade _ -> Ready
|
||||
| _ ->
|
||||
if Body.Reader.is_closed t.request_body
|
||||
then Complete
|
||||
else if Body.Reader.is_read_scheduled t.request_body
|
||||
then Ready
|
||||
else Wait
|
||||
|
||||
let output_state { response_state; writer; _ } =
|
||||
Response_state.output_state response_state ~writer
|
||||
|
||||
let flush_request_body t =
|
||||
if Body.Reader.has_pending_output t.request_body
|
||||
then try Body.Reader.execute_read t.request_body
|
||||
with exn -> report_exn t exn
|
||||
|
||||
let flush_response_body t =
|
||||
Response_state.flush_response_body t.response_state
|
||||
82
unikernel/duniverse/httpun/lib/request.ml
Normal file
82
unikernel/duniverse/httpun/lib/request.ml
Normal file
|
|
@ -0,0 +1,82 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2017 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
type t =
|
||||
{ meth : Method.t
|
||||
; target : string
|
||||
; version : Version.t
|
||||
; headers : Headers.t }
|
||||
|
||||
let create ?(version=Version.v1_1) ?(headers=Headers.empty) meth target =
|
||||
{ meth; target; version; headers }
|
||||
|
||||
let bad_request = `Error `Bad_request
|
||||
|
||||
module Body_length = struct
|
||||
type t = [
|
||||
| `Fixed of Int64.t
|
||||
| `Chunked
|
||||
| `Error of [`Bad_request]
|
||||
]
|
||||
|
||||
let pp_hum fmt (len : t) =
|
||||
match len with
|
||||
| `Fixed n -> Format.fprintf fmt "Fixed %Li" n
|
||||
| `Chunked -> Format.pp_print_string fmt "Chunked"
|
||||
| `Error `Bad_request -> Format.pp_print_string fmt "Error: Bad request"
|
||||
;;
|
||||
end
|
||||
|
||||
let body_length { headers; _ } : Body_length.t =
|
||||
(* The last entry in transfer-encoding is the correct entry. We only accept
|
||||
chunked transfer-encodings. *)
|
||||
match List.rev (Headers.get_multi headers "transfer-encoding") with
|
||||
| value::_ when Headers.ci_equal value "chunked" -> `Chunked
|
||||
| _ ::_ -> bad_request
|
||||
| [] ->
|
||||
begin match Message.unique_content_length_values headers with
|
||||
| [] -> `Fixed 0L
|
||||
| [ len ] ->
|
||||
let len = Message.content_length_of_string len in
|
||||
if len >= 0L
|
||||
then `Fixed len
|
||||
else bad_request
|
||||
| _ -> bad_request
|
||||
end
|
||||
|
||||
let persistent_connection ?proxy { version; headers; _ } =
|
||||
Message.persistent_connection ?proxy version headers
|
||||
|
||||
let pp_hum fmt { meth; target; version; headers } =
|
||||
Format.fprintf fmt "((method \"%a\") (target %S) (version \"%a\") (headers %a))"
|
||||
Method.pp_hum meth target Version.pp_hum version Headers.pp_hum headers
|
||||
135
unikernel/duniverse/httpun/lib/respd.ml
Normal file
135
unikernel/duniverse/httpun/lib/respd.ml
Normal file
|
|
@ -0,0 +1,135 @@
|
|||
module Writer = Serialize.Writer
|
||||
|
||||
type error =
|
||||
[ `Malformed_response of string
|
||||
| `Invalid_response_body_length of Response.t
|
||||
| `Exn of exn ]
|
||||
|
||||
module Request_state = struct
|
||||
type t =
|
||||
| Uninitialized
|
||||
| Awaiting_response
|
||||
| Received_response of Response.t * Body.Reader.t
|
||||
| Upgraded of Response.t
|
||||
| Closed
|
||||
end
|
||||
|
||||
type t =
|
||||
{ request : Request.t
|
||||
; request_body : Body.Writer.t
|
||||
; response_handler : (Response.t -> Body.Reader.t -> unit)
|
||||
; error_handler : (error -> unit)
|
||||
; mutable error_code : [ `Ok | error ]
|
||||
; writer : Writer.t
|
||||
; mutable state : Request_state.t
|
||||
; mutable persistent : bool
|
||||
}
|
||||
|
||||
let create error_handler request request_body writer response_handler =
|
||||
let rec handler response body =
|
||||
let t = Lazy.force t in
|
||||
if t.persistent then
|
||||
t.persistent <- Response.persistent_connection response;
|
||||
let next_state : Request_state.t = match response.status with
|
||||
| `Switching_protocols ->
|
||||
Upgraded response
|
||||
| _ ->
|
||||
Received_response (response, body)
|
||||
in
|
||||
t.state <- next_state;
|
||||
response_handler response body
|
||||
and t =
|
||||
lazy
|
||||
{ request
|
||||
; request_body
|
||||
; response_handler = handler
|
||||
; error_handler
|
||||
; error_code = `Ok
|
||||
; writer
|
||||
; state = Uninitialized
|
||||
; persistent = Request.persistent_connection request
|
||||
}
|
||||
in
|
||||
Lazy.force t
|
||||
|
||||
let request { request; _ } = request
|
||||
|
||||
let write_request t =
|
||||
Writer.write_request t.writer t.request;
|
||||
t.state <- Awaiting_response
|
||||
|
||||
let report_error t error =
|
||||
t.persistent <- false;
|
||||
Body.Writer.force_close t.request_body;
|
||||
match t.state, t.error_code with
|
||||
| (Uninitialized | Awaiting_response | Upgraded _), `Ok ->
|
||||
t.state <- Closed;
|
||||
t.error_code <- (error :> [`Ok | error]);
|
||||
t.error_handler error
|
||||
| Uninitialized, `Exn _ ->
|
||||
(* TODO(anmonteiro): Not entirely sure this is possible in the client. *)
|
||||
assert false
|
||||
| Received_response (_, response_body), `Ok ->
|
||||
t.error_code <- (error :> [`Ok | error]);
|
||||
t.error_handler error;
|
||||
Body.Reader.close response_body;
|
||||
| (Uninitialized | Awaiting_response | Received_response _ | Closed | Upgraded _), _ ->
|
||||
(* XXX(seliopou): Once additional logging support is added, log the error
|
||||
* in case it is not spurious. *)
|
||||
()
|
||||
|
||||
let persistent_connection t =
|
||||
t.persistent
|
||||
|
||||
let close_request_body t =
|
||||
Body.Writer.close t.request_body
|
||||
|
||||
let close_response_body t =
|
||||
match t.state with
|
||||
| Uninitialized
|
||||
| Awaiting_response
|
||||
| Closed -> ()
|
||||
| Received_response (_, response_body) ->
|
||||
Body.Reader.close response_body
|
||||
| Upgraded _ -> t.state <- Closed
|
||||
|
||||
let input_state t : Input_state.t =
|
||||
match t.state with
|
||||
| Uninitialized
|
||||
| Awaiting_response -> Ready
|
||||
| Received_response (_, response_body) ->
|
||||
if Body.Reader.is_closed response_body
|
||||
then Complete
|
||||
else if Body.Reader.is_read_scheduled response_body
|
||||
then Ready
|
||||
else Wait
|
||||
(* Upgraded is "Complete" because the descriptor doesn't wish to receive
|
||||
* any more input. *)
|
||||
| Upgraded _
|
||||
| Closed -> Complete
|
||||
|
||||
let output_state { request_body; state; writer; _ } : Output_state.t =
|
||||
match state with
|
||||
| Upgraded _ ->
|
||||
(* XXX(anmonteiro): Connections that have been upgraded "require output"
|
||||
* forever, but outside the HTTP layer, meaning they're permanently
|
||||
* "yielding". For now they need to be explicitly shutdown in order to
|
||||
* transition the response descriptor to the `Closed` state. *)
|
||||
Waiting
|
||||
| state ->
|
||||
if Writer.is_closed writer then Complete
|
||||
else if state = Uninitialized || Body.Writer.requires_output request_body
|
||||
then Ready
|
||||
else Complete
|
||||
|
||||
let flush_request_body { request_body; _ } =
|
||||
if Body.Writer.has_pending_output request_body then
|
||||
Body.Writer.transfer_to_writer request_body
|
||||
|
||||
let flush_response_body t =
|
||||
match t.state with
|
||||
| Uninitialized | Awaiting_response | Closed | Upgraded _ -> ()
|
||||
| Received_response(_, 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)
|
||||
119
unikernel/duniverse/httpun/lib/response.ml
Normal file
119
unikernel/duniverse/httpun/lib/response.ml
Normal file
|
|
@ -0,0 +1,119 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2017 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
type t =
|
||||
{ version : Version.t
|
||||
; status : Status.t
|
||||
; reason : string
|
||||
; headers : Headers.t }
|
||||
|
||||
let create ?reason ?(version=Version.v1_1) ?(headers=Headers.empty) status =
|
||||
let reason =
|
||||
match reason with
|
||||
| Some reason -> reason
|
||||
| None ->
|
||||
begin match status with
|
||||
| #Status.standard as status -> Status.default_reason_phrase status
|
||||
| `Code _ -> "Non-standard status code"
|
||||
end
|
||||
in
|
||||
{ version; status; reason; headers }
|
||||
|
||||
let persistent_connection ?proxy { version; headers; _ } =
|
||||
Message.persistent_connection ?proxy version headers
|
||||
|
||||
let proxy_error = `Error `Bad_gateway
|
||||
let server_error = `Error `Internal_server_error
|
||||
|
||||
module Body_length = struct
|
||||
type t = [
|
||||
| `Fixed of Int64.t
|
||||
| `Chunked
|
||||
| `Close_delimited
|
||||
| `Error of [ `Bad_gateway | `Internal_server_error ]
|
||||
]
|
||||
|
||||
let pp_hum fmt (len : t) =
|
||||
match len with
|
||||
| `Fixed n -> Format.fprintf fmt "Fixed %Li" n
|
||||
| `Chunked -> Format.pp_print_string fmt "Chunked"
|
||||
| `Close_delimited -> Format.pp_print_string fmt "Close delimited"
|
||||
| `Error `Bad_gateway -> Format.pp_print_string fmt "Error: Bad gateway"
|
||||
| `Error `Internal_server_error ->
|
||||
Format.pp_print_string fmt "Error: Internal server error"
|
||||
;;
|
||||
end
|
||||
|
||||
let body_length ?(proxy=false) ~request_method { status; headers; _ } : Body_length.t =
|
||||
match status, request_method with
|
||||
| _, `HEAD ->
|
||||
(* From RFC7230§3.3.2:
|
||||
A server MAY send a Content-Length header field in a response to a
|
||||
HEAD request (Section 4.3.2 of [RFC7231]); a server MUST NOT send
|
||||
Content-Length in such a response unless its field-value equals the
|
||||
decimal number of octets that would have been sent in the payload body
|
||||
of a response if the same request had used the GET method. *)
|
||||
`Fixed 0L
|
||||
| (`No_content | `Not_modified), _ ->
|
||||
(* From RFC7230§3.3.2:
|
||||
A server MAY send a Content-Length header field in a 304 (Not
|
||||
Modified) response to a conditional GET request (Section 4.1 of
|
||||
[RFC7232]); a server MUST NOT send Content-Length in such a response
|
||||
unless its field-value equals the decimal number of octets that would
|
||||
have been sent in the payload body of a 200 (OK) response to the same
|
||||
request. *)
|
||||
`Fixed 0L
|
||||
| s, _ when Status.is_informational s -> `Fixed 0L
|
||||
| s, `CONNECT when Status.is_successful s -> `Close_delimited
|
||||
| _, _ ->
|
||||
(* The last entry in transfer-encoding is the correct entry. We only handle
|
||||
chunked transfer-encodings. *)
|
||||
begin match List.rev (Headers.get_multi headers "transfer-encoding") with
|
||||
| value::_ when Headers.ci_equal value "chunked" -> `Chunked
|
||||
| _ ::_ -> `Close_delimited
|
||||
| [] ->
|
||||
begin match Message.unique_content_length_values headers with
|
||||
| [] -> `Close_delimited
|
||||
| [ len ] ->
|
||||
let len = Message.content_length_of_string len in
|
||||
if len >= 0L
|
||||
then `Fixed len
|
||||
else if proxy then proxy_error else server_error
|
||||
| _ ->
|
||||
if proxy then proxy_error else server_error
|
||||
end
|
||||
end
|
||||
|
||||
let pp_hum fmt { version; status; reason; headers } =
|
||||
Format.fprintf fmt "((version \"%a\") (status %a) (reason %S) (headers %a))"
|
||||
Version.pp_hum version Status.pp_hum status reason Headers.pp_hum headers
|
||||
24
unikernel/duniverse/httpun/lib/response_state.ml
Normal file
24
unikernel/duniverse/httpun/lib/response_state.ml
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
type t =
|
||||
| Waiting
|
||||
| Fixed of Response.t
|
||||
| Streaming of Response.t * Body.Writer.t
|
||||
| Upgrade of Response.t * (unit -> unit)
|
||||
|
||||
let output_state t ~writer : Output_state.t =
|
||||
match t with
|
||||
| Fixed _ -> Complete
|
||||
| Waiting ->
|
||||
if Serialize.Writer.is_closed writer then Complete
|
||||
else Waiting
|
||||
| Streaming(_, response_body) ->
|
||||
if Serialize.Writer.is_closed writer then Complete
|
||||
else if Body.Writer.requires_output response_body
|
||||
then Ready
|
||||
else Complete
|
||||
| Upgrade _ -> Ready
|
||||
|
||||
let flush_response_body t =
|
||||
match t with
|
||||
| Streaming (_, response_body) ->
|
||||
Body.Writer.transfer_to_writer response_body
|
||||
| _ -> ()
|
||||
204
unikernel/duniverse/httpun/lib/serialize.ml
Normal file
204
unikernel/duniverse/httpun/lib/serialize.ml
Normal file
|
|
@ -0,0 +1,204 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2017 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
open Faraday
|
||||
|
||||
let write_space t = write_char t ' '
|
||||
let write_crlf t = write_string t "\r\n"
|
||||
|
||||
let write_version t version =
|
||||
write_string t (Version.to_string version)
|
||||
|
||||
let write_method t meth =
|
||||
write_string t (Method.to_string meth)
|
||||
|
||||
let write_status t status =
|
||||
write_string t (Status.to_string status)
|
||||
|
||||
let write_headers t headers =
|
||||
(* XXX(seliopou): escape these thigns *)
|
||||
List.iter (fun (name, value) ->
|
||||
write_string t name;
|
||||
write_string t ": ";
|
||||
write_string t value;
|
||||
write_crlf t)
|
||||
(Headers.to_list headers);
|
||||
write_crlf t
|
||||
|
||||
let write_request t { Request.meth; target; version; headers } =
|
||||
write_method t meth ; write_space t;
|
||||
write_string t target ; write_space t;
|
||||
write_version t version; write_crlf t;
|
||||
write_headers t headers
|
||||
|
||||
let write_response t { Response.version; status; reason; headers } =
|
||||
write_version t version; write_space t;
|
||||
write_status t status ; write_space t;
|
||||
write_string t reason ; write_crlf t;
|
||||
write_headers t headers
|
||||
|
||||
let write_chunk_length t len =
|
||||
write_string t (Printf.sprintf "%x" len);
|
||||
write_crlf t
|
||||
|
||||
let write_string_chunk t chunk =
|
||||
write_chunk_length t (String.length chunk);
|
||||
write_string t chunk;
|
||||
write_crlf t
|
||||
|
||||
let write_bigstring_chunk t chunk =
|
||||
write_chunk_length t (Bigstringaf.length chunk);
|
||||
write_bigstring t chunk;
|
||||
write_crlf t
|
||||
|
||||
let schedule_bigstring_chunk t chunk =
|
||||
write_chunk_length t (Bigstringaf.length chunk);
|
||||
schedule_bigstring t chunk;
|
||||
write_crlf t
|
||||
|
||||
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
|
||||
(* The callback from the runtime to be invoked when output is ready to be
|
||||
* flushed. *)
|
||||
}
|
||||
|
||||
let create ?(buffer_size=0x800) () =
|
||||
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 write_request t request =
|
||||
write_request t.encoder request
|
||||
|
||||
let write_response t response =
|
||||
write_response t.encoder response
|
||||
|
||||
let write_string t ?off ?len string =
|
||||
write_string t.encoder ?off ?len string
|
||||
|
||||
let write_bytes t ?off ?len bytes =
|
||||
write_bytes t.encoder ?off ?len bytes
|
||||
|
||||
let write_bigstring t ?off ?len bigstring =
|
||||
write_bigstring t.encoder ?off ?len bigstring
|
||||
|
||||
let schedule_bigstring t ?off ?len bigstring =
|
||||
schedule_bigstring t.encoder ?off ?len bigstring
|
||||
|
||||
let schedule_fixed t iovecs =
|
||||
List.iter (fun { IOVec.buffer; off; len } ->
|
||||
schedule_bigstring t ~off ~len buffer)
|
||||
iovecs
|
||||
|
||||
let schedule_chunk t iovecs =
|
||||
let length = IOVec.lengthv iovecs in
|
||||
write_chunk_length t.encoder length;
|
||||
schedule_fixed t iovecs;
|
||||
write_crlf t.encoder
|
||||
|
||||
let on_wakeup t k =
|
||||
if Faraday.is_closed t.encoder
|
||||
then failwith "on_wakeup on closed writer"
|
||||
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 =
|
||||
(* This would be better implemented by a function that just takes the
|
||||
encoder out of a yielded state if it's in that state. Requires a change
|
||||
to the faraday library. *)
|
||||
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;
|
||||
wakeup t
|
||||
|
||||
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 =
|
||||
(* assert (Optional_thunk.is_none t.wakeup); *)
|
||||
match Faraday.operation t.encoder with
|
||||
| `Close -> `Close (drained_bytes t)
|
||||
| `Yield -> `Yield
|
||||
| `Writev iovecs -> `Write iovecs
|
||||
end
|
||||
392
unikernel/duniverse/httpun/lib/server_connection.ml
Normal file
392
unikernel/duniverse/httpun/lib/server_connection.ml
Normal file
|
|
@ -0,0 +1,392 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2017 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
|
||||
module Reader = Parse.Reader
|
||||
module Writer = Serialize.Writer
|
||||
|
||||
|
||||
type request_handler = Reqd.t -> unit
|
||||
|
||||
type error =
|
||||
[ `Bad_gateway | `Bad_request | `Internal_server_error | `Exn of exn]
|
||||
|
||||
type error_handler =
|
||||
?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit
|
||||
|
||||
type error_code =
|
||||
| No_error
|
||||
| Error of
|
||||
{ request: Request.t option
|
||||
; mutable response_state: Response_state.t
|
||||
}
|
||||
|
||||
type t =
|
||||
{ reader : Reader.request
|
||||
; writer : Writer.t
|
||||
; response_body_buffer : Bigstringaf.t
|
||||
; request_handler : request_handler
|
||||
; error_handler : error_handler
|
||||
; request_queue : Reqd.t Queue.t
|
||||
(* invariant: If [request_queue] is not empty, then the head of the queue
|
||||
has already had [request_handler] called on it. *)
|
||||
; mutable error_code : error_code
|
||||
(* Represents an unrecoverable error that will cause the connection to
|
||||
* shutdown. Holds on to the response body created by the error handler
|
||||
* that might be streaming to the client. *)
|
||||
}
|
||||
|
||||
let is_closed t =
|
||||
Reader.is_closed t.reader && Writer.is_closed t.writer
|
||||
|
||||
let is_active t =
|
||||
not (Queue.is_empty t.request_queue)
|
||||
|
||||
let current_reqd_exn t =
|
||||
Queue.peek t.request_queue
|
||||
|
||||
let yield_reader t k =
|
||||
Reader.on_wakeup t.reader k
|
||||
|
||||
let wakeup_reader t =
|
||||
if is_active t then begin
|
||||
let reqd = current_reqd_exn t in
|
||||
(* Before going through another read loop, give the body a chance to flush
|
||||
its buffered bytes to the application. This fixes a pathological case
|
||||
where the body could buffer too much without a chance of executing
|
||||
scheduled reads. *)
|
||||
Reqd.flush_request_body reqd;
|
||||
end;
|
||||
Reader.wakeup t.reader
|
||||
|
||||
let yield_writer t k =
|
||||
Writer.on_wakeup t.writer k
|
||||
;;
|
||||
|
||||
let wakeup_writer t = Writer.wakeup t.writer
|
||||
|
||||
let default_error_handler ?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
|
||||
;;
|
||||
|
||||
let create ?(config=Config.default) ?(error_handler=default_error_handler) request_handler =
|
||||
let
|
||||
{ Config
|
||||
. response_buffer_size
|
||||
; response_body_buffer_size
|
||||
; _ } = config
|
||||
in
|
||||
let writer = Writer.create ~buffer_size:response_buffer_size () in
|
||||
let request_queue = Queue.create () in
|
||||
let response_body_buffer = Bigstringaf.create response_body_buffer_size in
|
||||
let rec reader = lazy (Reader.request handler)
|
||||
and handler request request_body =
|
||||
let reqd =
|
||||
Reqd.create error_handler request request_body (Lazy.force reader) writer response_body_buffer
|
||||
in
|
||||
let call_handler = Queue.is_empty request_queue in
|
||||
Queue.push reqd request_queue;
|
||||
if call_handler
|
||||
then request_handler reqd;
|
||||
|
||||
and t = lazy
|
||||
{ reader = Lazy.force reader
|
||||
; writer
|
||||
; response_body_buffer
|
||||
; request_handler = request_handler
|
||||
; error_handler = error_handler
|
||||
; request_queue
|
||||
; error_code = No_error
|
||||
}
|
||||
in
|
||||
Lazy.force t
|
||||
|
||||
let shutdown_reader t =
|
||||
if is_active t
|
||||
then Reqd.close_request_body (current_reqd_exn t);
|
||||
Reader.force_close t.reader;
|
||||
wakeup_reader t
|
||||
|
||||
let shutdown_writer t =
|
||||
if is_active t then (
|
||||
let reqd = current_reqd_exn t in
|
||||
(* XXX(dpatti): I'm not sure I understand why we close the *request* body
|
||||
here. Maybe we can write a test such that removing this line causes it to
|
||||
fail? *)
|
||||
Reqd.close_request_body reqd;
|
||||
Reqd.flush_response_body reqd);
|
||||
Writer.close t.writer;
|
||||
wakeup_writer t
|
||||
|
||||
let error_code t =
|
||||
if is_active t
|
||||
then Reqd.error_code (current_reqd_exn t)
|
||||
else None
|
||||
|
||||
let shutdown t =
|
||||
shutdown_reader t;
|
||||
shutdown_writer t
|
||||
|
||||
let set_error_and_handle ?request t error =
|
||||
if is_active t then begin
|
||||
assert (request = None);
|
||||
let reqd = current_reqd_exn t in
|
||||
Reqd.report_error reqd error
|
||||
end else begin
|
||||
let status =
|
||||
match (error :> [error | Status.standard]) with
|
||||
| `Exn _ -> `Internal_server_error
|
||||
| #Status.standard as status -> status
|
||||
in
|
||||
shutdown_reader t;
|
||||
let writer = t.writer in
|
||||
match t.error_code with
|
||||
| No_error ->
|
||||
t.error_code <- Error { request; response_state = Waiting };
|
||||
t.error_handler ?request error (fun headers ->
|
||||
let response = Response.create ~headers status in
|
||||
let encoding =
|
||||
(* If we haven't parsed the request method, just use GET as a standard
|
||||
placeholder. The method is only used for edge cases, like HEAD or
|
||||
CONNECT. *)
|
||||
let request_method =
|
||||
match request with
|
||||
| None -> `GET
|
||||
| Some (request: Request.t) -> request.meth
|
||||
in
|
||||
match Response.body_length ~request_method response with
|
||||
| `Fixed _ | `Close_delimited | `Chunked as encoding -> encoding
|
||||
| `Error (`Bad_gateway | `Internal_server_error) ->
|
||||
failwith "httpun.Server_connection.error_handler: invalid response body length"
|
||||
in
|
||||
let response_body =
|
||||
(* The (shared) response body buffer can be used in this case
|
||||
* because in this conditional branch we're not sending a response
|
||||
* (is_active t == false), and are therefore not making use of that
|
||||
* buffer. *)
|
||||
|
||||
Body.Writer.create
|
||||
t.response_body_buffer
|
||||
~encoding ~writer:t.writer
|
||||
in
|
||||
Writer.write_response writer response;
|
||||
t.error_code <- Error { request; response_state = Streaming(response, response_body) };
|
||||
wakeup_writer t;
|
||||
response_body)
|
||||
| Error _ ->
|
||||
(* When reading, this should be impossible: even if we try to read more,
|
||||
* the parser does not ingest it, and even if someone attempts to feed
|
||||
* more bytes to the parser when we already told them to [`Close], that's
|
||||
* really their own fault.
|
||||
*
|
||||
* We do, however, need to handle this case if any other exception is
|
||||
* reported (we're already handling an error and e.g. the writing channel
|
||||
* is closed). Just shut down the connection in that case.
|
||||
*)
|
||||
Writer.close_and_drain t.writer;
|
||||
shutdown t
|
||||
end
|
||||
|
||||
let report_exn t exn =
|
||||
set_error_and_handle t (`Exn exn)
|
||||
|
||||
let advance_request_queue t =
|
||||
ignore (Queue.take t.request_queue);
|
||||
if not (Queue.is_empty t.request_queue)
|
||||
then t.request_handler (Queue.peek t.request_queue);
|
||||
;;
|
||||
|
||||
let rec _next_read_operation t =
|
||||
if not (is_active t) then (
|
||||
let next = Reader.next t.reader in
|
||||
begin match next with
|
||||
| `Error _ ->
|
||||
(* Don't tear down the whole connection if we saw an unrecoverable
|
||||
* parsing error, as we might be in the process of streaming back the
|
||||
* error response body to the client. *)
|
||||
shutdown_reader t
|
||||
| `Close ->
|
||||
(match t.error_code with
|
||||
| No_error -> shutdown t
|
||||
| Error _ -> ())
|
||||
| _ -> ()
|
||||
end;
|
||||
next
|
||||
) else (
|
||||
let reqd = current_reqd_exn t in
|
||||
match Reqd.input_state reqd with
|
||||
| Wait ->
|
||||
begin match Reqd.output_state reqd with
|
||||
| Complete ->
|
||||
(* this branch happens if the writer has completed sending the response
|
||||
and there are still bytes remaining to be read in the request body.
|
||||
*)
|
||||
Reader.next t.reader
|
||||
| Waiting | Ready ->
|
||||
(* `Wait` signals that we should add backpressure to the read channel,
|
||||
* meaning the reader should tell the runtime to yield.
|
||||
*
|
||||
* The exception here is if there has been an error in the parser; in
|
||||
* that case, we need to return that exception and signal the runtime to
|
||||
* close. *)
|
||||
begin match Reader.next t.reader with
|
||||
| `Error _ as operation -> operation
|
||||
| _ -> `Yield
|
||||
end
|
||||
end
|
||||
| Ready -> Reader.next t.reader
|
||||
| Complete -> _final_read_operation_for t reqd
|
||||
)
|
||||
|
||||
and _final_read_operation_for t reqd =
|
||||
if Reader.is_closed t.reader || not (Reqd.persistent_connection reqd) then (
|
||||
shutdown_reader t;
|
||||
Reader.next t.reader;
|
||||
) else
|
||||
match Reqd.output_state reqd with
|
||||
| Waiting | Ready -> `Yield
|
||||
| Complete ->
|
||||
(* The "final read" operation for a request descriptor that is
|
||||
* `Complete` from both input and output perspectives needs to account
|
||||
* for the fact that the reader may not have finished reading the
|
||||
* request body.
|
||||
* It's important that we don't advance the request queue in this case
|
||||
* for persistent connections, or we'd break the invariant that a
|
||||
* non-empty `request_queue` has had the request handler called on its
|
||||
* head element. *)
|
||||
match Reader.next t.reader with
|
||||
| `Error _ as op ->
|
||||
(* Keep reading when in a "partial" state (`Read).
|
||||
* Don't advance the request queue if in an error state. *)
|
||||
op
|
||||
| `Read as op ->
|
||||
(* we just don't advance the request queue in the case of a parser
|
||||
error. *)
|
||||
advance_request_queue t;
|
||||
op
|
||||
| _ ->
|
||||
advance_request_queue t;
|
||||
_next_read_operation t
|
||||
|
||||
let next_read_operation t =
|
||||
match _next_read_operation t with
|
||||
| `Error (`Parse _) -> set_error_and_handle t `Bad_request; `Close
|
||||
| `Error (`Bad_request request) -> set_error_and_handle ~request t `Bad_request; `Close
|
||||
| `Start | `Read -> `Read
|
||||
| (`Yield | `Close) as operation -> operation
|
||||
|
||||
let read_with_more t bs ~off ~len more =
|
||||
let consumed = Reader.read_with_more t.reader bs ~off ~len more in
|
||||
if is_active t
|
||||
then (
|
||||
let reqd = current_reqd_exn t in
|
||||
Reqd.flush_request_body reqd;
|
||||
);
|
||||
consumed
|
||||
;;
|
||||
|
||||
let read t bs ~off ~len =
|
||||
read_with_more t bs ~off ~len Incomplete
|
||||
|
||||
let read_eof t bs ~off ~len =
|
||||
read_with_more t bs ~off ~len Complete
|
||||
|
||||
let flush_response_error_body response_state =
|
||||
Response_state.flush_response_body response_state
|
||||
|
||||
let rec _next_write_operation t =
|
||||
if not (is_active t) then (
|
||||
match t.error_code with
|
||||
| No_error ->
|
||||
if Reader.is_closed t.reader
|
||||
then shutdown t;
|
||||
Writer.next t.writer
|
||||
| Error { response_state; _ } ->
|
||||
match Response_state.output_state response_state ~writer:t.writer with
|
||||
| Waiting -> `Yield
|
||||
| Ready ->
|
||||
flush_response_error_body response_state;
|
||||
Writer.next t.writer
|
||||
| Complete ->
|
||||
shutdown_writer t;
|
||||
Writer.next t.writer
|
||||
) else (
|
||||
let reqd = current_reqd_exn t in
|
||||
match Reqd.output_state reqd with
|
||||
| Waiting -> Writer.next t.writer
|
||||
| Ready ->
|
||||
Reqd.flush_response_body reqd;
|
||||
Writer.next t.writer
|
||||
| Complete -> _final_write_operation_for t reqd
|
||||
)
|
||||
|
||||
and _final_write_operation_for t reqd =
|
||||
if not (Reqd.persistent_connection reqd) then (
|
||||
shutdown_writer t;
|
||||
wakeup_reader t;
|
||||
Writer.next t.writer;
|
||||
) else (
|
||||
match Reqd.input_state reqd with
|
||||
| Wait ->
|
||||
wakeup_reader t;
|
||||
Writer.next t.writer
|
||||
| Ready ->
|
||||
(* we can't close the request body here, otherwise the reader loop is
|
||||
going to think that its "input state" is complete, and remove the
|
||||
request descriptor from the request queue, when in fact it needs to
|
||||
read the remainder of the request body. It needs to hang around
|
||||
because there could be a sudden EOF while discarding the request body,
|
||||
which we need to handle. *)
|
||||
wakeup_reader t;
|
||||
Writer.next t.writer
|
||||
| Complete ->
|
||||
match Reader.next t.reader with
|
||||
| `Error _ -> Writer.next t.writer
|
||||
| _ ->
|
||||
advance_request_queue t;
|
||||
wakeup_reader t;
|
||||
_next_write_operation t
|
||||
)
|
||||
;;
|
||||
|
||||
let next_write_operation t = _next_write_operation t
|
||||
|
||||
let report_write_result t result =
|
||||
Writer.report_result t.writer result
|
||||
15
unikernel/duniverse/httpun/lib_test/dune
Normal file
15
unikernel/duniverse/httpun/lib_test/dune
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
(test
|
||||
(package httpun)
|
||||
(libraries bigstringaf httpun alcotest)
|
||||
(modules
|
||||
helpers
|
||||
test_client_connection
|
||||
test_headers
|
||||
test_httpun
|
||||
test_iovec
|
||||
test_method
|
||||
test_request
|
||||
test_response
|
||||
test_server_connection
|
||||
test_version)
|
||||
(name test_httpun))
|
||||
73
unikernel/duniverse/httpun/lib_test/helpers.ml
Normal file
73
unikernel/duniverse/httpun/lib_test/helpers.ml
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
open Httpun
|
||||
|
||||
let maybe_serialize_body f body =
|
||||
match body with
|
||||
| None -> ()
|
||||
| Some body -> Faraday.write_string f body
|
||||
|
||||
let request_to_string ?body r =
|
||||
let f = Faraday.create 0x1000 in
|
||||
Httpun_private.Serialize.write_request f r;
|
||||
maybe_serialize_body f body;
|
||||
Faraday.serialize_to_string f
|
||||
|
||||
let response_to_string ?body r =
|
||||
let f = Faraday.create 0x1000 in
|
||||
Httpun_private.Serialize.write_response f r;
|
||||
maybe_serialize_body f body;
|
||||
Faraday.serialize_to_string f
|
||||
|
||||
module Read_operation = struct
|
||||
type t = [ `Read | `Yield | `Close ]
|
||||
|
||||
let pp_hum fmt (t : t) =
|
||||
let str =
|
||||
match t with
|
||||
| `Read -> "Read"
|
||||
| `Yield -> "Yield"
|
||||
| `Close -> "Close"
|
||||
in
|
||||
Format.pp_print_string fmt str
|
||||
;;
|
||||
end
|
||||
|
||||
module Write_operation = struct
|
||||
type t = [ `Write of Bigstringaf.t IOVec.t list | `Yield | `Close of int ]
|
||||
|
||||
let iovecs_to_string iovecs =
|
||||
let len = IOVec.lengthv iovecs in
|
||||
let bytes = Bytes.create len in
|
||||
let dst_off = ref 0 in
|
||||
List.iter (fun { IOVec.buffer; off = src_off; len } ->
|
||||
Bigstringaf.unsafe_blit_to_bytes buffer ~src_off bytes ~dst_off:!dst_off ~len;
|
||||
dst_off := !dst_off + len)
|
||||
iovecs;
|
||||
Bytes.unsafe_to_string bytes
|
||||
;;
|
||||
|
||||
let pp_hum fmt (t : t) =
|
||||
match t with
|
||||
| `Write iovecs -> Format.fprintf fmt "Write %S" (iovecs_to_string iovecs)
|
||||
| `Yield -> Format.pp_print_string fmt "Yield"
|
||||
| `Close len -> Format.fprintf fmt "Close %i" len
|
||||
;;
|
||||
|
||||
let to_write_as_string t =
|
||||
match t with
|
||||
| `Write iovecs -> Some (iovecs_to_string iovecs)
|
||||
| `Close _ | `Yield -> None
|
||||
;;
|
||||
end
|
||||
|
||||
let write_operation = Alcotest.of_pp Write_operation.pp_hum
|
||||
let read_operation = Alcotest.of_pp Read_operation.pp_hum
|
||||
|
||||
module Headers = struct
|
||||
include Headers
|
||||
|
||||
let (@) a b = Headers.add_list a (Headers.to_list b)
|
||||
|
||||
let connection_close = Headers.of_list ["connection", "close"]
|
||||
let encoding_chunked = Headers.of_list ["transfer-encoding", "chunked"]
|
||||
let encoding_fixed n = Headers.of_list ["content-length", string_of_int n]
|
||||
end
|
||||
1917
unikernel/duniverse/httpun/lib_test/test_client_connection.ml
Normal file
1917
unikernel/duniverse/httpun/lib_test/test_client_connection.ml
Normal file
File diff suppressed because it is too large
Load diff
78
unikernel/duniverse/httpun/lib_test/test_headers.ml
Normal file
78
unikernel/duniverse/httpun/lib_test/test_headers.ml
Normal file
|
|
@ -0,0 +1,78 @@
|
|||
open Httpun
|
||||
module Array = ArrayLabels
|
||||
module List = ListLabels
|
||||
|
||||
let check msg ~expect actual =
|
||||
Alcotest.(check (list (pair string string))) msg expect (Headers.to_list actual)
|
||||
;;
|
||||
|
||||
let test_replace () =
|
||||
check "replace trailing element"
|
||||
~expect:["c", "d"; "a", "d"]
|
||||
(Headers.replace
|
||||
(Headers.of_list ["c", "d"; "a", "b"])
|
||||
"a"
|
||||
"d");
|
||||
|
||||
check "replace middle element"
|
||||
~expect:["e", "f"; "c", "z"; "a", "b"]
|
||||
(Headers.replace
|
||||
(Headers.of_list ["e", "f"; "c", "d"; "a", "b"])
|
||||
"c"
|
||||
"z");
|
||||
|
||||
check "remove multiple trailing elements"
|
||||
~expect:["c", "d"; "a", "d"]
|
||||
(Headers.replace
|
||||
(Headers.of_list [ "c", "d"; "a", "b"; "a", "c"])
|
||||
"a"
|
||||
"d");
|
||||
;;
|
||||
|
||||
let test_remove () =
|
||||
check "remove leading element"
|
||||
~expect:["c", "d"]
|
||||
(Headers.remove
|
||||
(Headers.of_list ["a", "b"; "c", "d"])
|
||||
"a");
|
||||
check "remove trailing element"
|
||||
~expect:["c", "d"]
|
||||
(Headers.remove
|
||||
(Headers.of_list ["c", "d"; "a", "b"])
|
||||
"a");
|
||||
;;
|
||||
|
||||
let test_ci_equal () =
|
||||
let string_of_char x = String.init 1 (fun _ -> x) in
|
||||
let ascii =
|
||||
Array.init (0xff + 1) ~f:Char.chr
|
||||
|> Array.to_list
|
||||
in
|
||||
let ascii_pairs =
|
||||
List.map ascii ~f:(fun x ->
|
||||
List.map ascii ~f:(fun y -> x, y))
|
||||
|> List.concat
|
||||
in
|
||||
(* Ensure that the branch free case-insensitive equality check is consistent
|
||||
* with a naive implementation. *)
|
||||
List.iter ascii_pairs ~f:(fun (x, y) ->
|
||||
let char_ci_equal =
|
||||
Char.compare (Char.lowercase_ascii x) (Char.lowercase_ascii y) = 0
|
||||
in
|
||||
let headers_equal =
|
||||
let headers = Headers.of_list [ string_of_char y, "value" ] in
|
||||
Headers.mem headers (string_of_char x)
|
||||
in
|
||||
Alcotest.(check bool)
|
||||
(Printf.sprintf "CI: %C = %C" x y)
|
||||
char_ci_equal
|
||||
headers_equal)
|
||||
;;
|
||||
|
||||
|
||||
|
||||
let tests =
|
||||
[ "remove" , `Quick, test_remove
|
||||
; "replace" , `Quick, test_replace
|
||||
; "CI equal", `Quick, test_ci_equal
|
||||
]
|
||||
11
unikernel/duniverse/httpun/lib_test/test_httpun.ml
Normal file
11
unikernel/duniverse/httpun/lib_test/test_httpun.ml
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
let () =
|
||||
Alcotest.run "httpun unit tests"
|
||||
[ "version" , Test_version.tests
|
||||
; "method" , Test_method.tests
|
||||
; "iovec" , Test_iovec.tests
|
||||
; "headers" , Test_headers.tests
|
||||
; "request" , Test_request.tests
|
||||
; "response" , Test_response.tests
|
||||
; "client connection", Test_client_connection.tests
|
||||
; "server connection", Test_server_connection.tests
|
||||
]
|
||||
43
unikernel/duniverse/httpun/lib_test/test_iovec.ml
Normal file
43
unikernel/duniverse/httpun/lib_test/test_iovec.ml
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
open Httpun
|
||||
open IOVec
|
||||
|
||||
(* The length of the buffer is ignored by iovec operations *)
|
||||
let buffer = Bigstringaf.empty
|
||||
|
||||
let test_lengthv () =
|
||||
Alcotest.(check int) "lengthv [] = 0" (lengthv []) 0;
|
||||
Alcotest.(check int) "lengthv [iovec] = length iovec"
|
||||
(lengthv [{ buffer; off = 0; len = 0 }]) (length {buffer; off = 0; len = 0 });
|
||||
Alcotest.(check int) "lengthv [iovec] = length iovec"
|
||||
(lengthv [{ buffer; off = 0; len = 10 }]) (length {buffer; off = 0; len = 10 });
|
||||
;;
|
||||
|
||||
let test_shiftv_raises () =
|
||||
Alcotest.check_raises
|
||||
"IOVec.shiftv: -1 is a negative number"
|
||||
(Failure "IOVec.shiftv: -1 is a negative number")
|
||||
(fun () -> ignore (shiftv [] (-1)));
|
||||
let test f =
|
||||
Alcotest.check_raises
|
||||
"shiftv iovecs n raises when n > lengthv iovecs"
|
||||
(Failure "shiftv: n > lengthv iovecs")
|
||||
(fun () -> ignore (f ()))
|
||||
in
|
||||
test (fun () -> shiftv [] 1);
|
||||
test (fun () -> shiftv [{ buffer; off = 0; len = 1 }] 2);
|
||||
test (fun () -> shiftv [{ buffer; off = 0; len = 1 }; { buffer; off = 0; len = 1 }] 3);
|
||||
;;
|
||||
|
||||
let test_shiftv () =
|
||||
Alcotest.(check (of_pp pp_hum |> list)) "shiftv [] 0 = []" (shiftv [] 0) [];
|
||||
Alcotest.(check (of_pp pp_hum |> list)) "shiftv [{... len ... }] len = []"
|
||||
(shiftv [{ buffer; off = 0; len = 1 }] 1) [];
|
||||
Alcotest.(check (of_pp pp_hum |> list)) "shiftv [iovec] n when length iovec < n"
|
||||
(shiftv [{ buffer; off = 0; len = 4 }] 2) [{ buffer; off = 2; len = 2 }];
|
||||
;;
|
||||
|
||||
let tests =
|
||||
[ "lengthv" , `Quick, test_lengthv
|
||||
; "shiftv" , `Quick, test_shiftv
|
||||
; "shiftv raises ", `Quick, test_shiftv_raises
|
||||
]
|
||||
41
unikernel/duniverse/httpun/lib_test/test_method.ml
Normal file
41
unikernel/duniverse/httpun/lib_test/test_method.ml
Normal file
|
|
@ -0,0 +1,41 @@
|
|||
open Httpun
|
||||
open Method
|
||||
|
||||
let test_is_safe () =
|
||||
Alcotest.(check bool) "GET is safe" (is_safe `GET ) true;
|
||||
Alcotest.(check bool) "HEAD is safe" (is_safe `HEAD) true;
|
||||
Alcotest.(check bool) "POST is safe" (is_safe `POST) false;
|
||||
Alcotest.(check bool) "PUT is safe" (is_safe `PUT ) false;
|
||||
Alcotest.(check bool) "DELETE is safe" (is_safe `DELETE ) false;
|
||||
Alcotest.(check bool) "CONNECT is safe" (is_safe `CONNECT) false;
|
||||
Alcotest.(check bool) "OPTIONS is safe" (is_safe `OPTIONS) true;
|
||||
Alcotest.(check bool) "TRACE is safe" (is_safe `TRACE ) true;
|
||||
;;
|
||||
|
||||
let test_is_cacheable () =
|
||||
Alcotest.(check bool) "GET is cacheable" (is_cacheable `GET ) true;
|
||||
Alcotest.(check bool) "HEAD is cacheable" (is_cacheable `HEAD) true;
|
||||
Alcotest.(check bool) "POST is cacheable" (is_cacheable `POST) true;
|
||||
Alcotest.(check bool) "PUT is cacheable" (is_cacheable `PUT ) false;
|
||||
Alcotest.(check bool) "DELETE is cacheable" (is_cacheable `DELETE ) false;
|
||||
Alcotest.(check bool) "CONNECT is cacheable" (is_cacheable `CONNECT) false;
|
||||
Alcotest.(check bool) "OPTIONS is cacheable" (is_cacheable `OPTIONS) false;
|
||||
Alcotest.(check bool) "TRACE is cacheable" (is_cacheable `TRACE ) false;
|
||||
;;
|
||||
|
||||
let test_is_idempotent () =
|
||||
Alcotest.(check bool) "GET is idempotent" (is_idempotent `GET ) true;
|
||||
Alcotest.(check bool) "HEAD is idempotent" (is_idempotent `HEAD) true;
|
||||
Alcotest.(check bool) "POST is idempotent" (is_idempotent `POST) false;
|
||||
Alcotest.(check bool) "PUT is idempotent" (is_idempotent `PUT ) true;
|
||||
Alcotest.(check bool) "DELETE is idempotent" (is_idempotent `DELETE ) true;
|
||||
Alcotest.(check bool) "CONNECT is idempotent" (is_idempotent `CONNECT) false;
|
||||
Alcotest.(check bool) "OPTIONS is idempotent" (is_idempotent `OPTIONS) true;
|
||||
Alcotest.(check bool) "TRACE is idempotent" (is_idempotent `TRACE ) true;
|
||||
;;
|
||||
|
||||
let tests =
|
||||
[ "is_safe" , `Quick, test_is_safe
|
||||
; "is_cacheable" , `Quick, test_is_cacheable
|
||||
; "is_idempotent", `Quick, test_is_idempotent
|
||||
]
|
||||
104
unikernel/duniverse/httpun/lib_test/test_request.ml
Normal file
104
unikernel/duniverse/httpun/lib_test/test_request.ml
Normal file
|
|
@ -0,0 +1,104 @@
|
|||
open Httpun
|
||||
open Request
|
||||
open Helpers
|
||||
|
||||
let body_length = Alcotest.of_pp Request.Body_length.pp_hum
|
||||
|
||||
let check =
|
||||
let alco =
|
||||
Alcotest.result
|
||||
(Alcotest.of_pp pp_hum)
|
||||
Alcotest.string
|
||||
in
|
||||
fun message ~expect input ->
|
||||
let actual =
|
||||
Angstrom.parse_string ~consume:All Httpun_private.Parse.request input
|
||||
in
|
||||
Alcotest.check alco message expect actual
|
||||
;;
|
||||
|
||||
let test_parse_valid () =
|
||||
check
|
||||
"valid GET without headers"
|
||||
~expect:(Ok (Request.create `GET "/"))
|
||||
"GET / HTTP/1.1\r\n\r\n";
|
||||
check
|
||||
"valid non-standard method without headers"
|
||||
~expect:(Ok (Request.create (`Other "some-other-verb") "/"))
|
||||
"some-other-verb / HTTP/1.1\r\n\r\n";
|
||||
check
|
||||
"valid GET with headers"
|
||||
~expect:(Ok (Request.create ~headers:(Headers.of_list [ "Link", "/path/to/some/website"]) `GET "/"))
|
||||
"GET / HTTP/1.1\r\nLink: /path/to/some/website\r\n\r\n";
|
||||
;;
|
||||
|
||||
let test_parse_invalid_errors () =
|
||||
check
|
||||
"doesn't end"
|
||||
~expect:(Error ": not enough input")
|
||||
"GET / HTTP/1.1\r\n";
|
||||
check
|
||||
"invalid version"
|
||||
~expect:(Error "eol: string")
|
||||
"GET / HTTP/1.22\r\n\r\n";
|
||||
check
|
||||
"malformed header"
|
||||
~expect:(Error "header: char ':'")
|
||||
"GET / HTTP/1.1\r\nLink : /path/to/some/website\r\n\r\n";
|
||||
;;
|
||||
|
||||
let test_body_length () =
|
||||
let check message request ~expect =
|
||||
let actual = Request.body_length request in
|
||||
Alcotest.check body_length message expect actual
|
||||
in
|
||||
let req method_ headers = Request.create method_ ~headers "/" in
|
||||
check
|
||||
"no headers"
|
||||
~expect:(`Fixed 0L)
|
||||
(req `GET Headers.empty);
|
||||
check
|
||||
"single fixed"
|
||||
~expect:(`Fixed 10L)
|
||||
(req `GET Headers.(encoding_fixed 10));
|
||||
check
|
||||
"negative fixed"
|
||||
~expect:(`Error `Bad_request)
|
||||
(req `GET Headers.(encoding_fixed (-10)));
|
||||
check
|
||||
"multiple fixed"
|
||||
~expect:(`Error `Bad_request)
|
||||
(req `GET Headers.(encoding_fixed 10 @ encoding_fixed 20));
|
||||
check
|
||||
"chunked"
|
||||
~expect:`Chunked
|
||||
(req `GET Headers.encoding_chunked);
|
||||
check
|
||||
"chunked multiple times"
|
||||
~expect:`Chunked
|
||||
(req `GET Headers.(encoding_chunked @ encoding_chunked));
|
||||
let encoding_gzip = Headers.of_list ["transfer-encoding", "gzip"] in
|
||||
check
|
||||
"non-chunked transfer-encoding"
|
||||
~expect:(`Error `Bad_request)
|
||||
(req `GET encoding_gzip);
|
||||
check
|
||||
"chunked after non-chunked"
|
||||
~expect:`Chunked
|
||||
(req `GET Headers.(encoding_gzip @ encoding_chunked));
|
||||
check
|
||||
"chunked before non-chunked"
|
||||
~expect:(`Error `Bad_request)
|
||||
(req `GET Headers.(encoding_chunked @ encoding_gzip));
|
||||
check
|
||||
"chunked case-insensitive"
|
||||
~expect:`Chunked
|
||||
(req `GET Headers.(of_list ["transfer-encoding", "CHUNKED"]));
|
||||
;;
|
||||
|
||||
|
||||
let tests =
|
||||
[ "parse valid" , `Quick, test_parse_valid
|
||||
; "parse invalid errors", `Quick, test_parse_invalid_errors
|
||||
; "body length", `Quick, test_body_length
|
||||
]
|
||||
115
unikernel/duniverse/httpun/lib_test/test_response.ml
Normal file
115
unikernel/duniverse/httpun/lib_test/test_response.ml
Normal file
|
|
@ -0,0 +1,115 @@
|
|||
open Httpun
|
||||
open Response
|
||||
open Helpers
|
||||
|
||||
let body_length = Alcotest.of_pp Response.Body_length.pp_hum
|
||||
|
||||
let check =
|
||||
let alco =
|
||||
Alcotest.result
|
||||
(Alcotest.of_pp pp_hum)
|
||||
Alcotest.string
|
||||
in
|
||||
fun message ~expect input ->
|
||||
let actual =
|
||||
Angstrom.parse_string ~consume:All Httpun_private.Parse.response input
|
||||
in
|
||||
Alcotest.check alco message expect actual
|
||||
;;
|
||||
|
||||
let test_parse_valid () =
|
||||
check
|
||||
"OK response without headers"
|
||||
~expect:(Ok (Response.create `OK))
|
||||
"HTTP/1.1 200 OK\r\n\r\n";
|
||||
;;
|
||||
|
||||
let test_parse_invalid_error () =
|
||||
check
|
||||
"OK response without a status message"
|
||||
~expect:(Error ": char ' '")
|
||||
"HTTP/1.1 200\r\n\r\n";
|
||||
check
|
||||
"OK response without a status message"
|
||||
~expect:(Error ": status-code empty")
|
||||
"HTTP/1.1 OK\r\n\r\n";
|
||||
check
|
||||
"OK response without a status message"
|
||||
~expect:(Error ": status-code too long: \"999999937377999999999200\"")
|
||||
"HTTP/1.1 999999937377999999999200\r\n\r\n";
|
||||
;;
|
||||
|
||||
let test_body_length () =
|
||||
let check message request_method response ~expect =
|
||||
let actual = Response.body_length response ~request_method in
|
||||
Alcotest.check body_length message expect actual
|
||||
in
|
||||
let res status headers = Response.create status ~headers in
|
||||
check
|
||||
"requested HEAD"
|
||||
~expect:(`Fixed 0L)
|
||||
`HEAD (res `OK Headers.empty);
|
||||
check
|
||||
"requested CONNECT"
|
||||
~expect:(`Close_delimited)
|
||||
`CONNECT (res `OK Headers.empty);
|
||||
check
|
||||
"status: informational"
|
||||
~expect:(`Fixed 0L)
|
||||
`GET (res `Continue Headers.empty);
|
||||
check
|
||||
"status: no content"
|
||||
~expect:(`Fixed 0L)
|
||||
`GET (res `No_content Headers.empty);
|
||||
check
|
||||
"status: not modified"
|
||||
~expect:(`Fixed 0L)
|
||||
`GET (res `Not_modified Headers.empty);
|
||||
check
|
||||
"no header"
|
||||
~expect:(`Close_delimited)
|
||||
`GET (res `OK Headers.empty);
|
||||
check
|
||||
"single fixed"
|
||||
~expect:(`Fixed 10L)
|
||||
`GET (res `OK Headers.(encoding_fixed 10));
|
||||
check
|
||||
"negative fixed"
|
||||
~expect:(`Error `Internal_server_error)
|
||||
`GET (res `OK Headers.(encoding_fixed (-10)));
|
||||
check
|
||||
"multiple fixed"
|
||||
~expect:(`Error `Internal_server_error)
|
||||
`GET (res `OK Headers.(encoding_fixed 10 @ encoding_fixed 20));
|
||||
check
|
||||
"chunked"
|
||||
~expect:`Chunked
|
||||
`GET (res `OK Headers.encoding_chunked);
|
||||
check
|
||||
"chunked multiple times"
|
||||
~expect:`Chunked
|
||||
`GET (res `OK Headers.(encoding_chunked @ encoding_chunked));
|
||||
let encoding_gzip = Headers.of_list ["transfer-encoding", "gzip"] in
|
||||
check
|
||||
"non-chunked transfer-encoding"
|
||||
~expect:`Close_delimited
|
||||
`GET (res `OK encoding_gzip);
|
||||
check
|
||||
"chunked after non-chunked"
|
||||
~expect:`Chunked
|
||||
`GET (res `OK Headers.(encoding_gzip @ encoding_chunked));
|
||||
check
|
||||
"chunked before non-chunked"
|
||||
~expect:`Close_delimited
|
||||
`GET (res `OK Headers.(encoding_chunked @ encoding_gzip));
|
||||
check
|
||||
"chunked case-insensitive"
|
||||
~expect:`Chunked
|
||||
`GET (res `OK Headers.(of_list ["transfer-encoding", "CHUNKED"]));
|
||||
;;
|
||||
|
||||
let tests =
|
||||
[ "parse valid" , `Quick, test_parse_valid
|
||||
; "parse invalid error", `Quick, test_parse_invalid_error
|
||||
; "body length" , `Quick, test_body_length
|
||||
]
|
||||
2523
unikernel/duniverse/httpun/lib_test/test_server_connection.ml
Normal file
2523
unikernel/duniverse/httpun/lib_test/test_server_connection.ml
Normal file
File diff suppressed because it is too large
Load diff
22
unikernel/duniverse/httpun/lib_test/test_version.ml
Normal file
22
unikernel/duniverse/httpun/lib_test/test_version.ml
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
open Httpun
|
||||
open Version
|
||||
|
||||
let v1_0 = { major = 1; minor = 0 }
|
||||
let v1_1 = { major = 1; minor = 1 }
|
||||
|
||||
let test_compare () =
|
||||
Alcotest.(check int) "compare v1_1 v1_0" (compare v1_1 v1_0) 1;
|
||||
Alcotest.(check int) "compare v1_1 v1_1" (compare v1_1 v1_1) 0;
|
||||
Alcotest.(check int) "compare v1_0 v1_0" (compare v1_0 v1_0) 0;
|
||||
Alcotest.(check int) "compare v1_0 v1_1" (compare v1_0 v1_1) (-1);
|
||||
;;
|
||||
|
||||
let test_to_string () =
|
||||
Alcotest.(check string) "to_string v1_1" (to_string v1_1) "HTTP/1.1";
|
||||
Alcotest.(check string) "to_string v1_0" (to_string v1_0) "HTTP/1.0";
|
||||
;;
|
||||
|
||||
let tests =
|
||||
[ "compare" , `Quick, test_compare
|
||||
; "to_string", `Quick, test_to_string
|
||||
]
|
||||
4
unikernel/duniverse/httpun/lwt-unix/dune
Normal file
4
unikernel/duniverse/httpun/lwt-unix/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(library
|
||||
(name httpun_lwt_unix)
|
||||
(public_name httpun-lwt-unix)
|
||||
(libraries httpun httpun-lwt gluten-lwt-unix lwt.unix))
|
||||
112
unikernel/duniverse/httpun/lwt-unix/httpun_lwt_unix.ml
Normal file
112
unikernel/duniverse/httpun/lwt-unix/httpun_lwt_unix.ml
Normal file
|
|
@ -0,0 +1,112 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2018 Inhabited Type LLC.
|
||||
Copyright (c) 2018 Anton Bachin
|
||||
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 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 Lwt.Infix
|
||||
|
||||
module Server = struct
|
||||
include Httpun_lwt.Server (Gluten_lwt_unix.Server)
|
||||
|
||||
module TLS = struct
|
||||
include Httpun_lwt.Server (Gluten_lwt_unix.Server.TLS)
|
||||
|
||||
let create_connection_handler_with_default
|
||||
~certfile
|
||||
~keyfile
|
||||
?config
|
||||
~request_handler
|
||||
~error_handler =
|
||||
let make_tls_server =
|
||||
Gluten_lwt_unix.Server.TLS.create_default ~certfile ~keyfile
|
||||
in
|
||||
fun client_addr socket ->
|
||||
make_tls_server client_addr ~alpn_protocols:["http/1.1"] socket
|
||||
>>= fun tls_server ->
|
||||
create_connection_handler
|
||||
?config
|
||||
~request_handler
|
||||
~error_handler
|
||||
client_addr
|
||||
tls_server
|
||||
end
|
||||
|
||||
module SSL = struct
|
||||
include Httpun_lwt.Server (Gluten_lwt_unix.Server.SSL)
|
||||
|
||||
let create_connection_handler_with_default
|
||||
~certfile
|
||||
~keyfile
|
||||
?config
|
||||
~request_handler
|
||||
~error_handler =
|
||||
let make_ssl_server =
|
||||
Gluten_lwt_unix.Server.SSL.create_default ~certfile ~keyfile
|
||||
in
|
||||
fun client_addr socket ->
|
||||
make_ssl_server ~alpn_protocols:["http/1.1"] client_addr socket
|
||||
>>= fun ssl_server ->
|
||||
create_connection_handler
|
||||
?config
|
||||
~request_handler
|
||||
~error_handler
|
||||
client_addr
|
||||
ssl_server
|
||||
end
|
||||
end
|
||||
|
||||
module Client = struct
|
||||
include Httpun_lwt.Client (Gluten_lwt_unix.Client)
|
||||
|
||||
module TLS = struct
|
||||
include Httpun_lwt.Client (Gluten_lwt_unix.Client.TLS)
|
||||
|
||||
let create_connection_with_default ?config socket =
|
||||
Gluten_lwt_unix.Client.TLS.create_default
|
||||
~alpn_protocols:["http/1.1"]
|
||||
socket
|
||||
>>= fun tls_client ->
|
||||
create_connection ?config tls_client
|
||||
end
|
||||
|
||||
module SSL = struct
|
||||
include Httpun_lwt.Client (Gluten_lwt_unix.Client.SSL)
|
||||
|
||||
let create_connection_with_default ?config socket =
|
||||
Gluten_lwt_unix.Client.SSL.create_default
|
||||
~alpn_protocols:["http/1.1"]
|
||||
socket
|
||||
>>= fun ssl_client ->
|
||||
create_connection ?config ssl_client
|
||||
end
|
||||
end
|
||||
106
unikernel/duniverse/httpun/lwt-unix/httpun_lwt_unix.mli
Normal file
106
unikernel/duniverse/httpun/lwt-unix/httpun_lwt_unix.mli
Normal file
|
|
@ -0,0 +1,106 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2018 Inhabited Type LLC.
|
||||
Copyright (c) 2018 Anton Bachin
|
||||
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 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 Httpun
|
||||
|
||||
(* The function that results from [create_connection_handler] should be passed
|
||||
to [Lwt_io.establish_server_with_client_socket]. For an example, see
|
||||
[examples/lwt_echo_server.ml]. *)
|
||||
module Server : sig
|
||||
include Httpun_lwt.Server
|
||||
with type socket = Lwt_unix.file_descr
|
||||
and type addr := Unix.sockaddr
|
||||
|
||||
module TLS : sig
|
||||
include Httpun_lwt.Server
|
||||
with type socket = Gluten_lwt_unix.Server.TLS.socket
|
||||
and type addr := Unix.sockaddr
|
||||
|
||||
val create_connection_handler_with_default
|
||||
: certfile : string
|
||||
-> keyfile : string
|
||||
-> ?config : Config.t
|
||||
-> request_handler : (Unix.sockaddr -> Httpun.Reqd.t Gluten.reqd -> unit)
|
||||
-> error_handler : (Unix.sockaddr -> Server_connection.error_handler)
|
||||
-> Unix.sockaddr
|
||||
-> Lwt_unix.file_descr
|
||||
-> unit Lwt.t
|
||||
end
|
||||
|
||||
module SSL : sig
|
||||
include Httpun_lwt.Server
|
||||
with type socket = Gluten_lwt_unix.Server.SSL.socket
|
||||
and type addr := Unix.sockaddr
|
||||
|
||||
val create_connection_handler_with_default
|
||||
: certfile : string
|
||||
-> keyfile : string
|
||||
-> ?config : Config.t
|
||||
-> request_handler : (Unix.sockaddr -> Httpun.Reqd.t Gluten.reqd -> unit)
|
||||
-> error_handler : (Unix.sockaddr -> Server_connection.error_handler)
|
||||
-> Unix.sockaddr
|
||||
-> Lwt_unix.file_descr
|
||||
-> unit Lwt.t
|
||||
end
|
||||
end
|
||||
|
||||
(* For an example, see [examples/lwt_get.ml]. *)
|
||||
module Client : sig
|
||||
include Httpun_lwt.Client
|
||||
with type socket = Lwt_unix.file_descr
|
||||
and type runtime = Gluten_lwt_unix.Client.t
|
||||
|
||||
module TLS : sig
|
||||
include Httpun_lwt.Client
|
||||
with type socket = Gluten_lwt_unix.Client.TLS.socket
|
||||
and type runtime = Gluten_lwt_unix.Client.TLS.t
|
||||
|
||||
val create_connection_with_default
|
||||
: ?config : Config.t
|
||||
-> Lwt_unix.file_descr
|
||||
-> t Lwt.t
|
||||
end
|
||||
|
||||
module SSL : sig
|
||||
include Httpun_lwt.Client
|
||||
with type socket = Gluten_lwt_unix.Client.SSL.socket
|
||||
and type runtime = Gluten_lwt_unix.Client.SSL.t
|
||||
|
||||
val create_connection_with_default
|
||||
: ?config : Config.t
|
||||
-> Lwt_unix.file_descr
|
||||
-> t Lwt.t
|
||||
end
|
||||
end
|
||||
4
unikernel/duniverse/httpun/lwt/dune
Normal file
4
unikernel/duniverse/httpun/lwt/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(library
|
||||
(name httpun_lwt)
|
||||
(public_name httpun-lwt)
|
||||
(libraries httpun lwt gluten gluten-lwt))
|
||||
88
unikernel/duniverse/httpun/lwt/httpun_lwt.ml
Normal file
88
unikernel/duniverse/httpun/lwt/httpun_lwt.ml
Normal file
|
|
@ -0,0 +1,88 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2018 Inhabited Type LLC.
|
||||
Copyright (c) 2018 Anton Bachin
|
||||
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 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
include Httpun_lwt_intf
|
||||
|
||||
module Server (Server_runtime: Gluten_lwt.Server) = struct
|
||||
type socket = Server_runtime.socket
|
||||
|
||||
let create_connection_handler
|
||||
?(config=Httpun.Config.default)
|
||||
~request_handler
|
||||
~error_handler =
|
||||
fun client_addr socket ->
|
||||
let create_connection =
|
||||
Httpun.Server_connection.create
|
||||
~config
|
||||
~error_handler:(error_handler client_addr)
|
||||
in
|
||||
Server_runtime.create_upgradable_connection_handler
|
||||
~read_buffer_size:config.read_buffer_size
|
||||
~protocol:(module Httpun.Server_connection)
|
||||
~create_protocol:create_connection
|
||||
~request_handler
|
||||
client_addr
|
||||
socket
|
||||
end
|
||||
|
||||
module Client (Client_runtime: Gluten_lwt.Client) = struct
|
||||
type socket = Client_runtime.socket
|
||||
|
||||
type runtime = Client_runtime.t
|
||||
|
||||
type t =
|
||||
{ connection: Httpun.Client_connection.t
|
||||
; runtime: runtime
|
||||
}
|
||||
|
||||
let create_connection ?(config=Httpun.Config.default) socket =
|
||||
let open Lwt.Infix in
|
||||
let connection = Httpun.Client_connection.create ~config () in
|
||||
Client_runtime.create
|
||||
~read_buffer_size:config.read_buffer_size
|
||||
~protocol:(module Httpun.Client_connection)
|
||||
connection
|
||||
socket
|
||||
>|= fun runtime ->
|
||||
{ runtime; connection }
|
||||
|
||||
let request t = Httpun.Client_connection.request t.connection
|
||||
|
||||
let shutdown t = Client_runtime.shutdown t.runtime
|
||||
|
||||
let is_closed t = Client_runtime.is_closed t.runtime
|
||||
|
||||
let upgrade t protocol = Client_runtime.upgrade t.runtime protocol
|
||||
end
|
||||
56
unikernel/duniverse/httpun/lwt/httpun_lwt.mli
Normal file
56
unikernel/duniverse/httpun/lwt/httpun_lwt.mli
Normal file
|
|
@ -0,0 +1,56 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2018 Inhabited Type LLC.
|
||||
Copyright (c) 2018 Anton Bachin
|
||||
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 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 type Server = Httpun_lwt_intf.Server
|
||||
|
||||
module type Client = Httpun_lwt_intf.Client
|
||||
|
||||
(* The function that results from [create_connection_handler] should be passed
|
||||
to [Lwt_io.establish_server_with_client_socket]. For an example, see
|
||||
[examples/lwt_echo_server.ml]. *)
|
||||
module Server (Server_runtime: Gluten_lwt.Server) :
|
||||
Server with type socket = Server_runtime.socket
|
||||
and type addr := Server_runtime.addr
|
||||
|
||||
(* For an example, see [examples/lwt_get.ml]. *)
|
||||
module Client (Client_runtime: Gluten_lwt.Client) : sig
|
||||
include Client with type socket = Client_runtime.socket
|
||||
and type runtime = Client_runtime.t
|
||||
|
||||
val create_connection
|
||||
: ?config : Httpun.Config.t
|
||||
-> Client_runtime.socket
|
||||
-> t Lwt.t
|
||||
end
|
||||
77
unikernel/duniverse/httpun/lwt/httpun_lwt_intf.ml
Normal file
77
unikernel/duniverse/httpun/lwt/httpun_lwt_intf.ml
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
* 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 Httpun
|
||||
|
||||
module type Server = sig
|
||||
type socket
|
||||
|
||||
type addr
|
||||
|
||||
val create_connection_handler
|
||||
: ?config : Config.t
|
||||
-> request_handler : (addr -> Httpun.Reqd.t Gluten.reqd -> unit)
|
||||
-> error_handler : (addr -> Server_connection.error_handler)
|
||||
-> addr
|
||||
-> socket
|
||||
-> unit Lwt.t
|
||||
end
|
||||
|
||||
module type Client = sig
|
||||
type socket
|
||||
|
||||
type runtime
|
||||
|
||||
type t =
|
||||
{ connection: Httpun.Client_connection.t
|
||||
; runtime: runtime
|
||||
}
|
||||
|
||||
val create_connection
|
||||
: ?config : Config.t
|
||||
-> socket
|
||||
-> t Lwt.t
|
||||
|
||||
val request
|
||||
: t
|
||||
-> ?flush_headers_immediately:bool
|
||||
-> Request.t
|
||||
-> error_handler : Client_connection.error_handler
|
||||
-> response_handler : Client_connection.response_handler
|
||||
-> Body.Writer.t
|
||||
|
||||
val shutdown: t -> unit Lwt.t
|
||||
|
||||
val is_closed : t -> bool
|
||||
|
||||
val upgrade : t -> Gluten.impl -> unit
|
||||
end
|
||||
10
unikernel/duniverse/httpun/mirage/dune
Normal file
10
unikernel/duniverse/httpun/mirage/dune
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
(library
|
||||
(name httpun_mirage)
|
||||
(public_name httpun-mirage)
|
||||
(libraries
|
||||
httpun
|
||||
httpun-lwt
|
||||
gluten-mirage
|
||||
lwt
|
||||
mirage-flow
|
||||
cstruct))
|
||||
71
unikernel/duniverse/httpun/mirage/httpun_mirage.ml
Normal file
71
unikernel/duniverse/httpun/mirage/httpun_mirage.ml
Normal file
|
|
@ -0,0 +1,71 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2018 Inhabited Type LLC.
|
||||
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 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 Server (Flow : Mirage_flow.S) = struct
|
||||
module Server_runtime = Httpun_lwt.Server (Gluten_mirage.Server (Flow))
|
||||
type socket = Flow.flow
|
||||
|
||||
let create_connection_handler ?config ~request_handler ~error_handler =
|
||||
fun flow ->
|
||||
let request_handler () = request_handler in
|
||||
let error_handler () = error_handler in
|
||||
Server_runtime.create_connection_handler
|
||||
?config
|
||||
~request_handler
|
||||
~error_handler
|
||||
()
|
||||
(Gluten_mirage.Buffered_flow.create flow)
|
||||
end
|
||||
|
||||
(* Almost like the `Httpun_lwt.Server` module type but we don't need the client
|
||||
* address argument in Mirage. It's somewhere else. *)
|
||||
module type Server = sig
|
||||
type socket
|
||||
|
||||
val create_connection_handler
|
||||
: ?config : Httpun.Config.t
|
||||
-> request_handler : (Httpun.Reqd.t Gluten.reqd -> unit)
|
||||
-> error_handler : Httpun.Server_connection.error_handler
|
||||
-> (socket -> unit Lwt.t)
|
||||
end
|
||||
|
||||
module type Client = Httpun_lwt.Client
|
||||
|
||||
module Client (Flow : Mirage_flow.S) = struct
|
||||
include Httpun_lwt.Client (Gluten_mirage.Client (Flow))
|
||||
type socket = Flow.flow
|
||||
|
||||
let create_connection ?config flow =
|
||||
create_connection ?config (Gluten_mirage.Buffered_flow.create flow)
|
||||
end
|
||||
52
unikernel/duniverse/httpun/mirage/httpun_mirage.mli
Normal file
52
unikernel/duniverse/httpun/mirage/httpun_mirage.mli
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2018 Inhabited Type LLC.
|
||||
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 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 Httpun
|
||||
|
||||
module type Server = sig
|
||||
type socket
|
||||
|
||||
val create_connection_handler
|
||||
: ?config : Config.t
|
||||
-> request_handler : (Reqd.t Gluten.reqd -> unit)
|
||||
-> error_handler : Server_connection.error_handler
|
||||
-> (socket -> unit Lwt.t)
|
||||
end
|
||||
|
||||
module Server (Flow : Mirage_flow.S) :
|
||||
Server with type socket = Flow.flow
|
||||
|
||||
module type Client = Httpun_lwt.Client
|
||||
|
||||
module Client (Flow : Mirage_flow.S) : Client with type socket = Flow.flow
|
||||
31
unikernel/duniverse/httpun/nix/ci/test.nix
Normal file
31
unikernel/duniverse/httpun/nix/ci/test.nix
Normal file
|
|
@ -0,0 +1,31 @@
|
|||
{ ocamlVersion }:
|
||||
|
||||
let
|
||||
lock = builtins.fromJSON (builtins.readFile ./../../flake.lock);
|
||||
src = fetchGit {
|
||||
url = with lock.nodes.nixpkgs.locked; "https://github.com/${owner}/${repo}";
|
||||
inherit (lock.nodes.nixpkgs.locked) rev;
|
||||
allRefs = true;
|
||||
};
|
||||
nix-filter-src = fetchGit {
|
||||
url = with lock.nodes.nix-filter.locked; "https://github.com/${owner}/${repo}";
|
||||
inherit (lock.nodes.nix-filter.locked) rev;
|
||||
# inherit (lock.nodes.nixpkgs.original) ref;
|
||||
allRefs = true;
|
||||
};
|
||||
nix-filter = import "${nix-filter-src}";
|
||||
|
||||
pkgs = import "${src}" {
|
||||
extraOverlays = [
|
||||
(self: super: {
|
||||
ocamlPackages = super.ocaml-ng."ocamlPackages_${ocamlVersion}";
|
||||
})
|
||||
];
|
||||
};
|
||||
|
||||
in
|
||||
|
||||
pkgs.callPackage ./.. {
|
||||
inherit nix-filter;
|
||||
doCheck = true;
|
||||
}
|
||||
117
unikernel/duniverse/httpun/nix/default.nix
Normal file
117
unikernel/duniverse/httpun/nix/default.nix
Normal file
|
|
@ -0,0 +1,117 @@
|
|||
{ nix-filter, lib, stdenv, ocamlPackages, doCheck ? true }:
|
||||
|
||||
with ocamlPackages;
|
||||
|
||||
let
|
||||
genSrc = { dirs, files }:
|
||||
with nix-filter; filter {
|
||||
root = ./..;
|
||||
include = [ "dune-project" ] ++ files ++ (builtins.map inDirectory dirs);
|
||||
};
|
||||
buildHttpun = args: buildDunePackage ({
|
||||
version = "0.6.5-dev";
|
||||
doCheck = doCheck;
|
||||
} // args);
|
||||
|
||||
httpunPkgs = rec {
|
||||
httpun-types = buildHttpun {
|
||||
pname = "httpun-types";
|
||||
src = genSrc {
|
||||
dirs = [ "types" ];
|
||||
files = [ "httpun-types.opam" ];
|
||||
};
|
||||
propagatedBuildInputs = [ faraday ];
|
||||
};
|
||||
|
||||
httpun = buildHttpun {
|
||||
pname = "httpun";
|
||||
src = genSrc {
|
||||
dirs = [ "lib" "lib_test" ];
|
||||
files = [ "httpun.opam" ];
|
||||
};
|
||||
buildInputs = [ alcotest hex yojson ];
|
||||
propagatedBuildInputs = [
|
||||
angstrom
|
||||
faraday
|
||||
httpun-types
|
||||
];
|
||||
};
|
||||
|
||||
# These two don't have tests
|
||||
httpun-lwt = buildHttpun {
|
||||
pname = "httpun-lwt";
|
||||
src = genSrc {
|
||||
dirs = [ "lwt" ];
|
||||
files = [ "httpun-lwt.opam" ];
|
||||
};
|
||||
doCheck = false;
|
||||
propagatedBuildInputs = [ gluten-lwt httpun lwt ];
|
||||
};
|
||||
|
||||
httpun-lwt-unix = buildHttpun {
|
||||
pname = "httpun-lwt-unix";
|
||||
src = genSrc {
|
||||
dirs = [ "lwt-unix" ];
|
||||
files = [ "httpun-lwt-unix.opam" ];
|
||||
};
|
||||
doCheck = false;
|
||||
propagatedBuildInputs = [
|
||||
gluten-lwt-unix
|
||||
httpun-lwt
|
||||
faraday-lwt-unix
|
||||
lwt_ssl
|
||||
];
|
||||
};
|
||||
|
||||
httpun-async = buildHttpun {
|
||||
pname = "httpun-async";
|
||||
src = genSrc {
|
||||
dirs = [ "async" ];
|
||||
files = [ "httpun-async.opam" ];
|
||||
};
|
||||
doCheck = false;
|
||||
propagatedBuildInputs = [
|
||||
httpun
|
||||
async
|
||||
gluten-async
|
||||
faraday-async
|
||||
async_ssl
|
||||
];
|
||||
};
|
||||
|
||||
httpun-mirage = buildHttpun {
|
||||
pname = "httpun-mirage";
|
||||
src = genSrc {
|
||||
dirs = [ "mirage" ];
|
||||
files = [ "httpun-mirage.opam" ];
|
||||
};
|
||||
doCheck = false;
|
||||
propagatedBuildInputs = [
|
||||
faraday-lwt
|
||||
conduit-mirage
|
||||
httpun-lwt
|
||||
gluten-mirage
|
||||
];
|
||||
};
|
||||
};
|
||||
|
||||
in
|
||||
|
||||
with httpunPkgs;
|
||||
|
||||
httpunPkgs // (if lib.versionOlder "5.0" ocaml.version then {
|
||||
httpun-eio = buildHttpun {
|
||||
pname = "httpun-eio";
|
||||
src = genSrc {
|
||||
dirs = [ "eio" ];
|
||||
files = [ "httpun-eio.opam" ];
|
||||
};
|
||||
|
||||
propagatedBuildInputs = [
|
||||
httpun
|
||||
gluten-eio
|
||||
eio
|
||||
];
|
||||
};
|
||||
|
||||
} else { })
|
||||
32
unikernel/duniverse/httpun/nix/shell.nix
Normal file
32
unikernel/duniverse/httpun/nix/shell.nix
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
{ pkgs
|
||||
, packages
|
||||
, stdenv
|
||||
, lib
|
||||
, release-mode ? false
|
||||
}:
|
||||
|
||||
let
|
||||
httpunDrvs = lib.filterAttrs (_: value: lib.isDerivation value) packages;
|
||||
|
||||
in
|
||||
with pkgs;
|
||||
|
||||
(mkShell {
|
||||
OCAMLRUNPARAM = "b";
|
||||
nativeBuildInputs =
|
||||
lib.optionals release-mode [
|
||||
cacert
|
||||
curl
|
||||
ocamlPackages.dune-release
|
||||
git
|
||||
];
|
||||
inputsFrom = lib.attrValues httpunDrvs;
|
||||
buildInputs = with ocamlPackages; [ merlin utop ];
|
||||
}).overrideAttrs (o: {
|
||||
propagatedBuildInputs = lib.filter
|
||||
(drv:
|
||||
!(lib.hasAttr "pname" drv) ||
|
||||
drv.pname == null ||
|
||||
!(lib.any (name: name == drv.pname) (lib.attrNames httpunDrvs)))
|
||||
o.propagatedBuildInputs;
|
||||
})
|
||||
4
unikernel/duniverse/httpun/types/dune
Normal file
4
unikernel/duniverse/httpun/types/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(library
|
||||
(public_name httpun-types)
|
||||
(name httpun_types)
|
||||
(libraries faraday))
|
||||
177
unikernel/duniverse/httpun/types/headers.ml
Normal file
177
unikernel/duniverse/httpun/types/headers.ml
Normal file
|
|
@ -0,0 +1,177 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2017 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
|
||||
type name = string
|
||||
type value = string
|
||||
type t = (name * value) list
|
||||
|
||||
let empty : t = []
|
||||
|
||||
let of_rev_list t = t
|
||||
let of_list t = of_rev_list (List.rev t)
|
||||
let to_rev_list t = t
|
||||
let to_list t = List.rev (to_rev_list t)
|
||||
|
||||
module CI = struct
|
||||
(* Convert codes to upper case and compare them. This is a port of assembly
|
||||
code from the page:
|
||||
|
||||
http://www.azillionmonkeys.com/qed/asmexample.html *)
|
||||
let[@inline always] char_code_equal_ci x y =
|
||||
let codes = (x lsl 8) lor y in
|
||||
let b = 0x8080 lor codes in
|
||||
let c = b - 0x6161 in
|
||||
let d = lnot (b - 0x7b7b) in
|
||||
let e = (c land d) land (lnot codes land 0x8080) in
|
||||
let upper = codes - (e lsr 2) in
|
||||
upper lsr 8 = upper land 0xff
|
||||
|
||||
let equal x y =
|
||||
let len = String.length x in
|
||||
len = String.length y && (
|
||||
let equal_so_far = ref true in
|
||||
let i = ref 0 in
|
||||
while !equal_so_far && !i < len do
|
||||
let c1 = Char.code (String.unsafe_get x !i) in
|
||||
let c2 = Char.code (String.unsafe_get y !i) in
|
||||
equal_so_far := char_code_equal_ci c1 c2;
|
||||
incr i
|
||||
done;
|
||||
!equal_so_far
|
||||
)
|
||||
end
|
||||
|
||||
let ci_equal = CI.equal
|
||||
|
||||
let rec mem t name =
|
||||
match t with
|
||||
| (name', _)::t' -> CI.equal name name' || mem t' name
|
||||
| _ -> false
|
||||
|
||||
let add t name value = (name,value)::t
|
||||
let add_list t ls = 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 ((n,v)::t) n vs' lss
|
||||
in
|
||||
loop_outer
|
||||
|
||||
let add_unless_exists t name value =
|
||||
if mem t name then t else (name,value)::t
|
||||
|
||||
exception Local
|
||||
|
||||
let replace t name value =
|
||||
let rec loop t needle nv seen =
|
||||
match t with
|
||||
| [] ->
|
||||
if not seen then raise Local else []
|
||||
| (name,_ as nv')::t ->
|
||||
if CI.equal needle name
|
||||
then (
|
||||
if seen
|
||||
then loop t needle nv true
|
||||
else nv::loop t needle nv true)
|
||||
else nv'::loop t needle nv seen
|
||||
in
|
||||
try loop t name (name,value) false
|
||||
with Local -> t
|
||||
|
||||
let remove t name =
|
||||
let rec loop s needle seen =
|
||||
match s with
|
||||
| [] ->
|
||||
if not seen then raise Local else []
|
||||
| (name,_ as nv')::s' ->
|
||||
if CI.equal needle name
|
||||
then loop s' needle true
|
||||
else nv'::(loop s' needle seen)
|
||||
in
|
||||
try loop t name false
|
||||
with Local -> t
|
||||
|
||||
let get t name =
|
||||
let rec loop t n =
|
||||
match t with
|
||||
| [] -> None
|
||||
| (n',v)::t' -> if CI.equal n n' then Some v else loop t' n
|
||||
in
|
||||
loop t name
|
||||
|
||||
let get_exn t name =
|
||||
let rec loop t n =
|
||||
match t with
|
||||
| [] -> raise Not_found
|
||||
| (n',v)::t' -> if CI.equal n n' then v else loop t' n
|
||||
in
|
||||
loop t name
|
||||
|
||||
let get_multi t name =
|
||||
let rec loop t n acc =
|
||||
match t with
|
||||
| [] -> acc
|
||||
| (n',v)::t' ->
|
||||
if CI.equal n n'
|
||||
then loop t' n (v::acc)
|
||||
else loop t' n acc
|
||||
in
|
||||
loop t name []
|
||||
|
||||
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 to_string t =
|
||||
let b = Buffer.create 128 in
|
||||
iter (to_list t) ~f:(fun name value ->
|
||||
Buffer.add_string b name;
|
||||
Buffer.add_string b ": ";
|
||||
Buffer.add_string b value;
|
||||
Buffer.add_string b "\r\n");
|
||||
Buffer.add_string b "\r\n";
|
||||
Buffer.contents b
|
||||
|
||||
let pp_hum fmt t =
|
||||
let pp_elem fmt (n,v) = Format.fprintf fmt "@[(%S %S)@]" n v in
|
||||
Format.fprintf fmt "@[(";
|
||||
Format.pp_print_list pp_elem fmt (to_list t);
|
||||
Format.fprintf fmt ")@]";
|
||||
94
unikernel/duniverse/httpun/types/headers.mli
Normal file
94
unikernel/duniverse/httpun/types/headers.mli
Normal file
|
|
@ -0,0 +1,94 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2017 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
(** Header Fields
|
||||
|
||||
Each header field consists of a case-insensitive {b field name} and a {b
|
||||
field value}. The order in which header fields {i with differing field
|
||||
names} are received is not significant. However, it is good practice to
|
||||
send header fields that contain control data first so that implementations
|
||||
can decide when not to handle a message as early as possible.
|
||||
|
||||
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. *)
|
||||
|
||||
type t
|
||||
|
||||
type name = string
|
||||
type value = string
|
||||
|
||||
(** Case-insensitive equality for testing header names or values *)
|
||||
val ci_equal : string -> string -> bool
|
||||
|
||||
val empty : t
|
||||
|
||||
val of_list : (name * value) list -> t
|
||||
val of_rev_list : (name * value) list -> t
|
||||
val to_list : t -> (name * value) list
|
||||
val to_rev_list : t -> (name * value) list
|
||||
|
||||
val add : t -> name -> value -> t
|
||||
val add_unless_exists : t -> name -> value -> t
|
||||
val add_list : t -> (name * value) list -> t
|
||||
val add_multi : t -> (name * value list) list -> t
|
||||
|
||||
val remove : t -> name -> t
|
||||
val replace : t -> name -> value -> t
|
||||
|
||||
val mem : t -> name -> bool
|
||||
val get : t -> name -> value option
|
||||
val get_exn : t -> name -> value
|
||||
val get_multi : t -> name -> value list
|
||||
|
||||
val iter : f:(name -> value -> unit) -> t -> unit
|
||||
val fold : f:(name -> value -> 'a -> 'a) -> init:'a -> t -> 'a
|
||||
|
||||
val to_string : t -> string
|
||||
val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer]
|
||||
63
unikernel/duniverse/httpun/types/iOVec.ml
Normal file
63
unikernel/duniverse/httpun/types/iOVec.ml
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2017 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
|
||||
type 'a t = 'a Faraday.iovec =
|
||||
{ buffer : 'a
|
||||
; off : int
|
||||
; len : int }
|
||||
|
||||
let length { len; _ } = len
|
||||
let lengthv iovs = List.fold_left (fun acc { len; _ } -> acc + len) 0 iovs
|
||||
|
||||
let shift { buffer; off; len } n =
|
||||
assert (n <= len);
|
||||
{ buffer; off = off + n; len = len - n }
|
||||
|
||||
let shiftv iovecs n =
|
||||
if n < 0 then failwith (Printf.sprintf "IOVec.shiftv: %d is a negative number" n);
|
||||
let rec loop iovecs n =
|
||||
if n = 0
|
||||
then iovecs
|
||||
else match iovecs with
|
||||
| [] -> failwith "shiftv: n > lengthv iovecs"
|
||||
| iovec::iovecs ->
|
||||
let iovec_len = length iovec in
|
||||
if iovec_len <= n
|
||||
then loop iovecs (n - iovec_len)
|
||||
else (shift iovec n)::iovecs
|
||||
in
|
||||
loop iovecs n
|
||||
|
||||
let pp_hum fmt t =
|
||||
Format.fprintf fmt "{ buffer = <opaque>; off = %d; len = %d }" t.off t.len
|
||||
45
unikernel/duniverse/httpun/types/iOVec.mli
Normal file
45
unikernel/duniverse/httpun/types/iOVec.mli
Normal file
|
|
@ -0,0 +1,45 @@
|
|||
(*----------------------------------------------------------------------------
|
||||
Copyright (c) 2017 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.
|
||||
----------------------------------------------------------------------------*)
|
||||
|
||||
type 'a t = 'a Faraday.iovec =
|
||||
{ buffer : 'a
|
||||
; off : int
|
||||
; len : int }
|
||||
|
||||
val length : _ t -> int
|
||||
val lengthv : _ t list -> int
|
||||
|
||||
val shift : 'a t -> int -> 'a t
|
||||
val shiftv : 'a t list -> int -> 'a t list
|
||||
|
||||
val pp_hum : Format.formatter -> _ t -> unit [@@ocaml.toplevel_printer]
|
||||
Some files were not shown because too many files have changed in this diff Show more
Loading…
Add table
Add a link
Reference in a new issue