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