Libguestfs - Jul 2017 - Re: [PATCH 02/27] daemon: Allow parts of the daemon and APIs to be written in OCaml.

On Friday, 14 July 2017 15:39:10 CEST Richard W.M. Jones
wrote:
>  .gitignore                 |   6 +-
>  Makefile.am                |   2 +-
>  common/mlutils/Makefile.am |   4 -
>  daemon/Makefile.am         | 103 +++++++++++++++++++++++--
>  daemon/chroot.ml           |  85 +++++++++++++++++++++
>  daemon/chroot.mli          |  35 +++++++++
>  daemon/daemon-c.c          |  35 +++++++++
>  daemon/daemon.ml           |  39 ++++++++++
>  daemon/guestfsd.c          |  50 ++++++++++++
>  daemon/sysroot-c.c         |  37 +++++++++
>  daemon/sysroot.ml          |  19 +++++
>  daemon/sysroot.mli         |  22 ++++++
>  daemon/utils.ml            | 156 +++++++++++++++++++++++++++++++++++++
>  daemon/utils.mli           |  65 ++++++++++++++++
TBH I'd just have a single "Daemon" module for the OCaml helpers
for
the daemon, instead of different modules, wirh a single -c.c file for
all the C implementations.  The Sysroot submodule could be implemented
like the various submodules in Unix_utils.
> diff --git a/daemon/Makefile.am b/daemon/Makefile.am
> index eedf09d52..40b770762 100644
> --- a/daemon/Makefile.am
> +++ b/daemon/Makefile.am
> @@ -19,6 +19,7 @@ include $(top_srcdir)/subdir-rules.mk
>  
>  generator_built = \
>  	actions.h \
> +	caml-stubs.c \
>  	dispatch.c \
>  	names.c \
>  	lvm-tokenization.c \
> @@ -31,13 +32,30 @@ generator_built = \
>  	stubs-4.c \
>  	stubs-5.c \
>  	stubs-6.c \
> -	stubs.h
> +	stubs.h \
> +	callbacks.ml \
> +	types.ml
>  
>  BUILT_SOURCES = \
> -	$(generator_built)
> +	actions.h \
> +	caml-stubs.c \
> +	dispatch.c \
> +	names.c \
> +	lvm-tokenization.c \
> +	structs-cleanups.c \
> +	structs-cleanups.h \
> +	stubs-0.c \
> +	stubs-1.c \
> +	stubs-2.c \
> +	stubs-3.c \
> +	stubs-4.c \
> +	stubs-5.c \
> +	stubs-6.c \
> +	stubs.h
Hm why the duplication here? I mean, I see generator_built has
callbacks.ml, and types.ml -- could it be possible to add a new
variable? (or use BUILT_SOURCES in generator_built, maybe)
> +OCAML_LIBS = \
> +	-lmlcutils \
> +	-lmlstdutils \
> +	-lmlhivex \
> +	-lcamlstr \
> +	-lunix \
> +	-l$(CAMLRUN) -ldl -lm
Are ld and m needed?
> diff --git a/daemon/chroot.mli b/daemon/chroot.mli
> new file mode 100644
> index 000000000..eda3a785f
> --- /dev/null
> +++ b/daemon/chroot.mli
> @@ -0,0 +1,35 @@
> +(* guestfs-inspection
> + * Copyright (C) 2009-2017 Red Hat Inc.
> + *
> + * This program is free software; you can redistribute it and/or modify
> + * it under the terms of the GNU General Public License as published by
> + * the Free Software Foundation; either version 2 of the License, or
> + * (at your option) any later version.
> + *
> + * This program is distributed in the hope that it will be useful,
> + * but WITHOUT ANY WARRANTY; without even the implied warranty of
> + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> + * GNU General Public License for more details.
> + *
> + * You should have received a copy of the GNU General Public License along
> + * with this program; if not, write to the Free Software Foundation, Inc.,
> + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
> + *)
> +
> +(** This is a generic module for running functions in a chroot.
> +    The function runs in a forked subprocess too so that we can
> +    restore the root afterwards.
> +
> +    It handles passing the parmeter, forking, running the
typo, "parameter"
> +    function and marshalling the result or any exceptions. *)
> +
> +type t
> +
> +val create : ?name:string -> string -> t
> +(** Create a chroot handle.  [?name] is an optional name used in
> +    debugging and error messages.  The string is the chroot
> +    directory. *)
> +
> +val f : t -> ('a -> 'b) -> 'a -> 'b
> +(** Run a function in the chroot, returning the result or re-raising
> +    any exception thrown. *)
After reading patch #11, IMHO there should be a variant that takes a
generic (unit -> unit) function (called 'fn', maybe?), and have
'f'
use it:

  let f t fun arg     f (fun () -> fun arg)
