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

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

17
unikernel/duniverse/ocaml-tls/.gitignore vendored Normal file
View file

@ -0,0 +1,17 @@
_build/
*.native
*.byte
*.install
.merlin
main.ml
.mirage.config
mirage-unikernel*opam
mirage/*/myocamlbuild.ml
mirage/*/*ukvm
mirage/*/tls_client
mirage/*/tls_server
Makefile
key_gen.ml
random/

516
unikernel/duniverse/ocaml-tls/CHANGES.md Normal file
View file

@ -0,0 +1,516 @@
## v2.0.3 (2025-09-26)
* Provide an implementation which uses the Unix module (distributed with OCaml),
based on the miou-unix implementation
(#518 #443 @kit-ty-kate @dinosaure, fixes #517)
## v2.0.2 (2025-08-22)
* put CERTIFICATE_UNKNOWN alert back (#516 @copy)
* improve README (#514 @dinosaure)
## v2.0.1 (2025-04-14)
* core, send_application_data: allocate much fewer data. previously, we
allocated a lot to split the data into chunks of 2^14 - and did not have
tail calls. the memory footprint, esp. for big amounts of data passed to
send_application_data has changed now (#515 @hannesm @reynir)
## v2.0.0 (2025-02-05)
* Use dune variants (mirage-ptime) instead of functorising over PCLOCK
(#513 @hannesm)
## v1.0.4 (2024-10-28)
* Removed links to nqsb (we're no longer in charge of that domain)
(23c0deef586df4a1732efbf8d8da006111ca76e0,
f6455e37513a74da63dc8819dfc8dd1aaebafb9a, fixes #512 reported by @msub2)
## v1.0.3 (2024-09-29)
* tls-miou-unix: fix recursive call in read_in (#511 @dinosaure)
## v1.0.2 (2024-09-04)
* tls-lwt: `read` now has an optional `?off:int` argument (#510 @hannesm)
* Use the kdf package instead of hkdf (#509 @hannesm)
## v1.0.1 (2024-08-25)
* tls-miou-unix: fix file descriptor leak (#508 @dinosaure)
* tls-miou-unix: fix fuzz test (#507 @dinosaure)
## v1.0.0 (2024-08-21)
* API breaking change: remove usage of Cstruct.t inside of TLS, use bytes
and string instead (#497 by @art-w, @hannesm, @dinosaure, @reynir)
Performance is up to 3x improved (bandwidth), 2x improvement for handshake/s
on an Intel Core(TM) i7-5600U CPU @ 2.60GHz
* FEATURE: add tls-miou-unix package, which adds miou support for TLS
(#494 #503 @dinosaure)
* FEATURE: tls-lwt and tls-async: allow TLS over an existing connection
`Tls_lwt.client_of_channels : Tls.Config.client -> ?host:[`host] Domain_name.t -> Lwt_io.input_channel * Lwt_io.output_channel -> t Lwt.t`
and
`Tls_lwt.server_of_channels : Tls.Config.server -> Lwt_io.input_channel * Lwt_io.output_channel -> t Lwt.t`
(#499 @art-w @MisterDA)
* API breaking changes: revise errors - reduce the polymorphic variant
in size, align it with RFC specified errors, be in parts more precise
about errors, in other parts skip data (#505, @hannesm - fixes #491)
NB: if you relied on a specific error constructor, please open an issue
* Remove unused constructors from Packet.{alert_type, compression_methods,
client_certificate_type, extension_type} (#505, @hannesm)
NB: if you relied on specific constructors, please open an issue
* API breaking change: Tls.Config.{server,client} now return a result
type instead of raising an exception (#502, @hannesm, fixes #411)
* FEATURE: add bench/speed.exe, a benchmark for bandwidth (for different
ciphersuites) and handshakes (different key exchanges and private keys)
(#500 @hannesm @dinosaure @reynir)
* BUGFIX: tests/feedback.exe update with TLS 1.3 semantics, run as test
(#501, @hannesm - reported by @dinosaure)
## v0.17.5 (2024-05-14)
* tls: documentation: clarify send_application_data (#492 @reynir)
* BUGFIX: tls: export_key_material was wrong for the server side on TLS 1.3,
reported in robur-coop/miragevpn#181 by @reynir, fix in #495 @hannesm
* FEATURE: tls: add channel_binding (RFC 5929, RFC 9266) support (tls_unique,
tls_exporter, tls_server_endpoint), requested by @Neustradamus in #484, added
in #496 by @hannesm
## v0.17.4 (2024-03-26)
* tls: handle half-closed connection properly: a received CLOSE_NOTIFY does not
lead to a CLOSE_NOTIFY to be sent (a `send_close_notify` sends it explicitly)
(#488 @hannesm)
* tls: modify return type of `handle_tls` - the Alert is now in the right hand
side, and `` `Eof `` is explicit in the second part of the tuple
(#488 @hannesm)
* tls: remove `can_handle_appdata`, the function `handshake_in_progress` is
available (#488 @hannesm)
* tls-mirage: avoid exceptions in reneg and rekey (#487 @hannesm)
* tls: remove HEARTBEAT decoding - HEARTBEAT was never supported in this
library, the decoder was superfluous (#487 @hannesm)
* tls-mirage: provide `underlying : flow -> FLOW.flow` (#487 @hannesm,
fixes #425 @dinosaure)
* tls-mirage: implement mirage-flow 4 API (`val shutdown`) (#488 @hannesm)
* tls-eio: adapt to half-closed connections (#488 @talex5)
* tls-eio: implement Eio.Resource.Close (#489 @paurkedal, reviewed by @talex5)
## v0.17.3 (2023-11-20)
* tls: provide Engine.export_key_material, which implements RFC 5705 (and 8446)
TLS EKM (#482 @hannesm)
* tls: fix protocol_version in Engine.epoch (TLS 1.3 always pretended TLS 1.0)
(#482 @hannesm)
* tls: add the side (`` `Client `` or `` `Server ``) to epoch_data
(#482 @hannesm)
* BREAKING tls: Engine.epoch - return result instead of custom variant
(#483 @hannesm)
## v0.17.2 (2023-09-24)
* tls-eio: update to eio 0.12 (#479 @talex5)
## v0.17.1 (2023-07-03)
* tls-async: update to 0.16 series (#476 @tmcgilchrist, review by @torinnd)
* avoid Cstruct.copy (@hannesm)
## v0.17.0 (2023-03-01)
* tls-async: remove ocaml < 5.0.0 constraint (#471 #474 @hannesm)
* remove dependency on ppx, especially ppx_cstruct and ppx_sexp_conv across
the libraries (#473 @hannesm, discussion in #472)
## v0.16.0 (2023-02-14)
* BREAKING: new opam package tls-lwt (formerly tls.lwt), in dune:
(libraries tls.lwt) should now be libraries (tls-lwt)
(#468 @hannesm, reported #449 by @mbacarella)
* tls: update to mirage-crypto 0.11 API (#468 @hannesm)
* tls: relax SignatureAlgorithms extension handling to allow OpenSSL
interoperability tests with TLS 1.0 and TLS 1.1 (#469 @hannesm)
* tls: remove Utils.filter_map and and Utils.option, use Stdlib instead (#455
@hannesm)
* tls: do not globally open Utils (#455 @hannesm)
* tls: export log source of Tracing module (#461 @bikallem)
* tls: remove unused ciphersuites to reduce binary size (#467 @hannesm)
* tls-lwt: do not catch out of memory exception (#469 @hannesm)
* tls-eio: add fuzz testing using crowbar (#456 #463 @talex5)
* tls-eio: update to eio 0.7 (#456 @talex5)
* tls-eio: fix test for develop with vendoring (#462 @bikallem)
## v0.15.5 (2022-10-25)
* tls-eio release only: fix end-of-file handling (#454 @talex5), avoid
deprecation warnings (#454 @hannesm)
## v0.15.4 (2022-09-27)
* New package tls-eio (#451 @talex5)
* Tls_async: expose tls_handler (#448 @mbacarella, reviewed by @torinnd)
## v0.15.3 (2022-03-29)
* Upgrade to v0.15 of Jane Street packages (#444 @bcc32)
* Use cmdliner 1.1.0 in lwt/examples (#445 @hannesm)
## v0.15.2 (2021-11-14)
* Tls_async: drop dependency on async_find, now trust anchors in a directory
are not recursively read - aligns it with the lwt and mirage implementations
(#442 @torinnd)
## v0.15.1 (2021-10-29)
* Tls_lwt: avoid exception if connect is executed with a non-host name string
(e.g. an IP address) (#441 @hannesm)
* Bugfix: log a warning if certificate decoding fails (#441 @hannesm)
* Remove rresult dependency (#441 @hannesm)
## v0.15.0 (2021-10-07)
* Adapt to x509 0.15.0 changes (#440 @hannesm)
## v0.14.1 (2021-09-13)
* Bugfix: do not filter signature_algorithms based on server certificate. Since
signature_algorithms is also used for client authentication (as
SignatureAlgorithms extension in CertificateVerify), previously the client
needed the same key type as the server.
Discovered in https://github.com/roburio/albatross/commit/df434da0e531e1b0c8091a0fc82e8b37ed319e7a
## v0.14.0 (2021-08-02)
* Breaking: peer_name (in config and epoch data, also own_name) is now a
[`host] Domain_name.t instead of a string. (#434 #438 @torinnd @hannesm)
* Add a X509_async module (#435 @torinnd)
* Client and server constructor log messages are on the debug level (#436
reported by @talex5, fix by @hannesm)
* Adapt to cstruct 6.0.0 API (Cstruct.len is deprecated) #439 @hannesm
## v0.13.2 (2021-06-04)
* New package tls-async that provides an effectful layer of TLS using async.
(#432, @torinnd, @dinosaure, @kit-ty-kate, reviews by @hannesm @avsm @seliopou)
## v0.13.1 (2021-04-22)
* Breaking: use deriving sexp_of instead of sexp. Constructing a state from
a sexp has not been supported (lead to exception), and is now removed
(#430 by @torinnd, continued in #431 by @hannesm)
* Bugfix: TLS 1.3 client authentication with certificate, client side. This
used to work accidentally before 0.13.0 changed the signature algorithms
handling, now the right signature algorithm (as requested by server) is used.
(#431 @hannesm, @talex5 reported https://github.com/mirage/capnp-rpc/pull/228)
* adapt to x509 0.13.0 and mirage-crypto-ec 0.10.0 changes (#431 @hannesm)
## v0.13.0 (2021-04-14)
* Remove static RSA and CBC ciphersuites from default configuration. The
default configuration now includes FFDHE and ECDHE key exchanges with RSA or
ECDSA/EdDSA certificates, and AEAD ciphers
(AES-GCM, AES-CCM, ChaCha20-Poly1305) (#429 by @hannesm)
* Remove SHA1 from signature_algorithms in the default configuration
(#429 by @hannesm)
* Support ECDSA and EdDSA certificates and private keys via x509 0.12.0 and
mirage-crypto-ec (#428 by @hannesm)
Breaking changes:
- the second part of type Tls.Config.certchain is now a X509.Private_key.t
(previously Mirage_crypto_pk.Rsa.priv)
- the type aliases X509_lwt.priv and X509_lwt.authenticator have been removed
* Use mirage-crypto-ec instead of fiat-p256 and hacl_x25519 for elliptic curve
support - this adds P384 and P521 ECDH support (#428 by @hannesm)
* Remove custom Monad implementation, use Result and Rresult instead
(#429 by @hannesm)
* Remove Utils.Cs submodule, use Cstruct API instead (#429 by @hannesm)
* Breaking: Tls.Engine.ret type is now a result instead of a custom variant type
(#429 by @hannesm)
* Breaking: Tls_lwt.Unix.epoch results in (Tls.Core.epoch_data, unit) result -
it was a custom error type previously (#429 by @hannesm)
## v0.12.8 (2020-12-08)
* Re-add ECPointFormats hello extension (both client and server) to avoid
handshake failures with Go's TLS stack (RFC 8422 makes it optional, but go
(1.15.5) requires it) - reported by @jeffa5 at
https://discuss.ocaml.org/t/strange-prohibited-tls-1-2-cipher-suite-9d-issue/
fix by @hannesm #424
## v0.12.7 (2020-12-04)
* Tls.lwt: make the receive buffer connection-local to avoid potential data
races (#422 by @dinosaure)
* Tls_mirage: remove unneeded type alias (@hannesm)
* Add Tls.Config.Ciphers.http2 - a list of ciphersuites allowed to be negotiated
for HTTP2 sessions (#423 by @jeffa5)
## v0.12.6 (2020-11-06)
* OCaml 4.12 support (#421 @kit-ty-kate)
## v0.12.5 (2020-09-22)
* Rename length to v_length to be compatible with cstruct 6.0.0 (#419 @dinosaure)
## v0.12.4 (2020-08-08)
* handshake_server13: demote group and cipher log level (#417 by @xguerin)
* tls_lwt: register printers for Tls_alert and Tls_failure (#418 by @hannesm)
## v0.12.3 (2020-07-04)
* Adapt to new GCM and CCM API of mirage-crypto (#416 by @hannesm)
* Add support for ChaCha20/Poly1305 ciphersuite (#416 by @hannesm)
## v0.12.2 (2020-06-20)
* tls_lwt again calls Mirage_crypto_rng_lwt.initialize () -- which is since
mirage-crypto-rng 0.8 no longer inside the lwt monad, and safe to be called
multiple times and on top level (#415 by @hannesm)
## v0.12.1 (2020-06-12)
in #414 by @hannesm
* Drop support for RC4 ciphersuite
* Raise lower TLS version in default configuration to 1.2
* tls_lwt no longer calls Mirage_crypto_rng_unix.initialize -- this needs to be
done in the application, inside Lwt_main.run:
`Mirage_crypto_rng_lwt.initialize () >>= fun () ->`
* Support ECDHE ciphersuites in TLS 1.2 and below as specified in RFC 8422
(requested in #413 by @ryanakca, also in #362 by @orbitz @annubiz)
* drop "TLS_" prefix from ciphersuite constructors
* BUGFIX: TLS client (<= 1.2) assembling an empty Certificate message
(noticed in #413, present since 0.12.0 release)
* Cleanup Packet.any_ciphersuite list (remove ARIA, CAMELLIA, KRB5, EXPORT)
* Adapt interoperability test scripts with TLS 1.3 support
## v0.12.0 (2020-05-12)
in #405 by @hannesm
* TLS 1.3 support
* Tracing now uses the logs library (log source tls.tracing on debug level)
* bugfix for padding in ClientHello, which computed wrong length
* bugfix hs_fragments to be set before executing the protocol handling logic
* bugfix guard RSA signature with an Insufficient_key handler, which may occur
when using an RSA key which size is too small for the used digest algorithm
## v0.11.1 (2020-04-09)
* Adapt to X509.0.11.0 API changes (#412)
## v0.11.0 (2020-03-12)
* use dune as build system (#407)
* BREAKING split into tls and tls-mirage opam packages (#407)
* BREAKING use mirage-crypto instead of nocrypto (#407)
## v0.10.6 (2020-01-23)
* adapt to x509 0.9.0 interface: certificate revocation lists can now be passed
to the authenticator in Tls_mirage and X509_lwt; also a list of hash
algorithms to be used for certificate signature verification can be passed to
the authenticator
* adapt to lwt 5.0.0
## v0.10.5 (2019-11-01)
* adapt to mirage-flow 2.0.0, mirage-clock 3.0.0, mirage-kv 3.0.0 interfaces (#401 @hannesm)
## 0.10.4 (2019-08-15)
* tls_lwt: avoid double close by checking in the default `close` callback of
`Lwt_io.make` whether the underlying file descriptor has been closed already.
(reported and discussed by @hcarty in #395, merged #397)
## 0.10.3 (2019-07-26)
* support x509 0.7.0+
* remove dependency on Astring (was only used in the lwt-starttls example)
## 0.10.2 (2019-04-02)
* support for cstruct 4.0.0+
* remove support for < 4.04.2 (same as x509 in master)
* remove result (part of 4.03.0)
* enhance mirage/example2 to work on more platforms than unix
## 0.10.1 (2019-02-28)
* tls-mirage: fix compilation
## 0.10.0 (2019-02-28)
* tls: fix extensions length (used to include the 2 byte extension length field)
if padding is inserted (introduced on May 5, 2014 in #73)
* tls-mirage: adapt to mirage-kv 2.0.0 API (#384, @samoht)
## 0.9.3 (2019-01-07)
* tls: do not require client sent ciphersuites to be a proper set
(interoperability with some android devices)
* tls_lwt: delay error from writing to peer while reading, record errors only
if state is active (fixes #347)
* migrate opam file to opam 2.0 format
## 0.9.2 (2018-08-24)
* compatibility with ppx_sexp_conv >v0.11.0 (#381), required for 4.07.0
* support ALPN (#378, @bobbypriambodo)
## 0.9.1 (2018-02-26)
* Tls_lwt: use Tls.Config instead of Config directly to avoid polluting imported
names (#376, @rgrinberg)
## 0.9.0 (2017-12-23)
* renegotiation semantics (#375)
allow acceptable_ca, authenticator, and own_cert to be updated (Config.with_x)
semantics of reneg is blocking
`{Tls_lwt.Unix|Tls_mirage}.reneg ~drop:bool` drops data of earlier epoch
* implement acceptable_ca (#332, @reynir)
* fix client renegotiation with ExtendedMasterSecret (#373, broken since 0.7.0)
* Config.client can get ~peer_name (#373)
* Asn.Time.t is Ptime.t now (asn1-combinators.0.2.0, x509.0.6.0, #372)
* cleanups (#360, #363, #369, @rgrinberg)
* remove 3DES CBC SHA from default ciphers (#359)
## 0.8.0 (2017-02-01)
* lwt: in Unix.client_of_fd the named argument host is now optional (#336)
* mirage: in client_of_flow the (positional) hostname argument is now optional (#336)
* mirage: adapt to PCLOCK interface (@mattgray #329 #331)
* build system migrated from oasis to topkg (#342)
* mirage: adapt to MirageOS3 (@yomimono @samoht #338 #349 #350 #351 #353)
* lwt: do not crash on double close (@vbmithr #345)
* fixed docstring typos (@mor1 #340)
## 0.7.1 (2016-03-21)
* remove camlp4 dependency (use cstruct ppx and sexplib ppx instead)
* sort client extensions, there are servers which dislike an extension without
data at the end, thus try to send extensions with data at the end (#319)
* initial GCM support (#310)
* fix `hs_can_handle_appdata` (#315):
Initially we allowed application data always after the first handshake.
Turns out, between CCS and Finished there is new crypto_context in place
which has not yet been authenticated -- bad idea to accept application data
at that point (beginning of 2015 in OCaml TLS).
The fix was to only allow application data in Established state (and block
in Tls_lwt/Tls_mirage when the user requested renegotiation) (December 2015
in OCaml-TLS).
Renegotiation was also turned off by default when we introduced resumption
(mid October 2015): both features together (without mitigating via session
hash) allow the triple handshake.
It turns out, the server side can happily accept application data from the
other side when it just sent a HelloRequest (and waits for the ClientHello;
same is true for the client side, waiting for the ServerHello in
renegotiation case might be interleaved with application data) to let the
client initiate a new handshake. By this commit, OCaml-TLS allows
application data then.
In the end, it is a pretty academic thing anyways, since nobody uses
renegotiation with OCaml-TLS in the field.
* during verification of a digitally signed: checked that the used hash
algorithm is one of the configured ones (#313)
* unify return type of handshake and change cipher spec handler (#314)
* separate client and server extensions (#317)
* type equality (no longer generative error type), use result (#318)
* removed Printer (was barely useful)
## 0.7.0 (2015-12-04)
* session resumption (via session ID) support (#283)
Config contains `session_cache : SessionID.t -> epoch_data option`
and `cached_session : epoch_data option`
* session hash and extended master secret (RFC 7627) support (#287)
### semantic changes
* disable renegotiation by default (#300)
* blocking semantics (both Mirage and Lwt) while renegotiating (#304)
* `Engine.handshake_in_progress` no longer exist
* `Hex_fingerprint / `Fingerprint authenticators no longer exist
* Mirage X509 does no longer prefix keys and trust anchors with "tls/" in the path
### minor fixes
* fix concurrent read/write in tls_mirage (#303)
* expose own_random and peer_random in epoch_data (@cfcs, #297)
* public key pinning (X509_lwt) via `Hex_key_fingerprint / `Key_fingerprint (#301)
* certificate chain and peer certificate are exposed via epoch_data (new path-building X.509 interface)
## 0.6.0 (2015-07-02)
* API: dropped 'perfect' from forward secrecy in Config.Ciphers:
fs instead of pfs, fs_of instead of pfs_of
* API: type epoch_data moved from Engine to Core
* removed Cstruct_s now that cstruct (since 1.6.0) provides
s-expression marshalling
* require at least 1024 bit DH group, use FFDHE 2048 bit DH group
by default instead of oakley2 (logjam)
* more specific alerts:
- UNRECOGNIZED_NAME: if hostname in SNI does not match
- UNSUPPORTED_EXTENSION: if server hello has an extension not present in
client hello
- ILLEGAL_PARAMETER: if a parse error occured
* encrypt outgoing alerts
* fix off-by-one in handling empty TLS records: if a record is less than 5
bytes, treat as a fragment. exactly 5 bytes might already be a valid
application data frame
## 0.5.0 (2015-05-02)
* updates to extension enum (contributed by Dave Garrett #264)
* removed entropy feeding (done by nocrypto) #265
* Tls_lwt file descriptor lifecycle: not eagerly close file descriptors #266
## 0.4.0 (2015-03-19)
* client authentication (both client and server side)
* server side SNI configuration (see sni.md)
* SCSV server-side downgrade prevention (by Gabriel de Perthuis @g2p #5)
* remove RC4 ciphers from default config #8
* support for AEAD ciphers, currently CCM #191
* proper bounds checking of handshake fragments #255
* disable application data between CCS and Finished #237
* remove secure renegotiation configuration option #256
* expose epoch in mirage interface, implement 2.3.0 API (error_message)
* error reporting (type failure in engine.mli) #246
* hook into Lwt event loop to feed RNG #254
## 0.3.0 (2014-12-21)
* X509_lwt provides `Fingerprints and `Hex_fingerprints constructor for
checking fingerprints of certificates instead of trusting trust
anchors #206 #207
* client configuration requires an authenticator #202
* server certificate must be at least Config.min_rsa_key_size bits
* expose epoch via lwt interface #208
* mirage-2.2.0 compatibility #212
* cleanups of mirage interface #213
* nocrypto-0.3.0 compatibility #194 #209 #210
## 0.2.0 (2014-10-30)
* distinguish between supported hash and mac algorithms (using Nocrypto.Hash)
and those which may occur on the wire #189
* expose trust anchor when authenticating certificate (requires x509 >=0.2) #178
* information about the active session is exposed via epoch : state -> epoch
* distinguish between supported ciphersuites (type ciphersuite) and
known ciphersuites (type any_ciphersuite) #173
* distinguish between supported versions by the stack (type tls_version)
and readable versions (tls_any_version), which might occur in a tls
record or client_hello read from the network #179 #172
* support > TLS-1.2 client hellos (as reported by ssllabs.com #161)
* support iOS 6 devices (who propose NULL ciphers - reported in #160)
* send minimal protocol version in record layer of client hello
(maximum version is in the client hello itself) (RFC5246, E.1) #165
## 0.1.0 (2014-07-08)
* initial beta release

23
unikernel/duniverse/ocaml-tls/LICENSE.md Normal file
View file

@ -0,0 +1,23 @@
Copyright (c) 2014, David Kaloper and Hannes Mehnert
All rights reserved.
Redistribution and use in source and binary forms, with or without modification,
are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice, this
list of conditions and the following disclaimer in the documentation and/or
other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

89
unikernel/duniverse/ocaml-tls/README.md Normal file
View file

@ -0,0 +1,89 @@
## TLS - Transport Layer Security purely in OCaml
v2.0.3
Transport Layer Security (TLS) is probably the most widely deployed security
protocol on the Internet. It provides communication privacy to prevent
eavesdropping, tampering, and message forgery. Furthermore, it optionally
provides authentication of the involved endpoints. TLS is commonly deployed for
securing web services ([HTTPS](http://tools.ietf.org/html/rfc2818)), emails,
virtual private networks, and wireless networks.
TLS uses asymmetric cryptography to exchange a symmetric key, and optionally
authenticate (using X.509) either or both endpoints. It provides algorithmic
agility, which means that the key exchange method, symmetric encryption
algorithm, and hash algorithm are negotiated.
Read our [Usenix Security 2015 paper](https://www.usenix.org/conference/usenixsecurity15/technical-sessions/presentation/kaloper-mersinjak) for further details.
## Documentation
[API documentation](https://mirleft.github.io/ocaml-tls/doc)
## Installation
`opam install tls` will install this library.
You can also build this locally by conducting the steps:
```bash
opam install --deps-only -t . # or a named package instead of `.` - i.e. ./tls-lwt.opam
dune build --profile=release # you can also put a package list here, i.e. tls,tls-lwt -- you can also use `@all` target to compile examples as well
```
## Usage
The core of `ocaml-tls` (the opam package `tls`, available in the `lib`
subdirectory) is an library independent of schedulers and does not perform any
I/O operations. The library is designed so that a `Tls.Engine.state` state
informs you of when to write and when to feed more data. It does not use
mutation and is in a value-passing style (so, read data and state is the input,
and data to be sent or presented to the upper layer, and state is the output).
There are therefore `ocaml-tls` derivations with different schedulers that
perform read and write operations. These derivations offer an interface similar
to what an SSL socket (like [ssl][ssl]) can offer.
- [lwt](https://ocsigen.org/lwt/latest/manual/manual): `tls-lwt` proposes to
initiate a TLS flow with `Lwt_io.{input,output}_channel` from a Unix socket.
It can also propose an abstract type `Tls_lwt.Unix.t` (which can be created
from a Unix socket) associated with a `Tls_lwt.Unix` interface similar to a
Unix socket.
- [miou](https://github.com/robur-coop/miou): `tls-miou-unix` proposes a TLS
flow via an abstract type `Tls_miou_unix.t` and an interface similar to a Unix
socket from a `Miou_unix.file_descr` socket.
- [MirageOS](https://mirageos.org): `tls-mirage` proposes a composition
of a [`Mirage_flow.S`](https://github.com/mirage/mirage-flow/) module to
obtain a new `Mirage_flow.S` (corresponding to the TLS layer) which uses the
lwt scheduler.
- [eio](https://github.com/ocaml-multicore/eio): `tls-eio` proposes the creation
of an _eio flow_ from another _eio flow_.
- [async](https://github.com/janestreet/async): `tls-async` proposes a TLS flow
via `Async.{Reader,Writer}.t` from a `Async.Socket`.
Depending on the scheduler you choose, you should choose one of these
`ocaml-tls` derivations, distributed in the mentioned opam packages (tls-lwt,
tls-mirage, tls-eio, tls-async). Each one takes advantage of what the scheduler
used has to offer.
### Composability
`ocaml-tls` can also be used as it is in order to be able to compose with other
protocols without choosing a scheduler. This is the case, for example, with
[sendmail.starttls][sendmail], which composes the SMTP and TLS protocols. The
user can also be more selective about the use of certificates involved in a TLS
connection, as [albatross][albatross] can offer in its transactions between
clients and the server.
When seen as OCaml values, the critical elements that enable instantiation of a
TLS connection can be very finely controlled.
### Portability
ocaml-tls is currently used for [MirageOS unikernels](https://mirageos.org),
which makes it portable and available on many systems (even the most restricted
ones such as [Solo5](https://github.com/solo5/solo5) as long as OCaml is
available on them.
[sendmail]: https://github.com/mirage/colombe
[albatross]: https://github.com/robur-coop/albatross
[ssl]: https://github.com/savonet/ocaml-ssl

5
unikernel/duniverse/ocaml-tls/async/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name tls_async)
(public_name tls-async)
(preprocess (pps ppx_jane))
(libraries async core cstruct-async mirage-crypto-rng mirage-crypto-rng.unix tls))

15
unikernel/duniverse/ocaml-tls/async/examples/dune Normal file
View file

@ -0,0 +1,15 @@
(executable
(name test_client)
(modules test_client)
(public_name tls-test-client)
(package tls-async)
(preprocess (pps ppx_jane))
(libraries async core core_unix.command_unix tls-async))
(executable
(name test_server)
(modules test_server)
(public_name tls-test-server)
(package tls-async)
(preprocess (pps ppx_jane))
(libraries async core core_unix.command_unix tls-async))

34
unikernel/duniverse/ocaml-tls/async/examples/test_client.ml Normal file
View file

@ -0,0 +1,34 @@
open! Core
open! Async
open Deferred.Or_error.Let_syntax
let config = match Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) () with
| Ok cfg -> cfg
| Error `Msg msg -> invalid_arg msg
let test_client () =
let host = "127.0.0.1" in
let port = 8443 in
let hnp = Host_and_port.create ~host ~port in
let%bind (_ : Tls_async.Session.t), rd, wr =
(* we can't build a [[ `host ] Domain_name.t] from an IP address *)
let host = None in
Tls_async.connect config (Tcp.Where_to_connect.of_host_and_port hnp) ~host
in
let req =
String.concat
~sep:"\r\n"
[ "GET / HTTP/1.1"; "Host: " ^ host; "Connection: close"; ""; "" ]
in
Writer.write wr req;
let%bind () = Writer.flushed wr |> Deferred.ok in
let%bind () =
match%map Reader.read_line rd |> Deferred.ok with
| `Ok str -> print_endline str
| `Eof -> print_endline "Eof reached"
in
Writer.close wr |> Deferred.ok
;;
let cmd = Command.async_or_error ~summary:"test client" (Command.Param.return test_client)
let () = Command_unix.run cmd

64
unikernel/duniverse/ocaml-tls/async/examples/test_server.ml Normal file
View file

@ -0,0 +1,64 @@
open! Core
open! Async
let server_cert = "./certificates/server.pem"
let server_key = "./certificates/server.key"
let serve_tls ~low_level port handler =
let%bind certificate =
Tls_async.X509_async.Certificate.of_pem_file server_cert |> Deferred.Or_error.ok_exn
in
let%bind priv_key =
Tls_async.X509_async.Private_key.of_pem_file server_key |> Deferred.Or_error.ok_exn
in
let config =
match Tls.Config.(
server
~version:(`TLS_1_0, `TLS_1_2)
~certificates:(`Single (certificate, priv_key))
~ciphers:Ciphers.supported
())
with
| Ok cfg -> cfg
| Error `Msg msg -> invalid_arg msg
in
let where_to_listen = Tcp.Where_to_listen.of_port port in
let on_handler_error = `Ignore in
if low_level then
Tcp.Server.create
~on_handler_error
where_to_listen
(fun sa ->
printf !"connection establised from %{Socket.Address.Inet} starting TLS\n" sa;
Tls_async.upgrade_server_handler ~config (handler sa))
else
Tls_async.listen ~on_handler_error config where_to_listen handler
;;
let test_server ~low_level port =
let handler (_ : Socket.Address.Inet.t) (_ : Tls_async.Session.t) rd wr =
let pipe = Reader.pipe rd in
let rec read_from_pipe () =
(match%map Pipe.read pipe with
| `Ok line -> Writer.write wr line
| `Eof -> ())
>>= read_from_pipe
in
read_from_pipe ()
in
serve_tls ~low_level port handler
;;
let cmd =
let open Command.Let_syntax in
Command.async
~summary:"test server"
(let%map_open port = anon ("PORT" %: int)
and low_level = flag "-low-level" no_arg ~doc:"set up Tcp.server directly" in
fun () ->
let open Deferred.Let_syntax in
let%bind server = test_server ~low_level port in
Tcp.Server.close_finished server)
;;
let () = Command_unix.run cmd

200
unikernel/duniverse/ocaml-tls/async/io.ml Normal file
View file

@ -0,0 +1,200 @@
open! Core
open! Async
include Io_intf
module Tls_error = struct
module Alert = struct
type t = Tls.Packet.alert_type
let sexp_of_t a =
Sexplib.Sexp.Atom (Tls.Packet.alert_type_to_string a)
end
module Fail = struct
type t = Tls.Engine.failure
let sexp_of_t a =
Sexplib.Sexp.Atom (Tls.Engine.string_of_failure a)
end
type t =
| Tls_alert of Alert.t
(** [Tls_alert] exception received from the other endpoint *)
| Tls_failure of Fail.t
(** [Tls_failure] exception while processing incoming data *)
| Connection_closed
| Connection_not_ready
| Unexpected_eof
| Unable_to_renegotiate
| Unable_to_update_key
[@@deriving sexp_of]
end
module Make (Fd : Fd) : S with module Fd := Fd = struct
open Deferred.Or_error.Let_syntax
module State = struct
type t =
| Active of Tls.Engine.state
| Eof
| Error of Tls_error.t
end
type t =
{ fd : Fd.t
; mutable state : State.t
; mutable linger : string option
; recv_buf : bytes
}
let tls_error = Fn.compose Deferred.Or_error.error_s Tls_error.sexp_of_t
let rec read_react t =
let handle tls buf =
match Tls.Engine.handle_tls tls buf with
| Ok (state, eof, `Response resp, `Data data) ->
t.state
<- (match eof with
| None -> Active state
| Some `Eof -> Eof);
let%map () =
match resp with
| None -> return ()
| Some resp -> Fd.write_full t.fd resp
in
`Ok data
| Error (alert, `Response resp) ->
t.state <- Error (match alert with `Alert a -> Tls_alert a | f -> Tls_failure f);
let%bind () = Fd.write_full t.fd resp in
read_react t
in
match t.state with
| Error e -> tls_error e
| Eof -> return `Eof
| Active _ ->
let%bind n = Fd.read t.fd t.recv_buf in
(match t.state, n with
| Active _, `Eof ->
t.state <- Eof;
return `Eof
| Active tls, `Ok n -> handle tls (Stdlib.Bytes.sub_string t.recv_buf 0 n)
| Error e, _ -> tls_error e
| Eof, _ -> return `Eof)
;;
let rec read t buf =
let writeout res =
let rlen = String.length res in
let n = min (Bytes.length buf) rlen in
Stdlib.Bytes.blit_string res 0 buf 0 n;
t.linger <- (if n < rlen then Some (Stdlib.String.sub res n (rlen - n)) else None);
return n
in
match t.linger with
| Some res -> writeout res
| None ->
(match%bind read_react t with
| `Eof -> return 0
| `Ok None -> read t buf
| `Ok (Some res) -> writeout res)
;;
let writev t css =
match t.state with
| Error err -> tls_error err
| Eof -> tls_error Connection_closed
| Active tls ->
(match Tls.Engine.send_application_data tls css with
| Some (tls, tlsdata) ->
t.state <- Active tls;
Fd.write_full t.fd tlsdata
| None -> tls_error Connection_not_ready)
;;
(*
* XXX bad XXX
* This is a point that should particularly be protected from concurrent r/w.
* Doing this before a `t` is returned is safe; redoing it during rekeying is
* not, as the API client already sees the `t` and can mistakenly interleave
* writes while this is in progress.
* *)
let rec drain_handshake t =
let push_linger t mcs =
match mcs, t.linger with
| None, _ -> ()
| scs, None -> t.linger <- scs
| Some cs, Some l -> t.linger <- Some (l ^ cs)
in
match t.state with
| Active tls when not (Tls.Engine.handshake_in_progress tls) -> return t
| _ ->
(match%bind read_react t with
| `Eof -> tls_error Unexpected_eof
| `Ok cs ->
push_linger t cs;
drain_handshake t)
;;
let reneg ?authenticator ?acceptable_cas ?cert ?(drop = true) t =
match t.state with
| Error err -> tls_error err
| Eof -> tls_error Connection_closed
| Active tls ->
(match Tls.Engine.reneg ?authenticator ?acceptable_cas ?cert tls with
| None -> tls_error Unable_to_renegotiate
| Some (tls', buf) ->
if drop then t.linger <- None;
t.state <- Active tls';
let%bind () = Fd.write_full t.fd buf in
let%bind _ = drain_handshake t in
return ())
;;
let key_update ?request t =
match t.state with
| Error err -> tls_error err
| Eof -> tls_error Connection_closed
| Active tls ->
(match Tls.Engine.key_update ?request tls with
| Error _ -> tls_error Unable_to_update_key
| Ok (tls', buf) ->
t.state <- Active tls';
Fd.write_full t.fd buf)
;;
let close_tls t =
match t.state with
| Active tls ->
let _, buf = Tls.Engine.send_close_notify tls in
t.state <- Eof;
Fd.write_full t.fd buf
| _ -> return ()
;;
let server_of_fd config fd =
drain_handshake
{ state = Active (Tls.Engine.server config)
; fd
; linger = None
; recv_buf = Bytes.create 4096
}
;;
let client_of_fd config ?host fd =
let config' =
match host with
| None -> config
| Some host -> Tls.Config.peer config host
in
let t = { state = Eof; fd; linger = None; recv_buf = Bytes.create 4096 } in
let tls, init = Tls.Engine.client config' in
let t = { t with state = Active tls } in
let%bind () = Fd.write_full t.fd init in
drain_handshake t
;;
let epoch t =
match t.state with
| Active tls -> (match Tls.Engine.epoch tls with
| Ok _ as o -> o
| Error () -> Or_error.error_string "no TLS state available yet")
| Eof -> Or_error.error_string "TLS state is end of file"
| Error _ -> Or_error.error_string "TLS state is error"
;;
end

6
unikernel/duniverse/ocaml-tls/async/io.mli Normal file
View file

@ -0,0 +1,6 @@
open! Core
module type Fd = Io_intf.Fd
module type S = Io_intf.S
module Make (Fd : Fd) : S with module Fd := Fd

64
unikernel/duniverse/ocaml-tls/async/io_intf.ml Normal file
View file

@ -0,0 +1,64 @@
open! Core
open! Async
module type Fd = sig
type t
val read : t -> bytes -> [ `Ok of int | `Eof ] Deferred.Or_error.t
val write_full : t -> string -> unit Deferred.Or_error.t
end
module type S = sig
module Fd : Fd
(** Abstract type of a session *)
type t
(** {2 Constructors} *)
(** [server_of_fd server fd] is [t], after server-side TLS
handshake of [fd] using [server] configuration. *)
val server_of_fd : Tls.Config.server -> Fd.t -> t Deferred.Or_error.t
(** [client_of_fd client ~host fd] is [t], after client-side
TLS handshake of [fd] using [client] configuration and [host]. *)
val client_of_fd
: Tls.Config.client
-> ?host:[ `host ] Domain_name.t
-> Fd.t
-> t Deferred.Or_error.t
(** {2 Common stream operations} *)
(** [read t buffer] is [length], the number of bytes read into
[buffer]. *)
val read : t -> bytes -> int Deferred.Or_error.t
(** [writev t buffers] writes the [buffers] to the session. *)
val writev : t -> string list -> unit Deferred.Or_error.t
(** [close t] closes the TLS session by sending a close notify to the peer. *)
val close_tls : t -> unit Deferred.Or_error.t
(** [reneg ~authenticator ~acceptable_cas ~cert ~drop t] renegotiates the
session, and blocks until the renegotiation finished. Optionally, a new
[authenticator] and [acceptable_cas] can be used. The own certificate can
be adjusted by [cert]. If [drop] is [true] (the default),
application data received before the renegotiation finished is dropped. *)
val reneg
: ?authenticator:X509.Authenticator.t
-> ?acceptable_cas:X509.Distinguished_name.t list
-> ?cert:Tls.Config.own_cert
-> ?drop:bool
-> t
-> unit Deferred.Or_error.t
(** [key_update ~request t] updates the traffic key and requests a traffic key
update from the peer if [request] is provided and [true] (the default).
This is only supported in TLS 1.3. *)
val key_update : ?request:bool -> t -> unit Deferred.Or_error.t
(** [epoch t] returns [epoch], which contains information of the
active session. *)
val epoch : t -> Tls.Core.epoch_data Or_error.t
end

27
unikernel/duniverse/ocaml-tls/async/session.ml Normal file
View file

@ -0,0 +1,27 @@
open! Core
open! Async
module Fd = struct
type t = Reader.t * Writer.t
let read (reader, (_ : Writer.t)) buf =
Deferred.Or_error.try_with (fun () -> Reader.read reader buf)
;;
let write ((_ : Reader.t), writer) buf =
Deferred.Or_error.try_with (fun () ->
Writer.write writer buf;
Writer.flushed writer)
;;
let rec write_full fd buf =
let open Deferred.Or_error.Let_syntax in
match String.length buf with
| 0 -> return ()
| len ->
let%bind () = write fd buf in
write_full fd (String.sub buf ~pos:len ~len:(String.length buf - len))
;;
end
include Io.Make (Fd)

3
unikernel/duniverse/ocaml-tls/async/session.mli Normal file
View file

@ -0,0 +1,3 @@
open! Core
open! Async
include Io.S with type Fd.t = Reader.t * Writer.t

154
unikernel/duniverse/ocaml-tls/async/tls_async.ml Normal file
View file

@ -0,0 +1,154 @@
open! Core
open! Async
module Session = Session
module X509_async = X509_async
let try_to_close t =
match%map Session.close_tls t with
| Ok () -> ()
| Error tls_close_error -> Log.Global.error_s [%sexp (tls_close_error : Error.t)]
;;
let pipe t =
let b_reader = Bytes.create 0x8000 in
let rec f_reader writer =
match%bind Session.read t b_reader with
| Ok 0 ->
Pipe.close writer;
return ()
| Ok len ->
let%bind () = Pipe.write writer (Stdlib.Bytes.sub_string b_reader 0 len) in
f_reader writer
| Error read_error ->
Log.Global.error_s [%sexp (read_error : Error.t)];
Pipe.close writer;
return ()
in
let rec f_writer reader =
let%bind pipe_read = Pipe.read reader in
match pipe_read with
| `Ok s ->
(match%bind Session.writev t [ s ] with
| Ok () -> f_writer reader
| Error (_ : Error.t) -> try_to_close t)
| `Eof -> try_to_close t
in
Pipe.create_reader ~close_on_exception:false f_reader, Pipe.create_writer f_writer
;;
let upgrade_connection tls_session ((_ : Reader.t), outer_writer) =
let pipe_r, pipe_w = pipe tls_session in
let%bind inner_reader = Reader.of_pipe (Info.of_string "tls_reader") pipe_r in
let%map inner_writer, `Closed_and_flushed_downstream inner_cafd =
Writer.of_pipe (Info.of_string "tls_writer") pipe_w
in
Writer.set_raise_when_consumer_leaves inner_writer false;
let outer_cafd =
(* Ordering is important here to ensure no data is lost during the session shutdown *)
let%bind () = Writer.close_finished inner_writer in
let%bind () = inner_cafd in
let%bind () = try_to_close tls_session in
Writer.flushed outer_writer
in
tls_session, inner_reader, inner_writer, `Tls_closed_and_flushed_downstream outer_cafd
;;
let upgrade_server_reader_writer_to_tls config rw =
let open Deferred.Or_error.Let_syntax in
let%bind tls_session = Session.server_of_fd config rw in
upgrade_connection tls_session rw |> Deferred.ok
;;
let upgrade_client_reader_writer_to_tls ?host config rw =
let open Deferred.Or_error.Let_syntax in
let%bind tls_session = Session.client_of_fd ?host config rw in
upgrade_connection tls_session rw |> Deferred.ok
;;
type 'a io_handler = Reader.t -> Writer.t -> 'a Deferred.t
type 'a tls_handler = Session.t -> 'a io_handler
let upgrade_server_handler ~config handle_client outer_reader outer_writer =
let%bind ( tls_session
, inner_reader
, inner_writer
, `Tls_closed_and_flushed_downstream inner_cafd )
=
upgrade_server_reader_writer_to_tls config (outer_reader, outer_writer)
|> Deferred.Or_error.ok_exn
in
Monitor.protect
(fun () -> handle_client tls_session inner_reader inner_writer)
~finally:(fun () ->
Deferred.all_unit
[ Reader.close inner_reader; Writer.close inner_writer; inner_cafd ])
;;
let listen
?buffer_age_limit
?max_connections
?max_accepts_per_batch
?backlog
?socket
~on_handler_error
config
where_to_listen
handle_client
=
Tcp.Server.create
?buffer_age_limit
?max_connections
?max_accepts_per_batch
?backlog
?socket
~on_handler_error
where_to_listen
(fun sock ->
upgrade_server_handler ~config (handle_client sock))
;;
let upgrade_client_to_tls config ~host outer_reader outer_writer =
let open Deferred.Or_error.Let_syntax in
let%bind ( tls_session
, inner_reader
, inner_writer
, `Tls_closed_and_flushed_downstream inner_cafd )
=
upgrade_client_reader_writer_to_tls ?host config (outer_reader, outer_writer)
in
don't_wait_for
(let%bind.Deferred () = inner_cafd in
Deferred.all_unit [ Writer.close outer_writer; Reader.close outer_reader ]);
return (tls_session, inner_reader, inner_writer)
;;
let connect
?socket
?buffer_age_limit
?interrupt
?reader_buffer_size
?writer_buffer_size
?timeout
?time_source
config
where_to_connect
~host
=
let open Deferred.Or_error.Let_syntax in
let%bind (_ : ([ `Active ], 'a) Socket.t), outer_reader, outer_writer =
Tcp.connect
?socket
?buffer_age_limit
?interrupt
?reader_buffer_size
?writer_buffer_size
?timeout
?time_source
where_to_connect
|> Deferred.ok
in
upgrade_client_to_tls ~host config outer_reader outer_writer
;;
(* initialized RNG early to maximise available entropy. *)
let () = Mirage_crypto_rng_unix.use_default ()

74
unikernel/duniverse/ocaml-tls/async/tls_async.mli Normal file
View file

@ -0,0 +1,74 @@
open! Core
open! Async
(** Low-level API for working with TLS sessions.
Most applications should use the high-level API below *)
module Session = Session
(** Helper functions for [Async_unix]-specific IO operations commonly used with X509
certificates, such as loading from a Unix filesystem *)
module X509_async = X509_async
(** [listen] creates a [Tcp.Server.t] with the requested parameters, including those
specified in [Tls.Config.server]. The handler function exposes the low-level
[Session.t] to accommodate cases like interrogating a client certificate *)
val listen
: ?buffer_age_limit:Writer.buffer_age_limit
-> ?max_connections:int (** defaults to [10_000]. *)
-> ?max_accepts_per_batch:int (** defaults to [1]. *)
-> ?backlog:int (** defaults to [64]. *)
-> ?socket:([ `Unconnected ], ([< Socket.Address.t ] as 'address)) Socket.t
-> on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ]
-> Tls.Config.server
-> ('address, 'listening_on) Tcp.Where_to_listen.t
-> ('address -> Session.t -> Reader.t -> Writer.t -> unit Deferred.t)
-> ('address, 'listening_on) Tcp.Server.t Deferred.t
type 'a io_handler = Reader.t -> Writer.t -> 'a Deferred.t
type 'a tls_handler = Session.t -> 'a io_handler
(** [upgrade_server_handler] is what [listen] calls to handle each client.
It is exposed so that low-level end-users of the library can use tls-async
inside of code that manages Tcp services directly.
The [tls_handler] argument will be called with the client Tls session,
reader and writer to be used for cleartext data.
The outer [reader] and [writer] will read encrypted data from and write
encrypted data to the connected socket. *)
val upgrade_server_handler
: config:Tls.Config.server
-> 'a tls_handler
-> 'a io_handler
(** [connect] behaves similarly to [Tcp.connect], exposing a cleartext reader and writer.
Callers should ensure they close the [Writer.t] and wait for the [unit Deferred.t]
returned by [`Closed_and_flushed_downstream] to completely shut down the TLS connection
[host] is used for peer name verification and should generally be provided. Passing
[None] will disable peer name verification unless [peer_name] was provided in the
[Tls.Config.client]. If both are present [host] overwrites [peer_name].
*)
val connect
: ?socket:([ `Unconnected ], 'addr) Socket.t
-> (Tls.Config.client
-> 'addr Tcp.Where_to_connect.t
-> host:[ `host ] Domain_name.t option
-> (Session.t * Reader.t * Writer.t) Deferred.Or_error.t)
Tcp.Aliases.with_connect_options
(** [upgrade_client_to_tls] upgrades an existing reader/writer to TLS,
returning a cleartext reader and writer.
Callers should ensure they close the [Writer.t] and wait for the [unit Deferred.t]
returned by [`Closed_and_flushed_downstream] to completely shut down the TLS connection
[host] is used for peer name verification and should generally be provided. Passing
[None] will disable peer name verification unless [peer_name] was provided in the
[Tls.Config.client]. If both are present [host] overwrites [peer_name].
*)
val upgrade_client_to_tls
: Tls.Config.client
-> host:[ `host ] Domain_name.t option
-> Reader.t
-> Writer.t
-> (Session.t * Reader.t * Writer.t) Deferred.Or_error.t

271
unikernel/duniverse/ocaml-tls/async/x509_async.ml Normal file
View file

@ -0,0 +1,271 @@
open! Core
open! Async
let file_contents file =
Deferred.Or_error.try_with ~name:(sprintf "read %s" file) (fun () ->
Reader.file_contents file)
;;
let load_all_in_directory ~directory ~f =
let open Deferred.Or_error.Let_syntax in
let%bind files = Deferred.Or_error.try_with (fun () -> Sys.ls_dir directory) in
Deferred.Or_error.List.map ~how:`Sequential files ~f:(fun file ->
let%bind contents = file_contents (directory ^/ file) in
f ~contents)
;;
module Or_error = struct
include Or_error
let of_result ~to_string = Result.map_error ~f:(Fn.compose Error.of_string to_string)
let of_result_msg x = of_result x ~to_string:(fun (`Msg msg) -> msg)
let lift_result_msg_of_string f ~contents =
f contents |> of_result_msg
;;
let lift_asn_error_of_string f ~contents =
f contents |> of_result ~to_string:(fun (`Parse msg) -> msg)
;;
end
module CRL = struct
include X509.CRL
let decode_der = Or_error.lift_result_msg_of_string decode_der
let revoke ?digest ~issuer ~this_update ?next_update ?extensions revoked_certs key =
revoke ?digest ~issuer ~this_update ?next_update ?extensions revoked_certs key
|> Or_error.of_result_msg
;;
let revoke_certificate revoked ~this_update ?next_update crl key =
revoke_certificate revoked ~this_update ?next_update crl key |> Or_error.of_result_msg
;;
let revoke_certificates revoked ~this_update ?next_update crl key =
revoke_certificates revoked ~this_update ?next_update crl key
|> Or_error.of_result_msg
;;
let of_pem_dir ~directory =
load_all_in_directory ~directory ~f:(fun ~contents ->
decode_der ~contents |> Deferred.return)
;;
end
module Certificate = struct
include X509.Certificate
open Deferred.Or_error.Let_syntax
let decode_pem_multiple = Or_error.lift_result_msg_of_string decode_pem_multiple
let decode_pem = Or_error.lift_result_msg_of_string decode_pem
let decode_der = Or_error.lift_result_msg_of_string decode_der
let of_pem_file ca_file =
let%bind contents = file_contents ca_file in
decode_pem_multiple ~contents |> Deferred.return
;;
let of_pem_directory ~directory =
load_all_in_directory ~directory ~f:(fun ~contents ->
decode_pem_multiple ~contents |> Deferred.return)
>>| List.concat
;;
end
module Authenticator = struct
include X509.Authenticator
module Param = struct
module Chain_of_trust = struct
type t =
{ trust_anchors : [ `File of Filename.t | `Directory of Filename.t ]
; allowed_hashes : Digestif.hash' list option
; crls : Filename.t option
}
let to_certs = function
| `File file -> Certificate.of_pem_file file
| `Directory directory -> Certificate.of_pem_directory ~directory
;;
end
type t =
| Chain_of_trust of Chain_of_trust.t
| Cert_fingerprint of Digestif.hash' * string
| Key_fingerprint of Digestif.hash' * string
let ca_file ?allowed_hashes ?crls filename () =
let trust_anchors = `File filename in
Chain_of_trust { trust_anchors; allowed_hashes; crls }
;;
let ca_dir ?allowed_hashes ?crls directory_name () =
let trust_anchors = `Directory directory_name in
Chain_of_trust { trust_anchors; allowed_hashes; crls }
;;
let cert_fingerprint hash fingerprint = Cert_fingerprint (hash, fingerprint)
let key_fingerprint hash fingerprint = Key_fingerprint (hash, fingerprint)
let cleanup_fingerprint fingerprint =
let known_delimiters = [ ':'; ' ' ] in
String.filter fingerprint ~f:(fun c ->
not (List.exists known_delimiters ~f:(Char.equal c)))
|> Ohex.decode
;;
let of_cas ~time ({ trust_anchors; allowed_hashes; crls } : Chain_of_trust.t) =
let open Deferred.Or_error.Let_syntax in
let%bind cas = Chain_of_trust.to_certs trust_anchors in
let%map crls =
match crls with
| Some directory ->
let%map crls = CRL.of_pem_dir ~directory in
Some crls
| None -> return None
in
X509.Authenticator.chain_of_trust ?allowed_hashes ?crls ~time cas
;;
let of_cert_fingerprint ~time hash fingerprint =
let fingerprint = cleanup_fingerprint fingerprint in
X509.Authenticator.cert_fingerprint ~time ~hash ~fingerprint
;;
let of_key_fingerprint ~time hash fingerprint =
let fingerprint = cleanup_fingerprint fingerprint in
X509.Authenticator.key_fingerprint ~time ~hash ~fingerprint
;;
let time = Fn.compose Ptime.of_float_s Unix.gettimeofday
let to_authenticator ~time param =
match param with
| Chain_of_trust chain_of_trust -> of_cas ~time chain_of_trust
| Cert_fingerprint (hash, fingerprint) ->
of_cert_fingerprint ~time hash fingerprint |> Deferred.Or_error.return
| Key_fingerprint (hash, fingerprint) ->
of_key_fingerprint ~time hash fingerprint |> Deferred.Or_error.return
;;
end
end
module Distinguished_name = struct
include X509.Distinguished_name
let decode_der = Or_error.lift_result_msg_of_string decode_der
end
module OCSP = struct
include X509.OCSP
module Request = struct
include Request
let create ?certs ?digest ?requestor_name ?key cert_ids =
create ?certs ?digest ?requestor_name ?key cert_ids |> Or_error.of_result_msg
;;
let decode_der = Or_error.lift_asn_error_of_string decode_der
end
module Response = struct
include Response
let create_success
?digest
?certs
?response_extensions
private_key
responderID
producedAt
responses
=
create_success
?digest
?certs
?response_extensions
private_key
responderID
producedAt
responses
|> Or_error.of_result_msg
;;
let responses t = responses t |> Or_error.of_result_msg
let decode_der = Or_error.lift_asn_error_of_string decode_der
end
end
module PKCS12 = struct
include X509.PKCS12
let decode_der = Or_error.lift_result_msg_of_string decode_der
let verify password t = verify password t |> Or_error.of_result_msg
end
module Private_key = struct
include X509.Private_key
let sign hash ?scheme key data =
sign hash ?scheme key data
|> Or_error.of_result_msg
;;
let decode_der = Or_error.lift_result_msg_of_string decode_der
let decode_pem = Or_error.lift_result_msg_of_string decode_pem
let of_pem_file file =
let%map contents = Reader.file_contents file in
decode_pem ~contents
;;
end
module Public_key = struct
include X509.Public_key
let verify hash ?scheme ~signature key data =
verify hash ?scheme ~signature key data |> Or_error.of_result_msg
;;
let decode_der = Or_error.lift_result_msg_of_string decode_der
let decode_pem = Or_error.lift_result_msg_of_string decode_pem
end
module Signing_request = struct
include X509.Signing_request
let decode_der ?allowed_hashes der =
decode_der ?allowed_hashes der |> Or_error.of_result_msg
;;
let decode_pem pem = decode_pem pem |> Or_error.of_result_msg
let create subject ?digest ?extensions key =
create subject ?digest ?extensions key |> Or_error.of_result_msg
;;
let sign
?allowed_hashes
?digest
?serial
?extensions
t
key
issuer
~valid_from
~valid_until
=
sign ?allowed_hashes ?digest ?serial ?extensions t key issuer ~valid_from ~valid_until
|> Or_error.of_result ~to_string:(Fmt.to_to_string X509.Validation.pp_signature_error)
;;
end
module Extension = X509.Extension
module General_name = X509.General_name
module Host = X509.Host
module Key_type = X509.Key_type
module Validation = X509.Validation

231
unikernel/duniverse/ocaml-tls/async/x509_async.mli Normal file
View file

@ -0,0 +1,231 @@
open! Core
open! Async
include module type of struct
include X509
end
module Authenticator : sig
include module type of struct
include Authenticator
end
module Param : sig
type t
val ca_file
: ?allowed_hashes:Digestif.hash' list
-> ?crls:Filename.t
-> Filename.t
-> unit
-> t
val ca_dir
: ?allowed_hashes:Digestif.hash' list
-> ?crls:Filename.t
-> Filename.t
-> unit
-> t
(** The fingerprint can be collected from a browser or by invoking an openssl command
like 'openssl x509 -in <pem_file> -noout -fingerprint -sha256' *)
val cert_fingerprint
: Digestif.hash'
-> string
-> t
(** The fingerprint can be collected from a browser or by invoking an openssl command
like 'openssl x509 -in <pem_file> -noout -pubkey | openssl pkey -pubin -outform DER | openssl dgst -sha256' *)
val key_fingerprint
: Digestif.hash'
-> string
-> t
(** Async programs often don't use [Ptime_clock], so this is provided as a convenience
function. Relies on [Unix.gettimeofday]. *)
val time : unit -> Ptime.t option
val to_authenticator
: time:(unit -> Ptime.t option)
-> t
-> Authenticator.t Deferred.Or_error.t
end
end
module Private_key : sig
include module type of struct
include Private_key
end
val sign
: Digestif.hash'
-> ?scheme:Key_type.signature_scheme
-> t
-> [ `Digest of string | `Message of string ]
-> string Or_error.t
val decode_der : contents:string -> t Or_error.t
val decode_pem : contents:string -> t Or_error.t
val of_pem_file : Filename.t -> t Deferred.Or_error.t
end
module Public_key : sig
include module type of struct
include Public_key
end
val verify
: Digestif.hash'
-> ?scheme:Key_type.signature_scheme
-> signature:string
-> t
-> [ `Digest of string | `Message of string ]
-> unit Or_error.t
val decode_der : contents:string -> t Or_error.t
val decode_pem : contents:string -> t Or_error.t
end
module Certificate : sig
include module type of struct
include Certificate
end
val decode_pem_multiple : contents:string -> t list Or_error.t
val decode_pem : contents:string -> t Or_error.t
val decode_der : contents:string -> t Or_error.t
val of_pem_file : Filename.t -> t list Deferred.Or_error.t
val of_pem_directory : directory:Filename.t -> t list Deferred.Or_error.t
end
module Distinguished_name : sig
include module type of struct
include Distinguished_name
end
val decode_der : contents:string -> t Or_error.t
end
module CRL : sig
include module type of struct
include CRL
end
val decode_der : contents:string -> t Or_error.t
val revoke
: ?digest:Digestif.hash'
-> issuer:Distinguished_name.t
-> this_update:Ptime.t
-> ?next_update:Ptime.t
-> ?extensions:Extension.t
-> revoked_cert list
-> Private_key.t
-> t Or_error.t
val revoke_certificate
: revoked_cert
-> this_update:Ptime.t
-> ?next_update:Ptime.t
-> t
-> Private_key.t
-> t Or_error.t
val revoke_certificates
: revoked_cert list
-> this_update:Ptime.t
-> ?next_update:Ptime.t
-> t
-> Private_key.t
-> t Or_error.t
val of_pem_dir : directory:Filename.t -> t list Deferred.Or_error.t
end
module OCSP : sig
include module type of struct
include OCSP
end
module Request : sig
include module type of struct
include Request
end
val create
: ?certs:Certificate.t list
-> ?digest:Digestif.hash'
-> ?requestor_name:General_name.b
-> ?key:Private_key.t
-> cert_id list
-> t Or_error.t
val decode_der : contents:string -> t Or_error.t
end
module Response : sig
include module type of struct
include Response
end
val create_success
: ?digest:Digestif.hash'
-> ?certs:Certificate.t list
-> ?response_extensions:Extension.t
-> Private_key.t
-> responder_id
-> Ptime.t
-> single_response list
-> t Or_error.t
val responses : t -> single_response list Or_error.t
val decode_der : contents:string -> t Or_error.t
end
end
module PKCS12 : sig
include module type of struct
include PKCS12
end
val decode_der : contents:string -> t Or_error.t
val verify
: string
-> t
-> [ `Certificate of Certificate.t
| `Crl of CRL.t
| `Decrypted_private_key of Private_key.t
| `Private_key of Private_key.t
]
list
Or_error.t
end
module Signing_request : sig
include module type of struct
include Signing_request
end
val decode_der : ?allowed_hashes:Digestif.hash' list -> string -> t Or_error.t
val decode_pem : string -> t Or_error.t
val create
: Distinguished_name.t
-> ?digest:Digestif.hash'
-> ?extensions:Ext.t
-> Private_key.t
-> t Or_error.t
val sign
: ?allowed_hashes:Digestif.hash' list
-> ?digest:Digestif.hash'
-> ?serial:string
-> ?extensions:Extension.t
-> t
-> Private_key.t
-> Distinguished_name.t
-> valid_from:Ptime.t
-> valid_until:Ptime.t
-> Certificate.t Or_error.t
end

293
unikernel/duniverse/ocaml-tls/attacks.md Normal file
View file

@ -0,0 +1,293 @@
### Attacks on TLS
TLS the most widely deployed security protocol on the Internet and, at
over 15 years, is also showing its age. As such, a flaw is a valuable
commodity due to the commercially sensitive nature of data that is
encrypted with TLS. Various vulnerabilities on different layers of TLS
have been found - [heartbleed][] and others are implementation
specific, advancements in cryptanalysis such as [collisions of
MD5][md5_collision] lead to vulnerabilities, and even others are due
to incorrect usage of TLS ([truncation attack][truncation] or
[BREACH][breach]). Finally, some weaknesses are in the protocol
itself. Extensive [overviews][tls_attacks] of [attacks on
TLS][mitls_attacks] are available.
We look at protocol level attacks of TLS and how [ocaml-tls][ocaml-tls]
implements mitigations against these. [TLS 1.2 RFC][RFC5246] provides an
overview of attacks and mitigations, and we [track][issue31] our progress in
covering them. This is slightly out of date as the RFC is roughly six years old and
in the meantime more attacks have been published, such as the [renegotiation
flaw][understanding_reneg].
We track all our [mitigated][closed] and [open][open] security issues
on our GitHub issue tracker.
Due to the choice of using OCaml, a memory managed programming
language, we obstruct entire bug classes, namely temporal and spatial
memory safety.
Cryptanalysis and improvement of computational power weaken some
ciphers, such as RC4 and 3DES (see [issue 8][issue8] and [issue
10][issue10]). If we phase these two ciphers out, there wouldn't be
any matching ciphersuite left to communicate with some compliant TLS-1.0
implementations, such as Windows XP, that do not support AES.
[issue8]: https://github.com/mirleft/ocaml-tls/issues/8
[issue10]: https://github.com/mirleft/ocaml-tls/issues/10
[open]: https://github.com/mirleft/ocaml-tls/issues?labels=security+concern&page=1&state=open
[closed]: https://github.com/mirleft/ocaml-tls/issues?labels=security+concern&page=1&state=closed
[ocaml-tls]: https://github.com/mirleft/ocaml-tls
[understanding_reneg]: http://www.educatedguesswork.org/2009/11/understanding_the_tls_renegoti.html
[heartbleed]: https://en.wikipedia.org/wiki/Heartbleed
[md5_collision]: http://eprint.iacr.org/2005/067
[truncation]: http://www.theregister.co.uk/2013/08/01/gmail_hotmail_hijacking/
[breach]: http://breachattack.com/
[RFC5246]: https://tools.ietf.org/html/rfc5246#appendix-D.4
[tls_attacks]: http://eprint.iacr.org/2013/049.pdf
[mitls_attacks]: http://www.mitls.org/wsgi/tls-attacks
[issue31]: https://github.com/mirleft/ocaml-tls/issues/31
**Timing attacks**
When the timing characteristics between the common case and the error
case are different, this might potentially leak confidential
information. Timing is a very prominent side-channel and there are a huge
variety of timing attacks on different layers, which are observable by
different attackers. Small differences in timing behaviour might
initially be exploitable only by a local attacker, but advancements to
the attack (e.g. increasing the number of tests) might allow a
remote attacker to filter the noise and exploit the different timing
behaviour.
**Timing of cryptographic primitives**
We [already mentioned][nocrypto-intro] [cache][] [timing][cache_timing]
attacks on our AES implementation, and that we use [blinding][]
techniques to mitigate RSA timing attacks.
By using a memory managed programming language, we open the attack
vector of garbage collector (GC) timing attacks (also mentioned [in
our nocrypto introduction][nocrypto-intro]).
Furthermore, research has been done on virtual machine side channels
([l3][], [cross vm][cross_vm] and [cache timing][cache_vm]), which we
will need to study and mitigate appropriately.
**For the time being we suggest to not use the stack on a multi-tenant
shared host or on a shared host which malicious users might have
access to.**
[blinding]: https://en.wikipedia.org/wiki/Blinding_(cryptography)
[cache]: http://www.cs.tau.ac.il/~tromer/papers/cache.pdf
[cache_timing]: http://cr.yp.to/antiforgery/cachetiming-20050414.pdf
[l3]: http://eprint.iacr.org/2013/448.pdf
[cross_vm]: http://www.cs.unc.edu/~reiter/papers/2012/CCS.pdf
[cache_vm]: http://fc12.ifca.ai/pre-proceedings/paper_70.pdf
**Bleichenbacher**
In 1998, Daniel Bleichenbacher discovered a [timing flaw in the
PKCS1][bleichenbacher] encoding of the premaster secret: the TLS server
failed faster when the padding was wrong than when the decryption
failed. Using this timing, an attacker can run an adaptive chosen
ciphertext attack and find out the plain text of a PKCS1 encrypted
message. In TLS, when RSA is used as the key exchange method, this
leads to discovery of the premaster secret, which is used to derive the
keys for the current session.
The mitigation is to have both padding and decryption failures use the
exact same amount of time, thus there should not be any data-dependent
branches or different memory access patterns in the code. We
implemented this mitigation in [Handshake_server][answer_client_key_exchange].
[bleichenbacher]: http://archiv.infsec.ethz.ch/education/fs08/secsem/Bleichenbacher98.pdf
[answer_client_key_exchange]: https://github.com/mirleft/ocaml-tls/blob/c06cbaaffe49024d8570916b70f7839603a54692/lib/handshake_server.ml#L45
**Padding oracle and CBC timing**
[Vaudenay][] discovered a vulnerability involving block ciphers: if an
attacker can distinguish between bad mac and bad padding, recovery of
the plaintext is possible (within an adaptive chosen ciphertext
attack). Another approach using the same issue is to use
[timing][practical] information instead of separate error messages.
Further details are described [here][tls_cbc].
The countermeasure, which we implement [here][cbc_mit], is to continue
with the mac computation even though the padding is
incorrect. Furthermore, we send the same alert (`bad_record_mac`)
independent of whether the padding is malformed or the mac is
incorrect.
[tls_cbc]: https://www.openssl.org/~bodo/tls-cbc.txt
[Vaudenay]: http://www.iacr.org/archive/eurocrypt2002/23320530/cbc02_e02d.pdf
[practical]: http://lasecwww.epfl.ch/memo/memo_ssl.shtml
[cbc_mit]: https://github.com/mirleft/ocaml-tls/blob/c06cbaaffe49024d8570916b70f7839603a54692/lib/engine.ml#L100
**Lucky 13**
An advancement of the CBC timing attack was discovered in 2013, named
[Lucky 13][Lucky13]. Due to the fact that the mac is computed over the
plaintext without padding, there is a slight (but measurable)
difference in timing between computing the mac of the plaintext and
computing the fake mac of the ciphertext. This leaks information. We
do not have proper mitigation against Lucky 13 in place yet. You can
find further discussion in [issue 7][issue7] and [pull request
49][pull49].
[Lucky13]: http://www.isg.rhul.ac.uk/tls/Lucky13.html
[issue7]: https://github.com/mirleft/ocaml-tls/issues/7
[pull49]: https://github.com/mirleft/ocaml-tls/pull/49
**Renegotiation not authenticated**
In 2009, Marsh Ray published a vulnerability of the TLS protocol which
lets an attacker prepend arbitrary data to a session due to
[unauthenticated renegotiation][understanding_reneg]. The attack
exploits the fact that a renegotiation of ciphers and key material is
possible within a session, and this renegotiated handshake is not
authenticated by the previous handshake. A man in the middle can
initiate a session with a server, send some data, and hand over the
session to a client. Neither the client nor the server can detect the
man in the middle.
A fix for this issue is the [secure renegotiation extension][RFC5746],
which embeds authenticated data of the previous handshake into the
client and server hello messages. Now, if a man in the middle
initiates a renegotiation, the server will not complete it due to
missing authentication data (the client believes this is the first
handshake).
We implement and require the secure renegotiation extension by
default, but it is possible to configure `ocaml-tls` to not require
it -- to be able to communicate with servers and
clients which do not support this extension.
Implementation of the mitigation is on the server side in
[ensure_reneg][] and on the client side in [validate_reneg][]. The
data required for the secure renegotiation is stored in
[`handshake_state`][reneg_state] while sending and receiving Finished
messages. You can find further discussion in [issue 3][issue3].
[RFC5746]: https://tools.ietf.org/html/rfc5746
[validate_reneg]: https://github.com/mirleft/ocaml-tls/blob/c06cbaaffe49024d8570916b70f7839603a54692/lib/handshake_client.ml#L50
[ensure_reneg]: https://github.com/mirleft/ocaml-tls/blob/c06cbaaffe49024d8570916b70f7839603a54692/lib/handshake_server.ml#L85
[issue3]: https://github.com/mirleft/ocaml-tls/issues/3
[reneg_state]: https://github.com/mirleft/ocaml-tls/blob/c06cbaaffe49024d8570916b70f7839603a54692/lib/state.ml#L97
**TLS 1.0 and known-plaintext (BEAST)**
TLS 1.0 reuses the last ciphertext block as IV in CBC mode. If an attacker
has a (partially) known plaintext, she can find the remaining plaintext.
This is known as the [BEAST][] attack and there is a [long discussion][mozilla-bug]
about mitigations. Our mitigation is to prepend each TLS-1.0
application data fragment with an empty fragment to randomize the IV.
We do this exactly [here][empty_iv]. There is further discussion in
[issue 2][issue2].
Our mitigation is slightly different from the 1/n-1 splitting proposed
[here][qualys]: we split every application data frame into a 0 byte
and n byte frame, whereas they split into a 1 byte and a n-1 byte
frame.
Researchers have exploited this vulnerability in 2011, although it was
known since [2006][]. TLS versions 1.1 and 1.2 use an explicit IV,
instead of reusing the last cipher block on the wire.
[qualys]: https://community.qualys.com/blogs/securitylabs/2013/09/10/is-beast-still-a-threat
[mozilla-bug]: https://bugzilla.mozilla.org/show_bug.cgi?id=665814
[BEAST]: http://vnhacker.blogspot.co.uk/2011/09/beast.html
[empty_iv]: https://github.com/mirleft/ocaml-tls/blob/c06cbaaffe49024d8570916b70f7839603a54692/lib/engine.ml#L375
[2006]: http://eprint.iacr.org/2006/136
[issue2]: https://github.com/mirleft/ocaml-tls/issues/2
**Compression and information leakage (CRIME)**
When using compression on a chosen-plaintext, encrypting this can leak
information, known as [CRIME][crime]. [BREACH][breach] furthermore
exploits application layer compression, such as HTTP compression. We
mitigate CRIME by not providing any TLS compression support, while we
cannot do anything to mitigate BREACH.
[crime]: http://arstechnica.com/security/2012/09/crime-hijacks-https-sessions/
**Traffic analysis**
Due to limited amount of padding data, the actual size of transmitted
data can be recovered. The mitigation is to implement [length hiding
policies][length_hiding]. This is tracked as [issue 162][issue162].
[issue162]: https://github.com/mirleft/ocaml-tls/issues/162
[length_hiding]: http://tools.ietf.org/html/draft-pironti-tls-length-hiding-02
**Version rollback**
SSL-2.0 is insecure, a man in the middle can downgrade the version to
SSL-2.0. The mitigation we implement is that we do not support
SSL-2.0, and thus cannot be downgraded. Also, we check that the
version of the client hello matches the first two bytes in the
premaster secret [here][client_version]. You can find further discussion in
[issue 5][issue5].
[client_version]: https://github.com/mirleft/ocaml-tls/blob/c06cbaaffe49024d8570916b70f7839603a54692/lib/handshake_server.ml#L55
[issue5]: https://github.com/mirleft/ocaml-tls/issues/5
**Triple handshake**
A vulnerability including session resumption and renegotiation was
discovered by the [miTLS team][mitls], named [triple
handshake][triple]. Mitigations include disallowing renegotiation,
disallowing modification of the certificate during renegotiation, or
a hello extension. Since we do not support session resumption yet, we
have not yet implemented any of the mentioned mitigations. There is
further discussion in [issue 9][issue9].
[mitls]: http://www.mitls.org
[issue9]: https://github.com/mirleft/ocaml-tls/issues/9
[triple]: https://secure-resumption.com/
**Alert attack**
A [fragment of an alert][alert_attack] can be sent by a man in the
middle during the initial handshake. If the fragment is not cleared
once the handshake is finished, the authentication of alerts is
broken. This was discovered in 2012; our mitigation is to discard
fragmented alerts.
[alert_attack]: http://www.mitls.org/wsgi/alert-attack
### EOF.
Within six months, two hackers managed to develop a clean-slate TLS
stack, together with required crypto primitives, ASN.1, and X.509
handling, in a high-level pure language. We interoperate with widely
deployed TLS stacks, as shown by our [demo server][demo]. The code
size is nearly two orders of magnitude smaller than OpenSSL, the most
widely used open source library (written in C, which a lot of
programming languages wrap instead of providing their own TLS
implementation). Our code base seems to be robust -- the [demo
server][demo] successfully finished over 22500 sessions in less than a
week, with only 11 failing traces.
There is a huge need for high quality TLS implementations, because
several TLS implementations suffered this year from severe security
problems, such as [heartbleed][], [goto fail][CVE-2014-1266], [session
id][CVE-2014-3466], [Bleichenbacher][java], [change cipher
suite][CVE-2014-0224] and [GCM DoS][polar]. The main cause is
implementation complexity due to lack of abstraction, and memory
safety issues.
We still need to address some security issues, and improve our performance. We
invite people to do rigorous code audits (both manual and automated) and try
testing our code in their services.
**Please be aware that this release is a *beta* and is missing external code audits.
It is not yet intended for use in any security critical applications.**
[demo]: https://tls.openmirage.org
[polar]: https://polarssl.org/tech-updates/security-advisories/polarssl-security-advisory-2014-02
[java]: http://armoredbarista.blogspot.de/2014/04/easter-hack-even-more-critical-bugs-in.html
[CVE-2014-1266]: https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2014-1266
[CVE-2014-3466]: https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2014-3466
[CVE-2014-0224]: https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2014-0224
[nocrypto-intro]: http://openmirage.org/blog/introducing-nocrypto

3
unikernel/duniverse/ocaml-tls/bench/dune Normal file
View file

@ -0,0 +1,3 @@
(executable
(name speed)
(libraries fmt.tty logs.fmt mirage-crypto-rng mirage-crypto-rng.unix tls ptime.clock.os))

284
unikernel/duniverse/ocaml-tls/bench/speed.ml Normal file
View file

@ -0,0 +1,284 @@
let now = Ptime_clock.now
let cert ~digest ~key =
let subject =
let open X509.Distinguished_name in
[ Relative_distinguished_name.singleton (CN "ocaml-tls") ]
in
let csr = X509.Signing_request.create ~digest subject key |> Result.get_ok in
let pubkey = (X509.Signing_request.info csr).public_key in
let extensions =
let open X509.Extension in
let auth =
(Some (X509.Public_key.id pubkey), X509.General_name.empty, None)
in
singleton Authority_key_id (false, auth)
|> add Subject_key_id (false, X509.Public_key.id pubkey)
|> add Basic_constraints (true, (true, None))
|> add Key_usage
(true,
[ `Key_cert_sign
; `CRL_sign
; `Digital_signature
; `Content_commitment
; `Key_encipherment ])
|> add Ext_key_usage (true, [ `Server_auth ])
in
let valid_from = now () in
let valid_until = Ptime.add_span valid_from (Ptime.Span.of_int_s 60) in
let valid_until = Option.get valid_until in
let cert = X509.Signing_request.sign csr ~valid_from ~valid_until ~digest
~extensions key subject in
match cert with
| Ok cert -> cert
| Error e -> Fmt.failwith "cert error %a" X509.Validation.pp_signature_error e
let authenticator ?ip:_ ~host:_ _certs = Ok None
let consume state input =
match Tls.Engine.handle_tls state input with
| Ok (state, Some `Eof, `Response out, `Data v) ->
let data = Option.fold ~none:0 ~some:String.length v in
`Eof state, out, data
| Ok (state, None, `Response out, `Data v) ->
let data = Option.fold ~none:0 ~some:String.length v in
`Continue state, out, data
| Error (err, `Response out) ->
`Error err, Some out, 0
let to_state state input =
match consume state input with
| `Eof _, _, _ -> Fmt.failwith "Unexpected eof"
| `Error err, _, _ -> Fmt.failwith "Unexpected error: %a" Tls.Engine.pp_failure err
| `Continue state, out, data -> state, out, data
type flow =
| To_client of Tls.Engine.state * Tls.Engine.state * string option
| To_server of Tls.Engine.state * Tls.Engine.state * string option
type state =
{ flow : flow
; server_out : int
; client_out : int
; direction : [ `To_server | `To_client ] }
let get_ok = function
| Ok cfg -> cfg
| Error `Msg msg -> invalid_arg msg
let make ?groups ~cipher ~digest ~key version direction =
let cert = cert ~digest ~key in
let client_cfg =
get_ok (Tls.Config.client ?groups ~version:(version, version)
~ciphers:[ cipher ] ~authenticator ())
and server_cfg =
get_ok (Tls.Config.server ~certificates:(`Single ([ cert ], key)) ())
in
let client_state, client_out = Tls.Engine.client client_cfg
and server_state = Tls.Engine.server server_cfg in
{ flow= To_server (client_state, server_state, Some client_out)
; server_out= 0
; client_out= 0
; direction }
let actually_send_application_data client_state server_state direction buf =
match direction with
| `To_server ->
let[@warning "-8"] Some (client_state, to_server) =
Tls.Engine.send_application_data client_state [ buf ] in
To_server (client_state, server_state, Some to_server)
| `To_client ->
let[@warning "-8"] Some (server_state, to_client) =
Tls.Engine.send_application_data server_state [ buf ] in
To_client (client_state, server_state, Some to_client)
let rec once state buf = match state.flow, buf with
| To_server (client_state, server_state, None), Some buf
| To_client (client_state, server_state, None), Some buf ->
let flow = actually_send_application_data
client_state server_state state.direction buf in
once { state with flow } None
| To_server (_, _, None), None
| To_client (_, _, None), None -> state
| To_server (client_state, server_state, Some to_server), buf ->
let server_state, to_client, n = to_state server_state to_server in
let flow = To_client (client_state, server_state, to_client) in
once { state with flow; server_out= state.server_out + n } buf
| To_client (client_state, server_state, Some to_client), _ ->
let client_state, to_server, n = to_state client_state to_client in
let flow = To_server (client_state, server_state, to_server) in
once { state with flow; client_out= state.client_out + n } buf
let to_consumer state =
let state = ref state in
fun buf -> state := once !state (Some buf)
module Time = struct
let time ~n fn a =
let t1 = Sys.time () in
for _i = 0 to n - 1 do ignore (fn a) done;
let t2 = Sys.time () in
(t2 -. t1)
end
let burn_period = 2.0
let sizes = [ 16; 64; 256; 1024; 4096; 8192 ]
let burn fn size =
let cs = Mirage_crypto_rng.generate size in
let (t1, i1) =
let rec go it =
let t = Time.time ~n:it fn cs in
if t > 0.2 then (t, it) else go (it * 10) in
go 10 in
let iters = int_of_float (float i1 *. burn_period /. t1) in
let time = Time.time ~n:iters fn cs in
(iters, time, float (size * iters) /. time)
let mb = 1024. *. 1024.
let throughput title fn =
Fmt.pr "\n## %s\n\n%!" title ;
Fmt.pr "| block | MB/s |\n%!" ;
Fmt.pr "| ----- | ------- |\n%!" ;
List.iter begin fun size ->
Gc.full_major ();
let (_iters, _time, bw) = burn fn size in
Fmt.pr "| %5d | %7.2f |\n%!" size (bw /. mb)
end sizes
let bm name fn = (name, fun () -> fn name)
let count_period = 10.
let count f n =
ignore (f n);
let i1 = 5 in
let t1 = Time.time ~n:i1 f n in
let iters = int_of_float (float i1 *. count_period /. t1) in
let time = Time.time ~n:iters f n in
(iters, time)
let count title f to_str args =
Printf.printf "\n## %s\n\n%!" title ;
Printf.printf "| group | hs/s |\n%!" ;
Printf.printf "| --------- | ------- |\n%!" ;
args |> List.iter @@ fun arg ->
Gc.full_major () ;
let iters, time = count f arg in
Printf.printf "| %s | %7.2f |\n%!"
(to_str arg) (float iters /. time)
let print_group group =
let str = Fmt.to_to_string Tls.Core.pp_group group in
let pad = 9 - String.length str in
str ^ String.make pad ' '
let throughput =
[ bm "tls-1.3, rsa/2048, x25519, aes-128-ccm-sha256" begin fun name ->
let key = X509.Private_key.generate ~bits:2048 `RSA in
let state = make ~groups:[ `X25519 ] ~cipher:`AES_128_CCM_SHA256 ~digest:`SHA256 ~key `TLS_1_3 `To_server in
throughput name (to_consumer state)
end
; bm "tls-1.3, rsa/2048, x25519, aes-128-gcm-sha256" begin fun name ->
let key = X509.Private_key.generate ~bits:2048 `RSA in
let state = make ~groups:[ `X25519 ] ~cipher:`AES_128_GCM_SHA256 ~digest:`SHA256 ~key `TLS_1_3 `To_server in
throughput name (to_consumer state)
end
; bm "tls-1.3, rsa/2048, x25519, aes-256-gcm-sha384" begin fun name ->
let key = X509.Private_key.generate ~bits:2048 `RSA in
let state = make ~groups:[ `X25519 ] ~cipher:`AES_256_GCM_SHA384 ~digest:`SHA256 ~key `TLS_1_3 `To_server in
throughput name (to_consumer state)
end
; bm "tls-1.3, rsa/2048, x25519, chacha20-poly1305-sha256" begin fun name ->
let key = X509.Private_key.generate ~bits:2048 `RSA in
let state = make ~groups:[ `X25519 ] ~cipher:`CHACHA20_POLY1305_SHA256 ~digest:`SHA256 ~key `TLS_1_3 `To_server in
throughput name (to_consumer state)
end
; bm "tls-1.2, rsa/2048, ffdhe2048, aes-128-ccm" begin fun name ->
let key = X509.Private_key.generate ~bits:2048 `RSA in
let state = make ~groups:[ `FFDHE2048 ] ~cipher:`DHE_RSA_WITH_AES_128_CCM ~digest:`SHA256 ~key `TLS_1_2 `To_server in
throughput name (to_consumer state)
end
; bm "tls-1.2, rsa/2048, ffdhe2048, aes-256-ccm" begin fun name ->
let key = X509.Private_key.generate ~bits:2048 `RSA in
let state = make ~groups:[ `FFDHE2048 ] ~cipher:`DHE_RSA_WITH_AES_256_CCM ~digest:`SHA256 ~key `TLS_1_2 `To_server in
throughput name (to_consumer state)
end
; bm "tls-1.2, rsa/2048, ffdhe2048, aes-128-gcm-sha256" begin fun name ->
let key = X509.Private_key.generate ~bits:2048 `RSA in
let state = make ~groups:[ `FFDHE2048 ] ~cipher:`DHE_RSA_WITH_AES_128_GCM_SHA256 ~digest:`SHA256 ~key `TLS_1_2 `To_server in
throughput name (to_consumer state)
end
; bm "tls-1.2, rsa/2048, ffdhe2048, aes-256-gcm-sha384" begin fun name ->
let key = X509.Private_key.generate ~bits:2048 `RSA in
let state = make ~groups:[ `FFDHE2048 ] ~cipher:`DHE_RSA_WITH_AES_256_GCM_SHA384 ~digest:`SHA256 ~key `TLS_1_2 `To_server in
throughput name (to_consumer state)
end
; bm "tls-1.2, rsa/2048, ffdhe2048, chacha20_poly1305_sha256" begin fun name ->
let key = X509.Private_key.generate ~bits:2048 `RSA in
let state = make ~groups:[ `FFDHE2048 ] ~cipher:`DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 ~digest:`SHA256 ~key `TLS_1_2 `To_server in
throughput name (to_consumer state)
end
]
and handshake =
[ bm "tls-1.3 handshake, rsa2048" begin fun name ->
let key = X509.Private_key.generate ~bits:2048 `RSA in
count name begin fun group ->
let state = make ~groups:[ group ] ~cipher:`CHACHA20_POLY1305_SHA256 ~digest:`SHA256 ~key `TLS_1_3 `To_server in
ignore (once state None)
end
print_group
([ `X25519 ; `P256 ; `P384 ; `P521 ; `FFDHE2048 ; `FFDHE3072 ])
end
; bm "tls-1.3 handshake, ed25519" begin fun name ->
let key = X509.Private_key.generate `ED25519 in
count name begin fun group ->
let state = make ~groups:[ group ] ~cipher:`CHACHA20_POLY1305_SHA256 ~digest:`SHA256 ~key `TLS_1_3 `To_server in
ignore (once state None)
end
print_group
([ `X25519 ; `P256 ; `P384 ; `P521 ; `FFDHE2048 ; `FFDHE3072 ])
end
; bm "tls-1.3 handshake, p256" begin fun name ->
let key = X509.Private_key.generate `P256 in
count name begin fun group ->
let state = make ~groups:[ group ] ~cipher:`CHACHA20_POLY1305_SHA256 ~digest:`SHA256 ~key `TLS_1_3 `To_server in
ignore (once state None)
end
print_group
([ `X25519 ; `P256 ; `P384 ; `P521 ; `FFDHE2048 ; `FFDHE3072 ])
end
; bm "tls-1.2 handshake, rsa2048" begin fun name ->
let key = X509.Private_key.generate ~bits:2048 `RSA in
count name begin fun group ->
let cipher = match group with
| `FFDHE4096 | `FFDHE6144 | `FFDHE8192 | `FFDHE2048 | `FFDHE3072 -> `DHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `X25519 | `P256 | `P384 | `P521 -> `ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256
in
let state = make ~groups:[ group ] ~cipher ~digest:`SHA256 ~key `TLS_1_2 `To_server in
ignore (once state None)
end
print_group
([ `X25519 ; `P256; `P384 ; `P521 ; `FFDHE2048 ; `FFDHE3072 ])
end
]
let run fns =
List.iter (fun (_, fn) -> fn ()) fns
let () = Mirage_crypto_rng_unix.use_default ()
let () =
let seed = "0xdeadbeef" in
let g = Mirage_crypto_rng.(create ~seed (module Fortuna)) in
Mirage_crypto_rng.set_default_generator g;
let bench =
match Sys.argv.(1) with
| exception Invalid_argument _ -> throughput @ handshake
| "hs" -> handshake
| "bw" -> throughput
| _ -> invalid_arg "supported is: 'hs' (for handshake) or 'bw' (for bandwidth)"
in
run bench

14
unikernel/duniverse/ocaml-tls/certificates/bar.pem Normal file
View file

@ -0,0 +1,14 @@
-----BEGIN CERTIFICATE-----
MIICHTCCAYYCCQDyqsjENH2CvTANBgkqhkiG9w0BAQUFADBTMQswCQYDVQQGEwJB
VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0
cyBQdHkgTHRkMQwwCgYDVQQDDANiYXIwHhcNMTQwODExMTIxMDEwWhcNMTUwODEx
MTIxMDEwWjBTMQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8G
A1UECgwYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMQwwCgYDVQQDDANiYXIwgZ8w
DQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBALZASN7mvCGUPaKrXrb42DcAf0F8D+M0
ksOqL1U+TV4xQ0aJwm8r5o4A0oiw46v2/hGIRdlJiYUS8ZLL5J/VsIMfAcstJ02z
pjj1vvs86Bq2tVk5NEQET+3WyhVPdr+9UlYIu1UKObvS7RLm1x+fhLohql4hgBUC
ZxqrBJr4ZA2hAgMBAAEwDQYJKoZIhvcNAQEFBQADgYEAci6xzomZWURSro7/B8Hy
DgoMF15tcocsyeFnxLBGqXyg2RQnvZXjv7DFkQgieDFqXvAFgxG+bcZzBFrKHI6A
FKH9IeBpgtVPVbnHJYMpEShzOSyc/8MFSuqMqo9a/XWK7VTguZqzTVSoyE06S6AP
10W+CBZBT+5Gah6I9rsLDNo=
-----END CERTIFICATE-----

4157
unikernel/duniverse/ocaml-tls/certificates/ca-root-nss-short.crt Normal file
View file

File diff suppressed because it is too large Load diff

14
unikernel/duniverse/ocaml-tls/certificates/foo.pem Normal file
View file

@ -0,0 +1,14 @@
-----BEGIN CERTIFICATE-----
MIICHTCCAYYCCQDPsW8ipzRmaTANBgkqhkiG9w0BAQUFADBTMQswCQYDVQQGEwJB
VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0
cyBQdHkgTHRkMQwwCgYDVQQDDANmb28wHhcNMTQwODExMTIwOTI4WhcNMTUwODEx
MTIwOTI4WjBTMQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8G
A1UECgwYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMQwwCgYDVQQDDANmb28wgZ8w
DQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBALZASN7mvCGUPaKrXrb42DcAf0F8D+M0
ksOqL1U+TV4xQ0aJwm8r5o4A0oiw46v2/hGIRdlJiYUS8ZLL5J/VsIMfAcstJ02z
pjj1vvs86Bq2tVk5NEQET+3WyhVPdr+9UlYIu1UKObvS7RLm1x+fhLohql4hgBUC
ZxqrBJr4ZA2hAgMBAAEwDQYJKoZIhvcNAQEFBQADgYEAVE2BBZI/MTCZorKkGVVj
ZFosVv4qhiajzT/yr3nd7/8vLMsHnqrkfwycES9s9RRE9glv1WNptFSxkUxKzP2r
jv2c7jdkXkDZsLlCh/qmaaKymZ+WuATbGm/edItnwy3RQDzufjsTfOFUH/08JWwz
rnWkhcnpCqdTTniWwy/HRYQ=
-----END CERTIFICATE-----

5
unikernel/duniverse/ocaml-tls/certificates/server-ec.key Normal file
View file

@ -0,0 +1,5 @@
-----BEGIN PRIVATE KEY-----
MGACAQAwEAYHKoZIzj0CAQYFK4EEACMESTBHAgEBBEIAtmFgIVel9k9Ivp7S5Mlc
adxdv3KvDHc1j787n4avTUpzk+Aj7g0zxen7UsBOk2q/EGbZbtVFsO4zdOvPqP1+
m94=
-----END PRIVATE KEY-----

14
unikernel/duniverse/ocaml-tls/certificates/server-ec.pem Normal file
View file

@ -0,0 +1,14 @@
-----BEGIN CERTIFICATE-----
MIICDDCCAW+gAwIBAgIIQcOa7kqxp9cwCgYIKoZIzj0EAwQwFjEUMBIGA1UEAwwL
ZXhhbXBsZS5jb20wHhcNMjEwNDA0MTcwMTU3WhcNMjIwNDA0MTcwMTU3WjAWMRQw
EgYDVQQDDAtleGFtcGxlLmNvbTCBmzAQBgcqhkjOPQIBBgUrgQQAIwOBhgAEAXIK
VyKRhKOJjxXQtKJiTX9nM3lZs6qy632NYmG9BwJ74FidW1NYlT0eiN71nMHU9FOH
BZ76AH0ISrbo3hjG7uFzAPMplhTwTlA7IcQoR8FOGjrN0w+H5YJZRtkfYU0hFETU
F4quomVmbrxtcIgFRWLJdf7qciYYJyYc8ZlTZoHpZY02o2QwYjAdBgNVHQ4EFgQU
nku+GxZTewB6/D2bJFQcOkBN4QMwDwYDVR0PAQH/BAUDAwfGADAPBgNVHRMBAf8E
BTADAQH/MB8GA1UdIwQYMBaAFJ5LvhsWU3sAevw9myRUHDpATeEDMAoGCCqGSM49
BAMEA4GKADCBhgJBfZBX4o5Df/fJUnzmQKo6KFFWlc70VkO3hXH6lUhVRLcT+Ame
6gJUjgYy65GryW4Tx/pFTI7tdX19UDm+kBvgv1sCQRIgxgt/eJ74VsRgt7Br3Smm
px1uULyS4PIGBKT4O4C4bWS1wdzw8ZOlegss1+pkxYYrfJFNJYyBaqY0ScTpvE4F
-----END CERTIFICATE-----
----

15
unikernel/duniverse/ocaml-tls/certificates/server.key Normal file
View file

@ -0,0 +1,15 @@
-----BEGIN RSA PRIVATE KEY-----
MIICXQIBAAKBgQC2QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJv
K+aOANKIsOOr9v4RiEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTRE
BE/t1soVT3a/vVJWCLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQAB
AoGAd/CShG8g/JBMh9Nz/8KAuKHRHc2BvysIM1C62cSosgaFmdRrazJfBrEv3Nlc
2/0uc2dVYIxuvm8bIFqi2TWOdX9jWJf6oXwEPXCD0SaDbJTaoh0b+wjyHuaGlttY
Ztvmf8mK1BOhyl3vNMxh/8Re0dGvGgPZHpn8zanaqfGVz+ECQQDngieUpwzxA0QZ
GZKRYhHoLEaPiQzBaXphqWcCLLN7oAKxZlUCUckxRRe0tKINf0cB3Kr9gGQjPpm0
YoqXo8mNAkEAyYgdd+JDi9FH3Cz6ijvPU0hYkriwTii0V09+Ar5DvYQNzNEIEJu8
Q3Yte/TPRuK8zhnp97Bsy9v/Ji/LSWbtZQJBAJe9y8u3otfmWCBLjrIUIcCYJLe4
ENBFHp4ctxPJ0Ora+mjkthuLF+BfdSZQr1dBcX1a8giuuvQO+Bgv7r9t75ECQC7F
omEyaA7JEW5uGe9/Fgz0G2ph5rkdBU3GKy6jzcDsJu/EC6UfH8Bgawn7tSd0c/E5
Xm2Xyog9lKfeK8XrV2kCQQCTico5lQPjfIwjhvn45ALc/0OrkaK0hQNpXgUNFJFQ
tuX2WMD5flMyA5PCx5XBU8gEMHYa8Kr5d6uoixnbS0cZ
-----END RSA PRIVATE KEY-----

15
unikernel/duniverse/ocaml-tls/certificates/server.pem Normal file
View file

@ -0,0 +1,15 @@
-----BEGIN CERTIFICATE-----
MIICYzCCAcwCCQDLbE6ES1ih1DANBgkqhkiG9w0BAQUFADB2MQswCQYDVQQGEwJB
VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0
cyBQdHkgTHRkMRUwEwYDVQQDDAxZT1VSIE5BTUUhISExGDAWBgkqhkiG9w0BCQEW
CW1lQGJhci5kZTAeFw0xNDAyMTcyMjA4NDVaFw0xNTAyMTcyMjA4NDVaMHYxCzAJ
BgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l
dCBXaWRnaXRzIFB0eSBMdGQxFTATBgNVBAMMDFlPVVIgTkFNRSEhITEYMBYGCSqG
SIb3DQEJARYJbWVAYmFyLmRlMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC2
QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJvK+aOANKIsOOr9v4R
iEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTREBE/t1soVT3a/vVJW
CLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQABMA0GCSqGSIb3DQEB
BQUAA4GBAIo4ZppIlp3JRyltRC1/AyCC0tsh5TdM3W7258wdoP3lEe08UlLwpnPc
aJ/cX8rMG4Xf4it77yrbVrU3MumBEGN5TW4jn4+iZyFbp6TT3OUF55nsXDjNHBbu
deDVpGuPTI6CZQVhU5qEMF3xmlokG+VV+HCDTglNQc+fdLM0LoNF
-----END CERTIFICATE-----

249
unikernel/duniverse/ocaml-tls/design.md Normal file
View file

@ -0,0 +1,249 @@
### The OCaml-TLS architecture
The OCaml ecosystem has several distinct ways of interacting with the outside world
(and the network in particular): straightforward [unix][ocaml-unix] interfaces
and the asynchronous programming libraries [lwt][] and [async][]. One of the
early considerations was not to restrict ourselves to any of those -- we wanted
to support them all.
There were also two distinct basic "platforms" we wanted to target from the
outset: the case of a simple executable, and the case of `Mirage` unikernels.
So one of the first questions we faced was deciding how to represent
interactions with the network in a portable way. This can be done by
systematically abstracting out the API boundary which gives access to network
operations, but we had a third thing in mind as well: we wanted to exploit the
functional nature of OCaml to its fullest extent!
Our various prior experiences with Haskell and Idris convinced us to adopt
what is called "purely functional" technique. We believe it to be an approach
which first forces the programmer to give principled answers to all the
difficult design questions (errors and global data-flow) *in advance*, and then
leads to far cleaner and composable code later on. A purely functional system
has all the data paths made completely explicit in the form of function
arguments and results. There are no unaccounted-for interactions between
components mediated by shared state, and all the activity of the parts of the
system is exposed through types since, after all, it's only about computing
values from values.
For these reasons, the library is split into two parts: the directory `/lib`
(and the corresponding findlib package `tls`) contains the core TLS logic, and
`/mirage` and `/lwt` (packaged as `tls.mirage` and `tls.lwt` respectively)
contain front-ends that tie the core to `Mirage` and `Lwt_unix`.
[ocaml-unix]: http://caml.inria.fr/pub/docs/manual-ocaml/libref/Unix.html
[lwt]: http://ocsigen.org/lwt/
[async]: https://realworldocaml.org/v1/en/html/concurrent-programming-with-async.html
### Core
The [core][tls-engine-mli] library is purely functional. A TLS session is represented by the
abstract type `Tls.Engine.state`, and various functions consume this session
type together with raw bytes (`Cstruct.t` -- which is by itself mutable, but
`ocaml-tls` eschews this) and produce new session values and resulting buffers.
The central entry point is [handle_tls][], which transforms an input state and a
buffer to an output state, a (possibly empty) buffer to send to the
communication partner, and an optional buffer of data intended to be received by
the application:
```OCaml
type state
type ret = [
| `Ok of [ `Ok of state | `Eof | `Alert of alert ] *
[ `Response of Cstruct.t ] * [ `Data of Cstruct.t option ]
| `Fail of alert * [ `Response of Cstruct.t ]
]
val handle_tls : state -> Cstruct.t -> ret
```
As the signature shows, errors are signalled through the `ret` type, which is a [polymorphic variant][poly]. This
reflects the actual internal structure: all the errors are represented as
values, and operations are composed using an error [monad][monad-ml].
Other entry points share the same basic behaviour: they transform the prior
state and input bytes into the later state and output bytes.
Here's a rough outline of what happens in `handle_tls`:
- TLS packets consist of a header, which contains the protocol
version, length, and content type, and the payload of the given
content type. Once inside our [main handler][handle_tls], we
[separate][separate_records] the buffer into TLS records, and
[process][handle_raw_record] each individually. We first check that
the version number is correct, then [decrypt][decrypt], and [verify
the mac][verify_mac].
- Decrypted data is then [dispatched][handle_packet] to one of four
sub-protocol handlers (Handshake, Change Cipher Spec, Alert and
Application Data). Each handler can [return][return_types] a new
handshake state, outgoing data, application data, the new decryption
state or an error (with the outgoing data being an interleaved list
of buffers and new encryption states).
- The outgoing buffers and the encryption states are
[traversed][encrypt] to produce the final output to be sent to the
communication partner, and the final encryption, decryption and
handshake states are combined into a new overall state which is
returned to the caller.
Handshake is (by far) the most complex TLS sub-protocol, with an elaborate state
machine. Our [client][client_handshake] and [server][server_handshake] encode
this state as a "flat" [sum type][handshake_states], with exactly one incoming
message allowed per state. The handlers first [parse][parse_handshake] the
handshake packet (which fails in case of malformed or unknown data) and then
dispatch it to the handling function. The [handshake state][handshake_state] is
carried around and a fresh one is returned from the handler in case it needs
updates. It consists of a protocol version, the handshake state, configuration,
renegotiation data, and possibly a handshake fragment.
Logic of both handshake handlers is very localised, and does not mutate any
global data structures.
[poly]: https://realworldocaml.org/v1/en/html/variants.html#polymorphic-variants
[monad-ml]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/control.ml
[return_types]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/state.ml#L109
[encrypt]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/engine.ml#L48
[handle_packet]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/engine.ml#L240
[verify_mac]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/engine.ml#L85
[decrypt]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/engine.ml#L95
[handle_tls]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/engine.ml#L321
[handle_raw_record]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/engine.ml#L275
[separate_records]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/engine.ml#L150
[handshake_state]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/state.ml#L92
[parse_handshake]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/reader.ml#L361
[separate_handshakes]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/engine.ml#L217
[handshake_states]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/state.ml#L61
[server_handshake]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/handshake_server.ml#L247
[client_handshake]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/handshake_client.ml#L285
### Core API
OCaml permits the implementation a module to be exported via a more
abstract *signature* that hides the internal representation
details. Our public API for the core library consists of the
[Tls.Engine][tls-engine-mli] and [Tls.Config][tls-config-mli] modules.
`Tls.Engine` contains the basic reactive function `handle_tls`, mentioned above,
which processes incoming data and optionally produces a response, together with
several operations that allow one to initiate message transfer like
`send_application_data` (which processes application-level messages for
sending), `send_close_notify` (for sending the ending message) and `reneg`
(which initiates full TLS renegotiation).
The module also contains the only two ways to obtain the initial state:
```OCaml
val client : Config.client -> (state * Cstruct.t)
val server : Config.server -> state
```
That is, one needs a configuration value to create it. The `Cstruct.t`
that `client` emits is the initial Client Hello since in TLS,
the client starts the session.
`Tls.Config` synthesizes configurations, separately for client and server
endpoints, through the functions `client_exn` and `server_exn`. They take a
number of parameters that define a TLS session, check them for consistency, and
return the sanitized `config` value which can be used to create a `state` and,
thus, a session. If the check fails, they raise an exception.
The parameters include the pair of a certificate and its private key for the
server, and an `X509.Authenticator.t` for the client, both produced by our
[ocaml-x509][] library and described in a [previous article][x509-intro].
This design reflects our attempts to make the API as close to "fire and forget"
as we could, given the complexity of TLS: we wanted the library to be relatively
straightforward to use, have a minimal API footprint and, above all, fail very
early and very loudly when misconfigured.
[tls-engine-mli]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/engine.mli
[tls-config-mli]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lib/config.mli
[ocaml-x509]: https://github.com/mirleft/ocaml-x509
### Effectful front-ends
Clearly, reading and writing network data *does* change the state of the world.
Having a pure value describing the state of a TLS session is not really useful
once we write something onto the network; it is certainly not the case that we
can use more than one distinct `state` to process further data, as only one
value is in sync with the other endpoint at any given time.
Therefore we wrap the core types into stateful structures loosely inspired by
sockets and provide IO operations on those. The structures of `mirage` and `lwt`
front-ends mirror one another.
In both cases, the structure is pull-based in the sense that no processing is
done until the client requires a read, as opposed to a callback-driven design
where the client registers a callback and the library starts spinning in a
listening loop and invoking it as soon as there is data to be processed. We do
this because in an asynchronous context, it is easy to create a callback-driven
interface from a demand-driven one, but the opposite is possible only with
unbounded buffering of incoming data.
One exception to demand-driven design is the initial session creation: the
library will only yield the connection after the first handshake is over,
ensuring the invariant that it is impossible to interact with a connection if it
hasn't already been fully established.
**Mirage**
The `Mirage` [interface][tls_mirage_types_mli] matches the [FLOW][flow]
signature (with additional TLS-specific operations). We provide a functor that
needs to be applied to an underlying TCP module, to obtain a TLS transport on
top. For example:
```OCaml
module Server (Stack: STACKV4) (KV: KV_RO) =
struct
module TLS = Tls_mirage.Make (Stack.TCPV4)
module X509 = Tls_mirage.X509 (KV) (Clock)
let accept conf flow =
TLS.server_of_tcp_flow conf flow >>= function
| `Ok tls ->
TLS.read tls >>= function
| `Ok buf ->
TLS.write tls buf >>= fun () -> TLS.close buf
let start stack e kv =
lwt authenticator = X509.authenticator kv `Default in
let conf = Tls.Config.server_exn ~authenticator () in
Stack.listen_tcpv4 stack 4433 (accept conf) ;
Stack.listen stack
end
```
**Lwt**
The `lwt` interface has [two layers][tls_lwt_mli]. `Tls_lwt.Unix` is loosely based
on read/write operations from `Lwt_unix` and provides in-place update of
buffers. `read`, for example, takes a `Cstruct.t` to write into and returns the
number of bytes read. The surrounding module, `Tls_lwt`, provides a simpler,
`Lwt_io`-compatible API built on top:
```OCaml
let main host port =
lwt authenticator = X509_lwt.authenticator (`Ca_dir nss_trusted_ca_dir) in
lwt (ic, oc) = Tls_lwt.connect ~authenticator (host, port) in
let req = String.concat "\r\n" [
"GET / HTTP/1.1" ; "Host: " ^ host ; "Connection: close" ; "" ; ""
] in
Lwt_io.(write oc req >>= fun () -> read ic >>= print)
```
We have further plans to provide wrappers for [`Async`][async] and plain [`Unix`][ocaml-unix] in a
similar vein.
[tls_mirage_types_mli]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/mirage/tls_mirage_types.mli
[flow]: https://github.com/mirage/mirage/blob/ae3c966f8d726dc97208595b8005e02e39478cb1/types/V1.mli#L136
[example_unikernel]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/mirage/example/unikernel.ml
[tls_lwt_mli]: https://github.com/mirleft/ocaml-tls/blob/6dc9258a38489665abf2bd6cdbed8a1ba544d522/lwt/tls_lwt.mli

5
unikernel/duniverse/ocaml-tls/dune-project Normal file
View file

@ -0,0 +1,5 @@
(lang dune 3.0)
(name tls)
(version v2.0.3)
(formatting disabled)
(using mdx 0.2)

5
unikernel/duniverse/ocaml-tls/eio/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name tls_eio)
(public_name tls-eio)
(wrapped false)
(libraries tls eio ptime.clock.os))

30
unikernel/duniverse/ocaml-tls/eio/tests/dune Normal file
View file

@ -0,0 +1,30 @@
(copy_files ../../certificates/*.crt)
(copy_files ../../certificates/*.key)
(copy_files ../../certificates/*.pem)
(mdx
(package tls-eio)
(deps
server.pem
server.key
server-ec.pem
server-ec.key
(package tls-eio)
(package mirage-crypto-rng)
(package eio_main)))
; "dune runtest" just does a quick run with random inputs.
;
; To run with afl-fuzz instead (make sure you have a compiler with the afl option on!):
;
; dune runtest
; mkdir input
; echo hi > input/foo
; cp certificates/server.{key,pem} .
; afl-fuzz -m 1000 -i input -o output ./_build/default/eio/tests/fuzz.exe @@
(test
(package tls-eio)
(libraries crowbar tls-eio eio.mock logs logs.fmt)
(deps server.pem server.key)
(name fuzz)
(action (run %{test} --repeat 200)))

297
unikernel/duniverse/ocaml-tls/eio/tests/fuzz.ml Normal file
View file

@ -0,0 +1,297 @@
(* Fuzz testing for tls-eio.
This code picks two random strings, one for the client to send and one for
the server. It then starts a send and receive fiber for each end.
A dispatcher fiber then sends commands to these worker fibers
(see [action] for the possible actions).
This is intended to check for bugs in the Eio wrapper (rather than in Tls itself).
At the moment, it's just checking that tls-eio works when used correctly.
Each endpoint overlaps reads with writes (but not reads with other reads or
writes with other writes).
Some possible future improvements:
- It currently only checks the basic read/write/close operations.
It should be extended to check [reneg], etc too.
- Currently, cancelling a read operation marks the Tls flow as broken.
We should allow resuming after a cancelled read, and test that here.
- We should try injecting faults and make sure they're handled sensibly.
- It would be good to get coverage reports for these tests.
However, this requires changes to crowbar:
https://github.com/stedolan/crowbar/issues/4#issuecomment-1310277551
(a patched version reported 54% coverage of Tls_eio.ml) *)
open Eio.Std
let src = Logs.Src.create "fuzz" ~doc:"Fuzz tests"
module Log = (val Logs.src_log src : Logs.LOG)
module W = Eio.Buf_write
type transmit_amount = Mock_socket.transmit_amount
type op =
| Send of int (* The application sends some bytes to Tls *)
| Transmit of transmit_amount (* The network sends some types to the peer *)
| Recv (* The application tries to read some data *)
| Shutdown_send (* The application shuts down the sending side *)
let label name gen =
Crowbar.with_printer Fmt.(const string name) gen
let op =
Crowbar.choose @@ [
Crowbar.(map [range 4096]) (fun n -> Send n);
Crowbar.(map [range ~min:1 4096]) (fun n -> Transmit (`Bytes n));
label "recv" @@ Crowbar.const Recv;
label "shutdown-send" @@ Crowbar.const Shutdown_send;
]
type dir = To_client | To_server
let pp_dir f = function
| To_server -> Fmt.string f "client-to-server"
| To_client -> Fmt.string f "server-to-client"
let dir =
Crowbar.choose [
label "server-to-client" @@ Crowbar.const To_client;
label "client-to-server" @@ Crowbar.const To_server;
]
(* A test case is a random sequence of [action]s, followed by party shutting
down the sending side of the connection (if it hasn't already done so) and
the network draining any queued traffic.
Once all fibers have finished, we check that what was sent matches the data
that has been received. *)
let action =
Crowbar.option (Crowbar.pair dir op) (* None means yield *)
(* A [Path] is one direction (either server-to-client or client-to-server).
The two paths can be tested mostly independently (except for shutdown at the moment). *)
module Path : sig
type t
val create :
sender:(Tls_eio.t, exn) result Promise.t ->
receiver:(Tls_eio.t, exn) result Promise.t ->
transmit:(transmit_amount -> unit) ->
dir -> string -> t
(** Create a test driver for one direction, from [sender] to [receiver].
[transmit n] causes [n] bytes to be transferred over the mock network. *)
val close : t -> unit
(** [close t] causes the sender to close the socket for sending.
Futher send operations will be ignored. *)
val run : t -> unit
(** Run the send and receive fibers. Returns once the receiver has read EOF. *)
val enqueue : t -> op -> unit
(** Send a command to the send or receive fiber (depending on [op]). *)
end = struct
type t = {
dir : dir;
message : string; (* The complete message to be transmitted over this path. *)
(* We need to construct [t] before the handshake is done, so these are promises: *)
sender : Tls_eio.t Promise.or_exn;
receiver : Tls_eio.t Promise.or_exn;
mutable sent : int; (* Bytes of [message] sent so far *)
mutable recv : int; (* Bytes of [message] received so far *)
send_commands : [`Send of int | `Exit] Eio.Stream.t; (* Commands for the sending fiber *)
recv_commands : [`Recv | `Drain] Eio.Stream.t; (* Commands for the receiving fiber *)
transmit : transmit_amount -> unit;
}
let pp_dir f t =
pp_dir f t.dir
let create ~sender ~receiver ~transmit dir message =
let send_commands = Eio.Stream.create max_int in
let recv_commands = Eio.Stream.create max_int in
{ dir; message; sender; receiver; sent = 0; recv = 0;
send_commands; recv_commands; transmit }
let shutdown t =
Eio.Stream.add t.send_commands `Exit
let close t =
shutdown t; (* Sender stops sending *)
t.transmit `Drain; (* Network transmits everything *)
Eio.Stream.add t.recv_commands `Drain (* Receiver reads everything *)
let run_send_thread t =
let sender = Promise.await_exn t.sender in
Logs.info (fun f -> f "%a: sender ready" pp_dir t);
let rec aux () =
match Eio.Stream.take t.send_commands with
| `Exit ->
Log.info (fun f -> f "%a: shutdown send (Tls level)" pp_dir t);
Eio.Flow.shutdown sender `Send
| `Send len ->
let available = String.length t.message - t.sent in
let len = min len available in
if len > 0 then (
let msg = Cstruct.of_string ~off:t.sent ~len t.message in
t.sent <- t.sent + len;
Log.info (fun f -> f "%a: sending %S" pp_dir t (Cstruct.to_string msg));
Eio.Flow.write sender [msg];
);
aux ()
in
aux()
let run_recv_thread t =
let recv = Promise.await_exn t.receiver in
Logs.info (fun f -> f "%a: receiver ready" pp_dir t);
try
let drain = ref false in
while true do
if !drain = false then (
begin match Eio.Stream.take t.recv_commands with
| `Recv -> ()
| `Drain -> drain := true
end
);
let buf = Cstruct.create 4096 in
let got = Eio.Flow.single_read recv buf in
let received = Cstruct.to_string buf ~len:got in
Log.info (fun f -> f "%a: received %S" pp_dir t received);
let expected = String.sub t.message t.recv got in
if received <> expected then
Fmt.failwith "%a: excepted %S but got %S!" pp_dir t expected received;
t.recv <- t.recv + got
done
with End_of_file ->
if t.recv <> t.sent then (
Fmt.failwith "%a: Sender sent %d bytes, but receiver got EOF after reading only %d"
pp_dir t
t.sent
t.recv
);
Log.info (fun f -> f "%a: recv thread done (got EOF)" pp_dir t)
let run t =
Fiber.both
(fun () -> run_send_thread t)
(fun () -> run_recv_thread t)
let pp_amount f = function
| `Bytes n -> Fmt.pf f "%d bytes" n
| `Drain -> Fmt.string f "all bytes"
let enqueue t = function
| Send i->
Log.info (fun f -> f "%a: enqueue send %d bytes of plaintext" pp_dir t i);
Eio.Stream.add t.send_commands @@ `Send i;
| Recv ->
Log.info (fun f -> f "%a: enqueue read from Tls" pp_dir t);
Eio.Stream.add t.recv_commands @@ `Recv;
| Transmit i ->
Log.info (fun f -> f "%a: enqueue transmit %a over network" pp_dir t pp_amount i);
t.transmit i
| Shutdown_send ->
Log.info (fun f -> f "%a: enqueue shutdown send" pp_dir t);
shutdown t
end
module Config : sig
val client : Tls.Config.client
val server : Tls.Config.server
end = struct
let null_auth ?ip:_ ~host:_ _ = Ok None
let client =
Result.get_ok (Tls.Config.client ~authenticator:null_auth ())
let read_file path =
let ch = open_in_bin path in
let len = in_channel_length ch in
let data = really_input_string ch len in
close_in ch;
data
let server =
let certs = Result.get_ok (X509.Certificate.decode_pem_multiple (read_file "server.pem")) in
let pk = Result.get_ok (X509.Private_key.decode_pem (read_file "server.key")) in
let certificates = `Single (certs, pk) in
Result.get_ok Tls.Config.(server ~version:(`TLS_1_0, `TLS_1_3) ~certificates ~ciphers:Ciphers.supported ())
end
let dispatch_commands ~to_server ~to_client actions =
let rec aux = function
| [] ->
Log.info (fun f -> f "dispatch_commands: done");
Path.close to_client;
Path.close to_server
| None :: xs ->
Fiber.yield (); aux xs
| Some (dir, op) :: xs ->
let path =
match dir with
| To_server-> to_server
| To_client -> to_client
in
Path.enqueue path op;
aux xs
in
aux actions
(* In some runs we automatically perform these actions first, which allows the handshake to complete.
This lets the fuzz tester get to the interesting cases more quickly. *)
let quickstart_actions = [
Some (To_server, Transmit (`Bytes 4096));
None; (* Client sends handshake *)
None; (* Server reads handshake *)
Some (To_client, Transmit (`Bytes 4096));
None; (* Server replies to handshake *)
None; (* Client reads reply *)
Some (To_server, Transmit (`Bytes 4096));
None; (* Client sends final part *)
None; (* Server receives it *)
Some (To_client, Recv);
Some (To_server, Recv);
]
let main client_message server_message quickstart actions =
let actions =
if quickstart then quickstart_actions @ actions
else actions
in
Eio_mock.Backend.run @@ fun () ->
Switch.run @@ fun sw ->
let insecure_test_rng = Mirage_crypto_rng.create (module Test_rng) in
Mirage_crypto_rng.set_default_generator insecure_test_rng;
let client_socket, server_socket = Mock_socket.create_pair () in
let server_flow = Fiber.fork_promise ~sw (fun () -> Tls_eio.server_of_flow Config.server server_socket) in
let client_flow = Fiber.fork_promise ~sw (fun () -> Tls_eio.client_of_flow Config.client client_socket) in
let to_server =
Path.create
~sender:client_flow
~receiver:server_flow
~transmit:(Mock_socket.transmit client_socket)
To_server client_message in
let to_client =
Path.create
~sender:server_flow
~receiver:client_flow
~transmit:(Mock_socket.transmit server_socket)
To_client server_message
in
Fiber.all [
(fun () -> dispatch_commands actions ~to_server ~to_client);
(fun () -> Path.run to_server);
(fun () -> Path.run to_client);
]
let () =
Logs.set_level (Some Warning);
Logs.set_reporter (Logs_fmt.reporter ());
Crowbar.(add_test ~name:"random ops" [bytes; bytes; bool; list action] main)

94
unikernel/duniverse/ocaml-tls/eio/tests/mock_socket.ml Normal file
View file

@ -0,0 +1,94 @@
open Eio.Std
module W = Eio.Buf_write
let src = Logs.Src.create "mock-socket" ~doc:"Test socket"
module Log = (val Logs.src_log src : Logs.LOG)
type transmit_amount = [`Bytes of int | `Drain]
type ty = [`Mock_tls | Eio.Flow.two_way_ty | Eio.Resource.close_ty]
type t = ty r
let rec takev len = function
| [] -> []
| x :: xs ->
if len = 0 then []
else if Cstruct.length x >= len then [Cstruct.sub x 0 len]
else x :: takev (len - Cstruct.length x) xs
module Impl = struct
type t = {
to_peer : W.t;
from_peer : W.t;
label : string;
output_sizes : transmit_amount Eio.Stream.t;
}
let create ~to_peer ~from_peer label = {
to_peer;
from_peer;
label;
output_sizes = Eio.Stream.create max_int;
}
let transmit t x =
Eio.Stream.add t.output_sizes x
let single_write t bufs =
let size =
match Eio.Stream.take t.output_sizes with
| `Drain -> Eio.Stream.add t.output_sizes `Drain; Cstruct.lenv bufs
| `Bytes size -> size
in
let bufs = takev size bufs in
List.iter (W.cstruct t.to_peer) bufs;
let len = Cstruct.lenv bufs in
Log.info (fun f -> f "%s: wrote %d bytes to network" t.label len);
len
let copy t ~src = Eio.Flow.Pi.simple_copy ~single_write t ~src
let single_read t buf =
let batch = W.await_batch t.from_peer in
let got, _ = Cstruct.fillv ~src:batch ~dst:buf in
Log.info (fun f -> f "%s: read %d bytes from network" t.label got);
W.shift t.from_peer got;
got
let shutdown t = function
| `Send ->
Log.info (fun f -> f "%s: close writer" t.label);
W.close t.to_peer
| _ -> failwith "Not implemented"
let close t =
Log.info (fun f -> f "%s: close connection" t.label)
let read_methods = []
type (_, _, _) Eio.Resource.pi += Raw : ('t, 't -> t, ty) Eio.Resource.pi
let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw t
end
let handler =
Eio.Resource.handler (
H (Impl.Raw, Fun.id) ::
H (Eio.Resource.Close, Impl.close) ::
Eio.Resource.bindings (Eio.Flow.Pi.two_way (module Impl))
)
let transmit t x =
let t = Impl.raw t in
Impl.transmit t x
let create ~from_peer ~to_peer label =
let t = Impl.create ~from_peer ~to_peer label in
Eio.Resource.T (t, handler)
let create_pair () =
let to_a = W.create 100 in
let to_b = W.create 100 in
let a = create ~from_peer:to_a ~to_peer:to_b "client" in
let b = create ~from_peer:to_b ~to_peer:to_a "server" in
a, b

13
unikernel/duniverse/ocaml-tls/eio/tests/mock_socket.mli Normal file
View file

@ -0,0 +1,13 @@
open Eio.Std
type transmit_amount = [
| `Bytes of int (* Send the next n bytes of data *)
| `Drain (* Transmit all data immediately from now on *)
]
type t = [`Mock_tls | Eio.Flow.two_way_ty | Eio.Resource.close_ty] r
val create_pair : unit -> t * t
(** Create a pair of sockets [client, server], such that writes to one can be read from the other. *)
val transmit : t -> transmit_amount -> unit

21
unikernel/duniverse/ocaml-tls/eio/tests/test_rng.ml Normal file
View file

@ -0,0 +1,21 @@
(* Insecure predictable RNG for fuzz testing. *)
type g = int ref
let block = 1
let create ?time:_ () = ref 1234
let generate_into ~g buf ~off n =
for i = off to off + n - 1 do
Bytes.set_uint8 buf i !g;
g := !g + 1
done
let reseed ~g:_ _ = ()
let accumulate ~g:_ _ = `Acc ignore
let seeded ~g:_ = true
let pools = 0

114
unikernel/duniverse/ocaml-tls/eio/tests/tls_eio.md Normal file
View file

@ -0,0 +1,114 @@
```ocaml
# #require "digestif.c";;
# #require "eio_main";;
# #require "tls-eio";;
# #require "mirage-crypto-rng.unix";;
```
```ocaml
open Eio.Std
module Flow = Eio.Flow
```
## Test client
```ocaml
let null_auth ?ip:_ ~host:_ _ = Ok None
let mypsk = ref None
let ticket_cache = {
Tls.Config.lookup = (fun _ -> None) ;
ticket_granted = (fun psk epoch -> mypsk := Some (psk, epoch)) ;
lifetime = 0l ;
timestamp = Ptime_clock.now
}
let test_client ~net (host, service) =
match Eio.Net.getaddrinfo_stream net host ~service with
| [] -> failwith "No addresses found!"
| addr :: _ ->
let authenticator = null_auth in
Switch.run @@ fun sw ->
let socket = Eio.Net.connect ~sw net addr in
let flow =
let host =
Result.to_option
(Result.bind (Domain_name.of_string host) Domain_name.host)
in
Tls_eio.client_of_flow
(Result.get_ok Tls.Config.(client ~version:(`TLS_1_0, `TLS_1_3) ?cached_ticket:!mypsk ~ticket_cache ~authenticator ~ciphers:Ciphers.supported ()))
?host socket
in
let req = String.concat "\r\n" [
"GET / HTTP/1.1" ; "Host: " ^ host ; "Connection: close" ; "" ; ""
] in
Flow.copy_string req flow;
let r = Eio.Buf_read.of_flow flow ~max_size:max_int in
let line = Eio.Buf_read.take 3 r in
traceln "client <- %s" line;
Eio.Resource.close flow;
traceln "client done."
```
## Test server
```ocaml
let server_config dir =
let ( / ) = Eio.Path.( / ) in
let certificate =
X509_eio.private_of_pems
~cert:(dir / "server.pem")
~priv_key:(dir / "server.key")
in
let ec_certificate =
X509_eio.private_of_pems
~cert:(dir / "server-ec.pem")
~priv_key:(dir / "server-ec.key")
in
let certificates = `Multiple [ certificate ; ec_certificate ] in
Result.get_ok Tls.Config.(server ~version:(`TLS_1_0, `TLS_1_3) ~certificates ~ciphers:Ciphers.supported ())
let serve_ssl ~config server_s callback =
Switch.run @@ fun sw ->
let client, addr = Eio.Net.accept ~sw server_s in
let flow = Tls_eio.server_of_flow config client in
traceln "server -> connect";
callback flow addr
```
## Test case
```ocaml
# Eio_main.run @@ fun env ->
let net = env#net in
let certificates_dir = env#cwd in
Mirage_crypto_rng_unix.use_default ();
Switch.run @@ fun sw ->
let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 4433) in
let listening_socket = Eio.Net.listen ~sw net ~backlog:5 ~reuse_addr:true addr in
(* Eio.Time.with_timeout_exn env#clock 0.1 @@ fun () -> *)
Fiber.both
(fun () ->
traceln "server -> start @@ %a" Eio.Net.Sockaddr.pp addr;
let config = server_config certificates_dir in
serve_ssl ~config listening_socket @@ fun flow _addr ->
traceln "handler accepted";
let r = Eio.Buf_read.of_flow flow ~max_size:max_int in
let line = Eio.Buf_read.line r in
traceln "handler + %s" line;
Flow.copy_string line flow
)
(fun () ->
test_client ~net ("127.0.0.1", "4433")
)
;;
+server -> start @ tcp:127.0.0.1:4433
+server -> connect
+handler accepted
+handler + GET / HTTP/1.1
+client <- GET
+client done.
- : unit = ()
```

250
unikernel/duniverse/ocaml-tls/eio/tls_eio.ml Normal file
View file

@ -0,0 +1,250 @@
open Eio.Std
module Flow = Eio.Flow
exception Tls_alert of Tls.Packet.alert_type
exception Tls_failure of Tls.Engine.failure
type Eio.Exn.Backend.t += Tls_socket_closed
let () = Eio.Exn.Backend.register_pp (fun f -> function
| Tls_socket_closed -> Fmt.pf f "TLS_socket_closed"; true
| _ -> false
)
type ty = [ `Tls | Eio.Flow.two_way_ty | Eio.Resource.close_ty ]
type t = ty r
module Raw = struct
(* We could replace [`Eof] with [`Error End_of_file] and then use
a regular [result] type here. *)
type t = {
flow : [Flow.two_way_ty | Eio.Resource.close_ty] r;
mutable state : [ `Active of Tls.Engine.state
| `Read_closed of Tls.Engine.state
| `Write_closed of Tls.Engine.state
| `Closed
| `Error of exn ] ;
mutable linger : Cstruct.t option ;
recv_buf : Cstruct.t ;
}
let half_close state mode =
match state, mode with
| `Active tls, `read -> `Read_closed tls
| `Active tls, `write -> `Write_closed tls
| `Active _, `read_write -> `Closed
| `Read_closed tls, `read -> `Read_closed tls
| `Read_closed _, (`write | `read_write) -> `Closed
| `Write_closed tls, `write -> `Write_closed tls
| `Write_closed _, (`read | `read_write) -> `Closed
| (`Closed | `Error _) as e, (`read | `write | `read_write) -> e
let inject_state tls = function
| `Active _ -> `Active tls
| `Read_closed _ -> `Read_closed tls
| `Write_closed _ -> `Write_closed tls
| (`Closed | `Error _) as e -> e
let write_t t s =
try Flow.copy_string s t.flow
with exn ->
(match t.state with
| `Error _ -> ()
| _ -> t.state <- `Error exn) ;
raise exn
let try_write_t t cs =
try write_t t cs
with _ -> Eio.Fiber.check () (* Error is in [t.state] *)
let rec read_react t =
let handle tls buf =
match Tls.Engine.handle_tls tls buf with
| Ok (state', eof, `Response resp, `Data data) ->
let state' = inject_state state' t.state in
let state' = Option.(value ~default:state' (map (fun `Eof -> half_close state' `read) eof)) in
t.state <- state' ;
Option.iter (try_write_t t) resp;
Option.map Cstruct.of_string data
| Error (fail, `Response resp) ->
t.state <- `Error (match fail with `Alert a -> Tls_alert a | f -> Tls_failure f) ;
write_t t resp; read_react t
in
match t.state with
| `Error e -> raise e
| `Closed
| `Read_closed _ -> raise End_of_file
| _ ->
match Flow.single_read t.flow t.recv_buf with
| exception End_of_file ->
t.state <- half_close t.state `read;
raise End_of_file
| exception exn ->
(match t.state with
| `Error _ -> ()
| _ -> t.state <- `Error exn) ;
raise exn
| n ->
match t.state with
| `Error e -> raise e
| `Active tls | `Read_closed tls | `Write_closed tls ->
handle tls (Cstruct.to_string t.recv_buf ~off:0 ~len:n)
| `Closed -> raise End_of_file
let rec single_read t buf =
let writeout res =
let open Cstruct in
let rlen = length res in
let n = min (length buf) rlen in
blit res 0 buf 0 n ;
t.linger <-
(if n < rlen then Some (sub res n (rlen - n)) else None) ;
n in
match t.linger with
| Some res -> writeout res
| None ->
match read_react t with
| None -> single_read t buf
| Some res -> writeout res
let writev t css =
match t.state with
| `Error err -> raise err
| `Write_closed _ | `Closed -> raise (Eio.Net.err (Connection_reset Tls_socket_closed))
| `Active tls | `Read_closed tls ->
let css = List.map Cstruct.to_string css in
match Tls.Engine.send_application_data tls css with
| Some (tls, tlsdata) ->
( t.state <- inject_state tls t.state ; write_t t tlsdata )
| None -> invalid_arg "tls: write: socket not ready"
let single_write t bufs =
writev t bufs;
Cstruct.lenv bufs
(*
* XXX bad XXX
* This is a point that should particularly be protected from concurrent r/w.
* Doing this before a `t` is returned is safe; redoing it during rekeying is
* not, as the API client already sees the `t` and can mistakenly interleave
* writes while this is in progress.
* *)
let rec drain_handshake t =
let push_linger t mcs =
match (mcs, t.linger) with
| (None, _) -> ()
| (scs, None) -> t.linger <- scs
| (Some cs, Some l) -> t.linger <- Some (Cstruct.append l cs)
in
match t.state with
| `Active tls when not (Tls.Engine.handshake_in_progress tls) ->
t
| _ ->
let cs = read_react t in
push_linger t cs; drain_handshake t
let reneg ?authenticator ?acceptable_cas ?cert ?(drop = true) t =
match t.state with
| `Error err -> raise err
| `Closed | `Read_closed _ | `Write_closed _ -> invalid_arg "tls: closed socket"
| `Active tls ->
match Tls.Engine.reneg ?authenticator ?acceptable_cas ?cert tls with
| None -> invalid_arg "tls: can't renegotiate"
| Some (tls', buf) ->
if drop then t.linger <- None ;
t.state <- inject_state tls' t.state ;
write_t t buf;
ignore (drain_handshake t : t)
let key_update ?request t =
match t.state with
| `Error err -> raise err
| `Write_closed _ | `Closed -> invalid_arg "tls: closed socket"
| `Active tls | `Read_closed tls ->
match Tls.Engine.key_update ?request tls with
| Error f -> Fmt.invalid_arg "tls: can't update key: %a" Tls.Engine.pp_failure f
| Ok (tls', buf) ->
t.state <- inject_state tls' t.state ;
write_t t buf
let shutdown t = function
| `Receive -> ()
| `Send | `All ->
match t.state with
| `Active tls | `Read_closed tls ->
let tls', buf = Tls.Engine.send_close_notify tls in
t.state <- inject_state tls' (half_close t.state `write) ;
write_t t buf
| _ -> ()
let server_of_flow config flow =
drain_handshake {
state = `Active (Tls.Engine.server config) ;
flow = (flow :> [Flow.two_way_ty | Eio.Resource.close_ty] r) ;
linger = None ;
recv_buf = Cstruct.create 4096
}
let client_of_flow config ?host flow =
let config' = match host with
| None -> config
| Some host -> Tls.Config.peer config host
in
let (tls, init) = Tls.Engine.client config' in
let t = {
state = `Active tls ;
flow = (flow :> [Flow.two_way_ty | Eio.Resource.close_ty] r);
linger = None ;
recv_buf = Cstruct.create 4096
} in
write_t t init;
drain_handshake t
let epoch t =
match t.state with
| `Active tls | `Read_closed tls | `Write_closed tls -> Tls.Engine.epoch tls
| `Closed | `Error _ -> Error ()
let copy t ~src = Eio.Flow.Pi.simple_copy ~single_write t ~src
let read_methods = []
let close t = Eio.Resource.close t.flow
type (_, _, _) Eio.Resource.pi += T : ('t, 't -> t, ty) Eio.Resource.pi
end
let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw.T t
let handler =
Eio.Resource.handler [
H (Eio.Flow.Pi.Source, (module Raw));
H (Eio.Flow.Pi.Sink, (module Raw));
H (Eio.Flow.Pi.Shutdown, (module Raw));
H (Eio.Resource.Close, Raw.close);
H (Raw.T, Fun.id);
]
let of_t t = Eio.Resource.T (t, handler)
let server_of_flow config flow = Raw.server_of_flow config flow |> of_t
let client_of_flow config ?host flow = Raw.client_of_flow config ?host flow |> of_t
let reneg ?authenticator ?acceptable_cas ?cert ?drop (t:t) = Raw.reneg ?authenticator ?acceptable_cas ?cert ?drop (raw t)
let key_update ?request (t:t) = Raw.key_update ?request (raw t)
let epoch (t:t) = Raw.epoch (raw t)
let () =
Printexc.register_printer (function
| Tls_alert typ ->
Some ("TLS alert from peer: " ^ Tls.Packet.alert_type_to_string typ)
| Tls_failure f ->
Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
| _ -> None)

59
unikernel/duniverse/ocaml-tls/eio/tls_eio.mli Normal file
View file

@ -0,0 +1,59 @@
(** Effectful operations using Eio for pure TLS.
The pure TLS is state and buffer in, state and buffer out. This
module uses Eio for communication over the network. *)
open Eio.Std
(** [Tls_alert] exception received from the other endpoint *)
exception Tls_alert of Tls.Packet.alert_type
(** [Tls_failure] exception while processing incoming data *)
exception Tls_failure of Tls.Engine.failure
type t = [ `Tls | Eio.Flow.two_way_ty | Eio.Resource.close_ty ] r
(** {2 Constructors} *)
(** [server_of_flow server flow] is [t], after server-side TLS
handshake of [flow] using [server] configuration.
You must ensure a RNG is installed while using TLS, e.g. using [Mirage_crypto_rng_unix.use_default ()].
Ideally, this would be part of the [server] config so you couldn't forget it,
but for now you'll get a runtime error if you forget. *)
val server_of_flow :
Tls.Config.server ->
[> Eio.Flow.two_way_ty | Eio.Resource.close_ty] r -> t
(** [client_of_flow client ~host fd] is [t], after client-side
TLS handshake of [flow] using [client] configuration and [host].
You must ensure a RNG is installed while using TLS, e.g. using [Mirage_crypto_rng_unix.use_default ()].
Ideally, this would be part of the [client] config so you couldn't forget it,
but for now you'll get a runtime error if you forget. *)
val client_of_flow :
Tls.Config.client -> ?host:[ `host ] Domain_name.t ->
[> Eio.Flow.two_way_ty | Eio.Resource.close_ty] r -> t
(** {2 Control of TLS features} *)
(** [reneg ~authenticator ~acceptable_cas ~cert ~drop t] renegotiates the
session, and blocks until the renegotiation finished. Optionally, a new
[authenticator] and [acceptable_cas] can be used. The own certificate can
be adjusted by [cert]. If [drop] is [true] (the default),
application data received before the renegotiation finished is dropped. *)
val reneg :
?authenticator:X509.Authenticator.t ->
?acceptable_cas:X509.Distinguished_name.t list ->
?cert:Tls.Config.own_cert ->
?drop:bool ->
t -> unit
(** [key_update ~request t] updates the traffic key and requests a traffic key
update from the peer if [request] is provided and [true] (the default).
This is only supported in TLS 1.3. *)
val key_update : ?request:bool -> t -> unit
(** [epoch t] returns [epoch], which contains information of the
active session. *)
val epoch : t -> (Tls.Core.epoch_data, unit) result

89
unikernel/duniverse/ocaml-tls/eio/x509_eio.ml Normal file
View file

@ -0,0 +1,89 @@
open Eio.Std
module Path = Eio.Path
let (</>) = Path.( / )
let extension str =
let n = String.length str in
let rec scan = function
| i when i = 0 -> None
| i when str.[i - 1] = '.' ->
Some (String.sub str i (n - i))
| i -> scan (pred i) in
scan n
let private_of_pems ~cert ~priv_key =
let certs =
try
let pem = Path.load cert in
match X509.Certificate.decode_pem_multiple pem with
| Ok cs -> cs
| Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m)
with Invalid_argument m ->
Fmt.failwith "Private certificates %a: %s" Path.pp cert m
in
let pk =
try
let pem = Path.load priv_key in
match X509.Private_key.decode_pem pem with
| Ok key -> key
| Error (`Msg m) -> invalid_arg ("failed to parse private key " ^ m)
with Invalid_argument m ->
Fmt.failwith "Private key (%a): %s" Path.pp priv_key m
in
(certs, pk)
let certs_of_pem path =
try
let pem = Path.load path in
match X509.Certificate.decode_pem_multiple pem with
| Ok cs -> cs
| Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m)
with Invalid_argument m ->
Fmt.failwith "Certificates in %a: %s" Path.pp path m
let certs_of_pem_dir path =
Path.read_dir path
|> List.filter (fun file -> extension file = Some "crt")
|> Fiber.List.map (fun file -> certs_of_pem (path </> file))
|> List.concat
let crl_of_pem path =
try
let data = Path.load path in
match X509.CRL.decode_der data with
| Ok cs -> cs
| Error (`Msg m) -> invalid_arg ("failed to parse CRL " ^ m)
with Invalid_argument m ->
Fmt.failwith "CRL in %a: %s" Path.pp path m
let crls_of_pem_dir path =
Path.read_dir path
|> Fiber.List.map (fun file -> crl_of_pem (path </> file))
(* Would be better to take an Eio.Time.clock here, but that API is likely to change soon. *)
let authenticator ?allowed_hashes ?crls param =
let time () = Some (Ptime_clock.now ()) in
let of_cas cas =
let crls = Option.map crls_of_pem_dir crls in
X509.Authenticator.chain_of_trust ?allowed_hashes ?crls ~time cas
and dotted_hex_to_cs hex =
Cstruct.to_string (Cstruct.of_hex (String.map (function ':' -> ' ' | x -> x) hex))
and fingerp hash fingerprint =
X509.Authenticator.key_fingerprint ~time ~hash ~fingerprint
and cert_fingerp hash fingerprint =
X509.Authenticator.cert_fingerprint ~time ~hash ~fingerprint
in
match param with
| `Ca_file path -> certs_of_pem path |> of_cas
| `Ca_dir path -> certs_of_pem_dir path |> of_cas
| `Key_fingerprint (hash, fp) -> fingerp hash fp
| `Hex_key_fingerprint (hash, fp) ->
let fp = dotted_hex_to_cs fp in
fingerp hash fp
| `Cert_fingerprint (hash, fp) -> cert_fingerp hash fp
| `Hex_cert_fingerprint (hash, fp) ->
let fp = dotted_hex_to_cs fp in
cert_fingerp hash fp

26
unikernel/duniverse/ocaml-tls/eio/x509_eio.mli Normal file
View file

@ -0,0 +1,26 @@
(** X.509 certificate handling using Eio. *)
(** [private_of_pems ~cert ~priv_key] is [priv], after reading the
private key and certificate chain from the given PEM-encoded
files. *)
val private_of_pems : cert:_ Eio.Path.t -> priv_key:_ Eio.Path.t -> Tls.Config.certchain
(** [certs_of_pem file] is [certificates], which are read from the
PEM-encoded [file]. *)
val certs_of_pem : _ Eio.Path.t -> X509.Certificate.t list
(** [certs_of_pem_dir dir] is [certificates], which are read from all
PEM-encoded files in [dir]. *)
val certs_of_pem_dir : _ Eio.Path.t -> X509.Certificate.t list
(** [authenticator methods] constructs an [authenticator] using the
specified method and data. *)
val authenticator : ?allowed_hashes:Digestif.hash' list -> ?crls:_ Eio.Path.t ->
[ `Ca_file of _ Eio.Path.t
| `Ca_dir of _ Eio.Path.t
| `Key_fingerprint of Digestif.hash' * string
| `Hex_key_fingerprint of Digestif.hash' * string
| `Cert_fingerprint of Digestif.hash' * string
| `Hex_cert_fingerprint of Digestif.hash' * string
]
-> X509.Authenticator.t

366
unikernel/duniverse/ocaml-tls/lib/ciphersuite.ml Normal file
View file

@ -0,0 +1,366 @@
(** Ciphersuite definitions and some helper functions. *)
(** sum type of all possible key exchange methods *)
type key_exchange_algorithm_dhe = [ `FFDHE | `ECDHE ]
type key_exchange_algorithm = [ key_exchange_algorithm_dhe | `RSA ]
let pp_key_exchange_algorithm_dhe ppf = function
| `FFDHE -> Fmt.string ppf "FFDHE"
| `ECDHE -> Fmt.string ppf "ECDHE"
let pp_key_exchange_algorithm ppf = function
| #key_exchange_algorithm_dhe as d -> pp_key_exchange_algorithm_dhe ppf d
| `RSA -> Fmt.string ppf "RSA"
(** [required_usage kex] is [usage] which a certificate must have if it is used in the given [kex] method *)
let required_usage = function
| #key_exchange_algorithm_dhe -> `Digital_signature
| `RSA -> `Key_encipherment
type block_cipher =
| TRIPLE_DES_EDE_CBC
| AES_128_CBC
| AES_256_CBC
let pp_block_cipher ppf = function
| TRIPLE_DES_EDE_CBC -> Fmt.string ppf "3DES EDE CBC"
| AES_128_CBC -> Fmt.string ppf "AES128 CBC"
| AES_256_CBC -> Fmt.string ppf "AES256 CBC"
type aead_cipher =
| AES_128_CCM
| AES_256_CCM
| AES_128_GCM
| AES_256_GCM
| CHACHA20_POLY1305
let pp_aead_cipher ppf = function
| AES_128_CCM -> Fmt.string ppf "AES128 CCM"
| AES_256_CCM -> Fmt.string ppf "AES256 CCM"
| AES_128_GCM -> Fmt.string ppf "AES128 GCM"
| AES_256_GCM -> Fmt.string ppf "AES256 GCM"
| CHACHA20_POLY1305 -> Fmt.string ppf "CHACHA20 POLY1305"
type payload_protection13 = [ `AEAD of aead_cipher ]
let pp_payload_protection13 ppf = function
| `AEAD a -> Fmt.pf ppf "AEAD %a" pp_aead_cipher a
type payload_protection = [
payload_protection13
| `Block of block_cipher * Digestif.hash'
]
let pp_hash ppf = function
| `MD5 -> Fmt.string ppf "MD5"
| `SHA1 -> Fmt.string ppf "SHA1"
| `SHA224 -> Fmt.string ppf "SHA224"
| `SHA256 -> Fmt.string ppf "SHA256"
| `SHA384 -> Fmt.string ppf "SHA384"
| `SHA512 -> Fmt.string ppf "SHA512"
let pp_payload_protection ppf = function
| #payload_protection13 as p -> pp_payload_protection13 ppf p
| `Block (b, h) -> Fmt.pf ppf "BLOCK %a %a" pp_block_cipher b pp_hash h
(* this is K_LEN, max 8 N_MIN from RFC5116 sections 5.1 & 5.2 -- as defined in TLS1.3 RFC 8446 Section 5.3 *)
let kn_13 = function
| AES_128_GCM -> (16, 12)
| AES_256_GCM -> (32, 12)
| AES_128_CCM -> (16, 12)
| AES_256_CCM -> (32, 12)
| CHACHA20_POLY1305 -> (32, 12)
(** [key_length iv payload_protection] is [(key size, IV size, mac size)] where key IV, and mac sizes are the required bytes for the given [payload_protection] *)
(* NB only used for <= TLS 1.2, IV length for AEAD defined in RFC 5288 Section 3 (for GCM), salt[4] for CCM in RFC 6655 Section 3 *)
let key_length iv pp =
let mac_size m =
let module H = (val Digestif.module_of_hash' m) in
H.digest_size
in
match pp with
| `AEAD AES_128_CCM -> (16, 4 , 0)
| `AEAD AES_256_CCM -> (32, 4 , 0)
| `AEAD AES_128_GCM -> (16, 4 , 0)
| `AEAD AES_256_GCM -> (32, 4 , 0)
| `AEAD CHACHA20_POLY1305 -> (32, 12, 0)
| `Block (bc, mac) ->
let keylen, ivlen = match bc with
| TRIPLE_DES_EDE_CBC -> (24, 8)
| AES_128_CBC -> (16, 16)
| AES_256_CBC -> (32, 16)
and maclen = mac_size mac
in
match iv with
| None -> (keylen, 0, maclen)
| Some () -> (keylen, ivlen, maclen)
type ciphersuite13 = [
| `AES_128_GCM_SHA256
| `AES_256_GCM_SHA384
| `CHACHA20_POLY1305_SHA256
| `AES_128_CCM_SHA256
]
let privprot13 = function
| `AES_128_GCM_SHA256 -> AES_128_GCM
| `AES_256_GCM_SHA384 -> AES_256_GCM
| `CHACHA20_POLY1305_SHA256 -> CHACHA20_POLY1305
| `AES_128_CCM_SHA256 -> AES_128_CCM
let hash13 = function
| `AES_128_GCM_SHA256 -> `SHA256
| `AES_256_GCM_SHA384 -> `SHA384
| `CHACHA20_POLY1305_SHA256 -> `SHA256
| `AES_128_CCM_SHA256 -> `SHA256
let any_ciphersuite_to_ciphersuite13 = function
| Packet.TLS_AES_128_GCM_SHA256 -> Some `AES_128_GCM_SHA256
| Packet.TLS_AES_256_GCM_SHA384 -> Some `AES_256_GCM_SHA384
| Packet.TLS_CHACHA20_POLY1305_SHA256 -> Some `CHACHA20_POLY1305_SHA256
| Packet.TLS_AES_128_CCM_SHA256 -> Some `AES_128_CCM_SHA256
| _ -> None
type ciphersuite = [
ciphersuite13
| `DHE_RSA_WITH_AES_128_GCM_SHA256
| `DHE_RSA_WITH_AES_256_GCM_SHA384
| `DHE_RSA_WITH_AES_256_CCM
| `DHE_RSA_WITH_AES_128_CCM
| `DHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `DHE_RSA_WITH_AES_256_CBC_SHA256
| `DHE_RSA_WITH_AES_128_CBC_SHA256
| `DHE_RSA_WITH_AES_256_CBC_SHA
| `DHE_RSA_WITH_AES_128_CBC_SHA
| `DHE_RSA_WITH_3DES_EDE_CBC_SHA
| `ECDHE_RSA_WITH_AES_128_GCM_SHA256
| `ECDHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `ECDHE_RSA_WITH_AES_256_CBC_SHA384
| `ECDHE_RSA_WITH_AES_128_CBC_SHA256
| `ECDHE_RSA_WITH_AES_256_CBC_SHA
| `ECDHE_RSA_WITH_AES_128_CBC_SHA
| `ECDHE_RSA_WITH_3DES_EDE_CBC_SHA
| `RSA_WITH_AES_256_CBC_SHA256
| `RSA_WITH_AES_128_CBC_SHA256
| `RSA_WITH_AES_256_CBC_SHA
| `RSA_WITH_AES_128_CBC_SHA
| `RSA_WITH_3DES_EDE_CBC_SHA
| `RSA_WITH_AES_128_GCM_SHA256
| `RSA_WITH_AES_256_GCM_SHA384
| `RSA_WITH_AES_256_CCM
| `RSA_WITH_AES_128_CCM
| `ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA256
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384
| `ECDHE_ECDSA_WITH_AES_128_GCM_SHA256
| `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384
| `ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256
]
let ciphersuite_to_ciphersuite13 : ciphersuite -> ciphersuite13 option = function
| #ciphersuite13 as cs -> Some cs
| _ -> None
let any_ciphersuite_to_ciphersuite = function
| Packet.TLS_DHE_RSA_WITH_AES_256_CBC_SHA256 -> Some `DHE_RSA_WITH_AES_256_CBC_SHA256
| Packet.TLS_DHE_RSA_WITH_AES_128_CBC_SHA256 -> Some `DHE_RSA_WITH_AES_128_CBC_SHA256
| Packet.TLS_DHE_RSA_WITH_AES_256_CBC_SHA -> Some `DHE_RSA_WITH_AES_256_CBC_SHA
| Packet.TLS_DHE_RSA_WITH_AES_128_CBC_SHA -> Some `DHE_RSA_WITH_AES_128_CBC_SHA
| Packet.TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA -> Some `DHE_RSA_WITH_3DES_EDE_CBC_SHA
| Packet.TLS_RSA_WITH_AES_256_CBC_SHA256 -> Some `RSA_WITH_AES_256_CBC_SHA256
| Packet.TLS_RSA_WITH_AES_128_CBC_SHA256 -> Some `RSA_WITH_AES_128_CBC_SHA256
| Packet.TLS_RSA_WITH_AES_256_CBC_SHA -> Some `RSA_WITH_AES_256_CBC_SHA
| Packet.TLS_RSA_WITH_AES_128_CBC_SHA -> Some `RSA_WITH_AES_128_CBC_SHA
| Packet.TLS_RSA_WITH_3DES_EDE_CBC_SHA -> Some `RSA_WITH_3DES_EDE_CBC_SHA
| Packet.TLS_RSA_WITH_AES_128_CCM -> Some `RSA_WITH_AES_128_CCM
| Packet.TLS_RSA_WITH_AES_256_CCM -> Some `RSA_WITH_AES_256_CCM
| Packet.TLS_DHE_RSA_WITH_AES_128_CCM -> Some `DHE_RSA_WITH_AES_128_CCM
| Packet.TLS_DHE_RSA_WITH_AES_256_CCM -> Some `DHE_RSA_WITH_AES_256_CCM
| Packet.TLS_RSA_WITH_AES_128_GCM_SHA256 -> Some `RSA_WITH_AES_128_GCM_SHA256
| Packet.TLS_RSA_WITH_AES_256_GCM_SHA384 -> Some `RSA_WITH_AES_256_GCM_SHA384
| Packet.TLS_DHE_RSA_WITH_AES_128_GCM_SHA256 -> Some `DHE_RSA_WITH_AES_128_GCM_SHA256
| Packet.TLS_DHE_RSA_WITH_AES_256_GCM_SHA384 -> Some `DHE_RSA_WITH_AES_256_GCM_SHA384
| Packet.TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256 -> Some `ECDHE_RSA_WITH_AES_128_GCM_SHA256
| Packet.TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384 -> Some `ECDHE_RSA_WITH_AES_256_GCM_SHA384
| Packet.TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384 -> Some `ECDHE_RSA_WITH_AES_256_CBC_SHA384
| Packet.TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256 -> Some `ECDHE_RSA_WITH_AES_128_CBC_SHA256
| Packet.TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA -> Some `ECDHE_RSA_WITH_AES_256_CBC_SHA
| Packet.TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA -> Some `ECDHE_RSA_WITH_AES_128_CBC_SHA
| Packet.TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA -> Some `ECDHE_RSA_WITH_3DES_EDE_CBC_SHA
| Packet.TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> Some `ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| Packet.TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> Some `DHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| Packet.TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA -> Some `ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA
| Packet.TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA -> Some `ECDHE_ECDSA_WITH_AES_128_CBC_SHA
| Packet.TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA -> Some `ECDHE_ECDSA_WITH_AES_256_CBC_SHA
| Packet.TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 -> Some `ECDHE_ECDSA_WITH_AES_128_CBC_SHA256
| Packet.TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 -> Some `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384
| Packet.TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 -> Some `ECDHE_ECDSA_WITH_AES_128_GCM_SHA256
| Packet.TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 -> Some `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384
| Packet.TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 -> Some `ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256
| x -> any_ciphersuite_to_ciphersuite13 x
let ciphersuite_to_any_ciphersuite = function
| `DHE_RSA_WITH_AES_256_CBC_SHA256 -> Packet.TLS_DHE_RSA_WITH_AES_256_CBC_SHA256
| `DHE_RSA_WITH_AES_128_CBC_SHA256 -> Packet.TLS_DHE_RSA_WITH_AES_128_CBC_SHA256
| `DHE_RSA_WITH_AES_256_CBC_SHA -> Packet.TLS_DHE_RSA_WITH_AES_256_CBC_SHA
| `DHE_RSA_WITH_AES_128_CBC_SHA -> Packet.TLS_DHE_RSA_WITH_AES_128_CBC_SHA
| `DHE_RSA_WITH_3DES_EDE_CBC_SHA -> Packet.TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA
| `RSA_WITH_AES_256_CBC_SHA256 -> Packet.TLS_RSA_WITH_AES_256_CBC_SHA256
| `RSA_WITH_AES_128_CBC_SHA256 -> Packet.TLS_RSA_WITH_AES_128_CBC_SHA256
| `RSA_WITH_AES_256_CBC_SHA -> Packet.TLS_RSA_WITH_AES_256_CBC_SHA
| `RSA_WITH_AES_128_CBC_SHA -> Packet.TLS_RSA_WITH_AES_128_CBC_SHA
| `RSA_WITH_3DES_EDE_CBC_SHA -> Packet.TLS_RSA_WITH_3DES_EDE_CBC_SHA
| `RSA_WITH_AES_128_CCM -> Packet.TLS_RSA_WITH_AES_128_CCM
| `RSA_WITH_AES_256_CCM -> Packet.TLS_RSA_WITH_AES_256_CCM
| `DHE_RSA_WITH_AES_128_CCM -> Packet.TLS_DHE_RSA_WITH_AES_128_CCM
| `DHE_RSA_WITH_AES_256_CCM -> Packet.TLS_DHE_RSA_WITH_AES_256_CCM
| `RSA_WITH_AES_128_GCM_SHA256 -> Packet.TLS_RSA_WITH_AES_128_GCM_SHA256
| `RSA_WITH_AES_256_GCM_SHA384 -> Packet.TLS_RSA_WITH_AES_256_GCM_SHA384
| `DHE_RSA_WITH_AES_128_GCM_SHA256 -> Packet.TLS_DHE_RSA_WITH_AES_128_GCM_SHA256
| `DHE_RSA_WITH_AES_256_GCM_SHA384 -> Packet.TLS_DHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_AES_128_GCM_SHA256 -> Packet.TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256
| `ECDHE_RSA_WITH_AES_256_GCM_SHA384 -> Packet.TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_AES_256_CBC_SHA384 -> Packet.TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384
| `ECDHE_RSA_WITH_AES_128_CBC_SHA256 -> Packet.TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256
| `ECDHE_RSA_WITH_AES_256_CBC_SHA -> Packet.TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA
| `ECDHE_RSA_WITH_AES_128_CBC_SHA -> Packet.TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA
| `ECDHE_RSA_WITH_3DES_EDE_CBC_SHA -> Packet.TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA
| `ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> Packet.TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> Packet.TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `AES_128_GCM_SHA256 -> Packet.TLS_AES_128_GCM_SHA256
| `AES_256_GCM_SHA384 -> Packet.TLS_AES_256_GCM_SHA384
| `CHACHA20_POLY1305_SHA256 -> Packet.TLS_CHACHA20_POLY1305_SHA256
| `AES_128_CCM_SHA256 -> Packet.TLS_AES_128_CCM_SHA256
| `ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA -> Packet.TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA -> Packet.TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA -> Packet.TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 -> Packet.TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 -> Packet.TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384
| `ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 -> Packet.TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256
| `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 -> Packet.TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384
| `ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 -> Packet.TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256
(** [get_kex_privprot ciphersuite] is [(kex, privacy_protection)] where it dissects the [ciphersuite] into a pair containing the key exchange method [kex], and its [privacy_protection] *)
let get_keytype_kex_privprot = function
| `RSA_WITH_3DES_EDE_CBC_SHA -> (`RSA, `RSA, `Block (TRIPLE_DES_EDE_CBC, `SHA1))
| `DHE_RSA_WITH_3DES_EDE_CBC_SHA -> (`RSA, `FFDHE, `Block (TRIPLE_DES_EDE_CBC, `SHA1))
| `RSA_WITH_AES_128_CBC_SHA -> (`RSA, `RSA, `Block (AES_128_CBC, `SHA1))
| `DHE_RSA_WITH_AES_128_CBC_SHA -> (`RSA, `FFDHE, `Block (AES_128_CBC, `SHA1))
| `RSA_WITH_AES_256_CBC_SHA -> (`RSA, `RSA, `Block (AES_256_CBC, `SHA1))
| `DHE_RSA_WITH_AES_256_CBC_SHA -> (`RSA, `FFDHE, `Block (AES_256_CBC, `SHA1))
| `RSA_WITH_AES_128_CBC_SHA256 -> (`RSA, `RSA, `Block (AES_128_CBC, `SHA256))
| `RSA_WITH_AES_256_CBC_SHA256 -> (`RSA, `RSA, `Block (AES_256_CBC, `SHA256))
| `DHE_RSA_WITH_AES_128_CBC_SHA256 -> (`RSA, `FFDHE, `Block (AES_128_CBC, `SHA256))
| `DHE_RSA_WITH_AES_256_CBC_SHA256 -> (`RSA, `FFDHE, `Block (AES_256_CBC, `SHA256))
| `RSA_WITH_AES_128_CCM -> (`RSA, `RSA, `AEAD AES_128_CCM)
| `RSA_WITH_AES_256_CCM -> (`RSA, `RSA, `AEAD AES_256_CCM)
| `DHE_RSA_WITH_AES_128_CCM -> (`RSA, `FFDHE, `AEAD AES_128_CCM)
| `DHE_RSA_WITH_AES_256_CCM -> (`RSA, `FFDHE, `AEAD AES_256_CCM)
| `RSA_WITH_AES_128_GCM_SHA256 -> (`RSA, `RSA, `AEAD AES_128_GCM)
| `RSA_WITH_AES_256_GCM_SHA384 -> (`RSA, `RSA, `AEAD AES_256_GCM)
| `DHE_RSA_WITH_AES_128_GCM_SHA256 -> (`RSA, `FFDHE, `AEAD AES_128_GCM)
| `DHE_RSA_WITH_AES_256_GCM_SHA384 -> (`RSA, `FFDHE, `AEAD AES_256_GCM)
| `ECDHE_RSA_WITH_AES_128_GCM_SHA256 -> (`RSA, `ECDHE, `AEAD AES_128_GCM)
| `ECDHE_RSA_WITH_AES_256_GCM_SHA384 -> (`RSA, `ECDHE, `AEAD AES_256_GCM)
| `ECDHE_RSA_WITH_AES_256_CBC_SHA384 -> (`RSA, `ECDHE, `Block (AES_256_CBC, `SHA384))
| `ECDHE_RSA_WITH_AES_128_CBC_SHA256 -> (`RSA, `ECDHE, `Block (AES_128_CBC, `SHA256))
| `ECDHE_RSA_WITH_AES_256_CBC_SHA -> (`RSA, `ECDHE, `Block (AES_256_CBC, `SHA1))
| `ECDHE_RSA_WITH_AES_128_CBC_SHA -> (`RSA, `ECDHE, `Block (AES_128_CBC, `SHA1))
| `ECDHE_RSA_WITH_3DES_EDE_CBC_SHA -> (`RSA, `ECDHE, `Block (TRIPLE_DES_EDE_CBC, `SHA1))
| `DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> (`RSA, `FFDHE, `AEAD CHACHA20_POLY1305)
| `ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> (`RSA, `ECDHE, `AEAD CHACHA20_POLY1305)
| `ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA -> (`EC, `ECDHE, `Block (TRIPLE_DES_EDE_CBC, `SHA1))
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA -> (`EC, `ECDHE, `Block (AES_128_CBC, `SHA1))
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA -> (`EC, `ECDHE, `Block (AES_256_CBC, `SHA1))
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 -> (`EC, `ECDHE, `Block (AES_128_CBC, `SHA256))
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 -> (`EC, `ECDHE, `Block (AES_256_CBC, `SHA384))
| `ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 -> (`EC, `ECDHE, `AEAD AES_128_GCM)
| `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 -> (`EC, `ECDHE, `AEAD AES_256_GCM)
| `ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 -> (`EC, `ECDHE, `AEAD CHACHA20_POLY1305)
| #ciphersuite13 as cs13 -> (`RSA, `FFDHE, `AEAD (privprot13 cs13)) (* this is mostly wrong *)
(** [ciphersuite_kex ciphersuite] is [kex], first projection of [get_kex_privprot] *)
let ciphersuite_kex c =
let _keytype, kex, _pp = get_keytype_kex_privprot c in
kex
(** [ciphersuite_privprot ciphersuite] is [privprot], second projection of [get_kex_privprot] *)
let ciphersuite_privprot c =
let _keytype, _kex, pp = get_keytype_kex_privprot c in
pp
let ciphersuite_keytype c =
let keytype, _kex, _pp = get_keytype_kex_privprot c in
keytype
let pp_ciphersuite ppf cs =
let keytype, kex, pp = get_keytype_kex_privprot cs in
let pp_keytype ppf = function
| `EC -> Fmt.string ppf "ECDSA"
| `RSA -> Fmt.string ppf "RSA"
in
match cs with
| #ciphersuite13 -> Fmt.pf ppf "%a" pp_payload_protection pp
| _ -> Fmt.pf ppf "%a %a %a" pp_key_exchange_algorithm kex pp_keytype keytype
pp_payload_protection pp
let pp_any_ciphersuite ppf cs =
match any_ciphersuite_to_ciphersuite cs with
| Some cs -> pp_ciphersuite ppf cs
| None -> Fmt.pf ppf "ciphersuite %04X" (Packet.any_ciphersuite_to_int cs)
let ciphersuite_fs cs =
match ciphersuite_kex cs with
| #key_exchange_algorithm_dhe -> true
| `RSA -> false
let ecdhe_only = function
| #ciphersuite13 -> false
| cs -> match get_keytype_kex_privprot cs with
| (_, `ECDHE, _) -> true
| _ -> false
let dhe_only = function
| #ciphersuite13 -> false
| cs -> match get_keytype_kex_privprot cs with
| (_, `FFDHE, _) -> true
| _ -> false
let ecdhe = function
| #ciphersuite13 -> true
| cs -> match get_keytype_kex_privprot cs with
| (_, `ECDHE, _) -> true
| _ -> false
let ciphersuite_tls12_only = function
| `DHE_RSA_WITH_AES_256_CBC_SHA256
| `DHE_RSA_WITH_AES_128_CBC_SHA256
| `RSA_WITH_AES_256_CBC_SHA256
| `RSA_WITH_AES_128_CBC_SHA256
| `RSA_WITH_AES_128_CCM
| `RSA_WITH_AES_256_CCM
| `DHE_RSA_WITH_AES_128_CCM
| `DHE_RSA_WITH_AES_256_CCM
| `RSA_WITH_AES_128_GCM_SHA256
| `RSA_WITH_AES_256_GCM_SHA384
| `DHE_RSA_WITH_AES_128_GCM_SHA256
| `DHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_AES_128_GCM_SHA256
| `ECDHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_AES_256_CBC_SHA384
| `ECDHE_RSA_WITH_AES_128_CBC_SHA256
| `DHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA256
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384
| `ECDHE_ECDSA_WITH_AES_128_GCM_SHA256
| `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384
| `ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 -> true
| _ -> false
let ciphersuite_tls13 = function
| #ciphersuite13 -> true
| _ -> false

643
unikernel/duniverse/ocaml-tls/lib/config.ml Normal file
View file

@ -0,0 +1,643 @@
open Core
let src = Logs.Src.create "tls.config" ~doc:"TLS config"
module Log = (val Logs.src_log src : Logs.LOG)
type certchain = X509.Certificate.t list * X509.Private_key.t
type own_cert = [
| `None
| `Single of certchain
| `Multiple of certchain list
| `Multiple_default of certchain * certchain list
]
let pp_cert ppf cs =
let from, until = X509.Certificate.validity cs in
Fmt.pf ppf "subject %a@ issuer %a@ valid from %a until %a"
X509.Distinguished_name.pp (X509.Certificate.subject cs)
X509.Distinguished_name.pp (X509.Certificate.issuer cs)
(Ptime.pp_human ~tz_offset_s:0 ()) from
(Ptime.pp_human ~tz_offset_s:0 ()) until
let pp_certchain ppf (chain, _) =
Fmt.(list ~sep:(any "@.") pp_cert) ppf chain
let pp_own_cert ppf = function
| `None -> Fmt.string ppf "NONE"
| `Single chain -> pp_certchain ppf chain
| `Multiple cs ->
Fmt.pf ppf "multiple: %a" Fmt.(list ~sep:(any "@.@.") pp_certchain) cs
| `Multiple_default (c, cs) ->
Fmt.pf ppf "multiple default:@.%a@.others:@.%a"
pp_certchain c
Fmt.(list ~sep:(any "@.@.") pp_certchain) cs
type session_cache = SessionID.t -> epoch_data option
type ticket_cache = {
lookup : string -> (psk13 * epoch_data) option ;
ticket_granted : psk13 -> epoch_data -> unit ;
lifetime : int32 ;
timestamp : unit -> Ptime.t
}
(* TODO: min_rsa, min_dh *)
type config = {
ciphers : Ciphersuite.ciphersuite list ;
protocol_versions : tls_version * tls_version ;
signature_algorithms : signature_algorithm list ;
use_reneg : bool ;
authenticator : X509.Authenticator.t option ;
peer_name : [`host] Domain_name.t option ;
own_certificates : own_cert ;
acceptable_cas : X509.Distinguished_name.t list ;
session_cache : session_cache ;
ticket_cache : ticket_cache option ;
cached_session : epoch_data option ;
cached_ticket : (psk13 * epoch_data) option ;
alpn_protocols : string list ;
groups : group list ;
zero_rtt : int32 ;
ip : Ipaddr.t option ;
}
let pp_config ppf cfg =
Fmt.pf ppf
"ciphers: %a@. \
minimal protocol version: %a@. \
maximum protocol version: %a@. \
signature algorithms: %a@. \
renegotiation enabled %B@. \
peer name: %a@. \
own certificate: %a@. \
acceptable CAs: %a@. \
alpn protocols: %a@. \
groups: %a@. \
IP: %a@."
Fmt.(list ~sep:(any ", ") Ciphersuite.pp_ciphersuite) cfg.ciphers
pp_tls_version (fst cfg.protocol_versions)
pp_tls_version (snd cfg.protocol_versions)
Fmt.(list ~sep:(any ", ") pp_signature_algorithm) cfg.signature_algorithms
cfg.use_reneg
Fmt.(option ~none:(any "none provided") Domain_name.pp) cfg.peer_name
pp_own_cert cfg.own_certificates
Fmt.(list ~sep:(any ", ") X509.Distinguished_name.pp) cfg.acceptable_cas
Fmt.(list ~sep:(any ", ") string) cfg.alpn_protocols
Fmt.(list ~sep:(any ", ") pp_group) cfg.groups
Fmt.(option ~none:(any "none provided") Ipaddr.pp) cfg.ip
let ciphers13 cfg =
List.rev
(List.fold_left (fun acc cs ->
match Ciphersuite.ciphersuite_to_ciphersuite13 cs with
| None -> acc
| Some c -> c :: acc)
[] cfg.ciphers)
module Ciphers = struct
(* A good place for various pre-baked cipher lists and helper functions to
* slice and groom those lists. *)
let default13 = [
`AES_128_GCM_SHA256 ;
`AES_256_GCM_SHA384 ;
`CHACHA20_POLY1305_SHA256 ;
`AES_128_CCM_SHA256 ;
]
let default = default13 @ [
`DHE_RSA_WITH_AES_256_GCM_SHA384 ;
`DHE_RSA_WITH_AES_128_GCM_SHA256 ;
`DHE_RSA_WITH_AES_256_CCM ;
`DHE_RSA_WITH_AES_128_CCM ;
`DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 ;
`ECDHE_RSA_WITH_AES_128_GCM_SHA256 ;
`ECDHE_RSA_WITH_AES_256_GCM_SHA384 ;
`ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 ;
`ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 ;
`ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 ;
`ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 ;
]
let supported = default @ [
`DHE_RSA_WITH_AES_256_CBC_SHA256 ;
`DHE_RSA_WITH_AES_128_CBC_SHA256 ;
`DHE_RSA_WITH_AES_256_CBC_SHA ;
`DHE_RSA_WITH_AES_128_CBC_SHA ;
`ECDHE_RSA_WITH_AES_256_CBC_SHA384 ;
`ECDHE_RSA_WITH_AES_128_CBC_SHA256 ;
`ECDHE_RSA_WITH_AES_256_CBC_SHA ;
`ECDHE_RSA_WITH_AES_128_CBC_SHA ;
`ECDHE_ECDSA_WITH_AES_128_CBC_SHA ;
`ECDHE_ECDSA_WITH_AES_256_CBC_SHA ;
`ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 ;
`ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 ;
`RSA_WITH_AES_256_CBC_SHA256 ;
`RSA_WITH_AES_128_CBC_SHA256 ;
`RSA_WITH_AES_256_CBC_SHA ;
`RSA_WITH_AES_128_CBC_SHA ;
`RSA_WITH_AES_256_GCM_SHA384 ;
`RSA_WITH_AES_128_GCM_SHA256 ;
`RSA_WITH_AES_256_CCM ;
`RSA_WITH_AES_128_CCM ;
`DHE_RSA_WITH_3DES_EDE_CBC_SHA ;
`RSA_WITH_3DES_EDE_CBC_SHA ;
`ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA ;
]
(* as defined in https://httpwg.org/specs/rfc7540.html#BadCipherSuites *)
let http2 = default13 @ [
`DHE_RSA_WITH_AES_256_GCM_SHA384 ;
`DHE_RSA_WITH_AES_128_GCM_SHA256 ;
`DHE_RSA_WITH_AES_256_CCM ;
`DHE_RSA_WITH_AES_128_CCM ;
`DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 ;
`ECDHE_RSA_WITH_AES_128_GCM_SHA256 ;
`ECDHE_RSA_WITH_AES_256_GCM_SHA384 ;
`ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 ;
`ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 ;
`ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 ;
`ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 ;
]
let fs_of = List.filter Ciphersuite.ciphersuite_fs
let fs = fs_of default
end
let default_signature_algorithms =
[ `ECDSA_SECP256R1_SHA256 ;
`ECDSA_SECP384R1_SHA384 ;
`ECDSA_SECP521R1_SHA512 ;
`ED25519 ;
`RSA_PSS_RSAENC_SHA256 ;
`RSA_PSS_RSAENC_SHA384 ;
`RSA_PSS_RSAENC_SHA512 ;
`RSA_PKCS1_SHA256 ;
`RSA_PKCS1_SHA384 ;
`RSA_PKCS1_SHA512 ;
]
let supported_signature_algorithms =
default_signature_algorithms @ [
`RSA_PKCS1_SHA224 ;
`ECDSA_SECP256R1_SHA1 ;
`RSA_PKCS1_SHA1 ;
`RSA_PKCS1_MD5
]
let min_dh_size = 1024
let min_rsa_key_size = 1024
let supported_groups =
[ `X25519 ; `P384 ; `P256 ; `P521 ;
`FFDHE2048 ; `FFDHE3072 ; `FFDHE4096 ; `FFDHE6144 ; `FFDHE8192 ]
let elliptic_curve = function
| `X25519 | `P256 | `P384 | `P521 -> true
| `FFDHE2048 | `FFDHE3072 | `FFDHE4096 | `FFDHE6144 | `FFDHE8192 -> false
let default_config = {
ciphers = Ciphers.default ;
protocol_versions = (`TLS_1_2, `TLS_1_3) ;
signature_algorithms = default_signature_algorithms ;
use_reneg = false ;
authenticator = None ;
peer_name = None ;
own_certificates = `None ;
acceptable_cas = [] ;
session_cache = (fun _ -> None) ;
cached_session = None ;
cached_ticket = None ;
alpn_protocols = [] ;
groups = supported_groups ;
ticket_cache = None ;
zero_rtt = 0l ;
ip = None ;
}
(* There are inter-configuration option constraints that are checked and
adjusted here. The overall approach is if the client explicitly provided
values, these are taken as granted (a conflict will result in an error). If
the defaults are used, they are adjusted depending on the others.
The options in question are:
- ciphers, which before 1.3 include the key exchange (FFDHE, ECDHE, RSA)
- groups, which name the FFDHE and ECDHE groups used for DH
- signature_algorithms, which (since 1.2) specify the key type and algorithm
used for signatures (RSA-PKCS, RSA-PSS, ECDSA/EdDSA)
- certificate chains, which influence ciphers (before 1.3) and
signature_algorithms
Using everywhere the default (but a custom certificate / or multiple) result
in a working configuration (where, depending on the certificate key type,
some signature_algorithms and ciphersuites are removed). The provided server
certificate may remove ciphers & signature_algorithms, but will only result
in failure if these will then be empty.
An invalid configuration is for example: only FFDHE ciphersuites, but no
FFDHE groups. Or only EC signature algorithms, but only ciphers where the
key type is RSA.
At session initiation time, the server implementation selects cipher,
certificate, signature_algorithm, and group depending on its configuration
and client request.
*)
let ciphers_and_groups ?ciphers ?groups default_ciphers =
let tls13 = function #Ciphersuite.ciphersuite13 -> true | _ -> false in
match ciphers, groups with
| None, None -> Ok (default_ciphers, supported_groups)
| Some cs, None ->
Ok (cs,
let has_kex x = function
| #Ciphersuite.ciphersuite13 -> true
| c -> x = Ciphersuite.ciphersuite_kex c
in
begin
match List.exists (has_kex `ECDHE) cs, List.exists (has_kex `FFDHE) cs with
| true, true -> supported_groups
| true, false ->
Log.warn (fun m -> m "removed FFDHE groups (no FFDHE ciphersuite) from configuation");
List.filter elliptic_curve supported_groups
| false, true ->
Log.warn (fun m -> m "removed ECDHE groups (no ECDHE ciphersuite) from configuration");
List.filter (fun g -> not (elliptic_curve g)) supported_groups
| false, false -> []
end)
| None, Some g ->
Ok (begin match List.partition elliptic_curve g with
| [], [] ->
Log.warn (fun m -> m "removed DHE and ECDHE ciphersuites (empty groups provided) from configuration");
List.filter (fun c -> not (Ciphersuite.ciphersuite_fs c)) default_ciphers
| _::_, [] ->
Log.warn (fun m -> m "removed DHE ciphersuites (no FFDHE groups provided) from configuration");
List.filter (fun c -> not (Ciphersuite.dhe_only c)) default_ciphers
| [], _ :: _ ->
Log.warn (fun m -> m "removed ECDHE ciphersuites (no EC groups provided) from configuration");
List.filter (fun c -> not (Ciphersuite.ecdhe_only c)) default_ciphers
| _ -> default_ciphers
end, g)
| Some cs, Some g ->
if List.exists Ciphersuite.ecdhe_only cs && not (List.exists elliptic_curve g) then
Error (`Msg "ciphersuite with ECDHE provided, but no EC group")
else if List.exists Ciphersuite.dhe_only cs && not (List.exists (fun g -> not (elliptic_curve g)) g) then
Error (`Msg "ciphersuite with FFDHE provided, but no FF group")
else if List.exists Ciphersuite.ciphersuite_fs cs && g = [] then
Error (`Msg "ciphersuite with forward security provided, but no group")
else if List.exists elliptic_curve g && not (List.exists Ciphersuite.ecdhe cs) then
Error (`Msg "EC group provided, but no ciphersuite with ECDHE")
else if List.exists (fun g -> not (elliptic_curve g)) g &&
not (List.exists (fun c -> Ciphersuite.dhe_only c || tls13 c) cs)
then
Error (`Msg "FF group provided, but no ciphersuite with DHE")
else
Ok (cs, g)
let ciphers_and_sig_alg ?ciphers ?signature_algorithms default_ciphers =
let tls13 = function #Ciphersuite.ciphersuite13 -> true | _ -> false in
let default_sa_from_ciphers c =
let has_key k c = tls13 c || k = Ciphersuite.ciphersuite_keytype c in
match List.exists (has_key `RSA) c, List.exists (has_key `EC) c with
| true, true -> Ok supported_signature_algorithms
| true, false ->
Log.warn (fun m -> m "removed EC signature algorithms (no EC ciphersuite present)");
Ok (List.filter rsa_sigalg supported_signature_algorithms)
| false, true ->
Log.warn (fun m -> m "removed RSA signature algorithms (no RSA ciphersuite present)");
Ok (List.filter (fun sa -> not (rsa_sigalg sa)) supported_signature_algorithms)
| false, false ->
Error (`Msg "ciphersuite list without RSA and EC keys")
in
let ( let* ) = Result.bind in
match ciphers, signature_algorithms with
| None, None ->
let* sig_algs = default_sa_from_ciphers default_ciphers in
Ok (default_ciphers, sig_algs)
| Some c, None ->
let* sig_algs = default_sa_from_ciphers c in
Ok (c, sig_algs)
| None, Some sa ->
begin match List.partition rsa_sigalg sa with
| [], [] -> Error (`Msg "empty signature algorithms provided")
| _::_, [] ->
Log.warn (fun m -> m "removing EC ciphers (no EC signature algorithm provided)");
Ok (List.filter
(fun c -> tls13 c || not (Ciphersuite.ciphersuite_keytype c = `EC))
default_ciphers,
sa)
| [], _::_ ->
Log.warn (fun m -> m "removing RSA ciphers (no RSA signature algorithm provided)");
Ok (List.filter
(fun c -> tls13 c || not (Ciphersuite.ciphersuite_keytype c = `RSA))
default_ciphers,
sa)
| _::_, _::_ -> Ok (default_ciphers, sa)
end
| Some c, Some sa ->
if List.exists rsa_sigalg sa && not (List.exists (fun c -> Ciphersuite.ciphersuite_keytype c = `RSA) c) then
Error (`Msg "RSA signature algorithm, but no ciphersuites with RSA keys")
else if List.exists (fun s -> not (rsa_sigalg s)) sa && not (List.exists (fun c -> Ciphersuite.ciphersuite_keytype c = `EC) c) then
Error (`Msg "EC signature algorithm, but no ciphersuites with EC keys")
else if List.exists (fun c -> Ciphersuite.ciphersuite_keytype c = `RSA) c && not (List.exists rsa_sigalg sa) then
Error (`Msg "RSA ciphersuite, but no RSA signature algorithm")
else if List.exists (fun c -> Ciphersuite.ciphersuite_keytype c = `EC) c && not (List.exists (fun s -> not (rsa_sigalg s)) sa) then
Error (`Msg "EC ciphersuite, but no EC signature algorithm")
else
Ok (c, sa)
let validate_common config =
let ( let* ) = Result.bind in
let (v_min, v_max) = config.protocol_versions in
if v_max < v_min then
Error (`Msg "bad version range")
else
let* ciphers, signature_algorithms =
match v_min, v_max with
| _, `TLS_1_1 | _, `TLS_1_0 ->
Log.warn (fun m -> m "TLS 1.0 or TLS 1.1 as maximum version configured, removing 1.2 and 1.3 ciphersuites");
Ok (List.filter (fun c ->
not (Ciphersuite.ciphersuite_tls12_only c || Ciphersuite.ciphersuite_tls13 c))
config.ciphers,
[])
| _, `TLS_1_2 ->
if config.signature_algorithms = [] then
Error (`Msg "TLS 1.2 configured but no signature algorithms provided")
else begin
Log.warn (fun m -> m "TLS 1.2 as maximum version configured, removing 1.3 cipher suites");
Ok (List.filter
(fun c -> not (Ciphersuite.ciphersuite_tls13 c)) config.ciphers,
config.signature_algorithms)
end
| `TLS_1_3, `TLS_1_3 ->
let sa = List.filter tls13_sigalg config.signature_algorithms in
if sa = [] then
Error (`Msg "TLS 1.3 configured but no 1.3 signature algorithms provided")
else begin
Log.warn (fun m -> m "only TLS 1.3 configured, removing pre-1.3 cipher suites and signature algorithms");
Ok (List.filter Ciphersuite.ciphersuite_tls13 config.ciphers, sa)
end
| _ -> Ok (config.ciphers, config.signature_algorithms)
in
if not (Utils.List_set.is_proper_set ciphers) then
Error (`Msg "set of ciphers is not a proper set")
else if List.length ciphers = 0 then
Error (`Msg "set of ciphers is empty")
else if not (Utils.List_set.is_proper_set config.groups) then
Error (`Msg "set of groups is not a proper set")
else if not (Utils.List_set.is_proper_set signature_algorithms) then
Error (`Msg "set of signature algorithms is not a proper set")
else if List.exists (fun proto -> let len = String.length proto in len = 0 || len > 255) config.alpn_protocols then
Error (`Msg "invalid alpn protocol")
else if List.length config.alpn_protocols > 0xffff then
Error (`Msg "alpn protocols list too large")
else
Ok { config with ciphers ; signature_algorithms }
let validate_certificate_chain = function
| (s::chain, priv) ->
let ( let* ) = Result.bind in
let pub = X509.Private_key.public priv in
let* () =
match pub with
| `RSA pub when Mirage_crypto_pk.Rsa.pub_bits pub < min_rsa_key_size ->
Error (`Msg "RSA key too short!")
| _ -> Ok ()
in
let* () =
let eq_pub a b =
String.equal (X509.Public_key.fingerprint a) (X509.Public_key.fingerprint b)
in
if not (eq_pub pub (X509.Certificate.public_key s)) then
Error (`Msg "public / private key combination" )
else
Ok ()
in
( match Utils.init_and_last chain with
| Some (ch, trust) ->
(* TODO: verify that certificates are x509 v3 if TLS_1_2 *)
( match X509.Validation.verify_chain_of_trust ~time:(fun () -> None) ~host:None ~anchors:[trust] (s :: ch) with
| Ok _ -> Ok ()
| Error x ->
let s = Fmt.to_to_string X509.Validation.pp_validation_error x in
Error (`Msg ("certificate chain does not validate: " ^ s)))
| None -> Ok () )
| _ -> Error (`Msg "certificate chain")
let validate_client config =
match config.own_certificates with
| `None -> Ok ()
| `Single c -> validate_certificate_chain c
| _ -> Error (`Msg "multiple client certificates not supported in client config")
let non_overlapping cs =
let namessets =
List.filter_map (function
| (s :: _, _) -> Some s
| _ -> None)
cs
|> List.map X509.Certificate.hostnames
in
let rec check = function
| [] -> ()
| s::ss ->
if not (List.for_all (fun ss' ->
X509.Host.Set.is_empty (X509.Host.Set.inter s ss'))
ss)
then
invalid_arg "overlapping names in certificates"
else
check ss
in
check namessets
module KU = Set.Make (struct
type t = X509.Extension.key_usage
let compare a b = compare a b
end)
module PK = Map.Make (struct
type t = [ `RSA | `ED25519 | `P256 | `P384 | `P521 ]
let compare a b = compare a b
end)
let validate_server config =
let ( let* ) = Result.bind in
let open Ciphersuite in
let usages =
List.fold_left
(fun acc c -> KU.add (required_usage (ciphersuite_kex c)) acc)
KU.empty config.ciphers
in
let* certificate_chains =
match config.own_certificates with
| `Single c -> Ok [c]
| `Multiple cs -> Ok cs
| `Multiple_default (c, cs) -> Ok (c :: cs)
| `None -> Error (`Msg "no server certificate provided")
in
let* server_certs =
List.fold_left (fun acc cc ->
let* acc = acc in
match cc with
| (s::_,_) -> Ok (s :: acc)
| _ -> Error (`Msg "empty certificate chain"))
(Ok []) certificate_chains
in
let* () =
if not
(KU.for_all (fun u ->
List.exists (supports_key_usage ~not_present:true u) server_certs)
usages)
then
Error (`Msg "certificate usage does not match")
else
Ok ()
in
let* () =
List.fold_left (fun acc cc ->
let* () = acc in
validate_certificate_chain cc)
(Ok ()) certificate_chains
in
let rsa_cert, ec_cert =
let is_ec_cert c = match X509.Certificate.public_key c with
| `ED25519 _ | `P256 _ | `P384 _ | `P521 _ -> true
| _ -> false
and is_rsa_cert c = match X509.Certificate.public_key c with
| `RSA _ -> true | _ -> false
in
List.exists is_rsa_cert server_certs,
List.exists is_ec_cert server_certs
in
let ciphers =
List.filter
(function
| #Ciphersuite.ciphersuite13 -> true
| c ->
let keytype = ciphersuite_keytype c in
(rsa_cert && keytype = `RSA) || (ec_cert && keytype = `EC))
config.ciphers
in
( match config.own_certificates with
| `Multiple cs
| `Multiple_default (_, cs) ->
let add k v acc = match PK.find_opt k acc with
| None -> PK.add k [v] acc
| Some r -> PK.add k (v :: r) acc
in
let pk =
List.fold_left (fun acc cs ->
match snd cs with
| `RSA _ -> add `RSA cs acc
| `ED25519 _ -> add `ED25519 cs acc
| `P256 _ -> add `P256 cs acc
| `P384 _ -> add `P384 cs acc
| `P521 _ -> add `P521 cs acc)
PK.empty cs
in
PK.iter (fun _ chains -> non_overlapping chains) pk
| _ -> () );
Ok { config with ciphers }
let validate_keys_sig_algs config =
let ( let* ) = Result.bind in
let _, v_max = config.protocol_versions in
if v_max = `TLS_1_2 || v_max = `TLS_1_3 then
let* certificate_chains =
match config.own_certificates with
| `Single c -> Ok [c]
| `Multiple cs -> Ok cs
| `Multiple_default (c, cs) -> Ok (c :: cs)
| `None -> Error (`Msg "no server certificate provided")
in
let* server_keys =
List.fold_left (fun acc cc ->
let* acc = acc in
match cc with
| (s::_,_) -> Ok (X509.Certificate.public_key s :: acc)
| _ -> Error (`Msg "empty certificate chain"))
(Ok []) certificate_chains
in
if not
(List.for_all (fun cert ->
List.exists (pk_matches_sa cert) config.signature_algorithms)
server_keys)
then
Error (`Msg "certificate provided which does not allow any signature algorithm")
else
Ok ()
else
Ok ()
type client = config
type server = config
let of_server conf = conf
and of_client conf = conf
let peer conf name = { conf with peer_name = Some name }
let with_authenticator conf auth = { conf with authenticator = Some auth }
let with_own_certificates conf own_certificates = { conf with own_certificates }
let with_acceptable_cas conf acceptable_cas = { conf with acceptable_cas }
let (<?>) ma b = match ma with None -> b | Some a -> a
let client
~authenticator ?peer_name ?ciphers ?version ?signature_algorithms ?reneg ?certificates ?cached_session ?cached_ticket ?ticket_cache ?alpn_protocols ?groups ?ip () =
let ( let* ) = Result.bind in
let* ciphers', groups = ciphers_and_groups ?ciphers ?groups default_config.ciphers in
let* ciphers, signature_algorithms = ciphers_and_sig_alg ?ciphers ?signature_algorithms ciphers' in
let config =
{ default_config with
authenticator = Some authenticator ;
ciphers ;
protocol_versions = version <?> default_config.protocol_versions ;
signature_algorithms ;
use_reneg = reneg <?> default_config.use_reneg ;
own_certificates = certificates <?> default_config.own_certificates ;
peer_name = peer_name ;
cached_session = cached_session ;
alpn_protocols = alpn_protocols <?> default_config.alpn_protocols ;
ticket_cache = ticket_cache ;
cached_ticket = cached_ticket ;
groups ;
ip ;
} in
let* config = validate_common config in
let* () = validate_client config in
Log.debug (fun m -> m "client with %a" pp_config config);
Ok config
let server
?ciphers ?version ?signature_algorithms ?reneg ?certificates ?acceptable_cas ?authenticator ?session_cache ?ticket_cache ?alpn_protocols ?groups ?zero_rtt ?ip () =
let ( let* ) = Result.bind in
let* ciphers', groups = ciphers_and_groups ?ciphers ?groups default_config.ciphers in
let* ciphers, signature_algorithms = ciphers_and_sig_alg ?ciphers ?signature_algorithms ciphers' in
let config =
{ default_config with
ciphers ;
protocol_versions = version <?> default_config.protocol_versions ;
signature_algorithms ;
use_reneg = reneg <?> default_config.use_reneg ;
own_certificates = certificates <?> default_config.own_certificates ;
acceptable_cas = acceptable_cas <?> default_config.acceptable_cas ;
authenticator = authenticator ;
session_cache = session_cache <?> default_config.session_cache ;
alpn_protocols = alpn_protocols <?> default_config.alpn_protocols ;
ticket_cache = ticket_cache ;
groups ;
zero_rtt = zero_rtt <?> default_config.zero_rtt ;
ip ;
} in
let* config = validate_server config in
let* config = validate_common config in
let* () = validate_keys_sig_algs config in
Log.debug (fun m -> m "server with %a" pp_config config);
Ok config

174
unikernel/duniverse/ocaml-tls/lib/config.mli Normal file
View file

@ -0,0 +1,174 @@
open Core
(** Configuration of the TLS stack *)
(** {1 Config type} *)
(** certificate chain and private key of the first certificate *)
type certchain = X509.Certificate.t list * X509.Private_key.t
(** polymorphic variant of own certificates *)
type own_cert = [
| `None
| `Single of certchain
| `Multiple of certchain list
| `Multiple_default of certchain * certchain list
]
type session_cache = SessionID.t -> epoch_data option
type ticket_cache = {
lookup : string -> (psk13 * epoch_data) option ;
ticket_granted : psk13 -> epoch_data -> unit ;
lifetime : int32 ;
timestamp : unit -> Ptime.t
}
(** configuration parameters *)
type config = private {
ciphers : Ciphersuite.ciphersuite list ; (** ordered list (regarding preference) of supported cipher suites *)
protocol_versions : tls_version * tls_version ; (** supported protocol versions (min, max) *)
signature_algorithms : signature_algorithm list ; (** ordered list of supported signature algorithms (regarding preference) *)
use_reneg : bool ; (** endpoint should accept renegotiation requests *)
authenticator : X509.Authenticator.t option ; (** optional X509 authenticator *)
peer_name : [ `host ] Domain_name.t option ; (** optional name of other endpoint (used for SNI RFC4366) *)
own_certificates : own_cert ; (** optional default certificate chain and other certificate chains *)
acceptable_cas : X509.Distinguished_name.t list ; (** ordered list of acceptable certificate authorities *)
session_cache : session_cache ;
ticket_cache : ticket_cache option ;
cached_session : epoch_data option ;
cached_ticket : (psk13 * epoch_data) option ;
alpn_protocols : string list ; (** optional ordered list of accepted alpn_protocols *)
groups : group list ; (** the first FFDHE will be used for TLS 1.2 and below if a DHE ciphersuite is used *)
zero_rtt : int32 ;
ip : Ipaddr.t option ;
}
(** [ciphers13 config] are the ciphersuites for TLS 1.3 in the configuration. *)
val ciphers13 : config -> Ciphersuite.ciphersuite13 list
(** opaque type of a client configuration *)
type client
(** opaque type of a server configuration *)
type server
(** {1 Constructors} *)
(** [client authenticator ?peer_name ?ciphers ?version ?hashes ?reneg ?certificates ?alpn_protocols] is
[client] configuration with the given parameters. Returns an error if the configuration is invalid. *)
val client :
authenticator : X509.Authenticator.t ->
?peer_name : [ `host ] Domain_name.t ->
?ciphers : Ciphersuite.ciphersuite list ->
?version : tls_version * tls_version ->
?signature_algorithms : signature_algorithm list ->
?reneg : bool ->
?certificates : own_cert ->
?cached_session : epoch_data ->
?cached_ticket : psk13 * epoch_data ->
?ticket_cache : ticket_cache ->
?alpn_protocols : string list ->
?groups : group list ->
?ip : Ipaddr.t ->
unit -> (client, [> `Msg of string ]) result
(** [server ?ciphers ?version ?hashes ?reneg ?certificates ?acceptable_cas ?authenticator ?alpn_protocols]
is [server] configuration with the given parameters. Returns an error if the configuration is invalid. *)
val server :
?ciphers : Ciphersuite.ciphersuite list ->
?version : tls_version * tls_version ->
?signature_algorithms : signature_algorithm list ->
?reneg : bool ->
?certificates : own_cert ->
?acceptable_cas : X509.Distinguished_name.t list ->
?authenticator : X509.Authenticator.t ->
?session_cache : session_cache ->
?ticket_cache : ticket_cache ->
?alpn_protocols : string list ->
?groups : group list ->
?zero_rtt : int32 ->
?ip : Ipaddr.t ->
unit -> (server, [> `Msg of string ]) result
(** [peer client name] is [client] with [name] as [peer_name] *)
val peer : client -> [ `host ] Domain_name.t -> client
(** {1 Note on ALPN protocol selection}
Both {!val:client} and {!val:server} constructors accept an [alpn_protocols] list. The list for server
should be given in a descending order of preference. In the case of protocol selection, the server will
iterate its list and select the first element that the client's list also advertises.
For example, if the client advertises [["foo"; "bar"; "baz"]] and the server has [["bar"; "foo"]],
["bar"] will be selected as the protocol of the handshake. *)
(** {1 Utility functions} *)
(** [default_signature_algorithms] is a list of signature algorithms used by default *)
val default_signature_algorithms : signature_algorithm list
(** [supported_signature_algorithms] is a list of supported signature algorithms by this library *)
val supported_signature_algorithms : signature_algorithm list
(** [min_dh_size] is minimal diffie hellman group size in bits (currently 1024) *)
val min_dh_size : int
(** [supported_groups] are the Diffie-Hellman groups supported in this
library. *)
val supported_groups : group list
(** [elliptic_curve group] is [true] if group is an elliptic curve, [false]
otherwise. *)
val elliptic_curve : group -> bool
(** [min_rsa_key_size] is minimal RSA modulus key size in bits (currently 1024) *)
val min_rsa_key_size : int
(** Cipher selection *)
module Ciphers : sig
open Ciphersuite
(** Cipher selection related utilities. *)
(** {1 Cipher selection} *)
val default : ciphersuite list
(** [default] is a list of ciphersuites this library uses by default. *)
val supported : ciphersuite list
(** [supported] is a list of ciphersuites this library supports
(larger than [default]). *)
val fs : ciphersuite list
(** [fs] is a list of ciphersuites which provide forward secrecy
(sublist of [default]). *)
val http2 : ciphersuite list
(** [http2] is a list of ciphersuites which are allowed to be used with HTTP2:
not a member of
{{:https://httpwg.org/specs/rfc7540.html#BadCipherSuites}bad cipher
suites}. These are only ephemeral key exchanges with AEAD ciphers. *)
val fs_of : ciphersuite list -> ciphersuite list
(** [fs_of ciphers] selects all ciphersuites which provide forward
secrecy from [ciphers]. *)
end
(** {1 Internal use only} *)
(** [of_client client] is a client configuration for [client] *)
val of_client : client -> config
(** [of_server server] is a server configuration for [server] *)
val of_server : server -> config
(** [with_authenticator config auth] is [config] with [auth] as [authenticator] *)
val with_authenticator : config -> X509.Authenticator.t -> config
(** [with_own_certificates config cert] is [config] with [cert] as [own_cert] *)
val with_own_certificates : config -> own_cert -> config
(** [with_acceptable_cas config cas] is [config] with [cas] as [accepted_cas] *)
val with_acceptable_cas : config -> X509.Distinguished_name.t list -> config

501
unikernel/duniverse/ocaml-tls/lib/core.ml Normal file
View file

@ -0,0 +1,501 @@
(** Core type definitions *)
open Packet
open Ciphersuite
let ( let* ) = Result.bind
let guard p e = if p then Ok () else Error e
let split_str ?(start = 0) str off =
String.sub str start off,
String.sub str (start + off) (String.length str - off - start)
let map_reader_error r =
Result.map_error (fun e -> `Fatal e) r
type tls13 = [ `TLS_1_3 ]
let pp_tls13 ppf `TLS_1_3 = Fmt.string ppf "TLS 1.3"
type tls_before_13 = [
| `TLS_1_0
| `TLS_1_1
| `TLS_1_2
]
let pp_tls_before_13 ppf = function
| `TLS_1_0 -> Fmt.string ppf "TLS 1.0"
| `TLS_1_1 -> Fmt.string ppf "TLS 1.1"
| `TLS_1_2 -> Fmt.string ppf "TLS 1.2"
type tls_version = [ tls13 | tls_before_13 ]
let pp_tls_version ppf = function
| #tls13 as v -> pp_tls13 ppf v
| #tls_before_13 as v -> pp_tls_before_13 ppf v
let pair_of_tls_version = function
| `TLS_1_0 -> (3, 1)
| `TLS_1_1 -> (3, 2)
| `TLS_1_2 -> (3, 3)
| `TLS_1_3 -> (3, 4)
let compare_tls_version a b = match a, b with
| `TLS_1_0, `TLS_1_0 -> 0 | `TLS_1_0, _ -> -1 | _, `TLS_1_0 -> 1
| `TLS_1_1, `TLS_1_1 -> 0 | `TLS_1_1, _ -> -1 | _, `TLS_1_1 -> 1
| `TLS_1_2, `TLS_1_2 -> 0 | `TLS_1_2, _ -> -1 | _, `TLS_1_2 -> 1
| `TLS_1_3, `TLS_1_3 -> 0
let next = function
| `TLS_1_0 -> Some `TLS_1_1
| `TLS_1_1 -> Some `TLS_1_2
| `TLS_1_2 -> Some `TLS_1_3
| `TLS_1_3 -> None
let all_versions (min, max) =
let rec gen curr =
if compare_tls_version max curr >= 0 then
match next curr with
| None -> [curr]
| Some c -> curr :: gen c
else
[]
in
List.rev (gen min)
let tls_version_of_pair = function
| (3, 1) -> Some `TLS_1_0
| (3, 2) -> Some `TLS_1_1
| (3, 3) -> Some `TLS_1_2
| (3, 4) -> Some `TLS_1_3
| _ -> None
type tls_any_version = [
| tls_version
| `SSL_3
| `TLS_1_X of int
]
let pp_tls_any_version ppf = function
| #tls_version as v -> pp_tls_version ppf v
| `SSL_3 -> Fmt.string ppf "SSL3"
| `TLS_1_X x -> Fmt.pf ppf "TLS1.%u" x
let any_version_to_version = function
| #tls_version as v -> Some v
| _ -> None
let version_eq a b =
match a with
| #tls_version as x -> compare_tls_version x b = 0
| _ -> false
let version_ge a b =
match a with
| #tls_version as x -> compare_tls_version x b >= 0
| `SSL_3 -> false
| `TLS_1_X _ -> true
let tls_any_version_of_pair x =
match tls_version_of_pair x with
| Some v -> Some v
| None ->
match x with
| (3, 0) -> Some `SSL_3
| (3, x) -> Some (`TLS_1_X x)
| _ -> None
let pair_of_tls_any_version = function
| #tls_version as x -> pair_of_tls_version x
| `SSL_3 -> (3, 0)
| `TLS_1_X m -> (3, m)
let max_protocol_version (_, hi) = hi
let min_protocol_version (lo, _) = lo
type tls_hdr = {
content_type : content_type;
version : tls_any_version;
}
let pp_tls_hdr ppf { content_type ; version } =
Fmt.pf ppf "content type: %a version: %a" pp_content_type content_type
pp_tls_any_version version
module SessionID = struct
type t = string
let compare = String.compare
let hash t = Hashtbl.hash t
let equal = String.equal
end
module PreSharedKeyID = struct
type t = string
let compare = String.compare
let hash t = Hashtbl.hash t
let equal = String.equal
end
type psk_identity = (string * int32) * string
let binders_len psks =
let binder_len (_, binder) =
String.length binder + 1 (* binder len *)
in
2 (* binder len *) + List.fold_left (+) 0 (List.map binder_len psks)
type group = [
| `FFDHE2048
| `FFDHE3072
| `FFDHE4096
| `FFDHE6144
| `FFDHE8192
| `X25519
| `P256
| `P384
| `P521
]
let pp_group ppf = function
| `FFDHE2048 -> Fmt.string ppf "FFDHE2048"
| `FFDHE3072 -> Fmt.string ppf "FFDHE3072"
| `FFDHE4096 -> Fmt.string ppf "FFDHE4096"
| `FFDHE6144 -> Fmt.string ppf "FFDHE6144"
| `FFDHE8192 -> Fmt.string ppf "FFDHE8192"
| `X25519 -> Fmt.string ppf "X25519"
| `P256 -> Fmt.string ppf "P256"
| `P384 -> Fmt.string ppf "P384"
| `P521 -> Fmt.string ppf "P521"
let named_group_to_group = function
| FFDHE2048 -> Some `FFDHE2048
| FFDHE3072 -> Some `FFDHE3072
| FFDHE4096 -> Some `FFDHE4096
| FFDHE6144 -> Some `FFDHE6144
| FFDHE8192 -> Some `FFDHE8192
| X25519 -> Some `X25519
| SECP256R1 -> Some `P256
| SECP384R1 -> Some `P384
| SECP521R1 -> Some `P521
| _ -> None
let group_to_named_group = function
| `FFDHE2048 -> FFDHE2048
| `FFDHE3072 -> FFDHE3072
| `FFDHE4096 -> FFDHE4096
| `FFDHE6144 -> FFDHE6144
| `FFDHE8192 -> FFDHE8192
| `X25519 -> X25519
| `P256 -> SECP256R1
| `P384 -> SECP384R1
| `P521 -> SECP521R1
let group_to_impl = function
| `FFDHE2048 -> `Finite_field Mirage_crypto_pk.Dh.Group.ffdhe2048
| `FFDHE3072 -> `Finite_field Mirage_crypto_pk.Dh.Group.ffdhe3072
| `FFDHE4096 -> `Finite_field Mirage_crypto_pk.Dh.Group.ffdhe4096
| `FFDHE6144 -> `Finite_field Mirage_crypto_pk.Dh.Group.ffdhe6144
| `FFDHE8192 -> `Finite_field Mirage_crypto_pk.Dh.Group.ffdhe8192
| `X25519 -> `X25519
| `P256 -> `P256
| `P384 -> `P384
| `P521 -> `P521
type signature_algorithm = [
| `RSA_PKCS1_MD5
| `RSA_PKCS1_SHA1
| `RSA_PKCS1_SHA224
| `RSA_PKCS1_SHA256
| `RSA_PKCS1_SHA384
| `RSA_PKCS1_SHA512
| `ECDSA_SECP256R1_SHA1
| `ECDSA_SECP256R1_SHA256
| `ECDSA_SECP384R1_SHA384
| `ECDSA_SECP521R1_SHA512
| `RSA_PSS_RSAENC_SHA256
| `RSA_PSS_RSAENC_SHA384
| `RSA_PSS_RSAENC_SHA512
| `ED25519
(* | `ED448
| `RSA_PSS_PSS_SHA256
| `RSA_PSS_PSS_SHA384
| `RSA_PSS_PSS_SHA512 *)
]
let hash_of_signature_algorithm = function
| `RSA_PKCS1_MD5 -> `MD5
| `RSA_PKCS1_SHA1 -> `SHA1
| `RSA_PKCS1_SHA224 -> `SHA224
| `RSA_PKCS1_SHA256 -> `SHA256
| `RSA_PKCS1_SHA384 -> `SHA384
| `RSA_PKCS1_SHA512 -> `SHA512
| `RSA_PSS_RSAENC_SHA256 -> `SHA256
| `RSA_PSS_RSAENC_SHA384 -> `SHA384
| `RSA_PSS_RSAENC_SHA512 -> `SHA512
| `ECDSA_SECP256R1_SHA1 -> `SHA1
| `ECDSA_SECP256R1_SHA256 -> `SHA256
| `ECDSA_SECP384R1_SHA384 -> `SHA384
| `ECDSA_SECP521R1_SHA512 -> `SHA512
| `ED25519 -> `SHA512
let signature_scheme_of_signature_algorithm = function
| `RSA_PKCS1_MD5 -> `RSA_PKCS1
| `RSA_PKCS1_SHA1 -> `RSA_PKCS1
| `RSA_PKCS1_SHA224 -> `RSA_PKCS1
| `RSA_PKCS1_SHA256 -> `RSA_PKCS1
| `RSA_PKCS1_SHA384 -> `RSA_PKCS1
| `RSA_PKCS1_SHA512 -> `RSA_PKCS1
| `RSA_PSS_RSAENC_SHA256 -> `RSA_PSS
| `RSA_PSS_RSAENC_SHA384 -> `RSA_PSS
| `RSA_PSS_RSAENC_SHA512 -> `RSA_PSS
| `ECDSA_SECP256R1_SHA1 -> `ECDSA
| `ECDSA_SECP256R1_SHA256 -> `ECDSA
| `ECDSA_SECP384R1_SHA384 -> `ECDSA
| `ECDSA_SECP521R1_SHA512 -> `ECDSA
| `ED25519 -> `ED25519
let pp_signature_algorithm ppf sa =
let h = hash_of_signature_algorithm sa
and ss = signature_scheme_of_signature_algorithm sa
in
let pp_signature_scheme ppf = function
| `RSA_PKCS1 -> Fmt.string ppf "RSA-PKCS1"
| `RSA_PSS -> Fmt.string ppf "RSA-PSS"
| `ECDSA -> Fmt.string ppf "ECDSA"
| `ED25519 -> Fmt.string ppf "ED25519"
in
match ss with
| `ED25519 -> Fmt.pf ppf "%a" pp_signature_scheme ss
| `ECDSA ->
let group_to_string = function
| `ECDSA_SECP256R1_SHA1 -> "SECP256R1"
| `ECDSA_SECP256R1_SHA256 -> "SECP256R1"
| `ECDSA_SECP384R1_SHA384 -> "SECP384R1"
| `ECDSA_SECP521R1_SHA512 -> "SECP521R1"
| _ -> assert false
in
Fmt.pf ppf "%a %s %a" pp_signature_scheme ss (group_to_string sa) pp_hash h
| _ -> Fmt.pf ppf "%a %a" pp_signature_scheme ss pp_hash h
let rsa_sigalg = function
| `RSA_PSS_RSAENC_SHA256 | `RSA_PSS_RSAENC_SHA384 | `RSA_PSS_RSAENC_SHA512
| `RSA_PKCS1_SHA256 | `RSA_PKCS1_SHA384 | `RSA_PKCS1_SHA512
| `RSA_PKCS1_SHA224 | `RSA_PKCS1_SHA1 | `RSA_PKCS1_MD5 -> true
| `ECDSA_SECP256R1_SHA1 | `ECDSA_SECP256R1_SHA256 | `ECDSA_SECP384R1_SHA384
| `ECDSA_SECP521R1_SHA512 | `ED25519 -> false
let tls13_sigalg = function
| `RSA_PSS_RSAENC_SHA256 | `RSA_PSS_RSAENC_SHA384 | `RSA_PSS_RSAENC_SHA512
| `ECDSA_SECP256R1_SHA256 | `ECDSA_SECP384R1_SHA384
| `ECDSA_SECP521R1_SHA512 | `ED25519 -> true
| `RSA_PKCS1_SHA256 | `RSA_PKCS1_SHA384 | `RSA_PKCS1_SHA512
| `RSA_PKCS1_SHA224 | `RSA_PKCS1_SHA1 | `RSA_PKCS1_MD5
| `ECDSA_SECP256R1_SHA1 -> false
let pk_matches_sa pk sa =
match pk, sa with
| `RSA _, _ -> rsa_sigalg sa
| `ED25519 _, `ED25519
| `P256 _, (`ECDSA_SECP256R1_SHA1 | `ECDSA_SECP256R1_SHA256)
| `P384 _, `ECDSA_SECP384R1_SHA384
| `P521 _, `ECDSA_SECP521R1_SHA512 -> true
| _ -> false
type client_extension = [
| `Hostname of [`host] Domain_name.t
| `MaxFragmentLength of max_fragment_length
| `SupportedGroups of Packet.named_group list
| `SecureRenegotiation of string
| `Padding of int
| `SignatureAlgorithms of signature_algorithm list
| `ExtendedMasterSecret
| `ALPN of string list
| `KeyShare of (Packet.named_group * string) list
| `EarlyDataIndication
| `PreSharedKeys of psk_identity list
| `SupportedVersions of tls_any_version list
| `PostHandshakeAuthentication
| `Cookie of string
| `PskKeyExchangeModes of psk_key_exchange_mode list
| `ECPointFormats
| `UnknownExtension of (int * string)
]
type server13_extension = [
| `KeyShare of (group * string)
| `PreSharedKey of int
| `SelectedVersion of tls_version (* only used internally in writer!! *)
]
type server_extension = [
server13_extension
| `Hostname
| `MaxFragmentLength of max_fragment_length
| `SecureRenegotiation of string
| `ExtendedMasterSecret
| `ALPN of string
| `ECPointFormats
| `UnknownExtension of (int * string)
]
type encrypted_extension = [
| `Hostname
| `MaxFragmentLength of max_fragment_length
| `SupportedGroups of group list
| `ALPN of string
| `EarlyDataIndication
| `UnknownExtension of (int * string)
]
type hello_retry_extension = [
| `SelectedGroup of group (* only used internally in writer!! *)
| `Cookie of string
| `SelectedVersion of tls_version (* only used internally in writer!! *)
| `UnknownExtension of (int * string)
]
type client_hello = {
client_version : tls_any_version;
client_random : string;
sessionid : SessionID.t option;
ciphersuites : any_ciphersuite list;
extensions : client_extension list
}
type server_hello = {
server_version : tls_version;
server_random : string;
sessionid : SessionID.t option;
ciphersuite : ciphersuite;
extensions : server_extension list
}
type dh_parameters = {
dh_p : string;
dh_g : string;
dh_Ys : string;
}
type hello_retry = {
retry_version : tls_version ;
ciphersuite : ciphersuite13 ;
sessionid : SessionID.t option ;
selected_group : group ;
extensions : hello_retry_extension list
}
type session_ticket_extension = [
| `EarlyDataIndication of int32
| `UnknownExtension of int * string
]
type session_ticket = {
lifetime : int32 ;
age_add : int32 ;
nonce : string ;
ticket : string ;
extensions : session_ticket_extension list
}
type certificate_request_extension = [
(* | `StatusRequest *)
| `SignatureAlgorithms of signature_algorithm list
(* | `SignedCertificateTimestamp *)
| `CertificateAuthorities of X509.Distinguished_name.t list
(* | `OidFilters *)
(* | `SignatureAlgorithmsCert *)
| `UnknownExtension of (int * string)
]
type tls_handshake =
| HelloRequest
| HelloRetryRequest of hello_retry
| EncryptedExtensions of encrypted_extension list
| ServerHelloDone
| ClientHello of client_hello
| ServerHello of server_hello
| Certificate of string
| ServerKeyExchange of string
| CertificateRequest of string
| ClientKeyExchange of string
| CertificateVerify of string
| Finished of string
| SessionTicket of session_ticket
| KeyUpdate of key_update_request_type
| EndOfEarlyData
let pp_handshake ppf = function
| HelloRequest -> Fmt.string ppf "HelloRequest"
| HelloRetryRequest _ -> Fmt.string ppf "HelloRetryRequest"
| EncryptedExtensions _ -> Fmt.string ppf "EncryptedExtensions"
| ServerHelloDone -> Fmt.string ppf "ServerHelloDone"
| ClientHello _ -> Fmt.string ppf "ClientHello"
| ServerHello _ -> Fmt.string ppf "ServerHello"
| Certificate _ -> Fmt.string ppf "Certificate"
| ServerKeyExchange _ -> Fmt.string ppf "ServerKeyExchange"
| CertificateRequest _ -> Fmt.string ppf "CertificateRequest"
| ClientKeyExchange _ -> Fmt.string ppf "ClientKeyExchange"
| CertificateVerify _ -> Fmt.string ppf "CertificateVerify"
| Finished _ -> Fmt.string ppf "Finished"
| SessionTicket _ -> Fmt.string ppf "SessionTicket"
| KeyUpdate _ -> Fmt.string ppf "KeyUpdate"
| EndOfEarlyData -> Fmt.string ppf "EndOfEarlyData"
let src = Logs.Src.create "tls.tracing" ~doc:"TLS tracing"
module Tracing = struct
include (val Logs.src_log src : Logs.LOG)
let cs ~tag buf = debug (fun m -> m "%s@.%a" tag (Ohex.pp_hexdump ()) buf)
let hs ~tag hs = debug (fun m -> m "%s %a" tag pp_handshake hs)
end
type tls_alert = alert_level * alert_type
(** the master secret of a TLS connection *)
type master_secret = string
type psk13 = {
identifier : string ;
obfuscation : int32 ;
secret : string ;
lifetime : int32 ;
early_data : int32 ;
issued_at : Ptime.t ;
(* origin : [ `Resumption | `External ] (* using different labels for binder_key *) *)
}
type epoch_state = [ `ZeroRTT | `Established ]
(** information about an open session *)
type epoch_data = {
side : [ `Client | `Server ] ;
state : epoch_state ;
protocol_version : tls_version ;
ciphersuite : Ciphersuite.ciphersuite ;
peer_random : string ;
peer_certificate_chain : X509.Certificate.t list ;
peer_certificate : X509.Certificate.t option ;
peer_name : [`host] Domain_name.t option ;
trust_anchor : X509.Certificate.t option ;
received_certificates : X509.Certificate.t list ;
own_random : string ;
own_certificate : X509.Certificate.t list ;
own_private_key : X509.Private_key.t option ;
own_name : [`host] Domain_name.t option ;
master_secret : master_secret ;
exporter_master_secret : master_secret ;
session_id : SessionID.t ;
extended_ms : bool ;
alpn_protocol : string option ;
tls_unique : string option ;
}
let supports_key_usage ?(not_present = false) usage cert =
match X509.Extension.(find Key_usage (X509.Certificate.extensions cert)) with
| None -> not_present
| Some (_, kus) -> List.mem usage kus
let supports_extended_key_usage ?(not_present = false) usage cert =
match X509.Extension.(find Ext_key_usage (X509.Certificate.extensions cert)) with
| None -> not_present
| Some (_, kus) -> List.mem usage kus

159
unikernel/duniverse/ocaml-tls/lib/crypto.ml Normal file
View file

@ -0,0 +1,159 @@
open Mirage_crypto
open Ciphersuite
(* on-the-wire dh_params <-> (group, pub_message) *)
let dh_params_pack { Mirage_crypto_pk.Dh.p; gg ; _ } message =
let cs_of_z = Mirage_crypto_pk.Z_extra.to_octets_be ?size:None in
{ Core.dh_p = cs_of_z p ; dh_g = cs_of_z gg ; dh_Ys = message }
and dh_params_unpack { Core.dh_p ; dh_g ; dh_Ys } =
let z_of_cs = Mirage_crypto_pk.Z_extra.of_octets_be ?bits:None in
match Mirage_crypto_pk.Dh.group ~p:(z_of_cs dh_p) ~gg:(z_of_cs dh_g) () with
| Ok dh -> Ok (dh, dh_Ys)
| Error _ as e -> e
module Ciphers = struct
(* I'm not sure how to get rid of this type, but would welcome a solution *)
(* only used as result of get_block, which is called by get_cipher below *)
type keyed = | K_CBC : 'k State.cbc_cipher * (string -> 'k) -> keyed
let get_block = function
| TRIPLE_DES_EDE_CBC ->
K_CBC ( (module DES.CBC : Block.CBC with type key = DES.CBC.key),
DES.CBC.of_secret )
| AES_128_CBC ->
K_CBC ( (module AES.CBC : Block.CBC with type key = AES.CBC.key),
AES.CBC.of_secret )
| AES_256_CBC ->
K_CBC ( (module AES.CBC : Block.CBC with type key = AES.CBC.key),
AES.CBC.of_secret )
type aead_keyed = | K_AEAD : 'k State.aead_cipher * (string -> 'k) * bool -> aead_keyed
let get_aead =
function
| AES_128_CCM | AES_256_CCM ->
K_AEAD ((module AES.CCM16 : AEAD with type key = AES.CCM16.key),
AES.CCM16.of_secret, true)
| AES_128_GCM | AES_256_GCM ->
K_AEAD ((module AES.GCM : AEAD with type key = AES.GCM.key),
AES.GCM.of_secret, true)
| CHACHA20_POLY1305 ->
K_AEAD ((module Chacha20 : AEAD with type key = Chacha20.key),
Chacha20.of_secret, false)
let get_aead_cipher ~secret ~nonce aead_cipher =
match get_aead aead_cipher with
| K_AEAD (cipher, sec, explicit_nonce) ->
let cipher_secret = sec secret in
State.(AEAD { cipher ; cipher_secret ; nonce ; explicit_nonce })
let get_cipher ~secret ~hmac_secret ~iv_mode ~nonce = function
| `Block (cipher, hmac) ->
( match get_block cipher with
| K_CBC (cipher, sec) ->
let cipher_secret = sec secret in
State.(CBC { cipher ; cipher_secret ; iv_mode ; hmac ; hmac_secret })
)
| `AEAD cipher -> get_aead_cipher ~secret ~nonce cipher
end
let sequence_buf seq =
let buf = Bytes.create 8 in
Bytes.set_int64_be buf 0 seq ;
Bytes.unsafe_to_string buf
let aead_nonce nonce seq =
let s =
let l = String.length nonce in
let buf = Bytes.make l '\x00' in
Bytes.set_int64_be buf (l - 8) seq;
Bytes.unsafe_to_string buf
in
Uncommon.xor nonce s
let adata_1_3 len =
(* additional data in TLS 1.3 is using the header (RFC 8446 Section 5.2):
- APPLICATION_TYPE
- 0x03 0x03 (for TLS version 1.2 -- binary representation is 0x03 0x03)
- <length in 16 bit>
*)
let buf = Bytes.create 5 in
Bytes.set_uint8 buf 0 (Packet.content_type_to_int Packet.APPLICATION_DATA) ;
Bytes.set_uint8 buf 1 3;
Bytes.set_uint8 buf 2 3;
Bytes.set_uint16_be buf 3 len ;
Bytes.unsafe_to_string buf
let pseudo_header seq ty (v_major, v_minor) v_length =
let buf = Bytes.create 13 in
Bytes.set_int64_be buf 0 seq;
Bytes.set_uint8 buf 8 (Packet.content_type_to_int ty);
Bytes.set_uint8 buf 9 v_major;
Bytes.set_uint8 buf 10 v_minor;
Bytes.set_uint16_be buf 11 v_length;
Bytes.unsafe_to_string buf
(* MAC used in TLS *)
let mac hash key pseudo_hdr data =
let module H = (val Digestif.module_of_hash' hash) in
H.(to_raw_string (hmacv_string ~key [ pseudo_hdr ; data ]))
let cbc_block (type a) cipher =
let module C = (val cipher : Block.CBC with type key = a) in C.block_size
(* crazy CBC padding and unpadding for TLS *)
let cbc_pad block data =
(* 1 is the padding length, encoded as 8 bit at the end of the fragment *)
let len = 1 + String.length data in
(* we might want to add additional blocks of padding *)
let padding_length = block - (len mod block) in
(* 1 is again padding length field *)
let cstruct_len = padding_length + 1 in
String.make cstruct_len (Char.unsafe_chr padding_length)
let cbc_unpad data =
let len = String.length data in
let padlen = String.get_uint8 data (pred len) in
let rec check = function
| i when i > padlen -> true
| i -> (String.get_uint8 data (len - padlen - 1 + i) = padlen) && check (succ i) in
try
if check 0 then Some (String.sub data 0 (len - padlen - 1)) else None
with Invalid_argument _ -> None
let tag_len (type a) cipher =
let module C = (val cipher : AEAD with type key = a) in
C.tag_size
let encrypt_aead (type a) ~cipher ~key ~nonce ?adata data =
let module C = (val cipher : AEAD with type key = a) in
C.authenticate_encrypt ~key ~nonce ?adata data
let decrypt_aead (type a) ~cipher ~key ~nonce ?adata data =
let module C = (val cipher : AEAD with type key = a) in
C.authenticate_decrypt ~key ~nonce ?adata data
let encrypt_cbc (type a) ~cipher ~key ~iv data =
let module C = (val cipher : Block.CBC with type key = a) in
let message = C.encrypt ~key ~iv (data ^ cbc_pad C.block_size data) in
(message, C.next_iv ~iv message)
let decrypt_cbc (type a) ~cipher ~key ~iv data =
let module C = (val cipher : Block.CBC with type key = a) in
try
let message = C.decrypt ~key ~iv data in
match cbc_unpad message with
| Some res -> Some (res, C.next_iv ~iv data)
| None -> None
with
(* This bails out immediately on mis-alignment, making it very timeable.
* However, decryption belongs to the outermost level and this operation's
* timing does not leak information ala padding oracle and friends. *)
| Invalid_argument _ -> None

5
unikernel/duniverse/ocaml-tls/lib/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name tls)
(public_name tls)
(libraries logs kdf.hkdf ohex digestif mirage-crypto mirage-crypto-rng
mirage-crypto-pk x509 domain-name fmt mirage-crypto-ec ipaddr))

761
unikernel/duniverse/ocaml-tls/lib/engine.ml Normal file
View file

@ -0,0 +1,761 @@
open Core
open State
type state = State.state
type error = State.error
type fatal = State.fatal
type failure = State.failure
let alert_of_authentication_failure = function
| `LeafCertificateExpired _ -> Packet.CERTIFICATE_EXPIRED
| _ -> Packet.BAD_CERTIFICATE
let alert_of_error = function
| `NoConfiguredVersions _ -> Packet.PROTOCOL_VERSION
| `NoConfiguredCiphersuite _ -> Packet.HANDSHAKE_FAILURE
| `NoConfiguredSignatureAlgorithm _ -> Packet.HANDSHAKE_FAILURE
| `AuthenticationFailure err -> alert_of_authentication_failure err
| `NoMatchingCertificateFound _ -> Packet.UNRECOGNIZED_NAME
| `CouldntSelectCertificate -> Packet.HANDSHAKE_FAILURE
let alert_of_fatal = function
| `Protocol_version _ -> Packet.PROTOCOL_VERSION
| `Unexpected _ -> Packet.UNEXPECTED_MESSAGE
| `Decode _ -> Packet.DECODE_ERROR
| `Handshake _ -> Packet.HANDSHAKE_FAILURE
| `Bad_mac -> Packet.BAD_RECORD_MAC
| `Record_overflow _ -> Packet.RECORD_OVERFLOW
| `Unsupported_extension -> Packet.UNSUPPORTED_EXTENSION
| `Bad_certificate _ -> Packet.BAD_CERTIFICATE
| `Missing_extension _ -> Packet.MISSING_EXTENSION
| `Inappropriate_fallback -> Packet.INAPPROPRIATE_FALLBACK
| `No_application_protocol -> Packet.NO_APPLICATION_PROTOCOL
let alert_of_failure = function
| `Error x -> Packet.FATAL, alert_of_error x
| `Fatal x -> Packet.FATAL, alert_of_fatal x
| `Alert _ -> Packet.WARNING, Packet.CLOSE_NOTIFY
let pp_failure = State.pp_failure
let string_of_failure = Fmt.to_to_string pp_failure
type ret =
(state * [ `Eof ] option
* [ `Response of string option ]
* [ `Data of string option ],
failure * [ `Response of string ]) result
let new_state config role =
let handshake_state = match role with
| `Client -> Client ClientInitial
| `Server -> Server AwaitClientHello
in
let version = max_protocol_version Config.(config.protocol_versions) in
let handshake = {
session = [] ;
protocol_version = version ;
early_data_left = 0l ;
machina = handshake_state ;
config = config ;
hs_fragment = "" ;
}
in
{
handshake = handshake ;
decryptor = None ;
encryptor = None ;
fragment = "" ;
read_closed = false ;
write_closed = false ;
}
type raw_record = tls_hdr * string
let pp_raw_record ppf (hdr, data) =
Fmt.pf ppf "%a (%u bytes data)" pp_tls_hdr hdr (String.length data)
let pp_frame ppf (ty, data) =
Fmt.pf ppf "%a (%u bytes data)" Packet.pp_content_type ty
(String.length data)
(* well-behaved pure encryptor *)
let encrypt (version : tls_version) (st : crypto_state) ty buf off len =
match st with
| None -> (st, ty, String.sub buf off len)
| Some ctx ->
match version with
| `TLS_1_3 ->
(match ctx.cipher_st with
| AEAD c ->
let buf =
let b = Bytes.create (len + 1) in
Bytes.set_uint8 b len (Packet.content_type_to_int ty);
Bytes.blit_string buf off b 0 len;
Bytes.unsafe_to_string b
in
let nonce = Crypto.aead_nonce c.nonce ctx.sequence in
let adata = Crypto.adata_1_3 (String.length buf + Crypto.tag_len c.cipher) in
let buf = Crypto.encrypt_aead ~cipher:c.cipher ~adata ~key:c.cipher_secret ~nonce buf in
(Some { ctx with sequence = Int64.succ ctx.sequence }, Packet.APPLICATION_DATA, buf)
| _ -> assert false)
| _ ->
let pseudo_hdr =
let seq = ctx.sequence
and ver = pair_of_tls_version version
in
Crypto.pseudo_header seq ty ver len
in
let c_st, enc =
match ctx.cipher_st with
| CBC c ->
let enc iv =
(* TODO only until digestif goes beyond 1.2.0 (feedable hmac) *)
let data = String.sub buf off len in
let signature = Crypto.mac c.hmac c.hmac_secret pseudo_hdr buf in
let to_encrypt = data ^ signature in
Crypto.encrypt_cbc ~cipher:c.cipher ~key:c.cipher_secret ~iv to_encrypt
in
( match c.iv_mode with
| Random_iv ->
let iv = Mirage_crypto_rng.generate (Crypto.cbc_block c.cipher) in
let m, _ = enc iv in
(CBC c, iv ^ m)
| Iv iv ->
let m, iv' = enc iv in
(CBC { c with iv_mode = Iv iv' }, m) )
| AEAD c ->
let buf = String.sub buf off len in
if c.explicit_nonce then
let explicit_nonce = Crypto.sequence_buf ctx.sequence in
let nonce = c.nonce ^ explicit_nonce
in
let msg =
Crypto.encrypt_aead ~cipher:c.cipher ~key:c.cipher_secret ~nonce ~adata:pseudo_hdr buf
in
(AEAD c, explicit_nonce ^ msg)
else
(* RFC 7905: no explicit nonce, instead TLS 1.3 construction is adapted *)
let nonce = Crypto.aead_nonce c.nonce ctx.sequence in
let msg =
Crypto.encrypt_aead ~cipher:c.cipher ~key:c.cipher_secret ~nonce ~adata:pseudo_hdr buf
in
(AEAD c, msg)
in
(Some { sequence = Int64.succ ctx.sequence ; cipher_st = c_st }, ty, enc)
(* well-behaved pure decryptor *)
let verify_mac sequence mac mac_k ty ver decrypted =
let macstart =
let module H = (val Digestif.module_of_hash' mac) in
String.length decrypted - H.digest_size
in
let* () = guard (macstart >= 0) (`Fatal (`Decode "MAC underflow")) in
let (body, mmac) = split_str decrypted macstart in
let cmac =
let ver = pair_of_tls_version ver in
let hdr = Crypto.pseudo_header sequence ty ver (String.length body) in
Crypto.mac mac mac_k hdr body in
let* () = guard (String.equal cmac mmac) (`Fatal `Bad_mac) in
Ok body
let decrypt ?(trial = false) (version : tls_version) (st : crypto_state) ty buf =
let compute_mac seq mac mac_k buf = verify_mac seq mac mac_k ty version buf in
(* hmac is computed in this failure branch from the encrypted data, in the
successful branch it is decrypted - padding (which is smaller equal than
encrypted data) *)
(* This comment is borrowed from miTLS, but applies here as well: *)
(* We implement standard mitigation for padding oracles. Still, we note a
small timing leak here: The time to verify the mac is linear in the
plaintext length. *)
(* defense against http://lasecwww.epfl.ch/memo/memo_ssl.shtml 1) in
https://www.openssl.org/~bodo/tls-cbc.txt *)
let mask_decrypt_failure seq mac mac_k =
let* _ = compute_mac seq mac mac_k buf in
Error (`Fatal `Bad_mac)
in
let dec ctx =
let seq = ctx.sequence in
match ctx.cipher_st with
| CBC c ->
let dec iv buf =
match Crypto.decrypt_cbc ~cipher:c.cipher ~key:c.cipher_secret ~iv buf with
| None ->
mask_decrypt_failure seq c.hmac c.hmac_secret
| Some (dec, iv') ->
let* msg = compute_mac seq c.hmac c.hmac_secret dec in
Ok (msg, iv')
in
( match c.iv_mode with
| Iv iv ->
let* msg, iv' = dec iv buf in
Ok (CBC { c with iv_mode = Iv iv' }, msg)
| Random_iv ->
if String.length buf < Crypto.cbc_block c.cipher then
Error (`Fatal (`Decode "MAC underflow"))
else
let iv, buf = split_str buf (Crypto.cbc_block c.cipher) in
let* msg, _ = dec iv buf in
Ok (CBC c, msg) )
| AEAD c ->
if c.explicit_nonce then
let explicit_nonce_len = 8 in
if String.length buf < explicit_nonce_len then
Error (`Fatal (`Decode "MAC underflow"))
else
let explicit_nonce, buf = split_str buf explicit_nonce_len in
let adata =
let ver = pair_of_tls_version version in
Crypto.pseudo_header seq ty ver (String.length buf - Crypto.tag_len c.cipher)
and nonce = c.nonce ^ explicit_nonce
in
match Crypto.decrypt_aead ~cipher:c.cipher ~key:c.cipher_secret ~nonce ~adata buf with
| None -> Error (`Fatal `Bad_mac)
| Some x -> Ok (AEAD c, x)
else
(* RFC 7905: no explicit nonce, instead TLS 1.3 construction is adapted *)
let adata =
let ver = pair_of_tls_version version in
Crypto.pseudo_header seq ty ver (String.length buf - Crypto.tag_len c.cipher)
and nonce = Crypto.aead_nonce c.nonce seq
in
(match Crypto.decrypt_aead ~adata ~cipher:c.cipher ~key:c.cipher_secret ~nonce buf with
| None -> Error (`Fatal `Bad_mac)
| Some x -> Ok (AEAD c, x))
in
match st, version with
| None, _ when ty = Packet.APPLICATION_DATA ->
(* the server can end up in the situation:
CH [+early_data +key_share] ; APP_DATA ---->
<--- HRR [+key_share] (does not install a decryptor,
early data now disallowed)
CH [+key_share] ----->
the APP_DATA above cannot be decrypted or used, so we drop it.
*)
Ok (None, "", Packet.APPLICATION_DATA)
| None, _ -> Ok (st, buf, ty)
| Some ctx, `TLS_1_3 ->
(match ty with
| Packet.CHANGE_CIPHER_SPEC -> Ok (st, buf, ty)
| Packet.APPLICATION_DATA ->
(match ctx.cipher_st with
| AEAD c ->
let nonce = Crypto.aead_nonce c.nonce ctx.sequence in
let unpad x =
let rec eat = function
| -1 -> Error (`Fatal (`Unexpected (`Message "missing content type")))
| idx -> match String.get_uint8 x idx with
| 0 -> eat (pred idx)
| n -> match Packet.int_to_content_type n with
| Some ct -> Ok (String.sub x 0 idx, ct)
| None -> Error (`Fatal (`Unexpected (`Content_type n)))
in
eat (pred (String.length x))
in
let adata = Crypto.adata_1_3 (String.length buf) in
(match Crypto.decrypt_aead ~adata ~cipher:c.cipher ~key:c.cipher_secret ~nonce buf with
| None ->
if trial then
Ok (Some ctx, "", Packet.APPLICATION_DATA)
else
Error (`Fatal `Bad_mac)
| Some x ->
let* data, ty = unpad x in
Ok (Some { ctx with sequence = Int64.succ ctx.sequence }, data, ty))
| _ -> Error (`Fatal (`Handshake (`Message "unexpected cipher state (must be AEAD)"))))
| ct ->
let msg = "unexpected content type (TLS 1.3, encrypted) " ^ Packet.content_type_to_string ct in
Error (`Fatal (`Handshake (`Message msg))))
| Some ctx, _ ->
let* st', msg = dec ctx in
let ctx' = { cipher_st = st' ; sequence = Int64.succ ctx.sequence } in
Ok (Some ctx', msg, ty)
(* party time *)
let rec separate_records : string -> ((tls_hdr * string) list * string, failure) result
= fun buf ->
match Reader.parse_record buf with
| Ok (`Fragment b) -> Ok ([], b)
| Ok (`Record (packet, fragment)) ->
let* tl, frag = separate_records fragment in
Ok (packet :: tl, frag)
| Error e ->
Tracing.cs ~tag:"buf-in" buf ;
Error (`Fatal e)
let encrypt_records encryptor version records =
let rec crypt st acc = function
| [] -> st, List.rev acc
| (ty, buf) :: rest ->
let bufl = String.length buf in
let rec doit st acc off =
if bufl - off >= 1 lsl 14 then
let len = 1 lsl 14 in
let st, ty, buf = encrypt version st ty buf off len in
(doit [@tailcall]) st ((ty, buf) :: acc) (off + len)
else
let st, ty, buf = encrypt version st ty buf off (bufl - off) in
st, (ty, buf) :: acc
in
let st, res = doit st [] 0 in
(crypt [@tailcall]) st (res @ acc) rest
in
crypt encryptor [] records
module Alert = struct
(* The alert protocol:
- receiving a close_notify leads to eof (never read() any further data)
- any fatal alert leads to sending a close_notify and state is closed
*)
open Packet
let make ?level typ = (ALERT, Writer.assemble_alert ?level typ)
let close_notify = make ~level:WARNING CLOSE_NOTIFY
let handle buf =
let* alert = map_reader_error (Reader.parse_alert buf) in
let _, a_type = alert in
Tracing.debug (fun m -> m "alert-in %a" pp_alert alert) ;
match a_type with
| CLOSE_NOTIFY | USER_CANCELED -> Ok true
| _ -> Error (`Alert a_type)
end
let hs_can_handle_appdata s =
(* When is a TLS session up for some application data?
- initial handshake must be finished!
- renegotiation must not be in progress
--> thus only ok for Established
- but ok if server sent a HelloRequest and can get first some appdata then ClientHello
--> or converse: client sent ClientHello, waiting for ServerHello *)
(* turns out, rules in 1.3 are slightly different -- server may send appdata after its first flight!
this means in any observable state! (apart from when a HRR was sent) *)
match s.machina with
| Server13 AwaitClientHelloHRR13 -> false
| Server Established | Server AwaitClientHelloRenegotiate | Server13 _
| Client Established | Client AwaitServerHelloRenegotiate _ | Client13 Established13 -> true
| _ -> false
let early_data s =
match s.machina with
| Server13 AwaitClientHelloHRR13
| Server13 (AwaitEndOfEarlyData13 _) | Server13 (AwaitClientFinished13 _)
| Server13 (AwaitClientCertificate13 _) | Server13 (AwaitClientCertificateVerify13 _) -> true
| _ -> false
let rec separate_handshakes buf =
match Reader.parse_handshake_frame buf with
| None, rest -> [], rest
| Some hs, rest ->
let rt, frag = separate_handshakes rest in
hs :: rt, frag
let handle_change_cipher_spec = function
| Client cs -> Handshake_client.handle_change_cipher_spec cs
| Server ss -> Handshake_server.handle_change_cipher_spec ss
(* D.4: the client may send a CCS before its second flight
(before second ClientHello or encrypted handshake flight)
the server may send it immediately after its first handshake message
(ServerHello or HelloRetryRequest) *)
| Client13 (AwaitServerEncryptedExtensions13 _)
| Client13 (AwaitServerHello13 _)
| Server13 AwaitClientHelloHRR13
| Server13 (AwaitClientCertificate13 _)
| Server13 (AwaitClientFinished13 _) -> (fun s _ -> Ok (s, []))
| _ -> (fun _ _ -> Error (`Fatal (`Unexpected (`Message "change cipher spec"))))
and handle_handshake = function
| Client cs -> Handshake_client.handle_handshake cs
| Server ss -> Handshake_server.handle_handshake ss
| Client13 cs -> Handshake_client13.handle_handshake cs
| Server13 ss -> Handshake_server13.handle_handshake ss
let non_empty cs =
if String.length cs = 0 then None else Some cs
let handle_packet hs buf = function
(* RFC 5246 -- 6.2.1.:
Implementations MUST NOT send zero-length fragments of Handshake,
Alert, or ChangeCipherSpec content types. Zero-length fragments of
Application data MAY be sent as they are potentially useful as a
traffic analysis countermeasure.
*)
| Packet.ALERT ->
let* eof = Alert.handle buf in
Ok (hs, [], None, eof)
| Packet.APPLICATION_DATA ->
if hs_can_handle_appdata hs || (early_data hs && String.length hs.hs_fragment = 0) then
(Tracing.cs ~tag:"application-data-in" buf;
Ok (hs, [], non_empty buf, false))
else
Error (`Fatal (`Unexpected (`Message "application data")))
| Packet.CHANGE_CIPHER_SPEC ->
let* hs, items = handle_change_cipher_spec hs.machina hs buf in
Ok (hs, items, None, false)
| Packet.HANDSHAKE ->
let hss, hs_fragment = separate_handshakes (hs.hs_fragment ^ buf) in
let hs = { hs with hs_fragment } in
let* hs, items =
List.fold_left (fun acc raw ->
let* hs, items = acc in
let* hs', items' = handle_handshake hs.machina hs raw in
Ok (hs', items @ items'))
(Ok (hs, [])) hss
in
Ok (hs, items, None, false)
let decrement_early_data hs ty buf =
let bytes left cipher =
let count = String.length buf - fst (Ciphersuite.kn_13 (Ciphersuite.privprot13 cipher)) in
let left' = Int32.sub left (Int32.of_int count) in
if left' < 0l then
Error (`Fatal (`Unexpected (`Message "too many 0RTT bytes")))
else
Ok left'
in
if ty = Packet.APPLICATION_DATA && early_data hs then
let cipher = match hs.session with
| `TLS13 sd::_ -> sd.ciphersuite13
| _ -> `AES_128_GCM_SHA256
(* TODO assert and ensure that all early_data states have a cipher *)
in
let* early_data_left = bytes hs.early_data_left cipher in
Ok { hs with early_data_left }
else
Ok hs
(* the main thingy *)
let handle_raw_record state (hdr, buf as record : raw_record) =
Tracing.debug (fun m -> m "record-in %a" pp_raw_record record) ;
let hs = state.handshake in
let version = hs.protocol_version in
let* () =
match hs.machina, version with
| Client (AwaitServerHello _), _ -> Ok ()
| Server AwaitClientHello, _ -> Ok ()
| Server13 AwaitClientHelloHRR13, _ -> Ok ()
| _, `TLS_1_3 ->
guard (hdr.version = `TLS_1_2)
(`Fatal (`Protocol_version (`Bad_record hdr.version)))
| _, v ->
guard (version_eq hdr.version v)
(`Fatal (`Protocol_version (`Bad_record hdr.version)))
in
let trial = match hs.machina with
| Server13 (AwaitEndOfEarlyData13 _) | Server13 Established13 -> false
| Server13 _ -> hs.early_data_left > 0l && String.length hs.hs_fragment = 0
| _ -> false
in
let* dec_st, dec, ty = decrypt ~trial version state.decryptor hdr.content_type buf in
let* handshake = decrement_early_data hs ty buf in
Tracing.debug (fun m -> m "frame-in %a" pp_frame (ty, dec)) ;
let* handshake, items, data, read_closed = handle_packet handshake dec ty in
let encryptor, decryptor, encs =
List.fold_left (fun (enc, dec, es) -> function
| `Change_enc enc' -> (Some enc', dec, es)
| `Change_dec dec' -> (enc, Some dec', es)
| `Record r ->
Tracing.debug (fun m -> m "frame-out %a" pp_frame r) ;
let (enc', encbuf) = encrypt_records enc handshake.protocol_version [r] in
(enc', dec, es @ encbuf))
(state.encryptor, dec_st, [])
items
in
List.iter (fun f -> Tracing.debug (fun m -> m "record-out %a" pp_frame f)) encs ;
let read_closed = read_closed || state.read_closed in
let state' = { state with handshake ; encryptor ; decryptor ; read_closed } in
Ok (state', encs, data)
let maybe_app a b = match a, b with
| Some x, Some y -> Some (x ^ y)
| Some x, None -> Some x
| None , Some y -> Some y
| None , None -> None
let assemble_records (version : tls_version) rs =
let version = match version with `TLS_1_3 -> `TLS_1_2 | x -> x in
String.concat "" (List.map (Writer.assemble_hdr version) rs)
(* main entry point *)
let handle_tls state buf =
Tracing.cs ~tag:"wire-in" buf ;
let rec handle_records st = function
| [] -> Ok (st, [], None)
| r::rs ->
let* st, raw_rs, data = handle_raw_record st r in
let* st', raw_rs', data' = handle_records st rs in
Ok (st', raw_rs @ raw_rs', maybe_app data data')
in
match
let* in_records, fragment = separate_records (state.fragment ^ buf) in
let* state', out_records, data = handle_records state in_records in
let version = state'.handshake.protocol_version in
let resp = match out_records with
| [] -> None
| _ ->
let out = assemble_records version out_records in
Tracing.cs ~tag:"wire-out" out ;
Some out
in
Ok ({ state' with fragment }, resp, data)
with
| Ok (state, resp, data) ->
let res =
if state.read_closed then begin
Tracing.debug (fun m -> m "eof-out") ;
Some `Eof
end else
None
in
(* Tracing.sexpf ~tag:"state-out" ~f:sexp_of_state state ; *)
Ok (state, res, `Response resp, `Data data)
| Error x ->
let version = state.handshake.protocol_version in
let level, alert = alert_of_failure x in
let record = Alert.make ~level alert in
let _, enc = encrypt_records state.encryptor version [record] in
let resp = assemble_records version enc in
Tracing.debug (fun m -> m "fail-alert-out %a" Packet.pp_alert (Packet.FATAL, alert)) ;
Tracing.debug (fun m -> m "failure %a" pp_failure x) ;
Error (x, `Response resp)
let send_records (st : state) records =
let version = st.handshake.protocol_version in
List.iter (fun f -> Tracing.debug (fun m -> m "frame-out %a" pp_frame f)) records ;
let (encryptor, encs) =
encrypt_records st.encryptor version records in
List.iter (fun f -> Tracing.debug (fun m -> m "record-out %a" pp_frame f)) encs ;
let data = assemble_records version encs in
Tracing.cs ~tag:"wire-out" data ;
({ st with encryptor }, data)
let handshake_in_progress s = match s.handshake.machina with
| Client Established | Server Established -> false
| Client13 Established13 | Server13 Established13 -> false
| _ -> true
(* entry for user data *)
let send_application_data st css =
if st.write_closed || not (hs_can_handle_appdata st.handshake) then
None
else begin
List.iter (fun cs -> Tracing.cs ~tag:"application-data-out" cs) css ;
let datas = match st.encryptor with
(* Mitigate implicit IV in CBC mode: prepend empty fragment *)
| Some { cipher_st = CBC { iv_mode = Iv _ ; _ } ; _ } -> "" :: css
| _ -> css
in
let ty = Packet.APPLICATION_DATA in
let data = List.map (fun cs -> (ty, cs)) datas in
Some (send_records st data)
end
let send_close_notify st =
let st = { st with write_closed = true } in
send_records st [Alert.close_notify]
let reneg ?authenticator ?acceptable_cas ?cert st =
if st.write_closed || st.read_closed then
(* this is a full handshake (with messages from both sides), thus if either
direction has closed the flow, the reneg won't succeed *)
None
else
let config = st.handshake.config in
let config = Option.fold ~none:config ~some:(Config.with_authenticator config) authenticator in
let config = Option.fold ~none:config ~some:(Config.with_acceptable_cas config) acceptable_cas in
let config = Option.fold ~none:config ~some:(Config.with_own_certificates config) cert in
let hs = { st.handshake with config } in
match hs.machina with
| Server Established ->
( match Handshake_server.hello_request hs with
| Ok (handshake, [`Record hr]) -> Some (send_records { st with handshake } [hr])
| _ -> None )
| Client Established ->
( match Handshake_client.answer_hello_request hs with
| Ok (handshake, [`Record ch]) -> Some (send_records { st with handshake } [ch])
| _ -> None )
| _ -> None
let key_update ?(request = true) state =
if state.write_closed then
Error (`Fatal (`Unexpected (`Message "write half already closed")))
else
let* state', out = Handshake_common.output_key_update ~request state in
let _, outbuf = send_records state [out] in
Ok (state', outbuf)
let client config =
let config = Config.of_client config in
let state = new_state config `Client in
let dch, _version, secrets = Handshake_client.default_client_hello config in
let ciphers, extensions = match config.Config.protocol_versions with
(* from RFC 5746 section 3.3:
Both the SSLv3 and TLS 1.0/TLS 1.1 specifications require
implementations to ignore data following the ClientHello (i.e.,
extensions) if they do not understand it. However, some SSLv3 and
TLS 1.0 implementations incorrectly fail the handshake in such a
case. This means that clients that offer the "renegotiation_info"
extension may encounter handshake failures. In order to enhance
compatibility with such servers, this document defines a second
signaling mechanism via a special Signaling Cipher Suite Value (SCSV)
"TLS_EMPTY_RENEGOTIATION_INFO_SCSV", with code point {0x00, 0xFF}.
This SCSV is not a true cipher suite (it does not correspond to any
valid set of algorithms) and cannot be negotiated. Instead, it has
the same semantics as an empty "renegotiation_info" extension, as
described in the following sections. Because SSLv3 and TLS
implementations reliably ignore unknown cipher suites, the SCSV may
be safely sent to any server. *)
| (_, `TLS_1_0) -> ([Packet.TLS_EMPTY_RENEGOTIATION_INFO_SCSV], [])
| (`TLS_1_3, _) -> ([], [])
| _ -> ([], [`SecureRenegotiation ""])
in
let client_hello =
{ dch with
ciphersuites = dch.ciphersuites @ ciphers ;
extensions = dch.extensions @ extensions }
in
let client_hello, ch, raw =
match config.Config.cached_ticket, config.Config.ticket_cache with
| None, _ | _, None ->
let ch = ClientHello client_hello in
client_hello, ch, Writer.assemble_handshake ch
| Some (psk, epoch), Some cache ->
let kex = `PskKeyExchangeModes [ Packet.PSK_KE_DHE ] in
(* what next!? *)
let now = cache.Config.timestamp () in
(* TODO check lifetime! *)
let obf_age =
let span = Ptime.Span.to_float_s (Ptime.diff now psk.issued_at) in
(* _in milliseconds_ *)
let ms = int_of_float (span *. 1000.) in
Int32.add psk.obfuscation (Int32.of_int ms)
in
let cipher = match Ciphersuite.ciphersuite_to_ciphersuite13 epoch.ciphersuite with
| None -> assert false
| Some c -> c
in
(* if all goes well, we can compute the binder key and embed into ch! *)
let early_secret = Handshake_crypto13.(derive (empty cipher) psk.secret) in
let binder_key = Handshake_crypto13.derive_secret early_secret "res binder" "" in
let hash =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
String.make H.digest_size '\x00'
in
let incomplete_psks = [ (psk.identifier, obf_age), hash ] in
let ch' = { client_hello with extensions = client_hello.extensions @ [ kex ; `PreSharedKeys incomplete_psks ] } in
let ch'_raw = Writer.assemble_handshake (ClientHello ch') in
let binders_len = binders_len incomplete_psks in
let ch_part = String.(sub ch'_raw 0 (length ch'_raw - binders_len)) in
let binder = Handshake_crypto13.finished early_secret.hash binder_key ch_part in
let blen = String.length binder in
let prefix = Bytes.create 3 in
Bytes.set_uint16_be prefix 0 (blen + 1) ;
Bytes.set_uint8 prefix 2 blen ;
let raw = String.concat "" [ ch_part ; Bytes.unsafe_to_string prefix ; binder ] in
let psks = [(psk.identifier, obf_age), binder] in
let client_hello' = { client_hello with extensions = client_hello.extensions @ [ kex ; `PreSharedKeys psks ] } in
let ch' = ClientHello client_hello' in
client_hello', ch', raw
in
let machina = AwaitServerHello (client_hello, secrets, [raw]) in
(* from RFC5246, appendix E.1
TLS clients that wish to negotiate with older servers MAY send any
value {03,XX} as the record layer version number. Typical values
would be {03,00}, the lowest version number supported by the client,
and the value of ClientHello.client_version. No single value will
guarantee interoperability with all old servers, but this is a
complex topic beyond the scope of this document. *)
let version = min_protocol_version Config.(config.protocol_versions) in
let handshake = {
state.handshake with
machina = Client machina ;
protocol_version = version
} in
let state = { state with handshake } in
Tracing.hs ~tag:"handshake-out" ch ;
send_records state [(Packet.HANDSHAKE, raw)]
let server config = new_state Config.(of_server config) `Server
let epoch state =
Option.to_result ~none:() (epoch_of_hs state.handshake)
let export_key_material (e : epoch_data) ?context label length =
match e.protocol_version with
| `TLS_1_3 ->
let hash =
let cipher = Option.get (Ciphersuite.ciphersuite_to_ciphersuite13 e.ciphersuite) in
Ciphersuite.hash13 cipher
in
let module H = (val Digestif.module_of_hash' hash) in
let ems = e.exporter_master_secret in
let prk =
let ctx = H.(to_raw_string (digest_string "")) in
Handshake_crypto13.derive_secret_no_hash hash ems ~ctx label
in
let ctx = Option.value ~default:"" context in
Handshake_crypto13.derive_secret_no_hash
hash prk ~ctx:H.(to_raw_string (digest_string ctx))
~length "exporter"
| #tls_before_13 as v ->
let seed =
let base =
match e.side with
| `Server -> e.peer_random ^ e.own_random
| `Client -> e.own_random ^ e.peer_random
in
match context with
| None -> base
| Some data ->
let len = Bytes.create 2 in
Bytes.set_uint16_be len 0 (String.length data);
String.concat "" [ base ; Bytes.unsafe_to_string len ; data ]
in
Handshake_crypto.pseudo_random_function v e.ciphersuite
length e.master_secret label seed
let channel_binding e = function
| `Tls_exporter ->
Ok (export_key_material e "EXPORTER-Channel-Binding" 32)
| `Tls_server_endpoint ->
let ( let* ) = Result.bind in
let* cert =
match e.side, e.peer_certificate, e.own_certificate with
| `Client, Some cert, _ -> Ok cert
| `Server, _, cert :: _ -> Ok cert
| `Client, _, _ -> Error (`Msg "no certificate received from the server")
| `Server, _, _ -> Error (`Msg "certificate not available")
in
let* sigalg =
Option.to_result ~none:(`Msg "unknown signature algorithm in certificate")
(Option.map snd (X509.Certificate.signature_algorithm cert))
in
let hash = match sigalg with `MD5 | `SHA1 -> `SHA256 | x -> x in
Ok (X509.Certificate.fingerprint hash cert)
| `Tls_unique ->
match e.protocol_version, e.tls_unique with
| `TLS_1_3, _ ->
Error (`Msg "tls-unique not defined for TLS 1.3")
| _, None -> Error (`Msg "couldn't find a tls-unique in the session data")
| _, Some data -> Ok data

172
unikernel/duniverse/ocaml-tls/lib/engine.mli Normal file
View file

@ -0,0 +1,172 @@
(** Transport layer security
[TLS] is an implementation of
{{:https://en.wikipedia.org/wiki/Transport_Layer_Security}transport
layer security} in OCaml. TLS is a widely used security protocol
which establishes an end-to-end secure channel (with optional
(mutual) authentication) between two endpoints. It uses TCP/IP as
transport. This library supports all four versions of TLS:
{{:https://tools.ietf.org/html/rfc8446}1.3, RFC8446},
{{:https://tools.ietf.org/html/rfc5246}1.2, RFC5246},
{{:https://tools.ietf.org/html/rfc4346}1.1, RFC4346}, and
{{:https://tools.ietf.org/html/rfc2246}1.0, RFC2246}. SSL, the
previous protocol definition, is not supported.
TLS is algorithmically agile: protocol version, key exchange
algorithm, symmetric cipher, and message authentication code are
negotiated upon connection.
This library implements several extensions of TLS,
{{:https://tools.ietf.org/html/rfc3268}AES ciphers},
{{:https://tools.ietf.org/html/rfc4366}TLS extensions} (such as
server name indication, SNI),
{{:https://tools.ietf.org/html/rfc5746}Renegotiation extension},
{{:https://tools.ietf.org/html/rfc7627}Session Hash and Extended
Master Secret Extension}.
This library does not contain insecure cipher suites (such as
single DES, export ciphers, ...). It does not expose the server
time in the server random, requires secure renegotiation.
This library consists of a core, implemented in a purely
functional matter ({!Engine}, this module), and effectful parts:
{!Tls_lwt} and {!Tls_mirage}.
{e v2.0.3} *)
(** {1 Abstract state type} *)
(** The abstract type of a TLS state. *)
type state
(** {1 Constructors} *)
(** [client client] is [tls * out] where [tls] is the initial state,
and [out] the initial client hello *)
val client : Config.client -> (state * string)
(** [server server] is [tls] where [tls] is the initial server
state *)
val server : Config.server -> state
(** {1 Protocol failures} *)
(** failures which can be mitigated by reconfiguration *)
type error = [
| `AuthenticationFailure of X509.Validation.validation_error
| `NoConfiguredCiphersuite of Ciphersuite.ciphersuite list
| `NoConfiguredVersions of Core.tls_version list
| `NoConfiguredSignatureAlgorithm of Core.signature_algorithm list
| `NoMatchingCertificateFound of string
| `CouldntSelectCertificate
]
(** failures from received garbage or lack of features *)
type fatal = [
| `Protocol_version of [
| `None_supported of Core.tls_any_version list
| `Unknown_record of int * int
| `Bad_record of Core.tls_any_version
]
| `Unexpected of [
| `Content_type of int
| `Message of string
| `Handshake of Core.tls_handshake
]
| `Decode of string
| `Handshake of [
| `Message of string
| `Fragments
| `BadDH of string
| `BadECDH of Mirage_crypto_ec.error
]
| `Bad_certificate of string
| `Missing_extension of string
| `Bad_mac
| `Record_overflow of int
| `Unsupported_extension
| `Inappropriate_fallback
| `No_application_protocol
]
(** type of failures *)
type failure = [
| `Error of error
| `Fatal of fatal
| `Alert of Packet.alert_type
]
(** [alert_of_failure failure] is [alert], the TLS alert type for this failure. *)
val alert_of_failure : failure -> Packet.alert_level * Packet.alert_type
(** [string_of_failure failure] is [string], the string representation of the [failure]. *)
val string_of_failure : failure -> string
(** [pp_failure failure] pretty-prints failure. *)
val pp_failure : failure Fmt.t
(** {1 Protocol handling} *)
(** result type of {!handle_tls}: either failed to handle the incoming
buffer ([`Fail]) with {!failure} and potentially a message to send
to the other endpoint, or sucessful operation ([`Ok]) with a new
{!state}, an end of file ([`Eof]), or an incoming ([`Alert]).
Possibly some [`Response] to the other endpoint is needed, and
potentially some [`Data] for the application was received. *)
type ret =
(state * [ `Eof ] option
* [ `Response of string option ]
* [ `Data of string option ],
failure * [ `Response of string ]) result
(** [handle_tls state buffer] is [ret], depending on incoming [state]
and [buffer], the result is the appropriate {!ret} *)
val handle_tls : state -> string -> ret
(** [handshake_in_progrss state] is a predicate which indicates whether there
is a handshake in progress or scheduled. *)
val handshake_in_progress : state -> bool
(** [send_application_data tls outs] is [Some (tls', out)] where
[tls'] is the new tls state, and [out] the cstruct to send over the
wire (encrypted [outs]) when the TLS session is ready. When the TLS
session is not ready it is [None]. *)
val send_application_data : state -> string list -> (state * string) option
(** [send_close_notify tls] is [tls' * out] where [tls'] is the new
tls state, and out the (possible encrypted) close notify alert. *)
val send_close_notify : state -> state * string
(** [reneg ~authenticator ~acceptable_cas ~cert tls] initiates a renegotation on
[tls], using the provided [authenticator]. It is [tls' * out] where [tls']
is the new tls state, and [out] either a client hello or hello request
(depending on which communication endpoint [tls] is). *)
val reneg : ?authenticator:X509.Authenticator.t ->
?acceptable_cas:X509.Distinguished_name.t list -> ?cert:Config.own_cert ->
state -> (state * string) option
(** [key_update ~request state] initiates a KeyUpdate (TLS 1.3 only). If
[request] is provided and [true] (the default), the KeyUpdate message
contains a request that the peer should update their traffic key as well. *)
val key_update : ?request:bool -> state -> (state * string, failure) result
(** {1 Session information} *)
(** [epoch state] is [epoch], which contains the session
information. If there's no established session yet, an error is returned. *)
val epoch : state -> (Core.epoch_data, unit) result
(** [export_key_material epoch_data ?context label length] is the RFC 5705
exported key material of [length] bytes using [label] and, if provided,
[context]. *)
val export_key_material : Core.epoch_data -> ?context:string -> string -> int ->
string
(** [channel_binding epoch_data mode] is the RFC 5929 and RFC 9266 specified
channel binding. Please note that [`Tls_unique] will error for TLS 1.3
sessions, and [`Tls_exporter] is not recommended for TLS < 1.3 sessions
(unless the uniqueness is ensured via another path). *)
val channel_binding : Core.epoch_data ->
[ `Tls_exporter | `Tls_unique | `Tls_server_endpoint ] ->
(string, [ `Msg of string ]) result

0
unikernel/duniverse/ocaml-tls/lib/explorator.ml Normal file
View file

544
unikernel/duniverse/ocaml-tls/lib/handshake_client.ml Normal file
View file

@ -0,0 +1,544 @@
open Core
open State
open Handshake_common
open Config
let state_version state = match state.protocol_version with
| #tls_before_13 as v -> v
| _ -> assert false
let default_client_hello config =
let host = match config.peer_name with
| None -> []
| Some x -> [`Hostname x]
in
let version = max_protocol_version config.protocol_versions in
let ecc_groups = match List.filter Config.elliptic_curve config.groups with
| [] -> []
| xs -> [ `ECPointFormats ; `SupportedGroups (List.map group_to_named_group xs) ]
in
let extensions, secrets = match version with
| `TLS_1_0 | `TLS_1_1 -> (ecc_groups, [])
| `TLS_1_2 ->
(`SignatureAlgorithms config.signature_algorithms :: ecc_groups, [])
| `TLS_1_3 ->
let sig_alg = config.signature_algorithms (* TODO: filter deprecated ones *)
and groups = List.map group_to_named_group config.groups
and secrets, keyshares =
(* OTOH, we could send all the keyshares (but this is pretty substantial size) *)
(* instead we pick the first two groups and send keyshares *)
let rec gen c gs acc = match c with
| 0 -> List.rev acc
| _ -> match gs with
| [] -> List.rev acc (* TODO log? complain? *)
| g::gs' ->
let priv, share = Handshake_crypto13.dh_gen_key g in
let acc' = ((g, priv),(group_to_named_group g, share)) :: acc in
gen (pred c) gs' acc'
in
List.split (gen 2 config.groups [])
in
let all = all_versions config.protocol_versions in
let supported_versions = List.map (fun x -> (x :> tls_any_version)) all in
let point_format =
if min_protocol_version config.protocol_versions = `TLS_1_3 then
[]
else
[ `ECPointFormats ]
in
let exts =
point_format @ [`SignatureAlgorithms sig_alg ; `SupportedGroups groups ; `KeyShare keyshares ; `SupportedVersions supported_versions ]
in
(exts, secrets)
in
let alpn = match config.alpn_protocols with
| [] -> []
| protocols -> [`ALPN protocols]
in
let sessionid =
match config.use_reneg, config.cached_session with
| _, Some { session_id ; extended_ms ; _ } when extended_ms && not (String.length session_id = 0) -> Some session_id
| false, Some { session_id ; _ } when not (String.length session_id = 0) -> Some session_id
| _ -> None
in
let ch = {
client_version = (version :> tls_any_version) ;
client_random = Mirage_crypto_rng.generate 32 ;
sessionid = sessionid ;
ciphersuites = List.map Ciphersuite.ciphersuite_to_any_ciphersuite config.ciphers ;
extensions = `ExtendedMasterSecret :: host @ extensions @ alpn
}
in
(ch, version, secrets)
let common_server_hello_validation config reneg (sh : server_hello) (ch : client_hello) =
let validate_reneg data =
let err = `Fatal (`Handshake (`Message "invalid renegotiation")) in
match reneg, data with
| Some (cvd, svd), Some x -> guard (String.equal (cvd ^ svd) x) err
| Some _, None -> Error err
| None, Some x -> guard (String.length x = 0) err
| None, None -> Ok ()
in
let* () =
guard (List.mem sh.ciphersuite config.ciphers)
(`Error (`NoConfiguredCiphersuite [sh.ciphersuite]))
in
let* () =
guard (server_hello_valid sh &&
server_exts_subset_of_client sh.extensions ch.extensions)
(`Fatal `Unsupported_extension)
in
let* () =
match get_alpn_protocol sh with
| None -> Ok ()
| Some x ->
guard (List.mem x config.alpn_protocols) (`Fatal `Unsupported_extension)
in
validate_reneg (get_secure_renegotiation sh.extensions)
let common_server_hello_machina state (sh : server_hello) (ch : client_hello) raw log =
let cipher = sh.ciphersuite in
let session_id = Option.value ~default:"" sh.sessionid in
let extended_ms =
List.mem `ExtendedMasterSecret ch.extensions &&
List.mem `ExtendedMasterSecret sh.extensions
in
let alpn_protocol = get_alpn_protocol sh in
let session =
let session = empty_session in
let common_session_data = {
session.common_session_data with
client_random = ch.client_random ;
server_random = sh.server_random ;
alpn_protocol ;
} in {
session with
common_session_data ;
ciphersuite = cipher ;
session_id ;
extended_ms ;
client_version = ch.client_version ;
}
in
let state = { state with protocol_version = sh.server_version } in
match Ciphersuite.ciphersuite_kex cipher with
| #Ciphersuite.key_exchange_algorithm_dhe ->
let machina = Client (AwaitCertificate_DHE (session, log @ [raw])) in
Ok ({ state with machina }, [])
| `RSA ->
let machina = Client (AwaitCertificate_RSA (session, log @ [raw])) in
Ok ({ state with machina }, [])
let answer_server_hello state (ch : client_hello) sh secrets raw log =
let validate_version requested (lo, _) server_version =
guard (version_ge requested server_version && server_version >= lo)
(`Error (`NoConfiguredVersions [ server_version ]))
in
let cfg = state.config in
let* () = common_server_hello_validation cfg None sh ch in
let* () = validate_version ch.client_version state.config.protocol_versions sh.server_version in
let* () =
if max_protocol_version state.config.protocol_versions = `TLS_1_3 then
let* () =
guard (not (Utils.sub_equal ~off:24 ~len:8 Packet.downgrade12 sh.server_random))
(`Fatal (`Handshake (`Message "random contains downgrade TLS 1.2")))
in
guard (not (Utils.sub_equal ~off:24 ~len:8 Packet.downgrade11 sh.server_random))
(`Fatal (`Handshake (`Message "random contains downgrade TLS 1.1")))
else
Ok ()
in
let epoch_matches (epoch : epoch_data) =
epoch.ciphersuite = sh.ciphersuite &&
epoch.protocol_version = sh.server_version &&
Option.fold ~none:false ~some:(SessionID.equal epoch.session_id) sh.sessionid &&
(not cfg.use_reneg ||
(List.mem `ExtendedMasterSecret sh.extensions && epoch.extended_ms))
in
Tracing.debug (fun m -> m "version %a" pp_tls_version sh.server_version) ;
trace_cipher sh.ciphersuite ;
let state = { state with protocol_version = sh.server_version } in
match sh.server_version with
| #tls13 ->
Handshake_client13.answer_server_hello state ch sh secrets raw (String.concat "" log)
| #tls_before_13 as v ->
match state.config.cached_session with
| Some epoch when epoch_matches epoch ->
let session =
let session = session_of_epoch epoch in
let common_session_data = {
session.common_session_data with
client_random = ch.client_random ;
server_random = sh.server_random ;
client_auth = match epoch.own_certificate with [] -> false | _ -> true ;
} in
{ session with
common_session_data ;
client_version = ch.client_version ;
}
in
let client_ctx, server_ctx =
Handshake_crypto.initialise_crypto_ctx v session
in
let machina = AwaitServerChangeCipherSpecResume (session, client_ctx, server_ctx, log @ [raw]) in
Ok ({ state with machina = Client machina }, [])
| _ -> common_server_hello_machina state sh ch raw log
let answer_server_hello_renegotiate state session (ch : client_hello) sh raw log =
let* () = common_server_hello_validation state.config (Some session.renegotiation) sh ch in
let* () =
guard (state.protocol_version = sh.server_version)
(`Fatal (`Handshake (`Message "invalid renegotiation version")))
in
common_server_hello_machina state sh ch raw log
let validate_keyusage certificate kex =
let usage = Ciphersuite.required_usage kex in
let* cert =
Option.to_result ~none:(`Fatal (`Bad_certificate "none received")) certificate
in
let* () =
guard (supports_key_usage ~not_present:true usage cert)
(`Fatal (`Bad_certificate "key usage"))
in
guard
(supports_extended_key_usage `Server_auth cert ||
supports_extended_key_usage ~not_present:true `Any cert)
(`Fatal (`Bad_certificate "extended key usage"))
let answer_certificate_RSA state (session : session_data) cs raw log =
let cfg = state.config in
let* peer_certificate, received_certificates, peer_certificate_chain, trust_anchor =
validate_chain cfg.authenticator cs cfg.ip cfg.peer_name
in
let* () = validate_keyusage peer_certificate `RSA in
let session =
let common_session_data = { session.common_session_data with received_certificates ; peer_certificate ; peer_certificate_chain ; trust_anchor } in
{ session with common_session_data }
in
let* version =
match session.client_version with
| `TLS_1_3 -> Ok `TLS_1_2
| #tls_before_13 as v -> Ok v
| _ -> assert false
in
let buf = Bytes.create (2 + 46) in
let _ver = Writer.assemble_protocol_version ~buf version in
Mirage_crypto_rng.generate_into buf ~off:2 46;
let premaster = Bytes.unsafe_to_string buf in
let* k = peer_key peer_certificate in
match k with
| `RSA key ->
let kex = Mirage_crypto_pk.Rsa.PKCS1.encrypt ~key premaster in
let kex = Writer.assemble_client_dh_key_exchange kex in
let machina =
AwaitCertificateRequestOrServerHelloDone
(session, kex, premaster, log @ [raw])
in
Ok ({ state with machina = Client machina }, [])
| _ -> Error (`Fatal (`Bad_certificate "not an RSA certificate"))
let answer_certificate_DHE state (session : session_data) cs raw log =
let cfg = state.config in
let* peer_certificate, received_certificates, peer_certificate_chain, trust_anchor =
validate_chain cfg.authenticator cs cfg.ip cfg.peer_name
in
let* () = validate_keyusage peer_certificate `FFDHE in
let session =
let common_session_data = { session.common_session_data with received_certificates ; peer_certificate ; peer_certificate_chain ; trust_anchor } in
{ session with common_session_data }
in
let machina = AwaitServerKeyExchange_DHE (session, log @ [raw]) in
Ok ({ state with machina = Client machina }, [])
let answer_server_key_exchange_DHE state (session : session_data) kex raw log =
let* group, shared, raw_dh_params, leftover =
if Ciphersuite.ecdhe session.ciphersuite then
let* g, share, raw, left =
map_reader_error (Reader.parse_ec_parameters kex)
in
Ok (`Ec g, share, raw, left)
else
let unpack_dh dh_params =
Result.map_error
(function `Msg m -> `Fatal (`Decode m))
(Crypto.dh_params_unpack dh_params)
in
let* dh_params, raw_dh_params, leftover =
map_reader_error (Reader.parse_dh_parameters kex)
in
let* group, shared = unpack_dh dh_params in
let* () =
guard (Mirage_crypto_pk.Dh.modulus_size group >= Config.min_dh_size)
(`Fatal (`Handshake (`BadDH "too small")))
in
Ok (`Finite_field group, shared, raw_dh_params, leftover)
in
let sigdata =
String.concat "" [
session.common_session_data.client_random ;
session.common_session_data.server_random ;
raw_dh_params
]
in
let* () =
verify_digitally_signed state.protocol_version
state.config.signature_algorithms leftover sigdata
session.common_session_data.peer_certificate
in
let* pms, kex =
let open Mirage_crypto_ec in
let map_ecdh_error =
Result.map_error (fun e -> `Fatal (`Handshake (`BadECDH e)))
in
match group with
| `Finite_field g ->
let secret, client_share = Mirage_crypto_pk.Dh.gen_key g in
let* pms =
Option.to_result
~none:(`Fatal (`Handshake (`BadDH "invalid FF")))
(Mirage_crypto_pk.Dh.shared secret shared)
in
Ok (pms, Writer.assemble_client_dh_key_exchange client_share)
| `Ec `P256 ->
let secret, client_share = P256.Dh.gen_key () in
let* pms = map_ecdh_error (P256.Dh.key_exchange secret shared) in
Ok (pms, Writer.assemble_client_ec_key_exchange client_share)
| `Ec `P384 ->
let secret, client_share = P384.Dh.gen_key () in
let* pms = map_ecdh_error (P384.Dh.key_exchange secret shared) in
Ok (pms, Writer.assemble_client_ec_key_exchange client_share)
| `Ec `P521 ->
let secret, client_share = P521.Dh.gen_key () in
let* pms = map_ecdh_error (P521.Dh.key_exchange secret shared) in
Ok (pms, Writer.assemble_client_ec_key_exchange client_share)
| `Ec `X25519 ->
let secret, client_share = X25519.gen_key () in
let* pms = map_ecdh_error (X25519.key_exchange secret shared) in
Ok (pms, Writer.assemble_client_ec_key_exchange client_share)
in
let machina =
AwaitCertificateRequestOrServerHelloDone
(session, kex, pms, log @ [raw])
in
Ok ({ state with machina = Client machina }, [])
let answer_certificate_request state (session : session_data) cr kex pms raw log =
let cfg = state.config in
let* _types, sigalgs, _cas =
match state_version state with
| `TLS_1_0 | `TLS_1_1 ->
let* types, cas =
map_reader_error (Reader.parse_certificate_request cr)
in
Ok (types, None, cas)
| `TLS_1_2 ->
let* types, sigalgs, cas =
map_reader_error (Reader.parse_certificate_request_1_2 cr)
in
Ok (types, Some sigalgs, cas)
in
(* TODO: respect _types and _cas, multiple client certificates *)
let own_certificate, own_private_key =
match cfg.own_certificates with
| `Single (chain, priv) -> (chain, Some priv)
| _ -> ([], None)
in
let session =
let common_session_data = {
session.common_session_data with
own_certificate ;
own_private_key ;
client_auth = true
} in
{ session with common_session_data }
in
let machina = AwaitServerHelloDone (session, sigalgs, kex, pms, log @ [raw]) in
Ok ({ state with machina = Client machina }, [])
let answer_server_hello_done state (session : session_data) sigalgs kex premaster raw log =
let kex = ClientKeyExchange kex in
let ckex = Writer.assemble_handshake kex in
let* msgs, raw_msgs, raws, cert_verify =
match session.common_session_data.client_auth, session.common_session_data.own_private_key with
| true, Some p ->
let cs = List.map X509.Certificate.encode_der session.common_session_data.own_certificate in
let cert = Certificate (Writer.assemble_certificates cs) in
let ccert = Writer.assemble_handshake cert in
let to_sign = log @ [ raw ; ccert ; ckex ] in
let data = String.concat "" to_sign in
let ver = state.protocol_version
and my_sigalgs = state.config.signature_algorithms in
let* signature = signature ver data sigalgs my_sigalgs p in
let cert_verify = CertificateVerify signature in
let ccert_verify = Writer.assemble_handshake cert_verify in
Ok ([ cert ; kex ; cert_verify ],
[ ccert ; ckex ; ccert_verify ],
to_sign, Some ccert_verify)
| true, None ->
let cert = Certificate (Writer.assemble_certificates []) in
let ccert = Writer.assemble_handshake cert in
Ok ([cert ; kex], [ccert ; ckex], log @ [ raw ; ccert ; ckex ], None)
| false, _ ->
Ok ([kex], [ckex], log @ [ raw ; ckex ], None)
in
let to_fin = raws @ Option.to_list cert_verify in
let master_secret =
Handshake_crypto.derive_master_secret (state_version state) session premaster raws
in
let session =
let common_session_data = { session.common_session_data with master_secret } in
{ session with common_session_data }
in
let client_ctx, server_ctx =
Handshake_crypto.initialise_crypto_ctx (state_version state) session
in
let checksum = Handshake_crypto.finished (state_version state) session.ciphersuite master_secret "client finished" to_fin in
let fin = Finished checksum in
let raw_fin = Writer.assemble_handshake fin in
let session = { session with tls_unique = checksum } in
let ps = to_fin @ [raw_fin] in
let session =
let common_session_data = { session.common_session_data with master_secret } in
{ session with common_session_data }
in
let machina = AwaitServerChangeCipherSpec (session, server_ctx, checksum, ps)
and ccst, ccs = change_cipher_spec in
List.iter (Tracing.hs ~tag:"handshake-out") msgs;
Tracing.cs ~tag:"change-cipher-spec-out" ccs ;
Tracing.cs ~tag:"master-secret" master_secret;
Tracing.hs ~tag:"handshake-out" fin;
Ok ({ state with machina = Client machina },
List.map (fun x -> `Record (Packet.HANDSHAKE, x)) raw_msgs @
[ `Record (ccst, ccs);
`Change_enc client_ctx;
`Record (Packet.HANDSHAKE, raw_fin)])
let answer_server_finished state (session : session_data) client_verify fin log =
let computed =
Handshake_crypto.finished (state_version state) session.ciphersuite session.common_session_data.master_secret "server finished" log
in
let* () =
guard (String.equal computed fin)
(`Fatal (`Handshake (`Message "couldn't verify finished")))
in
let* () =
guard (String.length state.hs_fragment = 0) (`Fatal (`Handshake `Fragments))
in
let machina = Established
and session = { session with renegotiation = (client_verify, computed) } in
Ok ({ state with machina = Client machina ; session = `TLS session :: state.session }, [])
let answer_server_finished_resume state (session : session_data) fin raw log =
let client, server =
let checksum = Handshake_crypto.finished (state_version state) session.ciphersuite session.common_session_data.master_secret in
(checksum "client finished" (log @ [raw]), checksum "server finished" log)
in
let* () =
guard (String.equal server fin)
(`Fatal (`Handshake (`Message "couldn't verify finished")))
in
let session = { session with tls_unique = server } in
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let machina = Established
and session = { session with renegotiation = (client, server) }
in
let finished = Finished client in
let raw_finished = Writer.assemble_handshake finished in
Tracing.hs ~tag:"handshake-out" finished ;
Ok ({ state with machina = Client machina ; session = `TLS session :: state.session },
[`Record (Packet.HANDSHAKE, raw_finished)])
let answer_hello_request state =
let produce_client_hello session config exts =
let dch, _, _ = default_client_hello config in
let ch = { dch with extensions = dch.extensions @ exts ; sessionid = None } in
let raw = Writer.assemble_handshake (ClientHello ch) in
let machina = AwaitServerHelloRenegotiate (session, ch, [raw]) in
Tracing.hs ~tag:"handshake-out" (ClientHello ch) ;
({ state with machina = Client machina }, [`Record (Packet.HANDSHAKE, raw)])
in
match state.config.use_reneg, state.session with
| true , `TLS x :: _ ->
let ext = `SecureRenegotiation (fst x.renegotiation) in
Ok (produce_client_hello x state.config [ext])
| true , _ -> Error (`Fatal (`Handshake (`Message "couldn't find session")))
| false, _ ->
let no_reneg = Writer.assemble_alert ~level:Packet.WARNING Packet.NO_RENEGOTIATION in
Tracing.debug (fun m -> m "alert-out (warning, no_renegotiation)") ;
Ok (state, [`Record (Packet.ALERT, no_reneg)])
let handle_change_cipher_spec cs state packet =
let* () = map_reader_error (Reader.parse_change_cipher_spec packet) in
match cs with
| AwaitServerChangeCipherSpec (session, server_ctx, client_verify, log) ->
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let machina = AwaitServerFinished (session, client_verify, log) in
Tracing.cs ~tag:"change-cipher-spec-in" packet ;
Ok ({ state with machina = Client machina }, [`Change_dec server_ctx])
| AwaitServerChangeCipherSpecResume (session, client_ctx, server_ctx, log) ->
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let ccs = change_cipher_spec in
let machina = AwaitServerFinishedResume (session, log) in
Tracing.cs ~tag:"change-cipher-spec-in" packet ;
Tracing.cs ~tag:"change-cipher-spec-out" packet ;
Ok ({ state with machina = Client machina },
[`Record ccs ; `Change_enc client_ctx; `Change_dec server_ctx])
| _ -> Error (`Fatal (`Unexpected (`Message "change cipher spec")))
let handle_handshake cs hs buf =
let* handshake = map_reader_error (Reader.parse_handshake buf) in
Tracing.hs ~tag:"handshake-in" handshake ;
match cs, handshake with
| AwaitServerHello (ch, secrets, log), ServerHello sh ->
answer_server_hello hs ch sh secrets buf log
| AwaitServerHello (ch, secrets, log), HelloRetryRequest hrr ->
Handshake_client13.answer_hello_retry_request hs ch hrr secrets buf (String.concat "" log)
| AwaitServerHelloRenegotiate (session, ch, log), ServerHello sh ->
answer_server_hello_renegotiate hs session ch sh buf log
| AwaitCertificate_RSA (session, log), Certificate cs ->
let* cs = map_reader_error (Reader.parse_certificates cs) in
answer_certificate_RSA hs session cs buf log
| AwaitCertificate_DHE (session, log), Certificate cs ->
let* cs = map_reader_error (Reader.parse_certificates cs) in
answer_certificate_DHE hs session cs buf log
| AwaitServerKeyExchange_DHE (session, log), ServerKeyExchange kex ->
answer_server_key_exchange_DHE hs session kex buf log
| AwaitCertificateRequestOrServerHelloDone (session, kex, pms, log), CertificateRequest cr ->
answer_certificate_request hs session cr kex pms buf log
| AwaitCertificateRequestOrServerHelloDone (session, kex, pms, log), ServerHelloDone ->
answer_server_hello_done hs session None kex pms buf log
| AwaitServerHelloDone (session, sigalgs, kex, pms, log), ServerHelloDone ->
answer_server_hello_done hs session sigalgs kex pms buf log
| AwaitServerFinished (session, client_verify, log), Finished fin ->
answer_server_finished hs session client_verify fin log
| AwaitServerFinishedResume (session, log), Finished fin ->
answer_server_finished_resume hs session fin buf log
| Established, HelloRequest ->
answer_hello_request hs
| _, hs -> Error (`Fatal (`Unexpected (`Handshake hs)))

7
unikernel/duniverse/ocaml-tls/lib/handshake_client.mli Normal file
View file

@ -0,0 +1,7 @@
open Core
open State
val default_client_hello : Config.config -> (client_hello * tls_version * (group * dh_secret) list)
val handle_change_cipher_spec : client_handshake_state -> handshake_state -> string -> (handshake_return, failure) result
val handle_handshake : client_handshake_state -> handshake_state -> string -> (handshake_return, failure) result
val answer_hello_request : handshake_state -> (handshake_return, failure) result

307
unikernel/duniverse/ocaml-tls/lib/handshake_client13.ml Normal file
View file

@ -0,0 +1,307 @@
open State
open Core
open Handshake_common
open Config
let answer_server_hello state ch (sh : server_hello) secrets raw log =
(* assume SH valid, version 1.3, extensions are subset *)
match Ciphersuite.ciphersuite_to_ciphersuite13 sh.ciphersuite with
| None -> Error (`Fatal (`Handshake (`Message "not a TLS 1.3 ciphersuite")))
| Some cipher ->
let* () =
guard (List.mem cipher (ciphers13 state.config))
(`Fatal (`Handshake (`Message "not a configured ciphersuite")))
in
let* () = guard (String.length state.hs_fragment = 0) (`Fatal (`Handshake `Fragments)) in
(* TODO: PSK *)
(* TODO: early_secret elsewhere *)
match Utils.map_find ~f:(function `KeyShare ks -> Some ks | _ -> None) sh.extensions with
| None -> Error (`Fatal (`Handshake (`Message "missing key share extension")))
| Some (g, share) ->
match List.find_opt (fun (g', _) -> g = g') secrets with
| None -> Error (`Fatal (`Handshake (`Message "couldn't find our secret for the key share")))
| Some (_, secret) ->
let* shared = Handshake_crypto13.dh_shared secret share in
let hlen =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
H.digest_size
in
let* psk, resumed =
match
Utils.map_find ~f:(function `PreSharedKey idx -> Some idx | _ -> None) sh.extensions,
state.config.Config.cached_ticket
with
| None, _ | _, None -> Ok (String.make hlen '\x00', false)
| Some idx, Some (psk, _epoch) ->
let* () = guard (idx = 0) (`Fatal (`Handshake (`Message "resumed pre-shared idx not 0"))) in
Ok (psk.secret, true)
in
let early_secret = Handshake_crypto13.(derive (empty cipher) psk) in
let hs_secret = Handshake_crypto13.derive early_secret shared in
let log = log ^ raw in
let server_hs_secret, server_ctx, client_hs_secret, client_ctx =
Handshake_crypto13.hs_ctx hs_secret log in
let master_secret =
Handshake_crypto13.derive hs_secret (String.make hlen '\x00')
in
let session =
let base = empty_session13 cipher in
let common_session_data13 =
{ base.common_session_data13 with
server_random = sh.server_random ;
client_random = ch.client_random ;
master_secret = master_secret.secret }
in
{ base with master_secret ; common_session_data13 ; resumed }
in
let st = AwaitServerEncryptedExtensions13 (session, server_hs_secret, client_hs_secret, log) in
Ok ({ state with machina = Client13 st ; protocol_version = `TLS_1_3 },
[ `Change_enc client_ctx ; `Change_dec server_ctx ])
(* called from handshake_client.ml *)
let answer_hello_retry_request state (ch : client_hello) hrr _secrets raw log =
(* when is a HRR invalid / what do we need to check?
-> we advertised the group and cipher
-> TODO we did advertise such a keyshare already (does it matter?)
*)
let* () =
guard (`TLS_1_3 = hrr.retry_version)
(`Fatal (`Handshake (`Message "hello retry request with a version <> 1.3")))
in
let* () =
guard (List.mem hrr.selected_group state.config.groups)
(`Fatal (`Handshake (`Message "hello retry request with group we didn't advertise")))
in
let* () =
guard (List.mem hrr.ciphersuite (ciphers13 state.config))
(`Fatal (`Handshake (`Message "hello retet request with ciphersuite we didn't advertise"))) in
(* generate a fresh keyshare *)
let secret, keyshare =
let g = hrr.selected_group in
let priv, share = Handshake_crypto13.dh_gen_key g in
(g, priv), (group_to_named_group g, share)
in
(* append server extensions (i.e. cookie!) *)
let cookie = match Utils.map_find ~f:(function `Cookie c -> Some c | _ -> None) hrr.extensions with
| None -> []
| Some c -> [ `Cookie c ]
in
(* use the same extensions as in original CH, apart from PSK!? and early_data *)
let other_exts = List.filter (function `KeyShare _ -> false | _ -> true) ch.extensions in
let new_ch = { ch with extensions = `KeyShare [keyshare] :: other_exts @ cookie} in
let new_ch_raw = Writer.assemble_handshake (ClientHello new_ch) in
let ch0_data =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 hrr.ciphersuite)) in
H.(to_raw_string (digest_string log))
in
let ch0_hdr = Writer.assemble_message_hash (String.length ch0_data) in
let st = AwaitServerHello13 (new_ch, [secret], String.concat "" [ ch0_hdr ; ch0_data ; raw ; new_ch_raw ]) in
Tracing.hs ~tag:"handshake-out" (ClientHello new_ch);
Ok ({ state with machina = Client13 st ; protocol_version = `TLS_1_3 }, [`Record (Packet.HANDSHAKE, new_ch_raw)])
let answer_encrypted_extensions state (session : session_data13) server_hs_secret client_hs_secret ee raw log =
(* TODO we now know: - hostname - early_data (preserve this in session!!) *)
(* next message is either CertificateRequest or Certificate (or finished if PSK) *)
let alpn_protocol = Utils.map_find ~f:(function `ALPN proto -> Some proto | _ -> None) ee in
let session =
let common_session_data13 = { session.common_session_data13 with alpn_protocol } in
{ session with common_session_data13 }
in
let st =
if session.resumed then
AwaitServerFinished13 (session, server_hs_secret, client_hs_secret, None, log ^ raw)
else
AwaitServerCertificateRequestOrCertificate13 (session, server_hs_secret, client_hs_secret, log ^ raw)
in
Ok ({ state with machina = Client13 st }, [])
let answer_certificate state (session : session_data13) server_hs_secret client_hs_secret sigalgs certs raw log =
(* certificates are (cs, ext) list - ext being statusrequest or signed_cert_timestamp *)
let certs = List.map fst certs in
let* peer_certificate, received_certificates, peer_certificate_chain, trust_anchor =
validate_chain state.config.authenticator certs state.config.ip state.config.peer_name
in
let session =
let common_session_data13 = {
session.common_session_data13 with
received_certificates ; peer_certificate_chain ; peer_certificate ; trust_anchor
} in
{ session with common_session_data13 }
in
let st = AwaitServerCertificateVerify13 (session, server_hs_secret, client_hs_secret, sigalgs, log ^ raw) in
Ok ({ state with machina = Client13 st }, [])
let answer_certificate_verify (state : handshake_state) (session : session_data13) server_hs_secret client_hs_secret sigalgs cv raw log =
let tbs =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 session.ciphersuite13)) in
H.(to_raw_string (digest_string log))
in
let* () =
verify_digitally_signed state.protocol_version
~context_string:"TLS 1.3, server CertificateVerify"
state.config.signature_algorithms cv tbs
session.common_session_data13.peer_certificate
in
let st = AwaitServerFinished13 (session, server_hs_secret, client_hs_secret, sigalgs, log ^ raw) in
Ok ({ state with machina = Client13 st }, [])
let answer_certificate_request (state : handshake_state) (session : session_data13) server_hs_secret client_hs_secret extensions raw log =
(* TODO respect extensions (CA, OIDfilter)! *)
let session =
let common_session_data13 = { session.common_session_data13 with client_auth = true } in
{ session with common_session_data13 }
in
let sigalgs = Utils.map_find ~f:(function `SignatureAlgorithms s -> Some s | _ -> None) extensions in
let st = AwaitServerCertificate13 (session, server_hs_secret, client_hs_secret, sigalgs, log ^ raw) in
Ok ({ state with machina = Client13 st }, [])
let answer_finished state (session : session_data13) server_hs_secret client_hs_secret sigalgs fin raw log =
let hash = Ciphersuite.hash13 session.ciphersuite13 in
let f_data = Handshake_crypto13.finished hash server_hs_secret log in
let* () = guard (String.equal fin f_data) (`Fatal (`Handshake (`Message "couldn't verify finished"))) in
let* () = guard (String.length state.hs_fragment = 0) (`Fatal (`Handshake `Fragments)) in
let log = log ^ raw in
let server_app_secret, server_app_ctx, client_app_secret, client_app_ctx =
Handshake_crypto13.app_ctx session.master_secret log
in
let exporter_master_secret = Handshake_crypto13.exporter session.master_secret log in
let* c_cv, log =
if session.common_session_data13.client_auth then
let own_certificate, own_private_key =
match state.config.Config.own_certificates with
| `Single (chain, priv) -> (chain, Some priv)
| _ -> ([], None)
in
let certificate =
let cs = List.map X509.Certificate.encode_der own_certificate in
Certificate (Writer.assemble_certificates_1_3 "" cs)
in
let cert_raw = Writer.assemble_handshake certificate in
Tracing.hs ~tag:"handshake-out" certificate ;
let log = log ^ cert_raw in
match own_private_key with
| None ->
Ok ([cert_raw], log)
| Some priv ->
let tbs =
let module H = (val Digestif.module_of_hash' hash) in
H.(to_raw_string (digest_string log))
in
let* signed =
signature `TLS_1_3 ~context_string:"TLS 1.3, client CertificateVerify"
tbs sigalgs state.config.Config.signature_algorithms priv
in
let cv = CertificateVerify signed in
Tracing.hs ~tag:"handshake-out" cv ;
let cv_raw = Writer.assemble_handshake cv in
Ok ([ cert_raw ; cv_raw ], log ^ cv_raw)
else
Ok ([], log)
in
let myfin = Handshake_crypto13.finished hash client_hs_secret log in
let mfin = Writer.assemble_handshake (Finished myfin) in
let resumption_secret = Handshake_crypto13.resumption session.master_secret (log ^ mfin) in
let session = { session with resumption_secret ; exporter_master_secret ; client_app_secret ; server_app_secret } in
let machina = Client13 Established13 in
Tracing.hs ~tag:"handshake-out" (Finished myfin);
Ok ({ state with machina ; session = `TLS13 session :: state.session },
List.map (fun data -> `Record (Packet.HANDSHAKE, data)) c_cv @
[ `Record (Packet.HANDSHAKE, mfin) ;
`Change_dec server_app_ctx ; `Change_enc client_app_ctx ])
let answer_session_ticket state st =
(match state.config.ticket_cache with
| None -> ()
| Some cache ->
(* looks like we'll need the resumption secret in the state (we can compute once finished is done)! *)
match state.session with
| `TLS13 session :: _ ->
let epoch = epoch_of_session false state.config.Config.peer_name `TLS_1_3 (`TLS13 session) in
let secret = Handshake_crypto13.res_secret
(Ciphersuite.hash13 session.ciphersuite13)
session.resumption_secret st.nonce
in
let issued_at = cache.timestamp () in
let early_data = match Utils.map_find ~f:(function `EarlyDataIndication x -> Some x | _ -> None) st.extensions with
| None -> 0l
| Some x -> x
in
let psk = { identifier = st.ticket ; obfuscation = st.age_add ; secret ; lifetime = st.lifetime ; early_data ; issued_at } in
cache.ticket_granted psk epoch
| _ -> ());
Ok (state, [])
let handle_key_update state req =
match state.session with
| `TLS13 session :: _ ->
let* () = guard (String.length state.hs_fragment = 0) (`Fatal (`Handshake `Fragments)) in
let server_app_secret, server_ctx =
Handshake_crypto13.app_secret_n_1 session.master_secret session.server_app_secret
in
let session' = { session with server_app_secret } in
let session', out = match req with
| Packet.UPDATE_NOT_REQUESTED -> session', []
| Packet.UPDATE_REQUESTED ->
let client_app_secret, client_ctx =
Handshake_crypto13.app_secret_n_1 session.master_secret session.client_app_secret
in
let ku = KeyUpdate Packet.UPDATE_NOT_REQUESTED in
Tracing.hs ~tag:"handshake-out" ku ;
let ku_raw = Writer.assemble_handshake ku in
{ session' with client_app_secret },
[ `Record (Packet.HANDSHAKE, ku_raw); `Change_enc client_ctx ]
in
let session = `TLS13 session' :: state.session in
let state' = { state with machina = Server13 Established13 ; session } in
Ok (state', `Change_dec server_ctx :: out)
| _ -> Error (`Fatal (`Handshake (`Message "couldn't find an earlier session")))
let handle_handshake cs hs buf =
let open Reader in
let* handshake = map_reader_error (parse_handshake buf) in
Tracing.hs ~tag:"handshake-in" handshake;
match cs, handshake with
| AwaitServerHello13 (ch, secrets, log), ServerHello sh ->
answer_server_hello hs ch sh secrets buf log
| AwaitServerEncryptedExtensions13 (sd, es, ss, log), EncryptedExtensions ee ->
answer_encrypted_extensions hs sd es ss ee buf log
| AwaitServerCertificateRequestOrCertificate13 (sd, es, ss, log), CertificateRequest cr ->
let* ctx, exts = map_reader_error (parse_certificate_request_1_3 cr) in
(* during handshake, context must be empty! *)
let* () =
guard (ctx = None)
(`Fatal (`Handshake (`Message "certificate request context must be empty")))
in
answer_certificate_request hs sd es ss exts buf log
| AwaitServerCertificateRequestOrCertificate13 (sd, es, ss, log), Certificate cs ->
let* con, cs = map_reader_error (parse_certificates_1_3 cs) in
(* during handshake, context must be empty! and we'll not get any new certificate from server *)
let* () =
guard (String.length con = 0)
(`Fatal (`Handshake (`Message "certificate context must be empty")))
in
answer_certificate hs sd es ss None cs buf log
| AwaitServerCertificate13 (sd, es, ss, sigalgs, log), Certificate cs ->
let* con, cs = map_reader_error (parse_certificates_1_3 cs) in
(* during handshake, context must be empty! and we'll not get any new certificate from server *)
let* () =
guard (String.length con = 0)
(`Fatal (`Handshake (`Message "certificate context must be empty")))
in
answer_certificate hs sd es ss sigalgs cs buf log
| AwaitServerCertificateVerify13 (sd, es, ss, sigalgs, log), CertificateVerify cv ->
answer_certificate_verify hs sd es ss sigalgs cv buf log
| AwaitServerFinished13 (sd, es, ss, sigalgs, log), Finished fin ->
answer_finished hs sd es ss sigalgs fin buf log
| Established13, SessionTicket se -> answer_session_ticket hs se
| Established13, CertificateRequest _ ->
Error (`Fatal (`Unexpected (`Handshake handshake))) (* TODO send out C, CV, F *)
| Established13, KeyUpdate req -> handle_key_update hs req
| _, hs -> Error (`Fatal (`Unexpected (`Handshake hs)))

550
unikernel/duniverse/ocaml-tls/lib/handshake_common.ml Normal file
View file

@ -0,0 +1,550 @@
open Core
open State
let src = Logs.Src.create "handshake" ~doc:"TLS handshake"
module Log = (val Logs.src_log src : Logs.LOG)
let trace_cipher cipher =
Tracing.debug (fun m -> m "%a" Ciphersuite.pp_ciphersuite cipher)
let empty = function [] -> true | _ -> false
let change_cipher_spec =
(Packet.CHANGE_CIPHER_SPEC, Writer.assemble_change_cipher_spec)
let hostname (h : client_hello) : [ `host ] Domain_name.t option =
Utils.map_find ~f:(function `Hostname s -> Some s | _ -> None) h.extensions
let groups (h : client_hello) =
match Utils.map_find ~f:(function `SupportedGroups g -> Some g | _ -> None) h.extensions with
| Some xs ->
List.fold_left (fun acc g ->
match named_group_to_group g with Some g -> g :: acc | _ -> acc)
[] xs
| None -> []
let rec find_matching host certs =
match certs with
| (s::_, _) as chain ::xs ->
if X509.Certificate.supports_hostname s host then
Some chain
else
find_matching host xs
| _::xs -> find_matching host xs (* this should never happen! *)
| [] -> None
let agreed_cert certs ?f ?signature_algorithms hostname =
let match_host ?default host certs =
match find_matching host certs with
| Some x -> Ok x
| None ->
Option.to_result
~none:(`Error (`NoMatchingCertificateFound (Domain_name.to_string host)))
default
in
let filter = function
| ([], _) -> false (* cannot happen, TODO: adapt types to avoid this case *)
| (s :: _, _) ->
match f with
| None -> true
| Some f -> f s
in
let filter_sigalg c =
match signature_algorithms with
| None -> true
| Some s -> List.exists (pk_matches_sa (snd c)) s
in
match certs, hostname with
| `None, _ -> Error (`Error `CouldntSelectCertificate)
| `Single c, _ ->
if filter c && filter_sigalg c then Ok c else Error (`Error `CouldntSelectCertificate)
| `Multiple_default (c, _), None ->
if filter c && filter_sigalg c then Ok c else Error (`Error `CouldntSelectCertificate)
| `Multiple_default (c, cs), Some h ->
let default = if filter c && filter_sigalg c then Some c else None in
begin match default, List.filter (fun c -> filter c && filter_sigalg c) cs with
| Some d, cs -> match_host ~default:d h cs
| None, c :: cs -> match_host ~default:c h (c::cs)
| None, [] -> Error (`Error `CouldntSelectCertificate)
end
| `Multiple cs, None ->
begin match List.filter (fun c -> filter c && filter_sigalg c) cs with
| cert :: _ -> Ok cert
| _ -> Error (`Error `CouldntSelectCertificate)
end
| `Multiple cs, Some h ->
match List.filter (fun c -> filter c && filter_sigalg c) cs with
| [ cert ] -> Ok cert
| c :: cs -> match_host ~default:c h (c :: cs)
| [] -> Error (`Error `CouldntSelectCertificate)
let get_secure_renegotiation exts =
Utils.map_find
exts
~f:(function `SecureRenegotiation data -> Some data | _ -> None)
let get_alpn_protocols (ch : client_hello) =
Utils.map_find ~f:(function `ALPN protocols -> Some protocols | _ -> None) ch.extensions
let alpn_protocol config ch =
match config.Config.alpn_protocols, get_alpn_protocols ch with
| _, None | [], _ -> Ok None
| configured, Some client -> match Utils.first_match client configured with
| Some proto -> Ok (Some proto)
| None ->
(* RFC7301 Section 3.2:
In the event that the server supports no protocols that the client
advertises, then the server SHALL respond with a fatal
"no_application_protocol" alert. *)
Error (`Fatal `No_application_protocol)
let get_alpn_protocol (sh : server_hello) =
Utils.map_find ~f:(function `ALPN protocol -> Some protocol | _ -> None) sh.extensions
let empty_common_session_data = {
server_random = "" ;
client_random = "" ;
peer_certificate_chain = [] ;
peer_certificate = None ;
trust_anchor = None ;
received_certificates = [] ;
own_certificate = [] ;
own_private_key = None ;
own_name = None ;
client_auth = false ;
master_secret = "" ;
alpn_protocol = None ;
}
let empty_session = {
common_session_data = empty_common_session_data ;
client_version = `TLS_1_2 ;
ciphersuite = `DHE_RSA_WITH_AES_256_CBC_SHA ;
group = Some `FFDHE2048 ;
renegotiation = "", "" ;
session_id = "" ;
extended_ms = false ;
tls_unique = "" ;
}
let empty_session13 cipher = {
common_session_data13 = empty_common_session_data ;
ciphersuite13 = cipher ;
master_secret = Handshake_crypto13.empty cipher ;
exporter_master_secret = "" ;
resumption_secret = "" ;
state = `Established ;
resumed = false ;
client_app_secret = "" ;
server_app_secret = "" ;
}
let common_session_data_of_epoch (epoch : epoch_data) common_session_data =
{
common_session_data with
peer_certificate = epoch.peer_certificate ;
trust_anchor = epoch.trust_anchor ;
own_certificate = epoch.own_certificate ;
own_private_key = epoch.own_private_key ;
received_certificates = epoch.received_certificates ;
peer_certificate_chain = epoch.peer_certificate_chain ;
master_secret = epoch.master_secret ;
own_name = epoch.own_name ;
alpn_protocol = epoch.alpn_protocol ;
}
let session_of_epoch (epoch : epoch_data) : session_data =
let empty = empty_session in
let common_session_data = common_session_data_of_epoch epoch empty.common_session_data in
{ empty with
common_session_data ;
ciphersuite = epoch.ciphersuite ;
session_id = epoch.session_id ;
extended_ms = epoch.extended_ms ;
}
let session13_of_epoch cipher (epoch : epoch_data) : session_data13 =
let empty = empty_session13 cipher in
let common_session_data13 = common_session_data_of_epoch epoch empty.common_session_data13 in
{ empty with
common_session_data13 ;
ciphersuite13 = cipher ;
state = epoch.state ;
exporter_master_secret = epoch.exporter_master_secret ;
}
let supported_protocol_version (min, max) v =
if compare_tls_version min v > 0 then
None
else if compare_tls_version v max > 0 then
None
else
Some v
let to_client_ext_type = function
| `Hostname _ -> `Hostname
| `MaxFragmentLength _ -> `MaxFragmentLength
| `SupportedGroups _ -> `SupportedGroups
| `ECPointFormats -> `ECPointFormats
| `SecureRenegotiation _ -> `SecureRenegotiation
| `Padding _ -> `Padding
| `SignatureAlgorithms _ -> `SignatureAlgorithms
| `UnknownExtension _ -> `UnknownExtension
| `ExtendedMasterSecret -> `ExtendedMasterSecret
| `ALPN _ -> `ALPN
| `KeyShare _ -> `KeyShare
| `EarlyDataIndication -> `EarlyDataIndication
| `PreSharedKeys _ -> `PreSharedKey
| `Draft _ -> `Draft
| `SupportedVersions _ -> `SupportedVersion
| `PostHandshakeAuthentication -> `PostHandshakeAuthentication
| `Cookie _ -> `Cookie
| `PskKeyExchangeModes _ -> `PskKeyExchangeMode
let to_server_ext_type = function
| `Hostname -> `Hostname
| `MaxFragmentLength _ -> `MaxFragmentLength
| `ECPointFormats -> `ECPointFormats
| `SecureRenegotiation _ -> `SecureRenegotiation
| `UnknownExtension _ -> `UnknownExtension
| `ExtendedMasterSecret -> `ExtendedMasterSecret
| `ALPN _ -> `ALPN
| `KeyShare _ -> `KeyShare
| `EarlyDataIndication -> `EarlyDataIndication
| `PreSharedKey _ -> `PreSharedKey
| `Draft _ -> `Draft
| `SelectedVersion _ -> `SupportedVersion
let extension_types t exts = List.(
exts |> map t
|> filter @@ function `UnknownExtension -> false | _ -> true
)
(* a server hello may only contain extensions which are also in the client hello *)
(* RFC5246, 7.4.7.1
An extension type MUST NOT appear in the ServerHello unless the same
extension type appeared in the corresponding ClientHello. If a
client receives an extension type in ServerHello that it did not
request in the associated ClientHello, it MUST abort the handshake
with an unsupported_extension fatal alert. *)
let server_exts_subset_of_client sexts cexts =
let (sexts', cexts') =
(extension_types to_server_ext_type sexts, extension_types to_client_ext_type cexts) in
Utils.List_set.subset sexts' (`Cookie :: cexts')
module Group = struct
type t = Packet.named_group
let compare = Stdlib.compare
end
module GroupSet = Set.Make(Group)
(* Set.of_list appeared only in 4.02, for 4.01 compatibility *)
let of_list xs = List.fold_right GroupSet.add xs GroupSet.empty
let client_hello_valid version (ch : client_hello) =
(* match ch.version with
| TLS_1_0 ->
if List.mem TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA ch.ciphersuites then
return ()
else
fail HANDSHAKE_FAILURE
| TLS_1_1 ->
if List.mem TLS_RSA_WITH_3DES_EDE_CBC_SHA ch.ciphersuites then
return ()
else
fail HANDSHAKE_FAILURE
| TLS_1_2 ->
if List.mem TLS_RSA_WITH_AES_128_CBC_SHA ch.ciphersuites then
return ()
else
fail HANDSHAKE_FAILURE *)
let sig_alg =
Utils.map_find
~f:(function `SignatureAlgorithms sa -> Some sa | _ -> None)
ch.extensions
and key_share =
Utils.map_find
~f:(function `KeyShare ks -> Some ks | _ -> None)
ch.extensions
and groups =
Utils.map_find
~f:(function `SupportedGroups gs -> Some gs | _ -> None)
ch.extensions
in
let version_good = match version with
| `TLS_1_2 | `TLS_1_X _ -> Ok ()
| `TLS_1_3 ->
( let good_sig_alg =
List.exists (fun sa -> List.mem sa Config.supported_signature_algorithms)
in
match sig_alg with
| None -> Error (`Fatal (`Missing_extension "signature algorithms"))
| Some sig_alg when good_sig_alg sig_alg ->
( match key_share, groups with
| None, _ -> Error (`Fatal (`Missing_extension "key share"))
| _, None -> Error (`Fatal (`Missing_extension "supported group"))
| Some ks, Some gs ->
match
Utils.List_set.is_proper_set gs,
Utils.List_set.is_proper_set (List.map fst ks),
GroupSet.subset (of_list (List.map fst ks)) (of_list gs)
with
| true, true, true -> Ok ()
| false, _, _ -> Error (`Fatal (`Handshake (`Message "supported group is not a set")))
| _, false, _ -> Error (`Fatal (`Handshake (`Message "key share is not a set")))
| _, _, false -> Error (`Fatal (`Handshake (`Message "key share is not a subset of supported group")) ))
| Some _ -> Error (`Fatal (`Handshake (`Message "no good signature algorithms")))
)
| `SSL_3 | `TLS_1_0 | `TLS_1_1 -> Ok ()
in
let share_ciphers =
match
Utils.first_match (List.filter_map Ciphersuite.any_ciphersuite_to_ciphersuite ch.ciphersuites) Config.Ciphers.supported
with
| None -> false
| Some _ -> true
in
match
not (empty ch.ciphersuites),
share_ciphers,
Utils.List_set.is_proper_set (extension_types to_client_ext_type ch.extensions)
with
| true, true, true -> version_good
| false, _, _ -> Error (`Fatal (`Handshake (`Message "ciphersuites is empty")))
| _, false, _ -> Error (`Fatal (`Handshake (`Message "no supported ciphersuite")))
| _, _, false -> Error (`Fatal (`Handshake (`Message "extensions is not a set")))
let server_hello_valid (sh : server_hello) =
(* let open Ciphersuite in *)
Utils.List_set.is_proper_set (extension_types to_server_ext_type sh.extensions)
(* TODO:
- EC stuff must be present if EC ciphersuite chosen
*)
let to_sign_1_3 context_string =
(* input is prepended by 64 * 0x20 (to avoid cross-version attacks) *)
(* input for signature now contains also a context string *)
let len = match context_string with
| None -> 64 + 1
| Some v -> 64 + String.length v + 1 in
let buf = Bytes.create len in
Bytes.fill buf 0 64 '\x20';
begin match context_string with
| None -> ()
| Some v -> Bytes.blit_string v 0 buf 64 (String.length v) end;
Bytes.set buf (Bytes.length buf - 1) '\x00';
Bytes.unsafe_to_string buf
let signature version ?context_string data client_sig_algs signature_algorithms (private_key : X509.Private_key.t) =
match version with
| `TLS_1_0 | `TLS_1_1 ->
let* signed =
match private_key with
| `RSA key ->
begin try
let data =
Digestif.(MD5.(to_raw_string (digest_string data)) ^
SHA1.(to_raw_string (digest_string data)))
in
Ok (Mirage_crypto_pk.Rsa.PKCS1.sig_encode ~key data)
with Mirage_crypto_pk.Rsa.Insufficient_key ->
Error (`Fatal (`Bad_certificate "RSA key too small"))
end
| k ->
(* not passing ~scheme: only non-RSA keys sig scheme is trivial *)
Result.map_error
(function `Msg m -> `Fatal (`Handshake (`Message ("signing failed: " ^ m))))
(X509.Private_key.sign `SHA1 k (`Message data))
in
Ok (Writer.assemble_digitally_signed signed)
| `TLS_1_2 ->
let* sig_alg =
match client_sig_algs with
| None ->
Ok (match private_key with
| `RSA _ -> `RSA_PKCS1_SHA1
| `ED25519 _ -> `ED25519
| _ -> `ECDSA_SECP256R1_SHA1)
| Some client_algos ->
Option.to_result
~none:(`Error (`NoConfiguredSignatureAlgorithm client_algos))
(Utils.first_match client_algos (List.filter (pk_matches_sa private_key) signature_algorithms))
in
let scheme = signature_scheme_of_signature_algorithm sig_alg
and hash = hash_of_signature_algorithm sig_alg
in
let* signature =
Result.map_error (function `Msg m -> `Fatal (`Handshake (`Message ("signing failed: " ^ m))))
(X509.Private_key.sign hash ~scheme private_key (`Message data))
in
Ok (Writer.assemble_digitally_signed_1_2 sig_alg signature)
| `TLS_1_3 ->
let to_sign =
let prefix = to_sign_1_3 context_string in
prefix ^ data
in
let* sig_alg =
let* client_algos =
(* 8446 4.2.3 "client MUST send signatureAlgorithms" *)
Option.to_result
~none:(`Error (`NoConfiguredSignatureAlgorithm []))
client_sig_algs
in
let sa = List.filter tls13_sigalg signature_algorithms in
let sa = List.filter (pk_matches_sa private_key) sa in
Option.to_result
~none:(`Error (`NoConfiguredSignatureAlgorithm client_algos))
(Utils.first_match client_algos sa)
in
let scheme = signature_scheme_of_signature_algorithm sig_alg
and hash = hash_of_signature_algorithm sig_alg
in
let* signature =
Result.map_error (function `Msg m -> `Fatal (`Handshake (`Message ("signing failed: " ^ m))))
(X509.Private_key.sign hash ~scheme private_key (`Message to_sign))
in
Ok (Writer.assemble_digitally_signed_1_2 sig_alg signature)
let peer_key = function
| None -> Error (`Fatal (`Bad_certificate "none received"))
| Some cert -> Ok (X509.Certificate.public_key cert)
let verify_digitally_signed version ?context_string sig_algs data signature_data certificate =
let* pubkey = peer_key certificate in
match version with
| `TLS_1_0 | `TLS_1_1 ->
let* signature = map_reader_error (Reader.parse_digitally_signed data) in
begin match pubkey with
| `RSA key ->
let* raw =
Option.to_result
~none:(`Fatal (`Handshake (`Message "couldn't decode PKCS1")))
(Mirage_crypto_pk.Rsa.PKCS1.sig_decode ~key signature)
in
let computed =
Digestif.(MD5.(to_raw_string (digest_string signature_data)) ^
SHA1.(to_raw_string (digest_string signature_data)))
in
guard (String.equal raw computed)
(`Fatal (`Handshake (`Message "RSA PKCS1 raw <> computed")))
| key ->
Result.map_error
(function `Msg m -> `Fatal (`Handshake (`Message ("signature verification failed: " ^ m))))
(X509.Public_key.verify `SHA1 ~signature key (`Message signature_data))
end
| `TLS_1_2 ->
let* sig_alg, signature =
map_reader_error (Reader.parse_digitally_signed_1_2 data)
in
let* () =
guard (List.mem sig_alg sig_algs)
(`Error (`NoConfiguredSignatureAlgorithm sig_algs))
in
let hash = hash_of_signature_algorithm sig_alg
and scheme = signature_scheme_of_signature_algorithm sig_alg
in
Result.map_error
(function `Msg m -> `Fatal (`Handshake (`Message ("signature verification failed: " ^ m))))
(X509.Public_key.verify hash ~scheme ~signature pubkey (`Message signature_data))
| `TLS_1_3 ->
let* sig_alg, signature =
map_reader_error (Reader.parse_digitally_signed_1_2 data)
in
let* () =
guard (List.mem sig_alg sig_algs)
(`Error (`NoConfiguredSignatureAlgorithm sig_algs))
in
let hash = hash_of_signature_algorithm sig_alg
and scheme = signature_scheme_of_signature_algorithm sig_alg
and data =
let prefix = to_sign_1_3 context_string in
prefix ^ signature_data
in
Result.map_error
(function `Msg m -> `Fatal (`Handshake (`Message ("signature verification failed: " ^ m))))
(X509.Public_key.verify hash ~scheme ~signature pubkey (`Message data))
let validate_chain authenticator certificates ip hostname =
let authenticate authenticator host certificates =
Result.map_error
(fun err -> `Error (`AuthenticationFailure err))
(authenticator ?ip ~host certificates)
and key_size min cs =
let check c =
match X509.Certificate.public_key c with
| `RSA key -> Mirage_crypto_pk.Rsa.pub_bits key >= min
| _ -> true
in
guard (List.for_all check cs) (`Fatal (`Bad_certificate "key too small"))
and parse_certificates certs =
let certificates =
let f cs =
match X509.Certificate.decode_der cs with
| Ok c -> Some c
| Error `Msg msg ->
Log.warn (fun m -> m "cannot decode certificate %s:@.%a" msg
(Ohex.pp_hexdump ()) cs);
None
in
List.filter_map f certs
in
let* () =
guard (List.length certs = List.length certificates)
(`Fatal (`Bad_certificate "couldn't decode some certificates"))
in
Ok certificates
in
(* RFC5246: must be x509v3, take signaturealgorithms into account! *)
(* RFC2246/4346: is generally x509v3, signing algorithm for certificate _must_ be same as algorithm for certificate key *)
let* certs = parse_certificates certificates in
let server = match certs with
| s::_ -> Some s
| [] -> None
in
match authenticator with
| None -> Ok (server, certs, [], None)
| Some authenticator ->
let* anchor = authenticate authenticator hostname certs in
let* () = key_size Config.min_rsa_key_size certs in
Ok (Option.fold ~none:(server, certs, [], None)
~some:(fun (chain, anchor) -> (server, certs, chain, Some anchor))
anchor)
let output_key_update ~request state =
let hs = state.handshake in
match hs.session with
| `TLS13 session :: _ ->
let* session', encryptor =
match hs.machina with
| Client13 Established13 ->
let client_app_secret, client_ctx =
Handshake_crypto13.app_secret_n_1
session.master_secret session.client_app_secret
in
Ok ({ session with client_app_secret }, client_ctx)
| Server13 Established13 ->
let server_app_secret, server_ctx =
Handshake_crypto13.app_secret_n_1
session.master_secret session.server_app_secret
in
Ok ({ session with server_app_secret }, server_ctx)
| _ -> Error (`Fatal (`Handshake (`Message "invalid state for key update")))
in
let handshake = { hs with session = `TLS13 session' :: hs.session } in
let ku =
let p =
Packet.(if request then UPDATE_REQUESTED else UPDATE_NOT_REQUESTED)
in
KeyUpdate p
in
let out = Writer.assemble_handshake ku in
Ok ({ state with encryptor = Some encryptor ; handshake },
(Packet.HANDSHAKE, out))
| _ -> Error (`Fatal (`Handshake (`Message "no earlier session found")))

111
unikernel/duniverse/ocaml-tls/lib/handshake_crypto.ml Normal file
View file

@ -0,0 +1,111 @@
open State
let halve secret =
let size = String.length secret in
let half = size - size / 2 in
String.(sub secret 0 half, sub secret (size - half) half)
let p_hash (hmac, hmac_n) key seed len =
let rec expand a to_go =
let res = hmac ~key (a ^ seed) in
if to_go > hmac_n then
res ^ expand (hmac ~key a) (to_go - hmac_n)
else String.sub res 0 to_go
in
expand (hmac ~key seed) len
let prf_mac = function
| `RSA_WITH_AES_256_GCM_SHA384
| `DHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_AES_256_CBC_SHA384
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384
| `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 -> (module Digestif.SHA384 : Digestif.S)
| _ -> (module Digestif.SHA256 : Digestif.S)
let pseudo_random_function version cipher len secret label seed =
let labelled = label ^ seed in
match version with
| `TLS_1_1 | `TLS_1_0 ->
let (s1, s2) = halve secret in
let md5 = p_hash ((fun ~key s -> Digestif.MD5.(to_raw_string (hmac_string ~key s))), Digestif.MD5.digest_size) s1 labelled len
and sha = p_hash ((fun ~key s -> Digestif.SHA1.(to_raw_string (hmac_string ~key s))), Digestif.SHA1.digest_size) s2 labelled len in
Mirage_crypto.Uncommon.xor md5 sha
| `TLS_1_2 ->
let module D = (val (prf_mac cipher)) in
p_hash ((fun ~key s -> D.(to_raw_string (hmac_string ~key s))), D.digest_size) secret labelled len
let key_block version cipher len master_secret seed =
pseudo_random_function version cipher len master_secret "key expansion" seed
let hash version cipher data =
match version with
| `TLS_1_0 | `TLS_1_1 -> Digestif.(MD5.(to_raw_string (digest_string data)) ^ SHA1.(to_raw_string (digest_string data)))
| `TLS_1_2 ->
let module H = (val prf_mac cipher) in
H.(to_raw_string (digest_string data))
let finished version cipher master_secret label ps =
let data = String.concat "" ps in
let seed = hash version cipher data in
pseudo_random_function version cipher 12 master_secret label seed
let divide_keyblock key mac iv buf =
let c_mac, rt0 = Core.split_str buf mac in
let s_mac, rt1 = Core.split_str rt0 mac in
let c_key, rt2 = Core.split_str rt1 key in
let s_key, rt3 = Core.split_str rt2 key in
let c_iv , s_iv = Core.split_str rt3 iv
in
(c_mac, s_mac, c_key, s_key, c_iv, s_iv)
let derive_master_secret version (session : session_data) premaster log =
let prf = pseudo_random_function version session.ciphersuite 48 premaster in
if session.extended_ms then
let session_hash =
let data = String.concat "" log in
hash version session.ciphersuite data
in
prf "extended master secret" session_hash
else
prf "master secret" (session.common_session_data.client_random ^ session.common_session_data.server_random)
let initialise_crypto_ctx version (session : session_data) =
let open Ciphersuite in
let client_random = session.common_session_data.client_random
and server_random = session.common_session_data.server_random
and master = session.common_session_data.master_secret
and cipher = session.ciphersuite
in
let pp = ciphersuite_privprot cipher in
let c_mac, s_mac, c_key, s_key, c_iv, s_iv =
let iv_l = match version with
| `TLS_1_0 -> Some ()
| _ -> None
in
let key_len, iv_len, mac_len = Ciphersuite.key_length iv_l pp in
let kblen = 2 * key_len + 2 * mac_len + 2 * iv_len
and rand = server_random ^ client_random
in
let keyblock = key_block version cipher kblen master rand in
divide_keyblock key_len mac_len iv_len keyblock
in
let context cipher_k iv mac_k =
let open Crypto.Ciphers in
let cipher_st =
let iv_mode = match version with
| `TLS_1_0 -> Iv iv
| _ -> Random_iv
in
get_cipher ~secret:cipher_k ~hmac_secret:mac_k ~iv_mode ~nonce:iv pp
and sequence = 0L in
{ cipher_st ; sequence }
in
let c_context = context c_key c_iv c_mac
and s_context = context s_key s_iv s_mac in
(c_context, s_context)

9
unikernel/duniverse/ocaml-tls/lib/handshake_crypto.mli Normal file
View file

@ -0,0 +1,9 @@
open State
val derive_master_secret : Core.tls_before_13 -> session_data -> string -> string list -> Core.master_secret
val initialise_crypto_ctx : Core.tls_before_13 -> session_data -> (crypto_context * crypto_context)
val finished : Core.tls_before_13 -> Ciphersuite.ciphersuite -> string -> string -> string list -> string
(** [pseudo_random_function version cipher length secret label seed] *)
val pseudo_random_function : Core.tls_before_13 -> Ciphersuite.ciphersuite ->
int -> string -> string -> string -> string

183
unikernel/duniverse/ocaml-tls/lib/handshake_crypto13.ml Normal file
View file

@ -0,0 +1,183 @@
open Core
let cdiv (x : int) (y : int) =
if x > 0 && y > 0 then (x + y - 1) / y
else if x < 0 && y < 0 then (x + y + 1) / y
else x / y
let left_pad_dh group msg =
let bytes = cdiv (Mirage_crypto_pk.Dh.modulus_size group) 8 in
let padding = String.make (bytes - String.length msg) '\x00' in
padding ^ msg
let not_all_zero r =
let* str = r in
try
for i = 0 to String.length str - 1 do
if String.unsafe_get str i != '\x00' then raise_notrace Not_found;
done;
Error (`Fatal (`Handshake (`BadDH "all zero")))
with Not_found -> Ok str
let dh_shared secret share =
(* RFC 8556, Section 7.4.1 - we need zero-padding on the left *)
let map_ecdh_error =
Result.map_error (fun e -> `Fatal (`Handshake (`BadECDH e)))
in
let open Mirage_crypto_ec in
not_all_zero
(match secret with
| `Finite_field secret ->
let group = secret.Mirage_crypto_pk.Dh.group in
let bits = Mirage_crypto_pk.Dh.modulus_size group in
let* () =
(* truncated share, better reject this *)
guard (String.length share = cdiv bits 8)
(`Fatal (`Handshake (`BadDH "truncated")))
in
let* shared =
Option.to_result
~none:(`Fatal (`Handshake (`BadDH "invalid FF")))
(Mirage_crypto_pk.Dh.shared secret share)
in
Ok (left_pad_dh group shared)
| `P256 priv -> map_ecdh_error (P256.Dh.key_exchange priv share)
| `P384 priv -> map_ecdh_error (P384.Dh.key_exchange priv share)
| `P521 priv -> map_ecdh_error (P521.Dh.key_exchange priv share)
| `X25519 priv -> map_ecdh_error (X25519.key_exchange priv share))
let dh_gen_key group =
(* RFC 8556, Section 4.2.8.1 - we need zero-padding on the left *)
match Core.group_to_impl group with
| `Finite_field mc_group ->
let sec, shared = Mirage_crypto_pk.Dh.gen_key mc_group in
`Finite_field sec, left_pad_dh mc_group shared
| `P256 ->
let secret, shared = Mirage_crypto_ec.P256.Dh.gen_key () in
`P256 secret, shared
| `P384 ->
let secret, shared = Mirage_crypto_ec.P384.Dh.gen_key () in
`P384 secret, shared
| `P521 ->
let secret, shared = Mirage_crypto_ec.P521.Dh.gen_key () in
`P521 secret, shared
| `X25519 ->
let secret, shared = Mirage_crypto_ec.X25519.gen_key () in
`X25519 secret, shared
let trace tag cs = Tracing.cs ~tag:("crypto " ^ tag) cs
let pp_hash_k_n ciphersuite =
let open Ciphersuite in
let pp = privprot13 ciphersuite
and hash = hash13 ciphersuite
in
let k, n = kn_13 pp in
(pp, hash, k, n)
let hkdflabel label context length =
let lbl = "tls13 " ^ label in
let len_llen = Bytes.create 3 in
Bytes.set_uint16_be len_llen 0 length;
Bytes.set_uint8 len_llen 2 (String.length lbl);
let clen = String.make 1 (Char.unsafe_chr (String.length context)) in
let lbl = String.concat ""
[ Bytes.unsafe_to_string len_llen ;
lbl ;
clen ;
context ]
in
trace "hkdflabel" lbl ;
lbl
let derive_secret_no_hash hash prk ?length ?(ctx = "") label =
let length = match length with
| None ->
let module H = (val Digestif.module_of_hash' hash) in
H.digest_size
| Some x -> x
in
let info = hkdflabel label ctx length in
trace "prk" prk ;
let key = Hkdf.expand ~hash ~prk ~info length in
trace ("derive_secret: " ^ label) key ;
key
let derive_secret t label log =
let module H = (val Digestif.module_of_hash' t.State.hash) in
let ctx = H.(to_raw_string (digest_string log)) in
trace "derive secret ctx" ctx ;
derive_secret_no_hash t.State.hash t.State.secret ~ctx label
let empty cipher = {
State.secret = "" ;
cipher ;
hash = Ciphersuite.hash13 cipher
}
let derive t secret_ikm =
let salt =
if String.equal t.State.secret "" then
""
else
derive_secret t "derived" ""
in
trace "derive: secret_ikm" secret_ikm ;
trace "derive: salt" salt ;
let secret = Hkdf.extract ~hash:t.State.hash ~salt secret_ikm in
trace "derive (extracted secret)" secret ;
{ t with State.secret }
let traffic_key cipher prk =
let _, hash, key_len, iv_len = pp_hash_k_n cipher in
let key_info = hkdflabel "key" "" key_len in
let key = Hkdf.expand ~hash ~prk ~info:key_info key_len in
let iv_info = hkdflabel "iv" "" iv_len in
let iv = Hkdf.expand ~hash ~prk ~info:iv_info iv_len in
(key, iv)
let ctx t label secret =
let secret, nonce = traffic_key t.State.cipher secret in
trace (label ^ " secret") secret ;
trace (label ^ " nonce") nonce ;
let pp = Ciphersuite.privprot13 t.State.cipher in
{ State.sequence = 0L ; cipher_st = Crypto.Ciphers.get_aead_cipher ~secret ~nonce pp }
let early_traffic t log =
let secret = derive_secret t "c e traffic" log in
(secret, ctx t "client early traffic" secret)
let hs_ctx t log =
Tracing.cs ~tag:"hs ctx with sec" t.State.secret ;
Tracing.cs ~tag:"log is" log ;
let server_handshake_traffic_secret = derive_secret t "s hs traffic" log
and client_handshake_traffic_secret = derive_secret t "c hs traffic" log
in
(server_handshake_traffic_secret,
ctx t "server handshake traffic" server_handshake_traffic_secret,
client_handshake_traffic_secret,
ctx t "client handshake traffic" client_handshake_traffic_secret)
let app_ctx t log =
let server_application_traffic_secret = derive_secret t "s ap traffic" log
and client_application_traffic_secret = derive_secret t "c ap traffic" log
in
(server_application_traffic_secret,
ctx t "server application traffic" server_application_traffic_secret,
client_application_traffic_secret,
ctx t "client application traffic" client_application_traffic_secret)
let app_secret_n_1 t app_secret =
let secret = derive_secret_no_hash t.State.hash app_secret "traffic upd" in
secret, ctx t "traffic update" secret
let exporter t log = derive_secret t "exp master" log
let resumption t log = derive_secret t "res master" log
let res_secret hash secret nonce =
derive_secret_no_hash hash secret ~ctx:nonce "resumption"
let finished hash secret data =
let module H = (val Digestif.module_of_hash' hash) in
let key = derive_secret_no_hash hash secret "finished" in
H.(to_raw_string (hmac_string ~key (to_raw_string (digest_string data))))

662
unikernel/duniverse/ocaml-tls/lib/handshake_server.ml Normal file
View file

@ -0,0 +1,662 @@
open Core
open State
open Handshake_common
open Config
let state_version state = match state.protocol_version with
| #tls_before_13 as v -> v
| _ -> assert false
let hello_request state =
if state.config.use_reneg then
let hr = HelloRequest in
Tracing.hs ~tag:"handshake-out" hr ;
let state = { state with machina = Server AwaitClientHelloRenegotiate } in
Ok (state, [`Record (Packet.HANDSHAKE, Writer.assemble_handshake hr)])
else
Error (`Fatal (`Handshake (`Message "renegotation is not supported")))
let answer_client_finished state (session : session_data) client_fin raw log =
let client, server =
let checksum = Handshake_crypto.finished (state_version state)
session.ciphersuite session.common_session_data.master_secret
in
(checksum "client finished" log, checksum "server finished" (log @ [raw]))
in
let* () =
guard (String.equal client client_fin)
(`Fatal (`Handshake (`Message "couldn't verify finished")))
in
let session = { session with tls_unique = client } in
let fin = Finished server in
let fin_raw = Writer.assemble_handshake fin in
(* we really do not want to have any leftover handshake fragments *)
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let session = { session with renegotiation = (client, server) }
and machina = Server Established
in
Tracing.hs ~tag:"handshake-out" fin ;
Ok ({ state with machina ; session = `TLS session :: state.session },
[`Record (Packet.HANDSHAKE, fin_raw)])
let answer_client_finished_resume state (session : session_data) server_verify client_fin _raw log =
let client_verify =
Handshake_crypto.finished (state_version state) session.ciphersuite session.common_session_data.master_secret "client finished" log
in
let* () =
guard (String.equal client_verify client_fin)
(`Fatal (`Handshake (`Message "couldn't verify finished")))
in
(* we really do not want to have any leftover handshake fragments *)
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let session = { session with renegotiation = (client_verify, server_verify) }
and machina = Server Established
in
Ok ({ state with machina ; session = `TLS session :: state.session }, [])
let establish_master_secret state (session : session_data) premastersecret raw log =
let log = log @ [raw] in
let master_secret = Handshake_crypto.derive_master_secret
(state_version state) session premastersecret log
in
let session =
let common_session_data = { session.common_session_data with master_secret } in
{ session with common_session_data }
in
let client_ctx, server_ctx =
Handshake_crypto.initialise_crypto_ctx (state_version state) session
in
let machina =
match session.common_session_data.peer_certificate with
| None -> AwaitClientChangeCipherSpec (session, server_ctx, client_ctx, log)
| Some _ -> AwaitClientCertificateVerify (session, server_ctx, client_ctx, log)
in
Tracing.cs ~tag:"master-secret" master_secret ;
({ state with machina = Server machina }, [])
let private_key (session : session_data) =
match session.common_session_data.own_private_key with
| Some priv -> Ok priv
| None -> Error (`Fatal (`Handshake (`Message "couldn't locate private key")))
let validate_certs certs authenticator ip (session : session_data) =
let* peer_certificate, received_certificates, peer_certificate_chain, trust_anchor =
validate_chain authenticator certs ip None
in
let common_session_data = {
session.common_session_data with
received_certificates ;
peer_certificate ;
peer_certificate_chain ;
trust_anchor
} in
Ok { session with common_session_data }
let answer_client_certificate_RSA state (session : session_data) certs raw log =
let* session =
validate_certs certs state.config.authenticator state.config.ip session
in
let machina = AwaitClientKeyExchange_RSA (session, log @ [raw]) in
Ok ({ state with machina = Server machina }, [])
let answer_client_certificate_DHE state (session : session_data) dh_sent certs raw log =
let* session =
validate_certs certs state.config.authenticator state.config.ip session
in
let machina = AwaitClientKeyExchange_DHE (session, dh_sent, log @ [raw]) in
Ok ({ state with machina = Server machina }, [])
let answer_client_certificate_verify state (session : session_data) sctx cctx verify raw log =
let sigdata = String.concat "" log in
let* () =
verify_digitally_signed state.protocol_version
state.config.signature_algorithms verify sigdata
session.common_session_data.peer_certificate
in
let machina = AwaitClientChangeCipherSpec (session, sctx, cctx, log @ [raw]) in
Ok ({ state with machina = Server machina }, [])
let answer_client_key_exchange_RSA state (session : session_data) kex raw log =
(* due to bleichenbacher attach, we should use a random pms *)
(* then we do not leak any decryption or padding errors! *)
let other = Writer.assemble_protocol_version state.protocol_version ^ Mirage_crypto_rng.generate 46 in
let validate_premastersecret k =
(* Client implementations MUST always send the correct version number in
PreMasterSecret. If ClientHello.client_version is TLS 1.1 or higher,
server implementations MUST check the version number as described in
the note below. If the version number is TLS 1.0 or earlier, server
implementations SHOULD check the version number, but MAY have a
configuration option to disable the check. Note that if the check
fails, the PreMasterSecret SHOULD be randomized as described below *)
(* we do not provide an option to disable the version checking (yet!) *)
match String.length k = 48, Reader.parse_any_version k with
| true, Ok c_ver when c_ver = session.client_version -> k
| _ -> other
in
let* k = private_key session in
match k with
| `RSA key ->
let pms = match Mirage_crypto_pk.Rsa.PKCS1.decrypt ~key kex with
| None -> validate_premastersecret other
| Some k -> validate_premastersecret k
in
Ok (establish_master_secret state session pms raw log)
| _ -> Error (`Fatal (`Bad_certificate "expected RSA certificate"))
let answer_client_key_exchange_DHE state session secret kex raw log =
let* pms =
let open Mirage_crypto_ec in
let map_ecdh_error =
Result.map_error (fun e -> `Fatal (`Handshake (`BadECDH e)))
in
match secret with
| `P256 priv ->
let* share = map_reader_error (Reader.parse_client_ec_key_exchange kex) in
map_ecdh_error (P256.Dh.key_exchange priv share)
| `P384 priv ->
let* share = map_reader_error (Reader.parse_client_ec_key_exchange kex) in
map_ecdh_error (P384.Dh.key_exchange priv share)
| `P521 priv ->
let* share = map_reader_error (Reader.parse_client_ec_key_exchange kex) in
map_ecdh_error (P521.Dh.key_exchange priv share)
| `X25519 priv ->
let* share = map_reader_error (Reader.parse_client_ec_key_exchange kex) in
map_ecdh_error (X25519.key_exchange priv share)
| `Finite_field secret ->
let* share = map_reader_error (Reader.parse_client_dh_key_exchange kex) in
Option.to_result
~none:(`Fatal (`Handshake (`BadDH "invalid FF")))
(Mirage_crypto_pk.Dh.shared secret share)
in
Ok (establish_master_secret state session pms raw log)
let sig_algs (client_hello : client_hello) =
Utils.map_find
~f:(function `SignatureAlgorithms xs -> Some xs | _ -> None)
client_hello.extensions
let ecc_group configured_groups requested_groups =
Utils.first_match requested_groups configured_groups
let agreed_cipher cert ecc requested =
let usage_matches cipher =
let csusage =
Ciphersuite.(required_usage @@ ciphersuite_kex cipher)
in
supports_key_usage ~not_present:true csusage cert
in
let cciphers = List.filter usage_matches requested in
if ecc then
cciphers
else
List.filter (fun x -> not (Ciphersuite.ecdhe x)) cciphers
let server_hello config (client_hello : client_hello) (session : session_data) version reneg =
(* RFC 4366: server shall reply with an empty hostname extension *)
let host = Option.fold ~none:[] ~some:(fun _ -> [`Hostname]) session.common_session_data.own_name
and server_random =
let suffix =
match version, max_protocol_version config.protocol_versions with
| `TLS_1_2, `TLS_1_3 -> Packet.downgrade12
| _, `TLS_1_3 -> Packet.downgrade11
| _ -> ""
in
let rst = Mirage_crypto_rng.generate (32 - String.length suffix) in
rst ^ suffix
and secren = match reneg with
| None -> `SecureRenegotiation ""
| Some (cvd, svd) -> `SecureRenegotiation (cvd ^ svd)
and ems = if session.extended_ms then
[`ExtendedMasterSecret]
else
[]
and session_id =
match String.length session.session_id with
| 0 -> Mirage_crypto_rng.generate 32
| _ -> session.session_id
and alpn =
match session.common_session_data.alpn_protocol with
| None -> []
| Some protocol -> [`ALPN protocol]
and ecpointformat =
match Utils.map_find ~f:(function `ECPointFormats -> Some () | _ -> None) client_hello.extensions with
| Some () when Ciphersuite.ecdhe session.ciphersuite -> [ `ECPointFormats ]
| _ -> []
in
let sh = ServerHello
{ server_version = version ;
server_random = server_random ;
sessionid = Some session_id ;
ciphersuite = session.ciphersuite ;
extensions = secren :: host @ ems @ alpn @ ecpointformat }
in
trace_cipher session.ciphersuite ;
Tracing.debug (fun m -> m "version %a" pp_tls_version version) ;
Tracing.hs ~tag:"handshake-out" sh ;
let common_session_data = { session.common_session_data with server_random } in
(Writer.assemble_handshake sh,
{ session with common_session_data ; session_id })
let answer_client_hello_common state reneg ch raw =
let process_client_hello ch config =
let host = hostname ch
and groups = groups ch
and cciphers = List.filter_map Ciphersuite.any_ciphersuite_to_ciphersuite ch.ciphersuites
in
let configured_ecc_groups, other_groups = List.partition Config.elliptic_curve config.groups in
let ecc_group = ecc_group configured_ecc_groups groups
and cciphers = List.filter (fun c -> not (Ciphersuite.ciphersuite_tls13 c)) cciphers
in
let cciphers = List.filter (fun c -> List.mem c config.ciphers) cciphers in
let f =
(* from the ciphers, figure out:
- (a) RSA only (b) EC only
- (c) static RSA only (keyUsage = KeyEncipherment) (d) DHE only (keyUsage = DigitalSignature)
- (e) from the groups (they indicate the key type!)
*)
let kt_filter =
match List.partition (fun c -> Ciphersuite.ciphersuite_keytype c = `RSA) cciphers with
| _::_, [] -> begin fun s -> match X509.Certificate.public_key s with `RSA _ -> true | _ -> false end
| [], _::_ -> begin fun s -> match X509.Certificate.public_key s with `ED25519 _ | `P256 _ | `P384 _ | `P521 _ -> true | _ -> false end
| _, _ -> begin fun _s -> true end
in
let ku_filter =
match List.partition (fun c -> Ciphersuite.ciphersuite_kex c = `RSA) cciphers with
| _::_, [] -> supports_key_usage ~not_present:true `Key_encipherment
| [], _::_ -> supports_key_usage ~not_present:true `Digital_signature
| _ -> begin fun _ -> true end
in
let kt_matches_group s =
match X509.Certificate.public_key s with
| `RSA _ -> true
| `ED25519 _ -> List.mem `X25519 groups
| `P256 _ -> List.mem `P256 groups
| `P384 _ -> List.mem `P384 groups
| `P521 _ -> List.mem `P521 groups
in
fun s ->
kt_filter s && ku_filter s && kt_matches_group s
in
let signature_algorithms = sig_algs ch in
let* cciphers, chain, priv =
let* r =
agreed_cert ~f ?signature_algorithms config.own_certificates host
in
match r with
| (c::cs, priv) ->
let cciphers = agreed_cipher c (ecc_group <> None) cciphers in
Ok (cciphers, c::cs, Some priv)
| ([], _) -> Error (`Fatal (`Handshake (`Message "couldn't find certificate chain")))
in
let* cipher =
match Utils.first_match cciphers config.ciphers with
| Some x -> Ok x
| None ->
let* _ =
Option.to_result
~none:(`Fatal (`Handshake (`Message "no supported ciphersuite")))
(Utils.first_match cciphers Config.Ciphers.supported)
in
Error (`Error (`NoConfiguredCiphersuite cciphers))
in
let extended_ms = List.mem `ExtendedMasterSecret ch.extensions in
Log.debug (fun m -> m "cipher %a" Ciphersuite.pp_ciphersuite cipher) ;
let* alpn_protocol = alpn_protocol config ch in
let group =
if Ciphersuite.ecdhe cipher then
ecc_group
else match other_groups with
| [] -> None
| c::_ -> Some c
in
let session =
let session = empty_session in
let common_session_data = {
session.common_session_data with
client_random = ch.client_random ;
own_certificate = chain ;
own_private_key = priv ;
own_name = host ;
alpn_protocol = alpn_protocol
} in
{ session with
common_session_data ;
client_version = ch.client_version ;
ciphersuite = cipher ;
group = group ;
extended_ms = extended_ms ;
}
in
Ok session
and server_cert (session : session_data) =
match session.common_session_data.own_certificate with
| [] -> []
| certs ->
let cs = List.map X509.Certificate.encode_der certs in
let cert = Certificate (Writer.assemble_certificates cs) in
Tracing.hs ~tag:"handshake-out" cert ;
[ Writer.assemble_handshake cert ]
and cert_request version config (session : session_data) =
let open Writer in
match config.authenticator with
| None -> Ok ([], session)
| Some _ ->
let cas =
List.map X509.Distinguished_name.encode_der config.acceptable_cas
and certs =
[ Packet.RSA_SIGN ; Packet.ECDSA_SIGN ]
in
let* data =
match version with
| `TLS_1_0 | `TLS_1_1 ->
Ok (assemble_certificate_request certs cas)
| `TLS_1_2 ->
Ok (assemble_certificate_request_1_2 certs config.signature_algorithms cas)
in
let certreq = CertificateRequest data in
Tracing.hs ~tag:"handshake-out" certreq ;
let common_session_data = { session.common_session_data with client_auth = true } in
Ok ([ assemble_handshake certreq ], { session with common_session_data })
and kex_dhe config (session : session_data) version sig_algs =
let* secret, written =
match session.group with
| None -> assert false (* can not happen *)
| Some g ->
let open Mirage_crypto_ec in
match group_to_impl g with
| `Finite_field g ->
let secret, msg = Mirage_crypto_pk.Dh.gen_key g in
let dh_param = Crypto.dh_params_pack g msg in
let dh_params = Writer.assemble_dh_parameters dh_param in
Ok (`Finite_field secret, dh_params)
| `P256 ->
let secret, shared = P256.Dh.gen_key () in
let params = Writer.assemble_ec_parameters `P256 shared in
Ok (`P256 secret, params)
| `P384 ->
let secret, shared = P384.Dh.gen_key () in
let params = Writer.assemble_ec_parameters `P384 shared in
Ok (`P384 secret, params)
| `P521 ->
let secret, shared = P521.Dh.gen_key () in
let params = Writer.assemble_ec_parameters `P521 shared in
Ok (`P521 secret, params)
| `X25519 ->
let secret, shared = X25519.gen_key () in
let params = Writer.assemble_ec_parameters `X25519 shared in
Ok (`X25519 secret, params)
in
let data = String.concat "" [
session.common_session_data.client_random ;
session.common_session_data.server_random ;
written
]
in
let* priv = private_key session in
let* sgn = signature version data sig_algs config.signature_algorithms priv in
let kex = ServerKeyExchange (written ^ sgn) in
let hs = Writer.assemble_handshake kex in
Tracing.hs ~tag:"handshake-out" kex ;
Ok (hs, secret)
in
let* session = process_client_hello ch state.config in
let sh, session = server_hello state.config ch session state.protocol_version reneg in
let certificates = server_cert session
and hello_done = Writer.assemble_handshake ServerHelloDone
in
let* cert_req, session =
cert_request (state_version state) state.config session
in
let* out_recs, machina =
match Ciphersuite.ciphersuite_kex session.ciphersuite with
| #Ciphersuite.key_exchange_algorithm_dhe ->
let* kex, dh =
kex_dhe state.config session state.protocol_version (sig_algs ch)
in
let outs = sh :: certificates @ [ kex ] @ cert_req @ [ hello_done ] in
let log = raw :: outs in
let machina =
if session.common_session_data.client_auth then
AwaitClientCertificate_DHE (session, dh, log)
else
AwaitClientKeyExchange_DHE (session, dh, log)
in
Tracing.hs ~tag:"handshake-out" ServerHelloDone ;
Ok (outs, machina)
| `RSA ->
let outs = sh :: certificates @ cert_req @ [ hello_done ] in
let log = raw :: outs in
let machina =
if session.common_session_data.client_auth then
AwaitClientCertificate_RSA (session, log)
else
AwaitClientKeyExchange_RSA (session, log)
in
Tracing.hs ~tag:"handshake-out" ServerHelloDone ;
Ok (outs, machina)
in
Ok ({ state with machina = Server machina },
[`Record (Packet.HANDSHAKE, String.concat "" out_recs)])
(* TODO could benefit from result monadd *)
let agreed_version supported (client_hello : client_hello) =
let raw_client_versions =
match List.filter_map (function `SupportedVersions vs -> Some vs | _ -> None) client_hello.extensions with
| [] -> [client_hello.client_version]
| [vs] -> vs
| _ -> invalid_arg "bad supported version extension"
in
let supported_versions = List.fold_left (fun acc v ->
match any_version_to_version v with
| None -> acc
| Some v -> v :: acc) [] raw_client_versions
in
let client_versions = List.sort_uniq compare_tls_version supported_versions in
match
List.fold_left (fun r v ->
match supported_protocol_version supported v with
| None -> r
| Some v -> Some v)
None client_versions
with
| Some x -> Ok x
| None -> match supported_versions with
| [] -> Error (`Fatal (`Protocol_version (`None_supported raw_client_versions)))
| _ -> Error (`Error (`NoConfiguredVersions supported_versions))
let answer_client_hello state (ch : client_hello) raw =
let ensure_reneg ciphers their_data =
let reneg_cs = List.mem Packet.TLS_EMPTY_RENEGOTIATION_INFO_SCSV ciphers in
let err = `Fatal (`Handshake (`Message "invalid renegotiation")) in
match reneg_cs, their_data with
| _, Some x -> guard (String.length x = 0) err
| true, _ -> Ok ()
| _ -> Error err
and resume (ch : client_hello) state =
let epoch_matches (epoch : Core.epoch_data) version ciphers extensions =
let cciphers = List.filter_map Ciphersuite.any_ciphersuite_to_ciphersuite ciphers in
List.mem epoch.ciphersuite cciphers &&
version = epoch.protocol_version &&
(not state.config.use_reneg ||
(List.mem `ExtendedMasterSecret extensions && epoch.extended_ms))
in
match Option.bind ch.sessionid state.config.session_cache with
| Some epoch when epoch_matches epoch state.protocol_version ch.ciphersuites ch.extensions ->
let session =
let session = session_of_epoch epoch in
let common_session_data = {
session.common_session_data with
client_random = ch.client_random ;
client_auth = (epoch.peer_certificate <> None) ;
} in
{ session with common_session_data ; client_version = ch.client_version }
in
Some session
| _ -> None
and answer_resumption session state =
let version = state_version state in
let sh, session = server_hello state.config ch session version None in
(* we really do not want to have any leftover handshake fragments *)
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let client_ctx, server_ctx =
Handshake_crypto.initialise_crypto_ctx version session
in
let ccs = change_cipher_spec in
let log = [ raw ; sh ] in
let server =
Handshake_crypto.finished
version session.ciphersuite session.common_session_data.master_secret "server finished" log
in
let session = { session with tls_unique = server } in
let fin = Finished server in
let fin_raw = Writer.assemble_handshake fin in
Tracing.cs ~tag:"change-cipher-spec-out" (snd ccs) ;
Tracing.hs ~tag:"handshake-out" fin ;
let machina = AwaitClientChangeCipherSpecResume (session, client_ctx, server, log @ [fin_raw]) in
Ok ({ state with machina = Server machina },
[ `Record (Packet.HANDSHAKE, sh) ;
`Record ccs ;
`Change_enc server_ctx ;
`Record (Packet.HANDSHAKE, fin_raw)])
in
let process_client_hello config ch version =
let cciphers = ch.ciphersuites in
let* () = client_hello_valid version ch in
let* () =
guard (not (List.mem Packet.TLS_FALLBACK_SCSV cciphers) ||
version = max_protocol_version config.protocol_versions)
(`Fatal `Inappropriate_fallback)
in
let theirs = get_secure_renegotiation ch.extensions in
ensure_reneg cciphers theirs
in
let process protocol_version =
let* () = process_client_hello state.config ch protocol_version in
let state = { state with protocol_version } in
(match resume ch state with
| None -> answer_client_hello_common state None ch raw
| Some session -> answer_resumption session state)
in
let* v = agreed_version state.config.protocol_versions ch in
match v with
| `TLS_1_3 -> Handshake_server13.answer_client_hello ~hrr:false state ch raw
| protocol_version -> process protocol_version
let answer_client_hello_reneg state (ch : client_hello) raw =
(* ensure reneg allowed and supplied *)
let ensure_reneg our_data their_data =
let err = `Fatal (`Handshake (`Message "invalid renegotiation")) in
match our_data, their_data with
| (cvd, _), Some x -> guard (String.equal cvd x) err
| _ -> Error err
in
let process_client_hello config oldversion ours ch =
let* () = client_hello_valid oldversion ch in
let* version = agreed_version config.protocol_versions ch in
let* () =
guard (version = oldversion)
(`Fatal (`Handshake (`Message "invalid renegotiation version")))
in
let theirs = get_secure_renegotiation ch.extensions in
let* () = ensure_reneg ours theirs in
Ok version
in
let config = state.config in
match config.use_reneg, state.session with
| true , `TLS session :: _ ->
let reneg = session.renegotiation in
let* _version = process_client_hello config state.protocol_version reneg ch in
answer_client_hello_common state (Some reneg) ch raw
| false, _ ->
let no_reneg = Writer.assemble_alert ~level:Packet.WARNING Packet.NO_RENEGOTIATION in
Tracing.debug (fun m -> m "alert-out (warning, no_renegotiation)") ;
Ok (state, [`Record (Packet.ALERT, no_reneg)])
| true , _ -> Error (`Fatal (`Handshake (`Message "couldn't find an earlier session")))
let handle_change_cipher_spec ss state packet =
let* () = map_reader_error (Reader.parse_change_cipher_spec packet) in
match ss with
| AwaitClientChangeCipherSpec (session, server_ctx, client_ctx, log) ->
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let ccs = change_cipher_spec in
let machina = AwaitClientFinished (session, log)
in
Tracing.cs ~tag:"change-cipher-spec-in" packet ;
Tracing.cs ~tag:"change-cipher-spec-out" packet ;
Ok ({ state with machina = Server machina },
[`Record ccs; `Change_enc server_ctx; `Change_dec client_ctx])
| AwaitClientChangeCipherSpecResume (session, client_ctx, server_verify, log) ->
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let machina = AwaitClientFinishedResume (session, server_verify, log)
in
Tracing.cs ~tag:"change-cipher-spec-in" packet ;
Ok ({ state with machina = Server machina },
[`Change_dec client_ctx])
| _ -> Error (`Fatal (`Unexpected (`Message "change cipher spec")))
let handle_handshake ss hs buf =
let* handshake = map_reader_error (Reader.parse_handshake buf) in
Tracing.hs ~tag:"handshake-in" handshake;
match ss, handshake with
| AwaitClientHello, ClientHello ch ->
answer_client_hello hs ch buf
| AwaitClientCertificate_RSA (session, log), Certificate cs ->
let* cs = map_reader_error (Reader.parse_certificates cs) in
answer_client_certificate_RSA hs session cs buf log
| AwaitClientCertificate_DHE (session, dh_sent, log), Certificate cs ->
let* cs = map_reader_error (Reader.parse_certificates cs) in
answer_client_certificate_DHE hs session dh_sent cs buf log
| AwaitClientKeyExchange_RSA (session, log), ClientKeyExchange cs ->
let* kex = map_reader_error (Reader.parse_client_dh_key_exchange cs) in
answer_client_key_exchange_RSA hs session kex buf log
| AwaitClientKeyExchange_DHE (session, dh_sent, log), ClientKeyExchange kex ->
answer_client_key_exchange_DHE hs session dh_sent kex buf log
| AwaitClientCertificateVerify (session, sctx, cctx, log), CertificateVerify ver ->
answer_client_certificate_verify hs session sctx cctx ver buf log
| AwaitClientFinished (session, log), Finished fin ->
answer_client_finished hs session fin buf log
| AwaitClientFinishedResume (session, server_verify, log), Finished fin ->
answer_client_finished_resume hs session server_verify fin buf log
| Established, ClientHello ch -> (* client-initiated renegotiation *)
answer_client_hello_reneg hs ch buf
| AwaitClientHelloRenegotiate, ClientHello ch -> (* hello-request send, renegotiation *)
answer_client_hello_reneg hs ch buf
| _, hs -> Error (`Fatal (`Unexpected (`Handshake hs)))

6
unikernel/duniverse/ocaml-tls/lib/handshake_server.mli Normal file
View file

@ -0,0 +1,6 @@
open State
val hello_request : handshake_state -> (handshake_return, failure) result
val handle_change_cipher_spec : server_handshake_state -> handshake_state -> string -> (handshake_return, failure) result
val handle_handshake : server_handshake_state -> handshake_state -> string -> (handshake_return, failure) result

511
unikernel/duniverse/ocaml-tls/lib/handshake_server13.ml Normal file
View file

@ -0,0 +1,511 @@
open State
open Core
open Handshake_common
open Handshake_crypto13
let answer_client_hello ~hrr state ch raw =
let* () = client_hello_valid `TLS_1_3 ch in
let* () =
guard (not (hrr && List.mem `EarlyDataIndication ch.extensions))
(`Fatal (`Handshake (`Message "has 0RTT after hello retry request")))
in
Tracing.debug (fun m -> m "version %a" pp_tls_version `TLS_1_3) ;
let ciphers =
List.filter_map Ciphersuite.any_ciphersuite_to_ciphersuite13 ch.ciphersuites
in
let* groups =
let* gs =
Option.to_result
~none:(`Fatal (`Missing_extension "supported group"))
(Utils.map_find ~f:(function `SupportedGroups gs -> Some gs | _ -> None) ch.extensions)
in
Ok (List.filter_map Core.named_group_to_group gs)
in
let* keyshares =
let* ks =
Option.to_result
~none:(`Fatal (`Missing_extension "key share"))
(Utils.map_find ~f:(function `KeyShare ks -> Some ks | _ -> None) ch.extensions)
in
List.fold_left (fun acc (g, ks) ->
let* acc = acc in
match Core.named_group_to_group g with
| None -> Ok acc
| Some g -> Ok ((g, ks) :: acc))
(Ok []) ks
in
let base_server_hello ?epoch cipher extensions =
let ciphersuite = (cipher :> Ciphersuite.ciphersuite) in
let sh =
{ server_version = `TLS_1_3 ;
server_random = Mirage_crypto_rng.generate 32 ;
sessionid = ch.sessionid ;
ciphersuite ;
extensions }
in
let session : session_data13 =
let base = match epoch with None -> empty_session13 cipher | Some e -> session13_of_epoch cipher e in
let common_session_data13 = {
base.common_session_data13 with
server_random = sh.server_random ;
client_random = ch.client_random ;
} in
let resumed = match epoch with None -> false | Some _ -> true in
{ base with common_session_data13 ; ciphersuite13 = cipher ; resumed }
in
(sh, session)
in
let config = state.config in
match
Utils.first_match (List.map fst keyshares) config.Config.groups,
Utils.first_match ciphers (Config.ciphers13 config)
with
| _, None -> Error (`Error (`NoConfiguredCiphersuite ciphers))
| None, Some cipher ->
if hrr then
(* avoid loops CH -> HRR -> CH -> HRR -> ... *)
Error (`Fatal (`Handshake (`Message "hello retry request already sent, still no supported group")))
else
(* no keyshare, looks whether there's a supported group ++ send back HRR *)
begin match Utils.first_match groups config.Config.groups with
| None -> Error (`Fatal (`Handshake (`Message "no supported group found")))
| Some group ->
let cookie =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
H.(to_raw_string (digest_string raw))
in
let hrr = { retry_version = `TLS_1_3 ; ciphersuite = cipher ; sessionid = ch.sessionid ; selected_group = group ; extensions = [ `Cookie cookie ] } in
let hrr_raw = Writer.assemble_handshake (HelloRetryRequest hrr) in
Tracing.hs ~tag:"handshake-out" (HelloRetryRequest hrr) ;
(* there is no early data anymore if HRR was sent (see 4.1.2) *)
(* but the client wouldn't know until it received the HRR *)
let early_data_left = if List.mem `EarlyDataIndication ch.extensions then config.Config.zero_rtt else 0l in
let machina = Server13 AwaitClientHelloHRR13 in
Ok ({ state with early_data_left ; machina },
`Record (Packet.HANDSHAKE, hrr_raw) ::
(match ch.sessionid with
| None -> []
| Some _ -> [`Record change_cipher_spec]))
end
| Some group, Some cipher ->
Log.debug (fun m -> m "cipher %a" Ciphersuite.pp_ciphersuite cipher) ;
Log.debug (fun m -> m "group %a" pp_group group) ;
if not (List.mem group groups) then
Error (`Fatal (`Handshake (`Message "keyshare group not in group list")))
else
(* we already checked above in keyshares that group is present there *)
let keyshare =
snd (List.find (fun (g, _) -> g = group) keyshares)
in
(* DHE - full handshake *)
let* log =
if hrr then
let* c =
Option.to_result
~none:(`Fatal (`Missing_extension "cookie"))
(Utils.map_find ~f:(function `Cookie c -> Some c | _ -> None) ch.extensions)
in
(* log is: 254 00 00 length c :: HRR *)
let hash_hdr = Writer.assemble_message_hash (String.length c) in
let hrr = { retry_version = `TLS_1_3 ; ciphersuite = cipher ; sessionid = ch.sessionid ; selected_group = group ; extensions = [ `Cookie c ]} in
let hs_buf = Writer.assemble_handshake (HelloRetryRequest hrr) in
Ok (String.concat "" [ hash_hdr ; c ; hs_buf ])
else
Ok ""
in
let hostname = hostname ch in
let hlen =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
H.digest_size
in
let early_secret, epoch, exts, can_use_early_data =
let secret ?(psk = String.make hlen '\x00') () = Handshake_crypto13.(derive (empty cipher) psk) in
let no_resume = secret (), None, [], false in
match
config.Config.ticket_cache,
Utils.map_find ~f:(function `PreSharedKeys ids -> Some ids | _ -> None) ch.extensions,
Utils.map_find ~f:(function `PskKeyExchangeModes ms -> Some ms | _ -> None) ch.extensions
with
| None, _, _ | _, None, _ -> no_resume
| Some _, Some _, None -> no_resume (* should this lead to an error instead? *)
| Some cache, Some ids, Some ms ->
if not (List.mem Packet.PSK_KE_DHE ms) then
no_resume
else
let idx_ids = List.mapi (fun i id -> (i, id)) ids in
match
List.filter (fun (_, ((id, _), _)) ->
match cache.Config.lookup id with None -> false | Some _ -> true)
idx_ids
with
| [] ->
Log.info (fun m -> m "found no id in psk cache") ;
no_resume
| (idx, ((id, obf_age), binder))::_ ->
(* need to verify binder, do the obf_age computations + checking,
figure out whether the id is in our psk cache, and use the resumption secret as input
and Ok the idx *)
let psk, old_epoch =
match cache.Config.lookup id with
| None -> assert false (* see above *)
| Some x -> x
in
match Ciphersuite.(any_ciphersuite_to_ciphersuite13 (ciphersuite_to_any_ciphersuite old_epoch.ciphersuite)) with
| None -> no_resume
| Some c' ->
if c' = cipher &&
match hostname, old_epoch.own_name with
| None, None -> true
| Some x, Some y -> Domain_name.equal x y
| _ -> false
then
let now = cache.Config.timestamp () in
let server_delta_t = Ptime.diff now psk.issued_at in
let client_delta_t =
match Ptime.Span.of_float_s Int32.(to_float (sub obf_age psk.obfuscation) /. 1000.) with
| None ->
Logs.debug (fun m -> m "client_delta is not computable, using 0") ;
Ptime.Span.zero
| Some x -> x
in
(* ensure server&client_delta_t are not too far off! *)
match Ptime.Span.(to_int_s (abs (sub server_delta_t client_delta_t))) with
| None ->
Logs.debug (fun m -> m "s_c_delta computation lead nowhere") ;
no_resume
| Some s_c_delta ->
if s_c_delta > 10 then begin
Logs.debug (fun m -> m "delta between client and server is %d seconds, ignoring this ticket!" s_c_delta);
no_resume
end else
(* if ticket_creation ts + lifetime > now, continue *)
let until = match Ptime.add_span psk.issued_at (Ptime.Span.of_int_s (Int32.to_int cache.Config.lifetime)) with
| None -> Ptime.epoch
| Some ts -> ts
in
if Ptime.is_earlier now ~than:until then
let early_secret = secret ~psk:psk.secret () in
let binder_key = Handshake_crypto13.derive_secret early_secret "res binder" "" in
let binders_len = binders_len ids in
let ch_part = String.(sub raw 0 (length raw - binders_len)) in
let log = log ^ ch_part in
let binder' = Handshake_crypto13.finished early_secret.hash binder_key log in
if String.equal binder binder' then begin
(* from 4.1.2 - earlydata is not allowed after hrr *)
let zero = idx = 0 && not hrr && List.mem `EarlyDataIndication ch.extensions in
early_secret, Some old_epoch, [ `PreSharedKey idx ], zero
end else
no_resume
else
no_resume
else
no_resume
in
let _, early_traffic_ctx = Handshake_crypto13.early_traffic early_secret raw in
let secret, public = Handshake_crypto13.dh_gen_key group in
let* es = Handshake_crypto13.dh_shared secret keyshare in
let hs_secret = Handshake_crypto13.derive early_secret es in
Tracing.cs ~tag:"hs secret" hs_secret.secret ;
let sh, session = base_server_hello ?epoch cipher (`KeyShare (group, public) :: exts) in
let sh_raw = Writer.assemble_handshake (ServerHello sh) in
Tracing.hs ~tag:"handshake-out" (ServerHello sh) ;
let log = log ^ raw ^ sh_raw in
let server_hs_secret, server_ctx, client_hs_secret, client_ctx = hs_ctx hs_secret log in
let* sigalgs =
Option.to_result
~none:(`Fatal (`Missing_extension "signature algorithms"))
(Utils.map_find ~f:(function `SignatureAlgorithms sa -> Some sa | _ -> None) ch.extensions)
in
(* TODO respect certificate_signature_algs if present *)
let f = supports_key_usage ~not_present:true `Digital_signature in
let* chain, priv =
let* r = agreed_cert ~f ~signature_algorithms:sigalgs config.Config.own_certificates hostname in
match r with
| c::cs, priv -> Ok (c::cs, priv)
| _ -> Error (`Fatal (`Handshake (`Message "couldn't find certificate chain")))
in
let* alpn_protocol = alpn_protocol config ch in
let session =
let common_session_data13 = { session.common_session_data13 with
own_name = hostname ; own_certificate = chain ;
own_private_key = Some priv ; alpn_protocol }
in
{ session with common_session_data13 }
in
let ee =
let hostname_ext = Option.fold ~none:[] ~some:(fun _ -> [`Hostname]) hostname
and alpn = Option.fold ~none:[] ~some:(fun proto -> [`ALPN proto]) alpn_protocol
and early_data = if can_use_early_data && config.Config.zero_rtt <> 0l then [ `EarlyDataIndication ] else []
in
EncryptedExtensions (hostname_ext @ alpn @ early_data)
in
(* TODO also max_fragment_length ; client_certificate_url ; trusted_ca_keys ; user_mapping ; client_authz ; server_authz ; cert_type ; use_srtp ; heartbeat ; alpn ; status_request_v2 ; signed_cert_timestamp ; client_cert_type ; server_cert_type *)
let ee_raw = Writer.assemble_handshake ee in
Tracing.hs ~tag:"handshake-out" ee ;
let log = log ^ ee_raw in
let* c_out, log, session' =
if session.resumed then
Ok ([], log, session)
else
let out, log, session = match config.Config.authenticator with
| None -> [], log, session
| Some _ ->
let certreq =
let exts =
`SignatureAlgorithms config.Config.signature_algorithms ::
(match config.Config.acceptable_cas with
| [] -> []
| cas -> [ `CertificateAuthorities cas ])
in
CertificateRequest (Writer.assemble_certificate_request_1_3 exts)
in
Tracing.hs ~tag:"handshake-out" certreq ;
let raw_cert_req = Writer.assemble_handshake certreq in
let common_session_data13 = { session.common_session_data13 with client_auth = true } in
[raw_cert_req], log ^ raw_cert_req, { session with common_session_data13 }
in
let certs = List.map X509.Certificate.encode_der chain in
let cert = Certificate (Writer.assemble_certificates_1_3 "" certs) in
let cert_raw = Writer.assemble_handshake cert in
Tracing.hs ~tag:"handshake-out" cert ;
let log = log ^ cert_raw in
let tbs =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
H.(to_raw_string (digest_string log))
in
let* signed =
signature `TLS_1_3
~context_string:"TLS 1.3, server CertificateVerify"
tbs (Some sigalgs) config.Config.signature_algorithms priv
in
let cv = CertificateVerify signed in
let cv_raw = Writer.assemble_handshake cv in
Tracing.hs ~tag:"handshake-out" cv ;
let log = log ^ cv_raw in
Ok (out @ [cert_raw; cv_raw], log, session)
in
let master_secret = Handshake_crypto13.derive hs_secret (String.make hlen '\x00') in
Tracing.cs ~tag:"master-secret" master_secret.secret ;
let f_data = finished hs_secret.hash server_hs_secret log in
let fin = Finished f_data in
let fin_raw = Writer.assemble_handshake fin in
Tracing.hs ~tag:"handshake-out" fin ;
let log = log ^ fin_raw in
let server_app_secret, server_app_ctx, client_app_secret, client_app_ctx =
app_ctx master_secret log
in
let exporter_master_secret = Handshake_crypto13.exporter master_secret log in
let session' = { session' with server_app_secret ; client_app_secret ; exporter_master_secret } in
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
(* send sessionticket early *)
(* TODO track the nonce across handshakes / newsessionticket messages (i.e. after post-handshake auth) - needs to be unique! *)
let st, st_raw =
match session.resumed, config.Config.ticket_cache with
| true, _ | _, None -> None, []
| false, Some cache ->
let age_add =
let cs = Mirage_crypto_rng.generate 4 in
String.get_int32_be cs 0
in
let psk_id = Mirage_crypto_rng.generate 32 in
let nonce = Mirage_crypto_rng.generate 4 in
let extensions = match config.Config.zero_rtt with
| 0l -> []
| x -> [ `EarlyDataIndication x ]
in
let st = { lifetime = cache.Config.lifetime ; age_add ; nonce ; ticket = psk_id ; extensions } in
Tracing.hs ~tag:"handshake-out" (SessionTicket st) ;
let st_raw = Writer.assemble_handshake (SessionTicket st) in
(Some st, [st_raw])
in
let session =
let common_session_data13 = { session'.common_session_data13 with master_secret = master_secret.secret } in
{ session' with common_session_data13 ; master_secret }
in
let st, session =
if can_use_early_data then
(AwaitEndOfEarlyData13 (client_hs_secret, client_ctx, client_app_ctx, st, log),
`TLS13 { session with state = `ZeroRTT } :: state.session)
else if session.common_session_data13.client_auth then
(AwaitClientCertificate13 (session, client_hs_secret, client_app_ctx, st, log),
state.session)
else
(AwaitClientFinished13 (client_hs_secret, client_app_ctx, st, log),
`TLS13 session :: state.session)
in
let early_data_left = if List.mem `EarlyDataIndication ch.extensions then config.Config.zero_rtt else 0l in
Ok ({ state with machina = Server13 st ; session ; early_data_left },
`Record (Packet.HANDSHAKE, sh_raw) ::
(match ch.sessionid with
| Some _ when not hrr -> [`Record change_cipher_spec]
| _ -> []) @
[ `Change_enc server_ctx ;
`Change_dec (if can_use_early_data then early_traffic_ctx else client_ctx) ;
`Record (Packet.HANDSHAKE, ee_raw) ] @
List.map (fun data -> `Record (Packet.HANDSHAKE, data)) c_out @
[ `Record (Packet.HANDSHAKE, fin_raw) ;
`Change_enc server_app_ctx ] @
List.map (fun data -> `Record (Packet.HANDSHAKE, data)) st_raw)
let answer_client_certificate state cert (sd : session_data13) client_fini dec_ctx st raw log =
let* c = map_reader_error (Reader.parse_certificates_1_3 cert) in
match c, state.config.Config.authenticator with
| (_, []), None -> Error (`Fatal (`Handshake (`Message "couldn't find authenticator")))
| (_ctx, []), Some auth ->
begin match auth ~host:None [] with
| Ok anchor ->
let trust_anchor = match anchor with
| None -> None
| Some (_chain, ta) -> Some ta
in
let common_session_data13 = { sd.common_session_data13 with trust_anchor } in
let sd = { sd with common_session_data13 } in
let st = AwaitClientFinished13 (client_fini, dec_ctx, st, log ^ raw) in
Ok ({ state with machina = Server13 st ; session = `TLS13 sd :: state.session }, [])
| Error e -> Error (`Error (`AuthenticationFailure e))
end
| (_ctx, cert_exts), auth ->
(* TODO what to do with ctx? send through authenticator? *)
(* TODO what to do with extensions? *)
let certs = List.map fst cert_exts in
let* peer_certificate, received_certificates, peer_certificate_chain, trust_anchor =
validate_chain auth certs state.config.Config.ip None
in
let sd' = let common_session_data13 = {
sd.common_session_data13 with
received_certificates ;
peer_certificate ;
peer_certificate_chain ;
trust_anchor
} in
{ sd with common_session_data13 }
in
let st = AwaitClientCertificateVerify13 (sd', client_fini, dec_ctx, st, log ^ raw) in
Ok ({ state with machina = Server13 st }, [])
let answer_client_certificate_verify state cv (sd : session_data13) client_fini dec_ctx st raw log =
let tbs =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 sd.ciphersuite13)) in
H.(to_raw_string (digest_string log))
in
let* () =
verify_digitally_signed `TLS_1_3
~context_string:"TLS 1.3, client CertificateVerify"
state.config.Config.signature_algorithms cv tbs
sd.common_session_data13.peer_certificate
in
let st = AwaitClientFinished13 (client_fini, dec_ctx, st, log ^ raw) in
Ok ({ state with machina = Server13 st ; session = `TLS13 sd :: state.session }, [])
let answer_client_finished state fin client_fini dec_ctx st raw log =
match state.session with
| `TLS13 session :: rest ->
let hash = Ciphersuite.hash13 session.ciphersuite13 in
let data = finished hash client_fini log in
let* () =
guard (String.equal data fin)
(`Fatal (`Handshake (`Message "couldn't verify finished")))
in
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let session' = match st, state.config.Config.ticket_cache with
| None, _ | _, None -> session
| Some st, Some cache ->
let resumption_secret = Handshake_crypto13.resumption session.master_secret (log ^ raw) in
let session = { session with resumption_secret } in
let secret = Handshake_crypto13.res_secret hash resumption_secret st.nonce in
let issued_at = cache.Config.timestamp () in
let psk = { identifier = st.ticket ; obfuscation = st.age_add ; secret ; lifetime = st.lifetime ; early_data = state.config.Config.zero_rtt ; issued_at } in
let epoch = epoch_of_session true None `TLS_1_3 (`TLS13 session) in
cache.Config.ticket_granted psk epoch ;
session
in
let state' = { state with machina = Server13 Established13 ; session = `TLS13 session' :: rest } in
Ok (state', [ `Change_dec dec_ctx ])
| _ -> Error (`Fatal (`Handshake (`Message "no session found in finished")))
let handle_end_of_early_data state cf hs_ctx cc st buf log =
let machina = AwaitClientFinished13 (cf, cc, st, log ^ buf) in
match state.session with
| `TLS13 s1 :: _ ->
let session = `TLS13 { s1 with state = `Established } :: state.session in
Ok ({ state with machina = Server13 machina ; session }, [ `Change_dec hs_ctx ])
| _ ->
Error (`Fatal (`Handshake (`Message "no session handling end of early data")))
let handle_key_update state req =
match state.session with
| `TLS13 session :: _ ->
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let client_app_secret, client_ctx =
app_secret_n_1 session.master_secret session.client_app_secret
in
let session' = { session with client_app_secret } in
let session', out = match req with
| Packet.UPDATE_NOT_REQUESTED -> session', []
| Packet.UPDATE_REQUESTED ->
let server_app_secret, server_ctx =
app_secret_n_1 session.master_secret session.server_app_secret
in
let ku = KeyUpdate Packet.UPDATE_NOT_REQUESTED in
Tracing.hs ~tag:"handshake-out" ku ;
let ku_raw = Writer.assemble_handshake ku in
{ session' with server_app_secret },
[ `Record (Packet.HANDSHAKE, ku_raw); `Change_enc server_ctx ]
in
let session = `TLS13 session' :: state.session in
let state' = { state with machina = Server13 Established13 ; session } in
Ok (state', `Change_dec client_ctx :: out)
| _ -> Error (`Fatal (`Handshake (`Message "no session while handling key update")))
let handle_handshake cs hs buf =
let* handshake = map_reader_error (Reader.parse_handshake buf) in
Tracing.hs ~tag:"handshake-in" handshake;
match cs, handshake with
| AwaitClientHelloHRR13, ClientHello ch ->
answer_client_hello ~hrr:true hs ch buf
| AwaitClientCertificate13 (sd, cf, cc, st, log), Certificate cert ->
answer_client_certificate hs cert sd cf cc st buf log
| AwaitClientCertificateVerify13 (sd, cf, cc, st, log), CertificateVerify cv ->
answer_client_certificate_verify hs cv sd cf cc st buf log
| AwaitClientFinished13 (cf, cc, st, log), Finished x ->
answer_client_finished hs x cf cc st buf log
| AwaitEndOfEarlyData13 (cf, hs_c, cc, st, log), EndOfEarlyData ->
handle_end_of_early_data hs cf hs_c cc st buf log
| Established13, KeyUpdate req ->
handle_key_update hs req
| _, hs -> Error (`Fatal (`Unexpected (`Handshake hs)))

621
unikernel/duniverse/ocaml-tls/lib/packet.ml Normal file
View file

@ -0,0 +1,621 @@
(** Magic numbers of the TLS protocol. *)
(* HACK: 24 bits type not in cstruct *)
let get_uint24_len ~off buf =
(String.get_uint16_be buf off) * 0x100 + (String.get_uint8 buf (off + 2))
let set_uint24_len ~off buf num =
Bytes.set_uint16_be buf off (num / 0x100);
Bytes.set_uint8 buf (off + 2) (num mod 0x100)
(* TLS record content type *)
type content_type =
| CHANGE_CIPHER_SPEC
| ALERT
| HANDSHAKE
| APPLICATION_DATA
let content_type_to_int = function
| CHANGE_CIPHER_SPEC -> 20
| ALERT -> 21
| HANDSHAKE -> 22
| APPLICATION_DATA -> 23
and int_to_content_type = function
| 20 -> Some CHANGE_CIPHER_SPEC
| 21 -> Some ALERT
| 22 -> Some HANDSHAKE
| 23 -> Some APPLICATION_DATA
| _ -> None
let content_type_to_string = function
| CHANGE_CIPHER_SPEC -> "change cipher spec"
| ALERT -> "alert"
| HANDSHAKE -> "handshake"
| APPLICATION_DATA -> "application data"
let pp_content_type ppf ct =
Fmt.string ppf (content_type_to_string ct)
(* TLS alert level *)
type alert_level =
| WARNING
| FATAL
let pp_alert_level ppf = function
| WARNING -> Fmt.string ppf "warning"
| FATAL -> Fmt.string ppf "fatal"
let alert_level_to_int = function
| WARNING -> 1
| FATAL -> 2
and int_to_alert_level = function
| 1 -> Some WARNING
| 2 -> Some FATAL
| _ -> None
(* TLS alert types *)
type alert_type =
| CLOSE_NOTIFY [@id 0] (*RFC5246*)
| UNEXPECTED_MESSAGE [@id 10] (*RFC5246*)
| BAD_RECORD_MAC [@id 20] (*RFC5246*)
| RECORD_OVERFLOW [@id 22] (*RFC5246*)
| HANDSHAKE_FAILURE [@id 40] (*RFC5246*)
| BAD_CERTIFICATE [@id 42] (*RFC5246*)
| CERTIFICATE_EXPIRED [@id 45] (*RFC5246*)
| CERTIFICATE_UNKNOWN [@id 46] (*RFC5246*)
| DECODE_ERROR [@id 50] (*RFC5246*)
| PROTOCOL_VERSION [@id 70] (*RFC5246*)
| INAPPROPRIATE_FALLBACK [@id 86] (*draft-ietf-tls-downgrade-scsv*)
| USER_CANCELED [@id 90] (*RFC5246*)
| NO_RENEGOTIATION [@id 100] (*RFC5246*)
| MISSING_EXTENSION [@id 109] (*RFC8446*)
| UNSUPPORTED_EXTENSION [@id 110] (*RFC5246*)
| UNRECOGNIZED_NAME [@id 112] (*RFC6066*)
| NO_APPLICATION_PROTOCOL [@id 120] (*RFC7301*)
| UNKNOWN of int
let alert_type_to_string = function
| CLOSE_NOTIFY -> "close notify"
| UNEXPECTED_MESSAGE -> "unexpected message"
| BAD_RECORD_MAC -> "bad record mac"
| RECORD_OVERFLOW -> "record overflow"
| HANDSHAKE_FAILURE -> "handshake failure"
| BAD_CERTIFICATE -> "bad certificate"
| CERTIFICATE_EXPIRED -> "certificate expired"
| CERTIFICATE_UNKNOWN -> "certificate unknown"
| DECODE_ERROR -> "decode error"
| PROTOCOL_VERSION -> "protocol version"
| INAPPROPRIATE_FALLBACK -> "inappropriate fallback"
| USER_CANCELED -> "user canceled"
| NO_RENEGOTIATION -> "no renegotiation"
| MISSING_EXTENSION -> "missing extension"
| UNSUPPORTED_EXTENSION -> "unsupported extension"
| UNRECOGNIZED_NAME -> "unrecognized name"
| NO_APPLICATION_PROTOCOL -> "no application protocol"
| UNKNOWN x -> "unknown " ^ string_of_int x
let alert_type_to_int = function
| CLOSE_NOTIFY -> 0 (*RFC5246*)
| UNEXPECTED_MESSAGE -> 10 (*RFC5246*)
| BAD_RECORD_MAC -> 20 (*RFC5246*)
| RECORD_OVERFLOW -> 22 (*RFC5246*)
| HANDSHAKE_FAILURE -> 40 (*RFC5246*)
| BAD_CERTIFICATE -> 42 (*RFC5246*)
| CERTIFICATE_EXPIRED -> 45 (*RFC5246*)
| CERTIFICATE_UNKNOWN -> 46 (*RFC5246*)
| DECODE_ERROR -> 50 (*RFC5246*)
| PROTOCOL_VERSION -> 70 (*RFC5246*)
| INAPPROPRIATE_FALLBACK -> 86 (*draft-ietf-tls-downgrade-scsv*)
| USER_CANCELED -> 90 (*RFC5246*)
| NO_RENEGOTIATION -> 100 (*RFC5246*)
| MISSING_EXTENSION -> 109 (*RFC8446*)
| UNSUPPORTED_EXTENSION -> 110 (*RFC5246*)
| UNRECOGNIZED_NAME -> 112 (*RFC6066*)
| NO_APPLICATION_PROTOCOL -> 120 (*RFC7301*)
| UNKNOWN x -> x
and int_to_alert_type = function
| 0 -> CLOSE_NOTIFY
| 10 -> UNEXPECTED_MESSAGE
| 20 -> BAD_RECORD_MAC
| 22 -> RECORD_OVERFLOW
| 40 -> HANDSHAKE_FAILURE
| 42 -> BAD_CERTIFICATE
| 45 -> CERTIFICATE_EXPIRED
| 46 -> CERTIFICATE_UNKNOWN
| 50 -> DECODE_ERROR
| 70 -> PROTOCOL_VERSION
| 86 -> INAPPROPRIATE_FALLBACK
| 90 -> USER_CANCELED
| 100 -> NO_RENEGOTIATION
| 109 -> MISSING_EXTENSION
| 110 -> UNSUPPORTED_EXTENSION
| 112 -> UNRECOGNIZED_NAME
| 120 -> NO_APPLICATION_PROTOCOL
| x -> UNKNOWN x
let pp_alert ppf (lvl, typ) =
Fmt.pf ppf "ALERT %a %s" pp_alert_level lvl (alert_type_to_string typ)
(* TLS handshake type *)
type handshake_type =
| HELLO_REQUEST [@id 0]
| CLIENT_HELLO [@id 1]
| SERVER_HELLO [@id 2]
| HELLO_VERIFY_REQUEST [@id 3] (*RFC6347*)
| SESSION_TICKET [@id 4] (*RFC4507, RFC8446*)
| END_OF_EARLY_DATA [@id 5] (*RFC8446*)
| ENCRYPTED_EXTENSIONS [@id 8] (*RFC8446*)
| CERTIFICATE [@id 11]
| SERVER_KEY_EXCHANGE [@id 12]
| CERTIFICATE_REQUEST [@id 13]
| SERVER_HELLO_DONE [@id 14]
| CERTIFICATE_VERIFY [@id 15]
| CLIENT_KEY_EXCHANGE [@id 16]
| FINISHED [@id 20]
| CERTIFICATE_URL [@id 21] (*RFC4366*)
| CERTIFICATE_STATUS [@id 22] (*RFC4366*)
| SUPPLEMENTAL_DATA [@id 23] (*RFC4680*)
| KEY_UPDATE [@id 24] (*RFC8446*)
| MESSAGE_HASH [@id 254] (*RFC8446*)
let handshake_type_to_int = function
| HELLO_REQUEST -> 0
| CLIENT_HELLO -> 1
| SERVER_HELLO -> 2
| HELLO_VERIFY_REQUEST -> 3 (*RFC6347*)
| SESSION_TICKET -> 4 (*RFC4507, RFC8446*)
| END_OF_EARLY_DATA -> 5 (*RFC8446*)
| ENCRYPTED_EXTENSIONS -> 8 (*RFC8446*)
| CERTIFICATE -> 11
| SERVER_KEY_EXCHANGE -> 12
| CERTIFICATE_REQUEST -> 13
| SERVER_HELLO_DONE -> 14
| CERTIFICATE_VERIFY -> 15
| CLIENT_KEY_EXCHANGE -> 16
| FINISHED -> 20
| CERTIFICATE_URL -> 21 (*RFC4366*)
| CERTIFICATE_STATUS -> 22 (*RFC4366*)
| SUPPLEMENTAL_DATA -> 23 (*RFC4680*)
| KEY_UPDATE -> 24 (*RFC8446*)
| MESSAGE_HASH -> 254 (*RFC8446*)
and int_to_handshake_type = function
| 0 -> Some HELLO_REQUEST
| 1 -> Some CLIENT_HELLO
| 2 -> Some SERVER_HELLO
| 3 -> Some HELLO_VERIFY_REQUEST
| 4 -> Some SESSION_TICKET
| 5 -> Some END_OF_EARLY_DATA
| 8 -> Some ENCRYPTED_EXTENSIONS
| 11 -> Some CERTIFICATE
| 12 -> Some SERVER_KEY_EXCHANGE
| 13 -> Some CERTIFICATE_REQUEST
| 14 -> Some SERVER_HELLO_DONE
| 15 -> Some CERTIFICATE_VERIFY
| 16 -> Some CLIENT_KEY_EXCHANGE
| 20 -> Some FINISHED
| 21 -> Some CERTIFICATE_URL
| 22 -> Some CERTIFICATE_STATUS
| 23 -> Some SUPPLEMENTAL_DATA
| 24 -> Some KEY_UPDATE
| 254 -> Some MESSAGE_HASH
| _ -> None
(* TLS certificate types *)
type client_certificate_type =
| RSA_SIGN [@id 1] (*RFC5246*)
| ECDSA_SIGN [@id 64] (*RFC4492*)
let client_certificate_type_to_int = function
| RSA_SIGN -> 1 (*RFC5246*)
| ECDSA_SIGN -> 64 (*RFC4492*)
and int_to_client_certificate_type = function
| 1 -> Some RSA_SIGN
| 64 -> Some ECDSA_SIGN
| _ -> None
(* TLS compression methods, used in hello packets *)
type compression_method =
| NULL [@id 0]
let compression_method_to_int = function
| NULL -> 0
and int_to_compression_method = function
| 0 -> Some NULL
| _ -> None
(* TLS extensions in hello packets from RFC 6066, formerly RFC 4366 *)
type extension_type =
| SERVER_NAME [@id 0]
| MAX_FRAGMENT_LENGTH [@id 1]
| SUPPORTED_GROUPS [@id 10] (*RFC4492, RFC8446*)
| EC_POINT_FORMATS [@id 11] (*RFC4492*)
| SIGNATURE_ALGORITHMS [@id 13] (*RFC5246*)
| APPLICATION_LAYER_PROTOCOL_NEGOTIATION [@id 16] (*RFC7301*)
| PADDING [@id 21] (*RFC7685*)
| EXTENDED_MASTER_SECRET [@id 23] (*RFC7627*)
| SESSION_TICKET [@id 35] (*RFC4507*)
| PRE_SHARED_KEY [@id 41] (*RFC8446*)
| EARLY_DATA [@id 42] (*RFC8446*)
| SUPPORTED_VERSIONS [@id 43] (*RFC8446*)
| COOKIE [@id 44] (*RFC8446*)
| PSK_KEY_EXCHANGE_MODES [@id 45] (*RFC8446*)
| CERTIFICATE_AUTHORITIES [@id 47] (*RFC8446*)
| POST_HANDSHAKE_AUTH [@id 49] (*RFC8446*)
| KEY_SHARE [@id 51] (*RFC8446*)
| RENEGOTIATION_INFO [@id 0xFF01] (*RFC5746*)
let extension_type_to_int = function
| SERVER_NAME -> 0
| MAX_FRAGMENT_LENGTH -> 1
| SUPPORTED_GROUPS -> 10 (*RFC4492, RFC8446*)
| EC_POINT_FORMATS -> 11 (*RFC4492*)
| SIGNATURE_ALGORITHMS -> 13 (*RFC5246*)
| APPLICATION_LAYER_PROTOCOL_NEGOTIATION -> 16 (*RFC7301*)
| PADDING -> 21 (*RFC7685*)
| EXTENDED_MASTER_SECRET -> 23 (*RFC7627*)
| SESSION_TICKET -> 35 (*RFC4507*)
| PRE_SHARED_KEY -> 41 (*RFC8446*)
| EARLY_DATA -> 42 (*RFC8446*)
| SUPPORTED_VERSIONS -> 43 (*RFC8446*)
| COOKIE -> 44 (*RFC8446*)
| PSK_KEY_EXCHANGE_MODES -> 45 (*RFC8446*)
| CERTIFICATE_AUTHORITIES -> 47 (*RFC8446*)
| POST_HANDSHAKE_AUTH -> 49 (*RFC8446*)
| KEY_SHARE -> 51 (*RFC8446*)
| RENEGOTIATION_INFO -> 0xFF01 (*RFC5746*)
and int_to_extension_type = function
| 0 -> Some SERVER_NAME
| 1 -> Some MAX_FRAGMENT_LENGTH
| 10 -> Some SUPPORTED_GROUPS
| 11 -> Some EC_POINT_FORMATS
| 13 -> Some SIGNATURE_ALGORITHMS
| 16 -> Some APPLICATION_LAYER_PROTOCOL_NEGOTIATION
| 21 -> Some PADDING
| 23 -> Some EXTENDED_MASTER_SECRET
| 35 -> Some SESSION_TICKET
| 41 -> Some PRE_SHARED_KEY
| 42 -> Some EARLY_DATA
| 43 -> Some SUPPORTED_VERSIONS
| 44 -> Some COOKIE
| 45 -> Some PSK_KEY_EXCHANGE_MODES
| 47 -> Some CERTIFICATE_AUTHORITIES
| 49 -> Some POST_HANDSHAKE_AUTH
| 51 -> Some KEY_SHARE
| 0xFF01 -> Some RENEGOTIATION_INFO
| _ -> None
let extension_type_to_string et = string_of_int (extension_type_to_int et)
(* TLS maximum fragment length *)
type max_fragment_length =
| TWO_9 [@id 1]
| TWO_10 [@id 2]
| TWO_11 [@id 3]
| TWO_12 [@id 4]
let max_fragment_length_to_int = function
| TWO_9 -> 1
| TWO_10 -> 2
| TWO_11 -> 3
| TWO_12 -> 4
and int_to_max_fragment_length = function
| 1 -> Some TWO_9
| 2 -> Some TWO_10
| 3 -> Some TWO_11
| 4 -> Some TWO_12
| _ -> None
(* TLS 1.3 pre-shared key mode (4.2.9) *)
type psk_key_exchange_mode =
| PSK_KE [@id 0]
| PSK_KE_DHE [@id 1]
let psk_key_exchange_mode_to_int = function
| PSK_KE -> 0
| PSK_KE_DHE -> 1
and int_to_psk_key_exchange_mode = function
| 0 -> Some PSK_KE
| 1 -> Some PSK_KE_DHE
| _ -> None
(* TLS 1.3 4.2.3 *)
type signature_alg =
| RSA_PKCS1_MD5 [@id 0x0101] (* deprecated, TLS 1.2 only *)
| RSA_PKCS1_SHA1 [@id 0x0201] (* deprecated, TLS 1.2 only *)
| RSA_PKCS1_SHA224 [@id 0x0301]
| RSA_PKCS1_SHA256 [@id 0x0401]
| RSA_PKCS1_SHA384 [@id 0x0501]
| RSA_PKCS1_SHA512 [@id 0x0601]
| ECDSA_SECP256R1_SHA1 [@id 0x0203] (* deprecated, TLS 1.2 only *)
| ECDSA_SECP256R1_SHA256 [@id 0x0403]
| ECDSA_SECP384R1_SHA384 [@id 0x0503]
| ECDSA_SECP521R1_SHA512 [@id 0x0603]
| RSA_PSS_RSAENC_SHA256 [@id 0x0804]
| RSA_PSS_RSAENC_SHA384 [@id 0x0805]
| RSA_PSS_RSAENC_SHA512 [@id 0x0806]
| ED25519 [@id 0x0807]
| ED448 [@id 0x0808]
| RSA_PSS_PSS_SHA256 [@id 0x0809]
| RSA_PSS_PSS_SHA384 [@id 0x080a]
| RSA_PSS_PSS_SHA512 [@id 0x080b]
(* private use 0xFE00 - 0xFFFF *)
let signature_alg_to_int = function
| RSA_PKCS1_MD5 -> 0x0101 (* deprecated, TLS 1.2 only *)
| RSA_PKCS1_SHA1 -> 0x0201 (* deprecated, TLS 1.2 only *)
| RSA_PKCS1_SHA224 -> 0x0301
| RSA_PKCS1_SHA256 -> 0x0401
| RSA_PKCS1_SHA384 -> 0x0501
| RSA_PKCS1_SHA512 -> 0x0601
| ECDSA_SECP256R1_SHA1 -> 0x0203 (* deprecated, TLS 1.2 only *)
| ECDSA_SECP256R1_SHA256 -> 0x0403
| ECDSA_SECP384R1_SHA384 -> 0x0503
| ECDSA_SECP521R1_SHA512 -> 0x0603
| RSA_PSS_RSAENC_SHA256 -> 0x0804
| RSA_PSS_RSAENC_SHA384 -> 0x0805
| RSA_PSS_RSAENC_SHA512 -> 0x0806
| ED25519 -> 0x0807
| ED448 -> 0x0808
| RSA_PSS_PSS_SHA256 -> 0x0809
| RSA_PSS_PSS_SHA384 -> 0x080a
| RSA_PSS_PSS_SHA512 -> 0x080b
(* private use 0xFE00 - 0xFFFF *)
and int_to_signature_alg = function
| 0x0101 -> Some RSA_PKCS1_MD5
| 0x0201 -> Some RSA_PKCS1_SHA1
| 0x0301 -> Some RSA_PKCS1_SHA224
| 0x0401 -> Some RSA_PKCS1_SHA256
| 0x0501 -> Some RSA_PKCS1_SHA384
| 0x0601 -> Some RSA_PKCS1_SHA512
| 0x0203 -> Some ECDSA_SECP256R1_SHA1
| 0x0403 -> Some ECDSA_SECP256R1_SHA256
| 0x0503 -> Some ECDSA_SECP384R1_SHA384
| 0x0603 -> Some ECDSA_SECP521R1_SHA512
| 0x0804 -> Some RSA_PSS_RSAENC_SHA256
| 0x0805 -> Some RSA_PSS_RSAENC_SHA384
| 0x0806 -> Some RSA_PSS_RSAENC_SHA512
| 0x0807 -> Some ED25519
| 0x0808 -> Some ED448
| 0x0809 -> Some RSA_PSS_PSS_SHA256
| 0x080a -> Some RSA_PSS_PSS_SHA384
| 0x080b -> Some RSA_PSS_PSS_SHA512
| _ -> None
let to_signature_alg = function
| `RSA_PKCS1_MD5 -> RSA_PKCS1_MD5
| `RSA_PKCS1_SHA1 -> RSA_PKCS1_SHA1
| `RSA_PKCS1_SHA224 -> RSA_PKCS1_SHA224
| `RSA_PKCS1_SHA256 -> RSA_PKCS1_SHA256
| `RSA_PKCS1_SHA384 -> RSA_PKCS1_SHA384
| `RSA_PKCS1_SHA512 -> RSA_PKCS1_SHA512
| `RSA_PSS_RSAENC_SHA256 -> RSA_PSS_RSAENC_SHA256
| `RSA_PSS_RSAENC_SHA384 -> RSA_PSS_RSAENC_SHA384
| `RSA_PSS_RSAENC_SHA512 -> RSA_PSS_RSAENC_SHA512
| `ECDSA_SECP256R1_SHA1 -> ECDSA_SECP256R1_SHA1
| `ECDSA_SECP256R1_SHA256 -> ECDSA_SECP256R1_SHA256
| `ECDSA_SECP384R1_SHA384 -> ECDSA_SECP384R1_SHA384
| `ECDSA_SECP521R1_SHA512 -> ECDSA_SECP521R1_SHA512
| `ED25519 -> ED25519
let of_signature_alg = function
| RSA_PKCS1_MD5 -> Some `RSA_PKCS1_MD5
| RSA_PKCS1_SHA1 -> Some `RSA_PKCS1_SHA1
| RSA_PKCS1_SHA224 -> Some `RSA_PKCS1_SHA224
| RSA_PKCS1_SHA256 -> Some `RSA_PKCS1_SHA256
| RSA_PKCS1_SHA384 -> Some `RSA_PKCS1_SHA384
| RSA_PKCS1_SHA512 -> Some `RSA_PKCS1_SHA512
| RSA_PSS_RSAENC_SHA256 -> Some `RSA_PSS_RSAENC_SHA256
| RSA_PSS_RSAENC_SHA384 -> Some `RSA_PSS_RSAENC_SHA384
| RSA_PSS_RSAENC_SHA512 -> Some `RSA_PSS_RSAENC_SHA512
| ECDSA_SECP256R1_SHA1 -> Some `ECDSA_SECP256R1_SHA1
| ECDSA_SECP256R1_SHA256 -> Some `ECDSA_SECP256R1_SHA256
| ECDSA_SECP384R1_SHA384 -> Some `ECDSA_SECP384R1_SHA384
| ECDSA_SECP521R1_SHA512 -> Some `ECDSA_SECP521R1_SHA512
| ED25519 -> Some `ED25519
| _ -> None
(* EC RFC4492*)
type ec_curve_type =
(* 1 and 2 are deprecated in RFC 8422 *)
| NAMED_CURVE [@id 3]
let ec_curve_type_to_int = function
| NAMED_CURVE -> 3
and int_to_ec_curve_type = function
| 3 -> Some NAMED_CURVE
| _ -> None
type named_group =
(* OBSOLETE_RESERVED 0x0001 - 0x0016 *)
| SECP256R1 [@id 23]
| SECP384R1 [@id 24]
| SECP521R1 [@id 25]
(* OBSOLETE_RESERVED 0x001A - 0x001C *)
| X25519 [@id 29] (*RFC8446*)
| X448 [@id 30] (*RFC8446*)
| FFDHE2048 [@id 256] (*RFC8446*)
| FFDHE3072 [@id 257] (*RFC8446*)
| FFDHE4096 [@id 258] (*RFC8446*)
| FFDHE6144 [@id 259] (*RFC8446*)
| FFDHE8192 [@id 260] (*RFC8446*)
(* FFDHE_PRIVATE_USE 0x01FC - 0x01FF *)
(* ECDHE_PRIVATE_USE 0xFE00 - 0xFEFF *)
(* OBSOLETE_RESERVED 0xFF01 - 0xFF02 *)
let named_group_to_int = function
| SECP256R1 -> 23
| SECP384R1 -> 24
| SECP521R1 -> 25
(* OBSOLETE_RESERVED 0x001A - 0x001C *)
| X25519 -> 29 (*RFC8446*)
| X448 -> 30 (*RFC8446*)
| FFDHE2048 -> 256 (*RFC8446*)
| FFDHE3072 -> 257 (*RFC8446*)
| FFDHE4096 -> 258 (*RFC8446*)
| FFDHE6144 -> 259 (*RFC8446*)
| FFDHE8192 -> 260 (*RFC8446*)
(* FFDHE_PRIVATE_USE 0x01FC - 0x01FF *)
(* ECDHE_PRIVATE_USE 0xFE00 - 0xFEFF *)
(* OBSOLETE_RESERVED 0xFF01 - 0xFF02 *)
and int_to_named_group = function
| 23 -> Some SECP256R1
| 24 -> Some SECP384R1
| 25 -> Some SECP521R1
| 29 -> Some X25519
| 30 -> Some X448
| 256 -> Some FFDHE2048
| 257 -> Some FFDHE3072
| 258 -> Some FFDHE4096
| 259 -> Some FFDHE6144
| 260 -> Some FFDHE8192
| _ -> None
(** enum of all TLS ciphersuites *)
type any_ciphersuite =
| TLS_RSA_WITH_3DES_EDE_CBC_SHA [@id 0x000A]
| TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA [@id 0x0016]
(* from RFC 3268 *)
| TLS_RSA_WITH_AES_128_CBC_SHA [@id 0x002F]
| TLS_DHE_RSA_WITH_AES_128_CBC_SHA [@id 0x0033]
| TLS_RSA_WITH_AES_256_CBC_SHA [@id 0x0035]
| TLS_DHE_RSA_WITH_AES_256_CBC_SHA [@id 0x0039]
(* from RFC 5246 *)
| TLS_RSA_WITH_AES_128_CBC_SHA256 [@id 0x003C]
| TLS_RSA_WITH_AES_256_CBC_SHA256 [@id 0x003D]
| TLS_DHE_RSA_WITH_AES_128_CBC_SHA256 [@id 0x0067]
| TLS_DHE_RSA_WITH_AES_256_CBC_SHA256 [@id 0x006B]
| TLS_RSA_WITH_AES_128_GCM_SHA256 [@id 0x009C] (*RFC5288*)
| TLS_RSA_WITH_AES_256_GCM_SHA384 [@id 0x009D] (*RFC5288*)
| TLS_DHE_RSA_WITH_AES_128_GCM_SHA256 [@id 0x009E] (*RFC5288*)
| TLS_DHE_RSA_WITH_AES_256_GCM_SHA384 [@id 0x009F] (*RFC5288*)
| TLS_EMPTY_RENEGOTIATION_INFO_SCSV [@id 0x00FF] (*RFC5746*)
| TLS_AES_128_GCM_SHA256 [@id 0x1301] (*RFC8446*)
| TLS_AES_256_GCM_SHA384 [@id 0x1302] (*RFC8446*)
| TLS_CHACHA20_POLY1305_SHA256 [@id 0x1303] (*RFC8446*)
| TLS_AES_128_CCM_SHA256 [@id 0x1304] (*RFC8446*)
| TLS_FALLBACK_SCSV [@id 0x5600] (*draft-ietf-tls-downgrade-scsv*)
(* from RFC 4492 *)
| TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA [@id 0xC008]
| TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA [@id 0xC009]
| TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA [@id 0xC00A]
| TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA [@id 0xC012]
| TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA [@id 0xC013]
| TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA [@id 0xC014]
| TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 [@id 0xC023] (*RFC5289*)
| TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 [@id 0xC024] (*RFC5289*)
| TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256 [@id 0xC027] (*RFC5289*)
| TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384 [@id 0xC028] (*RFC5289*)
| TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 [@id 0xC02B] (*RFC5289*)
| TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 [@id 0xC02C] (*RFC5289*)
| TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256 [@id 0xC02F] (*RFC5289*)
| TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384 [@id 0xC030] (*RFC5289*)
| TLS_RSA_WITH_AES_128_CCM [@id 0xC09C] (*RFC6655*)
| TLS_RSA_WITH_AES_256_CCM [@id 0xC09D] (*RFC6655*)
| TLS_DHE_RSA_WITH_AES_128_CCM [@id 0xC09E] (*RFC6655*)
| TLS_DHE_RSA_WITH_AES_256_CCM [@id 0xC09F] (*RFC6655*)
| TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 [@id 0xCCA8] (*RFC7905*)
| TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 [@id 0xCCA9] (*RFC7905*)
| TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 [@id 0xCCAA] (*RFC7905*)
let any_ciphersuite_to_int = function
| TLS_RSA_WITH_3DES_EDE_CBC_SHA -> 0x000A
| TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA -> 0x0016
| TLS_RSA_WITH_AES_128_CBC_SHA -> 0x002F
| TLS_DHE_RSA_WITH_AES_128_CBC_SHA -> 0x0033
| TLS_RSA_WITH_AES_256_CBC_SHA -> 0x0035
| TLS_DHE_RSA_WITH_AES_256_CBC_SHA -> 0x0039
| TLS_RSA_WITH_AES_128_CBC_SHA256 -> 0x003C
| TLS_RSA_WITH_AES_256_CBC_SHA256 -> 0x003D
| TLS_DHE_RSA_WITH_AES_128_CBC_SHA256 -> 0x0067
| TLS_DHE_RSA_WITH_AES_256_CBC_SHA256 -> 0x006B
| TLS_RSA_WITH_AES_128_GCM_SHA256 -> 0x009C (*RFC5288*)
| TLS_RSA_WITH_AES_256_GCM_SHA384 -> 0x009D (*RFC5288*)
| TLS_DHE_RSA_WITH_AES_128_GCM_SHA256 -> 0x009E (*RFC5288*)
| TLS_DHE_RSA_WITH_AES_256_GCM_SHA384 -> 0x009F (*RFC5288*)
| TLS_EMPTY_RENEGOTIATION_INFO_SCSV -> 0x00FF (*RFC5746*)
| TLS_AES_128_GCM_SHA256 -> 0x1301 (*RFC8446*)
| TLS_AES_256_GCM_SHA384 -> 0x1302 (*RFC8446*)
| TLS_CHACHA20_POLY1305_SHA256 -> 0x1303 (*RFC8446*)
| TLS_AES_128_CCM_SHA256 -> 0x1304 (*RFC8446*)
| TLS_FALLBACK_SCSV -> 0x5600 (*draft-ietf-tls-downgrade-scsv*)
| TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA -> 0xC008
| TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA -> 0xC009
| TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA -> 0xC00A
| TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA -> 0xC012
| TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA -> 0xC013
| TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA -> 0xC014
| TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 -> 0xC023 (*RFC5289*)
| TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 -> 0xC024 (*RFC5289*)
| TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256 -> 0xC027 (*RFC5289*)
| TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384 -> 0xC028 (*RFC5289*)
| TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 -> 0xC02B (*RFC5289*)
| TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 -> 0xC02C (*RFC5289*)
| TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256 -> 0xC02F (*RFC5289*)
| TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384 -> 0xC030 (*RFC5289*)
| TLS_RSA_WITH_AES_128_CCM -> 0xC09C (*RFC6655*)
| TLS_RSA_WITH_AES_256_CCM -> 0xC09D (*RFC6655*)
| TLS_DHE_RSA_WITH_AES_128_CCM -> 0xC09E (*RFC6655*)
| TLS_DHE_RSA_WITH_AES_256_CCM -> 0xC09F (*RFC6655*)
| TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> 0xCCA8 (*RFC7905*)
| TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 -> 0xCCA9 (*RFC7905*)
| TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> 0xCCAA (*RFC7905*)
and int_to_any_ciphersuite = function
| 0x000A -> Some TLS_RSA_WITH_3DES_EDE_CBC_SHA
| 0x0016 -> Some TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA
| 0x002F -> Some TLS_RSA_WITH_AES_128_CBC_SHA
| 0x0033 -> Some TLS_DHE_RSA_WITH_AES_128_CBC_SHA
| 0x0035 -> Some TLS_RSA_WITH_AES_256_CBC_SHA
| 0x0039 -> Some TLS_DHE_RSA_WITH_AES_256_CBC_SHA
| 0x003C -> Some TLS_RSA_WITH_AES_128_CBC_SHA256
| 0x003D -> Some TLS_RSA_WITH_AES_256_CBC_SHA256
| 0x0067 -> Some TLS_DHE_RSA_WITH_AES_128_CBC_SHA256
| 0x006B -> Some TLS_DHE_RSA_WITH_AES_256_CBC_SHA256
| 0x009C -> Some TLS_RSA_WITH_AES_128_GCM_SHA256
| 0x009D -> Some TLS_RSA_WITH_AES_256_GCM_SHA384
| 0x009E -> Some TLS_DHE_RSA_WITH_AES_128_GCM_SHA256
| 0x009F -> Some TLS_DHE_RSA_WITH_AES_256_GCM_SHA384
| 0x00FF -> Some TLS_EMPTY_RENEGOTIATION_INFO_SCSV
| 0x1301 -> Some TLS_AES_128_GCM_SHA256
| 0x1302 -> Some TLS_AES_256_GCM_SHA384
| 0x1303 -> Some TLS_CHACHA20_POLY1305_SHA256
| 0x1304 -> Some TLS_AES_128_CCM_SHA256
| 0x5600 -> Some TLS_FALLBACK_SCSV
| 0xC008 -> Some TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA
| 0xC009 -> Some TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA
| 0xC00A -> Some TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA
| 0xC012 -> Some TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA
| 0xC013 -> Some TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA
| 0xC014 -> Some TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA
| 0xC023 -> Some TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256
| 0xC024 -> Some TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384
| 0xC027 -> Some TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256
| 0xC028 -> Some TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384
| 0xC02B -> Some TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256
| 0xC02C -> Some TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384
| 0xC02F -> Some TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256
| 0xC030 -> Some TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384
| 0xC09C -> Some TLS_RSA_WITH_AES_128_CCM
| 0xC09D -> Some TLS_RSA_WITH_AES_256_CCM
| 0xC09E -> Some TLS_DHE_RSA_WITH_AES_128_CCM
| 0xC09F -> Some TLS_DHE_RSA_WITH_AES_256_CCM
| 0xCCA8 -> Some TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| 0xCCA9 -> Some TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256
| 0xCCAA -> Some TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| _ -> None
type key_update_request_type =
| UPDATE_NOT_REQUESTED [@id 0]
| UPDATE_REQUESTED [@id 1]
let key_update_request_type_to_int = function
| UPDATE_NOT_REQUESTED -> 0
| UPDATE_REQUESTED -> 1
and int_to_key_update_request_type = function
| 0 -> Some UPDATE_NOT_REQUESTED
| 1 -> Some UPDATE_REQUESTED
| _ -> None
let helloretryrequest = Digestif.SHA256.(to_raw_string (digest_string "HelloRetryRequest"))
let downgrade12 = "\x44\x4F\x57\x4E\x47\x52\x44\x01"
let downgrade11 = "\x44\x4F\x57\x4E\x47\x52\x44\x00"

815
unikernel/duniverse/ocaml-tls/lib/reader.ml Normal file
View file

@ -0,0 +1,815 @@
open Packet
open Core
type error =
| TrailingBytes of string
| WrongLength of string
| Unknown of string
exception Reader_error of error
let raise_unknown msg = raise (Reader_error (Unknown msg))
and raise_wrong_length msg = raise (Reader_error (WrongLength msg))
and raise_trailing_bytes msg = raise (Reader_error (TrailingBytes msg))
let shift str amount = String.sub str amount (String.length str - amount)
let catch f x =
try Ok (f x) with
| Reader_error TrailingBytes msg -> Error (`Decode ("trailing bytes: " ^ msg))
| Reader_error WrongLength msg -> Error (`Decode ("wrong length: " ^ msg))
| Reader_error Unknown msg -> Error (`Decode msg)
| Invalid_argument msg -> Error (`Decode msg)
let parse_version_int buf =
let major = String.get_uint8 buf 0 in
let minor = String.get_uint8 buf 1 in
(major, minor)
let parse_version_exn buf =
let version = parse_version_int buf in
match tls_version_of_pair version with
| Some x -> x
| None -> raise_unknown "version"
let parse_any_version_opt buf =
let version = parse_version_int buf in
tls_any_version_of_pair version, shift buf 2
let parse_any_version_exn buf =
match parse_any_version_opt buf with
| Some x, _ -> x
| None, _ -> raise_unknown "version"
let parse_version = catch parse_version_exn
let parse_any_version = catch parse_any_version_exn
let parse_record buf =
if String.length buf < 5 then
Ok (`Fragment buf)
else
let typ = String.get_uint8 buf 0
and version = parse_version_int (shift buf 1)
in
match String.get_uint16_be buf 3 with
| x when x > (1 lsl 14 + 2048) ->
(* 2 ^ 14 + 2048 for TLSCiphertext
2 ^ 14 + 1024 for TLSCompressed
2 ^ 14 for TLSPlaintext *)
Error (`Record_overflow x)
| x when 5 + x > String.length buf -> Ok (`Fragment buf)
| x ->
match
tls_any_version_of_pair version,
int_to_content_type typ
with
| None, _ -> Error (`Protocol_version (`Unknown_record version))
| _, None -> Error (`Unexpected (`Content_type typ))
| Some version, Some content_type ->
let payload, rest = split_str ~start:5 buf x in
Ok (`Record (({ content_type ; version }, payload), rest))
let validate_alert (lvl, typ) =
let open Packet in
match lvl, typ with
(* from RFC, find out which ones must be always FATAL
and report if this does not meet the expectations *)
| WARNING, (UNEXPECTED_MESSAGE | BAD_RECORD_MAC | RECORD_OVERFLOW
| HANDSHAKE_FAILURE | BAD_CERTIFICATE | DECODE_ERROR
| PROTOCOL_VERSION | INAPPROPRIATE_FALLBACK | MISSING_EXTENSION
| UNSUPPORTED_EXTENSION | UNRECOGNIZED_NAME |
NO_APPLICATION_PROTOCOL as x) ->
raise_unknown (alert_type_to_string x ^ " must always be fatal")
(* those are always warnings *)
| FATAL, (USER_CANCELED | NO_RENEGOTIATION as x) ->
raise_unknown (alert_type_to_string x ^ " must always be a warning")
| lvl, typ -> (lvl, typ)
let parse_alert = catch @@ fun buf ->
if String.length buf <> 2 then
raise_trailing_bytes "after alert"
else
let level = String.get_uint8 buf 0 in
let typ = String.get_uint8 buf 1 in
match int_to_alert_level level, int_to_alert_type typ with
| (Some lvl, msg) -> validate_alert (lvl, msg)
| _ -> raise_unknown @@ "alert level " ^ string_of_int level
let parse_change_cipher_spec buf =
match String.length buf, String.get_uint8 buf 0 with
| 1, 1 -> Ok ()
| _ -> Error (`Decode "bad change cipher spec message")
let rec parse_count_list parsef buf acc = function
| 0 -> (List.rev acc, buf)
| n ->
match parsef buf with
| Some elem, buf' -> parse_count_list parsef buf' (elem :: acc) (pred n)
| None , buf' -> parse_count_list parsef buf' acc (pred n)
let rec parse_list parsef buf acc =
match String.length buf with
| 0 -> List.rev acc
| _ ->
match parsef buf with
| Some elem, buf' -> parse_list parsef buf' (elem :: acc)
| None , buf' -> parse_list parsef buf' acc
let parse_compression_method buf =
let cm = String.get_uint8 buf 0 in
(int_to_compression_method cm, shift buf 1)
let parse_compression_methods buf =
let count = String.get_uint8 buf 0 in
parse_count_list parse_compression_method (shift buf 1) [] count
let parse_any_ciphersuite buf =
let typ = String.get_uint16_be buf 0 in
(int_to_any_ciphersuite typ, shift buf 2)
let parse_any_ciphersuites buf =
let count = String.get_uint16_be buf 0 in
if count mod 2 <> 0 then
raise_wrong_length "ciphersuite list"
else
parse_count_list parse_any_ciphersuite (shift buf 2) [] (count / 2)
let parse_ciphersuite buf =
match parse_any_ciphersuite buf with
| None , buf' -> (None, buf')
| Some cs, buf' -> match Ciphersuite.any_ciphersuite_to_ciphersuite cs with
| None -> (None, buf')
| Some cs' -> (Some cs', buf')
let parse_hostnames buf =
match String.length buf with
| 0 -> []
| n ->
let parsef buf =
let typ = String.get_uint8 buf 0 in
let entrylen = String.get_uint16_be buf 1 in
let rt = shift buf (3 + entrylen) in
match typ with
| 0 -> let hostname = String.sub buf 3 entrylen in
(Some hostname, rt)
| _ -> (None, rt)
in
let list_length = String.get_uint16_be buf 0 in
if list_length + 2 <> n then
raise_trailing_bytes "hostname"
else
parse_list parsef (String.sub buf 2 list_length) []
let parse_fragment_length buf =
if String.length buf <> 1 then
raise_trailing_bytes "fragment length"
else
int_to_max_fragment_length (String.get_uint8 buf 0)
let parse_supported_version buf =
parse_any_version_opt buf
let parse_supported_versions buf =
let len = String.get_uint8 buf 0 in
if len mod 2 <> 0 then
raise_wrong_length "supported versions"
else
parse_count_list parse_supported_version (shift buf 1) [] (len / 2)
let parse_named_group buf =
let typ = String.get_uint16_be buf 0 in
(int_to_named_group typ, shift buf 2)
let parse_group buf =
match parse_named_group buf with
| Some x, buf -> (named_group_to_group x, buf)
| None, buf -> (None, buf)
let parse_supported_groups buf =
let count = String.get_uint16_be buf 0 in
if count mod 2 <> 0 then
raise_wrong_length "elliptic curve list"
else
let cs, rt = parse_count_list parse_named_group (shift buf 2) [] (count / 2) in
if String.length rt <> 0 then
raise_trailing_bytes "elliptic curves"
else
cs
let parse_signature_algorithm buf =
match int_to_signature_alg (String.get_uint16_be buf 0) with
| Some sig_alg -> of_signature_alg sig_alg
| _ -> None
let parse_signature_algorithms buf =
let parsef buf = parse_signature_algorithm buf, shift buf 2 in
let count = String.get_uint16_be buf 0 in
if count mod 2 <> 0 then
raise_wrong_length "signature hash"
else
parse_count_list parsef (shift buf 2) [] (count / 2)
let parse_alpn_protocol raw =
let length = String.get_uint8 raw 0 in
let protocol = String.sub raw 1 length in
(Some protocol, shift raw (1 + length))
let parse_alpn_protocols buf =
let len = String.get_uint16_be buf 0 in
if String.length buf <> len + 2 then
raise_trailing_bytes "alpn"
else
parse_list parse_alpn_protocol (String.sub buf 2 len) []
let parse_ec_point_format buf =
(* this is deprecated, we only check that uncompressed (typ 0) is present *)
let data = String.get_uint8 buf 0 in
Some (data = 0), shift buf 1
let parse_ec_point_formats buf =
let count = String.get_uint8 buf 0 in
parse_count_list parse_ec_point_format (shift buf 1) [] count
let parse_extension buf = function
| MAX_FRAGMENT_LENGTH ->
(match parse_fragment_length buf with
| Some mfl -> `MaxFragmentLength mfl
| None -> raise_unknown "maximum fragment length")
| RENEGOTIATION_INFO ->
let len' = String.get_uint8 buf 0 in
if String.length buf <> len' + 1 then
raise_trailing_bytes "renegotiation"
else
`SecureRenegotiation (String.sub buf 1 len')
| EXTENDED_MASTER_SECRET ->
if String.length buf > 0 then
raise_trailing_bytes "extended master secret"
else
`ExtendedMasterSecret
| EC_POINT_FORMATS ->
let formats, rt = parse_ec_point_formats buf in
if String.length rt <> 0 then
raise_trailing_bytes "ec point formats"
else if List.mem true formats then
`ECPointFormats
else
raise_unknown "EC Point Formats without uncompressed"
| x -> `UnknownExtension (extension_type_to_int x, buf)
let parse_keyshare_entry buf =
let parse_share data =
let size = String.get_uint16_be data 0 in
split_str ~start:2 data size
in
let g, rest = parse_named_group buf in
let share, left = parse_share rest in
match g with
| None -> None, left
| Some g -> Some (g, share), left
let parse_id buf =
let id_len = String.get_uint16_be buf 0 in
if id_len = 0 then (* id must be non-empty! *)
raise_wrong_length "PSK id is empty"
else
let age = String.get_int32_be buf (id_len + 2) in
(Some (String.sub buf 2 id_len, age), shift buf (id_len + 6))
let parse_binder buf =
let l = String.get_uint8 buf 0 in
Some (String.sub buf 1 l), shift buf (l + 1)
let parse_client_presharedkeys buf =
let id_len = String.get_uint16_be buf 0 in
let identities = parse_list parse_id (String.sub buf 2 id_len) [] in
let binders_len = String.get_uint16_be buf (id_len + 2) in
let binders = parse_list parse_binder (String.sub buf (4 + id_len) binders_len) [] in
let id_binder = List.combine identities binders in
if String.length buf <> 4 + binders_len + id_len then
raise_trailing_bytes "psk"
else
id_binder
let parse_cookie buf =
let len = String.get_uint16_be buf 0 in
(String.sub buf 2 len, shift buf (2 + len))
let parse_psk_key_exchange_mode buf =
let data = String.get_uint8 buf 0 in
(int_to_psk_key_exchange_mode data, shift buf 1)
let parse_psk_key_exchange_modes buf =
let count = String.get_uint8 buf 0 in
parse_count_list parse_psk_key_exchange_mode (shift buf 1) [] count
let parse_ext raw =
let etype = String.get_uint16_be raw 0
and length = String.get_uint16_be raw 2
in
(etype, length, String.sub raw 4 length)
let parse_client_extension raw =
let etype, len, buf = parse_ext raw in
let data =
match int_to_extension_type etype with
| Some SERVER_NAME ->
(match parse_hostnames buf with
| [name] ->
(match Domain_name.of_string name with
| Error (`Msg err) ->
raise_unknown ("unable to canonicalize " ^ name ^ "into a domain name: " ^ err)
| Ok domain_name ->
(match Domain_name.host domain_name with
| Error (`Msg err) ->
raise_unknown ("unable to build a hostname from " ^ name ^ ": " ^ err)
| Ok hostname -> `Hostname hostname))
| _ -> raise_unknown "bad server name indication (multiple names)")
| Some SUPPORTED_GROUPS ->
let gs = parse_supported_groups buf in
`SupportedGroups gs
| Some PADDING ->
let rec check = function
| 0 -> `Padding len
| n -> let idx = pred n in
if String.get_uint8 buf idx <> 0 then
raise_unknown "bad padding in padding extension"
else
check idx
in
check len
| Some SIGNATURE_ALGORITHMS ->
let algos, rt = parse_signature_algorithms buf in
if String.length rt <> 0 then
raise_trailing_bytes "signature algorithms"
else
`SignatureAlgorithms algos
| Some APPLICATION_LAYER_PROTOCOL_NEGOTIATION ->
let protocols = parse_alpn_protocols buf in
`ALPN protocols
| Some KEY_SHARE ->
let ll = String.get_uint16_be buf 0 in
if ll + 2 <> String.length buf then
raise_unknown "bad key share extension"
else
let shares = parse_list parse_keyshare_entry (String.sub buf 2 ll) [] in
`KeyShare shares
| Some PRE_SHARED_KEY ->
let ids = parse_client_presharedkeys buf in
`PreSharedKeys ids
| Some EARLY_DATA ->
if String.length buf <> 0 then
raise_trailing_bytes "early data"
else
`EarlyDataIndication
| Some SUPPORTED_VERSIONS ->
let versions, rt = parse_supported_versions buf in
if String.length rt <> 0 then
raise_trailing_bytes "supported versions"
else
`SupportedVersions versions
| Some POST_HANDSHAKE_AUTH ->
if String.length buf = 0 then
`PostHandshakeAuthentication
else
raise_unknown "non-empty post handshake authentication"
| Some COOKIE ->
let c, rt = parse_cookie buf in
if String.length rt <> 0 then
raise_trailing_bytes "cookie"
else
`Cookie c
| Some PSK_KEY_EXCHANGE_MODES ->
let modes, rt = parse_psk_key_exchange_modes buf in
if String.length rt <> 0 then
raise_trailing_bytes "psk key exchange modes"
else
`PskKeyExchangeModes modes
| Some x -> parse_extension buf x
| None -> `UnknownExtension (etype, buf)
in
(Some data, shift raw (4 + len))
let parse_server_extension raw =
let etype, len, buf = parse_ext raw in
let data =
match int_to_extension_type etype with
| Some SERVER_NAME ->
(match parse_hostnames buf with
| [] -> `Hostname
| _ -> raise_unknown "bad server name indication (multiple names)")
| Some KEY_SHARE ->
(match parse_keyshare_entry buf with
| _, xs when String.length xs <> 0 -> raise_trailing_bytes "server keyshare"
| None, _ -> raise_unknown "keyshare entry"
| Some (g, ks), _ ->
match named_group_to_group g with
| Some g -> `KeyShare (g, ks)
| None -> raise_unknown "keyshare entry")
| Some PRE_SHARED_KEY ->
if String.length buf <> 2 then
raise_trailing_bytes "server pre_shared_key"
else
`PreSharedKey (String.get_uint16_be buf 0)
| Some SUPPORTED_GROUPS | Some SIGNATURE_ALGORITHMS | Some PADDING ->
raise_unknown "invalid extension in server hello!"
| Some APPLICATION_LAYER_PROTOCOL_NEGOTIATION ->
(match parse_alpn_protocols buf with
| [protocol] -> `ALPN protocol
| _ -> raise_unknown "bad ALPN (none or multiple names)")
| Some SUPPORTED_VERSIONS ->
let version = parse_version_exn buf in
`SelectedVersion version
| Some x -> parse_extension buf x
| None -> `UnknownExtension (etype, buf)
in
(Some data, shift raw (4 + len))
let parse_encrypted_extension raw =
let etype, len, buf = parse_ext raw in
let data =
match int_to_extension_type etype with
| Some SERVER_NAME ->
(match parse_hostnames buf with
| [] -> `Hostname
| _ -> raise_unknown "bad server name indication (multiple names)")
| Some SUPPORTED_GROUPS ->
let gs = parse_supported_groups buf in
let supported = List.filter_map named_group_to_group gs in
`SupportedGroups supported
| Some APPLICATION_LAYER_PROTOCOL_NEGOTIATION ->
(match parse_alpn_protocols buf with
| [protocol] -> `ALPN protocol
| _ -> raise_unknown "bad ALPN (none or multiple names)")
| Some EARLY_DATA ->
if String.length buf <> 0 then
raise_trailing_bytes "server early_data"
else
`EarlyDataIndication
| Some x -> raise_unknown ("bad encrypted extension " ^ (extension_type_to_string x)) (* TODO maybe unknown instead? *)
| None -> `UnknownExtension (etype, buf)
in
(Some data, shift raw (4 + len))
let parse_retry_extension raw =
let etype, len, buf = parse_ext raw in
let data =
match int_to_extension_type etype with
| Some KEY_SHARE ->
begin
let group, rt = parse_group buf in
if String.length rt <> 0 then
raise_trailing_bytes "key share"
else
match group with
| None -> raise_unknown "unknown group in key share"
| Some g -> `SelectedGroup g
end
| Some SUPPORTED_VERSIONS ->
let version = parse_version_exn buf in
`SelectedVersion version
| Some COOKIE ->
let c, rt = parse_cookie buf in
if String.length rt <> 0 then
raise_trailing_bytes "cookie"
else
`Cookie c
| _ -> `UnknownExtension (etype, buf)
in
(Some data, shift raw (4 + len))
let parse_extensions parse_ext buf =
let len = String.get_uint16_be buf 0 in
if String.length buf <> len + 2 then
raise_trailing_bytes "extensions"
else
parse_list parse_ext (String.sub buf 2 len) []
let parse_client_hello buf =
let client_version = parse_any_version_exn buf in
let client_random = String.sub buf 2 32 in
let slen = String.get_uint8 buf 34 in
let sessionid = if slen = 0 then None else Some (String.sub buf 35 slen) in
let ciphersuites, rt = parse_any_ciphersuites (shift buf (35 + slen)) in
let _, rt' = parse_compression_methods rt in
let extensions =
if String.length rt' = 0 then [] else parse_extensions parse_client_extension rt'
in
(* TLS 1.3 mandates PreSharedKeys to be the last extension *)
(if List.exists (function `PreSharedKeys _ -> true | _ -> false) extensions then
match List.rev extensions with
| `PreSharedKeys _::_ -> ()
| _ -> raise_unknown "Pre-shared key extension exists, but is not the last");
ClientHello { client_version ; client_random ; sessionid ; ciphersuites ; extensions }
let parse_server_hello buf =
let server_version = parse_version_exn buf in
let server_random = String.sub buf 2 32 in
let slen = String.get_uint8 buf 34 in
let sessionid = if slen = 0 then None else Some (String.sub buf 35 slen) in
let ciphersuite, rt = match parse_ciphersuite (shift buf (35 + slen)) with
| Some x, buf' -> (x, buf')
| None , _ -> raise_unknown "ciphersuite"
in
let rt' = match parse_compression_method rt with
| Some NULL, buf' -> buf'
| None , _ -> raise_unknown "compression method"
in
(* depending on the content of the server_random we have to diverge in behaviour *)
if String.equal server_random helloretryrequest then begin
(* hello retry request, TODO: verify compression=empty *)
match Ciphersuite.ciphersuite_to_ciphersuite13 ciphersuite with
| None -> raise_unknown "unsupported ciphersuite in hello retry request"
| Some ciphersuite ->
let extensions =
if String.length rt' = 0 then [] else parse_extensions parse_retry_extension rt'
in
let retry_version =
match Utils.map_find ~f:(function `SelectedVersion v -> Some v | _ -> None) extensions with
| None -> server_version
| Some v -> v
in
let selected_group =
match Utils.map_find ~f:(function `SelectedGroup g -> Some g | _ -> None) extensions with
| None -> raise_unknown "unknown selected group"
| Some g -> g
in
HelloRetryRequest { retry_version ; sessionid ; ciphersuite ; selected_group ; extensions }
end else begin
let extensions =
if String.length rt' = 0 then [] else parse_extensions parse_server_extension rt'
in
let server_version =
match Utils.map_find ~f:(function `SelectedVersion v -> Some v | _ -> None) extensions with
| None -> server_version
| Some v -> v
in
ServerHello { server_version ; server_random ; sessionid ; ciphersuite ; extensions }
end
let parse_certificates_exn buf =
let parsef buf =
let len = get_uint24_len ~off:0 buf in
(Some (String.sub buf 3 len), shift buf (len + 3))
in
let len = get_uint24_len ~off:0 buf in
if String.length buf <> len + 3 then
raise_trailing_bytes "certificates"
else
parse_list parsef (String.sub buf 3 len) []
let parse_certificates = catch @@ parse_certificates_exn
(* TODO finish implementation of certificate extensions *)
let parse_certificate_ext _ = None, ""
let parse_certificate_ext_1_3_exn buf =
let certlen = get_uint24_len ~off:0 buf in
let cert, extbuf, rest =
let cert, rt = split_str ~start:3 buf certlen in
let ext_len = String.get_uint16_be rt 0 in
let extbuf, rt = split_str ~start:2 rt ext_len in
cert, extbuf, rt
in
let exts = parse_list parse_certificate_ext extbuf [] in
(Some (cert, exts), rest)
let parse_certificate_ext_list_1_3_exn buf =
let len = get_uint24_len ~off:0 buf in
if String.length buf <> len + 3 then
raise_trailing_bytes "certificates"
else
parse_list parse_certificate_ext_1_3_exn (shift buf 3) []
let parse_certificates_1_3_exn buf =
let clen = String.get_uint8 buf 0 in
let context, rt = split_str ~start:1 buf clen in
let certs = parse_certificate_ext_list_1_3_exn rt in
(context, certs)
let parse_certificates_1_3 = catch @@ parse_certificates_1_3_exn
let parse_certificate_types buf =
let parsef buf =
let byte = String.get_uint8 buf 0 in
(int_to_client_certificate_type byte, shift buf 1)
in
let count = String.get_uint8 buf 0 in
parse_count_list parsef (shift buf 1) [] count
let parse_cas buf =
let parsef buf =
let length = String.get_uint16_be buf 0 in
let name = String.sub buf 2 length in
(Some name, shift buf (2 + length))
in
let calength = String.get_uint16_be buf 0 in
let cas, rt = split_str ~start:2 buf calength in
(parse_list parsef cas [], rt)
let parse_certificate_request_exn buf =
let certificate_types, buf' = parse_certificate_types buf in
let certificate_authorities, buf' = parse_cas buf' in
if String.length buf' <> 0 then
raise_trailing_bytes "certificate request"
else
(certificate_types, certificate_authorities)
let parse_certificate_request =
catch parse_certificate_request_exn
let parse_certificate_request_1_2_exn buf =
let certificate_types, buf' = parse_certificate_types buf in
let sigs, buf' = parse_signature_algorithms buf' in
let cas, buf' = parse_cas buf' in
if String.length buf' <> 0 then
raise_trailing_bytes "certificate request"
else
(certificate_types, sigs, cas)
let parse_certificate_request_1_2 =
catch parse_certificate_request_1_2_exn
let parse_certificate_request_extension raw =
let etype, len, buf = parse_ext raw in
let data = match int_to_extension_type etype with
| Some SIGNATURE_ALGORITHMS ->
let algos, rt = parse_signature_algorithms buf in
if String.length rt <> 0 then
raise_trailing_bytes "signature algorithms"
else
`SignatureAlgorithms algos
| Some CERTIFICATE_AUTHORITIES ->
let cas, rt = parse_cas buf in
if String.length rt <> 0 then
raise_trailing_bytes "certificate authorities"
else
let cas = List.fold_left (fun cas buf ->
match X509.Distinguished_name.decode_der buf with
| Ok ca -> ca :: cas
| Error _ -> cas)
[] cas
in
`CertificateAuthorities (List.rev cas)
| _ -> `UnknownExtension (etype, buf)
in
(Some data, shift raw (4 + len))
let parse_certificate_request_1_3_exn buf =
let contextlen = String.get_uint8 buf 0 in
let context, rt =
if contextlen = 0 then
None, shift buf 1
else
let ctx, rest = split_str ~start:1 buf contextlen in
Some ctx, rest
in
let exts = parse_extensions parse_certificate_request_extension rt in
(context, exts)
let parse_certificate_request_1_3 =
catch parse_certificate_request_1_3_exn
let parse_dh_parameters = catch @@ fun raw ->
let plength = String.get_uint16_be raw 0 in
let dh_p = String.sub raw 2 plength in
let buf = shift raw (2 + plength) in
let glength = String.get_uint16_be buf 0 in
let dh_g = String.sub buf 2 glength in
let buf = shift buf (2 + glength) in
let yslength = String.get_uint16_be buf 0 in
let dh_Ys = String.sub buf 2 yslength in
let buf = shift buf (2 + yslength) in
let rawparams = String.sub raw 0 (plength + glength + yslength + 6) in
({ dh_p ; dh_g ; dh_Ys }, rawparams, buf)
let parse_ec_parameters = catch @@ fun raw ->
if String.get_uint8 raw 0 <> ec_curve_type_to_int NAMED_CURVE then
raise_unknown "EC curve type"
else
match int_to_named_group (String.get_uint16_be raw 1) with
| Some g ->
begin match named_group_to_group g with
| Some ((`X25519 | `P256 | `P384 | `P521) as g) ->
let data_len = String.get_uint8 raw 3 in
let d, rest = split_str ~start:4 raw data_len in
g, d, String.sub raw 0 (data_len + 4), rest
| _ -> raise_unknown "EC group"
end
| None -> raise_unknown "EC named group"
let parse_digitally_signed_exn buf =
let siglen = String.get_uint16_be buf 0 in
if String.length buf <> siglen + 2 then
raise_trailing_bytes "digitally signed"
else
String.sub buf 2 siglen
let parse_digitally_signed =
catch parse_digitally_signed_exn
let parse_digitally_signed_1_2 = catch @@ fun buf ->
match parse_signature_algorithm buf with
| Some sig_alg ->
let signature = parse_digitally_signed_exn (shift buf 2) in
(sig_alg, signature)
| None -> raise_unknown "hash or signature algorithm"
let parse_session_ticket_extension raw =
let etype, len, buf = parse_ext raw in
let data = match int_to_extension_type etype with
| Some EARLY_DATA ->
if String.length buf <> 4 then
raise_unknown "bad early_data extension in session ticket"
else
let size = String.get_int32_be buf 0 in
`EarlyDataIndication size
| _ -> `UnknownExtension (etype, buf)
in
(Some data, shift raw (4 + len))
let parse_session_ticket buf =
let lifetime = String.get_int32_be buf 0
and age_add = String.get_int32_be buf 4
and nonce_len = String.get_uint8 buf 8
in
let nonce = String.sub buf 9 nonce_len in
let ticket_len = String.get_uint16_be buf (9 + nonce_len) in
let ticket, exts_buf = split_str ~start:(11 + nonce_len) buf ticket_len in
let extensions = parse_extensions parse_session_ticket_extension exts_buf in
{ lifetime ; age_add ; nonce ; ticket ; extensions }
let parse_client_dh_key_exchange_exn buf =
let len = String.get_uint16_be buf 0 in
if String.length buf <> len + 2 then
raise_trailing_bytes "client key exchange"
else
String.sub buf 2 len
let parse_client_dh_key_exchange = catch parse_client_dh_key_exchange_exn
let parse_client_ec_key_exchange_exn buf =
let len = String.get_uint8 buf 0 in
if String.length buf <> len + 1 then
raise_trailing_bytes "client key exchange"
else
String.sub buf 1 len
let parse_client_ec_key_exchange = catch parse_client_ec_key_exchange_exn
let parse_keyupdate buf =
if String.length buf <> 1 then
raise_trailing_bytes "key update"
else
match int_to_key_update_request_type (String.get_uint8 buf 0) with
| Some y -> y
| None -> raise_unknown "key update content"
let parse_handshake_frame buf =
if String.length buf < 4 then
(None, buf)
else
let l = get_uint24_len ~off:1 buf in
let hslen = l + 4 in
if String.length buf >= hslen then
let hs, rest = split_str buf hslen in
(Some hs, rest)
else
(None, buf)
let parse_handshake = catch @@ fun buf ->
let typ = String.get_uint8 buf 0 in
let handshake_type = int_to_handshake_type typ in
let len = get_uint24_len ~off:1 buf in
if String.length buf <> len + 4 then
raise_trailing_bytes "handshake"
else
let payload = String.sub buf 4 len in
match handshake_type with
| Some HELLO_REQUEST ->
if String.length payload = 0 then HelloRequest else raise_trailing_bytes "hello request"
| Some CLIENT_HELLO -> parse_client_hello payload
| Some SERVER_HELLO -> parse_server_hello payload
| Some CERTIFICATE -> Certificate payload
| Some CERTIFICATE_VERIFY -> CertificateVerify payload
| Some SERVER_KEY_EXCHANGE -> ServerKeyExchange payload
| Some SERVER_HELLO_DONE ->
if String.length payload = 0 then ServerHelloDone else raise_trailing_bytes "server hello done"
| Some CERTIFICATE_REQUEST -> CertificateRequest payload
| Some CLIENT_KEY_EXCHANGE -> ClientKeyExchange payload
| Some FINISHED -> Finished payload
| Some ENCRYPTED_EXTENSIONS ->
let ee = parse_extensions parse_encrypted_extension payload in
EncryptedExtensions ee
| Some KEY_UPDATE ->
let ku = parse_keyupdate payload in
KeyUpdate ku
| Some SESSION_TICKET ->
let ticket = parse_session_ticket payload in
SessionTicket ticket
| Some END_OF_EARLY_DATA ->
EndOfEarlyData
| Some _
| None -> raise_unknown @@ "handshake type" ^ string_of_int typ

31
unikernel/duniverse/ocaml-tls/lib/reader.mli Normal file
View file

@ -0,0 +1,31 @@
val parse_version : string -> (Core.tls_version, [> `Decode of string ]) result
val parse_any_version : string -> (Core.tls_any_version, [> `Decode of string ]) result
val parse_record : string ->
([ `Record of (Core.tls_hdr * string) * string
| `Fragment of string
], [> `Unexpected of [> `Content_type of int ]
| `Protocol_version of [> `Unknown_record of int * int ]
| `Record_overflow of int ]) result
val parse_handshake_frame : string -> (string option * string)
val parse_handshake : string -> (Core.tls_handshake, [> `Decode of string ]) result
val parse_alert : string -> (Core.tls_alert, [> `Decode of string ]) result
val parse_change_cipher_spec : string -> (unit, [> `Decode of string ]) result
val parse_certificate_request : string -> (Packet.client_certificate_type list * string list, [> `Decode of string ]) result
val parse_certificate_request_1_2 : string -> (Packet.client_certificate_type list * Core.signature_algorithm list * string list, [> `Decode of string ]) result
val parse_certificate_request_1_3 : string -> (string option * Core.certificate_request_extension list, [> `Decode of string ]) result
val parse_certificates : string -> (string list, [> `Decode of string ]) result
val parse_certificates_1_3 : string -> (string * (string * 'a list) list, [> `Decode of string ]) result
val parse_client_dh_key_exchange : string -> (string, [> `Decode of string ]) result
val parse_client_ec_key_exchange : string -> (string, [> `Decode of string ]) result
val parse_dh_parameters : string -> (Core.dh_parameters * string * string, [> `Decode of string ]) result
val parse_ec_parameters : string -> ([ `X25519 | `P256 | `P384 | `P521 ] * string * string * string, [> `Decode of string ]) result
val parse_digitally_signed : string -> (string, [> `Decode of string ]) result
val parse_digitally_signed_1_2 : string -> (Core.signature_algorithm * string, [> `Decode of string ]) result

352
unikernel/duniverse/ocaml-tls/lib/state.ml Normal file
View file

@ -0,0 +1,352 @@
(* Defines all high-level datatypes for the TLS library. It is opaque to clients
of this library, and only used from within the library. *)
open Core
open Mirage_crypto
type hmac_key = string
(* initialisation vector style, depending on TLS version *)
type iv_mode =
| Iv of string (* traditional CBC (reusing last cipherblock) *)
| Random_iv (* TLS 1.1 and higher explicit IV (we use random) *)
type 'k cbc_cipher = (module Block.CBC with type key = 'k)
type 'k cbc_state = {
cipher : 'k cbc_cipher ;
cipher_secret : 'k ;
iv_mode : iv_mode ;
hmac : Digestif.hash' ;
hmac_secret : hmac_key
}
type nonce = string
type 'k aead_cipher = (module AEAD with type key = 'k)
type 'k aead_state = {
cipher : 'k aead_cipher ;
cipher_secret : 'k ;
nonce : nonce ;
explicit_nonce : bool ; (* RFC 7905: no explicit nonce, instead TLS 1.3 construction is adapted *)
}
(* state of a symmetric cipher *)
type cipher_st =
| CBC : 'k cbc_state -> cipher_st
| AEAD : 'k aead_state -> cipher_st
(* context of a TLS connection (both in and out has each one of these) *)
type crypto_context = {
sequence : int64 ; (* sequence number *)
cipher_st : cipher_st ; (* cipher state *)
}
(* the raw handshake log we need to carry around *)
type hs_log = string list
type dh_secret = [
| `Finite_field of Mirage_crypto_pk.Dh.secret
| `P256 of Mirage_crypto_ec.P256.Dh.secret
| `P384 of Mirage_crypto_ec.P384.Dh.secret
| `P521 of Mirage_crypto_ec.P521.Dh.secret
| `X25519 of Mirage_crypto_ec.X25519.secret
]
(* a collection of client and server verify bytes for renegotiation *)
type reneg_params = string * string
type common_session_data = {
server_random : string ; (* 32 bytes random from the server hello *)
client_random : string ; (* 32 bytes random from the client hello *)
peer_certificate_chain : X509.Certificate.t list ;
peer_certificate : X509.Certificate.t option ;
trust_anchor : X509.Certificate.t option ;
received_certificates : X509.Certificate.t list ;
own_certificate : X509.Certificate.t list ;
own_private_key : X509.Private_key.t option ;
own_name : [`host] Domain_name.t option ;
client_auth : bool ;
master_secret : master_secret ;
alpn_protocol : string option ; (* selected alpn protocol after handshake *)
}
type session_data = {
common_session_data : common_session_data ;
client_version : tls_any_version ; (* version in client hello (needed in RSA client key exchange) *)
ciphersuite : Ciphersuite.ciphersuite ;
group : group option ;
renegotiation : reneg_params ; (* renegotiation data *)
session_id : string ;
extended_ms : bool ;
tls_unique : string ;
}
(* state machine of the server *)
type server_handshake_state =
| AwaitClientHello (* initial state *)
| AwaitClientHelloRenegotiate
| AwaitClientCertificate_RSA of session_data * hs_log
| AwaitClientCertificate_DHE of session_data * dh_secret * hs_log
| AwaitClientKeyExchange_RSA of session_data * hs_log (* server hello done is sent, and RSA key exchange used, waiting for a client key exchange message *)
| AwaitClientKeyExchange_DHE of session_data * dh_secret * hs_log (* server hello done is sent, and DHE_RSA key exchange used, waiting for client key exchange *)
| AwaitClientCertificateVerify of session_data * crypto_context * crypto_context * hs_log
| AwaitClientChangeCipherSpec of session_data * crypto_context * crypto_context * hs_log (* client key exchange received, next should be change cipher spec *)
| AwaitClientChangeCipherSpecResume of session_data * crypto_context * string * hs_log (* resumption: next should be change cipher spec *)
| AwaitClientFinished of session_data * hs_log (* change cipher spec received, next should be the finished including a hmac over all handshake packets *)
| AwaitClientFinishedResume of session_data * string * hs_log (* change cipher spec received, next should be the finished including a hmac over all handshake packets *)
| Established (* handshake successfully completed *)
(* state machine of the client *)
type client_handshake_state =
| ClientInitial (* initial state *)
| AwaitServerHello of client_hello * (group * dh_secret) list * hs_log (* client hello is sent, handshake_params are half-filled *)
| AwaitServerHelloRenegotiate of session_data * client_hello * hs_log (* client hello is sent, handshake_params are half-filled *)
| AwaitCertificate_RSA of session_data * hs_log (* certificate expected with RSA key exchange *)
| AwaitCertificate_DHE of session_data * hs_log (* certificate expected with DHE key exchange *)
| AwaitServerKeyExchange_DHE of session_data * hs_log (* server key exchange expected with DHE *)
| AwaitCertificateRequestOrServerHelloDone of session_data * string * string * hs_log (* server hello done expected, client key exchange and premastersecret are ready *)
| AwaitServerHelloDone of session_data * signature_algorithm list option * string * string * hs_log (* server hello done expected, client key exchange and premastersecret are ready *)
| AwaitServerChangeCipherSpec of session_data * crypto_context * string * hs_log (* change cipher spec expected *)
| AwaitServerChangeCipherSpecResume of session_data * crypto_context * crypto_context * hs_log (* change cipher spec expected *)
| AwaitServerFinished of session_data * string * hs_log (* finished expected with a hmac over all handshake packets *)
| AwaitServerFinishedResume of session_data * hs_log (* finished expected with a hmac over all handshake packets *)
| Established (* handshake successfully completed *)
type kdf = {
secret : string ;
cipher : Ciphersuite.ciphersuite13 ;
hash : Digestif.hash' ;
}
(* TODO needs log of CH..CF for post-handshake auth *)
(* TODO drop master_secret!? *)
type session_data13 = {
common_session_data13 : common_session_data ;
ciphersuite13 : Ciphersuite.ciphersuite13 ;
master_secret : kdf ;
exporter_master_secret : string ;
resumption_secret : string ;
state : epoch_state ;
resumed : bool ;
client_app_secret : string ;
server_app_secret : string ;
}
type client13_handshake_state =
| AwaitServerHello13 of client_hello * (group * dh_secret) list * string (* this is for CH1 ~> HRR ~> CH2 <~ WAIT SH *)
| AwaitServerEncryptedExtensions13 of session_data13 * string * string * string
| AwaitServerCertificateRequestOrCertificate13 of session_data13 * string * string * string
| AwaitServerCertificate13 of session_data13 * string * string * signature_algorithm list option * string
| AwaitServerCertificateVerify13 of session_data13 * string * string * signature_algorithm list option * string
| AwaitServerFinished13 of session_data13 * string * string * signature_algorithm list option * string
| Established13
type server13_handshake_state =
| AwaitClientHelloHRR13 (* if we sent out HRR (also to-be-used for tls13-only) *)
| AwaitClientCertificate13 of session_data13 * string * crypto_context * session_ticket option * string
| AwaitClientCertificateVerify13 of session_data13 * string * crypto_context * session_ticket option * string
| AwaitClientFinished13 of string * crypto_context * session_ticket option * string
| AwaitEndOfEarlyData13 of string * crypto_context * crypto_context * session_ticket option * string
| Established13
type handshake_machina_state =
| Client of client_handshake_state
| Server of server_handshake_state
| Client13 of client13_handshake_state
| Server13 of server13_handshake_state
(* state during a handshake, used in the handlers *)
type handshake_state = {
session : [ `TLS of session_data | `TLS13 of session_data13 ] list ;
protocol_version : tls_version ;
early_data_left : int32 ;
machina : handshake_machina_state ; (* state machine state *)
config : Config.config ; (* given config *)
hs_fragment : string ; (* handshake messages can be fragmented, leftover from before *)
}
(* connection state: initially None, after handshake a crypto context *)
type crypto_state = crypto_context option
(* record consisting of a content type and a byte vector *)
type record = Packet.content_type * string
(* response returned by a handler *)
type rec_resp = [
| `Change_enc of crypto_context (* either instruction to change the encryptor to the given one *)
| `Change_dec of crypto_context (* either change the decryptor to the given one *)
| `Record of record (* or a record which should be sent out *)
]
(* return type of handshake handlers *)
type handshake_return = handshake_state * rec_resp list
(* Top level state, encapsulating the entire session. *)
type state = {
handshake : handshake_state ; (* the current handshake state *)
decryptor : crypto_state ; (* the current decryption state *)
encryptor : crypto_state ; (* the current encryption state *)
fragment : string ; (* the leftover fragment from TCP fragmentation *)
read_closed : bool ;
write_closed : bool ;
}
type error = [
| `AuthenticationFailure of X509.Validation.validation_error
| `NoConfiguredCiphersuite of Ciphersuite.ciphersuite list
| `NoConfiguredVersions of tls_version list
| `NoConfiguredSignatureAlgorithm of signature_algorithm list
| `NoMatchingCertificateFound of string
| `CouldntSelectCertificate
]
let pp_error ppf = function
| `AuthenticationFailure v ->
Fmt.pf ppf "authentication failure: %a" X509.Validation.pp_validation_error v
| `NoConfiguredCiphersuite cs ->
Fmt.pf ppf "no configured ciphersuite: %a"
Fmt.(list ~sep:(any ", ") Ciphersuite.pp_ciphersuite) cs
| `NoConfiguredVersions vs ->
Fmt.pf ppf "no configured version: %a"
Fmt.(list ~sep:(any ", ") pp_tls_version) vs
| `NoConfiguredSignatureAlgorithm sas ->
Fmt.pf ppf "no configure signature algorithm: %a"
Fmt.(list ~sep:(any ", ") pp_signature_algorithm) sas
| `NoMatchingCertificateFound host ->
Fmt.pf ppf "no matching certificate found for %s" host
| `CouldntSelectCertificate -> Fmt.string ppf "couldn't select certificate"
type fatal = [
| `Protocol_version of [
| `None_supported of tls_any_version list
| `Unknown_record of int * int
| `Bad_record of tls_any_version
]
| `Unexpected of [
| `Content_type of int
| `Message of string
| `Handshake of tls_handshake
]
| `Decode of string
| `Handshake of [
| `Message of string
| `Fragments
| `BadDH of string
| `BadECDH of Mirage_crypto_ec.error
]
| `Bad_certificate of string
| `Missing_extension of string
| `Bad_mac
| `Record_overflow of int
| `Unsupported_extension
| `Inappropriate_fallback
| `No_application_protocol
]
let pp_protocol_version ppf = function
| `None_supported vs ->
Fmt.pf ppf "none supported, client provided %a"
Fmt.(list ~sep:(any ", ") pp_tls_any_version) vs
| `Unknown_record (maj, min) ->
Fmt.pf ppf "unknown record version %u.%u" maj min
| `Bad_record v ->
Fmt.pf ppf "bad record version %a" pp_tls_any_version v
let pp_unexpected ppf = function
| `Content_type c -> Fmt.pf ppf "content type %u" c
| `Message msg -> Fmt.string ppf msg
| `Handshake hs -> Fmt.pf ppf "handshake %a" pp_handshake hs
let pp_handshake_error ppf = function
| `Message msg -> Fmt.string ppf msg
| `Fragments -> Fmt.string ppf "fragments are not empty"
| `BadDH msg -> Fmt.pf ppf "bad DH %s" msg
| `BadECDH e -> Fmt.pf ppf "bad ECDH %a" Mirage_crypto_ec.pp_error e
let pp_fatal ppf = function
| `Protocol_version e -> Fmt.pf ppf "version error: %a" pp_protocol_version e
| `Unexpected p -> Fmt.pf ppf "unexpected: %a" pp_unexpected p
| `Decode msg -> Fmt.pf ppf "decode error: %s" msg
| `Handshake h -> Fmt.pf ppf "handshake error: %a" pp_handshake_error h
| `Bad_certificate msg -> Fmt.pf ppf "bad certificate: %s" msg
| `Missing_extension msg -> Fmt.pf ppf "missing extension: %s" msg
| `Bad_mac -> Fmt.string ppf "MAC mismatch"
| `Record_overflow n -> Fmt.pf ppf "record overflow %u" n
| `Unsupported_extension -> Fmt.string ppf "unsupported extension"
| `Inappropriate_fallback -> Fmt.string ppf "inappropriate fallback"
| `No_application_protocol -> Fmt.string ppf "no application protocol"
type failure = [
| `Error of error
| `Fatal of fatal
| `Alert of Packet.alert_type
]
let pp_failure ppf = function
| `Error e -> pp_error ppf e
| `Fatal f -> pp_fatal ppf f
| `Alert a -> Fmt.pf ppf "alert %s" (Packet.alert_type_to_string a)
let common_data_to_epoch common is_server peer_name =
let own_random, peer_random =
if is_server then
common.server_random, common.client_random
else
common.client_random, common.server_random
in
let epoch : epoch_data =
{ side = if is_server then `Server else `Client ;
state = `Established ;
protocol_version = `TLS_1_0 ;
ciphersuite = `DHE_RSA_WITH_AES_256_CBC_SHA ;
peer_random ;
peer_certificate = common.peer_certificate ;
peer_certificate_chain = common.peer_certificate_chain ;
peer_name ;
trust_anchor = common.trust_anchor ;
own_random ;
own_certificate = common.own_certificate ;
own_private_key = common.own_private_key ;
own_name = common.own_name ;
received_certificates = common.received_certificates ;
master_secret = common.master_secret ;
exporter_master_secret = "" ;
alpn_protocol = common.alpn_protocol ;
session_id = "" ;
extended_ms = false ;
tls_unique = None ;
} in
epoch
let epoch_of_session server peer_name protocol_version = function
| `TLS (session : session_data) ->
let epoch = common_data_to_epoch session.common_session_data server peer_name in
{
epoch with
protocol_version = protocol_version ;
ciphersuite = session.ciphersuite ;
session_id = session.session_id ;
extended_ms = session.extended_ms ;
tls_unique = Some session.tls_unique ;
}
| `TLS13 (session : session_data13) ->
let epoch : epoch_data = common_data_to_epoch session.common_session_data13 server peer_name in
{
epoch with
protocol_version = protocol_version ;
ciphersuite = (session.ciphersuite13 :> Ciphersuite.ciphersuite) ;
extended_ms = true ; (* RFC 8446, Appendix D, last paragraph *)
state = session.state ;
exporter_master_secret = session.exporter_master_secret ;
}
let epoch_of_hs hs =
let server =
match hs.machina with
| Client _ | Client13 _ -> false
| Server _ | Server13 _ -> true
and peer_name = Config.(hs.config.peer_name)
in
match hs.session with
| [] -> None
| session :: _ -> Some (epoch_of_session server peer_name hs.protocol_version session)

40
unikernel/duniverse/ocaml-tls/lib/utils.ml Normal file
View file

@ -0,0 +1,40 @@
module List_set = struct
let subset ?(compare = compare) l1 l2 =
let rec loop xs ys =
match (xs, ys) with
| ([], _) -> true
| (_, []) -> false
| (x::xss, y::yss) ->
match compare x y with
| -1 -> false
| 1 -> loop xs yss
| _ -> loop xss yss in
loop (List.sort compare l1) (List.sort compare l2)
let is_proper_set l =
let rec repeats = function
| x::(y::_ as xs) -> x = y || repeats xs
| _ -> false in
not @@ repeats (List.sort compare l)
end
let rec map_find ~f = function
| [] -> None
| x::xs ->
match f x with
| None -> map_find ~f xs
| Some _ as x' -> x'
let init_and_last list =
List.fold_right (fun x -> function
| None -> Some ([], x)
| Some (xs, y) -> Some (x::xs, y))
list None
let rec first_match l1 = function
| [] -> None
| x::_ when List.mem x l1 -> Some x
| _::xs -> first_match l1 xs
let sub_equal ~off ~len v x =
v = String.sub x off len

491
unikernel/duniverse/ocaml-tls/lib/writer.ml Normal file
View file

@ -0,0 +1,491 @@
open Packet
open Core
let assemble_protocol_version_int buf off version =
let major, minor = pair_of_tls_version version in
Bytes.set_uint8 buf off major;
Bytes.set_uint8 buf (off + 1) minor
let assemble_protocol_version ?(buf= Bytes.create 2) version =
assemble_protocol_version_int buf 0 version;
Bytes.unsafe_to_string buf
let assemble_any_protocol_version_into buf off version =
let major, minor = pair_of_tls_any_version version in
Bytes.set_uint8 buf off major;
Bytes.set_uint8 buf (off + 1) minor
let assemble_any_protocol_version version =
let buf = Bytes.create 2 in
assemble_any_protocol_version_into buf 0 version;
Bytes.unsafe_to_string buf
let assemble_hdr version (content_type, payload) =
let buf = Bytes.create 5 in
Bytes.set_uint8 buf 0 (content_type_to_int content_type);
assemble_protocol_version_int buf 1 version;
Bytes.set_uint16_be buf 3 (String.length payload);
Bytes.unsafe_to_string buf ^ payload
type len = One | Two | Three
let assemble_list ?none_if_empty lenb f elements =
let length body =
match lenb with
| One ->
let l = Bytes.create 1 in
Bytes.set_uint8 l 0 (String.length body) ;
Bytes.unsafe_to_string l
| Two ->
let l = Bytes.create 2 in
Bytes.set_uint16_be l 0 (String.length body) ;
Bytes.unsafe_to_string l
| Three ->
let l = Bytes.create 3 in
set_uint24_len ~off:0 l (String.length body) ;
Bytes.unsafe_to_string l
in
let b es = String.concat "" (List.map f es) in
let full es =
let body = b es in
length body ^ body
in
match none_if_empty with
| Some _ -> (match elements with
| [] -> ""
| eles -> full eles)
| None -> full elements
let assemble_certificate c =
let length = String.length c in
let buf = Bytes.create 3 in
set_uint24_len ~off:0 buf length;
Bytes.unsafe_to_string buf ^ c
let assemble_certificates cs =
assemble_list Three assemble_certificate cs
let assemble_compression_method m =
String.make 1 (Char.unsafe_chr (compression_method_to_int m))
let assemble_compression_methods ms =
assemble_list One assemble_compression_method ms
let assemble_any_ciphersuite c =
let buf = Bytes.create 2 in
Bytes.set_uint16_be buf 0 (any_ciphersuite_to_int c);
Bytes.unsafe_to_string buf
let assemble_any_ciphersuites cs =
assemble_list Two assemble_any_ciphersuite cs
let assemble_ciphersuite c =
let acs = Ciphersuite.ciphersuite_to_any_ciphersuite c in
assemble_any_ciphersuite acs
let assemble_hostname host =
let host = Domain_name.to_string host in
(* 8 bit hostname type; 16 bit length; value *)
let vallength = String.length host in
let buf = Bytes.create 3 in
Bytes.set_uint8 buf 0 0; (* type, only 0 registered *)
Bytes.set_uint16_be buf 1 vallength;
Bytes.unsafe_to_string buf ^ host
let assemble_hostnames hosts =
assemble_list Two assemble_hostname hosts
let assemble_hash_signature sigalg =
let buf = Bytes.create 2 in
Bytes.set_uint16_be buf 0 (signature_alg_to_int (to_signature_alg sigalg)) ;
Bytes.unsafe_to_string buf
let assemble_signature_algorithms s =
assemble_list Two assemble_hash_signature s
let assemble_certificate_types ts =
let ass x =
String.make 1 (Char.unsafe_chr (client_certificate_type_to_int x))
in
assemble_list One ass ts
let assemble_cas cas =
let ass x =
let buf = Bytes.create 2 in
Bytes.set_uint16_be buf 0 (String.length x) ;
Bytes.unsafe_to_string buf ^ x
in
assemble_list Two ass cas
let assemble_certificate_request ts cas =
assemble_certificate_types ts ^ assemble_cas cas
let assemble_certificate_request_1_2 ts sigalgs cas =
String.concat "" [
assemble_certificate_types ts;
assemble_signature_algorithms sigalgs;
assemble_cas cas
]
let assemble_named_group g =
let buf = Bytes.create 2 in
Bytes.set_uint16_be buf 0 (named_group_to_int g);
Bytes.unsafe_to_string buf
let assemble_group g =
assemble_named_group (group_to_named_group g)
let assemble_supported_groups groups =
assemble_list Two assemble_named_group groups
let assemble_keyshare_entry (ng, ks) =
let g = assemble_named_group ng in
let l = Bytes.create 2 in
Bytes.set_uint16_be l 0 (String.length ks) ;
String.concat "" [ g ; Bytes.unsafe_to_string l ; ks ]
let assemble_psk_id (id, age) =
let id_len = Bytes.create 2 in
Bytes.set_uint16_be id_len 0 (String.length id) ;
let age_buf = Bytes.create 4 in
Bytes.set_int32_be age_buf 0 age ;
String.concat "" [ Bytes.unsafe_to_string id_len ; id ; Bytes.unsafe_to_string age_buf ]
let assemble_binder b =
let b_len = String.make 1 (Char.unsafe_chr (String.length b)) in
b_len ^ b
let assemble_client_psks psks =
let ids, binders = List.split psks in
let ids_buf = assemble_list Two assemble_psk_id ids in
let binders_buf = assemble_list Two assemble_binder binders in
ids_buf ^ binders_buf
let assemble_alpn_protocol p =
let buf = String.make 1 (Char.unsafe_chr (String.length p)) in
buf ^ p
let assemble_alpn_protocols protocols =
assemble_list Two assemble_alpn_protocol protocols
let assemble_supported_versions vs =
assemble_list One assemble_any_protocol_version vs
let assemble_extension = function
| `SecureRenegotiation x ->
let buf = String.make 1 (Char.unsafe_chr (String.length x)) in
(buf ^ x, RENEGOTIATION_INFO)
| `ExtendedMasterSecret -> ("", EXTENDED_MASTER_SECRET)
| `ECPointFormats ->
(* a list of point formats, we support type 0 = uncompressed unconditionally *)
let data = Bytes.make 2 '\x00' in
Bytes.set_uint8 data 0 1;
(Bytes.unsafe_to_string data, EC_POINT_FORMATS)
| _ -> invalid_arg "unknown extension"
let assemble_cookie c =
let l = Bytes.create 2 in
Bytes.set_uint16_be l 0 (String.length c) ;
Bytes.unsafe_to_string l ^ c
let assemble_psk_key_exchange_mode mode =
String.make 1 (Char.unsafe_chr (psk_key_exchange_mode_to_int mode))
let assemble_psk_key_exchange_modes modes =
assemble_list One assemble_psk_key_exchange_mode modes
let assemble_ext (pay, typ) =
let buf = Bytes.create 4 in
Bytes.set_uint16_be buf 0 (extension_type_to_int typ);
Bytes.set_uint16_be buf 2 (String.length pay);
Bytes.unsafe_to_string buf ^ pay
let assemble_extensions ?none_if_empty assemble_e es =
assemble_list ?none_if_empty Two assemble_e es
let assemble_ca ca =
let lenbuf = Bytes.create 2 in
let data = X509.Distinguished_name.encode_der ca in
Bytes.set_uint16_be lenbuf 0 (String.length data) ;
Bytes.unsafe_to_string lenbuf ^ data
let assemble_certificate_authorities cas =
assemble_list Two assemble_ca cas
let assemble_certificate_request_extension e =
assemble_ext @@ match e with
| `SignatureAlgorithms s ->
(assemble_signature_algorithms s, SIGNATURE_ALGORITHMS)
| `CertificateAuthorities cas ->
(assemble_certificate_authorities cas, CERTIFICATE_AUTHORITIES)
| _ -> invalid_arg "unknown extension"
let assemble_certificate_request_1_3 ?(context = "") exts =
let clen = String.make 1 (Char.unsafe_chr (String.length context)) in
let exts = assemble_extensions assemble_certificate_request_extension exts in
String.concat "" [ clen ; context ; exts ]
let assemble_client_extension e =
assemble_ext @@ match e with
| `SupportedGroups groups ->
(assemble_supported_groups groups, SUPPORTED_GROUPS)
| `Hostname name -> (assemble_hostnames [name], SERVER_NAME)
| `Padding x -> (String.make x '\x00', PADDING)
| `SignatureAlgorithms s ->
(assemble_signature_algorithms s, SIGNATURE_ALGORITHMS)
| `ALPN protocols ->
(assemble_alpn_protocols protocols, APPLICATION_LAYER_PROTOCOL_NEGOTIATION)
| `KeyShare ks ->
(assemble_list Two assemble_keyshare_entry ks, KEY_SHARE)
| `PreSharedKeys ids ->
(assemble_client_psks ids, PRE_SHARED_KEY)
| `EarlyDataIndication ->
("", EARLY_DATA)
| `SupportedVersions vs ->
(assemble_supported_versions vs, SUPPORTED_VERSIONS)
| `PostHandshakeAuthentication ->
("", POST_HANDSHAKE_AUTH)
| `Cookie c ->
(assemble_cookie c, COOKIE)
| `PskKeyExchangeModes modes ->
(assemble_psk_key_exchange_modes modes, PSK_KEY_EXCHANGE_MODES)
| x -> assemble_extension x
let assemble_server_extension e =
assemble_ext @@ match e with
| `Hostname -> ("", SERVER_NAME)
| `ALPN protocol ->
(assemble_alpn_protocols [protocol], APPLICATION_LAYER_PROTOCOL_NEGOTIATION)
| `KeyShare (g, ks) ->
let ng = group_to_named_group g in
(assemble_keyshare_entry (ng, ks), KEY_SHARE)
| `PreSharedKey id ->
let data = Bytes.create 2 in
Bytes.set_uint16_be data 0 id ;
(Bytes.unsafe_to_string data, PRE_SHARED_KEY)
| `SelectedVersion v -> (assemble_protocol_version v, SUPPORTED_VERSIONS)
| x -> assemble_extension x
let assemble_encrypted_extension e =
assemble_ext @@ match e with
| `Hostname -> ("", SERVER_NAME)
| `ALPN protocol ->
(assemble_alpn_protocols [protocol], APPLICATION_LAYER_PROTOCOL_NEGOTIATION)
| `SupportedGroups groups ->
(assemble_supported_groups (List.map group_to_named_group groups), SUPPORTED_GROUPS)
| `EarlyDataIndication -> ("", EARLY_DATA)
| _ -> invalid_arg "unknown extension"
let assemble_retry_extension e =
assemble_ext @@ match e with
| `SelectedGroup g -> (assemble_group g, KEY_SHARE)
| `Cookie c -> (assemble_cookie c, COOKIE)
| `SelectedVersion v -> (assemble_protocol_version v, SUPPORTED_VERSIONS)
| `UnknownExtension _ -> invalid_arg "unknown retry extension"
let assemble_cert_ext (certificate, extensions) =
let cert = assemble_certificate certificate
and exts = assemble_list Two assemble_server_extension extensions
in
cert ^ exts
let assemble_certs_exts cs =
assemble_list Three assemble_cert_ext cs
let assemble_certificates_1_3 context certs =
let l = String.make 1 (Char.unsafe_chr (String.length context)) in
String.concat "" [ l ; context ; assemble_certs_exts (List.map (fun c -> c, []) certs) ]
let assemble_sid sid =
match sid with
| None -> String.make 1 '\x00'
| Some s -> String.make 1 (Char.unsafe_chr (String.length s)) ^ s
let assemble_client_hello (cl : client_hello) : string =
let version = match cl.client_version with
| `TLS_1_3 -> `TLS_1_2 (* keep 0x03 0x03 on wire *)
| x -> x
in
let v = assemble_any_protocol_version version in
let sid = assemble_sid cl.sessionid in
let css = assemble_any_ciphersuites cl.ciphersuites in
(* compression methods, completely useless *)
let cms = assemble_compression_methods [NULL] in
let bbuf = String.concat "" [ v ; cl.client_random ; sid ; css ; cms ] in
let extensions = assemble_extensions ~none_if_empty:true assemble_client_extension cl.extensions in
(* some widely deployed firewalls drop ClientHello messages which are
> 256 and < 511 byte, insert PADDING extension for these *)
(* from draft-ietf-tls-padding-00:
As an example, consider a client that wishes to avoid sending a
ClientHello with a record size between 256 and 511 bytes (inclusive).
This case is considered because at least one TLS implementation is
known to hang the connection when such a ClientHello record is
received.
After building a ClientHello as normal, the client can add four to
the length (to account for the "msg_type" and "length" fields of the
handshake protocol) and test whether the resulting length falls into
that range. If it does, a padding extension can be added in order to
push the length to (at least) 512 bytes. *)
let extrapadding =
(* since PreSharedKeys _must_ be the last extension, don't bother padding
when it is present. rationale from ietf-tls WG
"Padding extension and 0-RTT" thread (2016-10-30) *)
if List.exists (function `PreSharedKeys _ -> true | _ -> false) cl.extensions then
""
else
let buflen = String.length bbuf + String.length extensions + 4 (* see above, header *) in
if buflen >= 256 && buflen <= 511 then
match String.length extensions with
| 0 -> (* need to construct a 2 byte extension length as well *)
let l = 512 (* desired length *) - 2 (* extension length *) - 4 (* padding extension header *) - buflen in
let l = max l 0 in (* negative size is not good *)
let padding = assemble_client_extension (`Padding l) in
let extension_length = Bytes.create 2 in
Bytes.set_uint16_be extension_length 0 (String.length padding);
Bytes.unsafe_to_string extension_length ^ padding
| _ ->
let l = 512 - 4 (* padding extension header *) - buflen in
let l = max l 0 in
let padding = assemble_client_extension (`Padding l) in
(* extensions include the 16 bit extension length field *)
let elen = String.length extensions + String.length padding - 2 (* the 16 bit length field *) in
Bytes.set_uint16_be (Bytes.unsafe_of_string extensions) 0 elen;
padding
else
""
in
String.concat "" [ bbuf ; extensions ; extrapadding ]
let assemble_server_hello (sh : server_hello) : string =
let version, exts = match sh.server_version with
| `TLS_1_3 -> `TLS_1_2, `SelectedVersion `TLS_1_3 :: sh.extensions
| x -> x, sh.extensions
in
let v = assemble_protocol_version version in
let sid = assemble_sid sh.sessionid in
let cs = assemble_ciphersuite sh.ciphersuite in
(* useless compression method *)
let cm = assemble_compression_method NULL in
let extensions = assemble_extensions ~none_if_empty:true assemble_server_extension exts in
String.concat "" [ v ; sh.server_random ; sid ; cs ; cm ; extensions ]
let assemble_dh_parameters p =
let plen, glen, yslen = (String.length p.dh_p, String.length p.dh_g, String.length p.dh_Ys) in
let buf = Bytes.create (2 + 2 + 2 + plen + glen + yslen) in
Bytes.set_uint16_be buf 0 plen;
Bytes.blit_string p.dh_p 0 buf 2 plen;
Bytes.set_uint16_be buf (2 + plen) glen;
Bytes.blit_string p.dh_g 0 buf (4 + plen) glen;
Bytes.set_uint16_be buf (4 + plen + glen) yslen;
Bytes.blit_string p.dh_Ys 0 buf (6 + plen + glen) yslen;
Bytes.unsafe_to_string buf
let assemble_ec_parameters named_curve point =
let hdr = Bytes.create 4 in
Bytes.set_uint8 hdr 0 (ec_curve_type_to_int NAMED_CURVE);
Bytes.set_uint16_be hdr 1 (named_group_to_int (group_to_named_group named_curve));
Bytes.set_uint8 hdr 3 (String.length point);
Bytes.unsafe_to_string hdr ^ point
let assemble_digitally_signed signature =
let lenbuf = Bytes.create 2 in
Bytes.set_uint16_be lenbuf 0 (String.length signature);
Bytes.unsafe_to_string lenbuf ^ signature
let assemble_digitally_signed_1_2 sigalg signature =
(assemble_hash_signature sigalg) ^ (assemble_digitally_signed signature)
let assemble_session_ticket_extension e =
assemble_ext @@ match e with
| `EarlyDataIndication max ->
let buf = Bytes.create 4 in
Bytes.set_int32_be buf 0 max ;
(Bytes.unsafe_to_string buf, EARLY_DATA)
| _ -> invalid_arg "unknown extension"
let assemble_session_ticket (se : session_ticket) =
let buf = Bytes.create 9 in
Bytes.set_int32_be buf 0 se.lifetime ;
Bytes.set_int32_be buf 4 se.age_add ;
Bytes.set_uint8 buf 8 (String.length se.nonce) ;
let ticketlen = Bytes.create 2 in
Bytes.set_uint16_be ticketlen 0 (String.length se.ticket) ;
let exts = assemble_extensions assemble_session_ticket_extension se.extensions in
String.concat "" [ Bytes.unsafe_to_string buf ; se.nonce ; Bytes.unsafe_to_string ticketlen ; se.ticket ; exts ]
let assemble_client_dh_key_exchange kex =
let len = String.length kex in
let buf = Bytes.create (len + 2) in
Bytes.set_uint16_be buf 0 len;
Bytes.blit_string kex 0 buf 2 len;
Bytes.unsafe_to_string buf
let assemble_client_ec_key_exchange kex =
let len = String.length kex in
let buf = Bytes.create (len + 1) in
Bytes.set_uint8 buf 0 len;
Bytes.blit_string kex 0 buf 1 len;
Bytes.unsafe_to_string buf
let assemble_hello_retry_request hrr =
let exts = `SelectedGroup hrr.selected_group :: hrr.extensions in
let version, exts = match hrr.retry_version with
| `TLS_1_3 -> `TLS_1_2, `SelectedVersion `TLS_1_3 :: exts
| x -> x, exts
in
let v = assemble_protocol_version version in
let sid = assemble_sid hrr.sessionid in
let cs = assemble_ciphersuite (hrr.ciphersuite :> Ciphersuite.ciphersuite) in
(* useless compression method *)
let cm = String.make 1 '\x00' in
let extensions = assemble_extensions ~none_if_empty:true assemble_retry_extension exts in
String.concat "" [ v ; helloretryrequest ; sid ; cs ; cm ; extensions ]
let assemble_hs typ len =
let buf = Bytes.create 4 in
Bytes.set_uint8 buf 0 (handshake_type_to_int typ);
set_uint24_len ~off:1 buf len;
Bytes.unsafe_to_string buf
let assemble_message_hash len =
assemble_hs MESSAGE_HASH len
let assemble_key_update req =
String.make 1 (Char.unsafe_chr (key_update_request_type_to_int req))
let assemble_handshake hs =
let (payload, payload_type) =
match hs with
| ClientHello ch -> (assemble_client_hello ch, CLIENT_HELLO)
| ServerHello sh -> (assemble_server_hello sh, SERVER_HELLO)
| HelloRetryRequest hr -> (assemble_hello_retry_request hr, SERVER_HELLO)
| Certificate cs -> (cs, CERTIFICATE)
| CertificateRequest cr -> (cr, CERTIFICATE_REQUEST)
| CertificateVerify c -> (c, CERTIFICATE_VERIFY)
| ServerKeyExchange kex -> (kex, SERVER_KEY_EXCHANGE)
| ClientKeyExchange kex -> (kex, CLIENT_KEY_EXCHANGE)
| ServerHelloDone -> ("", SERVER_HELLO_DONE)
| HelloRequest -> ("", HELLO_REQUEST)
| Finished fs -> (fs, FINISHED)
| SessionTicket st -> (assemble_session_ticket st, SESSION_TICKET)
| EncryptedExtensions ee ->
let cs = assemble_extensions assemble_encrypted_extension ee in
(cs, ENCRYPTED_EXTENSIONS)
| KeyUpdate req ->
let cs = assemble_key_update req in
(cs, KEY_UPDATE)
| EndOfEarlyData -> ("", END_OF_EARLY_DATA)
in
let pay_len = String.length payload in
let buf = assemble_hs payload_type pay_len in
buf ^ payload
let assemble_alert ?(level = Packet.FATAL) typ =
let buf = Bytes.create 2 in
Bytes.set_uint8 buf 1 (alert_type_to_int typ);
Bytes.set_uint8 buf 0 (alert_level_to_int level) ;
Bytes.unsafe_to_string buf
let assemble_change_cipher_spec =
String.make 1 '\x01'

34
unikernel/duniverse/ocaml-tls/lib/writer.mli Normal file
View file

@ -0,0 +1,34 @@
val assemble_protocol_version : ?buf:bytes -> Core.tls_version -> string
val assemble_handshake : Core.tls_handshake -> string
val assemble_message_hash : int -> string
val assemble_hdr : Core.tls_version -> (Packet.content_type * string) -> string
val assemble_alert : ?level:Packet.alert_level -> Packet.alert_type -> string
val assemble_change_cipher_spec : string
val assemble_dh_parameters : Core.dh_parameters -> string
val assemble_ec_parameters : Core.group -> string -> string
val assemble_client_dh_key_exchange : string -> string
val assemble_client_ec_key_exchange : string -> string
val assemble_digitally_signed : string -> string
val assemble_digitally_signed_1_2 : Core.signature_algorithm -> string -> string
val assemble_certificate_request : Packet.client_certificate_type list -> string list -> string
val assemble_certificate_request_1_2 : Packet.client_certificate_type list -> Core.signature_algorithm list -> string list -> string
val assemble_certificate_request_1_3 : ?context:string -> Core.certificate_request_extension list -> string
val assemble_certificates : string list -> string
val assemble_certificates_1_3 : string -> string list -> string

5
unikernel/duniverse/ocaml-tls/lwt/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name tls_lwt)
(public_name tls-lwt)
(wrapped false)
(libraries tls lwt lwt.unix ptime.clock.os mirage-crypto-rng.unix))

69
unikernel/duniverse/ocaml-tls/lwt/examples/dune Normal file
View file

@ -0,0 +1,69 @@
(library
(name ex_common)
(libraries lwt lwt.unix tls tls-lwt cmdliner fmt.cli logs.fmt fmt.tty logs.cli)
(modules ex_common))
(executable
(name starttls_server)
(modules starttls_server)
(libraries tls-lwt lwt.unix ex_common))
(executable
(name echo_server)
(modules echo_server)
(libraries tls-lwt lwt.unix ex_common))
(executable
(name echo_server_sni)
(modules echo_server_sni)
(libraries tls-lwt lwt.unix ex_common))
(executable
(name echo_server_alpn)
(modules echo_server_alpn)
(libraries tls-lwt lwt.unix ex_common))
(executable
(name echo_client)
(modules echo_client)
(libraries tls-lwt lwt.unix ex_common))
(executable
(name echo_client_alpn)
(modules echo_client_alpn)
(libraries tls-lwt lwt.unix ex_common))
(executable
(name test_server)
(modules test_server)
(libraries tls-lwt lwt.unix ex_common))
(executable
(name test_client)
(modules test_client)
(libraries tls-lwt lwt.unix ex_common))
(executable
(name tls_over_tls)
(modules tls_over_tls)
(libraries tls-lwt lwt lwt.unix ex_common))
(executable
(name http_client)
(modules http_client)
(libraries tls-lwt lwt.unix ex_common))
(executable
(name fuzz_server)
(modules fuzz_server)
(libraries tls-lwt lwt.unix ex_common))
(executable
(name resume_client)
(modules resume_client)
(libraries tls-lwt lwt.unix ex_common))
(executable
(name resume_echo_server)
(modules resume_echo_server)
(libraries randomconv tls-lwt lwt.unix ex_common))

73
unikernel/duniverse/ocaml-tls/lwt/examples/echo_client.ml Normal file
View file

@ -0,0 +1,73 @@
open Ex_common
open Lwt
let cached_session : Tls.Core.epoch_data =
let hex = Ohex.decode in
{
Tls.Core.side = `Client ;
protocol_version = `TLS_1_3 ;
ciphersuite = `DHE_RSA_WITH_AES_128_GCM_SHA256 ;
peer_random = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
peer_certificate = None ;
peer_certificate_chain = [] ;
peer_name = None ;
trust_anchor = None ;
received_certificates = [] ;
own_random = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
own_certificate = [] ;
own_private_key = None ;
own_name = None ;
master_secret = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
exporter_master_secret = "" ;
session_id = "" ;
extended_ms = true ;
alpn_protocol = None ;
state = `Established ;
tls_unique = None ;
}
let echo_client ?ca hostname port =
let open Lwt_io in
auth ?ca () >>= fun authenticator ->
X509_lwt.private_of_pems
~cert:server_cert
~priv_key:server_key >>= fun certificate ->
Tls_lwt.connect_ext
(get_ok Tls.Config.(client ~authenticator ~cached_session ~certificates:(`Single certificate) ~ciphers:Ciphers.supported ()))
(hostname, port) >>= fun (ic, oc) ->
Lwt.join [
lines ic |> Lwt_stream.iter_s (printf "+ %s\n%!") ;
lines stdin |> Lwt_stream.iter_s (write_line oc)
]
let jump _ port host ca =
try
Lwt_main.run (echo_client ?ca host port)
with
| Tls_lwt.Tls_alert alert as exn ->
print_alert "remote end" alert ; raise exn
| Tls_lwt.Tls_failure alert as exn ->
print_fail "our end" alert ; raise exn
open Cmdliner
let port =
let doc = "Port to connect to" in
Arg.(value & opt int 443 & info [ "port" ] ~doc)
let host =
let doc = "Host to connect to" in
Arg.(value & opt string "" & info [ "host" ] ~doc)
let trust =
let doc = "Trust anchor" in
Arg.(value & opt (some string) None & info [ "trust" ] ~doc)
let cmd =
let term = Term.(const jump $ setup_log $ port $ host $ trust)
and info = Cmd.info "echo_client" ~version:"2.0.3"
in
Cmd.v info term
let () = exit (Cmd.eval cmd)

22
unikernel/duniverse/ocaml-tls/lwt/examples/echo_client_alpn.ml Normal file
View file

@ -0,0 +1,22 @@
open Ex_common
open Lwt
let echo_client host port =
let open Lwt_io in
let port = int_of_string port in
let authenticator = null_auth in
Tls_lwt.Unix.connect
(get_ok Tls.Config.(client ~authenticator ~alpn_protocols:["http/1.1"; "h2"] ()))
(host, port) >>= fun t ->
match Tls_lwt.Unix.epoch t with
| Error () -> printl "Error"
| Ok epoch -> (
match epoch.Tls.Core.alpn_protocol with
| None -> printl "No protocol selected"
| Some protocol -> printl ("Selected protocol: " ^ protocol)
)
>>= fun () -> Tls_lwt.Unix.close t
let () =
Lwt_main.run (echo_client "127.0.0.1" "4433")

75
unikernel/duniverse/ocaml-tls/lwt/examples/echo_server.ml Normal file
View file

@ -0,0 +1,75 @@
open Lwt
open Ex_common
let string_of_unix_err err f p =
Printf.sprintf "Unix_error (%s, %s, %s)"
(Unix.error_message err) f p
let serve_ssl port callback =
let tag = "server" in
X509_lwt.private_of_pems
~cert:server_cert
~priv_key:server_key >>= fun cert ->
let server_s () =
let open Lwt_unix in
let s = socket PF_INET SOCK_STREAM 0 in
setsockopt s SO_REUSEADDR true ;
bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () ->
listen s 10 ;
s in
let handle channels addr =
async @@ fun () ->
Lwt.catch (fun () -> callback channels addr >>= fun () -> yap ~tag "<- handler done")
(function
| Tls_lwt.Tls_alert a ->
yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a
| Tls_lwt.Tls_failure a ->
yap ~tag @@ "handler: " ^ Tls.Engine.string_of_failure a
| Unix.Unix_error (e, f, p) ->
yap ~tag @@ "handler: " ^ (string_of_unix_err e f p)
| _exn -> yap ~tag "handler: exception")
in
yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () ->
let rec loop s =
let authenticator = null_auth in
let config = get_ok (Tls.Config.server ~version:(`TLS_1_0, `TLS_1_3) ~ciphers:Tls.Config.Ciphers.supported ~reneg:true ~certificates:(`Single cert) ~authenticator ()) in
(Lwt.catch
(fun () -> Tls_lwt.accept_ext config s >|= fun r -> `R r)
(function
| Unix.Unix_error (e, f, p) -> return (`L (string_of_unix_err e f p))
| Tls_lwt.Tls_alert a -> return (`L (Tls.Packet.alert_type_to_string a))
| Tls_lwt.Tls_failure f -> return (`L (Tls.Engine.string_of_failure f))
| exn -> return (`L ("loop: exception: " ^ Printexc.to_string exn)))) >>= function
| `R (channels, addr) ->
yap ~tag "-> connect" >>= fun () -> ( handle channels addr ; loop s )
| `L (msg) ->
yap ~tag ("server socket: " ^ msg) >>= fun () -> loop s
in
server_s () >>= fun s ->
loop s
let echo_server _ port =
Lwt_main.run (
serve_ssl port @@ fun (ic, oc) _addr ->
lines ic |> Lwt_stream.iter_s (fun line ->
yap ~tag:"handler" ("+ " ^ line) >>= fun () ->
Lwt_io.write_line oc line))
open Cmdliner
let port =
let doc = "Port to connect to" in
Arg.(value & opt int 4433 & info [ "port" ] ~doc)
let cmd =
let term = Term.(ret (const echo_server $ setup_log $ port))
and info = Cmd.info "echo_server" ~version:"2.0.3"
in
Cmd.v info term
let () = exit (Cmd.eval cmd)

68
unikernel/duniverse/ocaml-tls/lwt/examples/echo_server_alpn.ml Normal file
View file

@ -0,0 +1,68 @@
open Lwt
open Ex_common
let split_on_char sep s =
let r = ref [] in
let j = ref (String.length s) in
for i = String.length s - 1 downto 0 do
if s.[i] = sep then begin
r := String.sub s (i + 1) (!j - i - 1) :: !r;
j := i
end
done;
String.sub s 0 !j :: !r
let serve_ssl alpn_protocols port callback =
let tag = "server" in
X509_lwt.private_of_pems
~cert:server_cert
~priv_key:server_key >>= fun certificate ->
let server_s =
let open Lwt_unix in
let s = socket PF_INET SOCK_STREAM 0 in
bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () ->
listen s 10 ;
s in
let handle ep channels addr =
let alpn = match ep with
| Ok data -> (match data.Tls.Core.alpn_protocol with
| Some a -> a
| None -> "no alpn")
| Error () -> "no session"
in
async @@ fun () ->
Lwt.catch (fun () -> callback alpn channels addr >>= fun () -> yap ~tag "<- handler done")
(function
| Tls_lwt.Tls_alert a ->
yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a
| exn -> yap ~tag "handler: exception" >>= fun () -> fail exn)
in
let ps = string_of_int port in
yap ~tag ("-> start @ " ^ ps ^ " (use `openssl s_client -connect host:" ^ ps ^ " -alpn <proto>`), available protocols: " ^ String.concat "," alpn_protocols) >>= fun () ->
let rec loop () =
let config = get_ok (Tls.Config.server ~certificates:(`Single certificate) ~alpn_protocols ()) in
server_s >>= fun s ->
Tls_lwt.Unix.accept config s >>= fun (t, addr) ->
yap ~tag "-> connect" >>= fun () ->
( handle (Tls_lwt.Unix.epoch t) (Tls_lwt.of_t t) addr ; loop () )
in
loop ()
let echo_server protocols port =
serve_ssl protocols port @@ fun alpn (ic, oc) _addr ->
lines ic |> Lwt_stream.iter_s (fun line ->
yap ~tag:("handler alpn: " ^ alpn) ("+ " ^ line) >>= fun () ->
Lwt_io.write_line oc line)
let () =
let protocols =
try split_on_char ',' Sys.argv.(1) with _ -> [ "h2" ; "http/1.1" ]
in
Lwt_main.run (echo_server protocols 4433)

61
unikernel/duniverse/ocaml-tls/lwt/examples/echo_server_sni.ml Normal file
View file

@ -0,0 +1,61 @@
open Lwt
open Ex_common
let serve_ssl port callback =
let tag = "server" in
X509_lwt.private_of_pems
~cert:(ca_cert_dir ^ "/bar.pem")
~priv_key:server_key >>= fun barcert ->
X509_lwt.private_of_pems
~cert:(ca_cert_dir ^ "/foo.pem")
~priv_key:server_key >>= fun foocert ->
let server_s =
let open Lwt_unix in
let s = socket PF_INET SOCK_STREAM 0 in
bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () ->
listen s 10 ;
s in
let handle ep channels addr =
let host = match ep with
| Ok data -> ( match data.Tls.Core.own_name with
| Some n -> Domain_name.to_string n
| None -> "no name" )
| Error () -> "no session"
in
async @@ fun () ->
Lwt.catch (fun () -> callback host channels addr >>= fun () -> yap ~tag "<- handler done")
(function
| Tls_lwt.Tls_alert a ->
yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a
| exn -> yap ~tag "handler: exception" >>= fun () -> fail exn)
in
let ps = string_of_int port in
yap ~tag ("-> start @ " ^ ps ^ " (use `openssl s_client -connect host:" ^ ps ^ " -servername foo` (or -servername bar))") >>= fun () ->
let rec loop () =
let config = get_ok (Tls.Config.server ~certificates:(`Multiple [barcert ; foocert]) ()) in
server_s >>= fun s ->
Tls_lwt.Unix.accept config s >>= fun (t, addr) ->
yap ~tag "-> connect" >>= fun () ->
( handle (Tls_lwt.Unix.epoch t) (Tls_lwt.of_t t) addr ; loop () )
in
loop ()
let echo_server port =
serve_ssl port @@ fun host (ic, oc) _addr ->
lines ic |> Lwt_stream.iter_s (fun line ->
yap ~tag:("handler " ^ host) ("+ " ^ line) >>= fun () ->
Lwt_io.write_line oc line)
let () =
let port =
try int_of_string Sys.argv.(1) with _ -> 4433
in
Lwt_main.run (echo_server port)

55
unikernel/duniverse/ocaml-tls/lwt/examples/ex_common.ml Normal file
View file

@ -0,0 +1,55 @@
open Lwt
let o f g x = f (g x)
let ca_cert_dir = "./certificates"
let server_cert = "./certificates/server.pem"
let server_key = "./certificates/server.key"
let server_ec_cert = "./certificates/server-ec.pem"
let server_ec_key = "./certificates/server-ec.key"
let yap ~tag msg = Lwt_io.printf "(%s %s)\n%!" tag msg
let lines ic =
Lwt_stream.from @@ fun () ->
Lwt_io.read_line_opt ic >>= function
| None -> Lwt_io.close ic >>= fun () -> return_none
| line -> return line
let print_alert where alert =
Printf.eprintf "(TLS ALERT (%s): %s)\n%!"
where (Tls.Packet.alert_type_to_string alert)
let print_fail where fail =
Printf.eprintf "(TLS FAIL (%s): %s)\n%!"
where (Tls.Engine.string_of_failure fail)
let null_auth ?ip:_ ~host:_ _ = Ok None
let auth ?ca ?fp () =
match ca with
| Some "NONE" when fp = None -> Lwt.return null_auth
| _ ->
let a = match ca, fp with
| None, Some fp -> `Hex_key_fingerprint (`SHA256, fp)
| None, _ -> `Ca_dir ca_cert_dir
| Some f, _ -> `Ca_file f
in
X509_lwt.authenticator a
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let get_ok = function
| Ok cfg -> cfg
| Error `Msg msg -> invalid_arg msg

101
unikernel/duniverse/ocaml-tls/lwt/examples/fuzz_server.ml Normal file
View file

@ -0,0 +1,101 @@
open Lwt
open Ex_common
let string_of_unix_err err f p =
Printf.sprintf "Unix_error (%s, %s, %s)"
(Unix.error_message err) f p
let add_to_cache, find_in_cache =
let c = ref [] in
(fun ticket session ->
let id = ticket.Tls.Core.identifier in
Logs.info (fun m -> m "adding id %a to cache" Ohex.pp id) ;
c := (id, (ticket, session)) :: !c),
(fun id -> match List.find_opt (fun (id', _) -> String.compare id id' = 0) !c with
| None -> None
| Some (_, ep) -> Some ep)
let ticket_cache = {
Tls.Config.lookup = find_in_cache ;
ticket_granted = add_to_cache ;
lifetime = 300l ;
timestamp = Ptime_clock.now
}
let serve_ssl port callback =
let tag = "server" in
X509_lwt.private_of_pems
~cert:server_cert
~priv_key:server_key >>= fun cert ->
let server_s () =
let open Lwt_unix in
let s = socket PF_INET SOCK_STREAM 0 in
setsockopt s SO_REUSEADDR true ;
bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () ->
listen s 10 ;
s in
let handle channels addr =
async @@ fun () ->
Lwt.catch (fun () -> callback channels addr >>= fun () -> yap ~tag "<- handler done")
(function
| Tls_lwt.Tls_alert a ->
yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a
| Tls_lwt.Tls_failure a ->
yap ~tag @@ "handler: " ^ Tls.Engine.string_of_failure a
| Unix.Unix_error (e, f, p) ->
yap ~tag @@ "handler: " ^ (string_of_unix_err e f p)
| _exn -> yap ~tag "handler: exception")
in
yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () ->
let rec loop s =
let config = get_ok (Tls.Config.server ~ticket_cache ~reneg:true ~certificates:(`Single cert) ~version:(`TLS_1_2, `TLS_1_3) ~zero_rtt:32768l ()) in
(Lwt.catch
(fun () -> Tls_lwt.Unix.accept config s >|= fun r -> `R r)
(function
| Unix.Unix_error (e, f, p) -> return (`L (string_of_unix_err e f p))
| Tls_lwt.Tls_alert a -> return (`L (Tls.Packet.alert_type_to_string a))
| Tls_lwt.Tls_failure f -> return (`L (Tls.Engine.string_of_failure f))
| exn -> let str = Printexc.to_string exn in return (`L ("loop: exception " ^ str)))) >>= function
| `R (t, addr) ->
let channels = Tls_lwt.of_t t in
yap ~tag "-> connect" >>= fun () -> ( handle channels addr ; loop s )
| `L (msg) ->
yap ~tag ("server socket: " ^ msg) >>= fun () -> loop s
in
server_s () >>= fun s ->
loop s
let echo_server port =
serve_ssl port @@ fun (ic, oc) _addr ->
yap ~tag:"handler" "accepted" >>= fun () ->
let out = "HTTP/1.1 404 Not Found\r\n\r\n" in
Lwt_io.write_from_string_exactly oc out 0 (String.length out) >>= fun () ->
(* Lwt_io.close oc *)
let rec loop () =
Lwt_io.read_line ic >>= fun line ->
yap ~tag:"handler" ("+ " ^ line) >>= fun () ->
loop ()
in
loop ()
let jump _ port =
Lwt_main.run (echo_server port)
open Cmdliner
let port =
let doc = "Port to connect to" in
Arg.(value & opt int 4433 & info [ "port" ] ~doc)
let cmd =
let term = Term.(ret (const jump $ setup_log $ port))
and info = Cmd.info "fuzz_server" ~version:"2.0.3"
in
Cmd.v info term
let () = exit (Cmd.eval cmd)

29
unikernel/duniverse/ocaml-tls/lwt/examples/http_client.ml Normal file
View file

@ -0,0 +1,29 @@
open Lwt
open Ex_common
let http_client ?ca ?fp hostname port =
let port = int_of_string port in
auth ?ca ?fp () >>= fun authenticator ->
Tls_lwt.connect_ext
(get_ok (Tls.Config.client ~authenticator ()))
(hostname, port) >>= fun (ic, oc) ->
let req = String.concat "\r\n" [
"GET / HTTP/1.1" ; "Host: " ^ hostname ; "Connection: close" ; "" ; ""
] in
Lwt_io.(write oc req >>= fun () -> read ic >>= print >>= fun () -> printf "++ done.\n%!")
let () =
try
match Sys.argv with
| [| _ ; host ; port ; "FP" ; fp |] -> Lwt_main.run (http_client host port ~fp)
| [| _ ; host ; port ; trust |] -> Lwt_main.run (http_client host port ~ca:trust)
| [| _ ; host ; port |] -> Lwt_main.run (http_client host port)
| [| _ ; host |] -> Lwt_main.run (http_client host "443")
| args -> Printf.eprintf "%s <host> <port>\n%!" args.(0)
with
| Tls_lwt.Tls_alert alert as exn ->
print_alert "remote end" alert ; raise exn
| Tls_lwt.Tls_failure fail as exn ->
print_fail "our end" fail ; raise exn

39
unikernel/duniverse/ocaml-tls/lwt/examples/resume_client.ml Normal file
View file

@ -0,0 +1,39 @@
open Lwt
open Ex_common
let http_client ?ca ?fp hostname port =
let port = int_of_string port in
auth ?ca ?fp () >>= fun authenticator ->
let config = get_ok (Tls.Config.client ~authenticator ()) in
Tls_lwt.Unix.connect config (hostname, port) >>= fun t ->
Tls_lwt.Unix.write t "foo\n" >>= fun () ->
let cs = Bytes.create 4 in
Tls_lwt.Unix.read t cs >>= fun _len ->
let cached_session = match Tls_lwt.Unix.epoch t with
| Ok e -> e
| Error () -> invalid_arg "error retrieving epoch"
in
Tls_lwt.Unix.close t >>= fun () ->
Printf.printf "closed session\n" ;
let config = get_ok (Tls.Config.client ~authenticator ~cached_session ()) in
Tls_lwt.connect_ext config (hostname, port) >>= fun (ic, oc) ->
let req = String.concat "\r\n" [
"GET / HTTP/1.1" ; "Host: " ^ hostname ; "Connection: close" ; "" ; ""
] in
Lwt_io.(write oc req >>= fun () -> read ic >>= print >>= fun () -> printf "++ done.\n%!")
let () =
try
match Sys.argv with
| [| _ ; host ; port ; "FP" ; fp |] -> Lwt_main.run (http_client host port ~fp)
| [| _ ; host ; port ; trust |] -> Lwt_main.run (http_client host port ~ca:trust)
| [| _ ; host ; port |] -> Lwt_main.run (http_client host port)
| [| _ ; host |] -> Lwt_main.run (http_client host "443")
| args -> Printf.eprintf "%s <host> <port>\n%!" args.(0)
with
| Tls_lwt.Tls_alert alert as exn ->
print_alert "remote end" alert ; raise exn
| Tls_lwt.Tls_failure fail as exn ->
print_fail "our end" fail ; raise exn

123
unikernel/duniverse/ocaml-tls/lwt/examples/resume_echo_server.ml Normal file
View file

@ -0,0 +1,123 @@
open Lwt
open Ex_common
let string_of_unix_err err f p =
Printf.sprintf "Unix_error (%s, %s, %s)"
(Unix.error_message err) f p
module HT = Hashtbl.Make (Tls.Core.PreSharedKeyID)
let cache_psk, psk_cache =
let cache = HT.create 7 in
((fun psk ed -> HT.add cache psk.Tls.Core.identifier (psk, ed)),
HT.find_opt cache)
let ticket_cache = {
Tls.Config.lookup = psk_cache ;
ticket_granted = cache_psk ;
lifetime = 300l ;
timestamp = Ptime_clock.now
}
let serve_ssl port callback =
let tag = "server" in
X509_lwt.private_of_pems
~cert:server_cert
~priv_key:server_key >>= fun cert ->
let hex = Ohex.decode in
let epoch =
{
Tls.Core.side = `Client ;
state = `Established ;
protocol_version = `TLS_1_3 ;
ciphersuite = `DHE_RSA_WITH_AES_128_GCM_SHA256 ;
peer_random = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
peer_certificate_chain = [] ;
peer_certificate = None ;
peer_name = None ;
trust_anchor = None ;
received_certificates = [] ;
own_random = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
own_certificate = fst cert ;
own_private_key = Some (snd cert) ;
own_name = Some Domain_name.(host_exn (of_string_exn "tls13test.nqsb.io")) ;
master_secret = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
exporter_master_secret = "" ;
session_id = "" ;
extended_ms = true ;
alpn_protocol = None ;
tls_unique = None ;
}
and psk = {
Tls.Core.identifier = hex "0000" ;
obfuscation = Randomconv.int32 Mirage_crypto_rng.generate ;
secret = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
lifetime = 300l ;
early_data = 0l ;
issued_at = Ptime_clock.now ();
}
in
cache_psk psk epoch ;
let server_s () =
let open Lwt_unix in
let s = socket PF_INET SOCK_STREAM 0 in
setsockopt s SO_REUSEADDR true ;
bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () ->
listen s 10 ;
s in
let handle channels =
async @@ fun () ->
Lwt.catch (fun () -> callback channels >>= fun () -> yap ~tag "<- handler done")
(function
| Tls_lwt.Tls_alert a ->
yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a
| Tls_lwt.Tls_failure a ->
yap ~tag @@ "handler: " ^ Tls.Engine.string_of_failure a
| Unix.Unix_error (e, f, p) ->
yap ~tag @@ "handler: " ^ (string_of_unix_err e f p)
| _exn -> yap ~tag "handler: exception")
in
yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () ->
let rec loop s =
let authenticator ?ip:_ ~host:_ _ = Ok None in
let config = get_ok (Tls.Config.server ~certificates:(`Single cert) ~ticket_cache ~authenticator ()) in
(Lwt.catch
(fun () ->
Lwt_unix.accept s >>= fun (s, addr) ->
let txt = Unix.(match addr with
| ADDR_UNIX x -> "unix-" ^ x
| ADDR_INET (ip, p) -> string_of_inet_addr ip ^ ":" ^ string_of_int p)
in
yap ~tag:"client-connect" txt >>= fun () ->
Tls_lwt.Unix.server_of_fd config s >|= fun t -> `R t)
(function
| Unix.Unix_error (e, f, p) -> return (`L (string_of_unix_err e f p))
| Tls_lwt.Tls_alert a -> return (`L (Tls.Packet.alert_type_to_string a))
| Tls_lwt.Tls_failure f -> return (`L (Tls.Engine.string_of_failure f))
| exn -> let str = Printexc.to_string exn in return (`L ("loop: exception " ^ str)))) >>= function
| `R t ->
yap ~tag "-> connect" >>= fun () ->
handle (Tls_lwt.of_t t); loop s
| `L msg ->
yap ~tag ("server socket: " ^ msg) >>= fun () -> loop s
in
server_s () >>= fun s ->
loop s
let echo_server port =
serve_ssl port @@ fun (ic, oc) ->
lines ic |> Lwt_stream.iter_s (fun line ->
yap ~tag:"handler" ("+ " ^ string_of_int (String.length line)) >>= fun () ->
Lwt_io.write_line oc line)
let () =
let port =
try int_of_string Sys.argv.(1) with _ -> 4433
in
Lwt_main.run (echo_server port)

74
unikernel/duniverse/ocaml-tls/lwt/examples/starttls_server.ml Normal file
View file

@ -0,0 +1,74 @@
open Lwt.Infix
open Ex_common
let capability = "[CAPABILITY IMAP4rev1 LITERAL+ SASL-IR LOGIN-REFERRALS ID ENABLE IDLE STARTTLS AUTH=PLAIN] server ready.\r\n"
let ok_starttls = "OK STARTTLS\r\n"
let cert () =
X509_lwt.private_of_pems
~cert:"./certificates/server.pem"
~priv_key:"./certificates/server.key"
let init_socket addr port =
let sockaddr = Unix.ADDR_INET (Unix.inet_addr_of_string addr, port) in
let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true;
Lwt_unix.bind socket sockaddr >|= fun () ->
socket
let create_srv_socket addr port =
init_socket addr port >|= fun socket ->
Lwt_unix.listen socket 10;
socket
let accept sock =
Lwt_unix.accept sock >>= fun (sock_cl, addr) ->
let ic = Lwt_io.of_fd ~close:(fun () -> Lwt.return_unit) ~mode:Lwt_io.input sock_cl in
let oc = Lwt_io.of_fd ~close:(fun () -> Lwt.return_unit) ~mode:Lwt_io.output sock_cl in
Lwt.return ((ic,oc), addr, sock_cl)
let start_server () =
let write oc buff =
Lwt_io.write oc buff >>= fun () -> Lwt_io.flush oc
in
let read ic =
Lwt_io.read ic ~count:2048 >>= fun buff ->
Printf.printf "%s%!" buff;
Lwt.return buff
in
let parse buff =
match String.index buff ' ' with
| exception Not_found -> "", ""
| idx ->
let l = String.length buff in
String.sub buff 0 idx, String.sub buff (succ idx) (l - succ idx)
in
let rec wait_cmd sock_cl ic oc =
read ic >>= fun buff ->
let tag,cmd = parse buff in
match cmd with
| "CAPABILITY" ->
write oc ("* " ^ capability ^ tag ^ " OK CAPABILITY\r\n") >>= fun () ->
wait_cmd sock_cl ic oc
| "STARTTLS" ->
write oc (tag ^ ok_starttls) >>= fun () ->
Lwt_io.close ic >>= fun () ->
Lwt_io.close oc >>= fun () ->
cert () >>= fun cert ->
Tls_lwt.Unix.server_of_fd
(get_ok (Tls.Config.server ~certificates:(`Single cert) ())) sock_cl >>= fun s ->
let ic,oc = Tls_lwt.of_t s in
write oc ("* OK " ^ capability) >>= fun () ->
wait_cmd sock_cl ic oc
| _ ->
write oc ("BAD\r\n") >>= fun () ->
wait_cmd sock_cl ic oc
in
create_srv_socket "127.0.0.1" 143 >>= fun sock ->
accept sock >>= fun ((ic,oc), _addr, sock_cl) ->
write oc ("* OK " ^ capability) >>= fun () ->
wait_cmd sock_cl ic oc
let () =
Lwt_main.run (start_server ())

49
unikernel/duniverse/ocaml-tls/lwt/examples/test_client.ml Normal file
View file

@ -0,0 +1,49 @@
open Lwt
open Ex_common
let mypsk = ref None
let ticket_cache = {
Tls.Config.lookup = (fun _ -> None) ;
ticket_granted = (fun psk epoch -> mypsk := Some (psk, epoch)) ;
lifetime = 0l ;
timestamp = Ptime_clock.now
}
let test_client _ =
(* X509_lwt.private_of_pems
~cert:server_cert
~priv_key:server_key >>= fun cert -> *)
let port = 4433 in
let host = "127.0.0.1" in
let authenticator = null_auth in
Tls_lwt.Unix.connect
(get_ok Tls.Config.(client ~version:(`TLS_1_0, `TLS_1_3) (* ~certificates:(`Single cert) *) ?cached_ticket:!mypsk ~ticket_cache ~authenticator ~ciphers:Ciphers.supported ()))
(host, port) >>= fun t ->
let (ic, oc) = Tls_lwt.of_t t in
let req = String.concat "\r\n" [
"GET / HTTP/1.1" ; "Host: " ^ host ; "Connection: close" ; "" ; ""
] in
Lwt_io.(write oc req >>= fun () ->
read ~count:3 ic >>= print >>= fun () ->
close oc >>= fun () ->
printf "++ done.\n%!")
let jump _ =
try
Lwt_main.run (test_client ()) ; `Ok ()
with
| Tls_lwt.Tls_alert alert as exn ->
print_alert "remote end" alert ; raise exn
| Tls_lwt.Tls_failure alert as exn ->
print_fail "our end" alert ; raise exn
open Cmdliner
let cmd =
let term = Term.(ret (const jump $ setup_log))
and info = Cmd.info "test_client" ~version:"2.0.3"
in
Cmd.v info term
let () = exit (Cmd.eval cmd)

47
unikernel/duniverse/ocaml-tls/lwt/examples/test_server.ml Normal file
View file

@ -0,0 +1,47 @@
open Lwt
open Ex_common
let serve_ssl port callback =
let tag = "server" in
X509_lwt.private_of_pems
~cert:server_cert
~priv_key:server_key >>= fun certificate ->
X509_lwt.private_of_pems
~cert:server_ec_cert
~priv_key:server_ec_key >>= fun ec_certificate ->
let certificates = `Multiple [ certificate ; ec_certificate ] in
let config =
get_ok (Tls.Config.(server ~version:(`TLS_1_0, `TLS_1_3) ~certificates ~ciphers:Ciphers.supported ()))
in
let server_s =
let open Lwt_unix in
let s = socket PF_INET SOCK_STREAM 0 in
setsockopt s Unix.SO_REUSEADDR true ;
bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () ->
listen s 10 ;
s in
yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () ->
server_s >>= fun s ->
Tls_lwt.Unix.accept config s >>= fun (t, addr) ->
let channels = Tls_lwt.of_t t in
yap ~tag "-> connect" >>= fun () ->
callback channels addr >>= fun () ->
yap ~tag "<- handler done"
let test_server port =
serve_ssl port @@ fun (ic, oc) _addr ->
yap ~tag:"handler" "accepted" >>= fun () ->
Lwt_io.read_line ic >>= fun line ->
yap ~tag:"handler" ("+ " ^ line) >>= fun () ->
Lwt_io.write_line oc line
let () =
let port =
try int_of_string Sys.argv.(1) with _ -> 4433
in
Lwt_main.run (test_server port)

70
unikernel/duniverse/ocaml-tls/lwt/examples/tls_over_tls.ml Normal file
View file

@ -0,0 +1,70 @@
open Lwt
open Ex_common
let hostname = "mirage.io"
let proxy = "127.0.0.1", 3129
(* To test TLS-over-TLS, the `squid` proxy can be installed locally and configured to support HTTPS:
- Generate a certificate for localhost: https://gist.github.com/cecilemuller/9492b848eb8fe46d462abeb26656c4f8
$ openssl req -x509 -nodes -new -sha256 -days 1024 -newkey rsa:2048 -keyout RootCA.key -out RootCA.pem -subj "/C=US/CN=Example-Root-CA"
$ openssl x509 -outform pem -in RootCA.pem -out RootCA.crt
$ cat <<EOF > domains.ext
authorityKeyIdentifier=keyid,issuer
basicConstraints=CA:FALSE
keyUsage = digitalSignature, nonRepudiation, keyEncipherment, dataEncipherment
subjectAltName = @alt_names
[alt_names]
DNS.1 = localhost
EOF
$ openssl req -new -nodes -newkey rsa:2048 -keyout localhost.key -out localhost.csr -subj "/C=US/ST=YourState/L=YourCity/O=Example-Certificates/CN=localhost.local"
$ openssl x509 -req -sha256 -days 1024 -in localhost.csr -CA RootCA.pem -CAkey RootCA.key -CAcreateserial -extfile domains.ext -out localhost.crt
- Configure squid by adding HTTPS support on port 3129 in /etc/squid/squid.conf :
https_port 3129 tls-cert=/path/to/localhost.crt tls-key=/path/to/localhost.key
*)
let client = get_ok (Tls.Config.client ~authenticator:null_auth ())
let string_prefix ~prefix msg =
let len = String.length prefix in
String.length msg >= len && String.sub msg 0 len = prefix
let host = Result.get_ok (Domain_name.of_string hostname)
let host = Result.get_ok (Domain_name.host host)
let test_client _ =
(* Connect to proxy *)
Tls_lwt.Unix.connect client proxy >>= fun t ->
let (ic, oc) = Tls_lwt.of_t t in
(* Request proxy to connect to hostname *)
let req =
Printf.sprintf "CONNECT %s:443 HTTP/1.1\r\nHost: %s\r\n\r\n"
hostname hostname
in
Lwt_io.write oc req >>= fun () ->
Lwt_io.read ic ~count:1024 >>= fun msg ->
assert (string_prefix ~prefix:"HTTP/1.1 200 " msg) ;
(* TLS with hostname, over the TLS connection with the proxy *)
Tls_lwt.Unix.client_of_channels client ~host (ic, oc) >>= fun t ->
let (ic, oc) = Tls_lwt.of_t t in
(* Request homepage from host *)
let req =
Printf.sprintf "GET / HTTP/1.1\r\nHost: %s\r\nConnection: close\r\n\r\n"
hostname
in
Lwt_io.(write oc req >>= fun () ->
read ~count:1024 ic >>= print >>= fun () ->
read ~count:1024 ic >>= print >>= fun () ->
close oc >>= fun () ->
printf "++ done.\n%!")
let () = Lwt_main.run (test_client ())

364
unikernel/duniverse/ocaml-tls/lwt/tls_lwt.ml Normal file
View file

@ -0,0 +1,364 @@
open Lwt.Infix
exception Tls_alert of Tls.Packet.alert_type
exception Tls_failure of Tls.Engine.failure
(* This really belongs just about anywhere else: generic unix name resolution. *)
let resolve host service =
let open Lwt_unix in
getprotobyname "tcp" >>= fun tcp ->
getaddrinfo host service [AI_PROTOCOL tcp.p_proto] >>= function
| [] ->
let msg = Printf.sprintf "no address for %s:%s" host service in
Lwt.reraise (Invalid_argument msg)
| ai::_ -> Lwt.return ai.ai_addr
module Lwt_cs = struct
let naked ~name f fd cs off len =
f fd cs off len >>= fun res ->
match Lwt_unix.getsockopt_error fd with
| None -> Lwt.return res
| Some err -> Lwt.reraise @@ Unix.Unix_error (err, name, "")
let write = naked ~name:"Tls_lwt.write" Lwt_unix.write
and read = naked ~name:"Tls_lwt.read" Lwt_unix.read
let rec write_full ?(off = 0) ?len fd buf =
let len = Option.value ~default:(String.length buf - off) len in
if len = 0 then
Lwt.return_unit
else
write fd (Bytes.unsafe_of_string buf) off len >>= fun written ->
write_full ~off:(off + written) ~len:(len - written) fd buf
let read fd buf = read fd buf 0 (Bytes.length buf)
end
module Lwt_fd = struct
type t = {
read : bytes -> int Lwt.t ;
write : string -> unit Lwt.t ;
close : unit -> unit Lwt.t ;
}
let read t cs = t.read cs
let write t cs = t.write cs
let close t = t.close ()
let of_fd fd =
let close () =
(* (partially) avoid double-closes by checking if the fd has already been closed *)
match Lwt_unix.state fd with
| Lwt_unix.Closed -> Lwt.return_unit
| Lwt_unix.Opened | Lwt_unix.Aborted _ -> Lwt_unix.close fd
in
{
read = Lwt_cs.read fd ;
write = Lwt_cs.write_full fd ;
close = close ;
}
let of_channels ic oc =
{
read = (fun bs -> Lwt_io.read_into ic bs 0 (Bytes.length bs)) ;
write = (Lwt_io.write oc) ;
close = (fun () -> Lwt_io.close oc <&> Lwt_io.close ic) ;
}
end
module Unix = struct
type t = {
fd : Lwt_fd.t ;
mutable state : [ `Active of Tls.Engine.state
| `Read_closed of Tls.Engine.state
| `Write_closed of Tls.Engine.state
| `Closed
| `Error of exn ] ;
mutable linger : string option ;
recv_buf : bytes ;
}
let half_close state mode =
match state, mode with
| `Active tls, `read -> `Read_closed tls
| `Active tls, `write -> `Write_closed tls
| `Active _, `read_write -> `Closed
| `Read_closed tls, `read -> `Read_closed tls
| `Read_closed _, (`write | `read_write) -> `Closed
| `Write_closed tls, `write -> `Write_closed tls
| `Write_closed _, (`read | `read_write) -> `Closed
| (`Closed | `Error _) as e, (`read | `write | `read_write) -> e
let inject_state tls = function
| `Active _ -> `Active tls
| `Read_closed _ -> `Read_closed tls
| `Write_closed _ -> `Write_closed tls
| (`Closed | `Error _) as e -> e
let safely th =
Lwt.catch
(fun () -> th >>= fun _ -> Lwt.return_unit)
(function
| Out_of_memory -> raise Out_of_memory
| _ -> Lwt.return_unit)
let (read_t, write_t) =
let recording_errors op t cs =
Lwt.catch
(fun () -> op t.fd cs)
(function
| Out_of_memory -> raise Out_of_memory
| exn -> (match t.state with
| `Error _ -> ()
| _ -> t.state <- `Error exn) ;
Lwt.reraise exn)
in
(recording_errors Lwt_fd.read, recording_errors Lwt_fd.write)
let when_some f = function None -> Lwt.return_unit | Some x -> f x
let rec read_react t =
let handle tls buf =
match Tls.Engine.handle_tls tls buf with
| Ok (state', eof, `Response resp, `Data data) ->
let state' = inject_state state' t.state in
let state' = Option.(value ~default:state' (map (fun `Eof -> half_close state' `read) eof)) in
t.state <- state' ;
safely (resp |> when_some (write_t t)) >|= fun () ->
`Ok data
| Error (fail, `Response resp) ->
t.state <- `Error (match fail with
| `Alert a -> Tls_alert a
| f -> Tls_failure f);
write_t t resp >>= fun () -> read_react t
in
match t.state with
| `Error e -> Lwt.reraise e
| `Closed
| `Read_closed _ -> Lwt.return `Eof
| _ ->
read_t t t.recv_buf >>= function
| 0 ->
t.state <- half_close t.state `read;
Lwt.return `Eof
| n ->
match t.state with
| `Error e -> Lwt.reraise e
| `Active tls | `Read_closed tls | `Write_closed tls ->
handle tls (String.sub (Bytes.unsafe_to_string t.recv_buf) 0 n)
| `Closed -> Lwt.return `Eof
let rec read t ?(off = 0) buf =
if off < 0 || off >= Bytes.length buf then
invalid_arg "offset must be >= 0 and < Bytes.length buf";
let writeout res =
let rlen = String.length res in
let n = min (Bytes.length buf - off) rlen in
Bytes.blit_string res 0 buf off n ;
t.linger <-
(if n < rlen then Some (String.sub res n (rlen - n)) else None) ;
Lwt.return n in
match t.linger with
| Some res -> writeout res
| None ->
read_react t >>= function
| `Eof -> Lwt.return 0
| `Ok None -> read t ~off buf
| `Ok (Some res) -> writeout res
let writev t css =
match t.state with
| `Error err -> Lwt.reraise err
| `Write_closed _ | `Closed -> Lwt.reraise @@ Invalid_argument "tls: closed socket"
| `Active tls | `Read_closed tls ->
match Tls.Engine.send_application_data tls css with
| Some (tls, tlsdata) ->
( t.state <- inject_state tls t.state ; write_t t tlsdata )
| None -> Lwt.reraise @@ Invalid_argument "tls: write: socket not ready"
let write t cs = writev t [cs]
(*
* XXX bad XXX
* This is a point that should particularly be protected from concurrent r/w.
* Doing this before a `t` is returned is safe; redoing it during rekeying is
* not, as the API client already sees the `t` and can mistakenly interleave
* writes while this is in progress.
* *)
let rec drain_handshake t =
let push_linger t mcs =
match (mcs, t.linger) with
| (None, _) -> ()
| (scs, None) -> t.linger <- scs
| (Some cs, Some l) -> t.linger <- Some (l ^ cs)
in
match t.state with
| `Active tls when not (Tls.Engine.handshake_in_progress tls) ->
Lwt.return t
| _ ->
read_react t >>= function
| `Eof -> Lwt.reraise End_of_file
| `Ok cs -> push_linger t cs ; drain_handshake t
let reneg ?authenticator ?acceptable_cas ?cert ?(drop = true) t =
match t.state with
| `Error err -> Lwt.reraise err
| `Closed | `Read_closed _ | `Write_closed _ ->
Lwt.reraise @@ Invalid_argument "tls: closed socket"
| `Active tls ->
match Tls.Engine.reneg ?authenticator ?acceptable_cas ?cert tls with
| None -> Lwt.reraise @@ Invalid_argument "tls: can't renegotiate"
| Some (tls', buf) ->
if drop then t.linger <- None ;
t.state <- inject_state tls' t.state ;
write_t t buf >>= fun () ->
drain_handshake t >>= fun _ ->
Lwt.return_unit
let key_update ?request t =
match t.state with
| `Error err -> Lwt.reraise err
| `Write_closed _ | `Closed -> Lwt.reraise @@ Invalid_argument "tls: closed socket"
| `Active tls | `Read_closed tls ->
match Tls.Engine.key_update ?request tls with
| Error f -> Lwt.reraise @@ Invalid_argument (Format.asprintf "tls: can't update key: %a" Tls.Engine.pp_failure f)
| Ok (tls', buf) ->
t.state <- inject_state tls' t.state ;
write_t t buf
let shutdown t mode =
(match mode with
| `read -> Lwt.return_unit
| `write | `read_write ->
match t.state with
| `Active tls | `Read_closed tls ->
let tls', buf = Tls.Engine.send_close_notify tls in
t.state <- inject_state tls' (half_close t.state `write) ;
write_t t buf
| _ -> Lwt.return_unit) >>= fun () ->
t.state <- half_close t.state mode;
match t.state with
| `Closed | `Error _ -> safely (Lwt_fd.close t.fd)
| _ -> Lwt.return_unit
let close t = shutdown t `read_write
let server_of_fd config fd =
drain_handshake {
state = `Active (Tls.Engine.server config) ;
fd = fd ;
linger = None ;
recv_buf = Bytes.create 4096
}
let server_of_channels config (ic, oc) =
server_of_fd config (Lwt_fd.of_channels ic oc)
let server_of_fd config fd =
server_of_fd config (Lwt_fd.of_fd fd)
let client_of_fd config ?host fd =
let config' = match host with
| None -> config
| Some host -> Tls.Config.peer config host
in
let (tls, init) = Tls.Engine.client config' in
let t = {
state = `Active tls ;
fd = fd ;
linger = None ;
recv_buf = Bytes.create 4096
}
in
write_t t init >>= fun () ->
drain_handshake t
let client_of_channels config ?host (ic, oc) =
client_of_fd config ?host (Lwt_fd.of_channels ic oc)
let client_of_fd config ?host fd =
client_of_fd config ?host (Lwt_fd.of_fd fd)
let accept conf fd =
Lwt_unix.accept fd >>= fun (fd', addr) ->
Lwt.catch (fun () -> server_of_fd conf fd' >|= fun t -> (t, addr))
(function
| Out_of_memory -> raise Out_of_memory
| exn -> safely (Lwt_unix.close fd') >>= fun () -> Lwt.reraise exn)
let connect conf (host, port) =
resolve host (string_of_int port) >>= fun addr ->
let fd = Lwt_unix.(socket (Unix.domain_of_sockaddr addr) SOCK_STREAM 0) in
Lwt.catch (fun () ->
let host =
Result.to_option
(Result.bind (Domain_name.of_string host) Domain_name.host)
in
Lwt_unix.connect fd addr >>= fun () -> client_of_fd conf ?host fd)
(function
| Out_of_memory -> raise Out_of_memory
| exn -> safely (Lwt_unix.close fd) >>= fun () -> Lwt.reraise exn)
let read_bytes t bs off len =
let buf = Bytes.create len in
read t buf >|= fun n ->
let to_copy = min n len in
Lwt_bytes.blit_from_bytes buf 0 bs off to_copy;
to_copy
let write_bytes t bs off len =
let buf = Bytes.create len in
Lwt_bytes.blit_to_bytes bs off buf 0 len;
write t (Bytes.unsafe_to_string buf)
let epoch t =
match t.state with
| `Active tls | `Read_closed tls | `Write_closed tls -> Tls.Engine.epoch tls
| `Closed | `Error _ -> Error ()
end
type ic = Lwt_io.input_channel
type oc = Lwt_io.output_channel
let of_t ?close t =
let close = match close with
| Some f -> (fun () -> Unix.safely (f ()))
| None -> (fun () -> Unix.(safely (close t)))
in
(Lwt_io.make ~close ~mode:Lwt_io.Input (Unix.read_bytes t)),
(Lwt_io.make ~close ~mode:Lwt_io.Output @@
fun a b c -> Unix.write_bytes t a b c >>= fun () -> Lwt.return c)
let accept_ext conf fd =
Unix.accept conf fd >|= fun (t, peer) -> (of_t t, peer)
and connect_ext conf addr =
Unix.connect conf addr >|= of_t
let accept certificate fd =
match Tls.Config.server ~certificates:certificate () with
| Ok config -> accept_ext config fd >|= fun w -> Ok w
| Error _ as e -> Lwt.return e
and connect authenticator addr =
match Tls.Config.client ~authenticator () with
| Ok config -> connect_ext config addr >|= fun w -> Ok w
| Error _ as e -> Lwt.return e
(* Boot the entropy loop at module init time. *)
let () = Mirage_crypto_rng_unix.use_default ()
let () =
Printexc.register_printer (function
| Tls_alert typ ->
Some ("TLS alert from peer: " ^ Tls.Packet.alert_type_to_string typ)
| Tls_failure f ->
Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
| _ -> None)

129
unikernel/duniverse/ocaml-tls/lwt/tls_lwt.mli Normal file
View file

@ -0,0 +1,129 @@
(** Effectful operations using Lwt for pure TLS.
The pure TLS is state and buffer in, state and buffer out. This
module uses Lwt for communication over the network.
This module implements a high-level API and a low-level API (in
{!Unix}). Most applications should use the high-level API described below. *)
(** [Tls_alert] exception received from the other endpoint *)
exception Tls_alert of Tls.Packet.alert_type
(** [Tls_failure] exception while processing incoming data *)
exception Tls_failure of Tls.Engine.failure
(** Low-level API *)
module Unix : sig
(** {1 Unix API} *)
(** It is the responsibility of the client to handle error
conditions. The underlying file descriptors are not closed. *)
(** Abstract type of a session *)
type t
(** {2 Constructors} *)
(** [server_of_fd server fd] is [t], after server-side TLS
handshake of [fd] using [server] configuration. *)
val server_of_fd : Tls.Config.server -> Lwt_unix.file_descr -> t Lwt.t
(** [server_of_channels server (ic, oc)] is [t], after server-side TLS
handshake on the input/output channels [ic, oc] using [server] configuration. *)
val server_of_channels : Tls.Config.server -> Lwt_io.input_channel * Lwt_io.output_channel -> t Lwt.t
(** [client_of_fd client ~host fd] is [t], after client-side
TLS handshake of [fd] using [client] configuration and [host]. *)
val client_of_fd : Tls.Config.client -> ?host:[ `host ] Domain_name.t -> Lwt_unix.file_descr -> t Lwt.t
(** [client_of_channels client ~host (ic, oc)] is [t], after client-side
TLS handshake over the input/output channels [ic, oc] using [client] configuration and [host]. *)
val client_of_channels : Tls.Config.client -> ?host:[ `host ] Domain_name.t -> Lwt_io.input_channel * Lwt_io.output_channel -> t Lwt.t
(** [accept server fd] is [t, sockaddr], after accepting a
client on [fd] and upgrading to a TLS connection. *)
val accept : Tls.Config.server -> Lwt_unix.file_descr -> (t * Lwt_unix.sockaddr) Lwt.t
(** [connect client (host, port)] is [t], after successful
connection to [host] on [port] and TLS upgrade. *)
val connect : Tls.Config.client -> string * int -> t Lwt.t
(** {2 Common stream operations} *)
(** [read t ~off buffer] is [length], the number of bytes read into
[buffer]. It fills [buffer] starting at [off] (default is 0). *)
val read : t -> ?off:int -> bytes -> int Lwt.t
(** [write t buffer] writes the [buffer] to the session. *)
val write : t -> string -> unit Lwt.t
(** [writev t buffers] writes the [buffers] to the session. *)
val writev : t -> string list -> unit Lwt.t
(** [read_bytes t bytes offset len] is [read_bytes], the amount of
bytes read. *)
val read_bytes : t -> Lwt_bytes.t -> int -> int -> int Lwt.t
(** [write_bytes t bytes offset length] writes [length] bytes of
[bytes] starting at [offset] to the session. *)
val write_bytes : t -> Lwt_bytes.t -> int -> int -> unit Lwt.t
(** [shutdown t direction] closes the [direction] of the TLS session [t].
If [`read_write] or [`write] is closed, a TLS close_notify is sent to the
other endpoint. If this results in a fully closed session (or an
errorneous session), the underlying file descriptor is closed. *)
val shutdown : t -> [ `read | `write | `read_write ] -> unit Lwt.t
(** [close t] closes the TLS session and the underlying file descriptor. *)
val close : t -> unit Lwt.t
(** [reneg ~authenticator ~acceptable_cas ~cert ~drop t] renegotiates the
session, and blocks until the renegotiation finished. Optionally, a new
[authenticator] and [acceptable_cas] can be used. The own certificate can
be adjusted by [cert]. If [drop] is [true] (the default),
application data received before the renegotiation finished is dropped. *)
val reneg : ?authenticator:X509.Authenticator.t ->
?acceptable_cas:X509.Distinguished_name.t list -> ?cert:Tls.Config.own_cert ->
?drop:bool -> t -> unit Lwt.t
(** [key_update ~request t] updates the traffic key and requests a traffic key
update from the peer if [request] is provided and [true] (the default).
This is only supported in TLS 1.3. *)
val key_update : ?request:bool -> t -> unit Lwt.t
(** [epoch t] returns [epoch], which contains information of the
active session. *)
val epoch : t -> (Tls.Core.epoch_data, unit) result
end
(** {1 High-level API} *)
type ic = Lwt_io.input_channel
type oc = Lwt_io.output_channel
(** [accept_ext server fd] is [(ic, oc), sockaddr], the input
and output channel from an accepted connection on the given [fd],
after upgrading to TLS using the [server] configuration. *)
val accept_ext : Tls.Config.server -> Lwt_unix.file_descr ->
((ic * oc) * Lwt_unix.sockaddr) Lwt.t
(** [accept own_cert fd] is [(ic, oc), sockaddr], the input and
output channel from the accepted connection on [fd], using the
default configuration with the given [own_cert]. *)
val accept : Tls.Config.own_cert -> Lwt_unix.file_descr ->
((ic * oc) * Lwt_unix.sockaddr, [> `Msg of string]) result Lwt.t
(** [connect_ext client (host, port)] is [ic, oc], the input
and output channel of a TLS connection to [host] on [port] using
the [client] configuration. *)
val connect_ext : Tls.Config.client -> string * int -> (ic * oc) Lwt.t
(** [connect authenticator (host, port)] is [ic, oc], the input
and output channel of a TLS connection to [host] on [port] using the
default configuration and the [authenticator]. *)
val connect : X509.Authenticator.t -> string * int -> (ic * oc, [> `Msg of string ]) result Lwt.t
(** [of_t t] is [ic, oc], the input and output channel. [close]
defaults to [!Unix.close]. *)
val of_t : ?close:(unit -> unit Lwt.t) -> Unix.t -> ic * oc

109
unikernel/duniverse/ocaml-tls/lwt/x509_lwt.ml Normal file
View file

@ -0,0 +1,109 @@
open Lwt
let failure msg = fail @@ Failure msg
let catch_invalid_arg th h =
Lwt.catch (fun () -> th)
(function
| Invalid_argument msg -> h msg
| exn -> fail exn)
let (</>) a b = a ^ "/" ^ b
let o f g x = f (g x)
let read_file path =
let open Lwt_io in
open_file ~mode:Input path >>= fun file ->
read file >>= fun cs ->
close file >|= fun () ->
cs
let read_dir path =
let open Lwt_unix in
let rec collect acc d =
readdir_n d 10 >>= function
| [||] -> return acc
| xs -> collect (Array.to_list xs @ acc) d in
opendir path >>= fun dir ->
collect [] dir >>= fun entries ->
closedir dir >|= fun () ->
entries
let extension str =
let n = String.length str in
let rec scan = function
| i when i = 0 -> None
| i when str.[i - 1] = '.' ->
Some (String.sub str i (n - i))
| i -> scan (pred i) in
scan n
let private_of_pems ~cert ~priv_key =
catch_invalid_arg
(read_file cert >|= fun pem ->
match X509.Certificate.decode_pem_multiple pem with
| Ok cs -> cs
| Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m))
(o failure @@ Printf.sprintf "Private certificates (%s): %s" cert) >>= fun certs ->
catch_invalid_arg
(read_file priv_key >|= fun pem ->
match X509.Private_key.decode_pem pem with
| Ok key -> key
| Error (`Msg m) -> invalid_arg ("failed to parse private key " ^ m))
(o failure @@ Printf.sprintf "Private key (%s): %s" priv_key) >>= fun pk ->
return (certs, pk)
let certs_of_pem path =
catch_invalid_arg
(read_file path >|= fun pem ->
match X509.Certificate.decode_pem_multiple pem with
| Ok cs -> cs
| Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m))
(o failure @@ Printf.sprintf "Certificates in %s: %s" path)
let certs_of_pem_dir path =
read_dir path
>|= List.filter (fun file -> extension file = Some "crt")
>>= Lwt_list.map_p (fun file -> certs_of_pem (path </> file))
>|= List.concat
let crl_of_pem path =
catch_invalid_arg
(read_file path >|= fun data ->
match X509.CRL.decode_der data with
| Ok cs -> cs
| Error (`Msg m) -> invalid_arg ("failed to parse CRL " ^ m))
(o failure @@ Printf.sprintf "CRL in %s: %s" path)
let crls_of_pem_dir = function
| None -> Lwt.return None
| Some path ->
read_dir path >>= fun files ->
Lwt_list.map_p (fun file -> crl_of_pem (path </> file)) files >|= fun crls ->
Some crls
let authenticator ?allowed_hashes ?crls param =
let time () = Some (Ptime_clock.now ()) in
let of_cas cas =
crls_of_pem_dir crls >|= fun crls ->
X509.Authenticator.chain_of_trust ?allowed_hashes ?crls ~time cas
and dotted_hex_to_cs hex =
Ohex.decode (String.map (function ':' -> ' ' | x -> x) hex)
and fingerp hash fingerprint =
X509.Authenticator.key_fingerprint ~time ~hash ~fingerprint
and cert_fingerp hash fingerprint =
X509.Authenticator.cert_fingerprint ~time ~hash ~fingerprint
in
match param with
| `Ca_file path -> certs_of_pem path >>= of_cas
| `Ca_dir path -> certs_of_pem_dir path >>= of_cas
| `Key_fingerprint (hash, fp) -> return (fingerp hash fp)
| `Hex_key_fingerprint (hash, fp) ->
let fp = dotted_hex_to_cs fp in
return (fingerp hash fp)
| `Cert_fingerprint (hash, fp) -> return (cert_fingerp hash fp)
| `Hex_cert_fingerprint (hash, fp) ->
let fp = dotted_hex_to_cs fp in
return (cert_fingerp hash fp)

26
unikernel/duniverse/ocaml-tls/lwt/x509_lwt.mli Normal file
View file

@ -0,0 +1,26 @@
(** X.509 certificate handling using Lwt. *)
(** [private_of_pems ~cert ~priv_key] is [priv], after reading the
private key and certificate chain from the given PEM-encoded
files. *)
val private_of_pems : cert:Lwt_io.file_name -> priv_key:Lwt_io.file_name -> Tls.Config.certchain Lwt.t
(** [certs_of_pem file] is [certificates], which are read from the
PEM-encoded [file]. *)
val certs_of_pem : Lwt_io.file_name -> X509.Certificate.t list Lwt.t
(** [certs_of_pem_dir dir] is [certificates], which are read from all
PEM-encoded files in [dir]. *)
val certs_of_pem_dir : Lwt_io.file_name -> X509.Certificate.t list Lwt.t
(** [authenticator methods] constructs an [authenticator] using the
specified method and data. *)
val authenticator : ?allowed_hashes:Digestif.hash' list -> ?crls:Lwt_io.file_name ->
[ `Ca_file of Lwt_io.file_name
| `Ca_dir of Lwt_io.file_name
| `Key_fingerprint of Digestif.hash' * string
| `Hex_key_fingerprint of Digestif.hash' * string
| `Cert_fingerprint of Digestif.hash' * string
| `Hex_cert_fingerprint of Digestif.hash' * string
]
-> X509.Authenticator.t Lwt.t

4
unikernel/duniverse/ocaml-tls/miou/dune Normal file
View file

@ -0,0 +1,4 @@
(library
(name tls_miou_unix)
(public_name tls-miou-unix)
(libraries miou.unix tls))

15
unikernel/duniverse/ocaml-tls/miou/tests/dune Normal file
View file

@ -0,0 +1,15 @@
(test
(name fuzz)
(package tls-miou-unix)
(libraries
mirage-crypto-rng-miou-unix
ohex
rresult
ptime
ptime.clock.os
crowbar
hxd.core
hxd.string
tls-miou-unix)
(instrumentation
(backend bisect_ppx)))

339
unikernel/duniverse/ocaml-tls/miou/tests/fuzz.ml Normal file
View file

@ -0,0 +1,339 @@
let rec random_path ?(tries = 10) fmt =
if tries <= 0 then failwith "Impossible to generate an available random path";
let res = Bytes.create 6 in
for i = 0 to Bytes.length res - 1 do
let chr =
match Random.int (10 + 26 + 26) with
| n when n < 10 -> Char.chr (Char.code '0' + n)
| n when n < 10 + 26 -> Char.chr (Char.code 'a' + n - 10)
| n -> Char.chr (Char.code 'A' + n - 10 - 26)
in
Bytes.set res i chr
done;
let path = Fmt.str fmt (Bytes.unsafe_to_string res) in
if Sys.file_exists path then random_path ~tries:(pred tries) fmt else path
let unlink_if_exists path =
try Unix.unlink path with Unix.Unix_error (Unix.ENOENT, _, _) -> ()
let bind_and_listen ?(backlog = 16) () =
let tmp = random_path "socket-%s.socket" in
unlink_if_exists tmp;
let socket = Unix.socket ~cloexec:true Unix.PF_UNIX Unix.SOCK_STREAM 0 in
let addr = Unix.ADDR_UNIX tmp in
Unix.bind socket addr;
Unix.listen socket backlog;
(Miou_unix.of_file_descr ~non_blocking:true socket, addr, tmp)
module Ca = struct
open Rresult
let prefix =
X509.Distinguished_name.
[ Relative_distinguished_name.singleton (CN "Fuzzer") ]
let cacert_dn =
X509.Distinguished_name.(
prefix
@ [ Relative_distinguished_name.singleton (CN "Ephemeral CA for fuzzer") ])
let cacert_lifetime = Ptime.Span.v (365, 0L)
let _10s = Ptime.Span.of_int_s 10
let make domain_name seed =
let valid_from = Option.get Ptime.(sub_span (v (Ptime_clock.now_d_ps ())) _10s) in
Domain_name.of_string domain_name >>= Domain_name.host
>>= fun domain_name ->
let private_key =
let seed = Base64.decode_exn ~pad:false seed in
let g = Mirage_crypto_rng.(create ~seed (module Fortuna)) in
Mirage_crypto_pk.Rsa.generate ~g ~bits:2048 ()
in
Ptime.add_span valid_from cacert_lifetime
|> Option.to_result ~none:(R.msgf "End time out of range")
>>= fun valid_until ->
X509.Signing_request.create cacert_dn (`RSA private_key) >>= fun ca_csr ->
let extensions =
let open X509.Extension in
let key_id =
X509.Public_key.id X509.Signing_request.((info ca_csr).public_key)
in
empty
|> add Subject_alt_name
( true,
X509.General_name.(
singleton DNS [ Domain_name.to_string domain_name ]) )
|> add Basic_constraints (true, (false, None))
|> add Key_usage
(true, [ `Digital_signature; `Content_commitment; `Key_encipherment ])
|> add Subject_key_id (false, key_id)
in
X509.Signing_request.sign ~valid_from ~valid_until ~extensions
ca_csr (`RSA private_key) cacert_dn
|> R.reword_error (R.msgf "%a" X509.Validation.pp_signature_error)
>>= fun certificate ->
let fingerprint = X509.Certificate.fingerprint `SHA256 certificate in
let time () = Some (Ptime_clock.now ()) in
let authenticator =
X509.Authenticator.cert_fingerprint ~time ~hash:`SHA256
~fingerprint
in
Ok (certificate, `RSA private_key, authenticator)
end
let fuzz_coop = "fuzz.coop"
let mutex = Miou.Mutex.create ()
let epr fmt = Miou.Mutex.protect mutex @@ fun () -> Fmt.epr fmt
type operation =
| Send of string
| Recv of int
| Shutdown of [ `read | `write ]
| Close
| Noop
module Stop = struct
type t = {
mutex : Miou.Mutex.t;
condition : Miou.Condition.t;
mutable stop : bool;
}
let create () =
let mutex = Miou.Mutex.create () in
let condition = Miou.Condition.create () in
{ mutex; condition; stop = false }
let stop t =
Miou.Mutex.protect t.mutex @@ fun () ->
t.stop <- true;
Miou.Condition.broadcast t.condition
let wait t =
Miou.Mutex.protect t.mutex @@ fun () ->
while t.stop = false do
Miou.Condition.wait t.condition t.mutex
done
end
let inhibit fn = try fn () with _exn -> ()
let run ~role:_ actions tls =
let rec go buf tls = function
| [] -> Buffer.contents buf
| Noop :: actions ->
Miou.yield ();
go buf tls actions
| Send str :: actions ->
Tls_miou_unix.write tls str;
go buf tls actions
| Close :: actions ->
Tls_miou_unix.close tls;
go buf tls actions
| Shutdown cmd :: actions ->
Tls_miou_unix.shutdown tls (cmd :> [ `read | `write | `read_write ]);
go buf tls actions
| Recv len :: actions ->
let tmp = Bytes.make len '\000' in
Tls_miou_unix.really_read tls tmp;
Buffer.add_subbytes buf tmp 0 len;
go buf tls actions
in
let buf = Buffer.create 0x100 in
try go buf tls actions with
| End_of_file | Tls_miou_unix.Closed_by_peer | Tls_miou_unix.Tls_alert _
| Tls_miou_unix.Tls_failure _ ->
inhibit (fun () -> Miou_unix.close (Tls_miou_unix.file_descr tls));
Buffer.contents buf
| exn ->
inhibit (fun () -> Miou_unix.close (Tls_miou_unix.file_descr tls));
raise exn
let run_client ~to_client:actions cfg addr =
let domain = Unix.domain_of_sockaddr addr in
let socket = Unix.socket ~cloexec:true domain Unix.SOCK_STREAM 0 in
Unix.connect socket addr;
let fd = Miou_unix.of_file_descr ~non_blocking:true socket in
let tls = Tls_miou_unix.client_of_fd cfg fd in
let finally () =
inhibit (fun () -> Unix.close socket)
in
Fun.protect ~finally @@ fun () -> run ~role:"client" actions tls
let rec cleanup orphans clients =
match Miou.care orphans with
| None | Some None -> clients
| Some (Some prm) ->
let clients = Miou.await prm :: clients in
cleanup orphans clients
let rec terminate orphans clients =
match Miou.care orphans with
| None -> List.rev clients
| Some None ->
Miou.yield ();
terminate orphans clients
| Some (Some prm) ->
let clients = Miou.await prm :: clients in
terminate orphans clients
exception Stop
let run_server ~to_server:actions ~stop fd cfg =
let rec go orphans clients =
let clients = cleanup orphans clients in
let accept = Miou.async @@ fun () -> Miou_unix.accept ~cloexec:true fd in
let stop =
Miou.async @@ fun () ->
Stop.wait stop;
raise Stop
in
match Miou.await_first [ accept; stop ] with
| Error _ ->
inhibit (fun () -> Miou_unix.close fd);
terminate orphans clients
| Ok (fd, _) ->
ignore
( Miou.async ~orphans @@ fun () ->
match Tls_miou_unix.server_of_fd cfg fd with
| tls ->
let str = run ~role:"server" actions tls in
inhibit (fun () -> Miou_unix.close fd); str
| exception _ ->
Miou_unix.close fd;
String.empty );
go orphans clients
in
go (Miou.orphans ()) []
let compile to_client to_server =
let close_client close = function
| Close -> close lor 0b1100
| Shutdown `read -> close lor 0b1000
| Shutdown `write -> close lor 0b0100
| _ -> close
in
let close_server close = function
| Close -> close lor 0b0011
| Shutdown `read -> close lor 0b0010
| Shutdown `write -> close lor 0b0001
| _ -> close
in
let client = Buffer.create 0x100 in
let server = Buffer.create 0x100 in
let rec go close to_client to_server =
match (close, to_client, to_server) with
| _, [], _ | _, _, [] -> ()
| close, ((Shutdown _ | Close) as operation) :: to_client, _ ->
go (close_client close operation) to_client to_server
| close, _, ((Shutdown _ | Close) as operation) :: to_server ->
go (close_server close operation) to_client to_server
| close, Noop :: to_client, to_server | close, to_client, Noop :: to_server
->
go close to_client to_server
| close, Send str :: to_client, Recv n :: to_server ->
assert (String.length str = n);
if close land 0b0100 = 0 && close land 0b0010 = 0 then
Buffer.add_string server str;
if close land 0b0100 = 0 && close land 0b0010 = 0 then
go close to_client to_server
| close, Recv n :: to_client, Send str :: to_server ->
assert (String.length str = n);
if close land 0b1000 = 0 && close land 0b0001 = 0 then
Buffer.add_string client str;
if close land 0b1000 = 0 && close land 0b0001 = 0 then
go close to_client to_server
| _, Send _ :: _, Send _ :: _ | _, Recv _ :: _, Recv _ :: _ ->
assert false (* GADT? *)
in
go 0x0 to_client to_server;
(Buffer.contents client, Buffer.contents server)
let pp_exn ppf exn = Fmt.string ppf (Printexc.to_string exn)
let pp_str ppf str = Hxd_string.pp Hxd.default ppf str
let run seed operations =
Miou_unix.run ~domains:1 @@ fun () ->
let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in
let fd, addr, path = bind_and_listen () in
let finally () = Unix.unlink path in
Fun.protect ~finally @@ fun () ->
let cert, pk, authenticator =
Rresult.R.failwith_error_msg (Ca.make fuzz_coop seed)
in
let cfg_server =
Result.get_ok (Tls.Config.server ~certificates:(`Single ([ cert ], pk)) ())
in
let cfg_client = Result.get_ok (Tls.Config.client ~authenticator ()) in
let to_client, to_server = List.split operations in
let stop = Stop.create () in
let prm0 = Miou.async @@ fun () -> run_server ~to_server ~stop fd cfg_server in
let prm1 =
Miou.async @@ fun () ->
let finally () = Stop.stop stop in
Fun.protect ~finally @@ fun () -> run_client ~to_client cfg_client addr
in
let send_to_client, send_to_server = compile to_client to_server in
match (Miou.await prm0, Miou.await prm1) with
| Ok [ Ok send_to_server' ], Ok send_to_client' ->
Crowbar.check (String.equal send_to_client send_to_client');
Crowbar.check (String.equal send_to_server send_to_server');
let n = String.length send_to_client in
let m = String.length send_to_server in
Mirage_crypto_rng_miou_unix.kill rng;
epr "[%a] %db %db transmitted\n%!" Fmt.(styled `Green string) "OK" n m
| a, b ->
Mirage_crypto_rng_miou_unix.kill rng;
Crowbar.failf "[%a] Unexpected result: %a & %a\n%!"
Fmt.(styled `Red string) "ERROR"
Fmt.(Dump.result ~error:pp_exn ~ok:Fmt.(Dump.list (Dump.result ~error:pp_exn ~ok:pp_str))) a
Fmt.(Dump.result ~error:pp_exn ~ok:pp_str) b
let label name gen = Crowbar.with_printer Fmt.(const string name) gen
let direction =
let open Crowbar in
choose
[
label "server-to-client" (const `To_client);
label "client-to-server" (const `To_server);
]
let shutdown =
let open Crowbar in
choose
[
label "close" (const Close);
label "shutdown-recv" (const (Shutdown `read));
label "shutdown-send" (const (Shutdown `write));
label "noop" (const Noop);
]
let operation =
let open Crowbar in
map [ direction; bytes ] @@ fun direction str ->
match (direction, str) with
| _, "" -> (Noop, Noop)
| `To_server, str -> (Send str, Recv (String.length str))
| `To_client, str -> (Recv (String.length str), Send str)
let counter = Atomic.make 0
let operations =
let open Crowbar in
fix @@ fun m ->
let continue (to_client, to_server) =
if Atomic.fetch_and_add counter 1 >= 4 then const [ (Close, Close) ]
else map [ m ] @@ fun ops -> (to_client, to_server) :: ops
in
map
[ list1 operation; dynamic_bind (pair shutdown shutdown) continue ]
List.rev_append
let seed = Crowbar.(map [ bytes ] Base64.encode_exn)
let () =
Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
Crowbar.add_test ~name:"run" Crowbar.[ seed; operations ] @@ fun seed operations ->
run seed operations;
Atomic.set counter 0

332
unikernel/duniverse/ocaml-tls/miou/tls_miou_unix.ml Normal file
View file

@ -0,0 +1,332 @@
(* NOTE: the unix/tls_unix.ml is mostly copied from here, so any change should be synchronized. *)
let src = Logs.Src.create "tls-miou"
module Log = (val Logs.src_log src : Logs.LOG)
external reraise : exn -> 'a = "%reraise"
let ( $ ) f x = f x
exception Tls_alert of Tls.Packet.alert_type
exception Tls_failure of Tls.Engine.failure
exception Closed_by_peer
let () =
Printexc.register_printer @@ function
| Closed_by_peer -> Some "Connection closed by peer"
| Tls_alert alert -> Some (Tls.Packet.alert_type_to_string alert)
| Tls_failure failure -> Some (Tls.Engine.string_of_failure failure)
| _ -> None
type state =
[ `Active of Tls.Engine.state
| `Read_closed of Tls.Engine.state
| `Write_closed of Tls.Engine.state
| `Closed
| `Error of exn ]
type t = {
role : [ `Server | `Client ];
fd : Miou_unix.file_descr;
mutable state : state;
mutable linger : string option;
read_buffer_size : int;
buf : bytes;
mutable rd_closed : bool;
}
let file_descr { fd; _ } = fd
let half_close state mode =
match (state, mode) with
| `Active tls, `read -> `Read_closed tls
| `Active tls, `write -> `Write_closed tls
| `Active _, `read_write -> `Closed
| `Read_closed tls, `read -> `Read_closed tls
| `Read_closed _, (`write | `read_write) -> `Closed
| `Write_closed tls, `write -> `Write_closed tls
| `Write_closed _, (`read | `read_write) -> `Closed
| ((`Closed | `Error _) as e), (`read | `write | `read_write) -> e
let inject_state tls = function
| `Active _ -> `Active tls
| `Read_closed _ -> `Read_closed tls
| `Write_closed _ -> `Write_closed tls
| (`Closed | `Error _) as e -> e
let tls_alert a = Tls_alert a
let tls_fail f = Tls_failure f
let inhibit fn v = try fn v with _ -> ()
let write flow str =
Log.debug (fun m -> m "try to write %d byte(s)" (String.length str));
try Miou_unix.write flow.fd str with
| Unix.Unix_error ((Unix.EPIPE | Unix.ECONNRESET), _, _) ->
flow.state <- half_close flow.state `write;
raise Closed_by_peer
| Unix.Unix_error (_, _, _) as exn ->
flow.state <- `Error exn;
reraise exn
let handle flow tls str =
match Tls.Engine.handle_tls tls str with
| Ok (state, eof, `Response resp, `Data data) ->
Log.debug (fun m -> m "We handled %d byte(s)" (String.length str));
let state = inject_state state flow.state in
let state = Option.(value ~default:state (map (fun `Eof -> half_close state `read) eof)) in
flow.state <- state;
let to_close = flow.state = `Closed in
Option.iter (inhibit $ write flow) resp;
(* NOTE(dinosaure): [write flow] can set [flow.state]. So we must
check if the actual [flow.state] or the [flow.state] after [write flow]
want to close the underlying file-descriptor. *)
if to_close || flow.state = `Closed then Miou_unix.close flow.fd;
data
| Error (fail, `Response resp) ->
let exn = match fail with
| `Alert a -> tls_alert a | f -> tls_fail f in
flow.state <- `Error exn;
let _ = inhibit (write flow) resp in
raise exn
let read flow =
match Miou_unix.read flow.fd flow.buf ~off:0 ~len:(Bytes.length flow.buf) with
| 0 -> Ok String.empty
| len -> Ok (Bytes.sub_string flow.buf 0 len)
| exception Unix.Unix_error (Unix.ECONNRESET, _, _) -> Ok String.empty
| exception exn -> Error exn
let not_errored = function `Error _ -> false | _ -> true
let garbage flow = match flow.linger with
| Some "" | None -> false
| _ -> true
let read_react flow =
match flow.state with
| `Error exn -> raise exn
| `Read_closed _ | `Closed when garbage flow ->
(* XXX(dinosaure): [`Closed] can appear "at the same time" than some
application-data. In that case, we stored them into [t.linger]. Depending
on who closed the connection, [read_react] gives this /garbage/ in any
situation (even if the user closed the connection).
An extra layer with [read] below check if [`Read_closed]/[`Close] comes
from the network (the peer closed the connection) or the user. In the
first case, we must give pending application-data. In the second case,
we must return [0] (or raise [End_of_file]). *)
let mbuf = flow.linger in
flow.linger <- None;
mbuf
| `Read_closed _ | `Closed ->
(* XXX(dinosaure): the goal of [read_react] is to read some encrypted bytes
and try to decrypt them with [handle]. If the linger is empty, this means
that we're trying to get more data (to decrypt) when we can't get any
more. From this point of view, it's an error that needs to be notified.
However, this error can be interpreted in 2 ways:
- we want to have more data decrypted. In this case, this error is
expected and may result in the user being told that there is nothing
left to read (for example, returning 0).
- we attempt a handshake. In this case, we are dealing with an unexpected
error. *)
raise End_of_file
| `Active _ | `Write_closed _ ->
Log.debug (fun m -> m "read something from the TLS session");
match read flow with
| Error exn ->
if not_errored flow.state then flow.state <- `Error exn;
raise exn
| Ok "" ->
(* XXX(dinosaure): see [`Read_closed _ | `Closed] case. *)
raise End_of_file
| Ok str ->
Log.debug (fun m -> m "got %d byte(s)" (String.length str));
match flow.state with
| `Active tls | `Read_closed tls | `Write_closed tls -> handle flow tls str
| `Closed -> raise End_of_file
| `Error exn -> raise exn
[@@ocamlformat "disable"]
let rec read_in flow ?(off= 0) ?len buf =
let len = Option.value ~default:(Bytes.length buf - off) len in
let write_in res =
let rlen = String.length res in
let mlen = min len rlen in
Bytes.blit_string res 0 buf off mlen;
let linger = if mlen < rlen
then Some (String.sub res mlen (rlen - mlen))
else None in
flow.linger <- linger; mlen
in
match flow.linger with
| Some res -> write_in res
| None -> (
match read_react flow with
| None -> read_in ~off ~len flow buf
| Some res -> write_in res)
let writev flow bufs =
match flow.state with
| `Closed | `Write_closed _ -> raise Closed_by_peer
| `Error exn -> reraise exn
| `Active tls | `Read_closed tls -> (
match Tls.Engine.send_application_data tls bufs with
| Some (tls, answer) ->
flow.state <- inject_state tls flow.state;
write flow answer
| None -> assert false)
let rec drain_handshake flow =
let push_linger flow mcs =
match (mcs, flow.linger) with
| None, _ -> ()
| scs, None -> flow.linger <- scs
| Some cs, Some l -> flow.linger <- Some (l ^ cs)
in
match flow.state with
| `Active tls when not (Tls.Engine.handshake_in_progress tls) -> flow
| (`Read_closed _ | `Closed) when garbage flow -> flow
| _ ->
Log.debug (fun m -> m "start to read something from the TLS session");
let mcs = read_react flow in
push_linger flow mcs;
drain_handshake flow
let close flow =
match flow.state with
| `Active tls | `Read_closed tls ->
let tls, str = Tls.Engine.send_close_notify tls in
flow.rd_closed <- true;
flow.state <- inject_state tls flow.state;
flow.state <- `Closed;
inhibit (write flow) str;
Miou_unix.close flow.fd
| `Write_closed _ ->
flow.rd_closed <- true;
flow.state <- `Closed;
Miou_unix.close flow.fd
| `Closed -> flow.rd_closed <- true
| `Error _ ->
flow.rd_closed <- true;
Miou_unix.close flow.fd
let closed_by_user flow = function
| `read | `read_write -> flow.rd_closed <- true
| `write -> ()
let shutdown flow mode =
closed_by_user flow mode;
match (flow.state, mode) with
| `Active tls, `read ->
Log.debug (fun m -> m "shutdown `read");
flow.state <- inject_state tls (half_close flow.state mode)
| (`Active tls | `Read_closed tls), (`write | `read_write) ->
let tls, str = Tls.Engine.send_close_notify tls in
flow.state <- inject_state tls (half_close flow.state mode);
(* NOTE(dinosaure): [write flow] can set [flow.state]. So we must
check if the actual [flow.state] or the [flow.state] after [write flow]
want to close the underlying file-descriptor. *)
let to_close = flow.state = `Closed in
inhibit (write flow) str;
if to_close || flow.state = `Closed then Miou_unix.close flow.fd
| `Write_closed tls, (`read | `read_write) ->
flow.state <- inject_state tls (half_close flow.state mode);
if flow.state = `Closed then Miou_unix.close flow.fd
| `Error _, _ -> Miou_unix.close flow.fd
| `Read_closed _, `read -> ()
| `Write_closed _, `write -> ()
| `Closed, _ -> ()
let client_of_fd conf ?(read_buffer_size = 0x1000) ?host fd =
let conf' =
match host with None -> conf | Some host -> Tls.Config.peer conf host
in
let tls, init = Tls.Engine.client conf' in
let tls_flow =
{
role = `Client;
fd;
state = `Active tls;
linger = None;
read_buffer_size;
buf = Bytes.make read_buffer_size '\000';
rd_closed = false;
}
in
write tls_flow init;
drain_handshake tls_flow
let server_of_fd conf ?(read_buffer_size = 0x1000) fd =
let tls = Tls.Engine.server conf in
let tls_flow =
{
role = `Server;
fd;
state = `Active tls;
linger = None;
read_buffer_size;
buf = Bytes.make read_buffer_size '\000';
rd_closed = false;
}
in
drain_handshake tls_flow
let write flow ?(off = 0) ?len str =
let len = Option.value ~default:(String.length str - off) len in
if off < 0 || len < 0 || off > String.length str - len
then invalid_arg "Tls_miou.write";
if len > 0 then writev flow [ String.sub str off len ]
let read t ?(off= 0) ?len buf =
let len = Option.value ~default:(Bytes.length buf - off) len in
if off < 0 || len < 0 || off > Bytes.length buf - len
then invalid_arg "Tls_miou.read";
if t.rd_closed then 0
else try read_in t ~off ~len buf with End_of_file -> 0
let rec really_read_go t off len buf =
let len' = read t buf ~off ~len in
if len' == 0 then raise End_of_file
else if len - len' > 0
then really_read_go t (off + len') (len - len') buf
let really_read t ?(off= 0) ?len buf =
let len = Option.value ~default:(Bytes.length buf - off) len in
if off < 0 || len < 0 || off > Bytes.length buf - len
then invalid_arg "Tls_miou.really_read";
if len > 0 then really_read_go t off len buf
let resolve host service =
let tcp = Unix.getprotobyname "tcp" in
match Unix.getaddrinfo host service [ AI_PROTOCOL tcp.p_proto ] with
| [] -> Fmt.invalid_arg "No address for %s:%s" host service
| ai :: _ -> ai.ai_addr
let connect authenticator (v, port) =
let conf =
match Tls.Config.client ~authenticator () with
| Ok config -> config
| Error `Msg msg -> Fmt.invalid_arg "Configuration failure: %s" msg
in
let addr = resolve v (string_of_int port) in
let fd =
match addr with
| Unix.ADDR_UNIX _ -> invalid_arg "Tls_miou.connect: Invalid UNIX socket"
| Unix.ADDR_INET (inet_addr, _) ->
if Unix.is_inet6_addr inet_addr then Miou_unix.tcpv6 ()
else Miou_unix.tcpv4 ()
in
let host = Result.to_option Domain_name.(Result.bind (of_string v) host) in
match Miou_unix.connect fd addr with
| () -> client_of_fd conf ?host fd
| exception exn ->
Miou_unix.close fd;
raise exn
let epoch flow = match flow.state with
| `Active tls | `Read_closed tls | `Write_closed tls ->
( match Tls.Engine.epoch tls with
| Error () -> assert false
| Ok data -> Some data )
| _ -> None

96
unikernel/duniverse/ocaml-tls/miou/tls_miou_unix.mli Normal file
View file

@ -0,0 +1,96 @@
(** Effectful operations using Miou for pure TLS.
The pure TLS is state and buffer in, state and buffer out. This module uses
Miou (and its Unix layer) for communication over the network. *)
exception Tls_alert of Tls.Packet.alert_type
exception Tls_failure of Tls.Engine.failure
exception Closed_by_peer
type t
(** Abstract type of a session. *)
val file_descr : t -> Miou_unix.file_descr
(** [file_descr] returns the underlying file-descriptor used by the given
TLS {i socket}. *)
val read : t -> ?off:int -> ?len:int -> bytes -> int
(** [read fd buf ~off ~len] reads up to [len] bytes (defaults to
[Bytes.length buf - off] from the given TLS {i socket} [fd], storing them in
byte sequence [buf], starting at position [off] in [buf] (defaults to [0]).
It returns the actual number of characters read, between 0 and [len]
(inclusive).
@raise Unix_error raised by the system call {!val:Unix.read}. The function
handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK}
exceptions and redo the system call.
@raise Invalid_argument if [off] and [len] do not designate a valid range of
[buf]. *)
val really_read : t -> ?off:int -> ?len:int -> bytes -> unit
(** [really_read fd buf ~off ~len] reads [len] bytes (defaults to
[Bytes.length buf - off]) from the given TLS {i socket} [fd], storing them
in byte sequence [buf], starting at position [off] in [buf] (defaults to
[0]). If [len = 0], [really_read] does nothing.
@raise Unix_error raised by the system call {!val:Unix.read}. The function
handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK}
exceptions and redo the system call.
@raise End_of_file if {!val:Unix.read} returns [0] before [len] characters
have been read.
@raise Invalid_argument if [off] and [len] do not designate a valid range of
[buf]. *)
val write : t -> ?off:int -> ?len:int -> string -> unit
(** [write t str ~off ~len] writes [len] bytes (defaults to
[String.length str - off]) from byte sequence [str], starting at offset
[off] (defaults to [0]), to the given TLS {i socket} [fd].
@raise Unix_error raised by the syscall call {!val:Unix.write}. The function
handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK}
exceptions and redo the system call.
@raise Closed_by_peer if [t] is connected to a peer whose reading end is
closed. Similar to the {!val:EPIPE} error for pipe/socket connected.
@raise Invalid_argument if [off] and [len] do not designate a valid range of
[buf]. *)
val close : t -> unit
(** [close flow] closes the TLS session and the underlying file-descriptor. *)
val shutdown : t -> [ `read | `write | `read_write ] -> unit
(** [shutdown t direction] closes the direction of the TLS session [t]. If
[`read_write] or [`write] is closed, a TLS close-notify is sent to the other
endpoint. If this results in a fully-closed session (or an errorneous
session), the underlying file descriptor is closed. *)
val client_of_fd :
Tls.Config.client ->
?read_buffer_size:int ->
?host:[ `host ] Domain_name.t ->
Miou_unix.file_descr ->
t
(** [client_of_flow client ~host fd] is [t], after client-side TLS handshake of
[fd] using [client] configuration and [host].
@raise End_of_file if we are not able to complete the handshake. *)
val server_of_fd :
Tls.Config.server -> ?read_buffer_size:int -> Miou_unix.file_descr -> t
(** [server_of_fd server fd] is [t], after server-side TLS handshake of [fd]
using [server] configuration.
@raise End_of_file if we are not able to complete the handshake. *)
val connect : X509.Authenticator.t -> string * int -> t
(** [connect authenticator (host, port)] is [t], a connected TLS connection
to [host] on [port] using the default configuration and the
[authenticator]. *)
val epoch : t -> Tls.Core.epoch_data option
(** [epoch t] returns [epoch], which contains information of the active
session. *)

5
unikernel/duniverse/ocaml-tls/mirage/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name tls_mirage)
(public_name tls-mirage)
(wrapped false)
(libraries tls lwt ptime mirage-flow mirage-kv mirage-ptime mirage-crypto mirage-crypto-pk))

1
unikernel/duniverse/ocaml-tls/mirage/example/.gitignore vendored Normal file
View file

@ -0,0 +1 @@
/static?.ml*

32
unikernel/duniverse/ocaml-tls/mirage/example/config.ml Normal file
View file

@ -0,0 +1,32 @@
open Mirage
let secrets_dir = "sekrit"
let build =
try
match Sys.getenv "BUILD" with
| "client" -> `Client
| _ -> `Server
with Not_found -> `Server
let disk = generic_kv_ro secrets_dir
let stack = generic_stackv4 default_network
let packages = [
package ~sublibs:["mirage"] "tls" ;
package ~sublibs:["lwt"] "logs"
]
let server =
foreign ~deps:[abstract nocrypto] ~packages "Unikernel.Server" @@ stackv4 @-> kv_ro @-> pclock @-> job
let client =
foreign ~deps:[abstract nocrypto] ~packages "Unikernel.Client" @@ stackv4 @-> kv_ro @-> pclock @-> job
let () =
match build with
| `Server ->
register "tls-server" [ server $ stack $ disk $ default_posix_clock ]
| `Client ->
register "tls-client" [ client $ stack $ disk $ default_posix_clock ]

4157
unikernel/duniverse/ocaml-tls/mirage/example/sekrit/ca-roots.crt Normal file
View file

File diff suppressed because it is too large Load diff

15
unikernel/duniverse/ocaml-tls/mirage/example/sekrit/server.key Normal file
View file

@ -0,0 +1,15 @@
-----BEGIN RSA PRIVATE KEY-----
MIICXQIBAAKBgQC2QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJv
K+aOANKIsOOr9v4RiEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTRE
BE/t1soVT3a/vVJWCLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQAB
AoGAd/CShG8g/JBMh9Nz/8KAuKHRHc2BvysIM1C62cSosgaFmdRrazJfBrEv3Nlc
2/0uc2dVYIxuvm8bIFqi2TWOdX9jWJf6oXwEPXCD0SaDbJTaoh0b+wjyHuaGlttY
Ztvmf8mK1BOhyl3vNMxh/8Re0dGvGgPZHpn8zanaqfGVz+ECQQDngieUpwzxA0QZ
GZKRYhHoLEaPiQzBaXphqWcCLLN7oAKxZlUCUckxRRe0tKINf0cB3Kr9gGQjPpm0
YoqXo8mNAkEAyYgdd+JDi9FH3Cz6ijvPU0hYkriwTii0V09+Ar5DvYQNzNEIEJu8
Q3Yte/TPRuK8zhnp97Bsy9v/Ji/LSWbtZQJBAJe9y8u3otfmWCBLjrIUIcCYJLe4
ENBFHp4ctxPJ0Ora+mjkthuLF+BfdSZQr1dBcX1a8giuuvQO+Bgv7r9t75ECQC7F
omEyaA7JEW5uGe9/Fgz0G2ph5rkdBU3GKy6jzcDsJu/EC6UfH8Bgawn7tSd0c/E5
Xm2Xyog9lKfeK8XrV2kCQQCTico5lQPjfIwjhvn45ALc/0OrkaK0hQNpXgUNFJFQ
tuX2WMD5flMyA5PCx5XBU8gEMHYa8Kr5d6uoixnbS0cZ
-----END RSA PRIVATE KEY-----

15
unikernel/duniverse/ocaml-tls/mirage/example/sekrit/server.pem Normal file
View file

@ -0,0 +1,15 @@
-----BEGIN CERTIFICATE-----
MIICYzCCAcwCCQDLbE6ES1ih1DANBgkqhkiG9w0BAQUFADB2MQswCQYDVQQGEwJB
VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0
cyBQdHkgTHRkMRUwEwYDVQQDDAxZT1VSIE5BTUUhISExGDAWBgkqhkiG9w0BCQEW
CW1lQGJhci5kZTAeFw0xNDAyMTcyMjA4NDVaFw0xNTAyMTcyMjA4NDVaMHYxCzAJ
BgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l
dCBXaWRnaXRzIFB0eSBMdGQxFTATBgNVBAMMDFlPVVIgTkFNRSEhITEYMBYGCSqG
SIb3DQEJARYJbWVAYmFyLmRlMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC2
QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJvK+aOANKIsOOr9v4R
iEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTREBE/t1soVT3a/vVJW
CLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQABMA0GCSqGSIb3DQEB
BQUAA4GBAIo4ZppIlp3JRyltRC1/AyCC0tsh5TdM3W7258wdoP3lEe08UlLwpnPc
aJ/cX8rMG4Xf4it77yrbVrU3MumBEGN5TW4jn4+iZyFbp6TT3OUF55nsXDjNHBbu
deDVpGuPTI6CZQVhU5qEMF3xmlokG+VV+HCDTglNQc+fdLM0LoNF
-----END CERTIFICATE-----

96
unikernel/duniverse/ocaml-tls/mirage/example/unikernel.ml Normal file
View file

@ -0,0 +1,96 @@
open Lwt.Infix
let escape_data buf = String.escaped (Cstruct.to_string buf)
let make_tracer dump =
let traces = ref [] in
let trace sexp =
traces := Sexplib.Sexp.to_string_hum sexp :: !traces
and flush () =
let msgs = List.rev !traces in
traces := [] ;
Lwt_list.iter_s dump msgs in
(trace, flush)
module Server (S : Mirage_stack.V4)
(KV : Mirage_kv.RO)
(CL : Mirage_clock.PCLOCK) =
struct
module TLS = Tls_mirage.Make (S.TCPV4)
module X509 = Tls_mirage.X509 (KV) (CL)
let rec handle flush tls =
TLS.read tls >>= fun res ->
flush () >>= fun () ->
match res with
| Ok (`Data buf) ->
Logs_lwt.info (fun p -> p "recv %s" (escape_data buf)) >>= fun () ->
(TLS.write tls buf >>= function
| Ok () -> handle flush tls
| Error e -> Logs_lwt.err (fun p -> p "write error %a" TLS.pp_write_error e))
| Ok `Eof -> Logs_lwt.info (fun p -> p "eof from server")
| Error e -> Logs_lwt.err (fun p -> p "read error %a" TLS.pp_error e)
let accept conf k flow =
let trace, flush_trace =
make_tracer (fun s -> Logs_lwt.debug (fun p -> p "%s" s))
in
Logs_lwt.info (fun p -> p "accepted.") >>= fun () ->
TLS.server_of_flow ~trace conf flow >>= function
| Ok tls -> Logs_lwt.info (fun p -> p "shook hands") >>= fun () -> k flush_trace tls
| Error e -> Logs_lwt.err (fun p -> p "%a" TLS.pp_write_error e)
let start stack kv _ _ =
X509.certificate kv `Default >>= fun cert ->
let conf = Tls.Config.server ~certificates:(`Single cert) () in
S.listen_tcpv4 stack ~port:4433 (accept conf handle) ;
S.listen stack
end
module Client (S : Mirage_stack.V4)
(KV : Mirage_kv.RO)
(CL : Mirage_clock.PCLOCK) =
struct
module TLS = Tls_mirage.Make (S.TCPV4)
module X509 = Tls_mirage.X509 (KV) (CL)
open Ipaddr
let peer = ((V4.of_string_exn "127.0.0.1", 4433), "localhost")
let peer = ((V4.of_string_exn "2.19.157.15", 443), "www.apple.com")
let peer = ((V4.of_string_exn "74.125.195.103", 443), "www.google.com")
let peer = ((V4.of_string_exn "10.0.0.1", 4433), "localhost")
let peer = ((V4.of_string_exn "23.253.164.126", 443), "tls.openmirage.org")
let peer = ((V4.of_string_exn "216.105.38.15", 443), "slashdot.org")
let peer = ((V4.of_string_exn "46.43.42.136", 443), "mirage.io")
let peer = ((V4.of_string_exn "198.167.222.205", 443), "hannes.nqsb.io")
let initial = Cstruct.of_string @@
"GET / HTTP/1.1\r\nConnection: Close\r\nHost: " ^ snd peer ^ "\r\n\r\n"
let chat tls =
let rec dump () =
TLS.read tls >>= function
| Ok (`Data buf) -> Logs_lwt.info (fun p -> p "recv %s" (escape_data buf)) >>= dump
| Ok `Eof -> Logs_lwt.info (fun p -> p "eof")
| Error e -> Logs_lwt.err (fun p -> p "chat err %a" TLS.pp_error e)
in
TLS.write tls initial >>= function
| Ok () -> dump ()
| Error e -> Logs_lwt.err (fun p -> p "write error %a" TLS.pp_write_error e)
let start stack kv _clock _ =
X509.authenticator kv `CAs >>= fun authenticator ->
let conf = Tls.Config.client ~authenticator () in
S.TCPV4.create_connection (S.tcpv4 stack) (fst peer)
>>= function
| Error e -> Logs_lwt.err (fun p -> p "%a" S.TCPV4.pp_error e)
| Ok tcp ->
TLS.client_of_flow conf ~host:(snd peer) tcp >>= function
| Ok tls -> chat tls
| Error e -> Logs_lwt.err (fun p -> p "%a" TLS.pp_write_error e)
end

17
unikernel/duniverse/ocaml-tls/mirage/example2/config.ml Normal file
View file

@ -0,0 +1,17 @@
open Mirage
let secrets_dir = "sekrit"
let disk = direct_kv_ro secrets_dir
and stack = generic_stackv4 default_network
let packages = [
package "cohttp-mirage" ;
package ~min:"0.99" "cohttp-lwt" ;
package ~sublibs:["mirage"] "tls" ;
package "tcpip" ;
]
let server = foreign ~deps:[abstract nocrypto] ~packages "Unikernel.Main" @@ stackv4 @-> kv_ro @-> pclock @-> job
let () =
register "tls-server" [ server $ stack $ disk $ default_posix_clock ]

15
unikernel/duniverse/ocaml-tls/mirage/example2/sekrit/server.key Normal file
View file

@ -0,0 +1,15 @@
-----BEGIN RSA PRIVATE KEY-----
MIICXQIBAAKBgQC2QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJv
K+aOANKIsOOr9v4RiEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTRE
BE/t1soVT3a/vVJWCLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQAB
AoGAd/CShG8g/JBMh9Nz/8KAuKHRHc2BvysIM1C62cSosgaFmdRrazJfBrEv3Nlc
2/0uc2dVYIxuvm8bIFqi2TWOdX9jWJf6oXwEPXCD0SaDbJTaoh0b+wjyHuaGlttY
Ztvmf8mK1BOhyl3vNMxh/8Re0dGvGgPZHpn8zanaqfGVz+ECQQDngieUpwzxA0QZ
GZKRYhHoLEaPiQzBaXphqWcCLLN7oAKxZlUCUckxRRe0tKINf0cB3Kr9gGQjPpm0
YoqXo8mNAkEAyYgdd+JDi9FH3Cz6ijvPU0hYkriwTii0V09+Ar5DvYQNzNEIEJu8
Q3Yte/TPRuK8zhnp97Bsy9v/Ji/LSWbtZQJBAJe9y8u3otfmWCBLjrIUIcCYJLe4
ENBFHp4ctxPJ0Ora+mjkthuLF+BfdSZQr1dBcX1a8giuuvQO+Bgv7r9t75ECQC7F
omEyaA7JEW5uGe9/Fgz0G2ph5rkdBU3GKy6jzcDsJu/EC6UfH8Bgawn7tSd0c/E5
Xm2Xyog9lKfeK8XrV2kCQQCTico5lQPjfIwjhvn45ALc/0OrkaK0hQNpXgUNFJFQ
tuX2WMD5flMyA5PCx5XBU8gEMHYa8Kr5d6uoixnbS0cZ
-----END RSA PRIVATE KEY-----

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