Add albatross-systemd package

Co-authored-by: Hannes Mehnert <hannes@mehnert.org>

.cirrus.yml

@@ -4,7 +4,8 @@ freebsd_instance:
 freebsd_task:
   env:
     matrix:
-      - OCAML_VERSION: 4.11.1
+      - OCAML_VERSION: 4.08.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

@@ -1,33 +0,0 @@
-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

@@ -0,0 +1,17 @@
+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,5 +1,7 @@
 # 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
@@ -83,7 +85,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/roburio/albatross`.
+https://github.com/hannesm/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

@@ -0,0 +1,19 @@
+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,18 +1,17 @@
 opam-version: "2.0"
 maintainer: "Hannes Mehnert <hannes@mehnert.org>"
 authors: ["Hannes Mehnert <hannes@mehnert.org>"]
-homepage: "https://github.com/roburio/albatross"
-dev-repo: "git+https://github.com/roburio/albatross.git"
-bug-reports: "https://github.com/roburio/albatross/issues"
+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"
 
 depends: [
   "ocaml" {>= "4.08.0"}
   "dune"
-  "dune-configurator"
-  "conf-pkg-config" {build}
   "lwt" {>= "3.0.0"}
   "ipaddr" {>= "4.0.0"}
+  "hex"
   "cstruct"
   "logs"
   "rresult"
@@ -38,8 +37,4 @@ 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,9 +102,7 @@ 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
-  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 () ->
+  Bos.OS.File.read (Fpath.v image) >>| fun image ->
   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 () ->
-             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 () ->
+             (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 () ->
              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/roburio/albatross
+www:	      https://github.com/hannesm/albatross
 maintainer:   Hannes Mehnert <hannes@mehnert.org>
 prefix:	      /usr/local
 licenselogic: single

packaging/Linux/albatross_console.socket

@@ -1,12 +0,0 @@
-[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

@@ -1,11 +0,0 @@
-[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

@@ -1,12 +0,0 @@
-[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

@@ -1,12 +0,0 @@
-[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

@@ -0,0 +1,16 @@
+(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

@@ -0,0 +1,51 @@
+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,7 +5,8 @@ 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 ./albatross_*.socket /etc/systemd/system/
+sudo cp ../../_build/install/default/share/albatross-systemd/albatross_*.service /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 ptime astring duration cstruct jsonm
+  (libraries rresult logs ipaddr bos hex ptime astring duration cstruct jsonm
              decompress lwt lwt.unix ptime.clock.os asn1-combinators metrics))

src/vmm_commands.ml

@@ -141,17 +141,12 @@ 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 -> 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
+  | `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
 
 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.%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"
+    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"
       (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.%06d"
+    Fmt.pf ppf "virtual-size %Lu rss %Lu text-size %Lu data-size %Lu stack-size %Lu runtime %Lu cow %u start %Lu.%d"
       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,30 +16,6 @@ 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,48 +201,6 @@ 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 ->
@@ -256,8 +214,6 @@ 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 ()
@@ -274,11 +230,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 arg ->
+  List.fold_left (fun acc (net, bri) ->
       acc >>= fun acc ->
-      let bridge = bridge_name arg in
+      let bridge = match bri with None -> net | Some b -> b in
       create_tap bridge >>= fun tap ->
-      Ok ((fst arg, tap) :: acc))
+      Ok ((net, tap) :: acc))
     (Ok []) vm.Unikernel.bridges >>= fun taps ->
   Ok (List.rev taps)
 

src/vmm_unix.mli

@@ -37,6 +37,3 @@ 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,6 +17,11 @@ 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) ->
@@ -58,17 +63,6 @@ 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 ;
@@ -218,7 +212,12 @@ let handle_policy_cmd t id = function
         (fun prefix policy policies-> (prefix, policy) :: policies)
         []
     in
-    Ok (t, `End (`Success (`Policies policies)))
+    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
   | `Unikernel_info ->
@@ -230,7 +229,13 @@ let handle_unikernel_cmd t id = function
            (id, cfg) :: vms)
         []
     in
-    Ok (t, `End (`Success (`Unikernels vms)))
+    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
@@ -299,7 +304,12 @@ let handle_block_cmd t id = function
         (fun prefix (size, active) blocks -> (prefix, size, active) :: blocks)
         []
     in
-    Ok (t, `End (`Success (`Block_devices blocks)))
+    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) =
   let msg_to_err = function

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 -> (unit -> 'b * 'a) -> 'a t * ('b list)
+val killall : 'a t -> bool
 
 val restore_unikernels : unit -> (Unikernel.config Vmm_trie.t, [> `Msg of string ]) result
 

stats/albatross_stats_pure.ml

@@ -5,8 +5,6 @@ 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"
@@ -101,103 +99,9 @@ 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 rusage pid with
+    match wrap sysctl_kinfo_proc pid with
     | None -> None, None
     | Some (mem, ru) -> Some mem, Some ru
   in

stats/albatross_stats_stubs.c

@@ -17,17 +17,6 @@
 #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>
@@ -222,100 +211,7 @@ CAMLprim value vmmanage_sysctl_ifdata (value num) {
 
   CAMLreturn(res);
 }
-#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 */
+#else /* FreeBSD */
 
 /* stub symbols for OS currently not supported */
 

stats/config/discover.ml

@@ -1,39 +0,0 @@
-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

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

stats/dune

@@ -1,11 +1,15 @@
+(* -*- 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
@@ -13,6 +17,7 @@
   (public_name albatross-stats)
   (package albatross)
   (modules albatross_stats)
+  %s
   (libraries albatross.cli albatross.stats albatross))
 
 (executable
@@ -20,8 +25,9 @@
   (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)))