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