libvirt/libvirt_c_oneoffs.c

   1 /* OCaml bindings for libvirt.
   2  * (C) Copyright 2007-2017 Richard W.M. Jones, Red Hat Inc.
   3  * https://libvirt.org/
   4  *
   5  * This library is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU Lesser General Public
   7  * License as published by the Free Software Foundation; either
   8  * version 2 of the License, or (at your option) any later version.
   9  *
  10  * This library is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  * Lesser General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU Lesser General Public
  16  * License along with this library; if not, write to the Free Software
  17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301  USA
  18  */
  19
  20 /* Please read libvirt/README file. */
  21
  22 #ifdef __GNUC__
  23 #pragma GCC diagnostic ignored "-Wmissing-prototypes"
  24 #endif
  25
  26 /*----------------------------------------------------------------------*/
  27
  28 CAMLprim value
  29 ocaml_libvirt_get_version (value driverv, value unit)
  30 {
  31   CAMLparam2 (driverv, unit);
  32   CAMLlocal1 (rv);
  33   const char *driver = Optstring_val (driverv);
  34   unsigned long libVer, typeVer = 0, *typeVer_ptr;
  35   int r;
  36
  37   typeVer_ptr = driver ? &typeVer : NULL;
  38   NONBLOCKING (r = virGetVersion (&libVer, driver, typeVer_ptr));
  39   CHECK_ERROR (r == -1, "virGetVersion");
  40
  41   rv = caml_alloc_tuple (2);
  42   Store_field (rv, 0, Val_int (libVer));
  43   Store_field (rv, 1, Val_int (typeVer));
  44   CAMLreturn (rv);
  45 }
  46
  47 /*----------------------------------------------------------------------*/
  48
  49 /* Connection object. */
  50
  51 CAMLprim value
  52 ocaml_libvirt_connect_open (value namev, value unit)
  53 {
  54   CAMLparam2 (namev, unit);
  55   CAMLlocal1 (rv);
  56   const char *name = Optstring_val (namev);
  57   virConnectPtr conn;
  58
  59   NONBLOCKING (conn = virConnectOpen (name));
  60   CHECK_ERROR (!conn, "virConnectOpen");
  61
  62   rv = Val_connect (conn);
  63
  64   CAMLreturn (rv);
  65 }
  66
  67 CAMLprim value
  68 ocaml_libvirt_connect_open_readonly (value namev, value unit)
  69 {
  70   CAMLparam2 (namev, unit);
  71   CAMLlocal1 (rv);
  72   const char *name = Optstring_val (namev);
  73   virConnectPtr conn;
  74
  75   NONBLOCKING (conn = virConnectOpenReadOnly (name));
  76   CHECK_ERROR (!conn, "virConnectOpen");
  77
  78   rv = Val_connect (conn);
  79
  80   CAMLreturn (rv);
  81 }
  82
  83 /* Helper struct holding data needed for the helper C authentication
  84  * callback (which will call the actual OCaml callback).
  85  */
  86 struct ocaml_auth_callback_data {
  87   value *fvp;                  /* The OCaml auth callback. */
  88 };
  89
  90 static int
  91 _ocaml_auth_callback (virConnectCredentialPtr cred, unsigned int ncred, void *cbdata)
  92 {
  93   CAMLparam0 ();
  94   CAMLlocal4 (listv, elemv, rv, v);
  95   struct ocaml_auth_callback_data *s = cbdata;
  96   int i, len;
  97
  98   listv = Val_emptylist;
  99   for (i = ncred - 1; i >= 0; --i) {
 100     elemv = caml_alloc (2, 0);
 101     Store_field (elemv, 0, Val_virconnectcredential (&cred[i]));
 102     Store_field (elemv, 1, listv);
 103     listv = elemv;
 104   }
 105
 106   /* Call the auth callback. */
 107   rv = caml_callback_exn (*s->fvp, listv);
 108   if (Is_exception_result (rv)) {
 109     /* The callback raised an exception, so return an error. */
 110     CAMLreturnT (int, -1);
 111   }
 112
 113   len = _list_length (rv);
 114   if (len != (int) ncred) {
 115     /* The callback did not return the same number of results as the
 116      * credentials.
 117      */
 118     CAMLreturnT (int, -1);
 119   }
 120
 121   for (i = 0; rv != Val_emptylist; rv = Field (rv, 1), ++i) {
 122     virConnectCredentialPtr c = &cred[i];
 123     elemv = Field (rv, 0);
 124     if (elemv == Val_int (0)) {
 125       c->result = NULL;
 126       c->resultlen = 0;
 127     } else {
 128       v = Field (elemv, 0);
 129       len = caml_string_length (v);
 130       c->result = malloc (len + 1);
 131       if (c->result == NULL)
 132         CAMLreturnT (int, -1);
 133       memcpy (c->result, String_val (v), len);
 134       c->result[len] = '\0';
 135       c->resultlen = len;
 136     }
 137   }
 138
 139   CAMLreturnT (int, 0);
 140 }
 141
 142 static virConnectPtr
 143 _ocaml_libvirt_connect_open_auth_common (value namev, value authv, int flags)
 144 {
 145   CAMLparam2 (namev, authv);
 146   CAMLlocal2 (listv, fv);
 147   virConnectPtr conn;
 148   virConnectAuth auth;
 149   struct ocaml_auth_callback_data data;
 150   int i;
 151   char *name = NULL;
 152
 153   /* Keep a copy of the 'namev' string, as its value could move around
 154    * when calling other OCaml code that allocates memory.
 155    */
 156   if (namev != Val_int (0)) {  /* Some string */
 157     name = strdup (String_val (Field (namev, 0)));
 158     if (name == NULL)
 159       caml_raise_out_of_memory ();
 160   }
 161
 162   fv = Field (authv, 1);
 163   data.fvp = &fv;
 164
 165   listv = Field (authv, 0);
 166   auth.ncredtype = _list_length (listv);
 167   auth.credtype = malloc (sizeof (int) * auth.ncredtype);
 168   if (auth.credtype == NULL)
 169     caml_raise_out_of_memory ();
 170   for (i = 0; listv != Val_emptylist; listv = Field (listv, 1), ++i) {
 171     auth.credtype[i] = Int_val (Field (listv, 0)) + 1;
 172   }
 173   auth.cb = &_ocaml_auth_callback;
 174   auth.cbdata = &data;
 175
 176   /* Call virConnectOpenAuth directly, without using the NONBLOCKING
 177    * macro, as this will indeed call ocaml_* APIs, and run OCaml code.
 178    */
 179   conn = virConnectOpenAuth (name, &auth, flags);
 180   free (auth.credtype);
 181   free (name);
 182   CHECK_ERROR (!conn, "virConnectOpenAuth");
 183
 184   CAMLreturnT (virConnectPtr, conn);
 185 }
 186
 187 CAMLprim value
 188 ocaml_libvirt_connect_open_auth (value namev, value authv)
 189 {
 190   CAMLparam2 (namev, authv);
 191   CAMLlocal1 (rv);
 192   virConnectPtr conn;
 193
 194   conn = _ocaml_libvirt_connect_open_auth_common (namev, authv, 0);
 195   rv = Val_connect (conn);
 196
 197   CAMLreturn (rv);
 198 }
 199
 200 CAMLprim value
 201 ocaml_libvirt_connect_open_auth_readonly (value namev, value authv)
 202 {
 203   CAMLparam2 (namev, authv);
 204   CAMLlocal1 (rv);
 205   virConnectPtr conn;
 206
 207   conn = _ocaml_libvirt_connect_open_auth_common (namev, authv, VIR_CONNECT_RO);
 208   rv = Val_connect (conn);
 209
 210   CAMLreturn (rv);
 211 }
 212
 213 CAMLprim value
 214 ocaml_libvirt_connect_get_version (value connv)
 215 {
 216   CAMLparam1 (connv);
 217   virConnectPtr conn = Connect_val (connv);
 218   unsigned long hvVer;
 219   int r;
 220
 221   NONBLOCKING (r = virConnectGetVersion (conn, &hvVer));
 222   CHECK_ERROR (r == -1, "virConnectGetVersion");
 223
 224   CAMLreturn (Val_int (hvVer));
 225 }
 226
 227 CAMLprim value
 228 ocaml_libvirt_connect_get_max_vcpus (value connv, value typev)
 229 {
 230   CAMLparam2 (connv, typev);
 231   virConnectPtr conn = Connect_val (connv);
 232   const char *type = Optstring_val (typev);
 233   int r;
 234
 235   NONBLOCKING (r = virConnectGetMaxVcpus (conn, type));
 236   CHECK_ERROR (r == -1, "virConnectGetMaxVcpus");
 237
 238   CAMLreturn (Val_int (r));
 239 }
 240
 241 CAMLprim value
 242 ocaml_libvirt_connect_get_node_info (value connv)
 243 {
 244   CAMLparam1 (connv);
 245   CAMLlocal2 (rv, v);
 246   virConnectPtr conn = Connect_val (connv);
 247   virNodeInfo info;
 248   int r;
 249
 250   NONBLOCKING (r = virNodeGetInfo (conn, &info));
 251   CHECK_ERROR (r == -1, "virNodeGetInfo");
 252
 253   rv = caml_alloc (8, 0);
 254   v = caml_copy_string (info.model); Store_field (rv, 0, v);
 255   v = caml_copy_int64 (info.memory); Store_field (rv, 1, v);
 256   Store_field (rv, 2, Val_int (info.cpus));
 257   Store_field (rv, 3, Val_int (info.mhz));
 258   Store_field (rv, 4, Val_int (info.nodes));
 259   Store_field (rv, 5, Val_int (info.sockets));
 260   Store_field (rv, 6, Val_int (info.cores));
 261   Store_field (rv, 7, Val_int (info.threads));
 262
 263   CAMLreturn (rv);
 264 }
 265
 266 CAMLprim value
 267 ocaml_libvirt_connect_node_get_free_memory (value connv)
 268 {
 269   CAMLparam1 (connv);
 270   CAMLlocal1 (rv);
 271   virConnectPtr conn = Connect_val (connv);
 272   unsigned long long r;
 273
 274   NONBLOCKING (r = virNodeGetFreeMemory (conn));
 275   CHECK_ERROR (r == 0, "virNodeGetFreeMemory");
 276
 277   rv = caml_copy_int64 ((int64_t) r);
 278   CAMLreturn (rv);
 279 }
 280
 281 CAMLprim value
 282 ocaml_libvirt_connect_node_get_cells_free_memory (value connv,
 283                                                   value startv, value maxv)
 284 {
 285   CAMLparam3 (connv, startv, maxv);
 286   CAMLlocal2 (rv, iv);
 287   virConnectPtr conn = Connect_val (connv);
 288   int start = Int_val (startv);
 289   int max = Int_val (maxv);
 290   int r, i;
 291   unsigned long long *freemems;
 292
 293   freemems = malloc(sizeof (*freemems) * max);
 294   if (freemems == NULL)
 295     caml_raise_out_of_memory ();
 296
 297   NONBLOCKING (r = virNodeGetCellsFreeMemory (conn, freemems, start, max));
 298   CHECK_ERROR_CLEANUP (r == -1, free (freemems), "virNodeGetCellsFreeMemory");
 299
 300   rv = caml_alloc (r, 0);
 301   for (i = 0; i < r; ++i) {
 302     iv = caml_copy_int64 ((int64_t) freemems[i]);
 303     Store_field (rv, i, iv);
 304   }
 305   free (freemems);
 306
 307   CAMLreturn (rv);
 308 }
 309
 310 CAMLprim value
 311 ocaml_libvirt_connect_set_keep_alive(value connv,
 312                                      value intervalv, value countv)
 313 {
 314   CAMLparam3 (connv, intervalv, countv);
 315   virConnectPtr conn = Connect_val(connv);
 316   int interval = Int_val(intervalv);
 317   unsigned int count = Int_val(countv);
 318   int r;
 319
 320   NONBLOCKING(r = virConnectSetKeepAlive(conn, interval, count));
 321   CHECK_ERROR (r == -1, "virConnectSetKeepAlive");
 322
 323   CAMLreturn(Val_unit);
 324 }
 325
 326 CAMLprim value
 327 ocaml_libvirt_connect_credtypes_from_auth_default (value unitv)
 328 {
 329   CAMLparam1 (unitv);
 330   CAMLlocal2 (listv, itemv);
 331   int i;
 332
 333   listv = Val_emptylist;
 334
 335   if (virConnectAuthPtrDefault) {
 336     for (i = virConnectAuthPtrDefault->ncredtype; i >= 0; --i) {
 337       const int type = virConnectAuthPtrDefault->credtype[i];
 338       itemv = caml_alloc (2, 0);
 339       Store_field (itemv, 0, Val_int (type - 1));
 340       Store_field (itemv, 1, listv);
 341       listv = itemv;
 342     }
 343   }
 344
 345   CAMLreturn (listv);
 346 }
 347
 348 CAMLprim value
 349 ocaml_libvirt_connect_call_auth_default_callback (value listv)
 350 {
 351   CAMLparam1 (listv);
 352   CAMLlocal5 (credv, retv, elemv, optv, v);
 353   int i, len, ret;
 354   const char *str;
 355   virConnectCredentialPtr creds;
 356
 357   if (virConnectAuthPtrDefault == NULL
 358       || virConnectAuthPtrDefault->cb == NULL)
 359     CAMLreturn (Val_unit);
 360
 361   len = _list_length (listv);
 362   creds = calloc (len, sizeof (*creds));
 363   if (creds == NULL)
 364     caml_raise_out_of_memory ();
 365   for (i = 0; listv != Val_emptylist; listv = Field (listv, 1), ++i) {
 366     virConnectCredentialPtr cred = &creds[i];
 367     credv = Field (listv, 0);
 368     cred->type = Int_val (Field (credv, 0)) + 1;
 369     cred->prompt = strdup (String_val (Field (credv, 1)));
 370     if (cred->prompt == NULL)
 371       caml_raise_out_of_memory ();
 372     str = Optstring_val (Field (credv, 2));
 373     if (str) {
 374       cred->challenge = strdup (str);
 375       if (cred->challenge == NULL)
 376         caml_raise_out_of_memory ();
 377     }
 378     str = Optstring_val (Field (credv, 3));
 379     if (str) {
 380       cred->defresult = strdup (str);
 381       if (cred->defresult == NULL)
 382         caml_raise_out_of_memory ();
 383     }
 384   }
 385
 386   ret = virConnectAuthPtrDefault->cb (creds, len,
 387                                       virConnectAuthPtrDefault->cbdata);
 388   if (ret >= 0) {
 389     retv = Val_emptylist;
 390     for (i = len - 1; i >= 0; --i) {
 391       virConnectCredentialPtr cred = &creds[i];
 392       elemv = caml_alloc (2, 0);
 393       if (cred->result != NULL && cred->resultlen > 0) {
 394         v = caml_alloc_string (cred->resultlen);
 395         memcpy (String_val (v), cred->result, cred->resultlen);
 396         optv = caml_alloc (1, 0);
 397         Store_field (optv, 0, v);
 398       } else
 399         optv = Val_int (0);
 400       Store_field (elemv, 0, optv);
 401       Store_field (elemv, 1, retv);
 402       retv = elemv;
 403     }
 404   }
 405   for (i = 0; i < len; ++i) {
 406     virConnectCredentialPtr cred = &creds[i];
 407     /* Cast to char *, as the virConnectCredential structs we fill have
 408      * const char * qualifiers.
 409      */
 410     free ((char *) cred->prompt);
 411     free ((char *) cred->challenge);
 412     free ((char *) cred->defresult);
 413   }
 414   free (creds);
 415
 416   if (ret < 0)
 417     caml_failwith ("virConnectAuthPtrDefault callback failed");
 418
 419   CAMLreturn (retv);
 420 }
 421
 422 CAMLprim value
 423 ocaml_libvirt_domain_get_id (value domv)
 424 {
 425   CAMLparam1 (domv);
 426   virDomainPtr dom = Domain_val (domv);
 427   unsigned int r;
 428
 429   NONBLOCKING (r = virDomainGetID (dom));
 430   /* In theory this could return -1 on error, but in practice
 431    * libvirt never does this unless you call it with a corrupted
 432    * or NULL dom object.  So ignore errors here.
 433    */
 434
 435   CAMLreturn (Val_int ((int) r));
 436 }
 437
 438 CAMLprim value
 439 ocaml_libvirt_domain_get_max_memory (value domv)
 440 {
 441   CAMLparam1 (domv);
 442   CAMLlocal1 (rv);
 443   virDomainPtr dom = Domain_val (domv);
 444   unsigned long r;
 445
 446   NONBLOCKING (r = virDomainGetMaxMemory (dom));
 447   CHECK_ERROR (r == 0 /* [sic] */, "virDomainGetMaxMemory");
 448
 449   rv = caml_copy_int64 (r);
 450   CAMLreturn (rv);
 451 }
 452
 453 CAMLprim value
 454 ocaml_libvirt_domain_set_max_memory (value domv, value memv)
 455 {
 456   CAMLparam2 (domv, memv);
 457   virDomainPtr dom = Domain_val (domv);
 458   unsigned long mem = Int64_val (memv);
 459   int r;
 460
 461   NONBLOCKING (r = virDomainSetMaxMemory (dom, mem));
 462   CHECK_ERROR (r == -1, "virDomainSetMaxMemory");
 463
 464   CAMLreturn (Val_unit);
 465 }
 466
 467 CAMLprim value
 468 ocaml_libvirt_domain_set_memory (value domv, value memv)
 469 {
 470   CAMLparam2 (domv, memv);
 471   virDomainPtr dom = Domain_val (domv);
 472   unsigned long mem = Int64_val (memv);
 473   int r;
 474
 475   NONBLOCKING (r = virDomainSetMemory (dom, mem));
 476   CHECK_ERROR (r == -1, "virDomainSetMemory");
 477
 478   CAMLreturn (Val_unit);
 479 }
 480
 481 CAMLprim value
 482 ocaml_libvirt_domain_get_info (value domv)
 483 {
 484   CAMLparam1 (domv);
 485   CAMLlocal2 (rv, v);
 486   virDomainPtr dom = Domain_val (domv);
 487   virDomainInfo info;
 488   int r;
 489
 490   NONBLOCKING (r = virDomainGetInfo (dom, &info));
 491   CHECK_ERROR (r == -1, "virDomainGetInfo");
 492
 493   rv = caml_alloc (5, 0);
 494   Store_field (rv, 0, Val_int (info.state)); // These flags are compatible.
 495   v = caml_copy_int64 (info.maxMem); Store_field (rv, 1, v);
 496   v = caml_copy_int64 (info.memory); Store_field (rv, 2, v);
 497   Store_field (rv, 3, Val_int (info.nrVirtCpu));
 498   v = caml_copy_int64 (info.cpuTime); Store_field (rv, 4, v);
 499
 500   CAMLreturn (rv);
 501 }
 502
 503 CAMLprim value
 504 ocaml_libvirt_domain_get_scheduler_type (value domv)
 505 {
 506   CAMLparam1 (domv);
 507   CAMLlocal2 (rv, strv);
 508   virDomainPtr dom = Domain_val (domv);
 509   char *r;
 510   int nparams;
 511
 512   NONBLOCKING (r = virDomainGetSchedulerType (dom, &nparams));
 513   CHECK_ERROR (!r, "virDomainGetSchedulerType");
 514
 515   rv = caml_alloc_tuple (2);
 516   strv = caml_copy_string (r); Store_field (rv, 0, strv);
 517   free (r);
 518   Store_field (rv, 1, nparams);
 519   CAMLreturn (rv);
 520 }
 521
 522 CAMLprim value
 523 ocaml_libvirt_domain_get_scheduler_parameters (value domv, value nparamsv)
 524 {
 525   CAMLparam2 (domv, nparamsv);
 526   CAMLlocal4 (rv, v, v2, v3);
 527   virDomainPtr dom = Domain_val (domv);
 528   int nparams = Int_val (nparamsv);
 529   virSchedParameterPtr params;
 530   int r, i;
 531
 532   params = malloc (sizeof (*params) * nparams);
 533   if (params == NULL)
 534     caml_raise_out_of_memory ();
 535
 536   NONBLOCKING (r = virDomainGetSchedulerParameters (dom, params, &nparams));
 537   CHECK_ERROR_CLEANUP (r == -1, free (params), "virDomainGetSchedulerParameters");
 538
 539   rv = caml_alloc (nparams, 0);
 540   for (i = 0; i < nparams; ++i) {
 541     v = caml_alloc_tuple (2); Store_field (rv, i, v);
 542     v2 = caml_copy_string (params[i].field); Store_field (v, 0, v2);
 543     switch (params[i].type) {
 544     case VIR_DOMAIN_SCHED_FIELD_INT:
 545       v2 = caml_alloc (1, 0);
 546       v3 = caml_copy_int32 (params[i].value.i); Store_field (v2, 0, v3);
 547       break;
 548     case VIR_DOMAIN_SCHED_FIELD_UINT:
 549       v2 = caml_alloc (1, 1);
 550       v3 = caml_copy_int32 (params[i].value.ui); Store_field (v2, 0, v3);
 551       break;
 552     case VIR_DOMAIN_SCHED_FIELD_LLONG:
 553       v2 = caml_alloc (1, 2);
 554       v3 = caml_copy_int64 (params[i].value.l); Store_field (v2, 0, v3);
 555       break;
 556     case VIR_DOMAIN_SCHED_FIELD_ULLONG:
 557       v2 = caml_alloc (1, 3);
 558       v3 = caml_copy_int64 (params[i].value.ul); Store_field (v2, 0, v3);
 559       break;
 560     case VIR_DOMAIN_SCHED_FIELD_DOUBLE:
 561       v2 = caml_alloc (1, 4);
 562       v3 = caml_copy_double (params[i].value.d); Store_field (v2, 0, v3);
 563       break;
 564     case VIR_DOMAIN_SCHED_FIELD_BOOLEAN:
 565       v2 = caml_alloc (1, 5);
 566       Store_field (v2, 0, Val_int (params[i].value.b));
 567       break;
 568     default:
 569       caml_failwith ((char *)__FUNCTION__);
 570     }
 571     Store_field (v, 1, v2);
 572   }
 573   free (params);
 574   CAMLreturn (rv);
 575 }
 576
 577 CAMLprim value
 578 ocaml_libvirt_domain_set_scheduler_parameters (value domv, value paramsv)
 579 {
 580   CAMLparam2 (domv, paramsv);
 581   CAMLlocal1 (v);
 582   virDomainPtr dom = Domain_val (domv);
 583   int nparams = Wosize_val (paramsv);
 584   virSchedParameterPtr params;
 585   int r, i;
 586   char *name;
 587
 588   params = malloc (sizeof (*params) * nparams);
 589   if (params == NULL)
 590     caml_raise_out_of_memory ();
 591
 592   for (i = 0; i < nparams; ++i) {
 593     v = Field (paramsv, i);     /* Points to the two-element tuple. */
 594     name = String_val (Field (v, 0));
 595     strncpy (params[i].field, name, VIR_DOMAIN_SCHED_FIELD_LENGTH);
 596     params[i].field[VIR_DOMAIN_SCHED_FIELD_LENGTH-1] = '\0';
 597     v = Field (v, 1);           /* Points to the sched_param_value block. */
 598     switch (Tag_val (v)) {
 599     case 0:
 600       params[i].type = VIR_DOMAIN_SCHED_FIELD_INT;
 601       params[i].value.i = Int32_val (Field (v, 0));
 602       break;
 603     case 1:
 604       params[i].type = VIR_DOMAIN_SCHED_FIELD_UINT;
 605       params[i].value.ui = Int32_val (Field (v, 0));
 606       break;
 607     case 2:
 608       params[i].type = VIR_DOMAIN_SCHED_FIELD_LLONG;
 609       params[i].value.l = Int64_val (Field (v, 0));
 610       break;
 611     case 3:
 612       params[i].type = VIR_DOMAIN_SCHED_FIELD_ULLONG;
 613       params[i].value.ul = Int64_val (Field (v, 0));
 614       break;
 615     case 4:
 616       params[i].type = VIR_DOMAIN_SCHED_FIELD_DOUBLE;
 617       params[i].value.d = Double_val (Field (v, 0));
 618       break;
 619     case 5:
 620       params[i].type = VIR_DOMAIN_SCHED_FIELD_BOOLEAN;
 621       params[i].value.b = Int_val (Field (v, 0));
 622       break;
 623     default:
 624       caml_failwith ((char *)__FUNCTION__);
 625     }
 626   }
 627
 628   NONBLOCKING (r = virDomainSetSchedulerParameters (dom, params, nparams));
 629   free (params);
 630   CHECK_ERROR (r == -1, "virDomainSetSchedulerParameters");
 631
 632   CAMLreturn (Val_unit);
 633 }
 634
 635 CAMLprim value
 636 ocaml_libvirt_domain_set_vcpus (value domv, value nvcpusv)
 637 {
 638   CAMLparam2 (domv, nvcpusv);
 639   virDomainPtr dom = Domain_val (domv);
 640   int r, nvcpus = Int_val (nvcpusv);
 641
 642   NONBLOCKING (r = virDomainSetVcpus (dom, nvcpus));
 643   CHECK_ERROR (r == -1, "virDomainSetVcpus");
 644
 645   CAMLreturn (Val_unit);
 646 }
 647
 648 CAMLprim value
 649 ocaml_libvirt_domain_pin_vcpu (value domv, value vcpuv, value cpumapv)
 650 {
 651   CAMLparam3 (domv, vcpuv, cpumapv);
 652   virDomainPtr dom = Domain_val (domv);
 653   int maplen = caml_string_length (cpumapv);
 654   unsigned char *cpumap = (unsigned char *) String_val (cpumapv);
 655   int vcpu = Int_val (vcpuv);
 656   int r;
 657
 658   NONBLOCKING (r = virDomainPinVcpu (dom, vcpu, cpumap, maplen));
 659   CHECK_ERROR (r == -1, "virDomainPinVcpu");
 660
 661   CAMLreturn (Val_unit);
 662 }
 663
 664 CAMLprim value
 665 ocaml_libvirt_domain_get_vcpus (value domv, value maxinfov, value maplenv)
 666 {
 667   CAMLparam3 (domv, maxinfov, maplenv);
 668   CAMLlocal5 (rv, infov, strv, v, v2);
 669   virDomainPtr dom = Domain_val (domv);
 670   int maxinfo = Int_val (maxinfov);
 671   int maplen = Int_val (maplenv);
 672   virVcpuInfoPtr info;
 673   unsigned char *cpumaps;
 674   int r, i;
 675
 676   info = calloc (maxinfo, sizeof (*info));
 677   if (info == NULL)
 678     caml_raise_out_of_memory ();
 679   cpumaps = calloc (maxinfo * maplen, sizeof (*cpumaps));
 680   if (cpumaps == NULL) {
 681     free (info);
 682     caml_raise_out_of_memory ();
 683   }
 684
 685   NONBLOCKING (r = virDomainGetVcpus (dom, info, maxinfo, cpumaps, maplen));
 686   CHECK_ERROR_CLEANUP (r == -1, free (info); free (cpumaps), "virDomainPinVcpu");
 687
 688   /* Copy the virVcpuInfo structures. */
 689   infov = caml_alloc (maxinfo, 0);
 690   for (i = 0; i < maxinfo; ++i) {
 691     v2 = caml_alloc (4, 0); Store_field (infov, i, v2);
 692     Store_field (v2, 0, Val_int (info[i].number));
 693     Store_field (v2, 1, Val_int (info[i].state));
 694     v = caml_copy_int64 (info[i].cpuTime); Store_field (v2, 2, v);
 695     Store_field (v2, 3, Val_int (info[i].cpu));
 696   }
 697
 698   /* Copy the bitmap. */
 699   strv = caml_alloc_string (maxinfo * maplen);
 700   memcpy (String_val (strv), cpumaps, maxinfo * maplen);
 701
 702   /* Allocate the tuple and return it. */
 703   rv = caml_alloc_tuple (3);
 704   Store_field (rv, 0, Val_int (r)); /* number of CPUs. */
 705   Store_field (rv, 1, infov);
 706   Store_field (rv, 2, strv);
 707
 708   free (info);
 709   free (cpumaps);
 710
 711   CAMLreturn (rv);
 712 }
 713
 714 CAMLprim value
 715 ocaml_libvirt_domain_get_cpu_stats (value domv)
 716 {
 717   CAMLparam1 (domv);
 718   CAMLlocal5 (cpustats, param_head, param_node, typed_param, typed_param_value);
 719   CAMLlocal1 (v);
 720   virDomainPtr dom = Domain_val (domv);
 721   virTypedParameterPtr params;
 722   int r, cpu, ncpus, nparams, i, j, pos;
 723   int nr_pcpus;
 724
 725   /* get number of pcpus */
 726   NONBLOCKING (nr_pcpus = virDomainGetCPUStats(dom, NULL, 0, 0, 0, 0));
 727   CHECK_ERROR (nr_pcpus < 0, "virDomainGetCPUStats");
 728
 729   /* get percpu information */
 730   NONBLOCKING (nparams = virDomainGetCPUStats(dom, NULL, 0, 0, 1, 0));
 731   CHECK_ERROR (nparams < 0, "virDomainGetCPUStats");
 732
 733   if ((params = malloc(sizeof(*params) * nparams * 128)) == NULL)
 734     caml_failwith ("virDomainGetCPUStats: malloc");
 735
 736   cpustats = caml_alloc (nr_pcpus, 0); /* cpustats: array of params(list of typed_param) */
 737   cpu = 0;
 738   while (cpu < nr_pcpus) {
 739     ncpus = nr_pcpus - cpu > 128 ? 128 : nr_pcpus - cpu;
 740
 741     NONBLOCKING (r = virDomainGetCPUStats(dom, params, nparams, cpu, ncpus, 0));
 742     CHECK_ERROR (r < 0, "virDomainGetCPUStats");
 743
 744     for (i = 0; i < ncpus; i++) {
 745       /* list of typed_param: single linked list of param_nodes */
 746       param_head = Val_emptylist; /* param_head: the head param_node of list of typed_param */
 747
 748       if (params[i * nparams].type == 0) {
 749         Store_field(cpustats, cpu + i, param_head);
 750         continue;
 751       }
 752
 753       for (j = r - 1; j >= 0; j--) {
 754         pos = i * nparams + j;
 755           if (params[pos].type == 0)
 756             continue;
 757
 758         param_node = caml_alloc(2, 0); /* param_node: typed_param, next param_node */
 759         Store_field(param_node, 1, param_head);
 760         param_head = param_node;
 761
 762         typed_param = caml_alloc(2, 0); /* typed_param: field name(string), typed_param_value */
 763         Store_field(param_node, 0, typed_param);
 764         Store_field(typed_param, 0, caml_copy_string(params[pos].field));
 765
 766         /* typed_param_value: value with the corresponding type tag */
 767         switch(params[pos].type) {
 768         case VIR_TYPED_PARAM_INT:
 769           typed_param_value = caml_alloc (1, 0);
 770           v = caml_copy_int32 (params[pos].value.i);
 771           break;
 772         case VIR_TYPED_PARAM_UINT:
 773           typed_param_value = caml_alloc (1, 1);
 774           v = caml_copy_int32 (params[pos].value.ui);
 775           break;
 776         case VIR_TYPED_PARAM_LLONG:
 777           typed_param_value = caml_alloc (1, 2);
 778           v = caml_copy_int64 (params[pos].value.l);
 779           break;
 780         case VIR_TYPED_PARAM_ULLONG:
 781           typed_param_value = caml_alloc (1, 3);
 782           v = caml_copy_int64 (params[pos].value.ul);
 783           break;
 784         case VIR_TYPED_PARAM_DOUBLE:
 785           typed_param_value = caml_alloc (1, 4);
 786           v = caml_copy_double (params[pos].value.d);
 787           break;
 788         case VIR_TYPED_PARAM_BOOLEAN:
 789           typed_param_value = caml_alloc (1, 5);
 790           v = Val_bool (params[pos].value.b);
 791           break;
 792         case VIR_TYPED_PARAM_STRING:
 793           typed_param_value = caml_alloc (1, 6);
 794           v = caml_copy_string (params[pos].value.s);
 795           free (params[pos].value.s);
 796           break;
 797         default:
 798             /* XXX Memory leak on this path, if there are more
 799              * VIR_TYPED_PARAM_STRING past this point in the array.
 800              */
 801           free (params);
 802           caml_failwith ("virDomainGetCPUStats: "
 803                          "unknown parameter type returned");
 804         }
 805         Store_field (typed_param_value, 0, v);
 806         Store_field (typed_param, 1, typed_param_value);
 807       }
 808       Store_field (cpustats, cpu + i, param_head);
 809     }
 810     cpu += ncpus;
 811   }
 812   free(params);
 813   CAMLreturn (cpustats);
 814 }
 815
 816 value
 817 ocaml_libvirt_domain_get_all_domain_stats (value connv,
 818                                            value statsv, value flagsv)
 819 {
 820   CAMLparam3 (connv, statsv, flagsv);
 821   CAMLlocal5 (rv, dsv, tpv, v, v1);
 822   CAMLlocal1 (v2);
 823   virConnectPtr conn = Connect_val (connv);
 824   virDomainStatsRecordPtr *rstats;
 825   unsigned int stats = 0, flags = 0;
 826   int i, j, r;
 827   unsigned char uuid[VIR_UUID_BUFLEN];
 828
 829   /* Get stats and flags. */
 830   for (; statsv != Val_int (0); statsv = Field (statsv, 1)) {
 831     v = Field (statsv, 0);
 832     if (v == Val_int (0))
 833       stats |= VIR_DOMAIN_STATS_STATE;
 834     else if (v == Val_int (1))
 835       stats |= VIR_DOMAIN_STATS_CPU_TOTAL;
 836     else if (v == Val_int (2))
 837       stats |= VIR_DOMAIN_STATS_BALLOON;
 838     else if (v == Val_int (3))
 839       stats |= VIR_DOMAIN_STATS_VCPU;
 840     else if (v == Val_int (4))
 841       stats |= VIR_DOMAIN_STATS_INTERFACE;
 842     else if (v == Val_int (5))
 843       stats |= VIR_DOMAIN_STATS_BLOCK;
 844     else if (v == Val_int (6))
 845       stats |= VIR_DOMAIN_STATS_PERF;
 846   }
 847   for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1)) {
 848     v = Field (flagsv, 0);
 849     if (v == Val_int (0))
 850       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_ACTIVE;
 851     else if (v == Val_int (1))
 852       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_INACTIVE;
 853     else if (v == Val_int (2))
 854       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_OTHER;
 855     else if (v == Val_int (3))
 856       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_PAUSED;
 857     else if (v == Val_int (4))
 858       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_PERSISTENT;
 859     else if (v == Val_int (5))
 860       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_RUNNING;
 861     else if (v == Val_int (6))
 862       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_SHUTOFF;
 863     else if (v == Val_int (7))
 864       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_TRANSIENT;
 865     else if (v == Val_int (8))
 866       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_BACKING;
 867     else if (v == Val_int (9))
 868       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_ENFORCE_STATS;
 869   }
 870
 871   NONBLOCKING (r = virConnectGetAllDomainStats (conn, stats, &rstats, flags));
 872   CHECK_ERROR (r == -1, "virConnectGetAllDomainStats");
 873
 874   rv = caml_alloc (r, 0);       /* domain_stats_record array. */
 875   for (i = 0; i < r; ++i) {
 876     dsv = caml_alloc (2, 0);    /* domain_stats_record */
 877
 878     /* Libvirt returns something superficially resembling a
 879      * virDomainPtr, but it's not a real virDomainPtr object
 880      * (eg. dom->id == -1, and its refcount is wrong).  The only thing
 881      * we can safely get from it is the UUID.
 882      */
 883     v = caml_alloc_string (VIR_UUID_BUFLEN);
 884     virDomainGetUUID (rstats[i]->dom, uuid);
 885     memcpy (String_val (v), uuid, VIR_UUID_BUFLEN);
 886     Store_field (dsv, 0, v);
 887
 888     tpv = caml_alloc (rstats[i]->nparams, 0); /* typed_param array */
 889     for (j = 0; j < rstats[i]->nparams; ++j) {
 890       v2 = caml_alloc (2, 0);   /* typed_param: field name, value */
 891       Store_field (v2, 0, caml_copy_string (rstats[i]->params[j].field));
 892
 893       switch (rstats[i]->params[j].type) {
 894       case VIR_TYPED_PARAM_INT:
 895         v1 = caml_alloc (1, 0);
 896         v = caml_copy_int32 (rstats[i]->params[j].value.i);
 897         break;
 898       case VIR_TYPED_PARAM_UINT:
 899         v1 = caml_alloc (1, 1);
 900         v = caml_copy_int32 (rstats[i]->params[j].value.ui);
 901         break;
 902       case VIR_TYPED_PARAM_LLONG:
 903         v1 = caml_alloc (1, 2);
 904         v = caml_copy_int64 (rstats[i]->params[j].value.l);
 905         break;
 906       case VIR_TYPED_PARAM_ULLONG:
 907         v1 = caml_alloc (1, 3);
 908         v = caml_copy_int64 (rstats[i]->params[j].value.ul);
 909         break;
 910       case VIR_TYPED_PARAM_DOUBLE:
 911         v1 = caml_alloc (1, 4);
 912         v = caml_copy_double (rstats[i]->params[j].value.d);
 913         break;
 914       case VIR_TYPED_PARAM_BOOLEAN:
 915         v1 = caml_alloc (1, 5);
 916         v = Val_bool (rstats[i]->params[j].value.b);
 917         break;
 918       case VIR_TYPED_PARAM_STRING:
 919         v1 = caml_alloc (1, 6);
 920         v = caml_copy_string (rstats[i]->params[j].value.s);
 921         break;
 922       default:
 923         virDomainStatsRecordListFree (rstats);
 924         caml_failwith ("virConnectGetAllDomainStats: "
 925                        "unknown parameter type returned");
 926       }
 927       Store_field (v1, 0, v);
 928
 929       Store_field (v2, 1, v1);
 930       Store_field (tpv, j, v2);
 931     }
 932
 933     Store_field (dsv, 1, tpv);
 934     Store_field (rv, i, dsv);
 935   }
 936
 937   virDomainStatsRecordListFree (rstats);
 938   CAMLreturn (rv);
 939 }
 940
 941 CAMLprim value
 942 ocaml_libvirt_domain_migrate_native (value domv, value dconnv, value flagsv, value optdnamev, value opturiv, value optbandwidthv, value unitv)
 943 {
 944   CAMLparam5 (domv, dconnv, flagsv, optdnamev, opturiv);
 945   CAMLxparam2 (optbandwidthv, unitv);
 946   CAMLlocal2 (flagv, rv);
 947   virDomainPtr dom = Domain_val (domv);
 948   virConnectPtr dconn = Connect_val (dconnv);
 949   int flags = 0;
 950   const char *dname = Optstring_val (optdnamev);
 951   const char *uri = Optstring_val (opturiv);
 952   unsigned long bandwidth;
 953   virDomainPtr r;
 954
 955   /* Iterate over the list of flags. */
 956   for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1))
 957     {
 958       flagv = Field (flagsv, 0);
 959       if (flagv == Val_int (0))
 960         flags |= VIR_MIGRATE_LIVE;
 961     }
 962
 963   if (optbandwidthv == Val_int (0)) /* None */
 964     bandwidth = 0;
 965   else                          /* Some bandwidth */
 966     bandwidth = Int_val (Field (optbandwidthv, 0));
 967
 968   NONBLOCKING (r = virDomainMigrate (dom, dconn, flags, dname, uri, bandwidth));
 969   CHECK_ERROR (!r, "virDomainMigrate");
 970
 971   rv = Val_domain (r, dconnv);
 972
 973   CAMLreturn (rv);
 974 }
 975
 976 CAMLprim value
 977 ocaml_libvirt_domain_migrate_bytecode (value *argv, int argn)
 978 {
 979   return ocaml_libvirt_domain_migrate_native (argv[0], argv[1], argv[2],
 980                                               argv[3], argv[4], argv[5],
 981                                               argv[6]);
 982 }
 983
 984 CAMLprim value
 985 ocaml_libvirt_domain_block_stats (value domv, value pathv)
 986 {
 987   CAMLparam2 (domv, pathv);
 988   CAMLlocal2 (rv,v);
 989   virDomainPtr dom = Domain_val (domv);
 990   char *path = String_val (pathv);
 991   struct _virDomainBlockStats stats;
 992   int r;
 993
 994   NONBLOCKING (r = virDomainBlockStats (dom, path, &stats, sizeof stats));
 995   CHECK_ERROR (r == -1, "virDomainBlockStats");
 996
 997   rv = caml_alloc (5, 0);
 998   v = caml_copy_int64 (stats.rd_req); Store_field (rv, 0, v);
 999   v = caml_copy_int64 (stats.rd_bytes); Store_field (rv, 1, v);
1000   v = caml_copy_int64 (stats.wr_req); Store_field (rv, 2, v);
1001   v = caml_copy_int64 (stats.wr_bytes); Store_field (rv, 3, v);
1002   v = caml_copy_int64 (stats.errs); Store_field (rv, 4, v);
1003
1004   CAMLreturn (rv);
1005 }
1006
1007 CAMLprim value
1008 ocaml_libvirt_domain_interface_stats (value domv, value pathv)
1009 {
1010   CAMLparam2 (domv, pathv);
1011   CAMLlocal2 (rv,v);
1012   virDomainPtr dom = Domain_val (domv);
1013   char *path = String_val (pathv);
1014   struct _virDomainInterfaceStats stats;
1015   int r;
1016
1017   NONBLOCKING (r = virDomainInterfaceStats (dom, path, &stats, sizeof stats));
1018   CHECK_ERROR (r == -1, "virDomainInterfaceStats");
1019
1020   rv = caml_alloc (8, 0);
1021   v = caml_copy_int64 (stats.rx_bytes); Store_field (rv, 0, v);
1022   v = caml_copy_int64 (stats.rx_packets); Store_field (rv, 1, v);
1023   v = caml_copy_int64 (stats.rx_errs); Store_field (rv, 2, v);
1024   v = caml_copy_int64 (stats.rx_drop); Store_field (rv, 3, v);
1025   v = caml_copy_int64 (stats.tx_bytes); Store_field (rv, 4, v);
1026   v = caml_copy_int64 (stats.tx_packets); Store_field (rv, 5, v);
1027   v = caml_copy_int64 (stats.tx_errs); Store_field (rv, 6, v);
1028   v = caml_copy_int64 (stats.tx_drop); Store_field (rv, 7, v);
1029
1030   CAMLreturn (rv);
1031 }
1032
1033 CAMLprim value
1034 ocaml_libvirt_domain_block_peek_native (value domv, value pathv, value offsetv, value sizev, value bufferv, value boffv)
1035 {
1036   CAMLparam5 (domv, pathv, offsetv, sizev, bufferv);
1037   CAMLxparam1 (boffv);
1038   virDomainPtr dom = Domain_val (domv);
1039   const char *path = String_val (pathv);
1040   unsigned long long offset = Int64_val (offsetv);
1041   size_t size = Int_val (sizev);
1042   char *buffer = String_val (bufferv);
1043   int boff = Int_val (boffv);
1044   int r;
1045
1046   /* Check that the return buffer is big enough. */
1047   if (caml_string_length (bufferv) < boff + size)
1048     caml_failwith ("virDomainBlockPeek: return buffer too short");
1049
1050   /* NB. not NONBLOCKING because buffer might move (XXX) */
1051   r = virDomainBlockPeek (dom, path, offset, size, buffer+boff, 0);
1052   CHECK_ERROR (r == -1, "virDomainBlockPeek");
1053
1054   CAMLreturn (Val_unit);
1055 }
1056
1057 CAMLprim value
1058 ocaml_libvirt_domain_block_peek_bytecode (value *argv, int argn)
1059 {
1060   return ocaml_libvirt_domain_block_peek_native (argv[0], argv[1], argv[2],
1061                                                  argv[3], argv[4], argv[5]);
1062 }
1063
1064 CAMLprim value
1065 ocaml_libvirt_domain_memory_peek_native (value domv, value flagsv, value offsetv, value sizev, value bufferv, value boffv)
1066 {
1067   CAMLparam5 (domv, flagsv, offsetv, sizev, bufferv);
1068   CAMLxparam1 (boffv);
1069   CAMLlocal1 (flagv);
1070   virDomainPtr dom = Domain_val (domv);
1071   int flags = 0;
1072   unsigned long long offset = Int64_val (offsetv);
1073   size_t size = Int_val (sizev);
1074   char *buffer = String_val (bufferv);
1075   int boff = Int_val (boffv);
1076   int r;
1077
1078   /* Check that the return buffer is big enough. */
1079   if (caml_string_length (bufferv) < boff + size)
1080     caml_failwith ("virDomainMemoryPeek: return buffer too short");
1081
1082   /* Do flags. */
1083   for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1))
1084     {
1085       flagv = Field (flagsv, 0);
1086       if (flagv == Val_int (0))
1087         flags |= VIR_MEMORY_VIRTUAL;
1088     }
1089
1090   /* NB. not NONBLOCKING because buffer might move (XXX) */
1091   r = virDomainMemoryPeek (dom, offset, size, buffer+boff, flags);
1092   CHECK_ERROR (r == -1, "virDomainMemoryPeek");
1093
1094   CAMLreturn (Val_unit);
1095 }
1096
1097 CAMLprim value
1098 ocaml_libvirt_domain_memory_peek_bytecode (value *argv, int argn)
1099 {
1100   return ocaml_libvirt_domain_memory_peek_native (argv[0], argv[1], argv[2],
1101                                                   argv[3], argv[4], argv[5]);
1102 }
1103
1104 CAMLprim value
1105 ocaml_libvirt_domain_get_xml_desc_flags (value domv, value flagsv)
1106 {
1107   CAMLparam2 (domv, flagsv);
1108   CAMLlocal2 (rv, flagv);
1109   virDomainPtr dom = Domain_val (domv);
1110   int flags = 0;
1111   char *r;
1112
1113   /* Do flags. */
1114   for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1))
1115     {
1116       flagv = Field (flagsv, 0);
1117       if (flagv == Val_int (0))
1118         flags |= VIR_DOMAIN_XML_SECURE;
1119       else if (flagv == Val_int (1))
1120         flags |= VIR_DOMAIN_XML_INACTIVE;
1121       else if (flagv == Val_int (2))
1122         flags |= VIR_DOMAIN_XML_UPDATE_CPU;
1123       else if (flagv == Val_int (3))
1124         flags |= VIR_DOMAIN_XML_MIGRATABLE;
1125     }
1126
1127   NONBLOCKING (r = virDomainGetXMLDesc (dom, flags));
1128   CHECK_ERROR (!r, "virDomainGetXMLDesc");
1129
1130   rv = caml_copy_string (r);
1131   free (r);
1132   CAMLreturn (rv);
1133 }
1134
1135 /*----------------------------------------------------------------------*/
1136
1137 /* Domain events */
1138
1139 CAMLprim value
1140 ocaml_libvirt_event_register_default_impl (value unitv)
1141 {
1142   CAMLparam1 (unitv);
1143
1144   /* arg is of type unit = void */
1145   int r;
1146
1147   NONBLOCKING (r = virEventRegisterDefaultImpl ());
1148   /* must be called before connection, therefore we can't use CHECK_ERROR */
1149   if (r == -1) caml_failwith("virEventRegisterDefaultImpl");
1150
1151   CAMLreturn (Val_unit);
1152 }
1153
1154 CAMLprim value
1155 ocaml_libvirt_event_run_default_impl (value unitv)
1156 {
1157   CAMLparam1 (unitv);
1158
1159   /* arg is of type unit = void */
1160   int r;
1161
1162   NONBLOCKING (r = virEventRunDefaultImpl ());
1163   if (r == -1) caml_failwith("virEventRunDefaultImpl");
1164
1165   CAMLreturn (Val_unit);
1166 }
1167
1168 /* We register a single C callback function for every distinct
1169    callback signature. We encode the signature itself in the function
1170    name and also in the name of the assocated OCaml callback
1171    e.g.:
1172       a C function called
1173          i_i64_s_callback(virConnectPtr conn,
1174                           virDomainPtr dom,
1175                           int x,
1176                           long y,
1177                           char *z,
1178                           void *opaque)
1179       would correspond to an OCaml callback
1180          Libvirt.i_i64_s_callback :
1181            int64 -> [`R] Domain.t -> int -> int64 -> string option -> unit
1182       where the initial int64 is a unique ID used by the OCaml to
1183       dispatch to the specific OCaml closure and stored by libvirt
1184       as the "opaque" data. */
1185
1186 /* Every one of the callbacks starts with a DOMAIN_CALLBACK_BEGIN(NAME)
1187    where NAME is the string name of the OCaml callback registered
1188    in libvirt.ml. */
1189 #define DOMAIN_CALLBACK_BEGIN(NAME)                              \
1190   value connv, domv, callback_id, result;                        \
1191   connv = domv = callback_id = result = Val_int(0);              \
1192   static value *callback = NULL;                                 \
1193   caml_leave_blocking_section();                                 \
1194   if (callback == NULL)                                          \
1195     callback = caml_named_value(NAME);                           \
1196   if (callback == NULL)                                          \
1197     abort(); /* C code out of sync with OCaml code */            \
1198   if ((virDomainRef(dom) == -1) || (virConnectRef(conn) == -1))  \
1199     abort(); /* should never happen in practice? */              \
1200                                                                  \
1201   Begin_roots4(connv, domv, callback_id, result);                \
1202   connv = Val_connect(conn);                                     \
1203   domv = Val_domain(dom, connv);                                 \
1204   callback_id = caml_copy_int64(*(long *)opaque);
1205
1206 /* Every one of the callbacks ends with a CALLBACK_END */
1207 #define DOMAIN_CALLBACK_END                                      \
1208   (void) caml_callback3(*callback, callback_id, domv, result);   \
1209   End_roots();                                                   \
1210   caml_enter_blocking_section();
1211
1212
1213 static void
1214 i_i_callback(virConnectPtr conn,
1215              virDomainPtr dom,
1216              int x,
1217              int y,
1218              void * opaque)
1219 {
1220   DOMAIN_CALLBACK_BEGIN("Libvirt.i_i_callback")
1221   result = caml_alloc_tuple(2);
1222   Store_field(result, 0, Val_int(x));
1223   Store_field(result, 1, Val_int(y));
1224   DOMAIN_CALLBACK_END
1225 }
1226
1227 static void
1228 u_callback(virConnectPtr conn,
1229            virDomainPtr dom,
1230            void *opaque)
1231 {
1232   DOMAIN_CALLBACK_BEGIN("Libvirt.u_callback")
1233   result = Val_int(0); /* () */
1234   DOMAIN_CALLBACK_END
1235 }
1236
1237 static void
1238 i64_callback(virConnectPtr conn,
1239              virDomainPtr dom,
1240              long long int64,
1241              void *opaque)
1242 {
1243   DOMAIN_CALLBACK_BEGIN("Libvirt.i64_callback")
1244   result = caml_copy_int64(int64);
1245   DOMAIN_CALLBACK_END
1246 }
1247
1248 static void
1249 i_callback(virConnectPtr conn,
1250            virDomainPtr dom,
1251            int x,
1252            void *opaque)
1253 {
1254   DOMAIN_CALLBACK_BEGIN("Libvirt.i_callback")
1255   result = Val_int(x);
1256   DOMAIN_CALLBACK_END
1257 }
1258
1259 static void
1260 s_i_callback(virConnectPtr conn,
1261              virDomainPtr dom,
1262              char *x,
1263              int y,
1264              void * opaque)
1265 {
1266   DOMAIN_CALLBACK_BEGIN("Libvirt.s_i_callback")
1267   result = caml_alloc_tuple(2);
1268   Store_field(result, 0,
1269               Val_opt(x, (Val_ptr_t) caml_copy_string));
1270   Store_field(result, 1, Val_int(y));
1271   DOMAIN_CALLBACK_END
1272 }
1273
1274 static void
1275 s_i_i_callback(virConnectPtr conn,
1276                virDomainPtr dom,
1277                char *x,
1278                int y,
1279                int z,
1280                void * opaque)
1281 {
1282   DOMAIN_CALLBACK_BEGIN("Libvirt.s_i_i_callback")
1283   result = caml_alloc_tuple(3);
1284   Store_field(result, 0,
1285               Val_opt(x, (Val_ptr_t) caml_copy_string));
1286   Store_field(result, 1, Val_int(y));
1287   Store_field(result, 2, Val_int(z));
1288   DOMAIN_CALLBACK_END
1289 }
1290
1291 static void
1292 s_s_i_callback(virConnectPtr conn,
1293                virDomainPtr dom,
1294                char *x,
1295                char *y,
1296                int z,
1297                void *opaque)
1298 {
1299   DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_i_callback")
1300   result = caml_alloc_tuple(3);
1301   Store_field(result, 0,
1302               Val_opt(x, (Val_ptr_t) caml_copy_string));
1303   Store_field(result, 1,
1304               Val_opt(y, (Val_ptr_t) caml_copy_string));
1305   Store_field(result, 2, Val_int(z));
1306   DOMAIN_CALLBACK_END
1307 }
1308
1309 static void
1310 s_s_i_s_callback(virConnectPtr conn,
1311                  virDomainPtr dom,
1312                  char *x,
1313                  char *y,
1314                  int z,
1315                  char *a,
1316                  void *opaque)
1317 {
1318   DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_i_s_callback")
1319   result = caml_alloc_tuple(4);
1320   Store_field(result, 0,
1321               Val_opt(x, (Val_ptr_t) caml_copy_string));
1322   Store_field(result, 1,
1323               Val_opt(y, (Val_ptr_t) caml_copy_string));
1324   Store_field(result, 2, Val_int(z));
1325   Store_field(result, 3,
1326               Val_opt(a, (Val_ptr_t) caml_copy_string));
1327   DOMAIN_CALLBACK_END
1328 }
1329
1330 static void
1331 s_s_s_i_callback(virConnectPtr conn,
1332                  virDomainPtr dom,
1333                  char * x,
1334                  char * y,
1335                  char * z,
1336                  int a,
1337                  void * opaque)
1338 {
1339   DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_s_i_callback")
1340   result = caml_alloc_tuple(4);
1341   Store_field(result, 0,
1342               Val_opt(x, (Val_ptr_t) caml_copy_string));
1343   Store_field(result, 1,
1344               Val_opt(y, (Val_ptr_t) caml_copy_string));
1345   Store_field(result, 2,
1346               Val_opt(z, (Val_ptr_t) caml_copy_string));
1347   Store_field(result, 3, Val_int(a));
1348   DOMAIN_CALLBACK_END
1349 }
1350
1351 static value
1352 Val_event_graphics_address(virDomainEventGraphicsAddressPtr x)
1353 {
1354   CAMLparam0 ();
1355   CAMLlocal1(result);
1356   result = caml_alloc_tuple(3);
1357   Store_field(result, 0, Val_int(x->family));
1358   Store_field(result, 1,
1359               Val_opt((void *) x->node, (Val_ptr_t) caml_copy_string));
1360   Store_field(result, 2,
1361               Val_opt((void *) x->service, (Val_ptr_t) caml_copy_string));
1362   CAMLreturn(result);
1363 }
1364
1365 static value
1366 Val_event_graphics_subject_identity(virDomainEventGraphicsSubjectIdentityPtr x)
1367 {
1368   CAMLparam0 ();
1369   CAMLlocal1(result);
1370   result = caml_alloc_tuple(2);
1371   Store_field(result, 0,
1372               Val_opt((void *) x->type, (Val_ptr_t) caml_copy_string));
1373   Store_field(result, 1,
1374               Val_opt((void *) x->name, (Val_ptr_t) caml_copy_string));
1375   CAMLreturn(result);
1376
1377 }
1378
1379 static value
1380 Val_event_graphics_subject(virDomainEventGraphicsSubjectPtr x)
1381 {
1382   CAMLparam0 ();
1383   CAMLlocal1(result);
1384   int i;
1385   result = caml_alloc_tuple(x->nidentity);
1386   for (i = 0; i < x->nidentity; i++ )
1387     Store_field(result, i,
1388                 Val_event_graphics_subject_identity(x->identities + i));
1389   CAMLreturn(result);
1390 }
1391
1392 static void
1393 i_ga_ga_s_gs_callback(virConnectPtr conn,
1394                       virDomainPtr dom,
1395                       int i1,
1396                       virDomainEventGraphicsAddressPtr ga1,
1397                       virDomainEventGraphicsAddressPtr ga2,
1398                       char *s1,
1399                       virDomainEventGraphicsSubjectPtr gs1,
1400                       void * opaque)
1401 {
1402   DOMAIN_CALLBACK_BEGIN("Libvirt.i_ga_ga_s_gs_callback")
1403   result = caml_alloc_tuple(5);
1404   Store_field(result, 0, Val_int(i1));
1405   Store_field(result, 1, Val_event_graphics_address(ga1));
1406   Store_field(result, 2, Val_event_graphics_address(ga2));
1407   Store_field(result, 3,
1408               Val_opt(s1, (Val_ptr_t) caml_copy_string));
1409   Store_field(result, 4, Val_event_graphics_subject(gs1));
1410   DOMAIN_CALLBACK_END
1411 }
1412
1413 static void
1414 timeout_callback(int timer, void *opaque)
1415 {
1416   value callback_id, result;
1417   callback_id = result = Val_int(0);
1418   static value *callback = NULL;
1419   caml_leave_blocking_section();
1420   if (callback == NULL)
1421     callback = caml_named_value("Libvirt.timeout_callback");
1422   if (callback == NULL)
1423     abort(); /* C code out of sync with OCaml code */
1424
1425   Begin_roots2(callback_id, result);
1426   callback_id = caml_copy_int64(*(long *)opaque);
1427
1428   (void)caml_callback_exn(*callback, callback_id);
1429   End_roots();
1430   caml_enter_blocking_section();
1431 }
1432
1433 CAMLprim value
1434 ocaml_libvirt_event_add_timeout (value connv, value ms, value callback_id)
1435 {
1436   CAMLparam3 (connv, ms, callback_id);
1437   void *opaque;
1438   virFreeCallback freecb = free;
1439   virEventTimeoutCallback cb = timeout_callback;
1440
1441   int r;
1442
1443   /* Store the int64 callback_id as the opaque data so the OCaml
1444      callback can demultiplex to the correct OCaml handler. */
1445   if ((opaque = malloc(sizeof(long))) == NULL)
1446     caml_failwith ("virEventAddTimeout: malloc");
1447   *((long*)opaque) = Int64_val(callback_id);
1448   NONBLOCKING(r = virEventAddTimeout(Int_val(ms), cb, opaque, freecb));
1449   CHECK_ERROR(r == -1, "virEventAddTimeout");
1450
1451   CAMLreturn(Val_int(r));
1452 }
1453
1454 CAMLprim value
1455 ocaml_libvirt_event_remove_timeout (value connv, value timer_id)
1456 {
1457   CAMLparam2 (connv, timer_id);
1458   int r;
1459
1460   NONBLOCKING(r = virEventRemoveTimeout(Int_val(timer_id)));
1461   CHECK_ERROR(r == -1, "virEventRemoveTimeout");
1462
1463   CAMLreturn(Val_int(r));
1464 }
1465
1466 CAMLprim value
1467 ocaml_libvirt_connect_domain_event_register_any(value connv, value domv, value callback, value callback_id)
1468 {
1469   CAMLparam4(connv, domv, callback, callback_id);
1470
1471   virConnectPtr conn = Connect_val (connv);
1472   virDomainPtr dom = NULL;
1473   int eventID = Tag_val(callback);
1474
1475   virConnectDomainEventGenericCallback cb;
1476   void *opaque;
1477   virFreeCallback freecb = free;
1478   int r;
1479
1480   if (domv != Val_int(0))
1481     dom = Domain_val (Field(domv, 0));
1482
1483   switch (eventID){
1484   case VIR_DOMAIN_EVENT_ID_LIFECYCLE:
1485     cb = VIR_DOMAIN_EVENT_CALLBACK(i_i_callback);
1486     break;
1487   case VIR_DOMAIN_EVENT_ID_REBOOT:
1488     cb = VIR_DOMAIN_EVENT_CALLBACK(u_callback);
1489     break;
1490   case VIR_DOMAIN_EVENT_ID_RTC_CHANGE:
1491     cb = VIR_DOMAIN_EVENT_CALLBACK(i64_callback);
1492     break;
1493   case VIR_DOMAIN_EVENT_ID_WATCHDOG:
1494     cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
1495     break;
1496   case VIR_DOMAIN_EVENT_ID_IO_ERROR:
1497     cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_i_callback);
1498     break;
1499   case VIR_DOMAIN_EVENT_ID_GRAPHICS:
1500     cb = VIR_DOMAIN_EVENT_CALLBACK(i_ga_ga_s_gs_callback);
1501     break;
1502   case VIR_DOMAIN_EVENT_ID_IO_ERROR_REASON:
1503     cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_i_s_callback);
1504     break;
1505   case VIR_DOMAIN_EVENT_ID_CONTROL_ERROR:
1506     cb = VIR_DOMAIN_EVENT_CALLBACK(u_callback);
1507     break;
1508   case VIR_DOMAIN_EVENT_ID_BLOCK_JOB:
1509     cb = VIR_DOMAIN_EVENT_CALLBACK(s_i_i_callback);
1510     break;
1511   case VIR_DOMAIN_EVENT_ID_DISK_CHANGE:
1512     cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_s_i_callback);
1513     break;
1514   case VIR_DOMAIN_EVENT_ID_TRAY_CHANGE:
1515     cb = VIR_DOMAIN_EVENT_CALLBACK(s_i_callback);
1516     break;
1517   case VIR_DOMAIN_EVENT_ID_PMWAKEUP:
1518     cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
1519     break;
1520   case VIR_DOMAIN_EVENT_ID_PMSUSPEND:
1521     cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
1522     break;
1523   case VIR_DOMAIN_EVENT_ID_BALLOON_CHANGE:
1524     cb = VIR_DOMAIN_EVENT_CALLBACK(i64_callback);
1525     break;
1526   case VIR_DOMAIN_EVENT_ID_PMSUSPEND_DISK:
1527     cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
1528     break;
1529   default:
1530     caml_failwith("vifConnectDomainEventRegisterAny: unimplemented eventID");
1531   }
1532
1533   /* Store the int64 callback_id as the opaque data so the OCaml
1534      callback can demultiplex to the correct OCaml handler. */
1535   if ((opaque = malloc(sizeof(long))) == NULL)
1536     caml_failwith ("virConnectDomainEventRegisterAny: malloc");
1537   *((long*)opaque) = Int64_val(callback_id);
1538   NONBLOCKING(r = virConnectDomainEventRegisterAny(conn, dom, eventID, cb, opaque, freecb));
1539   CHECK_ERROR(r == -1, "virConnectDomainEventRegisterAny");
1540
1541   CAMLreturn(Val_int(r));
1542 }
1543
1544 CAMLprim value
1545 ocaml_libvirt_storage_pool_get_info (value poolv)
1546 {
1547   CAMLparam1 (poolv);
1548   CAMLlocal2 (rv, v);
1549   virStoragePoolPtr pool = Pool_val (poolv);
1550   virStoragePoolInfo info;
1551   int r;
1552
1553   NONBLOCKING (r = virStoragePoolGetInfo (pool, &info));
1554   CHECK_ERROR (r == -1, "virStoragePoolGetInfo");
1555
1556   rv = caml_alloc (4, 0);
1557   Store_field (rv, 0, Val_int (info.state));
1558   v = caml_copy_int64 (info.capacity); Store_field (rv, 1, v);
1559   v = caml_copy_int64 (info.allocation); Store_field (rv, 2, v);
1560   v = caml_copy_int64 (info.available); Store_field (rv, 3, v);
1561
1562   CAMLreturn (rv);
1563 }
1564
1565 CAMLprim value
1566 ocaml_libvirt_storage_vol_get_info (value volv)
1567 {
1568   CAMLparam1 (volv);
1569   CAMLlocal2 (rv, v);
1570   virStorageVolPtr vol = Volume_val (volv);
1571   virStorageVolInfo info;
1572   int r;
1573
1574   NONBLOCKING (r = virStorageVolGetInfo (vol, &info));
1575   CHECK_ERROR (r == -1, "virStorageVolGetInfo");
1576
1577   rv = caml_alloc (3, 0);
1578   Store_field (rv, 0, Val_int (info.type));
1579   v = caml_copy_int64 (info.capacity); Store_field (rv, 1, v);
1580   v = caml_copy_int64 (info.allocation); Store_field (rv, 2, v);
1581
1582   CAMLreturn (rv);
1583 }
1584
1585 CAMLprim value
1586 ocaml_libvirt_secret_lookup_by_usage (value connv, value usagetypev, value usageidv)
1587 {
1588   CAMLparam3 (connv, usagetypev, usageidv);
1589   CAMLlocal1 (rv);
1590   virConnectPtr conn = Connect_val (connv);
1591   int usageType = Int_val (usagetypev);
1592   const char *usageID = String_val (usageidv);
1593   virSecretPtr r;
1594
1595   NONBLOCKING (r = virSecretLookupByUsage (conn, usageType, usageID));
1596   CHECK_ERROR (!r, "virSecretLookupByUsage");
1597
1598   rv = Val_secret (r, connv);
1599
1600   CAMLreturn (rv);
1601 }
1602
1603 CAMLprim value
1604 ocaml_libvirt_secret_set_value (value secv, value vv)
1605 {
1606   CAMLparam2 (secv, vv);
1607   virSecretPtr sec = Secret_val (secv);
1608   const unsigned char *secval = (unsigned char *) String_val (vv);
1609   const size_t size = caml_string_length (vv);
1610   int r;
1611
1612   NONBLOCKING (r = virSecretSetValue (sec, secval, size, 0));
1613   CHECK_ERROR (r == -1, "virSecretSetValue");
1614
1615   CAMLreturn (Val_unit);
1616 }
1617
1618 CAMLprim value
1619 ocaml_libvirt_secret_get_value (value secv)
1620 {
1621   CAMLparam1 (secv);
1622   CAMLlocal1 (rv);
1623   virSecretPtr sec = Secret_val (secv);
1624   unsigned char *secval;
1625   size_t size = 0;
1626
1627   NONBLOCKING (secval = virSecretGetValue (sec, &size, 0));
1628   CHECK_ERROR (secval == NULL, "virSecretGetValue");
1629
1630   rv = caml_alloc_string (size);
1631   memcpy (String_val (rv), secval, size);
1632   free (secval);
1633
1634   CAMLreturn (rv);
1635 }
1636
1637 /*----------------------------------------------------------------------*/
1638
1639 CAMLprim value
1640 ocaml_libvirt_virterror_get_last_error (value unitv)
1641 {
1642   CAMLparam1 (unitv);
1643   CAMLlocal1 (rv);
1644   virErrorPtr err = virGetLastError ();
1645
1646   rv = Val_opt (err, (Val_ptr_t) Val_virterror);
1647
1648   CAMLreturn (rv);
1649 }
1650
1651 CAMLprim value
1652 ocaml_libvirt_virterror_get_last_conn_error (value connv)
1653 {
1654   CAMLparam1 (connv);
1655   CAMLlocal1 (rv);
1656   virConnectPtr conn = Connect_val (connv);
1657
1658   rv = Val_opt (conn, (Val_ptr_t) Val_connect);
1659
1660   CAMLreturn (rv);
1661 }
1662
1663 CAMLprim value
1664 ocaml_libvirt_virterror_reset_last_error (value unitv)
1665 {
1666   CAMLparam1 (unitv);
1667   virResetLastError ();
1668   CAMLreturn (Val_unit);
1669 }
1670
1671 CAMLprim value
1672 ocaml_libvirt_virterror_reset_last_conn_error (value connv)
1673 {
1674   CAMLparam1 (connv);
1675   virConnectPtr conn = Connect_val (connv);
1676   virConnResetLastError (conn);
1677   CAMLreturn (Val_unit);
1678 }
1679
1680 /*----------------------------------------------------------------------*/
1681
1682 static void
1683 ignore_errors (void *user_data, virErrorPtr error)
1684 {
1685   /* do nothing */
1686 }
1687
1688 /* Initialise the library. */
1689 CAMLprim value
1690 ocaml_libvirt_init (value unit)
1691 {
1692   CAMLparam1 (unit);
1693
1694   virSetErrorFunc (NULL, ignore_errors);
1695   virInitialize ();
1696
1697   CAMLreturn (Val_unit);
1698 }