Source file vmm_commands.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
open Vmm_core
type version = [ `AV3 | `AV4 ]
let current = `AV4
let pp_version ppf v =
Fmt.int ppf
(match v with
| `AV4 -> 4
| `AV3 -> 3)
let version_eq a b =
match a, b with
| `AV4, `AV4 -> true
| `AV3, `AV3 -> true
| _ -> false
let is_current = version_eq current
type since_count = [ `Since of Ptime.t | `Count of int ]
let pp_since_count ppf = function
| `Since since -> Fmt.pf ppf "since %a" (Ptime.pp_rfc3339 ()) since
| `Count n -> Fmt.pf ppf "number %d" n
type console_cmd = [
| `Console_add
| `Console_subscribe of since_count
]
let pp_console_cmd ppf = function
| `Console_add -> Fmt.string ppf "console add"
| `Console_subscribe ts -> Fmt.pf ppf "console subscribe %a" pp_since_count ts
type stats_cmd = [
| `Stats_add of string * int * (string * string) list
| `Stats_remove
| `Stats_subscribe
]
let pp_stats_cmd ppf = function
| `Stats_add (vmmdev, pid, taps) ->
Fmt.pf ppf "stats add: vmm device %s pid %d taps %a" vmmdev pid
Fmt.(list ~sep:(unit ", ") (pair ~sep:(unit ": ") string string)) taps
| `Stats_remove -> Fmt.string ppf "stat remove"
| `Stats_subscribe -> Fmt.string ppf "stat subscribe"
type unikernel_cmd = [
| `Unikernel_info
| `Unikernel_create of Unikernel.config
| `Unikernel_force_create of Unikernel.config
| `Unikernel_destroy
| `Unikernel_get
| `Old_unikernel_info
| `Old_unikernel_get
]
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"
| `Unikernel_get -> Fmt.string ppf "unikernel get"
| `Old_unikernel_info -> Fmt.string ppf "old unikernel info"
| `Old_unikernel_get -> Fmt.string ppf "old unikernel get"
type policy_cmd = [
| `Policy_info
| `Policy_add of Policy.t
| `Policy_remove
]
let pp_policy_cmd ppf = function
| `Policy_info -> Fmt.string ppf "policy info"
| `Policy_add policy -> Fmt.pf ppf "policy add %a" Policy.pp policy
| `Policy_remove -> Fmt.string ppf "policy remove"
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"
type t = [
| `Console_cmd of console_cmd
| `Stats_cmd of stats_cmd
| `Unikernel_cmd of unikernel_cmd
| `Policy_cmd of policy_cmd
| `Block_cmd of block_cmd
]
let pp ppf = function
| `Console_cmd c -> pp_console_cmd ppf c
| `Stats_cmd s -> pp_stats_cmd ppf s
| `Unikernel_cmd v -> pp_unikernel_cmd ppf v
| `Policy_cmd p -> pp_policy_cmd ppf p
| `Block_cmd b -> pp_block_cmd ppf b
type data = [
| `Console_data of Ptime.t * string
| `Stats_data of Stats.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
let ?(version = current) ?(sequence = 0L) name = { version ; sequence ; name }
type success = [
| `Empty
| `String of string
| `Policies of (Name.t * Policy.t) list
| `Old_unikernels of (Name.t * Unikernel.config) list
| `Unikernel_info of (Name.t * Unikernel.info) list
| `Unikernel_image of bool * Cstruct.t
| `Block_devices of (Name.t * int * bool) list
]
let pp_block ppf (id, size, active) =
Fmt.pf ppf "block %a size %d MB active %B" Name.pp id size active
let my_fmt_list empty pp_elt ppf xs =
match xs with
| [] -> Fmt.string ppf empty
| _ -> Fmt.(list ~sep:(unit "@.") pp_elt ppf xs)
let pp_success ppf = function
| `Empty -> Fmt.string ppf "success"
| `String data -> Fmt.pf ppf "success: %s" data
| `Policies ps -> my_fmt_list "no policies" Fmt.(pair ~sep:(unit ": ") Name.pp Policy.pp) ppf ps
| `Old_unikernels vms -> my_fmt_list "no unikernels" Fmt.(pair ~sep:(unit ": ") Name.pp Unikernel.pp_config) ppf vms
| `Unikernel_info infos -> my_fmt_list "no unikernels" Fmt.(pair ~sep:(unit ": ") Name.pp Unikernel.pp_info) ppf infos
| `Unikernel_image (compressed, image) -> Fmt.pf ppf "image (compression %B) %d bytes" compressed (Cstruct.len image)
| `Block_devices blocks -> my_fmt_list "no block devices" pp_block ppf blocks
type res = [
| `Command of t
| `Success of success
| `Failure of string
| `Data of data
]
type wire = header * res
let pp_wire ppf (, data) =
let name = header.name in
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
| `Data d -> pp_data ppf d
let endpoint = function
| `Unikernel_cmd _ -> `Vmmd, `End
| `Policy_cmd _ -> `Vmmd, `End
| `Block_cmd _ -> `Vmmd, `End
| `Stats_cmd `Stats_subscribe -> `Stats, `Read
| `Stats_cmd _ -> `Stats, `End
| `Console_cmd _ -> `Console, `Read