reynir/albatross
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

rename Vm to Unikernel

Browse source
This commit is contained in:
Hannes Mehnert 2018-11-13 01:02:05 +01:00
parent 85372b0c7e
commit c8f1030403
17 changed files with 171 additions and 163 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
app/vmm_cli.ml
View file

@ -17,18 +17,18 @@ let setup_log style_renderer level =
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
let create_vm force image cpuid requested_memory argv block_device network compression =
let create_vm force image cpuid memory argv block_device network_interfaces compression =
let open Rresult.R.Infix in
Bos.OS.File.read (Fpath.v image) >>| fun image ->
let vmimage = match compression with
let image = match compression with
| 0 -> `Hvt_amd64, Cstruct.of_string image
| level ->
let img = Vmm_compress.compress ~level image in
`Hvt_amd64_compressed, Cstruct.of_string img
and argv = match argv with [] -> None | xs -> Some xs
in
let vm_config = Vm.{ cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } in
if force then `Vm_force_create vm_config else `Vm_create vm_config
let config = Unikernel.{ cpuid ; memory ; block_device ; network_interfaces ; argv ; image } in
if force then `Unikernel_force_create config else `Unikernel_create config
let policy vms memory cpus block bridges =
let bridges = String.Set.of_list bridges

16
app/vmmc_bistro.ml
View file

