We didn’t get so far either time, but I’ve been taking a deeper look at CIL in an attempt to verify error handling in libguestfs.

Here is my partly working code so far.

(*
 * Analyse libguestfs APIs to find error overwriting.
 * Copyright (C) 2008-2013 Red Hat, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library.  If not, see
 * <http://www.gnu.org/licenses/>.
 *
 * Author: Daniel P. Berrange <berrange@redhat.com>
 * Author: Richard W.M. Jones <rjones@redhat.com>
 *)

open Unix
open Printf

open Cil

let debug = ref false

(* Set of ints. *)
module IntSet = Set.Make (struct type t = int let compare = compare end)

(* A module for storing any set (unordered list) of functions. *)
module FunctionSet = Set.Make (
  struct
    type t = varinfo
    let compare v1 v2 = compare v1.vid v2.vid
  end
)

(* Directed graph of functions.
 *
 * Function = a node in the graph
 * FunctionDigraph = the directed graph
 * FunctionPathChecker = path checker module using Dijkstra's algorithm
 *)
module Function =
struct
  type t = varinfo
  let compare f1 f2 = compare f1.vid f2.vid
  let hash f = Hashtbl.hash f.vid
  let equal f1 f2 = f1.vid = f2.vid
end
module FunctionDigraph = Graph.Imperative.Digraph.Concrete (Function)
module FunctionPathChecker = Graph.Path.Check (FunctionDigraph)

