albatross/src/vmm_commands.ml

159 lines
4.4 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
2018-11-12 21:11:06 +00:00
type version = [ `AV3 ]
2018-10-23 22:03:36 +00:00
let pp_version ppf v =
Fmt.int ppf
(match v with
2018-11-12 21:11:06 +00:00
| `AV3 -> 3)
2018-10-23 22:03:36 +00:00
let version_eq a b =
match a, b with
2018-11-12 21:11:06 +00:00
| `AV3, `AV3 -> true
2018-10-23 22:03:36 +00:00
| _ -> 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
2018-11-13 00:02:05 +00:00
type unikernel_cmd = [
| `Unikernel_info
| `Unikernel_create of Unikernel.config
| `Unikernel_force_create of Unikernel.config
| `Unikernel_destroy
2018-10-23 22:03:36 +00:00
]
2018-11-13 00:02:05 +00:00
let pp_unikernel_cmd ppf = function
| `Unikernel_info -> Fmt.string ppf "unikernel info"
| `Unikernel_create config -> Fmt.pf ppf "unikernel create %a" Unikernel.pp_config config
| `Unikernel_force_create config -> Fmt.pf ppf "vm force create %a" Unikernel.pp_config config
| `Unikernel_destroy -> Fmt.string ppf "unikernel destroy"
2018-10-23 22:03:36 +00:00
type policy_cmd = [
| `Policy_info
2018-11-11 02:09:37 +00:00
| `Policy_add of Policy.t
2018-10-23 22:03:36 +00:00
| `Policy_remove
]
let pp_policy_cmd ppf = function
| `Policy_info -> Fmt.string ppf "policy info"
2018-11-11 02:09:37 +00:00
| `Policy_add policy -> Fmt.pf ppf "policy add %a" Policy.pp 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
2018-11-13 00:02:05 +00:00
| `Unikernel_cmd of unikernel_cmd
2018-10-23 22:03:36 +00:00
| `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
2018-11-13 00:02:05 +00:00
| `Unikernel_cmd v -> pp_unikernel_cmd ppf v
2018-10-23 22:03:36 +00:00
| `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 ;
name : Name.t ;
2018-10-23 22:03:36 +00:00
}
2018-11-10 00:02:07 +00:00
type success = [
| `Empty
| `String of string
2018-11-11 02:09:37 +00:00
| `Policies of (Name.t * Policy.t) list
2018-11-13 00:02:05 +00:00
| `Unikernels of (Name.t * Unikernel.config) list
| `Block_devices of (Name.t * int * bool) list
2018-11-10 00:02:07 +00:00
]
let pp_block ppf (id, size, active) =
Fmt.pf ppf "block %a size %d MB active %B" Name.pp 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
2018-11-11 02:09:37 +00:00
| `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Policy.pp)) ppf ps
2018-11-13 00:02:05 +00:00
| `Unikernels vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Unikernel.pp_config)) ppf vms
| `Block_devices 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 name = header.name in
2018-10-23 22:03:36 +00:00
match data with
| `Command c -> Fmt.pf ppf "host %a: %a" Name.pp name pp c
| `Failure f -> Fmt.pf ppf "host %a: command failed %s" Name.pp name f
| `Success s -> Fmt.pf ppf "host %a: %a" Name.pp name pp_success s
2018-10-23 22:03:36 +00:00
| `Data d -> pp_data ppf d
let endpoint = function
2018-11-13 00:02:05 +00:00
| `Unikernel_cmd _ -> `Vmmd, `End
2018-10-22 21:20:00 +00:00
| `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