1 #!/usr/bin/ocamlrun ocaml
3 * Copyright (C) 2009 Red Hat Inc.
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.
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.
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
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.
29 type style = ret * args
31 (* "Err" as a return value means an int used as a simple error
32 * indication, ie. 0 or -1.
36 (* 0 arguments, 1 argument, etc. The guestfs_h param is implicit. *)
41 | String of string (* const char *name, cannot be NULL *)
44 ("mount", (Err, P2 (String "device", String "mountpoint")), 1,
45 "Mount a guest disk at a position in the filesystem",
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
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
58 ("sync", (Err, P0), 2,
59 "Sync disks, writes are flushed through to the disk image",
61 This syncs the disk, so that any writes are flushed through to the
62 underlying disk image.
64 You should always call this if you have modified a disk image, before
65 calling C<guestfs_close>.");
67 ("touch", (Err, P1 (String "path")), 3,
68 "Update file timestamps or create a new file",
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.");
75 (* 'pr' prints to the current output file. *)
77 let pr fs = ksprintf (output_string !chan) fs
79 let iter_args f = function
82 | P2 (arg1, arg2) -> f arg1; f arg2
84 type comment_style = CStyle | HashStyle | OCamlStyle
85 type license = GPLv2 | LGPLv2
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;
97 pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
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;
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;
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;
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;
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;
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;
131 | CStyle -> pr " */\n"
133 | OCamlStyle -> pr " *)\n"
137 (* Generate the pod documentation for the C API. *)
138 and generate_pod () =
140 fun (shortname, style, _, _, longdesc) ->
141 let name = "guestfs_" ^ shortname in
142 pr "=head2 %s\n\n" name;
144 generate_prototype ~extern:false ~handle:"handle" name style;
146 pr "%s\n\n" longdesc;
149 pr "This function return 0 on success or -1 on error.\n\n"
153 (* Generate the protocol (XDR) file. *)
154 and generate_xdr () =
155 generate_header CStyle LGPLv2;
158 fun (shortname, style, _, _, _) ->
159 let name = "guestfs_" ^ shortname in
160 pr "/* %s */\n\n" name;
164 pr "struct %s_args {\n" name;
167 | String name -> pr " string %s<>;\n" name
173 (* | ... -> pr "struct %s_ret ...\n" name; *)
177 (* Table of procedure numbers. *)
178 pr "enum guestfs_procedure {\n";
180 fun (shortname, _, proc_nr, _, _) ->
181 pr " GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
183 pr " GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
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.
193 pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
196 (* Message header, etc. *)
198 const GUESTFS_PROGRAM = 0x2000F5F5;
199 const GUESTFS_PROTOCOL_VERSION = 1;
201 enum guestfs_message_direction {
202 GUESTFS_DIRECTION_CALL = 0, /* client -> daemon */
203 GUESTFS_DIRECTION_REPLY = 1 /* daemon -> client */
206 enum guestfs_message_status {
207 GUESTFS_STATUS_OK = 0,
208 GUESTFS_STATUS_ERROR = 1
211 const GUESTFS_ERROR_LEN = 256;
213 struct guestfs_message_error {
214 string error<GUESTFS_ERROR_LEN>; /* error message */
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;
227 (* Generate the guestfs-actions.h file. *)
228 and generate_actions_h () =
229 generate_header CStyle LGPLv2;
231 fun (shortname, style, _, _, _) ->
232 let name = "guestfs_" ^ shortname in
233 generate_prototype ~single_line:true ~newline:true ~handle:"handle"
237 (* Generate the client-side dispatch stubs. *)
238 and generate_client_actions () =
239 generate_header CStyle LGPLv2;
241 fun (shortname, style, _, _, _) ->
242 let name = "guestfs_" ^ shortname in
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";
251 (* | _ -> pr " struct %s_ret ret;\n" name; *)
255 (* Generate the callback function. *)
256 pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
258 pr " struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
260 pr " if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
261 pr " error (g, \"%s: failed to parse reply header\");\n" name;
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;
274 (* | _ -> pr " if (!xdr_%s_ret (&xdr, &rv->ret)) ..." *)
278 pr " rv->cb_done = 1;\n";
279 pr " main_loop.main_loop_quit (g);\n";
282 (* Generate the action stub. *)
283 generate_prototype ~extern:false ~semicolon:false ~newline:true
284 ~handle:"g" name style;
288 | (Err, _) -> "-1" in
294 | _ -> pr " struct %s_args args;\n" name
297 pr " struct %s_rv rv;\n" shortname;
300 pr " if (g->state != READY) {\n";
301 pr " error (g, \"%s called from the wrong state, %%d != READY\",\n"
304 pr " return %s;\n" error_code;
307 pr " memset (&rv, 0, sizeof rv);\n";
312 pr " serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
313 (String.uppercase shortname)
318 | String name -> pr " args.%s = (char *) %s;\n" name name
320 pr " serial = dispatch (g, GUESTFS_PROC_%s,\n"
321 (String.uppercase shortname);
322 pr " (xdrproc_t) xdr_%s_args, (char *) &args);\n"
325 pr " if (serial == -1)\n";
326 pr " return %s;\n" error_code;
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;
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;
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;
353 | (Err, _) -> pr " return 0;\n"
359 (* Generate daemon/actions.h. *)
360 and generate_daemon_actions_h () =
361 generate_header CStyle GPLv2;
363 fun (name, style, _, _, _) ->
364 generate_prototype ~single_line:true ~newline:true ("do_" ^ name) style;
367 (* Generate the server-side stubs. *)
368 and generate_daemon_actions () =
369 generate_header CStyle GPLv2;
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";
379 fun (name, style, _, _, _) ->
380 (* Generate server-side stubs. *)
381 pr "static void %s_stub (XDR *xdr_in)\n" name;
385 | (Err, _) -> pr " int r;\n"; "-1" in
389 pr " struct guestfs_%s_args args;\n" name;
392 | String name -> pr " const char *%s;\n" name
400 pr " memset (&args, 0, sizeof args);\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;
408 | String name -> pr " %s = args.%s;\n" name name
413 pr " r = do_%s " name;
414 generate_call_args style;
417 pr " if (r == %s)\n" error_code;
418 pr " /* do_%s has already called reply_with_error, so just return */\n" name;
423 | (Err, _) -> pr " reply (NULL, NULL);\n"
429 (* Dispatch function. *)
430 pr "void dispatch_incoming_message (XDR *xdr_in)\n";
432 pr " switch (proc_nr) {\n";
435 fun (name, style, _, _, _) ->
436 pr " case GUESTFS_PROC_%s:\n" (String.uppercase name);
437 pr " %s_stub (xdr_in);\n" name;
442 pr " reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
446 (* Generate a C function prototype. *)
447 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
448 ?(single_line = false) ?(newline = false)
450 if extern then pr "extern ";
451 if static then pr "static ";
453 | (Err, _) -> pr "int "
456 let comma = ref false in
459 | Some handle -> pr "guestfs_h *%s" handle; comma := true
463 if single_line then pr ", " else pr ",\n\t\t"
469 | String name -> next (); pr "const char *%s" name
472 if semicolon then pr ";";
473 if newline then pr "\n"
475 (* Generate C call arguments, eg "(handle, foo, bar)" *)
476 and generate_call_args ?handle style =
478 let comma = ref false in
481 | Some handle -> pr "%s" handle; comma := true
485 if !comma then pr ", ";
488 | String name -> pr "%s" name
492 let output_to filename =
493 let filename_new = filename ^ ".new" in
494 chan := open_out filename_new;
498 Unix.rename filename_new filename;
499 printf "written %s\n%!" filename;
505 let close = output_to "src/guestfs_protocol.x" in
509 let close = output_to "src/guestfs-actions.h" in
510 generate_actions_h ();
513 let close = output_to "src/guestfs-actions.c" in
514 generate_client_actions ();
517 let close = output_to "daemon/actions.h" in
518 generate_daemon_actions_h ();
521 let close = output_to "daemon/stubs.c" in
522 generate_daemon_actions ();
525 let close = output_to "guestfs-actions.pod" in