ocaml/guestfs_c.c

   1 /* libguestfs
   2  * Copyright (C) 2009-2011 Red Hat Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2 of the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  */
  18
  19 #include <config.h>
  20 #include <stdio.h>
  21 #include <stdlib.h>
  22 #include <string.h>
  23
  24 #include <guestfs.h>
  25
  26 #include <caml/config.h>
  27 #include <caml/alloc.h>
  28 #include <caml/callback.h>
  29 #include <caml/custom.h>
  30 #include <caml/fail.h>
  31 #include <caml/memory.h>
  32 #include <caml/mlvalues.h>
  33 #include <caml/printexc.h>
  34 #include <caml/signals.h>
  35
  36 #include "guestfs_c.h"
  37
  38 static value **get_all_event_callbacks (guestfs_h *g, size_t *len_rtn);
  39 static void event_callback_wrapper (guestfs_h *g, void *data, uint64_t event, int event_handle, int flags, const char *buf, size_t buf_len, const uint64_t *array, size_t array_len);
  40
  41 /* This macro was added in OCaml 3.10.  Backport for earlier versions. */
  42 #ifndef CAMLreturnT
  43 #define CAMLreturnT(type, result) do{ \
  44   type caml__temp_result = (result); \
  45   caml_local_roots = caml__frame; \
  46   return (caml__temp_result); \
  47 }while(0)
  48 #endif
  49
  50 /* These prototypes are solely to quiet gcc warning.  */
  51 CAMLprim value ocaml_guestfs_create (void);
  52 CAMLprim value ocaml_guestfs_close (value gv);
  53 CAMLprim value ocaml_guestfs_set_event_callback (value gv, value closure, value events);
  54 CAMLprim value ocaml_guestfs_delete_event_callback (value gv, value eh);
  55 value ocaml_guestfs_last_errno (value gv);
  56 value ocaml_guestfs_user_cancel (value gv);
  57
  58 /* Allocate handles and deal with finalization. */
  59 static void
  60 guestfs_finalize (value gv)
  61 {
  62   guestfs_h *g = Guestfs_val (gv);
  63
  64   if (g) {
  65     /* There is a nasty, difficult to solve case here where the
  66      * user deletes events in one of the callbacks that we are
  67      * about to invoke, resulting in a double-free.  XXX
  68      */
  69     size_t len, i;
  70     value **roots = get_all_event_callbacks (g, &len);
  71
  72     value *v = guestfs_get_private (g, "_ocaml_g");
  73
  74     /* Close the handle: this could invoke callbacks from the list
  75      * above, which is why we don't want to delete them before
  76      * closing the handle.
  77      */
  78     guestfs_close (g);
  79
  80     /* Now unregister the global roots. */
  81     for (i = 0; i < len; ++i) {
  82       caml_remove_global_root (roots[i]);
  83       free (roots[i]);
  84     }
  85     free (roots);
  86
  87     caml_remove_global_root (v);
  88     free (v);
  89   }
  90 }
  91
  92 static struct custom_operations guestfs_custom_operations = {
  93   (char *) "guestfs_custom_operations",
  94   guestfs_finalize,
  95   custom_compare_default,
  96   custom_hash_default,
  97   custom_serialize_default,
  98   custom_deserialize_default
  99 };
 100
 101 static value
 102 Val_guestfs (guestfs_h *g)
 103 {
 104   CAMLparam0 ();
 105   CAMLlocal1 (rv);
 106
 107   rv = caml_alloc_custom (&guestfs_custom_operations,
 108                           sizeof (guestfs_h *), 0, 1);
 109   Guestfs_val (rv) = g;
 110
 111   CAMLreturn (rv);
 112 }
 113
 114 void
 115 ocaml_guestfs_raise_error (guestfs_h *g, const char *func)
 116 {
 117   CAMLparam0 ();
 118   CAMLlocal1 (v);
 119   const char *msg;
 120
 121   msg = guestfs_last_error (g);
 122
 123   if (msg)
 124     v = caml_copy_string (msg);
 125   else
 126     v = caml_copy_string (func);
 127   caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_error"), v);
 128   CAMLnoreturn;
 129 }
 130
 131 void
 132 ocaml_guestfs_raise_closed (const char *func)
 133 {
 134   CAMLparam0 ();
 135   CAMLlocal1 (v);
 136
 137   v = caml_copy_string (func);
 138   caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_closed"), v);
 139   CAMLnoreturn;
 140 }
 141
 142 /* Guestfs.create */
 143 CAMLprim value
 144 ocaml_guestfs_create (void)
 145 {
 146   CAMLparam0 ();
 147   CAMLlocal1 (gv);
 148   guestfs_h *g;
 149   value *v;
 150
 151   g = guestfs_create ();
 152   if (g == NULL)
 153     caml_failwith ("failed to create guestfs handle");
 154
 155   guestfs_set_error_handler (g, NULL, NULL);
 156
 157   gv = Val_guestfs (g);
 158
 159   /* Store the OCaml handle into the C handle.  This is only so we can
 160    * map the C handle to the OCaml handle in event_callback_wrapper.
 161    */
 162   v = guestfs_safe_malloc (g, sizeof *v);
 163   *v = gv;
 164   /* XXX This global root is generational, but we cannot rely on every
 165    * user having the OCaml 3.11 version which supports this.
 166    */
 167   caml_register_global_root (v);
 168   guestfs_set_private (g, "_ocaml_g", v);
 169
 170   CAMLreturn (gv);
 171 }
 172
 173 /* Guestfs.close */
 174 CAMLprim value
 175 ocaml_guestfs_close (value gv)
 176 {
 177   CAMLparam1 (gv);
 178
 179   guestfs_finalize (gv);
 180
 181   /* So we don't double-free in the finalizer. */
 182   Guestfs_val (gv) = NULL;
 183
 184   CAMLreturn (Val_unit);
 185 }
 186
 187 /* Copy string array value. */
 188 char **
 189 ocaml_guestfs_strings_val (guestfs_h *g, value sv)
 190 {
 191   CAMLparam1 (sv);
 192   char **r;
 193   unsigned int i;
 194
 195   r = guestfs_safe_malloc (g, sizeof (char *) * (Wosize_val (sv) + 1));
 196   for (i = 0; i < Wosize_val (sv); ++i)
 197     r[i] = guestfs_safe_strdup (g, String_val (Field (sv, i)));
 198   r[i] = NULL;
 199
 200   CAMLreturnT (char **, r);
 201 }
 202
 203 /* Free array of strings. */
 204 void
 205 ocaml_guestfs_free_strings (char **argv)
 206 {
 207   unsigned int i;
 208
 209   for (i = 0; argv[i] != NULL; ++i)
 210     free (argv[i]);
 211   free (argv);
 212 }
 213
 214 static uint64_t
 215 event_bitmask_of_event_list (value events)
 216 {
 217   uint64_t r = 0;
 218
 219   while (events != Val_int (0)) {
 220     r |= UINT64_C(1) << Int_val (Field (events, 0));
 221     events = Field (events, 1);
 222   }
 223
 224   return r;
 225 }
 226
 227 /* Guestfs.set_event_callback */
 228 CAMLprim value
 229 ocaml_guestfs_set_event_callback (value gv, value closure, value events)
 230 {
 231   CAMLparam3 (gv, closure, events);
 232   char key[64];
 233   int eh;
 234   uint64_t event_bitmask;
 235
 236   guestfs_h *g = Guestfs_val (gv);
 237
 238   event_bitmask = event_bitmask_of_event_list (events);
 239
 240   value *root = guestfs_safe_malloc (g, sizeof *root);
 241   *root = closure;
 242
 243   eh = guestfs_set_event_callback (g, event_callback_wrapper,
 244                                    event_bitmask, 0, root);
 245
 246   if (eh == -1) {
 247     free (root);
 248     ocaml_guestfs_raise_error (g, "set_event_callback");
 249   }
 250
 251   /* XXX This global root is generational, but we cannot rely on every
 252    * user having the OCaml 3.11 version which supports this.
 253    */
 254   caml_register_global_root (root);
 255
 256   snprintf (key, sizeof key, "_ocaml_event_%d", eh);
 257   guestfs_set_private (g, key, root);
 258
 259   CAMLreturn (Val_int (eh));
 260 }
 261
 262 /* Guestfs.delete_event_callback */
 263 CAMLprim value
 264 ocaml_guestfs_delete_event_callback (value gv, value ehv)
 265 {
 266   CAMLparam2 (gv, ehv);
 267   char key[64];
 268   int eh = Int_val (ehv);
 269
 270   guestfs_h *g = Guestfs_val (gv);
 271
 272   snprintf (key, sizeof key, "_ocaml_event_%d", eh);
 273
 274   value *root = guestfs_get_private (g, key);
 275   if (root) {
 276     caml_remove_global_root (root);
 277     free (root);
 278     guestfs_set_private (g, key, NULL);
 279     guestfs_delete_event_callback (g, eh);
 280   }
 281
 282   CAMLreturn (Val_unit);
 283 }
 284
 285 static value **
 286 get_all_event_callbacks (guestfs_h *g, size_t *len_rtn)
 287 {
 288   value **r;
 289   size_t i;
 290   const char *key;
 291   value *root;
 292
 293   /* Count the length of the array that will be needed. */
 294   *len_rtn = 0;
 295   root = guestfs_first_private (g, &key);
 296   while (root != NULL) {
 297     if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0)
 298       (*len_rtn)++;
 299     root = guestfs_next_private (g, &key);
 300   }
 301
 302   /* Copy them into the return array. */
 303   r = guestfs_safe_malloc (g, sizeof (value *) * (*len_rtn));
 304
 305   i = 0;
 306   root = guestfs_first_private (g, &key);
 307   while (root != NULL) {
 308     if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0) {
 309       r[i] = root;
 310       i++;
 311     }
 312     root = guestfs_next_private (g, &key);
 313   }
 314
 315   return r;
 316 }
 317
 318 /* Could do better: http://graphics.stanford.edu/~seander/bithacks.html */
 319 static int
 320 event_bitmask_to_event (uint64_t event)
 321 {
 322   int r = 0;
 323
 324   while (event >>= 1)
 325     r++;
 326
 327   return r;
 328 }
 329
 330 static void
 331 event_callback_wrapper_locked (guestfs_h *g,
 332                                void *data,
 333                                uint64_t event,
 334                                int event_handle,
 335                                int flags,
 336                                const char *buf, size_t buf_len,
 337                                const uint64_t *array, size_t array_len)
 338 {
 339   CAMLparam0 ();
 340   CAMLlocal5 (gv, evv, ehv, bufv, arrayv);
 341   CAMLlocal2 (rv, v);
 342   value *root;
 343   size_t i;
 344
 345   root = guestfs_get_private (g, "_ocaml_g");
 346   gv = *root;
 347
 348   /* Only one bit should be set in 'event'.  Which one? */
 349   evv = Val_int (event_bitmask_to_event (event));
 350
 351   ehv = Val_int (event_handle);
 352
 353   bufv = caml_alloc_string (buf_len);
 354   memcpy (String_val (bufv), buf, buf_len);
 355
 356   arrayv = caml_alloc (array_len, 0);
 357   for (i = 0; i < array_len; ++i) {
 358     v = caml_copy_int64 (array[i]);
 359     Store_field (arrayv, i, v);
 360   }
 361
 362   value args[5] = { gv, evv, ehv, bufv, arrayv };
 363
 364   rv = caml_callbackN_exn (*(value*)data, 5, args);
 365
 366   /* Callbacks shouldn't throw exceptions.  There's not much we can do
 367    * except to print it.
 368    */
 369   if (Is_exception_result (rv))
 370     fprintf (stderr,
 371              "libguestfs: uncaught OCaml exception in event callback: %s",
 372              caml_format_exception (Extract_exception (rv)));
 373
 374   CAMLreturn0;
 375 }
 376
 377 static void
 378 event_callback_wrapper (guestfs_h *g,
 379                         void *data,
 380                         uint64_t event,
 381                         int event_handle,
 382                         int flags,
 383                         const char *buf, size_t buf_len,
 384                         const uint64_t *array, size_t array_len)
 385 {
 386   /* Ensure we are holding the GC lock before any GC operations are
 387    * possible. (RHBZ#725824)
 388    */
 389   caml_leave_blocking_section ();
 390
 391   event_callback_wrapper_locked (g, data, event, event_handle, flags,
 392                                  buf, buf_len, array, array_len);
 393
 394   caml_enter_blocking_section ();
 395 }
 396
 397 value
 398 ocaml_guestfs_last_errno (value gv)
 399 {
 400   CAMLparam1 (gv);
 401   CAMLlocal1 (rv);
 402   int r;
 403   guestfs_h *g;
 404
 405   g = Guestfs_val (gv);
 406   if (g == NULL)
 407     ocaml_guestfs_raise_closed ("last_errno");
 408
 409   r = guestfs_last_errno (g);
 410
 411   rv = Val_int (r);
 412   CAMLreturn (rv);
 413 }
 414
 415 /* NB: This is and must remain a "noalloc" function. */
 416 value
 417 ocaml_guestfs_user_cancel (value gv)
 418 {
 419   guestfs_h *g = Guestfs_val (gv);
 420   if (g)
 421     guestfs_user_cancel (g);
 422   return Val_unit;
 423 }