PVE::CLIHandler::print_text_table - add option $sort_key
[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, $pwcallback, $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 ($prop eq 'password' && $pwcallback) {
1371             # we do not accept plain password on input line, instead
1372             # we turn this into a boolean option and ask for password below
1373             # using $pwcallback() (for security reasons).
1374             push @getopt, "$prop";
1375         } elsif ($pd->{type} eq 'boolean') {
1376             push @getopt, "$prop:s";
1377         } else {
1378             if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
1379                 push @getopt, "$prop=s@";
1380             } else {
1381                 push @getopt, "$prop=s";
1382             }
1383         }
1384     }
1385
1386     Getopt::Long::Configure('prefix_pattern=(--|-)');
1387
1388     my $opts = {};
1389     raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
1390         if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
1391
1392     if (@$args) {
1393         if ($list_param) {
1394             $opts->{$list_param} = $args;
1395             $args = [];
1396         } elsif (ref($arg_param)) {
1397             foreach my $arg_name (@$arg_param) {
1398                 if ($opts->{'extra-args'}) {
1399                     raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
1400                 }
1401                 if ($arg_name eq 'extra-args') {
1402                     $opts->{'extra-args'} = $args;
1403                     $args = [];
1404                     next;
1405                 }
1406                 raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
1407                 $opts->{$arg_name} = shift @$args;
1408             }
1409             raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
1410         } else {
1411             raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1412                 if scalar(@$args) != 0;
1413         }
1414     } else {
1415         if (ref($arg_param)) {
1416             foreach my $arg_name (@$arg_param) {
1417                 if ($arg_name eq 'extra-args') {
1418                     $opts->{'extra-args'} = [];
1419                 } else {
1420                     raise("not enough arguments\n", code => HTTP_BAD_REQUEST);
1421                 }
1422             }
1423         }
1424     }
1425
1426     if (my $pd = $schema->{properties}->{password}) {
1427         if ($pd->{type} ne 'boolean' && $pwcallback) {
1428             if ($opts->{password} || !$pd->{optional}) {
1429                 $opts->{password} = &$pwcallback(); 
1430             }
1431         }
1432     }
1433
1434     foreach my $entry (@interactive) {
1435         my ($opt, $func) = @$entry;
1436         my $pd = $schema->{properties}->{$opt};
1437         my $value = $opts->{$opt};
1438         if (defined($value) || !$pd->{optional}) {
1439             $opts->{$opt} = $func->($value);
1440         }
1441     }
1442
1443     # decode after Getopt as we are not sure how well it handles unicode
1444     foreach my $p (keys %$opts) {
1445         if (!ref($opts->{$p})) {
1446             $opts->{$p} = decode('locale', $opts->{$p});
1447         } elsif (ref($opts->{$p}) eq 'ARRAY') {
1448             my $tmp = [];
1449             foreach my $v (@{$opts->{$p}}) {
1450                 push @$tmp, decode('locale', $v);
1451             }
1452             $opts->{$p} = $tmp;
1453         } elsif (ref($opts->{$p}) eq 'SCALAR') {
1454             $opts->{$p} = decode('locale', $$opts->{$p});
1455         } else {
1456             raise("decoding options failed, unknown reference\n", code => HTTP_BAD_REQUEST);
1457         }
1458     }
1459
1460     foreach my $p (keys %$opts) {
1461         if (my $pd = $schema->{properties}->{$p}) {
1462             if ($pd->{type} eq 'boolean') {
1463                 if ($opts->{$p} eq '') {
1464                     $opts->{$p} = 1;
1465                 } elsif (defined(my $bool = parse_boolean($opts->{$p}))) {
1466                     $opts->{$p} = $bool;
1467                 } else {
1468                     raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
1469                 }
1470             } elsif ($pd->{format}) {
1471
1472                 if ($pd->{format} =~ m/-list/) {
1473                     # allow --vmid 100 --vmid 101 and --vmid 100,101
1474                     # allow --dow mon --dow fri and --dow mon,fri
1475                     $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1476                 } elsif ($pd->{format} =~ m/-alist/) {
1477                     # we encode array as \0 separated strings
1478                     # Note: CGI.pm also use this encoding
1479                     if (scalar(@{$opts->{$p}}) != 1) {
1480                         $opts->{$p} = join("\0", @{$opts->{$p}});
1481                     } else {
1482                         # st that split_list knows it is \0 terminated
1483                         my $v = $opts->{$p}->[0];
1484                         $opts->{$p} = "$v\0";
1485                     }
1486                 }
1487             }
1488         }       
1489     }
1490
1491     foreach my $p (keys %$fixed_param) {
1492         $opts->{$p} = $fixed_param->{$p};
1493     }
1494
1495     return $opts;
1496 }
1497
1498 # A way to parse configuration data by giving a json schema
1499 sub parse_config {
1500     my ($schema, $filename, $raw) = @_;
1501
1502     # do fast check (avoid validate_schema($schema))
1503     die "got strange schema" if !$schema->{type} || 
1504         !$schema->{properties} || $schema->{type} ne 'object';
1505
1506     my $cfg = {};
1507
1508     while ($raw =~ /^\s*(.+?)\s*$/gm) {
1509         my $line = $1;
1510
1511         next if $line =~ /^#/;
1512
1513         if ($line =~ m/^(\S+?):\s*(.*)$/) {
1514             my $key = $1;
1515             my $value = $2;
1516             if ($schema->{properties}->{$key} && 
1517                 $schema->{properties}->{$key}->{type} eq 'boolean') {
1518
1519                 $value = parse_boolean($value) // $value;
1520             }
1521             $cfg->{$key} = $value;
1522         } else {
1523             warn "ignore config line: $line\n"
1524         }
1525     }
1526
1527     my $errors = {};
1528     check_prop($cfg, $schema, '', $errors);
1529
1530     foreach my $k (keys %$errors) {
1531         warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1532         delete $cfg->{$k};
1533     } 
1534
1535     return $cfg;
1536 }
1537
1538 # generate simple key/value file
1539 sub dump_config {
1540     my ($schema, $filename, $cfg) = @_;
1541
1542     # do fast check (avoid validate_schema($schema))
1543     die "got strange schema" if !$schema->{type} || 
1544         !$schema->{properties} || $schema->{type} ne 'object';
1545
1546     validate($cfg, $schema, "validation error in '$filename'\n");
1547
1548     my $data = '';
1549
1550     foreach my $k (keys %$cfg) {
1551         $data .= "$k: $cfg->{$k}\n";
1552     }
1553
1554     return $data;
1555 }
1556
1557 # helpers used to generate our manual pages
1558
1559 my $find_schema_default_key = sub {
1560     my ($format) = @_;
1561
1562     my $default_key;
1563     my $keyAliasProps = {};
1564
1565     foreach my $key (keys %$format) {
1566         my $phash = $format->{$key};
1567         if ($phash->{default_key}) {
1568             die "multiple default keys in schema ($default_key, $key)\n"
1569                 if defined($default_key);
1570             die "default key '$key' is an alias - this is not allowed\n"
1571                 if defined($phash->{alias});
1572             die "default key '$key' with keyAlias attribute is not allowed\n"
1573                 if $phash->{keyAlias};
1574             $default_key = $key;
1575         }
1576         my $key_alias = $phash->{keyAlias};
1577         die "found keyAlias without 'alias definition for '$key'\n"
1578             if $key_alias && !$phash->{alias};
1579
1580         if ($phash->{alias} && $key_alias) {
1581             die "inconsistent keyAlias '$key_alias' definition"
1582                 if defined($keyAliasProps->{$key_alias}) &&
1583                 $keyAliasProps->{$key_alias} ne $phash->{alias};
1584             $keyAliasProps->{$key_alias} = $phash->{alias};
1585         }
1586     }
1587
1588     return wantarray ? ($default_key, $keyAliasProps) : $default_key;
1589 };
1590
1591 sub generate_typetext {
1592     my ($format, $list_enums) = @_;
1593
1594     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1595
1596     my $res = '';
1597     my $add_sep = 0;
1598
1599     my $add_option_string = sub {
1600         my ($text, $optional) = @_;
1601
1602         if ($add_sep) {
1603             $text = ",$text";
1604             $res .= ' ';
1605         }
1606         $text = "[$text]" if $optional;
1607         $res .= $text;
1608         $add_sep = 1;
1609     };
1610
1611     my $format_key_value = sub {
1612         my ($key, $phash) = @_;
1613
1614         die "internal error" if defined($phash->{alias});
1615
1616         my $keytext = $key;
1617
1618         my $typetext = '';
1619
1620         if (my $desc = $phash->{format_description}) {
1621             $typetext .= "<$desc>";
1622         } elsif (my $text = $phash->{typetext}) {
1623             $typetext .= $text;
1624         } elsif (my $enum = $phash->{enum}) {
1625             if ($list_enums || (scalar(@$enum) <= 3)) {
1626                 $typetext .= '<' . join('|', @$enum) . '>';
1627             } else {
1628                 $typetext .= '<enum>';
1629             }
1630         } elsif ($phash->{type} eq 'boolean') {
1631             $typetext .= '<1|0>';
1632         } elsif ($phash->{type} eq 'integer') {
1633             $typetext .= '<integer>';
1634         } elsif ($phash->{type} eq 'number') {
1635             $typetext .= '<number>';
1636         } else {
1637             die "internal error: neither format_description nor typetext found for option '$key'";
1638         }
1639
1640         if (defined($default_key) && ($default_key eq $key)) {
1641             &$add_option_string("[$keytext=]$typetext", $phash->{optional});
1642         } else {
1643             &$add_option_string("$keytext=$typetext", $phash->{optional});
1644         }
1645     };
1646
1647     my $done = {};
1648
1649     my $cond_add_key = sub {
1650         my ($key) = @_;
1651
1652         return if $done->{$key}; # avoid duplicates
1653
1654         $done->{$key} = 1;
1655
1656         my $phash = $format->{$key};
1657
1658         return if !$phash; # should not happen
1659
1660         return if $phash->{alias};
1661
1662         &$format_key_value($key, $phash);
1663
1664     };
1665
1666     &$cond_add_key($default_key) if defined($default_key);
1667
1668     # add required keys first
1669     foreach my $key (sort keys %$format) {
1670         my $phash = $format->{$key};
1671         &$cond_add_key($key) if $phash && !$phash->{optional};
1672     }
1673
1674     # add the rest
1675     foreach my $key (sort keys %$format) {
1676         &$cond_add_key($key);
1677     }
1678
1679     foreach my $keyAlias (sort keys %$keyAliasProps) {
1680         &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
1681     }
1682
1683     return $res;
1684 }
1685
1686 sub print_property_string {
1687     my ($data, $format, $skip, $path) = @_;
1688
1689     if (ref($format) ne 'HASH') {
1690         my $schema = get_format($format);
1691         die "not a valid format: $format\n" if !$schema;
1692         $format = $schema;
1693     }
1694
1695     my $errors = {};
1696     check_object($path, $format, $data, undef, $errors);
1697     if (scalar(%$errors)) {
1698         raise "format error", errors => $errors;
1699     }
1700
1701     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1702
1703     my $res = '';
1704     my $add_sep = 0;
1705
1706     my $add_option_string = sub {
1707         my ($text) = @_;
1708
1709         $res .= ',' if $add_sep;
1710         $res .= $text;
1711         $add_sep = 1;
1712     };
1713
1714     my $format_value = sub {
1715         my ($key, $value, $format) = @_;
1716
1717         if (defined($format) && ($format eq 'disk-size')) {
1718             return format_size($value);
1719         } else {
1720             die "illegal value with commas for $key\n" if $value =~ /,/;
1721             return $value;
1722         }
1723     };
1724
1725     my $done = { map { $_ => 1 } @$skip };
1726
1727     my $cond_add_key = sub {
1728         my ($key, $isdefault) = @_;
1729
1730         return if $done->{$key}; # avoid duplicates
1731
1732         $done->{$key} = 1;
1733
1734         my $value = $data->{$key};
1735
1736         return if !defined($value);
1737
1738         my $phash = $format->{$key};
1739
1740         # try to combine values if we have key aliases
1741         if (my $combine = $keyAliasProps->{$key}) {
1742             if (defined(my $combine_value = $data->{$combine})) {
1743                 my $combine_format = $format->{$combine}->{format};
1744                 my $value_str = &$format_value($key, $value, $phash->{format});
1745                 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
1746                 &$add_option_string("${value_str}=${combine_str}");
1747                 $done->{$combine} = 1;
1748                 return;
1749             }
1750         }
1751
1752         if ($phash && $phash->{alias}) {
1753             $phash = $format->{$phash->{alias}};
1754         }
1755
1756         die "invalid key '$key'\n" if !$phash;
1757         die "internal error" if defined($phash->{alias});
1758
1759         my $value_str = &$format_value($key, $value, $phash->{format});
1760         if ($isdefault) {
1761             &$add_option_string($value_str);
1762         } else {
1763             &$add_option_string("$key=${value_str}");
1764         }
1765     };
1766
1767     # add default key first
1768     &$cond_add_key($default_key, 1) if defined($default_key);
1769
1770     # add required keys first
1771     foreach my $key (sort keys %$data) {
1772         my $phash = $format->{$key};
1773         &$cond_add_key($key) if $phash && !$phash->{optional};
1774     }
1775
1776     # add the rest
1777     foreach my $key (sort keys %$data) {
1778         &$cond_add_key($key);
1779     }
1780
1781     return $res;
1782 }
1783
1784 sub schema_get_type_text {
1785     my ($phash, $style) = @_;
1786
1787     my $type = $phash->{type} || 'string';
1788
1789     if ($phash->{typetext}) {
1790         return $phash->{typetext};
1791     } elsif ($phash->{format_description}) {
1792         return "<$phash->{format_description}>";
1793     } elsif ($phash->{enum}) {
1794         return "<" . join(' | ', sort @{$phash->{enum}}) . ">";
1795     } elsif ($phash->{pattern}) {
1796         return $phash->{pattern};
1797     } elsif ($type eq 'integer' || $type eq 'number') {
1798         # NOTE: always access values as number (avoid converion to string)
1799         if (defined($phash->{minimum}) && defined($phash->{maximum})) {
1800             return "<$type> (" . ($phash->{minimum} + 0) . " - " .
1801                 ($phash->{maximum} + 0) . ")";
1802         } elsif (defined($phash->{minimum})) {
1803             return "<$type> (" . ($phash->{minimum} + 0) . " - N)";
1804         } elsif (defined($phash->{maximum})) {
1805             return "<$type> (-N - " . ($phash->{maximum} + 0) . ")";
1806         }
1807     } elsif ($type eq 'string') {
1808         if (my $format = $phash->{format}) {
1809             $format = get_format($format) if ref($format) ne 'HASH';
1810             if (ref($format) eq 'HASH') {
1811                 my $list_enums = 0;
1812                 $list_enums = 1 if $style && $style eq 'config-sub';
1813                 return generate_typetext($format, $list_enums);
1814             }
1815         }
1816     }
1817
1818     return "<$type>";
1819 }
1820
1821 1;