Codebase list ocaml-conduit / ab79be5
New upstream version 4.0.2 Stephane Glondu 2 years ago
87 changed file(s) with 5060 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+28
-0
.github/workflows/test.yml less more
0 name: Conduit
1 on: [push, pull_request]
2 jobs:
3 tests:
4 name: Tests
5 runs-on: ${{ matrix.operating-system }}
6 strategy:
7 matrix:
8 ocaml-version: [ '4.08.1', '4.09.0', '4.10.0', '4.11.1' ]
9 operating-system: [ ubuntu-latest ]
10 steps:
11 - uses: actions/checkout@v2
12 - uses: avsm/setup-ocaml@v1
13 with:
14 ocaml-version: ${{ matrix.ocaml-version }}
15 - name: Deps
16 run: |
17 opam pin add -n conduit.dev .
18 opam pin add -n conduit-lwt.dev .
19 opam pin add -n conduit-lwt-unix.dev .
20 opam pin add -n conduit-async.dev .
21 opam pin add -n conduit-mirage.dev .
22 opam depext -y conduit conduit-lwt conduit-lwt-unix conduit-async conduit-mirage
23 opam install --deps-only -t .
24 - name: Build
25 run: opam exec -- dune build
26 - name: Test
27 run: opam exec -- dune runtest --no-buffer --verbose -j 1
+5
-0
.gitignore less more
0 _build/
1 _opam
2 .*.swp
3 *.install
4 .merlin
+5
-0
.ocamlformat less more
0 version = 0.18.0
1 profile = conventional
2 break-infix = fit-or-vertical
3 parse-docstrings = true
4 module-item-spacing = compact
+352
-0
CHANGES.md less more
0 ## v4.0.2 (2021-10-09)
1
2 * Adapt conduit-mirage to tls 0.15.0 (@hannesm #404)
3 * Remove Conduit_mirage.Endpoint.ok_authenticator (@hannesm #404)
4 * Now Conduit_mirage.Endpoint.server does not use an authenticator - and thus
5 not request a client certificate (@hannesm #404)
6
7 ## v4.0.1 (2021-08-06)
8
9 * Add missing `ipaddr-sexp` dependency on conduit-async (#385, @anmonteiro)
10 * Update the link of the documentation (959f57a & #398, reported by @misterfish, @zshipko, @dinosaure)
11 * Gitignore `opam/` even if it is a symlink (#394, @CraigFe, @avsm)
12 * Adapt `conduit-lwt-unix` to `tls.0.14.0` (#396, @hannesm, @dinosaure)
13
14 ## v4.0.0 (2021-04-15)
15
16 * conduit-mirage: replace the alias `X509_lwt.priv` by
17 `Tls.Config.certchain` (@dinosaure, @samoht, #381)
18 * conduit-mirage: Upgrade to dns.5.0.0 and use `Mirage_stack.V4V6`
19 instead of `Mirage_stack.V4` - by this way, conduit-mirage supports
20 IPv6 connection
21 * conduit.3.0.0 will be unavailable with this release. The design
22 discussion did not reach consensus and `conduit.3.0.0` is unmaintained.
23 We advise use to use `conduit.2.*` or `conduit.4.*` then and discard
24 the migration process between `conduit.2.*` and `conduit.3.*`.
25
26 ## v2.3.0 (2020-02-06)
27
28 * conduit-mirage: simplify the API to not mix functors and first-class
29 modules anymore. We just use functors now and rely on the mirage tool
30 to apply them properly (#376, @samoht)
31 * add client-side TLS certificate validation using OS trust anchors for
32 `conduit-lwt-unix` and Mozilla's NSS for `conduit-mirage` (#375, @samoht)
33
34 ## v2.2.2 (2020-06-14)
35
36 * conduit-lwt-unix no longer calls Mirage_crypto_rng_unix.initialize, and is
37 compatible with tls 0.12.1 (#317 @hannesm)
38
39 ## v2.2.1 (2020-05-20)
40
41 * conduit-mirage requires mirage-time (fix opam and dune) (#315 @hannesm)
42
43 ## v2.2.0 (2020-05-12)
44
45 * conduit-mirage adapt to dns-client 4.5.0 (#314 @hannesm)
46
47 ## v2.1.0 (2020-03-14)
48
49 * port to tls.0.11.0 interfaces which also uses mirage-crypto (#309 @hannesm)
50 * do not use deprecated ppx sexplib declarations (#309 @avsm)
51 * replace Appveyor CI with GitHub Actions (#309 @avsm)
52
53 ## v2.0.2 (2019-11-02)
54
55 * mirage: do not raise exceptions in DNS lookup (#305 @hannesm)
56 * mirage: adapt to mirage-stack/mirage-time/mirage-flow/mirage-random 2.0.0 interfaces (#306 #hannesm)
57 * mirage: adapt to dns 4.1.0 changes (#306 @hannesm)
58 * mirage: adapt to vchan 5.0.0 changes (#306 @hannesm)
59
60 ## v2.0.1 (2019-08-19)
61
62 * lwt-unix: fix compilation with `lwt_ssl` and fix tests to correctly exercise this
63 part of the codepath (#304 @avsm).
64
65 ## v2.0.0 (2019-08-17)
66
67 * lwt-unix: obtain client IP correctly when using TLS connections (#277 @victorgomes)
68 * lwt-unix: replace the dune/ocaml file with a `(select)` build form.
69 This avoids invoking `ocamlfind` from the build, and fits in with the
70 rest of dune builds much more naturally (@avsm).
71 * lwt-unix: force callers to give a custom callback `on_exn` in case of exceptions
72 to avoid random crashes (#261 @kit-ty-kate)
73 * mirage: use `dns-client>=4.0.0` which is the `udns` implementation (#290 @hannesm)
74 * mirage: rename `mirage-conduit` to `conduit-mirage` to fit the naming structure
75 of this library suite more. All new users of Mirage should use `conduit-mirage`,
76 and migrating should involve simply swapping the name in your `dune` and `opam`
77 files (#302 @hannesm @avsm)
78 * async: expose `verify_mode` correctly in `Conduit_async` (#298 @brendanlong)
79
80 ## v1.5.0
81
82 * lwt-unix: Do not close file descriptors more than once, which led to a lot of
83 log spam due to EBADF (#294 @hcarty @avsm)
84 * lwt-unix: Always close channels after handling an event (#283 @hcarty)
85 * Allow TCP to be established from existing file descriptors
86 (for example, an inherited systemd socket) (#144 @SGrondin #282 @timbertson)
87 * async: add `Conduit_async.V3` which provides convenience functions for
88 resolving URIs to addresses (#287 @vbmithr)
89 * `Lwt_ssl`: Enable certification validation (#291 @vouillon)
90 * `Async_ssl`: fix exception raised when other side disconnects
91 due to sharing underlying fd (#295 @bogdan2412)
92
93 ## v1.4.0
94
95 * Use Ipaddr 3.0.0+ interfaces (#284 by @avsm).
96 * Update opam metadata files to the opam 2.0 format (#284 by @avsm)
97 * Hook in an introduction ocamldoc page to the `conduit` odoc (#284 by @avsm)
98
99 ## v1.3.0 (2018-10-19)
100
101 * Mark `ppx_sexp_conv` as not just a build dependency.
102 * Switch build to dune from jbuilder.
103 * Depend on more precise versions of `mirage-types` instead
104 of just the generic package.
105 * Fix ocamldoc headings to work with latest odoc (level 2 not 1).
106
107 ## v1.2.0 (2018-08-06)
108
109 * Correct depopt for conduit-lwt-unix (#260, @dra27)
110 * async: provide all `Async_ssl` options at config (#263, @vbmithr)
111 * async: add a V2 module for a new versioned API (#265, @rgrinberg)
112 * lwt-unix: do not link with tls.lwt on windows (#267, @samoht)
113
114 ## v1.1.0 (2018-03-22)
115
116 * Implement SNI (Server Name Indication) for SSL backend (#255 by @vouillon)
117 * Make hostname optional in `Conduit_lwt_unix_ssl.Client.connect` (#255 by @vouillon)
118 * Fix file descriptor leakage on `EADDRINUSE` for the Lwt backend (#257 by @rixed)
119
120 ## v1.0.3 (2018-01-06)
121
122 * Favour resolving over IPv4 instead of IPv6, if both are available
123 and one has to be chosen. (#245 via @rixed)
124 * Fix some warnings with the dummy `Lwt_unix_ssl` module.
125 * Add a direct dependency on xenstore for mirage-conduit.
126 * Support latest Async v0.10.0 interfaces (no more `Async.Std`).
127
128 ## v1.0.2 (2017-09-13)
129
130 * Fix regression with TLS/SSL backend: there is no need to set `CONDUIT_TLS`
131 manually when using tls (#234, @hcarty)
132 * Update to lwt.3.0.0 (#236, #241, @rgrinberg and @samoht)
133 * Fix regression in linking with the launchd backend (#240, @samoht)
134
135 ## v1.0.1 (2017-07-25)
136
137 * Fix linkage of mirage-conduit with apps, as a `tls.mirage` dependency
138 was missing in the mirage-conduit-3.0.0 release (#232 by @samoht)
139
140 ## v1.0.0 (2017-07-22)
141
142 Details on changes: https://discuss.ocaml.org/t/ann-major-releases-of-cohttp-conduit-dns-tcpip/571
143
144 Port build to jbuilder, and break up OPAM packages into multiple
145 independent packages instead of being optional dependencies against
146 the main `conduit` package. This makes it significantly easier to
147 depend on precisely the libraries you need, but requires porting
148 applications to use the new `ocamlfind` and `opam` scheme.
149
150 The new package layout is:
151
152 - `conduit`: the main `Conduit` module
153 - `conduit-lwt`: the portable Lwt implementation
154 - `conduit-lwt-unix`: the Lwt/Unix implementation
155 - `conduit-async` the Jane Street Async implementation
156 - `mirage-conduit`: the MirageOS compatible implementation
157
158 In each of these packages, the `opam` and `ocamlfind` package
159 names are now _the same_, so you will need to rename the former
160 subpackages such as `conduit.async` to `conduit-async`. The
161 implementation is otherwise the same, so no other code changes
162 should be required.
163
164 In return for these breaking changes to the packaging, it is
165 now significantly easier to depend on a particular backend,
166 also for us to rev the interfaces towards a stable 1.0 release.
167 Jbuilder also builds the source tree around 4x faster than it
168 did previously.
169
170 There are still some optional dependencies remaining, most
171 notably the `tls` and `ssl` packages. If they are present,
172 then conduit will be compiled with TLS support.
173
174 ## 0.15.4 (2017-05-31)
175 * Lwt: Fix meta file and building with lwt_ssl (#222, @dkim)
176
177 ## 0.15.3 (2017-05-04)
178 * Lwt: lwt 3.0 support for the tls backend too (#219, @@rgrinberg)
179
180 ## 0.15.2 (2017-05-02)
181 * Move cstruct dependency from conduit to mirage-conduit
182
183 ## 0.15.1 (2017-04-25)
184 * Lwt: Lwt 3.0 support (#214)
185 * Async: with_connection (#211)
186
187 ## 0.15.0 (2017-02-23)
188 * support MirageOS 3, and drop support for earlier versions (#203, #202)
189
190 ## 0.14.5 (2017-01-24)
191 * Fix exception swallowing (#206)
192
193 ## 0.14.4 (2017-01-03)
194 * Fix tests (#195)
195
196 ## 0.14.3 (2017-01-03)
197 * Fix mirage-conduit (@samoht, #188)
198 * Use ppx_driver's ocamlbuild plugin (@rgrinberg, #193)
199
200 ## 0.14.2 (2017-01-01)
201 * Fix discover.ml (#191)
202
203 ## 0.14.1 (2016-12-29)
204 * Tests: do not link with lwt.ssl if it is not installed (#186)
205
206 ## 0.14.0 (2016-12-25)
207 * Add listening backlog option and increase it to 128 by deafult (#151)
208 * Add IP based URI support
209 * Fix server stop issues for all Lwt servers
210 * Add Logs based logging to Lwt server errors (#172)
211 * Add on_exn hook to Lwt servers (#181)
212 * Limit maximum number of active connections (#116)
213
214 ## 0.13.0 (2016-09-18):
215 * Fix build system to stop compiling things twice (#137)
216 * Lwt: pass uncaught exceptions in server callback to async_exception_hook (#143)
217 * Lwt: stop printing stuff to stdout (#143)
218 * Async: fix swallowing of exceptions
219 * Async: add backlog argument to serve
220
221 ## 0.12.0 (2016-04-30):
222 * Convert build system to use PPX instead of Camlp4.
223 * Call `set_close_on_exec` on `Lwt_unix` listen sockets (#123)
224
225 ## 0.11.0 (2016-03-25):
226 * Minimum OCaml version is now 4.02.0
227 * Add multi-distro Travis testing script.
228 * Switch to using `pa_sexp_conv` for latest sexp.
229 * Support Core/Async >=113.24
230 * Fix `vchan` example code, and use functoria-style mirage
231 for it (#108 via @jonludlam)
232 * [async] Add an `Ssl_unsupported exception` for Async rather than
233 just raising `Failure`
234 * Workaround for infinite loop when failing to accept new connections
235 (Edwin Torok #115)
236 * Support TLSv1.1 and TLSv1.2 with openssl backend (Edwin Torok #115)
237 * Fix FD leak with the openssl backend (Edwin Torok #115)
238
239 ## 0.10.0 (2015-12-25):
240 * Add support for CA certificates in [Conduit_async.serve] (#98).
241 * Fix file descriptor leak in Lwt backend (#101 from @hannesm).
242 * Server in `Conduit_lwt_tls` waits for a user callback to finish
243 before accepting more connections. Instead, it should only wait
244 until the connection is accepted and detach client callback (#97).
245 * Close socket when `ssl_accept` fails, e.g. when cipher negotiation
246 mismatch (#104).
247
248 ## 0.9.0 (2015-10-14):
249 * Add a `Launchd` argument for the Conduit_lwt_unix server listener
250 to support the MacOSX service launcher (#96).
251
252 ## 0.8.8 (2015-09-15):
253 * Expose a new functor `Conduit_mirage.With_tcp` (#92, by @Drup)
254 * Expose a new functor: `Resolver_mirage.Make_with_stack` to build a DNS
255 resolver using an existing network stack (#92, by @Drup)
256 * Expose `Resolver_mirage.S`, the signature for Mirage's conduit resolvers than
257 can perform DNS lookups. These resolvers now expose their `DNS` implmentation
258 as a submodule (#92, by @Drup)
259 * Expose a ?version arg in Conduit_async_ssl.ssl_listen, default being TLS 1.2
260 (#94, by @vbmithr)
261
262 ## 0.8.7 (2015-08-18):
263 * Do not ignore custom context when calling `Conduit_lwt_unix_ssl.accept`
264 (reported by @jrb467 in #88)
265 * `Conduit_lwt_unix.Serve` now passes the client `flow` to the server
266 callback instead of the listening server one. This lets servers
267 retrieve the peer endpoint correctly (reported by @fxfactorial in #87)
268
269 ## 0.8.6 (2015-07-14)
270 * Add a `Conduit_mirage.Context`, a functor for creating HTTP(s) conduit
271 contexts (with a DNS resolver).
272
273 ## 0.8.5 (2015-07-12)
274 * Fix client-side `https://` resolution for `Conduit_mirage`
275
276 ## 0.8.4 (2015-05-29):
277 * Full support for `ocaml-tls.0.5.0`
278 * Breaking API change for mirage-conduit. Now all the flows are dynamic,
279 the functors are becoming first-class values so no big functor to build
280 first.
281
282 ## 0.8.3 (2015-05-04):
283 * Partial support for `ocaml-tls.0.5.0`
284 * setsockopt TCP_NODELAY fails on a Unix domain socket (#63 by @djs55)
285
286 ## 0.8.2 (2015-04-18):
287 * Make TLS optional in `Conduit_mirage`, and disable it by default
288 so that it is a developer-only option until it is properly released.
289 It can be enabled by setting the `HAVE_MIRAGE_LWT` env variable.
290
291 ## 0.8.1 (2015-04-17):
292 * Support Async_SSL version 112.24.00 and higher.
293 * Add a TLS echo server in `tests/async/`
294 * [lwt] Do not leak socket fd when a connect or handshake
295 operation fails (#56 via Edwin Torok).
296 * [async] Do not leak pipes in SSL handling (#54 from Trevor Smith).
297
298 ## 0.8.0 (2015-03-27):
299 * Add TLS client support for Mirage (#50)
300 * Do not overwrite the default name resolver for Mirage (#49)
301 * Add TLS support using the pure OCaml TLS stack (#46).
302 * Replace the Mirage `Make_flow` functor with `Dynamic_flow` that is
303 easier to extend with more flow types.
304
305 ## 0.7.2 (2015-01-26):
306 * Add an `error_message` function to simplify error display (#38).
307 * Improvements to documentation (#37).
308
309 ## 0.7.1 (2014-12-05):
310 * Do not emit debug output when the `CONDUIT_DEBUG` variable is not set.
311 * Do not create symlinks in a local build, which helps with OPAM pins.
312 * Improve ocamldoc for `Conduit_lwt_unix`.
313
314 ## 0.7.0 (2014-12-04):
315 * Add Lwt-unix support for the native OCaml/TLS stack as an alternative
316 to OpenSSL. This can be activated by setting the `CONDUIT_TLS` environment
317 variable to `native`. If this is not set and OpenSSL is available, then
318 OpenSSL is used by in preference to the pure OCaml implementation.
319 * Add sexp convertors for `Conduit_lwt_unix.ctx` and `Conduit_mirage.ctx`
320 and the `Resolver` service types.
321 * Fix the Mirage tests to the Mirage 2.0.1+ Conduit interfaces.
322 * Add more debugging output when the `CONDUIT_DEBUG` variable is set on Unix.
323 * *Interface breaking:* The `client` and `server` types in `Conduit_lwt_unix`
324 now explicitly label the fields of the tuples with a polymorphic variant.
325 This allows them to remain independent of this library but still be
326 more self-descriptive (i.e. `Port of int` instead of just `int`).
327
328 ## 0.6.1 (2014-11-07):
329 * When terminating conduits, always close the output channel first before
330 the input channel, so that any pending data in the underlying fd is flushed.
331
332 ## 0.6.0 (2014-11-04):
333 * Add an explicit `ctx` content to track every conduit's runtime state.
334 * Allow the source interface for a conduit to be set.
335 * Support a `password` callback for the SSL layer (#4).
336 * [lwt] Add stop parameters in main-loop of the server (#5).
337 * Add `Conduit_mirage` with Mirage functor suport.
338 * Add ocamldoc of most interfaces.
339 * Add a `CONDUIT_DEBUG` environment variable to the Unix backends for
340 live debugging.
341 * Add a `conn` value to the callback to query more information about the
342 current connection (#2).
343 * Expose the representation of `Conduit_lwt_unix.flow` in the external signature.
344 This lets library users obtain the original `Lwt_unix.file_descr` when using
345 Conduit libraries like Cohttp.
346
347 ## 0.5.1 (2014-08-07):
348 * Reenable Async SSL by default.
349
350 ## 0.5.0 (2014-04-13):
351 * First public release.
+17
-0
LICENSE.md less more
0 ## ISC License
1
2 Copyright (c) 2014-2018 The ocaml-conduit contributors
3
4 Permission to use, copy, modify, and/or distribute this software for
5 any purpose with or without fee is hereby granted, provided that the
6 above copyright notice and this permission notice appear in all
7 copies.
8
9 THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
10 WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
11 WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
12 AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
13 DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
14 PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
15 TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
16 PERFORMANCE OF THIS SOFTWARE.
+13
-0
Makefile less more
0 .PHONY: build clean test doc
1
2 build:
3 dune build
4
5 test:
6 dune runtest
7
8 clean:
9 dune clean
10
11 doc:
12 dune build @doc
+37
-0
README.md less more
0 ## conduit -- an OCaml network connection establishment library
1
2 [![Build Status](https://travis-ci.org/mirage/ocaml-conduit.svg?branch=master)](https://travis-ci.org/mirage/ocaml-conduit)
3
4 The `conduit` library takes care of establishing and listening for
5 TCP and SSL/TLS connections for the Lwt and Async libraries.
6
7 The reason this library exists is to provide a degree of abstraction
8 from the precise SSL library used, since there are a variety of ways
9 to bind to a library (e.g. the C FFI, or the Ctypes library), as well
10 as well as which library is used (just OpenSSL for now).
11
12 By default, OpenSSL is used as the preferred connection library, but
13 you can force the use of the pure OCaml TLS stack by setting the
14 environment variable `CONDUIT_TLS=native` when starting your program.
15
16 The opam packages available are:
17
18 - `conduit`: the main `Conduit` module
19 - `conduit-lwt`: the portable Lwt implementation
20 - `conduit-lwt-unix`: the Lwt/Unix implementation
21 - `conduit-async` the Jane Street Async implementation
22 - `conduit-mirage`: the MirageOS compatible implementation
23
24 ### Debugging
25
26 Some of the `Lwt_unix`-based modules use a non-empty `CONDUIT_DEBUG`
27 environment variable to output debugging information to standard error.
28 Just set this variable when running the program to see what URIs
29 are being resolved to.
30
31 ### Further Informartion
32
33 * **API Docs:** https://mirage.github.io/ocaml-conduit/
34 * **WWW:** https://github.com/mirage/ocaml-conduit
35 * **E-mail:** <mirageos-devel@lists.xenproject.org>
36 * **Bugs:** https://github.com/mirage/ocaml-conduit/issues
+33
-0
conduit-async.opam less more
0 version: "4.0.2"
1 opam-version: "2.0"
2 maintainer: "anil@recoil.org"
3 authors: [
4 "Anil Madhavapeddy" "Thomas Leonard" "Thomas Gazagnaire" "Rudi Grinberg"
5 ]
6 license: "ISC"
7 tags: "org:mirage"
8 homepage: "https://github.com/mirage/ocaml-conduit"
9 bug-reports: "https://github.com/mirage/ocaml-conduit/issues"
10 depends: [
11 "ocaml" {>= "4.03.0"}
12 "dune"
13 "core"
14 "uri" {>= "4.0.0"}
15 "ppx_here" {>= "v0.9.0"}
16 "ppx_sexp_conv" {>="v0.13.0"}
17 "sexplib"
18 "conduit" {=version}
19 "async" {>= "v0.10.0"}
20 "ipaddr" {>= "3.0.0"}
21 "ipaddr-sexp" {>= "4.0.0"}
22 ]
23 depopts: ["async_ssl"]
24 conflicts: [
25 "async_ssl" {< "v0.9.0"}
26 ]
27 build: [
28 ["dune" "subst"] {pinned}
29 ["dune" "build" "-p" name "-j" jobs]
30 ]
31 dev-repo: "git+https://github.com/mirage/ocaml-conduit.git"
32 synopsis: "A network connection establishment library for Async"⏎
+37
-0
conduit-lwt-unix.opam less more
0 version: "4.0.2"
1 opam-version: "2.0"
2 maintainer: "anil@recoil.org"
3 authors: [
4 "Anil Madhavapeddy" "Thomas Leonard" "Thomas Gazagnaire" "Rudi Grinberg"
5 ]
6 license: "ISC"
7 tags: "org:mirage"
8 homepage: "https://github.com/mirage/ocaml-conduit"
9 bug-reports: "https://github.com/mirage/ocaml-conduit/issues"
10 depends: [
11 "ocaml" {>= "4.07.0"}
12 "dune"
13 "base-unix"
14 "logs"
15 "ppx_sexp_conv" {>="v0.13.0"}
16 "conduit-lwt" {=version}
17 "lwt" {>= "3.0.0"}
18 "uri" {>= "1.9.4"}
19 "ipaddr" {>= "4.0.0"}
20 "ipaddr-sexp"
21 "ca-certs"
22 "lwt_log" {with-test}
23 "ssl" {with-test}
24 "lwt_ssl" {with-test}
25 ]
26 depopts: ["tls" "lwt_ssl" "launchd"]
27 conflicts: [
28 "tls" {< "0.14.0"}
29 "ssl" {< "0.5.9"}
30 ]
31 build: [
32 ["dune" "subst"] {pinned}
33 ["dune" "build" "-p" name "-j" jobs]
34 ]
35 dev-repo: "git+https://github.com/mirage/ocaml-conduit.git"
36 synopsis: "A network connection establishment library for Lwt_unix"⏎
+25
-0
conduit-lwt.opam less more
0 version: "4.0.2"
1 opam-version: "2.0"
2 maintainer: "anil@recoil.org"
3 authors: [
4 "Anil Madhavapeddy" "Thomas Leonard" "Thomas Gazagnaire" "Rudi Grinberg"
5 ]
6 license: "ISC"
7 tags: "org:mirage"
8 homepage: "https://github.com/mirage/ocaml-conduit"
9 bug-reports: "https://github.com/mirage/ocaml-conduit/issues"
10 depends: [
11 "ocaml" {>= "4.03.0"}
12 "dune"
13 "base-unix"
14 "ppx_sexp_conv" {>="v0.13.0"}
15 "sexplib"
16 "conduit" {=version}
17 "lwt" {>= "3.0.0"}
18 ]
19 build: [
20 ["dune" "subst"] {pinned}
21 ["dune" "build" "-p" name "-j" jobs]
22 ]
23 dev-repo: "git+https://github.com/mirage/ocaml-conduit.git"
24 synopsis: "A portable network connection establishment library using Lwt"⏎
+43
-0
conduit-mirage.opam less more
0 version: "4.0.2"
1 opam-version: "2.0"
2 maintainer: "anil@recoil.org"
3 authors: ["Anil Madhavapeddy" "Thomas Leonard" "Thomas Gazagnaire"]
4 license: "ISC"
5 tags: "org:mirage"
6 homepage: "https://github.com/mirage/ocaml-conduit"
7 bug-reports: "https://github.com/mirage/ocaml-conduit/issues"
8 depends: [
9 "ocaml" {>= "4.07.0"}
10 "dune"
11 "ppx_sexp_conv" {>="v0.13.0"}
12 "sexplib"
13 "uri" {>= "4.0.0"}
14 "cstruct" {>= "3.0.0"}
15 "mirage-stack" {>= "2.2.0"}
16 "mirage-clock" {>= "3.0.0"}
17 "mirage-flow" {>= "2.0.0"}
18 "mirage-flow-combinators" {>= "2.0.0"}
19 "mirage-random" {>= "2.0.0"}
20 "mirage-time" {>= "2.0.0"}
21 "dns-client" {>= "5.0.0"}
22 "conduit-lwt" {=version}
23 "vchan" {>= "5.0.0"}
24 "xenstore"
25 "tls" {>= "0.11.0"}
26 "tls-mirage" {>= "0.11.0"}
27 "ca-certs-nss"
28 "ipaddr" {>= "3.0.0"}
29 "ipaddr-sexp"
30 "tcpip" {with-test}
31 ]
32 conflicts: [
33 "mirage-conduit"
34 ]
35
36 build: [
37 ["dune" "subst"] {pinned}
38 ["dune" "build" "-p" name "-j" jobs]
39 ["dune" "runtest" "-p" name] {with-test}
40 ]
41 dev-repo: "git+https://github.com/mirage/ocaml-conduit.git"
42 synopsis: "A network connection establishment library for MirageOS"⏎
+49
-0
conduit.opam less more
0 version: "4.0.2"
1 opam-version: "2.0"
2 maintainer: "anil@recoil.org"
3 authors: [
4 "Anil Madhavapeddy" "Thomas Leonard" "Thomas Gazagnaire" "Rudi Grinberg"
5 ]
6 license: "ISC"
7 tags: "org:mirage"
8 homepage: "https://github.com/mirage/ocaml-conduit"
9 doc: "https://mirage.github.io/ocaml-conduit/"
10 bug-reports: "https://github.com/mirage/ocaml-conduit/issues"
11 depends: [
12 "ocaml" {>= "4.03.0"}
13 "dune"
14 "ppx_sexp_conv" {>="v0.13.0"}
15 "sexplib"
16 "astring"
17 "uri"
18 "logs" {>= "0.5.0"}
19 "ipaddr" {>= "4.0.0"}
20 "ipaddr-sexp"
21 ]
22 build: [
23 ["dune" "subst"] {pinned}
24 ["dune" "build" "-p" name "-j" jobs]
25 ]
26 dev-repo: "git+https://github.com/mirage/ocaml-conduit.git"
27 synopsis: "A network connection establishment library"
28 description: """
29 The `conduit` library takes care of establishing and listening for
30 TCP and SSL/TLS connections for the Lwt and Async libraries.
31
32 The reason this library exists is to provide a degree of abstraction
33 from the precise SSL library used, since there are a variety of ways
34 to bind to a library (e.g. the C FFI, or the Ctypes library), as well
35 as well as which library is used (just OpenSSL for now).
36
37 By default, OpenSSL is used as the preferred connection library, but
38 you can force the use of the pure OCaml TLS stack by setting the
39 environment variable `CONDUIT_TLS=native` when starting your program.
40
41 The useful opam packages available that extend this library are:
42
43 - `conduit`: the main `Conduit` module
44 - `conduit-lwt`: the portable Lwt implementation
45 - `conduit-lwt-unix`: the Lwt/Unix implementation
46 - `conduit-async` the Jane Street Async implementation
47 - `conduit-mirage`: the MirageOS compatible implementation
48 """⏎
+3
-0
dune-project less more
0 (lang dune 2.0)
1 (name conduit)
2 (version v4.0.2)
+6
-0
scripts/xenstore-conduit-init less more
0 #!/bin/sh -e
1
2 echo Setting up a /conduit path in Xenstore
3 xenstore-rm /conduit
4 xenstore-write /conduit ""
5 xenstore-chmod /conduit b0
+36
-0
src/conduit/conduit.ml less more
0 (*
1 * Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 open Sexplib.Std
18
19 type endp =
20 [ `TCP of Ipaddr_sexp.t * int (** ipaddr and dst port *)
21 | `Unix_domain_socket of string (** unix file path *)
22 | `Vchan_direct of int * string (** domain id, port *)
23 | `Vchan_domain_socket of string * string
24 | `TLS of string * endp (** wrap in a TLS channel, [hostname,endp] *)
25 | `Unknown of string (** failed resolution *) ]
26 [@@deriving sexp]
27 (** The resolver will return an [endp], which the Conduit backend must interpret
28 to make a connection. *)
29
30 module type IO = sig
31 type +'a t
32
33 val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
34 val return : 'a -> 'a t
35 end
+66
-0
src/conduit/conduit.mli less more
0 (*
1 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 (** Interface for establishing reliable stream-oriented connections.
18
19 This library abstracts the concerns of establishing connections to peers
20 that may be running within the same host (e.g. in another virtual machine)
21 or on a remote host via TCP. It consists of one library that is responsible
22 for {{!transport} establishing individual connections}, and a {{!resolution}
23 name resolver} that maps URIs to endpoints.
24
25 {2:transport Connection Establishment}
26
27 Connections are created by identifying remote nodes using an {{!endp} endp}
28 value. To ensure portability, the {!endp} values are translated into
29 concrete connections by separate modules that target [Lwt_unix], [Async] and
30 [Mirage]. This lets those backends use the appropriate local technique for
31 creating the connection (such as using OpenSSL on Unix, or a pure OCaml
32 TLS+TCP implementation on Mirage, or some other combination).
33
34 The modules dealing with connection establishment are:
35
36 {!modules:Conduit_lwt_unix Conduit_async Conduit_mirage}
37
38 {2:resolution Name Resolution}
39
40 This deals with resolving URIs into a list of {!endp} addresses that can
41 then be connected to by the {{!transport} connection establishment} modules.
42
43 All of the name resolvers conform to the {!RESOLVER} module type. The
44 OS-specific implementations of this interface are:
45
46 {!modules:Resolver_lwt Resolver_lwt_unix Resolver_mirage} *)
47
48 type endp =
49 [ `TCP of Ipaddr.t * int (** IP address and destination port *)
50 | `Unix_domain_socket of string (** Unix domain file path *)
51 | `Vchan_direct of int * string (** domain id, port *)
52 | `Vchan_domain_socket of string * string (** Vchan Xen domain socket *)
53 | `TLS of string * endp (** Wrap in a TLS channel, [hostname,endp] *)
54 | `Unknown of string (** Failed resolution *) ]
55 [@@deriving sexp]
56 (** End points that can potentially be connected to. These are typically
57 returned by a call to a {{!resolution} resolver}. *)
58
59 (** Module type for cooperative threading that can be satisfied by Lwt or Async *)
60 module type IO = sig
61 type +'a t
62
63 val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
64 val return : 'a -> 'a t
65 end
+95
-0
src/conduit/conduit_trie.ml less more
0 (*
1 * Copyright (c) 2007-2014 Dave Scott <dave.scott@citrix.com>
2 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *
16 *)
17
18 open Sexplib.Std
19
20 type 'a t = Node of string * 'a option * 'a t list [@@deriving sexp]
21
22 (* Invariant: the only node with an empty string is the root *)
23 let empty = Node ("", None, [])
24
25 let is_prefix a b =
26 String.length b >= String.length a && String.sub b 0 (String.length a) = a
27
28 let common_prefix a b =
29 let j = ref 0 in
30 (* length of common prefix *)
31 let skip = ref false in
32 for i = 0 to min (String.length a) (String.length b) - 1 do
33 if not !skip then if a.[i] = b.[i] then incr j else skip := true
34 done;
35 String.sub a 0 !j
36
37 let sub b a =
38 let length = String.length b - String.length a in
39 String.sub b (String.length b - length) length
40
41 let string = function Node (s, _, _) -> s
42
43 (* Relying on the invariant that only the root node has an empty string, it is
44 safe to examine the first characters of the child strings. Moreover since
45 common prefixes are always represented as shared nodes, there can be at most
46 one child with the same initial character as the key we're looking up. *)
47 let choose remaining ns =
48 match List.partition (fun x -> (string x).[0] = remaining.[0]) ns with
49 | [ n ], rest -> Some (n, rest)
50 | [], _ -> None
51 | _ :: _, _ -> assert false
52
53 let rec insert k v = function
54 (* k could be equal to s *)
55 | Node (s, None, ns) when k = s -> Node (s, Some v, ns)
56 (* k could be a prefix of s *)
57 | Node (s, v', ns) when is_prefix k s ->
58 assert (sub s k <> "");
59 Node (k, Some v, [ Node (sub s k, v', ns) ])
60 (* s could be a prefix of k *)
61 | Node (s, v', ns) when is_prefix s k -> (
62 let remaining = sub k s in
63 assert (remaining <> "");
64 match choose remaining ns with
65 | Some (n, rest) -> Node (s, v', insert remaining v n :: rest)
66 | None -> Node (s, v', Node (remaining, Some v, []) :: ns))
67 (* s and k could share a non-empty common prefix *)
68 | Node (s, v', ns) ->
69 let p = common_prefix s k in
70 let s' = sub s p and k' = sub k p in
71 assert (s' <> "");
72 assert (k' <> "");
73 Node (p, None, [ Node (s', v', ns); Node (k', Some v, []) ])
74
75 let rec fold_over_path f str acc = function
76 | Node (p, v, _) when p = str -> f acc v
77 | Node (p, v, ns) when is_prefix p str -> (
78 let remaining = sub str p in
79 match choose remaining ns with
80 | Some (n, _) -> fold_over_path f remaining (f acc v) n
81 | None -> f acc v)
82 | _ -> acc
83
84 let longest_prefix str t =
85 fold_over_path (fun acc b -> if b = None then acc else b) str None t
86
87 let fold f acc t =
88 let rec inner p acc = function
89 | Node (p', v, ns) ->
90 let pp = p ^ p' in
91 let acc = match v with Some v -> f pp v acc | None -> acc in
92 List.fold_left (fun acc n -> inner pp acc n) acc ns
93 in
94 inner "" acc t
+38
-0
src/conduit/conduit_trie.mli less more
0 (*
1 * Copyright (c) 2007-2014 Dave Scott <dave.scott@citrix.com>
2 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *
16 *)
17
18 (** Radix tree that can do longest-prefix searches on string keys *)
19
20 type 'a t [@@deriving sexp]
21 (** Radix tree that maps [string] keys to ['a] values *)
22
23 val empty : 'a t
24 (** An empty tree *)
25
26 val insert : string -> 'a -> 'a t -> 'a t
27 (** [insert key value tree] returns a new tree with the mapping [key] to [value] *)
28
29 val longest_prefix : string -> 'a t -> 'a option
30 (** [longest_prefix key tree] finds the key [k] which shares the longest prefix
31 with [key] and returns the associated value. *)
32
33 val fold : (string -> 'a -> 'b -> 'b) -> 'b -> 'a t -> 'b
34 (** [fold f initial t] folds [f] over all bindings in [t] *)
35
36 val is_prefix : string -> string -> bool
37 (** [is_prefix a b] returns true if [a] is a prefix of [b] *)
+11
-0
src/conduit/dune less more
0 (library
1 (name conduit)
2 (public_name conduit)
3 (wrapped false)
4 (preprocess
5 (pps ppx_sexp_conv))
6 (modules conduit conduit_trie resolver)
7 (libraries sexplib ipaddr ipaddr-sexp uri astring))
8
9 (documentation
10 (package conduit))
+43
-0
src/conduit/index.mld less more
0 {1 Introduction}
1
2 The {!Conduit} library abstracts the concerns of establishing connections to
3 peers that may be running within the same host (e.g. in another virtual
4 machine) or on a remote host via TCP. It consists of:
5
6 - The {!Conduit} module with basic type definitions for endpoints
7 - OS-specific modules for {{!transport}establishing individual connections}
8 - The {!Resolver} module for mapping URIs to endpoints
9 - OS-specific {{!resolution}name resolvers} that use available
10 resolution mechanisms
11
12 {2:transport Connection Establishment}
13
14 Connections are created by identifying remote nodes using an
15 {{!Conduit.endp}endp} value. To ensure portability, the
16 {{!Conduit.endp}endpoints} are translated into concrete connections by separate
17 modules that target [Lwt_unix], [Async] and [Mirage]. This lets those backends
18 use the appropriate local technique for creating the connection (such as using
19 OpenSSL on Unix, or a pure OCaml TLS+TCP implementation on Mirage, or some
20 other combination).
21
22 The modules dealing with connection establishment are:
23 {!modules: Conduit_lwt_unix Conduit_async Conduit_mirage}
24
25 {2:resolution Name Resolution}
26
27 This deals with resolving URIs into a list of {{!Conduit.endp}endp}
28 addresses that can
29 then be connected to by the {{!transport}connection establishment} modules.
30
31 All of the name resolvers conform to the {!Resolver.S} module type.
32 The OS-specific implementations of this interface are:
33 {!modules: Resolver_lwt Resolver_lwt_unix Resolver_mirage}
34
35 {2:resolution Mirage Connections}
36
37 On Mirage, the networking stack is configured via the application
38 of functors to satisfy various signatures. Some of the available
39 functors are:
40 {!modules: Conduit_xenstore Conduit_localhost}
41
42 {!indexlist}
+151
-0
src/conduit/resolver.ml less more
0 (*
1 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 open Sexplib.Std
18 open Astring
19
20 type service = { name : string; port : int; tls : bool } [@@deriving sexp]
21
22 (** Module type for a {{!resolution} resolver} that can map URIs to concrete
23 {{!Conduit.endp} endpoints} that stream connections can be established with. *)
24 module type S = sig
25 type +'a io
26 (** Abstract type of the cooperative threading library used, normally defined
27 via the {!IO} module type *)
28
29 type t [@@deriving sexp]
30 (** State handle for a running resolver *)
31
32 type svc [@@deriving sexp]
33 (** Abstract type for a service entry, which maps a URI scheme into a protocol
34 handler and TCP port *)
35
36 type rewrite_fn = svc -> Uri.t -> Conduit.endp io
37 (** A rewrite function resolves a {{!svc} service} and a URI into a concrete
38 endpoint. *)
39
40 type service_fn = string -> svc option io
41 (** A service function maps the string (such as [http] or [ftp]) from a URI
42 scheme into a {{!svc} service} description that includes enough metadata
43 about the service to subsequently {{!rewrite_fn} resolve} it into an
44 {{!Conduit.endp} endpoint}. *)
45
46 val ( ++ ) : service_fn -> service_fn -> service_fn
47
48 val init :
49 ?service:service_fn -> ?rewrites:(string * rewrite_fn) list -> unit -> t
50 (** [init ?service ?rewrites] will initialize the resolver and return a state
51 handler. The {{!service_fn} service} argument should contain the
52 system-specific resolution mechanism for URI schemas.
53
54 The [rewrites] argument can optionally override a subset of the URI domain
55 name with the given {!rewrite_fn} to permit custom resolution rules. For
56 example, a rewrite rule for ".xen" would let the rewrite function resolve
57 hostnames such as "foo.xen" into a shared memory channel for the "foo"
58 virtual machine. *)
59
60 val add_rewrite : host:string -> f:rewrite_fn -> t -> unit
61 (** [add_rewrite ~host f t] will add to the [t] resolver the [f] rewrite rule
62 for all the domain names that shortest-prefix match [host] *)
63
64 val set_service : f:service_fn -> t -> unit
65 val service : t -> service_fn
66
67 val resolve_uri :
68 ?rewrites:(string * rewrite_fn) list -> uri:Uri.t -> t -> Conduit.endp io
69 (** [resolve_uri ?rewrites ~uri t] will use [t] to resolve the [uri] into a
70 concrete endpoint. Any [rewrites] that are passed in will be overlayed on
71 the existing rules within the [t] resolver, but not otherwise modify it. *)
72 end
73
74 module Make (IO : Conduit.IO) = struct
75 open IO
76
77 type svc = service [@@deriving sexp]
78 type 'a io = 'a IO.t
79
80 type rewrite_fn = service -> Uri.t -> Conduit.endp IO.t [@@deriving sexp]
81 (** A rewrite modifies an input URI with more specialization towards a
82 concrete [endp] *)
83
84 type service_fn = string -> service option IO.t [@@deriving sexp]
85
86 type t = {
87 default_lookup : rewrite_fn;
88 mutable domains : rewrite_fn Conduit_trie.t;
89 mutable service : service_fn;
90 }
91 [@@deriving sexp]
92
93 let default_lookup _ uri =
94 (* TODO log *)
95 let host = match Uri.host uri with None -> "" | Some host -> host in
96 return (`Unknown host)
97
98 let default_service _name =
99 (* TODO log *)
100 return None
101
102 let host_to_domain_list host =
103 (* TODO: slow, specialise the Trie to be a rev string list instead *)
104 String.concat ~sep:"." (List.rev (String.cuts ~sep:"." host))
105
106 let add_rewrite ~host ~f t =
107 t.domains <- Conduit_trie.insert (host_to_domain_list host) f t.domains
108
109 let set_service ~f t = t.service <- f
110 let service t = t.service
111 let ( ++ ) f g h = f h >>= function None -> g h | x -> return x
112
113 let init ?(service = default_service) ?(rewrites = []) () =
114 let domains = Conduit_trie.empty in
115 let t = { domains; default_lookup; service } in
116 List.iter (fun (host, f) -> add_rewrite ~host ~f t) rewrites;
117 t
118
119 let resolve_uri ?rewrites ~uri t =
120 (* Find the service associated with the URI *)
121 match Uri.scheme uri with
122 | None -> return (`Unknown "no scheme")
123 | Some scheme -> (
124 t.service scheme >>= function
125 | None -> return (`Unknown "unknown scheme")
126 | Some service ->
127 let host =
128 match Uri.host uri with None -> "localhost" | Some host -> host
129 in
130 let trie =
131 (* If there are local rewrites, add them to the trie *)
132 match rewrites with
133 | None -> t.domains
134 | Some rewrites ->
135 List.fold_left
136 (fun acc (host, f) ->
137 Conduit_trie.insert (host_to_domain_list host) f acc)
138 t.domains rewrites
139 in
140 (* Find the longest prefix function that matches this host *)
141 let fn =
142 match
143 Conduit_trie.longest_prefix (host_to_domain_list host) trie
144 with
145 | None -> t.default_lookup
146 | Some fn -> fn
147 in
148 fn service uri >>= fun endp ->
149 if service.tls then return (`TLS (host, endp)) else return endp)
150 end
+84
-0
src/conduit/resolver.mli less more
0 (*
1 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 (** Resolve URIs to endpoints *)
18
19 type service = { name : string; port : int; tls : bool } [@@deriving sexp]
20 (** Description of a single service. Can be populated from [/etc/services] with
21 the exception of the [tls] field, which indicates if the connection is
22 intended to be TLS/SSL-encrypted or not (e.g. for [https]). *)
23
24 (** Module type for a {{!resolution} resolver} that can map URIs to concrete
25 {{!endp} endpoints} that stream connections can be established with. *)
26 module type S = sig
27 type +'a io
28 (** Abstract type of the cooperative threading library used, normally defined
29 via the {!IO} module type *)
30
31 type t [@@deriving sexp]
32 (** State handle for a running resolver *)
33
34 type svc [@@deriving sexp]
35 (** Abstract type for a service entry, which maps a URI scheme into a protocol
36 handler and TCP port *)
37
38 type rewrite_fn = svc -> Uri.t -> Conduit.endp io
39 (** A rewrite function resolves a {{!svc} service} and a URI into a concrete
40 endpoint. *)
41
42 type service_fn = string -> svc option io
43 (** A service function maps the string (such as [http] or [ftp]) from a URI
44 scheme into a {{!svc} service} description that includes enough metadata
45 about the service to subsequently {{!rewrite_fn} resolve} it into an
46 {{!endp} endpoint}. *)
47
48 val ( ++ ) : service_fn -> service_fn -> service_fn
49 (** [f ++ g] is the composition of the service functions [f] and [g]. *)
50
51 val init :
52 ?service:service_fn -> ?rewrites:(string * rewrite_fn) list -> unit -> t
53 (** [init ?service ?rewrites] will initialize the resolver and return a state
54 handler. The {{!service_fn} service} argument should contain the
55 system-specific resolution mechanism for URI schemas.
56
57 The [rewrites] argument can optionally override a subset of the URI domain
58 name with the given {!rewrite_fn} to permit custom resolution rules. For
59 example, a rewrite rule for ".xen" would let the rewrite function resolve
60 hostnames such as "foo.xen" into a shared memory channel for the "foo"
61 virtual machine. *)
62
63 val add_rewrite : host:string -> f:rewrite_fn -> t -> unit
64 (** [add_rewrite ~host f t] will add to the [t] resolver the [f] rewrite rule
65 for all the domain names that shortest-prefix match [host] *)
66
67 val set_service : f:service_fn -> t -> unit
68
69 val service : t -> service_fn
70 (** [service t] is the function which is called when trying to resolve a
71 hostname with [t]. *)
72
73 val resolve_uri :
74 ?rewrites:(string * rewrite_fn) list -> uri:Uri.t -> t -> Conduit.endp io
75 (** [resolve_uri ?rewrites ~uri t] will use [t] to resolve the [uri] into a
76 concrete endpoint. Any [rewrites] that are passed in will be overlayed on
77 the existing rules within the [t] resolver, but not otherwise modify it. *)
78 end
79
80 (** Functor to construct a concrete resolver using a {!Conduit.IO}
81 implementation, usually via either Lwt or Async *)
82 module Make (IO : Conduit.IO) :
83 S with type svc = service and type 'a io = 'a IO.t
+24
-0
src/conduit-async/conduit_async.ml less more
0 (*
1 * Copyright (c) 2012-2017 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 module V1 = V1
18 module V2 = V2
19 module V3 = V3
20
21 [@@@deprecated "Use Conduit_async.V1"]
22
23 include V1.Conduit_async
+32
-0
src/conduit-async/dune less more
0 (library
1 (name conduit_async)
2 (public_name conduit-async)
3 (modules conduit_async private_ssl v1 v2 v3 s)
4 (preprocess
5 (pps ppx_here ppx_sexp_conv))
6 (libraries
7 conduit
8 async
9 ipaddr-sexp
10 ipaddr.unix
11 uri.services
12 (select
13 private_ssl.ml
14 from
15 (async_ssl -> private_ssl.real.ml)
16 (!async_ssl -> private_ssl.dummy.ml))
17 (select
18 v1.mli
19 from
20 (async_ssl -> v1.real.mli)
21 (!async_ssl -> v1.dummy.mli))
22 (select
23 v2.mli
24 from
25 (async_ssl -> v2.real.mli)
26 (!async_ssl -> v2.dummy.mli))
27 (select
28 v3.mli
29 from
30 (async_ssl -> v3.real.mli)
31 (!async_ssl -> v3.dummy.mli))))
+54
-0
src/conduit-async/private_ssl.dummy.ml less more
0 open Core
1
2 module V1 = struct
3 module Ssl = struct
4 module Config = struct
5 type t = [ `Ssl_not_compiled_in ] [@@deriving sexp]
6
7 let verify_certificate _ =
8 failwith "Ssl not available, recompile with Async_ssl"
9
10 let create ?version:_ ?name:_ ?ca_file:_ ?ca_path:_ ?session:_ ?verify:_
11 () =
12 failwith "Ssl not available, recompile with Async_ssl"
13 end
14
15 let connect _cfg _r _w =
16 failwith "Ssl not available, recompile with Async_ssl"
17
18 let listen ?version:_ ?ca_file:_ ?ca_path:_ ~crt_file:_ ~key_file:_ _ _ =
19 failwith "Ssl not available, recompile with Async_ssl"
20
21 type session = [ `Ssl_not_compiled_in ] [@@deriving sexp]
22 type version = [ `Ssl_not_compiled_in ] [@@deriving sexp]
23 type connection = [ `Ssl_not_compiled_in ] [@@deriving sexp]
24 end
25 end
26
27 module V2 = struct
28 module Ssl = struct
29 module Config = struct
30 type t = [ `Ssl_not_compiled_in ] [@@deriving sexp]
31
32 let verify_certificate _ =
33 failwith "Ssl not available, recompile with Async_ssl"
34
35 let create ?version:_ ?options:_ ?name:_ ?hostname:_ ?allowed_ciphers:_
36 ?ca_file:_ ?ca_path:_ ?crt_file:_ ?key_file:_ ?session:_
37 ?verify_modes:_ ?verify:_ () =
38 failwith "Ssl not available, recompile with Async_ssl"
39 end
40
41 let connect ?cfg:_ _r _w =
42 failwith "Ssl not available, recompile with Async_ssl"
43
44 let listen _ _r _w = failwith "Ssl not available, recompile with Async_ssl"
45
46 type version = [ `Ssl_not_compiled_in ] [@@deriving sexp]
47 type session = [ `Ssl_not_compiled_in ] [@@deriving sexp]
48 type verify = [ `Ssl_not_compiled_in ] [@@deriving sexp]
49 type connection = [ `Ssl_not_compiled_in ] [@@deriving sexp]
50 type verify_mode = [ `Ssl_not_compiled_in ] [@@deriving sexp]
51 type opt = [ `Ssl_not_compiled_in ] [@@deriving sexp]
52 end
53 end
+232
-0
src/conduit-async/private_ssl.real.ml less more
0 open Core
1 open Async
2 open Async_ssl
3
4 let verify_certificate connection =
5 match Ssl.Connection.peer_certificate connection with
6 | None -> return false
7 | Some (Error _) -> return false
8 | Some (Ok _) -> return true
9
10 let teardown_connection r w =
11 Writer.close ~force_close:(Clock.after (sec 30.)) w >>= fun () ->
12 Reader.close r
13
14 (* One needs to be careful around Async Readers and Writers that share the same underyling
15 file descriptor, which is something that happens when they're used for sockets.
16
17 Closing the Reader before the Writer will cause the Writer to throw and complain about
18 its underlying file descriptor being closed. This is why instead of using Reader.pipe
19 directly below, we write out an equivalent version which will first close the Writer
20 before closing the Reader once the input pipe is fully consumed.
21
22 Additionally, [Writer.pipe] will not close the writer if the pipe is closed, so in
23 order to avoid leaking file descriptors, we allow the pipe 30 seconds to flush before
24 closing the writer. *)
25 let reader_writer_pipes r w =
26 let reader_pipe_r, reader_pipe_w = Pipe.create () in
27 let writer_pipe = Writer.pipe w in
28 upon (Reader.transfer r reader_pipe_w) (fun () ->
29 teardown_connection r w >>> fun () -> Pipe.close reader_pipe_w);
30 upon (Pipe.closed writer_pipe) (fun () ->
31 Deferred.choose
32 [
33 Deferred.choice (Clock.after (sec 30.)) (fun () -> ());
34 Deferred.choice (Pipe.downstream_flushed writer_pipe)
35 (fun (_ : Pipe.Flushed_result.t) -> ());
36 ]
37 >>> fun () -> don't_wait_for (teardown_connection r w));
38 (reader_pipe_r, writer_pipe)
39
40 (* [Reader.of_pipe] will not close the pipe when the returned [Reader] is closed, so we
41 manually do that ourselves.
42
43 [Writer.of_pipe] will create a writer that will raise once the pipe is closed, so we
44 set [raise_when_consumer_leaves] to false. *)
45 let reader_writer_of_pipes app_rd app_wr =
46 Reader.of_pipe (Info.of_string "async_conduit_ssl_reader") app_rd
47 >>= fun app_reader ->
48 upon (Reader.close_finished app_reader) (fun () -> Pipe.close_read app_rd);
49 Writer.of_pipe (Info.of_string "async_conduit_ssl_writer") app_wr
50 >>| fun (app_writer, _) ->
51 Writer.set_raise_when_consumer_leaves app_writer false;
52 (app_reader, app_writer)
53
54 module V1 = struct
55 module Ssl = struct
56 module Config = struct
57 type t = {
58 version : Ssl.Version.t option;
59 name : string option;
60 ca_file : string option;
61 ca_path : string option;
62 session : (Ssl.Session.t[@sexp.opaque]) option;
63 verify : (Ssl.Connection.t -> bool Deferred.t) option;
64 }
65 [@@deriving sexp]
66
67 let verify_certificate = verify_certificate
68
69 let create ?version ?name ?ca_file ?ca_path ?session ?verify () =
70 { version; name; ca_file; ca_path; session; verify }
71 end
72
73 let connect cfg r w =
74 let { Config.version; name; ca_file; ca_path; session; verify } = cfg in
75 let net_to_ssl, ssl_to_net = reader_writer_pipes r w in
76 let app_to_ssl, app_wr = Pipe.create () in
77 let app_rd, ssl_to_app = Pipe.create () in
78 let verify_connection =
79 match verify with None -> Fn.const (return true) | Some f -> f
80 in
81 Ssl.client ?version ?name ?ca_file ?ca_path ?session ~app_to_ssl
82 ~ssl_to_app ~net_to_ssl ~ssl_to_net ()
83 >>= function
84 | Error error -> teardown_connection r w >>= fun () -> Error.raise error
85 | Ok conn -> (
86 verify_connection conn >>= function
87 | false ->
88 teardown_connection r w >>= fun () ->
89 failwith "Connection verification failed."
90 | true ->
91 reader_writer_of_pipes app_rd app_wr
92 >>| fun (app_reader, app_writer) -> (app_reader, app_writer))
93
94 let listen ?(version = Ssl.Version.Tlsv1_2) ?ca_file ?ca_path ~crt_file
95 ~key_file r w =
96 let net_to_ssl, ssl_to_net = reader_writer_pipes r w in
97 let app_to_ssl, app_wr = Pipe.create () in
98 let app_rd, ssl_to_app = Pipe.create () in
99 Ssl.server ?ca_file ?ca_path ~version ~crt_file ~key_file ~app_to_ssl
100 ~ssl_to_app ~net_to_ssl ~ssl_to_net ()
101 >>= function
102 | Error error -> teardown_connection r w >>= fun () -> Error.raise error
103 | Ok _ ->
104 reader_writer_of_pipes app_rd app_wr
105 >>| fun (app_reader, app_writer) -> (app_reader, app_writer)
106
107 type session = (Ssl.Session.t[@sexp.opaque]) [@@deriving sexp]
108 type version = Ssl.Version.t [@@deriving sexp]
109 type connection = (Ssl.Connection.t[@sexp.opaque]) [@@deriving sexp]
110 end
111 end
112
113 module V2 = struct
114 module Ssl = struct
115 type allowed_ciphers = [ `Only of string list | `Openssl_default | `Secure ]
116 [@@deriving sexp]
117
118 module Config = struct
119 type t = {
120 version : Ssl.Version.t option;
121 options : Ssl.Opt.t list option;
122 name : string option;
123 hostname : string option;
124 allowed_ciphers : allowed_ciphers option;
125 ca_file : string option;
126 ca_path : string option;
127 crt_file : string option;
128 key_file : string option;
129 session : (Ssl.Session.t[@sexp.opaque]) option;
130 verify_modes : (Verify_mode.t[@sexp.opaque]) list option;
131 verify : (Ssl.Connection.t -> bool Deferred.t) option;
132 }
133 [@@deriving sexp_of]
134
135 let verify_certificate = verify_certificate
136
137 let create ?version ?options ?name ?hostname ?allowed_ciphers ?ca_file
138 ?ca_path ?crt_file ?key_file ?session ?verify_modes ?verify () =
139 {
140 version;
141 options;
142 name;
143 hostname;
144 allowed_ciphers;
145 ca_file;
146 ca_path;
147 crt_file;
148 key_file;
149 session;
150 verify_modes;
151 verify;
152 }
153 end
154
155 let connect ?(cfg = Config.create ()) r w =
156 let {
157 Config.version;
158 options;
159 name;
160 hostname;
161 allowed_ciphers;
162 ca_file;
163 ca_path;
164 crt_file;
165 key_file;
166 session;
167 verify_modes;
168 verify;
169 } =
170 cfg
171 in
172 let net_to_ssl, ssl_to_net = reader_writer_pipes r w in
173 let app_to_ssl, app_wr = Pipe.create () in
174 let app_rd, ssl_to_app = Pipe.create () in
175 let verify_connection =
176 match verify with None -> Fn.const (return true) | Some f -> f
177 in
178 Ssl.client ?version ?options ?name ?hostname ?allowed_ciphers ?ca_file
179 ?ca_path ?crt_file ?key_file ?session ?verify_modes ~app_to_ssl
180 ~ssl_to_app ~net_to_ssl ~ssl_to_net ()
181 >>= function
182 | Error error -> teardown_connection r w >>= fun () -> Error.raise error
183 | Ok conn -> (
184 verify_connection conn >>= function
185 | false ->
186 teardown_connection r w >>= fun () ->
187 failwith "Connection verification failed."
188 | true ->
189 reader_writer_of_pipes app_rd app_wr
190 >>| fun (app_reader, app_writer) -> (app_reader, app_writer))
191
192 let listen
193 {
194 Config.version;
195 options;
196 name;
197 allowed_ciphers;
198 ca_file;
199 ca_path;
200 crt_file;
201 key_file;
202 verify_modes;
203 _;
204 } r w =
205 let crt_file, key_file =
206 match (crt_file, key_file) with
207 | Some crt_file, Some key_file -> (crt_file, key_file)
208 | _ ->
209 invalid_arg
210 "Conduit_async_ssl.ssl_listen: crt_file and key_file must be \
211 specified in cfg."
212 in
213 let net_to_ssl, ssl_to_net = reader_writer_pipes r w in
214 let app_to_ssl, app_wr = Pipe.create () in
215 let app_rd, ssl_to_app = Pipe.create () in
216 Ssl.server ?version ?options ?name ?allowed_ciphers ?ca_file ?ca_path
217 ~crt_file ~key_file ?verify_modes ~app_to_ssl ~ssl_to_app ~net_to_ssl
218 ~ssl_to_net ()
219 >>= function
220 | Error error -> teardown_connection r w >>= fun () -> Error.raise error
221 | Ok _ ->
222 reader_writer_of_pipes app_rd app_wr
223 >>| fun (app_reader, app_writer) -> (app_reader, app_writer)
224
225 type verify_mode = Ssl.Verify_mode.t [@@deriving sexp_of]
226 type session = (Ssl.Session.t[@sexp.opaque]) [@@deriving sexp_of]
227 type version = Ssl.Version.t [@@deriving sexp]
228 type connection = Ssl.Connection.t [@@deriving sexp_of]
229 type opt = Ssl.Opt.t [@@deriving sexp]
230 end
231 end
+271
-0
src/conduit-async/s.ml less more
0 open Async
1
2 module type V1 = sig
3 type session [@@deriving sexp_of]
4 type ssl_conn [@@deriving sexp_of]
5 type ssl_version [@@deriving sexp]
6
7 module Conduit_async : sig
8 module Ssl : sig
9 type config [@@deriving sexp]
10
11 val verify_certificate : ssl_conn -> bool Deferred.t
12
13 val configure :
14 ?version:ssl_version ->
15 ?name:string ->
16 ?ca_file:string ->
17 ?ca_path:string ->
18 ?session:session ->
19 ?verify:(ssl_conn -> bool Deferred.t) ->
20 unit ->
21 config
22 end
23
24 type +'a io = 'a Deferred.t
25 type ic = Reader.t
26 type oc = Writer.t
27
28 type addr =
29 [ `OpenSSL of string * Ipaddr.t * int
30 | `OpenSSL_with_config of string * Ipaddr.t * int * Ssl.config
31 | `TCP of Ipaddr.t * int
32 | `Unix_domain_socket of string ]
33 [@@deriving sexp]
34
35 val connect : ?interrupt:unit io -> addr -> (ic * oc) io
36
37 val with_connection :
38 ?interrupt:unit io -> addr -> (ic -> oc -> unit io) -> unit io
39
40 type trust_chain =
41 [ `Ca_file of string
42 | `Ca_path of string
43 | `Search_file_first_then_path of [ `File of string ] * [ `Path of string ]
44 ]
45 [@@deriving sexp]
46
47 type openssl =
48 [ `OpenSSL of [ `Crt_file_path of string ] * [ `Key_file_path of string ] ]
49 [@@deriving sexp]
50
51 type server =
52 [ openssl | `TCP | `OpenSSL_with_trust_chain of openssl * trust_chain ]
53 [@@deriving sexp]
54
55 val serve :
56 ?max_connections:int ->
57 ?backlog:int ->
58 ?buffer_age_limit:Writer.buffer_age_limit ->
59 on_handler_error:
60 [ `Call of ([< Socket.Address.t ] as 'a) -> exn -> unit
61 | `Ignore
62 | `Raise ] ->
63 server ->
64 ('a, 'b) Tcp.Where_to_listen.t ->
65 ('a -> ic -> oc -> unit io) ->
66 ('a, 'b) Tcp.Server.t io
67 end
68
69 module Conduit_async_ssl : sig
70 module Ssl_config = Conduit_async.Ssl
71
72 val ssl_connect :
73 Conduit_async.Ssl.config ->
74 Reader.t ->
75 Writer.t ->
76 (Reader.t * Writer.t) Deferred.t
77
78 val ssl_listen :
79 ?version:ssl_version ->
80 ?ca_file:string ->
81 ?ca_path:string ->
82 crt_file:string ->
83 key_file:string ->
84 Reader.t ->
85 Writer.t ->
86 (Reader.t * Writer.t) Deferred.t
87 end
88 end
89
90 module type V2 = sig
91 type allowed_ciphers = [ `Only of string list | `Openssl_default | `Secure ]
92 [@@deriving sexp]
93
94 type ssl_version [@@deriving sexp]
95 type session [@@deriving sexp_of]
96 type verify_mode [@@deriving sexp_of]
97 type ssl_opt [@@deriving sexp]
98 type ssl_conn [@@deriving sexp_of]
99
100 module Ssl : sig
101 module Config : sig
102 type t [@@deriving sexp_of]
103
104 val create :
105 ?version:ssl_version ->
106 ?options:ssl_opt list ->
107 ?name:string ->
108 ?hostname:string ->
109 ?allowed_ciphers:allowed_ciphers ->
110 ?ca_file:string ->
111 ?ca_path:string ->
112 ?crt_file:string ->
113 ?key_file:string ->
114 ?session:session ->
115 ?verify_modes:verify_mode list ->
116 ?verify:(ssl_conn -> bool Deferred.t) ->
117 unit ->
118 t
119 end
120 end
121
122 type addr =
123 [ `OpenSSL of Ipaddr.t * int * Ssl.Config.t
124 | `TCP of Ipaddr.t * int
125 | `Unix_domain_socket of string ]
126 [@@deriving sexp_of]
127
128 val connect :
129 ?interrupt:unit Deferred.t -> addr -> (Reader.t * Writer.t) Deferred.t
130
131 val with_connection :
132 ?interrupt:unit Deferred.t ->
133 addr ->
134 (Reader.t -> Writer.t -> unit Deferred.t) ->
135 unit Deferred.t
136
137 type trust_chain =
138 [ `Ca_file of string
139 | `Ca_path of string
140 | `Search_file_first_then_path of [ `File of string ] * [ `Path of string ]
141 ]
142 [@@deriving sexp]
143
144 type openssl =
145 [ `OpenSSL of [ `Crt_file_path of string ] * [ `Key_file_path of string ] ]
146 [@@deriving sexp]
147
148 type server =
149 [ openssl | `TCP | `OpenSSL_with_trust_chain of openssl * trust_chain ]
150 [@@deriving sexp]
151
152 val serve :
153 ?max_connections:int ->
154 ?backlog:int ->
155 ?buffer_age_limit:Writer.buffer_age_limit ->
156 on_handler_error:
157 [ `Call of ([< Socket.Address.t ] as 'a) -> exn -> unit
158 | `Ignore
159 | `Raise ] ->
160 server ->
161 ('a, 'b) Tcp.Where_to_listen.t ->
162 ('a -> Reader.t -> Writer.t -> unit Deferred.t) ->
163 ('a, 'b) Tcp.Server.t Deferred.t
164 end
165
166 module type V3 = sig
167 type allowed_ciphers = [ `Only of string list | `Openssl_default | `Secure ]
168 [@@deriving sexp]
169
170 type ssl_version [@@deriving sexp]
171 type session [@@deriving sexp_of]
172 type verify_mode [@@deriving sexp_of]
173 type ssl_opt [@@deriving sexp]
174 type ssl_conn [@@deriving sexp_of]
175
176 module Ssl : sig
177 module Config : sig
178 type t [@@deriving sexp_of]
179
180 val create :
181 ?version:ssl_version ->
182 ?options:ssl_opt list ->
183 ?name:string ->
184 ?hostname:string ->
185 ?allowed_ciphers:allowed_ciphers ->
186 ?ca_file:string ->
187 ?ca_path:string ->
188 ?crt_file:string ->
189 ?key_file:string ->
190 ?session:session ->
191 ?verify_modes:verify_mode list ->
192 ?verify:(ssl_conn -> bool Deferred.t) ->
193 unit ->
194 t
195 end
196 end
197
198 type _ addr =
199 | OpenSSL :
200 Socket.Address.Inet.t * Ssl.Config.t
201 -> Socket.Address.Inet.t addr
202 | Inet : Socket.Address.Inet.t -> Socket.Address.Inet.t addr
203 | Unix : Socket.Address.Unix.t -> Socket.Address.Unix.t addr
204 [@@deriving sexp_of]
205
206 type _ tcp_sock =
207 | Inet_sock :
208 ([ `Active ], Socket.Address.Inet.t) Socket.t
209 -> Socket.Address.Inet.t tcp_sock
210 | Unix_sock :
211 ([ `Active ], Socket.Address.Unix.t) Socket.t
212 -> Socket.Address.Unix.t tcp_sock
213
214 val resolve_uri :
215 ?options:Unix.Addr_info.getaddrinfo_option list ->
216 Uri.t ->
217 Socket.Address.Inet.t addr Deferred.t
218
219 val connect :
220 ?interrupt:unit Deferred.t ->
221 'a addr ->
222 ('a tcp_sock * Reader.t * Writer.t) Deferred.t
223
224 val with_connection :
225 ?interrupt:unit Deferred.t ->
226 'a addr ->
227 ('a tcp_sock -> Reader.t -> Writer.t -> 'b Deferred.t) ->
228 'b Deferred.t
229
230 val connect_uri :
231 ?options:Unix.Addr_info.getaddrinfo_option list ->
232 ?interrupt:unit Deferred.t ->
233 Uri.t ->
234 (Socket.Address.Inet.t tcp_sock * Reader.t * Writer.t) Deferred.t
235
236 val with_connection_uri :
237 ?options:Unix.Addr_info.getaddrinfo_option list ->
238 ?interrupt:unit Deferred.t ->
239 Uri.t ->
240 (Socket.Address.Inet.t tcp_sock -> Reader.t -> Writer.t -> 'a Deferred.t) ->
241 'a Deferred.t
242
243 type trust_chain =
244 [ `Ca_file of string
245 | `Ca_path of string
246 | `Search_file_first_then_path of [ `File of string ] * [ `Path of string ]
247 ]
248 [@@deriving sexp]
249
250 type openssl =
251 [ `OpenSSL of [ `Crt_file_path of string ] * [ `Key_file_path of string ] ]
252 [@@deriving sexp]
253
254 type server =
255 [ openssl | `TCP | `OpenSSL_with_trust_chain of openssl * trust_chain ]
256 [@@deriving sexp]
257
258 val serve :
259 ?max_connections:int ->
260 ?backlog:int ->
261 ?buffer_age_limit:Writer.buffer_age_limit ->
262 on_handler_error:
263 [ `Call of ([< Socket.Address.t ] as 'a) -> exn -> unit
264 | `Ignore
265 | `Raise ] ->
266 server ->
267 ('a, 'b) Tcp.Where_to_listen.t ->
268 ('a -> Reader.t -> Writer.t -> unit Deferred.t) ->
269 ('a, 'b) Tcp.Server.t Deferred.t
270 end
+5
-0
src/conduit-async/v1.dummy.mli less more
0 include
1 S.V1
2 with type session = [ `Ssl_not_compiled_in ]
3 and type ssl_version = [ `Ssl_not_compiled_in ]
4 and type ssl_conn = [ `Ssl_not_compiled_in ]
+136
-0
src/conduit-async/v1.ml less more
0 open Core
1 open Async
2 open Private_ssl.V1
3
4 type session = Ssl.session [@@deriving sexp]
5 type ssl_version = Ssl.version [@@deriving sexp]
6 type ssl_conn = Ssl.connection [@@deriving sexp]
7
8 module Conduit_async = struct
9 module Ssl = struct
10 include Ssl
11
12 type nonrec config = Config.t [@@deriving sexp]
13
14 let configure = Config.create
15 let verify_certificate = Config.verify_certificate
16 end
17
18 type oc = Writer.t
19 type ic = Reader.t
20 type 'a io = 'a Deferred.t
21
22 type addr =
23 [ `OpenSSL of string * Ipaddr_sexp.t * int
24 | `OpenSSL_with_config of string * Ipaddr_sexp.t * int * Ssl.config
25 | `TCP of Ipaddr_sexp.t * int
26 | `Unix_domain_socket of string ]
27 [@@deriving sexp]
28
29 let connect ?interrupt dst =
30 match dst with
31 | `TCP (ip, port) ->
32 let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
33 Tcp.connect ?interrupt (Tcp.Where_to_connect.of_host_and_port endp)
34 >>= fun (_, rd, wr) -> return (rd, wr)
35 | `OpenSSL (_, ip, port) ->
36 let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
37 Tcp.connect ?interrupt (Tcp.Where_to_connect.of_host_and_port endp)
38 >>= fun (_, rd, wr) ->
39 let config = Ssl.configure () in
40 Ssl.connect config rd wr
41 | `OpenSSL_with_config (_, ip, port, config) ->
42 let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
43 Tcp.connect ?interrupt (Tcp.Where_to_connect.of_host_and_port endp)
44 >>= fun (_, rd, wr) -> Ssl.connect config rd wr
45 | `Unix_domain_socket file ->
46 Tcp.connect ?interrupt (Tcp.Where_to_connect.of_file file)
47 >>= fun (_, rd, wr) -> return (rd, wr)
48
49 let with_connection ?interrupt dst f =
50 match dst with
51 | `TCP (ip, port) ->
52 let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
53 Tcp.with_connection ?interrupt
54 (Tcp.Where_to_connect.of_host_and_port endp) (fun _ rd wr -> f rd wr)
55 | `OpenSSL (_, ip, port) ->
56 let config = Ssl.configure () in
57 let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
58 Tcp.with_connection ?interrupt
59 (Tcp.Where_to_connect.of_host_and_port endp) (fun _ rd wr ->
60 Ssl.connect config rd wr >>= fun (rd, wr) ->
61 Monitor.protect
62 (fun () -> f rd wr)
63 ~finally:(fun () ->
64 Deferred.all_unit [ Reader.close rd; Writer.close wr ]))
65 | `OpenSSL_with_config (_, ip, port, config) ->
66 let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
67 Tcp.with_connection ?interrupt
68 (Tcp.Where_to_connect.of_host_and_port endp) (fun _ rd wr ->
69 Ssl.connect config rd wr >>= fun (rd, wr) ->
70 Monitor.protect
71 (fun () -> f rd wr)
72 ~finally:(fun () ->
73 Deferred.all_unit [ Reader.close rd; Writer.close wr ]))
74 | `Unix_domain_socket file ->
75 Tcp.with_connection ?interrupt (Tcp.Where_to_connect.of_file file)
76 (fun _ rd wr -> f rd wr)
77
78 type trust_chain =
79 [ `Ca_file of string
80 | `Ca_path of string
81 | `Search_file_first_then_path of [ `File of string ] * [ `Path of string ]
82 ]
83 [@@deriving sexp]
84
85 type openssl =
86 [ `OpenSSL of [ `Crt_file_path of string ] * [ `Key_file_path of string ] ]
87 [@@deriving sexp]
88
89 type requires_async_ssl =
90 [ openssl | `OpenSSL_with_trust_chain of openssl * trust_chain ]
91 [@@deriving sexp]
92
93 type server = [ `TCP | requires_async_ssl ] [@@deriving sexp]
94
95 let serve ?max_connections ?backlog ?buffer_age_limit ~on_handler_error mode
96 where_to_listen handle_request =
97 let handle_client handle_request sock rd wr =
98 match mode with
99 | `TCP -> handle_request sock rd wr
100 | #requires_async_ssl as async_ssl ->
101 let crt_file, key_file, ca_file, ca_path =
102 match async_ssl with
103 | `OpenSSL (`Crt_file_path crt_file, `Key_file_path key_file) ->
104 (crt_file, key_file, None, None)
105 | `OpenSSL_with_trust_chain
106 (`OpenSSL (`Crt_file_path crt, `Key_file_path key), trust_chain)
107 ->
108 let ca_file, ca_path =
109 match trust_chain with
110 | `Ca_file ca_file -> (Some ca_file, None)
111 | `Ca_path ca_path -> (None, Some ca_path)
112 | `Search_file_first_then_path (`File ca_file, `Path ca_path)
113 ->
114 (Some ca_file, Some ca_path)
115 in
116 (crt, key, ca_file, ca_path)
117 in
118 Ssl.listen ?ca_file ?ca_path ~crt_file ~key_file rd wr
119 >>= fun (rd, wr) ->
120 Monitor.protect
121 (fun () -> handle_request sock rd wr)
122 ~finally:(fun () ->
123 Deferred.all_unit [ Reader.close rd; Writer.close wr ])
124 in
125 Tcp.Server.create ?max_connections ?backlog ?buffer_age_limit
126 ~on_handler_error where_to_listen
127 (handle_client handle_request)
128 end
129
130 module Conduit_async_ssl = struct
131 module Ssl_config = Conduit_async.Ssl
132
133 let ssl_connect = Ssl.connect
134 let ssl_listen = Ssl.listen
135 end
+7
-0
src/conduit-async/v1.real.mli less more
0 open Async_ssl
1
2 include
3 S.V1
4 with type session = Ssl.Session.t
5 and type ssl_version = Ssl.Version.t
6 and type ssl_conn = Ssl.Connection.t
+8
-0
src/conduit-async/v2.dummy.mli less more
0 include
1 S.V2
2 with type session = [ `Ssl_not_compiled_in ]
3 and type ssl_version = [ `Ssl_not_compiled_in ]
4 and type ssl_conn = [ `Ssl_not_compiled_in ]
5 and type ssl_opt = [ `Ssl_not_compiled_in ]
6 and type allowed_ciphers =
7 [ `Only of string list | `Openssl_default | `Secure ]
+106
-0
src/conduit-async/v2.ml less more
0 open Core
1 open Async
2 open Private_ssl.V2
3
4 type addr =
5 [ `OpenSSL of Ipaddr_sexp.t * int * Ssl.Config.t
6 | `TCP of Ipaddr_sexp.t * int
7 | `Unix_domain_socket of string ]
8 [@@deriving sexp_of]
9
10 let connect ?interrupt dst =
11 match dst with
12 | `TCP (ip, port) ->
13 let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
14 Tcp.connect ?interrupt (Tcp.Where_to_connect.of_host_and_port endp)
15 >>= fun (_, rd, wr) -> return (rd, wr)
16 | `OpenSSL (ip, port, cfg) ->
17 let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
18 Tcp.connect ?interrupt (Tcp.Where_to_connect.of_host_and_port endp)
19 >>= fun (_, rd, wr) -> Ssl.connect ~cfg rd wr
20 | `Unix_domain_socket file ->
21 Tcp.connect ?interrupt (Tcp.Where_to_connect.of_file file)
22 >>= fun (_, rd, wr) -> return (rd, wr)
23
24 let with_connection ?interrupt dst f =
25 match dst with
26 | `TCP (ip, port) ->
27 let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
28 Tcp.with_connection ?interrupt
29 (Tcp.Where_to_connect.of_host_and_port endp) (fun _ rd wr -> f rd wr)
30 | `OpenSSL (ip, port, cfg) ->
31 let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
32 Tcp.with_connection ?interrupt
33 (Tcp.Where_to_connect.of_host_and_port endp) (fun _ rd wr ->
34 Ssl.connect ~cfg rd wr >>= fun (rd, wr) ->
35 Monitor.protect
36 (fun () -> f rd wr)
37 ~finally:(fun () ->
38 Deferred.all_unit [ Reader.close rd; Writer.close wr ]))
39 | `Unix_domain_socket file ->
40 Tcp.with_connection ?interrupt (Tcp.Where_to_connect.of_file file)
41 (fun _ rd wr -> f rd wr)
42
43 type trust_chain =
44 [ `Ca_file of string
45 | `Ca_path of string
46 | `Search_file_first_then_path of [ `File of string ] * [ `Path of string ]
47 ]
48 [@@deriving sexp]
49
50 type openssl =
51 [ `OpenSSL of [ `Crt_file_path of string ] * [ `Key_file_path of string ] ]
52 [@@deriving sexp]
53
54 type requires_async_ssl =
55 [ openssl | `OpenSSL_with_trust_chain of openssl * trust_chain ]
56 [@@deriving sexp]
57
58 type server = [ `TCP | requires_async_ssl ] [@@deriving sexp]
59
60 let serve ?max_connections ?backlog ?buffer_age_limit ~on_handler_error mode
61 where_to_listen handle_request =
62 let handle_client handle_request sock rd wr =
63 match mode with
64 | `TCP -> handle_request sock rd wr
65 | #requires_async_ssl as async_ssl ->
66 let crt_file, key_file, ca_file, ca_path =
67 match async_ssl with
68 | `OpenSSL (`Crt_file_path crt_file, `Key_file_path key_file) ->
69 (crt_file, key_file, None, None)
70 | `OpenSSL_with_trust_chain
71 (`OpenSSL (`Crt_file_path crt, `Key_file_path key), trust_chain)
72 ->
73 let ca_file, ca_path =
74 match trust_chain with
75 | `Ca_file ca_file -> (Some ca_file, None)
76 | `Ca_path ca_path -> (None, Some ca_path)
77 | `Search_file_first_then_path (`File ca_file, `Path ca_path) ->
78 (Some ca_file, Some ca_path)
79 in
80 (crt, key, ca_file, ca_path)
81 in
82 let cfg = Ssl.Config.create ?ca_file ?ca_path ~crt_file ~key_file () in
83 Ssl.listen cfg rd wr >>= fun (rd, wr) ->
84 Monitor.protect
85 (fun () -> handle_request sock rd wr)
86 ~finally:(fun () ->
87 Deferred.all_unit [ Reader.close rd; Writer.close wr ])
88 in
89 Tcp.Server.create ?max_connections ?backlog ?buffer_age_limit
90 ~on_handler_error where_to_listen
91 (handle_client handle_request)
92
93 type ssl_version = Ssl.version [@@deriving sexp]
94 type ssl_opt = Ssl.opt [@@deriving sexp]
95 type ssl_conn = Ssl.connection [@@deriving sexp_of]
96
97 type allowed_ciphers = [ `Only of string list | `Openssl_default | `Secure ]
98 [@@deriving sexp]
99
100 type verify_mode = Ssl.verify_mode [@@deriving sexp_of]
101 type session = Ssl.session [@@deriving sexp_of]
102
103 module Ssl = struct
104 module Config = Ssl.Config
105 end
+11
-0
src/conduit-async/v2.real.mli less more
0 open Async_ssl
1
2 include
3 S.V2
4 with type session = Ssl.Session.t
5 and type ssl_version = Ssl.Version.t
6 and type ssl_conn = Ssl.Connection.t
7 and type ssl_opt = Ssl.Opt.t
8 and type verify_mode = Ssl.Verify_mode.t
9 and type allowed_ciphers =
10 [ `Only of string list | `Openssl_default | `Secure ]
+8
-0
src/conduit-async/v3.dummy.mli less more
0 include
1 S.V3
2 with type session = [ `Ssl_not_compiled_in ]
3 and type ssl_version = [ `Ssl_not_compiled_in ]
4 and type ssl_conn = [ `Ssl_not_compiled_in ]
5 and type ssl_opt = [ `Ssl_not_compiled_in ]
6 and type allowed_ciphers =
7 [ `Only of string list | `Openssl_default | `Secure ]
+143
-0
src/conduit-async/v3.ml less more
0 open Core
1 open Async
2 open Private_ssl.V2
3
4 type _ addr =
5 | OpenSSL : Socket.Address.Inet.t * Ssl.Config.t -> Socket.Address.Inet.t addr
6 | Inet : Socket.Address.Inet.t -> Socket.Address.Inet.t addr
7 | Unix : Socket.Address.Unix.t -> Socket.Address.Unix.t addr
8 [@@deriving sexp_of]
9
10 type _ tcp_sock =
11 | Inet_sock :
12 ([ `Active ], Socket.Address.Inet.t) Socket.t
13 -> Socket.Address.Inet.t tcp_sock
14 | Unix_sock :
15 ([ `Active ], Socket.Address.Unix.t) Socket.t
16 -> Socket.Address.Unix.t tcp_sock
17
18 let ssl_schemes = [ "https"; "wss" ]
19 let mem_scheme s = List.mem ssl_schemes ~equal:String.equal s
20
21 let resolve_uri ?(options = []) uri =
22 let host =
23 Option.value_exn ~here:[%here] ~message:"no host in URL" (Uri.host uri)
24 in
25 let service =
26 match (Uri.port uri, Uri_services.tcp_port_of_uri uri) with
27 | Some p, _ -> Some (string_of_int p)
28 | None, Some p -> Some (string_of_int p)
29 | _ -> None
30 in
31 (* Async_extra does not yet support IPv6 *)
32 let options = Unix.Addr_info.AI_FAMILY PF_INET :: options in
33 Unix.Addr_info.get ~host ?service options >>= function
34 | [] -> failwithf "unable to resolve %s" (Uri.to_string uri) ()
35 | { ai_addr; _ } :: _ -> (
36 match (Uri.scheme uri, ai_addr) with
37 | _, ADDR_UNIX _ -> invalid_arg "uri must resolve to inet address"
38 | Some s, ADDR_INET (h, p) when mem_scheme s ->
39 return (OpenSSL (`Inet (h, p), Ssl.Config.create ()))
40 | _, ADDR_INET (h, p) -> return (Inet (`Inet (h, p))))
41
42 let connect (type a) ?interrupt (addr : a addr) :
43 (a tcp_sock * Reader.t * Writer.t) Deferred.t =
44 match addr with
45 | Inet addr ->
46 Tcp.connect ?interrupt (Tcp.Where_to_connect.of_inet_address addr)
47 >>| fun (s, r, w) -> (Inet_sock s, r, w)
48 | OpenSSL (addr, cfg) ->
49 Tcp.connect ?interrupt (Tcp.Where_to_connect.of_inet_address addr)
50 >>= fun (s, rd, wr) ->
51 Ssl.connect ~cfg rd wr >>| fun (rd, wr) -> (Inet_sock s, rd, wr)
52 | Unix addr ->
53 Tcp.connect ?interrupt (Tcp.Where_to_connect.of_unix_address addr)
54 >>| fun (s, r, w) -> (Unix_sock s, r, w)
55
56 let with_connection (type a) ?interrupt (addr : a addr)
57 (f : a tcp_sock -> Reader.t -> Writer.t -> 'a Deferred.t) =
58 match addr with
59 | Inet addr ->
60 Tcp.with_connection ?interrupt (Tcp.Where_to_connect.of_inet_address addr)
61 (fun s rd wr -> f (Inet_sock s) rd wr)
62 | OpenSSL (addr, cfg) ->
63 Tcp.with_connection ?interrupt (Tcp.Where_to_connect.of_inet_address addr)
64 (fun s rd wr ->
65 Ssl.connect ~cfg rd wr >>= fun (rd, wr) ->
66 Monitor.protect
67 (fun () -> f (Inet_sock s) rd wr)
68 ~finally:(fun () ->
69 Deferred.all_unit [ Reader.close rd; Writer.close wr ]))
70 | Unix addr ->
71 Tcp.with_connection ?interrupt (Tcp.Where_to_connect.of_unix_address addr)
72 (fun s rd wr -> f (Unix_sock s) rd wr)
73
74 let connect_uri ?options ?interrupt uri =
75 resolve_uri ?options uri >>= fun addr -> connect ?interrupt addr
76
77 let with_connection_uri ?options ?interrupt uri f =
78 resolve_uri ?options uri >>= fun addr -> with_connection ?interrupt addr f
79
80 type trust_chain =
81 [ `Ca_file of string
82 | `Ca_path of string
83 | `Search_file_first_then_path of [ `File of string ] * [ `Path of string ]
84 ]
85 [@@deriving sexp]
86
87 type openssl =
88 [ `OpenSSL of [ `Crt_file_path of string ] * [ `Key_file_path of string ] ]
89 [@@deriving sexp]
90
91 type requires_async_ssl =
92 [ openssl | `OpenSSL_with_trust_chain of openssl * trust_chain ]
93 [@@deriving sexp]
94
95 type server = [ `TCP | requires_async_ssl ] [@@deriving sexp]
96
97 let serve ?max_connections ?backlog ?buffer_age_limit ~on_handler_error mode
98 where_to_listen handle_request =
99 let handle_client handle_request sock rd wr =
100 match mode with
101 | `TCP -> handle_request sock rd wr
102 | #requires_async_ssl as async_ssl ->
103 let crt_file, key_file, ca_file, ca_path =
104 match async_ssl with
105 | `OpenSSL (`Crt_file_path crt_file, `Key_file_path key_file) ->
106 (crt_file, key_file, None, None)
107 | `OpenSSL_with_trust_chain
108 (`OpenSSL (`Crt_file_path crt, `Key_file_path key), trust_chain)
109 ->
110 let ca_file, ca_path =
111 match trust_chain with
112 | `Ca_file ca_file -> (Some ca_file, None)
113 | `Ca_path ca_path -> (None, Some ca_path)
114 | `Search_file_first_then_path (`File ca_file, `Path ca_path) ->
115 (Some ca_file, Some ca_path)
116 in
117 (crt, key, ca_file, ca_path)
118 in
119 let cfg = Ssl.Config.create ?ca_file ?ca_path ~crt_file ~key_file () in
120 Ssl.listen cfg rd wr >>= fun (rd, wr) ->
121 Monitor.protect
122 (fun () -> handle_request sock rd wr)
123 ~finally:(fun () ->
124 Deferred.all_unit [ Reader.close rd; Writer.close wr ])
125 in
126 Tcp.Server.create ?max_connections ?backlog ?buffer_age_limit
127 ~on_handler_error where_to_listen
128 (handle_client handle_request)
129
130 type ssl_version = Ssl.version [@@deriving sexp]
131 type ssl_opt = Ssl.opt [@@deriving sexp]
132 type ssl_conn = Ssl.connection [@@deriving sexp_of]
133
134 type allowed_ciphers = [ `Only of string list | `Openssl_default | `Secure ]
135 [@@deriving sexp]
136
137 type verify_mode = Ssl.verify_mode [@@deriving sexp_of]
138 type session = Ssl.session [@@deriving sexp_of]
139
140 module Ssl = struct
141 module Config = Ssl.Config
142 end
+11
-0
src/conduit-async/v3.real.mli less more
0 open Async_ssl
1
2 include
3 S.V3
4 with type session = Ssl.Session.t
5 and type ssl_version = Ssl.Version.t
6 and type ssl_conn = Ssl.Connection.t
7 and type ssl_opt = Ssl.Opt.t
8 and type verify_mode = Ssl.Verify_mode.t
9 and type allowed_ciphers =
10 [ `Only of string list | `Openssl_default | `Secure ]
+8
-0
src/conduit-lwt/dune less more
0 (library
1 (name conduit_lwt)
2 (public_name conduit-lwt)
3 (preprocess
4 (pps ppx_sexp_conv))
5 (wrapped false)
6 (modules resolver_lwt)
7 (libraries conduit lwt))
+28
-0
src/conduit-lwt/resolver_lwt.ml less more
0 (*
1 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 module IO = struct
18 type 'a t = 'a Lwt.t
19
20 let ( >>= ) = Lwt.bind
21 let return = Lwt.return
22 end
23
24 module type S =
25 Resolver.S with type svc = Resolver.service and type 'a io = 'a Lwt.t
26
27 include Resolver.Make (IO)
+27
-0
src/conduit-lwt/resolver_lwt.mli less more
0 (*
1 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 (** Resolve URIs to endpoints using the {{:http://ocsigen.org/lwt} Lwt} library *)
18
19 module IO : Conduit.IO with type 'a t = 'a Lwt.t
20 (** IO module compatible with {!Conduit.IO} that uses Lwt *)
21
22 (** Module type that specialises {!Conduit.RESOLVER} to use Lwt threads *)
23 module type S =
24 Resolver.S with type svc = Resolver.service and type 'a io = 'a Lwt.t
25
26 include S
+18
-0
src/conduit-lwt-unix/conduit_lwt_launchd.dummy.ml less more
0 (*
1 * Copyright (c) 2015-2017 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 let activate _fn _name = Lwt.fail_with "No Launchd support"
+24
-0
src/conduit-lwt-unix/conduit_lwt_launchd.real.ml less more
0 (*
1 * Copyright (c) 2015-2017 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 open Lwt.Infix
18
19 let activate fn name =
20 Lwt_launchd.activate_socket name >>= fun sockets ->
21 match Launchd.error_to_msg sockets with
22 | Ok sockets -> Lwt_list.iter_p fn sockets
23 | Error (`Msg m) -> Lwt.fail_with m
+104
-0
src/conduit-lwt-unix/conduit_lwt_server.ml less more
0 open Lwt.Infix
1
2 let src = Logs.Src.create "conduit_lwt_server" ~doc:"Conduit Lwt transport"
3
4 module Log = (val Logs.src_log src : Logs.LOG)
5
6 let safe_close t =
7 Lwt.catch (fun () -> Lwt_io.close t) (fun _ -> Lwt.return_unit)
8
9 let close (ic, oc) = safe_close oc >>= fun () -> safe_close ic
10
11 let with_socket sockaddr f =
12 let fd =
13 Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0
14 in
15 Lwt.catch
16 (fun () -> f fd)
17 (fun e ->
18 Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit)
19 >>= fun () -> Lwt.fail e)
20
21 let listen ?(backlog = 128) sa =
22 with_socket sa (fun fd ->
23 Lwt_unix.(setsockopt fd SO_REUSEADDR true);
24 Lwt_unix.bind fd sa >|= fun () ->
25 Lwt_unix.listen fd backlog;
26 Lwt_unix.set_close_on_exec fd;
27 fd)
28
29 let process_accept ?timeout callback (sa, ic, oc) =
30 let c = callback sa ic oc in
31 let events =
32 match timeout with
33 | None -> [ c ]
34 | Some t -> [ c; Lwt_unix.sleep (float_of_int t) ]
35 in
36 Lwt.finalize (fun () -> Lwt.pick events) (fun () -> close (ic, oc))
37
38 (* File descriptors are a global resource so this has to be a global limit too *)
39 let maxactive = ref None
40 let active = ref 0
41 let cond = Lwt_condition.create ()
42 let connected () = incr active
43
44 let disconnected () =
45 decr active;
46 Lwt_condition.broadcast cond ()
47
48 let rec throttle () =
49 match !maxactive with
50 | Some limit when !active > limit -> Lwt_condition.wait cond >>= throttle
51 | _ -> Lwt.return_unit
52
53 let set_max_active max_active =
54 maxactive := Some max_active;
55 Lwt_condition.broadcast cond ()
56
57 let run_handler handler v =
58 Lwt.async (fun () ->
59 Lwt.try_bind
60 (fun () -> handler v)
61 (fun () ->
62 disconnected ();
63 Lwt.return_unit)
64 (fun x ->
65 disconnected ();
66 (match x with
67 | Lwt.Canceled -> ()
68 | ex ->
69 Log.warn (fun f ->
70 f "Uncaught exception in handler: %s" (Printexc.to_string ex)));
71 Lwt.return_unit))
72
73 let init ?(stop = fst (Lwt.wait ())) handler fd =
74 let stop = Lwt.map (fun () -> `Stop) stop in
75 let rec loop () =
76 Lwt.try_bind
77 (fun () ->
78 connected ();
79 throttle () >>= fun () ->
80 let accept = Lwt.map (fun v -> `Accept v) (Lwt_unix.accept fd) in
81 Lwt.choose [ accept; stop ] >|= function
82 | `Stop ->
83 Lwt.cancel accept;
84 `Stop
85 | `Accept _ as x -> x)
86 (function
87 | `Stop ->
88 disconnected ();
89 Lwt.return_unit
90 | `Accept v ->
91 run_handler handler v;
92 loop ())
93 (fun exn ->
94 disconnected ();
95 match exn with
96 | Lwt.Canceled -> Lwt.return_unit
97 | ex ->
98 Log.warn (fun f ->
99 f "Uncaught exception accepting connection: %s"
100 (Printexc.to_string ex));
101 Lwt_unix.yield () >>= loop)
102 in
103 Lwt.finalize loop (fun () -> Lwt_unix.close fd)
+16
-0
src/conduit-lwt-unix/conduit_lwt_server.mli less more
0 val close : 'a Lwt_io.channel * 'b Lwt_io.channel -> unit Lwt.t
1 val set_max_active : int -> unit
2 val listen : ?backlog:int -> Unix.sockaddr -> Lwt_unix.file_descr Lwt.t
3 val with_socket : Unix.sockaddr -> (Lwt_unix.file_descr -> 'a Lwt.t) -> 'a Lwt.t
4
5 val process_accept :
6 ?timeout:int ->
7 ('a -> 'b Lwt_io.channel -> 'c Lwt_io.channel -> unit Lwt.t) ->
8 'a * 'b Lwt_io.channel * 'c Lwt_io.channel ->
9 unit Lwt.t
10
11 val init :
12 ?stop:unit Lwt.t ->
13 (Lwt_unix.file_descr * Lwt_unix.sockaddr -> unit Lwt.t) ->
14 Lwt_unix.file_descr ->
15 unit Lwt.t
+22
-0
src/conduit-lwt-unix/conduit_lwt_tls.dummy.ml less more
0 module X509 = struct
1 let private_of_pems ~cert:_ ~priv_key:_ = Lwt.fail_with "Tls not available"
2
3 type authenticator = unit
4
5 let default_authenticator = ()
6 end
7
8 module Client = struct
9 let connect ?src:_ ?certificates:_ ~authenticator:_ _host _sa =
10 Lwt.fail_with "Tls not available"
11 end
12
13 module Server = struct
14 let init' ?backlog:_ ?stop:_ ?timeout:_ _tls _sa _callback =
15 Lwt.fail_with "Tls not available"
16
17 let init ?backlog:_ ~certfile:_ ~keyfile:_ ?stop:_ ?timeout:_ _sa _callback =
18 Lwt.fail_with "Tls not available"
19 end
20
21 let available = false
+69
-0
src/conduit-lwt-unix/conduit_lwt_tls.dummy.mli less more
0 (*
1 * Copyright (c) 2014 Hannes Mehnert <hannes@mehnert.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 (** TLS/SSL connections via OCaml-TLS *)
18
19 module X509 : sig
20 val private_of_pems : cert:string -> priv_key:string -> 'a Lwt.t
21
22 type authenticator = unit
23
24 val default_authenticator : authenticator
25 end
26
27 module Client : sig
28 val connect :
29 ?src:Lwt_unix.sockaddr ->
30 ?certificates:'a ->
31 authenticator:X509.authenticator ->
32 [ `host ] Domain_name.t ->
33 Lwt_unix.sockaddr ->
34 (Lwt_unix.file_descr * Lwt_io.input_channel * Lwt_io.output_channel) Lwt.t
35 end
36
37 module Server : sig
38 val init :
39 ?backlog:int ->
40 certfile:string ->
41 keyfile:string ->
42 ?stop:unit Lwt.t ->
43 ?timeout:int ->
44 Lwt_unix.sockaddr ->
45 (Lwt_unix.sockaddr ->
46 Lwt_unix.file_descr ->
47 Lwt_io.input_channel ->
48 Lwt_io.output_channel ->
49 unit Lwt.t) ->
50 unit Lwt.t
51
52 val init' :
53 ?backlog:int ->
54 ?stop:unit Lwt.t ->
55 ?timeout:int ->
56 'config ->
57 Lwt_unix.sockaddr ->
58 (Lwt_unix.sockaddr ->
59 Lwt_unix.file_descr ->
60 Lwt_io.input_channel ->
61 Lwt_io.output_channel ->
62 unit Lwt.t) ->
63 unit Lwt.t
64 end
65
66 (**/**)
67
68 val available : bool
+65
-0
src/conduit-lwt-unix/conduit_lwt_tls.real.ml less more
0 (*
1 * Copyright (c) 2014 Hannes Mehnert <hannes@mehnert.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 open Lwt.Infix
18
19 module X509 = struct
20 let private_of_pems ~cert ~priv_key = X509_lwt.private_of_pems ~cert ~priv_key
21
22 type authenticator = X509.Authenticator.t
23
24 let default_authenticator =
25 match Ca_certs.authenticator () with
26 | Ok a -> a
27 | Error (`Msg msg) -> failwith msg
28 end
29
30 module Client = struct
31 let connect ?src ?certificates ~authenticator host sa =
32 Conduit_lwt_server.with_socket sa (fun fd ->
33 (match src with
34 | None -> Lwt.return_unit
35 | Some src_sa -> Lwt_unix.bind fd src_sa)
36 >>= fun () ->
37 let config = Tls.Config.client ~authenticator ?certificates () in
38 Lwt_unix.connect fd sa >>= fun () ->
39 Tls_lwt.Unix.client_of_fd config ~host fd >|= fun t ->
40 let ic, oc = Tls_lwt.of_t t in
41 (fd, ic, oc))
42 end
43
44 module Server = struct
45 let init' ?backlog ?stop ?timeout tls sa callback =
46 sa
47 |> Conduit_lwt_server.listen ?backlog
48 >>= Conduit_lwt_server.init ?stop (fun (fd, addr) ->
49 Lwt.try_bind
50 (fun () -> Tls_lwt.Unix.server_of_fd tls fd)
51 (fun t ->
52 let ic, oc = Tls_lwt.of_t t in
53 Lwt.return (fd, ic, oc))
54 (fun exn -> Lwt_unix.close fd >>= fun () -> Lwt.fail exn)
55 >>= Conduit_lwt_server.process_accept ?timeout (callback addr))
56
57 let init ?backlog ~certfile ~keyfile ?stop ?timeout sa callback =
58 X509_lwt.private_of_pems ~cert:certfile ~priv_key:keyfile
59 >>= fun certificate ->
60 let config = Tls.Config.server ~certificates:(`Single certificate) () in
61 init' ?backlog ?stop ?timeout config sa callback
62 end
63
64 let available = true
+70
-0
src/conduit-lwt-unix/conduit_lwt_tls.real.mli less more
0 (*
1 * Copyright (c) 2014 Hannes Mehnert <hannes@mehnert.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 (** TLS/SSL connections via OCaml-TLS *)
18
19 module X509 : sig
20 val private_of_pems :
21 cert:string -> priv_key:string -> Tls.Config.certchain Lwt.t
22
23 type authenticator = X509.Authenticator.t
24
25 val default_authenticator : authenticator
26 end
27
28 module Client : sig
29 val connect :
30 ?src:Lwt_unix.sockaddr ->
31 ?certificates:Tls.Config.own_cert ->
32 authenticator:X509.authenticator ->
33 [ `host ] Domain_name.t ->
34 Lwt_unix.sockaddr ->
35 (Lwt_unix.file_descr * Lwt_io.input_channel * Lwt_io.output_channel) Lwt.t
36 end
37
38 module Server : sig
39 val init :
40 ?backlog:int ->
41 certfile:string ->
42 keyfile:string ->
43 ?stop:unit Lwt.t ->
44 ?timeout:int ->
45 Lwt_unix.sockaddr ->
46 (Lwt_unix.sockaddr ->
47 Lwt_unix.file_descr ->
48 Lwt_io.input_channel ->
49 Lwt_io.output_channel ->
50 unit Lwt.t) ->
51 unit Lwt.t
52
53 val init' :
54 ?backlog:int ->
55 ?stop:unit Lwt.t ->
56 ?timeout:int ->
57 Tls.Config.server ->
58 Lwt_unix.sockaddr ->
59 (Lwt_unix.sockaddr ->
60 Lwt_unix.file_descr ->
61 Lwt_io.input_channel ->
62 Lwt_io.output_channel ->
63 unit Lwt.t) ->
64 unit Lwt.t
65 end
66
67 (**/**)
68
69 val available : bool
+437
-0
src/conduit-lwt-unix/conduit_lwt_unix.ml less more
0 (*
1 * Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
2 * Copyright (c) 2014 Hannes Mehnert <hannes@mehnert.org>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *
16 *)
17
18 open Lwt.Infix
19 open Sexplib.Conv
20
21 let debug = ref false
22 let debug_print = ref Printf.eprintf
23
24 let () =
25 try
26 ignore (Sys.getenv "CONDUIT_DEBUG");
27 debug := true
28 with Not_found -> ()
29
30 type tls_lib = OpenSSL | Native | No_tls [@@deriving sexp]
31
32 let default_tls_library =
33 (* TODO build time selection *)
34 let default =
35 if Conduit_lwt_tls.available then Native
36 else if Conduit_lwt_unix_ssl.available then OpenSSL
37 else No_tls
38 in
39 match String.lowercase_ascii (Sys.getenv "CONDUIT_TLS") with
40 | "native" -> Native
41 | "openssl" | "libressl" -> OpenSSL
42 | "none" | "notls" -> No_tls
43 | _ -> default
44 | exception Not_found -> default
45
46 let tls_library = ref default_tls_library
47
48 let () =
49 if !debug then
50 !debug_print "Selected TLS library: %s\n"
51 (Sexplib.Sexp.to_string (sexp_of_tls_lib !tls_library))
52
53 type +'a io = 'a Lwt.t
54 type ic = Lwt_io.input_channel
55 type oc = Lwt_io.output_channel
56
57 type client_tls_config =
58 [ `Hostname of string ] * [ `IP of Ipaddr_sexp.t ] * [ `Port of int ]
59 [@@deriving sexp]
60
61 type client =
62 [ `TLS of client_tls_config
63 | `TLS_native of client_tls_config
64 | `OpenSSL of client_tls_config
65 | `TCP of [ `IP of Ipaddr_sexp.t ] * [ `Port of int ]
66 | `Unix_domain_socket of [ `File of string ]
67 | `Vchan_direct of [ `Domid of int ] * [ `Port of string ]
68 | `Vchan_domain_socket of [ `Domain_name of string ] * [ `Port of string ] ]
69 [@@deriving sexp]
70
71 type server_tls_config =
72 [ `Crt_file_path of string ]
73 * [ `Key_file_path of string ]
74 * [ `Password of bool -> string | `No_password ]
75 * [ `Port of int ]
76 [@@deriving sexp]
77 (** Configuration fragment for a listening TLS server *)
78
79 type tcp_config =
80 [ `Port of int | `Socket of (Lwt_unix.file_descr[@sexp.opaque]) ]
81 [@@deriving sexp]
82 (** Set of ways to create TCP servers *)
83
84 type server =
85 [ `TLS of server_tls_config
86 | `OpenSSL of server_tls_config
87 | `TLS_native of server_tls_config
88 | `TCP of tcp_config
89 | `Unix_domain_socket of [ `File of string ]
90 | `Vchan_direct of int * string
91 | `Vchan_domain_socket of string * string
92 | `Launchd of string ]
93 [@@deriving sexp]
94 (** Set of supported listening mechanisms that are supported by this module. *)
95
96 type tls_own_key =
97 [ `None
98 | `TLS of
99 [ `Crt_file_path of string ]
100 * [ `Key_file_path of string ]
101 * [ `Password of bool -> string | `No_password ] ]
102 [@@deriving sexp]
103
104 type tls_server_key = tls_own_key [@@deriving sexp]
105
106 type ctx = {
107 src : Unix.sockaddr option;
108 tls_own_key : tls_own_key;
109 tls_authenticator : Conduit_lwt_tls.X509.authenticator;
110 }
111
112 let string_of_unix_sockaddr sa =
113 let open Unix in
114 match sa with
115 | ADDR_UNIX s -> Printf.sprintf "ADDR_UNIX(%s)" s
116 | ADDR_INET (ia, port) ->
117 Printf.sprintf "ADDR_INET(%s,%d)" (string_of_inet_addr ia) port
118
119 let sexp_of_ctx ctx =
120 [%sexp_of: string option * tls_own_key]
121 ( (match ctx.src with
122 | None -> None
123 | Some sa -> Some (string_of_unix_sockaddr sa)),
124 ctx.tls_own_key )
125
126 type tcp_flow = {
127 fd : (Lwt_unix.file_descr[@sexp.opaque]);
128 ip : Ipaddr_sexp.t;
129 port : int;
130 }
131 [@@deriving sexp]
132
133 type domain_flow = { fd : (Lwt_unix.file_descr[@sexp.opaque]); path : string }
134 [@@deriving sexp]
135
136 type vchan_flow = { domid : int; port : string } [@@deriving sexp]
137
138 type flow =
139 | TCP of tcp_flow
140 | Domain_socket of domain_flow
141 | Vchan of vchan_flow
142 [@@deriving sexp]
143
144 let flow_of_fd fd sa =
145 match sa with
146 | Unix.ADDR_UNIX path -> Domain_socket { fd; path }
147 | Unix.ADDR_INET (ip, port) ->
148 TCP { fd; ip = Ipaddr_unix.of_inet_addr ip; port }
149
150 let default_ctx =
151 {
152 src = None;
153 tls_own_key = `None;
154 tls_authenticator = Conduit_lwt_tls.X509.default_authenticator;
155 }
156
157 let init ?src ?(tls_own_key = `None)
158 ?(tls_authenticator = Conduit_lwt_tls.X509.default_authenticator) () =
159 match src with
160 | None -> Lwt.return { src = None; tls_own_key; tls_authenticator }
161 | Some host -> (
162 let open Unix in
163 Lwt_unix.getaddrinfo host "0" [ AI_PASSIVE; AI_SOCKTYPE SOCK_STREAM ]
164 >>= function
165 | { ai_addr; _ } :: _ ->
166 Lwt.return { src = Some ai_addr; tls_own_key; tls_authenticator }
167 | [] -> Lwt.fail_with "Invalid conduit source address specified")
168
169 module Sockaddr_io = struct
170 let shutdown_no_exn fd mode =
171 try Lwt_unix.shutdown fd mode
172 with Unix.Unix_error (Unix.ENOTCONN, _, _) -> ()
173
174 let make_fd_state () = ref `Open
175
176 let make fd =
177 let fd_state = make_fd_state () in
178 let close_in () =
179 match !fd_state with
180 | `Open ->
181 fd_state := `In_closed;
182 shutdown_no_exn fd Unix.SHUTDOWN_RECEIVE;
183 Lwt.return_unit
184 | `Out_closed ->
185 fd_state := `Closed;
186 Lwt_unix.close fd
187 | `In_closed (* repeating on a closed channel is a noop in Lwt_io *)
188 | `Closed ->
189 Lwt.return_unit
190 in
191 let close_out () =
192 match !fd_state with
193 | `Open ->
194 fd_state := `Out_closed;
195 shutdown_no_exn fd Unix.SHUTDOWN_SEND;
196 Lwt.return_unit
197 | `In_closed ->
198 fd_state := `Closed;
199 Lwt_unix.close fd
200 | `Out_closed (* repeating on a closed channel is a noop in Lwt_io *)
201 | `Closed ->
202 Lwt.return_unit
203 in
204 let ic = Lwt_io.of_fd ~close:close_in ~mode:Lwt_io.input fd in
205 let oc = Lwt_io.of_fd ~close:close_out ~mode:Lwt_io.output fd in
206 (ic, oc)
207 end
208
209 (* Vanilla sockaddr connection *)
210 module Sockaddr_client = struct
211 let connect ?src sa =
212 Conduit_lwt_server.with_socket sa (fun fd ->
213 (match src with
214 | None -> Lwt.return_unit
215 | Some src_sa -> Lwt_unix.bind fd src_sa)
216 >>= fun () ->
217 Lwt_unix.connect fd sa >>= fun () ->
218 let ic, oc = Sockaddr_io.make fd in
219 Lwt.return (fd, ic, oc))
220 end
221
222 module Sockaddr_server = struct
223 let set_sockopts_no_exn fd =
224 try Lwt_unix.setsockopt fd Lwt_unix.TCP_NODELAY true
225 with
226 (* This is expected for Unix domain sockets *)
227 | Unix.Unix_error (Unix.EOPNOTSUPP, _, _) ->
228 ()
229
230 let process_accept ?timeout callback (client, peeraddr) =
231 set_sockopts_no_exn client;
232 let ic, oc = Sockaddr_io.make client in
233 let c = callback (flow_of_fd client peeraddr) ic oc in
234 let events =
235 match timeout with
236 | None -> [ c ]
237 | Some t -> [ c; Lwt_unix.sleep (float_of_int t) ]
238 in
239 Lwt.finalize
240 (fun () -> Lwt.pick events)
241 (fun () -> Conduit_lwt_server.close (ic, oc))
242
243 let init ~on ?stop ?backlog ?timeout callback =
244 (match on with
245 | `Socket s -> Lwt.return s
246 | `Sockaddr sockaddr -> Conduit_lwt_server.listen ?backlog sockaddr)
247 >>= Conduit_lwt_server.init ?stop (process_accept ?timeout callback)
248 end
249
250 let set_max_active maxactive = Conduit_lwt_server.set_max_active maxactive
251
252 (** TLS client connection functions *)
253
254 let connect_with_tls_native ~ctx (`Hostname hostname, `IP ip, `Port port) =
255 let sa = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) in
256 (match ctx.tls_own_key with
257 | `None -> Lwt.return_none
258 | `TLS (_, _, `Password _) ->
259 Lwt.fail_with "OCaml-TLS cannot handle encrypted pem files"
260 | `TLS (`Crt_file_path cert, `Key_file_path priv_key, `No_password) ->
261 Conduit_lwt_tls.X509.private_of_pems ~cert ~priv_key
262 >|= fun certificate -> Some (`Single certificate))
263 >>= fun certificates ->
264 let hostname =
265 try Domain_name.(host_exn (of_string_exn hostname))
266 with Invalid_argument msg ->
267 let s =
268 Printf.sprintf "couldn't convert %s to a [`host] Domain_name.t: %s"
269 hostname msg
270 in
271 invalid_arg s
272 in
273 Conduit_lwt_tls.Client.connect ?src:ctx.src ?certificates
274 ~authenticator:ctx.tls_authenticator hostname sa
275 >|= fun (fd, ic, oc) ->
276 let flow = TCP { fd; ip; port } in
277 (flow, ic, oc)
278
279 let connect_with_openssl ~ctx (`Hostname hostname, `IP ip, `Port port) =
280 let sa = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) in
281 let ctx_ssl =
282 match ctx.tls_own_key with
283 | `None -> None
284 | `TLS (`Crt_file_path certfile, `Key_file_path keyfile, password) ->
285 let password =
286 match password with `No_password -> None | `Password fn -> Some fn
287 in
288 let ctx_ssl =
289 Conduit_lwt_unix_ssl.Client.create_ctx ~certfile ~keyfile ?password ()
290 in
291 Some ctx_ssl
292 in
293 Conduit_lwt_unix_ssl.Client.connect ?ctx:ctx_ssl ?src:ctx.src ~hostname sa
294 >>= fun (fd, ic, oc) ->
295 let flow = TCP { fd; ip; port } in
296 Lwt.return (flow, ic, oc)
297
298 let connect_with_default_tls ~ctx tls_client_config =
299 match !tls_library with
300 | OpenSSL -> connect_with_openssl ~ctx tls_client_config
301 | Native -> connect_with_tls_native ~ctx tls_client_config
302 | No_tls -> Lwt.fail_with "No SSL or TLS support compiled into Conduit"
303
304 (** Main connection function *)
305
306 let connect ~ctx (mode : client) =
307 match mode with
308 | `TCP (`IP ip, `Port port) ->
309 let sa = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) in
310 Sockaddr_client.connect ?src:ctx.src sa >>= fun (fd, ic, oc) ->
311 let flow = TCP { fd; ip; port } in
312 Lwt.return (flow, ic, oc)
313 | `Unix_domain_socket (`File path) ->
314 Sockaddr_client.connect (Unix.ADDR_UNIX path) >>= fun (fd, ic, oc) ->
315 let flow = Domain_socket { fd; path } in
316 Lwt.return (flow, ic, oc)
317 | `TLS c -> connect_with_default_tls ~ctx c
318 | `OpenSSL c -> connect_with_openssl ~ctx c
319 | `TLS_native c -> connect_with_tls_native ~ctx c
320 | `Vchan_direct _ -> Lwt.fail_with "Vchan_direct not available on unix"
321 | `Vchan_domain_socket _uuid ->
322 Lwt.fail_with "Vchan_domain_socket not implemented"
323
324 let sockaddr_on_tcp_port ctx port =
325 let open Unix in
326 match ctx.src with
327 | Some (ADDR_UNIX _) -> failwith "Cant listen to TCP on a domain socket"
328 | Some (ADDR_INET (a, _)) -> (ADDR_INET (a, port), Ipaddr_unix.of_inet_addr a)
329 | None -> (ADDR_INET (inet_addr_any, port), Ipaddr.(V4 V4.any))
330
331 let serve_with_openssl ?timeout ?stop ~ctx ~certfile ~keyfile ~pass ~port
332 callback =
333 let sockaddr, _ = sockaddr_on_tcp_port ctx port in
334 let password =
335 match pass with `No_password -> None | `Password fn -> Some fn
336 in
337 Conduit_lwt_unix_ssl.Server.init ?password ~certfile ~keyfile ?timeout ?stop
338 sockaddr (fun addr fd ic oc -> callback (flow_of_fd fd addr) ic oc)
339
340 let serve_with_tls_native ?timeout ?stop ~ctx ~certfile ~keyfile ~pass ~port
341 callback =
342 let sockaddr, _ = sockaddr_on_tcp_port ctx port in
343 (match pass with
344 | `No_password -> Lwt.return ()
345 | `Password _ -> Lwt.fail_with "OCaml-TLS cannot handle encrypted pem files")
346 >>= fun () ->
347 Conduit_lwt_tls.Server.init ~certfile ~keyfile ?timeout ?stop sockaddr
348 (fun addr fd ic oc -> callback (flow_of_fd fd addr) ic oc)
349
350 let serve_with_default_tls ?timeout ?stop ~ctx ~certfile ~keyfile ~pass ~port
351 callback =
352 match !tls_library with
353 | OpenSSL ->
354 serve_with_openssl ?timeout ?stop ~ctx ~certfile ~keyfile ~pass ~port
355 callback
356 | Native ->
357 serve_with_tls_native ?timeout ?stop ~ctx ~certfile ~keyfile ~pass ~port
358 callback
359 | No_tls -> failwith "No SSL or TLS support compiled into Conduit"
360
361 let serve ?backlog ?timeout ?stop ~on_exn ~(ctx : ctx) ~(mode : server) callback
362 =
363 let callback flow ic oc =
364 Lwt.catch
365 (fun () -> callback flow ic oc)
366 (fun exn ->
367 on_exn exn;
368 Lwt.return_unit)
369 in
370 match mode with
371 | `TCP (`Port port) ->
372 let sockaddr, _ = sockaddr_on_tcp_port ctx port in
373 Sockaddr_server.init ~on:(`Sockaddr sockaddr) ?backlog ?timeout ?stop
374 callback
375 | `TCP (`Socket s) ->
376 Sockaddr_server.init ~on:(`Socket s) ?backlog ?timeout ?stop callback
377 | `Unix_domain_socket (`File path) ->
378 let sockaddr = Unix.ADDR_UNIX path in
379 Sockaddr_server.init ~on:(`Sockaddr sockaddr) ?backlog ?timeout ?stop
380 callback
381 | `TLS (`Crt_file_path certfile, `Key_file_path keyfile, pass, `Port port) ->
382 serve_with_default_tls ?timeout ?stop ~ctx ~certfile ~keyfile ~pass ~port
383 callback
384 | `OpenSSL (`Crt_file_path certfile, `Key_file_path keyfile, pass, `Port port)
385 ->
386 serve_with_openssl ?timeout ?stop ~ctx ~certfile ~keyfile ~pass ~port
387 callback
388 | `TLS_native
389 (`Crt_file_path certfile, `Key_file_path keyfile, pass, `Port port) ->
390 serve_with_tls_native ?timeout ?stop ~ctx ~certfile ~keyfile ~pass ~port
391 callback
392 | `Vchan_direct _ -> Lwt.fail_with "Vchan_direct not implemented"
393 | `Vchan_domain_socket _uuid ->
394 Lwt.fail_with "Vchan_domain_socket not implemented"
395 | `Launchd name ->
396 let fn s = Sockaddr_server.init ~on:(`Socket s) ?timeout ?stop callback in
397 Conduit_lwt_launchd.activate fn name
398
399 let endp_of_flow = function
400 | TCP { ip; port; _ } -> `TCP (ip, port)
401 | Domain_socket { path; _ } -> `Unix_domain_socket path
402 | Vchan { domid; port } -> `Vchan_direct (domid, port)
403
404 (** Use the configuration of the server to interpret how to handle a particular
405 endpoint from the resolver into a concrete implementation of type [client] *)
406 let endp_to_client ~ctx:_ (endp : Conduit.endp) : client Lwt.t =
407 match endp with
408 | `TCP (ip, port) -> Lwt.return (`TCP (`IP ip, `Port port))
409 | `Unix_domain_socket file -> Lwt.return (`Unix_domain_socket (`File file))
410 | `Vchan_direct (domid, port) ->
411 Lwt.return (`Vchan_direct (`Domid domid, `Port port))
412 | `Vchan_domain_socket (name, port) ->
413 Lwt.return (`Vchan_domain_socket (`Domain_name name, `Port port))
414 | `TLS (host, `TCP (ip, port)) ->
415 Lwt.return (`TLS (`Hostname host, `IP ip, `Port port))
416 | `TLS (host, endp) ->
417 Lwt.fail_with
418 (Printf.sprintf "TLS to non-TCP currently unsupported: host=%s endp=%s"
419 host
420 (Sexplib.Sexp.to_string_hum (Conduit.sexp_of_endp endp)))
421 | `Unknown err -> Lwt.fail_with ("resolution failed: " ^ err)
422
423 let endp_to_server ~ctx (endp : Conduit.endp) =
424 match endp with
425 | `Unix_domain_socket path -> Lwt.return (`Unix_domain_socket (`File path))
426 | `TLS (_host, `TCP (_ip, port)) -> (
427 match ctx.tls_own_key with
428 | `None -> Lwt.fail_with "No TLS server key configured"
429 | `TLS (`Crt_file_path crt, `Key_file_path key, pass) ->
430 Lwt.return
431 (`TLS (`Crt_file_path crt, `Key_file_path key, pass, `Port port)))
432 | `TCP (_ip, port) -> Lwt.return (`TCP (`Port port))
433 | `Vchan_direct _ as mode -> Lwt.return mode
434 | `Vchan_domain_socket _ as mode -> Lwt.return mode
435 | `TLS (_host, _) -> Lwt.fail_with "TLS to non-TCP currently unsupported"
436 | `Unknown err -> Lwt.fail_with ("resolution failed: " ^ err)
+224
-0
src/conduit-lwt-unix/conduit_lwt_unix.mli less more
0 (*
1 * Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
2 * Copyright (c) 2014 Hannes Mehnert <hannes@mehnert.org>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *
16 *)
17
18 (** Connection establishment using the {{:http://ocsigen.org/lwt/api/Lwt_unix}
19 Lwt_unix} library *)
20
21 (** {2 Core types} *)
22
23 type client_tls_config =
24 [ `Hostname of string ] * [ `IP of Ipaddr.t ] * [ `Port of int ]
25 [@@deriving sexp]
26 (** Configuration fragment for a TLS client connecting to a remote endpoint *)
27
28 type client =
29 [ `TLS of client_tls_config
30 | `TLS_native of client_tls_config
31 (** Force use of native OCaml TLS stack to connect.*)
32 | `OpenSSL of client_tls_config
33 (** Force use of Lwt OpenSSL bindings to connect. *)
34 | `TCP of [ `IP of Ipaddr.t ] * [ `Port of int ]
35 (** Use TCP to connect to the given [ip], [port] tuple. *)
36 | `Unix_domain_socket of [ `File of string ]
37 (** Use UNIX domain sockets to connect to a socket on the [path]. *)
38 | `Vchan_direct of [ `Domid of int ] * [ `Port of string ]
39 (** Connect to the remote VM on the [domid], [port] tuple. *)
40 | `Vchan_domain_socket of [ `Domain_name of string ] * [ `Port of string ]
41 (** Use the Vchan name resolution to connect *) ]
42 [@@deriving sexp]
43 (** Set of supported client connections that are supported by this module:
44
45 - [`TLS (`Hostname host, `IP ip, `Port port)]: Use OCaml-TLS or OpenSSL
46 (depending on CONDUIT_TLS) to connect to the given [host], [ip], [port]
47 tuple via TCP.
48 - [`TLS_native _]: Force use of native OCaml TLS stack to connect.
49 - [`OpenSSL _]: Force use of Lwt OpenSSL bindings to connect.
50 - [`TCP (`IP ip, `Port port)]: Use TCP to connect to the given [ip], [port]
51 tuple.
52 - [`Unix_domain_socket (`File path)]: Use UNIX domain sockets to connect to
53 a socket on the [path].
54 - [`Vchan_direct (`Domid domid, `Port port)]: Connect to the remote VM on
55 the [domid], [port] tuple.
56 - [`Vchan_domain_socket (`Domain_name domain, `Port port_name)]: Use the
57 Vchan name resolution to connect. *)
58
59 type server_tls_config =
60 [ `Crt_file_path of string ]
61 * [ `Key_file_path of string ]
62 * [ `Password of bool -> string | `No_password ]
63 * [ `Port of int ]
64 [@@deriving sexp]
65 (** Configuration fragment for a listening TLS server *)
66
67 type tcp_config =
68 [ `Port of int | `Socket of Lwt_unix.file_descr [@sexp.opaque] ]
69 [@@deriving sexp]
70 (** Set of ways to create TCP servers
71
72 - [`Port port]: Create a socket listening to provided port.
73 - [`Socket file_descr]: Use the provided file descriptor to create a server. *)
74
75 type server =
76 [ `TLS of server_tls_config
77 | `OpenSSL of server_tls_config
78 | `TLS_native of server_tls_config
79 | `TCP of tcp_config
80 | `Unix_domain_socket of [ `File of string ]
81 | `Vchan_direct of int * string
82 | `Vchan_domain_socket of string * string
83 | `Launchd of string ]
84 [@@deriving sexp]
85 (** Set of supported listening mechanisms that are supported by this module.
86
87 - [`TLS server_tls_config]: Use OCaml-TLS or OpenSSL (depending on
88 CONDUIT_TLS) to connect to the given [host], [ip], [port] tuple via TCP.
89 - [`TLS_native _]: Force use of native OCaml TLS stack to connect.
90 - [`OpenSSL _]: Force use of Lwt OpenSSL bindings to connect.
91 - [`TCP (`Port port)]: Listen on the specified TCPv4 port.
92 - [`Unix_domain_socket (`File path)]: Use UNIX domain sockets to listen on
93 the path.
94 - [`Vchan_direct (domid, port)]: Listen for the remote VM on the [domid],
95 [port] tuple.
96 - [`Vchan_domain_socket (domain, port_name)]: Use the Vchan name resolution
97 to listen
98 - [`Listening_socket fd]: Use the socket given, useful for inherited systemd
99 sockets.
100 - [`Launchd name]: uses MacOS X launchd to start the service, via the name
101 of the [Sockets] element within the service description plist file. See
102 the {{:http://mirage.github.io/ocaml-launchd/launchd/} ocaml-launchd}
103 documentation for more. *)
104
105 type 'a io = 'a Lwt.t
106 type ic = Lwt_io.input_channel
107 type oc = Lwt_io.output_channel
108
109 type tcp_flow = private {
110 fd : Lwt_unix.file_descr; [@sexp.opaque]
111 ip : Ipaddr.t;
112 port : int;
113 }
114 [@@deriving sexp_of]
115 (** [tcp_flow] contains the state of a single TCP connection. *)
116
117 type domain_flow = private {
118 fd : Lwt_unix.file_descr; [@sexp.opaque]
119 path : string;
120 }
121 [@@deriving sexp_of]
122 (** [domain_flow] contains the state of a single Unix domain socket connection. *)
123
124 type vchan_flow = private { domid : int; port : string } [@@deriving sexp_of]
125 (** [vchan_flow] contains the state of a single Vchan shared memory connection. *)
126
127 (** A [flow] contains the state of a single connection, over a specific
128 transport method. *)
129 type flow = private
130 | TCP of tcp_flow
131 | Domain_socket of domain_flow
132 | Vchan of vchan_flow
133 [@@deriving sexp_of]
134
135 type tls_own_key =
136 [ `None
137 | `TLS of
138 [ `Crt_file_path of string ]
139 * [ `Key_file_path of string ]
140 * [ `Password of bool -> string | `No_password ] ]
141 [@@deriving sexp]
142 (** Type describing where to locate a PEM key in the filesystem *)
143
144 (**/**)
145
146 type tls_server_key = tls_own_key [@@deriving sexp]
147
148 (**/**)
149
150 type ctx [@@deriving sexp_of]
151 (** State handler for an active conduit *)
152
153 (** {2 Connection and listening} *)
154
155 val default_ctx : ctx
156 (** Default context that listens on all source addresses with no TLS certificate
157 associated with the Conduit *)
158
159 val init :
160 ?src:string ->
161 ?tls_own_key:tls_own_key ->
162 ?tls_authenticator:Conduit_lwt_tls.X509.authenticator ->
163 unit ->
164 ctx io
165 (** [init ?src ?tls_own_key ()] will initialize a Unix conduit that binds to the
166 [src] interface if specified. If TLS server connections are used, then
167 [tls_server_key] must contain a valid certificate to be used to advertise a
168 TLS connection.
169
170 The certificate is validated using [tls_authenticator]. By default, the
171 validation is using the {{:https://github.com/mirage/ca-certs} OS trust
172 anchors}. *)
173
174 val connect : ctx:ctx -> client -> (flow * ic * oc) io
175 (** [connect ~ctx client] establishes an outgoing connection via the [ctx]
176 context to the endpoint described by [client] *)
177
178 val serve :
179 ?backlog:int ->
180 ?timeout:int ->
181 ?stop:unit io ->
182 on_exn:(exn -> unit) ->
183 ctx:ctx ->
184 mode:server ->
185 (flow -> ic -> oc -> unit io) ->
186 unit io
187 (** [serve ?backlog ?timeout ?stop ~on_exn ~ctx ~mode fn] establishes a
188 listening connection of type [mode], using the [ctx] context. The [stop]
189 thread will terminate the server if it ever becomes determined. Every
190 connection will be served in a new lightweight thread that is invoked via
191 the [fn] callback. The [fn] callback is passed the {!flow} representing the
192 client connection and the associated input {!ic} and output {!oc} channels.
193 If the callback raises an exception, it is passed to [on_exn]. *)
194
195 val set_max_active : int -> unit
196 (** [set_max_active nconn] sets the maximum number of active connections
197 accepted. When the limit is hit accept blocks until another server
198 connection is closed. *)
199
200 val endp_of_flow : flow -> Conduit.endp
201 (** [endp_of_flow flow] retrieves the original {!Conduit.endp} from the
202 established [flow] *)
203
204 val endp_to_client : ctx:ctx -> Conduit.endp -> client io
205 (** [endp_to_client ~ctx endp] converts an [endp] into a a concrete connection
206 mechanism of type [client] *)
207
208 val endp_to_server : ctx:ctx -> Conduit.endp -> server io
209 (** [endp_to_server ~ctx endp] converts an [endp] into a a concrete connection
210 mechanism of type [server] *)
211
212 (** {2 TLS library selection} *)
213
214 (** Currently selected method of using TLS for client and servers *)
215 type tls_lib =
216 | OpenSSL (** The [Lwt_ssl] bindings to the C OpenSSL library *)
217 | Native (** A pure OCaml TLS implementation *)
218 | No_tls (** No TLS implementation available, so any connections will fail *)
219
220 val tls_library : tls_lib ref
221 (** The default selection is to select {!OpenSSL}, {!Native} and {!No_tls} in
222 decreasing order of priority. The native OCaml stack can be forced by
223 setting the [CONDUIT_TLS] Unix environment variable to [native]. *)
+36
-0
src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.ml less more
0 (*
1 * Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 module Client = struct
18 let default_ctx = `Ssl_not_available
19 let create_ctx ?certfile:_ ?keyfile:_ ?password:_ () = default_ctx
20
21 let connect ?(ctx = default_ctx) ?src:_ ?hostname:_ _sa =
22 ignore ctx;
23 Lwt.fail_with "Ssl not available"
24 end
25
26 module Server = struct
27 let default_ctx = `Ssl_not_available
28
29 let init ?(ctx = default_ctx) ?backlog:_ ?password:_ ~certfile:_ ~keyfile:_
30 ?stop:_ ?timeout:_ _sa _cb =
31 ignore ctx;
32 Lwt.fail_with "Ssl not available"
33 end
34
35 let available = false
+60
-0
src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.mli less more
0 (*
1 * Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 (** TLS/SSL connections via {{:http://www.openssl.org} OpenSSL} C bindings *)
18
19 module Client : sig
20 val default_ctx : [ `Ssl_not_available ]
21
22 val create_ctx :
23 ?certfile:string ->
24 ?keyfile:string ->
25 ?password:(bool -> string) ->
26 unit ->
27 [ `Ssl_not_available ]
28
29 val connect :
30 ?ctx:[ `Ssl_not_available ] ->
31 ?src:Lwt_unix.sockaddr ->
32 ?hostname:string ->
33 Lwt_unix.sockaddr ->
34 (Lwt_unix.file_descr * Lwt_io.input_channel * Lwt_io.output_channel) Lwt.t
35 end
36
37 module Server : sig
38 val default_ctx : [ `Ssl_not_available ]
39
40 val init :
41 ?ctx:[ `Ssl_not_available ] ->
42 ?backlog:int ->
43 ?password:(bool -> string) ->
44 certfile:string ->
45 keyfile:string ->
46 ?stop:unit Lwt.t ->
47 ?timeout:int ->
48 Lwt_unix.sockaddr ->
49 (Lwt_unix.sockaddr ->
50 Lwt_unix.file_descr ->
51 Lwt_io.input_channel ->
52 Lwt_io.output_channel ->
53 unit Lwt.t) ->
54 unit Lwt.t
55 end
56
57 (**/**)
58
59 val available : bool
+99
-0
src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.ml less more
0 (*
1 * Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 open Lwt.Infix
18
19 let () = Ssl.init ()
20
21 let chans_of_fd sock =
22 let is_open = ref true in
23 let shutdown () =
24 if !is_open then Lwt_ssl.ssl_shutdown sock else Lwt.return_unit
25 in
26 let close () =
27 is_open := false;
28 Lwt_ssl.close sock
29 in
30 let oc =
31 Lwt_io.make ~mode:Lwt_io.output ~close:shutdown (Lwt_ssl.write_bytes sock)
32 in
33 let ic = Lwt_io.make ~mode:Lwt_io.input ~close (Lwt_ssl.read_bytes sock) in
34 (Lwt_ssl.get_fd sock, ic, oc)
35
36 module Client = struct
37 let create_ctx ?certfile ?keyfile ?password () =
38 let ctx = Ssl.create_context Ssl.SSLv23 Ssl.Client_context in
39 Ssl.disable_protocols ctx [ Ssl.SSLv23 ];
40 (* Use default CA certificates *)
41 ignore (Ssl.set_default_verify_paths ctx);
42 (* Enable peer verification *)
43 Ssl.set_verify ctx [ Ssl.Verify_peer ] None;
44 (match (certfile, keyfile) with
45 | Some certfile, Some keyfile -> Ssl.use_certificate ctx certfile keyfile
46 | None, _ | _, None -> ());
47 (match password with
48 | Some password -> Ssl.set_password_callback ctx password
49 | None -> ());
50 ctx
51
52 let default_ctx = create_ctx ()
53
54 let connect ?(ctx = default_ctx) ?src ?hostname sa =
55 Conduit_lwt_server.with_socket sa (fun fd ->
56 (match src with
57 | None -> Lwt.return_unit
58 | Some src_sa -> Lwt_unix.bind fd src_sa)
59 >>= fun () ->
60 Lwt_unix.connect fd sa >>= fun () ->
61 (match hostname with
62 | Some host ->
63 let s = Lwt_ssl.embed_uninitialized_socket fd ctx in
64 let ssl = Lwt_ssl.ssl_socket_of_uninitialized_socket s in
65 Ssl.set_client_SNI_hostname ssl host;
66 (* Enable hostname verification *)
67 Ssl.set_hostflags ssl [ Ssl.No_partial_wildcards ];
68 Ssl.set_host ssl host;
69 Lwt_ssl.ssl_perform_handshake s
70 | None -> Lwt_ssl.ssl_connect fd ctx)
71 >>= fun sock -> Lwt.return (chans_of_fd sock))
72 end
73
74 module Server = struct
75 let default_ctx = Ssl.create_context Ssl.SSLv23 Ssl.Server_context
76 let () = Ssl.disable_protocols default_ctx [ Ssl.SSLv23 ]
77
78 let listen ?(ctx = default_ctx) ?backlog ?password ~certfile ~keyfile sa =
79 let fd = Conduit_lwt_server.listen ?backlog sa in
80 (match password with
81 | None -> ()
82 | Some fn -> Ssl.set_password_callback ctx fn);
83 Ssl.use_certificate ctx certfile keyfile;
84 fd
85
86 let init ?(ctx = default_ctx) ?backlog ?password ~certfile ~keyfile ?stop
87 ?timeout sa cb =
88 sa
89 |> listen ~ctx ?backlog ?password ~certfile ~keyfile
90 >>= Conduit_lwt_server.init ?stop (fun (fd, addr) ->
91 Lwt.try_bind
92 (fun () -> Lwt_ssl.ssl_accept fd ctx)
93 (fun sock -> Lwt.return (chans_of_fd sock))
94 (fun exn -> Lwt_unix.close fd >>= fun () -> Lwt.fail exn)
95 >>= Conduit_lwt_server.process_accept ?timeout (cb addr))
96 end
97
98 let available = true
+60
-0
src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.mli less more
0 (*
1 * Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 (** TLS/SSL connections via {{:http://www.openssl.org} OpenSSL} C bindings *)
18
19 module Client : sig
20 val default_ctx : Ssl.context
21
22 val create_ctx :
23 ?certfile:string ->
24 ?keyfile:string ->
25 ?password:(bool -> string) ->
26 unit ->
27 Ssl.context
28
29 val connect :
30 ?ctx:Ssl.context ->
31 ?src:Lwt_unix.sockaddr ->
32 ?hostname:string ->
33 Lwt_unix.sockaddr ->
34 (Lwt_unix.file_descr * Lwt_io.input_channel * Lwt_io.output_channel) Lwt.t
35 end
36
37 module Server : sig
38 val default_ctx : Ssl.context
39
40 val init :
41 ?ctx:Ssl.context ->
42 ?backlog:int ->
43 ?password:(bool -> string) ->
44 certfile:string ->
45 keyfile:string ->
46 ?stop:unit Lwt.t ->
47 ?timeout:int ->
48 Lwt_unix.sockaddr ->
49 (Lwt_unix.sockaddr ->
50 Lwt_unix.file_descr ->
51 Lwt_io.input_channel ->
52 Lwt_io.output_channel ->
53 unit Lwt.t) ->
54 unit Lwt.t
55 end
56
57 (**/**)
58
59 val available : bool
+40
-0
src/conduit-lwt-unix/dune less more
0 (library
1 (name conduit_lwt_unix)
2 (public_name conduit-lwt-unix)
3 (preprocess
4 (pps ppx_sexp_conv))
5 (wrapped false)
6 (modules resolver_lwt_unix conduit_lwt_unix conduit_lwt_server
7 conduit_lwt_tls conduit_lwt_unix_ssl conduit_lwt_launchd)
8 (libraries
9 conduit-lwt
10 lwt.unix
11 uri.services
12 ipaddr-sexp
13 ipaddr.unix
14 logs
15 (select
16 conduit_lwt_launchd.ml
17 from
18 (launchd.lwt -> conduit_lwt_launchd.real.ml)
19 (-> conduit_lwt_launchd.dummy.ml))
20 (select
21 conduit_lwt_unix_ssl.ml
22 from
23 (lwt_ssl -> conduit_lwt_unix_ssl.real.ml)
24 (-> conduit_lwt_unix_ssl.dummy.ml))
25 (select
26 conduit_lwt_unix_ssl.mli
27 from
28 (lwt_ssl -> conduit_lwt_unix_ssl.real.mli)
29 (-> conduit_lwt_unix_ssl.dummy.mli))
30 (select
31 conduit_lwt_tls.ml
32 from
33 (tls.lwt ca-certs -> conduit_lwt_tls.real.ml)
34 (-> conduit_lwt_tls.dummy.ml))
35 (select
36 conduit_lwt_tls.mli
37 from
38 (tls.lwt ca-certs -> conduit_lwt_tls.real.mli)
39 (-> conduit_lwt_tls.dummy.mli))))
+103
-0
src/conduit-lwt-unix/resolver_lwt_unix.ml less more
0 (*
1 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 open Lwt.Infix
18
19 let debug = ref false
20 let debug_print = ref Printf.eprintf
21
22 let () =
23 try
24 ignore (Sys.getenv "CONDUIT_DEBUG");
25 debug := true
26 with Not_found -> ()
27
28 let return_endp name svc uri endp =
29 if !debug then
30 !debug_print "Resolver %s: %s %s -> %s\n%!" name (Uri.to_string uri)
31 (Sexplib.Sexp.to_string_hum (Resolver.sexp_of_service svc))
32 (Sexplib.Sexp.to_string_hum (Conduit.sexp_of_endp endp));
33 Lwt.return endp
34
35 let is_tls_service =
36 (* TODO fill in the blanks. nowhere else to get this information *)
37 function
38 | "https" | "imaps" -> true
39 | _ -> false
40
41 let system_service name =
42 (* TODO memoize *)
43 Lwt.catch
44 (fun () ->
45 Lwt_unix.getservbyname name "tcp" >>= fun s ->
46 let tls = is_tls_service name in
47 let svc = { Resolver.name; port = s.Lwt_unix.s_port; tls } in
48 Lwt.return (Some svc))
49 (function Not_found -> Lwt.return_none | e -> Lwt.fail e)
50
51 let static_service name =
52 match Uri_services.tcp_port_of_service name with
53 | [] -> Lwt.return_none
54 | port :: _ ->
55 let tls = is_tls_service name in
56 let svc = { Resolver.name; port; tls } in
57 Lwt.return (Some svc)
58
59 let get_host uri =
60 match Uri.host uri with
61 | None -> "localhost"
62 | Some host -> (
63 match Ipaddr.of_string host with
64 | Ok ip -> Ipaddr.to_string ip
65 | Error _ -> host)
66
67 let get_port service uri =
68 match Uri.port uri with None -> service.Resolver.port | Some port -> port
69
70 (* Build a default resolver that uses the system gethostbyname and
71 the /etc/services file *)
72 let system_resolver service uri =
73 let open Lwt_unix in
74 let host = get_host uri in
75 let port = get_port service uri in
76 getaddrinfo host (string_of_int port) [ AI_SOCKTYPE SOCK_STREAM ]
77 >>= fun addrinfos ->
78 (* In case both IPv4 and IPv6 addresses exist, favor IPv4: *)
79 let v4, rest = List.partition (fun i -> i.ai_family = PF_INET) addrinfos in
80 match List.rev_append v4 rest with
81 | [] -> return_endp "system" service uri (`Unknown "name resolution failed")
82 | { ai_addr = ADDR_INET (addr, port); _ } :: _ ->
83 return_endp "system" service uri
84 (`TCP (Ipaddr_unix.of_inet_addr addr, port))
85 | { ai_addr = ADDR_UNIX file; _ } :: _ ->
86 return_endp "system" service uri (`Unix_domain_socket file)
87
88 let static_resolver hosts service uri =
89 try return_endp "static" service uri (Hashtbl.find hosts (get_host uri))
90 with Not_found ->
91 return_endp "static" service uri (`Unknown "name resolution failed")
92
93 let system =
94 let service = system_service in
95 let rewrites = [ ("", system_resolver) ] in
96 Resolver_lwt.init ~service ~rewrites ()
97
98 (* Build a default resolver from a static set of lookup rules *)
99 let static hosts =
100 let service = static_service in
101 let rewrites = [ ("", static_resolver hosts) ] in
102 Resolver_lwt.init ~service ~rewrites ()
+61
-0
src/conduit-lwt-unix/resolver_lwt_unix.mli less more
0 (*
1 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 (** Resolve URIs to endpoints using Unix system calls *)
18
19 (** {2 Prebuilt resolvers} *)
20
21 val system : Resolver_lwt.t
22 (** Use the Unix system name resolver via [getaddrinfo] and [getservbyname] *)
23
24 val static : (string, Conduit.endp) Hashtbl.t -> Resolver_lwt.t
25 (** [static hosts] constructs a resolver that looks up any resolution requests
26 from the static [hosts] hashtable instead of using the system resolver. *)
27
28 (** {2 Rewrite and service functions}
29
30 These can be used to assemble your own resolvers if the prebuilt ones are
31 not quite what you need. *)
32
33 val system_service : string -> Resolver_lwt.svc option Lwt.t
34 (** Perform service lookup using [getservbyname] *)
35
36 val static_service : string -> Resolver_lwt.svc option Lwt.t
37 (** Perform service lookup using the builtin {!Uri_services} module *)
38
39 val system_resolver : Resolver_lwt.rewrite_fn
40 (** Rewrite function that uses the {!system_service} and {!static_service} to
41 resolve hosts *)
42
43 (** {2 Debugging Hooks} *)
44
45 val debug : bool ref
46 (** If [debug] is true, the builtin resolvers will output their resolution
47 responses via the {!debug_print} function. The default value of [debug] is
48 true if the [CONDUIT_DEBUG] environment variable is set, and false
49 otherwise. *)
50
51 val debug_print :
52 ((string -> string -> string -> string -> unit, out_channel, unit) format ->
53 string ->
54 string ->
55 string ->
56 string ->
57 unit)
58 ref
59 (** [debug_print] is called by the {!debug} functions to output the results of
60 resolution. Defaults to {!Printf.eprintf} to go to the standard error. *)
+248
-0
src/conduit-mirage/conduit_mirage.ml less more
0 (*
1 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
2 * Copyright (c) 2015 Thomas Gazagnaire <thomas@gazagnaire.org>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *
16 *)
17
18 open Sexplib.Conv
19
20 let ( >>= ) = Lwt.( >>= )
21 let ( >|= ) = Lwt.( >|= )
22 let fail fmt = Fmt.kstrf (fun s -> Lwt.fail (Failure s)) fmt
23 let err_tcp_not_supported = fail "%s: TCP is not supported"
24 let err_tls_not_supported = fail "%s: TLS is not supported"
25
26 let err_domain_sockets_not_supported =
27 fail "%s: Unix domain sockets are not supported inside Unikernels"
28
29 let err_vchan_not_supported = fail "%s: VCHAN is not supported"
30 let err_unknown = fail "%s: unknown endpoint type"
31
32 let err_not_supported = function
33 | `TLS _ -> err_tls_not_supported
34 | `TCP _ -> err_tcp_not_supported
35 | `Vchan _ -> err_vchan_not_supported
36
37 type client =
38 [ `TCP of Ipaddr_sexp.t * int
39 | `TLS of Tls.Config.client * client
40 | `Vchan of
41 [ `Direct of int * Vchan.Port.t | `Domain_socket of string * Vchan.Port.t ]
42 ]
43 [@@deriving sexp]
44
45 type server =
46 [ `TCP of int
47 | `TLS of Tls.Config.server * server
48 | `Vchan of [ `Direct of int * Vchan.Port.t | `Domain_socket ] ]
49 [@@deriving sexp]
50
51 module type S = sig
52 type t
53 type flow
54
55 module Flow : Mirage_flow.S with type flow = flow
56
57 val connect : t -> client -> flow Lwt.t
58 val listen : t -> server -> (flow -> unit Lwt.t) -> unit Lwt.t
59 end
60
61 (* TCP *)
62 let tcp_client i p = Lwt.return (`TCP (i, p))
63 let tcp_server _ p = Lwt.return (`TCP p)
64
65 module TCP (S : Mirage_stack.V4V6) = struct
66 module Flow = S.TCP
67
68 type flow = Flow.flow
69 type t = S.t
70
71 let err_tcp e =
72 Lwt.fail
73 @@ Failure (Format.asprintf "TCP connection failed: %a" S.TCP.pp_error e)
74
75 let connect (t : t) (c : client) =
76 match c with
77 | `TCP (ip, port) -> (
78 S.TCP.create_connection (S.tcp t) (ip, port) >>= function
79 | Error e -> err_tcp e
80 | Ok flow -> Lwt.return flow)
81 | _ -> err_not_supported c "connect"
82
83 let listen (t : t) (s : server) fn =
84 match s with
85 | `TCP port ->
86 let s, _u = Lwt.task () in
87 S.listen_tcp t ~port (fun flow -> fn flow);
88 s
89 | _ -> err_not_supported s "listen"
90 end
91
92 (* VCHAN *)
93
94 let err_vchan_port = fail "%s: invalid Vchan port"
95
96 let port p =
97 match Vchan.Port.of_string p with
98 | Error (`Msg s) -> err_vchan_port s
99 | Ok p -> Lwt.return p
100
101 let vchan_client = function
102 | `Vchan_direct (i, p) -> port p >|= fun p -> `Vchan (`Direct (i, p))
103 | `Vchan_domain_socket (i, p) ->
104 port p >|= fun p -> `Vchan (`Domain_socket (i, p))
105
106 let vchan_server = function
107 | `Vchan_direct (i, p) -> port p >|= fun p -> `Vchan (`Direct (i, p))
108 | `Vchan_domain_socket _ -> Lwt.return (`Vchan `Domain_socket)
109
110 module Vchan
111 (Xs : Xs_client_lwt.S)
112 (V : Vchan.S.ENDPOINT with type port = Vchan.Port.t) =
113 struct
114 module Flow = V
115 module XS = Conduit_xenstore.Make (Xs)
116
117 type flow = Flow.flow
118 type t = XS.t
119
120 let register = XS.register
121
122 let rec connect (t : t) (c : client) =
123 match c with
124 | `Vchan (`Domain_socket (uid, port)) ->
125 XS.connect t ~remote_name:uid ~port >>= fun endp ->
126 connect t (`Vchan endp :> client)
127 | `Vchan (`Direct (domid, port)) -> V.client ~domid ~port ()
128 | _ -> err_not_supported c "connect"
129
130 let listen (t : t) (s : server) fn =
131 match s with
132 | `Vchan (`Direct (domid, port)) -> V.server ~domid ~port () >>= fn
133 | `Vchan `Domain_socket ->
134 XS.listen t >>= fun conns ->
135 Lwt_stream.iter_p
136 (function `Direct (domid, port) -> V.server ~domid ~port () >>= fn)
137 conns
138 | _ -> err_not_supported s "listen"
139 end
140
141 (* TLS *)
142
143 let tls_client ~authenticator x = `TLS (Tls.Config.client ~authenticator (), x)
144 let tls_server ?authenticator x = `TLS (Tls.Config.server ?authenticator (), x)
145
146 module TLS (S : S) = struct
147 module TLS = Tls_mirage.Make (S.Flow)
148
149 type flow = TLS of TLS.flow | Clear of S.flow
150 type t = S.t
151
152 module Flow = struct
153 type nonrec flow = flow
154 type error = [ `Flow of S.Flow.error | `TLS of TLS.error ]
155
156 type write_error =
157 [ Mirage_flow.write_error
158 | `Flow of S.Flow.write_error
159 | `TLS of TLS.write_error ]
160
161 let pp_error ppf = function
162 | `Flow e -> S.Flow.pp_error ppf e
163 | `TLS e -> TLS.pp_error ppf e
164
165 let pp_write_error ppf = function
166 | #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e
167 | `Flow e -> S.Flow.pp_write_error ppf e
168 | `TLS e -> TLS.pp_write_error ppf e
169
170 let tls_err = function Ok _ as x -> x | Error e -> Error (`TLS e)
171 let flow_err = function Ok _ as x -> x | Error e -> Error (`Flow e)
172
173 let tls_write_err = function
174 | Ok _ as x -> x
175 | Error `Closed as x -> x
176 | Error e -> Error (`TLS e)
177
178 let flow_write_err = function
179 | Ok _ as x -> x
180 | Error `Closed as x -> x
181 | Error e -> Error (`Flow e)
182
183 let read = function
184 | TLS f -> TLS.read f >|= tls_err
185 | Clear f -> S.Flow.read f >|= flow_err
186
187 let write t x =
188 match t with
189 | TLS f -> TLS.write f x >|= tls_write_err
190 | Clear f -> S.Flow.write f x >|= flow_write_err
191
192 let writev t x =
193 match t with
194 | TLS f -> TLS.writev f x >|= tls_err
195 | Clear f -> S.Flow.writev f x >|= flow_err
196
197 let close = function TLS f -> TLS.close f | Clear f -> S.Flow.close f
198 end
199
200 let err_flow_write m e = fail "%s: %a" m TLS.pp_write_error e
201
202 let connect (t : t) (c : client) =
203 match c with
204 | `TLS (c, x) -> (
205 S.connect t x >>= fun flow ->
206 TLS.client_of_flow c flow >>= function
207 | Error e -> err_flow_write "connect" e
208 | Ok flow -> Lwt.return (TLS flow))
209 | _ -> S.connect t c >|= fun t -> Clear t
210
211 let listen (t : t) (s : server) fn =
212 match s with
213 | `TLS (c, x) ->
214 S.listen t x (fun flow ->
215 TLS.server_of_flow c flow >>= function
216 | Error e -> err_flow_write "listen" e
217 | Ok flow -> fn (TLS flow))
218 | _ -> S.listen t s (fun f -> fn (Clear f))
219 end
220
221 module Endpoint (P : Mirage_clock.PCLOCK) = struct
222 module Ca_certs = Ca_certs_nss.Make (P)
223
224 let nss_authenticator =
225 match Ca_certs.authenticator () with
226 | Ok a -> a
227 | Error (`Msg msg) -> failwith msg
228
229 let rec client ?(tls_authenticator = nss_authenticator) e =
230 match e with
231 | `TCP (x, y) -> tcp_client x y
232 | `Unix_domain_socket _ -> err_domain_sockets_not_supported "client"
233 | (`Vchan_direct _ | `Vchan_domain_socket _) as x -> vchan_client x
234 | `TLS (_host, y) ->
235 client ~tls_authenticator y
236 >|= tls_client ~authenticator:tls_authenticator
237 | `Unknown s -> err_unknown s
238
239 let rec server ?tls_authenticator e =
240 match e with
241 | `TCP (x, y) -> tcp_server x y
242 | `Unix_domain_socket _ -> err_domain_sockets_not_supported "server"
243 | (`Vchan_direct _ | `Vchan_domain_socket _) as x -> vchan_server x
244 | `TLS (_host, y) ->
245 server y >|= tls_server ?authenticator:tls_authenticator
246 | `Unknown s -> err_unknown s
247 end
+101
-0
src/conduit-mirage/conduit_mirage.mli less more
0 (*
1 * Copyright (c) 2012-2015 Anil Madhavapeddy <anil@recoil.org>
2 * Copyright (c) 2015 Thomas Gazagnaire <thomas@gazagnaire.org>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *
16 *)
17
18 (** Functorial connection establishment interface that is compatible with the
19 Mirage libraries. *)
20
21 type client =
22 [ `TCP of Ipaddr.t * int (** address and destination port *)
23 | `TLS of Tls.Config.client * client
24 | `Vchan of
25 [ `Direct of int * Vchan.Port.t (** domain id, port *)
26 | `Domain_socket of string * Vchan.Port.t (** Vchan Xen domain socket *)
27 ] ]
28 [@@deriving sexp]
29 (** The type for client configuration values. *)
30
31 type server =
32 [ `TCP of int (** listening port *)
33 | `TLS of Tls.Config.server * server
34 | `Vchan of
35 [ `Direct of int * Vchan.Port.t (** domain id, port *)
36 | `Domain_socket (** Vchan Xen domain socket *) ] ]
37 [@@deriving sexp]
38 (** The type for server configuration values. *)
39
40 module Endpoint (P : Mirage_clock.PCLOCK) : sig
41 val nss_authenticator : X509.Authenticator.t
42 (** [nss_authenticator] is the validator using the
43 {{:https://github.com/mirage/ca-certs-nss} trust anchors extracted from
44 Mozilla's NSS}. *)
45
46 val client :
47 ?tls_authenticator:X509.Authenticator.t -> Conduit.endp -> client Lwt.t
48 (** [client] resolves a conduit endpoint into a client configuration.
49
50 The certificate is validated using [tls_authenticator]. By default, it is
51 [nss_authenticator] *)
52
53 val server :
54 ?tls_authenticator:X509.Authenticator.t -> Conduit.endp -> server Lwt.t
55 (** [server] resolves a confuit endpoint into a server configuration.
56
57 Clent certificates are validated using [tls_authenticator]. *)
58 end
59
60 module type S = sig
61 (** The signature for conduits *)
62
63 type flow
64 (** The type for networking flows. *)
65
66 type t
67 (** The type for handlers. *)
68
69 module Flow : Mirage_flow.S with type flow = flow
70 (** The type for flows. *)
71
72 val connect : t -> client -> flow Lwt.t
73 (** Connect a conduit using client configuration. *)
74
75 val listen : t -> server -> (flow -> unit Lwt.t) -> unit Lwt.t
76 (** Listen to a conduit using a server configuration. *)
77 end
78
79 (** {2 TCP} *)
80
81 module TCP (S : Mirage_stack.V4V6) :
82 S with type t = S.t and type flow = S.TCP.flow
83
84 (** {2 VCHAN} *)
85
86 module Vchan
87 (X : Xs_client_lwt.S)
88 (V : Vchan.S.ENDPOINT with type port = Vchan.Port.t) : sig
89 include S
90
91 val register : string -> t Lwt.t
92 end
93
94 (** {2 TLS} *)
95
96 module TLS (S : S) : sig
97 type flow = TLS of Tls_mirage.Make(S.Flow).flow | Clear of S.flow
98
99 include S with type t = S.t and type flow := flow
100 end
+98
-0
src/conduit-mirage/conduit_xenstore.ml less more
0 (*
1 * Copyright (c) 2014-2015 Anil Madhavapeddy <anil@recoil.org>
2 * Copyright (c) 2015 Thomas Gazagnaire <thomas@gazagnaire.org>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *
16 *)
17
18 open Sexplib.Conv
19
20 type direct = [ `Direct of int * Vchan.Port.t ]
21
22 let ( >>= ) = Lwt.( >>= )
23 let ( / ) = Filename.concat
24 let fail fmt = Printf.ksprintf (fun m -> Lwt.fail (Failure m)) fmt
25 let err_peer_not_found = fail "Conduit_xenstore: %s peer not found"
26
27 let err_no_entry_found () =
28 fail "No /conduit Xenstore entry found. Run `xenstore-conduit-init`"
29
30 let err_port = fail "%s: invalid port"
31
32 module Make (Xs : Xs_client_lwt.S) = struct
33 type t = { xs : (Xs.client[@sexp.opaque]); name : string }
34 [@@deriving sexp_of]
35
36 let get_my_id xs = Xs.(immediate xs (fun h -> read h "domid"))
37
38 let xenstore_register xs myname =
39 get_my_id xs >>= fun domid ->
40 Xs.(immediate xs (fun h -> write h ("/conduit" / myname) domid))
41
42 let get_peer_id xs name =
43 Lwt.catch
44 (fun () -> Xs.(immediate xs (fun h -> read h ("/conduit" / name))))
45 (fun _ -> err_peer_not_found name)
46
47 let readdir h d =
48 Xs.(directory h d) >>= fun dirs ->
49 let dirs = List.filter (fun p -> p <> "") dirs in
50 match dirs with
51 | [] -> Lwt.fail Xs_protocol.Eagain
52 | hd :: _ -> Lwt.return hd
53
54 let register name =
55 Xs.make () >>= fun xs ->
56 (* Check that a /conduit directory exists *)
57 Lwt.catch
58 (fun () ->
59 Xs.(immediate xs (fun h -> read h "/conduit")) >>= fun _ ->
60 Lwt.return_unit)
61 (fun _ -> err_no_entry_found ())
62 >>= fun () ->
63 xenstore_register xs name >>= fun () -> Lwt.return { xs; name }
64
65 let accept { xs; name } =
66 let waitfn h =
67 readdir h ("/conduit" / name) >>= fun remote_name ->
68 readdir h ("/conduit" / name / remote_name) >>= fun port ->
69 Xs.read h ("/conduit" / remote_name) >>= fun remote_domid ->
70 let remote_domid = int_of_string remote_domid in
71 Xs.rm h ("/conduit" / name / remote_name) >>= fun () ->
72 match Vchan.Port.of_string port with
73 | Error (`Msg e) -> err_port e
74 | Ok port -> Lwt.return (`Direct (remote_domid, port))
75 in
76 Xs.wait xs waitfn
77
78 let listen ({ name; _ } as v) =
79 (* TODO cancellation *)
80 let conn, push_conn = Lwt_stream.create () in
81 Printf.printf "Conduit_xenstore: listen on %s\n%!" name;
82 let rec loop () =
83 accept v >>= fun c ->
84 push_conn (Some c);
85 loop ()
86 in
87 Lwt.ignore_result (loop ());
88 Lwt.return conn
89
90 let connect { xs; name } ~remote_name ~port =
91 let port_str = Vchan.Port.to_string port in
92 get_peer_id xs remote_name >>= fun remote_domid ->
93 let remote_domid = int_of_string remote_domid in
94 let path = "/conduit" / remote_name / name / port_str in
95 Xs.(immediate xs (fun h -> write h path port_str)) >>= fun () ->
96 Lwt.return (`Direct (remote_domid, port))
97 end
+28
-0
src/conduit-mirage/conduit_xenstore.mli less more
0 (*
1 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 (** Establish Vchans via named endpoints in XenStore *)
18
19 type direct = [ `Direct of int * Vchan.Port.t ]
20
21 module Make (Xs : Xs_client_lwt.S) : sig
22 type t
23
24 val register : string -> t Lwt.t
25 val listen : t -> direct Lwt_stream.t Lwt.t
26 val connect : t -> remote_name:string -> port:Vchan.Port.t -> direct Lwt.t
27 end
+10
-0
src/conduit-mirage/dune less more
0 (library
1 (name conduit_mirage)
2 (public_name conduit-mirage)
3 (preprocess
4 (pps ppx_sexp_conv))
5 (modules conduit_mirage resolver_mirage conduit_xenstore)
6 (wrapped false)
7 (libraries conduit conduit-lwt mirage-stack mirage-clock mirage-random
8 mirage-time mirage-flow mirage-flow-combinators dns-client.mirage
9 ipaddr-sexp vchan tls tls-mirage xenstore.client uri.services ca-certs-nss))
+133
-0
src/conduit-mirage/resolver_mirage.ml less more
0 (*
1 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 open Lwt.Infix
18
19 module type S = sig
20 include Resolver_lwt.S
21
22 val static : (string, port:int -> Conduit.endp) Hashtbl.t -> t
23 val localhost : t
24 end
25
26 module Make
27 (R : Mirage_random.S)
28 (T : Mirage_time.S)
29 (C : Mirage_clock.MCLOCK)
30 (S : Mirage_stack.V4V6) =
31 struct
32 include Resolver_lwt
33
34 let is_tls_service =
35 (* TODO fill in the blanks. nowhere else to get this information *)
36 function
37 | "https" | "imaps" -> true
38 | _ -> false
39
40 let get_host uri =
41 match Uri.host uri with
42 | None -> "localhost"
43 | Some host -> (
44 match Ipaddr.of_string host with
45 | Ok ip -> Ipaddr.to_string ip
46 | Error _ -> host)
47
48 let get_port service uri =
49 match Uri.port uri with None -> service.Resolver.port | Some port -> port
50
51 let static_resolver hosts service uri =
52 let port = get_port service uri in
53 try
54 let fn = Hashtbl.find hosts (get_host uri) in
55 Lwt.return (fn ~port)
56 with Not_found -> Lwt.return (`Unknown "name resolution failed")
57
58 let static_service name =
59 match Uri_services.tcp_port_of_service name with
60 | [] -> Lwt.return_none
61 | port :: _ ->
62 let tls = is_tls_service name in
63 let svc = { Resolver.name; port; tls } in
64 Lwt.return (Some svc)
65
66 let static hosts =
67 let service = static_service in
68 let rewrites = [ ("", static_resolver hosts) ] in
69 Resolver_lwt.init ~service ~rewrites ()
70
71 let localhost =
72 let hosts = Hashtbl.create 3 in
73 Hashtbl.add hosts "localhost" (fun ~port ->
74 `TCP (Ipaddr.(V4 V4.localhost), port));
75 static hosts
76
77 let vchan_resolver ~tld =
78 let tld_len = String.length tld in
79 let get_short_host uri =
80 let n = get_host uri in
81 let len = String.length n in
82 if len > tld_len && String.sub n (len - tld_len) tld_len = tld then
83 String.sub n 0 (len - tld_len)
84 else n
85 in
86 fun service uri ->
87 (* Strip the tld from the hostname *)
88 let remote_name = get_short_host uri in
89 Printf.printf "vchan_lookup: %s %s -> normalizes to %s\n%!"
90 (Sexplib.Sexp.to_string_hum (Resolver.sexp_of_service service))
91 (Uri.to_string uri) remote_name;
92 Lwt.return (`Vchan_domain_socket (remote_name, service.Resolver.name))
93
94 module DNS = Dns_client_mirage.Make (R) (T) (C) (S)
95
96 let dns_stub_resolver dns service uri : Conduit.endp Lwt.t =
97 let hostn = get_host uri in
98 let port = get_port service uri in
99 (match Ipaddr.V4.of_string hostn with
100 | Ok addr -> Lwt.return (Ok addr)
101 | Error _ -> (
102 match Domain_name.of_string hostn with
103 | Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
104 | Ok domain -> (
105 match Domain_name.host domain with
106 | Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
107 | Ok host -> DNS.gethostbyname dns host)))
108 >|= function
109 | Error (`Msg err) -> `Unknown ("name resolution failed: " ^ err)
110 | Ok addr -> `TCP (Ipaddr.V4 addr, port)
111
112 let register ?ns ?(ns_port = 53) s res =
113 (* DNS stub resolver *)
114 let nameserver =
115 match ns with None -> None | Some ip -> Some (`TCP, (ip, ns_port))
116 in
117 let dns = DNS.create ?nameserver s in
118 let f = dns_stub_resolver dns in
119 Resolver_lwt.add_rewrite ~host:"" ~f res;
120 let service = Resolver_lwt.(service res ++ static_service) in
121 Resolver_lwt.set_service ~f:service res;
122 let vchan_tld = ".xen" in
123 let vchan_res = vchan_resolver ~tld:vchan_tld in
124 Resolver_lwt.add_rewrite ~host:vchan_tld ~f:vchan_res res
125
126 let v ?ns ?ns_port stack =
127 let res = Resolver_lwt.init () in
128 register ?ns ?ns_port stack res;
129 res
130
131 type t = Resolver_lwt.t
132 end
+42
-0
src/conduit-mirage/resolver_mirage.mli less more
0 (*
1 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 (** Functorial interface for resolving URIs to endpoints. *)
18
19 module type S = sig
20 include Resolver_lwt.S
21
22 val static : (string, port:int -> Conduit.endp) Hashtbl.t -> t
23 (** [static hosts] constructs a resolver that looks up any resolution requests
24 from the static [hosts] hashtable instead of using the system resolver. *)
25
26 val localhost : t
27 (** [localhost] is a static resolver that has a single entry that maps
28 [localhost] to [127.0.0.1], and fails on all other hostnames. *)
29 end
30
31 (** Provides a DNS-enabled {!Resolver_lwt} given a network stack. *)
32 module Make
33 (R : Mirage_random.S)
34 (T : Mirage_time.S)
35 (C : Mirage_clock.MCLOCK)
36 (S : Mirage_stack.V4V6) : sig
37 include S
38
39 val v : ?ns:Ipaddr.t -> ?ns_port:int -> S.t -> t
40 (** [v ?ns ?ns_port ?stack ()] TODO *)
41 end
+3
-0
tests/conduit-async/build.sh less more
0 #!/bin/sh
1
2 corebuild -tag annot -pkgs conduit.async ssl_echo.native
+11
-0
tests/conduit-async/dune less more
0 (executable
1 (libraries async conduit-async)
2 (name ssl_echo))
3
4 (rule
5 (alias runtest)
6 (deps
7 (:echo ./ssl_echo.exe))
8 (package conduit-async)
9 (action
10 (run echo skip)))
+57
-0
tests/conduit-async/ssl_echo.ml less more
0 (*
1 * Copyright (c) 2015 Anil Madhavapeddy <anil@recoil.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *
15 *)
16
17 open Async
18
19 let handler _sock ic oc =
20 Reader.pipe ic |> fun rd ->
21 Writer.pipe oc |> fun wr -> Pipe.transfer_id rd wr
22
23 let determine_mode cert_file_path key_file_path =
24 (* Determines if the server runs in http or https *)
25 match (cert_file_path, key_file_path) with
26 | Some c, Some k -> `OpenSSL (`Crt_file_path c, `Key_file_path k)
27 | None, None -> `TCP
28 | _ -> failwith "Error: must specify both certificate and key for TLS"
29
30 let start_server port host cert_file key_file () =
31 let mode = determine_mode cert_file key_file in
32 let mode_str = match mode with `OpenSSL _ -> "OpenSSL" | `TCP -> "TCP" in
33 printf "Listening for %s requests on: %s %d\n%!" mode_str host port;
34 Unix.Inet_addr.of_string_or_getbyname host >>= fun host ->
35 let listen_on =
36 Tcp.Where_to_listen.create ~socket_type:Socket.Type.tcp
37 ~address:(`Inet (host, port))
38 ~listening_on:(fun _ -> port)
39 in
40 Conduit_async.serve ~on_handler_error:`Raise mode listen_on handler
41 >>= fun _ -> never ()
42
43 let () =
44 Command.async_spec ~summary:"Echo server over SSL"
45 Command.Spec.(
46 empty
47 +> flag "-p"
48 (optional_with_default 8080 int)
49 ~doc:"port TCP port to listen on"
50 +> flag "-s"
51 (optional_with_default "0.0.0.0" string)
52 ~doc:"address IP address to listen on"
53 +> flag "-cert-file" (optional string) ~doc:"file Certificate file"
54 +> flag "-key-file" (optional string) ~doc:"File Private key file")
55 start_server
56 |> Command.run
+3
-0
tests/conduit-lwt-unix/.gitignore less more
0 server.conf
1 server.key
2 server.pem
+106
-0
tests/conduit-lwt-unix/cdtest.ml less more
0 (*
1 * Copyright (c) 2016 Skylable Ltd. <info-copyright@skylable.com>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *)
15
16 open Lwt.Infix
17
18 let port =
19 Random.self_init ();
20 16_384 + Random.int 10_000
21
22 let config =
23 ( `Crt_file_path "server.pem",
24 `Key_file_path "server.key",
25 `No_password,
26 `Port port )
27
28 let rec repeat n f =
29 if n = 0 then Lwt.return_unit else f () >>= fun () -> repeat (n - 1) f
30
31 let skip _ = ()
32
33 let perform () =
34 let stop, do_stop = Lwt.wait () in
35 Conduit_lwt_unix.init ~src:"127.0.0.1" () >>= fun ctx ->
36 let _ =
37 Conduit_lwt_unix.serve ~stop ~ctx ~mode:(`TLS config) ~on_exn:skip
38 (fun _ ic oc ->
39 Lwt_io.read ic >>= fun _ ->
40 Lwt_io.write oc "foo" >>= fun () -> Lwt_io.flush oc)
41 in
42 let sa = Unix.ADDR_INET (Unix.inet_addr_loopback, port) in
43 let wait, wake = Lwt.task () in
44 let active = ref 0 in
45 let cond = Lwt_condition.create () in
46 let client_test_wait timeout wait =
47 (* connect using low-level operations to check what happens if client closes connection
48 without calling ssl_shutdown (e.g. TCP connection is lost) *)
49 let s = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
50 let ctx = Ssl.create_context Ssl.TLSv1_2 Ssl.Client_context in
51 Lwt_unix.with_timeout timeout (fun () ->
52 Lwt.finalize
53 (fun () ->
54 Lwt_unix.connect s sa >>= fun () ->
55 Lwt_ssl.ssl_connect s ctx >>= fun _ss ->
56 incr active;
57 Lwt_condition.signal cond ();
58 wait)
59 (fun () -> Lwt_unix.close s))
60 in
61 let client_test _ = client_test_wait 1. Lwt.return_unit in
62 let limit = 5 in
63
64 Conduit_lwt_unix.set_max_active limit;
65 (* when clients = max_active no more clients are allowed and some get errors,
66 * use a higher timeout here so that all these connections are still active
67 * when doing the 2nd test below *)
68 let t =
69 Array.init limit (fun _ -> client_test_wait 10. wait)
70 |> Array.to_list
71 |> Lwt.join
72 in
73 Lwt.catch
74 (fun () ->
75 (* wait for all 5 threads to connect *)
76 let rec wait_all_conn () =
77 Lwt_condition.wait cond >>= fun () ->
78 if !active < limit then wait_all_conn () else Lwt.return_unit
79 in
80 wait_all_conn () >>= fun () ->
81 print_endline "Waiting for error";
82 (* use a lower timeout here, these should fail immediately *)
83 Array.init (2 * limit) client_test |> Array.to_list |> Lwt.pick
84 >>= fun () ->
85 prerr_endline "Expected errors, but got none";
86 exit 2)
87 (fun _exn ->
88 print_endline "Waking up connections";
89 Lwt.wakeup wake ();
90 Lwt.catch (fun () -> t) (fun _ -> Lwt.return_unit) >>= fun () ->
91 print_endline "Opening more connections";
92 (* clients can connect again, handled in batches of 5 *)
93 Array.init 10 client_test |> Array.to_list |> Lwt.join)
94 >>= fun () ->
95 print_endline "Running single connection leak test";
96 repeat 1024 client_test >>= fun () ->
97 Lwt.wakeup do_stop ();
98 Lwt.return_unit
99
100 let () =
101 Lwt.async_exception_hook := ignore;
102 Sys.(set_signal sigpipe Signal_ignore);
103 Lwt_main.run
104 (Lwt_unix.with_timeout 60. (fun () -> Lwt_unix.handle_unix_error perform ()));
105 print_endline "OK"
+72
-0
tests/conduit-lwt-unix/cdtest_tls.ml less more
0 (*
1 * Copyright (c) 2016 Skylable Ltd. <info-copyright@skylable.com>
2 * Copyright (c) 2016 Vincent Bernardoff <vb@luminar.eu.org>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *)
16
17 open Lwt.Infix
18
19 let port =
20 Random.self_init ();
21 16_384 + Random.int 10_000
22
23 let config =
24 ( `Crt_file_path "server.pem",
25 `Key_file_path "server.key",
26 `No_password,
27 `Port port )
28
29 let rec repeat n f =
30 if n = 0 then Lwt.return_unit else f () >>= fun () -> repeat (n - 1) f
31
32 let skip _ = ()
33
34 let perform () =
35 let stop, do_stop = Lwt.wait () in
36 Conduit_lwt_unix.init ~src:"::1" () >>= fun ctx ->
37 let serve () =
38 Conduit_lwt_unix.serve ~stop ~ctx ~mode:(`TLS config) ~on_exn:skip
39 (fun _flow ic oc ->
40 Lwt_log.notice "Server: Callback started." >>= fun () ->
41 Lwt_io.read ~count:5 ic >>= fun msg ->
42 Lwt_log.notice_f "Server: read %s." msg >>= fun () ->
43 Lwt_io.write oc "foo")
44 in
45 let client_test () =
46 (* connect using low-level operations to check what happens if client closes connection
47 without calling ssl_shutdown (e.g. TCP connection is lost) *)
48 let client =
49 `TLS (`Hostname "", `IP Ipaddr.(V6 V6.localhost), `Port port)
50 in
51 Conduit_lwt_unix.(connect ~ctx:default_ctx client)
52 >>= fun (_flow, ic, oc) ->
53 Lwt_log.notice "Connected!" >>= fun () ->
54 Lwt_io.write oc "hello" >>= fun () ->
55 Lwt_log.notice "Written hello." >>= fun () ->
56 Lwt_io.read ic ~count:3 >>= fun msg ->
57 Lwt_log.notice_f "Got correct msg (%s), disconnecting." msg >>= fun () ->
58 Lwt_io.close ic
59 in
60 Lwt.async serve;
61 Lwt_unix.sleep 1. >>= fun () ->
62 Lwt_log.notice_f "Server running on port %d" port >>= fun () ->
63 repeat 10 client_test >>= fun () ->
64 Lwt.wakeup do_stop ();
65 Lwt.return_unit
66
67 let () =
68 Lwt.async_exception_hook := ignore;
69 Sys.(set_signal sigpipe Signal_ignore);
70 Lwt_main.run (Lwt_unix.handle_unix_error perform ());
71 print_endline "OK"
+10
-0
tests/conduit-lwt-unix/dune less more
0 (executables
1 (libraries lwt_ssl ssl conduit-lwt-unix lwt_log)
2 (names cdtest cdtest_tls exit_test))
3
4 (rule
5 (alias runtest)
6 (deps ./cdtest.exe ./cdtest_tls.exe ./exit_test.exe)
7 (package conduit-lwt-unix)
8 (action
9 (run echo skip)))
+42
-0
tests/conduit-lwt-unix/exit_test.ml less more
0 (*
1 * Copyright (c) 2016 Vincent Bernardoff <vb@luminar.eu.org>
2 *
3 * Permission to use, copy, modify, and distribute this software for any
4 * purpose with or without fee is hereby granted, provided that the above
5 * copyright notice and this permission notice appear in all copies.
6 *
7 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 *)
15
16 open Lwt.Infix
17
18 let skip _ = ()
19
20 let perform () =
21 let stop, do_stop = Lwt.wait () in
22 Conduit_lwt_unix.init ~src:"::1" () >>= fun ctx ->
23 let serve () =
24 let callback _flow ic oc =
25 Lwt_io.read ~count:5 ic >>= fun _msg -> Lwt_io.write oc "foo"
26 in
27 Conduit_lwt_unix.serve ~stop ~ctx
28 ~mode:(`TCP (`Port 8080))
29 ~on_exn:skip callback
30 in
31 let handle = serve () in
32 Lwt.async (fun () -> Lwt_unix.sleep 0.2 >|= Lwt.wakeup do_stop);
33 handle
34
35 let () =
36 Lwt.async_exception_hook := ignore;
37 let t_start = Unix.gettimeofday () in
38 Lwt_main.run (Lwt_unix.handle_unix_error perform ());
39 let t_end = Unix.gettimeofday () in
40 if t_end -. t_start > 0.15 then Printf.printf "OK %.3f\n" (t_end -. t_start)
41 else Printf.printf "FAILED %.3f (must be > 0.2)" (t_end -. t_start)
+29
-0
tests/conduit-lwt-unix/gen.sh less more
0 #!/bin/sh
1 set -e
2 set -o nounset
3 cat >server.conf <<EOF
4 [ req ]
5 default_bits = 2048
6 distinguished_name = req_distinguished_name
7 prompt = no
8 encrypt_key = no
9 x509_extensions = v3_ca
10
11 [ req_distinguished_name ]
12 CN = localhost
13
14 [ CA_default ]
15 copy_extensions = copy
16
17 [ alternate_names ]
18 DNS.2=localhost
19
20 [ v3_ca ]
21 subjectAltName=@alternate_names
22 subjectKeyIdentifier=hash
23 authorityKeyIdentifier=keyid:always,issuer:always
24 basicConstraints = critical,CA:true
25 keyUsage=keyCertSign,cRLSign,digitalSignature,keyEncipherment,nonRepudiation
26 EOF
27
28 openssl req -days 1 -x509 -config server.conf -new -keyout server.key -out server.pem
+22
-0
tests/conduit-lwt-unix/server.conf less more
0 [ req ]
1 default_bits = 2048
2 distinguished_name = req_distinguished_name
3 prompt = no
4 encrypt_key = no
5 x509_extensions = v3_ca
6
7 [ req_distinguished_name ]
8 CN = localhost
9
10 [ CA_default ]
11 copy_extensions = copy
12
13 [ alternate_names ]
14 DNS.2=localhost
15
16 [ v3_ca ]
17 subjectAltName=@alternate_names
18 subjectKeyIdentifier=hash
19 authorityKeyIdentifier=keyid:always,issuer:always
20 basicConstraints = critical,CA:true
21 keyUsage=keyCertSign,cRLSign,digitalSignature,keyEncipherment,nonRepudiation
+14
-0
tests/conduit-mirage/Makefile less more
0 all: http-server-unix http-fetch-unix vchan-client-xen vchan-server-xen
1 @
2
3 http-server-unix:
4 cd http-server && mirage configure -t unix && make
5
6 http-fetch-unix:
7 cd http-fetch && mirage configure -t unix && make
8
9 vchan-client-xen:
10 cd vchan && mirage configure -f config_client.ml -t xen && make
11
12 vchan-server-xen:
13 cd vchan && mirage configure -f config_server.ml -t xen && make
+8
-0
tests/conduit-mirage/http-fetch/.gitignore less more
0 Makefile
1 *.xe
2 *.xl
3 _build
4 main.ml
5 mir-conduit-client
6 log
7 *.xen
+14
-0
tests/conduit-mirage/http-fetch/config.ml less more
0 open Mirage
1
2 let client =
3 foreign ~deps:[ abstract nocrypto ] "Unikernel.Client"
4 @@ console
5 @-> stackv4
6 @-> job
7
8 let () =
9 register
10 ~libraries:[ "conduit.lwt"; "conduit.mirage"; "dns.mirage" ]
11 ~packages:[ "mirage-dns"; "conduit" ]
12 "conduit-client"
13 [ client $ default_console $ generic_stackv4 default_console tap0 ]
+40
-0
tests/conduit-mirage/http-fetch/unikernel.ml less more
0 open Lwt.Infix
1 open Mirage_types_lwt
2 open Printf
3
4 let red fmt = sprintf ("\027[31m" ^^ fmt ^^ "\027[m")
5 let green fmt = sprintf ("\027[32m" ^^ fmt ^^ "\027[m")
6 let yellow fmt = sprintf ("\027[33m" ^^ fmt ^^ "\027[m")
7 let blue fmt = sprintf ("\027[36m" ^^ fmt ^^ "\027[m")
8 let domain = "anil.recoil.org"
9 let uri = Uri.of_string "http://anil.recoil.org"
10 let ns = "8.8.8.8"
11
12 module Client (C : CONSOLE) (S : STACKV4) = struct
13 module DNS = Dns_resolver_mirage.Make (OS.Time) (S)
14 module RES = Resolver_mirage.Make (DNS)
15
16 let start c stack _ =
17 C.log_s c (sprintf "Resolving in 3s using DNS server %s" ns) >>= fun () ->
18 OS.Time.sleep 3.0 >>= fun () ->
19 let res = Resolver_lwt.init () in
20 RES.register ~ns:(Ipaddr.V4.of_string_exn ns) ~stack res;
21 Resolver_lwt.resolve_uri ~uri res >>= fun endp ->
22 mk_conduit stack >>= fun conduit ->
23 Conduit_mirage.client endp >>= fun client ->
24 let endp = Sexplib.Sexp.to_string_hum (Conduit.sexp_of_endp endp) in
25 C.log_s c endp >>= fun () ->
26 Conduit_mirage.connect conduit client >>= fun flow ->
27 let page = Io_page.(to_cstruct (get 1)) in
28 let http_get = "GET / HTTP/1.1\nHost: anil.recoil.org\n\n" in
29 Cstruct.blit_from_string http_get 0 page 0 (String.length http_get);
30 let buf = Cstruct.sub page 0 (String.length http_get) in
31 Conduit_mirage.Flow.write flow buf >>= function
32 | `Eof -> C.log_s c "EOF on write"
33 | `Error _ -> C.log_s c "ERR on write"
34 | `Ok buf -> (
35 Conduit_mirage.Flow.read flow >>= function
36 | `Eof -> C.log_s c "EOF"
37 | `Error _ -> C.log_s c "ERR"
38 | `Ok buf -> C.log_s c (sprintf "OK\n%s\n" (Cstruct.to_string buf)))
39 end
+8
-0
tests/conduit-mirage/http-server/.gitignore less more
0 Makefile
1 *.xe
2 *.xl
3 _build
4 main.ml
5 mir-http-server
6 log
7 *.xen
+13
-0
tests/conduit-mirage/http-server/config.ml less more
0 open Mirage
1
2 let client =
3 foreign ~deps:[ abstract nocrypto ] "Unikernel.Client"
4 @@ console
5 @-> stackv4
6 @-> job
7
8 let () =
9 register
10 ~libraries:[ "conduit.lwt"; "conduit.mirage"; "vchan" ]
11 "http-server"
12 [ client $ default_console $ generic_stackv4 default_console tap0 ]
+25
-0
tests/conduit-mirage/http-server/unikernel.ml less more
0 open Lwt.Infix
1 open Mirage_types_lwt
2 open Printf
3
4 let red fmt = sprintf ("\027[31m" ^^ fmt ^^ "\027[m")
5 let green fmt = sprintf ("\027[32m" ^^ fmt ^^ "\027[m")
6 let yellow fmt = sprintf ("\027[33m" ^^ fmt ^^ "\027[m")
7 let blue fmt = sprintf ("\027[36m" ^^ fmt ^^ "\027[m")
8 let uri = Uri.of_string "http://localhost"
9
10 module Client (C : CONSOLE) (S : STACKV4) = struct
11 let mk_conduit s =
12 let stackv4 = Conduit_mirage.stackv4 (module S) in
13 Conduit_mirage.with_tcp Conduit_mirage.empty stackv4 s
14
15 let callback c _flow = C.log_s c "Connection!"
16
17 let start c stack _ =
18 let r = Resolver_mirage.localhost in
19 mk_conduit stack >>= fun conduit ->
20 Resolver_lwt.resolve_uri ~uri r >>= fun endp ->
21 Conduit_mirage.server endp >>= fun mode ->
22 let endp = Sexplib.Sexp.to_string_hum (Conduit.sexp_of_endp endp) in
23 C.log_s c endp >>= fun () -> Conduit_mirage.listen conduit mode (callback c)
24 end
+4
-0
tests/conduit-mirage/simple/dune less more
0 (test
1 (name test)
2 (libraries conduit-mirage tcpip.stack-socket)
3 (package conduit-mirage))
+20
-0
tests/conduit-mirage/simple/test.ml less more
0 open Lwt.Infix
1
2 let client : Conduit_mirage.client =
3 `TCP (Ipaddr.of_string_exn "127.0.0.1", 12345)
4
5 let server : Conduit_mirage.server = `TCP 12345
6
7 module TCP = Conduit_mirage.TCP (Tcpip_stack_socket.V4V6)
8
9 let tcp () =
10 let ipv4_only = false and ipv6_only = false in
11 Udpv4v6_socket.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None
12 >>= fun udp ->
13 Tcpv4v6_socket.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None
14 >>= fun tcp -> Tcpip_stack_socket.V4V6.connect udp tcp
15
16 let _client () = tcp () >>= fun t -> TCP.connect t client
17
18 let _server () =
19 tcp () >>= fun t -> TCP.listen t server (fun _flow -> Lwt.return ())
+8
-0
tests/conduit-mirage/vchan/config_client.ml less more
0 open Mirage
1
2 let main = foreign "Unikernel.Client" (time @-> job)
3
4 let () =
5 register
6 ~libraries:[ "conduit.mirage"; "vchan.xen" ]
7 ~packages:[ "conduit"; "vchan" ] "vchan_client" [ main $ default_time ]
+8
-0
tests/conduit-mirage/vchan/config_server.ml less more
0 open Mirage
1
2 let main = foreign "Unikernel.Server" (time @-> job)
3
4 let () =
5 register
6 ~libraries:[ "conduit.mirage"; "vchan.xen" ]
7 ~packages:[ "conduit"; "vchan" ] "vchan_server" [ main $ default_time ]
+6
-0
tests/conduit-mirage/vchan/init-xenstore.sh less more
0 #!/bin/sh -e
1
2 echo Setting up a /conduit path in xenstore
3 xenstore-rm /conduit
4 xenstore-write /conduit ""
5 xenstore-chmod /conduit b0
+6
-0
tests/conduit-mirage/vchan/run.sh less more
0 #!/bin/sh
1
2 sudo xl destroy vchan_server || true
3 sudo xl destroy vchan_client || true
4 sudo ./init-xenstore.sh
5 ./build.sh
+75
-0
tests/conduit-mirage/vchan/unikernel.ml less more
0 open Lwt.Infix
1 open Printf
2
3 let conduit = Conduit_mirage.empty
4 let vchan = Conduit_mirage.vchan (module Vchan_xen)
5 let xs = Conduit_mirage.xs (module OS.Xs)
6
7 module Server (Time : Mirage_types_lwt.TIME) = struct
8 let server_src = Logs.Src.create "server" ~doc:"vchan server"
9
10 module Log = (val Logs.src_log server_src : Logs.LOG)
11
12 let start _ =
13 Conduit_mirage.with_vchan conduit xs vchan "foo_server" >>= fun t ->
14 Log.info (fun f -> f "Server initialising");
15 let callback flow =
16 Log.info (fun f -> f "Got a new flow!");
17 let rec loop () =
18 Conduit_mirage.Flow.read flow >>= fun res ->
19 match res with
20 | `Ok buf ->
21 Log.info (fun f -> f "Received: %s" @@ Cstruct.to_string buf);
22 loop ()
23 | `Eof ->
24 Log.info (fun f -> f "End of transmission!");
25 Lwt.return_unit
26 | `Error e ->
27 Log.warn (fun f -> f "Error reading the vchan flow!");
28 Lwt.return_unit
29 in
30 loop ()
31 in
32 Conduit_mirage.listen t (`Vchan `Domain_socket) callback
33 end
34
35 module Client (Time : Mirage_types_lwt.TIME) = struct
36 let client_src = Logs.Src.create "client" ~doc:"vchan client"
37
38 module Log = (val Logs.src_log client_src : Logs.LOG)
39
40 let conduit = Conduit_mirage.empty
41
42 let start _t =
43 Time.sleep 2.0 >>= fun () ->
44 Conduit_mirage.with_vchan conduit xs vchan "foo_client" >>= fun t ->
45 Log.info (fun f -> f "Connecting...");
46 let client =
47 match Vchan.Port.of_string "flibble" with
48 | `Ok port -> `Vchan (`Domain_socket ("foo_server", port))
49 | `Error e -> failwith e
50 in
51 Conduit_mirage.connect t client >>= fun flow ->
52 ( Conduit_mirage.sexp_of_client client
53 |> Sexplib.Sexp.to_string_hum
54 |> sprintf "Endpoint: %s"
55 |> fun s -> Log.info (fun f -> f "%s" s) );
56
57 Log.info (fun f -> f "Client connected");
58 let rec write num =
59 let buf = Io_page.(to_cstruct (get 1)) in
60 let s = sprintf "num is %d" num in
61 let len = String.length s in
62 Cstruct.blit_from_string s 0 buf 0 len;
63 let buf = Cstruct.sub buf 0 len in
64 Conduit_mirage.Flow.write flow buf >>= function
65 | `Eof ->
66 Log.info (fun f -> f "EOF");
67 Time.sleep 5.
68 | `Error _ ->
69 Log.warn (fun f -> f "ERR");
70 Time.sleep 5.
71 | `Ok () -> Time.sleep 0.1 >>= fun () -> write (num + 1)
72 in
73 write 0
74 end