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