Skip to content
This repository
tag: v1574
Fetching contributors…

Cannot retrieve contributors at this time

file 475 lines (424 sloc) 18.938 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475
(*
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 -> ()
Something went wrong with that request. Please try again.