src/PVE/JSONSchema.pm

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