> diff --git a/daemon/guestfsd.c b/daemon/guestfsd.c
> index b3f40628b..1d35991b6 100644
> --- a/daemon/guestfsd.c
> +++ b/daemon/guestfsd.c
> @@ -56,6 +56,10 @@
>  
>  #include <augeas.h>
>  
> +#include <caml/callback.h>
> +#include <caml/mlvalues.h>
> +#include <caml/unixsupport.h>
> +
>  #include "sockets.h"
>  #include "c-ctype.h"
>  #include "ignore-value.h"
> @@ -348,6 +352,9 @@ main (int argc, char *argv[])
>     */
>    udev_settle ();
>  
> +  /* Initialize the OCaml stubs. */
> +  caml_startup (argv);
> +
>    /* Send the magic length message which indicates that
>     * userspace is up inside the guest.
>     */
> @@ -1205,3 +1212,46 @@ cleanup_free_mountable (mountable_t *mountable)
>      free (mountable->volume);
>    }
>  }
> +
> +/* Convert an OCaml exception to a reply_with_error_errno call
> + * as best we can.
> + */
> +extern void ocaml_exn_to_reply_with_error (const char *func, value exn);
> +
> +void
> +ocaml_exn_to_reply_with_error (const char *func, value exn)
> +{
Shouldn't this use CAMLparam1 + CAMLreturn?
> diff --git a/daemon/sysroot-c.c b/daemon/sysroot-c.c
> new file mode 100644
> index 000000000..ad31d36ee
> --- /dev/null
> +++ b/daemon/sysroot-c.c
> @@ -0,0 +1,37 @@
> +/* guestfs-inspection
> + * Copyright (C) 2017 Red Hat Inc.
> + *
> + * This program is free software; you can redistribute it and/or modify
> + * it under the terms of the GNU General Public License as published by
> + * the Free Software Foundation; either version 2 of the License, or
> + * (at your option) any later version.
> + *
> + * This program is distributed in the hope that it will be useful,
> + * but WITHOUT ANY WARRANTY; without even the implied warranty of
> + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> + * GNU General Public License for more details.
> + *
> + * You should have received a copy of the GNU General Public License
> + * along with this program; if not, write to the Free Software
> + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301 USA.
> + */
> +
> +#include <config.h>
> +
> +#include <stdio.h>
> +#include <stdlib.h>
> +
> +#include <caml/alloc.h>
> +#include <caml/fail.h>
> +#include <caml/memory.h>
> +#include <caml/mlvalues.h>
> +
> +#include "daemon.h"
> +
> +extern value guestfs_int_daemon_sysroot (value unitv);
> +
> +value
> +guestfs_int_daemon_sysroot (value unitv)
> +{
Ditto.
> diff --git a/daemon/utils.ml b/daemon/utils.ml
> new file mode 100644
> index 000000000..7630a5534
> --- /dev/null
> +++ b/daemon/utils.ml
> @@ -0,0 +1,156 @@
> +(* guestfs-inspection
> + * Copyright (C) 2009-2017 Red Hat Inc.
> + *
> + * This program is free software; you can redistribute it and/or modify
> + * it under the terms of the GNU General Public License as published by
> + * the Free Software Foundation; either version 2 of the License, or
> + * (at your option) any later version.
> + *
> + * This program is distributed in the hope that it will be useful,
> + * but WITHOUT ANY WARRANTY; without even the implied warranty of
> + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> + * GNU General Public License for more details.
> + *
> + * You should have received a copy of the GNU General Public License along
> + * with this program; if not, write to the Free Software Foundation, Inc.,
> + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
> + *)
> +
> +open Unix
> +open Printf
> +
> +open Std_utils
> +
> +let prog_exists prog > +  try ignore (which prog); true
> +  with Executable_not_found _ -> false
> +
> +let commandr prog args 
Another option here, instead of the manual implementation, would be to
bind the C command* APIs -- this way there is no need to do fixes &
additions in both places.
> +  if verbose () then
> +    eprintf "command: %s %s\n%!"
> +            prog (String.concat " " args);
stringify_args could help here.
> +  let argv = Array.of_list (prog :: args) in
> +
> +  let stdout_file, stdout_chan = Filename.open_temp_file "cmd"
".out" in
> +  let stderr_file, stderr_chan = Filename.open_temp_file "cmd"
".err" in
> +  let stdout_fd = descr_of_out_channel stdout_chan in
> +  let stderr_fd = descr_of_out_channel stderr_chan in
> +  let stdin_fd = openfile "/dev/null" [O_RDONLY] 0 in
> +
> +  let pid = fork () in
> +  if pid = 0 then (
> +    (* Child process. *)
> +    dup2 stdin_fd stdin;
> +    close stdin_fd;
> +    dup2 stdout_fd stdout;
> +    close stdout_fd;
> +    dup2 stderr_fd stderr;
> +    close stderr_fd;
> +
> +    execvp prog argv
> +  );
> +
> +  (* Parent process. *)
> +  close stdin_fd;
> +  close stdout_fd;
> +  close stderr_fd;
> +  let _, status = waitpid [] pid in
> +  let r > +    match status with
> +    | WEXITED i -> i
> +    | WSIGNALED i ->
> +       failwithf "external command ‘%s’ killed by signal %d"
prog i
> +    | WSTOPPED i ->
> +       failwithf "external command ‘%s’ stopped by signal %d"
prog i in
> +
> +  if verbose () then
> +    eprintf "command: %s returned %d\n" prog r;
> +
> +  let stdout = read_whole_file stdout_file in
> +  let stderr = read_whole_file stderr_file in
> +
> +  if verbose () then (
> +    if stdout <> "" then (
> +      eprintf "command: %s: stdout:\n%s%!" prog stdout;
> +      if not (String.is_suffix stdout "\n") then eprintf
"\n%!"
> +    );
> +    if stderr <> "" then (
> +      eprintf "command: %s: stderr:\n%s%!" prog stderr;
> +      if not (String.is_suffix stderr "\n") then eprintf
"\n%!"
> +    )
> +  );
> +
> +  (* Strip trailing \n from stderr but NOT from stdout. *)
> +  let stderr > +    let n = String.length stderr in
> +    if n > 0 && stderr.[n-1] = '\n' then
> +      String.sub stderr 0 (n-1)
> +    else
> +      stderr in
This bit is already done in v2v/linux_bootloaders.ml, get_default_image
helper function; can you please move that to a chop function in
Std_utils?  Most probably it could be used in Common_utils.uuidgen as
well.

(Also, funny thing is that, while grepping for that, I noticed the C
equivalent is written in many places, all around daemon, library, and
tools...)
> +
> +  (r, stdout, stderr)
> +
> +let command prog args > +  let r, stdout, stderr = commandr prog args
in
> +  if r <> 0 then
> +    failwithf "%s exited with status %d: %s" prog r stderr;
> +  stdout
> +
> +let udev_settle ?filename () 
Ditto.
> +  let args = ref [] in
> +  if verbose () then
> +    push_back args "--debug";
> +  push_back args "settle";
> +  (match filename with
> +   | None -> ()
> +   | Some filename ->
> +      push_back args "-E";
> +      push_back args filename
> +  );
> +  let args = !args in
> +  let r, _, err = commandr "udevadm" args in
> +  if r <> 0 then
> +    eprintf "udevadm settle: %s\n" err
> +
> +let root_device = lazy ((stat "/").st_dev)
> +
> +let is_root_device_stat statbuf > +  statbuf.st_rdev = Lazy.force
root_device
> +
> +let is_root_device device > +  udev_settle ~filename:device ();
> +  try
> +    let statbuf = stat device in
> +    is_root_device_stat statbuf
> +  with
> +    Unix_error (err, func, arg) ->
> +      eprintf "is_root_device: %s: %s: %s: %s\n"
> +              device func arg (error_message err);
> +      false
> +
> +let proc_unmangle_path path > +  let n = String.length path in
> +  let b = Buffer.create n in
> +  let rec loop i > +    if i < n-3 && path.[i] =
'\\' then (
> +      let to_int c = Char.code c - Char.code '0' in
> +      let v > +        (to_int path.[i+1] lsl 6) lor
> +        (to_int path.[i+2] lsl 3) lor
> +        to_int path.[i+3] in
> +      Buffer.add_char b (Char.chr v);
> +      loop (i+4)
> +    )
> +    else if i < n then (
> +      Buffer.add_char b path.[i];
> +      loop (i+1)
> +    )
> +    else
> +      Buffer.contents b
> +  in
> +  loop 0
> +
> +let is_small_file path > +  is_regular_file path &&
> +    (stat path).st_size <= 2 * 1048 * 1024
There could be an helper function sysroot_path, to mimick the C
function with the same name, and simplify code like

  let mp = Sysroot.sysroot () // mountpoint in

into

  let mp = sysroot_path mountpoint in

-- 
Pino Toscano

On Wed, Jul 19, 2017 at 03:13:47PM +0200, Pino Toscano
wrote:
> On Friday, 14 July 2017 15:39:10 CEST Richard W.M. Jones wrote:
> >  .gitignore                 |   6 +-
> >  Makefile.am                |   2 +-
> >  common/mlutils/Makefile.am |   4 -
> >  daemon/Makefile.am         | 103 +++++++++++++++++++++++--
> >  daemon/chroot.ml           |  85 +++++++++++++++++++++
> >  daemon/chroot.mli          |  35 +++++++++
> >  daemon/daemon-c.c          |  35 +++++++++
> >  daemon/daemon.ml           |  39 ++++++++++
> >  daemon/guestfsd.c          |  50 ++++++++++++
> >  daemon/sysroot-c.c         |  37 +++++++++
> >  daemon/sysroot.ml          |  19 +++++
> >  daemon/sysroot.mli         |  22 ++++++
> >  daemon/utils.ml            | 156
+++++++++++++++++++++++++++++++++++++
> >  daemon/utils.mli           |  65 ++++++++++++++++
> 
> TBH I'd just have a single "Daemon" module for the OCaml
helpers for
> the daemon, instead of different modules, wirh a single -c.c file for
> all the C implementations.  The Sysroot submodule could be implemented
> like the various submodules in Unix_utils.
Do you mean Daemon.Chroot, Daemon.Sysroot etc?
> > +val f : t -> ('a -> 'b) -> 'a -> 'b
> > +(** Run a function in the chroot, returning the result or re-raising
> > +    any exception thrown. *)
> 
> After reading patch #11, IMHO there should be a variant that takes a
> generic (unit -> unit) function (called 'fn', maybe?), and have
'f'
> use it:
> 
>   let f t fun arg >     f (fun () -> fun arg)
I'm a bit confused, do you have a compilable example?
> > +/* Convert an OCaml exception to a reply_with_error_errno call
> > + * as best we can.
> > + */
> > +extern void ocaml_exn_to_reply_with_error (const char *func, value
exn);
> > +
> > +void
> > +ocaml_exn_to_reply_with_error (const char *func, value exn)
> > +{
> 
> Shouldn't this use CAMLparam1 + CAMLreturn?
It doesn't allocate on the OCaml heap so it should be safe.
> > +let udev_settle ?filename () > 
> Ditto.
‘Ditto’ means bind the C udev_settle_* functions?

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
virt-builder quickly builds VMs from scratch
http://libguestfs.org/virt-builder.1.html

On Wednesday, 19 July 2017 22:25:41 CEST Richard W.M. Jones
wrote:
> On Wed, Jul 19, 2017 at 03:13:47PM +0200, Pino Toscano wrote:
> > On Friday, 14 July 2017 15:39:10 CEST Richard W.M. Jones wrote:
> > >  .gitignore                 |   6 +-
> > >  Makefile.am                |   2 +-
> > >  common/mlutils/Makefile.am |   4 -
> > >  daemon/Makefile.am         | 103 +++++++++++++++++++++++--
> > >  daemon/chroot.ml           |  85 +++++++++++++++++++++
> > >  daemon/chroot.mli          |  35 +++++++++
> > >  daemon/daemon-c.c          |  35 +++++++++
> > >  daemon/daemon.ml           |  39 ++++++++++
> > >  daemon/guestfsd.c          |  50 ++++++++++++
> > >  daemon/sysroot-c.c         |  37 +++++++++
> > >  daemon/sysroot.ml          |  19 +++++
> > >  daemon/sysroot.mli         |  22 ++++++
> > >  daemon/utils.ml            | 156
+++++++++++++++++++++++++++++++++++++
> > >  daemon/utils.mli           |  65 ++++++++++++++++
> > 
> > TBH I'd just have a single "Daemon" module for the OCaml
helpers for
> > the daemon, instead of different modules, wirh a single -c.c file for
> > all the C implementations.  The Sysroot submodule could be implemented
> > like the various submodules in Unix_utils.
> 
> Do you mean Daemon.Chroot, Daemon.Sysroot etc?
Yes, exactly.
> > > +val f : t -> ('a -> 'b) -> 'a -> 'b
> > > +(** Run a function in the chroot, returning the result or
re-raising
> > > +    any exception thrown. *)
> > 
> > After reading patch #11, IMHO there should be a variant that takes a
> > generic (unit -> unit) function (called 'fn', maybe?), and
have 'f'
> > use it:
> > 
> >   let f t fun arg > >     f (fun () -> fun arg)
> 
> I'm a bit confused, do you have a compilable example?
Not really without rewriting all of it, but I can improve the snippets.

An interface like:
  val f : t -> ('a -> 'b) -> 'a -> 'b
  val fn : t -> (unit -> unit) -> 'a

With the implementation like:
  let f t func arg     fn (fun () -> func arg)
  let fn func     ...
      let ret         try Either (func ())
        with exn -> Or exn in

This way, when calling more more than a single-parameter function, it
is slightly easier to read (IMHO, of course):

  let res = Chroot.f chroot (fun () -> ...) in

than

  let res = Chroot.f chroot (fun () -> ...) () in

This is mostly syntactic sugar.
> > > +/* Convert an OCaml exception to a reply_with_error_errno call
> > > + * as best we can.
> > > + */
> > > +extern void ocaml_exn_to_reply_with_error (const char *func,
value exn);
> > > +
> > > +void
> > > +ocaml_exn_to_reply_with_error (const char *func, value exn)
> > > +{
> > 
> > Shouldn't this use CAMLparam1 + CAMLreturn?
> 
> It doesn't allocate on the OCaml heap so it should be safe.
> 
> > > +let udev_settle ?filename () > > 
> > Ditto.
> 
> ‘Ditto’ means bind the C udev_settle_* functions?
Yes, that's correct.

-- 
Pino Toscano