(*
 Copyright (C) 2003-2005 Samuel Mimram

 This file is part of Ocaml-ssl.

 This library is free software; you can redistribute it and/or
 modify it under the terms of the GNU Lesser General Public
 License as published by the Free Software Foundation; either
 version 2.1 of the License, or (at your option) any later version.

 This library 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
 Lesser General Public License for more details.

 You should have received a copy of the GNU Lesser General Public
 License along with this library; if not, write to the Free Software
 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
 *)

(* $Id: ssl.ml 2683 2006-08-28 14:53:19Z smimram $ *)

type protocol =
  | SSLv2
  | SSLv23
  | SSLv3
  | TLSv1

type context

type certificate

type socket

type ssl_error =
  | Error_none
  | Error_ssl
  | Error_want_read
  | Error_want_write
  | Error_want_x509_lookup
  | Error_syscall
  | Error_zero_return
  | Error_want_connect
  | Error_want_accept

type verify_error =
  | Error_v_unable_to_get_issuer_cert (** Tthe issuer certificate could not be found: this occurs if the issuer certificate of an untrusted certificate cannot be found.*)
  | Error_v_unable_to_get_ctl (** The CRL of a certificate could not be found. Unused. *)
  | Error_v_unable_to_decrypt_cert_signature (** The certificate signature could not be decrypted. This means that the actual signature value could not be determined rather than it not matching the expected value, this is only meaningful for RSA keys.*)
  | Error_v_unable_to_decrypt_CRL_signature (** The CRL signature could not be decrypted: this means that the actual signature value could not be determined rather than it not matching the expected value. Unused. *)
  | Error_v_unable_to_decode_issuer_public_key (** The public key in the certificate SubjectPublicKeyInfo could not be read. *)
  | Error_v_cert_signature_failure (** The signature of the certificate is invalid. *)
  | Error_v_CRL_signature_failure (** The signature of the certificate is invalid. Unused. *)
  | Error_v_cert_not_yet_valid (** The certificate is not yet valid: the notBefore date is after the current time. *)
  | Error_v_cert_has_expired (** The certificate has expired: that is the notAfter date is before the current time. *)
  | Error_v_CRL_not_yet_valid (** The CRL is not yet valid. Unused. *)
  | Error_v_CRL_has_expired (** The CRL has expired. Unused. *)
  | Error_v_error_in_cert_not_before_field (** The certificate notBefore field contains an invalid time. *)
  | Error_v_error_in_cert_not_after_field (** The certificate notAfter field contains an invalid time. *)
  | Error_v_error_in_CRL_last_update_field (** The CRL lastUpdate field contains an invalid time. Unused. *)
  | Error_v_error_in_CRL_next_update_field (** The CRL nextUpdate field contains an invalid time. Unused. *)
  | Error_v_out_of_mem (** An error occurred trying to allocate memory. This should never happen. *)
  | Error_v_depth_zero_self_signed_cert (** The passed certificate is self signed and the same certificate cannot be found in the list of trusted certificates. *)
  | Error_v_self_signed_cert_in_chain (** The certificate chain could be built up using the untrusted certificates but the root could not be found locally. *)
  | Error_v_unable_to_get_issuer_cert_locally (** The issuer certificate of a locally looked up certificate could not be found. This normally means the list of trusted certificates is not complete. *)
  | Error_v_unable_to_verify_leaf_signature (** No signatures could be verified because the chain contains only one certificate and it is not self signed. *)
  | Error_v_cert_chain_too_long (** The certificate chain length is greater than the supplied maximum depth. Unused. *)
  | Error_v_cert_revoked (** The certificate has been revoked. Unused. *)
  | Error_v_invalid_CA (** A CA certificate is invalid. Either it is not a CA or its extensions are not consistent with the supplied purpose. *)
  | Error_v_path_length_exceeded (** The basicConstraints pathlength parameter has been exceeded. *)
  | Error_v_invalid_purpose (** The supplied certificate cannot be used for the specified purpose. *)
  | Error_v_cert_untrusted (** The root CA is not marked as trusted for the specified purpose. *)
  | Error_v_cert_rejected (** The root CA is marked to reject the specified purpose. *)
  | Error_v_subject_issuer_mismatch (** The current candidate issuer certificate was rejected because its subject name did not match the issuer name of the current certificate. *)
  | Error_v_akid_skid_mismatch (** The current candidate issuer certificate was rejected because its subject key identifier was present and did not match the authority key identifier current certificate. *)
  | Error_v_akid_issuer_serial_mismatch (** The current candidate issuer certificate was rejected because its issuer name and serial number was present and did not match the authority key identifier of the current certificate. *)
  | Error_v_keyusage_no_certsign (** The current candidate issuer certificate was rejected because its keyUsage extension does not permit certificate signing. *)
  | Error_v_application_verification (** An application specific error. Unused. *)

