QEMU/KVM virtual machine management via QMP
json: rename mem -> member / finish -> seal across the codec + value API
Object combinators: [Object.mem] -> [Object.member], [Object.opt_mem]
-> [Object.opt_member], [Object.case_mem] -> [Object.case_member]. The
sibling submodules [Object.Mem] / [Object.Mems] become
[Object.Member] / [Object.Members]. RFC 8259 §4 calls these
"name/value pairs, referred to as the members", so mirror the spec
name rather than the shortened [mem].
[Object.finish] -> [Object.seal]. "Seal" reads as "close the map, no
more members added", which is what the operation does.
Value constructors/queries: [Value.mem] (function) -> [Value.member];
[Value.mem_find] -> [Value.member_key]; [Value.mem_names] ->
[Value.member_names]; [Value.mem_keys] -> [Value.member_keys].
[type mem = ...] -> [type member = ...]; [type object'] still points
at [member list].
Downstream (~80 files across slack, sbom, stripe, sigstore, requests,
claude, irmin, freebox) updated via perl-pie. dune build clean,
dune test ocaml-json clean.
+43
-53
+2
-1
dune-project
+2
-1
dune-project
+40
-52
lib/qmp_protocol.ml
+40
-52
lib/qmp_protocol.ml
···
25
25
let open Json.Codec in
26
26
Object.map ~kind:"qemu_version" (fun major minor micro ->
27
27
{ major; minor; micro })
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
28
+
|> Object.member "major" int ~enc:(fun v -> v.major)
29
+
|> Object.member "minor" int ~enc:(fun v -> v.minor)
30
+
|> Object.member "micro" int ~enc:(fun v -> v.micro)
31
+
|> Object.skip_unknown |> Object.seal
32
32
33
33
let jsont =
34
34
let open Json.Codec in
35
-
Object.map ~kind:"version" (fun qemu package ->
36
-
{ qemu; package })
37
-
|> Object.mem "qemu" qemu_jsont ~enc:(fun v -> v.qemu)
38
-
|> Object.mem "package" string ~enc:(fun v ->
39
-
v.package)
40
-
|> Object.skip_unknown |> Object.finish
35
+
Object.map ~kind:"version" (fun qemu package -> { qemu; package })
36
+
|> Object.member "qemu" qemu_jsont ~enc:(fun v -> v.qemu)
37
+
|> Object.member "package" string ~enc:(fun v -> v.package)
38
+
|> Object.skip_unknown |> Object.seal
41
39
42
40
let pp ppf v =
43
41
Fmt.pf ppf "%d.%d.%d%s" v.qemu.major v.qemu.minor v.qemu.micro
···
52
50
let open Json.Codec in
53
51
Object.map ~kind:"qmp_info" (fun version capabilities ->
54
52
{ version; capabilities })
55
-
|> Object.mem "version" Version.jsont ~enc:(fun q -> q.version)
56
-
|> Object.mem "capabilities" (list string)
57
-
~enc:(fun q -> q.capabilities)
58
-
|> Object.skip_unknown |> Object.finish
53
+
|> Object.member "version" Version.jsont ~enc:(fun q -> q.version)
54
+
|> Object.member "capabilities" (list string) ~enc:(fun q -> q.capabilities)
55
+
|> Object.skip_unknown |> Object.seal
59
56
60
57
let jsont =
61
58
let open Json.Codec in
62
59
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
60
+
|> Object.member "QMP" qmp_info_jsont ~enc:(fun g -> g.qmp)
61
+
|> Object.skip_unknown |> Object.seal
65
62
66
63
let version t = t.qmp.version
67
64
let capabilities t = t.qmp.capabilities
···
74
71
let open Json.Codec in
75
72
Object.map ~kind:"timestamp" (fun seconds microseconds ->
76
73
{ seconds; microseconds })
77
-
|> Object.mem "seconds" int ~enc:(fun t -> t.seconds)
78
-
|> Object.mem "microseconds" int ~enc:(fun t ->
79
-
t.microseconds)
80
-
|> Object.skip_unknown |> Object.finish
74
+
|> Object.member "seconds" int ~enc:(fun t -> t.seconds)
75
+
|> Object.member "microseconds" int ~enc:(fun t -> t.microseconds)
76
+
|> Object.skip_unknown |> Object.seal
81
77
82
78
let to_float t = Float.of_int t.seconds +. (Float.of_int t.microseconds /. 1e6)
83
79
end
···
87
83
88
84
let jsont =
89
85
let open Json.Codec in
90
-
Object.map ~kind:"qmp_error" (fun class_ desc ->
91
-
{ class_; desc })
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
86
+
Object.map ~kind:"qmp_error" (fun class_ desc -> { class_; desc })
87
+
|> Object.member "class" string ~enc:(fun e -> e.class_)
88
+
|> Object.member "desc" string ~enc:(fun e -> e.desc)
89
+
|> Object.skip_unknown |> Object.seal
95
90
96
91
let pp ppf e = Fmt.pf ppf "%s: %s" e.class_ e.desc
97
92
end
···
103
98
let open Json.Codec in
104
99
Object.map ~kind:"event" (fun event data timestamp ->
105
100
{ event; data; timestamp })
106
-
|> Object.mem "event" string ~enc:(fun e -> e.event)
107
-
|> Object.opt_mem "data" Value.t ~enc:(fun e ->
108
-
e.data)
109
-
|> Object.mem "timestamp" Timestamp.jsont ~enc:(fun e ->
110
-
e.timestamp)
111
-
|> Object.skip_unknown |> Object.finish
101
+
|> Object.member "event" string ~enc:(fun e -> e.event)
102
+
|> Object.opt_member "data" Value.t ~enc:(fun e -> e.data)
103
+
|> Object.member "timestamp" Timestamp.jsont ~enc:(fun e -> e.timestamp)
104
+
|> Object.skip_unknown |> Object.seal
112
105
113
106
let name t = t.event
114
107
let data t = t.data
···
129
122
let jsont =
130
123
let open Json.Codec in
131
124
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
125
+
|> Object.member "execute" string ~enc:execute
126
+
|> Object.opt_member "arguments" Value.t ~enc:arguments
127
+
|> Object.opt_member "id" string ~enc:id
128
+
|> Object.skip_unknown |> Object.seal
136
129
137
130
let to_json t =
138
131
match Json.encode jsont t with
···
162
155
163
156
let success_jsont : success Json.codec =
164
157
let open Json.Codec in
165
-
Object.map ~kind:"success" (fun return success_id ->
166
-
{ return; success_id })
167
-
|> Object.mem "return" Value.t ~enc:(fun s ->
168
-
s.return)
169
-
|> Object.opt_mem "id" string ~enc:(fun s ->
170
-
s.success_id)
171
-
|> Object.skip_unknown |> Object.finish
158
+
Object.map ~kind:"success" (fun return success_id -> { return; success_id })
159
+
|> Object.member "return" Value.t ~enc:(fun s -> s.return)
160
+
|> Object.opt_member "id" string ~enc:(fun s -> s.success_id)
161
+
|> Object.skip_unknown |> Object.seal
172
162
173
163
let error_jsont : error_response Json.codec =
174
164
let open Json.Codec in
175
165
Object.map ~kind:"error_response" (fun qmp_error error_id ->
176
166
{ qmp_error; error_id })
177
-
|> Object.mem "error" Error.jsont ~enc:(fun e -> e.qmp_error)
178
-
|> Object.opt_mem "id" string ~enc:(fun e ->
179
-
e.error_id)
180
-
|> Object.skip_unknown |> Object.finish
167
+
|> Object.member "error" Error.jsont ~enc:(fun e -> e.qmp_error)
168
+
|> Object.opt_member "id" string ~enc:(fun e -> e.error_id)
169
+
|> Object.skip_unknown |> Object.seal
181
170
end
182
171
183
172
(** {1 Message parsing} *)
···
191
180
192
181
(* Helper to check if an object has a member *)
193
182
let has_member name = function
194
-
| Json.Object (mems, _) -> Option.is_some (Json.find_mem name mems)
183
+
| Json.Object (mems, _) -> Option.is_some (Json.Value.member_key name mems)
195
184
| _ -> false
196
185
197
186
let err e = Result.Error (Json.Error.to_string e)
···
308
297
let open Json.Codec in
309
298
Object.map ~kind:"status" (fun running singlestep status ->
310
299
{ running; singlestep; status })
311
-
|> Object.mem "running" bool ~enc:(fun s -> s.running)
312
-
|> Object.mem "singlestep" bool ~enc:(fun s ->
313
-
s.singlestep)
314
-
|> Object.mem "status" run_state_jsont ~enc:(fun s -> s.status)
315
-
|> Object.skip_unknown |> Object.finish
300
+
|> Object.member "running" bool ~enc:(fun s -> s.running)
301
+
|> Object.member "singlestep" bool ~enc:(fun s -> s.singlestep)
302
+
|> Object.member "status" run_state_jsont ~enc:(fun s -> s.status)
303
+
|> Object.skip_unknown |> Object.seal
316
304
317
305
let of_json json =
318
306
Result.map_error Json.Error.to_string (Json.decode jsont json)