From 82782363b8ca90744d7aedde6fe28618a88e2956 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Sun, 27 Oct 2019 20:46:07 +0100
Subject: [PATCH] Vmm_unix.check_commands : unit -> (unit, [> `Msg of string ])
 result - which  checks (platform-dependent) all required executables
 Vmm_unix.prepare/exec execute solo5-{spt/hvt} depending on the image type 
 (solo5-elftool figures that out), use jsonm to parse output Vmm_unix: use ip
 on linux, no longer ifconfig

---
 albatross.opam       |  1 +
 daemon/albatrossd.ml |  2 ++
 src/dune             |  4 +--
 src/vmm_json.ml      | 38 ++++++++++++++++++++
 src/vmm_unix.ml      | 84 ++++++++++++++++++++++++++++++++++----------
 src/vmm_unix.mli     |  2 ++
 6 files changed, 110 insertions(+), 21 deletions(-)
 create mode 100644 src/vmm_json.ml

diff --git a/albatross.opam b/albatross.opam
index 7965076..ad96a3c 100644
--- a/albatross.opam
+++ b/albatross.opam
@@ -19,6 +19,7 @@ depends: [
   "cmdliner" {>= "1.0.0"}
   "fmt"
   "astring"
+  "jsonm"
   "x509" {>= "0.8.0"}
   "tls" {>= "0.9.0"}
   "nocrypto"
diff --git a/daemon/albatrossd.ml b/daemon/albatrossd.ml
index a798877..58bca9d 100644
--- a/daemon/albatrossd.ml
+++ b/daemon/albatrossd.ml
@@ -147,6 +147,8 @@ let m = conn_metrics "unix"
 
 let jump _ influx =
   Sys.(set_signal sigpipe Signal_ignore);
+  Rresult.R.error_msg_to_invalid_arg
+    (Vmm_unix.check_commands ());
   match Vmm_vmmd.restore_unikernels () with
   | Error (`Msg msg) -> Logs.err (fun m -> m "bailing out: %s" msg)
   | Ok old_unikernels ->
diff --git a/src/dune b/src/dune
index e8f2ec0..0c6bda0 100644
--- a/src/dune
+++ b/src/dune
@@ -2,5 +2,5 @@
   (name albatross)
   (public_name albatross)
   (wrapped false)
-  (libraries rresult logs ipaddr bos hex ptime astring duration cstruct
-             decompress lwt lwt.unix ptime.clock.os asn1-combinators metrics))
\ No newline at end of file
+  (libraries rresult logs ipaddr bos hex ptime astring duration cstruct jsonm
+             decompress lwt lwt.unix ptime.clock.os asn1-combinators metrics))
diff --git a/src/vmm_json.ml b/src/vmm_json.ml
new file mode 100644
index 0000000..f320867
--- /dev/null
+++ b/src/vmm_json.ml
@@ -0,0 +1,38 @@
+(* this is copied from the example (in a comment) in jsonm *)
+
+(*
+type json =
+  [ `Null | `Bool of bool | `Float of float| `String of string
+  | `A of json list | `O of (string * json) list ]
+*)
+
+exception Escape of ((int * int) * (int * int)) * Jsonm.error
+
+let find_string_value k = function
+  | `Null | `Bool _ | `Float _ | `String _ | `A _ ->
+    Rresult.R.error_msgf "couldn't find %s in json" k
+  | `O dict ->
+    match List.find_opt (fun (key, _) -> String.equal k key) dict with
+    | Some (_, `String value) -> Ok value
+    | _ -> Rresult.R.error_msgf "couldn't find %s in json dictionary" k
+
+let json_of_string src =
+  let dec d = match Jsonm.decode d with
+    | `Lexeme l -> l
+    | `Error e -> raise (Escape (Jsonm.decoded_range d, e))
+    | `End | `Await -> assert false
+  in
+  let rec value v k d = match v with
+    | `Os -> obj [] k d  | `As -> arr [] k d
+    | `Null | `Bool _ | `String _ | `Float _ as v -> k v d
+    | _ -> assert false
+  and arr vs k d = match dec d with
+    | `Ae -> k (`A (List.rev vs)) d
+    | v -> value v (fun v -> arr (v :: vs) k) d
+  and obj ms k d = match dec d with
+    | `Oe -> k (`O (List.rev ms)) d
+    | `Name n -> value (dec d) (fun v -> obj ((n, v) :: ms) k) d
+    | _ -> assert false
+  in
+  let d = Jsonm.decoder (`String src) in
+  try Ok (value (dec d) (fun v _ -> v) d) with Escape (_, e) -> Error e
diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml
index 4cdcee7..e65122b 100644
--- a/src/vmm_unix.ml
+++ b/src/vmm_unix.ml
@@ -1,6 +1,47 @@
 (* (c) 2017 Hannes Mehnert, all rights reserved *)
 
 open Rresult
+
+open Vmm_core
+
+let dbdir = Fpath.(v "/var" / "db" / "albatross")
+
+type supported = FreeBSD | Linux
+
+let uname =
+  let cmd = Bos.Cmd.(v "uname" % "-s") in
+  lazy (match Bos.OS.Cmd.(run_out cmd |> out_string) with
+      | Ok (s, _) when s = "FreeBSD" -> FreeBSD
+      | Ok (s, _) when s = "Linux" -> Linux
+      | Ok (s, _) -> invalid_arg (Printf.sprintf "OS %s not supported" s)
+      | Error (`Msg m) -> invalid_arg m)
+
+let check_solo5_cmd name =
+  match
+    Bos.OS.Cmd.must_exist (Bos.Cmd.v name),
+    Bos.OS.Cmd.must_exist Bos.Cmd.(v (p Fpath.(dbdir / name)))
+  with
+  | Ok cmd, _ | _, Ok cmd -> Ok cmd
+  | _ -> R.error_msgf "%s does not exist" name
+
+(* here we check that the binaries we use in this file are actually present *)
+let check_commands () =
+  let uname_cmd = Bos.Cmd.v "uname" in
+  Bos.OS.Cmd.must_exist uname_cmd >>= fun _ ->
+  let cmds =
+    match Lazy.force uname with
+    | Linux -> [ "ip" ; "brctl" ; "taskset" ]
+    | FreeBSD -> [ "ifconfig" ; "cpuset" ]
+  in
+  List.fold_left
+    (fun acc cmd -> acc >>= fun _ ->
+      Bos.OS.Cmd.must_exist (Bos.Cmd.v cmd))
+    (Ok uname_cmd) cmds >>= fun _ ->
+  check_solo5_cmd "solo5-elftool" >>| fun _ ->
+  ()
+  (* we could check for solo5-hvt OR solo5-spt, but in practise we need
+     to handle either being absent and we get an image of that type anyways *)
+
 (* bits copied over from Bos *)
 (*---------------------------------------------------------------------------
    Copyright (c) 2014 Daniel C. Bünzli
@@ -51,10 +92,6 @@ let close_no_err fd = try close fd with _ -> ()
 (* own code starts here
    (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
 
-open Vmm_core
-
-let dbdir = Fpath.(v "/var" / "db" / "albatross")
-
 let dump, restore =
   let open R.Infix in
   let state_file = Fpath.(dbdir / "state") in
@@ -89,16 +126,6 @@ let rec fifo_exists file =
   | Unix.Unix_error (e, _, _) ->
       R.error_msgf "file %a exists: %s" Fpath.pp file (Unix.error_message e)
 
-type supported = FreeBSD | Linux
-
-let uname =
-  let cmd = Bos.Cmd.(v "uname" % "-s") in
-  lazy (match Bos.OS.Cmd.(run_out cmd |> out_string) with
-      | Ok (s, _) when s = "FreeBSD" -> FreeBSD
-      | Ok (s, _) when s = "Linux" -> Linux
-      | Ok (s, _) -> invalid_arg (Printf.sprintf "OS %s not supported" s)
-      | Error (`Msg m) -> invalid_arg m)
-
 let create_tap bridge =
   match Lazy.force uname with
   | FreeBSD ->
@@ -110,7 +137,7 @@ let create_tap bridge =
     let prefix = "vmmtap" in
     let rec find_n x =
       let nam = prefix ^ string_of_int x in
-      match Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % nam) with
+      match Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "link" % "show" % nam) with
       | Error _ -> nam
       | Ok _ -> find_n (succ x)
     in
@@ -127,6 +154,20 @@ let destroy_tap tap =
   in
   Bos.OS.Cmd.run cmd
 
+type solo5_target = Spt | Hvt
+
+let solo5_image_target image =
+  check_solo5_cmd "solo5-elftool" >>= fun cmd ->
+  let cmd = Bos.Cmd.(cmd % "query-abi" % p image) in
+  Bos.OS.Cmd.(run_out cmd |> out_string) >>= fun (s, _) ->
+  R.error_to_msg ~pp_error:Jsonm.pp_error
+    (Vmm_json.json_of_string s) >>= fun data ->
+  Vmm_json.find_string_value "target" data >>= function
+  | "spt" -> Ok Spt | "hvt" -> Ok Hvt
+  | x -> R.error_msgf "unsupported solo5 target %s" x
+
+let solo5_tender = function Spt -> "solo5-spt" | Hvt -> "solo5-hvt"
+
 let prepare name vm =
   (match vm.Unikernel.typ with
    | `Solo5 ->
@@ -136,6 +177,10 @@ let prepare name vm =
        | Error () -> Error (`Msg "failed to uncompress")
      else
        Ok vm.Unikernel.image) >>= fun image ->
+  let filename = Name.image_file name in
+  Bos.OS.File.write filename (Cstruct.to_string image) >>= fun () ->
+  solo5_image_target filename >>= fun target ->
+  check_solo5_cmd (solo5_tender target) >>= fun _ ->
   let fifo = Name.fifo_file name in
   begin match fifo_exists fifo with
     | Ok true -> Ok ()
@@ -143,15 +188,13 @@ let prepare name vm =
     | Error _ ->
       try Ok (mkfifo fifo) with
       | Unix.Unix_error (e, f, _) ->
-        Logs.err (fun m -> m "%a error in %s: %a" Fpath.pp fifo f pp_unix_err e);
-        Error (`Msg "while creating fifo")
+        R.error_msgf "file %a error in %s: %a" Fpath.pp fifo f pp_unix_err e
   end >>= fun () ->
   List.fold_left (fun acc b ->
       acc >>= fun acc ->
       create_tap b >>= fun tap ->
       Ok (tap :: acc))
     (Ok []) vm.Unikernel.bridges >>= fun taps ->
-  Bos.OS.File.write (Name.image_file name) (Cstruct.to_string image) >>= fun () ->
   Ok (List.rev taps)
 
 let vm_device vm =
@@ -184,8 +227,11 @@ let exec name config bridge_taps blocks =
   and mem = "--mem=" ^ string_of_int config.Unikernel.memory
   in
   cpuset config.Unikernel.cpuid >>= fun cpuset ->
+  let filename = Name.image_file name in
+  solo5_image_target filename >>= fun target ->
+  check_solo5_cmd (solo5_tender target) >>= fun tender ->
   let cmd =
-    Bos.Cmd.(of_list cpuset % p Fpath.(dbdir / "solo5-hvt") % mem %%
+    Bos.Cmd.(of_list cpuset %% tender % mem %%
              of_list net %% of_list macs %% of_list blocks %
              "--" % p (Name.image_file name) %% of_list argv)
   in
diff --git a/src/vmm_unix.mli b/src/vmm_unix.mli
index c1e45c8..09fb5fd 100644
--- a/src/vmm_unix.mli
+++ b/src/vmm_unix.mli
@@ -4,6 +4,8 @@ open Rresult
 
 open Vmm_core
 
+val check_commands : unit -> (unit, [> R.msg ]) result
+
 val prepare : Name.t -> Unikernel.config -> (string list, [> R.msg ]) result
 
 val exec : Name.t -> Unikernel.config -> (string * string) list ->