Vmm_core.cmd is now a variant (no longer polymorphic variant), some renames in Vmm_wire.Stats and Vmm_wire.Console to disambiguate
This commit is contained in:
parent
fdab43aed6
commit
a89b2925fd
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 =
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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))
|
||||||
|
|
Loading…
Reference in a new issue