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 struct guestfs_message_header {
 212   unsigned prog;                     /* GUESTFS_PROGRAM */
 213   unsigned vers;                     /* GUESTFS_PROTOCOL_VERSION */
 214   guestfs_procedure proc;            /* GUESTFS_PROC_x */
 215   guestfs_message_direction direction;
 216   unsigned serial;                   /* message serial number */
 217   guestfs_message_status status;
 218 };
 219 "
 220
 221 (* Generate the guestfs-actions.h file. *)
 222 and generate_actions_h () =
 223   generate_header CStyle LGPLv2;
 224   List.iter (
 225     fun (shortname, style, _, _, _) ->
 226       let name = "guestfs_" ^ shortname in
 227       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
 228         name style
 229   ) functions
 230
 231 (* Generate the client-side dispatch stubs. *)
 232 and generate_client_actions () =
 233   generate_header CStyle LGPLv2;
 234   List.iter (
 235     fun (shortname, style, _, _, _) ->
 236       let name = "guestfs_" ^ shortname in
 237
 238       (* Generate the return value struct. *)
 239       pr "struct %s_rv {\n" shortname;
 240       pr "  int err_code;      /* 0 OK or -1 error */\n";
 241       pr "  int serial;        /* serial number of reply */\n";
 242       pr "  char err_str[256]; /* error from daemon */\n";
 243       (match style with
 244        | (Err, _) -> ()
 245     (* | _ -> pr "  struct %s_ret ret;\n" name; *)
 246       );
 247       pr "};\n\n";
 248
 249       (* Generate the callback function. *)
 250       pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
 251       pr "{\n";
 252       pr "  struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
 253       pr "\n";
 254       pr "  /* XXX */ rv->err_code = 0;\n";
 255       pr "  /* XXX rv->serial = ?; */\n";
 256       pr "  main_loop.main_loop_quit (g);\n";
 257       pr "}\n\n";
 258
 259       (* Generate the action stub. *)
 260       generate_prototype ~extern:false ~semicolon:false ~newline:true
 261         ~handle:"g" name style;
 262
 263       let error_code =
 264         match style with
 265         | (Err, _) -> "-1" in
 266
 267       pr "{\n";
 268
 269       (match style with
 270        | (_, P0) -> ()
 271        | _ -> pr "  struct %s_args args;\n" name
 272       );
 273
 274       pr "  struct %s_rv rv;\n" shortname;
 275       pr "  int serial;\n";
 276       pr "\n";
 277       pr "  if (g->state != READY) {\n";
 278       pr "    error (g, \"%s called from the wrong state, %%d != READY\",\n"
 279         name;
 280       pr "      g->state);\n";
 281       pr "    return %s;\n" error_code;
 282       pr "  }\n";
 283
 284       (match style with
 285        | (_, P0) ->
 286            pr "  serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
 287              (String.uppercase shortname)
 288        | (_, args) ->
 289            pr "\n";
 290            iter_args (
 291              function
 292              | String name -> pr "  args.%s = (char *) %s;\n" name name
 293            ) args;
 294            pr "  serial = dispatch (g, GUESTFS_PROC_%s,\n"
 295              (String.uppercase shortname);
 296            pr "                     (xdrproc_t) xdr_%s_args, (char *) &args);\n"
 297              name;
 298       );
 299       pr "  if (serial == -1)\n";
 300       pr "    return %s;\n" error_code;
 301       pr "\n";
 302
 303       pr "  rv.err_code = 42;\n";
 304       pr "  g->reply_cb_internal = %s_cb;\n" shortname;
 305       pr "  g->reply_cb_internal_data = &rv;\n";
 306       pr "  main_loop.main_loop_run (g);\n";
 307       pr "  g->reply_cb_internal = NULL;\n";
 308       pr "  g->reply_cb_internal_data = NULL;\n";
 309       pr "  if (rv.err_code == 42) { /* callback wasn't called */\n";
 310       pr "    error (g, \"%s failed, see earlier error messages\");\n" name;
 311       pr "    return %s;\n" error_code;
 312       pr "  }\n";
 313       pr "  else if (rv.err_code == -1) { /* error from remote end */\n";
 314       pr "    error (g, \"%%s\", rv.err_str);\n";
 315       pr "    return %s;\n" error_code;
 316       pr "  }\n";
 317       pr "\n";
 318
 319       pr "  /* XXX check serial number agrees */\n\n";
 320
 321       (match style with
 322        | (Err, _) -> pr "  return 0;\n"
 323       );
 324
 325       pr "}\n\n"
 326   ) functions
 327
 328 (* Generate daemon/actions.h. *)
 329 and generate_daemon_actions_h () =
 330   generate_header CStyle GPLv2;
 331   List.iter (
 332     fun (name, style, _, _, _) ->
 333       generate_prototype ~single_line:true ~newline:true ("do_" ^ name) style;
 334   ) functions
 335
 336 (* Generate the server-side stubs. *)
 337 and generate_daemon_actions () =
 338   generate_header CStyle GPLv2;
 339
 340   pr "#include <rpc/types.h>\n";
 341   pr "#include <rpc/xdr.h>\n";
 342   pr "#include \"daemon.h\"\n";
 343   pr "#include \"../src/guestfs_protocol.h\"\n";
 344   pr "#include \"actions.h\"\n";
 345   pr "\n";
 346
 347   List.iter (
 348     fun (name, style, _, _, _) ->
 349       (* Generate server-side stubs. *)
 350       pr "static void %s_stub (XDR *xdr_in)\n" name;
 351       pr "{\n";
 352       let error_code =
 353         match style with
 354         | (Err, _) -> pr "  int r;\n"; "-1" in
 355       (match style with
 356        | (_, P0) -> ()
 357        | (_, args) ->
 358            pr "  struct guestfs_%s_args args;\n" name;
 359            iter_args (
 360              function
 361              | String name -> pr "  const char *%s;\n" name
 362            ) args
 363       );
 364       pr "\n";
 365
 366       (match style with
 367        | (_, P0) -> ()
 368        | (_, args) ->
 369            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
 370            pr "    reply_with_error (\"%s: daemon failed to decode procedure arguments\");\n" name;
 371            pr "    return;\n";
 372            pr "  }\n";
 373            iter_args (
 374              function
 375              | String name -> pr "  %s = args.%s;\n" name name
 376            ) args;
 377            pr "\n"
 378       );
 379
 380       pr "  r = do_%s " name;
 381       generate_call_args style;
 382       pr ";\n";
 383
 384       pr "  if (r == %s)\n" error_code;
 385       pr "    /* do_%s has already called reply_with_error, so just return */\n" name;
 386       pr "    return;\n";
 387       pr "\n";
 388
 389       (match style with
 390        | (Err, _) -> pr "  reply (NULL, NULL);\n"
 391       );
 392
 393       pr "}\n\n";
 394   ) functions;
 395
 396   (* Dispatch function. *)
 397   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
 398   pr "{\n";
 399   pr "  switch (proc_nr) {\n";
 400
 401   List.iter (
 402     fun (name, style, _, _, _) ->
 403       pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
 404       pr "      %s_stub (xdr_in);\n" name;
 405       pr "      break;\n"
 406   ) functions;
 407
 408   pr "    default:\n";
 409   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
 410   pr "  }\n";
 411   pr "}\n";
 412
 413 (* Generate a C function prototype. *)
 414 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
 415     ?(single_line = false) ?(newline = false)
 416     ?handle name style =
 417   if extern then pr "extern ";
 418   if static then pr "static ";
 419   (match style with
 420    | (Err, _) -> pr "int "
 421   );
 422   pr "%s (" name;
 423   let comma = ref false in
 424   (match handle with
 425    | None -> ()
 426    | Some handle -> pr "guestfs_h *%s" handle; comma := true
 427   );
 428   let next () =
 429     if !comma then (
 430       if single_line then pr ", " else pr ",\n\t\t"
 431     );
 432     comma := true
 433   in
 434   iter_args (
 435     function
 436     | String name -> next (); pr "const char *%s" name
 437   ) (snd style);
 438   pr ")";
 439   if semicolon then pr ";";
 440   if newline then pr "\n"
 441
 442 (* Generate C call arguments, eg "(handle, foo, bar)" *)
 443 and generate_call_args ?handle style =
 444   pr "(";
 445   let comma = ref false in
 446   (match handle with
 447    | None -> ()
 448    | Some handle -> pr "%s" handle; comma := true
 449   );
 450   iter_args (
 451     fun arg ->
 452       if !comma then pr ", ";
 453       comma := true;
 454       match arg with
 455       | String name -> pr "%s" name
 456   ) (snd style);
 457   pr ")"
 458
 459 let output_to filename =
 460   let filename_new = filename ^ ".new" in
 461   chan := open_out filename_new;
 462   let close () =
 463     close_out !chan;
 464     chan := stdout;
 465     Unix.rename filename_new filename;
 466     printf "written %s\n%!" filename;
 467   in
 468   close
 469
 470 (* Main program. *)
 471 let () =
 472   let close = output_to "src/guestfs_protocol.x" in
 473   generate_xdr ();
 474   close ();
 475
 476   let close = output_to "src/guestfs-actions.h" in
 477   generate_actions_h ();
 478   close ();
 479
 480   let close = output_to "src/guestfs-actions.c" in
 481   generate_client_actions ();
 482   close ();
 483
 484   let close = output_to "daemon/actions.h" in
 485   generate_daemon_actions_h ();
 486   close ();
 487
 488   let close = output_to "daemon/stubs.c" in
 489   generate_daemon_actions ();
 490   close ();
 491
 492   let close = output_to "guestfs-actions.pod" in
 493   generate_pod ();
 494   close ()