libvirt/libvirt_c_oneoffs.c

   1 /* OCaml bindings for libvirt.
   2  * (C) Copyright 2007-2017 Richard W.M. Jones, Red Hat Inc.
   3  * http://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_domain_get_id (value domv)
 328 {
 329   CAMLparam1 (domv);
 330   virDomainPtr dom = Domain_val (domv);
 331   unsigned int r;
 332
 333   NONBLOCKING (r = virDomainGetID (dom));
 334   /* In theory this could return -1 on error, but in practice
 335    * libvirt never does this unless you call it with a corrupted
 336    * or NULL dom object.  So ignore errors here.
 337    */
 338
 339   CAMLreturn (Val_int ((int) r));
 340 }
 341
 342 CAMLprim value
 343 ocaml_libvirt_domain_get_max_memory (value domv)
 344 {
 345   CAMLparam1 (domv);
 346   CAMLlocal1 (rv);
 347   virDomainPtr dom = Domain_val (domv);
 348   unsigned long r;
 349
 350   NONBLOCKING (r = virDomainGetMaxMemory (dom));
 351   CHECK_ERROR (r == 0 /* [sic] */, "virDomainGetMaxMemory");
 352
 353   rv = caml_copy_int64 (r);
 354   CAMLreturn (rv);
 355 }
 356
 357 CAMLprim value
 358 ocaml_libvirt_domain_set_max_memory (value domv, value memv)
 359 {
 360   CAMLparam2 (domv, memv);
 361   virDomainPtr dom = Domain_val (domv);
 362   unsigned long mem = Int64_val (memv);
 363   int r;
 364
 365   NONBLOCKING (r = virDomainSetMaxMemory (dom, mem));
 366   CHECK_ERROR (r == -1, "virDomainSetMaxMemory");
 367
 368   CAMLreturn (Val_unit);
 369 }
 370
 371 CAMLprim value
 372 ocaml_libvirt_domain_set_memory (value domv, value memv)
 373 {
 374   CAMLparam2 (domv, memv);
 375   virDomainPtr dom = Domain_val (domv);
 376   unsigned long mem = Int64_val (memv);
 377   int r;
 378
 379   NONBLOCKING (r = virDomainSetMemory (dom, mem));
 380   CHECK_ERROR (r == -1, "virDomainSetMemory");
 381
 382   CAMLreturn (Val_unit);
 383 }
 384
 385 CAMLprim value
 386 ocaml_libvirt_domain_get_info (value domv)
 387 {
 388   CAMLparam1 (domv);
 389   CAMLlocal2 (rv, v);
 390   virDomainPtr dom = Domain_val (domv);
 391   virDomainInfo info;
 392   int r;
 393
 394   NONBLOCKING (r = virDomainGetInfo (dom, &info));
 395   CHECK_ERROR (r == -1, "virDomainGetInfo");
 396
 397   rv = caml_alloc (5, 0);
 398   Store_field (rv, 0, Val_int (info.state)); // These flags are compatible.
 399   v = caml_copy_int64 (info.maxMem); Store_field (rv, 1, v);
 400   v = caml_copy_int64 (info.memory); Store_field (rv, 2, v);
 401   Store_field (rv, 3, Val_int (info.nrVirtCpu));
 402   v = caml_copy_int64 (info.cpuTime); Store_field (rv, 4, v);
 403
 404   CAMLreturn (rv);
 405 }
 406
 407 CAMLprim value
 408 ocaml_libvirt_domain_get_scheduler_type (value domv)
 409 {
 410   CAMLparam1 (domv);
 411   CAMLlocal2 (rv, strv);
 412   virDomainPtr dom = Domain_val (domv);
 413   char *r;
 414   int nparams;
 415
 416   NONBLOCKING (r = virDomainGetSchedulerType (dom, &nparams));
 417   CHECK_ERROR (!r, "virDomainGetSchedulerType");
 418
 419   rv = caml_alloc_tuple (2);
 420   strv = caml_copy_string (r); Store_field (rv, 0, strv);
 421   free (r);
 422   Store_field (rv, 1, nparams);
 423   CAMLreturn (rv);
 424 }
 425
 426 CAMLprim value
 427 ocaml_libvirt_domain_get_scheduler_parameters (value domv, value nparamsv)
 428 {
 429   CAMLparam2 (domv, nparamsv);
 430   CAMLlocal4 (rv, v, v2, v3);
 431   virDomainPtr dom = Domain_val (domv);
 432   int nparams = Int_val (nparamsv);
 433   virSchedParameterPtr params;
 434   int r, i;
 435
 436   params = malloc (sizeof (*params) * nparams);
 437   if (params == NULL)
 438     caml_raise_out_of_memory ();
 439
 440   NONBLOCKING (r = virDomainGetSchedulerParameters (dom, params, &nparams));
 441   CHECK_ERROR_CLEANUP (r == -1, free (params), "virDomainGetSchedulerParameters");
 442
 443   rv = caml_alloc (nparams, 0);
 444   for (i = 0; i < nparams; ++i) {
 445     v = caml_alloc_tuple (2); Store_field (rv, i, v);
 446     v2 = caml_copy_string (params[i].field); Store_field (v, 0, v2);
 447     switch (params[i].type) {
 448     case VIR_DOMAIN_SCHED_FIELD_INT:
 449       v2 = caml_alloc (1, 0);
 450       v3 = caml_copy_int32 (params[i].value.i); Store_field (v2, 0, v3);
 451       break;
 452     case VIR_DOMAIN_SCHED_FIELD_UINT:
 453       v2 = caml_alloc (1, 1);
 454       v3 = caml_copy_int32 (params[i].value.ui); Store_field (v2, 0, v3);
 455       break;
 456     case VIR_DOMAIN_SCHED_FIELD_LLONG:
 457       v2 = caml_alloc (1, 2);
 458       v3 = caml_copy_int64 (params[i].value.l); Store_field (v2, 0, v3);
 459       break;
 460     case VIR_DOMAIN_SCHED_FIELD_ULLONG:
 461       v2 = caml_alloc (1, 3);
 462       v3 = caml_copy_int64 (params[i].value.ul); Store_field (v2, 0, v3);
 463       break;
 464     case VIR_DOMAIN_SCHED_FIELD_DOUBLE:
 465       v2 = caml_alloc (1, 4);
 466       v3 = caml_copy_double (params[i].value.d); Store_field (v2, 0, v3);
 467       break;
 468     case VIR_DOMAIN_SCHED_FIELD_BOOLEAN:
 469       v2 = caml_alloc (1, 5);
 470       Store_field (v2, 0, Val_int (params[i].value.b));
 471       break;
 472     default:
 473       caml_failwith ((char *)__FUNCTION__);
 474     }
 475     Store_field (v, 1, v2);
 476   }
 477   free (params);
 478   CAMLreturn (rv);
 479 }
 480
 481 CAMLprim value
 482 ocaml_libvirt_domain_set_scheduler_parameters (value domv, value paramsv)
 483 {
 484   CAMLparam2 (domv, paramsv);
 485   CAMLlocal1 (v);
 486   virDomainPtr dom = Domain_val (domv);
 487   int nparams = Wosize_val (paramsv);
 488   virSchedParameterPtr params;
 489   int r, i;
 490   char *name;
 491
 492   params = malloc (sizeof (*params) * nparams);
 493   if (params == NULL)
 494     caml_raise_out_of_memory ();
 495
 496   for (i = 0; i < nparams; ++i) {
 497     v = Field (paramsv, i);     /* Points to the two-element tuple. */
 498     name = String_val (Field (v, 0));
 499     strncpy (params[i].field, name, VIR_DOMAIN_SCHED_FIELD_LENGTH);
 500     params[i].field[VIR_DOMAIN_SCHED_FIELD_LENGTH-1] = '\0';
 501     v = Field (v, 1);           /* Points to the sched_param_value block. */
 502     switch (Tag_val (v)) {
 503     case 0:
 504       params[i].type = VIR_DOMAIN_SCHED_FIELD_INT;
 505       params[i].value.i = Int32_val (Field (v, 0));
 506       break;
 507     case 1:
 508       params[i].type = VIR_DOMAIN_SCHED_FIELD_UINT;
 509       params[i].value.ui = Int32_val (Field (v, 0));
 510       break;
 511     case 2:
 512       params[i].type = VIR_DOMAIN_SCHED_FIELD_LLONG;
 513       params[i].value.l = Int64_val (Field (v, 0));
 514       break;
 515     case 3:
 516       params[i].type = VIR_DOMAIN_SCHED_FIELD_ULLONG;
 517       params[i].value.ul = Int64_val (Field (v, 0));
 518       break;
 519     case 4:
 520       params[i].type = VIR_DOMAIN_SCHED_FIELD_DOUBLE;
 521       params[i].value.d = Double_val (Field (v, 0));
 522       break;
 523     case 5:
 524       params[i].type = VIR_DOMAIN_SCHED_FIELD_BOOLEAN;
 525       params[i].value.b = Int_val (Field (v, 0));
 526       break;
 527     default:
 528       caml_failwith ((char *)__FUNCTION__);
 529     }
 530   }
 531
 532   NONBLOCKING (r = virDomainSetSchedulerParameters (dom, params, nparams));
 533   free (params);
 534   CHECK_ERROR (r == -1, "virDomainSetSchedulerParameters");
 535
 536   CAMLreturn (Val_unit);
 537 }
 538
 539 CAMLprim value
 540 ocaml_libvirt_domain_set_vcpus (value domv, value nvcpusv)
 541 {
 542   CAMLparam2 (domv, nvcpusv);
 543   virDomainPtr dom = Domain_val (domv);
 544   int r, nvcpus = Int_val (nvcpusv);
 545
 546   NONBLOCKING (r = virDomainSetVcpus (dom, nvcpus));
 547   CHECK_ERROR (r == -1, "virDomainSetVcpus");
 548
 549   CAMLreturn (Val_unit);
 550 }
 551
 552 CAMLprim value
 553 ocaml_libvirt_domain_pin_vcpu (value domv, value vcpuv, value cpumapv)
 554 {
 555   CAMLparam3 (domv, vcpuv, cpumapv);
 556   virDomainPtr dom = Domain_val (domv);
 557   int maplen = caml_string_length (cpumapv);
 558   unsigned char *cpumap = (unsigned char *) String_val (cpumapv);
 559   int vcpu = Int_val (vcpuv);
 560   int r;
 561
 562   NONBLOCKING (r = virDomainPinVcpu (dom, vcpu, cpumap, maplen));
 563   CHECK_ERROR (r == -1, "virDomainPinVcpu");
 564
 565   CAMLreturn (Val_unit);
 566 }
 567
 568 CAMLprim value
 569 ocaml_libvirt_domain_get_vcpus (value domv, value maxinfov, value maplenv)
 570 {
 571   CAMLparam3 (domv, maxinfov, maplenv);
 572   CAMLlocal5 (rv, infov, strv, v, v2);
 573   virDomainPtr dom = Domain_val (domv);
 574   int maxinfo = Int_val (maxinfov);
 575   int maplen = Int_val (maplenv);
 576   virVcpuInfoPtr info;
 577   unsigned char *cpumaps;
 578   int r, i;
 579
 580   info = calloc (maxinfo, sizeof (*info));
 581   if (info == NULL)
 582     caml_raise_out_of_memory ();
 583   cpumaps = calloc (maxinfo * maplen, sizeof (*cpumaps));
 584   if (cpumaps == NULL) {
 585     free (info);
 586     caml_raise_out_of_memory ();
 587   }
 588
 589   NONBLOCKING (r = virDomainGetVcpus (dom, info, maxinfo, cpumaps, maplen));
 590   CHECK_ERROR_CLEANUP (r == -1, free (info); free (cpumaps), "virDomainPinVcpu");
 591
 592   /* Copy the virVcpuInfo structures. */
 593   infov = caml_alloc (maxinfo, 0);
 594   for (i = 0; i < maxinfo; ++i) {
 595     v2 = caml_alloc (4, 0); Store_field (infov, i, v2);
 596     Store_field (v2, 0, Val_int (info[i].number));
 597     Store_field (v2, 1, Val_int (info[i].state));
 598     v = caml_copy_int64 (info[i].cpuTime); Store_field (v2, 2, v);
 599     Store_field (v2, 3, Val_int (info[i].cpu));
 600   }
 601
 602   /* Copy the bitmap. */
 603   strv = caml_alloc_string (maxinfo * maplen);
 604   memcpy (String_val (strv), cpumaps, maxinfo * maplen);
 605
 606   /* Allocate the tuple and return it. */
 607   rv = caml_alloc_tuple (3);
 608   Store_field (rv, 0, Val_int (r)); /* number of CPUs. */
 609   Store_field (rv, 1, infov);
 610   Store_field (rv, 2, strv);
 611
 612   free (info);
 613   free (cpumaps);
 614
 615   CAMLreturn (rv);
 616 }
 617
 618 CAMLprim value
 619 ocaml_libvirt_domain_get_cpu_stats (value domv)
 620 {
 621   CAMLparam1 (domv);
 622   CAMLlocal5 (cpustats, param_head, param_node, typed_param, typed_param_value);
 623   CAMLlocal1 (v);
 624   virDomainPtr dom = Domain_val (domv);
 625   virTypedParameterPtr params;
 626   int r, cpu, ncpus, nparams, i, j, pos;
 627   int nr_pcpus;
 628
 629   /* get number of pcpus */
 630   NONBLOCKING (nr_pcpus = virDomainGetCPUStats(dom, NULL, 0, 0, 0, 0));
 631   CHECK_ERROR (nr_pcpus < 0, "virDomainGetCPUStats");
 632
 633   /* get percpu information */
 634   NONBLOCKING (nparams = virDomainGetCPUStats(dom, NULL, 0, 0, 1, 0));
 635   CHECK_ERROR (nparams < 0, "virDomainGetCPUStats");
 636
 637   if ((params = malloc(sizeof(*params) * nparams * 128)) == NULL)
 638     caml_failwith ("virDomainGetCPUStats: malloc");
 639
 640   cpustats = caml_alloc (nr_pcpus, 0); /* cpustats: array of params(list of typed_param) */
 641   cpu = 0;
 642   while (cpu < nr_pcpus) {
 643     ncpus = nr_pcpus - cpu > 128 ? 128 : nr_pcpus - cpu;
 644
 645     NONBLOCKING (r = virDomainGetCPUStats(dom, params, nparams, cpu, ncpus, 0));
 646     CHECK_ERROR (r < 0, "virDomainGetCPUStats");
 647
 648     for (i = 0; i < ncpus; i++) {
 649       /* list of typed_param: single linked list of param_nodes */
 650       param_head = Val_emptylist; /* param_head: the head param_node of list of typed_param */
 651
 652       if (params[i * nparams].type == 0) {
 653         Store_field(cpustats, cpu + i, param_head);
 654         continue;
 655       }
 656
 657       for (j = r - 1; j >= 0; j--) {
 658         pos = i * nparams + j;
 659           if (params[pos].type == 0)
 660             continue;
 661
 662         param_node = caml_alloc(2, 0); /* param_node: typed_param, next param_node */
 663         Store_field(param_node, 1, param_head);
 664         param_head = param_node;
 665
 666         typed_param = caml_alloc(2, 0); /* typed_param: field name(string), typed_param_value */
 667         Store_field(param_node, 0, typed_param);
 668         Store_field(typed_param, 0, caml_copy_string(params[pos].field));
 669
 670         /* typed_param_value: value with the corresponding type tag */
 671         switch(params[pos].type) {
 672         case VIR_TYPED_PARAM_INT:
 673           typed_param_value = caml_alloc (1, 0);
 674           v = caml_copy_int32 (params[pos].value.i);
 675           break;
 676         case VIR_TYPED_PARAM_UINT:
 677           typed_param_value = caml_alloc (1, 1);
 678           v = caml_copy_int32 (params[pos].value.ui);
 679           break;
 680         case VIR_TYPED_PARAM_LLONG:
 681           typed_param_value = caml_alloc (1, 2);
 682           v = caml_copy_int64 (params[pos].value.l);
 683           break;
 684         case VIR_TYPED_PARAM_ULLONG:
 685           typed_param_value = caml_alloc (1, 3);
 686           v = caml_copy_int64 (params[pos].value.ul);
 687           break;
 688         case VIR_TYPED_PARAM_DOUBLE:
 689           typed_param_value = caml_alloc (1, 4);
 690           v = caml_copy_double (params[pos].value.d);
 691           break;
 692         case VIR_TYPED_PARAM_BOOLEAN:
 693           typed_param_value = caml_alloc (1, 5);
 694           v = Val_bool (params[pos].value.b);
 695           break;
 696         case VIR_TYPED_PARAM_STRING:
 697           typed_param_value = caml_alloc (1, 6);
 698           v = caml_copy_string (params[pos].value.s);
 699           free (params[pos].value.s);
 700           break;
 701         default:
 702             /* XXX Memory leak on this path, if there are more
 703              * VIR_TYPED_PARAM_STRING past this point in the array.
 704              */
 705           free (params);
 706           caml_failwith ("virDomainGetCPUStats: "
 707                          "unknown parameter type returned");
 708         }
 709         Store_field (typed_param_value, 0, v);
 710         Store_field (typed_param, 1, typed_param_value);
 711       }
 712       Store_field (cpustats, cpu + i, param_head);
 713     }
 714     cpu += ncpus;
 715   }
 716   free(params);
 717   CAMLreturn (cpustats);
 718 }
 719
 720 value
 721 ocaml_libvirt_domain_get_all_domain_stats (value connv,
 722                                            value statsv, value flagsv)
 723 {
 724   CAMLparam3 (connv, statsv, flagsv);
 725   CAMLlocal5 (rv, dsv, tpv, v, v1);
 726   CAMLlocal1 (v2);
 727   virConnectPtr conn = Connect_val (connv);
 728   virDomainStatsRecordPtr *rstats;
 729   unsigned int stats = 0, flags = 0;
 730   int i, j, r;
 731   unsigned char uuid[VIR_UUID_BUFLEN];
 732
 733   /* Get stats and flags. */
 734   for (; statsv != Val_int (0); statsv = Field (statsv, 1)) {
 735     v = Field (statsv, 0);
 736     if (v == Val_int (0))
 737       stats |= VIR_DOMAIN_STATS_STATE;
 738     else if (v == Val_int (1))
 739       stats |= VIR_DOMAIN_STATS_CPU_TOTAL;
 740     else if (v == Val_int (2))
 741       stats |= VIR_DOMAIN_STATS_BALLOON;
 742     else if (v == Val_int (3))
 743       stats |= VIR_DOMAIN_STATS_VCPU;
 744     else if (v == Val_int (4))
 745       stats |= VIR_DOMAIN_STATS_INTERFACE;
 746     else if (v == Val_int (5))
 747       stats |= VIR_DOMAIN_STATS_BLOCK;
 748     else if (v == Val_int (6))
 749       stats |= VIR_DOMAIN_STATS_PERF;
 750   }
 751   for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1)) {
 752     v = Field (flagsv, 0);
 753     if (v == Val_int (0))
 754       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_ACTIVE;
 755     else if (v == Val_int (1))
 756       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_INACTIVE;
 757     else if (v == Val_int (2))
 758       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_OTHER;
 759     else if (v == Val_int (3))
 760       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_PAUSED;
 761     else if (v == Val_int (4))
 762       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_PERSISTENT;
 763     else if (v == Val_int (5))
 764       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_RUNNING;
 765     else if (v == Val_int (6))
 766       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_SHUTOFF;
 767     else if (v == Val_int (7))
 768       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_TRANSIENT;
 769     else if (v == Val_int (8))
 770       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_BACKING;
 771     else if (v == Val_int (9))
 772       flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_ENFORCE_STATS;
 773   }
 774
 775   NONBLOCKING (r = virConnectGetAllDomainStats (conn, stats, &rstats, flags));
 776   CHECK_ERROR (r == -1, "virConnectGetAllDomainStats");
 777
 778   rv = caml_alloc (r, 0);       /* domain_stats_record array. */
 779   for (i = 0; i < r; ++i) {
 780     dsv = caml_alloc (2, 0);    /* domain_stats_record */
 781
 782     /* Libvirt returns something superficially resembling a
 783      * virDomainPtr, but it's not a real virDomainPtr object
 784      * (eg. dom->id == -1, and its refcount is wrong).  The only thing
 785      * we can safely get from it is the UUID.
 786      */
 787     v = caml_alloc_string (VIR_UUID_BUFLEN);
 788     virDomainGetUUID (rstats[i]->dom, uuid);
 789     memcpy (String_val (v), uuid, VIR_UUID_BUFLEN);
 790     Store_field (dsv, 0, v);
 791
 792     tpv = caml_alloc (rstats[i]->nparams, 0); /* typed_param array */
 793     for (j = 0; j < rstats[i]->nparams; ++j) {
 794       v2 = caml_alloc (2, 0);   /* typed_param: field name, value */
 795       Store_field (v2, 0, caml_copy_string (rstats[i]->params[j].field));
 796
 797       switch (rstats[i]->params[j].type) {
 798       case VIR_TYPED_PARAM_INT:
 799         v1 = caml_alloc (1, 0);
 800         v = caml_copy_int32 (rstats[i]->params[j].value.i);
 801         break;
 802       case VIR_TYPED_PARAM_UINT:
 803         v1 = caml_alloc (1, 1);
 804         v = caml_copy_int32 (rstats[i]->params[j].value.ui);
 805         break;
 806       case VIR_TYPED_PARAM_LLONG:
 807         v1 = caml_alloc (1, 2);
 808         v = caml_copy_int64 (rstats[i]->params[j].value.l);
 809         break;
 810       case VIR_TYPED_PARAM_ULLONG:
 811         v1 = caml_alloc (1, 3);
 812         v = caml_copy_int64 (rstats[i]->params[j].value.ul);
 813         break;
 814       case VIR_TYPED_PARAM_DOUBLE:
 815         v1 = caml_alloc (1, 4);
 816         v = caml_copy_double (rstats[i]->params[j].value.d);
 817         break;
 818       case VIR_TYPED_PARAM_BOOLEAN:
 819         v1 = caml_alloc (1, 5);
 820         v = Val_bool (rstats[i]->params[j].value.b);
 821         break;
 822       case VIR_TYPED_PARAM_STRING:
 823         v1 = caml_alloc (1, 6);
 824         v = caml_copy_string (rstats[i]->params[j].value.s);
 825         break;
 826       default:
 827         virDomainStatsRecordListFree (rstats);
 828         caml_failwith ("virConnectGetAllDomainStats: "
 829                        "unknown parameter type returned");
 830       }
 831       Store_field (v1, 0, v);
 832
 833       Store_field (v2, 1, v1);
 834       Store_field (tpv, j, v2);
 835     }
 836
 837     Store_field (dsv, 1, tpv);
 838     Store_field (rv, i, dsv);
 839   }
 840
 841   virDomainStatsRecordListFree (rstats);
 842   CAMLreturn (rv);
 843 }
 844
 845 CAMLprim value
 846 ocaml_libvirt_domain_migrate_native (value domv, value dconnv, value flagsv, value optdnamev, value opturiv, value optbandwidthv, value unitv)
 847 {
 848   CAMLparam5 (domv, dconnv, flagsv, optdnamev, opturiv);
 849   CAMLxparam2 (optbandwidthv, unitv);
 850   CAMLlocal2 (flagv, rv);
 851   virDomainPtr dom = Domain_val (domv);
 852   virConnectPtr dconn = Connect_val (dconnv);
 853   int flags = 0;
 854   const char *dname = Optstring_val (optdnamev);
 855   const char *uri = Optstring_val (opturiv);
 856   unsigned long bandwidth;
 857   virDomainPtr r;
 858
 859   /* Iterate over the list of flags. */
 860   for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1))
 861     {
 862       flagv = Field (flagsv, 0);
 863       if (flagv == Val_int (0))
 864         flags |= VIR_MIGRATE_LIVE;
 865     }
 866
 867   if (optbandwidthv == Val_int (0)) /* None */
 868     bandwidth = 0;
 869   else                          /* Some bandwidth */
 870     bandwidth = Int_val (Field (optbandwidthv, 0));
 871
 872   NONBLOCKING (r = virDomainMigrate (dom, dconn, flags, dname, uri, bandwidth));
 873   CHECK_ERROR (!r, "virDomainMigrate");
 874
 875   rv = Val_domain (r, dconnv);
 876
 877   CAMLreturn (rv);
 878 }
 879
 880 CAMLprim value
 881 ocaml_libvirt_domain_migrate_bytecode (value *argv, int argn)
 882 {
 883   return ocaml_libvirt_domain_migrate_native (argv[0], argv[1], argv[2],
 884                                               argv[3], argv[4], argv[5],
 885                                               argv[6]);
 886 }
 887
 888 CAMLprim value
 889 ocaml_libvirt_domain_block_stats (value domv, value pathv)
 890 {
 891   CAMLparam2 (domv, pathv);
 892   CAMLlocal2 (rv,v);
 893   virDomainPtr dom = Domain_val (domv);
 894   char *path = String_val (pathv);
 895   struct _virDomainBlockStats stats;
 896   int r;
 897
 898   NONBLOCKING (r = virDomainBlockStats (dom, path, &stats, sizeof stats));
 899   CHECK_ERROR (r == -1, "virDomainBlockStats");
 900
 901   rv = caml_alloc (5, 0);
 902   v = caml_copy_int64 (stats.rd_req); Store_field (rv, 0, v);
 903   v = caml_copy_int64 (stats.rd_bytes); Store_field (rv, 1, v);
 904   v = caml_copy_int64 (stats.wr_req); Store_field (rv, 2, v);
 905   v = caml_copy_int64 (stats.wr_bytes); Store_field (rv, 3, v);
 906   v = caml_copy_int64 (stats.errs); Store_field (rv, 4, v);
 907
 908   CAMLreturn (rv);
 909 }
 910
 911 CAMLprim value
 912 ocaml_libvirt_domain_interface_stats (value domv, value pathv)
 913 {
 914   CAMLparam2 (domv, pathv);
 915   CAMLlocal2 (rv,v);
 916   virDomainPtr dom = Domain_val (domv);
 917   char *path = String_val (pathv);
 918   struct _virDomainInterfaceStats stats;
 919   int r;
 920
 921   NONBLOCKING (r = virDomainInterfaceStats (dom, path, &stats, sizeof stats));
 922   CHECK_ERROR (r == -1, "virDomainInterfaceStats");
 923
 924   rv = caml_alloc (8, 0);
 925   v = caml_copy_int64 (stats.rx_bytes); Store_field (rv, 0, v);
 926   v = caml_copy_int64 (stats.rx_packets); Store_field (rv, 1, v);
 927   v = caml_copy_int64 (stats.rx_errs); Store_field (rv, 2, v);
 928   v = caml_copy_int64 (stats.rx_drop); Store_field (rv, 3, v);
 929   v = caml_copy_int64 (stats.tx_bytes); Store_field (rv, 4, v);
 930   v = caml_copy_int64 (stats.tx_packets); Store_field (rv, 5, v);
 931   v = caml_copy_int64 (stats.tx_errs); Store_field (rv, 6, v);
 932   v = caml_copy_int64 (stats.tx_drop); Store_field (rv, 7, v);
 933
 934   CAMLreturn (rv);
 935 }
 936
 937 CAMLprim value
 938 ocaml_libvirt_domain_block_peek_native (value domv, value pathv, value offsetv, value sizev, value bufferv, value boffv)
 939 {
 940   CAMLparam5 (domv, pathv, offsetv, sizev, bufferv);
 941   CAMLxparam1 (boffv);
 942   virDomainPtr dom = Domain_val (domv);
 943   const char *path = String_val (pathv);
 944   unsigned long long offset = Int64_val (offsetv);
 945   size_t size = Int_val (sizev);
 946   char *buffer = String_val (bufferv);
 947   int boff = Int_val (boffv);
 948   int r;
 949
 950   /* Check that the return buffer is big enough. */
 951   if (caml_string_length (bufferv) < boff + size)
 952     caml_failwith ("virDomainBlockPeek: return buffer too short");
 953
 954   /* NB. not NONBLOCKING because buffer might move (XXX) */
 955   r = virDomainBlockPeek (dom, path, offset, size, buffer+boff, 0);
 956   CHECK_ERROR (r == -1, "virDomainBlockPeek");
 957
 958   CAMLreturn (Val_unit);
 959 }
 960
 961 CAMLprim value
 962 ocaml_libvirt_domain_block_peek_bytecode (value *argv, int argn)
 963 {
 964   return ocaml_libvirt_domain_block_peek_native (argv[0], argv[1], argv[2],
 965                                                  argv[3], argv[4], argv[5]);
 966 }
 967
 968 CAMLprim value
 969 ocaml_libvirt_domain_memory_peek_native (value domv, value flagsv, value offsetv, value sizev, value bufferv, value boffv)
 970 {
 971   CAMLparam5 (domv, flagsv, offsetv, sizev, bufferv);
 972   CAMLxparam1 (boffv);
 973   CAMLlocal1 (flagv);
 974   virDomainPtr dom = Domain_val (domv);
 975   int flags = 0;
 976   unsigned long long offset = Int64_val (offsetv);
 977   size_t size = Int_val (sizev);
 978   char *buffer = String_val (bufferv);
 979   int boff = Int_val (boffv);
 980   int r;
 981
 982   /* Check that the return buffer is big enough. */
 983   if (caml_string_length (bufferv) < boff + size)
 984     caml_failwith ("virDomainMemoryPeek: return buffer too short");
 985
 986   /* Do flags. */
 987   for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1))
 988     {
 989       flagv = Field (flagsv, 0);
 990       if (flagv == Val_int (0))
 991         flags |= VIR_MEMORY_VIRTUAL;
 992     }
 993
 994   /* NB. not NONBLOCKING because buffer might move (XXX) */
 995   r = virDomainMemoryPeek (dom, offset, size, buffer+boff, flags);
 996   CHECK_ERROR (r == -1, "virDomainMemoryPeek");
 997
 998   CAMLreturn (Val_unit);
 999 }