exception Method_error
exception Context_error
exception Certificate_error
exception Cipher_error
exception Private_key_error
exception Unmatching_keys
exception Invalid_socket
exception Handler_error
exception Connection_error of ssl_error
exception Accept_error of ssl_error
exception Read_error of ssl_error
exception Write_error of ssl_error
exception Verify_error of verify_error

let _ =
  Callback.register_exception "ssl_exn_method_error" Method_error;
  Callback.register_exception "ssl_exn_context_error" Context_error;
  Callback.register_exception "ssl_exn_certificate_error" Certificate_error;
  Callback.register_exception "ssl_exn_cipher_error" Cipher_error;
  Callback.register_exception "ssl_exn_private_key_error" Private_key_error;
  Callback.register_exception "ssl_exn_unmatching_keys" Unmatching_keys;
  Callback.register_exception "ssl_exn_invalid_socket" Invalid_socket;
  Callback.register_exception "ssl_exn_handler_error" Handler_error;
  Callback.register_exception "ssl_exn_connection_error" (Connection_error Error_none);
  Callback.register_exception "ssl_exn_accept_error" (Accept_error Error_none);
  Callback.register_exception "ssl_exn_read_error" (Read_error Error_none);
  Callback.register_exception "ssl_exn_write_error" (Write_error Error_none);
  Callback.register_exception "ssl_exn_verify_error" (Verify_error Error_v_application_verification)

external init : bool -> unit = "ocaml_ssl_init"

external get_error_string : unit -> string = "ocaml_ssl_get_error_string"

external crypto_num_locks : unit -> int = "ocaml_ssl_crypto_num_locks"

let thread_id_function = ref None

let _ =
  Callback.register "caml_ssl_thread_id_function" thread_id_function

let thread_locking_function = ref None

let _ =
  Callback.register "caml_ssl_thread_locking_function" thread_locking_function

let init () =
  match !thread_locking_function with
    | None -> init false
    | Some _ -> init true

type context_type =
  | Client_context
  | Server_context
  | Both_context

external create_context : protocol -> context_type -> context = "ocaml_ssl_create_context"

external use_certificate : context -> string -> string -> unit = "ocaml_ssl_ctx_use_certificate"

external set_password_callback : context -> (bool -> string) -> unit = "ocaml_ssl_ctx_set_default_passwd_cb"

external embed_socket : Unix.file_descr -> context -> socket = "ocaml_ssl_embed_socket"

external set_cipher_list : context -> string -> unit = "ocaml_ssl_ctx_set_cipher_list"

external load_verify_locations : context -> string -> string -> unit = "ocaml_ssl_ctx_load_verify_locations"

external get_verify_result : socket -> int = "ocaml_ssl_get_verify_result"

type verify_mode =
  | Verify_peer
  | Verify_fail_if_no_peer_cert
  | Verify_client_once

type verify_callback

external get_client_verify_callback_ptr : unit -> verify_callback = "ocaml_ssl_get_client_verify_callback_ptr"

