Skip to content

Commit acea71f

Browse files
thomassathomassa
committed
CP-12512 A switch to set stunnel protocol version
Before this change, when we wrote client-mode configuration for stunnel we did not specify SSL/TLS version or ciphersuites, so it was using defaults (e.g. SSLv3 for stunnel 4.15, TLSv1.0 for stunnel 4.56) Now we specify these things: TLSv1.2 protocol and TLSv1.2 ciphersuites are specified, or if the legacy flag is set, we allow all TLS protocol versions (but not SSL) and we add the ciphersuites that were accepted for incoming connections in older XenServer versions (6.5 and earlier). Signed-off-by: Thomas Sanders <thomas.sanders@citrix.com>
1 parent 6c0fc5b commit acea71f

File tree

3 files changed

+111
-58
lines changed

3 files changed

+111
-58
lines changed

‎stunnel/stunnel.ml‎

Lines changed: 70 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,9 @@
1313
*)
1414
(* Copyright (C) 2007 XenSource Inc *)
1515

16+
module D=Debug.Make(struct let name="stunnel" end)
17+
open D
18+
1619
open Printf
1720
open Pervasiveext
1821
open Xstringext
@@ -33,6 +36,11 @@ let stunnel_logger = ref ignore
3336

3437
let timeoutidle = ref None
3538

39+
let legacy_protocol_and_ciphersuites_allowed = ref true
40+
41+
let is_legacy_protocol_and_ciphersuites_allowed () =
42+
!legacy_protocol_and_ciphersuites_allowed
43+
3644
let init_stunnel_path () =
3745
try cached_stunnel_path := Some (Unix.getenv "XE_STUNNEL")
3846
with Not_found ->
@@ -116,32 +124,56 @@ type t = { mutable pid: pid; fd: Unix.file_descr; host: string; port: int;
116124
unique_id: int option;
117125
mutable logfile: string;
118126
verified: bool;
127+
legacy: bool;
119128
}
120129

121-
let config_file verify_cert extended_diagnosis host port =
122-
let lines = ["client=yes"; "foreground=yes"; "socket = r:TCP_NODELAY=1"; "socket = r:SO_KEEPALIVE=1"; "socket = a:SO_KEEPALIVE=1";
123-
(match !timeoutidle with None -> "" | Some x -> Printf.sprintf "TIMEOUTidle = %d" x);
124-
Printf.sprintf "connect=%s:%d" host port] @
125-
(if extended_diagnosis then
126-
["debug=4"]
127-
else
128-
[]) @
129-
(if verify_cert then
130-
["verify=2";
131-
sprintf "CApath=%s" certificate_path;
132-
sprintf "CRLpath=%s" crl_path]
133-
else
134-
[])
130+
let config_file verify_cert extended_diagnosis host port legacy =
131+
132+
let good_ciphers = "!EXPORT:TLSv1.2" in
133+
let back_compat_ciphers = "RSA+AES256-SHA:RSA+AES128-SHA:RSA+RC4-SHA:RSA+RC4-MD5:RSA+DES-CBC3-SHA" in
134+
135+
let lines = [
136+
"client=yes"; "foreground=yes"; "socket = r:TCP_NODELAY=1"; "socket = r:SO_KEEPALIVE=1"; "socket = a:SO_KEEPALIVE=1";
137+
(match !timeoutidle with None -> "" | Some x -> Printf.sprintf "TIMEOUTidle = %d" x);
138+
Printf.sprintf "connect=%s:%d" host port;
139+
"fips = no"; (* stunnel fips-mode stops us using sslVersion other than TLSv1 which means 1.0 only. *)
140+
] @ (if extended_diagnosis then
141+
["debug=4"]
142+
else
143+
[]
144+
) @ (
145+
if verify_cert then
146+
["verify=2";
147+
sprintf "CApath=%s" certificate_path;
148+
sprintf "CRLpath=%s" crl_path]
149+
else
150+
[]
151+
) @ (
152+
if legacy then [
153+
"sslVersion = all";
154+
"options = NO_SSLv2";
155+
"options = NO_SSLv3";
156+
"ciphers = " ^ good_ciphers ^ ":" ^ back_compat_ciphers;
157+
] else [
158+
"sslVersion = TLSv1.2";
159+
"ciphers = " ^ good_ciphers;
160+
]
161+
)
135162
in
136163
String.concat "" (List.map (fun x -> x ^ "\n") lines)
137164

165+
let set_legacy_protocol_and_ciphersuites_allowed b =
166+
legacy_protocol_and_ciphersuites_allowed := b;
167+
info "legacy-config %B; example: %s" b
168+
(String.escaped (config_file false false "dummyhost" 443 b))
169+
138170
let ignore_exn f x = try f x with _ -> ()
139171

