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.
35 (* "RString" and "RStringList" require special treatment because
36 * the caller must free them.
39 | RStringList of string
41 (* 0 arguments, 1 argument, etc. The guestfs_h param is implicit. *)
46 | String of string (* const char *name, cannot be NULL *)
48 type flags = ProtocolLimitWarning
51 ("cat", (RString "content", P1 (String "path")), 4, [ProtocolLimitWarning],
52 "list the files in a directory (long format)",
54 Return the contents of the file named C<path>.");
56 ("ll", (RString "listing", P1 (String "directory")), 5, [],
57 "list the files in a directory (long format)",
59 List the files in C<directory> (relative to the root directory,
60 there is no cwd) in the format of 'ls -la'.
62 This command is mostly useful for interactive sessions. It
63 is I<not> intended that you try to parse the output string.");
65 ("ls", (RStringList "listing", P1 (String "directory")), 6, [],
66 "list the files in a directory",
68 List the files in C<directory> (relative to the root directory,
69 there is no cwd). The '.' and '..' entries are not returned, but
70 hidden files are shown.
72 This command is mostly useful for interactive sessions.");
74 ("mount", (Err, P2 (String "device", String "mountpoint")), 1, [],
75 "mount a guest disk at a position in the filesystem",
77 Mount a guest disk at a position in the filesystem. Block devices
78 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
79 the guest. If those block devices contain partitions, they will have
80 the usual names (eg. C</dev/sda1>). Also LVM C</dev/VG/LV>-style
83 The rules are the same as for L<mount(2)>: A filesystem must
84 first be mounted on C</> before others can be mounted. Other
85 filesystems can only be mounted on directories which already
88 The mounted filesystem is writable, if we have sufficient permissions
89 on the underlying device.
91 The filesystem options C<sync> and C<noatime> are set with this
92 call, in order to improve reliability.");
94 ("sync", (Err, P0), 2, [],
95 "sync disks, writes are flushed through to the disk image",
97 This syncs the disk, so that any writes are flushed through to the
98 underlying disk image.
100 You should always call this if you have modified a disk image, before
101 calling C<guestfs_close>.");
103 ("touch", (Err, P1 (String "path")), 3, [],
104 "update file timestamps or create a new file",
106 Touch acts like the L<touch(1)> command. It can be used to
107 update the timestamps on a file, or, if the file does not exist,
108 to create a new zero-length file.");
111 (* 'pr' prints to the current output file. *)
112 let chan = ref stdout
113 let pr fs = ksprintf (output_string !chan) fs
115 let iter_args f = function
118 | P2 (arg1, arg2) -> f arg1; f arg2
120 let iteri_args f = function
122 | P1 arg1 -> f 0 arg1
123 | P2 (arg1, arg2) -> f 0 arg1; f 1 arg2
125 let map_args f = function
127 | P1 arg1 -> [f arg1]
128 | P2 (arg1, arg2) -> [f arg1; f arg2]
130 let nr_args = function | P0 -> 0 | P1 _ -> 1 | P2 _ -> 2
132 type comment_style = CStyle | HashStyle | OCamlStyle
133 type license = GPLv2 | LGPLv2
135 (* Generate a header block in a number of standard styles. *)
136 let rec generate_header comment license =
137 let c = match comment with
138 | CStyle -> pr "/* "; " *"
139 | HashStyle -> pr "# "; "#"
140 | OCamlStyle -> pr "(* "; " *" in
141 pr "libguestfs generated file\n";
142 pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
143 pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
145 pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
149 pr "%s This program is free software; you can redistribute it and/or modify\n" c;
150 pr "%s it under the terms of the GNU General Public License as published by\n" c;
151 pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
152 pr "%s (at your option) any later version.\n" c;
154 pr "%s This program is distributed in the hope that it will be useful,\n" c;
155 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
156 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n" c;
157 pr "%s GNU General Public License for more details.\n" c;
159 pr "%s You should have received a copy of the GNU General Public License along\n" c;
160 pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
161 pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
164 pr "%s This library is free software; you can redistribute it and/or\n" c;
165 pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
166 pr "%s License as published by the Free Software Foundation; either\n" c;
167 pr "%s version 2 of the License, or (at your option) any later version.\n" c;
169 pr "%s This library is distributed in the hope that it will be useful,\n" c;
170 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
171 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n" c;
172 pr "%s Lesser General Public License for more details.\n" c;
174 pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
175 pr "%s License along with this library; if not, write to the Free Software\n" c;
176 pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
179 | CStyle -> pr " */\n"
181 | OCamlStyle -> pr " *)\n"
185 (* Generate the pod documentation for the C API. *)
186 and generate_pod () =
188 fun (shortname, style, _, flags, _, longdesc) ->
189 let name = "guestfs_" ^ shortname in
190 pr "=head2 %s\n\n" name;
192 generate_prototype ~extern:false ~handle:"handle" name style;
194 pr "%s\n\n" longdesc;
195 (match fst style with
197 pr "This function returns 0 on success or -1 on error.\n\n"
199 pr "This function returns a string or NULL on error. The caller
200 must free the returned string after use.\n\n"
202 pr "This function returns a NULL-terminated array of strings
203 (like L<environ(3)>), or NULL if there was an error.
205 The caller must free the strings I<and> the array after use.\n\n"
207 if List.mem ProtocolLimitWarning flags then
208 pr "Because of the message protocol, there is a transfer limit
209 of somewhere between 2MB and 4MB. To transfer large files you should use
213 (* Generate the protocol (XDR) file. *)
214 and generate_xdr () =
215 generate_header CStyle LGPLv2;
217 (* This has to be defined to get around a limitation in Sun's rpcgen. *)
218 pr "typedef string str<>;\n";
222 fun (shortname, style, _, _, _, _) ->
223 let name = "guestfs_" ^ shortname in
224 pr "/* %s */\n\n" name;
225 (match snd style with
228 pr "struct %s_args {\n" name;
231 | String name -> pr " string %s<>;\n" name
235 (match fst style with
238 pr "struct %s_ret {\n" name;
239 pr " string %s<>;\n" n;
242 pr "struct %s_ret {\n" name;
248 (* Table of procedure numbers. *)
249 pr "enum guestfs_procedure {\n";
251 fun (shortname, _, proc_nr, _, _, _) ->
252 pr " GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
254 pr " GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
258 (* Having to choose a maximum message size is annoying for several
259 * reasons (it limits what we can do in the API), but it (a) makes
260 * the protocol a lot simpler, and (b) provides a bound on the size
261 * of the daemon which operates in limited memory space. For large
262 * file transfers you should use FTP.
264 pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
267 (* Message header, etc. *)
269 const GUESTFS_PROGRAM = 0x2000F5F5;
270 const GUESTFS_PROTOCOL_VERSION = 1;
272 enum guestfs_message_direction {
273 GUESTFS_DIRECTION_CALL = 0, /* client -> daemon */
274 GUESTFS_DIRECTION_REPLY = 1 /* daemon -> client */
277 enum guestfs_message_status {
278 GUESTFS_STATUS_OK = 0,
279 GUESTFS_STATUS_ERROR = 1
282 const GUESTFS_ERROR_LEN = 256;
284 struct guestfs_message_error {
285 string error<GUESTFS_ERROR_LEN>; /* error message */
288 struct guestfs_message_header {
289 unsigned prog; /* GUESTFS_PROGRAM */
290 unsigned vers; /* GUESTFS_PROTOCOL_VERSION */
291 guestfs_procedure proc; /* GUESTFS_PROC_x */
292 guestfs_message_direction direction;
293 unsigned serial; /* message serial number */
294 guestfs_message_status status;
298 (* Generate the guestfs-actions.h file. *)
299 and generate_actions_h () =
300 generate_header CStyle LGPLv2;
302 fun (shortname, style, _, _, _, _) ->
303 let name = "guestfs_" ^ shortname in
304 generate_prototype ~single_line:true ~newline:true ~handle:"handle"
308 (* Generate the client-side dispatch stubs. *)
309 and generate_client_actions () =
310 generate_header CStyle LGPLv2;
312 fun (shortname, style, _, _, _, _) ->
313 let name = "guestfs_" ^ shortname in
315 (* Generate the return value struct. *)
316 pr "struct %s_rv {\n" shortname;
317 pr " int cb_done; /* flag to indicate callback was called */\n";
318 pr " struct guestfs_message_header hdr;\n";
319 pr " struct guestfs_message_error err;\n";
320 (match fst style with
322 | RString _ | RStringList _ -> pr " struct %s_ret ret;\n" name;
326 (* Generate the callback function. *)
327 pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
329 pr " struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
331 pr " if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
332 pr " error (g, \"%s: failed to parse reply header\");\n" name;
335 pr " if (rv->hdr.status == GUESTFS_STATUS_ERROR) {\n";
336 pr " if (!xdr_guestfs_message_error (xdr, &rv->err)) {\n";
337 pr " error (g, \"%s: failed to parse reply error\");\n" name;
343 (match fst style with
345 | RString _ | RStringList _ ->
346 pr " if (!xdr_%s_ret (xdr, &rv->ret)) {\n" name;
347 pr " error (g, \"%s: failed to parse reply\");\n" name;
353 pr " rv->cb_done = 1;\n";
354 pr " main_loop.main_loop_quit (g);\n";
357 (* Generate the action stub. *)
358 generate_prototype ~extern:false ~semicolon:false ~newline:true
359 ~handle:"g" name style;
364 | RString _ | RStringList _ -> "NULL" in
368 (match snd style with
370 | _ -> pr " struct %s_args args;\n" name
373 pr " struct %s_rv rv;\n" shortname;
376 pr " if (g->state != READY) {\n";
377 pr " error (g, \"%s called from the wrong state, %%d != READY\",\n"
380 pr " return %s;\n" error_code;
383 pr " memset (&rv, 0, sizeof rv);\n";
386 (match snd style with
388 pr " serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
389 (String.uppercase shortname)
393 | String name -> pr " args.%s = (char *) %s;\n" name name
395 pr " serial = dispatch (g, GUESTFS_PROC_%s,\n"
396 (String.uppercase shortname);
397 pr " (xdrproc_t) xdr_%s_args, (char *) &args);\n"
400 pr " if (serial == -1)\n";
401 pr " return %s;\n" error_code;
404 pr " rv.cb_done = 0;\n";
405 pr " g->reply_cb_internal = %s_cb;\n" shortname;
406 pr " g->reply_cb_internal_data = &rv;\n";
407 pr " main_loop.main_loop_run (g);\n";
408 pr " g->reply_cb_internal = NULL;\n";
409 pr " g->reply_cb_internal_data = NULL;\n";
410 pr " if (!rv.cb_done) {\n";
411 pr " error (g, \"%s failed, see earlier error messages\");\n" name;
412 pr " return %s;\n" error_code;
416 pr " if (check_reply_header (g, &rv.hdr, GUESTFS_PROC_%s, serial) == -1)\n"
417 (String.uppercase shortname);
418 pr " return %s;\n" error_code;
421 pr " if (rv.hdr.status == GUESTFS_STATUS_ERROR) {\n";
422 pr " error (g, \"%%s\", rv.err.error);\n";
423 pr " return %s;\n" error_code;
427 (match fst style with
428 | Err -> pr " return 0;\n"
430 pr " return rv.ret.%s; /* caller will free */\n" n
432 pr " /* caller will free this, but we need to add a NULL entry */\n";
433 pr " rv.ret.%s.%s_val = safe_realloc (g, rv.ret.%s.%s_val, rv.ret.%s.%s_len + 1);\n" n n n n n n;
434 pr " rv.ret.%s.%s_val[rv.ret.%s.%s_len] = NULL;\n" n n n n;
435 pr " return rv.ret.%s.%s_val;\n" n n
441 (* Generate daemon/actions.h. *)
442 and generate_daemon_actions_h () =
443 generate_header CStyle GPLv2;
445 fun (name, style, _, _, _, _) ->
446 generate_prototype ~single_line:true ~newline:true ("do_" ^ name) style;
449 (* Generate the server-side stubs. *)
450 and generate_daemon_actions () =
451 generate_header CStyle GPLv2;
453 pr "#include <rpc/types.h>\n";
454 pr "#include <rpc/xdr.h>\n";
455 pr "#include \"daemon.h\"\n";
456 pr "#include \"../src/guestfs_protocol.h\"\n";
457 pr "#include \"actions.h\"\n";
461 fun (name, style, _, _, _, _) ->
462 (* Generate server-side stubs. *)
463 pr "static void %s_stub (XDR *xdr_in)\n" name;
467 | Err -> pr " int r;\n"; "-1"
468 | RString _ -> pr " char *r;\n"; "NULL"
469 | RStringList _ -> pr " char **r;\n"; "NULL" in
470 (match snd style with
473 pr " struct guestfs_%s_args args;\n" name;
476 | String name -> pr " const char *%s;\n" name
481 (match snd style with
484 pr " memset (&args, 0, sizeof args);\n";
486 pr " if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
487 pr " reply_with_error (\"%s: daemon failed to decode procedure arguments\");\n" name;
492 | String name -> pr " %s = args.%s;\n" name name
497 pr " r = do_%s " name;
498 generate_call_args style;
501 pr " if (r == %s)\n" error_code;
502 pr " /* do_%s has already called reply_with_error, so just return */\n" name;
506 (match fst style with
507 | Err -> pr " reply (NULL, NULL);\n"
509 pr " struct guestfs_%s_ret ret;\n" name;
510 pr " ret.%s = r;\n" n;
511 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
514 pr " struct guestfs_%s_ret ret;\n" name;
515 pr " ret.%s.%s_len = count_strings (r);\n" n n;
516 pr " ret.%s.%s_val = r;\n" n n;
517 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
518 pr " free_strings (r);\n"
524 (* Dispatch function. *)
525 pr "void dispatch_incoming_message (XDR *xdr_in)\n";
527 pr " switch (proc_nr) {\n";
530 fun (name, style, _, _, _, _) ->
531 pr " case GUESTFS_PROC_%s:\n" (String.uppercase name);
532 pr " %s_stub (xdr_in);\n" name;
537 pr " reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
541 (* Generate a lot of different functions for guestfish. *)
542 and generate_fish_cmds () =
543 generate_header CStyle GPLv2;
545 pr "#include <stdio.h>\n";
546 pr "#include <stdlib.h>\n";
547 pr "#include <string.h>\n";
549 pr "#include \"fish.h\"\n";
552 (* list_commands function, which implements guestfish -h *)
553 pr "void list_commands (void)\n";
555 pr " printf (\" %%-16s %%s\\n\", \"Command\", \"Description\");\n";
556 pr " list_builtin_commands ();\n";
558 fun (name, _, _, _, shortdesc, _) ->
559 pr " printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
562 pr " printf (\" Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
566 (* display_command function, which implements guestfish -h cmd *)
567 pr "void display_command (const char *cmd)\n";
570 fun (name, style, _, flags, shortdesc, longdesc) ->
577 String.concat "> <" (
579 | String n -> n) args
584 if List.mem ProtocolLimitWarning flags then
585 "\n\nBecause of the message protocol, there is a transfer limit
586 of somewhere between 2MB and 4MB. To transfer large files you should use
590 pr " if (strcasecmp (cmd, \"%s\") == 0)\n" name;
591 pr " pod2text (\"%s - %s\", %S);\n"
593 (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings);
596 pr " display_builtin_command (cmd);\n";
600 (* run_<action> actions *)
602 fun (name, style, _, _, _, _) ->
603 pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
605 (match fst style with
606 | Err -> pr " int r;\n"
607 | RString _ -> pr " char *r;\n"
608 | RStringList _ -> pr " char **r;\n"
612 | String name -> pr " const char *%s;\n" name
615 (* Check and convert parameters. *)
616 let argc_expected = nr_args (snd style) in
617 pr " if (argc != %d) {\n" argc_expected;
618 pr " fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
620 pr " fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
626 | String name -> pr " %s = argv[%d];\n" name i
629 (* Call C API function. *)
630 pr " r = guestfs_%s " name;
631 generate_call_args ~handle:"g" style;
634 (* Check return value for errors and display command results. *)
635 (match fst style with
636 | Err -> pr " return r;\n"
638 pr " if (r == NULL) return -1;\n";
639 pr " printf (\"%%s\", r);\n";
643 pr " if (r == NULL) return -1;\n";
644 pr " print_strings (r);\n";
645 pr " free_strings (r);\n";
652 (* run_action function *)
653 pr "int run_action (const char *cmd, int argc, char *argv[])\n";
656 fun (name, _, _, _, _, _) ->
657 pr " if (strcasecmp (cmd, \"%s\") == 0)\n" name;
658 pr " return run_%s (cmd, argc, argv);\n" name;
662 pr " fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
669 (* Generate a C function prototype. *)
670 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
671 ?(single_line = false) ?(newline = false)
673 if extern then pr "extern ";
674 if static then pr "static ";
675 (match fst style with
677 | RString _ -> pr "char *"
678 | RStringList _ -> pr "char **"
681 let comma = ref false in
684 | Some handle -> pr "guestfs_h *%s" handle; comma := true
688 if single_line then pr ", " else pr ",\n\t\t"
694 | String name -> next (); pr "const char *%s" name
697 if semicolon then pr ";";
698 if newline then pr "\n"
700 (* Generate C call arguments, eg "(handle, foo, bar)" *)
701 and generate_call_args ?handle style =
703 let comma = ref false in
706 | Some handle -> pr "%s" handle; comma := true
710 if !comma then pr ", ";
713 | String name -> pr "%s" name
717 let output_to filename =
718 let filename_new = filename ^ ".new" in
719 chan := open_out filename_new;
723 Unix.rename filename_new filename;
724 printf "written %s\n%!" filename;
730 let close = output_to "src/guestfs_protocol.x" in
734 let close = output_to "src/guestfs-actions.h" in
735 generate_actions_h ();
738 let close = output_to "src/guestfs-actions.c" in
739 generate_client_actions ();
742 let close = output_to "daemon/actions.h" in
743 generate_daemon_actions_h ();
746 let close = output_to "daemon/stubs.c" in
747 generate_daemon_actions ();
750 let close = output_to "fish/cmds.c" in
751 generate_fish_cmds ();
754 let close = output_to "guestfs-actions.pod" in