QEMU/KVM virtual machine management via QMP
follow loc record shape + Json.to_string plain: xtce, qemu, space-block, prune, rego, paseto, runc, monitor, json
- xtce: Xml.Value.element is now Xml.Value.t; Xml.Value.of_string returns
Xml.Error.t, convert to string at failwith.
- qemu bin + prune + space-block: drop stale Json.Error.to_string on
string-typed errors.
- rego data_error_of_json_error: Loc.Error.t is now a record; read e.meta.
- rego Value.of_json_string / to_json_string: use Json.Value.{of,to}_string
shorthand (no codec arg needed for the generic AST).
- paseto v3_encrypt: encode_claims now returns plain string (Json.to_string
is plain), drop the Ok/Error match.
- runc Command.t, Command.container: drop unused [sw] and [bundle] fields.
Command.create no longer needs ~sw — Runc.Command.create dropped it too.
- monitor Process.create still uses [sw] (passed to Eio.Process.spawn),
so keep it in the module type S signature.
- json fuzz: use Json.Value.of_string shorthand.
+27
-48
+1
-4
bin/main.ml
+1
-4
bin/main.ml
···
376
376
Fmt.epr "QMP error: %a@." Qemu.Qmp.Error.pp e;
377
377
`Error (false, "QMP error")
378
378
| Ok (Ok json) ->
379
-
(match Json.to_string Json.Codec.Value.t json with
380
-
| Ok s -> Fmt.pr "%s@." s
381
-
| Error e ->
382
-
Fmt.epr "JSON error: %s@." (Json.Error.to_string e));
379
+
Fmt.pr "%s@." (Json.Value.to_string json);
383
380
`Ok ())))
384
381
$ name_arg $ socket_arg $ command_arg)
385
382
in
+1
-1
lib/qmp_protocol.ml
+1
-1
lib/qmp_protocol.ml
+3
-6
lib/vm.ml
+3
-6
lib/vm.ml
···
263
263
264
264
let send_command t cmd =
265
265
let json = Qmp_protocol.Command.to_json cmd in
266
-
match Json.to_string Json.Codec.Value.t json with
267
-
| Ok s ->
268
-
Log.debug (fun m -> m "Sending: %s" s);
269
-
write_line t s
270
-
| Error e ->
271
-
Fmt.failwith "Failed to encode command: %s" (Json.Error.to_string e)
266
+
let s = Json.Value.to_string json in
267
+
Log.debug (fun m -> m "Sending: %s" s);
268
+
write_line t s
272
269
273
270
let receive_response t =
274
271
let rec loop () =
+12
-22
test/test_qemu.ml
+12
-22
test/test_qemu.ml
···
11
11
module Qmp = Qemu.Qmp
12
12
13
13
let parse_json s =
14
-
match Json.of_string Json.Codec.Value.t s with
15
-
| Ok json -> json
16
-
| Error e -> failwith (Json.Error.to_string e)
14
+
match Json.Value.of_string s with Ok json -> json | Error e -> failwith e
17
15
18
16
let check_message_ok msg json =
19
17
match Qmp.Message.of_string json with
···
271
269
let test_command_encode () =
272
270
let cmd = Qmp.Command.query_status in
273
271
let json = Qmp.Command.to_json cmd in
274
-
match Json.to_string Json.Codec.Value.t json with
275
-
| Ok s ->
276
-
Alcotest.(check bool)
277
-
"contains execute" true
278
-
(String.sub s 0 10 = "{\"execute\"")
279
-
| Error e -> Alcotest.fail (Json.Error.to_string e)
272
+
let s = Json.Value.to_string json in
273
+
Alcotest.(check bool)
274
+
"contains execute" true
275
+
(String.sub s 0 10 = "{\"execute\"")
280
276
281
277
let test_command_with_id () =
282
278
let cmd = Qmp.Command.make ~id:"cookie#1" "query-name" in
283
279
let json = Qmp.Command.to_json cmd in
284
280
(* Roundtrip through Command codec *)
285
-
match Json.to_string Json.Codec.Value.t json with
281
+
match Json.Value.to_string json with
286
282
| Ok s -> (
287
283
match Json.of_string Qmp.Command.jsont s with
288
284
| Ok cmd' ->
289
285
(* Encode again and check it still contains our id *)
290
286
let json' = Qmp.Command.to_json cmd' in
291
-
let s' =
292
-
match Json.to_string Json.Codec.Value.t json' with
293
-
| Ok s -> s
294
-
| Error e -> Alcotest.failf "re-encode: %s" (Json.Error.to_string e)
295
-
in
287
+
let s' = Json.Value.to_string json' e in
296
288
(* Both serializations should match *)
297
289
Alcotest.(check string) "roundtrip" s s'
298
-
| Error e -> Alcotest.failf "decode: %s" (Json.Error.to_string e))
299
-
| Error e -> Alcotest.fail (Json.Error.to_string e)
290
+
| Error e -> Alcotest.failf "decode: %s" e)
291
+
| Error e -> Alcotest.fail e
300
292
301
293
let test_command_roundtrip () =
302
294
let cmds =
···
318
310
List.iter
319
311
(fun cmd ->
320
312
let json = Qmp.Command.to_json cmd in
321
-
match Json.to_string Json.Codec.Value.t json with
313
+
match Json.Value.to_string json with
322
314
| Ok s -> (
323
315
match Json.of_string Qmp.Command.jsont s with
324
316
| Ok _ -> ()
325
-
| Error e ->
326
-
Alcotest.failf "roundtrip decode: %s" (Json.Error.to_string e))
327
-
| Error e ->
328
-
Alcotest.failf "roundtrip encode: %s" (Json.Error.to_string e))
317
+
| Error e -> Alcotest.failf "roundtrip decode: %s" e)
318
+
| Error e -> Alcotest.failf "roundtrip encode: %s" e)
329
319
cmds
330
320
331
321
(* {1 Status parsing tests} *)
+10
-15
test/test_qmp_protocol.ml
+10
-15
test/test_qmp_protocol.ml
···
18
18
module Qmp = Qemu.Qmp
19
19
20
20
let parse_json s =
21
-
match Json.of_string Json.Codec.Value.t s with
22
-
| Ok json -> json
23
-
| Error e -> failwith (Json.Error.to_string e)
21
+
match Json.Value.of_string s with Ok json -> json | Error e -> failwith e
24
22
25
-
let encode_json json =
26
-
match Json.to_string Json.Codec.Value.t json with
27
-
| Ok s -> s
28
-
| Error e -> failwith (Json.Error.to_string e)
23
+
let encode_json json = Json.Value.to_string json
29
24
30
25
(* {1 Version codec tests} *)
31
26
···
41
36
Alcotest.(check int) "minor" 0 v'.qemu.minor;
42
37
Alcotest.(check int) "micro" 0 v'.qemu.micro;
43
38
Alcotest.(check string) "package" "v9.0.0" v'.package
44
-
| Error e -> Alcotest.failf "decode: %s" (Json.Error.to_string e))
45
-
| Error e -> Alcotest.failf "encode: %s" (Json.Error.to_string e)
39
+
| Error e -> Alcotest.failf "decode: %s" e)
40
+
| Error e -> Alcotest.failf "encode: %s" e
46
41
47
42
let test_version_high_numbers () =
48
43
let v = Qmp.Version.make 99 12 3 "custom-build-2025" in
···
61
56
Alcotest.(check int) "minor" 2 v.qemu.minor;
62
57
Alcotest.(check int) "micro" 5 v.qemu.micro;
63
58
Alcotest.(check string) "package" "Debian 1:7.2+dfsg-7" v.package
64
-
| Error e -> Alcotest.failf "decode: %s" (Json.Error.to_string e)
59
+
| Error e -> Alcotest.failf "decode: %s" e
65
60
66
61
let test_version_extra_fields_ignored () =
67
62
(* Jsont skip_unknown should tolerate extra fields *)
···
73
68
| Ok v ->
74
69
Alcotest.(check int) "major" 8 v.qemu.major;
75
70
Alcotest.(check string) "package" "" v.package
76
-
| Error e -> Alcotest.failf "decode: %s" (Json.Error.to_string e)
71
+
| Error e -> Alcotest.failf "decode: %s" e
77
72
78
73
(* {1 Greeting tests -- QEMU 9.0 spec vector} *)
79
74
···
165
160
(* Roundtrip through codec *)
166
161
match Json.of_string Qmp.Command.jsont s with
167
162
| Ok _ -> ()
168
-
| Error e -> Alcotest.failf "roundtrip: %s" (Json.Error.to_string e)
163
+
| Error e -> Alcotest.failf "roundtrip: %s" e
169
164
170
165
let test_command_with_id_args () =
171
166
let args = parse_json {|{"protocol": "tcp", "hostname": "localhost"}|} in
···
174
169
let s = encode_json json in
175
170
match Json.of_string Qmp.Command.jsont s with
176
171
| Ok _ -> ()
177
-
| Error e -> Alcotest.failf "roundtrip: %s" (Json.Error.to_string e)
172
+
| Error e -> Alcotest.failf "roundtrip: %s" e
178
173
179
174
let test_command_blockdev_add () =
180
175
(* More complex arguments -- blockdev-add with nested config *)
···
187
182
let s = encode_json json in
188
183
match Json.of_string Qmp.Command.jsont s with
189
184
| Ok _ -> ()
190
-
| Error e -> Alcotest.failf "roundtrip: %s" (Json.Error.to_string e)
185
+
| Error e -> Alcotest.failf "roundtrip: %s" e
191
186
192
187
(* {1 Status run_state string roundtrip} *)
193
188
···
307
302
| Ok ts ->
308
303
Alcotest.(check int) "seconds" 1267040730 ts.seconds;
309
304
Alcotest.(check int) "microseconds" 682951 ts.microseconds
310
-
| Error e -> Alcotest.failf "decode: %s" (Json.Error.to_string e)
305
+
| Error e -> Alcotest.failf "decode: %s" e
311
306
312
307
(* {1 Event data extraction} *)
313
308