Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tag: v1717
Fetching contributors…

Cannot retrieve contributors at this time

476 lines (424 sloc) 18.938 kb
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* depends *)
module String = BaseString
exception InvalidCertificate
exception Want_read
exception Want_write
(* Certificate to provide *)
type ssl_certificate =
{ cert_file : string (* certificate file in PEM format *)
; cert_privkey : string (* private RSA key file in PEM format *)
; cert_password : string (* password to use if private key protected *)
; cert_cafile : string option (* the server CA certificate *)
; cert_capath : string option (* the server CA path *) }
(* Certificates verifications rules *)
type ssl_verify_params =
{ cafile : string option (* file of CA certificates in PEM format to use for verifications *)
; capath : string option (* directory containing CA certificates in PEM format to use for verifications *)
; certpath : string option (* directory containing client certificates in PEM format that are allowed *)
; client_ca_file : string option (* list of CAs sent to the client when requesting a client certificate *)
; accept_fun : Ssl.certificate -> bool (* function to call when meeting an unknown certificate, in order to be able
to accept in anyway (will not write the certificate into the certs path) *)
; always : bool (* always verify the presence of a certificate *) }
type secure_type = ssl_certificate option * ssl_verify_params option
type is_valid_cert = bool
type secure_response =
| UnsecuredRes
| SecuredRes of is_valid_cert * (Ssl.certificate option * ssl_verify_params option)
(* Digest name and size used for fingerprint *)
let digest_name, digest_size = (* "SHA1", 40 *) "SHA256", 64 (* "SHA512", 128 *)
(* ********** *)
#<Debugvar:SSL_DEBUG>
let dest = [Logger.make_rotating_destination "SslAS"]
let logger = Logger.make_logger dest 10
let string_of_certificate ce =
match ce with
| None -> ""
| Some c ->
Printf.sprintf "[cert_file %s] [cert_privkey %s] [cert_password %s] %s [cert_capath %s]"
c.cert_file
c.cert_privkey
c.cert_password
(match c.cert_cafile with
| None -> ""
| Some v -> (Printf.sprintf "[cert_cafile %s]" v))
(match c.cert_capath with
| None -> ""
| Some v -> (Printf.sprintf "[cert_capath %s]" v))
let string_of_param pe =
match pe with
| None -> ""
| Some p ->
Printf.sprintf "%s %s %s %s [always %s]"
(match p.cafile with
| None -> ""
| Some v -> (Printf.sprintf "[cafile %s]" v))
(match p.capath with
| None -> ""
| Some v -> (Printf.sprintf "[capath %s]" v))
(match p.certpath with
| None -> ""
| Some v -> (Printf.sprintf "[certpath %s]" v))
(match p.client_ca_file with
| None -> ""
| Some v -> (Printf.sprintf "[client_ca_file %s]" v))
(match p.always with
| true -> "true"
| false -> "false")
let log priority color fmt =
let _log fmt = Logger.log_error ~priority ~color ~logger fmt in
let _nolog fmt = Format.ifprintf Format.std_formatter fmt in
#<If>
_log fmt
#<Else>
_nolog fmt
#<End>
let info fct ?cert ?param fmt =
log Logger.Info `cyan "[SSL] [%s] %s %s %s" fct (string_of_certificate cert) (string_of_param param) fmt
let warning fct fmt =
log Logger.Warning `yellow "[SSL] [%s] %s" fct fmt
let error fct fmt =
log Logger.Error `red "[SSL] [%s] %s" fct fmt
(* ***************** *)
let make_ssl_verify_params ?(client_ca_file="") ?(accept_fun=fun _cert -> false) ?(always=true) cafile capath certpath =
let p = { cafile = if cafile = "" then None else Some cafile
; capath = if capath = "" then None else Some capath
; certpath = if certpath = "" then None else Some certpath
; client_ca_file = if client_ca_file = "" then None else Some client_ca_file
; accept_fun = accept_fun
; always = always } in
info "make_ssl_verify_params" ?param:(Some p) "";
p
let make_ssl_certificate ?cafile ?capath certfile privkey password =
let c = { cert_file = certfile
; cert_privkey = privkey
; cert_password = password
; cert_cafile = cafile
; cert_capath = capath } in
info "make_ssl_certificate" ?cert:(Some c) "";
c
let do_handshake sched conn ?retry ?timeout ssl_s ?err_cont cont =
let retry = Option.default 4 retry in
let err_cont = Option.default (fun _ -> ()) err_cont in
let rec do_retry n () = match n with
| 0 -> err_cont Scheduler.Timeout
| n ->
let no_err =
try Ssl_ext.do_handshake ssl_s;
true with
| Ssl_ext.Handshake_error Ssl.Error_want_read ->
Scheduler.listen_once sched conn ?timeout ~err_cont (do_retry (n-1));
false
| Ssl_ext.Handshake_error Ssl.Error_want_write ->
Scheduler.connect sched conn ?timeout ~err_cont (do_retry (n-1));
false
| (Ssl_ext.Handshake_error e) as ex -> print_endline (Ssl_ext.error_to_string
e);err_cont ex;false
| e -> err_cont e;
false
in
if no_err then cont ()
in
do_retry retry ()
let renegotiate sched conn ?timeout ?retry ssl_s ?err_cont cont =
(*
#<If$minlevel 5>
debug "Net.renegotiate";
#<End>;
*)
let err_cont = Option.default (fun _ -> ()) err_cont in
(try
Ssl_ext.renegotiate ssl_s
with
e -> err_cont e);
let cont' () = do_handshake sched conn ?timeout ?retry ssl_s ~err_cont cont
in do_handshake sched conn ?timeout ?retry ssl_s ~err_cont cont'
(*
#<If$minlevel 5>
debug "Renegotiated cert:\n%s" (Ssl_ext.certificate_to_string certificate digest_name digest_size);
#<End>;
*)
let renegotiate_client sched conn ?timeout ?retry ssl_s ?err_cont cont =
(*
#<If$minlevel 5>
debug "Net.renegotiate";
#<End>;
*)
let err_cont = Option.default (fun _ -> ()) err_cont in
(try
Ssl_ext.renegotiate ssl_s
with
e -> err_cont e);
do_handshake sched conn ?timeout ?retry ssl_s ~err_cont cont
(*
#<If$minlevel 5>
debug "Renegotiated cert:\n%s" (Ssl_ext.certificate_to_string certificate digest_name digest_size);
#<End>;
*)
(* Initialize the SSL library *)
let ssl_init = lazy (
(* DO NOT USE BECAUSE BUGS, and we don't use threads anyway...
Ssl_threads.init () ; *)
Ssl.init();
Ssl_ext.init();
)
(* Create an SSL server context *)
let ssl_server_context() =
Lazy.force ssl_init;
Ssl.create_context Ssl.SSLv23 Ssl.Server_context
(* Create an SSL client context *)
let ssl_client_context() =
Lazy.force ssl_init;
Ssl.create_context Ssl.SSLv23 Ssl.Client_context
(* Digest name and size used for fingerprint *)
let digest_name, digest_size = (* "SHA1", 40 *) "SHA256", 64 (* "SHA512", 128 *)
let compute_fingerprint certificate = Ssl_ext.compute_digest certificate digest_name digest_size
(* Map of valid client certificates
fingerprint -> subject *)
let certs = ref StringMap.empty
let reload_certs ?(extensions=["pem"]) verify_params =
info "reload_certs" ?param:(Some verify_params) (Printf.sprintf "[extensions %s]" (List.fold_left (fun a b -> (Printf.sprintf "%s %s" a b)) "" extensions));
(* Clean the map *)
certs := StringMap.empty;
(* Reload every files in certpath *)
try match verify_params.certpath with
| Some certpath -> File.iter_dir (
fun ~name ~path -> (*name_of_addr*) (
let is_pem = List.fold_left (
fun acc elt -> acc || String.is_suffix elt name
) false extensions in
if not is_pem then () (* Ignore file that does not have the right extension *)
else
begin try
let certificate = Ssl.read_certificate path in
let subject = Ssl.get_subject certificate
and fingerprint = compute_fingerprint certificate in
certs := StringMap.add fingerprint subject !certs;
info "reload_certs" (Printf.sprintf "Certificate loaded:\n%s" (Ssl_ext.certificate_to_string certificate digest_name digest_size))
with
| Ssl.Certificate_error (* read_certificate *)
| Not_found (* get_subject *) -> info "reload_certs" path (* Continue even if one file fails *)
end)
) certpath; true
| _ -> true
with Unix.Unix_error _ (* File.iter_dir fails *) -> false
let validate_certificate certificate verify_params =
(* let hash = Ssl_ext.get_hash certificate in *)
let has_certpath = Option.is_some verify_params.certpath in
let fingerprint = compute_fingerprint certificate in
if not has_certpath || ((* (hash = "" || fingerprint = hash) && *) StringMap.mem fingerprint !certs) then (
info "validate_certificate" (Printf.sprintf "Valid certificate received:\n%s" (Ssl_ext.certificate_to_string certificate digest_name digest_size));
true
) else if verify_params.accept_fun certificate then (
info "validate_certificate" (Printf.sprintf "Certificate accepted:\n%s" (Ssl_ext.certificate_to_string certificate digest_name digest_size));
true
) else (
info "validate_certificate" (Printf.sprintf "Invalid certificate received:\n%s" (Ssl_ext.certificate_to_string certificate digest_name digest_size));
false
)
(* == Public functions == *)
let get_listen_callback sched (server_params, client_params) server_fun =
info "get_listen_callback" "";
let server_params =
match server_params with
| Some sp -> sp
| None -> info "get_listen_callback" "Ssl listening : no server parameters provided"; assert false;
in
let has_cp, has_ca, has_client_ca_file = match client_params with
| Some cp -> true, (Option.is_some cp.cafile || Option.is_some cp.capath), Option.is_some cp.client_ca_file
| _ -> false, false, false in
let has_server_ca = Option.is_some server_params.cert_cafile || Option.is_some server_params.cert_capath in
info "glc" "ctx...";
let ctx = ssl_server_context() in
info "glc" "ctx ok";
if server_params.cert_password <> "" then
Ssl.set_password_callback ctx (fun _ -> server_params.cert_password);
begin try
info "glc" "use_certificate";
Ssl.use_certificate ctx server_params.cert_file server_params.cert_privkey;
info "glc" "load_verify";
Ssl.load_verify_locations ctx (server_params.cert_file) "";
if has_server_ca then (
info "glc" "has_server";
Ssl.load_verify_locations ctx (Option.default "" server_params.cert_cafile) (Option.default "" server_params.cert_capath);
);
info "glc" "set_session";
Ssl_ext.set_session_id_context ctx; (* Must be set, because bugs with firefox otherwise, don't know why... *)
if has_cp then
begin
info "glc" "has cp, set_ctx_opt";
let _ = Ssl_ext.set_ctx_options ctx in
let client_params = Option.get client_params in
if client_params.always then begin
info "glc" "always, verify";
Ssl.set_verify ctx [Ssl.Verify_peer; Ssl.Verify_fail_if_no_peer_cert] (
if has_ca then Some Ssl.client_verify_callback else Some Ssl_ext.no_client_verify_callback
)
end;
if has_ca then begin
info "glc" "has_ca, load";
(* http://www.openssl.org/docs/ssl/SSL_CTX_load_verify_locations.html *)
Ssl.load_verify_locations ctx (Option.default "" client_params.cafile) (Option.default "" client_params.capath);
end;
if has_client_ca_file then (
info "glc" "has_client, set";
(* http://www.openssl.org/docs/ssl/SSL_load_client_CA_file.html *)
Ssl.set_client_CA_list_from_file ctx (Option.default "" client_params.client_ca_file)
);
end
with
| Ssl.Private_key_error as e ->
warning "get_listen_callback" (Printf.sprintf "Error while trying to read private key file %S.\n" server_params.cert_privkey);
raise e
(*ServerLib.do_*)(* exit 1 *)
| Ssl.Certificate_error as e ->
warning "get_listen_callback" (Printf.sprintf "Error while trying to read ssl certificate %S.\n" server_params.cert_file);
raise e
(*ServerLib.do_*)(* exit 1 *)
end;
if has_cp then (
let client_params = Option.get client_params in
(* Load client certificates into memory in order to check client certificates validity *)
begin match client_params.certpath with
| Some _path -> info "glc" "reload_certs..."; ignore (reload_certs client_params)
| _ -> () end;
);
let f (conn: Scheduler.connection_info) =
let fd = Scheduler.get_connection_fd conn in
let ssl_s = Ssl.embed_socket fd ctx in
let rec continuation () =
try
info "glc" "accepting...";
Ssl.accept ssl_s;
info "glc" "accepting: OK";
let valid_cert, cert =
if has_cp then try
let client_params = Option.get client_params in
if client_params.always then (
info "glc" "always, get_certificate...";
let certificate = Ssl.get_certificate ssl_s in
info "glc" "ok get_certificate. validating...";
validate_certificate certificate client_params, Some certificate
)
else true, None
with Ssl.Certificate_error -> false, None
else true, None
in
let sconn = Scheduler.get_connection_secured_from_normal conn ssl_s in
server_fun (SecuredRes (valid_cert, (cert, client_params))) sconn
with Ssl.Accept_error ssl_error ->
match ssl_error with
| Ssl.Error_want_read -> Scheduler.listen_once sched conn continuation
| Ssl.Error_want_write -> Scheduler.connect sched conn continuation
| _ ->
warning "glc" (Printf.sprintf "Ssl.Error_%s : %s"
(Ssl_ext.error_to_string ssl_error) (Ssl.get_error_string()));
Scheduler.remove_connection sched conn
in
info "glc" "listening...";
Scheduler.listen_once sched conn continuation
in
f
(* Private function *)
let verify_certificate certificate verify_params =
info "gss" "get_cert";
(* Check the server certificate validity, or accept it *)
if Option.is_some verify_params.certpath then ignore (reload_certs verify_params);
let valid_cert = validate_certificate certificate verify_params in
if not valid_cert then raise InvalidCertificate;
()
let get_err_cont sched conn err_cont =
let backtrace = Printexc.get_backtrace() in
match err_cont with
| None -> (fun e ->
Scheduler.remove_connection sched conn;
match e with
| Ssl.Accept_error ssl_error ->
warning "SslAS" (Printf.sprintf "Ssl_ssl_error'%s'\n%s" (Ssl_ext.error_to_string ssl_error) backtrace)
| e -> warning "SslAS" (Printf.sprintf "%s\n%s" (Printexc.to_string e) backtrace)
)
| Some f -> f
let connect sched conn (client_certificate, verify_cert) ?err_cont cont =
let ctx = ssl_client_context() in
(* Provide this client certificate if asked *)
let err_cont = get_err_cont sched conn err_cont in
begin match client_certificate with
| Some params ->
if params.cert_password <> "" then (
info "gss" "set_pass_callb";
Ssl.set_password_callback ctx (fun _ -> params.cert_password)
);
begin try
info "gss" "use_certificate";
Ssl.use_certificate ctx params.cert_file params.cert_privkey
with
| Ssl.Private_key_error as e ->
warning "get_secure_socket" (Printf.sprintf "SslAS.client_connect: Error while trying to read private key file %s.\n" params.cert_privkey);
err_cont e
(*ServerLib.do_*)(* exit 1 *)
| Ssl.Certificate_error as e ->
warning "get_secure_socket" (Printf.sprintf "SslAS.client_connect: Error while trying to read ssl certificate %s.\n" params.cert_file);
err_cont e
(*ServerLib.do_*)(* exit 1 *)
end;
| _ -> () end;
(* let _ = Ssl_ext.set_ctx_options ctx in *)
info "gss" "open_conn";
let ssl_sock = Ssl.embed_socket (Scheduler.get_connection_fd conn) ctx in
let ssl_conn = Scheduler.get_connection_secured_from_normal conn ssl_sock in
let cert_cont () =
begin
let certificate = Ssl.get_certificate ssl_sock in
match verify_cert with
| Some vp -> verify_certificate certificate vp
| None -> ()
end;
cont ssl_conn
in
(* We don't use Ssl.open_connection_with_context because we are *)
(* working with non blocking socket *)
let rec connect_cont () =
try
Ssl.connect ssl_sock;
cert_cont ()
with
(* Normal message on non blocking mode. *)
(* We use Epoll to be warned when we can read or wirte *)
| Ssl.Connection_error Ssl.Error_want_read -> info "gss" "want_read"; Scheduler.listen_once sched ssl_conn connect_cont
| Ssl.Connection_error Ssl.Error_want_write -> info "gss" "want_write"; Scheduler.connect sched ssl_conn connect_cont
| (Ssl.Connection_error e) as exn -> (Logger.error "%s" (Ssl_ext.error_to_string e);
err_cont exn)
| exn -> err_cont exn
in
connect_cont ()
let get_valid_certificate sched conn ?timeout ?retry ssl_s cp ?err_cont cont =
let has_ca = Option.is_some cp.cafile || Option.is_some cp.capath in
let validate_cert _ =
let certif = Ssl.get_certificate ssl_s in
let is_valid = validate_certificate certif cp
in cont is_valid in
match
try
info "gvc" "get_cert";
let certif = Ssl.get_certificate ssl_s in
Some (validate_certificate certif cp)
with Ssl.Certificate_error ->
info "gvc" "set_verify";
let cb = if has_ca then Some Ssl.client_verify_callback else Some Ssl_ext.no_client_verify_callback
in Ssl_ext.set_verify ssl_s [Ssl.Verify_peer;Ssl.Verify_fail_if_no_peer_cert] cb;
renegotiate sched conn ?timeout ?retry ssl_s ?err_cont validate_cert;None
with
| Some b -> cont b
| None -> ()
Jump to Line
Something went wrong with that request. Please try again.