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