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)
| Ok (name, off) ->
match Console.int_to_op hdr.tag with
| Some Add -> add_fifo s name
| Some Attach -> attach name
| Some Detach -> detach name
| Some Add_console -> add_fifo s name
| Some Attach_console -> attach name
| Some Detach_console -> detach name
| Some History ->
(match decode_ts ~off data with
| 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 ->
f_done := true ;
(* 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 ;
Logs.debug (fun m -> m "writing %a over TLS" Cstruct.hexdump_pp (Cstruct.of_string out)) ;
(Vmm_tls.write_tls tls out >|= function
@ -223,7 +223,7 @@ let rec tcp_listener db tcp tls =
| Error () -> Lwt.return (Error ())
| Ok () ->
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 ;
command := succ !command ;
Vmm_tls.write_tls tls out >|= function

65
src/vmm_core.ml
View file

@ -39,48 +39,47 @@ let permission_of_string = function
| _ -> None
type cmd =
[ `Info
| `Destroy_vm
| `Create_block
| `Destroy_block
| `Statistics
| `Attach
| `Detach
| `Log
]
| Info
| Destroy_vm
| Create_block
| Destroy_block
| Statistics
| Attach
| Detach
| Log
let pp_cmd ppf = function
| `Info -> Fmt.pf ppf "info"
| `Destroy_vm -> Fmt.pf ppf "destroy"
| `Create_block -> Fmt.pf ppf "create-block"
| `Destroy_block -> Fmt.pf ppf "destroy-block"
| `Statistics -> Fmt.pf ppf "statistics"
| `Attach -> Fmt.pf ppf "attach"
| `Detach -> Fmt.pf ppf "detach"
| `Log -> Fmt.pf ppf "log"
| Info -> Fmt.pf ppf "info"
| Destroy_vm -> Fmt.pf ppf "destroy"
| Create_block -> Fmt.pf ppf "create-block"
| Destroy_block -> Fmt.pf ppf "destroy-block"
| Statistics -> Fmt.pf ppf "statistics"
| Attach -> Fmt.pf ppf "attach"
| Detach -> Fmt.pf ppf "detach"
| Log -> Fmt.pf ppf "log"
let cmd_of_string = function
| x when x = "info" -> Some `Info
| x when x = "destroy" -> Some `Destroy_vm
| x when x = "create-block" -> Some `Create_block
| x when x = "destroy-block" -> Some `Destroy_block
| x when x = "statistics" -> Some `Statistics
| x when x = "attach" -> Some `Attach
| x when x = "detach" -> Some `Detach
| x when x = "log" -> Some `Log
| x when x = "info" -> Some Info
| x when x = "destroy" -> Some Destroy_vm
| x when x = "create-block" -> Some Create_block
| x when x = "destroy-block" -> Some Destroy_block
| x when x = "statistics" -> Some Statistics
| x when x = "attach" -> Some Attach
| x when x = "detach" -> Some Detach
| x when x = "log" -> Some Log
| _ -> None
let cmd_allowed permissions cmd =
List.mem `All permissions ||
let perm = match cmd with
| `Info -> `Info
| `Destroy_vm -> `Create
| `Create_block -> `Block
| `Destroy_block -> `Block
| `Statistics -> `Statistics
| `Attach -> `Console
| `Detach -> `Console
| `Log -> `Log
| Info -> `Info
| Destroy_vm -> `Create
| Create_block -> `Block
| Destroy_block -> `Block
| Statistics -> `Statistics
| Attach -> `Console
| Detach -> `Console
| Log -> `Log
in
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) ->
let arg = if String.length buf = 0 then prefix else prefix @ [buf] in
match x with
| `Info ->
| Info ->
begin match Vmm_resources.find t.resources arg with
| None ->
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
Ok (t, [ `Tls (s, out) ])
end
| `Destroy_vm ->
| Destroy_vm ->
begin match Vmm_resources.find_vm t.resources arg with
| Some vm ->
Vmm_commands.destroy vm ;
@ -232,7 +232,7 @@ let handle_command t s prefix perms hdr buf =
| _ ->
Error (`Msg ("destroy: not found " ^ buf))
end
| `Attach ->
| Attach ->
(* TODO: get (optionally) <since> from client, instead of hardcoding Ptime.epoch below *)
let name = String.concat ~sep:"." arg in
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
Ok ({ t with console_counter = succ t.console_counter ; console_requests },
[ `Raw (t.console_socket, cons) ])
| `Detach ->
| Detach ->
let name = String.concat ~sep:"." arg in
let cons = Vmm_wire.Console.detach t.console_counter t.console_version name in
(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
Ok ({ t with console_counter = succ t.console_counter ; console_attached },
[ `Raw (t.console_socket, cons) ; `Tls (s, out) ])
| `Statistics ->
| Statistics ->
begin match t.stats_socket with
| None -> Error (`Msg "no statistics available")
| 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)
| _ -> Error (`Msg ("statistics: not found " ^ buf))
end
| `Log ->
| Log ->
begin
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_counter = succ t.log_counter in
Ok ({ t with log_counter ; log_requests }, [ `Raw (t.log_socket, log_out) ])
end
| `Create_block | `Destroy_block -> Error (`Msg "NYI")
| Create_block | Destroy_block -> Error (`Msg "NYI")
end
| Some _ -> Error (`Msg "unauthorised command")
in
@ -399,7 +399,7 @@ let handle_initial t s addr chain ca =
handle_revocation t s leaf chain ca prefix
else
let log_attached =
if cmd_allowed perms `Log then
if cmd_allowed perms Log then
let pre = string_of_id prefix in
let v = match String.Map.find pre t.log_attached with
| None -> []
@ -430,7 +430,7 @@ let handle_stat state hdr data =
let state = { state with stats_requests } in
let out =
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
| Ok (ru, vmm, ifs) ->
let ifs =

52
src/vmm_wire.ml
View file

@ -191,9 +191,9 @@ let fail ?msg id version =
module Console = struct
[%%cenum
type op =
| Add
| Attach
| Detach
| Add_console
| Attach_console
| Detach_console
| History
| Data
[@@uint16_t]
@ -222,11 +222,11 @@ module Console = struct
in
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 payload = encode_ptime since in
@ -238,8 +238,8 @@ module Stats = struct
type op =
| Add
| Remove
| Statistics
| StatReply
| Stat_request
| Stat_reply
[@@uint16_t]
]
@ -358,11 +358,11 @@ module Stats = struct
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 length = Cstruct.len payload
and tag = op_to_int StatReply
and tag = op_to_int Stat_reply
in
let r =
Cstruct.append (create_header { length ; id ; version ; tag }) payload
@ -575,23 +575,23 @@ end
module Client = struct
let cmd_to_int = function
| `Info -> 0
| `Destroy_vm -> 1
| `Create_block -> 2
| `Destroy_block -> 3
| `Statistics -> 4
| `Attach -> 5
| `Detach -> 6
| `Log -> 7
| Info -> 0
| Destroy_vm -> 1
| Create_block -> 2
| Destroy_block -> 3
| Statistics -> 4
| Attach -> 5
| Detach -> 6
| Log -> 7
and cmd_of_int = function
| 0 -> Some `Info
| 1 -> Some `Destroy_vm
| 2 -> Some `Create_block
| 3 -> Some `Destroy_block
| 4 -> Some `Statistics
| 5 -> Some `Attach
| 6 -> Some `Detach
| 7 -> Some `Log
| 0 -> Some Info
| 1 -> Some Destroy_vm
| 2 -> Some Create_block
| 3 -> Some Destroy_block
| 4 -> Some Statistics
| 5 -> Some Attach
| 6 -> Some Detach
| 7 -> Some Log
| _ -> None
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 ->
let t = remove_pid t pid in
Ok (t, success ~msg:"removed" hdr.id my_version)
| Some Statistics ->
| Some Stat_request ->
decode_pid cs >>= fun pid ->
stats t pid >>= fun s ->
Ok (t, stat_reply hdr.id my_version (encode_stats s))