(* Module used to analyze the paths through each function. *)
module ErrorCounter =
struct
  let name = "ErrorCounter"
  let debug = debug

  (* Our current state is very simple, just the number of error
   * function calls did encountered up to this statement.
   *)
  type t = int

  let copy errcalls = errcalls

  (* Start data for each statement. *)
  let stmtStartData = Inthash.create 97

  let printable errcalls = sprintf "(errcalls=%d)" errcalls

  let pretty () t = Pretty.text (printable t)

  let computeFirstPredecessor stmt x = x (* XXX??? *)

  let combinePredecessors stmt ~old:old_t new_t =
    if old_t = new_t then None
    else Some new_t

  (* This will be initialized after we have calculated the set of all
   * functions which can call an error function, in main() below.
   *)
  let error_functions_set = ref FunctionSet.empty

  (* Handle a Cil.Instr. *)
  let doInstr instr _ =
    match instr with
    (* A call to an error function. *)
    | Call (_, Lval (Var callee, _), _, _)
        when FunctionSet.mem callee !error_functions_set ->
      Dataflow.Post (fun errcalls -> errcalls+1)

    | _ -> Dataflow.Default

  (* Handle a Cil.Stmt. *)
  let doStmt _ _ = Dataflow.SDefault

  (* Handle a Cil.Guard. *)
  let doGuard _ _ = Dataflow.GDefault

  (* Filter statements we've seen already to prevent loops. *)
  let filter_set = ref IntSet.empty
  let filterStmt { sid = sid } =
    if IntSet.mem sid !filter_set then false
    else (
      filter_set := IntSet.add sid !filter_set;
      true
    )

  (* Initialize the module before each function that we examine. *)
  let init stmts =
    filter_set := IntSet.empty;
    Inthash.clear stmtStartData;
    (* Add the initial statement(s) to the hash. *)
    List.iter (fun stmt -> Inthash.add stmtStartData stmt.sid 0) stmts
end

module ForwardsErrorCounter = Dataflow.ForwardsDataFlow (ErrorCounter)

(* The always useful filter + map function. *)
let rec filter_map f = function
  | [] -> []
  | x :: xs ->
      match f x with
      | Some y -> y :: filter_map f xs
      | None -> filter_map f xs

let rec main () =
  (* Read the list of input C files. *)
  let files =
    let chan = open_process_in "find src -name '*.i' | sort" in
    let files = input_chan chan in
    if close_process_in chan <> WEXITED 0 then
      failwith "failed to read input list of files";
    if files = [] then
      failwith "no input files; is the program running from the top directory? did you compile with make -C src CFLAGS=\"-save-temps\"?";
    files in

  (* Load and parse each input file. *)
  let files =
    List.map (
      fun filename ->
        printf "loading %s\n%!" filename;
        Frontc.parse filename ()
    ) files in

  (* Merge the files. *)
  printf "merging files\n%!";
  let sourcecode = Mergecil.merge files "libguestfs" in

  (* CFG analysis. *)
  printf "computing control flow\n%!";
  Cfg.computeFileCFG sourcecode;

  let functions =
    filter_map (function GFun (f, loc) -> Some (f, loc) | _ -> None)
      sourcecode.globals in

  (* Examine which functions directly call which other functions. *)
  printf "computing call graph\n%!";
  let call_graph = make_call_graph functions in
  (*
  FunctionDigraph.iter_edges (
    fun caller callee ->
      printf "%s calls %s\n" caller.vname callee.vname
  ) call_graph;
  *)

  (* The libguestfs error functions.  These are global function names,
   * but to be any use to us we have to look these up in the list of
   * all global functions (ie. 'functions') and turn them into the
   * corresponding varinfo structures.
   *)
  let error_function_names = [ "guestfs_error_errno";
                               "guestfs_perrorf" ] in

  let find_function name =
    try List.find (fun ({ svar = { vname = n }}, _) -> n = name) functions
    with Not_found -> failwith ("function '" ^ name ^ "' does not exist")
  in
  let error_function_names = List.map (
    fun f -> (fst (find_function f)).svar
  ) error_function_names in

  (* Get a list of functions that might (directly or indirectly) call
   * one of the error functions.
   *)
  let error_functions, non_error_functions =
    functions_which_call call_graph error_function_names functions in

  (*
  List.iter (
    fun f -> printf "%s can call an error function\n" f.vname
  ) error_functions;

  List.iter (
    fun f -> printf "%s can NOT call an error function\n" f.vname
  ) non_error_functions;
  *)

  (* Save the list of error functions in a global set for fast lookups. *)
  let set =
    List.fold_left (
      fun set elt -> FunctionSet.add elt set
    ) FunctionSet.empty error_functions in
  ErrorCounter.error_functions_set := set;

  (* Analyze each top-level function to ensure it calls an error
   * function exactly once on error paths, and never on normal return
   * paths.
   *)
  printf "analyzing correctness of error paths\n%!";
  List.iter compute_error_paths functions;

  ()

(* Make a directed graph of which functions directly call which other
 * functions.
 *)
and make_call_graph functions =
  let graph = FunctionDigraph.create () in

  List.iter (
    fun ({ svar = caller; sallstmts = sallstmts }, _) ->
      (* Evaluate which other functions 'caller' calls.  First pull
       * out every 'Call' instruction anywhere in the function.
       *)
      let insns =  List.concat (
        filter_map (
          function
          | { skind = Instr insns } -> Some insns
          | _ -> None
        ) sallstmts
      ) in
      let calls = List.filter (function Call _ -> true | _ -> false) insns in
      (* Then examine what function is being called at each place. *)
      let callees = filter_map (
        function
        | Call (_, Lval (Var callee, _), _, _) -> Some callee
        | _ -> None
      ) calls in

      List.iter (
        fun callee ->
          FunctionDigraph.add_edge graph caller callee
      ) callees
  ) functions;

  graph

(* [functions_which_call g endpoints functions] partitions the
 * [functions] list, returning those functions that call directly or
 * indirectly one of the functions in [endpoints], and a separate list
 * of functions which do not.  [g] is the direct call graph.
 *)
and functions_which_call g endpoints functions =
  let functions = List.map (fun ({ svar = svar }, _) -> svar) functions in

  let checker = FunctionPathChecker.create g in
  List.partition (
    fun f ->
      (* Does a path exist from f to any of the endpoints? *)
      List.exists (
        fun endpoint ->
          try FunctionPathChecker.check_path checker f endpoint
          with
          (* It appears safe to ignore this exception.  It seems to
           * mean that this function is in a part of the graph which
           * is completely disconnected from the other part of the graph
           * that contains the endpoint.
           *)
          | Invalid_argument "[ocamlgraph] iter_succ" -> false
      ) endpoints
  ) functions

and compute_error_paths ({ svar = svar } as f, loc) =
  (*ErrorCounter.debug := true;*)

  (* Find the initial statement in this function (assumes that the
   * function can only be entered in one place, which is normal for C
   * functions).
   *)
  let initial_stmts =
    match f.sbody.bstmts with
    | [] -> []
    | first::_ -> [first] in

  (* Initialize ErrorCounter. *)
  ErrorCounter.init initial_stmts;

  (* Compute the error counters along paths through the function. *)
  ForwardsErrorCounter.compute initial_stmts;

  (* Process all Return statements in this function. *)
  List.iter (
    fun stmt ->
      try
        let errcalls = Inthash.find ErrorCounter.stmtStartData stmt.sid in

        match stmt with
        (* return -1; *)
        | { skind = Return (Some i, loc) } when is_literal_minus_one i ->
          if errcalls = 0 then
            printf "%s:%d: %s: may return an error code without calling error/perrorf\n"
              loc.file loc.line svar.vname
          else if errcalls > 1 then
            printf "%s:%d: %s: may call error/perrorf %d times (more than once) along an error path\n"
          loc.file loc.line svar.vname errcalls

        (* return 0; *)
        | { skind = Return (Some i, loc) } when is_literal_zero i ->
          if errcalls >= 1 then
            printf "%s:%d: %s: may call error/perrorf along a non-error return path\n"
              loc.file loc.line svar.vname

        (* return; (void return) *)
        | { skind = Return (None, loc) } ->
          if errcalls >= 1 then
            printf "%s:%d: %s: may call error/perrorf and return void\n"
              loc.file loc.line svar.vname

        | _ -> ()

      with
        Not_found ->
          printf "%s:%d: %s: may contain unreachable code\n"
            loc.file loc.line svar.vname
  ) f.sallstmts

(* Some convenience CIL matching functions. *)
and is_literal_minus_one = function
  | Const (CInt64 (-1L, _, _)) -> true
  | _ -> false

and is_literal_zero = function
  | Const (CInt64 (0L, _, _)) -> true
  | _ -> false

(* Convenient routine to load the contents of a channel into a list of
 * strings.
 *)
and input_chan chan =
  let lines = ref [] in
  try while true; do lines := input_line chan :: !lines done; []
  with End_of_file -> List.rev !lines

and input_file filename =
  let chan = open_in filename in
  let r = input_chan chan in
  close_in chan;
  r

let () =
  try main ()
  with 
    exn ->
      prerr_endline (Printexc.to_string exn);
      Printexc.print_backtrace Pervasives.stderr;
      exit 1

In other OCaml news, the various “retired” code generators (PPC64, MIPS, IA64, HPPA, Alpha) now have their own repository. Who wants to volunteer to write an s/390x code generator?

I’m intending to submit a talk on using OCaml for code generation in libguestfs.

Firstly, while it’s a nice feature of whenjobs that I can set variables, sometimes I don’t want jobs to be triggered as a result of setting variables. The new whenjobs --whisper command lets me set variables without reevaluating when-clauses:

$ whenjobs --whisper libguestfs_version=1.17.16

Secondly, my jobs file was getting pretty long and unmaintainable (400 lines), since I added various libguestfs branches and hivex to be managed by whenjobs. So I’ve added a feature where you can split the jobs file into multiple files:

$ ls -l .whenjobs/*.ml
-rw-rw-r--. 1 rjones rjones 3284 Mar 13 19:10 .whenjobs/jobs_hivex.ml
-rw-rw-r--. 1 rjones rjones 4039 Mar 13 19:07 .whenjobs/jobs_libguestfs.ml
-rw-rw-r--. 1 rjones rjones 3766 Mar 13 19:09 .whenjobs/jobs_libguestfs_stable.ml
-rw-rw-r--. 1 rjones rjones   45 Mar 13 19:10 .whenjobs/jobs.ml

I think I described whenjobs as a “cron replacement”. It is a cron replacement for me, for my personal use, but it’s not officially a cron replacement and this project has nothing whatsoever to do with Red Hat or Fedora. The reason I say this is I get some pretty idiotic comments like these.

$ whenjobs --jobs
61 job$1
	running in: /tmp/whenjobs20d88a48f2c4eb0062e1b44ded6d0ae7
	started at: 2012-02-23 22:43:20
62 job$2
	running in: /tmp/whenjobse9e6b93c3ced1967cbf8c5865d6a1ccb
	started at: 2012-02-23 22:43:20
$ whenjobs --cancel 62

You can manually start jobs. Gerd’s ocamlnet makes it almost trivial to add new RPCs between the tool and the daemon, so adding functions like this is simple.

You can put arbitrary OCaml actions into the job script too, so you can run code when a job is cleaned up, and you will (soon) be able to create jobs algorithmically. For example, the standard mailto cleanup lets you send mail containing the output of the job when it finishes.

let from = "me@example.com"
let to_addr = "you@example.com"
let prefix = "hostname "
let script = << # shell script here >>

job (prefix ^ "poll")
cleanup (Whentools.mailto ~from to_addr)
every minute : script

Whenjobs is a powerful but simple replacement for cron. It lets you run jobs periodically like cron, but it also lets you trigger jobs to run when user-defined variables are set or change value.

Periodic jobs are written like this:

every 10 minutes :
<<
  # Get the current load average.
  load=`awk '{print $1}' /proc/loadavg`
  whenjobs --set load $load --type float
>>

When-statements let you create jobs that run based on variables set elsewhere:

when load >= 6 :
<<
  mail -s "ALERT: high load average: $load" $LOGNAME < /dev/null
>>

(When statements are "edge-triggered", meaning that this job will only run when the load goes from under 6 to ≥ 6).

The motivation is building things from git automatically. Here is another job script:

Every 10 minutes, get the latest tagged version from the git repository. The variable ‘version’ will be set to something like “v1.2.3″, “v1.2.4″, etc over time as new releases get tagged.

every 10 minutes :
<<
  cd /my/git/repo
  tag=`git-describe --tags`
  whenjobs --set version $tag
>>

When the ‘version’ variable changes (ie. a new release is tagged) try to build it. ‘changes’ is a function that compares the previous value of a variable from when this job last ran with the current value of a variable, and returns true if the previous and current values are different.

when changes version :
<<
  cd /my/git/buildrepo
  git pull
  git reset --hard $version
  ./configure
  make clean all check dist
  whenjobs --set successful_local_build $version
>>

In parallel, build on a remote machine.

when changes version :
<<
  ssh remote ./do_build $version
  whenjobs --set successful_remote_build $version
>>

Only when the new release has been successfully built on local and remote, upload it to the website.

when successful_local_build == version &&
     successful_remote_build == version :
<<
  cd /my/git/buildrepo
  curl -T name-$success.tar.gz ftp://ftp.example.com/upload/
>>

Note: There is source that goes with this. Download libguestfs-1.13.13.tar.gz and look in the respective directories.

The best

It’s going to be a controversial choice, but in my opinion: C#. You just add some simple annotations to your functions and structs, and you can call into shared libraries (or “DllImport”s as Microsoft insisted on calling them) directly. It’s just about as easy as directly calling C and that is no simple achievement considering how the underlying runtime of C# is very different from C.

Example: a C struct:

[StructLayout (LayoutKind.Sequential)]
public class _int_bool {
  int i;
  int b;
}

The worst

There are two languages in the doghouse: Haskell and PHP. PHP first because their method of binding is just very broken. For example, 64 bit types aren’t possible on a 32 bit platform. It requires a very complex autoconf setup. And the quality of their implementation is very poor verging on broken — it makes me wonder if the rest of PHP can be this bad.

Haskell: even though I’m an experienced functional programmer and have done a fair bit of Haskell programming in the past, the FFI is deeply strange and very poorly documented. I simply could not work out how to return anything other than integers from my functions. You end up with bindings that look like this:

write_file h path content size = do
  r <- withCString path $ \path -> withCString content $ \content -> withForeignPtr h (\p -> c_write_file p path content (fromIntegral size))
  if (r == -1)
    then do
      err <- last_error h
      fail err
    else return ()

The middle tier

There’s not a lot to choose between OCaml, Ruby, Java and Erlang. For all of them: you write bindings in C, there’s good documentation, it’s a bit tedious but basically mechanical, and in 3 out of 4 you’re dealing with a reasonable garbage collector so you have to be aware of GC issues.

Erlang is slightly peculiar because the method I chose (out of many possible) is to write an external process that talks to the Erlang over stdin/stdout. But I can’t fault their documentation, and the rest of it is sensible.

Example: Here is a function binding in OCaml, but with mechanical changes this could be Ruby, Java or Erlang too:

CAMLprim value
ocaml_guestfs_add_drive_ro (value gv, value filenamev)
{
  CAMLparam2 (gv, filenamev);
  CAMLlocal1 (rv);

  guestfs_h *g = Guestfs_val (gv);
  if (g == NULL)
    ocaml_guestfs_raise_closed ("add_drive_ro");

  char *filename = guestfs_safe_strdup (g, String_val (filenamev));
  int r;

  caml_enter_blocking_section ();
  r = guestfs_add_drive_ro (g, filename);
  caml_leave_blocking_section ();
  free (filename);
  if (r == -1)
    ocaml_guestfs_raise_error (g, "add_drive_ro");

  rv = Val_unit;
  CAMLreturn (rv);
}

The ugly

Perl: Get reading. You’d better start with perlxs because Perl uses its own language — C with bizarre macros on top so your code looks like this:

SV *
is_config (g)
      guestfs_h *g;
PREINIT:
      int r;
   CODE:
      r = guestfs_is_config (g);
      if (r == -1)
        croak ("%s", guestfs_last_error (g));
      RETVAL = newSViv (r);
 OUTPUT:
      RETVAL

After that, get familiar with perlguts. Perl has only 3 structures and you’ll be using them a lot. There are some brilliant things about Perl which shouldn’t be overlooked, including POD which libguestfs uses to make effortless manual pages.

Python: Best described as half arsed. Rather like the language itself.

Python, Ruby, Erlang: If your language depends on “int”, “long”, “long long” without defining what those mean, and differing based on your C compiler and platform, then you’ve made a big mistake that will unfortunately dog you throughout the runtime, FFIs and the language itself. It’s better either to define them precisely (like Java) or to just use int32 and int64 (like OCaml).

And finally, reference counting (Perl, Python). It’s tremendously easy to make mistakes that are fiendishly difficult to track down. It’s a poor way to do GC and it indicates to me that the language designer didn’t know any better.

The good:

• It works.
• OCaml and Python programs can talk to each other.
• It works across remote hosts. You need to open port 5672/tcp on the firewall.

The bad:

• RabbitMQ and Apache Qpid use different versions of AMQP and are not interoperable! Good summary of the mess here. This might be resolved when everyone gets around to supporting AMQP 1-0, but even though that standard has been published, no one is expecting interop to happen for at least a year.
• You can’t cluster different versions of the RabbitMQ broker together.
• Even if all your hosts are at the same RabbitMQ version, you have to open more firewall ports and make changes to the start-up scripts. (Dynamic ports? Really? Did we learn nothing from NFS?)
• Long, obscure Erlang error messages which don’t point to the problem. eg. You’ll get a good 25 lines of error message if another process is already bound to a port.
• Possibly just a Fedora packaging problem: I managed to get my host into some state where it’s impossible to stop the RabbitMQ server except by kill -9, and after that I can’t start or stop it.

After two days, I nearly have the first tab (out of four) working.

Granted, maybe the first tab is the hardest one:

The job of the first tab is to ask the user for the source (disk image or libvirt guest). It then fires off a background job to open that guest and inspect it for operating systems. Based on the outcome of that (opened OK, found OSes, no OSes found, etc) it has to update and enable the other tabs.

Also the user can preselect a guest on the command line. We also have to deal with connecting to libvirt asynchronously to read the list of guests (and this might also fail in a number of ways).

So far, 1600 lines of code, and the first tab is by no means complete.

One part of the problem is there’s a certain “impedance mismatch” between functional programming in OCaml and writing Gtk. Gtk is heavily mutable and object based. OCaml prefers (but does not require) immutability, and objects in OCaml are obscure and not widely used, and the Gtk bindings are written in a very hard-core object OCaml style.

Another part is just that it’s tedious. It would be tedious if I was doing this in C or Python too. You’ve got asynchronous actions going off here and there which update bits of state. Every control or input could potentially affect every other control or output, resulting in a kind of O(n²) mess of wiring up signals and callbacks.

Is there an easier way? I don’t know …

If you want to call libguestfs from Perl, you have to use Sys::Guestfs.

All 300+ libguestfs API calls are available to all language bindings equally because we generate the bindings.

One remaining issue with packrat parsers is that they don’t natively support left recursion, making it hard to translate yacc-style parsers. However a couple of years ago an interesting paper was published, Packrat Parsers Can Support Left Recursion (PDF) which shows how to modify the memoization to support left recursion.

This really works, but unfortunately the pseudocode used in the paper is obscure and it’s hard to find example code, so I implemented this packrat parser with support for left recursion in OCaml.

Compile with:

$ ocamlfind opt -package extlib -linkpkg \
    testparse.ml -o testparse

and run it like this:

$ cat input
( fun a -> a + 1 ) (a + b)
$ ./testparse < input

open Printf

type grammar = production list
and production = string * choice list   (* rule name -> e1 | e2 | ... *)
and choice = string * string * parsing list (* choice name, comment, sequence *)
and parsing =
  | Z of parsing                        (* e* *)
  | P of parsing                        (* e+ *)
  | Opt of parsing                      (* e? *)
(*  | Lookahead of parsing                (* &e *)
  | Not of parsing                      (* !e *) *)
  | NT of string                        (* nonterminal 'name' *)
  | T of string                         (* terminal *)
  | Chars of char * char                (* [a-z] *)
  | Empty                               (* epsilon *)

let grammar : grammar = [
  (*
    start -> expr
  *)
  "start", [
    "", "", [NT "expr"]
  ];

  (*
    expr ->
          | expr expr
          | "fun" patt "->" expr = "fundecl" ; function
          | "(" expr ")"
          | expr "+" expr
          | ident
          | int64
  *)
  "expr", [
    "funappl", "", [NT"expr"; NT"sp"; NT"expr"];
    "fundecl", "function declaration",
      [T"fun"; NT"sp"; NT"patt"; NT"osp"; T"->"; NT"sp"; NT"expr"];
    "paren", "", [T"("; NT"osp"; NT"expr"; NT"osp"; T")"];
    "addition", "", [NT"expr"; NT"osp"; T"+"; NT"osp"; NT"expr"];
    "ident", "", [NT"ident"];
    "int64", "", [NT"int64"];
  ];

  (*
    patt -> ident
  *)
  "patt", [
    "", "", [NT "ident"]
  ];

  (*
    int64 -> digit19 digit*
           | digit
    digit -> [0-9]
    digit19 -> [1-9]
  *)
  "int64", [
    (*"", "", [NT"digit19"; Z(NT"digit")]; XXX *)
    "", "", [NT"digit"];
  ];
  "digit", [
    "", "", [Chars ('0', '9')];
  ];
  "digit19", [
    "", "", [Chars ('1', '9')];
  ];

  (*
    ident -> alpha+
    alpha -> [a-z]
  *)
  "ident", [
    "", "", [P (NT"alpha")];
  ];
  "alpha", [
    "", "", [Chars ('a', 'z')];
  ];

  (*
    sp -> " "+
    osp -> " "*
  *)
  "sp", [
    "", "", [P (T" ")];
  ];
  "osp", [
    "", "", [Z (T" ")];
  ];
]

let initial_state = "start"

(* To support backtracking, need to read all input. *)
let input =
  let lines = ref [] in
  (try
     while true do
       lines := read_line () :: !lines
     done
   with
     End_of_file -> ()
  );
  let lines = List.rev !lines in
  String.concat " " lines

let len = String.length input

(* Parser.
 * Packrat parser with left recursion, see:
 * "Packrat Parsers Can Support Left Recursion"
 * Alessandro Warth, James R. Douglass, Todd Millstein
 *)
module StringSet = Set.Make (String)
exception Found of int

type lr = {
  mutable seed : ans;
  mutable rulename : string;
  mutable head : head option;
}
and memoentry = { mutable ans : ans_or_lr; mutable pos : int }
and ans_or_lr = Answer of ans | LR of lr
and ans = int
and head = {
  mutable hrule : string;
  mutable involved_set : StringSet.t;
  mutable eval_set : StringSet.t;
}

let lrstack = ref []
let memo = Hashtbl.create 13
let pos = ref 0
let heads = Hashtbl.create 13

(* Apply rule 'rulename' at position 'i' in the input.  Returns the new
 * position if the rule can be applied, else -1 if fails.
 *)
let rec apply_rule rulename i =
  match recall rulename i with
  | None ->
      let lr = { seed = -1; rulename = rulename; head = None } in
      lrstack := lr :: !lrstack;
      let m = { ans = LR lr; pos = i } in
      Hashtbl.add memo (rulename, i) m;
      let r = parse rulename i in
      lrstack := List.tl !lrstack;
      m.pos <- !pos;
      if lr.head <> None then (
        lr.seed <- r;
        lr_answer rulename i m
      ) else (
        m.ans <- Answer r;
        r
      )
  | Some m ->
      pos := m.pos;
      match m.ans with
      | LR lr -> setup_lr rulename lr; lr.seed
      | Answer r -> r

and setup_lr rulename lr =
  if lr.head = None then
    lr.head <- Some { hrule = rulename;
                      involved_set = StringSet.empty;
                      eval_set = StringSet.empty };
  let lr_head = Option.get lr.head in
  let rec loop = function
    | [] -> assert false
    | l::_ when l.head = Some lr_head -> ()
    | l::ls ->
        l.head <- Some lr_head;
        lr_head.involved_set <- StringSet.add l.rulename lr_head.involved_set;
        loop ls
  in
  loop !lrstack

and lr_answer rulename i m =
  let lr = match m.ans with
    | Answer _ -> assert false
    | LR lr -> lr in
  let h = match lr.head with
    | None -> assert false
    | Some h -> h in
  if h.hrule <> rulename then
    lr.seed
  else (
    m.ans <- Answer lr.seed;
    if lr.seed = -1 then -1
    else grow_lr rulename i m h
  )

and recall rulename i =
  let m = try Some (Hashtbl.find memo (rulename, i)) with Not_found -> None in
  let h = try Some (Hashtbl.find heads i) with Not_found -> None in
  match h with
  | None -> m
  | Some h ->
      if m = None && not (StringSet.mem rulename
                            (StringSet.add h.hrule h.involved_set)) then
        Some { ans = Answer (-1); pos = i }
      else (
        if StringSet.mem rulename h.eval_set then (
          h.eval_set <- StringSet.remove rulename h.eval_set;
          let r = parse rulename i in
          (* Original paper RECALL function seems to have a bug ... *)
          let m = Option.get m in
          m.ans <- Answer r;
          m.pos <- !pos
        );
        m
      )

and grow_lr rulename i m h =
  Hashtbl.replace heads i h; (* A *)
  let rec loop () =
    pos := i;
    h.eval_set <- h.involved_set; (* B *)
    let ans = parse rulename i in
    if ans = -1 || !pos <= m.pos then ()
    else (
      m.ans <- Answer ans;
      m.pos <- !pos;
      loop ()
    )
  in
  loop ();
  Hashtbl.remove heads i; (* C *)
  pos := m.pos;
  match m.ans with
  | Answer r -> r
  | LR _ -> assert false

and parse rulename i =
  printf "parse %s %d\n" rulename i;
  let choices =
    try List.assoc rulename grammar
    with Not_found ->
      eprintf "error in grammar: unknown rulename '%s'\n" rulename;
      exit 1 in
  (* Try each choice in turn until one matches. *)
  try
    List.iter (
      fun (name, comment, rs) ->
        printf "parse %s \"%s\" %d\n" rulename name i;
        let rec loop i = function
          | Empty :: rest ->
              loop i rest
          | NT n :: rest ->
              let i' = apply_rule n i in
              if i' >= i then loop i' rest else (-1)
          | T str :: rest ->
              let slen = String.length str in
              if i + slen > len then (-1)
              else (
                let sub = String.sub input i slen in
                if sub = str then loop (i+slen) rest
                else (-1)
              )
          | Chars (c1, c2) :: rest ->
              if i >= len then (-1)
              else if input.[i] >= c1 && input.[i] <= c2 then
                loop (i+1) rest
              else (-1)
          | Z subr :: rest ->
              let i' = greedy 0 None subr i in
              if i' >= i then loop i' rest else (-1)
          | P subr :: rest ->
              let i' = greedy 1 None subr i in
              if i' >= i then loop i' rest else (-1)
          | Opt subr :: rest ->
              let i' = greedy 0 (Some 1) subr i in
              if i' >= i then loop i' rest else (-1)
          | [] -> i
        and greedy min max subr i = (* implements e* e+ e? *)
          printf "greedy %d %s %d\n" min
            (match max with None -> "None" | Some n -> sprintf "Some %d" n)
            i;
          match max with
          | Some 0 -> i
          | _ ->
              if min > 0 then (
                (* we must match at least min or fail *)
                let i' = loop i [subr] in
                if i' >= i then greedy (min-1) max subr i'
                else (-1)
              ) else (
                (* try matching, doesn't matter if we fail *)
                let i' = loop i [subr] in
                if i' >= i then (
                  let max =
                    match max with None -> None | Some n -> Some (n-1) in
                  greedy 0 max subr i'
                )
                else i (* don't fail, return longest match *)
              )
        in
        let i' = loop i rs in
        if i' >= i then (
          printf "match %s \"%s\" [%d..%d]\n" rulename name i (i'-1);
          raise (Found i')
        )
    ) choices;
    (-1)
  with
    Found i -> i

let () =
  let i = apply_rule initial_state 0 in
  if i = -1 then (
    eprintf "parse error: parsing failed\n";
    exit 1
  )
  else if i < len then (
    eprintf "parse error: extra characters after end of input\n";
    exit 1
  )
  else
    printf "parsed OK\n"

What you do is call guestfs_mountpoints which returns a hash of device name to mount point, eg:

/dev/sda1 -> /boot
/dev/sda2 -> /
/dev/sda3 -> /usr

Then compare the pathname (“/boot/grub”) to each entry in the hash. If the mountpoint is a string prefix of the path, give this entry a score which is the length of the mountpoint string. If it is not a prefix, give the entry a score 0. So:

/dev/sda1 -> /boot (score: 5)
/dev/sda2 -> / (score: 1)
/dev/sda3 -> /usr (score: 0)

Then sort the entries to pick the highest score. If the hash is empty or the highest score is 0, then return an error, otherwise return the device with the highest score.

Here is the code to implement this in OCaml:

open Printf
open ExtString
open ExtList

let get_mounted_device g path =
  let mps = g#mountpoints () in
  let mps = List.map (
    fun (dev, mp) ->
      if String.starts_with path mp then
        dev, String.length mp
      else
        dev, 0
  ) mps in
  let cmp (_,n1) (_,n2) = compare n2 n1 in
  let mps = List.sort ~cmp mps in
  match mps with
  | [] ->
      invalid_arg (sprintf "%s: not mounted" path)
  | (_,0) :: _ ->
      invalid_arg (sprintf "%s: not found on any filesystem" path)
  | (dev,_) :: _ -> dev

To answer the question “is this directory mounted on ext4?” you would then call guestfs_vfs_type on the result of this, eg:

if g#vfs_type (get_mounted_device g "/boot/grub") = "ext4" then
  (* do something based on ext4 *)

You can now browse into the Registry on Windows guests:

# chmod +x findsuid.ml
# ./findsuid.ml RHEL60
/dev/vg_rhel6brewx64/lv_root:/sbin/mount.nfs is setuid file
/dev/vg_rhel6brewx64/lv_root:/sbin/netreport is setgid file
/dev/vg_rhel6brewx64/lv_root:/sbin/pam_timestamp_check is setuid file
/dev/vg_rhel6brewx64/lv_root:/sbin/unix_chkpwd is setuid file
/dev/vg_rhel6brewx64/lv_root:/usr/bin/Xorg is setuid file
/dev/vg_rhel6brewx64/lv_root:/usr/bin/at is setuid file
/dev/vg_rhel6brewx64/lv_root:/usr/bin/chage is setuid file
/dev/vg_rhel6brewx64/lv_root:/usr/bin/chfn is setuid file
/dev/vg_rhel6brewx64/lv_root:/usr/bin/chsh is setuid file
etc

You could make simple adaptions to this script to audit for all sorts of things of interest: public writeable directories, unusual SELinux labels, hard links to setuid files, over-sized files. With more work you could look for files with unusual/changed checksums, infected files and so on.

#!/usr/bin/ocamlrun /usr/bin/ocaml
#load "unix.cma";;
#directory "+guestfs";;
#load "mlguestfs.cma";;

open Printf

let (//) = Filename.concat

let () =
  let prog = Filename.basename Sys.executable_name in
  if Array.length Sys.argv < 2 then (
    eprintf "Usage: %s guest\n" prog;
    exit 1
  );

  (* Open guest domain. *)
  let g = new Guestfs.guestfs () in
  ignore (g#add_domain ~readonly:true Sys.argv.(1));
  g#launch ();

  (* If VMs could be encrypted you would have to
   * add additional calls to luks* here.
   * See fish/inspect.c:inspect_do_decrypt()
   *)

  (* Useful functions to test file types.  Note
   * can't use the regular stat functions, because
   * these modes are the ones defined in the Linux
   * ABI, not the host OS.
   *)
  let rec file_type mask mode =
    Int64.logand mode 0o170000L = mask
  (*and is_socket mode =
    file_type 0o140000L mode
  and is_symlink mode =
    file_type 0o120000L mode*)
  and is_regular_file mode =
    file_type 0o100000L mode
  (*and is_block mode =
    file_type 0o060000L mode*)
  and is_directory mode =
    file_type 0o040000L mode
  (*and is_char mode =
    file_type 0o020000L mode
  and is_fifo mode =
    file_type 0o010000L mode*)

  and is_suid mode = test_bit 0o4000L mode
  and is_sgid mode = test_bit 0o2000L mode
  (*and is_svtx mode = test_bit 0o1000L mode*)

  and test_bit mask mode =
    Int64.logand mode mask = mask
  in

  (* Visit each file in the mounted filesystem.
   * TODO: Add libguestfs APIs to make this simpler
   * and faster.
   *)
  let rec visit f dir =
    let names = g#ls dir in
    let stats = lstatlist dir names in
    let entries = List.combine (Array.to_list names) stats in
    List.iter (f dir) entries;
    let dirs = List.filter entry_is_dir entries in
    List.iter (
      fun (name, stat) ->
        visit f (dir // name)
    ) dirs
  and entry_is_dir (_, { Guestfs.mode = mode }) =
    is_directory mode
  and lstatlist dir = function
    | [| |] -> []
    | names ->
        (* Split large requests so we don't overrun
         * the libguestfs protocol limit.
         *)
        let len = Array.length names in
        let first, rest =
          if len <= 1000 then names, [| |]
          else (
            Array.sub names 0 1000,
            Array.sub names 1000 (len-1000)
          ) in
        let stats = g#lstatlist dir first in
        Array.to_list stats @ lstatlist dir rest
  in

  (* Test each file, printing those that match
   * the criteria.
   *)
  let search dev dir (name, { Guestfs.mode = mode }) =
    if is_regular_file mode && is_suid mode then
      printf "%s:%s is setuid file\n%!" dev (dir // name)
    else if is_regular_file mode && is_sgid mode then
      printf "%s:%s is setgid file\n%!" dev (dir // name)
  in

  (* Search every mountable filesystem. *)
  let fses = g#list_filesystems () in
  List.iter (
    fun (dev, _) ->
      g#umount_all ();
      let mounted_ok =
        try g#mount_ro dev "/"; true
        with exn -> false in
      if mounted_ok then
        visit (search dev) "/"
  ) fses

1. C/C++ example
2. OCaml example
3. Python example
4. Ruby example