QEMU/KVM virtual machine management via QMP
qmp: let open Json.Codec in cleanup
48 Json.Codec. prefixes removed. Command.t carries an `id` field
that clashes with Json.Codec.mem_map.id, so:
- Hoisted `execute`, `arguments`, `id` accessors. Only `id`
needs `(c : t)` annotation.
- Introduced positional `v` constructor (alongside the existing
labeled `make`) so the codec body's `Object.map ~kind:"command" v`
avoids the inline-record-literal disambiguation problem under
the open.
All 115 qemu tests pass.
+64
-51
+64
-51
lib/qmp_protocol.ml
+64
-51
lib/qmp_protocol.ml
···
22
22
{ qemu = { major; minor; micro }; package }
23
23
24
24
let qemu_jsont =
25
-
Json.Codec.Object.map ~kind:"qemu_version" (fun major minor micro ->
25
+
let open Json.Codec in
26
+
Object.map ~kind:"qemu_version" (fun major minor micro ->
26
27
{ major; minor; micro })
27
-
|> Json.Codec.Object.mem "major" Json.Codec.int ~enc:(fun v -> v.major)
28
-
|> Json.Codec.Object.mem "minor" Json.Codec.int ~enc:(fun v -> v.minor)
29
-
|> Json.Codec.Object.mem "micro" Json.Codec.int ~enc:(fun v -> v.micro)
30
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
28
+
|> Object.mem "major" int ~enc:(fun v -> v.major)
29
+
|> Object.mem "minor" int ~enc:(fun v -> v.minor)
30
+
|> Object.mem "micro" int ~enc:(fun v -> v.micro)
31
+
|> Object.skip_unknown |> Object.finish
31
32
32
33
let jsont =
33
-
Json.Codec.Object.map ~kind:"version" (fun qemu package ->
34
+
let open Json.Codec in
35
+
Object.map ~kind:"version" (fun qemu package ->
34
36
{ qemu; package })
35
-
|> Json.Codec.Object.mem "qemu" qemu_jsont ~enc:(fun v -> v.qemu)
36
-
|> Json.Codec.Object.mem "package" Json.Codec.string ~enc:(fun v ->
37
+
|> Object.mem "qemu" qemu_jsont ~enc:(fun v -> v.qemu)
38
+
|> Object.mem "package" string ~enc:(fun v ->
37
39
v.package)
38
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
40
+
|> Object.skip_unknown |> Object.finish
39
41
40
42
let pp ppf v =
41
43
Fmt.pf ppf "%d.%d.%d%s" v.qemu.major v.qemu.minor v.qemu.micro
···
47
49
type t = { qmp : qmp_info }
48
50
49
51
let qmp_info_jsont =
50
-
Json.Codec.Object.map ~kind:"qmp_info" (fun version capabilities ->
52
+
let open Json.Codec in
53
+
Object.map ~kind:"qmp_info" (fun version capabilities ->
51
54
{ version; capabilities })
52
-
|> Json.Codec.Object.mem "version" Version.jsont ~enc:(fun q -> q.version)
53
-
|> Json.Codec.Object.mem "capabilities" (Json.Codec.list Json.Codec.string)
55
+
|> Object.mem "version" Version.jsont ~enc:(fun q -> q.version)
56
+
|> Object.mem "capabilities" (list string)
54
57
~enc:(fun q -> q.capabilities)
55
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
58
+
|> Object.skip_unknown |> Object.finish
56
59
57
60
let jsont =
58
-
Json.Codec.Object.map ~kind:"greeting" (fun qmp -> { qmp })
59
-
|> Json.Codec.Object.mem "QMP" qmp_info_jsont ~enc:(fun g -> g.qmp)
60
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
61
+
let open Json.Codec in
62
+
Object.map ~kind:"greeting" (fun qmp -> { qmp })
63
+
|> Object.mem "QMP" qmp_info_jsont ~enc:(fun g -> g.qmp)
64
+
|> Object.skip_unknown |> Object.finish
61
65
62
66
let version t = t.qmp.version
63
67
let capabilities t = t.qmp.capabilities
···
67
71
type t = { seconds : int; microseconds : int }
68
72
69
73
let jsont =
70
-
Json.Codec.Object.map ~kind:"timestamp" (fun seconds microseconds ->
74
+
let open Json.Codec in
75
+
Object.map ~kind:"timestamp" (fun seconds microseconds ->
71
76
{ seconds; microseconds })
72
-
|> Json.Codec.Object.mem "seconds" Json.Codec.int ~enc:(fun t -> t.seconds)
73
-
|> Json.Codec.Object.mem "microseconds" Json.Codec.int ~enc:(fun t ->
77
+
|> Object.mem "seconds" int ~enc:(fun t -> t.seconds)
78
+
|> Object.mem "microseconds" int ~enc:(fun t ->
74
79
t.microseconds)
75
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
80
+
|> Object.skip_unknown |> Object.finish
76
81
77
82
let to_float t = Float.of_int t.seconds +. (Float.of_int t.microseconds /. 1e6)
78
83
end
···
81
86
type t = { class_ : string; desc : string }
82
87
83
88
let jsont =
84
-
Json.Codec.Object.map ~kind:"qmp_error" (fun class_ desc ->
89
+
let open Json.Codec in
90
+
Object.map ~kind:"qmp_error" (fun class_ desc ->
85
91
{ class_; desc })
86
-
|> Json.Codec.Object.mem "class" Json.Codec.string ~enc:(fun e -> e.class_)
87
-
|> Json.Codec.Object.mem "desc" Json.Codec.string ~enc:(fun e -> e.desc)
88
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
92
+
|> Object.mem "class" string ~enc:(fun e -> e.class_)
93
+
|> Object.mem "desc" string ~enc:(fun e -> e.desc)
94
+
|> Object.skip_unknown |> Object.finish
89
95
90
96
let pp ppf e = Fmt.pf ppf "%s: %s" e.class_ e.desc
91
97
end
···
94
100
type t = { event : string; data : Json.t option; timestamp : Timestamp.t }
95
101
96
102
let jsont =
97
-
Json.Codec.Object.map ~kind:"event" (fun event data timestamp ->
103
+
let open Json.Codec in
104
+
Object.map ~kind:"event" (fun event data timestamp ->
98
105
{ event; data; timestamp })
99
-
|> Json.Codec.Object.mem "event" Json.Codec.string ~enc:(fun e -> e.event)
100
-
|> Json.Codec.Object.opt_mem "data" Json.Codec.Value.t ~enc:(fun e ->
106
+
|> Object.mem "event" string ~enc:(fun e -> e.event)
107
+
|> Object.opt_mem "data" Value.t ~enc:(fun e ->
101
108
e.data)
102
-
|> Json.Codec.Object.mem "timestamp" Timestamp.jsont ~enc:(fun e ->
109
+
|> Object.mem "timestamp" Timestamp.jsont ~enc:(fun e ->
103
110
e.timestamp)
104
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
111
+
|> Object.skip_unknown |> Object.finish
105
112
106
113
let name t = t.event
107
114
let data t = t.data
···
114
121
type t = { execute : string; arguments : Json.t option; id : string option }
115
122
116
123
let make ?arguments ?id execute = { execute; arguments; id }
124
+
let v execute arguments id = { execute; arguments; id }
125
+
let execute c = c.execute
126
+
let arguments c = c.arguments
127
+
let id (c : t) = c.id
117
128
118
129
let jsont =
119
-
Json.Codec.Object.map ~kind:"command" (fun execute arguments id ->
120
-
{ execute; arguments; id })
121
-
|> Json.Codec.Object.mem "execute" Json.Codec.string ~enc:(fun c ->
122
-
c.execute)
123
-
|> Json.Codec.Object.opt_mem "arguments" Json.Codec.Value.t ~enc:(fun c ->
124
-
c.arguments)
125
-
|> Json.Codec.Object.opt_mem "id" Json.Codec.string ~enc:(fun c -> c.id)
126
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
130
+
let open Json.Codec in
131
+
Object.map ~kind:"command" v
132
+
|> Object.mem "execute" string ~enc:execute
133
+
|> Object.opt_mem "arguments" Value.t ~enc:arguments
134
+
|> Object.opt_mem "id" string ~enc:id
135
+
|> Object.skip_unknown |> Object.finish
127
136
128
137
let to_json t =
129
138
match Json.encode jsont t with
···
152
161
type t = Success of success | Error of error_response
153
162
154
163
let success_jsont : success Json.codec =
155
-
Json.Codec.Object.map ~kind:"success" (fun return success_id ->
164
+
let open Json.Codec in
165
+
Object.map ~kind:"success" (fun return success_id ->
156
166
{ return; success_id })
157
-
|> Json.Codec.Object.mem "return" Json.Codec.Value.t ~enc:(fun s ->
167
+
|> Object.mem "return" Value.t ~enc:(fun s ->
158
168
s.return)
159
-
|> Json.Codec.Object.opt_mem "id" Json.Codec.string ~enc:(fun s ->
169
+
|> Object.opt_mem "id" string ~enc:(fun s ->
160
170
s.success_id)
161
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
171
+
|> Object.skip_unknown |> Object.finish
162
172
163
173
let error_jsont : error_response Json.codec =
164
-
Json.Codec.Object.map ~kind:"error_response" (fun qmp_error error_id ->
174
+
let open Json.Codec in
175
+
Object.map ~kind:"error_response" (fun qmp_error error_id ->
165
176
{ qmp_error; error_id })
166
-
|> Json.Codec.Object.mem "error" Error.jsont ~enc:(fun e -> e.qmp_error)
167
-
|> Json.Codec.Object.opt_mem "id" Json.Codec.string ~enc:(fun e ->
177
+
|> Object.mem "error" Error.jsont ~enc:(fun e -> e.qmp_error)
178
+
|> Object.opt_mem "id" string ~enc:(fun e ->
168
179
e.error_id)
169
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
180
+
|> Object.skip_unknown |> Object.finish
170
181
end
171
182
172
183
(** {1 Message parsing} *)
···
272
283
type t = { running : bool; singlestep : bool; status : run_state }
273
284
274
285
let run_state_jsont =
275
-
Json.Codec.enum ~kind:"run_state"
286
+
let open Json.Codec in
287
+
enum ~kind:"run_state"
276
288
[
277
289
("debug", Debug);
278
290
("inmigrate", Inmigrate);
···
293
305
]
294
306
295
307
let jsont =
296
-
Json.Codec.Object.map ~kind:"status" (fun running singlestep status ->
308
+
let open Json.Codec in
309
+
Object.map ~kind:"status" (fun running singlestep status ->
297
310
{ running; singlestep; status })
298
-
|> Json.Codec.Object.mem "running" Json.Codec.bool ~enc:(fun s -> s.running)
299
-
|> Json.Codec.Object.mem "singlestep" Json.Codec.bool ~enc:(fun s ->
311
+
|> Object.mem "running" bool ~enc:(fun s -> s.running)
312
+
|> Object.mem "singlestep" bool ~enc:(fun s ->
300
313
s.singlestep)
301
-
|> Json.Codec.Object.mem "status" run_state_jsont ~enc:(fun s -> s.status)
302
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
314
+
|> Object.mem "status" run_state_jsont ~enc:(fun s -> s.status)
315
+
|> Object.skip_unknown |> Object.finish
303
316
304
317
let of_json json =
305
318
Result.map_error Json.Error.to_string (Json.decode jsont json)