Acquire create_lock in self_destruct

We need to acquire the lock for updating the state.

.cirrus.yml

@@ -4,8 +4,7 @@ freebsd_instance:
 freebsd_task:
   env:
     matrix:
-      - OCAML_VERSION: 4.08.1
-      - OCAML_VERSION: 4.09.0
+      - OCAML_VERSION: 4.11.1
   pkg_install_script: pkg install -y ocaml-opam gmp gmake pkgconf bash
   ocaml_script: opam init -a --comp=$OCAML_VERSION
   dependencies_script: eval `opam env` && opam install -y --deps-only .

.github/workflows/build.yml

@@ -0,0 +1,33 @@
+name: Albatross
+
+on: [push, pull_request]
+
+jobs:
+  tests:
+    name: Tests
+
+    strategy:
+      fail-fast: false
+      matrix:
+        ocaml-version: ["4.11.1", "4.10.1", "4.09.0", "4.08.1"]
+        operating-system: [ubuntu-latest]
+
+    runs-on: ${{ matrix.operating-system }}
+
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v2
+
+      - name: Use OCaml ${{ matrix.ocaml-version }}
+        uses: avsm/setup-ocaml@v1
+        with:
+          ocaml-version: ${{ matrix.ocaml-version }}
+
+      - name: Install dependencies
+        run: |
+          opam pin add -n albatross .
+          opam depext -y albatross
+          opam install -t --deps-only .
+
+      - name: Build
+        run: opam exec -- dune build

.travis.yml

@@ -1,17 +0,0 @@
-language: c
-install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh
-script: bash -ex .travis-docker.sh
-sudo: false
-services:
-  - docker
-env:
-  global:
-    - PACKAGE="albatross"
-    - DISTRO=ubuntu
-    - TESTS=false
-  matrix:
-    - OCAML_VERSION=4.08
-    - OCAML_VERSION=4.09
-    - OCAML_VERSION=4.10
-notifications:
-  email: false

README.md

@@ -1,7 +1,5 @@
 # Albatross: orchestrate and manage MirageOS unikernels with Solo5
 
