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