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