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

rename Vmm_core.id to Vmm_core.Name.t and make it private - also check constructors to fit into 20 chars ldh (and in Vmm_tls max depth = 10)

Browse source
This commit is contained in:
Hannes Mehnert 2018-11-11 01:21:12 +01:00
parent 6dcde8eb68
commit 43379d6d9d
26 changed files with 336 additions and 244 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
README.md
View file

@ -34,7 +34,7 @@ https://github.com/hannesm/albatross`.
The following elaborates on how to get the software up and running, following by
provisioning and deploying some unikernels. There is a *server* (`SRV`)
component which needs six binaries: vmm_console, vmm_log, vmm_stats_lwt, vmmd,
solo5-hvt.none, and solo5-hvt.net; a `CA` machine (which should be air-gapped, or
solo5-hvt.none, solo5-hvt.net, solo5-hvt.block and solo5-hvt.block-net; a `CA` machine (which should be air-gapped, or
at least use some hardware token) for provisioning which needs vmm_sign, and
vmm_gen_ca; and a *development* (`DEV`) machine which has a fully featured OCaml
and MirageOS environment. Each step is prefixed with the machine it is supposed

18
app/vmm_cli.ml
View file

@ -3,15 +3,13 @@
open Astring
open Vmm_core
open Lwt.Infix
let print_result version (header, reply) =
if not (Vmm_commands.version_eq header.Vmm_commands.version version) then
Logs.err (fun m -> m "version not equal")
else match reply with
| `Success s -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply))
| `Data d -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply))
| `Failure d -> Logs.warn (fun m -> m "%a" Vmm_commands.pp_wire (header, reply))
| `Success _ -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply))
| `Data _ -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply))
| `Failure _ -> Logs.warn (fun m -> m "%a" Vmm_commands.pp_wire (header, reply))
| `Command _ -> Logs.err (fun m -> m "unexpected command %a" Vmm_commands.pp_wire (header, reply))
let setup_log style_renderer level =
@ -88,13 +86,15 @@ let bridge =
(parse, pp_bridge)
let vm_c =
let parse s = `Ok (id_of_string s)
let parse s = match Name.of_string s with
| Error (`Msg msg) -> `Error msg
| Ok name -> `Ok name
in
(parse, pp_id)
(parse, Name.pp)
let opt_vm_name =
let doc = "name of virtual machine." in
Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc)
Arg.(value & opt vm_c Name.root & info [ "n" ; "name"] ~doc)
let compress_level =
let doc = "Compression level (0 for no compression)" in
@ -130,7 +130,7 @@ let block_size =
let opt_block_name =
let doc = "Name of block device." in
Arg.(value & opt vm_c [] & info [ "name" ] ~doc)
Arg.(value & opt vm_c Name.root & info [ "name" ] ~doc)
let opt_block_size =
let doc = "Block storage to allow in MB" in

16
app/vmm_stats_pure.ml
View file

@ -114,10 +114,10 @@ let tick t =
ru', vmm', ifd
in
List.fold_left (fun out (id, socket) ->
match Vmm_core.drop_super ~super:id ~sub:vmid with
| None -> Logs.err (fun m -> m "couldn't drop super %a from sub %a" Vmm_core.pp_id id Vmm_core.pp_id vmid) ; out
match Vmm_core.Name.drop_super ~super:id ~sub:vmid with
| None -> Logs.err (fun m -> m "couldn't drop super %a from sub %a" Vmm_core.Name.pp id Vmm_core.Name.pp vmid) ; out
| Some real_id ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id = real_id } in
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; name = real_id } in
((socket, vmid, (header, `Data (`Stats_data stats))) :: out))
out xs)
[] (Vmm_trie.all t'.vmid_pid)
@ -133,8 +133,8 @@ let add_pid t vmid pid nics =
let rec go cnt acc id =
if id > 0 && cnt > 0 then
match wrap sysctl_ifdata id with
| Some ifd when List.mem ifd.Vmm_core.Stats.name nics ->
go (pred cnt) ((id, ifd.Vmm_core.Stats.name) :: acc) (pred id)
| Some ifd when List.mem ifd.Vmm_core.Stats.ifname nics ->
go (pred cnt) ((id, ifd.Vmm_core.Stats.ifname) :: acc) (pred id)
| _ -> go cnt acc (pred id)
else
List.rev acc
@ -150,9 +150,9 @@ let add_pid t vmid pid nics =
Ok { t with pid_nic ; vmid_pid }
let remove_vmid t vmid =
Logs.info (fun m -> m "removing vmid %a" Vmm_core.pp_id vmid) ;
Logs.info (fun m -> m "removing vmid %a" Vmm_core.Name.pp vmid) ;
match Vmm_trie.find vmid t.vmid_pid with
| None -> Logs.warn (fun m -> m "no pid found for %a" Vmm_core.pp_id vmid) ; t
| None -> Logs.warn (fun m -> m "no pid found for %a" Vmm_core.Name.pp vmid) ; t
| Some pid ->
Logs.info (fun m -> m "removing pid %d" pid) ;
(try
@ -179,7 +179,7 @@ let handle t socket (header, wire) =
match wire with
| `Command (`Stats_cmd cmd) ->
begin
let id = header.Vmm_commands.id in
let id = header.Vmm_commands.name in
match cmd with
| `Stats_add (pid, taps) ->
add_pid t id pid taps >>= fun t ->

2
app/vmmc_bistro.ml
View file

@ -31,7 +31,7 @@ let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
Vmm_lwt.read_from_file key >>= fun key_cs ->
let key = X509.Encoding.Pem.Private_key.of_pem_cstruct1 key_cs in
let tmpkey = Nocrypto.Rsa.generate 4096 in
let name = Vmm_core.string_of_id id in
let name = Vmm_core.Name.to_string id in
let extensions =
[ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
; (true, `Basic_constraints (false, None))

4
app/vmmc_local.ml
View file

@ -28,10 +28,10 @@ let read fd =
in
loop ()
let handle opt_socket id (cmd : Vmm_commands.t) =
let handle opt_socket name (cmd : Vmm_commands.t) =
let sock, next = Vmm_commands.endpoint cmd in
connect (socket sock opt_socket) >>= fun fd ->
let header = Vmm_commands.{ version ; sequence = 0L ; id } in
let header = Vmm_commands.{ version ; sequence = 0L ; name } in
Vmm_lwt.write_wire fd (header, `Command cmd) >>= function
| Error `Exception -> Lwt.return ()
| Ok () ->

19
app/vmmd_console.ml
View file

@ -20,8 +20,7 @@ let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e)
let active = ref String.Map.empty
let read_console name ring channel () =
let id = Vmm_core.id_of_string name in
let read_console id name ring channel () =
Lwt.catch (fun () ->
let rec loop () =
Lwt_io.read_line channel >>= fun line ->
@ -31,7 +30,7 @@ let read_console name ring channel () =
(match String.Map.find name !active with
| None -> Lwt.return_unit
| Some fd ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; name = id } in
Vmm_lwt.write_wire fd (header, `Data (`Console_data (t, line))) >>= function
| Error _ ->
Vmm_lwt.safe_close fd >|= fun () ->
@ -68,21 +67,21 @@ let open_fifo name =
let t = ref String.Map.empty
let add_fifo id =
let name = Vmm_core.string_of_id id in
let name = Vmm_core.Name.to_string id in
open_fifo name >|= function
| Some f ->
let ring = Vmm_ring.create "" () in
Logs.debug (fun m -> m "inserting fifo %s" name) ;
let map = String.Map.add name ring !t in
t := map ;
Lwt.async (read_console name ring f) ;
Lwt.async (read_console id name ring f) ;
Ok ()
| None ->
Error (`Msg "opening")
let subscribe s id =
let name = Vmm_core.string_of_id id in
Logs.debug (fun m -> m "attempting to subscribe %a" Vmm_core.pp_id id) ;
let name = Vmm_core.Name.to_string id in
Logs.debug (fun m -> m "attempting to subscribe %a" Vmm_core.Name.pp id) ;
match String.Map.find name !t with
| None ->
active := String.Map.add name s !active ;
@ -100,9 +99,9 @@ let send_history s r id since =
| None -> Vmm_ring.read r
| Some ts -> Vmm_ring.read_history r ts
in
Logs.debug (fun m -> m "%a found %d history" Vmm_core.pp_id id (List.length entries)) ;
Logs.debug (fun m -> m "%a found %d history" Vmm_core.Name.pp id (List.length entries)) ;
Lwt_list.iter_s (fun (i, v) ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; name = id } in
Vmm_lwt.write_wire s (header, `Data (`Console_data (i, v))) >>= function
| Ok () -> Lwt.return_unit
| Error _ -> Vmm_lwt.safe_close s)
@ -120,7 +119,7 @@ let handle s addr () =
Logs.err (fun m -> m "ignoring data with bad version") ;
Lwt.return_unit
end else begin
let name = header.Vmm_commands.id in
let name = header.Vmm_commands.name in
match cmd with
| `Console_add ->
begin

8
app/vmmd_influx.ml
View file

@ -138,7 +138,7 @@ module P = struct
in
let fields = List.map (fun (k, v) -> k ^ "=" ^ v) fields in
Printf.sprintf "interface,vm=%s,ifname=%s %s"
vm ifd.name (String.concat ~sep:"," fields)
vm ifd.ifname (String.concat ~sep:"," fields)
end
let my_version = `AV2
@ -198,7 +198,7 @@ let rec read_sock_write_tcp c ?fd addr addrtype =
safe_close c >|= fun () ->
false
end else
let name = string_of_id hdr.Vmm_commands.id in
let name = Name.to_string hdr.Vmm_commands.name in
let ru = P.encode_ru name ru in
let vmm = match vmm with None -> [] | Some xs -> [ P.encode_vmm name xs ] in
let taps = List.map (P.encode_if name) ifs in
@ -220,9 +220,9 @@ let rec read_sock_write_tcp c ?fd addr addrtype =
read_sock_write_tcp c ?fd addr addrtype
let query_sock vm c =
let header = Vmm_commands.{ version = my_version ; sequence = !command ; id = vm } in
let header = Vmm_commands.{ version = my_version ; sequence = !command ; name = vm } in
command := Int64.succ !command ;
Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id vm) ;
Logs.debug (fun m -> m "%Lu requesting %a via socket" !command Name.pp vm) ;
Vmm_lwt.write_wire c (header, `Command (`Stats_cmd `Stats_subscribe))
let rec maybe_connect stat_socket =

10
app/vmmd_log.ml
View file

@ -68,7 +68,7 @@ let send_history s ring id ts =
let res =
List.fold_left (fun acc (ts, event) ->
let sub = Vmm_core.Log.name event in
if Vmm_core.is_sub_id ~super:id ~sub
if Vmm_core.Name.is_sub ~super:id ~sub
then (ts, event) :: acc
else acc)
[] elements
@ -77,7 +77,7 @@ let send_history s ring id ts =
Lwt_list.fold_left_s (fun r (ts, event) ->
match r with
| Ok () ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; name = id } in
Vmm_lwt.write_wire s (header, `Data (`Log_data (ts, event)))
| Error e -> Lwt.return (Error e))
(Ok ()) (List.rev res)
@ -93,7 +93,7 @@ let handle_data s mvar ring hdr entry =
Vmm_ring.write ring entry ;
Lwt_mvar.put mvar entry >>= fun () ->
let data' = (hdr, `Data (`Log_data entry)) in
broadcast hdr.Vmm_commands.id data' !tree >|= fun tree' ->
broadcast hdr.Vmm_commands.name data' !tree >|= fun tree' ->
tree := tree'
end
@ -128,7 +128,7 @@ let handle mvar ring s addr () =
end else begin
match lc with
| `Log_subscribe ts ->
let tree', ret = Vmm_trie.insert hdr.Vmm_commands.id s !tree in
let tree', ret = Vmm_trie.insert hdr.Vmm_commands.name s !tree in
tree := tree' ;
(match ret with
| None -> Lwt.return_unit
@ -138,7 +138,7 @@ let handle mvar ring s addr () =
| Error _ -> Logs.err (fun m -> m "error while sending reply for subscribe") ;
Lwt.return_unit
| Ok () ->
send_history s ring hdr.Vmm_commands.id ts >>= function
send_history s ring hdr.Vmm_commands.name ts >>= function
| Error _ -> Logs.err (fun m -> m "error while sending history") ; Lwt.return_unit
| Ok () ->
(* command processing is finished, but we leave the socket open

2
app/vmmd_stats.ml
View file

@ -66,7 +66,7 @@ let rec timer interval () =
Vmm_lwt.write_wire s stat >>= function
| Ok () -> Lwt.return_unit
| Error `Exception ->
Logs.debug (fun m -> m "removing entry %a" Vmm_core.pp_id name) ;
Logs.debug (fun m -> m "removing entry %a" Vmm_core.Name.pp name) ;
t := remove_entry !t name ;
Vmm_lwt.safe_close s)
outs >>= fun () ->

8
app/vmmd_tls.ml
View file

@ -71,8 +71,8 @@ let handle ca (tls, addr) =
match r with
| Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
| Ok () ->
Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.pp_id id Vmm_core.pp_policy policy) ;
let header = Vmm_commands.{version = my_version ; sequence = !command ; id } in
Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.Name.pp id Vmm_core.pp_policy policy) ;
let header = Vmm_commands.{version = my_version ; sequence = !command ; name = id } in
command := Int64.succ !command ;
Vmm_lwt.write_wire fd (header, `Command (`Policy_cmd (`Policy_add policy))) >>= function
| Error `Exception -> Lwt.return (Error (`Msg "failed to write policy"))
@ -91,7 +91,7 @@ let handle ca (tls, addr) =
begin
Logs.warn (fun m -> m "error while applying policies %s" msg) ;
let wire =
let header = Vmm_commands.{version = my_version ; sequence = 0L ; id = name } in
let header = Vmm_commands.{version = my_version ; sequence = 0L ; name } in
header, `Failure msg
in
Vmm_tls_lwt.write_tls tls wire >>= fun _ ->
@ -100,7 +100,7 @@ let handle ca (tls, addr) =
end
| Ok () ->
let wire =
let header = Vmm_commands.{version = my_version ; sequence = !command ; id = name } in
let header = Vmm_commands.{version = my_version ; sequence = !command ; name } in
command := Int64.succ !command ;
(header, `Command cmd)
in

2
app/vmmp_request.ml
View file

@ -15,7 +15,7 @@ let csr priv name cmd =
let jump id cmd =
Nocrypto_entropy_unix.initialize () ;
let name = Vmm_core.string_of_id id in
let name = Vmm_core.Name.to_string id in
match
priv_key None name >>= fun priv ->
let csr = csr priv name cmd in

48
src/vmm_asn.ml
View file

@ -150,14 +150,14 @@ let int32 =
let ifdata =
let open Stats in
let f (name, (flags, (send_length, (max_send_length, (send_drops, (mtu, (baudrate, (input_packets, (input_errors, (output_packets, (output_errors, (collisions, (input_bytes, (output_bytes, (input_mcast, (output_mcast, (input_dropped, output_dropped))))))))))))))))) =
{ name; flags; send_length; max_send_length; send_drops; mtu; baudrate; input_packets; input_errors; output_packets; output_errors; collisions; input_bytes; output_bytes; input_mcast; output_mcast; input_dropped; output_dropped }
let f (ifname, (flags, (send_length, (max_send_length, (send_drops, (mtu, (baudrate, (input_packets, (input_errors, (output_packets, (output_errors, (collisions, (input_bytes, (output_bytes, (input_mcast, (output_mcast, (input_dropped, output_dropped))))))))))))))))) =
{ ifname; flags; send_length; max_send_length; send_drops; mtu; baudrate; input_packets; input_errors; output_packets; output_errors; collisions; input_bytes; output_bytes; input_mcast; output_mcast; input_dropped; output_dropped }
and g i =
(i.name, (i.flags, (i.send_length, (i.max_send_length, (i.send_drops, (i.mtu, (i.baudrate, (i.input_packets, (i.input_errors, (i.output_packets, (i.output_errors, (i.collisions, (i.input_bytes, (i.output_bytes, (i.input_mcast, (i.output_mcast, (i.input_dropped, i.output_dropped)))))))))))))))))
(i.ifname, (i.flags, (i.send_length, (i.max_send_length, (i.send_drops, (i.mtu, (i.baudrate, (i.input_packets, (i.input_errors, (i.output_packets, (i.output_errors, (i.collisions, (i.input_bytes, (i.output_bytes, (i.input_mcast, (i.output_mcast, (i.input_dropped, i.output_dropped)))))))))))))))))
in
Asn.S.map f g @@
Asn.S.(sequence @@
(required ~label:"name" utf8_string)
(required ~label:"ifname" utf8_string)
@ (required ~label:"flags" int32)
@ (required ~label:"send_length" int32)
@ (required ~label:"max_send_length" int32)
@ -194,31 +194,37 @@ let stats_cmd =
(explicit 1 null)
(explicit 2 null))
let of_name, to_name =
Name.to_list,
fun list -> match Name.of_list list with
| Error (`Msg msg) -> Asn.S.error (`Parse msg)
| Ok name -> name
let log_event =
let f = function
| `C1 () -> `Startup
| `C2 (name, ip, port) -> `Login (name, ip, port)
| `C3 (name, ip, port) -> `Logout (name, ip, port)
| `C4 (name, pid, taps, block) -> `Vm_start (name, pid, taps, block)
| `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)
| `C5 (name, pid, status) ->
let status' = match status with
| `C1 n -> `Exit n
| `C2 n -> `Signal n
| `C3 n -> `Stop n
in
`Vm_stop (name, pid, status')
`Vm_stop (to_name name, pid, status')
and g = function
| `Startup -> `C1 ()
| `Login (name, ip, port) -> `C2 (name, ip, port)
| `Logout (name, ip, port) -> `C3 (name, ip, port)
| `Vm_start (name, pid, taps, block) -> `C4 (name, pid, taps, block)
| `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) ->
let status' = match status with
| `Exit n -> `C1 n
| `Signal n -> `C2 n
| `Stop n -> `C3 n
in
`C5 (name, pid, status')
`C5 (of_name name, pid, status')
in
let endp =
Asn.S.(sequence3
@ -382,28 +388,28 @@ let data =
(required ~label:"event" log_event))))
let header =
let f (version, sequence, id) = { version ; sequence ; id }
and g h = h.version, h.sequence, h.id
let f (version, sequence, name) = { version ; sequence ; name = to_name name }
and g h = h.version, h.sequence, of_name h.name
in
Asn.S.map f g @@
Asn.S.(sequence3
(required ~label:"version" version)
(required ~label:"sequence" int64)
(required ~label:"id" (sequence_of utf8_string)))
(required ~label:"name" (sequence_of utf8_string)))
let success =
let f = function
| `C1 () -> `Empty
| `C2 str -> `String str
| `C3 policies -> `Policies policies
| `C4 vms -> `Vms vms
| `C5 blocks -> `Blocks blocks
| `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)
and g = function
| `Empty -> `C1 ()
| `String s -> `C2 s
| `Policies ps -> `C3 ps
| `Vms vms -> `C4 vms
| `Blocks blocks -> `C5 blocks
| `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)
in
Asn.S.map f g @@
Asn.S.(choice5

22
src/vmm_commands.ml
View file

@ -113,25 +113,25 @@ let pp_data ppf = function
type header = {
version : version ;
sequence : int64 ;
id : id ;
name : Name.t ;
}
type success = [
| `Empty
| `String of string
| `Policies of (id * policy) list
| `Vms of (id * vm_config) list
| `Blocks of (id * int * bool) list
| `Policies of (Name.t * policy) list
| `Vms of (Name.t * vm_config) list
| `Blocks of (Name.t * int * bool) list
]
let pp_block ppf (id, size, active) =
Fmt.pf ppf "block %a size %d MB active %B" pp_id id size active
Fmt.pf ppf "block %a size %d MB active %B" Name.pp id size active
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 ": ") pp_id pp_policy)) ppf ps
| `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms
| `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp pp_policy)) ppf ps
| `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp pp_vm_config)) ppf vms
| `Blocks blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks
type wire = header * [
@ -141,11 +141,11 @@ type wire = header * [
| `Data of data ]
let pp_wire ppf (header, data) =
let id = header.id in
let name = header.name in
match data with
| `Command c -> Fmt.pf ppf "host %a: %a" pp_id id pp c
| `Failure f -> Fmt.pf ppf "host %a: command failed %s" pp_id id f
| `Success s -> Fmt.pf ppf "host %a: %a" pp_id id pp_success s
| `Command c -> Fmt.pf ppf "host %a: %a" Name.pp name pp c
| `Failure f -> Fmt.pf ppf "host %a: command failed %s" Name.pp name f
| `Success s -> Fmt.pf ppf "host %a: %a" Name.pp name pp_success s
| `Data d -> pp_data ppf d
let endpoint = function

8
src/vmm_commands.mli
View file

@ -67,15 +67,15 @@ val pp_data : data Fmt.t
type header = {
version : version ;
sequence : int64 ;
id : id ;
name : Name.t ;
}
type success = [
| `Empty
| `String of string
| `Policies of (id * policy) list
| `Vms of (id * vm_config) list
| `Blocks of (id * int * bool) list
| `Policies of (Name.t * policy) list
| `Vms of (Name.t * vm_config) list
| `Blocks of (Name.t * int * bool) list
]
type wire = header * [

117
src/vmm_core.ml
View file

@ -40,31 +40,90 @@ let pp_vmtype ppf = function
| `Hvt_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed"
| `Hvt_arm64 -> Fmt.pf ppf "hvt-arm64"
type id = string list
module Name = struct
type t = string list
let string_of_id ids = String.concat ~sep:"." ids
let root = []
let id_of_string str = String.cuts ~sep:"." str
let is_root x = x = []
let drop_super ~super ~sub =
let rec go sup sub = match sup, sub with
| [], xs -> Some xs
| _, [] -> None
| x::xs, z::zs -> if String.equal x z then go xs zs else None
in
go super sub
let [@inline always] valid_label s =
String.length s < 20 &&
String.length s > 0 &&
String.get s 0 <> '-' && (* leading may not be '-' *)
String.for_all (function
| 'a'..'z' | 'A'..'Z' | '0'..'9' | '-' -> true
| _ -> false)
s (* only LDH (letters, digits, hyphen)! *)
let is_sub_id ~super ~sub =
match drop_super ~super ~sub with None -> false | Some _ -> true
let to_string ids = String.concat ~sep:"." ids
let domain id = match List.rev id with
| _::prefix -> List.rev prefix
| [] -> []
let to_list x = x
let block_name vm_name dev = List.rev (dev :: List.rev (domain vm_name))
let append_exn lbl x =
if valid_label lbl then
x @ [ lbl ]
else
invalid_arg "label not valid"
let pp_id ppf ids =
Fmt.(pf ppf "(%d)%a" (List.length ids) (list ~sep:(unit ".") string) ids)
let append lbl x =
if valid_label lbl then
Ok (x @ [ lbl ])
else
Error (`Msg "label not valid")
let prepend lbl x =
if valid_label lbl then
Ok (lbl :: x)
else
Error (`Msg "label not valid")
let domain id = match List.rev id with
| _::prefix -> List.rev prefix
| [] -> []
let image_file name =
let file = to_string name in
Fpath.(tmpdir / file + "img")
let fifo_file name =
let file = to_string name in
Fpath.(tmpdir / "fifo" / file)
let block_file name =
let file = to_string name in
Fpath.(blockdir / file)
let block_name vm_name dev =
List.rev (dev :: List.rev (domain vm_name))
let of_string str =
let id = String.cuts ~sep:"." str in
if List.for_all valid_label id then
Ok id
else
Error (`Msg "invalid name")
let of_list labels =
if List.for_all valid_label labels then
Ok labels
else
Error (`Msg "invalid name")
let drop_super ~super ~sub =
let rec go sup sub = match sup, sub with
| [], xs -> Some xs
| _, [] -> None
| x::xs, z::zs -> if String.equal x z then go xs zs else None
in
go super sub
let is_sub ~super ~sub =
match drop_super ~super ~sub with None -> false | Some _ -> true
let pp ppf ids =
Fmt.(pf ppf "(%d)%a" (List.length ids) (list ~sep:(unit ".") string) ids)
end
let pp_is ppf is = Fmt.pf ppf "%a" Fmt.(list ~sep:(unit ",") int) (IS.elements is)
@ -237,7 +296,7 @@ module Stats = struct
Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) ppf vmm
type ifdata = {
name : string ;
ifname : string ;
flags : int32 ;
send_length : int32 ;
max_send_length : int32 ;
@ -258,8 +317,8 @@ module Stats = struct
}
let pp_ifdata ppf i =
Fmt.pf ppf "name %s flags %lX send_length %lu max_send_length %lu send_drops %lu mtu %lu baudrate %Lu input_packets %Lu input_errors %Lu output_packets %Lu output_errors %Lu collisions %Lu input_bytes %Lu output_bytes %Lu input_mcast %Lu output_mcast %Lu input_dropped %Lu output_dropped %Lu"
i.name i.flags i.send_length i.max_send_length i.send_drops i.mtu i.baudrate i.input_packets i.input_errors i.output_packets i.output_errors i.collisions i.input_bytes i.output_bytes i.input_mcast i.output_mcast i.input_dropped i.output_dropped
Fmt.pf ppf "ifname %s flags %lX send_length %lu max_send_length %lu send_drops %lu mtu %lu baudrate %Lu input_packets %Lu input_errors %Lu output_packets %Lu output_errors %Lu collisions %Lu input_bytes %Lu output_bytes %Lu input_mcast %Lu output_mcast %Lu input_dropped %Lu output_dropped %Lu"
i.ifname i.flags i.send_length i.max_send_length i.send_drops i.mtu i.baudrate i.input_packets i.input_errors i.output_packets i.output_errors i.collisions i.input_bytes i.output_bytes i.input_mcast i.output_mcast i.input_dropped i.output_dropped
type t = rusage * vmm option * ifdata list
let pp ppf (ru, vmm, ifs) =
@ -278,11 +337,11 @@ let pp_process_exit ppf = function
module Log = struct
type log_event = [
| `Login of id * Ipaddr.V4.t * int
| `Logout of id * Ipaddr.V4.t * int
| `Login of Name.t * Ipaddr.V4.t * int
| `Logout of Name.t * Ipaddr.V4.t * int
| `Startup
| `Vm_start of id * int * string list * string option
| `Vm_stop of id * int * process_exit
| `Vm_start of Name.t * int * string list * string option
| `Vm_stop of Name.t * int * process_exit
]
let name = function
@ -294,14 +353,14 @@ module Log = struct
let pp_log_event ppf = function
| `Startup -> Fmt.(pf ppf "startup")
| `Login (name, ip, port) -> Fmt.pf ppf "%a login %a:%d" pp_id name Ipaddr.V4.pp_hum ip port
| `Logout (name, ip, port) -> Fmt.pf ppf "%a logout %a:%d" pp_id name Ipaddr.V4.pp_hum ip port
| `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) ->
Fmt.pf ppf "%a started %d (tap %a, block %a)"
pp_id name pid Fmt.(list ~sep:(unit "; ") string) taps
Name.pp name pid Fmt.(list ~sep:(unit "; ") string) taps
Fmt.(option ~none:(unit "no") string) block
| `Vm_stop (name, pid, code) ->
Fmt.pf ppf "%a stopped %d with %a" pp_id name pid pp_process_exit code
Fmt.pf ppf "%a stopped %d with %a" Name.pp name pid pp_process_exit code
type t = Ptime.t * log_event

47
src/vmm_core.mli
View file

@ -20,14 +20,31 @@ module IM : sig
include Map.S with type key = I.t
end
type id = string list
val string_of_id : id -> string
val id_of_string : string -> id
val drop_super : super:id -> sub:id -> id option
val is_sub_id : super:id -> sub:id -> bool
val domain : id -> id
val pp_id : id Fmt.t
val block_name : id -> string -> id
module Name : sig
type t
val is_root : t -> bool
val image_file : t -> Fpath.t
val fifo_file : t -> Fpath.t
val block_file : t -> Fpath.t
val of_list : string list -> (t, [> `Msg of string ]) result
val to_list : t -> string list
val append : string -> t -> (t, [> `Msg of string ]) result
val prepend : string -> t -> (t, [> `Msg of string ]) result
val append_exn : string -> t -> t
val root : t
val valid_label : string -> bool
val to_string : t -> string
val of_string : string -> (t, [> `Msg of string ]) result
val drop_super : super:t -> sub:t -> t option
val is_sub : super:t -> sub:t -> bool
val domain : t -> t
val pp : t Fmt.t
val block_name : t -> string -> t
end
type bridge =
[ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
@ -70,7 +87,7 @@ type vm_config = {
val pp_image : (vmtype * Cstruct.t) Fmt.t
val pp_vm_config : vm_config Fmt.t
val good_bridge : id -> 'a Astring.String.map -> bool
val good_bridge : string list -> 'a Astring.String.map -> bool
val vm_matches_res : policy -> vm_config -> bool
@ -113,7 +130,7 @@ module Stats : sig
val pp_vmm : vmm Fmt.t
type ifdata = {
name : string;
ifname : string;
flags : int32;
send_length : int32;
max_send_length : int32;
@ -144,13 +161,13 @@ val pp_process_exit : process_exit Fmt.t
module Log : sig
type log_event = [
| `Login of id * Ipaddr.V4.t * int
| `Logout of id * Ipaddr.V4.t * int
| `Login of Name.t * Ipaddr.V4.t * int
| `Logout of Name.t * Ipaddr.V4.t * int
| `Startup
| `Vm_start of id * int * string list * string option
| `Vm_stop of id * int * process_exit ]
| `Vm_start of Name.t * int * string list * string option
| `Vm_stop of Name.t * int * process_exit ]
val name : log_event -> id
val name : log_event -> Name.t
val pp_log_event : log_event Fmt.t