140-
let rec disconnect ?(wait = true) ?(force = false) x =
172+
let rec disconnect ?(wait = true) ?(force = false) x =
141173
List.iter (ignore_exn Unix.close) [ x.fd ];
142174

143175
let do_disc waiter pid =
144-
let res =
176+
let res =
145177
try waiter ()
146178
with Unix.Unix_error (Unix.ECHILD, _, _) -> pid, Unix.WEXITED 0 in
147179
match res with
@@ -151,18 +183,24 @@ let rec disconnect ?(wait = true) ?(force = false) x =
151183
disconnect ~wait:wait ~force:force x
152184
| _ -> ()
153185
in
186+
let verbose = x.legacy && not (!legacy_protocol_and_ciphersuites_allowed) in
154187
match x.pid with
155-
| FEFork pid -> do_disc
156-
(fun () ->
157-
(if wait then Forkhelpers.waitpid
158-
else Forkhelpers.waitpid_nohang) pid)
159-
(Forkhelpers.getpid pid)
160-
| StdFork pid -> do_disc
161-
(fun () ->
162-
(if wait then Unix.waitpid []
163-
else Unix.waitpid [Unix.WNOHANG]) pid)
164-
pid
165-
| Nopid -> ()
188+
| FEFork fpid ->
189+
let pid_int = Forkhelpers.getpid fpid in
190+
if verbose then info "Disconnecting FEFork %d" pid_int;
191+
do_disc
192+
(fun () ->
193+
(if wait then Forkhelpers.waitpid
194+
else Forkhelpers.waitpid_nohang) fpid)
195+
pid_int
196+
| StdFork pid ->
197+
if verbose then info "Disconnecting StdFork %d" pid;
198+
do_disc
199+
(fun () ->
200+
(if wait then Unix.waitpid []
201+
else Unix.waitpid [Unix.WNOHANG]) pid)
202+
pid
203+
| Nopid -> if verbose then info "Disconnecting Nopid"
166204

