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")),
  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),
  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")),
  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 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   List.iter (
 157     fun (shortname, style, _, _) ->
 158       let name = "guestfs_" ^ shortname in
 159       pr "/* %s */\n\n" name;
 160       (match style with
 161        | (_, P0) -> ()
 162        | (_, args) ->
 163            pr "struct %s_args {\n" name;
 164            iter_args (
 165              function
 166              | String name -> pr "  string %s<>;\n" name
 167            ) args;
 168            pr "};\n\n"
 169       );
 170       (match style with
 171        | (Err, _) -> ()
 172     (* | ... -> pr "struct %s_ret ...\n" name; *)
 173       );
 174   ) functions
 175
 176 (* Generate the guestfs-actions.h file. *)
 177 and generate_actions_h () =
 178   generate_header CStyle LGPLv2;
 179   List.iter (
 180     fun (shortname, style, _, _) ->
 181       let name = "guestfs_" ^ shortname in
 182       generate_prototype ~single_line:true ~newline:true name style
 183   ) functions
 184
 185 (* Generate the client-side dispatch stubs. *)
 186 and generate_client_actions () =
 187   generate_header CStyle LGPLv2;
 188   List.iter (
 189     fun (shortname, style, _, _) ->
 190       let name = "guestfs_" ^ shortname in
 191
 192       (* Generate the return value struct. *)
 193       pr "struct %s_rv {\n" shortname;
 194       pr "  int err_code; /* 0 or -1 */\n";
 195       pr "  char err_str[256];\n";
 196       (match style with
 197        | (Err, _) -> ()
 198     (* | _ -> pr "  struct %s_ret ret;\n" name; *)
 199       );
 200       pr "};\n\n";
 201
 202       (* Generate the callback function. *)
 203       pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
 204       pr "{\n";
 205       pr "  struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
 206       pr "\n";
 207       pr "  /* XXX */ rv.code = 0;\n";
 208       pr "  main_loop.main_loop_quit (g);\n";
 209       pr "}\n\n";
 210
 211       (* Generate the action stub. *)
 212       generate_prototype ~extern:false ~semicolon:false ~newline:true
 213         ~handle:"g" name style;
 214
 215       let error_code =
 216         match style with
 217         | (Err, _) -> "-1" in
 218
 219       pr "{\n";
 220
 221       (match style with
 222        | (_, P0) -> ()
 223        | _ -> pr "  struct %s_args args;\n" name
 224       );
 225
 226       pr "  struct %s_rv rv;\n" shortname;
 227       pr "\n";
 228       pr "  if (g->state != READY) {\n";
 229       pr "    error (g, \"%s called from the wrong state, %%d != READY\",\n"
 230         name;
 231       pr "      g->state);\n";
 232       pr "    return %s;\n" error_code;
 233       pr "  }\n";
 234
 235       (match style with
 236        | (_, P0) -> ()
 237        | (_, args) ->
 238            pr "\n";
 239            iter_args (
 240              function
 241              | String name -> pr "  args.%s = (char *) %s;\n" name name
 242            ) args;
 243            pr "  if (dispatch (g, (xdrproc_t) xdr_%s_args, (char *) &args) == -1)\n"
 244              name;
 245            pr "    return %s;\n" error_code;
 246            pr "\n";
 247       );
 248
 249       pr "  rv.err_code = 42;\n";
 250       pr "  g->reply_cb_internal = %s_cb;\n" shortname;
 251       pr "  g->reply_cb_internal_data = &rv;\n";
 252       pr "  main_loop.main_loop_run (g);\n";
 253       pr "  g->reply_cb_internal = NULL;\n";
 254       pr "  g->reply_cb_internal_data = NULL;\n";
 255       pr "  if (rv.err_code == 42) { /* callback wasn't called */\n";
 256       pr "    error (g, \"%s failed, see earlier error messages\");\n" name;
 257       pr "    return %s;\n" error_code;
 258       pr "  }\n";
 259       pr "  else if (rv.err_code == -1) { /* error from remote end */\n";
 260       pr "    error (g, \"%%s\", rv.err_str);\n";
 261       pr "    return %s;\n" error_code;
 262       pr "  }\n";
 263       pr "\n";
 264
 265       (match style with
 266        | (Err, _) -> pr "  return 0;\n"
 267       );
 268
 269       pr "}\n\n"
 270   ) functions
 271
 272 (* Generate daemon/actions.h. *)
 273 and generate_daemon_actions_h () =
 274   generate_header CStyle GPLv2;
 275   List.iter (
 276     fun (name, style, _, _) ->
 277       generate_prototype ~single_line:true ~newline:true ("do_" ^ name) style;
 278   ) functions
 279
 280 (* Generate the server-side stubs. *)
 281 and generate_daemon_actions () =
 282   generate_header CStyle GPLv2;
 283
 284   pr "#include <rpc/types.h>\n";
 285   pr "#include <rpc/xdr.h>\n";
 286   pr "#include \"daemon.h\"\n";
 287   pr "#include \"../src/guest_protocol.h\"\n";
 288   pr "#include \"actions.h\"\n";
 289   pr "\n";
 290
 291   List.iter (
 292     fun (name, style, _, _) ->
 293       (* Generate server-side stubs. *)
 294       pr "static void %s_stub (XDR *xdr_in)\n" name;
 295       pr "{\n";
 296       let error_code =
 297         match style with
 298         | (Err, _) -> pr "  int r;\n"; "-1" in
 299       (match style with
 300        | (_, P0) -> ()
 301        | (_, args) ->
 302            pr "  struct guestfs_%s_args args;\n" name;
 303            iter_args (
 304              function
 305              | String name -> pr "  const char *%s;\n" name
 306            ) args
 307       );
 308       pr "\n";
 309
 310       (match style with
 311        | (_, P0) -> ()
 312        | (_, args) ->
 313            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
 314            pr "    reply_with_error (\"%s: daemon failed to decode procedure arguments\");\n" name;
 315            pr "    return;\n";
 316            pr "  }\n";
 317            iter_args (
 318              function
 319              | String name -> pr "  %s = args.%s;\n" name name
 320            ) args;
 321            pr "\n"
 322       );
 323
 324       pr "  r = do_%s " name;
 325       generate_call_args style;
 326       pr ";\n";
 327
 328       pr "  if (r == %s)\n" error_code;
 329       pr "    /* do_%s has already called reply_with_error, so just return */\n" name;
 330       pr "    return;\n";
 331       pr "\n";
 332
 333       (match style with
 334        | (Err, _) -> pr "  reply (NULL, NULL);\n"
 335       );
 336
 337       pr "}\n\n";
 338   ) functions
 339
 340 (* Generate a C function prototype. *)
 341 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
 342     ?(single_line = false) ?(newline = false)
 343     ?(handle = "handle") name style =
 344   if extern then pr "extern ";
 345   if static then pr "static ";
 346   (match style with
 347    | (Err, _) -> pr "int "
 348   );
 349   pr "%s (guestfs_h *%s" name handle;
 350   let next () = if single_line then pr ", " else pr ",\n\t\t" in
 351   iter_args (
 352     function
 353     | String name -> next (); pr "const char *%s" name
 354   ) (snd style);
 355   pr ")";
 356   if semicolon then pr ";";
 357   if newline then pr "\n"
 358
 359 (* Generate C call arguments, eg "(handle, foo, bar)" *)
 360 and generate_call_args ?handle style =
 361   pr "(";
 362   let comma = ref false in
 363   (match handle with
 364    | None -> ()
 365    | Some handle -> pr "%s" handle; comma := true
 366   );
 367   iter_args (
 368     fun arg ->
 369       if !comma then pr ", ";
 370       comma := true;
 371       match arg with
 372       | String name -> pr "%s" name
 373   ) (snd style);
 374   pr ")"
 375
 376 let output_to filename =
 377   let filename_new = filename ^ ".new" in
 378   chan := open_out filename_new;
 379   let close () =
 380     close_out !chan;
 381     chan := stdout;
 382     Unix.rename filename_new filename;
 383     printf "written %s\n%!" filename;
 384   in
 385   close
 386
 387 (* Main program. *)
 388 let () =
 389   let close = output_to "src/guestfs_protocol.x" in
 390   generate_xdr ();
 391   close ();
 392
 393   let close = output_to "src/guestfs-actions.h" in
 394   generate_actions_h ();
 395   close ();
 396
 397   let close = output_to "src/guestfs-actions.c" in
 398   generate_client_actions ();
 399   close ();
 400
 401   let close = output_to "daemon/actions.h" in
 402   generate_daemon_actions_h ();
 403   close ();
 404
 405   let close = output_to "daemon/stubs.c" in
 406   generate_daemon_actions ();
 407   close ();
 408
 409   let close = output_to "guestfs-actions.pod" in
 410   generate_pod ();
 411   close ()