1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
open Core
open Async
open Private_ssl.V2
type addr =
[ `OpenSSL of Ipaddr_sexp.t * int * Ssl.Config.t
| `TCP of Ipaddr_sexp.t * int
| `Unix_domain_socket of string ]
[@@deriving sexp_of]
let connect ?interrupt dst =
match dst with
| `TCP (ip, port) ->
let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
Tcp.connect ?interrupt (Tcp.Where_to_connect.of_host_and_port endp)
>>= fun (_, rd, wr) -> return (rd, wr)
| `OpenSSL (ip, port, cfg) ->
let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
Tcp.connect ?interrupt (Tcp.Where_to_connect.of_host_and_port endp)
>>= fun (_, rd, wr) -> Ssl.connect ~cfg rd wr
| `Unix_domain_socket file ->
Tcp.connect ?interrupt (Tcp.Where_to_connect.of_file file)
>>= fun (_, rd, wr) -> return (rd, wr)
let with_connection ?interrupt dst f =
match dst with
| `TCP (ip, port) ->
let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
Tcp.with_connection ?interrupt
(Tcp.Where_to_connect.of_host_and_port endp) (fun _ rd wr -> f rd wr)
| `OpenSSL (ip, port, cfg) ->
let endp = Host_and_port.create ~host:(Ipaddr.to_string ip) ~port in
Tcp.with_connection ?interrupt
(Tcp.Where_to_connect.of_host_and_port endp) (fun _ rd wr ->
Ssl.connect ~cfg rd wr >>= fun (rd, wr) ->
Monitor.protect
(fun () -> f rd wr)
~finally:(fun () ->
Deferred.all_unit [ Reader.close rd; Writer.close wr ]))
| `Unix_domain_socket file ->
Tcp.with_connection ?interrupt (Tcp.Where_to_connect.of_file file)
(fun _ rd wr -> f rd wr)
type trust_chain =
[ `Ca_file of string
| `Ca_path of string
| `Search_file_first_then_path of [ `File of string ] * [ `Path of string ]
]
[@@deriving sexp]
type openssl =
[ `OpenSSL of [ `Crt_file_path of string ] * [ `Key_file_path of string ] ]
[@@deriving sexp]
type requires_async_ssl =
[ openssl | `OpenSSL_with_trust_chain of openssl * trust_chain ]
[@@deriving sexp]
type server = [ `TCP | requires_async_ssl ] [@@deriving sexp]
let serve ?max_connections ?backlog ?buffer_age_limit ~on_handler_error mode
where_to_listen handle_request =
let handle_client handle_request sock rd wr =
match mode with
| `TCP -> handle_request sock rd wr
| #requires_async_ssl as async_ssl ->
let crt_file, key_file, ca_file, ca_path =
match async_ssl with
| `OpenSSL (`Crt_file_path crt_file, `Key_file_path key_file) ->
(crt_file, key_file, None, None)
| `OpenSSL_with_trust_chain
(`OpenSSL (`Crt_file_path crt, `Key_file_path key), trust_chain)
->
let ca_file, ca_path =
match trust_chain with
| `Ca_file ca_file -> (Some ca_file, None)
| `Ca_path ca_path -> (None, Some ca_path)
| `Search_file_first_then_path (`File ca_file, `Path ca_path) ->
(Some ca_file, Some ca_path)
in
(crt, key, ca_file, ca_path)
in
let cfg = Ssl.Config.create ?ca_file ?ca_path ~crt_file ~key_file () in
Ssl.listen cfg rd wr >>= fun (rd, wr) ->
Monitor.protect
(fun () -> handle_request sock rd wr)
~finally:(fun () ->
Deferred.all_unit [ Reader.close rd; Writer.close wr ])
in
Tcp.Server.create ?max_connections ?backlog ?buffer_age_limit
~on_handler_error where_to_listen
(handle_client handle_request)
type ssl_version = Ssl.version [@@deriving sexp]
type ssl_opt = Ssl.opt [@@deriving sexp]
type ssl_conn = Ssl.connection [@@deriving sexp_of]
type allowed_ciphers = [ `Only of string list | `Openssl_default | `Secure ]
[@@deriving sexp]
type verify_mode = Ssl.verify_mode [@@deriving sexp_of]
type session = Ssl.session [@@deriving sexp_of]
module Ssl = struct
module Config = Ssl.Config
end