src/generator.ml

   1 #!/usr/bin/ocamlrun ocaml
   2 (* libguestfs
   3  * Copyright (C) 2009 Red Hat Inc.
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU General Public License as published by
   7  * the Free Software Foundation; either version 2 of the License, or
   8  * (at your option) any later version.
   9  *
  10  * This program 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
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this program; if not, write to the Free Software
  17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18  *
  19  * This script generates a large amount of code and documentation for
  20  * all the daemon actions.  To add a new action there are only two
  21  * files you need to change, this one to describe the interface, and
  22  * daemon/<somefile>.c to write the implementation.
  23  *)
  24
  25 #load "unix.cma";;
  26
  27 open Printf
  28
  29 type style = ret * args
  30 and ret =
  31     (* "Err" as a return value means an int used as a simple error
  32      * indication, ie. 0 or -1.
  33      *)
  34   | Err
  35 and args =
  36     (* 0 arguments, 1 argument, etc. The guestfs_h param is implicit. *)
  37   | P0
  38   | P1 of argt
  39   | P2 of argt * argt
  40 and argt =
  41   | String of string    (* const char *name, cannot be NULL *)
  42
  43 let functions = [
  44   ("mount", (Err, P2 (String "device", String "mountpoint")), 1,
  45    "Mount a guest disk at a position in the filesystem",
  46    "\
  47 Mount a guest disk at a position in the filesystem.  Block devices
  48 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
  49 the guest.  If those block devices contain partitions, they will have
  50 the usual names (eg. C</dev/sda1>).  Also LVM C</dev/VG/LV>-style
  51 names can be used.
  52
  53 The rules are the same as for L<mount(2)>:  A filesystem must
  54 first be mounted on C</> before others can be mounted.  Other
  55 filesystems can only be mounted on directories which already
  56 exist.
  57
  58 The mounted filesystem is writable, if we have sufficient permissions
  59 on the underlying device.
  60
  61 The filesystem options C<sync> and C<noatime> are set with this
  62 call, in order to improve reliability.");
  63
  64   ("sync", (Err, P0), 2,
  65    "Sync disks, writes are flushed through to the disk image",
  66    "\
  67 This syncs the disk, so that any writes are flushed through to the
  68 underlying disk image.
  69
  70 You should always call this if you have modified a disk image, before
  71 calling C<guestfs_close>.");
  72
  73   ("touch", (Err, P1 (String "path")), 3,
  74    "Update file timestamps or create a new file",
  75    "\
  76 Touch acts like the L<touch(1)> command.  It can be used to
  77 update the filesystems on a file, or, if the file does not exist,
  78 to create a new zero-length file.");
  79 ]
  80
  81 (* 'pr' prints to the current output file. *)
  82 let chan = ref stdout
  83 let pr fs = ksprintf (output_string !chan) fs
  84
  85 let iter_args f = function
  86   | P0 -> ()
  87   | P1 arg1 -> f arg1
  88   | P2 (arg1, arg2) -> f arg1; f arg2
  89
  90 type comment_style = CStyle | HashStyle | OCamlStyle
  91 type license = GPLv2 | LGPLv2
  92
  93 (* Generate a header block in a number of standard styles. *)
  94 let rec generate_header comment license =
  95   let c = match comment with
  96     | CStyle ->     pr "/* "; " *"
  97     | HashStyle ->  pr "# ";  "#"
  98     | OCamlStyle -> pr "(* "; " *" in
  99   pr "libguestfs generated file\n";
 100   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
 101   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
 102   pr "%s\n" c;
 103   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
 104   pr "%s\n" c;
 105   (match license with
 106    | GPLv2 ->
 107        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
 108        pr "%s it under the terms of the GNU General Public License as published by\n" c;
 109        pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
 110        pr "%s (at your option) any later version.\n" c;
 111        pr "%s\n" c;
 112        pr "%s This program is distributed in the hope that it will be useful,\n" c;
 113        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
 114        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
 115        pr "%s GNU General Public License for more details.\n" c;
 116        pr "%s\n" c;
 117        pr "%s You should have received a copy of the GNU General Public License along\n" c;
 118        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
 119        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
 120
 121    | LGPLv2 ->
 122        pr "%s This library is free software; you can redistribute it and/or\n" c;
 123        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
 124        pr "%s License as published by the Free Software Foundation; either\n" c;
 125        pr "%s version 2 of the License, or (at your option) any later version.\n" c;
 126        pr "%s\n" c;
 127        pr "%s This library is distributed in the hope that it will be useful,\n" c;
 128        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
 129        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
 130        pr "%s Lesser General Public License for more details.\n" c;
 131        pr "%s\n" c;
 132        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
 133        pr "%s License along with this library; if not, write to the Free Software\n" c;
 134        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
 135   );
 136   (match comment with
 137    | CStyle -> pr " */\n"
 138    | HashStyle -> ()
 139    | OCamlStyle -> pr " *)\n"
 140   );
 141   pr "\n"
 142
 143 (* Generate the pod documentation for the C API. *)
 144 and generate_pod () =
 145   List.iter (
 146     fun (shortname, style, _, _, longdesc) ->
 147       let name = "guestfs_" ^ shortname in
 148       pr "=head2 %s\n\n" name;
 149       pr " ";
 150       generate_prototype ~extern:false ~handle:"handle" name style;
 151       pr "\n\n";
 152       pr "%s\n\n" longdesc;
 153       (match style with
 154        | (Err, _) ->
 155            pr "This function return 0 on success or -1 on error.\n\n"
 156       );
 157   ) functions
 158
 159 (* Generate the protocol (XDR) file. *)
 160 and generate_xdr () =
 161   generate_header CStyle LGPLv2;
 162
 163   List.iter (
 164     fun (shortname, style, _, _, _) ->
 165       let name = "guestfs_" ^ shortname in
 166       pr "/* %s */\n\n" name;
 167       (match style with
 168        | (_, P0) -> ()
 169        | (_, args) ->
 170            pr "struct %s_args {\n" name;
 171            iter_args (
 172              function
 173              | String name -> pr "  string %s<>;\n" name
 174            ) args;
 175            pr "};\n\n"
 176       );
 177       (match style with
 178        | (Err, _) -> ()
 179            (* | ... -> pr "struct %s_ret ...\n" name; *)
 180       );
 181   ) functions;
 182
 183   (* Table of procedure numbers. *)
 184   pr "enum guestfs_procedure {\n";
 185   List.iter (
 186     fun (shortname, _, proc_nr, _, _) ->
 187       pr "  GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
 188   ) functions;
 189   pr "  GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
 190   pr "};\n";
 191   pr "\n";
 192
 193   (* Having to choose a maximum message size is annoying for several
 194    * reasons (it limits what we can do in the API), but it (a) makes
 195    * the protocol a lot simpler, and (b) provides a bound on the size
 196    * of the daemon which operates in limited memory space.  For large
 197    * file transfers you should use FTP.
 198    *)
 199   pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
 200   pr "\n";
 201
 202   (* Message header, etc. *)
 203   pr "\
 204 const GUESTFS_PROGRAM = 0x2000F5F5;
 205 const GUESTFS_PROTOCOL_VERSION = 1;
 206
 207 enum guestfs_message_direction {
 208   GUESTFS_DIRECTION_CALL = 0,        /* client -> daemon */
 209   GUESTFS_DIRECTION_REPLY = 1        /* daemon -> client */
 210 };
 211
 212 enum guestfs_message_status {
 213   GUESTFS_STATUS_OK = 0,
 214   GUESTFS_STATUS_ERROR = 1
 215 };
 216
 217 const GUESTFS_ERROR_LEN = 256;
 218
 219 struct guestfs_message_error {
 220   string error<GUESTFS_ERROR_LEN>;   /* error message */
 221 };
 222
 223 struct guestfs_message_header {
 224   unsigned prog;                     /* GUESTFS_PROGRAM */
 225   unsigned vers;                     /* GUESTFS_PROTOCOL_VERSION */
 226   guestfs_procedure proc;            /* GUESTFS_PROC_x */
 227   guestfs_message_direction direction;
 228   unsigned serial;                   /* message serial number */
 229   guestfs_message_status status;
 230 };
 231 "
 232
 233 (* Generate the guestfs-actions.h file. *)
 234 and generate_actions_h () =
 235   generate_header CStyle LGPLv2;
 236   List.iter (
 237     fun (shortname, style, _, _, _) ->
 238       let name = "guestfs_" ^ shortname in
 239       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
 240         name style
 241   ) functions
 242
 243 (* Generate the client-side dispatch stubs. *)
 244 and generate_client_actions () =
 245   generate_header CStyle LGPLv2;
 246   List.iter (
 247     fun (shortname, style, _, _, _) ->
 248       let name = "guestfs_" ^ shortname in
 249
 250       (* Generate the return value struct. *)
 251       pr "struct %s_rv {\n" shortname;
 252       pr "  int cb_done;  /* flag to indicate callback was called */\n";
 253       pr "  struct guestfs_message_header hdr;\n";
 254       pr "  struct guestfs_message_error err;\n";
 255       (match style with
 256        | (Err, _) -> ()
 257     (* | _ -> pr "  struct %s_ret ret;\n" name; *)
 258       );
 259       pr "};\n\n";
 260
 261       (* Generate the callback function. *)
 262       pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
 263       pr "{\n";
 264       pr "  struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
 265       pr "\n";
 266       pr "  if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
 267       pr "    error (g, \"%s: failed to parse reply header\");\n" name;
 268       pr "    return;\n";
 269       pr "  }\n";
 270       pr "  if (rv->hdr.status == GUESTFS_STATUS_ERROR) {\n";
 271       pr "    if (!xdr_guestfs_message_error (xdr, &rv->err)) {\n";
 272       pr "      error (g, \"%s: failed to parse reply error\");\n" name;
 273       pr "      return;\n";
 274       pr "    }\n";
 275       pr "    goto done;\n";
 276       pr "  }\n";
 277
 278       (match style with
 279        | (Err, _) -> ()
 280     (* |  _ -> pr "  if (!xdr_%s_ret (&xdr, &rv->ret)) ..." *)
 281       );
 282
 283       pr " done:\n";
 284       pr "  rv->cb_done = 1;\n";
 285       pr "  main_loop.main_loop_quit (g);\n";
 286       pr "}\n\n";
 287
 288       (* Generate the action stub. *)
 289       generate_prototype ~extern:false ~semicolon:false ~newline:true
 290         ~handle:"g" name style;
 291
 292       let error_code =
 293         match style with
 294         | (Err, _) -> "-1" in
 295
 296       pr "{\n";
 297
 298       (match style with
 299        | (_, P0) -> ()
 300        | _ -> pr "  struct %s_args args;\n" name
 301       );
 302
 303       pr "  struct %s_rv rv;\n" shortname;
 304       pr "  int serial;\n";
 305       pr "\n";
 306       pr "  if (g->state != READY) {\n";
 307       pr "    error (g, \"%s called from the wrong state, %%d != READY\",\n"
 308         name;
 309       pr "      g->state);\n";
 310       pr "    return %s;\n" error_code;
 311       pr "  }\n";
 312       pr "\n";
 313       pr "  memset (&rv, 0, sizeof rv);\n";
 314       pr "\n";
 315
 316       (match style with
 317        | (_, P0) ->
 318            pr "  serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
 319              (String.uppercase shortname)
 320        | (_, args) ->
 321            pr "\n";
 322            iter_args (
 323              function
 324              | String name -> pr "  args.%s = (char *) %s;\n" name name
 325            ) args;
 326            pr "  serial = dispatch (g, GUESTFS_PROC_%s,\n"
 327              (String.uppercase shortname);
 328            pr "                     (xdrproc_t) xdr_%s_args, (char *) &args);\n"
 329              name;
 330       );
 331       pr "  if (serial == -1)\n";
 332       pr "    return %s;\n" error_code;
 333       pr "\n";
 334
 335       pr "  rv.cb_done = 0;\n";
 336       pr "  g->reply_cb_internal = %s_cb;\n" shortname;
 337       pr "  g->reply_cb_internal_data = &rv;\n";
 338       pr "  main_loop.main_loop_run (g);\n";
 339       pr "  g->reply_cb_internal = NULL;\n";
 340       pr "  g->reply_cb_internal_data = NULL;\n";
 341       pr "  if (!rv.cb_done) {\n";
 342       pr "    error (g, \"%s failed, see earlier error messages\");\n" name;
 343       pr "    return %s;\n" error_code;
 344       pr "  }\n";
 345       pr "\n";
 346
 347       pr "  if (check_reply_header (g, &rv.hdr, GUESTFS_PROC_%s, serial) == -1)\n"
 348         (String.uppercase shortname);
 349       pr "    return %s;\n" error_code;
 350       pr "\n";
 351
 352       pr "  if (rv.hdr.status == GUESTFS_STATUS_ERROR) {\n";
 353       pr "    error (g, \"%%s\", rv.err.error);\n";
 354       pr "    return %s;\n" error_code;
 355       pr "  }\n";
 356       pr "\n";
 357
 358       (match style with
 359        | (Err, _) -> pr "  return 0;\n"
 360       );
 361
 362       pr "}\n\n"
 363   ) functions
 364
 365 (* Generate daemon/actions.h. *)
 366 and generate_daemon_actions_h () =
 367   generate_header CStyle GPLv2;
 368   List.iter (
 369     fun (name, style, _, _, _) ->
 370       generate_prototype ~single_line:true ~newline:true ("do_" ^ name) style;
 371   ) functions
 372
 373 (* Generate the server-side stubs. *)
 374 and generate_daemon_actions () =
 375   generate_header CStyle GPLv2;
 376
 377   pr "#include <rpc/types.h>\n";
 378   pr "#include <rpc/xdr.h>\n";
 379   pr "#include \"daemon.h\"\n";
 380   pr "#include \"../src/guestfs_protocol.h\"\n";
 381   pr "#include \"actions.h\"\n";
 382   pr "\n";
 383
 384   List.iter (
 385     fun (name, style, _, _, _) ->
 386       (* Generate server-side stubs. *)
 387       pr "static void %s_stub (XDR *xdr_in)\n" name;
 388       pr "{\n";
 389       let error_code =
 390         match style with
 391         | (Err, _) -> pr "  int r;\n"; "-1" in
 392       (match style with
 393        | (_, P0) -> ()
 394        | (_, args) ->
 395            pr "  struct guestfs_%s_args args;\n" name;
 396            iter_args (
 397              function
 398              | String name -> pr "  const char *%s;\n" name
 399            ) args
 400       );
 401       pr "\n";
 402
 403       (match style with
 404        | (_, P0) -> ()
 405        | (_, args) ->
 406            pr "  memset (&args, 0, sizeof args);\n";
 407            pr "\n";
 408            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
 409            pr "    reply_with_error (\"%s: daemon failed to decode procedure arguments\");\n" name;
 410            pr "    return;\n";
 411            pr "  }\n";
 412            iter_args (
 413              function
 414              | String name -> pr "  %s = args.%s;\n" name name
 415            ) args;
 416            pr "\n"
 417       );
 418
 419       pr "  r = do_%s " name;
 420       generate_call_args style;
 421       pr ";\n";
 422
 423       pr "  if (r == %s)\n" error_code;
 424       pr "    /* do_%s has already called reply_with_error, so just return */\n" name;
 425       pr "    return;\n";
 426       pr "\n";
 427
 428       (match style with
 429        | (Err, _) -> pr "  reply (NULL, NULL);\n"
 430       );
 431
 432       pr "}\n\n";
 433   ) functions;
 434
 435   (* Dispatch function. *)
 436   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
 437   pr "{\n";
 438   pr "  switch (proc_nr) {\n";
 439
 440   List.iter (
 441     fun (name, style, _, _, _) ->
 442       pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
 443       pr "      %s_stub (xdr_in);\n" name;
 444       pr "      break;\n"
 445   ) functions;
 446
 447   pr "    default:\n";
 448   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
 449   pr "  }\n";
 450   pr "}\n";
 451
 452 (* Generate a C function prototype. *)
 453 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
 454     ?(single_line = false) ?(newline = false)
 455     ?handle name style =
 456   if extern then pr "extern ";
 457   if static then pr "static ";
 458   (match style with
 459    | (Err, _) -> pr "int "
 460   );
 461   pr "%s (" name;
 462   let comma = ref false in
 463   (match handle with
 464    | None -> ()
 465    | Some handle -> pr "guestfs_h *%s" handle; comma := true
 466   );
 467   let next () =
 468     if !comma then (
 469       if single_line then pr ", " else pr ",\n\t\t"
 470     );
 471     comma := true
 472   in
 473   iter_args (
 474     function
 475     | String name -> next (); pr "const char *%s" name
 476   ) (snd style);
 477   pr ")";
 478   if semicolon then pr ";";
 479   if newline then pr "\n"
 480
 481 (* Generate C call arguments, eg "(handle, foo, bar)" *)
 482 and generate_call_args ?handle style =
 483   pr "(";
 484   let comma = ref false in
 485   (match handle with
 486    | None -> ()
 487    | Some handle -> pr "%s" handle; comma := true
 488   );
 489   iter_args (
 490     fun arg ->
 491       if !comma then pr ", ";
 492       comma := true;
 493       match arg with
 494       | String name -> pr "%s" name
 495   ) (snd style);
 496   pr ")"
 497
 498 let output_to filename =
 499   let filename_new = filename ^ ".new" in
 500   chan := open_out filename_new;
 501   let close () =
 502     close_out !chan;
 503     chan := stdout;
 504     Unix.rename filename_new filename;
 505     printf "written %s\n%!" filename;
 506   in
 507   close
 508
 509 (* Main program. *)
 510 let () =
 511   let close = output_to "src/guestfs_protocol.x" in
 512   generate_xdr ();
 513   close ();
 514
 515   let close = output_to "src/guestfs-actions.h" in
 516   generate_actions_h ();
 517   close ();
 518
 519   let close = output_to "src/guestfs-actions.c" in
 520   generate_client_actions ();
 521   close ();
 522
 523   let close = output_to "daemon/actions.h" in
 524   generate_daemon_actions_h ();
 525   close ();
 526
 527   let close = output_to "daemon/stubs.c" in
 528   generate_daemon_actions ();
 529   close ();
 530
 531   let close = output_to "guestfs-actions.pod" in
 532   generate_pod ();
 533   close ()