albatross/src/vmm_commands.ml

159 lines
4.2 KiB
OCaml
Raw Normal View History

2018-10-13 23:02:52 +00:00
(* (c) 2018 Hannes Mehnert, all rights reserved *)
2018-10-23 22:03:36 +00:00
(* the wire protocol *)
open Vmm_core
type version = [ `AV2 ]
2018-10-23 22:03:36 +00:00
let pp_version ppf v =
Fmt.int ppf
(match v with
| `AV2 -> 2)
let version_eq a b =
match a, b with
| `AV2, `AV2 -> true
| _ -> false
type console_cmd = [
| `Console_add
| `Console_subscribe of Ptime.t option
2018-10-23 22:03:36 +00:00
]
let pp_console_cmd ppf = function
| `Console_add -> Fmt.string ppf "console add"
| `Console_subscribe ts ->
Fmt.pf ppf "console subscribe since %a"
Fmt.(option ~none:(unit "epoch") (Ptime.pp_rfc3339 ())) ts
2018-10-23 22:03:36 +00:00
type stats_cmd = [
| `Stats_add of int * string list
| `Stats_remove
| `Stats_subscribe
]
let pp_stats_cmd ppf = function
| `Stats_add (pid, taps) -> Fmt.pf ppf "stats add: pid %d taps %a" pid Fmt.(list ~sep:(unit ", ") string) taps
| `Stats_remove -> Fmt.string ppf "stat remove"
| `Stats_subscribe -> Fmt.string ppf "stat subscribe"
type log_cmd = [
| `Log_subscribe of Ptime.t option
2018-10-23 22:03:36 +00:00
]
let pp_log_cmd ppf = function
| `Log_subscribe ts ->
Fmt.pf ppf "log subscribe since %a"
Fmt.(option ~none:(unit "epoch") (Ptime.pp_rfc3339 ())) ts
2018-10-23 22:03:36 +00:00
type vm_cmd = [
| `Vm_info
| `Vm_create of vm_config
| `Vm_force_create of vm_config
| `Vm_destroy
]
let pp_vm_cmd ppf = function
| `Vm_info -> Fmt.string ppf "vm info"
2018-11-10 00:02:07 +00:00
| `Vm_create vm_config -> Fmt.pf ppf "vm create %a" pp_vm_config vm_config
| `Vm_force_create vm_config -> Fmt.pf ppf "vm force create %a" pp_vm_config vm_config
2018-10-23 22:03:36 +00:00
| `Vm_destroy -> Fmt.string ppf "vm destroy"
type policy_cmd = [
| `Policy_info
| `Policy_add of policy
| `Policy_remove
]
let pp_policy_cmd ppf = function
| `Policy_info -> Fmt.string ppf "policy info"
2018-11-10 00:02:07 +00:00
| `Policy_add policy -> Fmt.pf ppf "policy add %a" pp_policy policy
2018-10-23 22:03:36 +00:00
| `Policy_remove -> Fmt.string ppf "policy remove"
2018-11-10 00:02:07 +00:00
type block_cmd = [
| `Block_info
| `Block_add of int
| `Block_remove
]
let pp_block_cmd ppf = function
| `Block_info -> Fmt.string ppf "block info"
| `Block_add size -> Fmt.pf ppf "block add %d" size
| `Block_remove -> Fmt.string ppf "block remove"
2018-10-23 22:03:36 +00:00
type t = [
| `Console_cmd of console_cmd
| `Stats_cmd of stats_cmd
| `Log_cmd of log_cmd
| `Vm_cmd of vm_cmd
| `Policy_cmd of policy_cmd
2018-11-10 00:02:07 +00:00
| `Block_cmd of block_cmd
2018-10-23 22:03:36 +00:00
]
let pp ppf = function
| `Console_cmd c -> pp_console_cmd ppf c
| `Stats_cmd s -> pp_stats_cmd ppf s
| `Log_cmd l -> pp_log_cmd ppf l
| `Vm_cmd v -> pp_vm_cmd ppf v
| `Policy_cmd p -> pp_policy_cmd ppf p
2018-11-10 00:02:07 +00:00
| `Block_cmd b -> pp_block_cmd ppf b
2018-10-23 22:03:36 +00:00
type data = [
| `Console_data of Ptime.t * string
| `Stats_data of Stats.t
| `Log_data of Log.t
]
let pp_data ppf = function
| `Console_data (ts, line) -> Fmt.pf ppf "console data %a: %s"
(Ptime.pp_rfc3339 ()) ts line
| `Stats_data stats -> Fmt.pf ppf "stats data: %a" Stats.pp stats
| `Log_data log -> Fmt.pf ppf "log data: %a" Log.pp log
type header = {
version : version ;
sequence : int64 ;
id : id ;
}
2018-11-10 00:02:07 +00:00
type success = [
| `Empty
| `String of string
| `Policies of (id * policy) list
| `Vms of (id * vm_config) list
| `Blocks of (id * int * bool) list
]
let pp_block ppf (id, size, active) =
Fmt.pf ppf "block %a size %d MB active %B" pp_id id size active
2018-10-23 22:03:36 +00:00
let pp_success ppf = function
| `Empty -> Fmt.string ppf "success"
| `String data -> Fmt.pf ppf "success: %s" data
| `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_policy)) ppf ps
| `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms
2018-11-10 00:02:07 +00:00
| `Blocks blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks
2018-10-23 22:03:36 +00:00
type wire = header * [
| `Command of t
| `Success of success
| `Failure of string
| `Data of data ]
let pp_wire ppf (header, data) =
let id = header.id in
match data with
| `Command c -> Fmt.pf ppf "host %a: %a" pp_id id pp c
| `Failure f -> Fmt.pf ppf "host %a: command failed %s" pp_id id f
| `Success s -> Fmt.pf ppf "host %a: %a" pp_id id pp_success s
| `Data d -> pp_data ppf d
let endpoint = function
2018-10-22 21:20:00 +00:00
| `Vm_cmd _ -> `Vmmd, `End
| `Policy_cmd _ -> `Vmmd, `End
2018-11-10 00:02:07 +00:00
| `Block_cmd _ -> `Vmmd, `End
2018-10-22 21:20:00 +00:00
| `Stats_cmd _ -> `Stats, `Read
| `Console_cmd _ -> `Console, `Read
| `Log_cmd _ -> `Log, `Read
2018-10-23 22:03:36 +00:00