1000
1001 CAMLprim value
1002 ocaml_libvirt_domain_memory_peek_bytecode (value *argv, int argn)
1003 {
1004   return ocaml_libvirt_domain_memory_peek_native (argv[0], argv[1], argv[2],
1005                                                   argv[3], argv[4], argv[5]);
1006 }
1007
1008 CAMLprim value
1009 ocaml_libvirt_domain_get_xml_desc_flags (value domv, value flagsv)
1010 {
1011   CAMLparam2 (domv, flagsv);
1012   CAMLlocal2 (rv, flagv);
1013   virDomainPtr dom = Domain_val (domv);
1014   int flags = 0;
1015   char *r;
1016
1017   /* Do flags. */
1018   for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1))
1019     {
1020       flagv = Field (flagsv, 0);
1021       if (flagv == Val_int (0))
1022         flags |= VIR_DOMAIN_XML_SECURE;
1023       else if (flagv == Val_int (1))
1024         flags |= VIR_DOMAIN_XML_INACTIVE;
1025       else if (flagv == Val_int (2))
1026         flags |= VIR_DOMAIN_XML_UPDATE_CPU;
1027       else if (flagv == Val_int (3))
1028         flags |= VIR_DOMAIN_XML_MIGRATABLE;
1029     }
1030
1031   NONBLOCKING (r = virDomainGetXMLDesc (dom, flags));
1032   CHECK_ERROR (!r, "virDomainGetXMLDesc");
1033
1034   rv = caml_copy_string (r);
1035   free (r);
1036   CAMLreturn (rv);
1037 }
1038
1039 /*----------------------------------------------------------------------*/
1040
1041 /* Domain events */
1042
1043 CAMLprim value
1044 ocaml_libvirt_event_register_default_impl (value unitv)
1045 {
1046   CAMLparam1 (unitv);
1047
1048   /* arg is of type unit = void */
1049   int r;
1050
1051   NONBLOCKING (r = virEventRegisterDefaultImpl ());
1052   /* must be called before connection, therefore we can't use CHECK_ERROR */
1053   if (r == -1) caml_failwith("virEventRegisterDefaultImpl");
1054
1055   CAMLreturn (Val_unit);
1056 }
1057
1058 CAMLprim value
1059 ocaml_libvirt_event_run_default_impl (value unitv)
1060 {
1061   CAMLparam1 (unitv);
1062
1063   /* arg is of type unit = void */
1064   int r;
1065
1066   NONBLOCKING (r = virEventRunDefaultImpl ());
1067   if (r == -1) caml_failwith("virEventRunDefaultImpl");
1068
1069   CAMLreturn (Val_unit);
1070 }
1071
1072 /* We register a single C callback function for every distinct
1073    callback signature. We encode the signature itself in the function
1074    name and also in the name of the assocated OCaml callback
1075    e.g.:
1076       a C function called
1077          i_i64_s_callback(virConnectPtr conn,
1078                           virDomainPtr dom,
1079                           int x,
1080                           long y,
1081                           char *z,
1082                           void *opaque)
1083       would correspond to an OCaml callback
1084          Libvirt.i_i64_s_callback :
1085            int64 -> [`R] Domain.t -> int -> int64 -> string option -> unit
1086       where the initial int64 is a unique ID used by the OCaml to
1087       dispatch to the specific OCaml closure and stored by libvirt
1088       as the "opaque" data. */
1089
1090 /* Every one of the callbacks starts with a DOMAIN_CALLBACK_BEGIN(NAME)
1091    where NAME is the string name of the OCaml callback registered
1092    in libvirt.ml. */
1093 #define DOMAIN_CALLBACK_BEGIN(NAME)                              \
1094   value connv, domv, callback_id, result;                        \
1095   connv = domv = callback_id = result = Val_int(0);              \
1096   static value *callback = NULL;                                 \
1097   caml_leave_blocking_section();                                 \
1098   if (callback == NULL)                                          \
1099     callback = caml_named_value(NAME);                           \
1100   if (callback == NULL)                                          \
1101     abort(); /* C code out of sync with OCaml code */            \
1102   if ((virDomainRef(dom) == -1) || (virConnectRef(conn) == -1))  \
1103     abort(); /* should never happen in practice? */              \
1104                                                                  \
1105   Begin_roots4(connv, domv, callback_id, result);                \
1106   connv = Val_connect(conn);                                     \
1107   domv = Val_domain(dom, connv);                                 \
1108   callback_id = caml_copy_int64(*(long *)opaque);
1109
1110 /* Every one of the callbacks ends with a CALLBACK_END */
1111 #define DOMAIN_CALLBACK_END                                      \
1112   (void) caml_callback3(*callback, callback_id, domv, result);   \
1113   End_roots();                                                   \
1114   caml_enter_blocking_section();
1115
1116
1117 static void
1118 i_i_callback(virConnectPtr conn,
1119              virDomainPtr dom,
1120              int x,
1121              int y,
1122              void * opaque)
1123 {
1124   DOMAIN_CALLBACK_BEGIN("Libvirt.i_i_callback")
1125   result = caml_alloc_tuple(2);
1126   Store_field(result, 0, Val_int(x));
1127   Store_field(result, 1, Val_int(y));
1128   DOMAIN_CALLBACK_END
1129 }
1130
1131 static void
1132 u_callback(virConnectPtr conn,
1133            virDomainPtr dom,
1134            void *opaque)
1135 {
1136   DOMAIN_CALLBACK_BEGIN("Libvirt.u_callback")
1137   result = Val_int(0); /* () */
1138   DOMAIN_CALLBACK_END
1139 }
1140
1141 static void
1142 i64_callback(virConnectPtr conn,
1143              virDomainPtr dom,
1144              long long int64,
1145              void *opaque)
1146 {
1147   DOMAIN_CALLBACK_BEGIN("Libvirt.i64_callback")
1148   result = caml_copy_int64(int64);
1149   DOMAIN_CALLBACK_END
1150 }
1151
1152 static void
1153 i_callback(virConnectPtr conn,
1154            virDomainPtr dom,
1155            int x,
1156            void *opaque)
1157 {
1158   DOMAIN_CALLBACK_BEGIN("Libvirt.i_callback")
1159   result = Val_int(x);
1160   DOMAIN_CALLBACK_END
1161 }
1162
1163 static void
1164 s_i_callback(virConnectPtr conn,
1165              virDomainPtr dom,
1166              char *x,
1167              int y,
1168              void * opaque)
1169 {
1170   DOMAIN_CALLBACK_BEGIN("Libvirt.s_i_callback")
1171   result = caml_alloc_tuple(2);
1172   Store_field(result, 0,
1173               Val_opt(x, (Val_ptr_t) caml_copy_string));
1174   Store_field(result, 1, Val_int(y));
1175   DOMAIN_CALLBACK_END
1176 }
1177
1178 static void
1179 s_i_i_callback(virConnectPtr conn,
1180                virDomainPtr dom,
1181                char *x,
1182                int y,
1183                int z,
1184                void * opaque)
1185 {
1186   DOMAIN_CALLBACK_BEGIN("Libvirt.s_i_i_callback")
1187   result = caml_alloc_tuple(3);
1188   Store_field(result, 0,
1189               Val_opt(x, (Val_ptr_t) caml_copy_string));
1190   Store_field(result, 1, Val_int(y));
1191   Store_field(result, 2, Val_int(z));
1192   DOMAIN_CALLBACK_END
1193 }
1194
1195 static void
1196 s_s_i_callback(virConnectPtr conn,
1197                virDomainPtr dom,
1198                char *x,
1199                char *y,
1200                int z,
1201                void *opaque)
1202 {
1203   DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_i_callback")
1204   result = caml_alloc_tuple(3);
1205   Store_field(result, 0,
1206               Val_opt(x, (Val_ptr_t) caml_copy_string));
1207   Store_field(result, 1,
1208               Val_opt(y, (Val_ptr_t) caml_copy_string));
1209   Store_field(result, 2, Val_int(z));
1210   DOMAIN_CALLBACK_END
1211 }
1212
1213 static void
1214 s_s_i_s_callback(virConnectPtr conn,
1215                  virDomainPtr dom,
1216                  char *x,
1217                  char *y,
1218                  int z,
1219                  char *a,
1220                  void *opaque)
1221 {
1222   DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_i_s_callback")
1223   result = caml_alloc_tuple(4);
1224   Store_field(result, 0,
1225               Val_opt(x, (Val_ptr_t) caml_copy_string));
1226   Store_field(result, 1,
1227               Val_opt(y, (Val_ptr_t) caml_copy_string));
1228   Store_field(result, 2, Val_int(z));
1229   Store_field(result, 3,
1230               Val_opt(a, (Val_ptr_t) caml_copy_string));
1231   DOMAIN_CALLBACK_END
1232 }
1233
1234 static void
1235 s_s_s_i_callback(virConnectPtr conn,
1236                  virDomainPtr dom,
1237                  char * x,
1238                  char * y,
1239                  char * z,
1240                  int a,
1241                  void * opaque)
1242 {
1243   DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_s_i_callback")
1244   result = caml_alloc_tuple(4);
1245   Store_field(result, 0,
1246               Val_opt(x, (Val_ptr_t) caml_copy_string));
1247   Store_field(result, 1,
1248               Val_opt(y, (Val_ptr_t) caml_copy_string));
1249   Store_field(result, 2,
1250               Val_opt(z, (Val_ptr_t) caml_copy_string));
1251   Store_field(result, 3, Val_int(a));
1252   DOMAIN_CALLBACK_END
1253 }
1254
1255 static value
1256 Val_event_graphics_address(virDomainEventGraphicsAddressPtr x)
1257 {
1258   CAMLparam0 ();
1259   CAMLlocal1(result);
1260   result = caml_alloc_tuple(3);
1261   Store_field(result, 0, Val_int(x->family));
1262   Store_field(result, 1,
1263               Val_opt((void *) x->node, (Val_ptr_t) caml_copy_string));
1264   Store_field(result, 2,
1265               Val_opt((void *) x->service, (Val_ptr_t) caml_copy_string));
1266   CAMLreturn(result);
1267 }
1268
1269 static value
1270 Val_event_graphics_subject_identity(virDomainEventGraphicsSubjectIdentityPtr x)
1271 {
1272   CAMLparam0 ();
1273   CAMLlocal1(result);
1274   result = caml_alloc_tuple(2);
1275   Store_field(result, 0,
1276               Val_opt((void *) x->type, (Val_ptr_t) caml_copy_string));
1277   Store_field(result, 1,
1278               Val_opt((void *) x->name, (Val_ptr_t) caml_copy_string));
1279   CAMLreturn(result);
1280
1281 }
1282
1283 static value
1284 Val_event_graphics_subject(virDomainEventGraphicsSubjectPtr x)
1285 {
1286   CAMLparam0 ();
1287   CAMLlocal1(result);
1288   int i;
1289   result = caml_alloc_tuple(x->nidentity);
1290   for (i = 0; i < x->nidentity; i++ )
1291     Store_field(result, i,
1292                 Val_event_graphics_subject_identity(x->identities + i));
1293   CAMLreturn(result);
1294 }
1295
1296 static void
1297 i_ga_ga_s_gs_callback(virConnectPtr conn,
1298                       virDomainPtr dom,
1299                       int i1,
1300                       virDomainEventGraphicsAddressPtr ga1,
1301                       virDomainEventGraphicsAddressPtr ga2,
1302                       char *s1,
1303                       virDomainEventGraphicsSubjectPtr gs1,
1304                       void * opaque)
1305 {
1306   DOMAIN_CALLBACK_BEGIN("Libvirt.i_ga_ga_s_gs_callback")
1307   result = caml_alloc_tuple(5);
1308   Store_field(result, 0, Val_int(i1));
1309   Store_field(result, 1, Val_event_graphics_address(ga1));
1310   Store_field(result, 2, Val_event_graphics_address(ga2));
1311   Store_field(result, 3,
1312               Val_opt(s1, (Val_ptr_t) caml_copy_string));
1313   Store_field(result, 4, Val_event_graphics_subject(gs1));
1314   DOMAIN_CALLBACK_END
1315 }
1316
1317 static void
1318 timeout_callback(int timer, void *opaque)
1319 {
1320   value callback_id, result;
1321   callback_id = result = Val_int(0);
1322   static value *callback = NULL;
1323   caml_leave_blocking_section();
1324   if (callback == NULL)
1325     callback = caml_named_value("Libvirt.timeout_callback");
1326   if (callback == NULL)
1327     abort(); /* C code out of sync with OCaml code */
1328
1329   Begin_roots2(callback_id, result);
1330   callback_id = caml_copy_int64(*(long *)opaque);
1331
1332   (void)caml_callback_exn(*callback, callback_id);
1333   End_roots();
1334   caml_enter_blocking_section();
1335 }
1336
1337 CAMLprim value
1338 ocaml_libvirt_event_add_timeout (value connv, value ms, value callback_id)
1339 {
1340   CAMLparam3 (connv, ms, callback_id);
1341   void *opaque;
1342   virFreeCallback freecb = free;
1343   virEventTimeoutCallback cb = timeout_callback;
1344
1345   int r;
1346
1347   /* Store the int64 callback_id as the opaque data so the OCaml
1348      callback can demultiplex to the correct OCaml handler. */
1349   if ((opaque = malloc(sizeof(long))) == NULL)
1350     caml_failwith ("virEventAddTimeout: malloc");
1351   *((long*)opaque) = Int64_val(callback_id);
1352   NONBLOCKING(r = virEventAddTimeout(Int_val(ms), cb, opaque, freecb));
1353   CHECK_ERROR(r == -1, "virEventAddTimeout");
1354
1355   CAMLreturn(Val_int(r));
1356 }
1357
1358 CAMLprim value
1359 ocaml_libvirt_event_remove_timeout (value connv, value timer_id)
1360 {
1361   CAMLparam2 (connv, timer_id);
1362   int r;
1363
1364   NONBLOCKING(r = virEventRemoveTimeout(Int_val(timer_id)));
1365   CHECK_ERROR(r == -1, "virEventRemoveTimeout");
1366
1367   CAMLreturn(Val_int(r));
1368 }
1369
1370 CAMLprim value
1371 ocaml_libvirt_connect_domain_event_register_any(value connv, value domv, value callback, value callback_id)
1372 {
1373   CAMLparam4(connv, domv, callback, callback_id);
1374
1375   virConnectPtr conn = Connect_val (connv);
1376   virDomainPtr dom = NULL;
1377   int eventID = Tag_val(callback);
1378
1379   virConnectDomainEventGenericCallback cb;
1380   void *opaque;
1381   virFreeCallback freecb = free;
1382   int r;
1383
1384   if (domv != Val_int(0))
1385     dom = Domain_val (Field(domv, 0));
1386
1387   switch (eventID){
1388   case VIR_DOMAIN_EVENT_ID_LIFECYCLE:
1389     cb = VIR_DOMAIN_EVENT_CALLBACK(i_i_callback);
1390     break;
1391   case VIR_DOMAIN_EVENT_ID_REBOOT:
1392     cb = VIR_DOMAIN_EVENT_CALLBACK(u_callback);
1393     break;
1394   case VIR_DOMAIN_EVENT_ID_RTC_CHANGE:
1395     cb = VIR_DOMAIN_EVENT_CALLBACK(i64_callback);
1396     break;
1397   case VIR_DOMAIN_EVENT_ID_WATCHDOG:
1398     cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
1399     break;
1400   case VIR_DOMAIN_EVENT_ID_IO_ERROR:
1401     cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_i_callback);
1402     break;
1403   case VIR_DOMAIN_EVENT_ID_GRAPHICS:
1404     cb = VIR_DOMAIN_EVENT_CALLBACK(i_ga_ga_s_gs_callback);
1405     break;
1406   case VIR_DOMAIN_EVENT_ID_IO_ERROR_REASON:
1407     cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_i_s_callback);
1408     break;
1409   case VIR_DOMAIN_EVENT_ID_CONTROL_ERROR:
1410     cb = VIR_DOMAIN_EVENT_CALLBACK(u_callback);
1411     break;
1412   case VIR_DOMAIN_EVENT_ID_BLOCK_JOB:
1413     cb = VIR_DOMAIN_EVENT_CALLBACK(s_i_i_callback);
1414     break;
1415   case VIR_DOMAIN_EVENT_ID_DISK_CHANGE:
1416     cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_s_i_callback);
1417     break;
1418   case VIR_DOMAIN_EVENT_ID_TRAY_CHANGE:
1419     cb = VIR_DOMAIN_EVENT_CALLBACK(s_i_callback);
1420     break;
1421   case VIR_DOMAIN_EVENT_ID_PMWAKEUP:
1422     cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
1423     break;
1424   case VIR_DOMAIN_EVENT_ID_PMSUSPEND:
1425     cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
1426     break;
1427   case VIR_DOMAIN_EVENT_ID_BALLOON_CHANGE:
1428     cb = VIR_DOMAIN_EVENT_CALLBACK(i64_callback);
1429     break;
1430   case VIR_DOMAIN_EVENT_ID_PMSUSPEND_DISK:
1431     cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
1432     break;
1433   default:
1434     caml_failwith("vifConnectDomainEventRegisterAny: unimplemented eventID");
1435   }
1436
1437   /* Store the int64 callback_id as the opaque data so the OCaml
1438      callback can demultiplex to the correct OCaml handler. */
1439   if ((opaque = malloc(sizeof(long))) == NULL)
1440     caml_failwith ("virConnectDomainEventRegisterAny: malloc");
1441   *((long*)opaque) = Int64_val(callback_id);
1442   NONBLOCKING(r = virConnectDomainEventRegisterAny(conn, dom, eventID, cb, opaque, freecb));
1443   CHECK_ERROR(r == -1, "virConnectDomainEventRegisterAny");
1444
1445   CAMLreturn(Val_int(r));
1446 }
1447
1448 CAMLprim value
1449 ocaml_libvirt_storage_pool_get_info (value poolv)
1450 {
1451   CAMLparam1 (poolv);
1452   CAMLlocal2 (rv, v);
1453   virStoragePoolPtr pool = Pool_val (poolv);
1454   virStoragePoolInfo info;
1455   int r;
1456
1457   NONBLOCKING (r = virStoragePoolGetInfo (pool, &info));
1458   CHECK_ERROR (r == -1, "virStoragePoolGetInfo");
1459
1460   rv = caml_alloc (4, 0);
1461   Store_field (rv, 0, Val_int (info.state));
1462   v = caml_copy_int64 (info.capacity); Store_field (rv, 1, v);
1463   v = caml_copy_int64 (info.allocation); Store_field (rv, 2, v);
1464   v = caml_copy_int64 (info.available); Store_field (rv, 3, v);
1465
1466   CAMLreturn (rv);
1467 }
1468
1469 CAMLprim value
1470 ocaml_libvirt_storage_vol_get_info (value volv)
1471 {
1472   CAMLparam1 (volv);
1473   CAMLlocal2 (rv, v);
1474   virStorageVolPtr vol = Volume_val (volv);
1475   virStorageVolInfo info;
1476   int r;
1477
1478   NONBLOCKING (r = virStorageVolGetInfo (vol, &info));
1479   CHECK_ERROR (r == -1, "virStorageVolGetInfo");
1480
1481   rv = caml_alloc (3, 0);
1482   Store_field (rv, 0, Val_int (info.type));
1483   v = caml_copy_int64 (info.capacity); Store_field (rv, 1, v);
1484   v = caml_copy_int64 (info.allocation); Store_field (rv, 2, v);
1485
1486   CAMLreturn (rv);
1487 }
1488
1489 /*----------------------------------------------------------------------*/
1490
1491 CAMLprim value
1492 ocaml_libvirt_virterror_get_last_error (value unitv)
1493 {
1494   CAMLparam1 (unitv);
1495   CAMLlocal1 (rv);
1496   virErrorPtr err = virGetLastError ();
1497
1498   rv = Val_opt (err, (Val_ptr_t) Val_virterror);
1499
1500   CAMLreturn (rv);
1501 }
1502
1503 CAMLprim value
1504 ocaml_libvirt_virterror_get_last_conn_error (value connv)
1505 {
1506   CAMLparam1 (connv);
1507   CAMLlocal1 (rv);
1508   virConnectPtr conn = Connect_val (connv);
1509
1510   rv = Val_opt (conn, (Val_ptr_t) Val_connect);
1511
1512   CAMLreturn (rv);
1513 }
1514
1515 CAMLprim value
1516 ocaml_libvirt_virterror_reset_last_error (value unitv)
1517 {
1518   CAMLparam1 (unitv);
1519   virResetLastError ();
1520   CAMLreturn (Val_unit);
1521 }
1522
1523 CAMLprim value
1524 ocaml_libvirt_virterror_reset_last_conn_error (value connv)
1525 {
1526   CAMLparam1 (connv);
1527   virConnectPtr conn = Connect_val (connv);
1528   virConnResetLastError (conn);
1529   CAMLreturn (Val_unit);
1530 }
1531
1532 /*----------------------------------------------------------------------*/
1533
1534 static void
1535 ignore_errors (void *user_data, virErrorPtr error)
1536 {
1537   /* do nothing */
1538 }
1539
1540 /* Initialise the library. */
1541 CAMLprim value
1542 ocaml_libvirt_init (value unit)
1543 {
1544   CAMLparam1 (unit);
1545
1546   virSetErrorFunc (NULL, ignore_errors);
1547   virInitialize ();
1548
1549   CAMLreturn (Val_unit);
1550 }