Reword bridge detection error message

ip tuntap show lists all tuntap devices and ignores the rest of the
arguments, annoyingly. It will always return with exit code 0.

We do not detect if the interface is a bridge.

.cirrus.yml

@@ -5,7 +5,9 @@ freebsd_task:
   env:
     matrix:
       - OCAML_VERSION: 4.08.1
-      - OCAML_VERSION: 4.09.0
+      - OCAML_VERSION: 4.09.1
+      - OCAML_VERSION: 4.10.1
+      - 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 .

.travis.yml

@@ -7,11 +7,12 @@ services:
 env:
   global:
     - PACKAGE="albatross"
-    - DISTRO=ubuntu
+    - DISTRO=ubuntu-lts
     - TESTS=false
   matrix:
     - OCAML_VERSION=4.08
     - OCAML_VERSION=4.09
     - OCAML_VERSION=4.10
+    - OCAML_VERSION=4.11
 notifications:
   email: false

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

@@ -9,6 +9,8 @@ license: "ISC"
 depends: [
   "ocaml" {>= "4.08.0"}
   "dune"
+  "dune-configurator"
+  "conf-pkg-config" {build}
   "lwt" {>= "3.0.0"}
   "ipaddr" {>= "4.0.0"}
   "hex"
@@ -37,4 +39,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 ->

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

@@ -212,11 +212,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 +224,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 +293,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) =

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)))