// Called by the host app to create a TLS connection.
int FFI_mitls_connect(struct _FFI_mitls_callbacks *callbacks, /* in */ mitls_state *state, /* out */ char **outmsg, /* out */ char **errmsg)
{
CAMLparam0();
CAMLlocal1(result);
int ret;
*outmsg = NULL;
*errmsg = NULL;
caml_acquire_runtime_system();
result = caml_callback2_exn(*g_mitls_FFI_Connect, state->fstar_state, PtrToValue(callbacks));
if (Is_exception_result(result)) {
// Call caml_format_exception(Extract_exception(result)) to extract the exception text
ret = 0;
} else {
// Connect returns back (Connection.connection * int)
value connection = Field(result,0);
ret = Int_val(Field(result,1));
if (ret == 0) {
caml_modify_generational_global_root(&state->fstar_state, connection);
ret = 1;
} else {
ret = 0;
}
// The result is an integer. How to deduce the value of 'c' needed for
// subsequent FFI.read and FFI.write is TBD.
}
caml_release_runtime_system();
CAMLreturnT(int,ret);
}
CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
{
CAMLparam1 (closure);
CAMLxparamN (args, narg);
CAMLlocal1 (res);
int i;
res = closure;
for (i = 0; i < narg; /*nothing*/) {
/* Pass as many arguments as possible */
switch (narg - i) {
case 1:
res = caml_callback_exn(res, args[i]);
if (Is_exception_result(res)) CAMLreturn (res);
i += 1;
break;
case 2:
res = caml_callback2_exn(res, args[i], args[i + 1]);
if (Is_exception_result(res)) CAMLreturn (res);
i += 2;
break;
default:
res = caml_callback3_exn(res, args[i], args[i + 1], args[i + 2]);
if (Is_exception_result(res)) CAMLreturn (res);
i += 3;
break;
}
}
CAMLreturn (res);
}
static inline int exec_not_null_callback(
void *cbx_, int num_columns, char **row, char **header)
{
callback_with_exn *cbx = cbx_;
value v_row, v_header, v_ret;
caml_leave_blocking_section();
v_row = copy_not_null_string_array((const char **) row, num_columns);
if (v_row == (value) NULL) return 1;
Begin_roots1(v_row);
v_header = safe_copy_string_array((const char **) header, num_columns);
End_roots();
v_ret = caml_callback2_exn(*cbx->cbp, v_row, v_header);
if (Is_exception_result(v_ret)) {
*cbx->exn = Extract_exception(v_ret);
caml_enter_blocking_section();
return 1;
}
caml_enter_blocking_section();
return 0;
}
// Called by the host app to configure miTLS ahead of creating a connection
int FFI_mitls_configure(mitls_state **state, const char *tls_version, const char *host_name, char **outmsg, char **errmsg)
{
CAMLparam0();
CAMLlocal3(config, version, host);
int ret = 0;
*state = NULL;
*outmsg = NULL;
*errmsg = NULL;
version = caml_copy_string(tls_version);
host = caml_copy_string(host_name);
caml_acquire_runtime_system();
config = caml_callback2_exn(*g_mitls_FFI_Config, version, host);
if (Is_exception_result(config)) {
// call caml_format_exception(Extract_exception(config)) to extract the exception information
} else {
mitls_state * s;
// Allocate space on the heap, to store an OCaml value
s = (mitls_state*)malloc(sizeof(mitls_state));
if (s) {
// Tell the OCaml GC about the heap address, so it is treated
// as a GC root, keeping the config object live.
s->fstar_state = config;
caml_register_generational_global_root(&s->fstar_state);
*state = s;
ret = 1;
}
}
caml_release_runtime_system();
CAMLreturnT(int,ret);
}
value* fdarray_get(value* in1, value* in2)
{
value a;
CLOSURE("FdArray.get");
a = caml_callback2_exn(*closure, *in1, *in2);
if Is_exception_result(a) return 0;
return fcl_wrap(a);
}
value* cstr_xor(value* in1, value* in2)
{
value a;
CLOSURE ("Cstr.xor");
a = caml_callback2_exn(*closure, *in1, *in2);
if Is_exception_result(a) return 0;
return fcl_wrap(a);
}
cairo_status_t
ml_cairo_unsafe_read_func (void *closure, unsigned char *data, unsigned int length)
{
value res, *c = closure;
res = caml_callback2_exn (Field (*c, 0), Val_bp (data), Val_int (length));
if (Is_exception_result (res))
{
Store_field (*c, 1, res);
return CAIRO_STATUS_READ_ERROR;
}
return CAIRO_STATUS_SUCCESS;
}
static int callml_custom_setscalingvectors(SUNLinearSolver ls,
N_Vector s1, N_Vector s2)
{
CAMLparam0();
CAMLlocal3(r, ss1, ss2);
ss1 = Val_none;
if (s1 != NULL) Store_some(ss1, NVEC_BACKLINK(s1));
ss2 = Val_none;
if (s2 != NULL) Store_some(ss2, NVEC_BACKLINK(s2));
r = caml_callback2_exn(GET_OP(ls, SET_SCALING_VECTORS), ss1, ss2);
CAMLreturnT(int, CHECK_EXCEPTION_SUCCESS(r));
}
static int bbbdlocal(sundials_ml_index nlocal, realtype t, N_Vector y,
N_Vector yb, N_Vector glocal, void *user_data)
{
CAMLparam0();
CAMLlocal3(args, session, cb);
args = caml_alloc_tuple (RECORD_CVODES_ADJ_BRHSFN_ARGS_SIZE);
Store_field (args, RECORD_CVODES_ADJ_BRHSFN_ARGS_T, caml_copy_double (t));
Store_field (args, RECORD_CVODES_ADJ_BRHSFN_ARGS_Y, NVEC_BACKLINK (y));
Store_field (args, RECORD_CVODES_ADJ_BRHSFN_ARGS_YB, NVEC_BACKLINK (yb));
WEAK_DEREF (session, *(value*)user_data);
cb = CVODE_LS_PRECFNS_FROM_ML (session);
cb = Field (cb, 0);
cb = Field (cb, RECORD_CVODES_BBBD_PRECFNS_LOCAL_FN);
assert (Tag_val (cb) == Closure_tag);
/* NB: Don't trigger GC while processing this return value! */
value r = caml_callback2_exn (cb, args, NVEC_BACKLINK (glocal));
CAMLreturnT(int, CHECK_EXCEPTION (session, r, RECOVERABLE));
}
// Called by the host app transmit a packet
int FFI_mitls_send(/* in */ mitls_state *state, const void* buffer, size_t buffer_size, /* out */ char **outmsg, /* out */ char **errmsg)
{
CAMLparam0();
CAMLlocal2(buffer_value, result);
int ret = 0;
*outmsg = NULL;
*errmsg = NULL;
caml_acquire_runtime_system();
buffer_value = caml_alloc_string(buffer_size);
memcpy(Bp_val(buffer_value), buffer, buffer_size);
result = caml_callback2_exn(*g_mitls_FFI_Send, state->fstar_state, buffer_value);
if (Is_exception_result(result)) {
// Call caml_format_exception(Extract_exception(result)) to extract the exception text
ret = 0;
} else {
ret = 1;
}
caml_release_runtime_system();
CAMLreturnT(int,ret);
}
CAMLexport value caml_callback2 (value closure, value arg1, value arg2)
{
value res = caml_callback2_exn(closure, arg1, arg2);
if (Is_exception_result(res)) caml_raise(Extract_exception(res));
return res;
}
static void
uwt_udp_recv_own_cb(uv_udp_t* handle,
ssize_t nread,
const uv_buf_t* buf,
const struct sockaddr* addr,
unsigned int flags)
{
HANDLE_CB_INIT_WITH_CLEAN(uh, handle);
value exn = Val_unit;
#ifndef UWT_NO_COPY_READ
bool buf_not_cleaned = true;
const int read_ba = uh->use_read_ba;
#else
(void) buf;
#endif
if ( uh->close_called == 0 && (nread != 0 || addr != NULL) ){
/* nread == 0 && addr == NULL only means we need to clear
the buffer */
assert ( uh->cb_read != CB_INVALID );
value param;
if ( nread < 0 ){
param = caml_alloc_small(1,Error_tag);
Field(param,0) = Val_uwt_error(nread);
}
else {
value triple = Val_unit;
value sockaddr = Val_unit;
param = Val_unit;
Begin_roots3(triple,sockaddr,param);
value is_partial;
if ( addr != NULL ){
param = uwt__alloc_sockaddr(addr);
if ( param != Val_unit ){
sockaddr = caml_alloc_small(1,Some_tag);
Field(sockaddr,0) = param;
}
}
if ( flags & UV_UDP_PARTIAL ){
is_partial = Val_long(1);
}
else {
is_partial = Val_long(0);
}
#ifndef UWT_NO_COPY_READ
if ( nread != 0 && read_ba == 0 ){
value o = Field(GET_CB_VAL(uh->cb_read),0);
memcpy(String_val(o) + uh->x.obuf_offset, buf->base, nread);
}
#endif
triple = caml_alloc_small(3,0);
Field(triple,0) = Val_long(nread);
Field(triple,1) = is_partial;
Field(triple,2) = sockaddr;
param = caml_alloc_small(1,Ok_tag);
Field(param,0) = triple;
End_roots();
}
#ifndef UWT_NO_COPY_READ
if ( buf->base && read_ba == 0 ){
buf_not_cleaned = false;
uwt__free_uv_buf_t_const(buf);
}
#endif
uh->can_reuse_cb_read = 1;
uh->read_waiting = 0;
uh->in_use_cnt--;
exn = Field(GET_CB_VAL(uh->cb_read),1);
uwt__gr_unregister(&uh->cb_read);
exn = caml_callback2_exn(*uwt__global_wakeup,exn,param);
if ( uh->close_called == 0 && uh->can_reuse_cb_read == 1 ){
uv_udp_recv_stop(handle);
uh->can_reuse_cb_read = 0;
}
}
#ifndef UWT_NO_COPY_READ
if ( read_ba == 0 && buf_not_cleaned && buf->base ){
uwt__free_uv_buf_t_const(buf);
}
#endif
HANDLE_CB_RET(exn);
}
