├── lib ├── explorator.ml ├── dune ├── handshake_server.mli ├── handshake_client.mli ├── handshake_crypto.mli ├── utils.ml ├── writer.mli ├── reader.mli ├── handshake_crypto.ml ├── crypto.ml ├── handshake_crypto13.ml ├── config.mli └── engine.mli ├── mirage ├── example │ ├── .gitignore │ ├── sekrit │ │ ├── server.key │ │ ├── server.pem │ │ └── ca-roots.crt │ ├── config.ml │ └── unikernel.ml ├── example2 │ ├── sekrit │ │ ├── server.key │ │ └── server.pem │ ├── config.ml │ └── unikernel.ml ├── dune └── tls_mirage.mli ├── tests ├── server.key ├── server.pem ├── unittestrunner.ml ├── unittests.ml ├── dh.pem ├── dune ├── testlib.ml ├── interop-mbedtls-client2.sh ├── interop-openssl-sclient.sh ├── interop-openssl-sserver.sh └── feedback.ml ├── dune-project ├── async ├── session.mli ├── io.mli ├── dune ├── examples │ ├── dune │ ├── test_client.ml │ └── test_server.ml ├── session.ml ├── io_intf.ml ├── tls_async.mli ├── tls_async.ml ├── x509_async.mli ├── io.ml └── x509_async.ml ├── miou ├── dune ├── tests │ └── dune └── tls_miou_unix.mli ├── eio ├── dune ├── tests │ ├── test_rng.ml │ ├── mock_socket.mli │ ├── dune │ ├── mock_socket.ml │ ├── tls_eio.md │ └── fuzz.ml ├── x509_eio.mli ├── tls_eio.mli ├── x509_eio.ml └── tls_eio.ml ├── bench └── dune ├── unix ├── dune └── tls_unix.mli ├── lwt ├── dune ├── examples │ ├── echo_client_alpn.ml │ ├── http_client.ml │ ├── test_server.ml │ ├── test_client.ml │ ├── ex_common.ml │ ├── resume_client.ml │ ├── dune │ ├── echo_server_sni.ml │ ├── echo_server_alpn.ml │ ├── echo_client.ml │ ├── starttls_server.ml │ ├── tls_over_tls.ml │ ├── echo_server.ml │ ├── fuzz_server.ml │ └── resume_echo_server.ml ├── x509_lwt.mli ├── x509_lwt.ml └── tls_lwt.mli ├── certificates ├── server-ec.key ├── server-ec.pem ├── bar.pem ├── foo.pem ├── server.key └── server.pem ├── .gitignore ├── tls-lwt.opam ├── tls-miou-unix.opam ├── tls-mirage.opam ├── tls-async.opam ├── LICENSE.md ├── tls-eio.opam ├── sni.md ├── tls.opam └── README.md /lib/explorator.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /mirage/example/.gitignore: -------------------------------------------------------------------------------- 1 | /static?.ml* 2 | -------------------------------------------------------------------------------- /tests/server.key: -------------------------------------------------------------------------------- 1 | ../certificates/server.key -------------------------------------------------------------------------------- /tests/server.pem: -------------------------------------------------------------------------------- 1 | ../certificates/server.pem -------------------------------------------------------------------------------- /mirage/example/sekrit/server.key: -------------------------------------------------------------------------------- 1 | ../../../certificates/server.key -------------------------------------------------------------------------------- /mirage/example/sekrit/server.pem: -------------------------------------------------------------------------------- 1 | ../../../certificates/server.pem -------------------------------------------------------------------------------- /mirage/example2/sekrit/server.key: -------------------------------------------------------------------------------- 1 | ../../../certificates/server.key -------------------------------------------------------------------------------- /mirage/example2/sekrit/server.pem: -------------------------------------------------------------------------------- 1 | ../../../certificates/server.pem -------------------------------------------------------------------------------- /mirage/example/sekrit/ca-roots.crt: -------------------------------------------------------------------------------- 1 | ../../../certificates/ca-root-nss-short.crt -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) 2 | (name tls) 3 | (formatting disabled) 4 | (using mdx 0.2) 5 | -------------------------------------------------------------------------------- /tests/unittestrunner.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let () = run_test_tt_main Unittests.suite 4 | -------------------------------------------------------------------------------- /async/session.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | include Io.S with type Fd.t = Reader.t * Writer.t 4 | -------------------------------------------------------------------------------- /miou/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tls_miou_unix) 3 | (public_name tls-miou-unix) 4 | (libraries miou.unix tls)) 5 | -------------------------------------------------------------------------------- /eio/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tls_eio) 3 | (public_name tls-eio) 4 | (wrapped false) 5 | (libraries tls eio ptime.clock.os)) 6 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name speed) 3 | (libraries fmt.tty logs.fmt mirage-crypto-rng mirage-crypto-rng.unix tls ptime.clock.os)) 4 | -------------------------------------------------------------------------------- /async/io.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | module type Fd = Io_intf.Fd 4 | module type S = Io_intf.S 5 | 6 | module Make (Fd : Fd) : S with module Fd := Fd 7 | -------------------------------------------------------------------------------- /unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tls_unix) 3 | (public_name tls.unix) 4 | (wrapped false) 5 | (libraries tls unix ptime.clock.os mirage-crypto-rng.unix)) 6 | -------------------------------------------------------------------------------- /lwt/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tls_lwt) 3 | (public_name tls-lwt) 4 | (wrapped false) 5 | (libraries tls lwt lwt.unix ptime.clock.os mirage-crypto-rng.unix)) 6 | -------------------------------------------------------------------------------- /mirage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tls_mirage) 3 | (public_name tls-mirage) 4 | (wrapped false) 5 | (libraries tls lwt ptime mirage-flow mirage-kv mirage-ptime mirage-crypto mirage-crypto-pk)) 6 | -------------------------------------------------------------------------------- /async/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tls_async) 3 | (public_name tls-async) 4 | (preprocess (pps ppx_jane)) 5 | (libraries async core cstruct-async mirage-crypto-rng mirage-crypto-rng.unix tls)) 6 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tls) 3 | (public_name tls) 4 | (libraries logs kdf.hkdf ohex digestif mirage-crypto mirage-crypto-rng 5 | mirage-crypto-pk x509 domain-name fmt mirage-crypto-ec ipaddr)) 6 | -------------------------------------------------------------------------------- /certificates/server-ec.key: -------------------------------------------------------------------------------- 1 | -----BEGIN PRIVATE KEY----- 2 | MGACAQAwEAYHKoZIzj0CAQYFK4EEACMESTBHAgEBBEIAtmFgIVel9k9Ivp7S5Mlc 3 | adxdv3KvDHc1j787n4avTUpzk+Aj7g0zxen7UsBOk2q/EGbZbtVFsO4zdOvPqP1+ 4 | m94= 5 | -----END PRIVATE KEY----- 6 | -------------------------------------------------------------------------------- /tests/unittests.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let suite = 4 | "All" >::: [ 5 | "Reader" >::: Readertests.reader_tests ; 6 | "Writer" >::: Writertests.writer_tests ; 7 | "ReaderWriter" >::: Readerwritertests.readerwriter_tests ; 8 | ] 9 | -------------------------------------------------------------------------------- /tests/dh.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN DH PARAMETERS----- 2 | MIGHAoGBAPmqFdDJzIT7OkV3ilTUbNK/vi8uosLWRg6BPoS3JdyUYchJgrXTX1wn 3 | YDOMD64s+5mONvFY4qOMBvdHgWYsppunnZT4UN18QkZeLuWslu12RiDUbI7HY5vY 4 | 0NX2NvKfBXVp0lChvM1v9s7N14ID3t7cXlfwu3IaAcs3jgc2ZR9TAgEC 5 | -----END DH PARAMETERS----- 6 | 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | *.native 3 | *.byte 4 | *.install 5 | .merlin 6 | 7 | main.ml 8 | .mirage.config 9 | mirage-unikernel*opam 10 | mirage/*/myocamlbuild.ml 11 | mirage/*/*ukvm 12 | mirage/*/tls_client 13 | mirage/*/tls_server 14 | Makefile 15 | key_gen.ml 16 | 17 | random/ -------------------------------------------------------------------------------- /miou/tests/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name fuzz) 3 | (package tls-miou-unix) 4 | (libraries 5 | mirage-crypto-rng-miou-unix 6 | ohex 7 | rresult 8 | ptime 9 | ptime.clock.os 10 | crowbar 11 | hxd.core 12 | hxd.string 13 | tls-miou-unix) 14 | (instrumentation 15 | (backend bisect_ppx))) 16 | -------------------------------------------------------------------------------- /lib/handshake_server.mli: -------------------------------------------------------------------------------- 1 | open State 2 | 3 | val hello_request : handshake_state -> (handshake_return, failure) result 4 | 5 | val handle_change_cipher_spec : server_handshake_state -> handshake_state -> string -> (handshake_return, failure) result 6 | val handle_handshake : server_handshake_state -> handshake_state -> string -> (handshake_return, failure) result 7 | -------------------------------------------------------------------------------- /eio/tests/test_rng.ml: -------------------------------------------------------------------------------- 1 | (* Insecure predictable RNG for fuzz testing. *) 2 | 3 | type g = int ref 4 | 5 | let block = 1 6 | 7 | let create ?time:_ () = ref 1234 8 | 9 | let generate_into ~g buf ~off n = 10 | for i = off to off + n - 1 do 11 | Bytes.set_uint8 buf i !g; 12 | g := !g + 1 13 | done 14 | 15 | let reseed ~g:_ _ = () 16 | 17 | let accumulate ~g:_ _ = `Acc ignore 18 | 19 | let seeded ~g:_ = true 20 | 21 | let pools = 0 22 | -------------------------------------------------------------------------------- /lib/handshake_client.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | open State 3 | 4 | val default_client_hello : Config.config -> (client_hello * tls_version * (group * dh_secret) list) 5 | val handle_change_cipher_spec : client_handshake_state -> handshake_state -> string -> (handshake_return, failure) result 6 | val handle_handshake : client_handshake_state -> handshake_state -> string -> (handshake_return, failure) result 7 | val answer_hello_request : handshake_state -> (handshake_return, failure) result 8 | -------------------------------------------------------------------------------- /async/examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_client) 3 | (modules test_client) 4 | (public_name tls-test-client) 5 | (package tls-async) 6 | (preprocess (pps ppx_jane)) 7 | (libraries async core core_unix.command_unix tls-async)) 8 | 9 | (executable 10 | (name test_server) 11 | (modules test_server) 12 | (public_name tls-test-server) 13 | (package tls-async) 14 | (preprocess (pps ppx_jane)) 15 | (libraries async core core_unix.command_unix tls-async)) 16 | -------------------------------------------------------------------------------- /eio/tests/mock_socket.mli: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | type transmit_amount = [ 4 | | `Bytes of int (* Send the next n bytes of data *) 5 | | `Drain (* Transmit all data immediately from now on *) 6 | ] 7 | 8 | type t = [`Mock_tls | Eio.Flow.two_way_ty | Eio.Resource.close_ty] r 9 | 10 | val create_pair : unit -> t * t 11 | (** Create a pair of sockets [client, server], such that writes to one can be read from the other. *) 12 | 13 | val transmit : t -> transmit_amount -> unit 14 | -------------------------------------------------------------------------------- /mirage/example2/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let secrets_dir = "sekrit" 4 | 5 | let disk = direct_kv_ro secrets_dir 6 | and stack = generic_stackv4 default_network 7 | 8 | let packages = [ 9 | package "cohttp-mirage" ; 10 | package ~min:"0.99" "cohttp-lwt" ; 11 | package ~sublibs:["mirage"] "tls" ; 12 | package "tcpip" ; 13 | ] 14 | let server = foreign ~deps:[abstract nocrypto] ~packages "Unikernel.Main" @@ stackv4 @-> kv_ro @-> pclock @-> job 15 | 16 | let () = 17 | register "tls-server" [ server $ stack $ disk $ default_posix_clock ] 18 | -------------------------------------------------------------------------------- /lib/handshake_crypto.mli: -------------------------------------------------------------------------------- 1 | open State 2 | 3 | val derive_master_secret : Core.tls_before_13 -> session_data -> string -> string list -> Core.master_secret 4 | val initialise_crypto_ctx : Core.tls_before_13 -> session_data -> (crypto_context * crypto_context) 5 | val finished : Core.tls_before_13 -> Ciphersuite.ciphersuite -> string -> string -> string list -> string 6 | 7 | (** [pseudo_random_function version cipher length secret label seed] *) 8 | val pseudo_random_function : Core.tls_before_13 -> Ciphersuite.ciphersuite -> 9 | int -> string -> string -> string -> string 10 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name testlib) 3 | (modules testlib) 4 | (libraries tls ounit2 mirage-crypto-rng.unix) 5 | (optional)) 6 | 7 | (test 8 | (name unittestrunner) 9 | (package tls) 10 | (modules readertests readerwritertests writertests unittests unittestrunner) 11 | (libraries tls ounit2 testlib)) 12 | 13 | (test 14 | (name key_derivation) 15 | (package tls) 16 | (modules key_derivation) 17 | (libraries tls mirage-crypto-rng.unix alcotest logs.fmt)) 18 | 19 | (test 20 | (name feedback) 21 | (package tls) 22 | (modules feedback) 23 | (deps server.key server.pem) 24 | (libraries tls x509 testlib cmdliner fmt.cli logs.fmt fmt.tty logs.cli)) 25 | -------------------------------------------------------------------------------- /lwt/examples/echo_client_alpn.ml: -------------------------------------------------------------------------------- 1 | 2 | open Ex_common 3 | open Lwt 4 | 5 | let echo_client host port = 6 | let open Lwt_io in 7 | let port = int_of_string port in 8 | let authenticator = null_auth in 9 | Tls_lwt.Unix.connect 10 | (get_ok Tls.Config.(client ~authenticator ~alpn_protocols:["http/1.1"; "h2"] ())) 11 | (host, port) >>= fun t -> 12 | match Tls_lwt.Unix.epoch t with 13 | | Error () -> printl "Error" 14 | | Ok epoch -> ( 15 | match epoch.Tls.Core.alpn_protocol with 16 | | None -> printl "No protocol selected" 17 | | Some protocol -> printl ("Selected protocol: " ^ protocol) 18 | ) 19 | >>= fun () -> Tls_lwt.Unix.close t 20 | 21 | let () = 22 | Lwt_main.run (echo_client "127.0.0.1" "4433") 23 | -------------------------------------------------------------------------------- /async/session.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | module Fd = struct 5 | type t = Reader.t * Writer.t 6 | 7 | let read (reader, (_ : Writer.t)) buf = 8 | Deferred.Or_error.try_with (fun () -> Reader.read reader buf) 9 | ;; 10 | 11 | let write ((_ : Reader.t), writer) buf = 12 | Deferred.Or_error.try_with (fun () -> 13 | Writer.write writer buf; 14 | Writer.flushed writer) 15 | ;; 16 | 17 | let rec write_full fd buf = 18 | let open Deferred.Or_error.Let_syntax in 19 | match String.length buf with 20 | | 0 -> return () 21 | | len -> 22 | let%bind () = write fd buf in 23 | write_full fd (String.sub buf ~pos:len ~len:(String.length buf - len)) 24 | ;; 25 | end 26 | 27 | include Io.Make (Fd) 28 | -------------------------------------------------------------------------------- /certificates/server-ec.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIICDDCCAW+gAwIBAgIIQcOa7kqxp9cwCgYIKoZIzj0EAwQwFjEUMBIGA1UEAwwL 3 | ZXhhbXBsZS5jb20wHhcNMjEwNDA0MTcwMTU3WhcNMjIwNDA0MTcwMTU3WjAWMRQw 4 | EgYDVQQDDAtleGFtcGxlLmNvbTCBmzAQBgcqhkjOPQIBBgUrgQQAIwOBhgAEAXIK 5 | VyKRhKOJjxXQtKJiTX9nM3lZs6qy632NYmG9BwJ74FidW1NYlT0eiN71nMHU9FOH 6 | BZ76AH0ISrbo3hjG7uFzAPMplhTwTlA7IcQoR8FOGjrN0w+H5YJZRtkfYU0hFETU 7 | F4quomVmbrxtcIgFRWLJdf7qciYYJyYc8ZlTZoHpZY02o2QwYjAdBgNVHQ4EFgQU 8 | nku+GxZTewB6/D2bJFQcOkBN4QMwDwYDVR0PAQH/BAUDAwfGADAPBgNVHRMBAf8E 9 | BTADAQH/MB8GA1UdIwQYMBaAFJ5LvhsWU3sAevw9myRUHDpATeEDMAoGCCqGSM49 10 | BAMEA4GKADCBhgJBfZBX4o5Df/fJUnzmQKo6KFFWlc70VkO3hXH6lUhVRLcT+Ame 11 | 6gJUjgYy65GryW4Tx/pFTI7tdX19UDm+kBvgv1sCQRIgxgt/eJ74VsRgt7Br3Smm 12 | px1uULyS4PIGBKT4O4C4bWS1wdzw8ZOlegss1+pkxYYrfJFNJYyBaqY0ScTpvE4F 13 | -----END CERTIFICATE----- 14 | ---- 15 | -------------------------------------------------------------------------------- /certificates/bar.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIICHTCCAYYCCQDyqsjENH2CvTANBgkqhkiG9w0BAQUFADBTMQswCQYDVQQGEwJB 3 | VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0 4 | cyBQdHkgTHRkMQwwCgYDVQQDDANiYXIwHhcNMTQwODExMTIxMDEwWhcNMTUwODEx 5 | MTIxMDEwWjBTMQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8G 6 | A1UECgwYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMQwwCgYDVQQDDANiYXIwgZ8w 7 | DQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBALZASN7mvCGUPaKrXrb42DcAf0F8D+M0 8 | ksOqL1U+TV4xQ0aJwm8r5o4A0oiw46v2/hGIRdlJiYUS8ZLL5J/VsIMfAcstJ02z 9 | pjj1vvs86Bq2tVk5NEQET+3WyhVPdr+9UlYIu1UKObvS7RLm1x+fhLohql4hgBUC 10 | ZxqrBJr4ZA2hAgMBAAEwDQYJKoZIhvcNAQEFBQADgYEAci6xzomZWURSro7/B8Hy 11 | DgoMF15tcocsyeFnxLBGqXyg2RQnvZXjv7DFkQgieDFqXvAFgxG+bcZzBFrKHI6A 12 | FKH9IeBpgtVPVbnHJYMpEShzOSyc/8MFSuqMqo9a/XWK7VTguZqzTVSoyE06S6AP 13 | 10W+CBZBT+5Gah6I9rsLDNo= 14 | -----END CERTIFICATE----- 15 | -------------------------------------------------------------------------------- /certificates/foo.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIICHTCCAYYCCQDPsW8ipzRmaTANBgkqhkiG9w0BAQUFADBTMQswCQYDVQQGEwJB 3 | VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0 4 | cyBQdHkgTHRkMQwwCgYDVQQDDANmb28wHhcNMTQwODExMTIwOTI4WhcNMTUwODEx 5 | MTIwOTI4WjBTMQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8G 6 | A1UECgwYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMQwwCgYDVQQDDANmb28wgZ8w 7 | DQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBALZASN7mvCGUPaKrXrb42DcAf0F8D+M0 8 | ksOqL1U+TV4xQ0aJwm8r5o4A0oiw46v2/hGIRdlJiYUS8ZLL5J/VsIMfAcstJ02z 9 | pjj1vvs86Bq2tVk5NEQET+3WyhVPdr+9UlYIu1UKObvS7RLm1x+fhLohql4hgBUC 10 | ZxqrBJr4ZA2hAgMBAAEwDQYJKoZIhvcNAQEFBQADgYEAVE2BBZI/MTCZorKkGVVj 11 | ZFosVv4qhiajzT/yr3nd7/8vLMsHnqrkfwycES9s9RRE9glv1WNptFSxkUxKzP2r 12 | jv2c7jdkXkDZsLlCh/qmaaKymZ+WuATbGm/edItnwy3RQDzufjsTfOFUH/08JWwz 13 | rnWkhcnpCqdTTniWwy/HRYQ= 14 | -----END CERTIFICATE----- 15 | -------------------------------------------------------------------------------- /eio/tests/dune: -------------------------------------------------------------------------------- 1 | (copy_files ../../certificates/*.crt) 2 | (copy_files ../../certificates/*.key) 3 | (copy_files ../../certificates/*.pem) 4 | 5 | (mdx 6 | (package tls-eio) 7 | (deps 8 | server.pem 9 | server.key 10 | server-ec.pem 11 | server-ec.key 12 | (package tls-eio) 13 | (package mirage-crypto-rng) 14 | (package eio_main))) 15 | 16 | ; "dune runtest" just does a quick run with random inputs. 17 | ; 18 | ; To run with afl-fuzz instead (make sure you have a compiler with the afl option on!): 19 | ; 20 | ; dune runtest 21 | ; mkdir input 22 | ; echo hi > input/foo 23 | ; cp certificates/server.{key,pem} . 24 | ; afl-fuzz -m 1000 -i input -o output ./_build/default/eio/tests/fuzz.exe @@ 25 | (test 26 | (package tls-eio) 27 | (libraries crowbar tls-eio eio.mock logs logs.fmt) 28 | (deps server.pem server.key) 29 | (name fuzz) 30 | (action (run %{test} --repeat 200))) 31 | -------------------------------------------------------------------------------- /mirage/example/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let secrets_dir = "sekrit" 4 | 5 | let build = 6 | try 7 | match Sys.getenv "BUILD" with 8 | | "client" -> `Client 9 | | _ -> `Server 10 | with Not_found -> `Server 11 | 12 | let disk = generic_kv_ro secrets_dir 13 | 14 | let stack = generic_stackv4 default_network 15 | 16 | let packages = [ 17 | package ~sublibs:["mirage"] "tls" ; 18 | package ~sublibs:["lwt"] "logs" 19 | ] 20 | 21 | let server = 22 | foreign ~deps:[abstract nocrypto] ~packages "Unikernel.Server" @@ stackv4 @-> kv_ro @-> pclock @-> job 23 | 24 | let client = 25 | foreign ~deps:[abstract nocrypto] ~packages "Unikernel.Client" @@ stackv4 @-> kv_ro @-> pclock @-> job 26 | 27 | let () = 28 | match build with 29 | | `Server -> 30 | register "tls-server" [ server $ stack $ disk $ default_posix_clock ] 31 | | `Client -> 32 | register "tls-client" [ client $ stack $ disk $ default_posix_clock ] 33 | -------------------------------------------------------------------------------- /certificates/server.key: -------------------------------------------------------------------------------- 1 | -----BEGIN RSA PRIVATE KEY----- 2 | MIICXQIBAAKBgQC2QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJv 3 | K+aOANKIsOOr9v4RiEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTRE 4 | BE/t1soVT3a/vVJWCLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQAB 5 | AoGAd/CShG8g/JBMh9Nz/8KAuKHRHc2BvysIM1C62cSosgaFmdRrazJfBrEv3Nlc 6 | 2/0uc2dVYIxuvm8bIFqi2TWOdX9jWJf6oXwEPXCD0SaDbJTaoh0b+wjyHuaGlttY 7 | Ztvmf8mK1BOhyl3vNMxh/8Re0dGvGgPZHpn8zanaqfGVz+ECQQDngieUpwzxA0QZ 8 | GZKRYhHoLEaPiQzBaXphqWcCLLN7oAKxZlUCUckxRRe0tKINf0cB3Kr9gGQjPpm0 9 | YoqXo8mNAkEAyYgdd+JDi9FH3Cz6ijvPU0hYkriwTii0V09+Ar5DvYQNzNEIEJu8 10 | Q3Yte/TPRuK8zhnp97Bsy9v/Ji/LSWbtZQJBAJe9y8u3otfmWCBLjrIUIcCYJLe4 11 | ENBFHp4ctxPJ0Ora+mjkthuLF+BfdSZQr1dBcX1a8giuuvQO+Bgv7r9t75ECQC7F 12 | omEyaA7JEW5uGe9/Fgz0G2ph5rkdBU3GKy6jzcDsJu/EC6UfH8Bgawn7tSd0c/E5 13 | Xm2Xyog9lKfeK8XrV2kCQQCTico5lQPjfIwjhvn45ALc/0OrkaK0hQNpXgUNFJFQ 14 | tuX2WMD5flMyA5PCx5XBU8gEMHYa8Kr5d6uoixnbS0cZ 15 | -----END RSA PRIVATE KEY----- 16 | -------------------------------------------------------------------------------- /certificates/server.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIICYzCCAcwCCQDLbE6ES1ih1DANBgkqhkiG9w0BAQUFADB2MQswCQYDVQQGEwJB 3 | VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0 4 | cyBQdHkgTHRkMRUwEwYDVQQDDAxZT1VSIE5BTUUhISExGDAWBgkqhkiG9w0BCQEW 5 | CW1lQGJhci5kZTAeFw0xNDAyMTcyMjA4NDVaFw0xNTAyMTcyMjA4NDVaMHYxCzAJ 6 | BgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l 7 | dCBXaWRnaXRzIFB0eSBMdGQxFTATBgNVBAMMDFlPVVIgTkFNRSEhITEYMBYGCSqG 8 | SIb3DQEJARYJbWVAYmFyLmRlMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC2 9 | QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJvK+aOANKIsOOr9v4R 10 | iEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTREBE/t1soVT3a/vVJW 11 | CLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQABMA0GCSqGSIb3DQEB 12 | BQUAA4GBAIo4ZppIlp3JRyltRC1/AyCC0tsh5TdM3W7258wdoP3lEe08UlLwpnPc 13 | aJ/cX8rMG4Xf4it77yrbVrU3MumBEGN5TW4jn4+iZyFbp6TT3OUF55nsXDjNHBbu 14 | deDVpGuPTI6CZQVhU5qEMF3xmlokG+VV+HCDTglNQc+fdLM0LoNF 15 | -----END CERTIFICATE----- 16 | -------------------------------------------------------------------------------- /tls-lwt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/mirleft/ocaml-tls" 3 | dev-repo: "git+https://github.com/mirleft/ocaml-tls.git" 4 | bug-reports: "https://github.com/mirleft/ocaml-tls/issues" 5 | doc: "https://mirleft.github.io/ocaml-tls/doc" 6 | author: ["David Kaloper " "Hannes Mehnert "] 7 | maintainer: ["Hannes Mehnert " "David Kaloper "] 8 | license: "BSD-2-Clause" 9 | 10 | build: [ 11 | ["dune" "subst"] {dev} 12 | ["dune" "build" "-p" name "-j" jobs] 13 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 14 | ] 15 | 16 | depends: [ 17 | "ocaml" {>= "4.13.0"} 18 | "dune" {>= "3.0"} 19 | "tls" {= version} 20 | "mirage-crypto-rng" {>= "1.2.0"} 21 | "lwt" {>= "5.7.0"} 22 | "cmdliner" {>= "1.1.0"} 23 | "ptime" {>= "0.8.1"} 24 | "randomconv" {with-test & >= "0.2.0"} 25 | ] 26 | conflicts: [ "result" {< "1.5"} ] 27 | tags: [ "org:mirage"] 28 | synopsis: "Transport Layer Security purely in OCaml, Lwt layer" 29 | description: """ 30 | Tls-lwt provides an effectful Tls_lwt module to be used with Lwt. 31 | """ 32 | x-maintenance-intent: [ "(latest)" ] 33 | -------------------------------------------------------------------------------- /eio/x509_eio.mli: -------------------------------------------------------------------------------- 1 | (** X.509 certificate handling using Eio. *) 2 | 3 | (** [private_of_pems ~cert ~priv_key] is [priv], after reading the 4 | private key and certificate chain from the given PEM-encoded 5 | files. *) 6 | val private_of_pems : cert:_ Eio.Path.t -> priv_key:_ Eio.Path.t -> Tls.Config.certchain 7 | 8 | (** [certs_of_pem file] is [certificates], which are read from the 9 | PEM-encoded [file]. *) 10 | val certs_of_pem : _ Eio.Path.t -> X509.Certificate.t list 11 | 12 | (** [certs_of_pem_dir dir] is [certificates], which are read from all 13 | PEM-encoded files in [dir]. *) 14 | val certs_of_pem_dir : _ Eio.Path.t -> X509.Certificate.t list 15 | 16 | (** [authenticator methods] constructs an [authenticator] using the 17 | specified method and data. *) 18 | val authenticator : ?allowed_hashes:Digestif.hash' list -> ?crls:_ Eio.Path.t -> 19 | [ `Ca_file of _ Eio.Path.t 20 | | `Ca_dir of _ Eio.Path.t 21 | | `Key_fingerprint of Digestif.hash' * string 22 | | `Hex_key_fingerprint of Digestif.hash' * string 23 | | `Cert_fingerprint of Digestif.hash' * string 24 | | `Hex_cert_fingerprint of Digestif.hash' * string 25 | ] 26 | -> X509.Authenticator.t 27 | -------------------------------------------------------------------------------- /tls-miou-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/mirleft/ocaml-tls" 3 | dev-repo: "git+https://github.com/mirleft/ocaml-tls.git" 4 | bug-reports: "https://github.com/mirleft/ocaml-tls/issues" 5 | doc: "https://mirleft.github.io/ocaml-tls/" 6 | author: ["Romain Calascibetta "] 7 | maintainer: ["Romain Calascibetta "] 8 | license: "BSD-2-Clause" 9 | 10 | build: [ 11 | ["dune" "subst"] {dev} 12 | ["dune" "build" "-p" name "-j" jobs] 13 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 14 | ] 15 | 16 | depends: [ 17 | "ocaml" {>= "5.0.0"} 18 | "dune" {>= "3.0"} 19 | "tls" {= version} 20 | "mirage-crypto-rng-miou-unix" {>= "1.0.0" & with-test} 21 | "x509" {>= "1.0.0"} 22 | "miou" {>= "0.3.0"} 23 | "crowbar" {with-test} 24 | "rresult" {with-test} 25 | "ohex" {with-test} 26 | "ptime" {with-test} 27 | "hxd" {with-test} 28 | ] 29 | tags: [ "org:mirage"] 30 | synopsis: "Transport Layer Security purely in OCaml, Miou+Unix layer" 31 | description: """ 32 | Tls-miou provides an effectful Tls_miou module to be used with Miou and Unix. 33 | """ 34 | x-maintenance-intent: [ "(latest)" ] 35 | -------------------------------------------------------------------------------- /async/examples/test_client.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open Deferred.Or_error.Let_syntax 4 | 5 | let config = match Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) () with 6 | | Ok cfg -> cfg 7 | | Error `Msg msg -> invalid_arg msg 8 | 9 | let test_client () = 10 | let host = "127.0.0.1" in 11 | let port = 8443 in 12 | let hnp = Host_and_port.create ~host ~port in 13 | let%bind (_ : Tls_async.Session.t), rd, wr = 14 | (* we can't build a [[ `host ] Domain_name.t] from an IP address *) 15 | let host = None in 16 | Tls_async.connect config (Tcp.Where_to_connect.of_host_and_port hnp) ~host 17 | in 18 | let req = 19 | String.concat 20 | ~sep:"\r\n" 21 | [ "GET / HTTP/1.1"; "Host: " ^ host; "Connection: close"; ""; "" ] 22 | in 23 | Writer.write wr req; 24 | let%bind () = Writer.flushed wr |> Deferred.ok in 25 | let%bind () = 26 | match%map Reader.read_line rd |> Deferred.ok with 27 | | `Ok str -> print_endline str 28 | | `Eof -> print_endline "Eof reached" 29 | in 30 | Writer.close wr |> Deferred.ok 31 | ;; 32 | 33 | let cmd = Command.async_or_error ~summary:"test client" (Command.Param.return test_client) 34 | let () = Command_unix.run cmd 35 | -------------------------------------------------------------------------------- /lwt/examples/http_client.ml: -------------------------------------------------------------------------------- 1 | 2 | open Lwt 3 | open Ex_common 4 | 5 | let http_client ?ca ?fp hostname port = 6 | let port = int_of_string port in 7 | auth ?ca ?fp () >>= fun authenticator -> 8 | Tls_lwt.connect_ext 9 | (get_ok (Tls.Config.client ~authenticator ())) 10 | (hostname, port) >>= fun (ic, oc) -> 11 | let req = String.concat "\r\n" [ 12 | "GET / HTTP/1.1" ; "Host: " ^ hostname ; "Connection: close" ; "" ; "" 13 | ] in 14 | Lwt_io.(write oc req >>= fun () -> read ic >>= print >>= fun () -> printf "++ done.\n%!") 15 | 16 | let () = 17 | try 18 | match Sys.argv with 19 | | [| _ ; host ; port ; "FP" ; fp |] -> Lwt_main.run (http_client host port ~fp) 20 | | [| _ ; host ; port ; trust |] -> Lwt_main.run (http_client host port ~ca:trust) 21 | | [| _ ; host ; port |] -> Lwt_main.run (http_client host port) 22 | | [| _ ; host |] -> Lwt_main.run (http_client host "443") 23 | | args -> Printf.eprintf "%s \n%!" args.(0) 24 | with 25 | | Tls_lwt.Tls_alert alert as exn -> 26 | print_alert "remote end" alert ; raise exn 27 | | Tls_lwt.Tls_failure fail as exn -> 28 | print_fail "our end" fail ; raise exn 29 | 30 | -------------------------------------------------------------------------------- /lwt/x509_lwt.mli: -------------------------------------------------------------------------------- 1 | (** X.509 certificate handling using Lwt. *) 2 | 3 | (** [private_of_pems ~cert ~priv_key] is [priv], after reading the 4 | private key and certificate chain from the given PEM-encoded 5 | files. *) 6 | val private_of_pems : cert:Lwt_io.file_name -> priv_key:Lwt_io.file_name -> Tls.Config.certchain Lwt.t 7 | 8 | (** [certs_of_pem file] is [certificates], which are read from the 9 | PEM-encoded [file]. *) 10 | val certs_of_pem : Lwt_io.file_name -> X509.Certificate.t list Lwt.t 11 | 12 | (** [certs_of_pem_dir dir] is [certificates], which are read from all 13 | PEM-encoded files in [dir]. *) 14 | val certs_of_pem_dir : Lwt_io.file_name -> X509.Certificate.t list Lwt.t 15 | 16 | (** [authenticator methods] constructs an [authenticator] using the 17 | specified method and data. *) 18 | val authenticator : ?allowed_hashes:Digestif.hash' list -> ?crls:Lwt_io.file_name -> 19 | [ `Ca_file of Lwt_io.file_name 20 | | `Ca_dir of Lwt_io.file_name 21 | | `Key_fingerprint of Digestif.hash' * string 22 | | `Hex_key_fingerprint of Digestif.hash' * string 23 | | `Cert_fingerprint of Digestif.hash' * string 24 | | `Hex_cert_fingerprint of Digestif.hash' * string 25 | ] 26 | -> X509.Authenticator.t Lwt.t 27 | -------------------------------------------------------------------------------- /lib/utils.ml: -------------------------------------------------------------------------------- 1 | module List_set = struct 2 | let subset ?(compare = compare) l1 l2 = 3 | let rec loop xs ys = 4 | match (xs, ys) with 5 | | ([], _) -> true 6 | | (_, []) -> false 7 | | (x::xss, y::yss) -> 8 | match compare x y with 9 | | -1 -> false 10 | | 1 -> loop xs yss 11 | | _ -> loop xss yss in 12 | loop (List.sort compare l1) (List.sort compare l2) 13 | 14 | let is_proper_set l = 15 | let rec repeats = function 16 | | x::(y::_ as xs) -> x = y || repeats xs 17 | | _ -> false in 18 | not @@ repeats (List.sort compare l) 19 | end 20 | 21 | let rec map_find ~f = function 22 | | [] -> None 23 | | x::xs -> 24 | match f x with 25 | | None -> map_find ~f xs 26 | | Some _ as x' -> x' 27 | 28 | let init_and_last list = 29 | List.fold_right (fun x -> function 30 | | None -> Some ([], x) 31 | | Some (xs, y) -> Some (x::xs, y)) 32 | list None 33 | 34 | let rec first_match l1 = function 35 | | [] -> None 36 | | x::_ when List.mem x l1 -> Some x 37 | | _::xs -> first_match l1 xs 38 | 39 | let sub_equal ~off ~len v x = 40 | v = String.sub x off len 41 | -------------------------------------------------------------------------------- /tls-mirage.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/mirleft/ocaml-tls" 3 | dev-repo: "git+https://github.com/mirleft/ocaml-tls.git" 4 | bug-reports: "https://github.com/mirleft/ocaml-tls/issues" 5 | doc: "https://mirleft.github.io/ocaml-tls/doc" 6 | author: ["David Kaloper " "Hannes Mehnert "] 7 | maintainer: ["Hannes Mehnert " "David Kaloper "] 8 | license: "BSD-2-Clause" 9 | 10 | build: [ 11 | ["dune" "subst"] {dev} 12 | ["dune" "build" "-p" name "-j" jobs] 13 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 14 | ] 15 | 16 | depends: [ 17 | "ocaml" {>= "4.13.0"} 18 | "dune" {>= "3.0"} 19 | "tls" {= version} 20 | "fmt" {>= "0.8.7"} 21 | "lwt" {>= "3.0.0"} 22 | "mirage-flow" {>= "4.0.0"} 23 | "mirage-kv" {>= "3.0.0"} 24 | "mirage-ptime" {>= "4.0.0"} 25 | "ptime" {>= "0.8.1"} 26 | "mirage-crypto" {>= "1.0.0"} 27 | "mirage-crypto-pk" {>= "1.0.0"} 28 | ] 29 | tags: [ "org:mirage"] 30 | synopsis: "Transport Layer Security purely in OCaml, MirageOS layer" 31 | description: """ 32 | Tls-mirage provides an effectful FLOW module to be used in the MirageOS 33 | ecosystem. 34 | """ 35 | x-maintenance-intent: [ "(latest)" ] 36 | -------------------------------------------------------------------------------- /tls-async.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/mirleft/ocaml-tls" 3 | dev-repo: "git+https://github.com/mirleft/ocaml-tls.git" 4 | bug-reports: "https://github.com/mirleft/ocaml-tls/issues" 5 | doc: "https://mirleft.github.io/ocaml-tls/doc" 6 | author: ["David Kaloper " "Hannes Mehnert " "Eric Ebinger " "Calascibetta Romain "] 7 | maintainer: ["Hannes Mehnert " "David Kaloper "] 8 | license: "BSD-2-Clause" 9 | 10 | build: [ 11 | ["dune" "subst"] {dev} 12 | ["dune" "build" "-p" name "-j" jobs] 13 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 14 | ] 15 | 16 | depends: [ 17 | "ocaml" {>= "4.14.0"} 18 | "dune" {>= "3.0"} 19 | "tls" {= version} 20 | "ptime" {>= "0.8.1"} 21 | "async" {>= "v0.16"} 22 | "async_unix" {>= "v0.16"} 23 | "core" {>= "v0.16"} 24 | "core_unix" {>= "v0.16"} 25 | "cstruct-async" 26 | "ppx_jane" {>= "v0.16"} 27 | "mirage-crypto-rng" {>= "1.2.0"} 28 | ] 29 | tags: [ "org:mirage"] 30 | synopsis: "Transport Layer Security purely in OCaml, Async layer" 31 | description: """ 32 | Tls-async provides Async-friendly tls bindings 33 | """ 34 | x-maintenance-intent: [ "(latest)" ] 35 | -------------------------------------------------------------------------------- /lib/writer.mli: -------------------------------------------------------------------------------- 1 | 2 | val assemble_protocol_version : ?buf:bytes -> Core.tls_version -> string 3 | 4 | val assemble_handshake : Core.tls_handshake -> string 5 | 6 | val assemble_message_hash : int -> string 7 | 8 | val assemble_hdr : Core.tls_version -> (Packet.content_type * string) -> string 9 | 10 | val assemble_alert : ?level:Packet.alert_level -> Packet.alert_type -> string 11 | 12 | val assemble_change_cipher_spec : string 13 | 14 | val assemble_dh_parameters : Core.dh_parameters -> string 15 | 16 | val assemble_ec_parameters : Core.group -> string -> string 17 | 18 | val assemble_client_dh_key_exchange : string -> string 19 | 20 | val assemble_client_ec_key_exchange : string -> string 21 | 22 | val assemble_digitally_signed : string -> string 23 | 24 | val assemble_digitally_signed_1_2 : Core.signature_algorithm -> string -> string 25 | 26 | val assemble_certificate_request : Packet.client_certificate_type list -> string list -> string 27 | 28 | val assemble_certificate_request_1_2 : Packet.client_certificate_type list -> Core.signature_algorithm list -> string list -> string 29 | 30 | val assemble_certificate_request_1_3 : ?context:string -> Core.certificate_request_extension list -> string 31 | 32 | val assemble_certificates : string list -> string 33 | 34 | val assemble_certificates_1_3 : string -> string list -> string 35 | -------------------------------------------------------------------------------- /mirage/example2/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Main (S : Mirage_stack.V4) 4 | (KV : Mirage_kv.RO) 5 | (CL : Mirage_clock.PCLOCK) = 6 | struct 7 | 8 | module TLS = Tls_mirage.Make (S.TCPV4) 9 | module X509 = Tls_mirage.X509 (KV) (CL) 10 | module Http = Cohttp_mirage.Server (TLS) 11 | 12 | module Body = Cohttp_lwt.Body 13 | 14 | let callback _conn req body = 15 | let resp = Cohttp.Response.make ~status:`OK () in 16 | (match Cohttp.Request.meth req with 17 | | `POST -> 18 | Body.to_string body >|= fun contents -> 19 | "
" ^ contents ^ "
" 20 | | _ -> Lwt.return "") >|= fun inlet -> 21 | let body = Body.of_string @@ 22 | "ohai \ 23 |

Secure CoHTTP on-line.

" 24 | ^ inlet ^ "\r\n" 25 | in 26 | (resp, body) 27 | 28 | let upgrade conf tcp = 29 | TLS.server_of_flow conf tcp >>= function 30 | | Error _ -> Lwt.fail (Failure "tls init") 31 | | Ok tls -> 32 | let t = Http.make ~callback () in 33 | Http.listen t tls 34 | 35 | let start stack kv _ _ = 36 | X509.certificate kv `Default >>= fun cert -> 37 | let conf = Tls.Config.server ~certificates:(`Single cert) () in 38 | S.listen_tcpv4 stack ~port:4433 (upgrade conf) ; 39 | S.listen stack 40 | 41 | end 42 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, David Kaloper and Hannes Mehnert 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, 5 | are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, this 11 | list of conditions and the following disclaimer in the documentation and/or 12 | other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 15 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 18 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 19 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 20 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 21 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 22 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 23 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /lwt/examples/test_server.ml: -------------------------------------------------------------------------------- 1 | 2 | open Lwt 3 | open Ex_common 4 | 5 | let serve_ssl port callback = 6 | 7 | let tag = "server" in 8 | 9 | X509_lwt.private_of_pems 10 | ~cert:server_cert 11 | ~priv_key:server_key >>= fun certificate -> 12 | X509_lwt.private_of_pems 13 | ~cert:server_ec_cert 14 | ~priv_key:server_ec_key >>= fun ec_certificate -> 15 | let certificates = `Multiple [ certificate ; ec_certificate ] in 16 | let config = 17 | get_ok (Tls.Config.(server ~version:(`TLS_1_0, `TLS_1_3) ~certificates ~ciphers:Ciphers.supported ())) 18 | in 19 | 20 | let server_s = 21 | let open Lwt_unix in 22 | let s = socket PF_INET SOCK_STREAM 0 in 23 | setsockopt s Unix.SO_REUSEADDR true ; 24 | bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () -> 25 | listen s 10 ; 26 | s in 27 | 28 | yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () -> 29 | server_s >>= fun s -> 30 | Tls_lwt.Unix.accept config s >>= fun (t, addr) -> 31 | let channels = Tls_lwt.of_t t in 32 | yap ~tag "-> connect" >>= fun () -> 33 | callback channels addr >>= fun () -> 34 | yap ~tag "<- handler done" 35 | 36 | let test_server port = 37 | serve_ssl port @@ fun (ic, oc) _addr -> 38 | yap ~tag:"handler" "accepted" >>= fun () -> 39 | Lwt_io.read_line ic >>= fun line -> 40 | yap ~tag:"handler" ("+ " ^ line) >>= fun () -> 41 | Lwt_io.write_line oc line 42 | 43 | let () = 44 | let port = 45 | try int_of_string Sys.argv.(1) with _ -> 4433 46 | in 47 | Lwt_main.run (test_server port) 48 | -------------------------------------------------------------------------------- /lwt/examples/test_client.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Ex_common 3 | 4 | let mypsk = ref None 5 | 6 | let ticket_cache = { 7 | Tls.Config.lookup = (fun _ -> None) ; 8 | ticket_granted = (fun psk epoch -> mypsk := Some (psk, epoch)) ; 9 | lifetime = 0l ; 10 | timestamp = Ptime_clock.now 11 | } 12 | 13 | let test_client _ = 14 | (* X509_lwt.private_of_pems 15 | ~cert:server_cert 16 | ~priv_key:server_key >>= fun cert -> *) 17 | let port = 4433 in 18 | let host = "127.0.0.1" in 19 | let authenticator = null_auth in 20 | Tls_lwt.Unix.connect 21 | (get_ok Tls.Config.(client ~version:(`TLS_1_0, `TLS_1_3) (* ~certificates:(`Single cert) *) ?cached_ticket:!mypsk ~ticket_cache ~authenticator ~ciphers:Ciphers.supported ())) 22 | (host, port) >>= fun t -> 23 | let (ic, oc) = Tls_lwt.of_t t in 24 | let req = String.concat "\r\n" [ 25 | "GET / HTTP/1.1" ; "Host: " ^ host ; "Connection: close" ; "" ; "" 26 | ] in 27 | Lwt_io.(write oc req >>= fun () -> 28 | read ~count:3 ic >>= print >>= fun () -> 29 | close oc >>= fun () -> 30 | printf "++ done.\n%!") 31 | 32 | let jump _ = 33 | try 34 | Lwt_main.run (test_client ()) ; `Ok () 35 | with 36 | | Tls_lwt.Tls_alert alert as exn -> 37 | print_alert "remote end" alert ; raise exn 38 | | Tls_lwt.Tls_failure alert as exn -> 39 | print_fail "our end" alert ; raise exn 40 | 41 | open Cmdliner 42 | 43 | let cmd = 44 | let term = Term.(ret (const jump $ setup_log)) 45 | and info = Cmd.info "test_client" ~version:"%%VERSION_NUM%%" 46 | in 47 | Cmd.v info term 48 | 49 | let () = exit (Cmd.eval cmd) 50 | -------------------------------------------------------------------------------- /lwt/examples/ex_common.ml: -------------------------------------------------------------------------------- 1 | 2 | open Lwt 3 | 4 | let o f g x = f (g x) 5 | 6 | let ca_cert_dir = "./certificates" 7 | let server_cert = "./certificates/server.pem" 8 | let server_key = "./certificates/server.key" 9 | let server_ec_cert = "./certificates/server-ec.pem" 10 | let server_ec_key = "./certificates/server-ec.key" 11 | 12 | let yap ~tag msg = Lwt_io.printf "(%s %s)\n%!" tag msg 13 | 14 | let lines ic = 15 | Lwt_stream.from @@ fun () -> 16 | Lwt_io.read_line_opt ic >>= function 17 | | None -> Lwt_io.close ic >>= fun () -> return_none 18 | | line -> return line 19 | 20 | let print_alert where alert = 21 | Printf.eprintf "(TLS ALERT (%s): %s)\n%!" 22 | where (Tls.Packet.alert_type_to_string alert) 23 | 24 | let print_fail where fail = 25 | Printf.eprintf "(TLS FAIL (%s): %s)\n%!" 26 | where (Tls.Engine.string_of_failure fail) 27 | 28 | let null_auth ?ip:_ ~host:_ _ = Ok None 29 | 30 | let auth ?ca ?fp () = 31 | match ca with 32 | | Some "NONE" when fp = None -> Lwt.return null_auth 33 | | _ -> 34 | let a = match ca, fp with 35 | | None, Some fp -> `Hex_key_fingerprint (`SHA256, fp) 36 | | None, _ -> `Ca_dir ca_cert_dir 37 | | Some f, _ -> `Ca_file f 38 | in 39 | X509_lwt.authenticator a 40 | 41 | let setup_log style_renderer level = 42 | Fmt_tty.setup_std_outputs ?style_renderer (); 43 | Logs.set_level level; 44 | Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) 45 | 46 | open Cmdliner 47 | 48 | let setup_log = 49 | Term.(const setup_log 50 | $ Fmt_cli.style_renderer () 51 | $ Logs_cli.level ()) 52 | 53 | let get_ok = function 54 | | Ok cfg -> cfg 55 | | Error `Msg msg -> invalid_arg msg 56 | -------------------------------------------------------------------------------- /lwt/examples/resume_client.ml: -------------------------------------------------------------------------------- 1 | 2 | open Lwt 3 | open Ex_common 4 | 5 | let http_client ?ca ?fp hostname port = 6 | let port = int_of_string port in 7 | auth ?ca ?fp () >>= fun authenticator -> 8 | let config = get_ok (Tls.Config.client ~authenticator ()) in 9 | Tls_lwt.Unix.connect config (hostname, port) >>= fun t -> 10 | Tls_lwt.Unix.write t "foo\n" >>= fun () -> 11 | let cs = Bytes.create 4 in 12 | Tls_lwt.Unix.read t cs >>= fun _len -> 13 | let cached_session = match Tls_lwt.Unix.epoch t with 14 | | Ok e -> e 15 | | Error () -> invalid_arg "error retrieving epoch" 16 | in 17 | Tls_lwt.Unix.close t >>= fun () -> 18 | Printf.printf "closed session\n" ; 19 | let config = get_ok (Tls.Config.client ~authenticator ~cached_session ()) in 20 | Tls_lwt.connect_ext config (hostname, port) >>= fun (ic, oc) -> 21 | let req = String.concat "\r\n" [ 22 | "GET / HTTP/1.1" ; "Host: " ^ hostname ; "Connection: close" ; "" ; "" 23 | ] in 24 | Lwt_io.(write oc req >>= fun () -> read ic >>= print >>= fun () -> printf "++ done.\n%!") 25 | 26 | let () = 27 | try 28 | match Sys.argv with 29 | | [| _ ; host ; port ; "FP" ; fp |] -> Lwt_main.run (http_client host port ~fp) 30 | | [| _ ; host ; port ; trust |] -> Lwt_main.run (http_client host port ~ca:trust) 31 | | [| _ ; host ; port |] -> Lwt_main.run (http_client host port) 32 | | [| _ ; host |] -> Lwt_main.run (http_client host "443") 33 | | args -> Printf.eprintf "%s \n%!" args.(0) 34 | with 35 | | Tls_lwt.Tls_alert alert as exn -> 36 | print_alert "remote end" alert ; raise exn 37 | | Tls_lwt.Tls_failure fail as exn -> 38 | print_fail "our end" fail ; raise exn 39 | 40 | -------------------------------------------------------------------------------- /lwt/examples/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ex_common) 3 | (libraries lwt lwt.unix tls tls-lwt cmdliner fmt.cli logs.fmt fmt.tty logs.cli) 4 | (modules ex_common)) 5 | 6 | (executable 7 | (name starttls_server) 8 | (modules starttls_server) 9 | (libraries tls-lwt lwt.unix ex_common)) 10 | 11 | (executable 12 | (name echo_server) 13 | (modules echo_server) 14 | (libraries tls-lwt lwt.unix ex_common)) 15 | 16 | (executable 17 | (name echo_server_sni) 18 | (modules echo_server_sni) 19 | (libraries tls-lwt lwt.unix ex_common)) 20 | 21 | (executable 22 | (name echo_server_alpn) 23 | (modules echo_server_alpn) 24 | (libraries tls-lwt lwt.unix ex_common)) 25 | 26 | (executable 27 | (name echo_client) 28 | (modules echo_client) 29 | (libraries tls-lwt lwt.unix ex_common)) 30 | 31 | (executable 32 | (name echo_client_alpn) 33 | (modules echo_client_alpn) 34 | (libraries tls-lwt lwt.unix ex_common)) 35 | 36 | (executable 37 | (name test_server) 38 | (modules test_server) 39 | (libraries tls-lwt lwt.unix ex_common)) 40 | 41 | (executable 42 | (name test_client) 43 | (modules test_client) 44 | (libraries tls-lwt lwt.unix ex_common)) 45 | 46 | (executable 47 | (name tls_over_tls) 48 | (modules tls_over_tls) 49 | (libraries tls-lwt lwt lwt.unix ex_common)) 50 | 51 | (executable 52 | (name http_client) 53 | (modules http_client) 54 | (libraries tls-lwt lwt.unix ex_common)) 55 | 56 | (executable 57 | (name fuzz_server) 58 | (modules fuzz_server) 59 | (libraries tls-lwt lwt.unix ex_common)) 60 | 61 | (executable 62 | (name resume_client) 63 | (modules resume_client) 64 | (libraries tls-lwt lwt.unix ex_common)) 65 | 66 | (executable 67 | (name resume_echo_server) 68 | (modules resume_echo_server) 69 | (libraries randomconv tls-lwt lwt.unix ex_common)) 70 | -------------------------------------------------------------------------------- /tls-eio.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/mirleft/ocaml-tls" 3 | dev-repo: "git+https://github.com/mirleft/ocaml-tls.git" 4 | bug-reports: "https://github.com/mirleft/ocaml-tls/issues" 5 | doc: "https://mirleft.github.io/ocaml-tls/doc" 6 | authors: ["Thomas Leonard"] 7 | maintainer: ["Hannes Mehnert " "David Kaloper "] 8 | license: "BSD-2-Clause" 9 | 10 | build: [ 11 | ["dune" "subst"] {dev} 12 | ["dune" "build" "-p" name "-j" jobs] 13 | ["dune" "runtest" "-p" name "-j" jobs] {with-test & os != "macos"} 14 | ] 15 | 16 | depends: [ 17 | "ocaml" {>= "5.0.0"} 18 | "dune" {>= "3.0"} 19 | "tls" {= version} 20 | "mirage-crypto-rng" {>= "1.2.0"} 21 | "eio" {>= "0.12"} 22 | "eio_main" {>= "0.12" & with-test} 23 | "mdx" {with-test} 24 | "crowbar" {>= "0.2.1" & with-test} 25 | "logs" {>= "0.7.0" & with-test} 26 | "ptime" {>= "1.0.0"} 27 | ] 28 | tags: [ "org:mirage"] 29 | synopsis: "Transport Layer Security purely in OCaml - Eio" 30 | description: """ 31 | Transport Layer Security (TLS) is probably the most widely deployed security 32 | protocol on the Internet. It provides communication privacy to prevent 33 | eavesdropping, tampering, and message forgery. Furthermore, it optionally 34 | provides authentication of the involved endpoints. TLS is commonly deployed for 35 | securing web services ([HTTPS](http://tools.ietf.org/html/rfc2818)), emails, 36 | virtual private networks, and wireless networks. 37 | 38 | TLS uses asymmetric cryptography to exchange a symmetric key, and optionally 39 | authenticate (using X.509) either or both endpoints. It provides algorithmic 40 | agility, which means that the key exchange method, symmetric encryption 41 | algorithm, and hash algorithm are negotiated. 42 | 43 | Read our [Usenix Security 2015 paper](https://www.usenix.org/conference/usenixsecurity15/technical-sessions/presentation/kaloper-mersinjak). 44 | """ 45 | x-maintenance-intent: [ "(latest)" ] 46 | -------------------------------------------------------------------------------- /lib/reader.mli: -------------------------------------------------------------------------------- 1 | 2 | val parse_version : string -> (Core.tls_version, [> `Decode of string ]) result 3 | val parse_any_version : string -> (Core.tls_any_version, [> `Decode of string ]) result 4 | val parse_record : string -> 5 | ([ `Record of (Core.tls_hdr * string) * string 6 | | `Fragment of string 7 | ], [> `Unexpected of [> `Content_type of int ] 8 | | `Protocol_version of [> `Unknown_record of int * int ] 9 | | `Record_overflow of int ]) result 10 | 11 | val parse_handshake_frame : string -> (string option * string) 12 | val parse_handshake : string -> (Core.tls_handshake, [> `Decode of string ]) result 13 | 14 | val parse_alert : string -> (Core.tls_alert, [> `Decode of string ]) result 15 | 16 | val parse_change_cipher_spec : string -> (unit, [> `Decode of string ]) result 17 | 18 | val parse_certificate_request : string -> (Packet.client_certificate_type list * string list, [> `Decode of string ]) result 19 | val parse_certificate_request_1_2 : string -> (Packet.client_certificate_type list * Core.signature_algorithm list * string list, [> `Decode of string ]) result 20 | val parse_certificate_request_1_3 : string -> (string option * Core.certificate_request_extension list, [> `Decode of string ]) result 21 | 22 | val parse_certificates : string -> (string list, [> `Decode of string ]) result 23 | val parse_certificates_1_3 : string -> (string * (string * 'a list) list, [> `Decode of string ]) result 24 | 25 | val parse_client_dh_key_exchange : string -> (string, [> `Decode of string ]) result 26 | val parse_client_ec_key_exchange : string -> (string, [> `Decode of string ]) result 27 | 28 | val parse_dh_parameters : string -> (Core.dh_parameters * string * string, [> `Decode of string ]) result 29 | val parse_ec_parameters : string -> ([ `X25519 | `P256 | `P384 | `P521 ] * string * string * string, [> `Decode of string ]) result 30 | val parse_digitally_signed : string -> (string, [> `Decode of string ]) result 31 | val parse_digitally_signed_1_2 : string -> (Core.signature_algorithm * string, [> `Decode of string ]) result 32 | -------------------------------------------------------------------------------- /lwt/examples/echo_server_sni.ml: -------------------------------------------------------------------------------- 1 | 2 | open Lwt 3 | open Ex_common 4 | 5 | let serve_ssl port callback = 6 | 7 | let tag = "server" in 8 | 9 | X509_lwt.private_of_pems 10 | ~cert:(ca_cert_dir ^ "/bar.pem") 11 | ~priv_key:server_key >>= fun barcert -> 12 | 13 | X509_lwt.private_of_pems 14 | ~cert:(ca_cert_dir ^ "/foo.pem") 15 | ~priv_key:server_key >>= fun foocert -> 16 | 17 | let server_s = 18 | let open Lwt_unix in 19 | let s = socket PF_INET SOCK_STREAM 0 in 20 | bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () -> 21 | listen s 10 ; 22 | s in 23 | 24 | let handle ep channels addr = 25 | let host = match ep with 26 | | Ok data -> ( match data.Tls.Core.own_name with 27 | | Some n -> Domain_name.to_string n 28 | | None -> "no name" ) 29 | | Error () -> "no session" 30 | in 31 | async @@ fun () -> 32 | Lwt.catch (fun () -> callback host channels addr >>= fun () -> yap ~tag "<- handler done") 33 | (function 34 | | Tls_lwt.Tls_alert a -> 35 | yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a 36 | | exn -> yap ~tag "handler: exception" >>= fun () -> fail exn) 37 | in 38 | 39 | let ps = string_of_int port in 40 | yap ~tag ("-> start @ " ^ ps ^ " (use `openssl s_client -connect host:" ^ ps ^ " -servername foo` (or -servername bar))") >>= fun () -> 41 | let rec loop () = 42 | let config = get_ok (Tls.Config.server ~certificates:(`Multiple [barcert ; foocert]) ()) in 43 | server_s >>= fun s -> 44 | Tls_lwt.Unix.accept config s >>= fun (t, addr) -> 45 | yap ~tag "-> connect" >>= fun () -> 46 | ( handle (Tls_lwt.Unix.epoch t) (Tls_lwt.of_t t) addr ; loop () ) 47 | in 48 | loop () 49 | 50 | 51 | let echo_server port = 52 | serve_ssl port @@ fun host (ic, oc) _addr -> 53 | lines ic |> Lwt_stream.iter_s (fun line -> 54 | yap ~tag:("handler " ^ host) ("+ " ^ line) >>= fun () -> 55 | Lwt_io.write_line oc line) 56 | 57 | let () = 58 | let port = 59 | try int_of_string Sys.argv.(1) with _ -> 4433 60 | in 61 | Lwt_main.run (echo_server port) 62 | -------------------------------------------------------------------------------- /async/examples/test_server.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | let server_cert = "./certificates/server.pem" 5 | let server_key = "./certificates/server.key" 6 | 7 | let serve_tls ~low_level port handler = 8 | let%bind certificate = 9 | Tls_async.X509_async.Certificate.of_pem_file server_cert |> Deferred.Or_error.ok_exn 10 | in 11 | let%bind priv_key = 12 | Tls_async.X509_async.Private_key.of_pem_file server_key |> Deferred.Or_error.ok_exn 13 | in 14 | let config = 15 | match Tls.Config.( 16 | server 17 | ~version:(`TLS_1_0, `TLS_1_2) 18 | ~certificates:(`Single (certificate, priv_key)) 19 | ~ciphers:Ciphers.supported 20 | ()) 21 | with 22 | | Ok cfg -> cfg 23 | | Error `Msg msg -> invalid_arg msg 24 | in 25 | let where_to_listen = Tcp.Where_to_listen.of_port port in 26 | let on_handler_error = `Ignore in 27 | if low_level then 28 | Tcp.Server.create 29 | ~on_handler_error 30 | where_to_listen 31 | (fun sa -> 32 | printf !"connection establised from %{Socket.Address.Inet} starting TLS\n" sa; 33 | Tls_async.upgrade_server_handler ~config (handler sa)) 34 | else 35 | Tls_async.listen ~on_handler_error config where_to_listen handler 36 | ;; 37 | 38 | let test_server ~low_level port = 39 | let handler (_ : Socket.Address.Inet.t) (_ : Tls_async.Session.t) rd wr = 40 | let pipe = Reader.pipe rd in 41 | let rec read_from_pipe () = 42 | (match%map Pipe.read pipe with 43 | | `Ok line -> Writer.write wr line 44 | | `Eof -> ()) 45 | >>= read_from_pipe 46 | in 47 | read_from_pipe () 48 | in 49 | serve_tls ~low_level port handler 50 | ;; 51 | 52 | let cmd = 53 | let open Command.Let_syntax in 54 | Command.async 55 | ~summary:"test server" 56 | (let%map_open port = anon ("PORT" %: int) 57 | and low_level = flag "-low-level" no_arg ~doc:"set up Tcp.server directly" in 58 | fun () -> 59 | let open Deferred.Let_syntax in 60 | let%bind server = test_server ~low_level port in 61 | Tcp.Server.close_finished server) 62 | ;; 63 | 64 | let () = Command_unix.run cmd 65 | -------------------------------------------------------------------------------- /tests/testlib.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let () = Mirage_crypto_rng_unix.use_default () 4 | 5 | let time f = 6 | let t1 = Sys.time () in 7 | let r = f () in 8 | let t2 = Sys.time () in 9 | ( Printf.eprintf "[time] %f.04 s\n%!" (t2 -. t1) ; r ) 10 | 11 | let list_to_cstruct xs = 12 | let buf = Bytes.create (List.length xs) in 13 | List.iteri (Bytes.set_uint8 buf) xs ; 14 | Bytes.unsafe_to_string buf 15 | 16 | let uint16_to_cstruct i = 17 | let buf = Bytes.create 2 in 18 | Bytes.set_uint16_be buf 0 i; 19 | buf 20 | 21 | let hexdump_to_str cs = 22 | Ohex.encode cs 23 | 24 | let assert_cs_eq ?msg cs1 cs2 = 25 | assert_equal 26 | ~cmp:String.equal 27 | ~printer:hexdump_to_str 28 | ?msg 29 | cs1 cs2 30 | 31 | let rec assert_lists_eq comparison a b = 32 | match a, b with 33 | | [], [] -> () 34 | | a::r1, b::r2 -> comparison a b ; assert_lists_eq comparison r1 r2 35 | | _ -> assert_failure "lists not equal" 36 | 37 | 38 | let assert_sessionid_equal a b = 39 | match a, b with 40 | | None, None -> () 41 | | Some x, Some y -> assert_cs_eq x y 42 | | _ -> assert_failure "session id not equal" 43 | 44 | let assert_client_extension_equal a b = 45 | match a, b with 46 | | `Hostname a, `Hostname b -> assert_equal a b 47 | | `MaxFragmentLength a, `MaxFragmentLength b -> assert_equal a b 48 | | `SupportedGroups a, `SupportedGroups b -> assert_lists_eq assert_equal a b 49 | | `SecureRenegotiation a, `SecureRenegotiation b -> assert_cs_eq a b 50 | | `Padding a, `Padding b -> assert_equal a b 51 | | `SignatureAlgorithms a, `SignatureAlgorithms b -> 52 | assert_lists_eq (fun sa sa' -> assert_equal sa sa') a b 53 | | `ALPN a, `ALPN b -> assert_lists_eq assert_equal a b 54 | | _ -> assert_failure "extensions did not match" 55 | 56 | let assert_server_extension_equal a b = 57 | match a, b with 58 | | `Hostname, `Hostname -> () 59 | | `MaxFragmentLength a, `MaxFragmentLength b -> assert_equal a b 60 | | `SecureRenegotiation a, `SecureRenegotiation b -> assert_cs_eq a b 61 | | `ALPN a, `ALPN b -> assert_equal a b 62 | | _ -> assert_failure "extensions did not match" 63 | 64 | let make_hostname_ext h = 65 | (`Hostname (Domain_name.of_string_exn h |> Domain_name.host_exn)) 66 | -------------------------------------------------------------------------------- /sni.md: -------------------------------------------------------------------------------- 1 | ### Server Name Indication 2 | 3 | Some TLS servers might want to provide service for various services, 4 | all on the same port, but with different names. The SNI extension 5 | allows a client to request a specific server name. The server may use 6 | the requested server name to select the X.509 certificate chain which 7 | it presents to the client. 8 | 9 | ### Configuration interface 10 | 11 | A user provides a full certificate chain and a private key 12 | corresponding to the first certificate in the list to OCaml-TLS, 13 | captured by the type `certchain`. 14 | 15 | ```` 16 | type certchain = Certificate.certificate list * Nocrypto.Rsa.priv 17 | ```` 18 | 19 | The `own_cert` polymorphic variant covers the various configuration 20 | options: either no certificate is provided, a single one, multiple 21 | ones (whose common name/subject alternative name are used for 22 | disambiguation), and multiple with a default one. 23 | 24 | ```` 25 | type own_cert = [ 26 | | `None 27 | | `Single of certchain 28 | | `Multiple of certchain list 29 | | `Multiple_default of certchain * certchain list 30 | ] 31 | 32 | ```` 33 | 34 | ### Validation 35 | 36 | The configuration of certificates is intertwined with ciphersuites: 37 | each ciphersuite which requires a certificate furthermore depends on 38 | properties of this certificate - RSA and DHE_RSA require the key to be 39 | RSA, RSA requires the X.509v3 extension key_usage to contain 40 | encipherment, DHE_RSA requires key_usage to contain digital_signature. 41 | There must exist at least one certificate with the mentioned 42 | properties for each configured ciphersuite. 43 | 44 | Furthermore, to avoid ambiguity, the hostnames in ``Multiple` and 45 | ``Multiple_default` certificate lists must be non-overlapping. 46 | 47 | ### Certificate selection 48 | 49 | If the server is configured with only a default certificate, this is 50 | always used. 51 | 52 | If the client does not request for a server name, the default 53 | certificate is used. 54 | 55 | If the client requests a specific server name: 56 | - find a strict match 57 | - find a wildcard match 58 | - use the default one if present 59 | 60 | Only after a certificate is set for the session, the ciphersuite is 61 | selected, depending on the properties of the certificate. 62 | -------------------------------------------------------------------------------- /lwt/examples/echo_server_alpn.ml: -------------------------------------------------------------------------------- 1 | 2 | open Lwt 3 | open Ex_common 4 | 5 | let split_on_char sep s = 6 | let r = ref [] in 7 | let j = ref (String.length s) in 8 | for i = String.length s - 1 downto 0 do 9 | if s.[i] = sep then begin 10 | r := String.sub s (i + 1) (!j - i - 1) :: !r; 11 | j := i 12 | end 13 | done; 14 | String.sub s 0 !j :: !r 15 | 16 | let serve_ssl alpn_protocols port callback = 17 | 18 | let tag = "server" in 19 | 20 | X509_lwt.private_of_pems 21 | ~cert:server_cert 22 | ~priv_key:server_key >>= fun certificate -> 23 | 24 | let server_s = 25 | let open Lwt_unix in 26 | let s = socket PF_INET SOCK_STREAM 0 in 27 | bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () -> 28 | listen s 10 ; 29 | s in 30 | 31 | let handle ep channels addr = 32 | let alpn = match ep with 33 | | Ok data -> (match data.Tls.Core.alpn_protocol with 34 | | Some a -> a 35 | | None -> "no alpn") 36 | | Error () -> "no session" 37 | in 38 | async @@ fun () -> 39 | Lwt.catch (fun () -> callback alpn channels addr >>= fun () -> yap ~tag "<- handler done") 40 | (function 41 | | Tls_lwt.Tls_alert a -> 42 | yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a 43 | | exn -> yap ~tag "handler: exception" >>= fun () -> fail exn) 44 | in 45 | 46 | let ps = string_of_int port in 47 | yap ~tag ("-> start @ " ^ ps ^ " (use `openssl s_client -connect host:" ^ ps ^ " -alpn `), available protocols: " ^ String.concat "," alpn_protocols) >>= fun () -> 48 | let rec loop () = 49 | let config = get_ok (Tls.Config.server ~certificates:(`Single certificate) ~alpn_protocols ()) in 50 | server_s >>= fun s -> 51 | Tls_lwt.Unix.accept config s >>= fun (t, addr) -> 52 | yap ~tag "-> connect" >>= fun () -> 53 | ( handle (Tls_lwt.Unix.epoch t) (Tls_lwt.of_t t) addr ; loop () ) 54 | in 55 | loop () 56 | 57 | 58 | let echo_server protocols port = 59 | serve_ssl protocols port @@ fun alpn (ic, oc) _addr -> 60 | lines ic |> Lwt_stream.iter_s (fun line -> 61 | yap ~tag:("handler alpn: " ^ alpn) ("+ " ^ line) >>= fun () -> 62 | Lwt_io.write_line oc line) 63 | 64 | let () = 65 | let protocols = 66 | try split_on_char ',' Sys.argv.(1) with _ -> [ "h2" ; "http/1.1" ] 67 | in 68 | Lwt_main.run (echo_server protocols 4433) 69 | -------------------------------------------------------------------------------- /tls.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/mirleft/ocaml-tls" 3 | dev-repo: "git+https://github.com/mirleft/ocaml-tls.git" 4 | bug-reports: "https://github.com/mirleft/ocaml-tls/issues" 5 | doc: "https://mirleft.github.io/ocaml-tls/doc" 6 | author: ["David Kaloper " "Hannes Mehnert "] 7 | maintainer: ["Hannes Mehnert " "David Kaloper "] 8 | license: "BSD-2-Clause" 9 | 10 | build: [ 11 | ["dune" "subst"] {dev} 12 | ["dune" "build" "-p" name "-j" jobs] 13 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 14 | ] 15 | 16 | depends: [ 17 | "ocaml" {>= "4.13.0"} 18 | "dune" {>= "3.0"} 19 | "mirage-crypto" {>= "1.1.0"} 20 | "mirage-crypto-ec" {>= "1.0.0"} 21 | "mirage-crypto-pk" {>= "1.0.0"} 22 | "mirage-crypto-rng" {>= "1.2.0"} 23 | "x509" {>= "1.0.0"} 24 | "domain-name" {>= "0.3.0"} 25 | "fmt" {>= "0.8.7"} 26 | "ounit2" {with-test & >= "2.2.0"} 27 | "kdf" {>= "1.0.0"} 28 | "logs" 29 | "ipaddr" 30 | "ohex" {>= "0.2.0"} 31 | "digestif" {>= "1.2.0"} 32 | "ptime" {>= "1.2.0"} 33 | "alcotest" {with-test} 34 | "cmdliner" {with-test & >= "1.3.0"} 35 | ] 36 | conflicts: [ "result" {< "1.5"} ] 37 | tags: [ "org:mirage"] 38 | synopsis: "Transport Layer Security purely in OCaml" 39 | description: """ 40 | Transport Layer Security (TLS) is probably the most widely deployed security 41 | protocol on the Internet. It provides communication privacy to prevent 42 | eavesdropping, tampering, and message forgery. Furthermore, it optionally 43 | provides authentication of the involved endpoints. TLS is commonly deployed for 44 | securing web services ([HTTPS](http://tools.ietf.org/html/rfc2818)), emails, 45 | virtual private networks, and wireless networks. 46 | 47 | TLS uses asymmetric cryptography to exchange a symmetric key, and optionally 48 | authenticate (using X.509) either or both endpoints. It provides algorithmic 49 | agility, which means that the key exchange method, symmetric encryption 50 | algorithm, and hash algorithm are negotiated. 51 | 52 | Read our [Usenix Security 2015 paper](https://www.usenix.org/conference/usenixsecurity15/technical-sessions/presentation/kaloper-mersinjak). 53 | """ 54 | available: [ arch != "arm32" ] # see SIGBUS failures at https://github.com/ocaml/opam-repository/pull/26387 55 | x-maintenance-intent: [ "(latest)" ] 56 | -------------------------------------------------------------------------------- /tests/interop-mbedtls-client2.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | port=4455 4 | polarssl="/opt/bin/mbedtls_ssl_client2 auth_mode=none server_port=" 5 | 6 | extra_args="" 7 | statfile="/tmp/test_server.status" 8 | 9 | testit () { 10 | /bin/sh -c "cd .. && ./_build/default/lwt/examples/test_server.exe $port > /dev/null && echo foo > $statfile" & 11 | 12 | sleep 0.3 13 | 14 | $polarssl$port $extra_args 2> /dev/null > /dev/null 15 | 16 | sleep 0.3 17 | 18 | if [ -e $statfile ]; then 19 | result=$(cat $statfile) 20 | if [ $result = "foo" ]; then 21 | echo "success with $extra_args" 22 | else 23 | echo "failure with $polarssl$port $extra_args (statfile there)" 24 | exit 1 25 | fi 26 | rm $statfile 27 | else 28 | echo "failure with $polarssl$port $extra_args" 29 | exit 1 30 | fi 31 | sleep 0.3 32 | port=$(expr $port + 1) 33 | } 34 | 35 | testit 36 | 37 | extra_args="force_version=tls1" 38 | testit 39 | 40 | extra_args="force_version=tls1_1" 41 | testit 42 | 43 | extra_args="force_version=tls1_2" 44 | testit 45 | 46 | ciphers=" 47 | TLS-DHE-RSA-WITH-AES-256-CBC-SHA 48 | TLS-DHE-RSA-WITH-AES-128-CBC-SHA 49 | TLS-DHE-RSA-WITH-3DES-EDE-CBC-SHA 50 | TLS-RSA-WITH-AES-256-CBC-SHA 51 | TLS-RSA-WITH-AES-128-CBC-SHA 52 | TLS-RSA-WITH-3DES-EDE-CBC-SHA 53 | TLS-RSA-WITH-RC4-128-SHA 54 | TLS-RSA-WITH-RC4-128-MD5" 55 | 56 | for i in $ciphers; do 57 | extra_args="force_ciphersuite=$i" 58 | testit 59 | 60 | extra_args="force_version=tls1 force_ciphersuite=$i" 61 | testit 62 | 63 | extra_args="force_version=tls1_1 force_ciphersuite=$i" 64 | testit 65 | 66 | extra_args="force_version=tls1_2 force_ciphersuite=$i" 67 | testit 68 | done 69 | 70 | tls12_ciphers=" 71 | TLS-DHE-RSA-WITH-AES-256-CCM 72 | TLS-DHE-RSA-WITH-AES-128-CCM 73 | TLS-DHE-RSA-WITH-AES-256-CBC-SHA256 74 | TLS-DHE-RSA-WITH-AES-128-CBC-SHA256 75 | TLS-DHE-RSA-WITH-AES-256-GCM-SHA384 76 | TLS-DHE-RSA-WITH-AES-128-GCM-SHA256 77 | TLS-RSA-WITH-AES-256-CCM 78 | TLS-RSA-WITH-AES-128-CCM 79 | TLS-RSA-WITH-AES-256-CBC-SHA256 80 | TLS-RSA-WITH-AES-128-CBC-SHA256 81 | TLS-RSA-WITH-AES-256-GCM-SHA384 82 | TLS-RSA-WITH-AES-128-GCM-SHA256" 83 | for i in $tls12_ciphers; do 84 | extra_args="force_ciphersuite=$i" 85 | testit 86 | 87 | extra_args="force_version=tls1_2 force_ciphersuite=$i" 88 | testit 89 | done 90 | -------------------------------------------------------------------------------- /async/io_intf.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | module type Fd = sig 5 | type t 6 | 7 | val read : t -> bytes -> [ `Ok of int | `Eof ] Deferred.Or_error.t 8 | val write_full : t -> string -> unit Deferred.Or_error.t 9 | end 10 | 11 | module type S = sig 12 | module Fd : Fd 13 | 14 | (** Abstract type of a session *) 15 | type t 16 | 17 | (** {2 Constructors} *) 18 | 19 | (** [server_of_fd server fd] is [t], after server-side TLS 20 | handshake of [fd] using [server] configuration. *) 21 | val server_of_fd : Tls.Config.server -> Fd.t -> t Deferred.Or_error.t 22 | 23 | (** [client_of_fd client ~host fd] is [t], after client-side 24 | TLS handshake of [fd] using [client] configuration and [host]. *) 25 | val client_of_fd 26 | : Tls.Config.client 27 | -> ?host:[ `host ] Domain_name.t 28 | -> Fd.t 29 | -> t Deferred.Or_error.t 30 | 31 | (** {2 Common stream operations} *) 32 | 33 | (** [read t buffer] is [length], the number of bytes read into 34 | [buffer]. *) 35 | val read : t -> bytes -> int Deferred.Or_error.t 36 | 37 | (** [writev t buffers] writes the [buffers] to the session. *) 38 | val writev : t -> string list -> unit Deferred.Or_error.t 39 | 40 | (** [close t] closes the TLS session by sending a close notify to the peer. *) 41 | val close_tls : t -> unit Deferred.Or_error.t 42 | 43 | (** [reneg ~authenticator ~acceptable_cas ~cert ~drop t] renegotiates the 44 | session, and blocks until the renegotiation finished. Optionally, a new 45 | [authenticator] and [acceptable_cas] can be used. The own certificate can 46 | be adjusted by [cert]. If [drop] is [true] (the default), 47 | application data received before the renegotiation finished is dropped. *) 48 | val reneg 49 | : ?authenticator:X509.Authenticator.t 50 | -> ?acceptable_cas:X509.Distinguished_name.t list 51 | -> ?cert:Tls.Config.own_cert 52 | -> ?drop:bool 53 | -> t 54 | -> unit Deferred.Or_error.t 55 | 56 | (** [key_update ~request t] updates the traffic key and requests a traffic key 57 | update from the peer if [request] is provided and [true] (the default). 58 | This is only supported in TLS 1.3. *) 59 | val key_update : ?request:bool -> t -> unit Deferred.Or_error.t 60 | 61 | (** [epoch t] returns [epoch], which contains information of the 62 | active session. *) 63 | val epoch : t -> Tls.Core.epoch_data Or_error.t 64 | end 65 | -------------------------------------------------------------------------------- /lwt/examples/echo_client.ml: -------------------------------------------------------------------------------- 1 | 2 | open Ex_common 3 | open Lwt 4 | 5 | let cached_session : Tls.Core.epoch_data = 6 | let hex = Ohex.decode in 7 | { 8 | Tls.Core.side = `Client ; 9 | protocol_version = `TLS_1_3 ; 10 | ciphersuite = `DHE_RSA_WITH_AES_128_GCM_SHA256 ; 11 | peer_random = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ; 12 | peer_certificate = None ; 13 | peer_certificate_chain = [] ; 14 | peer_name = None ; 15 | trust_anchor = None ; 16 | received_certificates = [] ; 17 | own_random = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ; 18 | own_certificate = [] ; 19 | own_private_key = None ; 20 | own_name = None ; 21 | master_secret = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ; 22 | exporter_master_secret = "" ; 23 | session_id = "" ; 24 | extended_ms = true ; 25 | alpn_protocol = None ; 26 | state = `Established ; 27 | tls_unique = None ; 28 | } 29 | 30 | let echo_client ?ca hostname port = 31 | let open Lwt_io in 32 | auth ?ca () >>= fun authenticator -> 33 | X509_lwt.private_of_pems 34 | ~cert:server_cert 35 | ~priv_key:server_key >>= fun certificate -> 36 | Tls_lwt.connect_ext 37 | (get_ok Tls.Config.(client ~authenticator ~cached_session ~certificates:(`Single certificate) ~ciphers:Ciphers.supported ())) 38 | (hostname, port) >>= fun (ic, oc) -> 39 | Lwt.join [ 40 | lines ic |> Lwt_stream.iter_s (printf "+ %s\n%!") ; 41 | lines stdin |> Lwt_stream.iter_s (write_line oc) 42 | ] 43 | 44 | let jump _ port host ca = 45 | try 46 | Lwt_main.run (echo_client ?ca host port) 47 | with 48 | | Tls_lwt.Tls_alert alert as exn -> 49 | print_alert "remote end" alert ; raise exn 50 | | Tls_lwt.Tls_failure alert as exn -> 51 | print_fail "our end" alert ; raise exn 52 | 53 | open Cmdliner 54 | 55 | let port = 56 | let doc = "Port to connect to" in 57 | Arg.(value & opt int 443 & info [ "port" ] ~doc) 58 | 59 | let host = 60 | let doc = "Host to connect to" in 61 | Arg.(value & opt string "" & info [ "host" ] ~doc) 62 | 63 | let trust = 64 | let doc = "Trust anchor" in 65 | Arg.(value & opt (some string) None & info [ "trust" ] ~doc) 66 | 67 | let cmd = 68 | let term = Term.(const jump $ setup_log $ port $ host $ trust) 69 | and info = Cmd.info "echo_client" ~version:"%%VERSION_NUM%%" 70 | in 71 | Cmd.v info term 72 | 73 | let () = exit (Cmd.eval cmd) 74 | -------------------------------------------------------------------------------- /tests/interop-openssl-sclient.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | port=4455 4 | s_client_args="s_client -quiet -connect 127.0.0.1:" 5 | 6 | extra_args="" 7 | statfile="/tmp/test_server.status" 8 | 9 | testit () { 10 | /bin/sh -c "cd ../ && ./_build/default/lwt/examples/test_server.exe $port > /dev/null && echo foo > $statfile" & 11 | 12 | sleep 0.3 13 | 14 | echo "GET /" | openssl $s_client_args$port $extra_args 2> /dev/null > /dev/null 15 | 16 | sleep 0.3 17 | 18 | if [ -e $statfile ]; then 19 | result=$(cat $statfile) 20 | if [ $result = "foo" ]; then 21 | echo "success with $extra_args" 22 | else 23 | echo "failure with openssl $s_client_args $extra_args (statfile there)" 24 | exit 1 25 | fi 26 | rm $statfile 27 | else 28 | echo "failure with openssl $s_client_args$port $extra_args (no statfile)" 29 | exit 1 30 | fi 31 | sleep 0.3 32 | port=$(expr $port + 1) 33 | } 34 | 35 | testit 36 | 37 | extra_args="-tls1" 38 | testit 39 | 40 | extra_args="-tls1_1" 41 | testit 42 | 43 | extra_args="-tls1_2" 44 | testit 45 | 46 | extra_args="-tls1_3" 47 | testit 48 | 49 | ciphers="DHE-RSA-AES256-SHA AES256-SHA DHE-RSA-AES128-SHA AES128-SHA ECDHE-RSA-AES256-SHA ECDHE-RSA-AES128-SHA ECDHE-ECDSA-AES128-SHA ECDHE-ECDSA-AES256-SHA" 50 | #OpenSSL <1.1.1: 51 | #EDH-RSA-DES-CBC3-SHA DES-CBC3-SHA 52 | for i in $ciphers; do 53 | extra_args="-cipher $i" 54 | testit 55 | 56 | extra_args="-tls1 -cipher $i" 57 | testit 58 | 59 | extra_args="-tls1_1 -cipher $i" 60 | testit 61 | 62 | extra_args="-tls1_2 -cipher $i" 63 | testit 64 | done 65 | 66 | tls12_ciphers="DHE-RSA-AES256-SHA256 AES256-SHA256 DHE-RSA-AES128-SHA256 AES128-SHA256 AES128-GCM-SHA256 DHE-RSA-AES128-GCM-SHA256 AES256-GCM-SHA384 DHE-RSA-AES256-GCM-SHA384 ECDHE-RSA-AES256-GCM-SHA384 ECDHE-RSA-AES128-GCM-SHA256 ECDHE-RSA-AES256-SHA384 ECDHE-RSA-AES128-SHA256 ECDHE-RSA-CHACHA20-POLY1305 DHE-RSA-CHACHA20-POLY1305 ECDHE-ECDSA-AES128-SHA256 ECDHE-ECDSA-AES256-SHA384 ECDHE-ECDSA-AES128-GCM-SHA256 ECDHE-ECDSA-AES256-GCM-SHA384 ECDHE-ECDSA-CHACHA20-POLY1305" 67 | for i in $tls12_ciphers; do 68 | extra_args="-cipher $i" 69 | testit 70 | 71 | extra_args="-tls1_2 -cipher $i" 72 | testit 73 | done 74 | 75 | tls13_ciphers="TLS_AES_256_GCM_SHA384 TLS_AES_128_GCM_SHA256 TLS_CHACHA20_POLY1305_SHA256" 76 | for i in $tls13_ciphers; do 77 | extra_args="-ciphersuites $i" 78 | testit 79 | 80 | extra_args="-tls1_3 -ciphersuites $i" 81 | testit 82 | done 83 | -------------------------------------------------------------------------------- /eio/tls_eio.mli: -------------------------------------------------------------------------------- 1 | (** Effectful operations using Eio for pure TLS. 2 | 3 | The pure TLS is state and buffer in, state and buffer out. This 4 | module uses Eio for communication over the network. *) 5 | 6 | open Eio.Std 7 | 8 | (** [Tls_alert] exception received from the other endpoint *) 9 | exception Tls_alert of Tls.Packet.alert_type 10 | 11 | (** [Tls_failure] exception while processing incoming data *) 12 | exception Tls_failure of Tls.Engine.failure 13 | 14 | type t = [ `Tls | Eio.Flow.two_way_ty | Eio.Resource.close_ty ] r 15 | 16 | (** {2 Constructors} *) 17 | 18 | (** [server_of_flow server flow] is [t], after server-side TLS 19 | handshake of [flow] using [server] configuration. 20 | 21 | You must ensure a RNG is installed while using TLS, e.g. using [Mirage_crypto_rng_unix.use_default ()]. 22 | Ideally, this would be part of the [server] config so you couldn't forget it, 23 | but for now you'll get a runtime error if you forget. *) 24 | val server_of_flow : 25 | Tls.Config.server -> 26 | [> Eio.Flow.two_way_ty | Eio.Resource.close_ty] r -> t 27 | 28 | (** [client_of_flow client ~host fd] is [t], after client-side 29 | TLS handshake of [flow] using [client] configuration and [host]. 30 | 31 | You must ensure a RNG is installed while using TLS, e.g. using [Mirage_crypto_rng_unix.use_default ()]. 32 | Ideally, this would be part of the [client] config so you couldn't forget it, 33 | but for now you'll get a runtime error if you forget. *) 34 | val client_of_flow : 35 | Tls.Config.client -> ?host:[ `host ] Domain_name.t -> 36 | [> Eio.Flow.two_way_ty | Eio.Resource.close_ty] r -> t 37 | 38 | (** {2 Control of TLS features} *) 39 | 40 | (** [reneg ~authenticator ~acceptable_cas ~cert ~drop t] renegotiates the 41 | session, and blocks until the renegotiation finished. Optionally, a new 42 | [authenticator] and [acceptable_cas] can be used. The own certificate can 43 | be adjusted by [cert]. If [drop] is [true] (the default), 44 | application data received before the renegotiation finished is dropped. *) 45 | val reneg : 46 | ?authenticator:X509.Authenticator.t -> 47 | ?acceptable_cas:X509.Distinguished_name.t list -> 48 | ?cert:Tls.Config.own_cert -> 49 | ?drop:bool -> 50 | t -> unit 51 | 52 | (** [key_update ~request t] updates the traffic key and requests a traffic key 53 | update from the peer if [request] is provided and [true] (the default). 54 | This is only supported in TLS 1.3. *) 55 | val key_update : ?request:bool -> t -> unit 56 | 57 | (** [epoch t] returns [epoch], which contains information of the 58 | active session. *) 59 | val epoch : t -> (Tls.Core.epoch_data, unit) result 60 | -------------------------------------------------------------------------------- /lwt/examples/starttls_server.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Ex_common 3 | 4 | let capability = "[CAPABILITY IMAP4rev1 LITERAL+ SASL-IR LOGIN-REFERRALS ID ENABLE IDLE STARTTLS AUTH=PLAIN] server ready.\r\n" 5 | 6 | let ok_starttls = "OK STARTTLS\r\n" 7 | 8 | let cert () = 9 | X509_lwt.private_of_pems 10 | ~cert:"./certificates/server.pem" 11 | ~priv_key:"./certificates/server.key" 12 | 13 | let init_socket addr port = 14 | let sockaddr = Unix.ADDR_INET (Unix.inet_addr_of_string addr, port) in 15 | let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 16 | Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true; 17 | Lwt_unix.bind socket sockaddr >|= fun () -> 18 | socket 19 | 20 | let create_srv_socket addr port = 21 | init_socket addr port >|= fun socket -> 22 | Lwt_unix.listen socket 10; 23 | socket 24 | 25 | let accept sock = 26 | Lwt_unix.accept sock >>= fun (sock_cl, addr) -> 27 | let ic = Lwt_io.of_fd ~close:(fun () -> Lwt.return_unit) ~mode:Lwt_io.input sock_cl in 28 | let oc = Lwt_io.of_fd ~close:(fun () -> Lwt.return_unit) ~mode:Lwt_io.output sock_cl in 29 | Lwt.return ((ic,oc), addr, sock_cl) 30 | 31 | let start_server () = 32 | let write oc buff = 33 | Lwt_io.write oc buff >>= fun () -> Lwt_io.flush oc 34 | in 35 | let read ic = 36 | Lwt_io.read ic ~count:2048 >>= fun buff -> 37 | Printf.printf "%s%!" buff; 38 | Lwt.return buff 39 | in 40 | let parse buff = 41 | match String.index buff ' ' with 42 | | exception Not_found -> "", "" 43 | | idx -> 44 | let l = String.length buff in 45 | String.sub buff 0 idx, String.sub buff (succ idx) (l - succ idx) 46 | in 47 | let rec wait_cmd sock_cl ic oc = 48 | read ic >>= fun buff -> 49 | let tag,cmd = parse buff in 50 | match cmd with 51 | | "CAPABILITY" -> 52 | write oc ("* " ^ capability ^ tag ^ " OK CAPABILITY\r\n") >>= fun () -> 53 | wait_cmd sock_cl ic oc 54 | | "STARTTLS" -> 55 | write oc (tag ^ ok_starttls) >>= fun () -> 56 | Lwt_io.close ic >>= fun () -> 57 | Lwt_io.close oc >>= fun () -> 58 | cert () >>= fun cert -> 59 | Tls_lwt.Unix.server_of_fd 60 | (get_ok (Tls.Config.server ~certificates:(`Single cert) ())) sock_cl >>= fun s -> 61 | let ic,oc = Tls_lwt.of_t s in 62 | write oc ("* OK " ^ capability) >>= fun () -> 63 | wait_cmd sock_cl ic oc 64 | | _ -> 65 | write oc ("BAD\r\n") >>= fun () -> 66 | wait_cmd sock_cl ic oc 67 | in 68 | create_srv_socket "127.0.0.1" 143 >>= fun sock -> 69 | accept sock >>= fun ((ic,oc), _addr, sock_cl) -> 70 | write oc ("* OK " ^ capability) >>= fun () -> 71 | wait_cmd sock_cl ic oc 72 | 73 | let () = 74 | Lwt_main.run (start_server ()) 75 | -------------------------------------------------------------------------------- /lwt/examples/tls_over_tls.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Ex_common 3 | 4 | let hostname = "mirage.io" 5 | 6 | let proxy = "127.0.0.1", 3129 7 | 8 | (* To test TLS-over-TLS, the `squid` proxy can be installed locally and configured to support HTTPS: 9 | 10 | - Generate a certificate for localhost: https://gist.github.com/cecilemuller/9492b848eb8fe46d462abeb26656c4f8 11 | 12 | $ openssl req -x509 -nodes -new -sha256 -days 1024 -newkey rsa:2048 -keyout RootCA.key -out RootCA.pem -subj "/C=US/CN=Example-Root-CA" 13 | $ openssl x509 -outform pem -in RootCA.pem -out RootCA.crt 14 | $ cat < domains.ext 15 | authorityKeyIdentifier=keyid,issuer 16 | basicConstraints=CA:FALSE 17 | keyUsage = digitalSignature, nonRepudiation, keyEncipherment, dataEncipherment 18 | subjectAltName = @alt_names 19 | [alt_names] 20 | DNS.1 = localhost 21 | EOF 22 | $ 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" 23 | $ openssl x509 -req -sha256 -days 1024 -in localhost.csr -CA RootCA.pem -CAkey RootCA.key -CAcreateserial -extfile domains.ext -out localhost.crt 24 | 25 | - Configure squid by adding HTTPS support on port 3129 in /etc/squid/squid.conf : 26 | 27 | https_port 3129 tls-cert=/path/to/localhost.crt tls-key=/path/to/localhost.key 28 | 29 | *) 30 | 31 | let client = get_ok (Tls.Config.client ~authenticator:null_auth ()) 32 | 33 | let string_prefix ~prefix msg = 34 | let len = String.length prefix in 35 | String.length msg >= len && String.sub msg 0 len = prefix 36 | 37 | let host = Result.get_ok (Domain_name.of_string hostname) 38 | let host = Result.get_ok (Domain_name.host host) 39 | 40 | let test_client _ = 41 | (* Connect to proxy *) 42 | Tls_lwt.Unix.connect client proxy >>= fun t -> 43 | let (ic, oc) = Tls_lwt.of_t t in 44 | 45 | (* Request proxy to connect to hostname *) 46 | let req = 47 | Printf.sprintf "CONNECT %s:443 HTTP/1.1\r\nHost: %s\r\n\r\n" 48 | hostname hostname 49 | in 50 | Lwt_io.write oc req >>= fun () -> 51 | Lwt_io.read ic ~count:1024 >>= fun msg -> 52 | assert (string_prefix ~prefix:"HTTP/1.1 200 " msg) ; 53 | 54 | (* TLS with hostname, over the TLS connection with the proxy *) 55 | Tls_lwt.Unix.client_of_channels client ~host (ic, oc) >>= fun t -> 56 | let (ic, oc) = Tls_lwt.of_t t in 57 | 58 | (* Request homepage from host *) 59 | let req = 60 | Printf.sprintf "GET / HTTP/1.1\r\nHost: %s\r\nConnection: close\r\n\r\n" 61 | hostname 62 | in 63 | 64 | Lwt_io.(write oc req >>= fun () -> 65 | read ~count:1024 ic >>= print >>= fun () -> 66 | read ~count:1024 ic >>= print >>= fun () -> 67 | close oc >>= fun () -> 68 | printf "++ done.\n%!") 69 | 70 | let () = Lwt_main.run (test_client ()) 71 | -------------------------------------------------------------------------------- /lwt/examples/echo_server.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Ex_common 3 | 4 | let string_of_unix_err err f p = 5 | Printf.sprintf "Unix_error (%s, %s, %s)" 6 | (Unix.error_message err) f p 7 | 8 | let serve_ssl port callback = 9 | 10 | let tag = "server" in 11 | 12 | X509_lwt.private_of_pems 13 | ~cert:server_cert 14 | ~priv_key:server_key >>= fun cert -> 15 | 16 | let server_s () = 17 | let open Lwt_unix in 18 | let s = socket PF_INET SOCK_STREAM 0 in 19 | setsockopt s SO_REUSEADDR true ; 20 | bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () -> 21 | listen s 10 ; 22 | s in 23 | 24 | let handle channels addr = 25 | async @@ fun () -> 26 | Lwt.catch (fun () -> callback channels addr >>= fun () -> yap ~tag "<- handler done") 27 | (function 28 | | Tls_lwt.Tls_alert a -> 29 | yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a 30 | | Tls_lwt.Tls_failure a -> 31 | yap ~tag @@ "handler: " ^ Tls.Engine.string_of_failure a 32 | | Unix.Unix_error (e, f, p) -> 33 | yap ~tag @@ "handler: " ^ (string_of_unix_err e f p) 34 | | _exn -> yap ~tag "handler: exception") 35 | in 36 | 37 | yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () -> 38 | let rec loop s = 39 | let authenticator = null_auth in 40 | 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 41 | (Lwt.catch 42 | (fun () -> Tls_lwt.accept_ext config s >|= fun r -> `R r) 43 | (function 44 | | Unix.Unix_error (e, f, p) -> return (`L (string_of_unix_err e f p)) 45 | | Tls_lwt.Tls_alert a -> return (`L (Tls.Packet.alert_type_to_string a)) 46 | | Tls_lwt.Tls_failure f -> return (`L (Tls.Engine.string_of_failure f)) 47 | | exn -> return (`L ("loop: exception: " ^ Printexc.to_string exn)))) >>= function 48 | | `R (channels, addr) -> 49 | yap ~tag "-> connect" >>= fun () -> ( handle channels addr ; loop s ) 50 | | `L (msg) -> 51 | yap ~tag ("server socket: " ^ msg) >>= fun () -> loop s 52 | in 53 | server_s () >>= fun s -> 54 | loop s 55 | 56 | let echo_server _ port = 57 | Lwt_main.run ( 58 | serve_ssl port @@ fun (ic, oc) _addr -> 59 | lines ic |> Lwt_stream.iter_s (fun line -> 60 | yap ~tag:"handler" ("+ " ^ line) >>= fun () -> 61 | Lwt_io.write_line oc line)) 62 | 63 | open Cmdliner 64 | 65 | let port = 66 | let doc = "Port to connect to" in 67 | Arg.(value & opt int 4433 & info [ "port" ] ~doc) 68 | 69 | let cmd = 70 | let term = Term.(ret (const echo_server $ setup_log $ port)) 71 | and info = Cmd.info "echo_server" ~version:"%%VERSION_NUM%%" 72 | in 73 | Cmd.v info term 74 | 75 | let () = exit (Cmd.eval cmd) 76 | -------------------------------------------------------------------------------- /eio/tests/mock_socket.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | module W = Eio.Buf_write 4 | 5 | let src = Logs.Src.create "mock-socket" ~doc:"Test socket" 6 | module Log = (val Logs.src_log src : Logs.LOG) 7 | 8 | type transmit_amount = [`Bytes of int | `Drain] 9 | 10 | type ty = [`Mock_tls | Eio.Flow.two_way_ty | Eio.Resource.close_ty] 11 | type t = ty r 12 | 13 | let rec takev len = function 14 | | [] -> [] 15 | | x :: xs -> 16 | if len = 0 then [] 17 | else if Cstruct.length x >= len then [Cstruct.sub x 0 len] 18 | else x :: takev (len - Cstruct.length x) xs 19 | 20 | module Impl = struct 21 | type t = { 22 | to_peer : W.t; 23 | from_peer : W.t; 24 | label : string; 25 | output_sizes : transmit_amount Eio.Stream.t; 26 | } 27 | 28 | let create ~to_peer ~from_peer label = { 29 | to_peer; 30 | from_peer; 31 | label; 32 | output_sizes = Eio.Stream.create max_int; 33 | } 34 | 35 | let transmit t x = 36 | Eio.Stream.add t.output_sizes x 37 | 38 | let single_write t bufs = 39 | let size = 40 | match Eio.Stream.take t.output_sizes with 41 | | `Drain -> Eio.Stream.add t.output_sizes `Drain; Cstruct.lenv bufs 42 | | `Bytes size -> size 43 | in 44 | let bufs = takev size bufs in 45 | List.iter (W.cstruct t.to_peer) bufs; 46 | let len = Cstruct.lenv bufs in 47 | Log.info (fun f -> f "%s: wrote %d bytes to network" t.label len); 48 | len 49 | 50 | let copy t ~src = Eio.Flow.Pi.simple_copy ~single_write t ~src 51 | 52 | let single_read t buf = 53 | let batch = W.await_batch t.from_peer in 54 | let got, _ = Cstruct.fillv ~src:batch ~dst:buf in 55 | Log.info (fun f -> f "%s: read %d bytes from network" t.label got); 56 | W.shift t.from_peer got; 57 | got 58 | 59 | let shutdown t = function 60 | | `Send -> 61 | Log.info (fun f -> f "%s: close writer" t.label); 62 | W.close t.to_peer 63 | | _ -> failwith "Not implemented" 64 | 65 | let close t = 66 | Log.info (fun f -> f "%s: close connection" t.label) 67 | 68 | let read_methods = [] 69 | 70 | type (_, _, _) Eio.Resource.pi += Raw : ('t, 't -> t, ty) Eio.Resource.pi 71 | let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw t 72 | end 73 | 74 | let handler = 75 | Eio.Resource.handler ( 76 | H (Impl.Raw, Fun.id) :: 77 | H (Eio.Resource.Close, Impl.close) :: 78 | Eio.Resource.bindings (Eio.Flow.Pi.two_way (module Impl)) 79 | ) 80 | 81 | let transmit t x = 82 | let t = Impl.raw t in 83 | Impl.transmit t x 84 | 85 | let create ~from_peer ~to_peer label = 86 | let t = Impl.create ~from_peer ~to_peer label in 87 | Eio.Resource.T (t, handler) 88 | 89 | let create_pair () = 90 | let to_a = W.create 100 in 91 | let to_b = W.create 100 in 92 | let a = create ~from_peer:to_a ~to_peer:to_b "client" in 93 | let b = create ~from_peer:to_b ~to_peer:to_a "server" in 94 | a, b 95 | -------------------------------------------------------------------------------- /eio/x509_eio.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | module Path = Eio.Path 4 | 5 | let () = Path.( / ) 6 | 7 | let extension str = 8 | let n = String.length str in 9 | let rec scan = function 10 | | i when i = 0 -> None 11 | | i when str.[i - 1] = '.' -> 12 | Some (String.sub str i (n - i)) 13 | | i -> scan (pred i) in 14 | scan n 15 | 16 | 17 | let private_of_pems ~cert ~priv_key = 18 | let certs = 19 | try 20 | let pem = Path.load cert in 21 | match X509.Certificate.decode_pem_multiple pem with 22 | | Ok cs -> cs 23 | | Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m) 24 | with Invalid_argument m -> 25 | Fmt.failwith "Private certificates %a: %s" Path.pp cert m 26 | in 27 | let pk = 28 | try 29 | let pem = Path.load priv_key in 30 | match X509.Private_key.decode_pem pem with 31 | | Ok key -> key 32 | | Error (`Msg m) -> invalid_arg ("failed to parse private key " ^ m) 33 | with Invalid_argument m -> 34 | Fmt.failwith "Private key (%a): %s" Path.pp priv_key m 35 | in 36 | (certs, pk) 37 | 38 | let certs_of_pem path = 39 | try 40 | let pem = Path.load path in 41 | match X509.Certificate.decode_pem_multiple pem with 42 | | Ok cs -> cs 43 | | Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m) 44 | with Invalid_argument m -> 45 | Fmt.failwith "Certificates in %a: %s" Path.pp path m 46 | 47 | let certs_of_pem_dir path = 48 | Path.read_dir path 49 | |> List.filter (fun file -> extension file = Some "crt") 50 | |> Fiber.List.map (fun file -> certs_of_pem (path file)) 51 | |> List.concat 52 | 53 | let crl_of_pem path = 54 | try 55 | let data = Path.load path in 56 | match X509.CRL.decode_der data with 57 | | Ok cs -> cs 58 | | Error (`Msg m) -> invalid_arg ("failed to parse CRL " ^ m) 59 | with Invalid_argument m -> 60 | Fmt.failwith "CRL in %a: %s" Path.pp path m 61 | 62 | let crls_of_pem_dir path = 63 | Path.read_dir path 64 | |> Fiber.List.map (fun file -> crl_of_pem (path file)) 65 | 66 | (* Would be better to take an Eio.Time.clock here, but that API is likely to change soon. *) 67 | let authenticator ?allowed_hashes ?crls param = 68 | let time () = Some (Ptime_clock.now ()) in 69 | let of_cas cas = 70 | let crls = Option.map crls_of_pem_dir crls in 71 | X509.Authenticator.chain_of_trust ?allowed_hashes ?crls ~time cas 72 | and dotted_hex_to_cs hex = 73 | Cstruct.to_string (Cstruct.of_hex (String.map (function ':' -> ' ' | x -> x) hex)) 74 | and fingerp hash fingerprint = 75 | X509.Authenticator.key_fingerprint ~time ~hash ~fingerprint 76 | and cert_fingerp hash fingerprint = 77 | X509.Authenticator.cert_fingerprint ~time ~hash ~fingerprint 78 | in 79 | match param with 80 | | `Ca_file path -> certs_of_pem path |> of_cas 81 | | `Ca_dir path -> certs_of_pem_dir path |> of_cas 82 | | `Key_fingerprint (hash, fp) -> fingerp hash fp 83 | | `Hex_key_fingerprint (hash, fp) -> 84 | let fp = dotted_hex_to_cs fp in 85 | fingerp hash fp 86 | | `Cert_fingerprint (hash, fp) -> cert_fingerp hash fp 87 | | `Hex_cert_fingerprint (hash, fp) -> 88 | let fp = dotted_hex_to_cs fp in 89 | cert_fingerp hash fp 90 | -------------------------------------------------------------------------------- /tests/interop-openssl-sserver.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | s_server_args="s_server -quiet -key ../certificates/server.key -cert ../certificates/server.pem -www -dhparam dh.pem " 4 | 5 | pidfile='/tmp/openssl.pid' 6 | 7 | extra_args="" 8 | 9 | testit () { 10 | /bin/sh -c "echo \$\$ > $pidfile && exec openssl $s_server_args $extra_args" & 11 | 12 | sleep 0.3 13 | 14 | ../_build/default/lwt/examples/test_client.exe > /dev/null 15 | 16 | if [ $? -eq 0 ]; then 17 | echo "success with $extra_args" 18 | else 19 | echo "failure with openssl $s_server_args $extra_args" 20 | exit 1 21 | fi 22 | cat $pidfile | xargs kill 23 | rm $pidfile 24 | sleep 0.5 25 | } 26 | 27 | testit 28 | 29 | extra_args="-tls1" 30 | testit 31 | 32 | extra_args="-tls1_1" 33 | testit 34 | 35 | extra_args="-tls1_2" 36 | testit 37 | 38 | extra_args="-tls1_3" 39 | testit 40 | 41 | ciphers="DHE-RSA-AES256-SHA AES256-SHA DHE-RSA-AES128-SHA AES128-SHA ECDHE-RSA-AES256-SHA ECDHE-RSA-AES128-SHA" 42 | #OpenSSL <1.1.1: 43 | #EDH-RSA-DES-CBC3-SHA DES-CBC3-SHA 44 | for i in $ciphers; do 45 | extra_args="-cipher $i" 46 | testit 47 | 48 | extra_args="-tls1 -cipher $i" 49 | testit 50 | 51 | extra_args="-tls1_1 -cipher $i" 52 | testit 53 | 54 | extra_args="-tls1_2 -cipher $i" 55 | testit 56 | done 57 | 58 | tls12_ciphers="DHE-RSA-AES256-SHA256 AES256-SHA256 DHE-RSA-AES128-SHA256 AES128-SHA256 AES128-GCM-SHA256 DHE-RSA-AES128-GCM-SHA256 AES256-GCM-SHA384 DHE-RSA-AES256-GCM-SHA384 ECDHE-RSA-AES256-GCM-SHA384 ECDHE-RSA-AES128-GCM-SHA256 ECDHE-RSA-AES256-SHA384 ECDHE-RSA-AES128-SHA256 ECDHE-RSA-CHACHA20-POLY1305 DHE-RSA-CHACHA20-POLY1305" 59 | for i in $tls12_ciphers; do 60 | extra_args="-cipher $i" 61 | testit 62 | 63 | extra_args="-tls1_2 -cipher $i" 64 | testit 65 | done 66 | 67 | tls13_ciphers="TLS_AES_256_GCM_SHA384 TLS_AES_128_GCM_SHA256 TLS_CHACHA20_POLY1305_SHA256" 68 | for i in $tls13_ciphers; do 69 | extra_args="-ciphersuites $i" 70 | testit 71 | 72 | extra_args="-tls1_3 -ciphersuites $i" 73 | testit 74 | done 75 | 76 | s_server_args="s_server -quiet -key ../certificates/server-ec.key -cert ../certificates/server-ec.pem -www -dhparam dh.pem " 77 | ec_ciphers="ECDHE-ECDSA-AES128-SHA ECDHE-ECDSA-AES256-SHA" 78 | ec_ciphers12="ECDHE-ECDSA-AES128-SHA256 ECDHE-ECDSA-AES256-SHA384 ECDHE-ECDSA-AES128-GCM-SHA256 ECDHE-ECDSA-AES256-GCM-SHA384 ECDHE-ECDSA-CHACHA20-POLY1305" 79 | 80 | extra_args="" 81 | testit 82 | 83 | extra_args="-tls1" 84 | testit 85 | 86 | extra_args="-tls1_1" 87 | testit 88 | 89 | extra_args="-tls1_2" 90 | testit 91 | 92 | extra_args="-tls1_3" 93 | testit 94 | 95 | for i in $ec_ciphers; do 96 | extra_args="-cipher $i" 97 | testit 98 | 99 | extra_args="-tls1 -cipher $i" 100 | testit 101 | 102 | extra_args="-tls1_1 -cipher $i" 103 | testit 104 | 105 | extra_args="-tls1_2 -cipher $i" 106 | testit 107 | done 108 | 109 | for i in $ec_ciphers12; do 110 | extra_args="-cipher $i" 111 | testit 112 | 113 | extra_args="-tls1_2 -cipher $i" 114 | testit 115 | done 116 | 117 | tls13_ciphers="TLS_AES_256_GCM_SHA384 TLS_AES_128_GCM_SHA256 TLS_CHACHA20_POLY1305_SHA256" 118 | for i in $tls13_ciphers; do 119 | extra_args="-ciphersuites $i" 120 | testit 121 | 122 | extra_args="-tls1_3 -ciphersuites $i" 123 | testit 124 | done 125 | -------------------------------------------------------------------------------- /mirage/tls_mirage.mli: -------------------------------------------------------------------------------- 1 | (** Effectful operations using Mirage for pure TLS. *) 2 | 3 | (** TLS module given a flow *) 4 | module Make (F : Mirage_flow.S) : sig 5 | 6 | (** possible errors: incoming alert, processing failure, or a 7 | problem in the underlying flow. *) 8 | type error = [ `Tls_alert of Tls.Packet.alert_type 9 | | `Tls_failure of Tls.Engine.failure 10 | | `Read of F.error 11 | | `Write of F.write_error ] 12 | 13 | type write_error = [ `Closed | error ] 14 | (** The type for write errors. *) 15 | 16 | (** we provide the FLOW interface *) 17 | include Mirage_flow.S 18 | with type error := error 19 | and type write_error := write_error 20 | 21 | (** [underlying t] returns the underlying flow. This is useful to extract 22 | information such as [src] and [dst] of that flow. *) 23 | val underlying : flow -> F.flow 24 | 25 | (** [reneg ~authenticator ~acceptable_cas ~cert ~drop t] renegotiates the 26 | session, and blocks until the renegotiation finished. Optionally, a new 27 | [authenticator] and [acceptable_cas] can be used. The own certificate can 28 | be adjusted by [cert]. If [drop] is [true] (the default), 29 | application data received before the renegotiation finished is dropped. *) 30 | val reneg : ?authenticator:X509.Authenticator.t -> 31 | ?acceptable_cas:X509.Distinguished_name.t list -> ?cert:Tls.Config.own_cert -> 32 | ?drop:bool -> flow -> (unit, [ write_error | `Msg of string ]) result Lwt.t 33 | 34 | (** [key_update ~request t] updates the traffic key and requests a traffic key 35 | update from the peer if [request] is provided and [true] (the default). 36 | This is only supported in TLS 1.3. *) 37 | val key_update : ?request:bool -> flow -> (unit, [ write_error | `Msg of string ]) result Lwt.t 38 | 39 | (** [client_of_flow client ~host flow] upgrades the existing connection 40 | to TLS using the [client] configuration, using [host] as peer name. *) 41 | val client_of_flow : Tls.Config.client -> ?host:[ `host ] Domain_name.t -> 42 | F.flow -> (flow, write_error) result Lwt.t 43 | 44 | (** [server_of_flow server flow] upgrades the flow to a TLS 45 | connection using the [server] configuration. *) 46 | val server_of_flow : Tls.Config.server -> F.flow -> 47 | (flow, write_error) result Lwt.t 48 | 49 | (** [epoch flow] extracts information of the established session. *) 50 | val epoch : flow -> (Tls.Core.epoch_data, unit) result 51 | 52 | end 53 | 54 | (** X.509 handling given a key value store and a clock *) 55 | module X509 (KV : Mirage_kv.RO) : sig 56 | (** [authenticator ~allowed_hashes ~crl store] creates an [authenticator], 57 | using the given certificate authorities in the [store] as 58 | value for key "ca_roots.crt". If [allowed_hashes] is provided, 59 | only these hash algorithms are allowed for signatures of the certificate chain. 60 | If [crl] is provided, the corresponding file is read and used as 61 | revocation list (DER encoded). Both options only apply if [`CAs] is used. 62 | *) 63 | val authenticator : ?allowed_hashes:Digestif.hash' list -> ?crl:string -> 64 | KV.t -> X509.Authenticator.t Lwt.t 65 | 66 | (** [certificate store typ] unmarshals a certificate chain and 67 | private key material from the [store]. *) 68 | val certificate : KV.t -> [< `Default | `Name of string ] 69 | -> Tls.Config.certchain Lwt.t 70 | end 71 | -------------------------------------------------------------------------------- /async/tls_async.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | (** Low-level API for working with TLS sessions. 5 | Most applications should use the high-level API below *) 6 | module Session = Session 7 | 8 | (** Helper functions for [Async_unix]-specific IO operations commonly used with X509 9 | certificates, such as loading from a Unix filesystem *) 10 | module X509_async = X509_async 11 | 12 | (** [listen] creates a [Tcp.Server.t] with the requested parameters, including those 13 | specified in [Tls.Config.server]. The handler function exposes the low-level 14 | [Session.t] to accommodate cases like interrogating a client certificate *) 15 | val listen 16 | : ?buffer_age_limit:Writer.buffer_age_limit 17 | -> ?max_connections:int (** defaults to [10_000]. *) 18 | -> ?max_accepts_per_batch:int (** defaults to [1]. *) 19 | -> ?backlog:int (** defaults to [64]. *) 20 | -> ?socket:([ `Unconnected ], ([< Socket.Address.t ] as 'address)) Socket.t 21 | -> on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ] 22 | -> Tls.Config.server 23 | -> ('address, 'listening_on) Tcp.Where_to_listen.t 24 | -> ('address -> Session.t -> Reader.t -> Writer.t -> unit Deferred.t) 25 | -> ('address, 'listening_on) Tcp.Server.t Deferred.t 26 | 27 | type 'a io_handler = Reader.t -> Writer.t -> 'a Deferred.t 28 | type 'a tls_handler = Session.t -> 'a io_handler 29 | 30 | (** [upgrade_server_handler] is what [listen] calls to handle each client. 31 | It is exposed so that low-level end-users of the library can use tls-async 32 | inside of code that manages Tcp services directly. 33 | 34 | The [tls_handler] argument will be called with the client Tls session, 35 | reader and writer to be used for cleartext data. 36 | 37 | The outer [reader] and [writer] will read encrypted data from and write 38 | encrypted data to the connected socket. *) 39 | val upgrade_server_handler 40 | : config:Tls.Config.server 41 | -> 'a tls_handler 42 | -> 'a io_handler 43 | 44 | (** [connect] behaves similarly to [Tcp.connect], exposing a cleartext reader and writer. 45 | Callers should ensure they close the [Writer.t] and wait for the [unit Deferred.t] 46 | returned by [`Closed_and_flushed_downstream] to completely shut down the TLS connection 47 | 48 | [host] is used for peer name verification and should generally be provided. Passing 49 | [None] will disable peer name verification unless [peer_name] was provided in the 50 | [Tls.Config.client]. If both are present [host] overwrites [peer_name]. 51 | *) 52 | val connect 53 | : ?socket:([ `Unconnected ], 'addr) Socket.t 54 | -> (Tls.Config.client 55 | -> 'addr Tcp.Where_to_connect.t 56 | -> host:[ `host ] Domain_name.t option 57 | -> (Session.t * Reader.t * Writer.t) Deferred.Or_error.t) 58 | Tcp.Aliases.with_connect_options 59 | 60 | (** [upgrade_client_to_tls] upgrades an existing reader/writer to TLS, 61 | returning a cleartext reader and writer. 62 | Callers should ensure they close the [Writer.t] and wait for the [unit Deferred.t] 63 | returned by [`Closed_and_flushed_downstream] to completely shut down the TLS connection 64 | 65 | [host] is used for peer name verification and should generally be provided. Passing 66 | [None] will disable peer name verification unless [peer_name] was provided in the 67 | [Tls.Config.client]. If both are present [host] overwrites [peer_name]. 68 | *) 69 | val upgrade_client_to_tls 70 | : Tls.Config.client 71 | -> host:[ `host ] Domain_name.t option 72 | -> Reader.t 73 | -> Writer.t 74 | -> (Session.t * Reader.t * Writer.t) Deferred.Or_error.t 75 | -------------------------------------------------------------------------------- /eio/tests/tls_eio.md: -------------------------------------------------------------------------------- 1 | ```ocaml 2 | # #require "digestif.c";; 3 | # #require "eio_main";; 4 | # #require "tls-eio";; 5 | # #require "mirage-crypto-rng.unix";; 6 | ``` 7 | 8 | ```ocaml 9 | open Eio.Std 10 | 11 | module Flow = Eio.Flow 12 | ``` 13 | 14 | ## Test client 15 | 16 | ```ocaml 17 | let null_auth ?ip:_ ~host:_ _ = Ok None 18 | 19 | let mypsk = ref None 20 | 21 | let ticket_cache = { 22 | Tls.Config.lookup = (fun _ -> None) ; 23 | ticket_granted = (fun psk epoch -> mypsk := Some (psk, epoch)) ; 24 | lifetime = 0l ; 25 | timestamp = Ptime_clock.now 26 | } 27 | 28 | let test_client ~net (host, service) = 29 | match Eio.Net.getaddrinfo_stream net host ~service with 30 | | [] -> failwith "No addresses found!" 31 | | addr :: _ -> 32 | let authenticator = null_auth in 33 | Switch.run @@ fun sw -> 34 | let socket = Eio.Net.connect ~sw net addr in 35 | let flow = 36 | let host = 37 | Result.to_option 38 | (Result.bind (Domain_name.of_string host) Domain_name.host) 39 | in 40 | Tls_eio.client_of_flow 41 | (Result.get_ok Tls.Config.(client ~version:(`TLS_1_0, `TLS_1_3) ?cached_ticket:!mypsk ~ticket_cache ~authenticator ~ciphers:Ciphers.supported ())) 42 | ?host socket 43 | in 44 | let req = String.concat "\r\n" [ 45 | "GET / HTTP/1.1" ; "Host: " ^ host ; "Connection: close" ; "" ; "" 46 | ] in 47 | Flow.copy_string req flow; 48 | let r = Eio.Buf_read.of_flow flow ~max_size:max_int in 49 | let line = Eio.Buf_read.take 3 r in 50 | traceln "client <- %s" line; 51 | Eio.Resource.close flow; 52 | traceln "client done." 53 | ``` 54 | 55 | ## Test server 56 | 57 | ```ocaml 58 | let server_config dir = 59 | let ( / ) = Eio.Path.( / ) in 60 | let certificate = 61 | X509_eio.private_of_pems 62 | ~cert:(dir / "server.pem") 63 | ~priv_key:(dir / "server.key") 64 | in 65 | let ec_certificate = 66 | X509_eio.private_of_pems 67 | ~cert:(dir / "server-ec.pem") 68 | ~priv_key:(dir / "server-ec.key") 69 | in 70 | let certificates = `Multiple [ certificate ; ec_certificate ] in 71 | Result.get_ok Tls.Config.(server ~version:(`TLS_1_0, `TLS_1_3) ~certificates ~ciphers:Ciphers.supported ()) 72 | 73 | let serve_ssl ~config server_s callback = 74 | Switch.run @@ fun sw -> 75 | let client, addr = Eio.Net.accept ~sw server_s in 76 | let flow = Tls_eio.server_of_flow config client in 77 | traceln "server -> connect"; 78 | callback flow addr 79 | ``` 80 | 81 | ## Test case 82 | 83 | ```ocaml 84 | # Eio_main.run @@ fun env -> 85 | let net = env#net in 86 | let certificates_dir = env#cwd in 87 | Mirage_crypto_rng_unix.use_default (); 88 | Switch.run @@ fun sw -> 89 | let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 4433) in 90 | let listening_socket = Eio.Net.listen ~sw net ~backlog:5 ~reuse_addr:true addr in 91 | (* Eio.Time.with_timeout_exn env#clock 0.1 @@ fun () -> *) 92 | Fiber.both 93 | (fun () -> 94 | traceln "server -> start @@ %a" Eio.Net.Sockaddr.pp addr; 95 | let config = server_config certificates_dir in 96 | serve_ssl ~config listening_socket @@ fun flow _addr -> 97 | traceln "handler accepted"; 98 | let r = Eio.Buf_read.of_flow flow ~max_size:max_int in 99 | let line = Eio.Buf_read.line r in 100 | traceln "handler + %s" line; 101 | Flow.copy_string line flow 102 | ) 103 | (fun () -> 104 | test_client ~net ("127.0.0.1", "4433") 105 | ) 106 | ;; 107 | +server -> start @ tcp:127.0.0.1:4433 108 | +server -> connect 109 | +handler accepted 110 | +handler + GET / HTTP/1.1 111 | +client <- GET 112 | +client done. 113 | - : unit = () 114 | ``` 115 | -------------------------------------------------------------------------------- /lwt/examples/fuzz_server.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Ex_common 3 | 4 | let string_of_unix_err err f p = 5 | Printf.sprintf "Unix_error (%s, %s, %s)" 6 | (Unix.error_message err) f p 7 | 8 | let add_to_cache, find_in_cache = 9 | let c = ref [] in 10 | (fun ticket session -> 11 | let id = ticket.Tls.Core.identifier in 12 | Logs.info (fun m -> m "adding id %a to cache" Ohex.pp id) ; 13 | c := (id, (ticket, session)) :: !c), 14 | (fun id -> match List.find_opt (fun (id', _) -> String.compare id id' = 0) !c with 15 | | None -> None 16 | | Some (_, ep) -> Some ep) 17 | 18 | let ticket_cache = { 19 | Tls.Config.lookup = find_in_cache ; 20 | ticket_granted = add_to_cache ; 21 | lifetime = 300l ; 22 | timestamp = Ptime_clock.now 23 | } 24 | 25 | let serve_ssl port callback = 26 | 27 | let tag = "server" in 28 | 29 | X509_lwt.private_of_pems 30 | ~cert:server_cert 31 | ~priv_key:server_key >>= fun cert -> 32 | 33 | let server_s () = 34 | let open Lwt_unix in 35 | let s = socket PF_INET SOCK_STREAM 0 in 36 | setsockopt s SO_REUSEADDR true ; 37 | bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () -> 38 | listen s 10 ; 39 | s in 40 | 41 | let handle channels addr = 42 | async @@ fun () -> 43 | Lwt.catch (fun () -> callback channels addr >>= fun () -> yap ~tag "<- handler done") 44 | (function 45 | | Tls_lwt.Tls_alert a -> 46 | yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a 47 | | Tls_lwt.Tls_failure a -> 48 | yap ~tag @@ "handler: " ^ Tls.Engine.string_of_failure a 49 | | Unix.Unix_error (e, f, p) -> 50 | yap ~tag @@ "handler: " ^ (string_of_unix_err e f p) 51 | | _exn -> yap ~tag "handler: exception") 52 | in 53 | 54 | yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () -> 55 | let rec loop s = 56 | 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 57 | (Lwt.catch 58 | (fun () -> Tls_lwt.Unix.accept config s >|= fun r -> `R r) 59 | (function 60 | | Unix.Unix_error (e, f, p) -> return (`L (string_of_unix_err e f p)) 61 | | Tls_lwt.Tls_alert a -> return (`L (Tls.Packet.alert_type_to_string a)) 62 | | Tls_lwt.Tls_failure f -> return (`L (Tls.Engine.string_of_failure f)) 63 | | exn -> let str = Printexc.to_string exn in return (`L ("loop: exception " ^ str)))) >>= function 64 | | `R (t, addr) -> 65 | let channels = Tls_lwt.of_t t in 66 | yap ~tag "-> connect" >>= fun () -> ( handle channels addr ; loop s ) 67 | | `L (msg) -> 68 | yap ~tag ("server socket: " ^ msg) >>= fun () -> loop s 69 | in 70 | server_s () >>= fun s -> 71 | loop s 72 | 73 | let echo_server port = 74 | serve_ssl port @@ fun (ic, oc) _addr -> 75 | yap ~tag:"handler" "accepted" >>= fun () -> 76 | let out = "HTTP/1.1 404 Not Found\r\n\r\n" in 77 | Lwt_io.write_from_string_exactly oc out 0 (String.length out) >>= fun () -> 78 | (* Lwt_io.close oc *) 79 | let rec loop () = 80 | Lwt_io.read_line ic >>= fun line -> 81 | yap ~tag:"handler" ("+ " ^ line) >>= fun () -> 82 | loop () 83 | in 84 | loop () 85 | 86 | let jump _ port = 87 | Lwt_main.run (echo_server port) 88 | 89 | open Cmdliner 90 | 91 | let port = 92 | let doc = "Port to connect to" in 93 | Arg.(value & opt int 4433 & info [ "port" ] ~doc) 94 | 95 | let cmd = 96 | let term = Term.(ret (const jump $ setup_log $ port)) 97 | and info = Cmd.info "fuzz_server" ~version:"%%VERSION_NUM%%" 98 | in 99 | Cmd.v info term 100 | 101 | let () = exit (Cmd.eval cmd) 102 | -------------------------------------------------------------------------------- /mirage/example/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let escape_data buf = String.escaped (Cstruct.to_string buf) 4 | 5 | let make_tracer dump = 6 | let traces = ref [] in 7 | let trace sexp = 8 | traces := Sexplib.Sexp.to_string_hum sexp :: !traces 9 | and flush () = 10 | let msgs = List.rev !traces in 11 | traces := [] ; 12 | Lwt_list.iter_s dump msgs in 13 | (trace, flush) 14 | 15 | module Server (S : Mirage_stack.V4) 16 | (KV : Mirage_kv.RO) 17 | (CL : Mirage_clock.PCLOCK) = 18 | struct 19 | 20 | module TLS = Tls_mirage.Make (S.TCPV4) 21 | module X509 = Tls_mirage.X509 (KV) (CL) 22 | 23 | let rec handle flush tls = 24 | TLS.read tls >>= fun res -> 25 | flush () >>= fun () -> 26 | match res with 27 | | Ok (`Data buf) -> 28 | Logs_lwt.info (fun p -> p "recv %s" (escape_data buf)) >>= fun () -> 29 | (TLS.write tls buf >>= function 30 | | Ok () -> handle flush tls 31 | | Error e -> Logs_lwt.err (fun p -> p "write error %a" TLS.pp_write_error e)) 32 | | Ok `Eof -> Logs_lwt.info (fun p -> p "eof from server") 33 | | Error e -> Logs_lwt.err (fun p -> p "read error %a" TLS.pp_error e) 34 | 35 | let accept conf k flow = 36 | let trace, flush_trace = 37 | make_tracer (fun s -> Logs_lwt.debug (fun p -> p "%s" s)) 38 | in 39 | Logs_lwt.info (fun p -> p "accepted.") >>= fun () -> 40 | TLS.server_of_flow ~trace conf flow >>= function 41 | | Ok tls -> Logs_lwt.info (fun p -> p "shook hands") >>= fun () -> k flush_trace tls 42 | | Error e -> Logs_lwt.err (fun p -> p "%a" TLS.pp_write_error e) 43 | 44 | let start stack kv _ _ = 45 | X509.certificate kv `Default >>= fun cert -> 46 | let conf = Tls.Config.server ~certificates:(`Single cert) () in 47 | S.listen_tcpv4 stack ~port:4433 (accept conf handle) ; 48 | S.listen stack 49 | 50 | end 51 | 52 | module Client (S : Mirage_stack.V4) 53 | (KV : Mirage_kv.RO) 54 | (CL : Mirage_clock.PCLOCK) = 55 | struct 56 | 57 | module TLS = Tls_mirage.Make (S.TCPV4) 58 | module X509 = Tls_mirage.X509 (KV) (CL) 59 | 60 | open Ipaddr 61 | 62 | let peer = ((V4.of_string_exn "127.0.0.1", 4433), "localhost") 63 | let peer = ((V4.of_string_exn "2.19.157.15", 443), "www.apple.com") 64 | let peer = ((V4.of_string_exn "74.125.195.103", 443), "www.google.com") 65 | let peer = ((V4.of_string_exn "10.0.0.1", 4433), "localhost") 66 | let peer = ((V4.of_string_exn "23.253.164.126", 443), "tls.openmirage.org") 67 | let peer = ((V4.of_string_exn "216.105.38.15", 443), "slashdot.org") 68 | let peer = ((V4.of_string_exn "46.43.42.136", 443), "mirage.io") 69 | let peer = ((V4.of_string_exn "198.167.222.205", 443), "hannes.nqsb.io") 70 | 71 | let initial = Cstruct.of_string @@ 72 | "GET / HTTP/1.1\r\nConnection: Close\r\nHost: " ^ snd peer ^ "\r\n\r\n" 73 | 74 | let chat tls = 75 | let rec dump () = 76 | TLS.read tls >>= function 77 | | Ok (`Data buf) -> Logs_lwt.info (fun p -> p "recv %s" (escape_data buf)) >>= dump 78 | | Ok `Eof -> Logs_lwt.info (fun p -> p "eof") 79 | | Error e -> Logs_lwt.err (fun p -> p "chat err %a" TLS.pp_error e) 80 | in 81 | TLS.write tls initial >>= function 82 | | Ok () -> dump () 83 | | Error e -> Logs_lwt.err (fun p -> p "write error %a" TLS.pp_write_error e) 84 | 85 | let start stack kv _clock _ = 86 | X509.authenticator kv `CAs >>= fun authenticator -> 87 | let conf = Tls.Config.client ~authenticator () in 88 | S.TCPV4.create_connection (S.tcpv4 stack) (fst peer) 89 | >>= function 90 | | Error e -> Logs_lwt.err (fun p -> p "%a" S.TCPV4.pp_error e) 91 | | Ok tcp -> 92 | TLS.client_of_flow conf ~host:(snd peer) tcp >>= function 93 | | Ok tls -> chat tls 94 | | Error e -> Logs_lwt.err (fun p -> p "%a" TLS.pp_write_error e) 95 | 96 | end 97 | -------------------------------------------------------------------------------- /lwt/x509_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | let failure msg = fail @@ Failure msg 4 | 5 | let catch_invalid_arg th h = 6 | Lwt.catch (fun () -> th) 7 | (function 8 | | Invalid_argument msg -> h msg 9 | | exn -> fail exn) 10 | 11 | let () a b = a ^ "/" ^ b 12 | 13 | let o f g x = f (g x) 14 | 15 | let read_file path = 16 | let open Lwt_io in 17 | open_file ~mode:Input path >>= fun file -> 18 | read file >>= fun cs -> 19 | close file >|= fun () -> 20 | cs 21 | 22 | let read_dir path = 23 | let open Lwt_unix in 24 | let rec collect acc d = 25 | readdir_n d 10 >>= function 26 | | [||] -> return acc 27 | | xs -> collect (Array.to_list xs @ acc) d in 28 | opendir path >>= fun dir -> 29 | collect [] dir >>= fun entries -> 30 | closedir dir >|= fun () -> 31 | entries 32 | 33 | let extension str = 34 | let n = String.length str in 35 | let rec scan = function 36 | | i when i = 0 -> None 37 | | i when str.[i - 1] = '.' -> 38 | Some (String.sub str i (n - i)) 39 | | i -> scan (pred i) in 40 | scan n 41 | 42 | 43 | let private_of_pems ~cert ~priv_key = 44 | catch_invalid_arg 45 | (read_file cert >|= fun pem -> 46 | match X509.Certificate.decode_pem_multiple pem with 47 | | Ok cs -> cs 48 | | Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m)) 49 | (o failure @@ Printf.sprintf "Private certificates (%s): %s" cert) >>= fun certs -> 50 | catch_invalid_arg 51 | (read_file priv_key >|= fun pem -> 52 | match X509.Private_key.decode_pem pem with 53 | | Ok key -> key 54 | | Error (`Msg m) -> invalid_arg ("failed to parse private key " ^ m)) 55 | (o failure @@ Printf.sprintf "Private key (%s): %s" priv_key) >>= fun pk -> 56 | return (certs, pk) 57 | 58 | let certs_of_pem path = 59 | catch_invalid_arg 60 | (read_file path >|= fun pem -> 61 | match X509.Certificate.decode_pem_multiple pem with 62 | | Ok cs -> cs 63 | | Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m)) 64 | (o failure @@ Printf.sprintf "Certificates in %s: %s" path) 65 | 66 | let certs_of_pem_dir path = 67 | read_dir path 68 | >|= List.filter (fun file -> extension file = Some "crt") 69 | >>= Lwt_list.map_p (fun file -> certs_of_pem (path file)) 70 | >|= List.concat 71 | 72 | let crl_of_pem path = 73 | catch_invalid_arg 74 | (read_file path >|= fun data -> 75 | match X509.CRL.decode_der data with 76 | | Ok cs -> cs 77 | | Error (`Msg m) -> invalid_arg ("failed to parse CRL " ^ m)) 78 | (o failure @@ Printf.sprintf "CRL in %s: %s" path) 79 | 80 | let crls_of_pem_dir = function 81 | | None -> Lwt.return None 82 | | Some path -> 83 | read_dir path >>= fun files -> 84 | Lwt_list.map_p (fun file -> crl_of_pem (path file)) files >|= fun crls -> 85 | Some crls 86 | 87 | let authenticator ?allowed_hashes ?crls param = 88 | let time () = Some (Ptime_clock.now ()) in 89 | let of_cas cas = 90 | crls_of_pem_dir crls >|= fun crls -> 91 | X509.Authenticator.chain_of_trust ?allowed_hashes ?crls ~time cas 92 | and dotted_hex_to_cs hex = 93 | Ohex.decode (String.map (function ':' -> ' ' | x -> x) hex) 94 | and fingerp hash fingerprint = 95 | X509.Authenticator.key_fingerprint ~time ~hash ~fingerprint 96 | and cert_fingerp hash fingerprint = 97 | X509.Authenticator.cert_fingerprint ~time ~hash ~fingerprint 98 | in 99 | match param with 100 | | `Ca_file path -> certs_of_pem path >>= of_cas 101 | | `Ca_dir path -> certs_of_pem_dir path >>= of_cas 102 | | `Key_fingerprint (hash, fp) -> return (fingerp hash fp) 103 | | `Hex_key_fingerprint (hash, fp) -> 104 | let fp = dotted_hex_to_cs fp in 105 | return (fingerp hash fp) 106 | | `Cert_fingerprint (hash, fp) -> return (cert_fingerp hash fp) 107 | | `Hex_cert_fingerprint (hash, fp) -> 108 | let fp = dotted_hex_to_cs fp in 109 | return (cert_fingerp hash fp) 110 | -------------------------------------------------------------------------------- /unix/tls_unix.mli: -------------------------------------------------------------------------------- 1 | (** Effectful operations using Unix for pure TLS. 2 | 3 | The pure TLS is state and buffer in, state and buffer out. This module uses 4 | the Unix layer for communication over the network. *) 5 | 6 | exception Tls_alert of Tls.Packet.alert_type 7 | exception Tls_failure of Tls.Engine.failure 8 | exception Closed_by_peer 9 | 10 | type t 11 | (** Abstract type of a session. *) 12 | 13 | val file_descr : t -> Unix.file_descr 14 | (** [file_descr] returns the underlying file-descriptor used by the given 15 | TLS {i socket}. *) 16 | 17 | val read : t -> ?off:int -> ?len:int -> bytes -> int 18 | (** [read fd buf ~off ~len] reads up to [len] bytes (defaults to 19 | [Bytes.length buf - off] from the given TLS {i socket} [fd], storing them in 20 | byte sequence [buf], starting at position [off] in [buf] (defaults to [0]). 21 | It returns the actual number of characters read, between 0 and [len] 22 | (inclusive). 23 | 24 | @raise Unix_error raised by the system call {!val:Unix.read}. The function 25 | handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} 26 | exceptions and redo the system call. 27 | 28 | @raise Invalid_argument if [off] and [len] do not designate a valid range of 29 | [buf]. *) 30 | 31 | val really_read : t -> ?off:int -> ?len:int -> bytes -> unit 32 | (** [really_read fd buf ~off ~len] reads [len] bytes (defaults to 33 | [Bytes.length buf - off]) from the given TLS {i socket} [fd], storing them 34 | in byte sequence [buf], starting at position [off] in [buf] (defaults to 35 | [0]). If [len = 0], [really_read] does nothing. 36 | 37 | @raise Unix_error raised by the system call {!val:Unix.read}. The function 38 | handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} 39 | exceptions and redo the system call. 40 | 41 | @raise End_of_file if {!val:Unix.read} returns [0] before [len] characters 42 | have been read. 43 | 44 | @raise Invalid_argument if [off] and [len] do not designate a valid range of 45 | [buf]. *) 46 | 47 | val write : t -> ?off:int -> ?len:int -> string -> unit 48 | (** [write t str ~off ~len] writes [len] bytes (defaults to 49 | [String.length str - off]) from byte sequence [str], starting at offset 50 | [off] (defaults to [0]), to the given TLS {i socket} [fd]. 51 | 52 | @raise Unix_error raised by the syscall call {!val:Unix.write}. The function 53 | handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} 54 | exceptions and redo the system call. 55 | 56 | @raise Closed_by_peer if [t] is connected to a peer whose reading end is 57 | closed. Similar to the {!val:EPIPE} error for pipe/socket connected. 58 | 59 | @raise Invalid_argument if [off] and [len] do not designate a valid range of 60 | [buf]. *) 61 | 62 | val close : t -> unit 63 | (** [close flow] closes the TLS session and the underlying file-descriptor. *) 64 | 65 | val shutdown : t -> [ `read | `write | `read_write ] -> unit 66 | (** [shutdown t direction] closes the direction of the TLS session [t]. If 67 | [`read_write] or [`write] is closed, a TLS close-notify is sent to the other 68 | endpoint. If this results in a fully-closed session (or an errorneous 69 | session), the underlying file descriptor is closed. *) 70 | 71 | val client_of_fd : 72 | Tls.Config.client -> 73 | ?read_buffer_size:int -> 74 | ?host:[ `host ] Domain_name.t -> 75 | Unix.file_descr -> 76 | t 77 | (** [client_of_flow client ~host fd] is [t], after client-side TLS handshake of 78 | [fd] using [client] configuration and [host]. 79 | 80 | @raise End_of_file if we are not able to complete the handshake. *) 81 | 82 | val server_of_fd : 83 | Tls.Config.server -> ?read_buffer_size:int -> Unix.file_descr -> t 84 | (** [server_of_fd server fd] is [t], after server-side TLS handshake of [fd] 85 | using [server] configuration. 86 | 87 | @raise End_of_file if we are not able to complete the handshake. *) 88 | 89 | val connect : X509.Authenticator.t -> string * int -> t 90 | (** [connect authenticator (host, port)] is [t], a connected TLS connection 91 | to [host] on [port] using the default configuration and the 92 | [authenticator]. *) 93 | 94 | val epoch : t -> Tls.Core.epoch_data option 95 | (** [epoch t] returns [epoch], which contains information of the active 96 | session. *) 97 | -------------------------------------------------------------------------------- /miou/tls_miou_unix.mli: -------------------------------------------------------------------------------- 1 | (** Effectful operations using Miou for pure TLS. 2 | 3 | The pure TLS is state and buffer in, state and buffer out. This module uses 4 | Miou (and its Unix layer) for communication over the network. *) 5 | 6 | exception Tls_alert of Tls.Packet.alert_type 7 | exception Tls_failure of Tls.Engine.failure 8 | exception Closed_by_peer 9 | 10 | type t 11 | (** Abstract type of a session. *) 12 | 13 | val file_descr : t -> Miou_unix.file_descr 14 | (** [file_descr] returns the underlying file-descriptor used by the given 15 | TLS {i socket}. *) 16 | 17 | val read : t -> ?off:int -> ?len:int -> bytes -> int 18 | (** [read fd buf ~off ~len] reads up to [len] bytes (defaults to 19 | [Bytes.length buf - off] from the given TLS {i socket} [fd], storing them in 20 | byte sequence [buf], starting at position [off] in [buf] (defaults to [0]). 21 | It returns the actual number of characters read, between 0 and [len] 22 | (inclusive). 23 | 24 | @raise Unix_error raised by the system call {!val:Unix.read}. The function 25 | handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} 26 | exceptions and redo the system call. 27 | 28 | @raise Invalid_argument if [off] and [len] do not designate a valid range of 29 | [buf]. *) 30 | 31 | val really_read : t -> ?off:int -> ?len:int -> bytes -> unit 32 | (** [really_read fd buf ~off ~len] reads [len] bytes (defaults to 33 | [Bytes.length buf - off]) from the given TLS {i socket} [fd], storing them 34 | in byte sequence [buf], starting at position [off] in [buf] (defaults to 35 | [0]). If [len = 0], [really_read] does nothing. 36 | 37 | @raise Unix_error raised by the system call {!val:Unix.read}. The function 38 | handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} 39 | exceptions and redo the system call. 40 | 41 | @raise End_of_file if {!val:Unix.read} returns [0] before [len] characters 42 | have been read. 43 | 44 | @raise Invalid_argument if [off] and [len] do not designate a valid range of 45 | [buf]. *) 46 | 47 | val write : t -> ?off:int -> ?len:int -> string -> unit 48 | (** [write t str ~off ~len] writes [len] bytes (defaults to 49 | [String.length str - off]) from byte sequence [str], starting at offset 50 | [off] (defaults to [0]), to the given TLS {i socket} [fd]. 51 | 52 | @raise Unix_error raised by the syscall call {!val:Unix.write}. The function 53 | handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} 54 | exceptions and redo the system call. 55 | 56 | @raise Closed_by_peer if [t] is connected to a peer whose reading end is 57 | closed. Similar to the {!val:EPIPE} error for pipe/socket connected. 58 | 59 | @raise Invalid_argument if [off] and [len] do not designate a valid range of 60 | [buf]. *) 61 | 62 | val close : t -> unit 63 | (** [close flow] closes the TLS session and the underlying file-descriptor. *) 64 | 65 | val shutdown : t -> [ `read | `write | `read_write ] -> unit 66 | (** [shutdown t direction] closes the direction of the TLS session [t]. If 67 | [`read_write] or [`write] is closed, a TLS close-notify is sent to the other 68 | endpoint. If this results in a fully-closed session (or an errorneous 69 | session), the underlying file descriptor is closed. *) 70 | 71 | val client_of_fd : 72 | Tls.Config.client -> 73 | ?read_buffer_size:int -> 74 | ?host:[ `host ] Domain_name.t -> 75 | Miou_unix.file_descr -> 76 | t 77 | (** [client_of_flow client ~host fd] is [t], after client-side TLS handshake of 78 | [fd] using [client] configuration and [host]. 79 | 80 | @raise End_of_file if we are not able to complete the handshake. *) 81 | 82 | val server_of_fd : 83 | Tls.Config.server -> ?read_buffer_size:int -> Miou_unix.file_descr -> t 84 | (** [server_of_fd server fd] is [t], after server-side TLS handshake of [fd] 85 | using [server] configuration. 86 | 87 | @raise End_of_file if we are not able to complete the handshake. *) 88 | 89 | val connect : X509.Authenticator.t -> string * int -> t 90 | (** [connect authenticator (host, port)] is [t], a connected TLS connection 91 | to [host] on [port] using the default configuration and the 92 | [authenticator]. *) 93 | 94 | val epoch : t -> Tls.Core.epoch_data option 95 | (** [epoch t] returns [epoch], which contains information of the active 96 | session. *) 97 | -------------------------------------------------------------------------------- /lib/handshake_crypto.ml: -------------------------------------------------------------------------------- 1 | open State 2 | 3 | let halve secret = 4 | let size = String.length secret in 5 | let half = size - size / 2 in 6 | String.(sub secret 0 half, sub secret (size - half) half) 7 | 8 | let p_hash (hmac, hmac_n) key seed len = 9 | let rec expand a to_go = 10 | let res = hmac ~key (a ^ seed) in 11 | if to_go > hmac_n then 12 | res ^ expand (hmac ~key a) (to_go - hmac_n) 13 | else String.sub res 0 to_go 14 | in 15 | expand (hmac ~key seed) len 16 | 17 | let prf_mac = function 18 | | `RSA_WITH_AES_256_GCM_SHA384 19 | | `DHE_RSA_WITH_AES_256_GCM_SHA384 20 | | `ECDHE_RSA_WITH_AES_256_GCM_SHA384 21 | | `ECDHE_RSA_WITH_AES_256_CBC_SHA384 22 | | `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 23 | | `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 -> (module Digestif.SHA384 : Digestif.S) 24 | | _ -> (module Digestif.SHA256 : Digestif.S) 25 | 26 | let pseudo_random_function version cipher len secret label seed = 27 | let labelled = label ^ seed in 28 | match version with 29 | | `TLS_1_1 | `TLS_1_0 -> 30 | let (s1, s2) = halve secret in 31 | let md5 = p_hash ((fun ~key s -> Digestif.MD5.(to_raw_string (hmac_string ~key s))), Digestif.MD5.digest_size) s1 labelled len 32 | and sha = p_hash ((fun ~key s -> Digestif.SHA1.(to_raw_string (hmac_string ~key s))), Digestif.SHA1.digest_size) s2 labelled len in 33 | Mirage_crypto.Uncommon.xor md5 sha 34 | | `TLS_1_2 -> 35 | let module D = (val (prf_mac cipher)) in 36 | p_hash ((fun ~key s -> D.(to_raw_string (hmac_string ~key s))), D.digest_size) secret labelled len 37 | 38 | let key_block version cipher len master_secret seed = 39 | pseudo_random_function version cipher len master_secret "key expansion" seed 40 | 41 | let hash version cipher data = 42 | match version with 43 | | `TLS_1_0 | `TLS_1_1 -> Digestif.(MD5.(to_raw_string (digest_string data)) ^ SHA1.(to_raw_string (digest_string data))) 44 | | `TLS_1_2 -> 45 | let module H = (val prf_mac cipher) in 46 | H.(to_raw_string (digest_string data)) 47 | 48 | let finished version cipher master_secret label ps = 49 | let data = String.concat "" ps in 50 | let seed = hash version cipher data in 51 | pseudo_random_function version cipher 12 master_secret label seed 52 | 53 | let divide_keyblock key mac iv buf = 54 | let c_mac, rt0 = Core.split_str buf mac in 55 | let s_mac, rt1 = Core.split_str rt0 mac in 56 | let c_key, rt2 = Core.split_str rt1 key in 57 | let s_key, rt3 = Core.split_str rt2 key in 58 | let c_iv , s_iv = Core.split_str rt3 iv 59 | in 60 | (c_mac, s_mac, c_key, s_key, c_iv, s_iv) 61 | 62 | let derive_master_secret version (session : session_data) premaster log = 63 | let prf = pseudo_random_function version session.ciphersuite 48 premaster in 64 | if session.extended_ms then 65 | let session_hash = 66 | let data = String.concat "" log in 67 | hash version session.ciphersuite data 68 | in 69 | prf "extended master secret" session_hash 70 | else 71 | prf "master secret" (session.common_session_data.client_random ^ session.common_session_data.server_random) 72 | 73 | let initialise_crypto_ctx version (session : session_data) = 74 | let open Ciphersuite in 75 | let client_random = session.common_session_data.client_random 76 | and server_random = session.common_session_data.server_random 77 | and master = session.common_session_data.master_secret 78 | and cipher = session.ciphersuite 79 | in 80 | 81 | let pp = ciphersuite_privprot cipher in 82 | 83 | let c_mac, s_mac, c_key, s_key, c_iv, s_iv = 84 | let iv_l = match version with 85 | | `TLS_1_0 -> Some () 86 | | _ -> None 87 | in 88 | let key_len, iv_len, mac_len = Ciphersuite.key_length iv_l pp in 89 | let kblen = 2 * key_len + 2 * mac_len + 2 * iv_len 90 | and rand = server_random ^ client_random 91 | in 92 | let keyblock = key_block version cipher kblen master rand in 93 | divide_keyblock key_len mac_len iv_len keyblock 94 | in 95 | 96 | let context cipher_k iv mac_k = 97 | let open Crypto.Ciphers in 98 | let cipher_st = 99 | let iv_mode = match version with 100 | | `TLS_1_0 -> Iv iv 101 | | _ -> Random_iv 102 | in 103 | get_cipher ~secret:cipher_k ~hmac_secret:mac_k ~iv_mode ~nonce:iv pp 104 | and sequence = 0L in 105 | { cipher_st ; sequence } 106 | in 107 | 108 | let c_context = context c_key c_iv c_mac 109 | and s_context = context s_key s_iv s_mac in 110 | 111 | (c_context, s_context) 112 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## TLS - Transport Layer Security purely in OCaml 2 | 3 | %%VERSION%% 4 | 5 | Transport Layer Security (TLS) is probably the most widely deployed security 6 | protocol on the Internet. It provides communication privacy to prevent 7 | eavesdropping, tampering, and message forgery. Furthermore, it optionally 8 | provides authentication of the involved endpoints. TLS is commonly deployed for 9 | securing web services ([HTTPS](http://tools.ietf.org/html/rfc2818)), emails, 10 | virtual private networks, and wireless networks. 11 | 12 | TLS uses asymmetric cryptography to exchange a symmetric key, and optionally 13 | authenticate (using X.509) either or both endpoints. It provides algorithmic 14 | agility, which means that the key exchange method, symmetric encryption 15 | algorithm, and hash algorithm are negotiated. 16 | 17 | Read our [Usenix Security 2015 paper](https://www.usenix.org/conference/usenixsecurity15/technical-sessions/presentation/kaloper-mersinjak) for further details. 18 | 19 | ## Documentation 20 | 21 | [API documentation](https://mirleft.github.io/ocaml-tls/doc) 22 | 23 | ## Installation 24 | 25 | `opam install tls` will install this library. 26 | 27 | You can also build this locally by conducting the steps: 28 | 29 | ```bash 30 | opam install --deps-only -t . # or a named package instead of `.` - i.e. ./tls-lwt.opam 31 | 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 32 | ``` 33 | 34 | ## Usage 35 | 36 | The core of `ocaml-tls` (the opam package `tls`, available in the `lib` 37 | subdirectory) is an library independent of schedulers and does not perform any 38 | I/O operations. The library is designed so that a `Tls.Engine.state` state 39 | informs you of when to write and when to feed more data. It does not use 40 | mutation and is in a value-passing style (so, read data and state is the input, 41 | and data to be sent or presented to the upper layer, and state is the output). 42 | 43 | There are therefore `ocaml-tls` derivations with different schedulers that 44 | perform read and write operations. These derivations offer an interface similar 45 | to what an SSL socket (like [ssl][ssl]) can offer. 46 | - [lwt](https://ocsigen.org/lwt/latest/manual/manual): `tls-lwt` proposes to 47 | initiate a TLS flow with `Lwt_io.{input,output}_channel` from a Unix socket. 48 | It can also propose an abstract type `Tls_lwt.Unix.t` (which can be created 49 | from a Unix socket) associated with a `Tls_lwt.Unix` interface similar to a 50 | Unix socket. 51 | - [miou](https://github.com/robur-coop/miou): `tls-miou-unix` proposes a TLS 52 | flow via an abstract type `Tls_miou_unix.t` and an interface similar to a Unix 53 | socket from a `Miou_unix.file_descr` socket. 54 | - [MirageOS](https://mirageos.org): `tls-mirage` proposes a composition 55 | of a [`Mirage_flow.S`](https://github.com/mirage/mirage-flow/) module to 56 | obtain a new `Mirage_flow.S` (corresponding to the TLS layer) which uses the 57 | lwt scheduler. 58 | - [eio](https://github.com/ocaml-multicore/eio): `tls-eio` proposes the creation 59 | of an _eio flow_ from another _eio flow_. 60 | - [async](https://github.com/janestreet/async): `tls-async` proposes a TLS flow 61 | via `Async.{Reader,Writer}.t` from a `Async.Socket`. 62 | 63 | Depending on the scheduler you choose, you should choose one of these 64 | `ocaml-tls` derivations, distributed in the mentioned opam packages (tls-lwt, 65 | tls-mirage, tls-eio, tls-async). Each one takes advantage of what the scheduler 66 | used has to offer. 67 | 68 | ### Composability 69 | 70 | `ocaml-tls` can also be used as it is in order to be able to compose with other 71 | protocols without choosing a scheduler. This is the case, for example, with 72 | [sendmail.starttls][sendmail], which composes the SMTP and TLS protocols. The 73 | user can also be more selective about the use of certificates involved in a TLS 74 | connection, as [albatross][albatross] can offer in its transactions between 75 | clients and the server. 76 | 77 | When seen as OCaml values, the critical elements that enable instantiation of a 78 | TLS connection can be very finely controlled. 79 | 80 | ### Portability 81 | 82 | ocaml-tls is currently used for [MirageOS unikernels](https://mirageos.org), 83 | which makes it portable and available on many systems (even the most restricted 84 | ones such as [Solo5](https://github.com/solo5/solo5) as long as OCaml is 85 | available on them. 86 | 87 | [sendmail]: https://github.com/mirage/colombe 88 | [albatross]: https://github.com/robur-coop/albatross 89 | [ssl]: https://github.com/savonet/ocaml-ssl 90 | -------------------------------------------------------------------------------- /lwt/examples/resume_echo_server.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Ex_common 3 | 4 | let string_of_unix_err err f p = 5 | Printf.sprintf "Unix_error (%s, %s, %s)" 6 | (Unix.error_message err) f p 7 | 8 | 9 | module HT = Hashtbl.Make (Tls.Core.PreSharedKeyID) 10 | let cache_psk, psk_cache = 11 | let cache = HT.create 7 in 12 | ((fun psk ed -> HT.add cache psk.Tls.Core.identifier (psk, ed)), 13 | HT.find_opt cache) 14 | 15 | let ticket_cache = { 16 | Tls.Config.lookup = psk_cache ; 17 | ticket_granted = cache_psk ; 18 | lifetime = 300l ; 19 | timestamp = Ptime_clock.now 20 | } 21 | 22 | let serve_ssl port callback = 23 | 24 | let tag = "server" in 25 | 26 | X509_lwt.private_of_pems 27 | ~cert:server_cert 28 | ~priv_key:server_key >>= fun cert -> 29 | 30 | let hex = Ohex.decode in 31 | let epoch = 32 | { 33 | Tls.Core.side = `Client ; 34 | state = `Established ; 35 | protocol_version = `TLS_1_3 ; 36 | ciphersuite = `DHE_RSA_WITH_AES_128_GCM_SHA256 ; 37 | peer_random = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ; 38 | peer_certificate_chain = [] ; 39 | peer_certificate = None ; 40 | peer_name = None ; 41 | trust_anchor = None ; 42 | received_certificates = [] ; 43 | own_random = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ; 44 | own_certificate = fst cert ; 45 | own_private_key = Some (snd cert) ; 46 | own_name = Some Domain_name.(host_exn (of_string_exn "tls13test.nqsb.io")) ; 47 | master_secret = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ; 48 | exporter_master_secret = "" ; 49 | session_id = "" ; 50 | extended_ms = true ; 51 | alpn_protocol = None ; 52 | tls_unique = None ; 53 | } 54 | and psk = { 55 | Tls.Core.identifier = hex "0000" ; 56 | obfuscation = Randomconv.int32 Mirage_crypto_rng.generate ; 57 | secret = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ; 58 | lifetime = 300l ; 59 | early_data = 0l ; 60 | issued_at = Ptime_clock.now (); 61 | } 62 | in 63 | cache_psk psk epoch ; 64 | 65 | let server_s () = 66 | let open Lwt_unix in 67 | let s = socket PF_INET SOCK_STREAM 0 in 68 | setsockopt s SO_REUSEADDR true ; 69 | bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () -> 70 | listen s 10 ; 71 | s in 72 | 73 | let handle channels = 74 | async @@ fun () -> 75 | Lwt.catch (fun () -> callback channels >>= fun () -> yap ~tag "<- handler done") 76 | (function 77 | | Tls_lwt.Tls_alert a -> 78 | yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a 79 | | Tls_lwt.Tls_failure a -> 80 | yap ~tag @@ "handler: " ^ Tls.Engine.string_of_failure a 81 | | Unix.Unix_error (e, f, p) -> 82 | yap ~tag @@ "handler: " ^ (string_of_unix_err e f p) 83 | | _exn -> yap ~tag "handler: exception") 84 | in 85 | 86 | yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () -> 87 | let rec loop s = 88 | let authenticator ?ip:_ ~host:_ _ = Ok None in 89 | let config = get_ok (Tls.Config.server ~certificates:(`Single cert) ~ticket_cache ~authenticator ()) in 90 | (Lwt.catch 91 | (fun () -> 92 | Lwt_unix.accept s >>= fun (s, addr) -> 93 | let txt = Unix.(match addr with 94 | | ADDR_UNIX x -> "unix-" ^ x 95 | | ADDR_INET (ip, p) -> string_of_inet_addr ip ^ ":" ^ string_of_int p) 96 | in 97 | yap ~tag:"client-connect" txt >>= fun () -> 98 | Tls_lwt.Unix.server_of_fd config s >|= fun t -> `R t) 99 | (function 100 | | Unix.Unix_error (e, f, p) -> return (`L (string_of_unix_err e f p)) 101 | | Tls_lwt.Tls_alert a -> return (`L (Tls.Packet.alert_type_to_string a)) 102 | | Tls_lwt.Tls_failure f -> return (`L (Tls.Engine.string_of_failure f)) 103 | | exn -> let str = Printexc.to_string exn in return (`L ("loop: exception " ^ str)))) >>= function 104 | | `R t -> 105 | yap ~tag "-> connect" >>= fun () -> 106 | handle (Tls_lwt.of_t t); loop s 107 | | `L msg -> 108 | yap ~tag ("server socket: " ^ msg) >>= fun () -> loop s 109 | in 110 | server_s () >>= fun s -> 111 | loop s 112 | 113 | let echo_server port = 114 | serve_ssl port @@ fun (ic, oc) -> 115 | lines ic |> Lwt_stream.iter_s (fun line -> 116 | yap ~tag:"handler" ("+ " ^ string_of_int (String.length line)) >>= fun () -> 117 | Lwt_io.write_line oc line) 118 | 119 | let () = 120 | let port = 121 | try int_of_string Sys.argv.(1) with _ -> 4433 122 | in 123 | Lwt_main.run (echo_server port) 124 | -------------------------------------------------------------------------------- /tests/feedback.ml: -------------------------------------------------------------------------------- 1 | 2 | module Flow = struct 3 | 4 | let rewrap_st = function (`S _, st) -> `S st | (`C _, st) -> `C st 5 | 6 | let unwrap_st = function `S st -> st | `C st -> st 7 | 8 | let can_handle_appdata st = 9 | not (Tls.Engine.handshake_in_progress (unwrap_st st)) 10 | 11 | let send_application_data state data = 12 | match Tls.Engine.send_application_data (unwrap_st state) data with 13 | | None -> None 14 | | Some (st', cs) -> Some (rewrap_st (state, st'), cs) 15 | 16 | let handle_tls ~tag state msg = 17 | let (st, descr) = match state with 18 | | `S st -> (st, "server") 19 | | `C st -> (st, "client") 20 | in 21 | match msg with 22 | | None -> state, None, None 23 | | Some msg -> 24 | match Tls.Engine.handle_tls st msg with 25 | | Ok (_, Some `Eof, _, _) -> 26 | failwith "received eof" 27 | | Ok (st', _eof, `Response (Some ans), `Data appdata) -> 28 | (rewrap_st (state, st'), Some ans, appdata) 29 | | Ok (st', _eof, `Response None, `Data appdata) -> 30 | (rewrap_st (state, st'), None, appdata) 31 | | Error (a, _) -> 32 | failwith @@ Printf.sprintf "[%s] %s error: %s" 33 | tag descr (Tls.Engine.string_of_failure a) 34 | end 35 | 36 | let get_ok = function 37 | | Ok cfg -> cfg 38 | | Error `Msg msg -> invalid_arg msg 39 | 40 | let loop_chatter ~certificate ~loops ~size = 41 | 42 | Printf.eprintf "Looping %d times, %d bytes.\n%!" loops size; 43 | 44 | let message = Mirage_crypto_rng.generate size 45 | and server = Tls.(Engine.server (get_ok (Config.server ~certificates:(`Single certificate) ()))) 46 | and (client, init) = 47 | let authenticator ?ip:_ ~host:_ _ = Ok None in 48 | Tls.(Engine.client @@ get_ok (Config.client ~authenticator ())) 49 | in 50 | Testlib.time @@ fun () -> 51 | 52 | let rec handshake srv cli cli_msg = 53 | let tag = "handshake" in 54 | let (srv, ans, _) = Flow.handle_tls ~tag srv cli_msg in 55 | let (cli, ans, _) = Flow.handle_tls ~tag cli ans in 56 | if Flow.can_handle_appdata cli && Flow.can_handle_appdata srv then (srv, cli) else 57 | handshake srv cli ans 58 | 59 | and chat srv cli data = function 60 | | 0 -> data 61 | | n -> 62 | let tag = "chat" in 63 | let simplex sender recv data = 64 | match Flow.send_application_data sender [data] with 65 | | None -> failwith @@ "can't send" 66 | | Some (sender', msg) -> 67 | match Flow.handle_tls ~tag recv (Some msg) with 68 | | (recv', _, Some data') -> (sender', recv', data') 69 | | (_, _, None) -> failwith "expected data" 70 | in 71 | let (cli, srv, data1) = simplex cli srv data in 72 | let (srv, cli, data2) = simplex srv cli data1 in 73 | chat srv cli data2 (pred n) 74 | in 75 | let (srv, cli) = handshake (`S server) (`C client) (Some init) in 76 | let message' = chat srv cli message loops in 77 | if String.equal message message' then Ok () 78 | else Error "the message got corrupted :(" 79 | 80 | let string_of_file file = 81 | try 82 | let fh = open_in file in 83 | let content = really_input_string fh (in_channel_length fh) in 84 | close_in_noerr fh; 85 | content 86 | with _ -> invalid_arg "Error reading file" 87 | 88 | let load_priv () = 89 | let cert, key = 90 | if Sys.file_exists "./certificates/server.pem" then 91 | "./certificates/server.pem", "./certificates/server.key" 92 | else 93 | "server.pem", "server.key" 94 | in 95 | let cs1 = string_of_file cert 96 | and cs2 = string_of_file key in 97 | match 98 | X509.Certificate.decode_pem_multiple cs1, X509.Private_key.decode_pem cs2 99 | with 100 | | Ok certs, Ok key -> certs, key 101 | | Error (`Msg m), _ -> failwith ("can't parse certificates " ^ m) 102 | | _, Error (`Msg m) -> failwith ("can't parse private key " ^ m) 103 | 104 | let jump () loops size = 105 | let certificate = load_priv () in 106 | loop_chatter ~certificate ~loops ~size 107 | 108 | let setup_log style_renderer level = 109 | Fmt_tty.setup_std_outputs ?style_renderer (); 110 | Logs.set_level level; 111 | Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) 112 | 113 | open Cmdliner 114 | 115 | let setup_log = 116 | Term.(const setup_log 117 | $ Fmt_cli.style_renderer () 118 | $ Logs_cli.level ()) 119 | 120 | let loops = 121 | let doc = "Number of loops to take" in 122 | Arg.(value & opt int 10 & info ~docv:"LOOPS" ~doc ["loops"]) 123 | 124 | let size = 125 | let doc = "Bytes to exchange" in 126 | Arg.(value & opt int 1024 & info ~docv:"SIZE" ~doc ["size"]) 127 | 128 | let cmd = 129 | let term = Term.(const jump $ setup_log $ loops $ size) 130 | and info = Cmd.info "feedback" ~version:"%%VERSION_NUM%%" 131 | in 132 | Cmd.v info term 133 | 134 | let () = exit (Cmd.eval_result cmd) 135 | -------------------------------------------------------------------------------- /async/tls_async.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | module Session = Session 4 | module X509_async = X509_async 5 | 6 | let try_to_close t = 7 | match%map Session.close_tls t with 8 | | Ok () -> () 9 | | Error tls_close_error -> Log.Global.error_s [%sexp (tls_close_error : Error.t)] 10 | ;; 11 | 12 | let pipe t = 13 | let b_reader = Bytes.create 0x8000 in 14 | let rec f_reader writer = 15 | match%bind Session.read t b_reader with 16 | | Ok 0 -> 17 | Pipe.close writer; 18 | return () 19 | | Ok len -> 20 | let%bind () = Pipe.write writer (Stdlib.Bytes.sub_string b_reader 0 len) in 21 | f_reader writer 22 | | Error read_error -> 23 | Log.Global.error_s [%sexp (read_error : Error.t)]; 24 | Pipe.close writer; 25 | return () 26 | in 27 | let rec f_writer reader = 28 | let%bind pipe_read = Pipe.read reader in 29 | match pipe_read with 30 | | `Ok s -> 31 | (match%bind Session.writev t [ s ] with 32 | | Ok () -> f_writer reader 33 | | Error (_ : Error.t) -> try_to_close t) 34 | | `Eof -> try_to_close t 35 | in 36 | Pipe.create_reader ~close_on_exception:false f_reader, Pipe.create_writer f_writer 37 | ;; 38 | 39 | let upgrade_connection tls_session ((_ : Reader.t), outer_writer) = 40 | let pipe_r, pipe_w = pipe tls_session in 41 | let%bind inner_reader = Reader.of_pipe (Info.of_string "tls_reader") pipe_r in 42 | let%map inner_writer, `Closed_and_flushed_downstream inner_cafd = 43 | Writer.of_pipe (Info.of_string "tls_writer") pipe_w 44 | in 45 | Writer.set_raise_when_consumer_leaves inner_writer false; 46 | let outer_cafd = 47 | (* Ordering is important here to ensure no data is lost during the session shutdown *) 48 | let%bind () = Writer.close_finished inner_writer in 49 | let%bind () = inner_cafd in 50 | let%bind () = try_to_close tls_session in 51 | Writer.flushed outer_writer 52 | in 53 | tls_session, inner_reader, inner_writer, `Tls_closed_and_flushed_downstream outer_cafd 54 | ;; 55 | 56 | let upgrade_server_reader_writer_to_tls config rw = 57 | let open Deferred.Or_error.Let_syntax in 58 | let%bind tls_session = Session.server_of_fd config rw in 59 | upgrade_connection tls_session rw |> Deferred.ok 60 | ;; 61 | 62 | let upgrade_client_reader_writer_to_tls ?host config rw = 63 | let open Deferred.Or_error.Let_syntax in 64 | let%bind tls_session = Session.client_of_fd ?host config rw in 65 | upgrade_connection tls_session rw |> Deferred.ok 66 | ;; 67 | 68 | type 'a io_handler = Reader.t -> Writer.t -> 'a Deferred.t 69 | type 'a tls_handler = Session.t -> 'a io_handler 70 | 71 | let upgrade_server_handler ~config handle_client outer_reader outer_writer = 72 | let%bind ( tls_session 73 | , inner_reader 74 | , inner_writer 75 | , `Tls_closed_and_flushed_downstream inner_cafd ) 76 | = 77 | upgrade_server_reader_writer_to_tls config (outer_reader, outer_writer) 78 | |> Deferred.Or_error.ok_exn 79 | in 80 | Monitor.protect 81 | (fun () -> handle_client tls_session inner_reader inner_writer) 82 | ~finally:(fun () -> 83 | Deferred.all_unit 84 | [ Reader.close inner_reader; Writer.close inner_writer; inner_cafd ]) 85 | ;; 86 | 87 | let listen 88 | ?buffer_age_limit 89 | ?max_connections 90 | ?max_accepts_per_batch 91 | ?backlog 92 | ?socket 93 | ~on_handler_error 94 | config 95 | where_to_listen 96 | handle_client 97 | = 98 | Tcp.Server.create 99 | ?buffer_age_limit 100 | ?max_connections 101 | ?max_accepts_per_batch 102 | ?backlog 103 | ?socket 104 | ~on_handler_error 105 | where_to_listen 106 | (fun sock -> 107 | upgrade_server_handler ~config (handle_client sock)) 108 | ;; 109 | 110 | let upgrade_client_to_tls config ~host outer_reader outer_writer = 111 | let open Deferred.Or_error.Let_syntax in 112 | let%bind ( tls_session 113 | , inner_reader 114 | , inner_writer 115 | , `Tls_closed_and_flushed_downstream inner_cafd ) 116 | = 117 | upgrade_client_reader_writer_to_tls ?host config (outer_reader, outer_writer) 118 | in 119 | don't_wait_for 120 | (let%bind.Deferred () = inner_cafd in 121 | Deferred.all_unit [ Writer.close outer_writer; Reader.close outer_reader ]); 122 | return (tls_session, inner_reader, inner_writer) 123 | ;; 124 | 125 | let connect 126 | ?socket 127 | ?buffer_age_limit 128 | ?interrupt 129 | ?reader_buffer_size 130 | ?writer_buffer_size 131 | ?timeout 132 | ?time_source 133 | config 134 | where_to_connect 135 | ~host 136 | = 137 | let open Deferred.Or_error.Let_syntax in 138 | let%bind (_ : ([ `Active ], 'a) Socket.t), outer_reader, outer_writer = 139 | Tcp.connect 140 | ?socket 141 | ?buffer_age_limit 142 | ?interrupt 143 | ?reader_buffer_size 144 | ?writer_buffer_size 145 | ?timeout 146 | ?time_source 147 | where_to_connect 148 | |> Deferred.ok 149 | in 150 | upgrade_client_to_tls ~host config outer_reader outer_writer 151 | ;; 152 | 153 | (* initialized RNG early to maximise available entropy. *) 154 | let () = Mirage_crypto_rng_unix.use_default () 155 | -------------------------------------------------------------------------------- /lwt/tls_lwt.mli: -------------------------------------------------------------------------------- 1 | (** Effectful operations using Lwt for pure TLS. 2 | 3 | The pure TLS is state and buffer in, state and buffer out. This 4 | module uses Lwt for communication over the network. 5 | 6 | This module implements a high-level API and a low-level API (in 7 | {!Unix}). Most applications should use the high-level API described below. *) 8 | 9 | (** [Tls_alert] exception received from the other endpoint *) 10 | exception Tls_alert of Tls.Packet.alert_type 11 | 12 | (** [Tls_failure] exception while processing incoming data *) 13 | exception Tls_failure of Tls.Engine.failure 14 | 15 | (** Low-level API *) 16 | module Unix : sig 17 | 18 | (** {1 Unix API} *) 19 | 20 | (** It is the responsibility of the client to handle error 21 | conditions. The underlying file descriptors are not closed. *) 22 | 23 | (** Abstract type of a session *) 24 | type t 25 | 26 | (** {2 Constructors} *) 27 | 28 | (** [server_of_fd server fd] is [t], after server-side TLS 29 | handshake of [fd] using [server] configuration. *) 30 | val server_of_fd : Tls.Config.server -> Lwt_unix.file_descr -> t Lwt.t 31 | 32 | (** [server_of_channels server (ic, oc)] is [t], after server-side TLS 33 | handshake on the input/output channels [ic, oc] using [server] configuration. *) 34 | val server_of_channels : Tls.Config.server -> Lwt_io.input_channel * Lwt_io.output_channel -> t Lwt.t 35 | 36 | (** [client_of_fd client ~host fd] is [t], after client-side 37 | TLS handshake of [fd] using [client] configuration and [host]. *) 38 | val client_of_fd : Tls.Config.client -> ?host:[ `host ] Domain_name.t -> Lwt_unix.file_descr -> t Lwt.t 39 | 40 | (** [client_of_channels client ~host (ic, oc)] is [t], after client-side 41 | TLS handshake over the input/output channels [ic, oc] using [client] configuration and [host]. *) 42 | val client_of_channels : Tls.Config.client -> ?host:[ `host ] Domain_name.t -> Lwt_io.input_channel * Lwt_io.output_channel -> t Lwt.t 43 | 44 | (** [accept server fd] is [t, sockaddr], after accepting a 45 | client on [fd] and upgrading to a TLS connection. *) 46 | val accept : Tls.Config.server -> Lwt_unix.file_descr -> (t * Lwt_unix.sockaddr) Lwt.t 47 | 48 | (** [connect client (host, port)] is [t], after successful 49 | connection to [host] on [port] and TLS upgrade. *) 50 | val connect : Tls.Config.client -> string * int -> t Lwt.t 51 | 52 | (** {2 Common stream operations} *) 53 | 54 | (** [read t ~off buffer] is [length], the number of bytes read into 55 | [buffer]. It fills [buffer] starting at [off] (default is 0). *) 56 | val read : t -> ?off:int -> bytes -> int Lwt.t 57 | 58 | (** [write t buffer] writes the [buffer] to the session. *) 59 | val write : t -> string -> unit Lwt.t 60 | 61 | (** [writev t buffers] writes the [buffers] to the session. *) 62 | val writev : t -> string list -> unit Lwt.t 63 | 64 | (** [read_bytes t bytes offset len] is [read_bytes], the amount of 65 | bytes read. *) 66 | val read_bytes : t -> Lwt_bytes.t -> int -> int -> int Lwt.t 67 | 68 | (** [write_bytes t bytes offset length] writes [length] bytes of 69 | [bytes] starting at [offset] to the session. *) 70 | val write_bytes : t -> Lwt_bytes.t -> int -> int -> unit Lwt.t 71 | 72 | (** [shutdown t direction] closes the [direction] of the TLS session [t]. 73 | If [`read_write] or [`write] is closed, a TLS close_notify is sent to the 74 | other endpoint. If this results in a fully closed session (or an 75 | errorneous session), the underlying file descriptor is closed. *) 76 | val shutdown : t -> [ `read | `write | `read_write ] -> unit Lwt.t 77 | 78 | (** [close t] closes the TLS session and the underlying file descriptor. *) 79 | val close : t -> unit Lwt.t 80 | 81 | (** [reneg ~authenticator ~acceptable_cas ~cert ~drop t] renegotiates the 82 | session, and blocks until the renegotiation finished. Optionally, a new 83 | [authenticator] and [acceptable_cas] can be used. The own certificate can 84 | be adjusted by [cert]. If [drop] is [true] (the default), 85 | application data received before the renegotiation finished is dropped. *) 86 | val reneg : ?authenticator:X509.Authenticator.t -> 87 | ?acceptable_cas:X509.Distinguished_name.t list -> ?cert:Tls.Config.own_cert -> 88 | ?drop:bool -> t -> unit Lwt.t 89 | 90 | (** [key_update ~request t] updates the traffic key and requests a traffic key 91 | update from the peer if [request] is provided and [true] (the default). 92 | This is only supported in TLS 1.3. *) 93 | val key_update : ?request:bool -> t -> unit Lwt.t 94 | 95 | (** [epoch t] returns [epoch], which contains information of the 96 | active session. *) 97 | val epoch : t -> (Tls.Core.epoch_data, unit) result 98 | end 99 | 100 | (** {1 High-level API} *) 101 | 102 | type ic = Lwt_io.input_channel 103 | type oc = Lwt_io.output_channel 104 | 105 | (** [accept_ext server fd] is [(ic, oc), sockaddr], the input 106 | and output channel from an accepted connection on the given [fd], 107 | after upgrading to TLS using the [server] configuration. *) 108 | val accept_ext : Tls.Config.server -> Lwt_unix.file_descr -> 109 | ((ic * oc) * Lwt_unix.sockaddr) Lwt.t 110 | 111 | (** [accept own_cert fd] is [(ic, oc), sockaddr], the input and 112 | output channel from the accepted connection on [fd], using the 113 | default configuration with the given [own_cert]. *) 114 | val accept : Tls.Config.own_cert -> Lwt_unix.file_descr -> 115 | ((ic * oc) * Lwt_unix.sockaddr, [> `Msg of string]) result Lwt.t 116 | 117 | (** [connect_ext client (host, port)] is [ic, oc], the input 118 | and output channel of a TLS connection to [host] on [port] using 119 | the [client] configuration. *) 120 | val connect_ext : Tls.Config.client -> string * int -> (ic * oc) Lwt.t 121 | 122 | (** [connect authenticator (host, port)] is [ic, oc], the input 123 | and output channel of a TLS connection to [host] on [port] using the 124 | default configuration and the [authenticator]. *) 125 | val connect : X509.Authenticator.t -> string * int -> (ic * oc, [> `Msg of string ]) result Lwt.t 126 | 127 | (** [of_t t] is [ic, oc], the input and output channel. [close] 128 | defaults to [!Unix.close]. *) 129 | val of_t : ?close:(unit -> unit Lwt.t) -> Unix.t -> ic * oc 130 | -------------------------------------------------------------------------------- /async/x509_async.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | include module type of struct 5 | include X509 6 | end 7 | 8 | module Authenticator : sig 9 | include module type of struct 10 | include Authenticator 11 | end 12 | 13 | module Param : sig 14 | type t 15 | 16 | val ca_file 17 | : ?allowed_hashes:Digestif.hash' list 18 | -> ?crls:Filename.t 19 | -> Filename.t 20 | -> unit 21 | -> t 22 | 23 | val ca_dir 24 | : ?allowed_hashes:Digestif.hash' list 25 | -> ?crls:Filename.t 26 | -> Filename.t 27 | -> unit 28 | -> t 29 | 30 | (** The fingerprint can be collected from a browser or by invoking an openssl command 31 | like 'openssl x509 -in -noout -fingerprint -sha256' *) 32 | val cert_fingerprint 33 | : Digestif.hash' 34 | -> string 35 | -> t 36 | 37 | (** The fingerprint can be collected from a browser or by invoking an openssl command 38 | like 'openssl x509 -in -noout -pubkey | openssl pkey -pubin -outform DER | openssl dgst -sha256' *) 39 | val key_fingerprint 40 | : Digestif.hash' 41 | -> string 42 | -> t 43 | 44 | (** Async programs often don't use [Ptime_clock], so this is provided as a convenience 45 | function. Relies on [Unix.gettimeofday]. *) 46 | val time : unit -> Ptime.t option 47 | 48 | val to_authenticator 49 | : time:(unit -> Ptime.t option) 50 | -> t 51 | -> Authenticator.t Deferred.Or_error.t 52 | end 53 | end 54 | 55 | module Private_key : sig 56 | include module type of struct 57 | include Private_key 58 | end 59 | 60 | val sign 61 | : Digestif.hash' 62 | -> ?scheme:Key_type.signature_scheme 63 | -> t 64 | -> [ `Digest of string | `Message of string ] 65 | -> string Or_error.t 66 | 67 | val decode_der : contents:string -> t Or_error.t 68 | val decode_pem : contents:string -> t Or_error.t 69 | val of_pem_file : Filename.t -> t Deferred.Or_error.t 70 | end 71 | 72 | module Public_key : sig 73 | include module type of struct 74 | include Public_key 75 | end 76 | 77 | val verify 78 | : Digestif.hash' 79 | -> ?scheme:Key_type.signature_scheme 80 | -> signature:string 81 | -> t 82 | -> [ `Digest of string | `Message of string ] 83 | -> unit Or_error.t 84 | 85 | val decode_der : contents:string -> t Or_error.t 86 | val decode_pem : contents:string -> t Or_error.t 87 | end 88 | 89 | module Certificate : sig 90 | include module type of struct 91 | include Certificate 92 | end 93 | 94 | val decode_pem_multiple : contents:string -> t list Or_error.t 95 | val decode_pem : contents:string -> t Or_error.t 96 | val decode_der : contents:string -> t Or_error.t 97 | val of_pem_file : Filename.t -> t list Deferred.Or_error.t 98 | val of_pem_directory : directory:Filename.t -> t list Deferred.Or_error.t 99 | end 100 | 101 | module Distinguished_name : sig 102 | include module type of struct 103 | include Distinguished_name 104 | end 105 | 106 | val decode_der : contents:string -> t Or_error.t 107 | end 108 | 109 | module CRL : sig 110 | include module type of struct 111 | include CRL 112 | end 113 | 114 | val decode_der : contents:string -> t Or_error.t 115 | 116 | val revoke 117 | : ?digest:Digestif.hash' 118 | -> issuer:Distinguished_name.t 119 | -> this_update:Ptime.t 120 | -> ?next_update:Ptime.t 121 | -> ?extensions:Extension.t 122 | -> revoked_cert list 123 | -> Private_key.t 124 | -> t Or_error.t 125 | 126 | val revoke_certificate 127 | : revoked_cert 128 | -> this_update:Ptime.t 129 | -> ?next_update:Ptime.t 130 | -> t 131 | -> Private_key.t 132 | -> t Or_error.t 133 | 134 | val revoke_certificates 135 | : revoked_cert list 136 | -> this_update:Ptime.t 137 | -> ?next_update:Ptime.t 138 | -> t 139 | -> Private_key.t 140 | -> t Or_error.t 141 | 142 | val of_pem_dir : directory:Filename.t -> t list Deferred.Or_error.t 143 | end 144 | 145 | module OCSP : sig 146 | include module type of struct 147 | include OCSP 148 | end 149 | 150 | module Request : sig 151 | include module type of struct 152 | include Request 153 | end 154 | 155 | val create 156 | : ?certs:Certificate.t list 157 | -> ?digest:Digestif.hash' 158 | -> ?requestor_name:General_name.b 159 | -> ?key:Private_key.t 160 | -> cert_id list 161 | -> t Or_error.t 162 | 163 | val decode_der : contents:string -> t Or_error.t 164 | end 165 | 166 | module Response : sig 167 | include module type of struct 168 | include Response 169 | end 170 | 171 | val create_success 172 | : ?digest:Digestif.hash' 173 | -> ?certs:Certificate.t list 174 | -> ?response_extensions:Extension.t 175 | -> Private_key.t 176 | -> responder_id 177 | -> Ptime.t 178 | -> single_response list 179 | -> t Or_error.t 180 | 181 | val responses : t -> single_response list Or_error.t 182 | val decode_der : contents:string -> t Or_error.t 183 | end 184 | end 185 | 186 | module PKCS12 : sig 187 | include module type of struct 188 | include PKCS12 189 | end 190 | 191 | val decode_der : contents:string -> t Or_error.t 192 | 193 | val verify 194 | : string 195 | -> t 196 | -> [ `Certificate of Certificate.t 197 | | `Crl of CRL.t 198 | | `Decrypted_private_key of Private_key.t 199 | | `Private_key of Private_key.t 200 | ] 201 | list 202 | Or_error.t 203 | end 204 | 205 | module Signing_request : sig 206 | include module type of struct 207 | include Signing_request 208 | end 209 | 210 | val decode_der : ?allowed_hashes:Digestif.hash' list -> string -> t Or_error.t 211 | val decode_pem : string -> t Or_error.t 212 | 213 | val create 214 | : Distinguished_name.t 215 | -> ?digest:Digestif.hash' 216 | -> ?extensions:Ext.t 217 | -> Private_key.t 218 | -> t Or_error.t 219 | 220 | val sign 221 | : ?allowed_hashes:Digestif.hash' list 222 | -> ?digest:Digestif.hash' 223 | -> ?serial:string 224 | -> ?extensions:Extension.t 225 | -> t 226 | -> Private_key.t 227 | -> Distinguished_name.t 228 | -> valid_from:Ptime.t 229 | -> valid_until:Ptime.t 230 | -> Certificate.t Or_error.t 231 | end 232 | -------------------------------------------------------------------------------- /lib/crypto.ml: -------------------------------------------------------------------------------- 1 | open Mirage_crypto 2 | 3 | open Ciphersuite 4 | 5 | (* on-the-wire dh_params <-> (group, pub_message) *) 6 | let dh_params_pack { Mirage_crypto_pk.Dh.p; gg ; _ } message = 7 | let cs_of_z = Mirage_crypto_pk.Z_extra.to_octets_be ?size:None in 8 | { Core.dh_p = cs_of_z p ; dh_g = cs_of_z gg ; dh_Ys = message } 9 | 10 | and dh_params_unpack { Core.dh_p ; dh_g ; dh_Ys } = 11 | let z_of_cs = Mirage_crypto_pk.Z_extra.of_octets_be ?bits:None in 12 | match Mirage_crypto_pk.Dh.group ~p:(z_of_cs dh_p) ~gg:(z_of_cs dh_g) () with 13 | | Ok dh -> Ok (dh, dh_Ys) 14 | | Error _ as e -> e 15 | 16 | module Ciphers = struct 17 | 18 | (* I'm not sure how to get rid of this type, but would welcome a solution *) 19 | (* only used as result of get_block, which is called by get_cipher below *) 20 | type keyed = | K_CBC : 'k State.cbc_cipher * (string -> 'k) -> keyed 21 | 22 | let get_block = function 23 | | TRIPLE_DES_EDE_CBC -> 24 | K_CBC ( (module DES.CBC : Block.CBC with type key = DES.CBC.key), 25 | DES.CBC.of_secret ) 26 | 27 | | AES_128_CBC -> 28 | K_CBC ( (module AES.CBC : Block.CBC with type key = AES.CBC.key), 29 | AES.CBC.of_secret ) 30 | 31 | | AES_256_CBC -> 32 | K_CBC ( (module AES.CBC : Block.CBC with type key = AES.CBC.key), 33 | AES.CBC.of_secret ) 34 | 35 | type aead_keyed = | K_AEAD : 'k State.aead_cipher * (string -> 'k) * bool -> aead_keyed 36 | let get_aead = 37 | function 38 | | AES_128_CCM | AES_256_CCM -> 39 | K_AEAD ((module AES.CCM16 : AEAD with type key = AES.CCM16.key), 40 | AES.CCM16.of_secret, true) 41 | | AES_128_GCM | AES_256_GCM -> 42 | K_AEAD ((module AES.GCM : AEAD with type key = AES.GCM.key), 43 | AES.GCM.of_secret, true) 44 | | CHACHA20_POLY1305 -> 45 | K_AEAD ((module Chacha20 : AEAD with type key = Chacha20.key), 46 | Chacha20.of_secret, false) 47 | 48 | let get_aead_cipher ~secret ~nonce aead_cipher = 49 | match get_aead aead_cipher with 50 | | K_AEAD (cipher, sec, explicit_nonce) -> 51 | let cipher_secret = sec secret in 52 | State.(AEAD { cipher ; cipher_secret ; nonce ; explicit_nonce }) 53 | 54 | let get_cipher ~secret ~hmac_secret ~iv_mode ~nonce = function 55 | | `Block (cipher, hmac) -> 56 | ( match get_block cipher with 57 | | K_CBC (cipher, sec) -> 58 | let cipher_secret = sec secret in 59 | State.(CBC { cipher ; cipher_secret ; iv_mode ; hmac ; hmac_secret }) 60 | ) 61 | 62 | | `AEAD cipher -> get_aead_cipher ~secret ~nonce cipher 63 | end 64 | 65 | let sequence_buf seq = 66 | let buf = Bytes.create 8 in 67 | Bytes.set_int64_be buf 0 seq ; 68 | Bytes.unsafe_to_string buf 69 | 70 | let aead_nonce nonce seq = 71 | let s = 72 | let l = String.length nonce in 73 | let buf = Bytes.make l '\x00' in 74 | Bytes.set_int64_be buf (l - 8) seq; 75 | Bytes.unsafe_to_string buf 76 | in 77 | Uncommon.xor nonce s 78 | 79 | let adata_1_3 len = 80 | (* additional data in TLS 1.3 is using the header (RFC 8446 Section 5.2): 81 | - APPLICATION_TYPE 82 | - 0x03 0x03 (for TLS version 1.2 -- binary representation is 0x03 0x03) 83 | - 84 | *) 85 | let buf = Bytes.create 5 in 86 | Bytes.set_uint8 buf 0 (Packet.content_type_to_int Packet.APPLICATION_DATA) ; 87 | Bytes.set_uint8 buf 1 3; 88 | Bytes.set_uint8 buf 2 3; 89 | Bytes.set_uint16_be buf 3 len ; 90 | Bytes.unsafe_to_string buf 91 | 92 | let pseudo_header seq ty (v_major, v_minor) v_length = 93 | let buf = Bytes.create 13 in 94 | Bytes.set_int64_be buf 0 seq; 95 | Bytes.set_uint8 buf 8 (Packet.content_type_to_int ty); 96 | Bytes.set_uint8 buf 9 v_major; 97 | Bytes.set_uint8 buf 10 v_minor; 98 | Bytes.set_uint16_be buf 11 v_length; 99 | Bytes.unsafe_to_string buf 100 | 101 | (* MAC used in TLS *) 102 | let mac hash key pseudo_hdr data = 103 | let module H = (val Digestif.module_of_hash' hash) in 104 | H.(to_raw_string (hmacv_string ~key [ pseudo_hdr ; data ])) 105 | 106 | let cbc_block (type a) cipher = 107 | let module C = (val cipher : Block.CBC with type key = a) in C.block_size 108 | 109 | (* crazy CBC padding and unpadding for TLS *) 110 | let cbc_pad block data = 111 | (* 1 is the padding length, encoded as 8 bit at the end of the fragment *) 112 | let len = 1 + String.length data in 113 | (* we might want to add additional blocks of padding *) 114 | let padding_length = block - (len mod block) in 115 | (* 1 is again padding length field *) 116 | let cstruct_len = padding_length + 1 in 117 | String.make cstruct_len (Char.unsafe_chr padding_length) 118 | 119 | let cbc_unpad data = 120 | let len = String.length data in 121 | let padlen = String.get_uint8 data (pred len) in 122 | 123 | let rec check = function 124 | | i when i > padlen -> true 125 | | i -> (String.get_uint8 data (len - padlen - 1 + i) = padlen) && check (succ i) in 126 | 127 | try 128 | if check 0 then Some (String.sub data 0 (len - padlen - 1)) else None 129 | with Invalid_argument _ -> None 130 | 131 | let tag_len (type a) cipher = 132 | let module C = (val cipher : AEAD with type key = a) in 133 | C.tag_size 134 | 135 | let encrypt_aead (type a) ~cipher ~key ~nonce ?adata data = 136 | let module C = (val cipher : AEAD with type key = a) in 137 | C.authenticate_encrypt ~key ~nonce ?adata data 138 | 139 | let decrypt_aead (type a) ~cipher ~key ~nonce ?adata data = 140 | let module C = (val cipher : AEAD with type key = a) in 141 | C.authenticate_decrypt ~key ~nonce ?adata data 142 | 143 | let encrypt_cbc (type a) ~cipher ~key ~iv data = 144 | let module C = (val cipher : Block.CBC with type key = a) in 145 | let message = C.encrypt ~key ~iv (data ^ cbc_pad C.block_size data) in 146 | (message, C.next_iv ~iv message) 147 | 148 | let decrypt_cbc (type a) ~cipher ~key ~iv data = 149 | let module C = (val cipher : Block.CBC with type key = a) in 150 | try 151 | let message = C.decrypt ~key ~iv data in 152 | match cbc_unpad message with 153 | | Some res -> Some (res, C.next_iv ~iv data) 154 | | None -> None 155 | with 156 | (* This bails out immediately on mis-alignment, making it very timeable. 157 | * However, decryption belongs to the outermost level and this operation's 158 | * timing does not leak information ala padding oracle and friends. *) 159 | | Invalid_argument _ -> None 160 | -------------------------------------------------------------------------------- /async/io.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | include Io_intf 4 | 5 | module Tls_error = struct 6 | module Alert = struct 7 | type t = Tls.Packet.alert_type 8 | let sexp_of_t a = 9 | Sexplib.Sexp.Atom (Tls.Packet.alert_type_to_string a) 10 | end 11 | module Fail = struct 12 | type t = Tls.Engine.failure 13 | let sexp_of_t a = 14 | Sexplib.Sexp.Atom (Tls.Engine.string_of_failure a) 15 | end 16 | type t = 17 | | Tls_alert of Alert.t 18 | (** [Tls_alert] exception received from the other endpoint *) 19 | | Tls_failure of Fail.t 20 | (** [Tls_failure] exception while processing incoming data *) 21 | | Connection_closed 22 | | Connection_not_ready 23 | | Unexpected_eof 24 | | Unable_to_renegotiate 25 | | Unable_to_update_key 26 | [@@deriving sexp_of] 27 | end 28 | 29 | module Make (Fd : Fd) : S with module Fd := Fd = struct 30 | open Deferred.Or_error.Let_syntax 31 | 32 | module State = struct 33 | type t = 34 | | Active of Tls.Engine.state 35 | | Eof 36 | | Error of Tls_error.t 37 | end 38 | 39 | type t = 40 | { fd : Fd.t 41 | ; mutable state : State.t 42 | ; mutable linger : string option 43 | ; recv_buf : bytes 44 | } 45 | 46 | let tls_error = Fn.compose Deferred.Or_error.error_s Tls_error.sexp_of_t 47 | 48 | let rec read_react t = 49 | let handle tls buf = 50 | match Tls.Engine.handle_tls tls buf with 51 | | Ok (state, eof, `Response resp, `Data data) -> 52 | t.state 53 | <- (match eof with 54 | | None -> Active state 55 | | Some `Eof -> Eof); 56 | let%map () = 57 | match resp with 58 | | None -> return () 59 | | Some resp -> Fd.write_full t.fd resp 60 | in 61 | `Ok data 62 | | Error (alert, `Response resp) -> 63 | t.state <- Error (match alert with `Alert a -> Tls_alert a | f -> Tls_failure f); 64 | let%bind () = Fd.write_full t.fd resp in 65 | read_react t 66 | in 67 | match t.state with 68 | | Error e -> tls_error e 69 | | Eof -> return `Eof 70 | | Active _ -> 71 | let%bind n = Fd.read t.fd t.recv_buf in 72 | (match t.state, n with 73 | | Active _, `Eof -> 74 | t.state <- Eof; 75 | return `Eof 76 | | Active tls, `Ok n -> handle tls (Stdlib.Bytes.sub_string t.recv_buf 0 n) 77 | | Error e, _ -> tls_error e 78 | | Eof, _ -> return `Eof) 79 | ;; 80 | 81 | let rec read t buf = 82 | let writeout res = 83 | let rlen = String.length res in 84 | let n = min (Bytes.length buf) rlen in 85 | Stdlib.Bytes.blit_string res 0 buf 0 n; 86 | t.linger <- (if n < rlen then Some (Stdlib.String.sub res n (rlen - n)) else None); 87 | return n 88 | in 89 | match t.linger with 90 | | Some res -> writeout res 91 | | None -> 92 | (match%bind read_react t with 93 | | `Eof -> return 0 94 | | `Ok None -> read t buf 95 | | `Ok (Some res) -> writeout res) 96 | ;; 97 | 98 | let writev t css = 99 | match t.state with 100 | | Error err -> tls_error err 101 | | Eof -> tls_error Connection_closed 102 | | Active tls -> 103 | (match Tls.Engine.send_application_data tls css with 104 | | Some (tls, tlsdata) -> 105 | t.state <- Active tls; 106 | Fd.write_full t.fd tlsdata 107 | | None -> tls_error Connection_not_ready) 108 | ;; 109 | 110 | (* 111 | * XXX bad XXX 112 | * This is a point that should particularly be protected from concurrent r/w. 113 | * Doing this before a `t` is returned is safe; redoing it during rekeying is 114 | * not, as the API client already sees the `t` and can mistakenly interleave 115 | * writes while this is in progress. 116 | * *) 117 | let rec drain_handshake t = 118 | let push_linger t mcs = 119 | match mcs, t.linger with 120 | | None, _ -> () 121 | | scs, None -> t.linger <- scs 122 | | Some cs, Some l -> t.linger <- Some (l ^ cs) 123 | in 124 | match t.state with 125 | | Active tls when not (Tls.Engine.handshake_in_progress tls) -> return t 126 | | _ -> 127 | (match%bind read_react t with 128 | | `Eof -> tls_error Unexpected_eof 129 | | `Ok cs -> 130 | push_linger t cs; 131 | drain_handshake t) 132 | ;; 133 | 134 | let reneg ?authenticator ?acceptable_cas ?cert ?(drop = true) t = 135 | match t.state with 136 | | Error err -> tls_error err 137 | | Eof -> tls_error Connection_closed 138 | | Active tls -> 139 | (match Tls.Engine.reneg ?authenticator ?acceptable_cas ?cert tls with 140 | | None -> tls_error Unable_to_renegotiate 141 | | Some (tls', buf) -> 142 | if drop then t.linger <- None; 143 | t.state <- Active tls'; 144 | let%bind () = Fd.write_full t.fd buf in 145 | let%bind _ = drain_handshake t in 146 | return ()) 147 | ;; 148 | 149 | let key_update ?request t = 150 | match t.state with 151 | | Error err -> tls_error err 152 | | Eof -> tls_error Connection_closed 153 | | Active tls -> 154 | (match Tls.Engine.key_update ?request tls with 155 | | Error _ -> tls_error Unable_to_update_key 156 | | Ok (tls', buf) -> 157 | t.state <- Active tls'; 158 | Fd.write_full t.fd buf) 159 | ;; 160 | 161 | let close_tls t = 162 | match t.state with 163 | | Active tls -> 164 | let _, buf = Tls.Engine.send_close_notify tls in 165 | t.state <- Eof; 166 | Fd.write_full t.fd buf 167 | | _ -> return () 168 | ;; 169 | 170 | let server_of_fd config fd = 171 | drain_handshake 172 | { state = Active (Tls.Engine.server config) 173 | ; fd 174 | ; linger = None 175 | ; recv_buf = Bytes.create 4096 176 | } 177 | ;; 178 | 179 | let client_of_fd config ?host fd = 180 | let config' = 181 | match host with 182 | | None -> config 183 | | Some host -> Tls.Config.peer config host 184 | in 185 | let t = { state = Eof; fd; linger = None; recv_buf = Bytes.create 4096 } in 186 | let tls, init = Tls.Engine.client config' in 187 | let t = { t with state = Active tls } in 188 | let%bind () = Fd.write_full t.fd init in 189 | drain_handshake t 190 | ;; 191 | 192 | let epoch t = 193 | match t.state with 194 | | Active tls -> (match Tls.Engine.epoch tls with 195 | | Ok _ as o -> o 196 | | Error () -> Or_error.error_string "no TLS state available yet") 197 | | Eof -> Or_error.error_string "TLS state is end of file" 198 | | Error _ -> Or_error.error_string "TLS state is error" 199 | ;; 200 | end 201 | -------------------------------------------------------------------------------- /lib/handshake_crypto13.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | let cdiv (x : int) (y : int) = 4 | if x > 0 && y > 0 then (x + y - 1) / y 5 | else if x < 0 && y < 0 then (x + y + 1) / y 6 | else x / y 7 | 8 | let left_pad_dh group msg = 9 | let bytes = cdiv (Mirage_crypto_pk.Dh.modulus_size group) 8 in 10 | let padding = String.make (bytes - String.length msg) '\x00' in 11 | padding ^ msg 12 | 13 | let not_all_zero r = 14 | let* str = r in 15 | try 16 | for i = 0 to String.length str - 1 do 17 | if String.unsafe_get str i != '\x00' then raise_notrace Not_found; 18 | done; 19 | Error (`Fatal (`Handshake (`BadDH "all zero"))) 20 | with Not_found -> Ok str 21 | 22 | let dh_shared secret share = 23 | (* RFC 8556, Section 7.4.1 - we need zero-padding on the left *) 24 | let map_ecdh_error = 25 | Result.map_error (fun e -> `Fatal (`Handshake (`BadECDH e))) 26 | in 27 | let open Mirage_crypto_ec in 28 | not_all_zero 29 | (match secret with 30 | | `Finite_field secret -> 31 | let group = secret.Mirage_crypto_pk.Dh.group in 32 | let bits = Mirage_crypto_pk.Dh.modulus_size group in 33 | let* () = 34 | (* truncated share, better reject this *) 35 | guard (String.length share = cdiv bits 8) 36 | (`Fatal (`Handshake (`BadDH "truncated"))) 37 | in 38 | let* shared = 39 | Option.to_result 40 | ~none:(`Fatal (`Handshake (`BadDH "invalid FF"))) 41 | (Mirage_crypto_pk.Dh.shared secret share) 42 | in 43 | Ok (left_pad_dh group shared) 44 | | `P256 priv -> map_ecdh_error (P256.Dh.key_exchange priv share) 45 | | `P384 priv -> map_ecdh_error (P384.Dh.key_exchange priv share) 46 | | `P521 priv -> map_ecdh_error (P521.Dh.key_exchange priv share) 47 | | `X25519 priv -> map_ecdh_error (X25519.key_exchange priv share)) 48 | 49 | let dh_gen_key group = 50 | (* RFC 8556, Section 4.2.8.1 - we need zero-padding on the left *) 51 | match Core.group_to_impl group with 52 | | `Finite_field mc_group -> 53 | let sec, shared = Mirage_crypto_pk.Dh.gen_key mc_group in 54 | `Finite_field sec, left_pad_dh mc_group shared 55 | | `P256 -> 56 | let secret, shared = Mirage_crypto_ec.P256.Dh.gen_key () in 57 | `P256 secret, shared 58 | | `P384 -> 59 | let secret, shared = Mirage_crypto_ec.P384.Dh.gen_key () in 60 | `P384 secret, shared 61 | | `P521 -> 62 | let secret, shared = Mirage_crypto_ec.P521.Dh.gen_key () in 63 | `P521 secret, shared 64 | | `X25519 -> 65 | let secret, shared = Mirage_crypto_ec.X25519.gen_key () in 66 | `X25519 secret, shared 67 | 68 | let trace tag cs = Tracing.cs ~tag:("crypto " ^ tag) cs 69 | 70 | let pp_hash_k_n ciphersuite = 71 | let open Ciphersuite in 72 | let pp = privprot13 ciphersuite 73 | and hash = hash13 ciphersuite 74 | in 75 | let k, n = kn_13 pp in 76 | (pp, hash, k, n) 77 | 78 | let hkdflabel label context length = 79 | let lbl = "tls13 " ^ label in 80 | let len_llen = Bytes.create 3 in 81 | Bytes.set_uint16_be len_llen 0 length; 82 | Bytes.set_uint8 len_llen 2 (String.length lbl); 83 | let clen = String.make 1 (Char.unsafe_chr (String.length context)) in 84 | let lbl = String.concat "" 85 | [ Bytes.unsafe_to_string len_llen ; 86 | lbl ; 87 | clen ; 88 | context ] 89 | in 90 | trace "hkdflabel" lbl ; 91 | lbl 92 | 93 | let derive_secret_no_hash hash prk ?length ?(ctx = "") label = 94 | let length = match length with 95 | | None -> 96 | let module H = (val Digestif.module_of_hash' hash) in 97 | H.digest_size 98 | | Some x -> x 99 | in 100 | let info = hkdflabel label ctx length in 101 | trace "prk" prk ; 102 | let key = Hkdf.expand ~hash ~prk ~info length in 103 | trace ("derive_secret: " ^ label) key ; 104 | key 105 | 106 | let derive_secret t label log = 107 | let module H = (val Digestif.module_of_hash' t.State.hash) in 108 | let ctx = H.(to_raw_string (digest_string log)) in 109 | trace "derive secret ctx" ctx ; 110 | derive_secret_no_hash t.State.hash t.State.secret ~ctx label 111 | 112 | let empty cipher = { 113 | State.secret = "" ; 114 | cipher ; 115 | hash = Ciphersuite.hash13 cipher 116 | } 117 | 118 | let derive t secret_ikm = 119 | let salt = 120 | if String.equal t.State.secret "" then 121 | "" 122 | else 123 | derive_secret t "derived" "" 124 | in 125 | trace "derive: secret_ikm" secret_ikm ; 126 | trace "derive: salt" salt ; 127 | let secret = Hkdf.extract ~hash:t.State.hash ~salt secret_ikm in 128 | trace "derive (extracted secret)" secret ; 129 | { t with State.secret } 130 | 131 | let traffic_key cipher prk = 132 | let _, hash, key_len, iv_len = pp_hash_k_n cipher in 133 | let key_info = hkdflabel "key" "" key_len in 134 | let key = Hkdf.expand ~hash ~prk ~info:key_info key_len in 135 | let iv_info = hkdflabel "iv" "" iv_len in 136 | let iv = Hkdf.expand ~hash ~prk ~info:iv_info iv_len in 137 | (key, iv) 138 | 139 | let ctx t label secret = 140 | let secret, nonce = traffic_key t.State.cipher secret in 141 | trace (label ^ " secret") secret ; 142 | trace (label ^ " nonce") nonce ; 143 | let pp = Ciphersuite.privprot13 t.State.cipher in 144 | { State.sequence = 0L ; cipher_st = Crypto.Ciphers.get_aead_cipher ~secret ~nonce pp } 145 | 146 | let early_traffic t log = 147 | let secret = derive_secret t "c e traffic" log in 148 | (secret, ctx t "client early traffic" secret) 149 | 150 | let hs_ctx t log = 151 | Tracing.cs ~tag:"hs ctx with sec" t.State.secret ; 152 | Tracing.cs ~tag:"log is" log ; 153 | let server_handshake_traffic_secret = derive_secret t "s hs traffic" log 154 | and client_handshake_traffic_secret = derive_secret t "c hs traffic" log 155 | in 156 | (server_handshake_traffic_secret, 157 | ctx t "server handshake traffic" server_handshake_traffic_secret, 158 | client_handshake_traffic_secret, 159 | ctx t "client handshake traffic" client_handshake_traffic_secret) 160 | 161 | let app_ctx t log = 162 | let server_application_traffic_secret = derive_secret t "s ap traffic" log 163 | and client_application_traffic_secret = derive_secret t "c ap traffic" log 164 | in 165 | (server_application_traffic_secret, 166 | ctx t "server application traffic" server_application_traffic_secret, 167 | client_application_traffic_secret, 168 | ctx t "client application traffic" client_application_traffic_secret) 169 | 170 | let app_secret_n_1 t app_secret = 171 | let secret = derive_secret_no_hash t.State.hash app_secret "traffic upd" in 172 | secret, ctx t "traffic update" secret 173 | 174 | let exporter t log = derive_secret t "exp master" log 175 | let resumption t log = derive_secret t "res master" log 176 | 177 | let res_secret hash secret nonce = 178 | derive_secret_no_hash hash secret ~ctx:nonce "resumption" 179 | 180 | let finished hash secret data = 181 | let module H = (val Digestif.module_of_hash' hash) in 182 | let key = derive_secret_no_hash hash secret "finished" in 183 | H.(to_raw_string (hmac_string ~key (to_raw_string (digest_string data)))) 184 | -------------------------------------------------------------------------------- /lib/config.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | (** Configuration of the TLS stack *) 4 | 5 | (** {1 Config type} *) 6 | 7 | (** certificate chain and private key of the first certificate *) 8 | type certchain = X509.Certificate.t list * X509.Private_key.t 9 | 10 | (** polymorphic variant of own certificates *) 11 | type own_cert = [ 12 | | `None 13 | | `Single of certchain 14 | | `Multiple of certchain list 15 | | `Multiple_default of certchain * certchain list 16 | ] 17 | 18 | type session_cache = SessionID.t -> epoch_data option 19 | 20 | type ticket_cache = { 21 | lookup : string -> (psk13 * epoch_data) option ; 22 | ticket_granted : psk13 -> epoch_data -> unit ; 23 | lifetime : int32 ; 24 | timestamp : unit -> Ptime.t 25 | } 26 | 27 | (** configuration parameters *) 28 | type config = private { 29 | ciphers : Ciphersuite.ciphersuite list ; (** ordered list (regarding preference) of supported cipher suites *) 30 | protocol_versions : tls_version * tls_version ; (** supported protocol versions (min, max) *) 31 | signature_algorithms : signature_algorithm list ; (** ordered list of supported signature algorithms (regarding preference) *) 32 | use_reneg : bool ; (** endpoint should accept renegotiation requests *) 33 | authenticator : X509.Authenticator.t option ; (** optional X509 authenticator *) 34 | peer_name : [ `host ] Domain_name.t option ; (** optional name of other endpoint (used for SNI RFC4366) *) 35 | own_certificates : own_cert ; (** optional default certificate chain and other certificate chains *) 36 | acceptable_cas : X509.Distinguished_name.t list ; (** ordered list of acceptable certificate authorities *) 37 | session_cache : session_cache ; 38 | ticket_cache : ticket_cache option ; 39 | cached_session : epoch_data option ; 40 | cached_ticket : (psk13 * epoch_data) option ; 41 | alpn_protocols : string list ; (** optional ordered list of accepted alpn_protocols *) 42 | groups : group list ; (** the first FFDHE will be used for TLS 1.2 and below if a DHE ciphersuite is used *) 43 | zero_rtt : int32 ; 44 | ip : Ipaddr.t option ; 45 | } 46 | 47 | (** [ciphers13 config] are the ciphersuites for TLS 1.3 in the configuration. *) 48 | val ciphers13 : config -> Ciphersuite.ciphersuite13 list 49 | 50 | (** opaque type of a client configuration *) 51 | type client 52 | 53 | (** opaque type of a server configuration *) 54 | type server 55 | 56 | (** {1 Constructors} *) 57 | 58 | (** [client authenticator ?peer_name ?ciphers ?version ?hashes ?reneg ?certificates ?alpn_protocols] is 59 | [client] configuration with the given parameters. Returns an error if the configuration is invalid. *) 60 | val client : 61 | authenticator : X509.Authenticator.t -> 62 | ?peer_name : [ `host ] Domain_name.t -> 63 | ?ciphers : Ciphersuite.ciphersuite list -> 64 | ?version : tls_version * tls_version -> 65 | ?signature_algorithms : signature_algorithm list -> 66 | ?reneg : bool -> 67 | ?certificates : own_cert -> 68 | ?cached_session : epoch_data -> 69 | ?cached_ticket : psk13 * epoch_data -> 70 | ?ticket_cache : ticket_cache -> 71 | ?alpn_protocols : string list -> 72 | ?groups : group list -> 73 | ?ip : Ipaddr.t -> 74 | unit -> (client, [> `Msg of string ]) result 75 | 76 | (** [server ?ciphers ?version ?hashes ?reneg ?certificates ?acceptable_cas ?authenticator ?alpn_protocols] 77 | is [server] configuration with the given parameters. Returns an error if the configuration is invalid. *) 78 | val server : 79 | ?ciphers : Ciphersuite.ciphersuite list -> 80 | ?version : tls_version * tls_version -> 81 | ?signature_algorithms : signature_algorithm list -> 82 | ?reneg : bool -> 83 | ?certificates : own_cert -> 84 | ?acceptable_cas : X509.Distinguished_name.t list -> 85 | ?authenticator : X509.Authenticator.t -> 86 | ?session_cache : session_cache -> 87 | ?ticket_cache : ticket_cache -> 88 | ?alpn_protocols : string list -> 89 | ?groups : group list -> 90 | ?zero_rtt : int32 -> 91 | ?ip : Ipaddr.t -> 92 | unit -> (server, [> `Msg of string ]) result 93 | 94 | (** [peer client name] is [client] with [name] as [peer_name] *) 95 | val peer : client -> [ `host ] Domain_name.t -> client 96 | 97 | (** {1 Note on ALPN protocol selection} 98 | 99 | Both {!val:client} and {!val:server} constructors accept an [alpn_protocols] list. The list for server 100 | should be given in a descending order of preference. In the case of protocol selection, the server will 101 | iterate its list and select the first element that the client's list also advertises. 102 | 103 | For example, if the client advertises [["foo"; "bar"; "baz"]] and the server has [["bar"; "foo"]], 104 | ["bar"] will be selected as the protocol of the handshake. *) 105 | 106 | (** {1 Utility functions} *) 107 | 108 | (** [default_signature_algorithms] is a list of signature algorithms used by default *) 109 | val default_signature_algorithms : signature_algorithm list 110 | 111 | (** [supported_signature_algorithms] is a list of supported signature algorithms by this library *) 112 | val supported_signature_algorithms : signature_algorithm list 113 | 114 | (** [min_dh_size] is minimal diffie hellman group size in bits (currently 1024) *) 115 | val min_dh_size : int 116 | 117 | (** [supported_groups] are the Diffie-Hellman groups supported in this 118 | library. *) 119 | val supported_groups : group list 120 | 121 | (** [elliptic_curve group] is [true] if group is an elliptic curve, [false] 122 | otherwise. *) 123 | val elliptic_curve : group -> bool 124 | 125 | (** [min_rsa_key_size] is minimal RSA modulus key size in bits (currently 1024) *) 126 | val min_rsa_key_size : int 127 | 128 | (** Cipher selection *) 129 | module Ciphers : sig 130 | 131 | open Ciphersuite 132 | 133 | (** Cipher selection related utilities. *) 134 | 135 | (** {1 Cipher selection} *) 136 | 137 | val default : ciphersuite list 138 | (** [default] is a list of ciphersuites this library uses by default. *) 139 | 140 | val supported : ciphersuite list 141 | (** [supported] is a list of ciphersuites this library supports 142 | (larger than [default]). *) 143 | 144 | val fs : ciphersuite list 145 | (** [fs] is a list of ciphersuites which provide forward secrecy 146 | (sublist of [default]). *) 147 | 148 | val http2 : ciphersuite list 149 | (** [http2] is a list of ciphersuites which are allowed to be used with HTTP2: 150 | not a member of 151 | {{:https://httpwg.org/specs/rfc7540.html#BadCipherSuites}bad cipher 152 | suites}. These are only ephemeral key exchanges with AEAD ciphers. *) 153 | 154 | val fs_of : ciphersuite list -> ciphersuite list 155 | (** [fs_of ciphers] selects all ciphersuites which provide forward 156 | secrecy from [ciphers]. *) 157 | end 158 | 159 | (** {1 Internal use only} *) 160 | 161 | (** [of_client client] is a client configuration for [client] *) 162 | val of_client : client -> config 163 | 164 | (** [of_server server] is a server configuration for [server] *) 165 | val of_server : server -> config 166 | 167 | (** [with_authenticator config auth] is [config] with [auth] as [authenticator] *) 168 | val with_authenticator : config -> X509.Authenticator.t -> config 169 | 170 | (** [with_own_certificates config cert] is [config] with [cert] as [own_cert] *) 171 | val with_own_certificates : config -> own_cert -> config 172 | 173 | (** [with_acceptable_cas config cas] is [config] with [cas] as [accepted_cas] *) 174 | val with_acceptable_cas : config -> X509.Distinguished_name.t list -> config 175 | -------------------------------------------------------------------------------- /lib/engine.mli: -------------------------------------------------------------------------------- 1 | (** Transport layer security 2 | 3 | [TLS] is an implementation of 4 | {{:https://en.wikipedia.org/wiki/Transport_Layer_Security}transport 5 | layer security} in OCaml. TLS is a widely used security protocol 6 | which establishes an end-to-end secure channel (with optional 7 | (mutual) authentication) between two endpoints. It uses TCP/IP as 8 | transport. This library supports all four versions of TLS: 9 | {{:https://tools.ietf.org/html/rfc8446}1.3, RFC8446}, 10 | {{:https://tools.ietf.org/html/rfc5246}1.2, RFC5246}, 11 | {{:https://tools.ietf.org/html/rfc4346}1.1, RFC4346}, and 12 | {{:https://tools.ietf.org/html/rfc2246}1.0, RFC2246}. SSL, the 13 | previous protocol definition, is not supported. 14 | 15 | TLS is algorithmically agile: protocol version, key exchange 16 | algorithm, symmetric cipher, and message authentication code are 17 | negotiated upon connection. 18 | 19 | This library implements several extensions of TLS, 20 | {{:https://tools.ietf.org/html/rfc3268}AES ciphers}, 21 | {{:https://tools.ietf.org/html/rfc4366}TLS extensions} (such as 22 | server name indication, SNI), 23 | {{:https://tools.ietf.org/html/rfc5746}Renegotiation extension}, 24 | {{:https://tools.ietf.org/html/rfc7627}Session Hash and Extended 25 | Master Secret Extension}. 26 | 27 | This library does not contain insecure cipher suites (such as 28 | single DES, export ciphers, ...). It does not expose the server 29 | time in the server random, requires secure renegotiation. 30 | 31 | This library consists of a core, implemented in a purely 32 | functional matter ({!Engine}, this module), and effectful parts: 33 | {!Tls_lwt} and {!Tls_mirage}. 34 | 35 | {e %%VERSION%%} *) 36 | 37 | 38 | (** {1 Abstract state type} *) 39 | 40 | (** The abstract type of a TLS state. *) 41 | type state 42 | 43 | (** {1 Constructors} *) 44 | 45 | (** [client client] is [tls * out] where [tls] is the initial state, 46 | and [out] the initial client hello *) 47 | val client : Config.client -> (state * string) 48 | 49 | (** [server server] is [tls] where [tls] is the initial server 50 | state *) 51 | val server : Config.server -> state 52 | 53 | (** {1 Protocol failures} *) 54 | 55 | (** failures which can be mitigated by reconfiguration *) 56 | type error = [ 57 | | `AuthenticationFailure of X509.Validation.validation_error 58 | | `NoConfiguredCiphersuite of Ciphersuite.ciphersuite list 59 | | `NoConfiguredVersions of Core.tls_version list 60 | | `NoConfiguredSignatureAlgorithm of Core.signature_algorithm list 61 | | `NoMatchingCertificateFound of string 62 | | `CouldntSelectCertificate 63 | ] 64 | 65 | (** failures from received garbage or lack of features *) 66 | type fatal = [ 67 | | `Protocol_version of [ 68 | | `None_supported of Core.tls_any_version list 69 | | `Unknown_record of int * int 70 | | `Bad_record of Core.tls_any_version 71 | ] 72 | | `Unexpected of [ 73 | | `Content_type of int 74 | | `Message of string 75 | | `Handshake of Core.tls_handshake 76 | ] 77 | | `Decode of string 78 | | `Handshake of [ 79 | | `Message of string 80 | | `Fragments 81 | | `BadDH of string 82 | | `BadECDH of Mirage_crypto_ec.error 83 | ] 84 | | `Bad_certificate of string 85 | | `Missing_extension of string 86 | | `Bad_mac 87 | | `Record_overflow of int 88 | | `Unsupported_extension 89 | | `Inappropriate_fallback 90 | | `No_application_protocol 91 | ] 92 | 93 | (** type of failures *) 94 | type failure = [ 95 | | `Error of error 96 | | `Fatal of fatal 97 | | `Alert of Packet.alert_type 98 | ] 99 | 100 | (** [alert_of_failure failure] is [alert], the TLS alert type for this failure. *) 101 | val alert_of_failure : failure -> Packet.alert_level * Packet.alert_type 102 | 103 | (** [string_of_failure failure] is [string], the string representation of the [failure]. *) 104 | val string_of_failure : failure -> string 105 | 106 | (** [pp_failure failure] pretty-prints failure. *) 107 | val pp_failure : failure Fmt.t 108 | 109 | (** {1 Protocol handling} *) 110 | 111 | (** result type of {!handle_tls}: either failed to handle the incoming 112 | buffer ([`Fail]) with {!failure} and potentially a message to send 113 | to the other endpoint, or sucessful operation ([`Ok]) with a new 114 | {!state}, an end of file ([`Eof]), or an incoming ([`Alert]). 115 | Possibly some [`Response] to the other endpoint is needed, and 116 | potentially some [`Data] for the application was received. *) 117 | type ret = 118 | (state * [ `Eof ] option 119 | * [ `Response of string option ] 120 | * [ `Data of string option ], 121 | failure * [ `Response of string ]) result 122 | 123 | (** [handle_tls state buffer] is [ret], depending on incoming [state] 124 | and [buffer], the result is the appropriate {!ret} *) 125 | val handle_tls : state -> string -> ret 126 | 127 | (** [handshake_in_progrss state] is a predicate which indicates whether there 128 | is a handshake in progress or scheduled. *) 129 | val handshake_in_progress : state -> bool 130 | 131 | (** [send_application_data tls outs] is [Some (tls', out)] where 132 | [tls'] is the new tls state, and [out] the cstruct to send over the 133 | wire (encrypted [outs]) when the TLS session is ready. When the TLS 134 | session is not ready it is [None]. *) 135 | val send_application_data : state -> string list -> (state * string) option 136 | 137 | (** [send_close_notify tls] is [tls' * out] where [tls'] is the new 138 | tls state, and out the (possible encrypted) close notify alert. *) 139 | val send_close_notify : state -> state * string 140 | 141 | (** [reneg ~authenticator ~acceptable_cas ~cert tls] initiates a renegotation on 142 | [tls], using the provided [authenticator]. It is [tls' * out] where [tls'] 143 | is the new tls state, and [out] either a client hello or hello request 144 | (depending on which communication endpoint [tls] is). *) 145 | val reneg : ?authenticator:X509.Authenticator.t -> 146 | ?acceptable_cas:X509.Distinguished_name.t list -> ?cert:Config.own_cert -> 147 | state -> (state * string) option 148 | 149 | (** [key_update ~request state] initiates a KeyUpdate (TLS 1.3 only). If 150 | [request] is provided and [true] (the default), the KeyUpdate message 151 | contains a request that the peer should update their traffic key as well. *) 152 | val key_update : ?request:bool -> state -> (state * string, failure) result 153 | 154 | (** {1 Session information} *) 155 | 156 | (** [epoch state] is [epoch], which contains the session 157 | information. If there's no established session yet, an error is returned. *) 158 | val epoch : state -> (Core.epoch_data, unit) result 159 | 160 | (** [export_key_material epoch_data ?context label length] is the RFC 5705 161 | exported key material of [length] bytes using [label] and, if provided, 162 | [context]. *) 163 | val export_key_material : Core.epoch_data -> ?context:string -> string -> int -> 164 | string 165 | 166 | (** [channel_binding epoch_data mode] is the RFC 5929 and RFC 9266 specified 167 | channel binding. Please note that [`Tls_unique] will error for TLS 1.3 168 | sessions, and [`Tls_exporter] is not recommended for TLS < 1.3 sessions 169 | (unless the uniqueness is ensured via another path). *) 170 | val channel_binding : Core.epoch_data -> 171 | [ `Tls_exporter | `Tls_unique | `Tls_server_endpoint ] -> 172 | (string, [ `Msg of string ]) result 173 | -------------------------------------------------------------------------------- /async/x509_async.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | let file_contents file = 5 | Deferred.Or_error.try_with ~name:(sprintf "read %s" file) (fun () -> 6 | Reader.file_contents file) 7 | ;; 8 | 9 | let load_all_in_directory ~directory ~f = 10 | let open Deferred.Or_error.Let_syntax in 11 | let%bind files = Deferred.Or_error.try_with (fun () -> Sys.ls_dir directory) in 12 | Deferred.Or_error.List.map ~how:`Sequential files ~f:(fun file -> 13 | let%bind contents = file_contents (directory ^/ file) in 14 | f ~contents) 15 | ;; 16 | 17 | module Or_error = struct 18 | include Or_error 19 | 20 | let of_result ~to_string = Result.map_error ~f:(Fn.compose Error.of_string to_string) 21 | let of_result_msg x = of_result x ~to_string:(fun (`Msg msg) -> msg) 22 | 23 | let lift_result_msg_of_string f ~contents = 24 | f contents |> of_result_msg 25 | ;; 26 | 27 | let lift_asn_error_of_string f ~contents = 28 | f contents |> of_result ~to_string:(fun (`Parse msg) -> msg) 29 | ;; 30 | end 31 | 32 | module CRL = struct 33 | include X509.CRL 34 | 35 | let decode_der = Or_error.lift_result_msg_of_string decode_der 36 | 37 | let revoke ?digest ~issuer ~this_update ?next_update ?extensions revoked_certs key = 38 | revoke ?digest ~issuer ~this_update ?next_update ?extensions revoked_certs key 39 | |> Or_error.of_result_msg 40 | ;; 41 | 42 | let revoke_certificate revoked ~this_update ?next_update crl key = 43 | revoke_certificate revoked ~this_update ?next_update crl key |> Or_error.of_result_msg 44 | ;; 45 | 46 | let revoke_certificates revoked ~this_update ?next_update crl key = 47 | revoke_certificates revoked ~this_update ?next_update crl key 48 | |> Or_error.of_result_msg 49 | ;; 50 | 51 | let of_pem_dir ~directory = 52 | load_all_in_directory ~directory ~f:(fun ~contents -> 53 | decode_der ~contents |> Deferred.return) 54 | ;; 55 | end 56 | 57 | module Certificate = struct 58 | include X509.Certificate 59 | open Deferred.Or_error.Let_syntax 60 | 61 | let decode_pem_multiple = Or_error.lift_result_msg_of_string decode_pem_multiple 62 | let decode_pem = Or_error.lift_result_msg_of_string decode_pem 63 | let decode_der = Or_error.lift_result_msg_of_string decode_der 64 | 65 | let of_pem_file ca_file = 66 | let%bind contents = file_contents ca_file in 67 | decode_pem_multiple ~contents |> Deferred.return 68 | ;; 69 | 70 | let of_pem_directory ~directory = 71 | load_all_in_directory ~directory ~f:(fun ~contents -> 72 | decode_pem_multiple ~contents |> Deferred.return) 73 | >>| List.concat 74 | ;; 75 | end 76 | 77 | module Authenticator = struct 78 | include X509.Authenticator 79 | 80 | module Param = struct 81 | module Chain_of_trust = struct 82 | type t = 83 | { trust_anchors : [ `File of Filename.t | `Directory of Filename.t ] 84 | ; allowed_hashes : Digestif.hash' list option 85 | ; crls : Filename.t option 86 | } 87 | 88 | let to_certs = function 89 | | `File file -> Certificate.of_pem_file file 90 | | `Directory directory -> Certificate.of_pem_directory ~directory 91 | ;; 92 | end 93 | 94 | type t = 95 | | Chain_of_trust of Chain_of_trust.t 96 | | Cert_fingerprint of Digestif.hash' * string 97 | | Key_fingerprint of Digestif.hash' * string 98 | 99 | let ca_file ?allowed_hashes ?crls filename () = 100 | let trust_anchors = `File filename in 101 | Chain_of_trust { trust_anchors; allowed_hashes; crls } 102 | ;; 103 | 104 | let ca_dir ?allowed_hashes ?crls directory_name () = 105 | let trust_anchors = `Directory directory_name in 106 | Chain_of_trust { trust_anchors; allowed_hashes; crls } 107 | ;; 108 | 109 | let cert_fingerprint hash fingerprint = Cert_fingerprint (hash, fingerprint) 110 | 111 | let key_fingerprint hash fingerprint = Key_fingerprint (hash, fingerprint) 112 | 113 | let cleanup_fingerprint fingerprint = 114 | let known_delimiters = [ ':'; ' ' ] in 115 | String.filter fingerprint ~f:(fun c -> 116 | not (List.exists known_delimiters ~f:(Char.equal c))) 117 | |> Ohex.decode 118 | ;; 119 | 120 | let of_cas ~time ({ trust_anchors; allowed_hashes; crls } : Chain_of_trust.t) = 121 | let open Deferred.Or_error.Let_syntax in 122 | let%bind cas = Chain_of_trust.to_certs trust_anchors in 123 | let%map crls = 124 | match crls with 125 | | Some directory -> 126 | let%map crls = CRL.of_pem_dir ~directory in 127 | Some crls 128 | | None -> return None 129 | in 130 | X509.Authenticator.chain_of_trust ?allowed_hashes ?crls ~time cas 131 | ;; 132 | 133 | let of_cert_fingerprint ~time hash fingerprint = 134 | let fingerprint = cleanup_fingerprint fingerprint in 135 | X509.Authenticator.cert_fingerprint ~time ~hash ~fingerprint 136 | ;; 137 | 138 | let of_key_fingerprint ~time hash fingerprint = 139 | let fingerprint = cleanup_fingerprint fingerprint in 140 | X509.Authenticator.key_fingerprint ~time ~hash ~fingerprint 141 | ;; 142 | 143 | let time = Fn.compose Ptime.of_float_s Unix.gettimeofday 144 | 145 | let to_authenticator ~time param = 146 | match param with 147 | | Chain_of_trust chain_of_trust -> of_cas ~time chain_of_trust 148 | | Cert_fingerprint (hash, fingerprint) -> 149 | of_cert_fingerprint ~time hash fingerprint |> Deferred.Or_error.return 150 | | Key_fingerprint (hash, fingerprint) -> 151 | of_key_fingerprint ~time hash fingerprint |> Deferred.Or_error.return 152 | ;; 153 | end 154 | end 155 | 156 | module Distinguished_name = struct 157 | include X509.Distinguished_name 158 | 159 | let decode_der = Or_error.lift_result_msg_of_string decode_der 160 | end 161 | 162 | module OCSP = struct 163 | include X509.OCSP 164 | 165 | module Request = struct 166 | include Request 167 | 168 | let create ?certs ?digest ?requestor_name ?key cert_ids = 169 | create ?certs ?digest ?requestor_name ?key cert_ids |> Or_error.of_result_msg 170 | ;; 171 | 172 | let decode_der = Or_error.lift_asn_error_of_string decode_der 173 | end 174 | 175 | module Response = struct 176 | include Response 177 | 178 | let create_success 179 | ?digest 180 | ?certs 181 | ?response_extensions 182 | private_key 183 | responderID 184 | producedAt 185 | responses 186 | = 187 | create_success 188 | ?digest 189 | ?certs 190 | ?response_extensions 191 | private_key 192 | responderID 193 | producedAt 194 | responses 195 | |> Or_error.of_result_msg 196 | ;; 197 | 198 | let responses t = responses t |> Or_error.of_result_msg 199 | let decode_der = Or_error.lift_asn_error_of_string decode_der 200 | end 201 | end 202 | 203 | module PKCS12 = struct 204 | include X509.PKCS12 205 | 206 | let decode_der = Or_error.lift_result_msg_of_string decode_der 207 | let verify password t = verify password t |> Or_error.of_result_msg 208 | end 209 | 210 | module Private_key = struct 211 | include X509.Private_key 212 | 213 | let sign hash ?scheme key data = 214 | sign hash ?scheme key data 215 | |> Or_error.of_result_msg 216 | ;; 217 | 218 | let decode_der = Or_error.lift_result_msg_of_string decode_der 219 | let decode_pem = Or_error.lift_result_msg_of_string decode_pem 220 | 221 | let of_pem_file file = 222 | let%map contents = Reader.file_contents file in 223 | decode_pem ~contents 224 | ;; 225 | end 226 | 227 | module Public_key = struct 228 | include X509.Public_key 229 | 230 | let verify hash ?scheme ~signature key data = 231 | verify hash ?scheme ~signature key data |> Or_error.of_result_msg 232 | ;; 233 | 234 | let decode_der = Or_error.lift_result_msg_of_string decode_der 235 | let decode_pem = Or_error.lift_result_msg_of_string decode_pem 236 | end 237 | 238 | module Signing_request = struct 239 | include X509.Signing_request 240 | 241 | let decode_der ?allowed_hashes der = 242 | decode_der ?allowed_hashes der |> Or_error.of_result_msg 243 | ;; 244 | 245 | let decode_pem pem = decode_pem pem |> Or_error.of_result_msg 246 | 247 | let create subject ?digest ?extensions key = 248 | create subject ?digest ?extensions key |> Or_error.of_result_msg 249 | ;; 250 | 251 | let sign 252 | ?allowed_hashes 253 | ?digest 254 | ?serial 255 | ?extensions 256 | t 257 | key 258 | issuer 259 | ~valid_from 260 | ~valid_until 261 | = 262 | sign ?allowed_hashes ?digest ?serial ?extensions t key issuer ~valid_from ~valid_until 263 | |> Or_error.of_result ~to_string:(Fmt.to_to_string X509.Validation.pp_signature_error) 264 | ;; 265 | end 266 | 267 | module Extension = X509.Extension 268 | module General_name = X509.General_name 269 | module Host = X509.Host 270 | module Key_type = X509.Key_type 271 | module Validation = X509.Validation 272 | -------------------------------------------------------------------------------- /eio/tls_eio.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | module Flow = Eio.Flow 4 | 5 | exception Tls_alert of Tls.Packet.alert_type 6 | exception Tls_failure of Tls.Engine.failure 7 | 8 | type Eio.Exn.Backend.t += Tls_socket_closed 9 | let () = Eio.Exn.Backend.register_pp (fun f -> function 10 | | Tls_socket_closed -> Fmt.pf f "TLS_socket_closed"; true 11 | | _ -> false 12 | ) 13 | 14 | type ty = [ `Tls | Eio.Flow.two_way_ty | Eio.Resource.close_ty ] 15 | type t = ty r 16 | 17 | module Raw = struct 18 | 19 | (* We could replace [`Eof] with [`Error End_of_file] and then use 20 | a regular [result] type here. *) 21 | type t = { 22 | flow : [Flow.two_way_ty | Eio.Resource.close_ty] r; 23 | mutable state : [ `Active of Tls.Engine.state 24 | | `Read_closed of Tls.Engine.state 25 | | `Write_closed of Tls.Engine.state 26 | | `Closed 27 | | `Error of exn ] ; 28 | mutable linger : Cstruct.t option ; 29 | recv_buf : Cstruct.t ; 30 | } 31 | 32 | let half_close state mode = 33 | match state, mode with 34 | | `Active tls, `read -> `Read_closed tls 35 | | `Active tls, `write -> `Write_closed tls 36 | | `Active _, `read_write -> `Closed 37 | | `Read_closed tls, `read -> `Read_closed tls 38 | | `Read_closed _, (`write | `read_write) -> `Closed 39 | | `Write_closed tls, `write -> `Write_closed tls 40 | | `Write_closed _, (`read | `read_write) -> `Closed 41 | | (`Closed | `Error _) as e, (`read | `write | `read_write) -> e 42 | 43 | let inject_state tls = function 44 | | `Active _ -> `Active tls 45 | | `Read_closed _ -> `Read_closed tls 46 | | `Write_closed _ -> `Write_closed tls 47 | | (`Closed | `Error _) as e -> e 48 | 49 | let write_t t s = 50 | try Flow.copy_string s t.flow 51 | with exn -> 52 | (match t.state with 53 | | `Error _ -> () 54 | | _ -> t.state <- `Error exn) ; 55 | raise exn 56 | 57 | let try_write_t t cs = 58 | try write_t t cs 59 | with _ -> Eio.Fiber.check () (* Error is in [t.state] *) 60 | 61 | let rec read_react t = 62 | 63 | let handle tls buf = 64 | match Tls.Engine.handle_tls tls buf with 65 | | Ok (state', eof, `Response resp, `Data data) -> 66 | let state' = inject_state state' t.state in 67 | let state' = Option.(value ~default:state' (map (fun `Eof -> half_close state' `read) eof)) in 68 | t.state <- state' ; 69 | Option.iter (try_write_t t) resp; 70 | Option.map Cstruct.of_string data 71 | 72 | | Error (fail, `Response resp) -> 73 | t.state <- `Error (match fail with `Alert a -> Tls_alert a | f -> Tls_failure f) ; 74 | write_t t resp; read_react t 75 | in 76 | 77 | match t.state with 78 | | `Error e -> raise e 79 | | `Closed 80 | | `Read_closed _ -> raise End_of_file 81 | | _ -> 82 | match Flow.single_read t.flow t.recv_buf with 83 | | exception End_of_file -> 84 | t.state <- half_close t.state `read; 85 | raise End_of_file 86 | | exception exn -> 87 | (match t.state with 88 | | `Error _ -> () 89 | | _ -> t.state <- `Error exn) ; 90 | raise exn 91 | | n -> 92 | match t.state with 93 | | `Error e -> raise e 94 | | `Active tls | `Read_closed tls | `Write_closed tls -> 95 | handle tls (Cstruct.to_string t.recv_buf ~off:0 ~len:n) 96 | | `Closed -> raise End_of_file 97 | 98 | let rec single_read t buf = 99 | 100 | let writeout res = 101 | let open Cstruct in 102 | let rlen = length res in 103 | let n = min (length buf) rlen in 104 | blit res 0 buf 0 n ; 105 | t.linger <- 106 | (if n < rlen then Some (sub res n (rlen - n)) else None) ; 107 | n in 108 | 109 | match t.linger with 110 | | Some res -> writeout res 111 | | None -> 112 | match read_react t with 113 | | None -> single_read t buf 114 | | Some res -> writeout res 115 | 116 | let writev t css = 117 | match t.state with 118 | | `Error err -> raise err 119 | | `Write_closed _ | `Closed -> raise (Eio.Net.err (Connection_reset Tls_socket_closed)) 120 | | `Active tls | `Read_closed tls -> 121 | let css = List.map Cstruct.to_string css in 122 | match Tls.Engine.send_application_data tls css with 123 | | Some (tls, tlsdata) -> 124 | ( t.state <- inject_state tls t.state ; write_t t tlsdata ) 125 | | None -> invalid_arg "tls: write: socket not ready" 126 | 127 | let single_write t bufs = 128 | writev t bufs; 129 | Cstruct.lenv bufs 130 | 131 | (* 132 | * XXX bad XXX 133 | * This is a point that should particularly be protected from concurrent r/w. 134 | * Doing this before a `t` is returned is safe; redoing it during rekeying is 135 | * not, as the API client already sees the `t` and can mistakenly interleave 136 | * writes while this is in progress. 137 | * *) 138 | let rec drain_handshake t = 139 | let push_linger t mcs = 140 | match (mcs, t.linger) with 141 | | (None, _) -> () 142 | | (scs, None) -> t.linger <- scs 143 | | (Some cs, Some l) -> t.linger <- Some (Cstruct.append l cs) 144 | in 145 | match t.state with 146 | | `Active tls when not (Tls.Engine.handshake_in_progress tls) -> 147 | t 148 | | _ -> 149 | let cs = read_react t in 150 | push_linger t cs; drain_handshake t 151 | 152 | let reneg ?authenticator ?acceptable_cas ?cert ?(drop = true) t = 153 | match t.state with 154 | | `Error err -> raise err 155 | | `Closed | `Read_closed _ | `Write_closed _ -> invalid_arg "tls: closed socket" 156 | | `Active tls -> 157 | match Tls.Engine.reneg ?authenticator ?acceptable_cas ?cert tls with 158 | | None -> invalid_arg "tls: can't renegotiate" 159 | | Some (tls', buf) -> 160 | if drop then t.linger <- None ; 161 | t.state <- inject_state tls' t.state ; 162 | write_t t buf; 163 | ignore (drain_handshake t : t) 164 | 165 | let key_update ?request t = 166 | match t.state with 167 | | `Error err -> raise err 168 | | `Write_closed _ | `Closed -> invalid_arg "tls: closed socket" 169 | | `Active tls | `Read_closed tls -> 170 | match Tls.Engine.key_update ?request tls with 171 | | Error f -> Fmt.invalid_arg "tls: can't update key: %a" Tls.Engine.pp_failure f 172 | | Ok (tls', buf) -> 173 | t.state <- inject_state tls' t.state ; 174 | write_t t buf 175 | 176 | let shutdown t = function 177 | | `Receive -> () 178 | | `Send | `All -> 179 | match t.state with 180 | | `Active tls | `Read_closed tls -> 181 | let tls', buf = Tls.Engine.send_close_notify tls in 182 | t.state <- inject_state tls' (half_close t.state `write) ; 183 | write_t t buf 184 | | _ -> () 185 | 186 | let server_of_flow config flow = 187 | drain_handshake { 188 | state = `Active (Tls.Engine.server config) ; 189 | flow = (flow :> [Flow.two_way_ty | Eio.Resource.close_ty] r) ; 190 | linger = None ; 191 | recv_buf = Cstruct.create 4096 192 | } 193 | 194 | let client_of_flow config ?host flow = 195 | let config' = match host with 196 | | None -> config 197 | | Some host -> Tls.Config.peer config host 198 | in 199 | let (tls, init) = Tls.Engine.client config' in 200 | let t = { 201 | state = `Active tls ; 202 | flow = (flow :> [Flow.two_way_ty | Eio.Resource.close_ty] r); 203 | linger = None ; 204 | recv_buf = Cstruct.create 4096 205 | } in 206 | write_t t init; 207 | drain_handshake t 208 | 209 | 210 | let epoch t = 211 | match t.state with 212 | | `Active tls | `Read_closed tls | `Write_closed tls -> Tls.Engine.epoch tls 213 | | `Closed | `Error _ -> Error () 214 | 215 | let copy t ~src = Eio.Flow.Pi.simple_copy ~single_write t ~src 216 | 217 | let read_methods = [] 218 | 219 | let close t = Eio.Resource.close t.flow 220 | 221 | type (_, _, _) Eio.Resource.pi += T : ('t, 't -> t, ty) Eio.Resource.pi 222 | end 223 | 224 | let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw.T t 225 | 226 | let handler = 227 | Eio.Resource.handler [ 228 | H (Eio.Flow.Pi.Source, (module Raw)); 229 | H (Eio.Flow.Pi.Sink, (module Raw)); 230 | H (Eio.Flow.Pi.Shutdown, (module Raw)); 231 | H (Eio.Resource.Close, Raw.close); 232 | H (Raw.T, Fun.id); 233 | ] 234 | 235 | let of_t t = Eio.Resource.T (t, handler) 236 | 237 | let server_of_flow config flow = Raw.server_of_flow config flow |> of_t 238 | let client_of_flow config ?host flow = Raw.client_of_flow config ?host flow |> of_t 239 | 240 | let reneg ?authenticator ?acceptable_cas ?cert ?drop (t:t) = Raw.reneg ?authenticator ?acceptable_cas ?cert ?drop (raw t) 241 | let key_update ?request (t:t) = Raw.key_update ?request (raw t) 242 | let epoch (t:t) = Raw.epoch (raw t) 243 | 244 | let () = 245 | Printexc.register_printer (function 246 | | Tls_alert typ -> 247 | Some ("TLS alert from peer: " ^ Tls.Packet.alert_type_to_string typ) 248 | | Tls_failure f -> 249 | Some ("TLS failure: " ^ Tls.Engine.string_of_failure f) 250 | | _ -> None) 251 | -------------------------------------------------------------------------------- /eio/tests/fuzz.ml: -------------------------------------------------------------------------------- 1 | (* Fuzz testing for tls-eio. 2 | 3 | This code picks two random strings, one for the client to send and one for 4 | the server. It then starts a send and receive fiber for each end. 5 | 6 | A dispatcher fiber then sends commands to these worker fibers 7 | (see [action] for the possible actions). 8 | 9 | This is intended to check for bugs in the Eio wrapper (rather than in Tls itself). 10 | At the moment, it's just checking that tls-eio works when used correctly. 11 | Each endpoint overlaps reads with writes (but not reads with other reads or 12 | writes with other writes). 13 | 14 | Some possible future improvements: 15 | 16 | - It currently only checks the basic read/write/close operations. 17 | It should be extended to check [reneg], etc too. 18 | 19 | - Currently, cancelling a read operation marks the Tls flow as broken. 20 | We should allow resuming after a cancelled read, and test that here. 21 | 22 | - We should try injecting faults and make sure they're handled sensibly. 23 | 24 | - It would be good to get coverage reports for these tests. 25 | However, this requires changes to crowbar: 26 | https://github.com/stedolan/crowbar/issues/4#issuecomment-1310277551 27 | (a patched version reported 54% coverage of Tls_eio.ml) *) 28 | 29 | open Eio.Std 30 | 31 | let src = Logs.Src.create "fuzz" ~doc:"Fuzz tests" 32 | module Log = (val Logs.src_log src : Logs.LOG) 33 | 34 | module W = Eio.Buf_write 35 | 36 | type transmit_amount = Mock_socket.transmit_amount 37 | 38 | type op = 39 | | Send of int (* The application sends some bytes to Tls *) 40 | | Transmit of transmit_amount (* The network sends some types to the peer *) 41 | | Recv (* The application tries to read some data *) 42 | | Shutdown_send (* The application shuts down the sending side *) 43 | 44 | let label name gen = 45 | Crowbar.with_printer Fmt.(const string name) gen 46 | 47 | let op = 48 | Crowbar.choose @@ [ 49 | Crowbar.(map [range 4096]) (fun n -> Send n); 50 | Crowbar.(map [range ~min:1 4096]) (fun n -> Transmit (`Bytes n)); 51 | label "recv" @@ Crowbar.const Recv; 52 | label "shutdown-send" @@ Crowbar.const Shutdown_send; 53 | ] 54 | 55 | type dir = To_client | To_server 56 | 57 | let pp_dir f = function 58 | | To_server -> Fmt.string f "client-to-server" 59 | | To_client -> Fmt.string f "server-to-client" 60 | 61 | let dir = 62 | Crowbar.choose [ 63 | label "server-to-client" @@ Crowbar.const To_client; 64 | label "client-to-server" @@ Crowbar.const To_server; 65 | ] 66 | 67 | (* A test case is a random sequence of [action]s, followed by party shutting 68 | down the sending side of the connection (if it hasn't already done so) and 69 | the network draining any queued traffic. 70 | 71 | Once all fibers have finished, we check that what was sent matches the data 72 | that has been received. *) 73 | 74 | let action = 75 | Crowbar.option (Crowbar.pair dir op) (* None means yield *) 76 | 77 | (* A [Path] is one direction (either server-to-client or client-to-server). 78 | The two paths can be tested mostly independently (except for shutdown at the moment). *) 79 | module Path : sig 80 | type t 81 | 82 | val create : 83 | sender:(Tls_eio.t, exn) result Promise.t -> 84 | receiver:(Tls_eio.t, exn) result Promise.t -> 85 | transmit:(transmit_amount -> unit) -> 86 | dir -> string -> t 87 | (** Create a test driver for one direction, from [sender] to [receiver]. 88 | [transmit n] causes [n] bytes to be transferred over the mock network. *) 89 | 90 | val close : t -> unit 91 | (** [close t] causes the sender to close the socket for sending. 92 | Futher send operations will be ignored. *) 93 | 94 | val run : t -> unit 95 | (** Run the send and receive fibers. Returns once the receiver has read EOF. *) 96 | 97 | val enqueue : t -> op -> unit 98 | (** Send a command to the send or receive fiber (depending on [op]). *) 99 | end = struct 100 | type t = { 101 | dir : dir; 102 | message : string; (* The complete message to be transmitted over this path. *) 103 | (* We need to construct [t] before the handshake is done, so these are promises: *) 104 | sender : Tls_eio.t Promise.or_exn; 105 | receiver : Tls_eio.t Promise.or_exn; 106 | mutable sent : int; (* Bytes of [message] sent so far *) 107 | mutable recv : int; (* Bytes of [message] received so far *) 108 | send_commands : [`Send of int | `Exit] Eio.Stream.t; (* Commands for the sending fiber *) 109 | recv_commands : [`Recv | `Drain] Eio.Stream.t; (* Commands for the receiving fiber *) 110 | transmit : transmit_amount -> unit; 111 | } 112 | 113 | let pp_dir f t = 114 | pp_dir f t.dir 115 | 116 | let create ~sender ~receiver ~transmit dir message = 117 | let send_commands = Eio.Stream.create max_int in 118 | let recv_commands = Eio.Stream.create max_int in 119 | { dir; message; sender; receiver; sent = 0; recv = 0; 120 | send_commands; recv_commands; transmit } 121 | 122 | let shutdown t = 123 | Eio.Stream.add t.send_commands `Exit 124 | 125 | let close t = 126 | shutdown t; (* Sender stops sending *) 127 | t.transmit `Drain; (* Network transmits everything *) 128 | Eio.Stream.add t.recv_commands `Drain (* Receiver reads everything *) 129 | 130 | let run_send_thread t = 131 | let sender = Promise.await_exn t.sender in 132 | Logs.info (fun f -> f "%a: sender ready" pp_dir t); 133 | let rec aux () = 134 | match Eio.Stream.take t.send_commands with 135 | | `Exit -> 136 | Log.info (fun f -> f "%a: shutdown send (Tls level)" pp_dir t); 137 | Eio.Flow.shutdown sender `Send 138 | | `Send len -> 139 | let available = String.length t.message - t.sent in 140 | let len = min len available in 141 | if len > 0 then ( 142 | let msg = Cstruct.of_string ~off:t.sent ~len t.message in 143 | t.sent <- t.sent + len; 144 | Log.info (fun f -> f "%a: sending %S" pp_dir t (Cstruct.to_string msg)); 145 | Eio.Flow.write sender [msg]; 146 | ); 147 | aux () 148 | in 149 | aux() 150 | 151 | let run_recv_thread t = 152 | let recv = Promise.await_exn t.receiver in 153 | Logs.info (fun f -> f "%a: receiver ready" pp_dir t); 154 | try 155 | let drain = ref false in 156 | while true do 157 | if !drain = false then ( 158 | begin match Eio.Stream.take t.recv_commands with 159 | | `Recv -> () 160 | | `Drain -> drain := true 161 | end 162 | ); 163 | let buf = Cstruct.create 4096 in 164 | let got = Eio.Flow.single_read recv buf in 165 | let received = Cstruct.to_string buf ~len:got in 166 | Log.info (fun f -> f "%a: received %S" pp_dir t received); 167 | let expected = String.sub t.message t.recv got in 168 | if received <> expected then 169 | Fmt.failwith "%a: excepted %S but got %S!" pp_dir t expected received; 170 | t.recv <- t.recv + got 171 | done 172 | with End_of_file -> 173 | if t.recv <> t.sent then ( 174 | Fmt.failwith "%a: Sender sent %d bytes, but receiver got EOF after reading only %d" 175 | pp_dir t 176 | t.sent 177 | t.recv 178 | ); 179 | Log.info (fun f -> f "%a: recv thread done (got EOF)" pp_dir t) 180 | 181 | let run t = 182 | Fiber.both 183 | (fun () -> run_send_thread t) 184 | (fun () -> run_recv_thread t) 185 | 186 | let pp_amount f = function 187 | | `Bytes n -> Fmt.pf f "%d bytes" n 188 | | `Drain -> Fmt.string f "all bytes" 189 | 190 | let enqueue t = function 191 | | Send i-> 192 | Log.info (fun f -> f "%a: enqueue send %d bytes of plaintext" pp_dir t i); 193 | Eio.Stream.add t.send_commands @@ `Send i; 194 | | Recv -> 195 | Log.info (fun f -> f "%a: enqueue read from Tls" pp_dir t); 196 | Eio.Stream.add t.recv_commands @@ `Recv; 197 | | Transmit i -> 198 | Log.info (fun f -> f "%a: enqueue transmit %a over network" pp_dir t pp_amount i); 199 | t.transmit i 200 | | Shutdown_send -> 201 | Log.info (fun f -> f "%a: enqueue shutdown send" pp_dir t); 202 | shutdown t 203 | end 204 | 205 | module Config : sig 206 | val client : Tls.Config.client 207 | val server : Tls.Config.server 208 | end = struct 209 | let null_auth ?ip:_ ~host:_ _ = Ok None 210 | 211 | let client = 212 | Result.get_ok (Tls.Config.client ~authenticator:null_auth ()) 213 | 214 | let read_file path = 215 | let ch = open_in_bin path in 216 | let len = in_channel_length ch in 217 | let data = really_input_string ch len in 218 | close_in ch; 219 | data 220 | 221 | let server = 222 | let certs = Result.get_ok (X509.Certificate.decode_pem_multiple (read_file "server.pem")) in 223 | let pk = Result.get_ok (X509.Private_key.decode_pem (read_file "server.key")) in 224 | let certificates = `Single (certs, pk) in 225 | Result.get_ok Tls.Config.(server ~version:(`TLS_1_0, `TLS_1_3) ~certificates ~ciphers:Ciphers.supported ()) 226 | end 227 | 228 | let dispatch_commands ~to_server ~to_client actions = 229 | let rec aux = function 230 | | [] -> 231 | Log.info (fun f -> f "dispatch_commands: done"); 232 | Path.close to_client; 233 | Path.close to_server 234 | | None :: xs -> 235 | Fiber.yield (); aux xs 236 | | Some (dir, op) :: xs -> 237 | let path = 238 | match dir with 239 | | To_server-> to_server 240 | | To_client -> to_client 241 | in 242 | Path.enqueue path op; 243 | aux xs 244 | in 245 | aux actions 246 | 247 | (* In some runs we automatically perform these actions first, which allows the handshake to complete. 248 | This lets the fuzz tester get to the interesting cases more quickly. *) 249 | let quickstart_actions = [ 250 | Some (To_server, Transmit (`Bytes 4096)); 251 | None; (* Client sends handshake *) 252 | None; (* Server reads handshake *) 253 | Some (To_client, Transmit (`Bytes 4096)); 254 | None; (* Server replies to handshake *) 255 | None; (* Client reads reply *) 256 | Some (To_server, Transmit (`Bytes 4096)); 257 | None; (* Client sends final part *) 258 | None; (* Server receives it *) 259 | Some (To_client, Recv); 260 | Some (To_server, Recv); 261 | ] 262 | 263 | let main client_message server_message quickstart actions = 264 | let actions = 265 | if quickstart then quickstart_actions @ actions 266 | else actions 267 | in 268 | Eio_mock.Backend.run @@ fun () -> 269 | Switch.run @@ fun sw -> 270 | let insecure_test_rng = Mirage_crypto_rng.create (module Test_rng) in 271 | Mirage_crypto_rng.set_default_generator insecure_test_rng; 272 | let client_socket, server_socket = Mock_socket.create_pair () in 273 | let server_flow = Fiber.fork_promise ~sw (fun () -> Tls_eio.server_of_flow Config.server server_socket) in 274 | let client_flow = Fiber.fork_promise ~sw (fun () -> Tls_eio.client_of_flow Config.client client_socket) in 275 | let to_server = 276 | Path.create 277 | ~sender:client_flow 278 | ~receiver:server_flow 279 | ~transmit:(Mock_socket.transmit client_socket) 280 | To_server client_message in 281 | let to_client = 282 | Path.create 283 | ~sender:server_flow 284 | ~receiver:client_flow 285 | ~transmit:(Mock_socket.transmit server_socket) 286 | To_client server_message 287 | in 288 | Fiber.all [ 289 | (fun () -> dispatch_commands actions ~to_server ~to_client); 290 | (fun () -> Path.run to_server); 291 | (fun () -> Path.run to_client); 292 | ] 293 | 294 | let () = 295 | Logs.set_level (Some Warning); 296 | Logs.set_reporter (Logs_fmt.reporter ()); 297 | Crowbar.(add_test ~name:"random ops" [bytes; bytes; bool; list action] main) 298 | --------------------------------------------------------------------------------