167205
(* With some probability, stunnel fails during its startup code before it reads
168206
the config data from us. Therefore we get a SIGPIPE writing the config data.
@@ -192,10 +230,13 @@ let attempt_one_connect ?unique_id ?(use_fork_exec_helper = true)
192230
["-fd"; if use_fork_exec_helper then config_out_uuid else config_out_fd]
193231
end in
194232
let data_out,data_in = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in
233+
(* Dereference just once to ensure we are consistent in t and config_file *)
234+
let legacy = !legacy_protocol_and_ciphersuites_allowed in
195235
let t =
196236
{ pid = Nopid; fd = data_out; host = host; port = port;
197237
connected_time = Unix.gettimeofday (); unique_id = unique_id;
198-
logfile = ""; verified = verify_cert } in
238+
logfile = ""; verified = verify_cert;
239+
legacy = legacy } in
199240
let result = Forkhelpers.with_logfile_fd "stunnel"
200241
~delete:(not extended_diagnosis)
201242
(fun logfd ->
@@ -221,7 +262,7 @@ let attempt_one_connect ?unique_id ?(use_fork_exec_helper = true)
221262
(fun () ->
222263
match config_in with
223264
| Some fd -> begin
224-
let config = config_file verify_cert extended_diagnosis host port in
265+
let config = config_file verify_cert extended_diagnosis host port legacy in
225266
(* Catch the occasional initialisation failure of stunnel: *)
226267
try
227268
let n = Unix.write fd config 0 (String.length config) in

‎stunnel/stunnel.mli‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ type t = { mutable pid: pid;
3737
unique_id: int option;
3838
mutable logfile: string;
3939
verified: bool;
40+
legacy: bool;
4041
}
4142

4243
(** Connects via stunnel (optionally via an external 'fork/exec' helper) to
@@ -60,3 +61,7 @@ val diagnose_failure : t -> unit
6061
val test : string -> int -> unit
6162

6263
val must_verify_cert : bool option -> bool
64+
65+
val set_legacy_protocol_and_ciphersuites_allowed : bool -> unit
66+
67+
val is_legacy_protocol_and_ciphersuites_allowed : unit -> bool

‎stunnel/stunnel_cache.ml‎

Lines changed: 36 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -78,19 +78,22 @@ let unlocked_gc () =
7878
let all_ids = Hashtbl.fold (fun k _ acc -> k :: acc) !stunnels [] in
7979

8080
let to_gc = ref [] in
81-
(* Find the ones which are too old *)
81+
(* Find the ones which are too old or have unwanted legacy config *)
8282
let now = Unix.gettimeofday () in
8383
Hashtbl.iter
8484
(fun idx stunnel ->
8585
let time = Hashtbl.find !times idx in
8686
let idle = now -. time in
8787
let age = now -. stunnel.Stunnel.connected_time in
88-
if age > max_age then begin
89-
debug "Expiring stunnel id %s; age (%.2f) > limit (%.2f)" (id_of_stunnel stunnel) age max_age;
90-
to_gc := idx :: !to_gc
88+
if stunnel.Stunnel.legacy && not (Stunnel.is_legacy_protocol_and_ciphersuites_allowed ()) then (
89+
info "Expiring stunnel id %s because it is legacy-mode." (id_of_stunnel stunnel);
90+
to_gc := idx :: !to_gc
91+
) else if age > max_age then begin
92+
debug "Expiring stunnel id %s; age (%.2f) > limit (%.2f)" (id_of_stunnel stunnel) age max_age;
93+
to_gc := idx :: !to_gc
9194
end else if idle > max_idle then begin
92-
debug "Expiring stunnel id %s; idle (%.2f) > limit (%.2f)" (id_of_stunnel stunnel) age max_idle;
93-
to_gc := idx :: !to_gc
95+
debug "Expiring stunnel id %s; idle (%.2f) > limit (%.2f)" (id_of_stunnel stunnel) age max_idle;
96+
to_gc := idx :: !to_gc
9497
end) !stunnels;
9598
let num_remaining = List.length all_ids - (List.length !to_gc) in
9699
if num_remaining > max_stunnel then begin
@@ -132,27 +135,32 @@ let gc () = Mutex.execute m unlocked_gc
132135

133136
let counter = ref 0
134137

135-
let add (x: Stunnel.t) =
136-
let now = Unix.gettimeofday () in
137-
Mutex.execute m
138-
(fun () ->
139-
let idx = !counter in
140-
incr counter;
141-
Hashtbl.add !times idx now;
142-
Hashtbl.add !stunnels idx x;
143-
let ep = { host = x.Stunnel.host; port = x.Stunnel.port; verified = x.Stunnel.verified } in
144-
let existing =
145-
if Hashtbl.mem !index ep
146-
then Hashtbl.find !index ep
147-
else [] in
148-
Hashtbl.replace !index ep (idx :: existing);
149-
debug "Adding stunnel id %s (idle %.2f) to the cache"
150-
(id_of_stunnel x) 0.;
151-
unlocked_gc ()
152-
)
153-
138+
let add (x: Stunnel.t) =
139+
if x.Stunnel.legacy && not (Stunnel.is_legacy_protocol_and_ciphersuites_allowed ()) then (
140+
info "Legacy-protocol stunnel (id=%s) not allowed in cache: disconnecting." (id_of_stunnel x);
141+
Stunnel.disconnect ~force:true x
142+
) else (
143+
let now = Unix.gettimeofday () in
144+
Mutex.execute m (fun () ->
145+
let idx = !counter in
146+
incr counter;
147+
Hashtbl.add !times idx now;
148+
Hashtbl.add !stunnels idx x;
149+
let ep = { host = x.Stunnel.host; port = x.Stunnel.port; verified = x.Stunnel.verified } in
150+
let existing =
151+
if Hashtbl.mem !index ep
152+
then Hashtbl.find !index ep
153+
else [] in
154+
Hashtbl.replace !index ep (idx :: existing);
155+
debug "Adding stunnel id %s (idle %.2f) to the cache"
156+
(id_of_stunnel x) 0.;
157+
unlocked_gc ()
158+
)
159+
)
160+
154161
(** Returns an Stunnel.t for this endpoint (oldest first), raising Not_found
155-
if none can be found *)
162+
if none can be found. First performs a garbage-collection, which discards
163+
legacy-config and expired stunnels if needed. *)
156164
let remove host port verified =
157165
let ep = { host = host; port = port; verified = verified } in
158166
Mutex.execute m
@@ -179,7 +187,7 @@ let remove host port verified =
179187
let flush () =
180188
Mutex.execute m
181189
(fun () ->
182-
info "Flushing cache";
190+
info "Flushing cache of all %d stunnels." (Hashtbl.length !stunnels);
183191
Hashtbl.iter (fun id st -> Stunnel.disconnect st) !stunnels;
184192
Hashtbl.clear !stunnels;
185193
Hashtbl.clear !times;
@@ -191,6 +199,5 @@ let connect ?use_fork_exec_helper ?write_to_log host port verify_cert =
191199
try
192200
remove host port verify_cert
193201
with Not_found ->
194-
error "Failed to find stunnel in cache for endpoint %s:%d" host port;
202+
info "connect did not find cached stunnel for endpoint %s:%d" host port;
195203
Stunnel.connect ?use_fork_exec_helper ?write_to_log ~verify_cert host port
196-

0 commit comments

Comments
 (0)