41a66528681e1c40812531798826462bb90c3c48
[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;