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