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_user_cancel (value gv);
  56
  57 /* Allocate handles and deal with finalization. */
  58 static void
  59 guestfs_finalize (value gv)
  60 {
  61   guestfs_h *g = Guestfs_val (gv);
  62
  63   if (g) {
  64     /* There is a nasty, difficult to solve case here where the
  65      * user deletes events in one of the callbacks that we are
  66      * about to invoke, resulting in a double-free.  XXX
  67      */
  68     size_t len, i;
  69     value **roots = get_all_event_callbacks (g, &len);
  70
  71     value *v = guestfs_get_private (g, "_ocaml_g");
  72
  73     /* Close the handle: this could invoke callbacks from the list
  74      * above, which is why we don't want to delete them before
  75      * closing the handle.
  76      */
  77     guestfs_close (g);
  78
  79     /* Now unregister the global roots. */
  80     for (i = 0; i < len; ++i) {
  81       caml_remove_global_root (roots[i]);
  82       free (roots[i]);
  83     }
  84
  85     caml_remove_global_root (v);
  86     free (v);
  87   }
  88 }
  89
  90 static struct custom_operations guestfs_custom_operations = {
  91   (char *) "guestfs_custom_operations",
  92   guestfs_finalize,
  93   custom_compare_default,
  94   custom_hash_default,
  95   custom_serialize_default,
  96   custom_deserialize_default
  97 };
  98
  99 static value
 100 Val_guestfs (guestfs_h *g)
 101 {
 102   CAMLparam0 ();
 103   CAMLlocal1 (rv);
 104
 105   rv = caml_alloc_custom (&guestfs_custom_operations,
 106                           sizeof (guestfs_h *), 0, 1);
 107   Guestfs_val (rv) = g;
 108
 109   CAMLreturn (rv);
 110 }
 111
 112 void
 113 ocaml_guestfs_raise_error (guestfs_h *g, const char *func)
 114 {
 115   CAMLparam0 ();
 116   CAMLlocal1 (v);
 117   const char *msg;
 118
 119   msg = guestfs_last_error (g);
 120
 121   if (msg)
 122     v = caml_copy_string (msg);
 123   else
 124     v = caml_copy_string (func);
 125   caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_error"), v);
 126   CAMLnoreturn;
 127 }
 128
 129 void
 130 ocaml_guestfs_raise_closed (const char *func)
 131 {
 132   CAMLparam0 ();
 133   CAMLlocal1 (v);
 134
 135   v = caml_copy_string (func);
 136   caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_closed"), v);
 137   CAMLnoreturn;
 138 }
 139
 140 /* Guestfs.create */
 141 CAMLprim value
 142 ocaml_guestfs_create (void)
 143 {
 144   CAMLparam0 ();
 145   CAMLlocal1 (gv);
 146   guestfs_h *g;
 147   value *v;
 148
 149   g = guestfs_create ();
 150   if (g == NULL)
 151     caml_failwith ("failed to create guestfs handle");
 152
 153   guestfs_set_error_handler (g, NULL, NULL);
 154
 155   gv = Val_guestfs (g);
 156
 157   /* Store the OCaml handle into the C handle.  This is only so we can
 158    * map the C handle to the OCaml handle in event_callback_wrapper.
 159    */
 160   v = guestfs_safe_malloc (g, sizeof *v);
 161   *v = gv;
 162   /* XXX This global root is generational, but we cannot rely on every
 163    * user having the OCaml 3.11 version which supports this.
 164    */
 165   caml_register_global_root (v);
 166   guestfs_set_private (g, "_ocaml_g", v);
 167
 168   CAMLreturn (gv);
 169 }
 170
 171 /* Guestfs.close */
 172 CAMLprim value
 173 ocaml_guestfs_close (value gv)
 174 {
 175   CAMLparam1 (gv);
 176
 177   guestfs_finalize (gv);
 178
 179   /* So we don't double-free in the finalizer. */
 180   Guestfs_val (gv) = NULL;
 181
 182   CAMLreturn (Val_unit);
 183 }
 184
 185 /* Copy string array value. */
 186 char **
 187 ocaml_guestfs_strings_val (guestfs_h *g, value sv)
 188 {
 189   CAMLparam1 (sv);
 190   char **r;
 191   unsigned int i;
 192
 193   r = guestfs_safe_malloc (g, sizeof (char *) * (Wosize_val (sv) + 1));
 194   for (i = 0; i < Wosize_val (sv); ++i)
 195     r[i] = guestfs_safe_strdup (g, String_val (Field (sv, i)));
 196   r[i] = NULL;
 197
 198   CAMLreturnT (char **, r);
 199 }
 200
 201 /* Free array of strings. */
 202 void
 203 ocaml_guestfs_free_strings (char **argv)
 204 {
 205   unsigned int i;
 206
 207   for (i = 0; argv[i] != NULL; ++i)
 208     free (argv[i]);
 209   free (argv);
 210 }
 211
 212 static uint64_t
 213 event_bitmask_of_event_list (value events)
 214 {
 215   uint64_t r = 0;
 216
 217   while (events != Val_int (0)) {
 218     r |= UINT64_C(1) << Int_val (Field (events, 0));
 219     events = Field (events, 1);
 220   }
 221
 222   return r;
 223 }
 224
 225 /* Guestfs.set_event_callback */
 226 CAMLprim value
 227 ocaml_guestfs_set_event_callback (value gv, value closure, value events)
 228 {
 229   CAMLparam3 (gv, closure, events);
 230   char key[64];
 231   int eh;
 232   uint64_t event_bitmask;
 233
 234   guestfs_h *g = Guestfs_val (gv);
 235
 236   event_bitmask = event_bitmask_of_event_list (events);
 237
 238   value *root = guestfs_safe_malloc (g, sizeof *root);
 239   *root = closure;
 240
 241   eh = guestfs_set_event_callback (g, event_callback_wrapper,
 242                                    event_bitmask, 0, root);
 243
 244   if (eh == -1) {
 245     free (root);
 246     ocaml_guestfs_raise_error (g, "set_event_callback");
 247   }
 248
 249   /* XXX This global root is generational, but we cannot rely on every
 250    * user having the OCaml 3.11 version which supports this.
 251    */
 252   caml_register_global_root (root);
 253
 254   snprintf (key, sizeof key, "_ocaml_event_%d", eh);
 255   guestfs_set_private (g, key, root);
 256
 257   CAMLreturn (Val_int (eh));
 258 }
 259
 260 /* Guestfs.delete_event_callback */
 261 CAMLprim value
 262 ocaml_guestfs_delete_event_callback (value gv, value ehv)
 263 {
 264   CAMLparam2 (gv, ehv);
 265   char key[64];
 266   int eh = Int_val (ehv);
 267
 268   guestfs_h *g = Guestfs_val (gv);
 269
 270   snprintf (key, sizeof key, "_ocaml_event_%d", eh);
 271
 272   value *root = guestfs_get_private (g, key);
 273   if (root) {
 274     caml_remove_global_root (root);
 275     free (root);
 276     guestfs_set_private (g, key, NULL);
 277     guestfs_delete_event_callback (g, eh);
 278   }
 279
 280   CAMLreturn (Val_unit);
 281 }
 282
 283 static value **
 284 get_all_event_callbacks (guestfs_h *g, size_t *len_rtn)
 285 {
 286   value **r;
 287   size_t i;
 288   const char *key;
 289   value *root;
 290
 291   /* Count the length of the array that will be needed. */
 292   *len_rtn = 0;
 293   root = guestfs_first_private (g, &key);
 294   while (root != NULL) {
 295     if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0)
 296       (*len_rtn)++;
 297     root = guestfs_next_private (g, &key);
 298   }
 299
 300   /* Copy them into the return array. */
 301   r = guestfs_safe_malloc (g, sizeof (value *) * (*len_rtn));
 302
 303   i = 0;
 304   root = guestfs_first_private (g, &key);
 305   while (root != NULL) {
 306     if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0) {
 307       r[i] = root;
 308       i++;
 309     }
 310     root = guestfs_next_private (g, &key);
 311   }
 312
 313   return r;
 314 }
 315
 316 /* Could do better: http://graphics.stanford.edu/~seander/bithacks.html */
 317 static int
 318 event_bitmask_to_event (uint64_t event)
 319 {
 320   int r = 0;
 321
 322   while (event >>= 1)
 323     r++;
 324
 325   return r;
 326 }
 327
 328 static void
 329 event_callback_wrapper (guestfs_h *g,
 330                         void *data,
 331                         uint64_t event,
 332                         int event_handle,
 333                         int flags,
 334                         const char *buf, size_t buf_len,
 335                         const uint64_t *array, size_t array_len)
 336 {
 337   CAMLparam0 ();
 338   CAMLlocal5 (gv, evv, ehv, bufv, arrayv);
 339   CAMLlocal2 (rv, v);
 340   value *root;
 341   size_t i;
 342
 343   root = guestfs_get_private (g, "_ocaml_g");
 344   gv = *root;
 345
 346   /* Only one bit should be set in 'event'.  Which one? */
 347   evv = Val_int (event_bitmask_to_event (event));
 348
 349   ehv = Val_int (event_handle);
 350
 351   bufv = caml_alloc_string (buf_len);
 352   memcpy (String_val (bufv), buf, buf_len);
 353
 354   arrayv = caml_alloc (array_len, 0);
 355   for (i = 0; i < array_len; ++i) {
 356     v = caml_copy_int64 (array[i]);
 357     Store_field (arrayv, i, v);
 358   }
 359
 360   value args[5] = { gv, evv, ehv, bufv, arrayv };
 361
 362   caml_leave_blocking_section ();
 363   rv = caml_callbackN_exn (*(value*)data, 5, args);
 364   caml_enter_blocking_section ();
 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 /* NB: This is and must remain a "noalloc" function. */
 378 value
 379 ocaml_guestfs_user_cancel (value gv)
 380 {
 381   guestfs_h *g = Guestfs_val (gv);
 382   if (g)
 383     guestfs_user_cancel (g);
 384   return Val_unit;
 385 }