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

Vmm_core.cmd is now a variant (no longer polymorphic variant), some renames in Vmm_wire.Stats and Vmm_wire.Console to disambiguate

Browse source
This commit is contained in:
Hannes Mehnert 2018-04-04 22:16:31 +02:00
parent fdab43aed6
commit a89b2925fd
6 changed files with 73 additions and 74 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
app/vmm_console.ml
View file

@ -127,9 +127,9 @@ let handle s addr () =
| Error e -> Lwt.return (Error e) | Error e -> Lwt.return (Error e)
| Ok (name, off) -> | Ok (name, off) ->
match Console.int_to_op hdr.tag with match Console.int_to_op hdr.tag with
| Some Add -> add_fifo s name | Some Add_console -> add_fifo s name
| Some Attach -> attach name | Some Attach_console -> attach name
| Some Detach -> detach name | Some Detach_console -> detach name
| Some History -> | Some History ->
(match decode_ts ~off data with (match decode_ts ~off data with
| Error e -> Lwt.return (Error e) | Error e -> Lwt.return (Error e)

4
app/vmm_prometheus_stats.ml
View file

@ -125,7 +125,7 @@ let process db tls hdr data =
| x when x = Client.log_msg_tag && not !f_done -> | x when x = Client.log_msg_tag && not !f_done ->
f_done := true ; f_done := true ;
(* issue initial "info" to get all the vm names *) (* issue initial "info" to get all the vm names *)
let out = Vmm_wire.Client.cmd `Info !command my_version in let out = Vmm_wire.Client.cmd Info !command my_version in
command := succ !command ; command := succ !command ;
Logs.debug (fun m -> m "writing %a over TLS" Cstruct.hexdump_pp (Cstruct.of_string out)) ; Logs.debug (fun m -> m "writing %a over TLS" Cstruct.hexdump_pp (Cstruct.of_string out)) ;
(Vmm_tls.write_tls tls out >|= function (Vmm_tls.write_tls tls out >|= function
@ -223,7 +223,7 @@ let rec tcp_listener db tcp tls =
| Error () -> Lwt.return (Error ()) | Error () -> Lwt.return (Error ())
| Ok () -> | Ok () ->
let vm_id = translate_name db vm in let vm_id = translate_name db vm in
let out = Vmm_wire.Client.cmd `Statistics ~arg:vm_id !command my_version in let out = Vmm_wire.Client.cmd Statistics ~arg:vm_id !command my_version in
t := IM.add !command (cs, sockaddr, vm) !t ; t := IM.add !command (cs, sockaddr, vm) !t ;
command := succ !command ; command := succ !command ;
Vmm_tls.write_tls tls out >|= function Vmm_tls.write_tls tls out >|= function

65
src/vmm_core.ml
View file

@ -39,48 +39,47 @@ let permission_of_string = function
| _ -> None | _ -> None
type cmd = type cmd =
[ `Info | Info
| `Destroy_vm | Destroy_vm
| `Create_block | Create_block
| `Destroy_block | Destroy_block
| `Statistics | Statistics
| `Attach | Attach
| `Detach | Detach
| `Log | Log
]
let pp_cmd ppf = function let pp_cmd ppf = function
| `Info -> Fmt.pf ppf "info" | Info -> Fmt.pf ppf "info"
| `Destroy_vm -> Fmt.pf ppf "destroy" | Destroy_vm -> Fmt.pf ppf "destroy"
| `Create_block -> Fmt.pf ppf "create-block" | Create_block -> Fmt.pf ppf "create-block"
| `Destroy_block -> Fmt.pf ppf "destroy-block" | Destroy_block -> Fmt.pf ppf "destroy-block"
| `Statistics -> Fmt.pf ppf "statistics" | Statistics -> Fmt.pf ppf "statistics"
| `Attach -> Fmt.pf ppf "attach" | Attach -> Fmt.pf ppf "attach"
| `Detach -> Fmt.pf ppf "detach" | Detach -> Fmt.pf ppf "detach"
| `Log -> Fmt.pf ppf "log" | Log -> Fmt.pf ppf "log"
let cmd_of_string = function let cmd_of_string = function
| x when x = "info" -> Some `Info | x when x = "info" -> Some Info
| x when x = "destroy" -> Some `Destroy_vm | x when x = "destroy" -> Some Destroy_vm
| x when x = "create-block" -> Some `Create_block | x when x = "create-block" -> Some Create_block
| x when x = "destroy-block" -> Some `Destroy_block | x when x = "destroy-block" -> Some Destroy_block
| x when x = "statistics" -> Some `Statistics | x when x = "statistics" -> Some Statistics
| x when x = "attach" -> Some `Attach | x when x = "attach" -> Some Attach
| x when x = "detach" -> Some `Detach | x when x = "detach" -> Some Detach
| x when x = "log" -> Some `Log | x when x = "log" -> Some Log
| _ -> None | _ -> None
let cmd_allowed permissions cmd = let cmd_allowed permissions cmd =
List.mem `All permissions || List.mem `All permissions ||
let perm = match cmd with let perm = match cmd with
| `Info -> `Info | Info -> `Info
| `Destroy_vm -> `Create | Destroy_vm -> `Create
| `Create_block -> `Block | Create_block -> `Block
| `Destroy_block -> `Block | Destroy_block -> `Block
| `Statistics -> `Statistics | Statistics -> `Statistics
| `Attach -> `Console | Attach -> `Console
| `Detach -> `Console | Detach -> `Console
| `Log -> `Log | Log -> `Log
in in
List.mem perm permissions List.mem perm permissions

18
src/vmm_engine.ml
View file

@ -209,7 +209,7 @@ let handle_command t s prefix perms hdr buf =
Vmm_wire.decode_str buf >>= fun (buf, _l) -> Vmm_wire.decode_str buf >>= fun (buf, _l) ->
let arg = if String.length buf = 0 then prefix else prefix @ [buf] in let arg = if String.length buf = 0 then prefix else prefix @ [buf] in
match x with match x with
| `Info -> | Info ->
begin match Vmm_resources.find t.resources arg with begin match Vmm_resources.find t.resources arg with
| None -> | None ->
Logs.debug (fun m -> m "info: couldn't find %a" pp_id arg) ; Logs.debug (fun m -> m "info: couldn't find %a" pp_id arg) ;
@ -223,7 +223,7 @@ let handle_command t s prefix perms hdr buf =
let out = Vmm_wire.Client.info data hdr.Vmm_wire.id t.client_version in let out = Vmm_wire.Client.info data hdr.Vmm_wire.id t.client_version in
Ok (t, [ `Tls (s, out) ]) Ok (t, [ `Tls (s, out) ])
end end
| `Destroy_vm -> | Destroy_vm ->
begin match Vmm_resources.find_vm t.resources arg with begin match Vmm_resources.find_vm t.resources arg with
| Some vm -> | Some vm ->
Vmm_commands.destroy vm ; Vmm_commands.destroy vm ;
@ -232,7 +232,7 @@ let handle_command t s prefix perms hdr buf =
| _ -> | _ ->
Error (`Msg ("destroy: not found " ^ buf)) Error (`Msg ("destroy: not found " ^ buf))
end end
| `Attach -> | Attach ->
(* TODO: get (optionally) <since> from client, instead of hardcoding Ptime.epoch below *) (* TODO: get (optionally) <since> from client, instead of hardcoding Ptime.epoch below *)
let name = String.concat ~sep:"." arg in let name = String.concat ~sep:"." arg in
let on_success t = let on_success t =
@ -251,7 +251,7 @@ let handle_command t s prefix perms hdr buf =
let console_requests = IM.add t.console_counter on_success t.console_requests in let console_requests = IM.add t.console_counter on_success t.console_requests in
Ok ({ t with console_counter = succ t.console_counter ; console_requests }, Ok ({ t with console_counter = succ t.console_counter ; console_requests },
[ `Raw (t.console_socket, cons) ]) [ `Raw (t.console_socket, cons) ])
| `Detach -> | Detach ->
let name = String.concat ~sep:"." arg in let name = String.concat ~sep:"." arg in
let cons = Vmm_wire.Console.detach t.console_counter t.console_version name in let cons = Vmm_wire.Console.detach t.console_counter t.console_version name in
(match String.Map.find name t.console_attached with (match String.Map.find name t.console_attached with
@ -261,7 +261,7 @@ let handle_command t s prefix perms hdr buf =
let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
Ok ({ t with console_counter = succ t.console_counter ; console_attached }, Ok ({ t with console_counter = succ t.console_counter ; console_attached },
[ `Raw (t.console_socket, cons) ; `Tls (s, out) ]) [ `Raw (t.console_socket, cons) ; `Tls (s, out) ])
| `Statistics -> | Statistics ->
begin match t.stats_socket with begin match t.stats_socket with
| None -> Error (`Msg "no statistics available") | None -> Error (`Msg "no statistics available")
| Some _ -> match Vmm_resources.find_vm t.resources arg with | Some _ -> match Vmm_resources.find_vm t.resources arg with
@ -273,14 +273,14 @@ let handle_command t s prefix perms hdr buf =
stat t stat_out) stat t stat_out)
| _ -> Error (`Msg ("statistics: not found " ^ buf)) | _ -> Error (`Msg ("statistics: not found " ^ buf))
end end
| `Log -> | Log ->
begin begin
let log_out = Vmm_wire.Log.history t.log_counter t.log_version (string_of_id prefix) Ptime.epoch in let log_out = Vmm_wire.Log.history t.log_counter t.log_version (string_of_id prefix) Ptime.epoch in
let log_requests = IM.add t.log_counter (s, hdr.Vmm_wire.id) t.log_requests in let log_requests = IM.add t.log_counter (s, hdr.Vmm_wire.id) t.log_requests in
let log_counter = succ t.log_counter in let log_counter = succ t.log_counter in
Ok ({ t with log_counter ; log_requests }, [ `Raw (t.log_socket, log_out) ]) Ok ({ t with log_counter ; log_requests }, [ `Raw (t.log_socket, log_out) ])
end end
| `Create_block | `Destroy_block -> Error (`Msg "NYI") | Create_block | Destroy_block -> Error (`Msg "NYI")
end end
| Some _ -> Error (`Msg "unauthorised command") | Some _ -> Error (`Msg "unauthorised command")
in in
@ -399,7 +399,7 @@ let handle_initial t s addr chain ca =
handle_revocation t s leaf chain ca prefix handle_revocation t s leaf chain ca prefix
else else
let log_attached = let log_attached =
if cmd_allowed perms `Log then if cmd_allowed perms Log then
let pre = string_of_id prefix in let pre = string_of_id prefix in
let v = match String.Map.find pre t.log_attached with let v = match String.Map.find pre t.log_attached with
| None -> [] | None -> []
@ -430,7 +430,7 @@ let handle_stat state hdr data =
let state = { state with stats_requests } in let state = { state with stats_requests } in
let out = let out =
match Stats.int_to_op hdr.tag with match Stats.int_to_op hdr.tag with
| Some Stats.StatReply -> | Some Stats.Stat_reply ->
begin match Stats.decode_stats (Cstruct.of_string data) with begin match Stats.decode_stats (Cstruct.of_string data) with
| Ok (ru, vmm, ifs) -> | Ok (ru, vmm, ifs) ->
let ifs = let ifs =

52
src/vmm_wire.ml
View file

@ -191,9 +191,9 @@ let fail ?msg id version =
module Console = struct module Console = struct
[%%cenum [%%cenum
type op = type op =
| Add | Add_console
| Attach | Attach_console
| Detach | Detach_console
| History | History
| Data | Data
[@@uint16_t] [@@uint16_t]
@ -222,11 +222,11 @@ module Console = struct
in in
encode id v Data ~payload file encode id v Data ~payload file
let add id v name = encode id v Add name let add id v name = encode id v Add_console name
let attach id v name = encode id v Attach name let attach id v name = encode id v Attach_console name
let detach id v name = encode id v Detach name let detach id v name = encode id v Detach_console name
let history id v name since = let history id v name since =
let payload = encode_ptime since in let payload = encode_ptime since in
@ -238,8 +238,8 @@ module Stats = struct
type op = type op =
| Add | Add
| Remove | Remove
| Statistics | Stat_request
| StatReply | Stat_reply
[@@uint16_t] [@@uint16_t]
] ]
@ -358,11 +358,11 @@ module Stats = struct
let remove id v pid = encode id v Remove pid let remove id v pid = encode id v Remove pid
let stat id v pid = encode id v Statistics pid let stat id v pid = encode id v Stat_request pid
let stat_reply id version payload = let stat_reply id version payload =
let length = Cstruct.len payload let length = Cstruct.len payload
and tag = op_to_int StatReply and tag = op_to_int Stat_reply
in in
let r = let r =
Cstruct.append (create_header { length ; id ; version ; tag }) payload Cstruct.append (create_header { length ; id ; version ; tag }) payload
@ -575,23 +575,23 @@ end
module Client = struct module Client = struct
let cmd_to_int = function let cmd_to_int = function
| `Info -> 0 | Info -> 0
| `Destroy_vm -> 1 | Destroy_vm -> 1
| `Create_block -> 2 | Create_block -> 2
| `Destroy_block -> 3 | Destroy_block -> 3
| `Statistics -> 4 | Statistics -> 4
| `Attach -> 5 | Attach -> 5
| `Detach -> 6 | Detach -> 6
| `Log -> 7 | Log -> 7
and cmd_of_int = function and cmd_of_int = function
| 0 -> Some `Info | 0 -> Some Info
| 1 -> Some `Destroy_vm | 1 -> Some Destroy_vm
| 2 -> Some `Create_block | 2 -> Some Create_block
| 3 -> Some `Destroy_block | 3 -> Some Destroy_block
| 4 -> Some `Statistics | 4 -> Some Statistics
| 5 -> Some `Attach | 5 -> Some Attach
| 6 -> Some `Detach | 6 -> Some Detach
| 7 -> Some `Log | 7 -> Some Log
| _ -> None | _ -> None
let console_msg_tag = 0xFFF0 let console_msg_tag = 0xFFF0

2
stats/vmm_stats.ml
View file

@ -175,7 +175,7 @@ let handle t hdr buf =
decode_pid cs >>= fun pid -> decode_pid cs >>= fun pid ->
let t = remove_pid t pid in let t = remove_pid t pid in
Ok (t, success ~msg:"removed" hdr.id my_version) Ok (t, success ~msg:"removed" hdr.id my_version)
| Some Statistics -> | Some Stat_request ->
decode_pid cs >>= fun pid -> decode_pid cs >>= fun pid ->
stats t pid >>= fun s -> stats t pid >>= fun s ->
Ok (t, stat_reply hdr.id my_version (encode_stats s)) Ok (t, stat_reply hdr.id my_version (encode_stats s))