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            iter_args (
 322              function
 323              | String name -> pr "  args.%s = (char *) %s;\n" name name
 324            ) args;
 325            pr "  serial = dispatch (g, GUESTFS_PROC_%s,\n"
 326              (String.uppercase shortname);
 327            pr "                     (xdrproc_t) xdr_%s_args, (char *) &args);\n"
 328              name;
 329       );
 330       pr "  if (serial == -1)\n";
 331       pr "    return %s;\n" error_code;
 332       pr "\n";
 333
 334       pr "  rv.cb_done = 0;\n";
 335       pr "  g->reply_cb_internal = %s_cb;\n" shortname;
 336       pr "  g->reply_cb_internal_data = &rv;\n";
 337       pr "  main_loop.main_loop_run (g);\n";
 338       pr "  g->reply_cb_internal = NULL;\n";
 339       pr "  g->reply_cb_internal_data = NULL;\n";
 340       pr "  if (!rv.cb_done) {\n";
 341       pr "    error (g, \"%s failed, see earlier error messages\");\n" name;
 342       pr "    return %s;\n" error_code;
 343       pr "  }\n";
 344       pr "\n";
 345
 346       pr "  if (check_reply_header (g, &rv.hdr, GUESTFS_PROC_%s, serial) == -1)\n"
 347         (String.uppercase shortname);
 348       pr "    return %s;\n" error_code;
 349       pr "\n";
 350
 351       pr "  if (rv.hdr.status == GUESTFS_STATUS_ERROR) {\n";
 352       pr "    error (g, \"%%s\", rv.err.error);\n";
 353       pr "    return %s;\n" error_code;
 354       pr "  }\n";
 355       pr "\n";
 356
 357       (match style with
 358        | (Err, _) -> pr "  return 0;\n"
 359       );
 360
 361       pr "}\n\n"
 362   ) functions
 363
 364 (* Generate daemon/actions.h. *)
 365 and generate_daemon_actions_h () =
 366   generate_header CStyle GPLv2;
 367   List.iter (
 368     fun (name, style, _, _, _) ->
 369       generate_prototype ~single_line:true ~newline:true ("do_" ^ name) style;
 370   ) functions
 371
 372 (* Generate the server-side stubs. *)
 373 and generate_daemon_actions () =
 374   generate_header CStyle GPLv2;
 375
 376   pr "#include <rpc/types.h>\n";
 377   pr "#include <rpc/xdr.h>\n";
 378   pr "#include \"daemon.h\"\n";
 379   pr "#include \"../src/guestfs_protocol.h\"\n";
 380   pr "#include \"actions.h\"\n";
 381   pr "\n";
 382
 383   List.iter (
 384     fun (name, style, _, _, _) ->
 385       (* Generate server-side stubs. *)
 386       pr "static void %s_stub (XDR *xdr_in)\n" name;
 387       pr "{\n";
 388       let error_code =
 389         match style with
 390         | (Err, _) -> pr "  int r;\n"; "-1" in
 391       (match style with
 392        | (_, P0) -> ()
 393        | (_, args) ->
 394            pr "  struct guestfs_%s_args args;\n" name;
 395            iter_args (
 396              function
 397              | String name -> pr "  const char *%s;\n" name
 398            ) args
 399       );
 400       pr "\n";
 401
 402       (match style with
 403        | (_, P0) -> ()
 404        | (_, args) ->
 405            pr "  memset (&args, 0, sizeof args);\n";
 406            pr "\n";
 407            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
 408            pr "    reply_with_error (\"%s: daemon failed to decode procedure arguments\");\n" name;
 409            pr "    return;\n";
 410            pr "  }\n";
 411            iter_args (
 412              function
 413              | String name -> pr "  %s = args.%s;\n" name name
 414            ) args;
 415            pr "\n"
 416       );
 417
 418       pr "  r = do_%s " name;
 419       generate_call_args style;
 420       pr ";\n";
 421
 422       pr "  if (r == %s)\n" error_code;
 423       pr "    /* do_%s has already called reply_with_error, so just return */\n" name;
 424       pr "    return;\n";
 425       pr "\n";
 426
 427       (match style with
 428        | (Err, _) -> pr "  reply (NULL, NULL);\n"
 429       );
 430
 431       pr "}\n\n";
 432   ) functions;
 433
 434   (* Dispatch function. *)
 435   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
 436   pr "{\n";
 437   pr "  switch (proc_nr) {\n";
 438
 439   List.iter (
 440     fun (name, style, _, _, _) ->
 441       pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
 442       pr "      %s_stub (xdr_in);\n" name;
 443       pr "      break;\n"
 444   ) functions;
 445
 446   pr "    default:\n";
 447   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
 448   pr "  }\n";
 449   pr "}\n";
 450
 451 (* Generate a C function prototype. *)
 452 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
 453     ?(single_line = false) ?(newline = false)
 454     ?handle name style =
 455   if extern then pr "extern ";
 456   if static then pr "static ";
 457   (match style with
 458    | (Err, _) -> pr "int "
 459   );
 460   pr "%s (" name;
 461   let comma = ref false in
 462   (match handle with
 463    | None -> ()
 464    | Some handle -> pr "guestfs_h *%s" handle; comma := true
 465   );
 466   let next () =
 467     if !comma then (
 468       if single_line then pr ", " else pr ",\n\t\t"
 469     );
 470     comma := true
 471   in
 472   iter_args (
 473     function
 474     | String name -> next (); pr "const char *%s" name
 475   ) (snd style);
 476   pr ")";
 477   if semicolon then pr ";";
 478   if newline then pr "\n"
 479
 480 (* Generate C call arguments, eg "(handle, foo, bar)" *)
 481 and generate_call_args ?handle style =
 482   pr "(";
 483   let comma = ref false in
 484   (match handle with
 485    | None -> ()
 486    | Some handle -> pr "%s" handle; comma := true
 487   );
 488   iter_args (
 489     fun arg ->
 490       if !comma then pr ", ";
 491       comma := true;
 492       match arg with
 493       | String name -> pr "%s" name
 494   ) (snd style);
 495   pr ")"
 496
 497 let output_to filename =
 498   let filename_new = filename ^ ".new" in
 499   chan := open_out filename_new;
 500   let close () =
 501     close_out !chan;
 502     chan := stdout;
 503     Unix.rename filename_new filename;
 504     printf "written %s\n%!" filename;
 505   in
 506   close
 507
 508 (* Main program. *)
 509 let () =
 510   let close = output_to "src/guestfs_protocol.x" in
 511   generate_xdr ();
 512   close ();
 513
 514   let close = output_to "src/guestfs-actions.h" in
 515   generate_actions_h ();
 516   close ();
 517
 518   let close = output_to "src/guestfs-actions.c" in
 519   generate_client_actions ();
 520   close ();
 521
 522   let close = output_to "daemon/actions.h" in
 523   generate_daemon_actions_h ();
 524   close ();
 525
 526   let close = output_to "daemon/stubs.c" in
 527   generate_daemon_actions ();
 528   close ();
 529
 530   let close = output_to "guestfs-actions.pod" in
 531   generate_pod ();
 532   close ()