revise the "--net=yyy" argument to (optionally) contain a service:bridge

it used to only contain service, and used the same string for the bridge. This
is not flexible enough to run off-the-shelf unikernels (configured for bridge
"service" and "management" on multi-homed servers). The old behaviour is the
new default (i.e. "--net=service" creates and attaches a tap device to bridge
"service", and passes "--net:service=tapYY" to the solo5 tender). But it is more
flexible now: "--net=service:other-bridge" will create a tap device attached to
"other-bridge" and pass "--net:service=tapYY" to the tender. This way, there's
no need to match bridge names on the actual server with network device names of
the unikernels.

NB: this is (mostly) backwards-compatible: the on-disk data structures are
versioned (and the version is bumped with this PR), an old albatross client can
send "create" commands to a new server. But a new client will get a parse error
from an old server - which is fine taking into consideration the deployment
base.

command-line/albatross_cli.ml

@@ -73,7 +73,7 @@ let create_vm force image cpuid memory argv block_devices bridges compression re
     let exits = match exit_codes with [] -> None | xs -> Some (IS.of_list xs) in
     if restart_on_fail then `Restart exits else `Quit
   in
-  let config = Unikernel.{ typ = `Solo5 ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv } in
+  let config = { Unikernel.typ = `Solo5 ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv } in
   if force then `Unikernel_force_create config else `Unikernel_create config
 
 let policy vms memory cpus block bridges =
@@ -216,9 +216,17 @@ let block =
   let doc = "Block device name" in
   Arg.(value & opt_all string [] & info [ "block" ] ~doc)
 
+let srv_bridge_c =
+  let parse s = match Astring.String.cut ~sep:":" s with
+    | None -> `Ok (s, None)
+    | Some (srv, bri) -> `Ok (srv, Some bri)
+  in
+  (parse, fun ppf (srv, bri) -> Fmt.pf ppf "%s:%s" srv
+       (match bri with None -> srv | Some bri -> bri))
+
 let net =
-  let doc = "Network device names" in
+  let doc = "Network device names (bridge or name:bridge)" in
-  Arg.(value & opt_all string [] & info [ "net" ] ~doc)
+  Arg.(value & opt_all srv_bridge_c [] & info [ "net" ] ~doc)
 
 let restart_on_fail =
   let doc = "Restart on fail" in

command-line/dune

@@ -3,4 +3,4 @@
   (public_name albatross.cli)
   (wrapped false)
   (modules albatross_cli)
-  (libraries checkseum.c albatross lwt.unix cmdliner logs.fmt logs.cli fmt.cli fmt.tty ipaddr.unix metrics metrics-lwt metrics-influx))
+  (libraries checkseum.c albatross lwt.unix cmdliner logs.fmt logs.cli fmt fmt.cli fmt.tty ipaddr.unix metrics metrics-lwt metrics-influx))

src/vmm_asn.ml

@@ -328,7 +328,7 @@ let fail_behaviour =
            (explicit 1 (set_of int)))
 
 (* this is part of the state file! *)
-let v3_unikernel_config =
+let v0_unikernel_config =
   let image =
     let f = function
       | `C1 x -> `Hvt_amd64, x
@@ -347,7 +347,7 @@ let v3_unikernel_config =
   in
   let open Unikernel in
   let f (cpuid, memory, block_device, network_interfaces, image, argv) =