@ -63,9 +63,6 @@ let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
let jump endp cert key ca name cmd =
`Ok (Lwt_main.run (handle endp cert key ca name cmd))
let info_ _ endp cert key ca name =
jump endp cert key ca name (`Vm_cmd `Vm_info)
let info_policy _ endp cert key ca name =
jump endp cert key ca name (`Policy_cmd `Policy_info)
@ -76,12 +73,15 @@ let add_policy _ endp cert key ca name vms memory cpus block bridges =
let p = Vmm_cli.policy vms memory cpus block bridges in
jump endp cert key ca name (`Policy_cmd (`Policy_add p))
let destroy _ endp cert key ca name =
jump endp cert key ca name (`Vm_cmd `Vm_destroy)
let info_ _ endp cert key ca name =
jump endp cert key ca name (`Unikernel_cmd `Unikernel_info)
let create _ endp cert key ca force name image cpuid requested_memory boot_params block_device network compression =
match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with
| Ok cmd -> jump endp cert key ca name (`Vm_cmd cmd)
let destroy _ endp cert key ca name =
jump endp cert key ca name (`Unikernel_cmd `Unikernel_destroy)
let create _ endp cert key ca force name image cpuid memory argv block network compression =
match Vmm_cli.create_vm force image cpuid memory argv block network compression with
| Ok cmd -> jump endp cert key ca name (`Unikernel_cmd cmd)
| Error (`Msg msg) -> `Error (false, msg)
let console _ endp cert key ca name since =

15
app/vmmc_local.ml
View file

@ -43,8 +43,6 @@ let handle opt_socket name (cmd : Vmm_commands.t) =
let jump opt_socket name cmd =
`Ok (Lwt_main.run (handle opt_socket name cmd))
let info_ _ opt_socket name = jump opt_socket name (`Vm_cmd `Vm_info)
let info_policy _ opt_socket name =
jump opt_socket name (`Policy_cmd `Policy_info)
@ -55,12 +53,15 @@ let add_policy _ opt_socket name vms memory cpus block bridges =
let p = Vmm_cli.policy vms memory cpus block bridges in
jump opt_socket name (`Policy_cmd (`Policy_add p))
let destroy _ opt_socket name =
jump opt_socket name (`Vm_cmd `Vm_destroy)
let info_ _ opt_socket name =
jump opt_socket name (`Unikernel_cmd `Unikernel_info)
let create _ opt_socket force name image cpuid requested_memory boot_params block_device network compression =
match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with
| Ok cmd -> jump opt_socket name (`Vm_cmd cmd)
let destroy _ opt_socket name =
jump opt_socket name (`Unikernel_cmd `Unikernel_destroy)
let create _ opt_socket force name image cpuid memory argv block network compression =
match Vmm_cli.create_vm force image cpuid memory argv block network compression with
| Ok cmd -> jump opt_socket name (`Unikernel_cmd cmd)
| Error (`Msg msg) -> `Error (false, msg)
let console _ opt_socket name since =

10
app/vmmd.ml
View file

@ -2,6 +2,8 @@
open Vmm_cli
open Vmm_core
type stats = {
start : Ptime.t ;
vm_created : int ;
@ -32,7 +34,7 @@ let create process cont =
state := state'' ;
s := { !s with vm_created = succ !s.vm_created } ;
Lwt.async (fun () ->
Vmm_lwt.wait_and_clear vm.Vmm_core.Vm.pid vm.Vmm_core.Vm.stdout >>= fun r ->
Vmm_lwt.wait_and_clear vm.Unikernel.pid vm.Unikernel.stdout >>= fun r ->
let state', out' = Vmm_vmmd.handle_shutdown !state name vm r in
s := { !s with vm_destroyed = succ !s.vm_destroyed } ;
state := state' ;
@ -104,7 +106,7 @@ let handle out fd addr =
Vmm_lwt.safe_close fd
let init_sock sock =
let name = Vmm_core.socket_path sock in
let name = socket_path sock in
let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.set_close_on_exec c ;
Lwt.catch (fun () ->
@ -128,13 +130,13 @@ let create_mbox sock =
Lwt_mvar.take mvar >>= fun data ->
Vmm_lwt.write_wire fd data >>= function
| Ok () -> loop ()
| Error `Exception -> invalid_arg ("exception while writing to " ^ Fmt.to_to_string Vmm_core.pp_socket sock) ;
| Error `Exception -> invalid_arg ("exception while writing to " ^ Fmt.to_to_string pp_socket sock) ;
in
Lwt.async loop ;
Some (mvar, fd)
let server_socket sock =
let name = Vmm_core.socket_path sock in
let name = socket_path sock in
(Lwt_unix.file_exists name >>= function
| true -> Lwt_unix.unlink name
| false -> Lwt.return_unit) >>= fun () ->

14
app/vmmp_request.ml
View file

@ -25,8 +25,6 @@ let jump id cmd =
| Ok () -> `Ok ()
| Error (`Msg m) -> `Error (false, m)
let info_ _ name = jump name (`Vm_cmd `Vm_info)
let info_policy _ name =
jump name (`Policy_cmd `Policy_info)
@ -37,12 +35,14 @@ let add_policy _ name vms memory cpus block bridges =
let p = Vmm_cli.policy vms memory cpus block bridges in
jump name (`Policy_cmd (`Policy_add p))
let destroy _ name =
jump name (`Vm_cmd `Vm_destroy)
let info_ _ name = jump name (`Unikernel_cmd `Unikernel_info)
let create _ force name image cpuid requested_memory boot_params block_device network compression =
match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with
| Ok cmd -> jump name (`Vm_cmd cmd)
let destroy _ name =
jump name (`Unikernel_cmd `Unikernel_destroy)
let create _ force name image cpuid memory argv block network compression =
match Vmm_cli.create_vm force image cpuid memory argv block network compression with
| Ok cmd -> jump name (`Unikernel_cmd cmd)
| Error (`Msg msg) -> `Error (false, msg)
let console _ name since =

63
src/vmm_asn.ml
View file

@ -184,20 +184,20 @@ let log_event =
| `C1 () -> `Startup
| `C2 (name, ip, port) -> `Login (to_name name, ip, port)
| `C3 (name, ip, port) -> `Logout (to_name name, ip, port)
| `C4 (name, pid, taps, block) -> `Vm_start (to_name name, pid, taps, block)
| `C4 (name, pid, taps, block) -> `Unikernel_start (to_name name, pid, taps, block)
| `C5 (name, pid, status) ->
let status' = match status with
| `C1 n -> `Exit n
| `C2 n -> `Signal n
| `C3 n -> `Stop n
in
`Vm_stop (to_name name, pid, status')
`Unikernel_stop (to_name name, pid, status')
and g = function
| `Startup -> `C1 ()
| `Login (name, ip, port) -> `C2 (of_name name, ip, port)
| `Logout (name, ip, port) -> `C3 (of_name name, ip, port)
| `Vm_start (name, pid, taps, block) -> `C4 (of_name name, pid, taps, block)
| `Vm_stop (name, pid, status) ->
| `Unikernel_start (name, pid, taps, block) -> `C4 (of_name name, pid, taps, block)
| `Unikernel_stop (name, pid, status) ->
let status' = match status with
| `Exit n -> `C1 n
| `Signal n -> `C2 n
@ -238,40 +238,41 @@ let log_cmd =
Asn.S.map f g @@
Asn.S.(sequence (single (optional ~label:"since" utc_time)))
let vm_config =
let f (cpuid, requested_memory, block_device, network, vmimage, argv) =
let network = match network with None -> [] | Some xs -> xs in
Vm.{ cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
let unikernel_config =
let open Unikernel in
let f (cpuid, memory, block_device, network_interfaces, image, argv) =
let network_interfaces = match network_interfaces with None -> [] | Some xs -> xs in
{ cpuid ; memory ; block_device ; network_interfaces ; image ; argv }
and g vm =
let network = match vm.Vm.network with [] -> None | xs -> Some xs in
(vm.Vm.cpuid, vm.Vm.requested_memory, vm.Vm.block_device, network, vm.Vm.vmimage, vm.Vm.argv)
let network_interfaces = match vm.network_interfaces with [] -> None | xs -> Some xs in
(vm.cpuid, vm.memory, vm.block_device, network_interfaces, vm.image, vm.argv)
in
Asn.S.map f g @@
Asn.S.(sequence6
(required ~label:"cpu" int)
(required ~label:"memory" int)
(optional ~label:"block" utf8_string)
(optional ~label:"bridges" (sequence_of utf8_string))
(required ~label:"vmimage" image)
(optional ~label:"network_interfaces" (sequence_of utf8_string))
(required ~label:"image" image)
(optional ~label:"arguments" (sequence_of utf8_string)))
let vm_cmd =
let unikernel_cmd =
let f = function
| `C1 () -> `Vm_info
| `C2 vm -> `Vm_create vm
| `C3 vm -> `Vm_force_create vm
| `C4 () -> `Vm_destroy
| `C1 () -> `Unikernel_info
| `C2 vm -> `Unikernel_create vm
| `C3 vm -> `Unikernel_force_create vm
| `C4 () -> `Unikernel_destroy
and g = function
| `Vm_info -> `C1 ()
| `Vm_create vm -> `C2 vm
| `Vm_force_create vm -> `C3 vm
| `Vm_destroy -> `C4 ()
| `Unikernel_info -> `C1 ()
| `Unikernel_create vm -> `C2 vm
| `Unikernel_force_create vm -> `C3 vm
| `Unikernel_destroy -> `C4 ()
in
Asn.S.map f g @@
Asn.S.(choice4
(explicit 0 null)
(explicit 1 vm_config)
(explicit 2 vm_config)
(explicit 1 unikernel_config)
(explicit 2 unikernel_config)
(explicit 3 null))
let policy_cmd =
@ -320,14 +321,14 @@ let wire_command =
| `C1 console -> `Console_cmd console
| `C2 stats -> `Stats_cmd stats
| `C3 log -> `Log_cmd log
| `C4 vm -> `Vm_cmd vm
| `C4 vm -> `Unikernel_cmd vm
| `C5 policy -> `Policy_cmd policy
| `C6 block -> `Block_cmd block
and g = function
| `Console_cmd c -> `C1 c
| `Stats_cmd c -> `C2 c
| `Log_cmd c -> `C3 c
| `Vm_cmd c -> `C4 c
| `Unikernel_cmd c -> `C4 c
| `Policy_cmd c -> `C5 c
| `Block_cmd c -> `C6 c
in
@ -336,7 +337,7 @@ let wire_command =
(explicit 0 console_cmd)
(explicit 1 stats_cmd)
(explicit 2 log_cmd)
(explicit 3 vm_cmd)
(explicit 3 unikernel_cmd)
(explicit 4 policy_cmd)
(explicit 5 block_cmd))
@ -381,14 +382,14 @@ let success =
| `C1 () -> `Empty
| `C2 str -> `String str
| `C3 policies -> `Policies (List.map (fun (name, p) -> to_name name, p) policies)
| `C4 vms -> `Vms (List.map (fun (name, vm) -> to_name name, vm) vms)
| `C5 blocks -> `Blocks (List.map (fun (name, s, a) -> to_name name, s, a) blocks)
| `C4 vms -> `Unikernels (List.map (fun (name, vm) -> to_name name, vm) vms)
| `C5 blocks -> `Block_devices (List.map (fun (name, s, a) -> to_name name, s, a) blocks)
and g = function
| `Empty -> `C1 ()
| `String s -> `C2 s
| `Policies ps -> `C3 (List.map (fun (name, p) -> of_name name, p) ps)
| `Vms vms -> `C4 (List.map (fun (name, v) -> of_name name, v) vms)
| `Blocks blocks -> `C5 (List.map (fun (name, s, a) -> of_name name, s, a) blocks)
| `Unikernels vms -> `C4 (List.map (fun (name, v) -> of_name name, v) vms)
| `Block_devices blocks -> `C5 (List.map (fun (name, s, a) -> of_name name, s, a) blocks)
in
Asn.S.map f g @@
Asn.S.(choice5
@ -401,7 +402,7 @@ let success =
(explicit 3 (sequence_of
(sequence2
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"vm_config" vm_config))))
(required ~label:"config" unikernel_config))))
(explicit 4 (sequence_of
(sequence3
(required ~label:"name" (sequence_of utf8_string))

34
src/vmm_commands.ml
View file

@ -46,18 +46,18 @@ let pp_log_cmd ppf = function
Fmt.pf ppf "log subscribe since %a"
Fmt.(option ~none:(unit "epoch") (Ptime.pp_rfc3339 ())) ts
type vm_cmd = [
| `Vm_info
| `Vm_create of Vm.config
| `Vm_force_create of Vm.config
| `Vm_destroy
type unikernel_cmd = [
| `Unikernel_info
| `Unikernel_create of Unikernel.config
| `Unikernel_force_create of Unikernel.config
| `Unikernel_destroy
]
let pp_vm_cmd ppf = function
| `Vm_info -> Fmt.string ppf "vm info"
| `Vm_create vm_config -> Fmt.pf ppf "vm create %a" Vm.pp_config vm_config
| `Vm_force_create vm_config -> Fmt.pf ppf "vm force create %a" Vm.pp_config vm_config
| `Vm_destroy -> Fmt.string ppf "vm destroy"
let pp_unikernel_cmd ppf = function
| `Unikernel_info -> Fmt.string ppf "unikernel info"
| `Unikernel_create config -> Fmt.pf ppf "unikernel create %a" Unikernel.pp_config config
| `Unikernel_force_create config -> Fmt.pf ppf "vm force create %a" Unikernel.pp_config config
| `Unikernel_destroy -> Fmt.string ppf "unikernel destroy"
type policy_cmd = [
| `Policy_info
@ -85,7 +85,7 @@ type t = [
| `Console_cmd of console_cmd
| `Stats_cmd of stats_cmd
| `Log_cmd of log_cmd
| `Vm_cmd of vm_cmd
| `Unikernel_cmd of unikernel_cmd
| `Policy_cmd of policy_cmd
| `Block_cmd of block_cmd
]
@ -94,7 +94,7 @@ let pp ppf = function
| `Console_cmd c -> pp_console_cmd ppf c
| `Stats_cmd s -> pp_stats_cmd ppf s
| `Log_cmd l -> pp_log_cmd ppf l
| `Vm_cmd v -> pp_vm_cmd ppf v
| `Unikernel_cmd v -> pp_unikernel_cmd ppf v
| `Policy_cmd p -> pp_policy_cmd ppf p
| `Block_cmd b -> pp_block_cmd ppf b
@ -120,8 +120,8 @@ type success = [
| `Empty
| `String of string
| `Policies of (Name.t * Policy.t) list
| `Vms of (Name.t * Vm.config) list
| `Blocks of (Name.t * int * bool) list
| `Unikernels of (Name.t * Unikernel.config) list
| `Block_devices of (Name.t * int * bool) list
]
let pp_block ppf (id, size, active) =
@ -131,8 +131,8 @@ 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
| `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Vm.pp_config)) ppf vms
| `Blocks blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks
| `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 wire = header * [
| `Command of t
@ -149,7 +149,7 @@ let pp_wire ppf (header, data) =
| `Data d -> pp_data ppf d
let endpoint = function
| `Vm_cmd _ -> `Vmmd, `End
| `Unikernel_cmd _ -> `Vmmd, `End
| `Policy_cmd _ -> `Vmmd, `End
| `Block_cmd _ -> `Vmmd, `End
| `Stats_cmd _ -> `Stats, `Read

16
src/vmm_commands.mli
View file

@ -26,11 +26,11 @@ type log_cmd = [
| `Log_subscribe of Ptime.t option
]
type vm_cmd = [
| `Vm_info
| `Vm_create of Vm.config
| `Vm_force_create of Vm.config
| `Vm_destroy
type unikernel_cmd = [
| `Unikernel_info
| `Unikernel_create of Unikernel.config
| `Unikernel_force_create of Unikernel.config
| `Unikernel_destroy
]
type policy_cmd = [
@ -49,7 +49,7 @@ type t = [
| `Console_cmd of console_cmd
| `Stats_cmd of stats_cmd
| `Log_cmd of log_cmd
| `Vm_cmd of vm_cmd
| `Unikernel_cmd of unikernel_cmd
| `Policy_cmd of policy_cmd
| `Block_cmd of block_cmd
]
@ -74,8 +74,8 @@ type success = [
| `Empty
| `String of string
| `Policies of (Name.t * Policy.t) list
| `Vms of (Name.t * Vm.config) list
| `Blocks of (Name.t * int * bool) list
| `Unikernels of (Name.t * Unikernel.config) list
| `Block_devices of (Name.t * int * bool) list
]
type wire = header * [

32
src/vmm_core.ml
View file

@ -146,33 +146,33 @@ module Policy = struct
(String.Set.pp ~sep:Fmt.(unit ", ") Fmt.string) res.bridges
end
module Vm = struct
type vmtype = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ]
module Unikernel = struct
type typ = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ]
let pp_vmtype ppf = function
let pp_typ ppf = function
| `Hvt_amd64 -> Fmt.pf ppf "hvt-amd64"
| `Hvt_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed"
| `Hvt_arm64 -> Fmt.pf ppf "hvt-arm64"
type config = {
cpuid : int ;
requested_memory : int ;
memory : int ;
block_device : string option ;
network : string list ;
vmimage : vmtype * Cstruct.t ;
network_interfaces : string list ;
image : typ * Cstruct.t ;
argv : string list option ;
}
let pp_image ppf (typ, blob) =
let l = Cstruct.len blob in
Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l
Fmt.pf ppf "%a: %d bytes" pp_typ typ l
let pp_config ppf (vm : config) =
Fmt.pf ppf "cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a"
vm.cpuid vm.requested_memory
vm.cpuid vm.memory
Fmt.(option ~none:(unit "no") string) vm.block_device
Fmt.(list ~sep:(unit ", ") string) vm.network
pp_image vm.vmimage
Fmt.(list ~sep:(unit ", ") string) vm.network_interfaces
pp_image vm.image
Fmt.(option ~none:(unit "no") (list ~sep:(unit " ") string)) vm.argv
type t = {
@ -264,26 +264,26 @@ module Log = struct
| `Login of Name.t * Ipaddr.V4.t * int
| `Logout of Name.t * Ipaddr.V4.t * int
| `Startup
| `Vm_start of Name.t * int * string list * string option
| `Vm_stop of Name.t * int * process_exit
| `Unikernel_start of Name.t * int * string list * string option
| `Unikernel_stop of Name.t * int * process_exit
]
let name = function
| `Startup -> []
| `Login (name, _, _) -> name
| `Logout (name, _, _) -> name
| `Vm_start (name, _, _ ,_) -> name
| `Vm_stop (name, _, _) -> name
| `Unikernel_start (name, _, _ ,_) -> name
| `Unikernel_stop (name, _, _) -> name
let pp_log_event ppf = function
| `Startup -> Fmt.(pf ppf "startup")
| `Login (name, ip, port) -> Fmt.pf ppf "%a login %a:%d" Name.pp name Ipaddr.V4.pp_hum ip port
| `Logout (name, ip, port) -> Fmt.pf ppf "%a logout %a:%d" Name.pp name Ipaddr.V4.pp_hum ip port
| `Vm_start (name, pid, taps, block) ->
| `Unikernel_start (name, pid, taps, block) ->
Fmt.pf ppf "%a started %d (tap %a, block %a)"
Name.pp name pid Fmt.(list ~sep:(unit "; ") string) taps
Fmt.(option ~none:(unit "no") string) block
| `Vm_stop (name, pid, code) ->
| `Unikernel_stop (name, pid, code) ->
Fmt.pf ppf "%a stopped %d with %a" Name.pp name pid pp_process_exit code
type t = Ptime.t * log_event

18
src/vmm_core.mli
View file

@ -53,20 +53,20 @@ module Policy : sig
val pp : t Fmt.t
end
module Vm : sig
type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
val pp_vmtype : vmtype Fmt.t
module Unikernel : sig
type typ = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
val pp_typ : typ Fmt.t
type config = {
cpuid : int;
requested_memory : int;
memory : int;
block_device : string option;
network : string list;
vmimage : vmtype * Cstruct.t;
network_interfaces : string list;
image : typ * Cstruct.t;
argv : string list option;
}
val pp_image : (vmtype * Cstruct.t) Fmt.t
val pp_image : (typ * Cstruct.t) Fmt.t
val pp_config : config Fmt.t
@ -140,8 +140,8 @@ module Log : sig
| `Login of Name.t * Ipaddr.V4.t * int
| `Logout of Name.t * Ipaddr.V4.t * int
| `Startup
| `Vm_start of Name.t * int * string list * string option
| `Vm_stop of Name.t * int * process_exit ]
| `Unikernel_start of Name.t * int * string list * string option
| `Unikernel_stop of Name.t * int * process_exit ]
val name : log_event -> Name.t

25
src/vmm_resources.ml
View file

@ -11,7 +11,7 @@ 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 ;
unikernels : Vm.t Vmm_trie.t ;
unikernels : Unikernel.t Vmm_trie.t ;
}
let pp ppf t =
@ -23,7 +23,7 @@ let pp ppf t =
Fmt.pf ppf "block device %a: %dMB (used %B)@." Name.pp id size used) () ;
Vmm_trie.fold Name.root t.unikernels
(fun id vm () ->
Fmt.pf ppf "vm %a: %a@." Name.pp id Vm.pp_config vm.Vm.config) ()
Fmt.pf ppf "vm %a: %a@." Name.pp id Unikernel.pp_config vm.Unikernel.config) ()
let empty = {
policies = Vmm_trie.empty ;
@ -40,7 +40,7 @@ let block_usage t name =
let vm_usage t name =
Vmm_trie.fold name t.unikernels
(fun _ vm (vms, memory) -> (succ vms, memory + vm.Vm.config.Vm.requested_memory))
(fun _ vm (vms, memory) -> (succ vms, memory + vm.Unikernel.config.Unikernel.memory))
(0, 0)
let find_vm t name = Vmm_trie.find name t.unikernels
@ -59,7 +59,7 @@ let set_block_usage t name active =
Ok (fst (Vmm_trie.insert name (size, active) t))
let maybe_use_block t name vm active =
match vm.Vm.config.Vm.block_device with
match vm.Unikernel.config.Unikernel.block_device with
| None -> Ok t
| Some block ->
let block_name = Name.block_name name block in
@ -87,14 +87,14 @@ let remove_block t name = match find_block t name with
let block_devices = Vmm_trie.remove name t.block_devices in
Ok { t with block_devices }
let check_policy (p : Policy.t) (running_vms, used_memory) (vm : Vm.config) =
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")
else if vm.Vm.requested_memory > p.Policy.memory - used_memory then
else if vm.Unikernel.memory > p.Policy.memory - used_memory then
Error (`Msg "maximum allowed memory reached")
else if not (IS.mem vm.Vm.cpuid p.Policy.cpuids) then
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.Vm.network) then
else if not (List.for_all (flipped_set_mem p.Policy.bridges) vm.Unikernel.network_interfaces) then
Error (`Msg "network not allowed by policy")
else Ok ()
@ -106,7 +106,7 @@ let check_vm t name vm =
| Some p ->
let used = vm_usage t dom in
check_policy p used vm
and block_ok = match vm.Vm.block_device with
and block_ok = match vm.Unikernel.block_device with
| None -> Ok ()
| Some block ->
let block_name = Name.block_name name block in
@ -126,7 +126,7 @@ let check_vm t name vm =
vm_ok
let insert_vm t name vm =
check_vm t name vm.Vm.config >>= fun () ->
check_vm t name vm.Unikernel.config >>= fun () ->
match Vmm_trie.insert name vm t.unikernels with
| unikernels, None ->
maybe_use_block t.block_devices name vm true >>| fun block_devices ->
@ -209,8 +209,9 @@ let check_vms t name p =
let bridges, cpuids =
Vmm_trie.fold name t.unikernels
(fun _ vm (bridges, cpuids) ->
let config = vm.Vm.config in
(String.Set.(union (of_list config.Vm.network) bridges), IS.add config.Vm.cpuid cpuids))
let config = vm.Unikernel.config in
(String.Set.(union (of_list config.Unikernel.network_interfaces) bridges),
IS.add config.Unikernel.cpuid cpuids))
(String.Set.empty, IS.empty)
in
let policy_block = match p.Policy.block with None -> 0 | Some x -> x in

8
src/vmm_resources.mli
View file

@ -17,7 +17,7 @@ open Vmm_core
type t = private {
policies : Policy.t Vmm_trie.t ;
block_devices : (int * bool) Vmm_trie.t ;
unikernels : Vm.t Vmm_trie.t ;
unikernels : Unikernel.t Vmm_trie.t ;
}
@ -25,7 +25,7 @@ type t = private {
val empty : t
(** [find_vm t id] is either [Some vm] or [None]. *)
val find_vm : t -> Name.t -> Vm.t option
val find_vm : t -> Name.t -> Unikernel.t option
(** [find_policy t Name.t] is either [Some policy] or [None]. *)
val find_policy : t -> Name.t -> Policy.t option
@ -35,11 +35,11 @@ val find_block : t -> Name.t -> (int * bool) option
(** [check_vm t Name.t vm] checks whether [vm] under [Name.t] in [t] would be
allowed under the current policies. *)
val check_vm : t -> Name.t -> Vm.config -> (unit, [> `Msg of string ]) result
val check_vm : t -> Name.t -> Unikernel.config -> (unit, [> `Msg of string ]) result
(** [insert_vm t Name.t vm] inserts [vm] under [Name.t] in [t], and returns the new [t] or
an error. *)
val insert_vm : t -> Name.t -> Vm.t -> (t, [> `Msg of string]) result
val insert_vm : t -> Name.t -> Unikernel.t -> (t, [> `Msg of string]) result
(** [insert_policy t Name.t policy] inserts [policy] under [Name.t] in [t], and returns
the new [t] or an error. *)

2
src/vmm_tls.ml
View file

@ -102,6 +102,6 @@ let handle _addr version chain =
| `Console_cmd (`Console_subscribe _)
| `Stats_cmd `Stats_subscribe
| `Log_cmd (`Log_subscribe _)
| `Vm_cmd _
| `Unikernel_cmd _
| `Policy_cmd `Policy_info -> Ok (name, policies, wire)
| _ -> Error (`Msg "unexpected command")

18
src/vmm_unix.ml
View file

@ -107,7 +107,7 @@ let destroy_tap tapname =
| x -> Error (`Msg ("unsupported operating system " ^ x))
let prepare name vm =
(match vm.Vm.vmimage with
(match vm.Unikernel.image with
| `Hvt_amd64, blob -> Ok blob
| `Hvt_amd64_compressed, blob ->
begin match Vmm_compress.uncompress (Cstruct.to_string blob) with
@ -128,7 +128,7 @@ let prepare name vm =
acc >>= fun acc ->
create_tap b >>= fun tap ->
Ok (tap :: acc))
(Ok []) vm.Vm.network >>= fun taps ->
(Ok []) vm.Unikernel.network_interfaces >>= fun taps ->
Bos.OS.File.write (Name.image_file name) (Cstruct.to_string image) >>= fun () ->
Ok (List.rev taps)
@ -136,7 +136,7 @@ let shutdown name vm =
(* same order as prepare! *)
Bos.OS.File.delete (Name.image_file name) >>= fun () ->
Bos.OS.File.delete (Name.fifo_file name) >>= fun () ->
List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.Vm.taps
List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.Unikernel.taps
let cpuset cpu =
Lazy.force (uname ()) >>= fun (sys, _) ->
@ -157,10 +157,10 @@ let exec name vm taps block =
| _, _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin ->
let net = List.map (fun t -> "--net=" ^ t) taps
and block = match block with None -> [] | Some dev -> [ "--disk=" ^ Fpath.to_string (block_file dev) ]
and argv = match vm.Vm.argv with None -> [] | Some xs -> xs
and mem = "--mem=" ^ string_of_int vm.Vm.requested_memory
and argv = match vm.Unikernel.argv with None -> [] | Some xs -> xs
and mem = "--mem=" ^ string_of_int vm.Unikernel.memory
in
cpuset vm.Vm.cpuid >>= fun cpuset ->
cpuset vm.Unikernel.cpuid >>= fun cpuset ->
let cmd =
Bos.Cmd.(of_list cpuset % p Fpath.(dbdir / "solo5-hvt" + bin) % mem %%
of_list net %% of_list block %
@ -178,14 +178,14 @@ let exec name vm taps block =
let pid = create_process prog line stdout stdout in
Logs.debug (fun m -> m "created process %d: %a" pid Bos.Cmd.pp cmd) ;
(* this should get rid of the vmimage from vmmd's memory! *)
let config = Vm.{ vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in
Ok Vm.{ config ; cmd ; pid ; taps ; stdout }
let config = Unikernel.{ vm with image = (fst vm.Unikernel.image, Cstruct.create 0) } in
Ok Unikernel.{ config ; cmd ; pid ; taps ; stdout }
with
Unix.Unix_error (e, _, _) ->
close_no_err stdout;
R.error_msgf "cmd %a exits: %a" Bos.Cmd.pp cmd pp_unix_error e
let destroy vm = Unix.kill vm.Vm.pid 15 (* 15 is SIGTERM *)
let destroy vm = Unix.kill vm.Unikernel.pid 15 (* 15 is SIGTERM *)
let bytes_of_mb size =
let res = size lsl 20 in

9
src/vmm_unix.mli
View file

@ -4,13 +4,14 @@ open Rresult
open Vmm_core
val prepare : Name.t -> Vm.config -> (string list, [> R.msg ]) result
val prepare : Name.t -> Unikernel.config -> (string list, [> R.msg ]) result
val shutdown : Name.t -> Vm.t -> (unit, [> R.msg ]) result
val exec : Name.t -> Unikernel.config -> string list -> Name.t option ->
(Unikernel.t, [> R.msg ]) result
val exec : Name.t -> Vm.config -> string list -> Name.t option -> (Vm.t, [> R.msg ]) result
val shutdown : Name.t -> Unikernel.t -> (unit, [> R.msg ]) result
val destroy : Vm.t -> unit
val destroy : Unikernel.t -> unit
val close_no_err : Unix.file_descr -> unit

36
src/vmm_vmmd.ml
View file

@ -34,7 +34,7 @@ let init wire_version =
List.fold_left (fun r (id, size) ->
match Vmm_resources.insert_block r id size with
| Error (`Msg msg) ->
Logs.err (fun m -> m "couldn't insert block device %a (%dM): %s" Name.pp id size msg) ;
Logs.err (fun m -> m "couldn't insert block device %a (%dMB): %s" Name.pp id size msg) ;
r
| Ok r -> r)
t.resources devs
@ -73,7 +73,7 @@ let handle_create t reply name vm_config =
[ `Cons cons_out ],
`Create (fun t task ->
(* actually execute the vm *)
let block_device = match vm_config.Vm.block_device with
let block_device = match vm_config.Unikernel.block_device with
| None -> None
| Some block -> Some (Name.block_name name block)
in
@ -82,11 +82,11 @@ let handle_create t reply name vm_config =
Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
let tasks = String.Map.add (Name.to_string name) task t.tasks in
let t = { t with resources ; tasks } in
let t, out = log t name (`Vm_start (name, vm.Vm.pid, vm.Vm.taps, None)) in
let t, out = log t name (`Unikernel_start (name, vm.Unikernel.pid, vm.Unikernel.taps, None)) in
Ok (t, [ reply (`String "created VM") ; out ], name, vm)))
let setup_stats t name vm =
let stat_out = `Stats_add (vm.Vm.pid, vm.Vm.taps) in
let stat_out = `Stats_add (vm.Unikernel.pid, vm.Unikernel.taps) in
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; name } in
let t = { t with stats_counter = Int64.succ t.stats_counter } in
t, `Stat (header, `Command (`Stats_cmd stat_out))
@ -94,17 +94,17 @@ let setup_stats t name vm =
let handle_shutdown t name vm r =
(match Vmm_unix.shutdown name vm with
| Ok () -> ()
| Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e Vm.pp vm)) ;
| Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e Unikernel.pp vm)) ;
let resources = match Vmm_resources.remove_vm t.resources name with
| Error (`Msg e) ->
Logs.warn (fun m -> m "%s while removing vm %a from resources" e Vm.pp vm) ;
Logs.warn (fun m -> m "%s while removing vm %a from resources" e Unikernel.pp vm) ;
t.resources
| Ok resources -> resources
in
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; name } in
let tasks = String.Map.remove (Name.to_string name) t.tasks in
let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in
let t, logout = log t name (`Vm_stop (name, vm.Vm.pid, r))
let t, logout = log t name (`Unikernel_stop (name, vm.Unikernel.pid, r))
in
(t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ])
@ -138,23 +138,23 @@ let handle_policy_cmd t reply id = function
| _ ->
Ok (t, [ reply (`Policies policies) ], `End)
let handle_vm_cmd t reply id msg_to_err = function
| `Vm_info ->
let handle_unikernel_cmd t reply id msg_to_err = function
| `Unikernel_info ->
Logs.debug (fun m -> m "info %a" Name.pp id) ;
let vms =
Vmm_trie.fold id t.resources.Vmm_resources.unikernels
(fun id vm vms -> (id, vm.Vm.config) :: vms)
(fun id vm vms -> (id, vm.Unikernel.config) :: vms)
[]
in
begin match vms with
| [] ->
Logs.debug (fun m -> m "info: couldn't find %a" Name.pp id) ;
Error (`Msg "info: not found")
Error (`Msg "info: no unikernel found")
| _ ->
Ok (t, [ reply (`Vms vms) ], `End)
Ok (t, [ reply (`Unikernels vms) ], `End)
end
| `Vm_create vm_config -> handle_create t reply id vm_config
| `Vm_force_create vm_config ->
| `Unikernel_create vm_config -> handle_create t reply id vm_config
| `Unikernel_force_create vm_config ->
begin
let resources =
match Vmm_resources.remove_vm t.resources id with
@ -175,13 +175,13 @@ let handle_vm_cmd t reply id msg_to_err = function
Ok (t, [], `Wait_and_create
(task, fun t -> msg_to_err @@ handle_create t reply id vm_config))
end
| `Vm_destroy ->
| `Unikernel_destroy ->
match Vmm_resources.find_vm t.resources id with
| Some vm ->
Vmm_unix.destroy vm ;
let id_str = Name.to_string id in
let out, next =
let s = reply (`String "destroyed vm") in
let s = reply (`String "destroyed unikernel") in
match String.Map.find_opt id_str t.tasks with
| None -> [ s ], `End
| Some t -> [], `Wait (t, s)
@ -224,7 +224,7 @@ let handle_block_cmd t reply id = function
Logs.debug (fun m -> m "block: couldn't find %a" Name.pp id) ;
Error (`Msg "block: not found")
| _ ->
Ok (t, [ reply (`Blocks blocks) ], `End)
Ok (t, [ reply (`Block_devices blocks) ], `End)
let handle_command t (header, payload) =
let msg_to_err = function
@ -238,7 +238,7 @@ let handle_command t (header, payload) =
msg_to_err (
match payload with
| `Command (`Policy_cmd pc) -> handle_policy_cmd t reply id pc
| `Command (`Vm_cmd vc) -> handle_vm_cmd t reply id msg_to_err vc
| `Command (`Unikernel_cmd vc) -> handle_unikernel_cmd t reply id msg_to_err vc
| `Command (`Block_cmd bc) -> handle_block_cmd t reply id bc
| _ ->
Logs.err (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, payload)) ;

10
src/vmm_vmmd.mli
View file

@ -1,5 +1,7 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Vmm_core
type 'a t
val init : Vmm_commands.version -> 'a t
@ -12,17 +14,17 @@ type service_out = [
type out = [ service_out | `Data of Vmm_commands.wire ]
val handle_shutdown : 'a t -> Vmm_core.Name.t -> Vmm_core.Vm.t ->
val handle_shutdown : 'a t -> Name.t -> Unikernel.t ->
[ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list
val handle_command : 'a t -> Vmm_commands.wire ->
'a t * out list *
[ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.Name.t * Vmm_core.Vm.t, [> `Msg of string ]) result
[ `Create of 'c t -> 'c -> ('c t * out list * Name.t * Unikernel.t, [> `Msg of string ]) result
| `Loop
| `End
| `Wait of 'a * out
| `Wait_and_create of 'a * ('a t -> 'a t * out list *
[ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.Name.t * Vmm_core.Vm.t, [> Rresult.R.msg ]) result
[ `Create of 'd t -> 'd -> ('d t * out list * Name.t * Unikernel.t, [> Rresult.R.msg ]) result
| `End ]) ]
val setup_stats : 'a t -> Vmm_core.Name.t -> Vmm_core.Vm.t -> 'a t * out
val setup_stats : 'a t -> Name.t -> Unikernel.t -> 'a t * out