Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 476 lines (424 sloc) 19.018 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
258395c [cleanup] open: remove Base in libsecurity
Raja authored
19 (* depends *)
20 module String = BaseString
fccc685 Initial open-source release
MLstate authored
21
22 exception InvalidCertificate
23 exception Want_read
24 exception Want_write
25
26 (* Certificate to provide *)
27 type ssl_certificate =
28 { cert_file : string (* certificate file in PEM format *)
29 ; cert_privkey : string (* private RSA key file in PEM format *)
30 ; cert_password : string (* password to use if private key protected *)
31 ; cert_cafile : string option (* the server CA certificate *)
32 ; cert_capath : string option (* the server CA path *) }
33
34 (* Certificates verifications rules *)
35 type ssl_verify_params =
36 { cafile : string option (* file of CA certificates in PEM format to use for verifications *)
37 ; capath : string option (* directory containing CA certificates in PEM format to use for verifications *)
38 ; certpath : string option (* directory containing client certificates in PEM format that are allowed *)
39 ; client_ca_file : string option (* list of CAs sent to the client when requesting a client certificate *)
40 ; accept_fun : Ssl.certificate -> bool (* function to call when meeting an unknown certificate, in order to be able
41 to accept in anyway (will not write the certificate into the certs path) *)
42 ; always : bool (* always verify the presence of a certificate *) }
43
44 type secure_type = ssl_certificate option * ssl_verify_params option
45
46 type is_valid_cert = bool
47
48 type secure_response =
49 | UnsecuredRes
50 | SecuredRes of is_valid_cert * (Ssl.certificate option * ssl_verify_params option)
51
52 (* Digest name and size used for fingerprint *)
53 let digest_name, digest_size = (* "SHA1", 40 *) "SHA256", 64 (* "SHA512", 128 *)
54
55 (* ********** *)
56
57 #<Debugvar:SSL_DEBUG>
58
59 let dest = [Logger.make_rotating_destination "SslAS"]
60 let logger = Logger.make_logger dest 10
61
62 let string_of_certificate ce =
63 match ce with
64 | None -> ""
65 | Some c ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
66 Printf.sprintf "[cert_file %s] [cert_privkey %s] [cert_password %s] %s [cert_capath %s]"
fccc685 Initial open-source release
MLstate authored
67 c.cert_file
68 c.cert_privkey
69 c.cert_password
70 (match c.cert_cafile with
71 | None -> ""
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
72 | Some v -> (Printf.sprintf "[cert_cafile %s]" v))
fccc685 Initial open-source release
MLstate authored
73 (match c.cert_capath with
74 | None -> ""
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
75 | Some v -> (Printf.sprintf "[cert_capath %s]" v))
fccc685 Initial open-source release
MLstate authored
76
77 let string_of_param pe =
78 match pe with
79 | None -> ""
80 | Some p ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
81 Printf.sprintf "%s %s %s %s [always %s]"
fccc685 Initial open-source release
MLstate authored
82 (match p.cafile with
83 | None -> ""
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
84 | Some v -> (Printf.sprintf "[cafile %s]" v))
fccc685 Initial open-source release
MLstate authored
85 (match p.capath with
86 | None -> ""
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
87 | Some v -> (Printf.sprintf "[capath %s]" v))
fccc685 Initial open-source release
MLstate authored
88 (match p.certpath with
89 | None -> ""
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
90 | Some v -> (Printf.sprintf "[certpath %s]" v))
fccc685 Initial open-source release
MLstate authored
91 (match p.client_ca_file with
92 | None -> ""
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
93 | Some v -> (Printf.sprintf "[client_ca_file %s]" v))
fccc685 Initial open-source release
MLstate authored
94 (match p.always with
95 | true -> "true"
96 | false -> "false")
97
98 let log priority color fmt =
99 let _log fmt = Logger.log_error ~priority ~color ~logger fmt in
100 let _nolog fmt = Format.ifprintf Format.std_formatter fmt in
101 #<If>
102 _log fmt
103 #<Else>
104 _nolog fmt
105 #<End>
106
107 let info fct ?cert ?param fmt =
108 log Logger.Info `cyan "[SSL] [%s] %s %s %s" fct (string_of_certificate cert) (string_of_param param) fmt
109
110 let warning fct fmt =
111 log Logger.Warning `yellow "[SSL] [%s] %s" fct fmt
112
113 let error fct fmt =
114 log Logger.Error `red "[SSL] [%s] %s" fct fmt
115
116 (* ***************** *)
117
118 let make_ssl_verify_params ?(client_ca_file="") ?(accept_fun=fun _cert -> false) ?(always=true) cafile capath certpath =
119 let p = { cafile = if cafile = "" then None else Some cafile
120 ; capath = if capath = "" then None else Some capath
121 ; certpath = if certpath = "" then None else Some certpath
122 ; client_ca_file = if client_ca_file = "" then None else Some client_ca_file
123 ; accept_fun = accept_fun
124 ; always = always } in
125 info "make_ssl_verify_params" ?param:(Some p) "";
126 p
127
128 let make_ssl_certificate ?(cafile="") ?(capath="") certfile privkey password =
129 let c = { cert_file = certfile
130 ; cert_privkey = privkey
131 ; cert_password = password
132 ; cert_cafile = if cafile = "" then None else Some cafile
133 ; cert_capath = if capath = "" then None else Some capath } in
134 info "make_ssl_certificate" ?cert:(Some c) "";
135 c
136
137 let do_handshake sched conn ?retry ?timeout ssl_s ?err_cont cont =
138 let retry = Option.default 4 retry in
139 let err_cont = Option.default (fun _ -> ()) err_cont in
140 let rec do_retry n () = match n with
141 | 0 -> err_cont Scheduler.Timeout
142 | n ->
143 let no_err =
144 try Ssl_ext.do_handshake ssl_s;
145 true with
146 | Ssl_ext.Handshake_error Ssl.Error_want_read ->
147 Scheduler.listen_once sched conn ?timeout ~err_cont (do_retry (n-1));
148 false
149 | Ssl_ext.Handshake_error Ssl.Error_want_write ->
150 Scheduler.connect sched conn ?timeout ~err_cont (do_retry (n-1));
151 false
152 | (Ssl_ext.Handshake_error e) as ex -> print_endline (Ssl_ext.error_to_string
153 e);err_cont ex;false
154 | e -> err_cont e;
155 false
156 in
157 if no_err then cont ()
158 in
159 do_retry retry ()
160
161
162 let renegotiate sched conn ?timeout ?retry ssl_s ?err_cont cont =
163 (*
164 #<If$minlevel 5>
165 debug "Net.renegotiate";
166 #<End>;
167 *)
168 let err_cont = Option.default (fun _ -> ()) err_cont in
169 (try
170 Ssl_ext.renegotiate ssl_s
171 with
172 e -> err_cont e);
173 let cont' () = do_handshake sched conn ?timeout ?retry ssl_s ~err_cont cont
174 in do_handshake sched conn ?timeout ?retry ssl_s ~err_cont cont'
175
176 (*
177 #<If$minlevel 5>
178 debug "Renegotiated cert:\n%s" (Ssl_ext.certificate_to_string certificate digest_name digest_size);
179 #<End>;
180 *)
181
182
183 let renegotiate_client sched conn ?timeout ?retry ssl_s ?err_cont cont =
184 (*
185 #<If$minlevel 5>
186 debug "Net.renegotiate";
187 #<End>;
188 *)
189 let err_cont = Option.default (fun _ -> ()) err_cont in
190 (try
191 Ssl_ext.renegotiate ssl_s
192 with
193 e -> err_cont e);
194 do_handshake sched conn ?timeout ?retry ssl_s ~err_cont cont
195 (*
196 #<If$minlevel 5>
197 debug "Renegotiated cert:\n%s" (Ssl_ext.certificate_to_string certificate digest_name digest_size);
198 #<End>;
199 *)
200
201
202
203 (* Initialize the SSL library *)
204
205 let ssl_init = lazy (
206 (* DO NOT USE BECAUSE BUGS, and we don't use threads anyway...
207 Ssl_threads.init () ; *)
208 Ssl.init();
209 Ssl_ext.init();
210 )
211
212 (* Create an SSL server context *)
7203823 [fix] ssl: create an ssl context for each connect/listen
Hugo Heuzard authored
213 let ssl_server_context() =
fccc685 Initial open-source release
MLstate authored
214 Lazy.force ssl_init;
7203823 [fix] ssl: create an ssl context for each connect/listen
Hugo Heuzard authored
215 Ssl.create_context Ssl.SSLv23 Ssl.Server_context
fccc685 Initial open-source release
MLstate authored
216
217 (* Create an SSL client context *)
7203823 [fix] ssl: create an ssl context for each connect/listen
Hugo Heuzard authored
218 let ssl_client_context() =
fccc685 Initial open-source release
MLstate authored
219 Lazy.force ssl_init;
7203823 [fix] ssl: create an ssl context for each connect/listen
Hugo Heuzard authored
220 Ssl.create_context Ssl.SSLv23 Ssl.Client_context
fccc685 Initial open-source release
MLstate authored
221
222 (* Digest name and size used for fingerprint *)
223 let digest_name, digest_size = (* "SHA1", 40 *) "SHA256", 64 (* "SHA512", 128 *)
224
225 let compute_fingerprint certificate = Ssl_ext.compute_digest certificate digest_name digest_size
226
227 (* Map of valid client certificates
228 fingerprint -> subject *)
229 let certs = ref StringMap.empty
230
231 let reload_certs ?(extensions=["pem"]) verify_params =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
232 info "reload_certs" ?param:(Some verify_params) (Printf.sprintf "[extensions %s]" (List.fold_left (fun a b -> (Printf.sprintf "%s %s" a b)) "" extensions));
fccc685 Initial open-source release
MLstate authored
233 (* Clean the map *)
234 certs := StringMap.empty;
235 (* Reload every files in certpath *)
236 try match verify_params.certpath with
237 | Some certpath -> File.iter_dir (
238 fun ~name ~path -> (*name_of_addr*) (
239 let is_pem = List.fold_left (
240 fun acc elt -> acc || String.is_suffix elt name
241 ) false extensions in
242 if not is_pem then () (* Ignore file that does not have the right extension *)
243 else
244 begin try
245 let certificate = Ssl.read_certificate path in
246 let subject = Ssl.get_subject certificate
247 and fingerprint = compute_fingerprint certificate in
248 certs := StringMap.add fingerprint subject !certs;
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
249 info "reload_certs" (Printf.sprintf "Certificate loaded:\n%s" (Ssl_ext.certificate_to_string certificate digest_name digest_size))
fccc685 Initial open-source release
MLstate authored
250 with
251 | Ssl.Certificate_error (* read_certificate *)
252 | Not_found (* get_subject *) -> info "reload_certs" path (* Continue even if one file fails *)
253 end)
254 ) certpath; true
255 | _ -> true
256 with Unix.Unix_error _ (* File.iter_dir fails *) -> false
257
258 let validate_certificate certificate verify_params =
259 (* let hash = Ssl_ext.get_hash certificate in *)
260 let has_certpath = Option.is_some verify_params.certpath in
261 let fingerprint = compute_fingerprint certificate in
262 if not has_certpath || ((* (hash = "" || fingerprint = hash) && *) StringMap.mem fingerprint !certs) then (
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
263 info "validate_certificate" (Printf.sprintf "Valid certificate received:\n%s" (Ssl_ext.certificate_to_string certificate digest_name digest_size));
fccc685 Initial open-source release
MLstate authored
264 true
265 ) else if verify_params.accept_fun certificate then (
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
266 info "validate_certificate" (Printf.sprintf "Certificate accepted:\n%s" (Ssl_ext.certificate_to_string certificate digest_name digest_size));
fccc685 Initial open-source release
MLstate authored
267 true
268 ) else (
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
269 info "validate_certificate" (Printf.sprintf "Invalid certificate received:\n%s" (Ssl_ext.certificate_to_string certificate digest_name digest_size));
fccc685 Initial open-source release
MLstate authored
270 false
271 )
272
273 (* == Public functions == *)
274
275 let get_listen_callback sched (server_params, client_params) server_fun =
276 info "get_listen_callback" "";
277 let server_params =
278 match server_params with
279 | Some sp -> sp
280 | None -> info "get_listen_callback" "Ssl listening : no server parameters provided"; assert false;
281 in
282 let has_cp, has_ca, has_client_ca_file = match client_params with
283 | Some cp -> true, (Option.is_some cp.cafile || Option.is_some cp.capath), Option.is_some cp.client_ca_file
284 | _ -> false, false, false in
285 let has_server_ca = Option.is_some server_params.cert_cafile || Option.is_some server_params.cert_capath in
286 info "glc" "ctx...";
7203823 [fix] ssl: create an ssl context for each connect/listen
Hugo Heuzard authored
287 let ctx = ssl_server_context() in
fccc685 Initial open-source release
MLstate authored
288 info "glc" "ctx ok";
289 if server_params.cert_password <> "" then
290 Ssl.set_password_callback ctx (fun _ -> server_params.cert_password);
291 begin try
292 info "glc" "use_certificate";
293 Ssl.use_certificate ctx server_params.cert_file server_params.cert_privkey;
294 info "glc" "load_verify";
295 Ssl.load_verify_locations ctx (server_params.cert_file) "";
296 if has_server_ca then (
297 info "glc" "has_server";
298 Ssl.load_verify_locations ctx (Option.default "" server_params.cert_cafile) (Option.default "" server_params.cert_capath);
299 );
300 info "glc" "set_session";
301 Ssl_ext.set_session_id_context ctx; (* Must be set, because bugs with firefox otherwise, don't know why... *)
302 if has_cp then
303 begin
304 info "glc" "has cp, set_ctx_opt";
305 let _ = Ssl_ext.set_ctx_options ctx in
306 let client_params = Option.get client_params in
307 if client_params.always then begin
308 info "glc" "always, verify";
309 Ssl.set_verify ctx [Ssl.Verify_peer; Ssl.Verify_fail_if_no_peer_cert] (
310 if has_ca then Some Ssl.client_verify_callback else Some Ssl_ext.no_client_verify_callback
311 )
312 end;
313 if has_ca then begin
314 info "glc" "has_ca, load";
315 (* http://www.openssl.org/docs/ssl/SSL_CTX_load_verify_locations.html *)
316 Ssl.load_verify_locations ctx (Option.default "" client_params.cafile) (Option.default "" client_params.capath);
317 end;
318 if has_client_ca_file then (
319 info "glc" "has_client, set";
320 (* http://www.openssl.org/docs/ssl/SSL_load_client_CA_file.html *)
321 Ssl.set_client_CA_list_from_file ctx (Option.default "" client_params.client_ca_file)
322 );
323 end
324 with
325 | Ssl.Private_key_error as e ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
326 warning "get_listen_callback" (Printf.sprintf "Error while trying to read private key file %S.\n" server_params.cert_privkey);
fccc685 Initial open-source release
MLstate authored
327 raise e
328 (*ServerLib.do_*)(* exit 1 *)
329 | Ssl.Certificate_error as e ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
330 warning "get_listen_callback" (Printf.sprintf "Error while trying to read ssl certificate %S.\n" server_params.cert_file);
fccc685 Initial open-source release
MLstate authored
331 raise e
332 (*ServerLib.do_*)(* exit 1 *)
333 end;
334
335 if has_cp then (
336 let client_params = Option.get client_params in
337 (* Load client certificates into memory in order to check client certificates validity *)
338 begin match client_params.certpath with
339 | Some _path -> info "glc" "reload_certs..."; ignore (reload_certs client_params)
340 | _ -> () end;
341 );
342
343 let f (conn: Scheduler.connection_info) =
344 let fd = Scheduler.get_connection_fd conn in
345 let ssl_s = Ssl.embed_socket fd ctx in
346 let rec continuation () =
347 try
348 info "glc" "accepting...";
349 Ssl.accept ssl_s;
350 info "glc" "accepting: OK";
351 let valid_cert, cert =
352 if has_cp then try
353 let client_params = Option.get client_params in
354 if client_params.always then (
355 info "glc" "always, get_certificate...";
356 let certificate = Ssl.get_certificate ssl_s in
357 info "glc" "ok get_certificate. validating...";
358 validate_certificate certificate client_params, Some certificate
359 )
360 else true, None
361 with Ssl.Certificate_error -> false, None
362 else true, None
363 in
364 let sconn = Scheduler.get_connection_secured_from_normal conn ssl_s in
365 server_fun (SecuredRes (valid_cert, (cert, client_params))) sconn
366 with Ssl.Accept_error ssl_error ->
367 match ssl_error with
f954c8e [feature] ssl: More debug for error
Hugo Heuzard authored
368 | Ssl.Error_want_read -> Scheduler.listen_once sched conn continuation
369 | Ssl.Error_want_write -> Scheduler.connect sched conn continuation
fccc685 Initial open-source release
MLstate authored
370 | _ ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
371 warning "glc" (Printf.sprintf "Ssl.Error_%s : %s"
f954c8e [feature] ssl: More debug for error
Hugo Heuzard authored
372 (Ssl_ext.error_to_string ssl_error) (Ssl.get_error_string()));
fccc685 Initial open-source release
MLstate authored
373 Scheduler.remove_connection sched conn
374 in
375 info "glc" "listening...";
376 Scheduler.listen_once sched conn continuation
377 in
378 f
379
380 (* Private function *)
381 let verify_certificate certificate verify_params =
382 info "gss" "get_cert";
383 (* Check the server certificate validity, or accept it *)
384 if Option.is_some verify_params.certpath then ignore (reload_certs verify_params);
385 let valid_cert = validate_certificate certificate verify_params in
386 if not valid_cert then raise InvalidCertificate;
387 ()
388
389 let get_err_cont sched conn err_cont =
390 let backtrace = Printexc.get_backtrace() in
391 match err_cont with
392 | None -> (fun e ->
393 Scheduler.remove_connection sched conn;
394 match e with
395 | Ssl.Accept_error ssl_error ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
396 warning "SslAS" (Printf.sprintf "Ssl_ssl_error'%s'\n%s" (Ssl_ext.error_to_string ssl_error) backtrace)
397 | e -> warning "SslAS" (Printf.sprintf "%s\n%s" (Printexc.to_string e) backtrace)
fccc685 Initial open-source release
MLstate authored
398 )
399 | Some f -> f
400
401
402 let connect sched conn (client_certificate, verify_cert) ?err_cont cont =
7203823 [fix] ssl: create an ssl context for each connect/listen
Hugo Heuzard authored
403 let ctx = ssl_client_context() in
fccc685 Initial open-source release
MLstate authored
404 (* Provide this client certificate if asked *)
405 let err_cont = get_err_cont sched conn err_cont in
406 begin match client_certificate with
407 | Some params ->
408 if params.cert_password <> "" then (
409 info "gss" "set_pass_callb";
410 Ssl.set_password_callback ctx (fun _ -> params.cert_password)
411 );
412 begin try
413 info "gss" "use_certificate";
414 Ssl.use_certificate ctx params.cert_file params.cert_privkey
415 with
416 | Ssl.Private_key_error as e ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
417 warning "get_secure_socket" (Printf.sprintf "SslAS.client_connect: Error while trying to read private key file %s.\n" params.cert_privkey);
fccc685 Initial open-source release
MLstate authored
418 err_cont e
419 (*ServerLib.do_*)(* exit 1 *)
420 | Ssl.Certificate_error as e ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
421 warning "get_secure_socket" (Printf.sprintf "SslAS.client_connect: Error while trying to read ssl certificate %s.\n" params.cert_file);
fccc685 Initial open-source release
MLstate authored
422 err_cont e
423 (*ServerLib.do_*)(* exit 1 *)
424 end;
425 | _ -> () end;
426 (* let _ = Ssl_ext.set_ctx_options ctx in *)
427 info "gss" "open_conn";
428 let ssl_sock = Ssl.embed_socket (Scheduler.get_connection_fd conn) ctx in
429 let ssl_conn = Scheduler.get_connection_secured_from_normal conn ssl_sock in
430 let cert_cont () =
431 begin
432 let certificate = Ssl.get_certificate ssl_sock in
433 match verify_cert with
434 | Some vp -> verify_certificate certificate vp
435 | None -> ()
436 end;
437 cont ssl_conn
438 in
439 (* We don't use Ssl.open_connection_with_context because we are *)
440 (* working with non blocking socket *)
441 let rec connect_cont () =
442 try
443 Ssl.connect ssl_sock;
444 cert_cont ()
445 with
446 (* Normal message on non blocking mode. *)
447 (* We use Epoll to be warned when we can read or wirte *)
448 | Ssl.Connection_error Ssl.Error_want_read -> info "gss" "want_read"; Scheduler.listen_once sched ssl_conn connect_cont
449 | Ssl.Connection_error Ssl.Error_want_write -> info "gss" "want_write"; Scheduler.connect sched ssl_conn connect_cont
450 | (Ssl.Connection_error e) as exn -> (Logger.error "%s" (Ssl_ext.error_to_string e);
451 err_cont exn)
452 | exn -> err_cont exn
453 in
454 connect_cont ()
455
456
457 let get_valid_certificate sched conn ?timeout ?retry ssl_s cp ?err_cont cont =
458 let has_ca = Option.is_some cp.cafile || Option.is_some cp.capath in
459 let validate_cert _ =
460 let certif = Ssl.get_certificate ssl_s in
461 let is_valid = validate_certificate certif cp
462 in cont is_valid in
463 match
464 try
465 info "gvc" "get_cert";
466 let certif = Ssl.get_certificate ssl_s in
467 Some (validate_certificate certif cp)
468 with Ssl.Certificate_error ->
469 info "gvc" "set_verify";
470 let cb = if has_ca then Some Ssl.client_verify_callback else Some Ssl_ext.no_client_verify_callback
471 in Ssl_ext.set_verify ssl_s [Ssl.Verify_peer;Ssl.Verify_fail_if_no_peer_cert] cb;
472 renegotiate sched conn ?timeout ?retry ssl_s ?err_cont validate_cert;None
473 with
474 | Some b -> cont b
475 | None -> ()
Something went wrong with that request. Please try again.