-    let bridges = match network_interfaces with None -> [] | Some xs -> xs
+    let bridges = match network_interfaces with None -> [] | Some xs -> List.map (fun n -> n, None) xs
     and block_devices = match block_device with None -> [] | Some b -> [ b ]
     in
     let typ = `Solo5
@@ -357,7 +357,7 @@ let v3_unikernel_config =
     in
     { typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
   and g vm =
-    let network_interfaces = match vm.bridges with [] -> None | xs -> Some xs
+    let network_interfaces = match vm.bridges with [] -> None | xs -> Some (List.map fst xs)
     and block_device = match vm.block_devices with [] -> None | x::_ -> Some x
     and typ = if vm.compressed then `Hvt_amd64_compressed else `Hvt_amd64
     in
@@ -376,6 +376,30 @@ let v3_unikernel_config =
 
 (* this is part of the state file (and unikernel_create command)
    be aware if this (or a dependent grammar) is changed! *)
+let v1_unikernel_config =
+  let open Unikernel in
+  let f (typ, (compressed, (image, (fail_behaviour, (cpuid, (memory, (blocks, (bridges, argv)))))))) =
+    let bridges = match bridges with None -> [] | Some xs -> List.map (fun b -> b, None) xs
+    and block_devices = match blocks with None -> [] | Some xs -> xs
+    in
+    { typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
+  and g vm =
+    let bridges = match vm.bridges with [] -> None | xs -> Some (List.map fst xs)
+    and blocks = match vm.block_devices with [] -> None | xs -> Some xs
+    in
+    (vm.typ, (vm.compressed, (vm.image, (vm.fail_behaviour, (vm.cpuid, (vm.memory, (blocks, (bridges, vm.argv))))))))
+  in
+  Asn.S.(map f g @@ sequence @@
+           (required ~label:"typ" typ)
+         @ (required ~label:"compressed" bool)
+         @ (required ~label:"image" octet_string)
+         @ (required ~label:"fail behaviour" fail_behaviour)
+         @ (required ~label:"cpuid" int)
+         @ (required ~label:"memory" int)
+         @ (optional ~label:"blocks" (explicit 0 (set_of utf8_string)))
+         @ (optional ~label:"bridges" (explicit 1 (set_of utf8_string)))
+        -@ (optional ~label:"arguments"(explicit 2 (sequence_of utf8_string))))
+
 let unikernel_config =
   let open Unikernel in
   let f (typ, (compressed, (image, (fail_behaviour, (cpuid, (memory, (blocks, (bridges, argv)))))))) =
@@ -397,7 +421,11 @@ let unikernel_config =
          @ (required ~label:"cpuid" int)
          @ (required ~label:"memory" int)
          @ (optional ~label:"blocks" (explicit 0 (set_of utf8_string)))
-         @ (optional ~label:"bridges" (explicit 1 (set_of utf8_string)))
+         @ (optional ~label:"bridges"
+              (explicit 1 (sequence_of
+                             (sequence2
+                                (required ~label:"netif" utf8_string)
+                                (optional ~label:"bridge" utf8_string)))))
         -@ (optional ~label:"arguments"(explicit 2 (sequence_of utf8_string))))
 
 let unikernel_cmd =
@@ -406,18 +434,22 @@ let unikernel_cmd =
     | `C2 vm -> `Unikernel_create vm
     | `C3 vm -> `Unikernel_force_create vm
     | `C4 () -> `Unikernel_destroy
+    | `C5 vm -> `Unikernel_create vm
+    | `C6 vm -> `Unikernel_force_create vm
   and g = function
     | `Unikernel_info -> `C1 ()
-    | `Unikernel_create vm -> `C2 vm
+    | `Unikernel_create vm -> `C5 vm
-    | `Unikernel_force_create vm -> `C3 vm
+    | `Unikernel_force_create vm -> `C6 vm
     | `Unikernel_destroy -> `C4 ()
   in
   Asn.S.map f g @@
-  Asn.S.(choice4
+  Asn.S.(choice6
            (explicit 0 null)
-           (explicit 1 unikernel_config)
+           (explicit 1 v1_unikernel_config)
-           (explicit 2 unikernel_config)
+           (explicit 2 v1_unikernel_config)
-           (explicit 3 null))
+           (explicit 3 null)
+           (explicit 4 unikernel_config)
+           (explicit 5 unikernel_config))
 
 let policy_cmd =
   let f = function
@@ -632,9 +664,11 @@ let trie e =
               (required ~label:"name" utf8_string)
               (required ~label:"value" e)))
 
-let version0_unikernels = trie v3_unikernel_config
+let version0_unikernels = trie v0_unikernel_config
 
-let version1_unikernels = trie unikernel_config
+let version1_unikernels = trie v1_unikernel_config
+
+let version2_unikernels = trie unikernel_config
 
 let unikernels =
    (* the choice is the implicit version + migration... be aware when
@@ -642,13 +676,15 @@ let unikernels =
   let f = function
     | `C1 data -> data
     | `C2 data -> data
+    | `C3 data -> data
   and g data =
