Skip to content

Commit 79c2a44

Browse files
thomassathomassa
committed
Merge pull request xapi-project#17 from thomassa/back-compat-switch
CP-12512 A switch to set stunnel protocol version
2 parents 7b01cff + acea71f commit 79c2a44

File tree

3 files changed

+122
-66
lines changed

3 files changed

+122
-66
lines changed

‎stunnel/stunnel.ml‎

Lines changed: 81 additions & 37 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,50 +124,83 @@ 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 ];
142-
let waiter, pid = match x.pid with
143-
| FEFork pid ->
144-
(fun () ->
145-
(if wait then Forkhelpers.waitpid
146-
else Forkhelpers.waitpid_nohang) pid),
147-
Forkhelpers.getpid pid
148-
| StdFork pid ->
149-
(fun () ->
150-
(if wait then Unix.waitpid []
151-
else Unix.waitpid [Unix.WNOHANG]) pid),
152-
pid in
153-
let res =
154-
try waiter ()
155-
with Unix.Unix_error (Unix.ECHILD, _, _) -> pid, Unix.WEXITED 0 in
156-
match res with
157-
| 0, _ when force ->
158-
(try Unix.kill pid Sys.sigkill
159-
with Unix.Unix_error (Unix.ESRCH, _, _) ->());
160-
disconnect ~wait:wait ~force:force x
161-
| _ -> ()
162174

175+
let do_disc waiter pid =
176+
let res =
177+
try waiter ()
178+
with Unix.Unix_error (Unix.ECHILD, _, _) -> pid, Unix.WEXITED 0 in
179+
match res with
180+
| 0, _ when force ->
181+
(try Unix.kill pid Sys.sigkill
182+
with Unix.Unix_error (Unix.ESRCH, _, _) ->());
183+
disconnect ~wait:wait ~force:force x
184+
| _ -> ()
185+
in
186+
let verbose = x.legacy && not (!legacy_protocol_and_ciphersuites_allowed) in
187+
match x.pid with
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"
163204

164205
(* With some probability, stunnel fails during its startup code before it reads
165206
the config data from us. Therefore we get a SIGPIPE writing the config data.
@@ -189,10 +230,13 @@ let attempt_one_connect ?unique_id ?(use_fork_exec_helper = true)
189230
["-fd"; if use_fork_exec_helper then config_out_uuid else config_out_fd]
190231
end in
191232
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
192235
let t =
193236
{ pid = Nopid; fd = data_out; host = host; port = port;
194237
connected_time = Unix.gettimeofday (); unique_id = unique_id;
195-
logfile = ""; verified = verify_cert } in
238+
logfile = ""; verified = verify_cert;
239+
legacy = legacy } in
196240
let result = Forkhelpers.with_logfile_fd "stunnel"
197241
~delete:(not extended_diagnosis)
198242
(fun logfd ->
@@ -218,7 +262,7 @@ let attempt_one_connect ?unique_id ?(use_fork_exec_helper = true)
218262
(fun () ->
219263
match config_in with
220264
| Some fd -> begin
221-
let config = config_file verify_cert extended_diagnosis host port in
265+
let config = config_file verify_cert extended_diagnosis host port legacy in
222266
(* Catch the occasional initialisation failure of stunnel: *)
223267
try
224268
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)