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 The following elaborates on how to get the software up and running, following by
provisioning and deploying some unikernels. There is a *server* (`SRV`) provisioning and deploying some unikernels. There is a *server* (`SRV`)
component which needs six binaries: vmm_console, vmm_log, vmm_stats_lwt, vmmd, 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 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 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 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 Astring
open Vmm_core open Vmm_core
open Lwt.Infix
let print_result version (header, reply) = let print_result version (header, reply) =
if not (Vmm_commands.version_eq header.Vmm_commands.version version) then if not (Vmm_commands.version_eq header.Vmm_commands.version version) then
Logs.err (fun m -> m "version not equal") Logs.err (fun m -> m "version not equal")
else match reply with else match reply with
| `Success s -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) | `Success _ -> 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)) | `Data _ -> 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)) | `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)) | `Command _ -> Logs.err (fun m -> m "unexpected command %a" Vmm_commands.pp_wire (header, reply))
let setup_log style_renderer level = let setup_log style_renderer level =
@ -88,13 +86,15 @@ let bridge =
(parse, pp_bridge) (parse, pp_bridge)
let vm_c = 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 in
(parse, pp_id) (parse, Name.pp)
let opt_vm_name = let opt_vm_name =
let doc = "name of virtual machine." in 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 compress_level =
let doc = "Compression level (0 for no compression)" in let doc = "Compression level (0 for no compression)" in
@ -130,7 +130,7 @@ let block_size =
let opt_block_name = let opt_block_name =
let doc = "Name of block device." in 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 opt_block_size =
let doc = "Block storage to allow in MB" in 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 ru', vmm', ifd
in in
List.fold_left (fun out (id, socket) -> List.fold_left (fun out (id, socket) ->
match Vmm_core.drop_super ~super:id ~sub:vmid with 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.pp_id id Vmm_core.pp_id vmid) ; out | 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 -> | 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)) ((socket, vmid, (header, `Data (`Stats_data stats))) :: out))
out xs) out xs)
[] (Vmm_trie.all t'.vmid_pid) [] (Vmm_trie.all t'.vmid_pid)
@ -133,8 +133,8 @@ let add_pid t vmid pid nics =
let rec go cnt acc id = let rec go cnt acc id =
if id > 0 && cnt > 0 then if id > 0 && cnt > 0 then
match wrap sysctl_ifdata id with match wrap sysctl_ifdata id with
| Some ifd when List.mem ifd.Vmm_core.Stats.name nics -> | Some ifd when List.mem ifd.Vmm_core.Stats.ifname nics ->
go (pred cnt) ((id, ifd.Vmm_core.Stats.name) :: acc) (pred id) go (pred cnt) ((id, ifd.Vmm_core.Stats.ifname) :: acc) (pred id)
| _ -> go cnt acc (pred id) | _ -> go cnt acc (pred id)
else else
List.rev acc List.rev acc
@ -150,9 +150,9 @@ let add_pid t vmid pid nics =
Ok { t with pid_nic ; vmid_pid } Ok { t with pid_nic ; vmid_pid }
let remove_vmid t vmid = 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 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 -> | Some pid ->
Logs.info (fun m -> m "removing pid %d" pid) ; Logs.info (fun m -> m "removing pid %d" pid) ;
(try (try
@ -179,7 +179,7 @@ let handle t socket (header, wire) =
match wire with match wire with
| `Command (`Stats_cmd cmd) -> | `Command (`Stats_cmd cmd) ->
begin begin
let id = header.Vmm_commands.id in let id = header.Vmm_commands.name in
match cmd with match cmd with
| `Stats_add (pid, taps) -> | `Stats_add (pid, taps) ->
add_pid t id pid taps >>= fun t -> 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 -> Vmm_lwt.read_from_file key >>= fun key_cs ->
let key = X509.Encoding.Pem.Private_key.of_pem_cstruct1 key_cs in let key = X509.Encoding.Pem.Private_key.of_pem_cstruct1 key_cs in
let tmpkey = Nocrypto.Rsa.generate 4096 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 = let extensions =
[ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ]) [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
; (true, `Basic_constraints (false, None)) ; (true, `Basic_constraints (false, None))

4
app/vmmc_local.ml
View file

@ -28,10 +28,10 @@ let read fd =
in in
loop () 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 let sock, next = Vmm_commands.endpoint cmd in
connect (socket sock opt_socket) >>= fun fd -> 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 Vmm_lwt.write_wire fd (header, `Command cmd) >>= function
| Error `Exception -> Lwt.return () | Error `Exception -> Lwt.return ()
| Ok () -> | 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 active = ref String.Map.empty
let read_console name ring channel () = let read_console id name ring channel () =
let id = Vmm_core.id_of_string name in
Lwt.catch (fun () -> Lwt.catch (fun () ->
let rec loop () = let rec loop () =
Lwt_io.read_line channel >>= fun line -> Lwt_io.read_line channel >>= fun line ->
@ -31,7 +30,7 @@ let read_console name ring channel () =
(match String.Map.find name !active with (match String.Map.find name !active with
| None -> Lwt.return_unit | None -> Lwt.return_unit
| Some fd -> | 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 Vmm_lwt.write_wire fd (header, `Data (`Console_data (t, line))) >>= function
| Error _ -> | Error _ ->
Vmm_lwt.safe_close fd >|= fun () -> Vmm_lwt.safe_close fd >|= fun () ->
@ -68,21 +67,21 @@ let open_fifo name =
let t = ref String.Map.empty let t = ref String.Map.empty
let add_fifo id = 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 open_fifo name >|= function
| Some f -> | Some f ->
let ring = Vmm_ring.create "" () in let ring = Vmm_ring.create "" () in
Logs.debug (fun m -> m "inserting fifo %s" name) ; Logs.debug (fun m -> m "inserting fifo %s" name) ;
let map = String.Map.add name ring !t in let map = String.Map.add name ring !t in
t := map ; t := map ;
Lwt.async (read_console name ring f) ; Lwt.async (read_console id name ring f) ;
Ok () Ok ()
| None -> | None ->
Error (`Msg "opening") Error (`Msg "opening")
let subscribe s id = let subscribe s id =
let name = Vmm_core.string_of_id id in let name = Vmm_core.Name.to_string id in
Logs.debug (fun m -> m "attempting to subscribe %a" Vmm_core.pp_id id) ; Logs.debug (fun m -> m "attempting to subscribe %a" Vmm_core.Name.pp id) ;
match String.Map.find name !t with match String.Map.find name !t with
| None -> | None ->
active := String.Map.add name s !active ; active := String.Map.add name s !active ;
@ -100,9 +99,9 @@ let send_history s r id since =
| None -> Vmm_ring.read r | None -> Vmm_ring.read r
| Some ts -> Vmm_ring.read_history r ts | Some ts -> Vmm_ring.read_history r ts
in 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) -> 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 Vmm_lwt.write_wire s (header, `Data (`Console_data (i, v))) >>= function
| Ok () -> Lwt.return_unit | Ok () -> Lwt.return_unit
| Error _ -> Vmm_lwt.safe_close s) | Error _ -> Vmm_lwt.safe_close s)
@ -120,7 +119,7 @@ let handle s addr () =
Logs.err (fun m -> m "ignoring data with bad version") ; Logs.err (fun m -> m "ignoring data with bad version") ;
Lwt.return_unit Lwt.return_unit
end else begin end else begin
let name = header.Vmm_commands.id in let name = header.Vmm_commands.name in
match cmd with match cmd with
| `Console_add -> | `Console_add ->
begin begin

8
app/vmmd_influx.ml
View file

@ -138,7 +138,7 @@ module P = struct
in in
let fields = List.map (fun (k, v) -> k ^ "=" ^ v) fields in let fields = List.map (fun (k, v) -> k ^ "=" ^ v) fields in
Printf.sprintf "interface,vm=%s,ifname=%s %s" Printf.sprintf "interface,vm=%s,ifname=%s %s"
vm ifd.name (String.concat ~sep:"," fields) vm ifd.ifname (String.concat ~sep:"," fields)
end end
let my_version = `AV2 let my_version = `AV2
@ -198,7 +198,7 @@ let rec read_sock_write_tcp c ?fd addr addrtype =
safe_close c >|= fun () -> safe_close c >|= fun () ->
false false
end else 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 ru = P.encode_ru name ru in
let vmm = match vmm with None -> [] | Some xs -> [ P.encode_vmm name xs ] 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 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 read_sock_write_tcp c ?fd addr addrtype
let query_sock vm c = 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 ; 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)) Vmm_lwt.write_wire c (header, `Command (`Stats_cmd `Stats_subscribe))
let rec maybe_connect stat_socket = 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 = let res =
List.fold_left (fun acc (ts, event) -> List.fold_left (fun acc (ts, event) ->
let sub = Vmm_core.Log.name event in 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 then (ts, event) :: acc
else acc) else acc)
[] elements [] elements
@ -77,7 +77,7 @@ let send_history s ring id ts =
Lwt_list.fold_left_s (fun r (ts, event) -> Lwt_list.fold_left_s (fun r (ts, event) ->
match r with match r with
| Ok () -> | 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))) Vmm_lwt.write_wire s (header, `Data (`Log_data (ts, event)))
| Error e -> Lwt.return (Error e)) | Error e -> Lwt.return (Error e))
(Ok ()) (List.rev res) (Ok ()) (List.rev res)
@ -93,7 +93,7 @@ let handle_data s mvar ring hdr entry =
Vmm_ring.write ring entry ; Vmm_ring.write ring entry ;
Lwt_mvar.put mvar entry >>= fun () -> Lwt_mvar.put mvar entry >>= fun () ->
let data' = (hdr, `Data (`Log_data entry)) in 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' tree := tree'
end end
@ -128,7 +128,7 @@ let handle mvar ring s addr () =
end else begin end else begin
match lc with match lc with
| `Log_subscribe ts -> | `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' ; tree := tree' ;
(match ret with (match ret with
| None -> Lwt.return_unit | 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") ; | Error _ -> Logs.err (fun m -> m "error while sending reply for subscribe") ;
Lwt.return_unit Lwt.return_unit
| Ok () -> | 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 | Error _ -> Logs.err (fun m -> m "error while sending history") ; Lwt.return_unit
| Ok () -> | Ok () ->
(* command processing is finished, but we leave the socket open (* 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 Vmm_lwt.write_wire s stat >>= function
| Ok () -> Lwt.return_unit | Ok () -> Lwt.return_unit
| Error `Exception -> | 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 ; t := remove_entry !t name ;
Vmm_lwt.safe_close s) Vmm_lwt.safe_close s)
outs >>= fun () -> outs >>= fun () ->

8
app/vmmd_tls.ml
View file

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

2
app/vmmp_request.ml
View file

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

48
src/vmm_asn.ml
View file

@ -150,14 +150,14 @@ let int32 =
let ifdata = let ifdata =
let open Stats in 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))))))))))))))))) = 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))))))))))))))))) =
{ 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 } { 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 = 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 in
Asn.S.map f g @@ Asn.S.map f g @@
Asn.S.(sequence @@ Asn.S.(sequence @@
(required ~label:"name" utf8_string) (required ~label:"ifname" utf8_string)
@ (required ~label:"flags" int32) @ (required ~label:"flags" int32)
@ (required ~label:"send_length" int32) @ (required ~label:"send_length" int32)
@ (required ~label:"max_send_length" int32) @ (required ~label:"max_send_length" int32)
@ -194,31 +194,37 @@ let stats_cmd =
(explicit 1 null) (explicit 1 null)
(explicit 2 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 log_event =
let f = function let f = function
| `C1 () -> `Startup | `C1 () -> `Startup
| `C2 (name, ip, port) -> `Login (name, ip, port) | `C2 (name, ip, port) -> `Login (to_name name, ip, port)
| `C3 (name, ip, port) -> `Logout (name, ip, port) | `C3 (name, ip, port) -> `Logout (to_name name, ip, port)
| `C4 (name, pid, taps, block) -> `Vm_start (name, pid, taps, block) | `C4 (name, pid, taps, block) -> `Vm_start (to_name name, pid, taps, block)
| `C5 (name, pid, status) -> | `C5 (name, pid, status) ->
let status' = match status with let status' = match status with
| `C1 n -> `Exit n | `C1 n -> `Exit n
| `C2 n -> `Signal n | `C2 n -> `Signal n
| `C3 n -> `Stop n | `C3 n -> `Stop n
in in
`Vm_stop (name, pid, status') `Vm_stop (to_name name, pid, status')
and g = function and g = function
| `Startup -> `C1 () | `Startup -> `C1 ()
| `Login (name, ip, port) -> `C2 (name, ip, port) | `Login (name, ip, port) -> `C2 (of_name name, ip, port)
| `Logout (name, ip, port) -> `C3 (name, ip, port) | `Logout (name, ip, port) -> `C3 (of_name name, ip, port)
| `Vm_start (name, pid, taps, block) -> `C4 (name, pid, taps, block) | `Vm_start (name, pid, taps, block) -> `C4 (of_name name, pid, taps, block)
| `Vm_stop (name, pid, status) -> | `Vm_stop (name, pid, status) ->
let status' = match status with let status' = match status with
| `Exit n -> `C1 n | `Exit n -> `C1 n
| `Signal n -> `C2 n | `Signal n -> `C2 n
| `Stop n -> `C3 n | `Stop n -> `C3 n
in in
`C5 (name, pid, status') `C5 (of_name name, pid, status')
in in
let endp = let endp =
Asn.S.(sequence3 Asn.S.(sequence3
@ -382,28 +388,28 @@ let data =
(required ~label:"event" log_event)))) (required ~label:"event" log_event))))
let header = let header =
let f (version, sequence, id) = { version ; sequence ; id } let f (version, sequence, name) = { version ; sequence ; name = to_name name }
and g h = h.version, h.sequence, h.id and g h = h.version, h.sequence, of_name h.name
in in
Asn.S.map f g @@ Asn.S.map f g @@
Asn.S.(sequence3 Asn.S.(sequence3
(required ~label:"version" version) (required ~label:"version" version)
(required ~label:"sequence" int64) (required ~label:"sequence" int64)
(required ~label:"id" (sequence_of utf8_string))) (required ~label:"name" (sequence_of utf8_string)))
let success = let success =
let f = function let f = function
| `C1 () -> `Empty | `C1 () -> `Empty
| `C2 str -> `String str | `C2 str -> `String str
| `C3 policies -> `Policies policies | `C3 policies -> `Policies (List.map (fun (name, p) -> to_name name, p) policies)
| `C4 vms -> `Vms vms | `C4 vms -> `Vms (List.map (fun (name, vm) -> to_name name, vm) vms)
| `C5 blocks -> `Blocks blocks | `C5 blocks -> `Blocks (List.map (fun (name, s, a) -> to_name name, s, a) blocks)
and g = function and g = function
| `Empty -> `C1 () | `Empty -> `C1 ()
| `String s -> `C2 s | `String s -> `C2 s
| `Policies ps -> `C3 ps | `Policies ps -> `C3 (List.map (fun (name, p) -> of_name name, p) ps)
| `Vms vms -> `C4 vms | `Vms vms -> `C4 (List.map (fun (name, v) -> of_name name, v) vms)
| `Blocks blocks -> `C5 blocks | `Blocks blocks -> `C5 (List.map (fun (name, s, a) -> of_name name, s, a) blocks)
in in
Asn.S.map f g @@ Asn.S.map f g @@
Asn.S.(choice5 Asn.S.(choice5

22
src/vmm_commands.ml
View file

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

8
src/vmm_commands.mli
View file

@ -67,15 +67,15 @@ val pp_data : data Fmt.t
type header = { type header = {
version : version ; version : version ;
sequence : int64 ; sequence : int64 ;
id : id ; name : Name.t ;
} }
type success = [ type success = [
| `Empty | `Empty
| `String of string | `String of string
| `Policies of (id * policy) list | `Policies of (Name.t * policy) list
| `Vms of (id * vm_config) list | `Vms of (Name.t * vm_config) list
| `Blocks of (id * int * bool) list | `Blocks of (Name.t * int * bool) list
] ]
type wire = header * [ 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_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed"
| `Hvt_arm64 -> Fmt.pf ppf "hvt-arm64" | `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 [@inline always] valid_label s =
let rec go sup sub = match sup, sub with String.length s < 20 &&
| [], xs -> Some xs String.length s > 0 &&
| _, [] -> None String.get s 0 <> '-' && (* leading may not be '-' *)
| x::xs, z::zs -> if String.equal x z then go xs zs else None String.for_all (function
in | 'a'..'z' | 'A'..'Z' | '0'..'9' | '-' -> true
go super sub | _ -> false)
s (* only LDH (letters, digits, hyphen)! *)
let is_sub_id ~super ~sub = let to_string ids = String.concat ~sep:"." ids
match drop_super ~super ~sub with None -> false | Some _ -> true
let domain id = match List.rev id with let to_list x = x
| _::prefix -> List.rev prefix
| [] -> []
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 = let append lbl x =
Fmt.(pf ppf "(%d)%a" (List.length ids) (list ~sep:(unit ".") string) ids) 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) 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 Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) ppf vmm
type ifdata = { type ifdata = {
name : string ; ifname : string ;
flags : int32 ; flags : int32 ;
send_length : int32 ; send_length : int32 ;
max_send_length : int32 ; max_send_length : int32 ;
@ -258,8 +317,8 @@ module Stats = struct
} }
let pp_ifdata ppf i = 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" 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.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
type t = rusage * vmm option * ifdata list type t = rusage * vmm option * ifdata list
let pp ppf (ru, vmm, ifs) = let pp ppf (ru, vmm, ifs) =
@ -278,11 +337,11 @@ let pp_process_exit ppf = function
module Log = struct module Log = struct
type log_event = [ type log_event = [
| `Login of id * Ipaddr.V4.t * int | `Login of Name.t * Ipaddr.V4.t * int
| `Logout of id * Ipaddr.V4.t * int | `Logout of Name.t * Ipaddr.V4.t * int
| `Startup | `Startup
| `Vm_start of id * int * string list * string option | `Vm_start of Name.t * int * string list * string option
| `Vm_stop of id * int * process_exit | `Vm_stop of Name.t * int * process_exit
] ]
let name = function let name = function
@ -294,14 +353,14 @@ module Log = struct
let pp_log_event ppf = function let pp_log_event ppf = function
| `Startup -> Fmt.(pf ppf "startup") | `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 | `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" pp_id 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) -> | `Vm_start (name, pid, taps, block) ->
Fmt.pf ppf "%a started %d (tap %a, block %a)" 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 Fmt.(option ~none:(unit "no") string) block
| `Vm_stop (name, pid, code) -> | `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 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 include Map.S with type key = I.t
end end
type id = string list module Name : sig
val string_of_id : id -> string type t
val id_of_string : string -> id
val drop_super : super:id -> sub:id -> id option val is_root : t -> bool
val is_sub_id : super:id -> sub:id -> bool
val domain : id -> id val image_file : t -> Fpath.t
val pp_id : id Fmt.t val fifo_file : t -> Fpath.t
val block_name : id -> string -> id 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 = type bridge =
[ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int [ `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_image : (vmtype * Cstruct.t) Fmt.t
val pp_vm_config : vm_config 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 val vm_matches_res : policy -> vm_config -> bool
@ -113,7 +130,7 @@ module Stats : sig
val pp_vmm : vmm Fmt.t val pp_vmm : vmm Fmt.t
type ifdata = { type ifdata = {
name : string; ifname : string;
flags : int32; flags : int32;
send_length : int32; send_length : int32;
max_send_length : int32; max_send_length : int32;
@ -144,13 +161,13 @@ val pp_process_exit : process_exit Fmt.t
module Log : sig module Log : sig
type log_event = [ type log_event = [
| `Login of id * Ipaddr.V4.t * int | `Login of Name.t * Ipaddr.V4.t * int
| `Logout of id * Ipaddr.V4.t * int | `Logout of Name.t * Ipaddr.V4.t * int
| `Startup | `Startup
| `Vm_start of id * int * string list * string option | `Vm_start of Name.t * int * string list * string option
| `Vm_stop of id * int * process_exit ] | `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 val pp_log_event : log_event Fmt.t

30
src/vmm_resources.ml
View file

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

52
src/vmm_resources.mli
View file

@ -18,48 +18,48 @@ type t
val empty : t val empty : t
(** [find_vm t id] is either [Some vm] or [None]. *) (** [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]. *) (** [find_policy t Name.t] is either [Some policy] or [None]. *)
val find_policy : t -> Vmm_core.id -> Vmm_core.policy option val find_policy : t -> Vmm_core.Name.t -> Vmm_core.policy option
(** [find_block t id] is either [Some (size, active)] or [None]. *) (** [find_block t Name.t] is either [Some (size, active)] or [None]. *)
val find_block : t -> Vmm_core.id -> (int * bool) option 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. *) 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. *) 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. *) 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. *) 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. *) 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]. *) (** [remove_vm t Name.t] removes vm [Name.t] from [t]. *)
val remove_vm : t -> Vmm_core.id -> (t, [> `Msg of string ]) result val remove_vm : t -> Vmm_core.Name.t -> (t, [> `Msg of string ]) result
(** [remove_policy t id] removes policy [id] from [t]. *) (** [remove_policy t Name.t] removes policy [Name.t] from [t]. *)
val remove_policy : t -> Vmm_core.id -> (t, [> `Msg of string ]) result val remove_policy : t -> Vmm_core.Name.t -> (t, [> `Msg of string ]) result
(** [remove_block t id] removes block [id] from [t]. *) (** [remove_block t Name.t] removes block [Name.t] from [t]. *)
val remove_block : t -> Vmm_core.id -> (t, [> `Msg of string ]) result 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]. *) (** [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.id -> val fold : t -> Vmm_core.Name.t ->
(Vmm_core.id -> Vmm_core.vm -> 'a -> 'a) -> (Vmm_core.Name.t -> Vmm_core.vm -> 'a -> 'a) ->
(Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> (Vmm_core.Name.t -> Vmm_core.policy -> 'a -> 'a) ->
(Vmm_core.id -> int -> bool -> 'a -> 'a) -> 'a -> 'a (Vmm_core.Name.t -> int -> bool -> 'a -> 'a) -> 'a -> 'a
(** [pp] is a pretty printer for [t]. *) (** [pp] is a pretty printer for [t]. *)
val pp : t Fmt.t val pp : t Fmt.t

29
src/vmm_tls.ml
View file

@ -12,7 +12,18 @@ let cert_name cert =
if name = "" then if name = "" then
match Vmm_asn.cert_extension_of_cstruct data with match Vmm_asn.cert_extension_of_cstruct data with
| Error (`Msg _) -> Error (`Msg "couldn't parse albatross extension") | 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 | _ -> Ok None
else Ok (Some name) else Ok (Some name)
@ -22,8 +33,12 @@ let name chain =
| Error e, _ -> Error e | Error e, _ -> Error e
| _, Error e -> Error e | _, Error e -> Error e
| Ok acc, Ok None -> Ok acc | Ok acc, Ok None -> Ok acc
| Ok acc, Ok Some data -> Ok (data :: acc)) | Ok acc, Ok (Some data) -> Vmm_core.Name.prepend data acc)
(Ok []) chain (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, (* this separates the leaf and top-level certificate from the chain,
and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA') 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 received
Vmm_commands.pp_version version Vmm_commands.pp_version version
| Ok (prefix, acc), Ok (`Policy_cmd (`Policy_add p)) -> | Ok (prefix, acc), Ok (`Policy_cmd (`Policy_add p)) ->
(cert_name cert >>| function (cert_name cert >>= function
| None -> prefix | None -> Ok prefix
| Some x -> x :: prefix) >>| fun name -> | Some x -> Vmm_core.Name.prepend x prefix) >>| fun name ->
(name, (name, p) :: acc) (name, (name, p) :: acc)
| _, Ok wire -> | _, Ok wire ->
R.error_msgf "unexpected wire %a" Vmm_commands.pp wire) R.error_msgf "unexpected wire %a" Vmm_commands.pp wire)
(Ok ([], [])) chain (Ok (Vmm_core.Name.root, [])) chain
let handle _addr version chain = let handle _addr version chain =
separate_chain chain >>= fun (leaf, rest) -> 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 : val handle :
'a -> Vmm_commands.version -> 'a -> Vmm_commands.version ->
X509.t list -> 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 [> `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 let entry, ret = go n xs in
N (es, String.Map.add x entry m), ret N (es, String.Map.add x entry m), ret
in in
go t id go t (Vmm_core.Name.to_list id)
let remove id t = let remove id t =
let rec go (N (es, m)) = function let rec go (N (es, m)) = function
@ -37,7 +37,7 @@ let remove id t =
in in
if String.Map.is_empty m' && es = None then None else Some (N (es, m')) if String.Map.is_empty m' && es = None then None else Some (N (es, m'))
in in
match go t id with match go t (Vmm_core.Name.to_list id) with
| None -> empty | None -> empty
| Some n -> n | Some n -> n
@ -49,7 +49,7 @@ let find id t =
| None -> None | None -> None
| Some n -> go n xs | Some n -> go n xs
in in
go t id go t (Vmm_core.Name.to_list id)
let collect id t = let collect id t =
let rec go acc prefix (N (es, m)) = let rec go acc prefix (N (es, m)) =
@ -63,9 +63,9 @@ let collect id t =
| x::xs -> | x::xs ->
match String.Map.find_opt x m with match String.Map.find_opt x m with
| None -> acc' | None -> acc'
| Some n -> go acc' (prefix @ [ x ]) n xs | Some n -> go acc' (Vmm_core.Name.append_exn x prefix) n xs
in in
go [] [] t id go [] Vmm_core.Name.root t (Vmm_core.Name.to_list id)
let all t = let all t =
let rec go acc prefix (N (es, m)) = let rec go acc prefix (N (es, m)) =
@ -75,15 +75,15 @@ let all t =
| Some e -> (prefix, e) :: acc | Some e -> (prefix, e) :: acc
in in
List.fold_left (fun acc (name, node) -> 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) acc' (String.Map.bindings m)
in in
go [] [] t go [] Vmm_core.Name.root t
let fold id t f acc = let fold id t f acc =
let rec explore (N (es, m)) prefix acc = let rec explore (N (es, m)) prefix acc =
let 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 m acc
in in
match es with match es with
@ -91,9 +91,9 @@ let fold id t f acc =
| Some e -> f prefix e acc' | Some e -> f prefix e acc'
and down prefix (N (es, m)) = and down prefix (N (es, m)) =
match prefix with 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 | x :: xs -> match String.Map.find_opt x m with
| None -> acc | None -> acc
| Some n -> down xs n | Some n -> down xs n
in 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 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 try Unix.mkfifo (Fpath.to_string name) 0o640 with
| Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name | 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 = let rec fifo_exists file =
try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with
| Unix.Unix_error (Unix.ENOENT, _, _) -> Error (`Msg "noent") | Unix.Unix_error (Unix.ENOENT, _, _) -> Error (`Msg "noent")
@ -112,7 +108,7 @@ let prepare name vm =
| Error () -> Error (`Msg "failed to uncompress") | Error () -> Error (`Msg "failed to uncompress")
end end
| `Hvt_arm64, _ -> Error (`Msg "no amd64 hvt image found")) >>= fun image -> | `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 (match fifo_exists fifo with
| Ok true -> Ok () | Ok true -> Ok ()
| Ok false -> Error (`Msg ("file " ^ Fpath.to_string fifo ^ " exists and is not a fifo")) | 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 -> create_tap b >>= fun tap ->
Ok (tap :: acc)) Ok (tap :: acc))
(Ok []) vm.network >>= fun taps -> (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) Ok (List.rev taps)
let shutdown name vm = let shutdown name vm =
(* same order as prepare! *) (* same order as prepare! *)
Bos.OS.File.delete (image_file name) >>= fun () -> Bos.OS.File.delete (Name.image_file name) >>= fun () ->
Bos.OS.File.delete (fifo_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 List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps
let cpuset cpu = let cpuset cpu =
@ -145,8 +141,6 @@ let cpuset cpu =
Ok ([ "taskset" ; "-c" ; cpustring ]) Ok ([ "taskset" ; "-c" ; cpustring ])
| x -> Error (`Msg ("unsupported operating system " ^ x)) | x -> Error (`Msg ("unsupported operating system " ^ x))
let block_device_name name = Fpath.(blockdir / string_of_id name)
let exec name vm taps block = let exec name vm taps block =
(match taps, block with (match taps, block with
| [], None -> Ok "none" | [], None -> Ok "none"
@ -155,7 +149,7 @@ let exec name vm taps block =
| [_], Some _ -> Ok "block-net" | [_], Some _ -> Ok "block-net"
| _, _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin -> | _, _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin ->
let net = List.map (fun t -> "--net=" ^ t) taps 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 argv = match vm.argv with None -> [] | Some xs -> xs
and mem = "--mem=" ^ string_of_int vm.requested_memory and mem = "--mem=" ^ string_of_int vm.requested_memory
in in
@ -163,12 +157,12 @@ let exec name vm taps block =
let cmd = let cmd =
Bos.Cmd.(of_list cpuset % p Fpath.(dbdir / "solo5-hvt" + bin) % mem %% Bos.Cmd.(of_list cpuset % p Fpath.(dbdir / "solo5-hvt" + bin) % mem %%
of_list net %% of_list block % of_list net %% of_list block %
"--" % p (image_file name) %% of_list argv) "--" % p (Name.image_file name) %% of_list argv)
in in
let line = Bos.Cmd.to_list cmd in let line = Bos.Cmd.to_list cmd in
let prog = try List.hd line with Failure _ -> failwith err_empty_line in let prog = try List.hd line with Failure _ -> failwith err_empty_line in
let line = Array.of_list 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); Logs.debug (fun m -> m "write fd for fifo %a" Fpath.pp fifo);
write_fd_for_file fifo >>= fun stdout -> write_fd_for_file fifo >>= fun stdout ->
Logs.debug (fun m -> m "opened file descriptor!"); Logs.debug (fun m -> m "opened file descriptor!");
@ -194,7 +188,7 @@ let bytes_of_mb size =
Error (`Msg "overflow while computing bytes") Error (`Msg "overflow while computing bytes")
let create_block name size = 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 Bos.OS.File.exists block_name >>= function
| true -> Error (`Msg "file already exists") | true -> Error (`Msg "file already exists")
| false -> | false ->
@ -202,7 +196,7 @@ let create_block name size =
Bos.OS.File.truncate block_name size' Bos.OS.File.truncate block_name size'
let destroy_block name = 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 = let mb_of_bytes size =
if size = 0 || size land 0xFFFFF <> 0 then if size = 0 || size land 0xFFFFF <> 0 then
@ -221,11 +215,13 @@ let find_block_devices () =
Ok acc Ok acc
| true -> | true ->
Bos.OS.Path.stat path >>= fun stats -> Bos.OS.Path.stat path >>= fun stats ->
match mb_of_bytes stats.Unix.st_size with match mb_of_bytes stats.Unix.st_size, Name.of_string (Fpath.to_string file) with
| Error (`Msg msg) -> | Error (`Msg msg), _ ->
Logs.warn (fun m -> m "file %a error: %s" Fpath.pp path msg) ; Logs.warn (fun m -> m "file %a size error: %s" Fpath.pp path msg) ;
Ok acc Ok acc
| Ok size -> | _, Error (`Msg msg) ->
let id = id_of_string (Fpath.to_string file) in 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 ((id, size) :: acc))
(Ok []) files (Ok []) files

12
src/vmm_unix.mli
View file

@ -4,18 +4,18 @@ open Rresult
open Vmm_core 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 destroy : vm -> unit
val close_no_err : Unix.file_descr -> 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) -> List.fold_left (fun r (id, size) ->
match Vmm_resources.insert_block r id size with match Vmm_resources.insert_block r id size with
| Error (`Msg msg) -> | 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 r
| Ok r -> r) | Ok r -> r)
t.resources devs t.resources devs
@ -49,9 +49,9 @@ type service_out = [
type out = [ service_out | `Data of Vmm_commands.wire ] 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 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 let log_counter = Int64.succ t.log_counter in
Logs.debug (fun m -> m "log %a" Log.pp data) ; Logs.debug (fun m -> m "log %a" Log.pp data) ;
({ t with log_counter }, `Log (header, `Data (`Log_data 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 (match vm_config.block_device with
| None -> Ok None | None -> Ok None
| Some dev -> | Some dev ->
let block_device_name = block_name name dev in let block_device_name = Name.block_name name dev in
Logs.debug (fun m -> m "looking for block device %a" pp_id block_device_name) ; 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 match Vmm_resources.find_block t.resources block_device_name with
| Some (_, false) -> Ok (Some block_device_name) | Some (_, false) -> Ok (Some block_device_name)
| Some (_, true) -> Error (`Msg "block device is busy") | 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 -> 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 ",@ ") string) taps) ;
let cons_out = 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)) (header, `Command (`Console_cmd `Console_add))
in in
Ok ({ t with console_counter = Int64.succ t.console_counter }, 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 -> Vmm_unix.exec name vm_config taps block_device >>= fun vm ->
Logs.debug (fun m -> m "exec()ed vm") ; Logs.debug (fun m -> m "exec()ed vm") ;
Vmm_resources.insert_vm t.resources name vm >>= fun resources -> 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 = { t with resources ; tasks } in
let t, out = log t name (`Vm_start (name, vm.pid, vm.taps, None)) 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))) Ok (t, [ reply (`String "created VM") ; out ], name, vm)))
let setup_stats t name vm = let setup_stats t name vm =
let stat_out = `Stats_add (vm.pid, vm.taps) in 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 let t = { t with stats_counter = Int64.succ t.stats_counter } in
t, `Stat (header, `Command (`Stats_cmd stat_out)) t, `Stat (header, `Command (`Stats_cmd stat_out))
@ -108,8 +108,8 @@ let handle_shutdown t name vm r =
t.resources t.resources
| Ok resources -> resources | Ok resources -> resources
in 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 tasks = String.Map.remove (string_of_id name) t.tasks 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 = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in
let t, logout = log t name (`Vm_stop (name, vm.pid, r)) let t, logout = log t name (`Vm_stop (name, vm.pid, r))
in in
@ -117,11 +117,11 @@ let handle_shutdown t name vm r =
let handle_policy_cmd t reply id = function let handle_policy_cmd t reply id = function
| `Policy_remove -> | `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 -> Vmm_resources.remove_policy t.resources id >>= fun resources ->
Ok ({ t with resources }, [ reply (`String "removed policy") ], `End) Ok ({ t with resources }, [ reply (`String "removed policy") ], `End)
| `Policy_add policy -> | `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 let same_policy = match Vmm_resources.find_policy t.resources id with
| None -> false | None -> false
| Some p' -> eq_policy policy p' | 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 -> Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
Ok ({ t with resources }, [ reply (`String "added policy") ], `Loop) Ok ({ t with resources }, [ reply (`String "added policy") ], `Loop)
| `Policy_info -> | `Policy_info ->
Logs.debug (fun m -> m "policy %a" pp_id id) ; Logs.debug (fun m -> m "policy %a" Name.pp id) ;
let policies = let policies =
Vmm_resources.fold t.resources id Vmm_resources.fold t.resources id
(fun _ _ policies -> policies) (fun _ _ policies -> policies)
@ -142,14 +142,14 @@ let handle_policy_cmd t reply id = function
in in
match policies with 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") Error (`Msg "policy: not found")
| _ -> | _ ->
Ok (t, [ reply (`Policies policies) ], `End) Ok (t, [ reply (`Policies policies) ], `End)
let handle_vm_cmd t reply id msg_to_err = function let handle_vm_cmd t reply id msg_to_err = function
| `Vm_info -> | `Vm_info ->
Logs.debug (fun m -> m "info %a" pp_id id) ; Logs.debug (fun m -> m "info %a" Name.pp id) ;
let vms = let vms =
Vmm_resources.fold t.resources id Vmm_resources.fold t.resources id
(fun id vm vms -> (id, vm.config) :: vms) (fun id vm vms -> (id, vm.config) :: vms)
@ -159,7 +159,7 @@ let handle_vm_cmd t reply id msg_to_err = function
in in
begin match vms with 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") Error (`Msg "info: not found")
| _ -> | _ ->
Ok (t, [ reply (`Vms vms) ], `End) 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 | None -> handle_create t reply id vm_config
| Some vm -> | Some vm ->
Vmm_unix.destroy 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 match String.Map.find_opt id_str t.tasks with
| None -> handle_create t reply id vm_config | None -> handle_create t reply id vm_config
| Some task -> | 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 match Vmm_resources.find_vm t.resources id with
| Some vm -> | Some vm ->
Vmm_unix.destroy 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 out, next =
let s = reply (`String "destroyed vm") in let s = reply (`String "destroyed vm") in
match String.Map.find_opt id_str t.tasks with 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 let handle_block_cmd t reply id = function
| `Block_remove -> | `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 begin match Vmm_resources.find_block t.resources id with
| None -> Error (`Msg "remove block: not found") | None -> Error (`Msg "remove block: not found")
| Some (_, true) -> Error (`Msg "remove block: is in use") | Some (_, true) -> Error (`Msg "remove block: is in use")
@ -215,7 +215,7 @@ let handle_block_cmd t reply id = function
end end
| `Block_add size -> | `Block_add size ->
begin 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 match Vmm_resources.find_block t.resources id with
| Some _ -> Error (`Msg "block device with same name already exists") | Some _ -> Error (`Msg "block device with same name already exists")
| None -> | None ->
@ -227,7 +227,7 @@ let handle_block_cmd t reply id = function
Ok ({ t with resources }, [ reply (`String "added block device") ], `Loop) Ok ({ t with resources }, [ reply (`String "added block device") ], `Loop)
end end
| `Block_info -> | `Block_info ->
Logs.debug (fun m -> m "block %a" pp_id id) ; Logs.debug (fun m -> m "block %a" Name.pp id) ;
let blocks = let blocks =
Vmm_resources.fold t.resources id Vmm_resources.fold t.resources id
(fun _ _ blocks -> blocks) (fun _ _ blocks -> blocks)
@ -237,7 +237,7 @@ let handle_block_cmd t reply id = function
in in
match blocks with 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") Error (`Msg "block: not found")
| _ -> | _ ->
Ok (t, [ reply (`Blocks blocks) ], `End) 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) ; Logs.err (fun m -> m "error while processing command: %s" msg) ;
(t, [ `Data (header, `Failure msg) ], `End) (t, [ `Data (header, `Failure msg) ], `End)
and reply x = `Data (header, `Success x) and reply x = `Data (header, `Success x)
and id = header.Vmm_commands.id and id = header.Vmm_commands.name
in in
msg_to_err ( msg_to_err (
match payload with 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 ] 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 [ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list
val handle_command : 'a t -> Vmm_commands.wire -> val handle_command : 'a t -> Vmm_commands.wire ->
'a t * out list * '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 | `Loop
| `End | `End
| `Wait of 'a * out | `Wait of 'a * out
| `Wait_and_create of 'a * ('a t -> 'a t * out list * | `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 ]) ] | `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