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