/* OCaml bindings for libvirt.
- * (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+ * (C) Copyright 2007-2017 Richard W.M. Jones, Red Hat Inc.
* http://libvirt.org/
*
* This library is free software; you can redistribute it and/or
CAMLreturn (rv);
}
+/* Helper struct holding data needed for the helper C authentication
+ * callback (which will call the actual OCaml callback).
+ */
+struct ocaml_auth_callback_data {
+ value *fvp; /* The OCaml auth callback. */
+};
+
+static int
+_ocaml_auth_callback (virConnectCredentialPtr cred, unsigned int ncred, void *cbdata)
+{
+ CAMLparam0 ();
+ CAMLlocal4 (listv, elemv, rv, v);
+ struct ocaml_auth_callback_data *s = cbdata;
+ int i, len;
+
+ listv = Val_emptylist;
+ for (i = ncred - 1; i >= 0; --i) {
+ elemv = caml_alloc (2, 0);
+ Store_field (elemv, 0, Val_virconnectcredential (&cred[i]));
+ Store_field (elemv, 1, listv);
+ listv = elemv;
+ }
+
+ /* Call the auth callback. */
+ rv = caml_callback_exn (*s->fvp, listv);
+ if (Is_exception_result (rv)) {
+ /* The callback raised an exception, so return an error. */
+ CAMLreturnT (int, -1);
+ }
+
+ len = _list_length (rv);
+ if (len != (int) ncred) {
+ /* The callback did not return the same number of results as the
+ * credentials.
+ */
+ CAMLreturnT (int, -1);
+ }
+
+ for (i = 0; rv != Val_emptylist; rv = Field (rv, 1), ++i) {
+ virConnectCredentialPtr c = &cred[i];
+ elemv = Field (rv, 0);
+ if (elemv == Val_int (0)) {
+ c->result = NULL;
+ c->resultlen = 0;
+ } else {
+ v = Field (elemv, 0);
+ len = caml_string_length (v);
+ c->result = malloc (len + 1);
+ if (c->result == NULL)
+ CAMLreturnT (int, -1);
+ memcpy (c->result, String_val (v), len);
+ c->result[len] = '\0';
+ c->resultlen = len;
+ }
+ }
+
+ CAMLreturnT (int, 0);
+}
+
+static virConnectPtr
+_ocaml_libvirt_connect_open_auth_common (value namev, value authv, int flags)
+{
+ CAMLparam2 (namev, authv);
+ CAMLlocal2 (listv, fv);
+ virConnectPtr conn;
+ virConnectAuth auth;
+ struct ocaml_auth_callback_data data;
+ int i;
+ char *name = NULL;
+
+ /* Keep a copy of the 'namev' string, as its value could move around
+ * when calling other OCaml code that allocates memory.
+ */
+ if (namev != Val_int (0)) { /* Some string */
+ name = strdup (String_val (Field (namev, 0)));
+ if (name == NULL)
+ caml_raise_out_of_memory ();
+ }
+
+ fv = Field (authv, 1);
+ data.fvp = &fv;
+
+ listv = Field (authv, 0);
+ auth.ncredtype = _list_length (listv);
+ auth.credtype = malloc (sizeof (int) * auth.ncredtype);
+ if (auth.credtype == NULL)
+ caml_raise_out_of_memory ();
+ for (i = 0; listv != Val_emptylist; listv = Field (listv, 1), ++i) {
+ auth.credtype[i] = Int_val (Field (listv, 0)) + 1;
+ }
+ auth.cb = &_ocaml_auth_callback;
+ auth.cbdata = &data;
+
+ /* Call virConnectOpenAuth directly, without using the NONBLOCKING
+ * macro, as this will indeed call ocaml_* APIs, and run OCaml code.
+ */
+ conn = virConnectOpenAuth (name, &auth, flags);
+ free (auth.credtype);
+ free (name);
+ CHECK_ERROR (!conn, "virConnectOpenAuth");
+
+ CAMLreturnT (virConnectPtr, conn);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_open_auth (value namev, value authv)
+{
+ CAMLparam2 (namev, authv);
+ CAMLlocal1 (rv);
+ virConnectPtr conn;
+
+ conn = _ocaml_libvirt_connect_open_auth_common (namev, authv, 0);
+ rv = Val_connect (conn);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_open_auth_readonly (value namev, value authv)
+{
+ CAMLparam2 (namev, authv);
+ CAMLlocal1 (rv);
+ virConnectPtr conn;
+
+ conn = _ocaml_libvirt_connect_open_auth_common (namev, authv, VIR_CONNECT_RO);
+ rv = Val_connect (conn);
+
+ CAMLreturn (rv);
+}
+
CAMLprim value
ocaml_libvirt_connect_get_version (value connv)
{
CAMLreturn(Val_unit);
}
-
CAMLprim value
ocaml_libvirt_domain_get_id (value domv)
{
CAMLreturn (cpustats);
}
+value
+ocaml_libvirt_domain_get_all_domain_stats (value connv,
+ value statsv, value flagsv)
+{
+ CAMLparam3 (connv, statsv, flagsv);
+ CAMLlocal5 (rv, dsv, tpv, v, v1);
+ CAMLlocal1 (v2);
+ virConnectPtr conn = Connect_val (connv);
+ virDomainStatsRecordPtr *rstats;
+ unsigned int stats = 0, flags = 0;
+ int i, j, r;
+ unsigned char uuid[VIR_UUID_BUFLEN];
+
+ /* Get stats and flags. */
+ for (; statsv != Val_int (0); statsv = Field (statsv, 1)) {
+ v = Field (statsv, 0);
+ if (v == Val_int (0))
+ stats |= VIR_DOMAIN_STATS_STATE;
+ else if (v == Val_int (1))
+ stats |= VIR_DOMAIN_STATS_CPU_TOTAL;
+ else if (v == Val_int (2))
+ stats |= VIR_DOMAIN_STATS_BALLOON;
+ else if (v == Val_int (3))
+ stats |= VIR_DOMAIN_STATS_VCPU;
+ else if (v == Val_int (4))
+ stats |= VIR_DOMAIN_STATS_INTERFACE;
+ else if (v == Val_int (5))
+ stats |= VIR_DOMAIN_STATS_BLOCK;
+ else if (v == Val_int (6))
+ stats |= VIR_DOMAIN_STATS_PERF;
+ }
+ for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1)) {
+ v = Field (flagsv, 0);
+ if (v == Val_int (0))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_ACTIVE;
+ else if (v == Val_int (1))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_INACTIVE;
+ else if (v == Val_int (2))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_OTHER;
+ else if (v == Val_int (3))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_PAUSED;
+ else if (v == Val_int (4))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_PERSISTENT;
+ else if (v == Val_int (5))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_RUNNING;
+ else if (v == Val_int (6))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_SHUTOFF;
+ else if (v == Val_int (7))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_TRANSIENT;
+ else if (v == Val_int (8))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_BACKING;
+ else if (v == Val_int (9))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_ENFORCE_STATS;
+ }
+
+ NONBLOCKING (r = virConnectGetAllDomainStats (conn, stats, &rstats, flags));
+ CHECK_ERROR (r == -1, "virConnectGetAllDomainStats");
+
+ rv = caml_alloc (r, 0); /* domain_stats_record array. */
+ for (i = 0; i < r; ++i) {
+ dsv = caml_alloc (2, 0); /* domain_stats_record */
+
+ /* Libvirt returns something superficially resembling a
+ * virDomainPtr, but it's not a real virDomainPtr object
+ * (eg. dom->id == -1, and its refcount is wrong). The only thing
+ * we can safely get from it is the UUID.
+ */
+ v = caml_alloc_string (VIR_UUID_BUFLEN);
+ virDomainGetUUID (rstats[i]->dom, uuid);
+ memcpy (String_val (v), uuid, VIR_UUID_BUFLEN);
+ Store_field (dsv, 0, v);
+
+ tpv = caml_alloc (rstats[i]->nparams, 0); /* typed_param array */
+ for (j = 0; j < rstats[i]->nparams; ++j) {
+ v2 = caml_alloc (2, 0); /* typed_param: field name, value */
+ Store_field (v2, 0, caml_copy_string (rstats[i]->params[j].field));
+
+ switch (rstats[i]->params[j].type) {
+ case VIR_TYPED_PARAM_INT:
+ v1 = caml_alloc (1, 0);
+ v = caml_copy_int32 (rstats[i]->params[j].value.i);
+ break;
+ case VIR_TYPED_PARAM_UINT:
+ v1 = caml_alloc (1, 1);
+ v = caml_copy_int32 (rstats[i]->params[j].value.ui);
+ break;
+ case VIR_TYPED_PARAM_LLONG:
+ v1 = caml_alloc (1, 2);
+ v = caml_copy_int64 (rstats[i]->params[j].value.l);
+ break;
+ case VIR_TYPED_PARAM_ULLONG:
+ v1 = caml_alloc (1, 3);
+ v = caml_copy_int64 (rstats[i]->params[j].value.ul);
+ break;
+ case VIR_TYPED_PARAM_DOUBLE:
+ v1 = caml_alloc (1, 4);
+ v = caml_copy_double (rstats[i]->params[j].value.d);
+ break;
+ case VIR_TYPED_PARAM_BOOLEAN:
+ v1 = caml_alloc (1, 5);
+ v = Val_bool (rstats[i]->params[j].value.b);
+ break;
+ case VIR_TYPED_PARAM_STRING:
+ v1 = caml_alloc (1, 6);
+ v = caml_copy_string (rstats[i]->params[j].value.s);
+ break;
+ default:
+ virDomainStatsRecordListFree (rstats);
+ caml_failwith ("virConnectGetAllDomainStats: "
+ "unknown parameter type returned");
+ }
+ Store_field (v1, 0, v);
+
+ Store_field (v2, 1, v1);
+ Store_field (tpv, j, v2);
+ }
+
+ Store_field (dsv, 1, tpv);
+ Store_field (rv, i, dsv);
+ }
+
+ virDomainStatsRecordListFree (rstats);
+ CAMLreturn (rv);
+}
+
CAMLprim value
ocaml_libvirt_domain_migrate_native (value domv, value dconnv, value flagsv, value optdnamev, value opturiv, value optbandwidthv, value unitv)
{
argv[3], argv[4], argv[5]);
}
+CAMLprim value
+ocaml_libvirt_domain_get_xml_desc_flags (value domv, value flagsv)
+{
+ CAMLparam2 (domv, flagsv);
+ CAMLlocal2 (rv, flagv);
+ virDomainPtr dom = Domain_val (domv);
+ int flags = 0;
+ char *r;
+
+ /* Do flags. */
+ for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1))
+ {
+ flagv = Field (flagsv, 0);
+ if (flagv == Val_int (0))
+ flags |= VIR_DOMAIN_XML_SECURE;
+ else if (flagv == Val_int (1))
+ flags |= VIR_DOMAIN_XML_INACTIVE;
+ else if (flagv == Val_int (2))
+ flags |= VIR_DOMAIN_XML_UPDATE_CPU;
+ else if (flagv == Val_int (3))
+ flags |= VIR_DOMAIN_XML_MIGRATABLE;
+ }
+
+ NONBLOCKING (r = virDomainGetXMLDesc (dom, flags));
+ CHECK_ERROR (!r, "virDomainGetXMLDesc");
+
+ rv = caml_copy_string (r);
+ free (r);
+ CAMLreturn (rv);
+}
+
/*----------------------------------------------------------------------*/
/* Domain events */
git.annexia.org / ocaml-libvirt.git / blobdiff