-    `C1 data
+    `C3 data
   in
   Asn.S.map f g @@
-  Asn.S.(choice2
+  Asn.S.(choice3
            (explicit 0 version1_unikernels)
-           (explicit 1 version0_unikernels))
+           (explicit 1 version0_unikernels)
+           (explicit 2 version2_unikernels))
 
 let unikernels_of_cstruct, unikernels_to_cstruct = projections_of unikernels
 

src/vmm_core.ml

@@ -207,10 +207,15 @@ module Unikernel = struct
     cpuid : int ;
     memory : int ;
     block_devices : string list ;
-    bridges : string list ;
+    bridges : (string * string option) list ;
     argv : string list option ;
   }
 
+  let bridges (vm : config) =
+    List.map
+      (fun (net, bri) -> match bri with None -> net | Some s -> s)
+      vm.bridges
+
   let pp_config ppf (vm : config) =
     Fmt.pf ppf "typ %a@ compression %B image %d bytes@ fail behaviour %a@ cpu %d@ %d MB memory@ block devices %a@ bridge %a@ argv %a"
       pp_typ vm.typ
@@ -219,7 +224,9 @@ module Unikernel = struct
       pp_fail_behaviour vm.fail_behaviour
       vm.cpuid vm.memory
       Fmt.(list ~sep:(unit ", ") string) vm.block_devices
-      Fmt.(list ~sep:(unit ", ") string) vm.bridges
+      Fmt.(list ~sep:(unit ", ")
+             (pair ~sep:(unit " -> ") string string))
+      (List.map (fun (a, b) -> a, (match b with None -> a | Some b -> b)) vm.bridges)
       Fmt.(option ~none:(unit "no") (list ~sep:(unit " ") string)) vm.argv
 
   let restart_handler config =

src/vmm_core.mli

@@ -82,10 +82,12 @@ module Unikernel : sig
     cpuid : int ;
     memory : int ;
     block_devices : string list ;
-    bridges : string list ;
+    bridges : (string * string option) list ;
     argv : string list option ;
   }
 
+  val bridges : config -> string list
+
   val pp_config : config Fmt.t
 
   val restart_handler : config -> bool

src/vmm_resources.ml

@@ -6,8 +6,6 @@ open Rresult.R.Infix
 
 open Vmm_core
 
