CAMLprim value ocaml_EVP_MD_CTX_init(value v_alg) {
CAMLparam1(v_alg);
EVP_MD_CTX *ctx;
const EVP_MD *digest;
char *digest_name = String_val(v_alg);
if (strcmp(digest_name, "sha1") == 0)
digest = EVP_sha1();
else if (strcmp(digest_name, "sha256") == 0)
digest = EVP_sha256();
else {
caml_failwith("Unknown digest name");
CAMLreturn(Val_unit); /* (make compiler happy) */
}
if ((ctx = EVP_MD_CTX_create()) == NULL)
caml_failwith("EVP_MD_CTX_create: out of memory");
EVP_DigestInit_ex(ctx, digest, NULL);
CAMLlocal1(block);
block = caml_alloc_custom(&ctx_ops, sizeof(EVP_MD_CTX*), 0, 1);
Ctx_val(block) = ctx;
CAMLreturn(block);
}
CAMLprim value ocaml_DigestUpdate(value v_ctx, value v_str) {
CAMLparam2(v_ctx, v_str);
EVP_MD_CTX *ctx = Ctx_val(v_ctx);
if (EVP_DigestUpdate(ctx, String_val(v_str), caml_string_length(v_str)) != 1)
caml_failwith("EVP_DigestUpdate: failed");
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_ssl_embed_socket(value socket_, value context)
{
CAMLparam1(context);
CAMLlocal1(block);
#ifdef Socket_val
SOCKET socket = Socket_val(socket_);
#else
int socket = Int_val(socket_);
#endif
SSL_CTX *ctx = Ctx_val(context);
SSL *ssl;
block = caml_alloc_custom(&socket_ops, sizeof(SSL*), 0, 1);
if (socket < 0)
caml_raise_constant(*caml_named_value("ssl_exn_invalid_socket"));
caml_enter_blocking_section();
ssl = SSL_new(ctx);
if (!ssl)
{
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_handler_error"));
}
SSL_set_fd(ssl, socket);
caml_leave_blocking_section();
SSL_val(block) = ssl;
CAMLreturn(block);
}
CAMLprim value ocaml_ssl_ctx_init_dh_from_file(value context, value dh_file_path)
{
CAMLparam2(context, dh_file_path);
DH *dh = NULL;
SSL_CTX *ctx = Ctx_val(context);
char *dh_cfile_path = String_val(dh_file_path);
if(*dh_cfile_path == 0)
caml_raise_constant(*caml_named_value("ssl_exn_diffie_hellman_error"));
dh = load_dh_param(dh_cfile_path);
caml_enter_blocking_section();
if (dh != NULL){
if(SSL_CTX_set_tmp_dh(ctx,dh) != 1){
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_diffie_hellman_error"));
}
SSL_CTX_set_options(ctx, SSL_OP_SINGLE_DH_USE);
caml_leave_blocking_section();
DH_free(dh);
}
else{
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_diffie_hellman_error"));
}
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_ssl_ctx_init_ec_from_named_curve(value context, value curve_name)
{
CAMLparam2(context, curve_name);
EC_KEY *ecdh = NULL;
int nid = 0;
SSL_CTX *ctx = Ctx_val(context);
char *ec_curve_name = String_val(curve_name);
if(*ec_curve_name == 0)
caml_raise_constant(*caml_named_value("ssl_exn_ec_curve_error"));
nid = OBJ_sn2nid(ec_curve_name);
if(nid == 0){
caml_raise_constant(*caml_named_value("ssl_exn_ec_curve_error"));
}
caml_enter_blocking_section();
ecdh = EC_KEY_new_by_curve_name(nid);
if(ecdh != NULL){
if(SSL_CTX_set_tmp_ecdh(ctx,ecdh) != 1){
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_ec_curve_error"));
}
SSL_CTX_set_options(ctx, SSL_OP_SINGLE_ECDH_USE);
caml_leave_blocking_section();
EC_KEY_free(ecdh);
}
else{
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_ec_curve_error"));
}
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_ssl_ctx_use_certificate(value context, value cert, value privkey)
{
CAMLparam3(context, cert, privkey);
SSL_CTX *ctx = Ctx_val(context);
char *cert_name = String_val(cert);
char *privkey_name = String_val(privkey);
caml_enter_blocking_section();
if (SSL_CTX_use_certificate_chain_file(ctx, cert_name) <= 0)
{
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_certificate_error"));
}
if (SSL_CTX_use_PrivateKey_file(ctx, privkey_name, SSL_FILETYPE_PEM) <= 0)
{
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_private_key_error"));
}
if (!SSL_CTX_check_private_key(ctx))
{
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_unmatching_keys"));
}
caml_leave_blocking_section();
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_ssl_ctx_set_verify_depth(value context, value vdepth)
{
SSL_CTX *ctx = Ctx_val(context);
int depth = Int_val(vdepth);
if (depth < 0)
caml_invalid_argument("depth");
caml_enter_blocking_section();
SSL_CTX_set_verify_depth(ctx, depth);
caml_leave_blocking_section();
return Val_unit;
}
CAMLprim value ocaml_DigestFinal_ex(value v_ctx) {
CAMLparam1(v_ctx);
EVP_MD_CTX *ctx = Ctx_val(v_ctx);
unsigned char md_value[EVP_MAX_MD_SIZE];
unsigned int md_len = 0;
if (EVP_DigestFinal_ex(ctx, md_value, &md_len) != 1)
caml_failwith("EVP_DigestFinal_ex: failed");
CAMLlocal1(result);
result = caml_alloc_string(md_len);
memmove(String_val(result), md_value, md_len);
CAMLreturn(result);
}
CAMLprim value ocaml_ssl_ctx_set_default_passwd_cb(value context, value cb)
{
CAMLparam2(context, cb);
SSL_CTX *ctx = Ctx_val(context);
value *pcb;
/* TODO: this never gets freed or even unregistered */
pcb = malloc(sizeof(value));
*pcb = cb;
caml_register_global_root(pcb);
caml_enter_blocking_section();
SSL_CTX_set_default_passwd_cb(ctx, pem_passwd_cb);
SSL_CTX_set_default_passwd_cb_userdata(ctx, pcb);
caml_leave_blocking_section();
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_ssl_ctx_set_cipher_list(value context, value ciphers_string)
{
CAMLparam2(context, ciphers_string);
SSL_CTX *ctx = Ctx_val(context);
char *ciphers = String_val(ciphers_string);
if(*ciphers == 0)
caml_raise_constant(*caml_named_value("ssl_exn_cipher_error"));
caml_enter_blocking_section();
if(SSL_CTX_set_cipher_list(ctx, ciphers) != 1)
{
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_cipher_error"));
}
caml_leave_blocking_section();
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_ssl_ctx_set_verify(value context, value vmode, value vcallback)
{
CAMLparam3(context, vmode, vcallback);
SSL_CTX *ctx = Ctx_val(context);
int mode = 0;
value mode_tl = vmode;
int (*callback) (int, X509_STORE_CTX*) = NULL;
if (Is_long(vmode))
mode = SSL_VERIFY_NONE;
while (Is_block(mode_tl))
{
switch(Int_val(Field(mode_tl, 0)))
{
case 0:
mode |= SSL_VERIFY_PEER;
break;
case 1:
mode |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT | SSL_VERIFY_PEER;
break;
case 2:
mode |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER;
break;
default:
caml_invalid_argument("mode");
}
mode_tl = Field(mode_tl, 1);
}
if (Is_block(vcallback))
callback = (int(*) (int, X509_STORE_CTX*))Field(vcallback, 0);
caml_enter_blocking_section();
SSL_CTX_set_verify(ctx, mode, callback);
caml_leave_blocking_section();
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_ssl_ctx_set_client_CA_list_from_file(value context, value vfilename)
{
CAMLparam2(context, vfilename);
SSL_CTX *ctx = Ctx_val(context);
char *filename = String_val(vfilename);
STACK_OF(X509_NAME) *cert_names;
caml_enter_blocking_section();
cert_names = SSL_load_client_CA_file(filename);
if (cert_names != 0)
SSL_CTX_set_client_CA_list(ctx, cert_names);
else
{
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_certificate_error"));
}
caml_leave_blocking_section();
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_ssl_ctx_load_verify_locations(value context, value ca_file, value ca_path)
{
CAMLparam3(context, ca_file, ca_path);
SSL_CTX *ctx = Ctx_val(context);
char *CAfile = String_val(ca_file);
char *CApath = String_val(ca_path);
if(*CAfile == 0)
CAfile = NULL;
if(*CApath == 0)
CApath = NULL;
caml_enter_blocking_section();
if(SSL_CTX_load_verify_locations(ctx, CAfile, CApath) != 1)
{
caml_leave_blocking_section();
caml_invalid_argument("cafile or capath");
}
caml_leave_blocking_section();
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_ssl_create_context(value protocol, value type)
{
value block;
SSL_CTX *ctx;
const SSL_METHOD *method = get_method(Int_val(protocol), Int_val(type));
caml_enter_blocking_section();
ctx = SSL_CTX_new(method);
if (!ctx)
{
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_context_error"));
}
/* In non-blocking mode, accept a buffer with a different address on
a write retry (since the GC may need to move it). In blocking
mode, hide SSL_ERROR_WANT_(READ|WRITE) from us. */
SSL_CTX_set_mode(ctx, SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER | SSL_MODE_AUTO_RETRY);
caml_leave_blocking_section();
block = caml_alloc_custom(&ctx_ops, sizeof(SSL_CTX*), 0, 1);
Ctx_val(block) = ctx;
return block;
}
static void finalize_ctx(value block)
{
EVP_MD_CTX *ctx = Ctx_val(block);
EVP_MD_CTX_destroy(ctx);
}
static void finalize_ctx(value block)
{
SSL_CTX *ctx = Ctx_val(block);
SSL_CTX_free(ctx);
}
