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