ocaml http/1, http/2 and websocket client and server library
gdiazlo.tngl.sh
1(** TLS configuration and helpers for HCS.
2
3 This module provides TLS configuration that works with tls-eio and ca-certs
4 for system certificate loading. *)
5
6(** {1 ALPN Protocol Identifiers} *)
7
8(** HTTP/2 over TLS ALPN identifier *)
9let alpn_h2 = "h2"
10
11(** HTTP/1.1 ALPN identifier *)
12let alpn_http11 = "http/1.1"
13
14(** HTTP/2 cleartext (h2c) identifier - used in Upgrade header, not ALPN *)
15let alpn_h2c = "h2c"
16
17(** Protocol type for negotiation results *)
18type protocol = HTTP_1_1 | HTTP_2
19
20(** Convert ALPN string to protocol type *)
21let protocol_of_alpn = function
22 | s when s = alpn_h2 -> Some HTTP_2
23 | s when s = alpn_http11 -> Some HTTP_1_1
24 | _ -> None
25
26(** Convert protocol to ALPN string *)
27let alpn_of_protocol = function HTTP_2 -> alpn_h2 | HTTP_1_1 -> alpn_http11
28
29(** Client TLS configuration *)
30module Client = struct
31 (** Certificate verification mode *)
32 type verification =
33 | System_certs (** Use system CA certificates *)
34 | No_verify (** Disable verification (INSECURE!) *)
35
36 type t = {
37 verification : verification;
38 alpn_protocols : string list option; (** ALPN: ["h2"; "http/1.1"] *)
39 }
40
41 let default =
42 { verification = System_certs; alpn_protocols = Some [ "http/1.1" ] }
43
44 (** TLS config for HTTP/2 - advertises h2 protocol *)
45 let h2 = { verification = System_certs; alpn_protocols = Some [ "h2" ] }
46
47 (** TLS config that prefers HTTP/2 but falls back to HTTP/1.1 *)
48 let h2_or_http11 =
49 { verification = System_certs; alpn_protocols = Some [ "h2"; "http/1.1" ] }
50
51 let with_alpn protocols config =
52 { config with alpn_protocols = Some protocols }
53
54 let insecure =
55 { verification = No_verify; alpn_protocols = Some [ "http/1.1" ] }
56
57 let insecure_h2 = { verification = No_verify; alpn_protocols = Some [ "h2" ] }
58
59 (** Create tls-eio authenticator from config *)
60 let make_authenticator config =
61 match config.verification with
62 | System_certs -> (
63 match Ca_certs.authenticator () with
64 | Ok auth -> Ok auth
65 | Error (`Msg msg) -> Error msg)
66 | No_verify -> Ok (fun ?ip:_ ~host:_ _ -> Ok None)
67
68 (** Create Tls.Config.client from our config *)
69 let to_tls_config config ~host:_ =
70 match make_authenticator config with
71 | Error msg -> Error msg
72 | Ok authenticator -> (
73 match
74 Tls.Config.client ~authenticator ?alpn_protocols:config.alpn_protocols
75 ()
76 with
77 | Ok tls_config -> Ok tls_config
78 | Error (`Msg msg) -> Error msg)
79end
80
81module Server = struct
82 type t = {
83 certificate : Tls.Config.own_cert;
84 alpn_protocols : string list option;
85 }
86
87 let with_alpn protocols config =
88 { config with alpn_protocols = Some protocols }
89
90 let h1_only config = with_alpn [ alpn_http11 ] config
91 let h2_only config = with_alpn [ alpn_h2 ] config
92 let h2_or_http11 config = with_alpn [ alpn_h2; alpn_http11 ] config
93
94 let of_pem ~cert_file ~key_file =
95 try
96 let cert_pem = In_channel.with_open_bin cert_file In_channel.input_all in
97 let key_pem = In_channel.with_open_bin key_file In_channel.input_all in
98 let certs = X509.Certificate.decode_pem_multiple cert_pem in
99 let key = X509.Private_key.decode_pem key_pem in
100 match (certs, key) with
101 | Ok certs, Ok key ->
102 Ok
103 {
104 certificate = `Single (certs, key);
105 alpn_protocols = Some [ alpn_h2; alpn_http11 ];
106 }
107 | Error (`Msg msg), _ -> Error ("Certificate error: " ^ msg)
108 | _, Error (`Msg msg) -> Error ("Key error: " ^ msg)
109 with Sys_error msg -> Error ("File error: " ^ msg)
110
111 (** Create Tls.Config.server from our config *)
112 let to_tls_config config =
113 Tls.Config.server ~certificates:config.certificate
114 ?alpn_protocols:config.alpn_protocols ()
115end
116
117(** Convert TLS failure to string *)
118let failure_to_string failure = Tls.Engine.string_of_failure failure
119
120(** Wrap an Eio flow with TLS (client side) *)
121let client_wrap ~config flow =
122 match Client.to_tls_config config ~host:"" with
123 | Error msg -> Error msg
124 | Ok tls_config -> (
125 try
126 let tls_flow = Tls_eio.client_of_flow tls_config flow in
127 Ok tls_flow
128 with
129 | Tls_eio.Tls_failure failure -> Error (failure_to_string failure)
130 | exn -> Error (Printexc.to_string exn))
131
132(** Wrap an Eio flow with TLS (server side) *)
133let server_wrap config flow =
134 match Server.to_tls_config config with
135 | Error (`Msg msg) -> Error msg
136 | Ok tls_config -> (
137 try
138 let tls_flow = Tls_eio.server_of_flow tls_config flow in
139 Ok tls_flow
140 with
141 | Tls_eio.Tls_failure failure -> Error (failure_to_string failure)
142 | exn -> Error (Printexc.to_string exn))
143
144let negotiated_protocol (tls_flow : Tls_eio.t) : protocol option =
145 match Tls_eio.epoch tls_flow with
146 | Error () -> None
147 | Ok epoch_data -> (
148 match epoch_data.Tls.Core.alpn_protocol with
149 | None -> None
150 | Some alpn -> protocol_of_alpn alpn)