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