From a89b2925fd6e57ab2301250dbaef86ba320d589a Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 4 Apr 2018 22:16:31 +0200 Subject: [PATCH] Vmm_core.cmd is now a variant (no longer polymorphic variant), some renames in Vmm_wire.Stats and Vmm_wire.Console to disambiguate --- app/vmm_console.ml | 6 ++-- app/vmm_prometheus_stats.ml | 4 +-- src/vmm_core.ml | 65 ++++++++++++++++++------------------- src/vmm_engine.ml | 18 +++++----- src/vmm_wire.ml | 52 ++++++++++++++--------------- stats/vmm_stats.ml | 2 +- 6 files changed, 73 insertions(+), 74 deletions(-) diff --git a/app/vmm_console.ml b/app/vmm_console.ml index 94e6e91..f6f4fbf 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -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) diff --git a/app/vmm_prometheus_stats.ml b/app/vmm_prometheus_stats.ml index 113af0f..98a2df9 100644 --- a/app/vmm_prometheus_stats.ml +++ b/app/vmm_prometheus_stats.ml @@ -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 diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 9bd2a53..624f192 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -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 diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index 5e67e95..4b377fb 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -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) 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 = diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index 651402f..57c2815 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -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 diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index 667aa6e..9f406d3 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -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))