JSONSchema: register new standard option 'pve-output-format'
[pve-common.git] / src / PVE / JSONSchema.pm
CommitLineData
e143e9d8
DM
1package PVE::JSONSchema;
2
e143e9d8 3use strict;
c36f332e 4use warnings;
e143e9d8
DM
5use Storable; # for dclone
6use Getopt::Long;
24197a9f
DM
7use Encode::Locale;
8use Encode;
e143e9d8 9use Devel::Cycle -quiet; # todo: remove?
e272bcb7 10use PVE::Tools qw(split_list $IPV6RE $IPV4RE);
e143e9d8
DM
11use PVE::Exception qw(raise);
12use HTTP::Status qw(:constants);
23b56245 13use Net::IP qw(:PROC);
bf27456b 14use Data::Dumper;
e143e9d8
DM
15
16use base 'Exporter';
17
18our @EXPORT_OK = qw(
19register_standard_option
20get_standard_option
21);
22
23# Note: This class implements something similar to JSON schema, but it is not 100% complete.
24# see: http://tools.ietf.org/html/draft-zyp-json-schema-02
25# see: http://json-schema.org/
26
27# the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
28
29my $standard_options = {};
30sub register_standard_option {
31 my ($name, $schema) = @_;
32
33 die "standard option '$name' already registered\n"
34 if $standard_options->{$name};
35
36 $standard_options->{$name} = $schema;
37}
38
39sub get_standard_option {
40 my ($name, $base) = @_;
41
42 my $std = $standard_options->{$name};
3432ae0c 43 die "no such standard option '$name'\n" if !$std;
e143e9d8
DM
44
45 my $res = $base || {};
46
47 foreach my $opt (keys %$std) {
c38ac70f 48 next if defined($res->{$opt});
e143e9d8
DM
49 $res->{$opt} = $std->{$opt};
50 }
51
52 return $res;
53};
54
55register_standard_option('pve-vmid', {
56 description => "The (unique) ID of the VM.",
57 type => 'integer', format => 'pve-vmid',
58 minimum => 1
59});
60
61register_standard_option('pve-node', {
62 description => "The cluster node name.",
63 type => 'string', format => 'pve-node',
64});
65
66register_standard_option('pve-node-list', {
67 description => "List of cluster node names.",
68 type => 'string', format => 'pve-node-list',
69});
70
71register_standard_option('pve-iface', {
72 description => "Network interface name.",
73 type => 'string', format => 'pve-iface',
74 minLength => 2, maxLength => 20,
75});
76
28a2669d 77register_standard_option('pve-storage-id', {
05e787c5
DM
78 description => "The storage identifier.",
79 type => 'string', format => 'pve-storage-id',
80});
81
28a2669d 82register_standard_option('pve-config-digest', {
dc5eae7d
DM
83 description => 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.',
84 type => 'string',
85 optional => 1,
86 maxLength => 40, # sha1 hex digest lenght is 40
87});
88
26bcdf92
WB
89register_standard_option('skiplock', {
90 description => "Ignore locks - only root is allowed to use this option.",
91 type => 'boolean',
92 optional => 1,
93});
94
28a2669d 95register_standard_option('extra-args', {
5851be88
WB
96 description => "Extra arguments as array",
97 type => 'array',
98 items => { type => 'string' },
99 optional => 1
100});
101
b21cf575
TL
102register_standard_option('fingerprint-sha256', {
103 description => "Certificate SHA 256 fingerprint.",
104 type => 'string',
105 pattern => '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}',
106});
107
ac15655f
DM
108register_standard_option('pve-output-format', {
109 type => 'string',
110 description => 'Output format.',
111 enum => [ 'text', 'plain', 'json' ],
112 optional => 1,
113 default => 'text',
114});
115
e143e9d8
DM
116my $format_list = {};
117
118sub register_format {
119 my ($format, $code) = @_;
120
121 die "JSON schema format '$format' already registered\n"
122 if $format_list->{$format};
123
124 $format_list->{$format} = $code;
125}
126
2421fba1
WB
127sub get_format {
128 my ($format) = @_;
129 return $format_list->{$format};
130}
131
b5212042
DM
132my $renderer_hash = {};
133
134sub register_renderer {
135 my ($name, $code) = @_;
136
137 die "renderer '$name' already registered\n"
138 if $renderer_hash->{$name};
139
140 $renderer_hash->{$name} = $code;
141}
142
143sub get_renderer {
144 my ($name) = @_;
145 return $renderer_hash->{$name};
146}
147
e143e9d8 148# register some common type for pve
8ba7c72b
DM
149
150register_format('string', sub {}); # allow format => 'string-list'
151
c77b4c96
WB
152register_format('urlencoded', \&pve_verify_urlencoded);
153sub pve_verify_urlencoded {
154 my ($text, $noerr) = @_;
155 if ($text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/) {
156 return undef if $noerr;
157 die "invalid urlencoded string: $text\n";
158 }
159 return $text;
160}
161
e143e9d8
DM
162register_format('pve-configid', \&pve_verify_configid);
163sub pve_verify_configid {
164 my ($id, $noerr) = @_;
165
166 if ($id !~ m/^[a-z][a-z0-9_]+$/i) {
167 return undef if $noerr;
39ed3462 168 die "invalid configuration ID '$id'\n";
e143e9d8
DM
169 }
170 return $id;
171}
172
05e787c5
DM
173PVE::JSONSchema::register_format('pve-storage-id', \&parse_storage_id);
174sub parse_storage_id {
175 my ($storeid, $noerr) = @_;
176
177 if ($storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
178 return undef if $noerr;
179 die "storage ID '$storeid' contains illegal characters\n";
180 }
181 return $storeid;
182}
183
184
e143e9d8
DM
185register_format('pve-vmid', \&pve_verify_vmid);
186sub pve_verify_vmid {
187 my ($vmid, $noerr) = @_;
188
50ae94c9 189 if ($vmid !~ m/^[1-9][0-9]{2,8}$/) {
e143e9d8
DM
190 return undef if $noerr;
191 die "value does not look like a valid VM ID\n";
192 }
193 return $vmid;
194}
195
196register_format('pve-node', \&pve_verify_node_name);
197sub pve_verify_node_name {
198 my ($node, $noerr) = @_;
199
e6db55c0 200 if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) {
e143e9d8
DM
201 return undef if $noerr;
202 die "value does not look like a valid node name\n";
203 }
204 return $node;
205}
206
207register_format('ipv4', \&pve_verify_ipv4);
208sub pve_verify_ipv4 {
209 my ($ipv4, $noerr) = @_;
210
ed5880ac
DM
211 if ($ipv4 !~ m/^(?:$IPV4RE)$/) {
212 return undef if $noerr;
213 die "value does not look like a valid IPv4 address\n";
e143e9d8
DM
214 }
215 return $ipv4;
216}
a13c6f08 217
ed5880ac 218register_format('ipv6', \&pve_verify_ipv6);
93276209 219sub pve_verify_ipv6 {
ed5880ac
DM
220 my ($ipv6, $noerr) = @_;
221
222 if ($ipv6 !~ m/^(?:$IPV6RE)$/) {
223 return undef if $noerr;
224 die "value does not look like a valid IPv6 address\n";
225 }
226 return $ipv6;
227}
228
229register_format('ip', \&pve_verify_ip);
230sub pve_verify_ip {
231 my ($ip, $noerr) = @_;
232
233 if ($ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/) {
234 return undef if $noerr;
235 die "value does not look like a valid IP address\n";
236 }
237 return $ip;
238}
239
a13c6f08
DM
240my $ipv4_mask_hash = {
241 '128.0.0.0' => 1,
242 '192.0.0.0' => 2,
243 '224.0.0.0' => 3,
244 '240.0.0.0' => 4,
245 '248.0.0.0' => 5,
246 '252.0.0.0' => 6,
247 '254.0.0.0' => 7,
248 '255.0.0.0' => 8,
249 '255.128.0.0' => 9,
250 '255.192.0.0' => 10,
251 '255.224.0.0' => 11,
252 '255.240.0.0' => 12,
253 '255.248.0.0' => 13,
254 '255.252.0.0' => 14,
255 '255.254.0.0' => 15,
256 '255.255.0.0' => 16,
257 '255.255.128.0' => 17,
258 '255.255.192.0' => 18,
259 '255.255.224.0' => 19,
260 '255.255.240.0' => 20,
261 '255.255.248.0' => 21,
262 '255.255.252.0' => 22,
263 '255.255.254.0' => 23,
264 '255.255.255.0' => 24,
265 '255.255.255.128' => 25,
266 '255.255.255.192' => 26,
267 '255.255.255.224' => 27,
268 '255.255.255.240' => 28,
269 '255.255.255.248' => 29,
e43faad9
WB
270 '255.255.255.252' => 30,
271 '255.255.255.254' => 31,
272 '255.255.255.255' => 32,
a13c6f08
DM
273};
274
e143e9d8
DM
275register_format('ipv4mask', \&pve_verify_ipv4mask);
276sub pve_verify_ipv4mask {
277 my ($mask, $noerr) = @_;
278
a13c6f08 279 if (!defined($ipv4_mask_hash->{$mask})) {
e143e9d8
DM
280 return undef if $noerr;
281 die "value does not look like a valid IP netmask\n";
282 }
283 return $mask;
284}
285
703c1f88
WB
286register_format('CIDRv6', \&pve_verify_cidrv6);
287sub pve_verify_cidrv6 {
e272bcb7
DM
288 my ($cidr, $noerr) = @_;
289
70ea2250 290 if ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 128)) {
e272bcb7 291 return $cidr;
703c1f88
WB
292 }
293
294 return undef if $noerr;
295 die "value does not look like a valid IPv6 CIDR network\n";
296}
297
298register_format('CIDRv4', \&pve_verify_cidrv4);
299sub pve_verify_cidrv4 {
300 my ($cidr, $noerr) = @_;
301
0526cc2d 302 if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 32)) {
e272bcb7
DM
303 return $cidr;
304 }
305
306 return undef if $noerr;
703c1f88
WB
307 die "value does not look like a valid IPv4 CIDR network\n";
308}
309
310register_format('CIDR', \&pve_verify_cidr);
311sub pve_verify_cidr {
312 my ($cidr, $noerr) = @_;
313
314 if (!(pve_verify_cidrv4($cidr, 1) ||
315 pve_verify_cidrv6($cidr, 1)))
316 {
317 return undef if $noerr;
318 die "value does not look like a valid CIDR network\n";
319 }
320
321 return $cidr;
322}
323
324register_format('pve-ipv4-config', \&pve_verify_ipv4_config);
325sub pve_verify_ipv4_config {
326 my ($config, $noerr) = @_;
327
328 return $config if $config =~ /^(?:dhcp|manual)$/ ||
329 pve_verify_cidrv4($config, 1);
330 return undef if $noerr;
331 die "value does not look like a valid ipv4 network configuration\n";
332}
333
334register_format('pve-ipv6-config', \&pve_verify_ipv6_config);
335sub pve_verify_ipv6_config {
336 my ($config, $noerr) = @_;
337
338 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
339 pve_verify_cidrv6($config, 1);
340 return undef if $noerr;
341 die "value does not look like a valid ipv6 network configuration\n";
e272bcb7
DM
342}
343
e143e9d8
DM
344register_format('email', \&pve_verify_email);
345sub pve_verify_email {
346 my ($email, $noerr) = @_;
347
87cb0e60
EK
348 # we use same regex as in Utils.js
349 if ($email !~ /^(\w+)([\-+.][\w]+)*@(\w[\-\w]*\.){1,5}([A-Za-z]){2,63}$/) {
e143e9d8
DM
350 return undef if $noerr;
351 die "value does not look like a valid email address\n";
352 }
353 return $email;
354}
355
34ebb226
DM
356register_format('dns-name', \&pve_verify_dns_name);
357sub pve_verify_dns_name {
358 my ($name, $noerr) = @_;
359
ce33e978 360 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)";
34ebb226
DM
361
362 if ($name !~ /^(${namere}\.)*${namere}$/) {
363 return undef if $noerr;
364 die "value does not look like a valid DNS name\n";
365 }
366 return $name;
367}
368
e143e9d8
DM
369# network interface name
370register_format('pve-iface', \&pve_verify_iface);
371sub pve_verify_iface {
372 my ($id, $noerr) = @_;
373
374 if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
375 return undef if $noerr;
376 die "invalid network interface name '$id'\n";
377 }
378 return $id;
379}
380
d07b7084
WB
381# general addresses by name or IP
382register_format('address', \&pve_verify_address);
383sub pve_verify_address {
384 my ($addr, $noerr) = @_;
385
386 if (!(pve_verify_ip($addr, 1) ||
387 pve_verify_dns_name($addr, 1)))
388 {
389 return undef if $noerr;
390 die "value does not look like a valid address: $addr\n";
391 }
392 return $addr;
393}
394
b944a22a
WB
395register_format('disk-size', \&pve_verify_disk_size);
396sub pve_verify_disk_size {
397 my ($size, $noerr) = @_;
398 if (!defined(parse_size($size))) {
399 return undef if $noerr;
400 die "value does not look like a valid disk size: $size\n";
401 }
402 return $size;
403}
404
f0a10afc
DM
405register_standard_option('spice-proxy', {
406 description => "SPICE proxy server. This can be used by the client to specify the proxy server. All nodes in a cluster runs 'spiceproxy', so it is up to the client to choose one. By default, we return the node where the VM is currently running. As resonable setting is to use same node you use to connect to the API (This is window.location.hostname for the JS GUI).",
d07b7084 407 type => 'string', format => 'address',
f0a10afc
DM
408});
409
410register_standard_option('remote-viewer-config', {
411 description => "Returned values can be directly passed to the 'remote-viewer' application.",
412 additionalProperties => 1,
413 properties => {
414 type => { type => 'string' },
415 password => { type => 'string' },
416 proxy => { type => 'string' },
417 host => { type => 'string' },
418 'tls-port' => { type => 'integer' },
419 },
420});
421
c70c3bbc 422register_format('pve-startup-order', \&pve_verify_startup_order);
b0edd8e6
DM
423sub pve_verify_startup_order {
424 my ($value, $noerr) = @_;
425
426 return $value if pve_parse_startup_order($value);
427
428 return undef if $noerr;
429
430 die "unable to parse startup options\n";
431}
432
2d167ad0
WB
433my %bwlimit_opt = (
434 optional => 1,
435 type => 'number', minimum => '0',
436 format_description => 'LIMIT',
437);
438
439my $bwlimit_format = {
440 default => {
441 %bwlimit_opt,
442 description => 'default bandwidth limit in MiB/s',
443 },
444 restore => {
445 %bwlimit_opt,
446 description => 'bandwidth limit in MiB/s for restoring guests from backups',
447 },
448 migration => {
449 %bwlimit_opt,
450 description => 'bandwidth limit in MiB/s for migrating guests',
451 },
452 clone => {
453 %bwlimit_opt,
454 description => 'bandwidth limit in MiB/s for cloning disks',
455 },
456 move => {
457 %bwlimit_opt,
458 description => 'bandwidth limit in MiB/s for moving disks',
459 },
460};
461register_format('bwlimit', $bwlimit_format);
462register_standard_option('bwlimit', {
463 description => "Set bandwidth/io limits various operations.",
464 optional => 1,
465 type => 'string',
466 format => $bwlimit_format,
467});
468
b0edd8e6
DM
469sub pve_parse_startup_order {
470 my ($value) = @_;
471
472 return undef if !$value;
473
474 my $res = {};
475
476 foreach my $p (split(/,/, $value)) {
477 next if $p =~ m/^\s*$/;
478
479 if ($p =~ m/^(order=)?(\d+)$/) {
480 $res->{order} = $2;
481 } elsif ($p =~ m/^up=(\d+)$/) {
482 $res->{up} = $1;
483 } elsif ($p =~ m/^down=(\d+)$/) {
484 $res->{down} = $1;
485 } else {
486 return undef;
487 }
488 }
489
490 return $res;
491}
492
493PVE::JSONSchema::register_standard_option('pve-startup-order', {
494 description => "Startup and shutdown behavior. Order is a non-negative number defining the general startup order. Shutdown in done with reverse ordering. Additionally you can set the 'up' or 'down' delay in seconds, which specifies a delay to wait before the next VM is started or stopped.",
495 optional => 1,
496 type => 'string', format => 'pve-startup-order',
497 typetext => '[[order=]\d+] [,up=\d+] [,down=\d+] ',
498});
499
e143e9d8 500sub check_format {
2f9e609a 501 my ($format, $value, $path) = @_;
e143e9d8 502
2f9e609a 503 return parse_property_string($format, $value, $path) if ref($format) eq 'HASH';
e143e9d8
DM
504 return if $format eq 'regex';
505
23dc9401 506 if ($format =~ m/^(.*)-a?list$/) {
e143e9d8
DM
507
508 my $code = $format_list->{$1};
509
510 die "undefined format '$format'\n" if !$code;
511
512 # Note: we allow empty lists
513 foreach my $v (split_list($value)) {
514 &$code($v);
515 }
516
517 } elsif ($format =~ m/^(.*)-opt$/) {
518
519 my $code = $format_list->{$1};
520
521 die "undefined format '$format'\n" if !$code;
522
523 return if !$value; # allow empty string
524
525 &$code($value);
526
527 } else {
528
529 my $code = $format_list->{$format};
530
531 die "undefined format '$format'\n" if !$code;
532
2f9e609a 533 return parse_property_string($code, $value, $path) if ref($code) eq 'HASH';
e143e9d8
DM
534 &$code($value);
535 }
536}
537
878fea8e
WB
538sub parse_size {
539 my ($value) = @_;
540
541 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
542 my ($size, $unit) = ($1, $3);
543 if ($unit) {
544 if ($unit eq 'K') {
545 $size = $size * 1024;
546 } elsif ($unit eq 'M') {
547 $size = $size * 1024 * 1024;
548 } elsif ($unit eq 'G') {
549 $size = $size * 1024 * 1024 * 1024;
550 } elsif ($unit eq 'T') {
551 $size = $size * 1024 * 1024 * 1024 * 1024;
552 }
553 }
554 return int($size);
555};
556
557sub format_size {
558 my ($size) = @_;
559
560 $size = int($size);
561
562 my $kb = int($size/1024);
563 return $size if $kb*1024 != $size;
564
565 my $mb = int($kb/1024);
566 return "${kb}K" if $mb*1024 != $kb;
567
568 my $gb = int($mb/1024);
569 return "${mb}M" if $gb*1024 != $mb;
570
571 my $tb = int($gb/1024);
572 return "${gb}G" if $tb*1024 != $gb;
573
574 return "${tb}T";
575};
576
1b71e564
WB
577sub parse_boolean {
578 my ($bool) = @_;
579 return 1 if $bool =~ m/^(1|on|yes|true)$/i;
580 return 0 if $bool =~ m/^(0|off|no|false)$/i;
581 return undef;
582}
583
095b88fd 584sub parse_property_string {
d1e490c1
WB
585 my ($format, $data, $path, $additional_properties) = @_;
586
587 # In property strings we default to not allowing additional properties
588 $additional_properties = 0 if !defined($additional_properties);
095b88fd 589
7c1617b0
WB
590 # Support named formats here, too:
591 if (!ref($format)) {
592 if (my $desc = $format_list->{$format}) {
593 $format = $desc;
594 } else {
595 die "unknown format: $format\n";
596 }
597 } elsif (ref($format) ne 'HASH') {
598 die "unexpected format value of type ".ref($format)."\n";
599 }
600
095b88fd
WB
601 my $default_key;
602
603 my $res = {};
604 foreach my $part (split(/,/, $data)) {
605 next if $part =~ /^\s*$/;
606
607 if ($part =~ /^([^=]+)=(.+)$/) {
608 my ($k, $v) = ($1, $2);
2d468b1a 609 die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
095b88fd 610 my $schema = $format->{$k};
303a9b34 611 if (my $alias = $schema->{alias}) {
bf27456b
DM
612 if (my $key_alias = $schema->{keyAlias}) {
613 die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
614 $res->{$key_alias} = $k;
615 }
303a9b34
WB
616 $k = $alias;
617 $schema = $format->{$k};
618 }
bf27456b 619
2d468b1a 620 die "invalid key in comma-separated list property: $k\n" if !$schema;
095b88fd 621 if ($schema->{type} && $schema->{type} eq 'boolean') {
1b71e564 622 $v = parse_boolean($v) // $v;
095b88fd
WB
623 }
624 $res->{$k} = $v;
625 } elsif ($part !~ /=/) {
2d468b1a 626 die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
095b88fd
WB
627 foreach my $key (keys %$format) {
628 if ($format->{$key}->{default_key}) {
629 $default_key = $key;
630 if (!$res->{$default_key}) {
631 $res->{$default_key} = $part;
632 last;
633 }
2d468b1a 634 die "duplicate key in comma-separated list property: $default_key\n";
095b88fd
WB
635 }
636 }
f0ba41a1 637 die "value without key, but schema does not define a default key\n" if !$default_key;
095b88fd 638 } else {
2d468b1a 639 die "missing key in comma-separated list property\n";
095b88fd
WB
640 }
641 }
642
643 my $errors = {};
d1e490c1 644 check_object($path, $format, $res, $additional_properties, $errors);
095b88fd 645 if (scalar(%$errors)) {
2d468b1a 646 raise "format error\n", errors => $errors;
095b88fd
WB
647 }
648
649 return $res;
650}
651
e143e9d8
DM
652sub add_error {
653 my ($errors, $path, $msg) = @_;
654
655 $path = '_root' if !$path;
656
657 if ($errors->{$path}) {
658 $errors->{$path} = join ('\n', $errors->{$path}, $msg);
659 } else {
660 $errors->{$path} = $msg;
661 }
662}
663
664sub is_number {
665 my $value = shift;
666
667 # see 'man perlretut'
668 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
669}
670
671sub is_integer {
672 my $value = shift;
673
674 return $value =~ m/^[+-]?\d+$/;
675}
676
677sub check_type {
678 my ($path, $type, $value, $errors) = @_;
679
680 return 1 if !$type;
681
682 if (!defined($value)) {
683 return 1 if $type eq 'null';
684 die "internal error"
685 }
686
687 if (my $tt = ref($type)) {
688 if ($tt eq 'ARRAY') {
689 foreach my $t (@$type) {
690 my $tmperr = {};
691 check_type($path, $t, $value, $tmperr);
692 return 1 if !scalar(%$tmperr);
693 }
694 my $ttext = join ('|', @$type);
695 add_error($errors, $path, "type check ('$ttext') failed");
696 return undef;
697 } elsif ($tt eq 'HASH') {
698 my $tmperr = {};
699 check_prop($value, $type, $path, $tmperr);
700 return 1 if !scalar(%$tmperr);
701 add_error($errors, $path, "type check failed");
702 return undef;
703 } else {
704 die "internal error - got reference type '$tt'";
705 }
706
707 } else {
708
709 return 1 if $type eq 'any';
710
711 if ($type eq 'null') {
712 if (defined($value)) {
713 add_error($errors, $path, "type check ('$type') failed - value is not null");
714 return undef;
715 }
716 return 1;
717 }
718
719 my $vt = ref($value);
720
721 if ($type eq 'array') {
722 if (!$vt || $vt ne 'ARRAY') {
723 add_error($errors, $path, "type check ('$type') failed");
724 return undef;
725 }
726 return 1;
727 } elsif ($type eq 'object') {
728 if (!$vt || $vt ne 'HASH') {
729 add_error($errors, $path, "type check ('$type') failed");
730 return undef;
731 }
732 return 1;
733 } elsif ($type eq 'coderef') {
734 if (!$vt || $vt ne 'CODE') {
735 add_error($errors, $path, "type check ('$type') failed");
736 return undef;
737 }
738 return 1;
88a490ff
WB
739 } elsif ($type eq 'string' && $vt eq 'Regexp') {
740 # qr// regexes can be used as strings and make sense for format=regex
741 return 1;
e143e9d8
DM
742 } else {
743 if ($vt) {
744 add_error($errors, $path, "type check ('$type') failed - got $vt");
745 return undef;
746 } else {
747 if ($type eq 'string') {
748 return 1; # nothing to check ?
749 } elsif ($type eq 'boolean') {
750 #if ($value =~ m/^(1|true|yes|on)$/i) {
751 if ($value eq '1') {
752 return 1;
753 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
754 } elsif ($value eq '0') {
79501b2a 755 return 1; # return success (not value)
e143e9d8
DM
756 } else {
757 add_error($errors, $path, "type check ('$type') failed - got '$value'");
758 return undef;
759 }
760 } elsif ($type eq 'integer') {
761 if (!is_integer($value)) {
762 add_error($errors, $path, "type check ('$type') failed - got '$value'");
763 return undef;
764 }
765 return 1;
766 } elsif ($type eq 'number') {
767 if (!is_number($value)) {
768 add_error($errors, $path, "type check ('$type') failed - got '$value'");
769 return undef;
770 }
771 return 1;
772 } else {
773 return 1; # no need to verify unknown types
774 }
775 }
776 }
777 }
778
779 return undef;
780}
781
782sub check_object {
783 my ($path, $schema, $value, $additional_properties, $errors) = @_;
784
785 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
786
787 my $st = ref($schema);
788 if (!$st || $st ne 'HASH') {
789 add_error($errors, $path, "Invalid schema definition.");
790 return;
791 }
792
793 my $vt = ref($value);
794 if (!$vt || $vt ne 'HASH') {
795 add_error($errors, $path, "an object is required");
796 return;
797 }
798
799 foreach my $k (keys %$schema) {
bf27456b 800 check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors);
e143e9d8
DM
801 }
802
803 foreach my $k (keys %$value) {
804
805 my $newpath = $path ? "$path.$k" : $k;
806
807 if (my $subschema = $schema->{$k}) {
808 if (my $requires = $subschema->{requires}) {
809 if (ref($requires)) {
810 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
811 check_prop($value, $requires, $path, $errors);
812 } elsif (!defined($value->{$requires})) {
813 add_error($errors, $path ? "$path.$requires" : $requires,
8b6e737a 814 "missing property - '$newpath' requires this property");
e143e9d8
DM
815 }
816 }
817
818 next; # value is already checked above
819 }
820
821 if (defined ($additional_properties) && !$additional_properties) {
822 add_error($errors, $newpath, "property is not defined in schema " .
823 "and the schema does not allow additional properties");
824 next;
825 }
826 check_prop($value->{$k}, $additional_properties, $newpath, $errors)
827 if ref($additional_properties);
828 }
829}
830
86425a09
WB
831sub check_object_warn {
832 my ($path, $schema, $value, $additional_properties) = @_;
833 my $errors = {};
834 check_object($path, $schema, $value, $additional_properties, $errors);
835 if (scalar(%$errors)) {
836 foreach my $k (keys %$errors) {
837 warn "parse error: $k: $errors->{$k}\n";
838 }
839 return 0;
840 }
841 return 1;
842}
843
e143e9d8
DM
844sub check_prop {
845 my ($value, $schema, $path, $errors) = @_;
846
847 die "internal error - no schema" if !$schema;
848 die "internal error" if !$errors;
849
850 #print "check_prop $path\n" if $value;
851
852 my $st = ref($schema);
853 if (!$st || $st ne 'HASH') {
854 add_error($errors, $path, "Invalid schema definition.");
855 return;
856 }
857
858 # if it extends another schema, it must pass that schema as well
859 if($schema->{extends}) {
860 check_prop($value, $schema->{extends}, $path, $errors);
861 }
862
863 if (!defined ($value)) {
864 return if $schema->{type} && $schema->{type} eq 'null';
445e8267 865 if (!$schema->{optional} && !$schema->{alias} && !$schema->{group}) {
e143e9d8
DM
866 add_error($errors, $path, "property is missing and it is not optional");
867 }
868 return;
869 }
870
871 return if !check_type($path, $schema->{type}, $value, $errors);
872
873 if ($schema->{disallow}) {
874 my $tmperr = {};
875 if (check_type($path, $schema->{disallow}, $value, $tmperr)) {
876 add_error($errors, $path, "disallowed value was matched");
877 return;
878 }
879 }
880
881 if (my $vt = ref($value)) {
882
883 if ($vt eq 'ARRAY') {
884 if ($schema->{items}) {
885 my $it = ref($schema->{items});
886 if ($it && $it eq 'ARRAY') {
887 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
888 die "not implemented";
889 } else {
890 my $ind = 0;
891 foreach my $el (@$value) {
892 check_prop($el, $schema->{items}, "${path}[$ind]", $errors);
893 $ind++;
894 }
895 }
896 }
897 return;
898 } elsif ($schema->{properties} || $schema->{additionalProperties}) {
899 check_object($path, defined($schema->{properties}) ? $schema->{properties} : {},
900 $value, $schema->{additionalProperties}, $errors);
901 return;
902 }
903
904 } else {
905
906 if (my $format = $schema->{format}) {
2f9e609a 907 eval { check_format($format, $value, $path); };
e143e9d8
DM
908 if ($@) {
909 add_error($errors, $path, "invalid format - $@");
910 return;
911 }
912 }
913
914 if (my $pattern = $schema->{pattern}) {
915 if ($value !~ m/^$pattern$/) {
916 add_error($errors, $path, "value does not match the regex pattern");
917 return;
918 }
919 }
920
921 if (defined (my $max = $schema->{maxLength})) {
922 if (length($value) > $max) {
923 add_error($errors, $path, "value may only be $max characters long");
924 return;
925 }
926 }
927
928 if (defined (my $min = $schema->{minLength})) {
929 if (length($value) < $min) {
930 add_error($errors, $path, "value must be at least $min characters long");
931 return;
932 }
933 }
934
935 if (is_number($value)) {
936 if (defined (my $max = $schema->{maximum})) {
937 if ($value > $max) {
938 add_error($errors, $path, "value must have a maximum value of $max");
939 return;
940 }
941 }
942
943 if (defined (my $min = $schema->{minimum})) {
944 if ($value < $min) {
945 add_error($errors, $path, "value must have a minimum value of $min");
946 return;
947 }
948 }
949 }
950
951 if (my $ea = $schema->{enum}) {
952
953 my $found;
954 foreach my $ev (@$ea) {
955 if ($ev eq $value) {
956 $found = 1;
957 last;
958 }
959 }
960 if (!$found) {
961 add_error($errors, $path, "value '$value' does not have a value in the enumeration '" .
962 join(", ", @$ea) . "'");
963 }
964 }
965 }
966}
967
968sub validate {
969 my ($instance, $schema, $errmsg) = @_;
970
971 my $errors = {};
972 $errmsg = "Parameter verification failed.\n" if !$errmsg;
973
974 # todo: cycle detection is only needed for debugging, I guess
975 # we can disable that in the final release
976 # todo: is there a better/faster way to detect cycles?
977 my $cycles = 0;
978 find_cycle($instance, sub { $cycles = 1 });
979 if ($cycles) {
980 add_error($errors, undef, "data structure contains recursive cycles");
981 } elsif ($schema) {
982 check_prop($instance, $schema, '', $errors);
983 }
984
985 if (scalar(%$errors)) {
986 raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors;
987 }
988
989 return 1;
990}
991
992my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
993my $default_schema_noref = {
994 description => "This is the JSON Schema for JSON Schemas.",
995 type => [ "object" ],
996 additionalProperties => 0,
997 properties => {
998 type => {
999 type => ["string", "array"],
1000 description => "This is a type definition value. This can be a simple type, or a union type",
1001 optional => 1,
1002 default => "any",
1003 items => {
1004 type => "string",
1005 enum => $schema_valid_types,
1006 },
1007 enum => $schema_valid_types,
1008 },
1009 optional => {
1010 type => "boolean",
1011 description => "This indicates that the instance property in the instance object is not required.",
1012 optional => 1,
1013 default => 0
1014 },
1015 properties => {
1016 type => "object",
1017 description => "This is a definition for the properties of an object value",
1018 optional => 1,
1019 default => {},
1020 },
1021 items => {
1022 type => "object",
1023 description => "When the value is an array, this indicates the schema to use to validate each item in an array",
1024 optional => 1,
1025 default => {},
1026 },
1027 additionalProperties => {
1028 type => [ "boolean", "object"],
1029 description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
1030 optional => 1,
1031 default => {},
1032 },
1033 minimum => {
1034 type => "number",
1035 optional => 1,
1036 description => "This indicates the minimum value for the instance property when the type of the instance value is a number.",
1037 },
1038 maximum => {
1039 type => "number",
1040 optional => 1,
1041 description => "This indicates the maximum value for the instance property when the type of the instance value is a number.",
1042 },
1043 minLength => {
1044 type => "integer",
1045 description => "When the instance value is a string, this indicates minimum length of the string",
1046 optional => 1,
1047 minimum => 0,
1048 default => 0,
1049 },
1050 maxLength => {
1051 type => "integer",
1052 description => "When the instance value is a string, this indicates maximum length of the string.",
1053 optional => 1,
1054 },
1055 typetext => {
1056 type => "string",
1057 optional => 1,
1058 description => "A text representation of the type (used to generate documentation).",
1059 },
1060 pattern => {
1061 type => "string",
1062 format => "regex",
166e27c7 1063 description => "When the instance value is a string, this provides a regular expression that a instance string value should match in order to be valid.",
e143e9d8
DM
1064 optional => 1,
1065 default => ".*",
166e27c7 1066 },
e143e9d8
DM
1067 enum => {
1068 type => "array",
1069 optional => 1,
1070 description => "This provides an enumeration of possible values that are valid for the instance property.",
1071 },
1072 description => {
1073 type => "string",
1074 optional => 1,
1075 description => "This provides a description of the purpose the instance property. The value can be a string or it can be an object with properties corresponding to various different instance languages (with an optional default property indicating the default description).",
1076 },
32f8e0c7
DM
1077 verbose_description => {
1078 type => "string",
1079 optional => 1,
1080 description => "This provides a more verbose description.",
1081 },
d5d10f85
WB
1082 format_description => {
1083 type => "string",
1084 optional => 1,
1085 description => "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1086 },
166e27c7
WB
1087 title => {
1088 type => "string",
e143e9d8 1089 optional => 1,
166e27c7
WB
1090 description => "This provides the title of the property",
1091 },
03c1e2a0
DM
1092 renderer => {
1093 type => "string",
1094 optional => 1,
1095 description => "This is used to provide rendering hints to format cli command output.",
1096 },
166e27c7
WB
1097 requires => {
1098 type => [ "string", "object" ],
e143e9d8 1099 optional => 1,
166e27c7
WB
1100 description => "indicates a required property or a schema that must be validated if this property is present",
1101 },
1102 format => {
2f9e609a 1103 type => [ "string", "object" ],
e143e9d8 1104 optional => 1,
166e27c7
WB
1105 description => "This indicates what format the data is among some predefined formats which may include:\n\ndate - a string following the ISO format \naddress \nschema - a schema definition object \nperson \npage \nhtml - a string representing HTML",
1106 },
095b88fd
WB
1107 default_key => {
1108 type => "boolean",
1109 optional => 1,
1110 description => "Whether this is the default key in a comma separated list property string.",
1111 },
303a9b34
WB
1112 alias => {
1113 type => 'string',
1114 optional => 1,
1115 description => "When a key represents the same property as another it can be an alias to it, causing the parsed datastructure to use the other key to store the current value under.",
1116 },
bf27456b 1117 keyAlias => {
445e8267
WB
1118 type => 'string',
1119 optional => 1,
bf27456b
DM
1120 description => "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1121 requires => 'alias',
445e8267 1122 },
e143e9d8
DM
1123 default => {
1124 type => "any",
1125 optional => 1,
1126 description => "This indicates the default for the instance property."
1127 },
166e27c7 1128 completion => {
7829989f
DM
1129 type => 'coderef',
1130 description => "Bash completion function. This function should return a list of possible values.",
1131 optional => 1,
166e27c7
WB
1132 },
1133 disallow => {
1134 type => "object",
e143e9d8 1135 optional => 1,
166e27c7 1136 description => "This attribute may take the same values as the \"type\" attribute, however if the instance matches the type or if this value is an array and the instance matches any type or schema in the array, then this instance is not valid.",
e143e9d8 1137 },
166e27c7
WB
1138 extends => {
1139 type => "object",
e143e9d8 1140 optional => 1,
166e27c7 1141 description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
e143e9d8 1142 default => {},
166e27c7
WB
1143 },
1144 # this is from hyper schema
1145 links => {
1146 type => "array",
1147 description => "This defines the link relations of the instance objects",
1148 optional => 1,
e143e9d8 1149 items => {
166e27c7
WB
1150 type => "object",
1151 properties => {
1152 href => {
1153 type => "string",
1154 description => "This defines the target URL for the relation and can be parameterized using {propertyName} notation. It should be resolved as a URI-reference relative to the URI that was used to retrieve the instance document",
1155 },
1156 rel => {
1157 type => "string",
1158 description => "This is the name of the link relation",
1159 optional => 1,
1160 default => "full",
1161 },
e143e9d8 1162 method => {
166e27c7
WB
1163 type => "string",
1164 description => "For submission links, this defines the method that should be used to access the target resource",
1165 optional => 1,
1166 default => "GET",
e143e9d8
DM
1167 },
1168 },
1169 },
1170 },
f8d4eff9
SI
1171 print_width => {
1172 type => "integer",
1173 description => "For CLI context, this defines the maximal width to print before truncating",
1174 optional => 1,
1175 },
e143e9d8
DM
1176 }
1177};
1178
1179my $default_schema = Storable::dclone($default_schema_noref);
1180
1181$default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
1182$default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
1183
1184$default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
1185$default_schema->{properties}->{items}->{additionalProperties} = 0;
1186
1187$default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
1188$default_schema->{properties}->{disallow}->{additionalProperties} = 0;
1189
1190$default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
1191$default_schema->{properties}->{requires}->{additionalProperties} = 0;
1192
1193$default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
1194$default_schema->{properties}->{extends}->{additionalProperties} = 0;
1195
1196my $method_schema = {
1197 type => "object",
1198 additionalProperties => 0,
1199 properties => {
1200 description => {
1201 description => "This a description of the method",
1202 optional => 1,
1203 },
1204 name => {
1205 type => 'string',
1206 description => "This indicates the name of the function to call.",
1207 optional => 1,
1208 requires => {
1209 additionalProperties => 1,
1210 properties => {
1211 name => {},
1212 description => {},
1213 code => {},
1214 method => {},
1215 parameters => {},
1216 path => {},
1217 parameters => {},
1218 returns => {},
1219 }
1220 },
1221 },
1222 method => {
1223 type => 'string',
1224 description => "The HTTP method name.",
1225 enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
1226 optional => 1,
1227 },
1228 protected => {
1229 type => 'boolean',
1230 description => "Method needs special privileges - only pvedaemon can execute it",
1231 optional => 1,
1232 },
62a8f27b
DM
1233 download => {
1234 type => 'boolean',
1235 description => "Method downloads the file content (filename is the return value of the method).",
1236 optional => 1,
1237 },
e143e9d8
DM
1238 proxyto => {
1239 type => 'string',
1240 description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1241 optional => 1,
1242 },
031efdd0
DM
1243 proxyto_callback => {
1244 type => 'coderef',
1245 description => "A function which is called to resolve the proxyto attribute. The default implementaion returns the value of the 'proxyto' parameter.",
1246 optional => 1,
1247 },
e143e9d8
DM
1248 permissions => {
1249 type => 'object',
1250 description => "Required access permissions. By default only 'root' is allowed to access this method.",
1251 optional => 1,
1252 additionalProperties => 0,
1253 properties => {
b18d1722
DM
1254 description => {
1255 description => "Describe access permissions.",
1256 optional => 1,
1257 },
e143e9d8 1258 user => {
b18d1722 1259 description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
e143e9d8 1260 type => 'string',
b18d1722 1261 enum => ['all', 'world'],
e143e9d8
DM
1262 optional => 1,
1263 },
b18d1722
DM
1264 check => {
1265 description => "Array of permission checks (prefix notation).",
1266 type => 'array',
1267 optional => 1
1268 },
e143e9d8
DM
1269 },
1270 },
1271 match_name => {
1272 description => "Used internally",
1273 optional => 1,
1274 },
1275 match_re => {
1276 description => "Used internally",
1277 optional => 1,
1278 },
1279 path => {
1280 type => 'string',
1281 description => "path for URL matching (uri template)",
1282 },
1283 fragmentDelimiter => {
1284 type => 'string',
1285 description => "A ways to override the default fragment delimiter '/'. This onyl works on a whole sub-class. You can set this to the empty string to match the whole rest of the URI.",
1286 optional => 1,
1287 },
1288 parameters => {
1289 type => 'object',
1290 description => "JSON Schema for parameters.",
1291 optional => 1,
1292 },
1293 returns => {
1294 type => 'object',
1295 description => "JSON Schema for return value.",
1296 optional => 1,
1297 },
1298 code => {
1299 type => 'coderef',
1300 description => "method implementaion (code reference)",
1301 optional => 1,
1302 },
1303 subclass => {
1304 type => 'string',
1305 description => "Delegate call to this class (perl class string).",
1306 optional => 1,
1307 requires => {
1308 additionalProperties => 0,
1309 properties => {
1310 subclass => {},
1311 path => {},
1312 match_name => {},
1313 match_re => {},
1314 fragmentDelimiter => { optional => 1 }
1315 }
1316 },
1317 },
1318 },
1319
1320};
1321
1322sub validate_schema {
1323 my ($schema) = @_;
1324
1325 my $errmsg = "internal error - unable to verify schema\n";
1326 validate($schema, $default_schema, $errmsg);
1327}
1328
1329sub validate_method_info {
1330 my $info = shift;
1331
1332 my $errmsg = "internal error - unable to verify method info\n";
1333 validate($info, $method_schema, $errmsg);
1334
1335 validate_schema($info->{parameters}) if $info->{parameters};
1336 validate_schema($info->{returns}) if $info->{returns};
1337}
1338
1339# run a self test on load
1340# make sure we can verify the default schema
1341validate_schema($default_schema_noref);
1342validate_schema($method_schema);
1343
1344# and now some utility methods (used by pve api)
1345sub method_get_child_link {
1346 my ($info) = @_;
1347
1348 return undef if !$info;
1349
1350 my $schema = $info->{returns};
1351 return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
1352
1353 my $links = $schema->{links};
1354 return undef if !$links;
1355
1356 my $found;
1357 foreach my $lnk (@$links) {
1358 if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
1359 $found = $lnk;
1360 last;
1361 }
1362 }
1363
1364 return $found;
1365}
1366
1367# a way to parse command line parameters, using a
1368# schema to configure Getopt::Long
1369sub get_options {
4842b651 1370 my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
e143e9d8
DM
1371
1372 if (!$schema || !$schema->{properties}) {
1373 raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1374 if scalar(@$args) != 0;
1375 return {};
1376 }
1377
0ce82909
DM
1378 my $list_param;
1379 if ($arg_param && !ref($arg_param)) {
1380 my $pd = $schema->{properties}->{$arg_param};
1381 die "expected list format $pd->{format}"
1382 if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
1383 $list_param = $arg_param;
1384 }
1385
c7171ff2 1386 my @interactive = ();
e143e9d8
DM
1387 my @getopt = ();
1388 foreach my $prop (keys %{$schema->{properties}}) {
1389 my $pd = $schema->{properties}->{$prop};
aab47b58 1390 next if $list_param && $prop eq $list_param;
0ce82909 1391 next if defined($fixed_param->{$prop});
e143e9d8 1392
c7171ff2
WB
1393 my $mapping = $param_mapping_hash->{$prop};
1394 if ($mapping && $mapping->{interactive}) {
1395 # interactive parameters such as passwords: make the argument
1396 # optional and call the mapping function afterwards.
1397 push @getopt, "$prop:s";
1398 push @interactive, [$prop, $mapping->{func}];
e143e9d8
DM
1399 } elsif ($pd->{type} eq 'boolean') {
1400 push @getopt, "$prop:s";
1401 } else {
23dc9401 1402 if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
8ba7c72b
DM
1403 push @getopt, "$prop=s@";
1404 } else {
1405 push @getopt, "$prop=s";
1406 }
e143e9d8
DM
1407 }
1408 }
1409
1068aeb3
WB
1410 Getopt::Long::Configure('prefix_pattern=(--|-)');
1411
e143e9d8
DM
1412 my $opts = {};
1413 raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
1414 if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
1d21344c 1415
5851be88 1416 if (@$args) {
0ce82909
DM
1417 if ($list_param) {
1418 $opts->{$list_param} = $args;
1419 $args = [];
1420 } elsif (ref($arg_param)) {
5851be88
WB
1421 foreach my $arg_name (@$arg_param) {
1422 if ($opts->{'extra-args'}) {
1423 raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
1424 }
1425 if ($arg_name eq 'extra-args') {
1426 $opts->{'extra-args'} = $args;
1427 $args = [];
1428 next;
1429 }
1430 raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
1431 $opts->{$arg_name} = shift @$args;
0ce82909 1432 }
5851be88 1433 raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
0ce82909
DM
1434 } else {
1435 raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1436 if scalar(@$args) != 0;
1437 }
ff2bf45f
DM
1438 } else {
1439 if (ref($arg_param)) {
1440 foreach my $arg_name (@$arg_param) {
1441 if ($arg_name eq 'extra-args') {
1442 $opts->{'extra-args'} = [];
1443 } else {
1444 raise("not enough arguments\n", code => HTTP_BAD_REQUEST);
1445 }
1446 }
1447 }
1d21344c
DM
1448 }
1449
c7171ff2
WB
1450 foreach my $entry (@interactive) {
1451 my ($opt, $func) = @$entry;
1452 my $pd = $schema->{properties}->{$opt};
1453 my $value = $opts->{$opt};
1454 if (defined($value) || !$pd->{optional}) {
1455 $opts->{$opt} = $func->($value);
1456 }
1457 }
1458
c9902568 1459 # decode after Getopt as we are not sure how well it handles unicode
24197a9f 1460 foreach my $p (keys %$opts) {
c9902568
TL
1461 if (!ref($opts->{$p})) {
1462 $opts->{$p} = decode('locale', $opts->{$p});
1463 } elsif (ref($opts->{$p}) eq 'ARRAY') {
1464 my $tmp = [];
1465 foreach my $v (@{$opts->{$p}}) {
1466 push @$tmp, decode('locale', $v);
1467 }
1468 $opts->{$p} = $tmp;
1469 } elsif (ref($opts->{$p}) eq 'SCALAR') {
1470 $opts->{$p} = decode('locale', $$opts->{$p});
1471 } else {
1472 raise("decoding options failed, unknown reference\n", code => HTTP_BAD_REQUEST);
1473 }
24197a9f 1474 }
815b2aba 1475
e143e9d8
DM
1476 foreach my $p (keys %$opts) {
1477 if (my $pd = $schema->{properties}->{$p}) {
1478 if ($pd->{type} eq 'boolean') {
1479 if ($opts->{$p} eq '') {
1480 $opts->{$p} = 1;
1b71e564
WB
1481 } elsif (defined(my $bool = parse_boolean($opts->{$p}))) {
1482 $opts->{$p} = $bool;
e143e9d8
DM
1483 } else {
1484 raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
1485 }
23dc9401 1486 } elsif ($pd->{format}) {
8ba7c72b 1487
23dc9401 1488 if ($pd->{format} =~ m/-list/) {
8ba7c72b 1489 # allow --vmid 100 --vmid 101 and --vmid 100,101
23dc9401 1490 # allow --dow mon --dow fri and --dow mon,fri
43479146 1491 $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
23dc9401 1492 } elsif ($pd->{format} =~ m/-alist/) {
8ba7c72b
DM
1493 # we encode array as \0 separated strings
1494 # Note: CGI.pm also use this encoding
1495 if (scalar(@{$opts->{$p}}) != 1) {
1496 $opts->{$p} = join("\0", @{$opts->{$p}});
1497 } else {
1498 # st that split_list knows it is \0 terminated
1499 my $v = $opts->{$p}->[0];
1500 $opts->{$p} = "$v\0";
1501 }
1502 }
e143e9d8
DM
1503 }
1504 }
1505 }
1506
0ce82909
DM
1507 foreach my $p (keys %$fixed_param) {
1508 $opts->{$p} = $fixed_param->{$p};
e143e9d8
DM
1509 }
1510
1511 return $opts;
1512}
1513
1514# A way to parse configuration data by giving a json schema
1515sub parse_config {
1516 my ($schema, $filename, $raw) = @_;
1517
1518 # do fast check (avoid validate_schema($schema))
1519 die "got strange schema" if !$schema->{type} ||
1520 !$schema->{properties} || $schema->{type} ne 'object';
1521
1522 my $cfg = {};
1523
3c4d612a 1524 while ($raw =~ /^\s*(.+?)\s*$/gm) {
e143e9d8 1525 my $line = $1;
e143e9d8 1526
3c4d612a
WB
1527 next if $line =~ /^#/;
1528
1529 if ($line =~ m/^(\S+?):\s*(.*)$/) {
e143e9d8
DM
1530 my $key = $1;
1531 my $value = $2;
1532 if ($schema->{properties}->{$key} &&
1533 $schema->{properties}->{$key}->{type} eq 'boolean') {
1534
1b71e564 1535 $value = parse_boolean($value) // $value;
e143e9d8
DM
1536 }
1537 $cfg->{$key} = $value;
1538 } else {
1539 warn "ignore config line: $line\n"
1540 }
1541 }
1542
1543 my $errors = {};
1544 check_prop($cfg, $schema, '', $errors);
1545
1546 foreach my $k (keys %$errors) {
1547 warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1548 delete $cfg->{$k};
1549 }
1550
1551 return $cfg;
1552}
1553
1554# generate simple key/value file
1555sub dump_config {
1556 my ($schema, $filename, $cfg) = @_;
1557
1558 # do fast check (avoid validate_schema($schema))
1559 die "got strange schema" if !$schema->{type} ||
1560 !$schema->{properties} || $schema->{type} ne 'object';
1561
1562 validate($cfg, $schema, "validation error in '$filename'\n");
1563
1564 my $data = '';
1565
1566 foreach my $k (keys %$cfg) {
1567 $data .= "$k: $cfg->{$k}\n";
1568 }
1569
1570 return $data;
1571}
1572
bf27456b
DM
1573# helpers used to generate our manual pages
1574
1575my $find_schema_default_key = sub {
1576 my ($format) = @_;
1577
1578 my $default_key;
1579 my $keyAliasProps = {};
1580
1581 foreach my $key (keys %$format) {
1582 my $phash = $format->{$key};
1583 if ($phash->{default_key}) {
1584 die "multiple default keys in schema ($default_key, $key)\n"
1585 if defined($default_key);
1586 die "default key '$key' is an alias - this is not allowed\n"
1587 if defined($phash->{alias});
1588 die "default key '$key' with keyAlias attribute is not allowed\n"
1589 if $phash->{keyAlias};
bf27456b
DM
1590 $default_key = $key;
1591 }
1592 my $key_alias = $phash->{keyAlias};
c88c582d
DM
1593 die "found keyAlias without 'alias definition for '$key'\n"
1594 if $key_alias && !$phash->{alias};
1595
bf27456b
DM
1596 if ($phash->{alias} && $key_alias) {
1597 die "inconsistent keyAlias '$key_alias' definition"
1598 if defined($keyAliasProps->{$key_alias}) &&
1599 $keyAliasProps->{$key_alias} ne $phash->{alias};
1600 $keyAliasProps->{$key_alias} = $phash->{alias};
1601 }
1602 }
1603
1604 return wantarray ? ($default_key, $keyAliasProps) : $default_key;
1605};
1606
1607sub generate_typetext {
abc1afd8 1608 my ($format, $list_enums) = @_;
bf27456b 1609
d8c2b947 1610 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
bf27456b
DM
1611
1612 my $res = '';
1613 my $add_sep = 0;
1614
1615 my $add_option_string = sub {
1616 my ($text, $optional) = @_;
1617
1618 if ($add_sep) {
1619 $text = ",$text";
1620 $res .= ' ';
1621 }
1622 $text = "[$text]" if $optional;
1623 $res .= $text;
1624 $add_sep = 1;
1625 };
1626
1627 my $format_key_value = sub {
1628 my ($key, $phash) = @_;
1629
1630 die "internal error" if defined($phash->{alias});
1631
1632 my $keytext = $key;
1633
1634 my $typetext = '';
1635
1636 if (my $desc = $phash->{format_description}) {
1637 $typetext .= "<$desc>";
1638 } elsif (my $text = $phash->{typetext}) {
1639 $typetext .= $text;
1640 } elsif (my $enum = $phash->{enum}) {
abc1afd8
DM
1641 if ($list_enums || (scalar(@$enum) <= 3)) {
1642 $typetext .= '<' . join('|', @$enum) . '>';
1643 } else {
1644 $typetext .= '<enum>';
1645 }
bf27456b
DM
1646 } elsif ($phash->{type} eq 'boolean') {
1647 $typetext .= '<1|0>';
1648 } elsif ($phash->{type} eq 'integer') {
1649 $typetext .= '<integer>';
1650 } elsif ($phash->{type} eq 'number') {
1651 $typetext .= '<number>';
1652 } else {
1653 die "internal error: neither format_description nor typetext found for option '$key'";
1654 }
1655
1656 if (defined($default_key) && ($default_key eq $key)) {
1657 &$add_option_string("[$keytext=]$typetext", $phash->{optional});
1658 } else {
1659 &$add_option_string("$keytext=$typetext", $phash->{optional});
1660 }
1661 };
1662
d8c2b947 1663 my $done = {};
bf27456b 1664
d8c2b947
DM
1665 my $cond_add_key = sub {
1666 my ($key) = @_;
1667
1668 return if $done->{$key}; # avoid duplicates
1669
1670 $done->{$key} = 1;
bf27456b
DM
1671
1672 my $phash = $format->{$key};
1673
d8c2b947
DM
1674 return if !$phash; # should not happen
1675
1676 return if $phash->{alias};
bf27456b
DM
1677
1678 &$format_key_value($key, $phash);
1679
d8c2b947
DM
1680 };
1681
1682 &$cond_add_key($default_key) if defined($default_key);
1683
1684 # add required keys first
1685 foreach my $key (sort keys %$format) {
1686 my $phash = $format->{$key};
1687 &$cond_add_key($key) if $phash && !$phash->{optional};
1688 }
1689
1690 # add the rest
1691 foreach my $key (sort keys %$format) {
1692 &$cond_add_key($key);
1693 }
1694
1695 foreach my $keyAlias (sort keys %$keyAliasProps) {
1696 &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
bf27456b
DM
1697 }
1698
1699 return $res;
1700}
1701
1702sub print_property_string {
1703 my ($data, $format, $skip, $path) = @_;
1704
1705 if (ref($format) ne 'HASH') {
1706 my $schema = get_format($format);
1707 die "not a valid format: $format\n" if !$schema;
1708 $format = $schema;
1709 }
1710
1711 my $errors = {};
1712 check_object($path, $format, $data, undef, $errors);
1713 if (scalar(%$errors)) {
1714 raise "format error", errors => $errors;
1715 }
1716
1717 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1718
1719 my $res = '';
1720 my $add_sep = 0;
1721
1722 my $add_option_string = sub {
1723 my ($text) = @_;
1724
1725 $res .= ',' if $add_sep;
1726 $res .= $text;
1727 $add_sep = 1;
1728 };
1729
1730 my $format_value = sub {
1731 my ($key, $value, $format) = @_;
1732
1733 if (defined($format) && ($format eq 'disk-size')) {
1734 return format_size($value);
1735 } else {
1736 die "illegal value with commas for $key\n" if $value =~ /,/;
1737 return $value;
1738 }
1739 };
1740
2289890b 1741 my $done = { map { $_ => 1 } @$skip };
bf27456b
DM
1742
1743 my $cond_add_key = sub {
971353e8 1744 my ($key, $isdefault) = @_;
bf27456b
DM
1745
1746 return if $done->{$key}; # avoid duplicates
1747
1748 $done->{$key} = 1;
1749
1750 my $value = $data->{$key};
1751
1752 return if !defined($value);
1753
1754 my $phash = $format->{$key};
1755
1756 # try to combine values if we have key aliases
1757 if (my $combine = $keyAliasProps->{$key}) {
1758 if (defined(my $combine_value = $data->{$combine})) {
1759 my $combine_format = $format->{$combine}->{format};
1760 my $value_str = &$format_value($key, $value, $phash->{format});
1761 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
1762 &$add_option_string("${value_str}=${combine_str}");
1763 $done->{$combine} = 1;
1764 return;
1765 }
1766 }
1767
1768 if ($phash && $phash->{alias}) {
1769 $phash = $format->{$phash->{alias}};
1770 }
1771
1772 die "invalid key '$key'\n" if !$phash;
1773 die "internal error" if defined($phash->{alias});
1774
1775 my $value_str = &$format_value($key, $value, $phash->{format});
971353e8
WB
1776 if ($isdefault) {
1777 &$add_option_string($value_str);
1778 } else {
1779 &$add_option_string("$key=${value_str}");
1780 }
bf27456b
DM
1781 };
1782
1783 # add default key first
971353e8 1784 &$cond_add_key($default_key, 1) if defined($default_key);
bf27456b 1785
d8c2b947
DM
1786 # add required keys first
1787 foreach my $key (sort keys %$data) {
1788 my $phash = $format->{$key};
1789 &$cond_add_key($key) if $phash && !$phash->{optional};
1790 }
1791
1792 # add the rest
bf27456b
DM
1793 foreach my $key (sort keys %$data) {
1794 &$cond_add_key($key);
1795 }
1796
1797 return $res;
1798}
1799
1800sub schema_get_type_text {
abc1afd8 1801 my ($phash, $style) = @_;
bf27456b 1802
32f8e0c7
DM
1803 my $type = $phash->{type} || 'string';
1804
bf27456b
DM
1805 if ($phash->{typetext}) {
1806 return $phash->{typetext};
1807 } elsif ($phash->{format_description}) {
1808 return "<$phash->{format_description}>";
1809 } elsif ($phash->{enum}) {
25d9bda9 1810 return "<" . join(' | ', sort @{$phash->{enum}}) . ">";
bf27456b
DM
1811 } elsif ($phash->{pattern}) {
1812 return $phash->{pattern};
32f8e0c7 1813 } elsif ($type eq 'integer' || $type eq 'number') {
05185ea2 1814 # NOTE: always access values as number (avoid converion to string)
bf27456b 1815 if (defined($phash->{minimum}) && defined($phash->{maximum})) {
25d9bda9 1816 return "<$type> (" . ($phash->{minimum} + 0) . " - " .
05185ea2 1817 ($phash->{maximum} + 0) . ")";
bf27456b 1818 } elsif (defined($phash->{minimum})) {
25d9bda9 1819 return "<$type> (" . ($phash->{minimum} + 0) . " - N)";
bf27456b 1820 } elsif (defined($phash->{maximum})) {
25d9bda9 1821 return "<$type> (-N - " . ($phash->{maximum} + 0) . ")";
bf27456b 1822 }
32f8e0c7 1823 } elsif ($type eq 'string') {
bf27456b
DM
1824 if (my $format = $phash->{format}) {
1825 $format = get_format($format) if ref($format) ne 'HASH';
1826 if (ref($format) eq 'HASH') {
abc1afd8
DM
1827 my $list_enums = 0;
1828 $list_enums = 1 if $style && $style eq 'config-sub';
1829 return generate_typetext($format, $list_enums);
bf27456b
DM
1830 }
1831 }
1832 }
1833
25d9bda9 1834 return "<$type>";
bf27456b
DM
1835}
1836
e143e9d8 18371;