1 package PVE
::JSONSchema
;
5 use Storable
; # for dclone
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);
19 register_standard_option
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/
27 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
29 my $standard_options = {};
30 sub register_standard_option
{
31 my ($name, $schema) = @_;
33 die "standard option '$name' already registered\n"
34 if $standard_options->{$name};
36 $standard_options->{$name} = $schema;
39 sub get_standard_option
{
40 my ($name, $base) = @_;
42 my $std = $standard_options->{$name};
43 die "no such standard option '$name'\n" if !$std;
45 my $res = $base || {};
47 foreach my $opt (keys %$std) {
48 next if defined($res->{$opt});
49 $res->{$opt} = $std->{$opt};
55 register_standard_option
('pve-vmid', {
56 description
=> "The (unique) ID of the VM.",
57 type
=> 'integer', format
=> 'pve-vmid',
61 register_standard_option
('pve-node', {
62 description
=> "The cluster node name.",
63 type
=> 'string', format
=> 'pve-node',
66 register_standard_option
('pve-node-list', {
67 description
=> "List of cluster node names.",
68 type
=> 'string', format
=> 'pve-node-list',
71 register_standard_option
('pve-iface', {
72 description
=> "Network interface name.",
73 type
=> 'string', format
=> 'pve-iface',
74 minLength
=> 2, maxLength
=> 20,
77 register_standard_option
('pve-storage-id', {
78 description
=> "The storage identifier.",
79 type
=> 'string', format
=> 'pve-storage-id',
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.',
86 maxLength
=> 40, # sha1 hex digest length is 40
89 register_standard_option
('skiplock', {
90 description
=> "Ignore locks - only root is allowed to use this option.",
95 register_standard_option
('extra-args', {
96 description
=> "Extra arguments as array",
98 items
=> { type
=> 'string' },
102 register_standard_option
('fingerprint-sha256', {
103 description
=> "Certificate SHA 256 fingerprint.",
105 pattern
=> '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}',
108 register_standard_option
('pve-output-format', {
110 description
=> 'Output format.',
111 enum
=> [ 'text', 'json', 'json-pretty', 'yaml' ],
116 my $format_list = {};
118 sub register_format
{
119 my ($format, $code) = @_;
121 die "JSON schema format '$format' already registered\n"
122 if $format_list->{$format};
124 $format_list->{$format} = $code;
129 return $format_list->{$format};
132 my $renderer_hash = {};
134 sub register_renderer
{
135 my ($name, $code) = @_;
137 die "renderer '$name' already registered\n"
138 if $renderer_hash->{$name};
140 $renderer_hash->{$name} = $code;
145 return $renderer_hash->{$name};
148 # register some common type for pve
150 register_format
('string', sub {}); # allow format => 'string-list'
152 register_format
('urlencoded', \
&pve_verify_urlencoded
);
153 sub pve_verify_urlencoded
{
154 my ($text, $noerr) = @_;
155 if ($text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/) {
156 return undef if $noerr;
157 die "invalid urlencoded string: $text\n";
162 register_format
('pve-configid', \
&pve_verify_configid
);
163 sub pve_verify_configid
{
164 my ($id, $noerr) = @_;
166 if ($id !~ m/^[a-z][a-z0-9_]+$/i) {
167 return undef if $noerr;
168 die "invalid configuration ID '$id'\n";
173 PVE
::JSONSchema
::register_format
('pve-storage-id', \
&parse_storage_id
);
174 sub parse_storage_id
{
175 my ($storeid, $noerr) = @_;
177 if ($storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
178 return undef if $noerr;
179 die "storage ID '$storeid' contains illegal characters\n";
185 register_format
('pve-vmid', \
&pve_verify_vmid
);
186 sub pve_verify_vmid
{
187 my ($vmid, $noerr) = @_;
189 if ($vmid !~ m/^[1-9][0-9]{2,8}$/) {
190 return undef if $noerr;
191 die "value does not look like a valid VM ID\n";
196 register_format
('pve-node', \
&pve_verify_node_name
);
197 sub pve_verify_node_name
{
198 my ($node, $noerr) = @_;
200 if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) {
201 return undef if $noerr;
202 die "value does not look like a valid node name\n";
207 register_format
('mac-addr', \
&pve_verify_mac_addr
);
208 sub pve_verify_mac_addr
{
209 my ($mac_addr, $noerr) = @_;
211 if ($mac_addr !~ m/^[0-9a-f]{2}(:[0-9a-f]{2}){5}$/i) {
212 return undef if $noerr;
213 die "value does not look like a valid MAC address\n";
218 register_format
('ipv4', \
&pve_verify_ipv4
);
219 sub pve_verify_ipv4
{
220 my ($ipv4, $noerr) = @_;
222 if ($ipv4 !~ m/^(?:$IPV4RE)$/) {
223 return undef if $noerr;
224 die "value does not look like a valid IPv4 address\n";
229 register_format
('ipv6', \
&pve_verify_ipv6
);
230 sub pve_verify_ipv6
{
231 my ($ipv6, $noerr) = @_;
233 if ($ipv6 !~ m/^(?:$IPV6RE)$/) {
234 return undef if $noerr;
235 die "value does not look like a valid IPv6 address\n";
240 register_format
('ip', \
&pve_verify_ip
);
242 my ($ip, $noerr) = @_;
244 if ($ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/) {
245 return undef if $noerr;
246 die "value does not look like a valid IP address\n";
251 my $ipv4_mask_hash = {
268 '255.255.128.0' => 17,
269 '255.255.192.0' => 18,
270 '255.255.224.0' => 19,
271 '255.255.240.0' => 20,
272 '255.255.248.0' => 21,
273 '255.255.252.0' => 22,
274 '255.255.254.0' => 23,
275 '255.255.255.0' => 24,
276 '255.255.255.128' => 25,
277 '255.255.255.192' => 26,
278 '255.255.255.224' => 27,
279 '255.255.255.240' => 28,
280 '255.255.255.248' => 29,
281 '255.255.255.252' => 30,
282 '255.255.255.254' => 31,
283 '255.255.255.255' => 32,
286 register_format
('ipv4mask', \
&pve_verify_ipv4mask
);
287 sub pve_verify_ipv4mask
{
288 my ($mask, $noerr) = @_;
290 if (!defined($ipv4_mask_hash->{$mask})) {
291 return undef if $noerr;
292 die "value does not look like a valid IP netmask\n";
297 register_format
('CIDRv6', \
&pve_verify_cidrv6
);
298 sub pve_verify_cidrv6
{
299 my ($cidr, $noerr) = @_;
301 if ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 128)) {
305 return undef if $noerr;
306 die "value does not look like a valid IPv6 CIDR network\n";
309 register_format
('CIDRv4', \
&pve_verify_cidrv4
);
310 sub pve_verify_cidrv4
{
311 my ($cidr, $noerr) = @_;
313 if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 32)) {
317 return undef if $noerr;
318 die "value does not look like a valid IPv4 CIDR network\n";
321 register_format
('CIDR', \
&pve_verify_cidr
);
322 sub pve_verify_cidr
{
323 my ($cidr, $noerr) = @_;
325 if (!(pve_verify_cidrv4
($cidr, 1) ||
326 pve_verify_cidrv6
($cidr, 1)))
328 return undef if $noerr;
329 die "value does not look like a valid CIDR network\n";
335 register_format
('pve-ipv4-config', \
&pve_verify_ipv4_config
);
336 sub pve_verify_ipv4_config
{
337 my ($config, $noerr) = @_;
339 return $config if $config =~ /^(?:dhcp|manual)$/ ||
340 pve_verify_cidrv4
($config, 1);
341 return undef if $noerr;
342 die "value does not look like a valid ipv4 network configuration\n";
345 register_format
('pve-ipv6-config', \
&pve_verify_ipv6_config
);
346 sub pve_verify_ipv6_config
{
347 my ($config, $noerr) = @_;
349 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
350 pve_verify_cidrv6
($config, 1);
351 return undef if $noerr;
352 die "value does not look like a valid ipv6 network configuration\n";
355 register_format
('email', \
&pve_verify_email
);
356 sub pve_verify_email
{
357 my ($email, $noerr) = @_;
359 if ($email !~ /^[\w\+\-\~]+(\.[\w\+\-\~]+)*@[a-zA-Z0-9\-]+(\.[a-zA-Z0-9\-]+)*$/) {
360 return undef if $noerr;
361 die "value does not look like a valid email address\n";
366 register_format
('dns-name', \
&pve_verify_dns_name
);
367 sub pve_verify_dns_name
{
368 my ($name, $noerr) = @_;
370 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)";
372 if ($name !~ /^(${namere}\.)*${namere}$/) {
373 return undef if $noerr;
374 die "value does not look like a valid DNS name\n";
379 # network interface name
380 register_format
('pve-iface', \
&pve_verify_iface
);
381 sub pve_verify_iface
{
382 my ($id, $noerr) = @_;
384 if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
385 return undef if $noerr;
386 die "invalid network interface name '$id'\n";
391 # general addresses by name or IP
392 register_format
('address', \
&pve_verify_address
);
393 sub pve_verify_address
{
394 my ($addr, $noerr) = @_;
396 if (!(pve_verify_ip
($addr, 1) ||
397 pve_verify_dns_name
($addr, 1)))
399 return undef if $noerr;
400 die "value does not look like a valid address: $addr\n";
405 register_format
('disk-size', \
&pve_verify_disk_size
);
406 sub pve_verify_disk_size
{
407 my ($size, $noerr) = @_;
408 if (!defined(parse_size
($size))) {
409 return undef if $noerr;
410 die "value does not look like a valid disk size: $size\n";
415 register_standard_option
('spice-proxy', {
416 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 reasonable setting is to use same node you use to connect to the API (This is window.location.hostname for the JS GUI).",
417 type
=> 'string', format
=> 'address',
420 register_standard_option
('remote-viewer-config', {
421 description
=> "Returned values can be directly passed to the 'remote-viewer' application.",
422 additionalProperties
=> 1,
424 type
=> { type
=> 'string' },
425 password
=> { type
=> 'string' },
426 proxy
=> { type
=> 'string' },
427 host
=> { type
=> 'string' },
428 'tls-port' => { type
=> 'integer' },
432 register_format
('pve-startup-order', \
&pve_verify_startup_order
);
433 sub pve_verify_startup_order
{
434 my ($value, $noerr) = @_;
436 return $value if pve_parse_startup_order
($value);
438 return undef if $noerr;
440 die "unable to parse startup options\n";
445 type
=> 'number', minimum
=> '0',
446 format_description
=> 'LIMIT',
449 my $bwlimit_format = {
452 description
=> 'default bandwidth limit in MiB/s',
456 description
=> 'bandwidth limit in MiB/s for restoring guests from backups',
460 description
=> 'bandwidth limit in MiB/s for migrating guests',
464 description
=> 'bandwidth limit in MiB/s for cloning disks',
468 description
=> 'bandwidth limit in MiB/s for moving disks',
471 register_format
('bwlimit', $bwlimit_format);
472 register_standard_option
('bwlimit', {
473 description
=> "Set bandwidth/io limits various operations.",
476 format
=> $bwlimit_format,
479 sub pve_parse_startup_order
{
482 return undef if !$value;
486 foreach my $p (split(/,/, $value)) {
487 next if $p =~ m/^\s*$/;
489 if ($p =~ m/^(order=)?(\d+)$/) {
491 } elsif ($p =~ m/^up=(\d+)$/) {
493 } elsif ($p =~ m/^down=(\d+)$/) {
503 PVE
::JSONSchema
::register_standard_option
('pve-startup-order', {
504 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.",
506 type
=> 'string', format
=> 'pve-startup-order',
507 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ',
511 my ($format, $value, $path) = @_;
513 return parse_property_string
($format, $value, $path) if ref($format) eq 'HASH';
514 return if $format eq 'regex';
516 if ($format =~ m/^(.*)-a?list$/) {
518 my $code = $format_list->{$1};
520 die "undefined format '$format'\n" if !$code;
522 # Note: we allow empty lists
523 foreach my $v (split_list
($value)) {
527 } elsif ($format =~ m/^(.*)-opt$/) {
529 my $code = $format_list->{$1};
531 die "undefined format '$format'\n" if !$code;
533 return if !$value; # allow empty string
539 my $code = $format_list->{$format};
541 die "undefined format '$format'\n" if !$code;
543 return parse_property_string
($code, $value, $path) if ref($code) eq 'HASH';
551 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
552 my ($size, $unit) = ($1, $3);
555 $size = $size * 1024;
556 } elsif ($unit eq 'M') {
557 $size = $size * 1024 * 1024;
558 } elsif ($unit eq 'G') {
559 $size = $size * 1024 * 1024 * 1024;
560 } elsif ($unit eq 'T') {
561 $size = $size * 1024 * 1024 * 1024 * 1024;
572 my $kb = int($size/1024);
573 return $size if $kb*1024 != $size;
575 my $mb = int($kb/1024);
576 return "${kb}K" if $mb*1024 != $kb;
578 my $gb = int($mb/1024);
579 return "${mb}M" if $gb*1024 != $mb;
581 my $tb = int($gb/1024);
582 return "${gb}G" if $tb*1024 != $gb;
589 return 1 if $bool =~ m/^(1|on|yes|true)$/i;
590 return 0 if $bool =~ m/^(0|off|no|false)$/i;
594 sub parse_property_string
{
595 my ($format, $data, $path, $additional_properties) = @_;
597 # In property strings we default to not allowing additional properties
598 $additional_properties = 0 if !defined($additional_properties);
600 # Support named formats here, too:
602 if (my $desc = $format_list->{$format}) {
605 die "unknown format: $format\n";
607 } elsif (ref($format) ne 'HASH') {
608 die "unexpected format value of type ".ref($format)."\n";
614 foreach my $part (split(/,/, $data)) {
615 next if $part =~ /^\s*$/;
617 if ($part =~ /^([^=]+)=(.+)$/) {
618 my ($k, $v) = ($1, $2);
619 die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
620 my $schema = $format->{$k};
621 if (my $alias = $schema->{alias
}) {
622 if (my $key_alias = $schema->{keyAlias
}) {
623 die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
624 $res->{$key_alias} = $k;
627 $schema = $format->{$k};
630 die "invalid key in comma-separated list property: $k\n" if !$schema;
631 if ($schema->{type
} && $schema->{type
} eq 'boolean') {
632 $v = parse_boolean
($v) // $v;
635 } elsif ($part !~ /=/) {
636 die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
637 foreach my $key (keys %$format) {
638 if ($format->{$key}->{default_key
}) {
640 if (!$res->{$default_key}) {
641 $res->{$default_key} = $part;
644 die "duplicate key in comma-separated list property: $default_key\n";
647 die "value without key, but schema does not define a default key\n" if !$default_key;
649 die "missing key in comma-separated list property\n";
654 check_object
($path, $format, $res, $additional_properties, $errors);
655 if (scalar(%$errors)) {
656 raise
"format error\n", errors
=> $errors;
663 my ($errors, $path, $msg) = @_;
665 $path = '_root' if !$path;
667 if ($errors->{$path}) {
668 $errors->{$path} = join ('\n', $errors->{$path}, $msg);
670 $errors->{$path} = $msg;
677 # see 'man perlretut'
678 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
684 return $value =~ m/^[+-]?\d+$/;
688 my ($path, $type, $value, $errors) = @_;
692 if (!defined($value)) {
693 return 1 if $type eq 'null';
697 if (my $tt = ref($type)) {
698 if ($tt eq 'ARRAY') {
699 foreach my $t (@$type) {
701 check_type
($path, $t, $value, $tmperr);
702 return 1 if !scalar(%$tmperr);
704 my $ttext = join ('|', @$type);
705 add_error
($errors, $path, "type check ('$ttext') failed");
707 } elsif ($tt eq 'HASH') {
709 check_prop
($value, $type, $path, $tmperr);
710 return 1 if !scalar(%$tmperr);
711 add_error
($errors, $path, "type check failed");
714 die "internal error - got reference type '$tt'";
719 return 1 if $type eq 'any';
721 if ($type eq 'null') {
722 if (defined($value)) {
723 add_error
($errors, $path, "type check ('$type') failed - value is not null");
729 my $vt = ref($value);
731 if ($type eq 'array') {
732 if (!$vt || $vt ne 'ARRAY') {
733 add_error
($errors, $path, "type check ('$type') failed");
737 } elsif ($type eq 'object') {
738 if (!$vt || $vt ne 'HASH') {
739 add_error
($errors, $path, "type check ('$type') failed");
743 } elsif ($type eq 'coderef') {
744 if (!$vt || $vt ne 'CODE') {
745 add_error
($errors, $path, "type check ('$type') failed");
749 } elsif ($type eq 'string' && $vt eq 'Regexp') {
750 # qr// regexes can be used as strings and make sense for format=regex
754 add_error
($errors, $path, "type check ('$type') failed - got $vt");
757 if ($type eq 'string') {
758 return 1; # nothing to check ?
759 } elsif ($type eq 'boolean') {
760 #if ($value =~ m/^(1|true|yes|on)$/i) {
763 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
764 } elsif ($value eq '0') {
765 return 1; # return success (not value)
767 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
770 } elsif ($type eq 'integer') {
771 if (!is_integer
($value)) {
772 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
776 } elsif ($type eq 'number') {
777 if (!is_number
($value)) {
778 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
783 return 1; # no need to verify unknown types
793 my ($path, $schema, $value, $additional_properties, $errors) = @_;
795 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
797 my $st = ref($schema);
798 if (!$st || $st ne 'HASH') {
799 add_error
($errors, $path, "Invalid schema definition.");
803 my $vt = ref($value);
804 if (!$vt || $vt ne 'HASH') {
805 add_error
($errors, $path, "an object is required");
809 foreach my $k (keys %$schema) {
810 check_prop
($value->{$k}, $schema->{$k}, $path ?
"$path.$k" : $k, $errors);
813 foreach my $k (keys %$value) {
815 my $newpath = $path ?
"$path.$k" : $k;
817 if (my $subschema = $schema->{$k}) {
818 if (my $requires = $subschema->{requires
}) {
819 if (ref($requires)) {
820 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
821 check_prop
($value, $requires, $path, $errors);
822 } elsif (!defined($value->{$requires})) {
823 add_error
($errors, $path ?
"$path.$requires" : $requires,
824 "missing property - '$newpath' requires this property");
828 next; # value is already checked above
831 if (defined ($additional_properties) && !$additional_properties) {
832 add_error
($errors, $newpath, "property is not defined in schema " .
833 "and the schema does not allow additional properties");
836 check_prop
($value->{$k}, $additional_properties, $newpath, $errors)
837 if ref($additional_properties);
841 sub check_object_warn
{
842 my ($path, $schema, $value, $additional_properties) = @_;
844 check_object
($path, $schema, $value, $additional_properties, $errors);
845 if (scalar(%$errors)) {
846 foreach my $k (keys %$errors) {
847 warn "parse error: $k: $errors->{$k}\n";
855 my ($value, $schema, $path, $errors) = @_;
857 die "internal error - no schema" if !$schema;
858 die "internal error" if !$errors;
860 #print "check_prop $path\n" if $value;
862 my $st = ref($schema);
863 if (!$st || $st ne 'HASH') {
864 add_error
($errors, $path, "Invalid schema definition.");
868 # if it extends another schema, it must pass that schema as well
869 if($schema->{extends
}) {
870 check_prop
($value, $schema->{extends
}, $path, $errors);
873 if (!defined ($value)) {
874 return if $schema->{type
} && $schema->{type
} eq 'null';
875 if (!$schema->{optional
} && !$schema->{alias
} && !$schema->{group
}) {
876 add_error
($errors, $path, "property is missing and it is not optional");
881 return if !check_type
($path, $schema->{type
}, $value, $errors);
883 if ($schema->{disallow
}) {
885 if (check_type
($path, $schema->{disallow
}, $value, $tmperr)) {
886 add_error
($errors, $path, "disallowed value was matched");
891 if (my $vt = ref($value)) {
893 if ($vt eq 'ARRAY') {
894 if ($schema->{items
}) {
895 my $it = ref($schema->{items
});
896 if ($it && $it eq 'ARRAY') {
897 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
898 die "not implemented";
901 foreach my $el (@$value) {
902 check_prop
($el, $schema->{items
}, "${path}[$ind]", $errors);
908 } elsif ($schema->{properties
} || $schema->{additionalProperties
}) {
909 check_object
($path, defined($schema->{properties
}) ?
$schema->{properties
} : {},
910 $value, $schema->{additionalProperties
}, $errors);
916 if (my $format = $schema->{format
}) {
917 eval { check_format
($format, $value, $path); };
919 add_error
($errors, $path, "invalid format - $@");
924 if (my $pattern = $schema->{pattern
}) {
925 if ($value !~ m/^$pattern$/) {
926 add_error
($errors, $path, "value does not match the regex pattern");
931 if (defined (my $max = $schema->{maxLength
})) {
932 if (length($value) > $max) {
933 add_error
($errors, $path, "value may only be $max characters long");
938 if (defined (my $min = $schema->{minLength
})) {
939 if (length($value) < $min) {
940 add_error
($errors, $path, "value must be at least $min characters long");
945 if (is_number
($value)) {
946 if (defined (my $max = $schema->{maximum
})) {
948 add_error
($errors, $path, "value must have a maximum value of $max");
953 if (defined (my $min = $schema->{minimum
})) {
955 add_error
($errors, $path, "value must have a minimum value of $min");
961 if (my $ea = $schema->{enum
}) {
964 foreach my $ev (@$ea) {
971 add_error
($errors, $path, "value '$value' does not have a value in the enumeration '" .
972 join(", ", @$ea) . "'");
979 my ($instance, $schema, $errmsg) = @_;
982 $errmsg = "Parameter verification failed.\n" if !$errmsg;
984 # todo: cycle detection is only needed for debugging, I guess
985 # we can disable that in the final release
986 # todo: is there a better/faster way to detect cycles?
988 find_cycle
($instance, sub { $cycles = 1 });
990 add_error
($errors, undef, "data structure contains recursive cycles");
992 check_prop
($instance, $schema, '', $errors);
995 if (scalar(%$errors)) {
996 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors;
1002 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
1003 my $default_schema_noref = {
1004 description
=> "This is the JSON Schema for JSON Schemas.",
1005 type
=> [ "object" ],
1006 additionalProperties
=> 0,
1009 type
=> ["string", "array"],
1010 description
=> "This is a type definition value. This can be a simple type, or a union type",
1015 enum
=> $schema_valid_types,
1017 enum
=> $schema_valid_types,
1021 description
=> "This indicates that the instance property in the instance object is not required.",
1027 description
=> "This is a definition for the properties of an object value",
1033 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array",
1037 additionalProperties
=> {
1038 type
=> [ "boolean", "object"],
1039 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
1046 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number.",
1051 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number.",
1055 description
=> "When the instance value is a string, this indicates minimum length of the string",
1062 description
=> "When the instance value is a string, this indicates maximum length of the string.",
1068 description
=> "A text representation of the type (used to generate documentation).",
1073 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.",
1080 description
=> "This provides an enumeration of possible values that are valid for the instance property.",
1085 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).",
1087 verbose_description
=> {
1090 description
=> "This provides a more verbose description.",
1092 format_description
=> {
1095 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1100 description
=> "This provides the title of the property",
1105 description
=> "This is used to provide rendering hints to format cli command output.",
1108 type
=> [ "string", "object" ],
1110 description
=> "indicates a required property or a schema that must be validated if this property is present",
1113 type
=> [ "string", "object" ],
1115 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",
1120 description
=> "Whether this is the default key in a comma separated list property string.",
1125 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.",
1130 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1131 requires
=> 'alias',
1136 description
=> "This indicates the default for the instance property."
1140 description
=> "Bash completion function. This function should return a list of possible values.",
1146 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.",
1151 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1154 # this is from hyper schema
1157 description
=> "This defines the link relations of the instance objects",
1164 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",
1168 description
=> "This is the name of the link relation",
1174 description
=> "For submission links, this defines the method that should be used to access the target resource",
1183 description
=> "For CLI context, this defines the maximal width to print before truncating",
1189 my $default_schema = Storable
::dclone
($default_schema_noref);
1191 $default_schema->{properties
}->{properties
}->{additionalProperties
} = $default_schema;
1192 $default_schema->{properties
}->{additionalProperties
}->{properties
} = $default_schema->{properties
};
1194 $default_schema->{properties
}->{items
}->{properties
} = $default_schema->{properties
};
1195 $default_schema->{properties
}->{items
}->{additionalProperties
} = 0;
1197 $default_schema->{properties
}->{disallow
}->{properties
} = $default_schema->{properties
};
1198 $default_schema->{properties
}->{disallow
}->{additionalProperties
} = 0;
1200 $default_schema->{properties
}->{requires
}->{properties
} = $default_schema->{properties
};
1201 $default_schema->{properties
}->{requires
}->{additionalProperties
} = 0;
1203 $default_schema->{properties
}->{extends
}->{properties
} = $default_schema->{properties
};
1204 $default_schema->{properties
}->{extends
}->{additionalProperties
} = 0;
1206 my $method_schema = {
1208 additionalProperties
=> 0,
1211 description
=> "This a description of the method",
1216 description
=> "This indicates the name of the function to call.",
1219 additionalProperties
=> 1,
1234 description
=> "The HTTP method name.",
1235 enum
=> [ 'GET', 'POST', 'PUT', 'DELETE' ],
1240 description
=> "Method needs special privileges - only pvedaemon can execute it",
1245 description
=> "Method downloads the file content (filename is the return value of the method).",
1250 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1253 proxyto_callback
=> {
1255 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter.",
1260 description
=> "Required access permissions. By default only 'root' is allowed to access this method.",
1262 additionalProperties
=> 0,
1265 description
=> "Describe access permissions.",
1269 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1271 enum
=> ['all', 'world'],
1275 description
=> "Array of permission checks (prefix notation).",
1282 description
=> "Used internally",
1286 description
=> "Used internally",
1291 description
=> "path for URL matching (uri template)",
1293 fragmentDelimiter
=> {
1295 description
=> "A way to override the default fragment delimiter '/'. This only works on a whole sub-class. You can set this to the empty string to match the whole rest of the URI.",
1300 description
=> "JSON Schema for parameters.",
1305 description
=> "JSON Schema for return value.",
1310 description
=> "method implementation (code reference)",
1315 description
=> "Delegate call to this class (perl class string).",
1318 additionalProperties
=> 0,
1324 fragmentDelimiter
=> { optional
=> 1 }
1332 sub validate_schema
{
1335 my $errmsg = "internal error - unable to verify schema\n";
1336 validate
($schema, $default_schema, $errmsg);
1339 sub validate_method_info
{
1342 my $errmsg = "internal error - unable to verify method info\n";
1343 validate
($info, $method_schema, $errmsg);
1345 validate_schema
($info->{parameters
}) if $info->{parameters
};
1346 validate_schema
($info->{returns
}) if $info->{returns
};
1349 # run a self test on load
1350 # make sure we can verify the default schema
1351 validate_schema
($default_schema_noref);
1352 validate_schema
($method_schema);
1354 # and now some utility methods (used by pve api)
1355 sub method_get_child_link
{
1358 return undef if !$info;
1360 my $schema = $info->{returns
};
1361 return undef if !$schema || !$schema->{type
} || $schema->{type
} ne 'array';
1363 my $links = $schema->{links
};
1364 return undef if !$links;
1367 foreach my $lnk (@$links) {
1368 if ($lnk->{href
} && $lnk->{rel
} && ($lnk->{rel
} eq 'child')) {
1377 # a way to parse command line parameters, using a
1378 # schema to configure Getopt::Long
1380 my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
1382 if (!$schema || !$schema->{properties
}) {
1383 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1384 if scalar(@$args) != 0;
1389 if ($arg_param && !ref($arg_param)) {
1390 my $pd = $schema->{properties
}->{$arg_param};
1391 die "expected list format $pd->{format}"
1392 if !($pd && $pd->{format
} && $pd->{format
} =~ m/-list/);
1393 $list_param = $arg_param;
1396 my @interactive = ();
1398 foreach my $prop (keys %{$schema->{properties
}}) {
1399 my $pd = $schema->{properties
}->{$prop};
1400 next if $list_param && $prop eq $list_param;
1401 next if defined($fixed_param->{$prop});
1403 my $mapping = $param_mapping_hash->{$prop};
1404 if ($mapping && $mapping->{interactive
}) {
1405 # interactive parameters such as passwords: make the argument
1406 # optional and call the mapping function afterwards.
1407 push @getopt, "$prop:s";
1408 push @interactive, [$prop, $mapping->{func
}];
1409 } elsif ($pd->{type
} eq 'boolean') {
1410 push @getopt, "$prop:s";
1412 if ($pd->{format
} && $pd->{format
} =~ m/-a?list/) {
1413 push @getopt, "$prop=s@";
1415 push @getopt, "$prop=s";
1420 Getopt
::Long
::Configure
('prefix_pattern=(--|-)');
1423 raise
("unable to parse option\n", code
=> HTTP_BAD_REQUEST
)
1424 if !Getopt
::Long
::GetOptionsFromArray
($args, $opts, @getopt);
1428 $opts->{$list_param} = $args;
1430 } elsif (ref($arg_param)) {
1431 foreach my $arg_name (@$arg_param) {
1432 if ($opts->{'extra-args'}) {
1433 raise
("internal error: extra-args must be the last argument\n", code
=> HTTP_BAD_REQUEST
);
1435 if ($arg_name eq 'extra-args') {
1436 $opts->{'extra-args'} = $args;
1440 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
) if !@$args;
1441 $opts->{$arg_name} = shift @$args;
1443 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
) if @$args;
1445 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1446 if scalar(@$args) != 0;
1449 if (ref($arg_param)) {
1450 foreach my $arg_name (@$arg_param) {
1451 if ($arg_name eq 'extra-args') {
1452 $opts->{'extra-args'} = [];
1454 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
);
1460 foreach my $entry (@interactive) {
1461 my ($opt, $func) = @$entry;
1462 my $pd = $schema->{properties
}->{$opt};
1463 my $value = $opts->{$opt};
1464 if (defined($value) || !$pd->{optional
}) {
1465 $opts->{$opt} = $func->($value);
1469 # decode after Getopt as we are not sure how well it handles unicode
1470 foreach my $p (keys %$opts) {
1471 if (!ref($opts->{$p})) {
1472 $opts->{$p} = decode
('locale', $opts->{$p});
1473 } elsif (ref($opts->{$p}) eq 'ARRAY') {
1475 foreach my $v (@{$opts->{$p}}) {
1476 push @$tmp, decode
('locale', $v);
1479 } elsif (ref($opts->{$p}) eq 'SCALAR') {
1480 $opts->{$p} = decode
('locale', $$opts->{$p});
1482 raise
("decoding options failed, unknown reference\n", code
=> HTTP_BAD_REQUEST
);
1486 foreach my $p (keys %$opts) {
1487 if (my $pd = $schema->{properties
}->{$p}) {
1488 if ($pd->{type
} eq 'boolean') {
1489 if ($opts->{$p} eq '') {
1491 } elsif (defined(my $bool = parse_boolean
($opts->{$p}))) {
1492 $opts->{$p} = $bool;
1494 raise
("unable to parse boolean option\n", code
=> HTTP_BAD_REQUEST
);
1496 } elsif ($pd->{format
}) {
1498 if ($pd->{format
} =~ m/-list/) {
1499 # allow --vmid 100 --vmid 101 and --vmid 100,101
1500 # allow --dow mon --dow fri and --dow mon,fri
1501 $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1502 } elsif ($pd->{format
} =~ m/-alist/) {
1503 # we encode array as \0 separated strings
1504 # Note: CGI.pm also use this encoding
1505 if (scalar(@{$opts->{$p}}) != 1) {
1506 $opts->{$p} = join("\0", @{$opts->{$p}});
1508 # st that split_list knows it is \0 terminated
1509 my $v = $opts->{$p}->[0];
1510 $opts->{$p} = "$v\0";
1517 foreach my $p (keys %$fixed_param) {
1518 $opts->{$p} = $fixed_param->{$p};
1524 # A way to parse configuration data by giving a json schema
1526 my ($schema, $filename, $raw) = @_;
1528 # do fast check (avoid validate_schema($schema))
1529 die "got strange schema" if !$schema->{type
} ||
1530 !$schema->{properties
} || $schema->{type
} ne 'object';
1534 while ($raw =~ /^\s*(.+?)\s*$/gm) {
1537 next if $line =~ /^#/;
1539 if ($line =~ m/^(\S+?):\s*(.*)$/) {
1542 if ($schema->{properties
}->{$key} &&
1543 $schema->{properties
}->{$key}->{type
} eq 'boolean') {
1545 $value = parse_boolean
($value) // $value;
1547 $cfg->{$key} = $value;
1549 warn "ignore config line: $line\n"
1554 check_prop
($cfg, $schema, '', $errors);
1556 foreach my $k (keys %$errors) {
1557 warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1564 # generate simple key/value file
1566 my ($schema, $filename, $cfg) = @_;
1568 # do fast check (avoid validate_schema($schema))
1569 die "got strange schema" if !$schema->{type
} ||
1570 !$schema->{properties
} || $schema->{type
} ne 'object';
1572 validate
($cfg, $schema, "validation error in '$filename'\n");
1576 foreach my $k (keys %$cfg) {
1577 $data .= "$k: $cfg->{$k}\n";
1583 # helpers used to generate our manual pages
1585 my $find_schema_default_key = sub {
1589 my $keyAliasProps = {};
1591 foreach my $key (keys %$format) {
1592 my $phash = $format->{$key};
1593 if ($phash->{default_key
}) {
1594 die "multiple default keys in schema ($default_key, $key)\n"
1595 if defined($default_key);
1596 die "default key '$key' is an alias - this is not allowed\n"
1597 if defined($phash->{alias
});
1598 die "default key '$key' with keyAlias attribute is not allowed\n"
1599 if $phash->{keyAlias
};
1600 $default_key = $key;
1602 my $key_alias = $phash->{keyAlias
};
1603 die "found keyAlias without 'alias definition for '$key'\n"
1604 if $key_alias && !$phash->{alias
};
1606 if ($phash->{alias
} && $key_alias) {
1607 die "inconsistent keyAlias '$key_alias' definition"
1608 if defined($keyAliasProps->{$key_alias}) &&
1609 $keyAliasProps->{$key_alias} ne $phash->{alias
};
1610 $keyAliasProps->{$key_alias} = $phash->{alias
};
1614 return wantarray ?
($default_key, $keyAliasProps) : $default_key;
1617 sub generate_typetext
{
1618 my ($format, $list_enums) = @_;
1620 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1625 my $add_option_string = sub {
1626 my ($text, $optional) = @_;
1632 $text = "[$text]" if $optional;
1637 my $format_key_value = sub {
1638 my ($key, $phash) = @_;
1640 die "internal error" if defined($phash->{alias
});
1646 if (my $desc = $phash->{format_description
}) {
1647 $typetext .= "<$desc>";
1648 } elsif (my $text = $phash->{typetext
}) {
1650 } elsif (my $enum = $phash->{enum
}) {
1651 if ($list_enums || (scalar(@$enum) <= 3)) {
1652 $typetext .= '<' . join('|', @$enum) . '>';
1654 $typetext .= '<enum>';
1656 } elsif ($phash->{type
} eq 'boolean') {
1657 $typetext .= '<1|0>';
1658 } elsif ($phash->{type
} eq 'integer') {
1659 $typetext .= '<integer>';
1660 } elsif ($phash->{type
} eq 'number') {
1661 $typetext .= '<number>';
1663 die "internal error: neither format_description nor typetext found for option '$key'";
1666 if (defined($default_key) && ($default_key eq $key)) {
1667 &$add_option_string("[$keytext=]$typetext", $phash->{optional
});
1669 &$add_option_string("$keytext=$typetext", $phash->{optional
});
1675 my $cond_add_key = sub {
1678 return if $done->{$key}; # avoid duplicates
1682 my $phash = $format->{$key};
1684 return if !$phash; # should not happen
1686 return if $phash->{alias
};
1688 &$format_key_value($key, $phash);
1692 &$cond_add_key($default_key) if defined($default_key);
1694 # add required keys first
1695 foreach my $key (sort keys %$format) {
1696 my $phash = $format->{$key};
1697 &$cond_add_key($key) if $phash && !$phash->{optional
};
1701 foreach my $key (sort keys %$format) {
1702 &$cond_add_key($key);
1705 foreach my $keyAlias (sort keys %$keyAliasProps) {
1706 &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
1712 sub print_property_string
{
1713 my ($data, $format, $skip, $path) = @_;
1715 if (ref($format) ne 'HASH') {
1716 my $schema = get_format
($format);
1717 die "not a valid format: $format\n" if !$schema;
1722 check_object
($path, $format, $data, undef, $errors);
1723 if (scalar(%$errors)) {
1724 raise
"format error", errors
=> $errors;
1727 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1732 my $add_option_string = sub {
1735 $res .= ',' if $add_sep;
1740 my $format_value = sub {
1741 my ($key, $value, $format) = @_;
1743 if (defined($format) && ($format eq 'disk-size')) {
1744 return format_size
($value);
1746 die "illegal value with commas for $key\n" if $value =~ /,/;
1751 my $done = { map { $_ => 1 } @$skip };
1753 my $cond_add_key = sub {
1754 my ($key, $isdefault) = @_;
1756 return if $done->{$key}; # avoid duplicates
1760 my $value = $data->{$key};
1762 return if !defined($value);
1764 my $phash = $format->{$key};
1766 # try to combine values if we have key aliases
1767 if (my $combine = $keyAliasProps->{$key}) {
1768 if (defined(my $combine_value = $data->{$combine})) {
1769 my $combine_format = $format->{$combine}->{format
};
1770 my $value_str = &$format_value($key, $value, $phash->{format
});
1771 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
1772 &$add_option_string("${value_str}=${combine_str}");
1773 $done->{$combine} = 1;
1778 if ($phash && $phash->{alias
}) {
1779 $phash = $format->{$phash->{alias
}};
1782 die "invalid key '$key'\n" if !$phash;
1783 die "internal error" if defined($phash->{alias
});
1785 my $value_str = &$format_value($key, $value, $phash->{format
});
1787 &$add_option_string($value_str);
1789 &$add_option_string("$key=${value_str}");
1793 # add default key first
1794 &$cond_add_key($default_key, 1) if defined($default_key);
1796 # add required keys first
1797 foreach my $key (sort keys %$data) {
1798 my $phash = $format->{$key};
1799 &$cond_add_key($key) if $phash && !$phash->{optional
};
1803 foreach my $key (sort keys %$data) {
1804 &$cond_add_key($key);
1810 sub schema_get_type_text
{
1811 my ($phash, $style) = @_;
1813 my $type = $phash->{type
} || 'string';
1815 if ($phash->{typetext
}) {
1816 return $phash->{typetext
};
1817 } elsif ($phash->{format_description
}) {
1818 return "<$phash->{format_description}>";
1819 } elsif ($phash->{enum
}) {
1820 return "<" . join(' | ', sort @{$phash->{enum
}}) . ">";
1821 } elsif ($phash->{pattern
}) {
1822 return $phash->{pattern
};
1823 } elsif ($type eq 'integer' || $type eq 'number') {
1824 # NOTE: always access values as number (avoid converion to string)
1825 if (defined($phash->{minimum
}) && defined($phash->{maximum
})) {
1826 return "<$type> (" . ($phash->{minimum
} + 0) . " - " .
1827 ($phash->{maximum
} + 0) . ")";
1828 } elsif (defined($phash->{minimum
})) {
1829 return "<$type> (" . ($phash->{minimum
} + 0) . " - N)";
1830 } elsif (defined($phash->{maximum
})) {
1831 return "<$type> (-N - " . ($phash->{maximum
} + 0) . ")";
1833 } elsif ($type eq 'string') {
1834 if (my $format = $phash->{format
}) {
1835 $format = get_format
($format) if ref($format) ne 'HASH';
1836 if (ref($format) eq 'HASH') {
1838 $list_enums = 1 if $style && $style eq 'config-sub';
1839 return generate_typetext
($format, $list_enums);