Command line and interactive shell parsing, prompts etc.
[libguestfs.git] / 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 (\"%%-20s %%s\\n\", \"Command\", \"Description\");\n";
470   List.iter (
471     fun (name, _, _, shortdesc, _) ->
472       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
473         name shortdesc
474   ) functions;
475   pr "  printf (\"Use -h <cmd> to show detailed help for a command.\\n\");\n";
476   pr "}\n";
477   pr "\n";
478
479   (* display_command function, which implements guestfish -h cmd *)
480   pr "void display_command (const char *cmd)\n";
481   pr "{\n";
482   List.iter (
483     fun (name, style, _, shortdesc, longdesc) ->
484       let synopsis =
485         match style with
486         | (Err, P0) -> name
487         | (Err, args) ->
488             sprintf "%s <%s>"
489               name (
490                 String.concat "> <" (
491                   map_args (function
492                             | String n -> n) args
493                 )
494               ) in
495
496       pr "  if (strcasecmp (cmd, \"%s\") == 0)\n" name;
497       pr "    pod2text (\"%s - %s\", %S);\n"
498         name shortdesc
499         (" " ^ synopsis ^ "\n\n" ^ longdesc);
500       pr "  else\n"
501   ) functions;
502   pr "  {\n";
503   pr "    fprintf (stderr, \"%%s: command not known, use -h to list all commands\\n\", cmd);\n";
504   pr "    exit (1);\n";
505   pr "  }\n";
506   pr "}\n";
507   pr "\n"
508
509 (* Generate a C function prototype. *)
510 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
511     ?(single_line = false) ?(newline = false)
512     ?handle name style =
513   if extern then pr "extern ";
514   if static then pr "static ";
515   (match style with
516    | (Err, _) -> pr "int "
517   );
518   pr "%s (" name;
519   let comma = ref false in
520   (match handle with
521    | None -> ()
522    | Some handle -> pr "guestfs_h *%s" handle; comma := true
523   );
524   let next () =
525     if !comma then (
526       if single_line then pr ", " else pr ",\n\t\t"
527     );
528     comma := true
529   in
530   iter_args (
531     function
532     | String name -> next (); pr "const char *%s" name
533   ) (snd style);
534   pr ")";
535   if semicolon then pr ";";
536   if newline then pr "\n"
537
538 (* Generate C call arguments, eg "(handle, foo, bar)" *)
539 and generate_call_args ?handle style =
540   pr "(";
541   let comma = ref false in
542   (match handle with
543    | None -> ()
544    | Some handle -> pr "%s" handle; comma := true
545   );
546   iter_args (
547     fun arg ->
548       if !comma then pr ", ";
549       comma := true;
550       match arg with
551       | String name -> pr "%s" name
552   ) (snd style);
553   pr ")"
554
555 let output_to filename =
556   let filename_new = filename ^ ".new" in
557   chan := open_out filename_new;
558   let close () =
559     close_out !chan;
560     chan := stdout;
561     Unix.rename filename_new filename;
562     printf "written %s\n%!" filename;
563   in
564   close
565
566 (* Main program. *)
567 let () =
568   let close = output_to "src/guestfs_protocol.x" in
569   generate_xdr ();
570   close ();
571
572   let close = output_to "src/guestfs-actions.h" in
573   generate_actions_h ();
574   close ();
575
576   let close = output_to "src/guestfs-actions.c" in
577   generate_client_actions ();
578   close ();
579
580   let close = output_to "daemon/actions.h" in
581   generate_daemon_actions_h ();
582   close ();
583
584   let close = output_to "daemon/stubs.c" in
585   generate_daemon_actions ();
586   close ();
587
588   let close = output_to "fish/cmds.c" in
589   generate_fish_cmds ();
590   close ();
591
592   let close = output_to "guestfs-actions.pod" in
593   generate_pod ();
594   close ()