30
src/vmm_resources.ml
View file

@ -27,14 +27,14 @@ type entry =
| Policy of policy
let pp_entry id ppf = function
| Vm vm -> Fmt.pf ppf "vm %a: %a@." pp_id id pp_vm_config vm.config
| Policy p -> Fmt.pf ppf "policy %a: %a@." pp_id id pp_policy p
| Block (size, used) -> Fmt.pf ppf "block device %a: %dMB (used %B)@." pp_id id size used
| Vm vm -> Fmt.pf ppf "vm %a: %a@." Name.pp id pp_vm_config vm.config
| Policy p -> Fmt.pf ppf "policy %a: %a@." Name.pp id pp_policy p
| Block (size, used) -> Fmt.pf ppf "block device %a: %dMB (used %B)@." Name.pp id size used
type t = entry Vmm_trie.t
let pp ppf t =
Vmm_trie.fold [] t
Vmm_trie.fold Name.root t
(fun id ele () -> pp_entry id ppf ele) ()
let empty = Vmm_trie.empty
@ -75,7 +75,7 @@ let set_block_usage active t name vm =
match vm.config.block_device with
| None -> Ok t
| Some block ->
let block_name = block_name name block in
let block_name = Name.block_name name block in
match find_block t block_name with
| None -> Error (`Msg "unknown block device")
| Some (size, curr) ->
@ -97,14 +97,14 @@ let remove_block t name = match find_block t name with
| Some _ -> Ok (Vmm_trie.remove name t)
let check_vm_policy t name vm =
let dom = domain name in
let dom = Name.domain name in
let res = resource_usage t dom in
match Vmm_trie.find dom t with
| None -> Ok true
| Some (Policy p) -> Ok (check_resource p vm res)
| Some x ->
Logs.err (fun m -> m "id %a, expected policy, got %a" pp_id dom (pp_entry dom) x) ;
Rresult.R.error_msgf "expected policy for %a" pp_id dom
Logs.err (fun m -> m "id %a, expected policy, got %a" Name.pp dom (pp_entry dom) x) ;
Rresult.R.error_msgf "expected policy for %a" Name.pp dom
let insert_vm t name vm =
let open Rresult.R.Infix in
@ -126,9 +126,9 @@ let check_policy_above t name p =
let check_policy_below t name p =
Vmm_trie.fold name t (fun name entry res ->
match name with
| [] -> res
| _ ->
if Name.is_root name then
res
else
match res, entry with
| Some p, Policy p' -> if is_sub ~super:p ~sub:p then Some p' else None
| Some p, Vm vm ->
@ -141,7 +141,7 @@ let check_policy_below t name p =
let insert_policy t name p =
match
check_policy_above t (domain name) p,
check_policy_above t (Name.domain name) p,
check_policy_below t name p,
check_resource_policy p (resource_usage t name)
with
@ -154,15 +154,15 @@ let check_block_policy t name size =
match find_block t name with
| Some _ -> Error (`Msg "block device with same name already exists")
| None ->
let dom = domain name in
let dom = Name.domain name in
let res = resource_usage t dom in
let res' = { res with used_blockspace = res.used_blockspace + size } in
match Vmm_trie.find dom t with
| None -> Ok true
| Some (Policy p) -> Ok (check_resource_policy p res')
| Some x ->
Logs.err (fun m -> m "id %a, expected policy, got %a" pp_id dom (pp_entry dom) x) ;
Rresult.R.error_msgf "expected policy for %a" pp_id dom
Logs.err (fun m -> m "id %a, expected policy, got %a" Name.pp dom (pp_entry dom) x) ;
Rresult.R.error_msgf "expected policy for %a" Name.pp dom
let insert_block t name size =
let open Rresult.R.Infix in

52
src/vmm_resources.mli
View file

@ -18,48 +18,48 @@ type t
val empty : t
(** [find_vm t id] is either [Some vm] or [None]. *)
val find_vm : t -> Vmm_core.id -> Vmm_core.vm option
val find_vm : t -> Vmm_core.Name.t -> Vmm_core.vm option
(** [find_policy t id] is either [Some policy] or [None]. *)
val find_policy : t -> Vmm_core.id -> Vmm_core.policy option
(** [find_policy t Name.t] is either [Some policy] or [None]. *)
val find_policy : t -> Vmm_core.Name.t -> Vmm_core.policy option
(** [find_block t id] is either [Some (size, active)] or [None]. *)
val find_block : t -> Vmm_core.id -> (int * bool) option
(** [find_block t Name.t] is either [Some (size, active)] or [None]. *)
val find_block : t -> Vmm_core.Name.t -> (int * bool) option
(** [check_vm_policy t id vm] checks whether [vm] under [id] in [t] would be
(** [check_vm_policy t Name.t vm] checks whether [vm] under [Name.t] in [t] would be
allowed under the current policies. *)
val check_vm_policy : t -> Vmm_core.id -> Vmm_core.vm_config -> (bool, [> `Msg of string ]) result
val check_vm_policy : t -> Vmm_core.Name.t -> Vmm_core.vm_config -> (bool, [> `Msg of string ]) result
(** [insert_vm t id vm] inserts [vm] under [id] in [t], and returns the new [t] or
(** [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 -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
val insert_vm : t -> Vmm_core.Name.t -> Vmm_core.vm -> (t, [> `Msg of string]) result
(** [insert_policy t id policy] inserts [policy] under [id] in [t], and returns
(** [insert_policy t Name.t policy] inserts [policy] under [Name.t] in [t], and returns
the new [t] or an error. *)
val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string]) result
val insert_policy : t -> Vmm_core.Name.t -> Vmm_core.policy -> (t, [> `Msg of string]) result
(** [check_block_policy t id size] checks whether [size] under [id] in [t] would be
(** [check_block_policy t Name.t size] checks whether [size] under [Name.t] in [t] would be
allowed under the current policies. *)
val check_block_policy : t -> Vmm_core.id -> int -> (bool, [> `Msg of string ]) result
val check_block_policy : t -> Vmm_core.Name.t -> int -> (bool, [> `Msg of string ]) result
(** [insert_block t id size] inserts [size] under [id] in [t], and returns the new [t] or
(** [insert_block t Name.t size] inserts [size] under [Name.t] in [t], and returns the new [t] or
an error. *)
val insert_block : t -> Vmm_core.id -> int -> (t, [> `Msg of string]) result
val insert_block : t -> Vmm_core.Name.t -> int -> (t, [> `Msg of string]) result
(** [remove_vm t id] removes vm [id] from [t]. *)
val remove_vm : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
(** [remove_vm t Name.t] removes vm [Name.t] from [t]. *)
val remove_vm : t -> Vmm_core.Name.t -> (t, [> `Msg of string ]) result
(** [remove_policy t id] removes policy [id] from [t]. *)
val remove_policy : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
(** [remove_policy t Name.t] removes policy [Name.t] from [t]. *)
val remove_policy : t -> Vmm_core.Name.t -> (t, [> `Msg of string ]) result
(** [remove_block t id] removes block [id] from [t]. *)
val remove_block : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
(** [remove_block t Name.t] removes block [Name.t] from [t]. *)
val remove_block : t -> Vmm_core.Name.t -> (t, [> `Msg of string ]) result
(** [fold t id f_vm f_policy f_block acc] folds [f_vm], [f_policy] and [f_block] below [id] over [t]. *)
val fold : t -> Vmm_core.id ->
(Vmm_core.id -> Vmm_core.vm -> 'a -> 'a) ->
(Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) ->
(Vmm_core.id -> int -> bool -> 'a -> 'a) -> 'a -> 'a
(** [fold t Name.t f_vm f_policy f_block acc] folds [f_vm], [f_policy] and [f_block] below [Name.t] over [t]. *)
val fold : t -> Vmm_core.Name.t ->
(Vmm_core.Name.t -> Vmm_core.vm -> 'a -> 'a) ->
(Vmm_core.Name.t -> Vmm_core.policy -> 'a -> 'a) ->
(Vmm_core.Name.t -> int -> bool -> 'a -> 'a) -> 'a -> 'a
(** [pp] is a pretty printer for [t]. *)
val pp : t Fmt.t

29
src/vmm_tls.ml
View file

@ -12,7 +12,18 @@ let cert_name cert =
if name = "" then
match Vmm_asn.cert_extension_of_cstruct data with
| Error (`Msg _) -> Error (`Msg "couldn't parse albatross extension")
| Ok (_, `Policy_cmd (`Policy_add _)) -> Error (`Msg "policy add may not have an empty name")
| Ok (_, `Policy_cmd pc) ->
begin match pc with
| `Policy_add _ -> Error (`Msg "policy add may not have an empty name")
| `Policy_remove -> Error (`Msg "policy remove may not have an empty name")
| `Policy_info -> Ok None
end
| Ok (_, `Block_cmd bc) ->
begin match bc with
| `Block_add _ -> Error (`Msg "block add may not have an empty name")
| `Block_remove -> Error (`Msg "block remove may not have an empty name")
| `Block_info -> Ok None
end
| _ -> Ok None
else Ok (Some name)
@ -22,8 +33,12 @@ let name chain =
| Error e, _ -> Error e
| _, Error e -> Error e
| Ok acc, Ok None -> Ok acc
| Ok acc, Ok Some data -> Ok (data :: acc))
(Ok []) chain
| Ok acc, Ok (Some data) -> Vmm_core.Name.prepend data acc)
(Ok Vmm_core.Name.root) chain >>= fun lbl ->
if List.length (Vmm_core.Name.to_list lbl) < 10 then
Ok lbl
else
Error (`Msg "too deep")
(* this separates the leaf and top-level certificate from the chain,
and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA')
@ -56,13 +71,13 @@ let extract_policies version chain =
Vmm_commands.pp_version received
Vmm_commands.pp_version version
| Ok (prefix, acc), Ok (`Policy_cmd (`Policy_add p)) ->
(cert_name cert >>| function
| None -> prefix
| Some x -> x :: prefix) >>| fun name ->
(cert_name cert >>= function
| None -> Ok prefix
| Some x -> Vmm_core.Name.prepend x prefix) >>| fun name ->
(name, (name, p) :: acc)
| _, Ok wire ->
R.error_msgf "unexpected wire %a" Vmm_commands.pp wire)
(Ok ([], [])) chain
(Ok (Vmm_core.Name.root, [])) chain
let handle _addr version chain =
separate_chain chain >>= fun (leaf, rest) ->

2
src/vmm_tls.mli
View file

@ -6,5 +6,5 @@ val wire_command_of_cert : Vmm_commands.version -> X509.t ->
val handle :
'a -> Vmm_commands.version ->
X509.t list ->
(Vmm_core.id * (Vmm_core.id * Vmm_core.policy) list * Vmm_commands.t,
(Vmm_core.Name.t * (Vmm_core.Name.t * Vmm_core.policy) list * Vmm_commands.t,
[> `Msg of string ]) Result.result

20
src/vmm_trie.ml
View file

@ -21,7 +21,7 @@ let insert id e t =
let entry, ret = go n xs in
N (es, String.Map.add x entry m), ret
in
go t id
go t (Vmm_core.Name.to_list id)
let remove id t =
let rec go (N (es, m)) = function
@ -37,7 +37,7 @@ let remove id t =
in
if String.Map.is_empty m' && es = None then None else Some (N (es, m'))
in
match go t id with
match go t (Vmm_core.Name.to_list id) with
| None -> empty
| Some n -> n
@ -49,7 +49,7 @@ let find id t =
| None -> None
| Some n -> go n xs
in
go t id
go t (Vmm_core.Name.to_list id)
let collect id t =
let rec go acc prefix (N (es, m)) =
@ -63,9 +63,9 @@ let collect id t =
| x::xs ->
match String.Map.find_opt x m with
| None -> acc'
| Some n -> go acc' (prefix @ [ x ]) n xs
| Some n -> go acc' (Vmm_core.Name.append_exn x prefix) n xs
in
go [] [] t id
go [] Vmm_core.Name.root t (Vmm_core.Name.to_list id)
let all t =
let rec go acc prefix (N (es, m)) =
@ -75,15 +75,15 @@ let all t =
| Some e -> (prefix, e) :: acc
in
List.fold_left (fun acc (name, node) ->
go acc (prefix@[name]) node)
go acc (Vmm_core.Name.append_exn name prefix) node)
acc' (String.Map.bindings m)
in
go [] [] t
go [] Vmm_core.Name.root t
let fold id t f acc =
let rec explore (N (es, m)) prefix acc =
let acc' =
String.Map.fold (fun name node acc -> explore node (prefix@[name]) acc)
String.Map.fold (fun name node acc -> explore node (Vmm_core.Name.append_exn name prefix) acc)
m acc
in
match es with
@ -91,9 +91,9 @@ let fold id t f acc =
| Some e -> f prefix e acc'
and down prefix (N (es, m)) =
match prefix with
| [] -> explore (N (es, m)) [] acc
| [] -> explore (N (es, m)) Vmm_core.Name.root acc
| x :: xs -> match String.Map.find_opt x m with
| None -> acc
| Some n -> down xs n
in
down id t
down (Vmm_core.Name.to_list id) t

12
src/vmm_trie.mli
View file

@ -6,14 +6,14 @@ type 'a t
val empty : 'a t
val insert : id -> 'a -> 'a t -> 'a t * 'a option
val insert : Name.t -> 'a -> 'a t -> 'a t * 'a option
val remove : id -> 'a t -> 'a t
val remove : Name.t -> 'a t -> 'a t
val find : id -> 'a t -> 'a option
val find : Name.t -> 'a t -> 'a option
val collect : id -> 'a t -> (id * 'a) list
val collect : Name.t -> 'a t -> (Name.t * 'a) list
val all : 'a t -> (id * 'a) list
val all : 'a t -> (Name.t * 'a) list
val fold : id -> 'a t -> (id -> 'a -> 'b -> 'b) -> 'b -> 'b
val fold : Name.t -> 'a t -> (Name.t -> 'a -> 'b -> 'b) -> 'b -> 'b

36
src/vmm_unix.ml
View file

@ -57,10 +57,6 @@ let rec mkfifo name =
try Unix.mkfifo (Fpath.to_string name) 0o640 with
| Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name
let image_file, fifo_file =
((fun name -> Fpath.(tmpdir / (string_of_id name) + "img")),
(fun name -> Fpath.(tmpdir / "fifo" / (string_of_id name))))
let rec fifo_exists file =
try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with
| Unix.Unix_error (Unix.ENOENT, _, _) -> Error (`Msg "noent")
@ -112,7 +108,7 @@ let prepare name vm =
| Error () -> Error (`Msg "failed to uncompress")
end
| `Hvt_arm64, _ -> Error (`Msg "no amd64 hvt image found")) >>= fun image ->
let fifo = fifo_file name in
let fifo = Name.fifo_file name in
(match fifo_exists fifo with
| Ok true -> Ok ()
| Ok false -> Error (`Msg ("file " ^ Fpath.to_string fifo ^ " exists and is not a fifo"))
@ -126,13 +122,13 @@ let prepare name vm =
create_tap b >>= fun tap ->
Ok (tap :: acc))
(Ok []) vm.network >>= fun taps ->
Bos.OS.File.write (image_file name) (Cstruct.to_string image) >>= fun () ->
Bos.OS.File.write (Name.image_file name) (Cstruct.to_string image) >>= fun () ->
Ok (List.rev taps)
let shutdown name vm =
(* same order as prepare! *)
Bos.OS.File.delete (image_file name) >>= fun () ->
Bos.OS.File.delete (fifo_file name) >>= fun () ->
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.taps
let cpuset cpu =
@ -145,8 +141,6 @@ let cpuset cpu =
Ok ([ "taskset" ; "-c" ; cpustring ])
| x -> Error (`Msg ("unsupported operating system " ^ x))
let block_device_name name = Fpath.(blockdir / string_of_id name)
let exec name vm taps block =
(match taps, block with
| [], None -> Ok "none"
@ -155,7 +149,7 @@ let exec name vm taps block =
| [_], Some _ -> Ok "block-net"
| _, _ -> 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_device_name dev) ]
and block = match block with None -> [] | Some dev -> [ "--disk=" ^ Fpath.to_string (Name.block_file dev) ]
and argv = match vm.argv with None -> [] | Some xs -> xs
and mem = "--mem=" ^ string_of_int vm.requested_memory
in
@ -163,12 +157,12 @@ let exec name vm taps block =
let cmd =
Bos.Cmd.(of_list cpuset % p Fpath.(dbdir / "solo5-hvt" + bin) % mem %%
of_list net %% of_list block %
"--" % p (image_file name) %% of_list argv)
"--" % p (Name.image_file name) %% of_list argv)
in
let line = Bos.Cmd.to_list cmd in
let prog = try List.hd line with Failure _ -> failwith err_empty_line in
let line = Array.of_list line in
let fifo = fifo_file name in
let fifo = Name.fifo_file name in
Logs.debug (fun m -> m "write fd for fifo %a" Fpath.pp fifo);
write_fd_for_file fifo >>= fun stdout ->
Logs.debug (fun m -> m "opened file descriptor!");
@ -194,7 +188,7 @@ let bytes_of_mb size =
Error (`Msg "overflow while computing bytes")
let create_block name size =
let block_name = block_device_name name in
let block_name = Name.block_file name in
Bos.OS.File.exists block_name >>= function
| true -> Error (`Msg "file already exists")
| false ->
@ -202,7 +196,7 @@ let create_block name size =
Bos.OS.File.truncate block_name size'
let destroy_block name =
Bos.OS.File.delete (block_device_name name)
Bos.OS.File.delete (Name.block_file name)
let mb_of_bytes size =
if size = 0 || size land 0xFFFFF <> 0 then
@ -221,11 +215,13 @@ let find_block_devices () =
Ok acc
| true ->
Bos.OS.Path.stat path >>= fun stats ->
match mb_of_bytes stats.Unix.st_size with
| Error (`Msg msg) ->
Logs.warn (fun m -> m "file %a error: %s" Fpath.pp path msg) ;
match mb_of_bytes stats.Unix.st_size, Name.of_string (Fpath.to_string file) with
| Error (`Msg msg), _ ->
Logs.warn (fun m -> m "file %a size error: %s" Fpath.pp path msg) ;
Ok acc
| Ok size ->
let id = id_of_string (Fpath.to_string file) in
| _, Error (`Msg msg) ->
Logs.warn (fun m -> m "file %a name error: %s" Fpath.pp path msg) ;
Ok acc
| Ok size, Ok id ->
Ok ((id, size) :: acc))
(Ok []) files

12
src/vmm_unix.mli
View file

@ -4,18 +4,18 @@ open Rresult
open Vmm_core
val prepare : id -> vm_config -> (string list, [> R.msg ]) result
val prepare : Name.t -> vm_config -> (string list, [> R.msg ]) result
val shutdown : id -> vm -> (unit, [> R.msg ]) result
val shutdown : Name.t -> vm -> (unit, [> R.msg ]) result
val exec : id -> vm_config -> string list -> string list option -> (vm, [> R.msg ]) result
val exec : Name.t -> vm_config -> string list -> Name.t option -> (vm, [> R.msg ]) result
val destroy : vm -> unit
val close_no_err : Unix.file_descr -> unit
val create_block : id -> int -> (unit, [> R.msg ]) result
val create_block : Name.t -> int -> (unit, [> R.msg ]) result
val destroy_block : id -> (unit, [> R.msg ]) result
val destroy_block : Name.t -> (unit, [> R.msg ]) result
val find_block_devices : unit -> ((id * int) list, [> R.msg ]) result
val find_block_devices : unit -> ((Name.t * int) list, [> R.msg ]) result

46
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" pp_id id size msg) ;
Logs.err (fun m -> m "couldn't insert block device %a (%dM): %s" Name.pp id size msg) ;
r
| Ok r -> r)
t.resources devs
@ -49,9 +49,9 @@ type service_out = [
type out = [ service_out | `Data of Vmm_commands.wire ]
let log t id event =
let log t name event =
let data = (Ptime_clock.now (), event) in
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.log_counter ; id } in
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.log_counter ; name } in
let log_counter = Int64.succ t.log_counter in
Logs.debug (fun m -> m "log %a" Log.pp data) ;
({ t with log_counter }, `Log (header, `Data (`Log_data data)))
@ -67,8 +67,8 @@ let handle_create t reply name vm_config =
(match vm_config.block_device with
| None -> Ok None
| Some dev ->
let block_device_name = block_name name dev in
Logs.debug (fun m -> m "looking for block device %a" pp_id block_device_name) ;
let block_device_name = Name.block_name name dev in
Logs.debug (fun m -> m "looking for block device %a" Name.pp block_device_name) ;
match Vmm_resources.find_block t.resources block_device_name with
| Some (_, false) -> Ok (Some block_device_name)
| Some (_, true) -> Error (`Msg "block device is busy")
@ -77,7 +77,7 @@ let handle_create t reply name vm_config =
Vmm_unix.prepare name vm_config >>= fun taps ->
Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
let cons_out =
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.console_counter ; name } in
(header, `Command (`Console_cmd `Console_add))
in
Ok ({ t with console_counter = Int64.succ t.console_counter },
@ -87,14 +87,14 @@ let handle_create t reply name vm_config =
Vmm_unix.exec name vm_config taps block_device >>= fun vm ->
Logs.debug (fun m -> m "exec()ed vm") ;
Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
let tasks = String.Map.add (string_of_id name) task t.tasks in
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.pid, vm.taps, None)) in
Ok (t, [ reply (`String "created VM") ; out ], name, vm)))
let setup_stats t name vm =
let stat_out = `Stats_add (vm.pid, vm.taps) in
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } 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))
@ -108,8 +108,8 @@ let handle_shutdown t name vm r =
t.resources
| Ok resources -> resources
in
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
let tasks = String.Map.remove (string_of_id name) t.tasks 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.pid, r))
in
@ -117,11 +117,11 @@ let handle_shutdown t name vm r =
let handle_policy_cmd t reply id = function
| `Policy_remove ->
Logs.debug (fun m -> m "remove policy %a" pp_id id) ;
Logs.debug (fun m -> m "remove policy %a" Name.pp id) ;
Vmm_resources.remove_policy t.resources id >>= fun resources ->
Ok ({ t with resources }, [ reply (`String "removed policy") ], `End)
| `Policy_add policy ->
Logs.debug (fun m -> m "insert policy %a" pp_id id) ;
Logs.debug (fun m -> m "insert policy %a" Name.pp id) ;
let same_policy = match Vmm_resources.find_policy t.resources id with
| None -> false
| Some p' -> eq_policy policy p'
@ -132,7 +132,7 @@ let handle_policy_cmd t reply id = function
Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
Ok ({ t with resources }, [ reply (`String "added policy") ], `Loop)
| `Policy_info ->
Logs.debug (fun m -> m "policy %a" pp_id id) ;
Logs.debug (fun m -> m "policy %a" Name.pp id) ;
let policies =
Vmm_resources.fold t.resources id
(fun _ _ policies -> policies)
@ -142,14 +142,14 @@ let handle_policy_cmd t reply id = function
in
match policies with
| [] ->
Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ;
Logs.debug (fun m -> m "policies: couldn't find %a" Name.pp id) ;
Error (`Msg "policy: not found")
| _ ->
Ok (t, [ reply (`Policies policies) ], `End)
let handle_vm_cmd t reply id msg_to_err = function
| `Vm_info ->
Logs.debug (fun m -> m "info %a" pp_id id) ;
Logs.debug (fun m -> m "info %a" Name.pp id) ;
let vms =
Vmm_resources.fold t.resources id
(fun id vm vms -> (id, vm.config) :: vms)
@ -159,7 +159,7 @@ let handle_vm_cmd t reply id msg_to_err = function
in
begin match vms with
| [] ->
Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ;
Logs.debug (fun m -> m "info: couldn't find %a" Name.pp id) ;
Error (`Msg "info: not found")
| _ ->
Ok (t, [ reply (`Vms vms) ], `End)
@ -178,7 +178,7 @@ let handle_vm_cmd t reply id msg_to_err = function
| None -> handle_create t reply id vm_config
| Some vm ->
Vmm_unix.destroy vm ;
let id_str = string_of_id id in
let id_str = Name.to_string id in
match String.Map.find_opt id_str t.tasks with
| None -> handle_create t reply id vm_config
| Some task ->
@ -191,7 +191,7 @@ let handle_vm_cmd t reply id msg_to_err = function
match Vmm_resources.find_vm t.resources id with
| Some vm ->
Vmm_unix.destroy vm ;
let id_str = string_of_id id in
let id_str = Name.to_string id in
let out, next =
let s = reply (`String "destroyed vm") in
match String.Map.find_opt id_str t.tasks with
@ -204,7 +204,7 @@ let handle_vm_cmd t reply id msg_to_err = function
let handle_block_cmd t reply id = function
| `Block_remove ->
Logs.debug (fun m -> m "removing block %a" pp_id id) ;
Logs.debug (fun m -> m "removing block %a" Name.pp id) ;
begin match Vmm_resources.find_block t.resources id with
| None -> Error (`Msg "remove block: not found")
| Some (_, true) -> Error (`Msg "remove block: is in use")
@ -215,7 +215,7 @@ let handle_block_cmd t reply id = function
end
| `Block_add size ->
begin
Logs.debug (fun m -> m "insert block %a: %dMB" pp_id id size) ;
Logs.debug (fun m -> m "insert block %a: %dMB" Name.pp id size) ;
match Vmm_resources.find_block t.resources id with
| Some _ -> Error (`Msg "block device with same name already exists")
| None ->
@ -227,7 +227,7 @@ let handle_block_cmd t reply id = function
Ok ({ t with resources }, [ reply (`String "added block device") ], `Loop)
end
| `Block_info ->
Logs.debug (fun m -> m "block %a" pp_id id) ;
Logs.debug (fun m -> m "block %a" Name.pp id) ;
let blocks =
Vmm_resources.fold t.resources id
(fun _ _ blocks -> blocks)
@ -237,7 +237,7 @@ let handle_block_cmd t reply id = function
in
match blocks with
| [] ->
Logs.debug (fun m -> m "block: couldn't find %a" pp_id id) ;
Logs.debug (fun m -> m "block: couldn't find %a" Name.pp id) ;
Error (`Msg "block: not found")
| _ ->
Ok (t, [ reply (`Blocks blocks) ], `End)
@ -249,7 +249,7 @@ let handle_command t (header, payload) =
Logs.err (fun m -> m "error while processing command: %s" msg) ;
(t, [ `Data (header, `Failure msg) ], `End)
and reply x = `Data (header, `Success x)
and id = header.Vmm_commands.id
and id = header.Vmm_commands.name
in
msg_to_err (
match payload with

8
src/vmm_vmmd.mli
View file

@ -12,17 +12,17 @@ type service_out = [
type out = [ service_out | `Data of Vmm_commands.wire ]
val handle_shutdown : 'a t -> Vmm_core.id -> Vmm_core.vm ->
val handle_shutdown : 'a t -> Vmm_core.Name.t -> Vmm_core.vm ->
[ `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.id * Vmm_core.vm, [> `Msg of string ]) result
[ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.Name.t * Vmm_core.vm, [> `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.id * Vmm_core.vm, [> Rresult.R.msg ]) result
[ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.Name.t * Vmm_core.vm, [> Rresult.R.msg ]) result
| `End ]) ]
val setup_stats : 'a t -> Vmm_core.id -> Vmm_core.vm -> 'a t * out
val setup_stats : 'a t -> Vmm_core.Name.t -> Vmm_core.vm -> 'a t * out