let client_verify_callback = get_client_verify_callback_ptr ()

external set_verify : context -> verify_mode list -> verify_callback option -> unit = "ocaml_ssl_ctx_set_verify"

external set_verify_depth : context -> int -> unit = "ocaml_ssl_ctx_set_verify_depth"

external set_client_CA_list_from_file : context -> string -> unit = "ocaml_ssl_ctx_set_client_CA_list_from_file"

type cipher

external get_cipher : socket -> cipher = "ocaml_ssl_get_current_cipher"

external get_cipher_description : cipher -> string = "ocaml_ssl_get_cipher_description"

(* TODO: get_cipher_bits *)

external get_cipher_name : cipher -> string = "ocaml_ssl_get_cipher_name"

external get_cipher_version : cipher -> string = "ocaml_ssl_get_cipher_version"

external get_certificate : socket -> certificate = "ocaml_ssl_get_certificate"

external read_certificate : string -> certificate = "ocaml_ssl_read_certificate"

external get_issuer : certificate -> string = "ocaml_ssl_get_issuer"

external get_subject : certificate -> string = "ocaml_ssl_get_subject"

external file_descr_of_socket : socket -> Unix.file_descr = "ocaml_ssl_get_file_descr"

external connect : socket -> unit = "ocaml_ssl_connect"

external verify : socket -> unit = "ocaml_ssl_verify"

external write : socket -> string -> int -> int -> int = "ocaml_ssl_write"

external read : socket -> string -> int -> int -> int = "ocaml_ssl_read"

external accept : socket -> unit = "ocaml_ssl_accept"

external flush : socket -> unit = "ocaml_ssl_flush"

external shutdown : socket -> unit = "ocaml_ssl_shutdown"

let open_connection_with_context context sockaddr =
  let domain =
    match sockaddr with
      | Unix.ADDR_UNIX _ -> Unix.PF_UNIX
      | Unix.ADDR_INET(_, _) -> Unix.PF_INET
  in
  let sock =
    Unix.socket domain Unix.SOCK_STREAM 0 in
    try
      Unix.connect sock sockaddr;
      let ssl = embed_socket sock context in
        connect ssl; ssl
    with
      | exn -> Unix.close sock; raise exn

let open_connection ssl_method sockaddr =
  open_connection_with_context (create_context ssl_method Client_context) sockaddr

let shutdown_connection = shutdown

let output_string ssl s =
  ignore (write ssl s 0 (String.length s))

let output_char ssl c =
  let tmp = String.create 1 in
    tmp.[0] <- c;
    ignore (write ssl tmp 0 1)

let output_int ssl i =
  let tmp = String.create 4 in
    tmp.[0] <- char_of_int (i lsr 24);
    tmp.[1] <- char_of_int ((i lsr 16) land 0xff);
    tmp.[2] <- char_of_int ((i lsr 8) land 0xff);
    tmp.[3] <- char_of_int (i land 0xff);
    if write ssl tmp 0 4 <> 4 then failwith "output_int error: all the byte were not sent"

let input_string ssl =
  let bufsize = 1024 in
  let buf = String.create bufsize in
  let ret = ref "" in
  let r = ref 1 in
    while !r <> 0
    do
      r := read ssl buf 0 bufsize;
      ret := !ret ^ (String.sub buf 0 !r)
    done;
    !ret

let input_char ssl =
  let tmp = String.create 1 in
    if read ssl tmp 0 1 <> 1 then
      raise End_of_file
    else
      tmp.[0]

let input_int ssl =
  let i = ref 0 in
  let tmp = String.create 4 in
    ignore (read ssl tmp 0 4);
    i := int_of_char (tmp.[0]);
    i := (!i lsl 8) + int_of_char (tmp.[1]);
    i := (!i lsl 8) + int_of_char (tmp.[2]);
    i := (!i lsl 8) + int_of_char (tmp.[3]);
    !i