-[![Build Status](https://travis-ci.org/hannesm/albatross.svg?branch=master)](https://travis-ci.org/hannesm/albatross)
-
 The goal of albatross is robust deployment of [MirageOS](https://mirage.io)
 unikernels using [Solo5](https://github.com/solo5/solo5). Resources managed
 by albatross are network interfaces of kind `tap`, which are connected to
@@ -85,7 +83,7 @@ The following command-line applications for local and remote management are prov
 ## Installation
 
 To install Albatross, run `opam pin add albatross
-https://github.com/hannesm/albatross`.
+https://github.com/roburio/albatross`.
 
 Init scripts for FreeBSD are provided in the `packaging/FreeBSD/rc.d`
 subdirectory, and a script to create a FreeBSD package

albatross.opam

@@ -1,17 +1,18 @@
 opam-version: "2.0"
 maintainer: "Hannes Mehnert <hannes@mehnert.org>"
 authors: ["Hannes Mehnert <hannes@mehnert.org>"]
-homepage: "https://github.com/hannesm/albatross"
-dev-repo: "git+https://github.com/hannesm/albatross.git"
-bug-reports: "https://github.com/hannesm/albatross/issues"
+homepage: "https://github.com/roburio/albatross"
+dev-repo: "git+https://github.com/roburio/albatross.git"
+bug-reports: "https://github.com/roburio/albatross/issues"
 license: "ISC"
 
 depends: [
   "ocaml" {>= "4.08.0"}
   "dune"
+  "dune-configurator"
+  "conf-pkg-config" {build}
   "lwt" {>= "3.0.0"}
   "ipaddr" {>= "4.0.0"}
-  "hex"
   "cstruct"
   "logs"
   "rresult"
@@ -37,4 +38,8 @@ build: [
   ["dune" "subst"] {pinned}
   ["dune" "build" "-p" name "-j" jobs]
 ]
+depexts: [
+  ["libnl-3-dev" "libnl-route-3-dev"] {os-family = "debian"}
+  ["libnl3" "libnl3-devel"] {os-family = "centos"}
+]
 synopsis: "Albatross - orchestrate and manage MirageOS unikernels with Solo5"

command-line/albatross_cli.ml

@@ -102,7 +102,9 @@ let setup_log style_renderer level =
 
 let create_vm force image cpuid memory argv block_devices bridges compression restart_on_fail exit_codes =
   let open Rresult.R.Infix in
-  Bos.OS.File.read (Fpath.v image) >>| fun image ->
+  let img_file = Fpath.v image in
+  Bos.OS.File.read img_file >>= fun image ->
+  Vmm_unix.manifest_devices_match ~bridges ~block_devices img_file >>| fun () ->
   let image, compressed = match compression with
     | 0 -> Cstruct.of_string image, false
     | level ->
@@ -345,6 +347,13 @@ let retry_connections =
   let doc = "Number of retries when connecting to other daemons (log, console, stats etc). 0 aborts after one failure, -1 is unlimited retries." in
   Arg.(value & opt int 0 & info [ "retry-connections" ] ~doc)
 
+let systemd_socket_activation =
+  match Lazy.force Vmm_unix.uname with
+  | FreeBSD -> Term.const false
+  | Linux ->
+    let doc = "Pass this flag when systemd socket activation is being used" in
+    Arg.(value & flag & info [ "systemd-socket-activation" ] ~doc)
+
 let exit_status = function
   | Ok () -> Ok Success
   | Error e -> Ok e

daemon/albatross_console.ml

@@ -158,12 +158,12 @@ let handle s addr =
 
 let m = Vmm_core.conn_metrics "unix"
 
-let jump _ influx tmpdir =
+let jump _ systemd influx tmpdir =
   Sys.(set_signal sigpipe Signal_ignore) ;
   Albatross_cli.set_tmpdir tmpdir;
   Lwt_main.run
     (Albatross_cli.init_influx "albatross_console" influx;
-     Vmm_lwt.server_socket `Console >>= fun s ->
+     Vmm_lwt.server_socket ~systemd `Console >>= fun s ->
      let rec loop () =
        Lwt_unix.accept s >>= fun (cs, addr) ->
        m `Open;
@@ -177,7 +177,7 @@ open Cmdliner
 open Albatross_cli
 
 let cmd =
-  Term.(term_result (const jump $ setup_log $ influx $ tmpdir)),
+  Term.(term_result (const jump $ setup_log $ systemd_socket_activation $ influx $ tmpdir)),
   Term.info "albatross_console" ~version
 
 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

daemon/albatross_log.ml

@@ -148,7 +148,7 @@ let handle mvar ring s addr =
 
 let m = Vmm_core.conn_metrics "unix"
 
-let jump _ file read_only influx tmpdir =
+let jump _ systemd file read_only influx tmpdir =
   Sys.(set_signal sigpipe Signal_ignore) ;
   Albatross_cli.set_tmpdir tmpdir;
   Lwt_main.run
@@ -161,7 +161,7 @@ let jump _ file read_only influx tmpdir =
        Lwt.return_unit
      end else begin
        Albatross_cli.init_influx "albatross_log" influx;
-       Vmm_lwt.server_socket `Log >>= fun s ->
+       Vmm_lwt.server_socket ~systemd `Log >>= fun s ->
        let ring = Vmm_ring.create `Startup () in
        List.iter (Vmm_ring.write ring) entries ;
        let mvar = Lwt_mvar.create_empty () in
@@ -192,7 +192,7 @@ let read_only =
   Arg.(value & flag & info [ "read-only" ] ~doc)
 
 let cmd =
-  Term.(const jump $ setup_log $ file $ read_only $ influx $ tmpdir),
+  Term.(const jump $ setup_log $ systemd_socket_activation $ file $ read_only $ influx $ tmpdir),
   Term.info "albatross_log" ~version
 
 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

daemon/albatrossd.ml

@@ -135,7 +135,7 @@ let write_reply name fd txt (hdr, cmd) =
 
 let m = conn_metrics "unix"
 
-let jump _ influx tmpdir dbdir retries enable_stats =
+let jump _ systemd influx tmpdir dbdir retries enable_stats =
   Sys.(set_signal sigpipe Signal_ignore);
   Albatross_cli.set_tmpdir tmpdir;
   Albatross_cli.set_dbdir dbdir;
@@ -165,7 +165,7 @@ let jump _ influx tmpdir dbdir retries enable_stats =
         else
           Lwt.return_none) >>= fun s ->
        Lwt.catch
-         (fun () -> Vmm_lwt.server_socket `Vmmd)
+         (fun () -> Vmm_lwt.server_socket ~systemd `Vmmd)
          (fun e ->
             let str =
               Fmt.strf "unable to create server socket %a: %s"
@@ -175,13 +175,13 @@ let jump _ influx tmpdir dbdir retries enable_stats =
        let self_destruct_mutex = Lwt_mutex.create () in
        let self_destruct () =
          Lwt_mutex.with_lock self_destruct_mutex (fun () ->
-             (if Vmm_vmmd.killall !state then
-                (* not too happy about the sleep here, but cleaning up resources
-                   is really important (fifos, vm images, tap devices) - which
-                   is done asynchronously (in the task waitpid() on the pid) *)
-                Lwt_unix.sleep 1.
-              else
-                Lwt.return_unit) >>= fun () ->
+             Lwt_mutex.with_lock create_lock (fun () ->
+                 let state', tasks = Vmm_vmmd.killall !state Lwt.task in
+                 state := state';
+                 Lwt.return tasks) >>= fun tasks ->
+             Lwt_list.iter_s (fun exit_code ->
+                 exit_code >>= fun (_ : process_exit) -> Lwt.return_unit)
+               tasks >>= fun () ->
              Vmm_lwt.safe_close ss)
        in
        Sys.(set_signal sigterm
@@ -218,7 +218,7 @@ let jump _ influx tmpdir dbdir retries enable_stats =
 open Cmdliner
 
 let cmd =
-  Term.(const jump $ setup_log $ influx $ tmpdir $ dbdir $ retry_connections $ enable_stats),
+  Term.(const jump $ setup_log $ systemd_socket_activation $ influx $ tmpdir $ dbdir $ retry_connections $ enable_stats),
   Term.info "albatrossd" ~version:Albatross_cli.version
 
 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

packaging/FreeBSD/MANIFEST

@@ -2,7 +2,7 @@ name:         albatross
 version:      1.0.%%GITVER%%_1
 origin:	      local/albatross
 comment:      Albatross: orchestrate and manage MirageOS unikernels with Solo5
-www:	      https://github.com/hannesm/albatross
+www:	      https://github.com/roburio/albatross
 maintainer:   Hannes Mehnert <hannes@mehnert.org>
 prefix:	      /usr/local
 licenselogic: single

packaging/Linux/README.md

@@ -1,6 +1,8 @@
 # systemd service scripts
 
 these are preliminary and just here to let people play with `solo5-spt`, the seccomp-enabled backend for [Solo5](https://github.com/Solo5/solo5) on Linux.
+Note: The socket paths are hardcoded relative to the RuntimeDirectory (tmpdir).
+If you modify `Vmm_core.socket_path` you must modify the corresponding `.socket` file(s) in this directory.
 
 1) You need to build the `albatross` tooling in this repository
 2) To run unikernels, you need to build and install solo5-elftool and at least one of the tenders: solo5-hvt and solo5-spt. They can be installed somewhere in PATH or in /var/lib/albatross/.

packaging/Linux/albatross_console.service

@@ -3,12 +3,13 @@
 # to create an override configuration:
 # systemctl edit albatross_console.service
 Description=Albatross console daemon (albatross_console)
+Requires=albatross_console.socket
 After=syslog.target
 
 [Service]
 Type=simple
 User=albatross
-ExecStart=/usr/local/sbin/albatross-console --tmpdir="%t/albatross/" -vv
+ExecStart=/usr/local/sbin/albatross-console --systemd-socket-activation --tmpdir="%t/albatross/" -vv
 RuntimeDirectoryPreserve=yes
 RuntimeDirectory=albatross
 ExecStartPre=/bin/mkdir -p %t/albatross/fifo
@@ -18,4 +19,5 @@ PIDFile=%t/albatross/console.pid
 RestrictAddressFamilies=AF_UNIX
 
 [Install]
+Also=albatross_console.socket
 WantedBy=multi-user.target

packaging/Linux/albatross_console.socket

@@ -0,0 +1,12 @@
+[Unit]
+Description=Albatross console socket
+PartOf=albatross_console.service
+
+[Socket]
+ListenStream=%t/albatross/util/console.sock
+SocketUser=albatross
+SocketMode=0600
+Accept=no
+
+[Install]
+WantedBy=sockets.target

packaging/Linux/albatross_daemon.service

@@ -1,6 +1,6 @@
 [Unit]
 Description=Albatross VMM daemon (albatrossd)
-Requires=albatross_console.service albatross_log.service
+Requires=albatross_console.socket albatross_log.socket albatross_daemon.socket
 After=syslog.target albatross_console.service albatross_log.service
 
 [Service]
@@ -8,7 +8,7 @@ Type=simple
 # TODO not necessarily needs to be run as root, anything that can solo5-spt/hvt,
 #  create tap interfaces should be fine!
 User=root
-ExecStart=/usr/local/sbin/albatrossd --tmpdir="%t/albatross/" -vv
+ExecStart=/usr/local/sbin/albatrossd --systemd-socket-activation --tmpdir="%t/albatross/" -vv
 #RuntimeDirectoryPreserve=yes
 #RuntimeDirectory=albatross
 PIDFile=%t/albatross/daemon.pid
@@ -27,4 +27,5 @@ IgnoreSIGPIPE=true
 #RuntimeDirectoryMode=0700
 
 [Install]
+Also=albatross_daemon.socket
 WantedBy=multi-user.target

packaging/Linux/albatross_daemon.socket

@@ -0,0 +1,11 @@
+[Unit]
+Description=Albatross daemon socket
+PartOf=albatross_daemon.service
+
+[Socket]
+ListenStream=%t/albatross/util/vmmd.sock
+SocketMode=0600
+Accept=no
+
+[Install]
+WantedBy=sockets.target

packaging/Linux/albatross_log.service

@@ -4,17 +4,18 @@
 # systemctl edit albatross_log.service
 Description=Albatross log daemon (albatross_log)
 After=syslog.target albatross_console.service
-Requires=albatross_console.service
+Requires=albatross_log.socket
+AssertPathExists=/var/lib/albatross/albatross.log
 
 [Service]
 Type=simple
 User=albatross
-AssertPathExists=/var/lib/albatross/albatross.log
-ExecStart=/usr/local/sbin/albatross-log --logfile="/var/lib/albatross/albatross.log" --tmpdir="%t/albatross/" -vv
+ExecStart=/usr/local/sbin/albatross-log --systemd-socket-activation --logfile="/var/lib/albatross/albatross.log" --tmpdir="%t/albatross/" -vv
 RuntimeDirectory=albatross albatross/util
 #RuntimeDirectoryPreserve=yes # avoid albatross.log being cleaned up
 PIDFile=%t/albatross/log.pid
 RestrictAddressFamilies=AF_UNIX
 
 [Install]
+Also=albatross_log.socket
 WantedBy=multi-user.target

packaging/Linux/albatross_log.socket

@@ -0,0 +1,12 @@
+[Unit]
+Description=Albatross log socket
+PartOf=albatross_log.service
+
+[Socket]
+ListenStream=%t/albatross/util/log.sock
+SocketUser=albatross
+SocketMode=0600
+Accept=no
+
+[Install]
+WantedBy=sockets.target

packaging/Linux/albatross_stats.service

@@ -3,16 +3,18 @@
 # to create an override configuration:
 # systemctl edit albatross_stat.service
 Description=Albatross stat daemon (albatross_stat)
+Requires=albatross_stat.socket
 After=syslog.target
 
 [Service]
 Type=simple
 User=albatross
-ExecStart=/usr/local/sbin/albatross-stats --tmpdir="%t/albatross/" -vv
+ExecStart=/usr/local/sbin/albatross-stats --systemd-socket-activation --tmpdir="%t/albatross/" -vv
 RuntimeDirectoryPreserve=yes
 RuntimeDirectory=albatross albatross/util
 PIDFile=%t/albatross/stat.pid
 RestrictAddressFamilies=AF_UNIX
 
 [Install]
+Also=albatross_stat.socket
 WantedBy=multi-user.target

packaging/Linux/albatross_stats.socket

@@ -0,0 +1,12 @@
+[Unit]
+Description=Albatross stats socket
+PartOf=albatross_stats.service
+
+[Socket]
+ListenStream=%t/albatross/util/stat.sock
+SocketUser=albatross
+SocketMode=0600
+Accept=no
+
+[Install]
+WantedBy=sockets.target

packaging/Linux/install.sh

@@ -5,7 +5,7 @@ sudo mkdir -m 0700 -p /var/lib/albatross/block
 sudo install -o "$ALBATROSS_USER" -- /dev/null /var/lib/albatross/albatross.log
 
 sudo cp ../../_build/install/default/bin/* /usr/local/sbin/
-sudo cp ./albatross_*.service  /etc/systemd/system/
+sudo cp ./albatross_*.service ./albatross_*.socket /etc/systemd/system/
 sudo systemctl daemon-reload
 sudo systemctl stop albatross_console
 sudo systemctl start albatross_console

src/dune

@@ -2,5 +2,5 @@
   (name albatross)
   (public_name albatross)
   (wrapped false)
-  (libraries rresult logs ipaddr bos hex ptime astring duration cstruct jsonm
+  (libraries rresult logs ipaddr bos ptime astring duration cstruct jsonm
              decompress lwt lwt.unix ptime.clock.os asn1-combinators metrics))

src/vmm_commands.ml

@@ -141,12 +141,17 @@ type success = [
 let pp_block ppf (id, size, active) =
   Fmt.pf ppf "block %a size %d MB active %B" Name.pp id size active
 
+let my_fmt_list empty pp_elt ppf xs =
+  match xs with
+  | [] -> Fmt.string ppf empty
+  | _ -> Fmt.(list ~sep:(unit "@.") pp_elt ppf xs)
+
 let pp_success ppf = function
   | `Empty -> Fmt.string ppf "success"
   | `String data -> Fmt.pf ppf "success: %s" data
-  | `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Policy.pp)) ppf ps
-  | `Unikernels vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Unikernel.pp_config)) ppf vms
-  | `Block_devices blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks
+  | `Policies ps -> my_fmt_list "no policies" Fmt.(pair ~sep:(unit ": ") Name.pp Policy.pp) ppf ps
+  | `Unikernels vms -> my_fmt_list "no unikernels" Fmt.(pair ~sep:(unit ": ") Name.pp Unikernel.pp_config) ppf vms
+  | `Block_devices blocks -> my_fmt_list "no block devices" pp_block ppf blocks
 
 type res = [
   | `Command of t

src/vmm_core.ml

@@ -268,7 +268,7 @@ module Stats = struct
   }
 
   let pp_rusage ppf r =
-    Fmt.pf ppf "utime %Lu.%d stime %Lu.%d maxrss %Lu ixrss %Lu idrss %Lu isrss %Lu minflt %Lu majflt %Lu nswap %Lu inblock %Lu outblock %Lu msgsnd %Lu msgrcv %Lu signals %Lu nvcsw %Lu nivcsw %Lu"
+    Fmt.pf ppf "utime %Lu.%06d stime %Lu.%06d maxrss %Lu ixrss %Lu idrss %Lu isrss %Lu minflt %Lu majflt %Lu nswap %Lu inblock %Lu outblock %Lu msgsnd %Lu msgrcv %Lu signals %Lu nvcsw %Lu nivcsw %Lu"
       (fst r.utime) (snd r.utime) (fst r.stime) (snd r.stime) r.maxrss r.ixrss r.idrss r.isrss r.minflt r.majflt r.nswap r.inblock r.outblock r.msgsnd r.msgrcv r.nsignals r.nvcsw r.nivcsw
   let pp_rusage_mem ppf r =
     Fmt.pf ppf "maxrss %Lu ixrss %Lu idrss %Lu isrss %Lu minflt %Lu majflt %Lu"
@@ -286,7 +286,7 @@ module Stats = struct
   }
 
   let pp_kinfo_mem ppf t =
-    Fmt.pf ppf "virtual-size %Lu rss %Lu text-size %Lu data-size %Lu stack-size %Lu runtime %Lu cow %u start %Lu.%d"
+    Fmt.pf ppf "virtual-size %Lu rss %Lu text-size %Lu data-size %Lu stack-size %Lu runtime %Lu cow %u start %Lu.%06d"
       t.vsize t.rss t.tsize t.dsize t.ssize t.runtime t.cow (fst t.start) (snd t.start)
 
   type vmm = (string * int64) list

src/vmm_json.ml

@@ -16,6 +16,30 @@ let find_string_value k = function
     | Some (_, `String value) -> Ok value
     | _ -> Rresult.R.error_msgf "couldn't find %s in json dictionary" k
 
+let find_devices x =
+  let open Rresult in
+  let device dev =
+    find_string_value "name" dev >>= fun name ->
+    find_string_value "type" dev >>| fun typ ->
+    name, typ
+  in
+  match x with
+  | `Null | `Bool _ | `Float _ | `String _ | `A _ ->
+    Rresult.R.error_msg "couldn't find devices in json"
+  | `O dict ->
+    match List.find_opt (fun (key, _) -> String.equal key "devices") dict with
+    | Some (_, `A devices) ->
+      List.fold_left
+        (fun acc dev ->
+           acc >>= fun (block_devices, networks) ->
+           device dev >>= fun (name, typ) ->
+           match typ with
+           | "BLOCK_BASIC" -> Ok (name :: block_devices, networks)
+           | "NET_BASIC" -> Ok (block_devices, name :: networks)
+           | _ -> Rresult.R.error_msgf "unknown device type %s in json" typ)
+        (Ok ([], [])) devices
+    | _ -> Rresult.R.error_msg "devices field is not array in json"
+
 let json_of_string src =
   let dec d = match Jsonm.decode d with
     | `Lexeme l -> l

src/vmm_lwt.ml

@@ -12,7 +12,12 @@ let safe_close fd =
     (fun () -> Lwt_unix.close fd)
     (fun _ -> Lwt.return_unit)
 
-let server_socket sock =
+let server_socket ~systemd sock =
+  if systemd
+  then match Vmm_unix.sd_listen_fds () with
+    | Some [fd] -> Lwt.return (Lwt_unix.of_unix_file_descr fd)
+    | _ -> failwith "Systemd socket activation error" (* FIXME *)
+  else
     let name = Vmm_core.socket_path sock in
     (Lwt_unix.file_exists name >>= function
       | true -> Lwt_unix.unlink name

src/vmm_lwt.mli

@@ -2,7 +2,7 @@
 
 val pp_sockaddr : Format.formatter -> Lwt_unix.sockaddr -> unit
 
-val server_socket : Vmm_core.service -> Lwt_unix.file_descr Lwt.t
+val server_socket : systemd:bool -> Vmm_core.service -> Lwt_unix.file_descr Lwt.t
 
 val connect : Lwt_unix.socket_domain -> Lwt_unix.sockaddr -> Lwt_unix.file_descr option Lwt.t
 

src/vmm_unix.ml

@@ -26,6 +26,26 @@ let check_solo5_cmd name =
   | Ok cmd, _ | _, Ok cmd -> Ok cmd
   | _ -> R.error_msgf "%s does not exist" name
 
+(* Pure OCaml implementation of SystemD's sd_listen_fds.
+ * Note: this implementation does not unset environment variables. *)
+let sd_listen_fds () =
+  let fd_of_int (fd : int) : Unix.file_descr = Obj.magic fd in
+  let sd_listen_fds_start = 3 in
+  match Sys.getenv_opt "LISTEN_PID", Sys.getenv_opt "LISTEN_FDS" with
+  | None, _ | _, None -> None
+  | Some listen_pid, Some listen_fds ->
+    match int_of_string_opt listen_pid, int_of_string_opt listen_fds with
+    | None, _ | _, None -> None
+    | Some listen_pid, Some listen_fds ->
+      if listen_pid = Unix.getpid ()
+      then Some (List.init listen_fds
+                   (fun i ->
+                      let fd = fd_of_int (sd_listen_fds_start + i) in
+                      let () = Unix.set_close_on_exec fd in
+                      fd))
+      else None
+
+
 (* 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
@@ -181,6 +201,48 @@ let solo5_image_target image =
 
 let solo5_tender = function Spt -> "solo5-spt" | Hvt -> "solo5-hvt"
 
+let solo5_image_devices image =
+  check_solo5_cmd "solo5-elftool" >>= fun cmd ->
+  let cmd = Bos.Cmd.(cmd % "query-manifest" % p image) in
+  Bos.OS.Cmd.(run_out cmd |> out_string |> success) >>= fun s ->
+  R.error_to_msg ~pp_error:Jsonm.pp_error
+    (Vmm_json.json_of_string s) >>= fun data ->
+  Vmm_json.find_devices data
+
+let equal_string_lists b1 b2 err =
+  let open Astring in
+  if String.Set.(equal (of_list b1) (of_list b2)) then
+    Ok ()
+  else
+    R.error_msg err
+
+let devices_match ~bridges ~block_devices (manifest_block, manifest_net) =
+  equal_string_lists manifest_block block_devices
+    "specified block device(s) does not match with manifest" >>= fun () ->
+  equal_string_lists manifest_net bridges
+    "specified bridge(s) does not match with the manifest"
+
+let manifest_devices_match ~bridges ~block_devices image_file =
+  solo5_image_devices image_file >>=
+  let bridges = List.map fst bridges in
+  devices_match ~bridges ~block_devices
+
+let bridge_name (service, b) = match b with None -> service | Some b -> b
+
+let bridge_exists bridge_name =
+  let cmd =
+    match Lazy.force uname with
+    | FreeBSD -> Bos.Cmd.(v "ifconfig" % bridge_name)
+    | Linux -> Bos.Cmd.(v "ip" % "link" % "show" % bridge_name)
+  in
+  Bos.OS.Cmd.(run_out ~err:err_null cmd |> out_null |> success)
+  |> R.reword_error (fun _e -> R.msgf "interface %s does not exist" bridge_name)
+
+let bridges_exist bridges =
+  List.fold_left
+    (fun acc b -> acc >>= fun () -> bridge_exists (bridge_name b))
+    (Ok ()) bridges
+
 let prepare name vm =
   (match vm.Unikernel.typ with
    | `Solo5 ->
@@ -194,6 +256,8 @@ let prepare name vm =
   Bos.OS.File.write filename (Cstruct.to_string image) >>= fun () ->
   solo5_image_target filename >>= fun target ->
   check_solo5_cmd (solo5_tender target) >>= fun _ ->
+  manifest_devices_match ~bridges:vm.Unikernel.bridges ~block_devices:vm.Unikernel.block_devices filename >>= fun () ->
+  bridges_exist vm.Unikernel.bridges >>= fun () ->
   let fifo = Name.fifo_file name in
   begin match fifo_exists fifo with
     | Ok true -> Ok ()
@@ -210,11 +274,11 @@ let prepare name vm =
         let _ = Unix.umask old_umask in
         R.error_msgf "file %a error in %s: %a" Fpath.pp fifo f pp_unix_err e
   end >>= fun () ->
-  List.fold_left (fun acc (net, bri) ->
+  List.fold_left (fun acc arg ->
       acc >>= fun acc ->
-      let bridge = match bri with None -> net | Some b -> b in
+      let bridge = bridge_name arg in
       create_tap bridge >>= fun tap ->
-      Ok ((net, tap) :: acc))
+      Ok ((fst arg, tap) :: acc))
     (Ok []) vm.Unikernel.bridges >>= fun taps ->
   Ok (List.rev taps)
 

src/vmm_unix.mli

@@ -8,6 +8,8 @@ type supported = FreeBSD | Linux
 
 val uname : supported Lazy.t
 
+val sd_listen_fds : unit -> Unix.file_descr list option
+
 val set_dbdir : Fpath.t -> unit
 
 val check_commands : unit -> (unit, [> R.msg ]) result
@@ -35,3 +37,6 @@ val dump : ?name:string -> Cstruct.t -> (unit, [> R.msg ]) result
 val restore : ?name:string -> unit -> (Cstruct.t, [> R.msg | `NoFile ]) result
 
 val vm_device : Unikernel.t -> (string, [> R.msg ]) result
+
+val manifest_devices_match : bridges:(string * string option) list ->
+  block_devices:string list -> Fpath.t -> (unit, [> R.msg]) result

src/vmm_vmmd.ml

@@ -17,11 +17,6 @@ type 'a t = {
 
 let in_shutdown = ref false
 
-let killall t =
-  match List.map snd (Vmm_trie.all t.resources.Vmm_resources.unikernels) with
-  | [] -> false
-  | vms -> in_shutdown := true ; List.iter Vmm_unix.destroy vms ; true
-
 let remove_resources t name =
   let resources = match Vmm_resources.remove_vm t.resources name with
     | Error (`Msg e) ->
@@ -63,6 +58,17 @@ let register_restart t id create =
   | Some _ -> Logs.err (fun m -> m "restart attempted to overwrite waiter"); None
   | _ -> Some (register t id create)
 
+let killall t create =
+  let vms = Vmm_trie.all t.resources.Vmm_resources.unikernels in
+  in_shutdown := true ;
+  let t, xs = List.fold_left
+      (fun (t, acc) (id, _) ->
+         let (t, a) = register t id create in
+         (t, a :: acc))
+      (t, []) vms in
+  List.iter Vmm_unix.destroy (List.map snd vms) ;
+  t, xs
+
 let init () =
   let t = {
     console_counter = 1L ;
@@ -212,11 +218,6 @@ let handle_policy_cmd t id = function
         (fun prefix policy policies-> (prefix, policy) :: policies)
         []
     in
-    match policies with
-    | [] ->
-      Logs.debug (fun m -> m "policies: couldn't find %a" Name.pp id) ;
-      Error (`Msg "policy: not found")
-    | _ ->
     Ok (t, `End (`Success (`Policies policies)))
 
 let handle_unikernel_cmd t id = function
@@ -229,13 +230,7 @@ let handle_unikernel_cmd t id = function
            (id, cfg) :: vms)
         []
     in
-    begin match vms with
-      | [] ->
-        Logs.debug (fun m -> m "info: couldn't find %a" Name.pp id) ;
-        Error (`Msg "info: no unikernel found")
-      | _ ->
     Ok (t, `End (`Success (`Unikernels vms)))
-    end
   | `Unikernel_get ->
     Logs.debug (fun m -> m "get %a" Name.pp id) ;
     begin match Vmm_trie.find id t.resources.Vmm_resources.unikernels with
@@ -304,11 +299,6 @@ let handle_block_cmd t id = function
         (fun prefix (size, active) blocks -> (prefix, size, active) :: blocks)
         []
     in
-    match blocks with
-    | [] ->
-      Logs.debug (fun m -> m "block: couldn't find %a" Name.pp id) ;
-      Error (`Msg "block: not found")
-    | _ ->
     Ok (t, `End (`Success (`Block_devices blocks)))
 
 let handle_command t (header, payload) =

src/vmm_vmmd.mli

@@ -32,7 +32,7 @@ val handle_command : 'a t -> Vmm_commands.wire ->
    | `Wait_and_create of Name.t * (Name.t * Unikernel.config) ],
    Vmm_commands.res) result
 
-val killall : 'a t -> bool
+val killall : 'a t -> (unit -> 'b * 'a) -> 'a t * ('b list)
 
 val restore_unikernels : unit -> (Unikernel.config Vmm_trie.t, [> `Msg of string ]) result
 

stats/albatross_stats.ml

@@ -66,13 +66,13 @@ let timer () =
 
 let m = Vmm_core.conn_metrics "unix"
 
-let jump _ interval influx tmpdir =
+let jump _ systemd interval influx tmpdir =
   Sys.(set_signal sigpipe Signal_ignore);
   Albatross_cli.set_tmpdir tmpdir;
   let interval = Duration.(to_f (of_sec interval)) in
   Lwt_main.run
     (Albatross_cli.init_influx "albatross_stats" influx;
-     Vmm_lwt.server_socket `Stats >>= fun s ->
+     Vmm_lwt.server_socket ~systemd `Stats >>= fun s ->
      let _ev = Lwt_engine.on_timer interval true (fun _e -> Lwt.async timer) in
      let rec loop () =
        Lwt_unix.accept s >>= fun (cs, addr) ->
@@ -90,7 +90,7 @@ let interval =
   Arg.(value & opt int 10 & info [ "interval" ] ~doc)
 
 let cmd =
-  Term.(term_result (const jump $ setup_log $ interval $ influx $ tmpdir)),
+  Term.(term_result (const jump $ setup_log $ systemd_socket_activation $ interval $ influx $ tmpdir)),
   Term.info "albatross_stats" ~version
 
 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

stats/albatross_stats_pure.ml

@@ -5,6 +5,8 @@ open Rresult.R.Infix
 
 open Vmm_core
 
+external sysconf_clock_tick : unit -> int = "vmmanage_sysconf_clock_tick"
+
 external sysctl_kinfo_proc : int -> Stats.rusage * Stats.kinfo_mem =
   "vmmanage_sysctl_kinfo_proc"
 external sysctl_ifcount : unit -> int = "vmmanage_sysctl_ifcount"
@@ -99,9 +101,103 @@ let try_open_vmmapi pid_nic =
       IM.add pid (vmctx, vmmdev, nics) fresh)
     pid_nic IM.empty
 
+let string_of_file filename =
+  try
+    let fh = open_in filename in
+    let content = input_line fh in
+    close_in_noerr fh ;
+    Ok content
+  with _ -> Rresult.R.error_msgf "Error reading file %S" filename
+
+let parse_proc_stat s =
+  let stats_opt =
+    let ( let* ) = Option.bind in
+    let* (pid, rest) = Astring.String.cut ~sep:" (" s in
+    let* (tcomm, rest) = Astring.String.cut ~rev:true ~sep:") " rest in
+    let rest = Astring.String.cuts ~sep:" " rest in
+    Some (pid :: tcomm :: rest)
+  in
+  Option.to_result ~none:(`Msg "unable to parse /proc/<pid>/stat") stats_opt
+
+let read_proc_status pid =
+  try
+    let fh = open_in ("/proc/" ^ string_of_int pid ^ "/status") in
+    let lines =
+      let rec read_lines acc = try
+          read_lines (input_line fh :: acc)
+        with End_of_file -> acc in
+      read_lines []
+    in
+    List.map (Astring.String.cut ~sep:":\t") lines |>
+    List.fold_left (fun acc x -> match acc, x with
+        | Some acc, Some x -> Some (x :: acc)
+        | _ -> None) (Some []) |>
+    Option.to_result ~none:(`Msg "failed to parse /proc/<pid>/status")
+  with _ -> Rresult.R.error_msgf "error reading file /proc/%d/status" pid
+
+let linux_rusage pid =
+  (match Unix.stat ("/proc/" ^ string_of_int pid) with
+   | { Unix.st_ctime = start; _ } ->
+     let frac = Float.rem start 1. in
+     Ok (Int64.of_float start, int_of_float (frac *. 1_000_000.))
+   | exception Unix.Unix_error (Unix.ENOENT,_,_) -> Error (`Msg "failed to stat process") ) >>= fun start ->
+  (* reading /proc/<pid>/stat - since it may disappear mid-time,
+     best to have it in memory *)
+  string_of_file ("/proc/" ^ string_of_int pid ^ "/stat") >>= fun data ->
+  parse_proc_stat data >>= fun stat_vals ->
+  string_of_file ("/proc/" ^ string_of_int pid ^ "/statm") >>= fun data ->
+  let statm_vals = Astring.String.cuts ~sep:" " data in
+  read_proc_status pid >>= fun status ->
+  let assoc_i64 key : (int64, _) result =
+    let e x = Option.to_result ~none:(`Msg "error parsing /proc/<pid>/status") x in
+    e (List.assoc_opt key status) >>= fun v ->
+    e (Int64.of_string_opt v)
+  in
+  let i64 s = try Ok (Int64.of_string s) with
+      Failure _ -> Error (`Msg "couldn't parse integer")
+  in
+  let time_of_int64 t =
+    let clock_tick = Int64.of_int (sysconf_clock_tick ()) in
+    let ( * ) = Int64.mul and ( / ) = Int64.div in
+    (t / clock_tick, Int64.to_int (((Int64.rem t clock_tick) * 1_000_000L) / clock_tick))
+  in
+  if List.length stat_vals >= 52 && List.length statm_vals >= 7 then
+    i64 (List.nth stat_vals 9) >>= fun minflt ->
+    i64 (List.nth stat_vals 11) >>= fun majflt ->
+    i64 (List.nth stat_vals 13) >>= fun utime -> (* divide by sysconf(_SC_CLK_TCK) *)
+    i64 (List.nth stat_vals 14) >>= fun stime -> (* divide by sysconf(_SC_CLK_TCK) *)
+    let runtime = fst (time_of_int64 Int64.(add utime stime)) in
+    let utime = time_of_int64 utime
+    and stime = time_of_int64 stime in
+    i64 (List.nth stat_vals 22) >>= fun vsize -> (* in bytes *)
+    i64 (List.nth stat_vals 23) >>= fun rss -> (* in pages *)
+    i64 (List.nth stat_vals 35) >>= fun nswap -> (* not maintained, 0 *)
+    i64 (List.nth statm_vals 3) >>= fun tsize ->
+    i64 (List.nth statm_vals 5) >>= fun dsize -> (* data + stack *)
+    i64 (List.nth statm_vals 5) >>= fun ssize -> (* data + stack *)
+    assoc_i64 "voluntary_ctxt_switches" >>= fun nvcsw ->
+    assoc_i64 "nonvoluntary_ctxt_switches" >>= fun nivcsw ->
+    let rusage = { Stats.utime ; stime ; maxrss = rss ; ixrss = 0L ;
+         idrss = 0L ; isrss = 0L ; minflt ; majflt ; nswap ; inblock = 0L ; outblock = 0L ;
+         msgsnd = 0L ; msgrcv = 0L ; nsignals = 0L ; nvcsw ; nivcsw }
+    and kmem = { Stats.vsize; rss; tsize; dsize; ssize; runtime; cow = 0; start }
+    in
+    Ok (rusage, kmem)
+  else
+    Error (`Msg "couldn't read /proc/<pid>/stat")
+
+let rusage pid =
+  match Lazy.force Vmm_unix.uname with
+  | Vmm_unix.FreeBSD -> wrap sysctl_kinfo_proc pid
+  | Vmm_unix.Linux -> match linux_rusage pid with
+    | Ok x -> Some x
+    | Error (`Msg msg) ->
+      Logs.err (fun m -> m "error %s while reading /proc/" msg);
+      None
+
 let gather pid vmctx nics =
   let ru, mem =
-    match wrap sysctl_kinfo_proc pid with
+    match rusage pid with
     | None -> None, None
     | Some (mem, ru) -> Some mem, Some ru
   in

stats/albatross_stats_stubs.c

@@ -17,6 +17,17 @@
 #define Val32 caml_copy_int32
 #define Val64 caml_copy_int64
 
+/* We only use sysconf(_SC_CLK_TCK) in Linux only, but it's well-defined in FreeBSD as well. */
+#include <unistd.h>
+CAMLprim value vmmanage_sysconf_clock_tick(value unit) {
+  CAMLparam1(unit);
+  long r;
+  r = sysconf(_SC_CLK_TCK);
+  if (r == 1)
+    uerror("sysconf", Nothing);
+  CAMLreturn(Val_long(r));
+}
+
 #ifdef __FreeBSD__
 #include <net/if_mib.h>
 #include <vmmapi.h>
@@ -211,7 +222,100 @@ CAMLprim value vmmanage_sysctl_ifdata (value num) {
 
   CAMLreturn(res);
 }
-#else /* FreeBSD */
+#elif __linux__ /* FreeBSD */
+#include <netlink/netlink.h>
+#include <netlink/socket.h>
+#include <netlink/route/link.h>
+
+#define get_stat(link, stat) rtnl_link_get_stat(link, RTNL_LINK_##stat)
+
+CAMLprim value vmmanage_sysctl_ifcount(value unit) {
+  CAMLparam1(unit);
+  int err;
+  struct nl_sock *nl_sock;
+  struct nl_cache *link_cache;
+
+  nl_sock = nl_socket_alloc();
+  if (nl_sock == 0)
+    uerror("nl_socket_alloc", Nothing);
+  err = nl_connect(nl_sock, NETLINK_ROUTE);
+  if (err < 0)
+    uerror("nl_connect", Nothing);
+  err = rtnl_link_alloc_cache(nl_sock, AF_UNSPEC, &link_cache);
+  if (err < 0)
+    uerror("rtnl_link_alloc_cache", Nothing);
+
+  CAMLreturn(Val_long(nl_cache_nitems(link_cache)));
+}
+
+CAMLprim value vmmanage_sysctl_ifdata(value num) {
+  CAMLparam1(num);
+  CAMLlocal1(res);
+  int err;
+  struct nl_sock *nl_sock;
+  struct nl_cache *link_cache;
+  struct rtnl_link *link;
+
+  nl_sock = nl_socket_alloc();
+  if (nl_sock == 0)
+    uerror("nl_socket_alloc", Nothing);
+  err = nl_connect(nl_sock, NETLINK_ROUTE);
+  if (err < 0)
+    uerror("nl_connect", Nothing);
+  err = rtnl_link_alloc_cache(nl_sock, AF_UNSPEC, &link_cache);
+  if (err < 0)
+    uerror("rtnl_link_alloc_cache", Nothing);
+  link = rtnl_link_get(link_cache, Int_val(num));
+  if (link == NULL)
+    uerror("rtnl_link_get", Nothing);
+  res = caml_alloc(18, 0);
+  Store_field(res, 0, caml_copy_string(rtnl_link_get_name(link)));
+  Store_field(res, 1, Val32(rtnl_link_get_flags(link)));
+  Store_field(res, 2, Val32(0)); /* send_length */
+  Store_field(res, 3, Val32(0)); /* max_send_length */
+  Store_field(res, 4, Val32(0)); /* send_drops */
+  Store_field(res, 5, Val32(rtnl_link_get_mtu(link)));
+  Store_field(res, 6, Val64(0)); /* baudrate */
+  Store_field(res, 7, Val64(get_stat(link, RX_PACKETS)));
+  Store_field(res, 8, Val64(get_stat(link, RX_ERRORS)));
+  Store_field(res, 9, Val64(get_stat(link, TX_PACKETS)));
+  Store_field(res, 10, Val64(get_stat(link, TX_ERRORS)));
+  Store_field(res, 11, Val64(get_stat(link, COLLISIONS)));
+  Store_field(res, 12, Val64(get_stat(link, RX_BYTES)));
+  Store_field(res, 13, Val64(get_stat(link, TX_BYTES)));
+  Store_field(res, 14, Val64(get_stat(link, MULTICAST)));
+  Store_field(res, 15, Val64(0));
+  Store_field(res, 16, Val64(get_stat(link, RX_DROPPED)));
+  Store_field(res, 17, Val64(get_stat(link, TX_DROPPED)));
+  CAMLreturn(res);
+}
+
+CAMLprim value vmmanage_sysctl_kinfo_proc (value pid_r) {
+  CAMLparam1(pid_r);
+  uerror("sysctl_kinfo_proc", Nothing);
+}
+
+CAMLprim value vmmanage_vmmapi_open (value name) {
+  CAMLparam1(name);
+  uerror("vmmapi_open", Nothing);
+}
+
+CAMLprim value vmmanage_vmmapi_close (value name) {
+  CAMLparam1(name);
+  uerror("vmmapi_close", Nothing);
+}
+
+CAMLprim value vmmanage_vmmapi_stats (value name) {
+  CAMLparam1(name);
+  uerror("vmmapi_stats", Nothing);
+}
+
+CAMLprim value vmmanage_vmmapi_statnames (value name) {
+  CAMLparam1(name);
+  uerror("vmmapi_statnames", Nothing);
+}
+
+#else /* Linux */
 
 /* stub symbols for OS currently not supported */
 

stats/config/discover.ml

@@ -0,0 +1,39 @@
+module C = Configurator.V1
+
+let write_sexp (conf : C.Pkg_config.package_conf) =
+  C.Flags.write_sexp "c_flags.sexp" conf.cflags;
+  C.Flags.write_sexp "c_library_flags.sexp" conf.libs
+
+let pkg_config_combine ~default deps =
+  let deps =
+    List.map (Result.fold ~ok:(fun x -> x) ~error:(fun e -> C.die "pkg-config: %s" e))
+      deps in
+  List.fold_left (fun conf dep ->
+      C.Pkg_config.{ libs = conf.libs @ dep.libs;
+                     cflags = conf.cflags @ dep.cflags })
+    default deps
+
+let freebsd _c =
+  let conf = { C.Pkg_config.libs = ["-lvmmapi"]; cflags = [] } in
+  write_sexp conf
+
+let linux c =
+  (* FIXME: cflags -I *)
+  let default = { C.Pkg_config.libs = ["-lnl-3"; "-lnl-route-3"]; cflags = [] } in
+  let conf =
+    match C.Pkg_config.get c with
+    | None -> default
+    | Some pc ->
+      pkg_config_combine ~default [
+        C.Pkg_config.query_expr_err pc ~package:"libnl-3.0" ~expr:"libnl-3.0";
+        C.Pkg_config.query_expr_err pc ~package:"libnl-route-3.0" ~expr:"libnl-route-3.0";
+      ]
+  in
+  write_sexp conf
+
+let () =
+  C.main ~name:"libnl-3-pkg-config" (fun c ->
+      match C.ocaml_config_var_exn c "system" with
+      | "freebsd" -> freebsd c
+      | "linux" -> linux c
+      | os -> failwith ("Unsupported platform: "^os))

stats/config/dune

@@ -0,0 +1,3 @@
+(executable
+ (name discover)
+ (libraries dune.configurator))

stats/dune

@@ -1,15 +1,11 @@
-(* -*- tuareg -*- *)
-
-let freebsd = try Sys.command "uname -s | grep -c FreeBSD > /dev/null" = 0 with _ -> false
-
-let () =
-  Jbuild_plugin.V1.send @@ Printf.sprintf {|
 (library
   (name albatross_stats)
   (public_name albatross.stats)
   (libraries albatross)
   (wrapped false)
   (c_names albatross_stats_stubs)
+  (c_flags (:include c_flags.sexp))
+  (c_library_flags (:include c_library_flags.sexp))
   (modules albatross_stats_pure))
 
 (executable
@@ -17,7 +13,6 @@ let () =
   (public_name albatross-stats)
   (package albatross)
   (modules albatross_stats)
-  %s
   (libraries albatross.cli albatross.stats albatross))
 
 (executable
@@ -25,9 +20,8 @@ let () =
   (public_name albatross-stat-client)
   (package albatross)
   (modules albatross_stat_client)
-  %s
   (libraries albatross.cli albatross.stats albatross))
- |}
-  (if freebsd then "(link_flags (-ccopt \"-lvmmapi\"))" else "")
-  (if freebsd then "(link_flags (-ccopt \"-lvmmapi\"))" else "")
 
+(rule
+  (targets c_flags.sexp c_library_flags.sexp)
+  (action (run ./config/discover.exe)))