-let flipped_set_mem set s = String.Set.mem s set
-
 type t = {
   policies : Policy.t Vmm_trie.t ;
   block_devices : (int * bool) Vmm_trie.t ;
@@ -135,6 +133,8 @@ let remove_block t name = match find_block t name with
       report_vms t' name;
       Ok t'
 
+let bridge_allowed set s = String.Set.mem s set
+
 let check_policy (p : Policy.t) (running_vms, used_memory) (vm : Unikernel.config) =
   if succ running_vms > p.Policy.vms then
     Error (`Msg "maximum amount of unikernels reached")
@@ -142,7 +142,7 @@ let check_policy (p : Policy.t) (running_vms, used_memory) (vm : Unikernel.confi
     Error (`Msg "maximum allowed memory reached")
   else if not (IS.mem vm.Unikernel.cpuid p.Policy.cpuids) then
     Error (`Msg "CPUid is not allowed by policy")
-  else if not (List.for_all (flipped_set_mem p.Policy.bridges) vm.Unikernel.bridges) then
+  else if not (List.for_all (bridge_allowed p.Policy.bridges) (Unikernel.bridges vm)) then
     Error (`Msg "network not allowed by policy")
   else Ok ()
 
@@ -261,7 +261,7 @@ let check_vms t name p =
     Vmm_trie.fold name t.unikernels
       (fun _ vm (bridges, cpuids) ->
          let config = vm.Unikernel.config in
-         (String.Set.(union (of_list config.Unikernel.bridges) bridges),
+         (String.Set.(union (of_list (Unikernel.bridges config)) bridges),
           IS.add config.Unikernel.cpuid cpuids))
       (String.Set.empty, IS.empty)
   in

src/vmm_unix.ml

@@ -202,10 +202,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 b ->
+  List.fold_left (fun acc (net, bri) ->
       acc >>= fun acc ->
-      create_tap b >>= fun tap ->
+      let bridge = match bri with None -> net | Some b -> b in
-      Ok (tap :: acc))
+      create_tap bridge >>= fun tap ->
+      Ok ((net, tap) :: acc))
     (Ok []) vm.Unikernel.bridges >>= fun taps ->
   Ok (List.rev taps)
 

src/vmm_unix.mli

@@ -12,7 +12,8 @@ val set_dbdir : Fpath.t -> unit
 
 val check_commands : unit -> (unit, [> R.msg ]) result
 
-val prepare : Name.t -> Unikernel.config -> (string list, [> R.msg ]) result
+val prepare : Name.t -> Unikernel.config ->
+  ((string * string) list, [> R.msg ]) result
 
 val exec : Name.t -> Unikernel.config -> (string * string) list ->
   (string * Name.t) list -> (Unikernel.t, [> R.msg ]) result

src/vmm_vmmd.ml

@@ -117,7 +117,7 @@ let setup_stats t name vm =
     let name = match Vmm_unix.vm_device vm with
       | Error _ -> ""
       | Ok name -> name
-    and ifs = Unikernel.(List.combine vm.config.bridges vm.taps)
+    and ifs = Unikernel.(List.combine (List.map fst vm.config.bridges) vm.taps)
     in
     `Stats_add (name, vm.Unikernel.pid, ifs)
   in
@@ -138,7 +138,9 @@ let handle_create t name vm_config =
   Vmm_resources.check_vm t.resources name vm_config >>= fun () ->
   (* prepare VM: save VM image to disk, create fifo, ... *)
   Vmm_unix.prepare name vm_config >>= fun taps ->
-  Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
+  Logs.debug (fun m -> m "prepared vm with taps %a"
+                 Fmt.(list ~sep:(unit ",@ ") (pair ~sep:(unit " -> ") string string))
+                 taps) ;
   let cons_out =
     let header = Vmm_commands.header ~sequence:t.console_counter name in
     (header, `Command (`Console_cmd `Console_add))
@@ -151,26 +153,25 @@ let handle_create t name vm_config =
        --> if either the first or second fails, then the fail continuation
            below needs to be called *)
     Vmm_resources.check_vm t.resources name vm_config >>= fun () ->
-    let ifs = List.combine vm_config.bridges taps
+    let block_devices =
-    and block_devices =
       List.map (fun d -> d, Name.block_name name d)
         vm_config.Unikernel.block_devices
     in
-    Vmm_unix.exec name vm_config ifs block_devices >>| fun vm ->
+    Vmm_unix.exec name vm_config taps block_devices >>| fun vm ->
     Logs.debug (fun m -> m "exec()ed vm") ;
     let resources = Vmm_resources.insert_vm t.resources name vm in
     let t = { t with resources } in
     dump_unikernels t ;
     let t, log_out =
       let start =
-        `Unikernel_start (name, vm.Unikernel.pid, ifs, block_devices)
+        `Unikernel_start (name, vm.Unikernel.pid, taps, block_devices)
       in
       log t name start
     in
     let t, stat_out = setup_stats t name vm in
     (t, stat_out, log_out, `Success (`String "created VM"), name, vm)
   and fail () =
-    match Vmm_unix.free_system_resources name taps with
+    match Vmm_unix.free_system_resources name (List.map snd taps) with
     | Ok () -> `Failure "could not create VM: console failed"
     | Error (`Msg msg) ->
       let m = "could not create VM: console failed, and also " ^ msg ^ " while cleaning resources" in