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.11.1
-      - OCAML_VERSION: 4.09.0
   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-systemd.opam

@@ -1,19 +0,0 @@
-opam-version: "2.0"
-maintainer: "Hannes Mehnert <hannes@mehnert.org>"
-authors: ["Hannes Mehnert <hannes@mehnert.org>" "Reynir Björnsson <reynir@reynir.dk>"]
-homepage: "https://github.com/hannesm/albatross"
-dev-repo: "git+https://github.com/hannesm/albatross.git"
-bug-reports: "https://github.com/hannesm/albatross/issues"
-license: "ISC"
-available: os = "linux"
-
-depends: [
-  "albatross" {= version}
-  "fmt"
-  "fpath"
-]
-build: [
-  ["dune" "subst"] {pinned}
-  ["dune" "build" "-p" name "-j" jobs]
-]
-synopsis: "Albatross - orchestrate and manage MirageOS unikernels with Solo5 (SystemD files)"

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"
+homepage: "https://github.com/roburio/albatross"
-dev-repo: "git+https://github.com/hannesm/albatross.git"
+dev-repo: "git+https://github.com/roburio/albatross.git"
-bug-reports: "https://github.com/hannesm/albatross/issues"
+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 ->

daemon/albatrossd.ml

@@ -175,13 +175,13 @@ let jump _ systemd 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
+             Lwt_mutex.with_lock create_lock (fun () ->
-                (* not too happy about the sleep here, but cleaning up resources
+                 let state', tasks = Vmm_vmmd.killall !state Lwt.task in
-                   is really important (fifos, vm images, tap devices) - which
+                 state := state';
-                   is done asynchronously (in the task waitpid() on the pid) *)
+                 Lwt.return tasks) >>= fun tasks ->
-                Lwt_unix.sleep 1.
+             Lwt_list.iter_s (fun exit_code ->
-              else
+                 exit_code >>= fun (_ : process_exit) -> Lwt.return_unit)
-                Lwt.return_unit) >>= fun () ->
+               tasks >>= fun () ->
              Vmm_lwt.safe_close ss)
        in
        Sys.(set_signal sigterm

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/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.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.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.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/dune

@@ -1,16 +0,0 @@
-(executable
-  (name gen_socket)
-  (libraries albatross))
-
-(install
-  (files albatross_console.service albatross_console.socket
-   albatross_daemon.service albatross_daemon.socket
-   albatross_log.service albatross_log.socket
-   albatross_stats.service albatross_stats.socket)
-  (section share)
-  (package albatross-systemd))
-
-(rule
-  (targets albatross_console.socket albatross_daemon.socket
-   albatross_log.socket albatross_stats.socket)
-  (action (run ./gen_socket.exe)))

packaging/Linux/gen_socket.ml

@@ -1,51 +0,0 @@
-let pp_service ppf = function
-  | `Console -> Fmt.pf ppf "console"
-  | `Vmmd -> Fmt.pf ppf "daemon"
-  | `Stats -> Fmt.pf ppf "stats"
-  | `Log -> Fmt.pf ppf "log"
-
-let unprivileged_services = [ `Console; `Log; `Stats ]
-let privileged_services = [ `Vmmd ]
-
-let unprivileged_format : _ format= {|[Unit]
-Description=Albatross %s socket
-PartOf=%s
-
-[Socket]
-ListenStream=%s
-SocketUser=albatross
-SocketMode=0600
-Accept=no
-
-[Install]
-WantedBy=sockets.target
-|}
-
-let privileged_format : _ format = {|[Unit]
-Description=Albatross %s socket
-PartOf=%s
-
-[Socket]
-ListenStream=%s
-SocketMode=0600
-Accept=no
-
-[Install]
-WantedBy=sockets.target
-|}
-
-let write_socket privileged service =
-  let out_file = Fmt.str "albatross_%a.socket" pp_service service in
-  let systemd_service = Fmt.str "albatross_%a.service" pp_service service in
-  let service_name = Fmt.str "%a" pp_service service in
-  let socket_path = Vmm_core.socket_path (service :> Vmm_core.service) in
-  let oc = open_out out_file in
-  let ppf = Format.formatter_of_out_channel oc in
-  Fmt.pf ppf (if privileged then privileged_format else unprivileged_format)
-    service_name systemd_service socket_path
-
-let () =
-  let tmpdir = Fpath.(v "%t" / "albatross") in
-  let () = Vmm_core.set_tmpdir tmpdir in
-  List.iter (write_socket false) unprivileged_services;
-  List.iter (write_socket true) privileged_services

packaging/Linux/install.sh

@@ -5,8 +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 ../../_build/install/default/share/albatross-systemd/albatross_*.service /etc/systemd/system/
+sudo cp ./albatross_*.service ./albatross_*.socket /etc/systemd/system/
-sudo cp ../../_build/install/default/share/albatross-systemd/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
+  | `Policies ps -> my_fmt_list "no policies" Fmt.(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
+  | `Unikernels vms -> my_fmt_list "no unikernels" Fmt.(pair ~sep:(unit ": ") Name.pp Unikernel.pp_config) ppf vms
-  | `Block_devices blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks
+  | `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_unix.ml

@@ -201,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 ->
@@ -214,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 ()
@@ -230,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

@@ -37,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_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)))