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