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
open Riot
let ( let* ) = Result.bind
module type Intf = sig
type config
val handshake :
accepted_at:Ptime.t ->
config:config ->
socket:Net.Socket.stream_socket ->
peer:Net.Addr.stream_addr ->
buffer_size:int ->
( Connection.t,
[> `Closed | `Inactive_tls_engine | `No_session_data ] )
IO.io_result
end
type t =
| T : {
transport : (module Intf with type config = 'config);
config : 'config;
}
-> t
let handshake (T { transport = (module T); config }) ~socket ~buffer_size =
T.handshake ~config ~socket ~buffer_size
module Tcp = struct
type config = { receive_timeout : int64; send_timeout : int64 }
let default_config =
{ receive_timeout = 5_000_000L; send_timeout = 5_000_000L }
let handshake ~accepted_at ~config ~socket ~peer ~buffer_size =
let reader, writer =
Net.Tcp_stream.
( to_reader ~timeout:config.receive_timeout socket,
to_writer ~timeout:config.send_timeout socket )
in
let conn =
Connection.make ~accepted_at ~reader ~writer ~buffer_size ~socket ~peer ()
in
Ok conn
end
let tcp ?(config = Tcp.default_config) () =
T { transport = (module Tcp); config }
module Ssl = struct
type config = { tcp : Tcp.config; tls : Tls.Config.server }
let handshake ~accepted_at ~config ~socket ~peer ~buffer_size =
let ssl =
SSL.of_server_socket ~read_timeout:config.tcp.receive_timeout
~send_timeout:config.tcp.send_timeout ~config:config.tls socket
in
let reader, writer = SSL.(to_reader ssl, to_writer ssl) in
let* protocol = SSL.negotiated_protocol ssl in
let conn =
Connection.make ~accepted_at ~protocol ~reader ~writer ~buffer_size
~socket ~peer ()
in
Ok conn
end
let ssl ~config () = T { transport = (module Ssl); config }