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     my $default_key;
 510
 511     my $res = {};
 512     foreach my $part (split(/,/, $data)) {
 513         next if $part =~ /^\s*$/;
 514
 515         if ($part =~ /^([^=]+)=(.+)$/) {
 516             my ($k, $v) = ($1, $2);
 517             die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
 518             my $schema = $format->{$k};
 519             if (my $alias = $schema->{alias}) {
 520                 if (my $key_alias = $schema->{keyAlias}) {
 521                     die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
 522                     $res->{$key_alias} = $k;
 523                 }
 524                 $k = $alias;
 525                 $schema = $format->{$k};
 526             }
 527
 528             die "invalid key in comma-separated list property: $k\n" if !$schema;
 529             if ($schema->{type} && $schema->{type} eq 'boolean') {
 530                 $v = 1 if $v =~ m/^(1|on|yes|true)$/i;
 531                 $v = 0 if $v =~ m/^(0|off|no|false)$/i;
 532             }
 533             $res->{$k} = $v;
 534         } elsif ($part !~ /=/) {
 535             die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
 536             foreach my $key (keys %$format) {
 537                 if ($format->{$key}->{default_key}) {
 538                     $default_key = $key;
 539                     if (!$res->{$default_key}) {
 540                         $res->{$default_key} = $part;
 541                         last;
 542                     }
 543                     die "duplicate key in comma-separated list property: $default_key\n";
 544                 }
 545             }
 546             die "value without key, but schema does not define a default key\n" if !$default_key;
 547         } else {
 548             die "missing key in comma-separated list property\n";
 549         }
 550     }
 551
 552     my $errors = {};
 553     check_object($path, $format, $res, $additional_properties, $errors);
 554     if (scalar(%$errors)) {
 555         raise "format error\n", errors => $errors;
 556     }
 557
 558     return $res;
 559 }
 560
 561 sub add_error {
 562     my ($errors, $path, $msg) = @_;
 563
 564     $path = '_root' if !$path;
 565
 566     if ($errors->{$path}) {
 567         $errors->{$path} = join ('\n', $errors->{$path}, $msg);
 568     } else {
 569         $errors->{$path} = $msg;
 570     }
 571 }
 572
 573 sub is_number {
 574     my $value = shift;
 575
 576     # see 'man perlretut'
 577     return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
 578 }
 579
 580 sub is_integer {
 581     my $value = shift;
 582
 583     return $value =~ m/^[+-]?\d+$/;
 584 }
 585
 586 sub check_type {
 587     my ($path, $type, $value, $errors) = @_;
 588
 589     return 1 if !$type;
 590
 591     if (!defined($value)) {
 592         return 1 if $type eq 'null';
 593         die "internal error"
 594     }
 595
 596     if (my $tt = ref($type)) {
 597         if ($tt eq 'ARRAY') {
 598             foreach my $t (@$type) {
 599                 my $tmperr = {};
 600                 check_type($path, $t, $value, $tmperr);
 601                 return 1 if !scalar(%$tmperr);
 602             }
 603             my $ttext = join ('|', @$type);
 604             add_error($errors, $path, "type check ('$ttext') failed");
 605             return undef;
 606         } elsif ($tt eq 'HASH') {
 607             my $tmperr = {};
 608             check_prop($value, $type, $path, $tmperr);
 609             return 1 if !scalar(%$tmperr);
 610             add_error($errors, $path, "type check failed");
 611             return undef;
 612         } else {
 613             die "internal error - got reference type '$tt'";
 614         }
 615
 616     } else {
 617
 618         return 1 if $type eq 'any';
 619
 620         if ($type eq 'null') {
 621             if (defined($value)) {
 622                 add_error($errors, $path, "type check ('$type') failed - value is not null");
 623                 return undef;
 624             }
 625             return 1;
 626         }
 627
 628         my $vt = ref($value);
 629
 630         if ($type eq 'array') {
 631             if (!$vt || $vt ne 'ARRAY') {
 632                 add_error($errors, $path, "type check ('$type') failed");
 633                 return undef;
 634             }
 635             return 1;
 636         } elsif ($type eq 'object') {
 637             if (!$vt || $vt ne 'HASH') {
 638                 add_error($errors, $path, "type check ('$type') failed");
 639                 return undef;
 640             }
 641             return 1;
 642         } elsif ($type eq 'coderef') {
 643             if (!$vt || $vt ne 'CODE') {
 644                 add_error($errors, $path, "type check ('$type') failed");
 645                 return undef;
 646             }
 647             return 1;
 648         } elsif ($type eq 'string' && $vt eq 'Regexp') {
 649             # qr// regexes can be used as strings and make sense for format=regex
 650             return 1;
 651         } else {
 652             if ($vt) {
 653                 add_error($errors, $path, "type check ('$type') failed - got $vt");
 654                 return undef;
 655             } else {
 656                 if ($type eq 'string') {
 657                     return 1; # nothing to check ?
 658                 } elsif ($type eq 'boolean') {
 659                     #if ($value =~ m/^(1|true|yes|on)$/i) {
 660                     if ($value eq '1') {
 661                         return 1;
 662                     #} elsif ($value =~ m/^(0|false|no|off)$/i) {
 663                     } elsif ($value eq '0') {
 664                         return 0;
 665                     } else {
 666                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 667                         return undef;
 668                     }
 669                 } elsif ($type eq 'integer') {
 670                     if (!is_integer($value)) {
 671                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 672                         return undef;
 673                     }
 674                     return 1;
 675                 } elsif ($type eq 'number') {
 676                     if (!is_number($value)) {
 677                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 678                         return undef;
 679                     }
 680                     return 1;
 681                 } else {
 682                     return 1; # no need to verify unknown types
 683                 }
 684             }
 685         }
 686     }
 687
 688     return undef;
 689 }
 690
 691 sub check_object {
 692     my ($path, $schema, $value, $additional_properties, $errors) = @_;
 693
 694     # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
 695
 696     my $st = ref($schema);
 697     if (!$st || $st ne 'HASH') {
 698         add_error($errors, $path, "Invalid schema definition.");
 699         return;
 700     }
 701
 702     my $vt = ref($value);
 703     if (!$vt || $vt ne 'HASH') {
 704         add_error($errors, $path, "an object is required");
 705         return;
 706     }
 707
 708     foreach my $k (keys %$schema) {
 709         check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors);
 710     }
 711
 712     foreach my $k (keys %$value) {
 713
 714         my $newpath =  $path ? "$path.$k" : $k;
 715
 716         if (my $subschema = $schema->{$k}) {
 717             if (my $requires = $subschema->{requires}) {
 718                 if (ref($requires)) {
 719                     #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
 720                     check_prop($value, $requires, $path, $errors);
 721                 } elsif (!defined($value->{$requires})) {
 722                     add_error($errors, $path ? "$path.$requires" : $requires,
 723                               "missing property - '$newpath' requiers this property");
 724                 }
 725             }
 726
 727             next; # value is already checked above
 728         }
 729
 730         if (defined ($additional_properties) && !$additional_properties) {
 731             add_error($errors, $newpath, "property is not defined in schema " .
 732                       "and the schema does not allow additional properties");
 733             next;
 734         }
 735         check_prop($value->{$k}, $additional_properties, $newpath, $errors)
 736             if ref($additional_properties);
 737     }
 738 }
 739
 740 sub check_object_warn {
 741     my ($path, $schema, $value, $additional_properties) = @_;
 742     my $errors = {};
 743     check_object($path, $schema, $value, $additional_properties, $errors);
 744     if (scalar(%$errors)) {
 745         foreach my $k (keys %$errors) {
 746             warn "parse error: $k: $errors->{$k}\n";
 747         }
 748         return 0;
 749     }
 750     return 1;
 751 }
 752
 753 sub check_prop {
 754     my ($value, $schema, $path, $errors) = @_;
 755
 756     die "internal error - no schema" if !$schema;
 757     die "internal error" if !$errors;
 758
 759     #print "check_prop $path\n" if $value;
 760
 761     my $st = ref($schema);
 762     if (!$st || $st ne 'HASH') {
 763         add_error($errors, $path, "Invalid schema definition.");
 764         return;
 765     }
 766
 767     # if it extends another schema, it must pass that schema as well
 768     if($schema->{extends}) {
 769         check_prop($value, $schema->{extends}, $path, $errors);
 770     }
 771
 772     if (!defined ($value)) {
 773         return if $schema->{type} && $schema->{type} eq 'null';
 774         if (!$schema->{optional} && !$schema->{alias} && !$schema->{group}) {
 775             add_error($errors, $path, "property is missing and it is not optional");
 776         }
 777         return;
 778     }
 779
 780     return if !check_type($path, $schema->{type}, $value, $errors);
 781
 782     if ($schema->{disallow}) {
 783         my $tmperr = {};
 784         if (check_type($path, $schema->{disallow}, $value, $tmperr)) {
 785             add_error($errors, $path, "disallowed value was matched");
 786             return;
 787         }
 788     }
 789
 790     if (my $vt = ref($value)) {
 791
 792         if ($vt eq 'ARRAY') {
 793             if ($schema->{items}) {
 794                 my $it = ref($schema->{items});
 795                 if ($it && $it eq 'ARRAY') {
 796                     #die "implement me $path: $vt " . Dumper($schema) ."\n".  Dumper($value);
 797                     die "not implemented";
 798                 } else {
 799                     my $ind = 0;
 800                     foreach my $el (@$value) {
 801                         check_prop($el, $schema->{items}, "${path}[$ind]", $errors);
 802                         $ind++;
 803                     }
 804                 }
 805             }
 806             return;
 807         } elsif ($schema->{properties} || $schema->{additionalProperties}) {
 808             check_object($path, defined($schema->{properties}) ? $schema->{properties} : {},
 809                          $value, $schema->{additionalProperties}, $errors);
 810             return;
 811         }
 812
 813     } else {
 814
 815         if (my $format = $schema->{format}) {
 816             eval { check_format($format, $value, $path); };
 817             if ($@) {
 818                 add_error($errors, $path, "invalid format - $@");
 819                 return;
 820             }
 821         }
 822
 823         if (my $pattern = $schema->{pattern}) {
 824             if ($value !~ m/^$pattern$/) {
 825                 add_error($errors, $path, "value does not match the regex pattern");
 826                 return;
 827             }
 828         }
 829
 830         if (defined (my $max = $schema->{maxLength})) {
 831             if (length($value) > $max) {
 832                 add_error($errors, $path, "value may only be $max characters long");
 833                 return;
 834             }
 835         }
 836
 837         if (defined (my $min = $schema->{minLength})) {
 838             if (length($value) < $min) {
 839                 add_error($errors, $path, "value must be at least $min characters long");
 840                 return;
 841             }
 842         }
 843
 844         if (is_number($value)) {
 845             if (defined (my $max = $schema->{maximum})) {
 846                 if ($value > $max) {
 847                     add_error($errors, $path, "value must have a maximum value of $max");
 848                     return;
 849                 }
 850             }
 851
 852             if (defined (my $min = $schema->{minimum})) {
 853                 if ($value < $min) {
 854                     add_error($errors, $path, "value must have a minimum value of $min");
 855                     return;
 856                 }
 857             }
 858         }
 859
 860         if (my $ea = $schema->{enum}) {
 861
 862             my $found;
 863             foreach my $ev (@$ea) {
 864                 if ($ev eq $value) {
 865                     $found = 1;
 866                     last;
 867                 }
 868             }
 869             if (!$found) {
 870                 add_error($errors, $path, "value '$value' does not have a value in the enumeration '" .
 871                           join(", ", @$ea) . "'");
 872             }
 873         }
 874     }
 875 }
 876
 877 sub validate {
 878     my ($instance, $schema, $errmsg) = @_;
 879
 880     my $errors = {};
 881     $errmsg = "Parameter verification failed.\n" if !$errmsg;
 882
 883     # todo: cycle detection is only needed for debugging, I guess
 884     # we can disable that in the final release
 885     # todo: is there a better/faster way to detect cycles?
 886     my $cycles = 0;
 887     find_cycle($instance, sub { $cycles = 1 });
 888     if ($cycles) {
 889         add_error($errors, undef, "data structure contains recursive cycles");
 890     } elsif ($schema) {
 891         check_prop($instance, $schema, '', $errors);
 892     }
 893
 894     if (scalar(%$errors)) {
 895         raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors;
 896     }
 897
 898     return 1;
 899 }
 900
 901 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
 902 my $default_schema_noref = {
 903     description => "This is the JSON Schema for JSON Schemas.",
 904     type => [ "object" ],
 905     additionalProperties => 0,
 906     properties => {
 907         type => {
 908             type => ["string", "array"],
 909             description => "This is a type definition value. This can be a simple type, or a union type",
 910             optional => 1,
 911             default => "any",
 912             items => {
 913                 type => "string",
 914                 enum => $schema_valid_types,
 915             },
 916             enum => $schema_valid_types,
 917         },
 918         optional => {
 919             type => "boolean",
 920             description => "This indicates that the instance property in the instance object is not required.",
 921             optional => 1,
 922             default => 0
 923         },
 924         properties => {
 925             type => "object",
 926             description => "This is a definition for the properties of an object value",
 927             optional => 1,
 928             default => {},
 929         },
 930         items => {
 931             type => "object",
 932             description => "When the value is an array, this indicates the schema to use to validate each item in an array",
 933             optional => 1,
 934             default => {},
 935         },
 936         additionalProperties => {
 937             type => [ "boolean", "object"],
 938             description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
 939             optional => 1,
 940             default => {},
 941         },
 942         minimum => {
 943             type => "number",
 944             optional => 1,
 945             description => "This indicates the minimum value for the instance property when the type of the instance value is a number.",
 946         },
 947         maximum => {
 948             type => "number",
 949             optional => 1,
 950             description => "This indicates the maximum value for the instance property when the type of the instance value is a number.",
 951         },
 952         minLength => {
 953             type => "integer",
 954             description => "When the instance value is a string, this indicates minimum length of the string",
 955             optional => 1,
 956             minimum => 0,
 957             default => 0,
 958         },
 959         maxLength => {
 960             type => "integer",
 961             description => "When the instance value is a string, this indicates maximum length of the string.",
 962             optional => 1,
 963         },
 964         typetext => {
 965             type => "string",
 966             optional => 1,
 967             description => "A text representation of the type (used to generate documentation).",
 968         },
 969         pattern => {
 970             type => "string",
 971             format => "regex",
 972             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.",
 973             optional => 1,
 974             default => ".*",
 975         },
 976         enum => {
 977             type => "array",
 978             optional => 1,
 979             description => "This provides an enumeration of possible values that are valid for the instance property.",
 980         },
 981         description => {
 982             type => "string",
 983             optional => 1,
 984             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).",
 985         },
 986         verbose_description => {
 987             type => "string",
 988             optional => 1,
 989             description => "This provides a more verbose description.",
 990         },
 991         format_description => {
 992             type => "string",
 993             optional => 1,
 994             description => "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
 995         },
 996         title => {
 997             type => "string",
 998             optional => 1,
 999             description => "This provides the title of the property",
1000         },
1001         requires => {
1002             type => [ "string", "object" ],
1003             optional => 1,
1004             description => "indicates a required property or a schema that must be validated if this property is present",
1005         },
1006         format => {
1007             type => [ "string", "object" ],
1008             optional => 1,
1009             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",
1010         },
1011         default_key => {
1012             type => "boolean",
1013             optional => 1,
1014             description => "Whether this is the default key in a comma separated list property string.",
1015         },
1016         alias => {
1017             type => 'string',
1018             optional => 1,
1019             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.",
1020         },
1021         keyAlias => {
1022             type => 'string',
1023             optional => 1,
1024             description => "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1025             requires => 'alias',
1026         },
1027         default => {
1028             type => "any",
1029             optional => 1,
1030             description => "This indicates the default for the instance property."
1031         },
1032         completion => {
1033             type => 'coderef',
1034             description => "Bash completion function. This function should return a list of possible values.",
1035             optional => 1,
1036         },
1037         disallow => {
1038             type => "object",
1039             optional => 1,
1040             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.",
1041         },
1042         extends => {
1043             type => "object",
1044             optional => 1,
1045             description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1046             default => {},
1047         },
1048         # this is from hyper schema
1049         links => {
1050             type => "array",
1051             description => "This defines the link relations of the instance objects",
1052             optional => 1,
1053             items => {
1054                 type => "object",
1055                 properties => {
1056                     href => {
1057                         type => "string",
1058                         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",
1059                     },
1060                     rel => {
1061                         type => "string",
1062                         description => "This is the name of the link relation",
1063                         optional => 1,
1064                         default => "full",
1065                     },
1066                     method => {
1067                         type => "string",
1068                         description => "For submission links, this defines the method that should be used to access the target resource",
1069                         optional => 1,
1070                         default => "GET",
1071                     },
1072                 },
1073             },
1074         },
1075     }
1076 };
1077
1078 my $default_schema = Storable::dclone($default_schema_noref);
1079
1080 $default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
1081 $default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
1082
1083 $default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
1084 $default_schema->{properties}->{items}->{additionalProperties} = 0;
1085
1086 $default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
1087 $default_schema->{properties}->{disallow}->{additionalProperties} = 0;
1088
1089 $default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
1090 $default_schema->{properties}->{requires}->{additionalProperties} = 0;
1091
1092 $default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
1093 $default_schema->{properties}->{extends}->{additionalProperties} = 0;
1094
1095 my $method_schema = {
1096     type => "object",
1097     additionalProperties => 0,
1098     properties => {
1099         description => {
1100             description => "This a description of the method",
1101             optional => 1,
1102         },
1103         name => {
1104             type =>  'string',
1105             description => "This indicates the name of the function to call.",
1106             optional => 1,
1107             requires => {
1108                 additionalProperties => 1,
1109                 properties => {
1110                     name => {},
1111                     description => {},
1112                     code => {},
1113                     method => {},
1114                     parameters => {},
1115                     path => {},
1116                     parameters => {},
1117                     returns => {},
1118                 }
1119             },
1120         },
1121         method => {
1122             type =>  'string',
1123             description => "The HTTP method name.",
1124             enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
1125             optional => 1,
1126         },
1127         protected => {
1128             type => 'boolean',
1129             description => "Method needs special privileges - only pvedaemon can execute it",
1130             optional => 1,
1131         },
1132         proxyto => {
1133             type =>  'string',
1134             description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1135             optional => 1,
1136         },
1137         permissions => {
1138             type => 'object',
1139             description => "Required access permissions. By default only 'root' is allowed to access this method.",
1140             optional => 1,
1141             additionalProperties => 0,
1142             properties => {
1143                 description => {
1144                      description => "Describe access permissions.",
1145                      optional => 1,
1146                 },
1147                 user => {
1148                     description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1149                     type => 'string',
1150                     enum => ['all', 'world'],
1151                     optional => 1,
1152                 },
1153                 check => {
1154                     description => "Array of permission checks (prefix notation).",
1155                     type => 'array',
1156                     optional => 1
1157                 },
1158             },
1159         },
1160         match_name => {
1161             description => "Used internally",
1162             optional => 1,
1163         },
1164         match_re => {
1165             description => "Used internally",
1166             optional => 1,
1167         },
1168         path => {
1169             type =>  'string',
1170             description => "path for URL matching (uri template)",
1171         },
1172         fragmentDelimiter => {
1173             type => 'string',
1174             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.",
1175             optional => 1,
1176         },
1177         parameters => {
1178             type => 'object',
1179             description => "JSON Schema for parameters.",
1180             optional => 1,
1181         },
1182         formatter => {
1183             type => 'object',
1184             description => "Used to store page formatter information (set by PVE::RESTHandler->register_page_formatter).",
1185             optional => 1,
1186         },
1187         returns => {
1188             type => 'object',
1189             description => "JSON Schema for return value.",
1190             optional => 1,
1191         },
1192         code => {
1193             type => 'coderef',
1194             description => "method implementaion (code reference)",
1195             optional => 1,
1196         },
1197         subclass => {
1198             type => 'string',
1199             description => "Delegate call to this class (perl class string).",
1200             optional => 1,
1201             requires => {
1202                 additionalProperties => 0,
1203                 properties => {
1204                     subclass => {},
1205                     path => {},
1206                     match_name => {},
1207                     match_re => {},
1208                     fragmentDelimiter => { optional => 1 }
1209                 }
1210             },
1211         },
1212     },
1213
1214 };
1215
1216 sub validate_schema {
1217     my ($schema) = @_;
1218
1219     my $errmsg = "internal error - unable to verify schema\n";
1220     validate($schema, $default_schema, $errmsg);
1221 }
1222
1223 sub validate_method_info {
1224     my $info = shift;
1225
1226     my $errmsg = "internal error - unable to verify method info\n";
1227     validate($info, $method_schema, $errmsg);
1228
1229     validate_schema($info->{parameters}) if $info->{parameters};
1230     validate_schema($info->{returns}) if $info->{returns};
1231 }
1232
1233 # run a self test on load
1234 # make sure we can verify the default schema
1235 validate_schema($default_schema_noref);
1236 validate_schema($method_schema);
1237
1238 # and now some utility methods (used by pve api)
1239 sub method_get_child_link {
1240     my ($info) = @_;
1241
1242     return undef if !$info;
1243
1244     my $schema = $info->{returns};
1245     return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
1246
1247     my $links = $schema->{links};
1248     return undef if !$links;
1249
1250     my $found;
1251     foreach my $lnk (@$links) {
1252         if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
1253             $found = $lnk;
1254             last;
1255         }
1256     }
1257
1258     return $found;
1259 }
1260
1261 # a way to parse command line parameters, using a
1262 # schema to configure Getopt::Long
1263 sub get_options {
1264     my ($schema, $args, $arg_param, $fixed_param, $pwcallback) = @_;
1265
1266     if (!$schema || !$schema->{properties}) {
1267         raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1268             if scalar(@$args) != 0;
1269         return {};
1270     }
1271
1272     my $list_param;
1273     if ($arg_param && !ref($arg_param)) {
1274         my $pd = $schema->{properties}->{$arg_param};
1275         die "expected list format $pd->{format}"
1276             if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
1277         $list_param = $arg_param;
1278     }
1279
1280     my @getopt = ();
1281     foreach my $prop (keys %{$schema->{properties}}) {
1282         my $pd = $schema->{properties}->{$prop};
1283         next if $list_param && $prop eq $list_param;
1284         next if defined($fixed_param->{$prop});
1285
1286         if ($prop eq 'password' && $pwcallback) {
1287             # we do not accept plain password on input line, instead
1288             # we turn this into a boolean option and ask for password below
1289             # using $pwcallback() (for security reasons).
1290             push @getopt, "$prop";
1291         } elsif ($pd->{type} eq 'boolean') {
1292             push @getopt, "$prop:s";
1293         } else {
1294             if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
1295                 push @getopt, "$prop=s@";
1296             } else {
1297                 push @getopt, "$prop=s";
1298             }
1299         }
1300     }
1301
1302     Getopt::Long::Configure('prefix_pattern=(--|-)');
1303
1304     my $opts = {};
1305     raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
1306         if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
1307
1308     if (@$args) {
1309         if ($list_param) {
1310             $opts->{$list_param} = $args;
1311             $args = [];
1312         } elsif (ref($arg_param)) {
1313             foreach my $arg_name (@$arg_param) {
1314                 if ($opts->{'extra-args'}) {
1315                     raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
1316                 }
1317                 if ($arg_name eq 'extra-args') {
1318                     $opts->{'extra-args'} = $args;
1319                     $args = [];
1320                     next;
1321                 }
1322                 raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
1323                 $opts->{$arg_name} = shift @$args;
1324             }
1325             raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
1326         } else {
1327             raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1328                 if scalar(@$args) != 0;
1329         }
1330     }
1331
1332     if (my $pd = $schema->{properties}->{password}) {
1333         if ($pd->{type} ne 'boolean' && $pwcallback) {
1334             if ($opts->{password} || !$pd->{optional}) {
1335                 $opts->{password} = &$pwcallback();
1336             }
1337         }
1338     }
1339
1340     $opts = PVE::Tools::decode_utf8_parameters($opts);
1341
1342     foreach my $p (keys %$opts) {
1343         if (my $pd = $schema->{properties}->{$p}) {
1344             if ($pd->{type} eq 'boolean') {
1345                 if ($opts->{$p} eq '') {
1346                     $opts->{$p} = 1;
1347                 } elsif ($opts->{$p} =~ m/^(1|true|yes|on)$/i) {
1348                     $opts->{$p} = 1;
1349                 } elsif ($opts->{$p} =~ m/^(0|false|no|off)$/i) {
1350                     $opts->{$p} = 0;
1351                 } else {
1352                     raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
1353                 }
1354             } elsif ($pd->{format}) {
1355
1356                 if ($pd->{format} =~ m/-list/) {
1357                     # allow --vmid 100 --vmid 101 and --vmid 100,101
1358                     # allow --dow mon --dow fri and --dow mon,fri
1359                     $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1360                 } elsif ($pd->{format} =~ m/-alist/) {
1361                     # we encode array as \0 separated strings
1362                     # Note: CGI.pm also use this encoding
1363                     if (scalar(@{$opts->{$p}}) != 1) {
1364                         $opts->{$p} = join("\0", @{$opts->{$p}});
1365                     } else {
1366                         # st that split_list knows it is \0 terminated
1367                         my $v = $opts->{$p}->[0];
1368                         $opts->{$p} = "$v\0";
1369                     }
1370                 }
1371             }
1372         }
1373     }
1374
1375     foreach my $p (keys %$fixed_param) {
1376         $opts->{$p} = $fixed_param->{$p};
1377     }
1378
1379     return $opts;
1380 }
1381
1382 # A way to parse configuration data by giving a json schema
1383 sub parse_config {
1384     my ($schema, $filename, $raw) = @_;
1385
1386     # do fast check (avoid validate_schema($schema))
1387     die "got strange schema" if !$schema->{type} ||
1388         !$schema->{properties} || $schema->{type} ne 'object';
1389
1390     my $cfg = {};
1391
1392     while ($raw =~ /^\s*(.+?)\s*$/gm) {
1393         my $line = $1;
1394
1395         next if $line =~ /^#/;
1396
1397         if ($line =~ m/^(\S+?):\s*(.*)$/) {
1398             my $key = $1;
1399             my $value = $2;
1400             if ($schema->{properties}->{$key} &&
1401                 $schema->{properties}->{$key}->{type} eq 'boolean') {
1402
1403                 $value = 1 if $value =~ m/^(1|on|yes|true)$/i;
1404                 $value = 0 if $value =~ m/^(0|off|no|false)$/i;
1405             }
1406             $cfg->{$key} = $value;
1407         } else {
1408             warn "ignore config line: $line\n"
1409         }
1410     }
1411
1412     my $errors = {};
1413     check_prop($cfg, $schema, '', $errors);
1414
1415     foreach my $k (keys %$errors) {
1416         warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1417         delete $cfg->{$k};
1418     }
1419
1420     return $cfg;
1421 }
1422
1423 # generate simple key/value file
1424 sub dump_config {
1425     my ($schema, $filename, $cfg) = @_;
1426
1427     # do fast check (avoid validate_schema($schema))
1428     die "got strange schema" if !$schema->{type} ||
1429         !$schema->{properties} || $schema->{type} ne 'object';
1430
1431     validate($cfg, $schema, "validation error in '$filename'\n");
1432
1433     my $data = '';
1434
1435     foreach my $k (keys %$cfg) {
1436         $data .= "$k: $cfg->{$k}\n";
1437     }
1438
1439     return $data;
1440 }
1441
1442 # helpers used to generate our manual pages
1443
1444 my $find_schema_default_key = sub {
1445     my ($format) = @_;
1446
1447     my $default_key;
1448     my $keyAliasProps = {};
1449
1450     foreach my $key (keys %$format) {
1451         my $phash = $format->{$key};
1452         if ($phash->{default_key}) {
1453             die "multiple default keys in schema ($default_key, $key)\n"
1454                 if defined($default_key);
1455             die "default key '$key' is an alias - this is not allowed\n"
1456                 if defined($phash->{alias});
1457             die "default key '$key' with keyAlias attribute is not allowed\n"
1458                 if $phash->{keyAlias};
1459             $default_key = $key;
1460         }
1461         my $key_alias = $phash->{keyAlias};
1462         die "found keyAlias without 'alias definition for '$key'\n"
1463             if $key_alias && !$phash->{alias};
1464
1465         if ($phash->{alias} && $key_alias) {
1466             die "inconsistent keyAlias '$key_alias' definition"
1467                 if defined($keyAliasProps->{$key_alias}) &&
1468                 $keyAliasProps->{$key_alias} ne $phash->{alias};
1469             $keyAliasProps->{$key_alias} = $phash->{alias};
1470         }
1471     }
1472
1473     return wantarray ? ($default_key, $keyAliasProps) : $default_key;
1474 };
1475
1476 sub generate_typetext {
1477     my ($format) = @_;
1478
1479     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1480
1481     my $res = '';
1482     my $add_sep = 0;
1483
1484     my $add_option_string = sub {
1485         my ($text, $optional) = @_;
1486
1487         if ($add_sep) {
1488             $text = ",$text";
1489             $res .= ' ';
1490         }
1491         $text = "[$text]" if $optional;
1492         $res .= $text;
1493         $add_sep = 1;
1494     };
1495
1496     my $format_key_value = sub {
1497         my ($key, $phash) = @_;
1498
1499         die "internal error" if defined($phash->{alias});
1500
1501         my $keytext = $key;
1502
1503         my $typetext = '';
1504
1505         if (my $desc = $phash->{format_description}) {
1506             $typetext .= "<$desc>";
1507         } elsif (my $text = $phash->{typetext}) {
1508             $typetext .= $text;
1509         } elsif (my $enum = $phash->{enum}) {
1510             $typetext .= '<' . join('|', @$enum) . '>';
1511         } elsif ($phash->{type} eq 'boolean') {
1512             $typetext .= '<1|0>';
1513         } elsif ($phash->{type} eq 'integer') {
1514             $typetext .= '<integer>';
1515         } elsif ($phash->{type} eq 'number') {
1516             $typetext .= '<number>';
1517         } else {
1518             die "internal error: neither format_description nor typetext found for option '$key'";
1519         }
1520
1521         if (defined($default_key) && ($default_key eq $key)) {
1522             &$add_option_string("[$keytext=]$typetext", $phash->{optional});
1523         } else {
1524             &$add_option_string("$keytext=$typetext", $phash->{optional});
1525         }
1526     };
1527
1528     my $done = {};
1529
1530     my $cond_add_key = sub {
1531         my ($key) = @_;
1532
1533         return if $done->{$key}; # avoid duplicates
1534
1535         $done->{$key} = 1;
1536
1537         my $phash = $format->{$key};
1538
1539         return if !$phash; # should not happen
1540
1541         return if $phash->{alias};
1542
1543         &$format_key_value($key, $phash);
1544
1545     };
1546
1547     &$cond_add_key($default_key) if defined($default_key);
1548
1549     # add required keys first
1550     foreach my $key (sort keys %$format) {
1551         my $phash = $format->{$key};
1552         &$cond_add_key($key) if $phash && !$phash->{optional};
1553     }
1554
1555     # add the rest
1556     foreach my $key (sort keys %$format) {
1557         &$cond_add_key($key);
1558     }
1559
1560     foreach my $keyAlias (sort keys %$keyAliasProps) {
1561         &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
1562     }
1563
1564     return $res;
1565 }
1566
1567 sub print_property_string {
1568     my ($data, $format, $skip, $path) = @_;
1569
1570     if (ref($format) ne 'HASH') {
1571         my $schema = get_format($format);
1572         die "not a valid format: $format\n" if !$schema;
1573         $format = $schema;
1574     }
1575
1576     my $errors = {};
1577     check_object($path, $format, $data, undef, $errors);
1578     if (scalar(%$errors)) {
1579         raise "format error", errors => $errors;
1580     }
1581
1582     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1583
1584     my $res = '';
1585     my $add_sep = 0;
1586
1587     my $add_option_string = sub {
1588         my ($text) = @_;
1589
1590         $res .= ',' if $add_sep;
1591         $res .= $text;
1592         $add_sep = 1;
1593     };
1594
1595     my $format_value = sub {
1596         my ($key, $value, $format) = @_;
1597
1598         if (defined($format) && ($format eq 'disk-size')) {
1599             return format_size($value);
1600         } else {
1601             die "illegal value with commas for $key\n" if $value =~ /,/;
1602             return $value;
1603         }
1604     };
1605
1606     my $done = { map { $_ => 1 } @$skip };
1607
1608     my $cond_add_key = sub {
1609         my ($key, $isdefault) = @_;
1610
1611         return if $done->{$key}; # avoid duplicates
1612
1613         $done->{$key} = 1;
1614
1615         my $value = $data->{$key};
1616
1617         return if !defined($value);
1618
1619         my $phash = $format->{$key};
1620
1621         # try to combine values if we have key aliases
1622         if (my $combine = $keyAliasProps->{$key}) {
1623             if (defined(my $combine_value = $data->{$combine})) {
1624                 my $combine_format = $format->{$combine}->{format};
1625                 my $value_str = &$format_value($key, $value, $phash->{format});
1626                 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
1627                 &$add_option_string("${value_str}=${combine_str}");
1628                 $done->{$combine} = 1;
1629                 return;
1630             }
1631         }
1632
1633         if ($phash && $phash->{alias}) {
1634             $phash = $format->{$phash->{alias}};
1635         }
1636
1637         die "invalid key '$key'\n" if !$phash;
1638         die "internal error" if defined($phash->{alias});
1639
1640         my $value_str = &$format_value($key, $value, $phash->{format});
1641         if ($isdefault) {
1642             &$add_option_string($value_str);
1643         } else {
1644             &$add_option_string("$key=${value_str}");
1645         }
1646     };
1647
1648     # add default key first
1649     &$cond_add_key($default_key, 1) if defined($default_key);
1650
1651     # add required keys first
1652     foreach my $key (sort keys %$data) {
1653         my $phash = $format->{$key};
1654         &$cond_add_key($key) if $phash && !$phash->{optional};
1655     }
1656
1657     # add the rest
1658     foreach my $key (sort keys %$data) {
1659         &$cond_add_key($key);
1660     }
1661
1662     return $res;
1663 }
1664
1665 sub schema_get_type_text {
1666     my ($phash) = @_;
1667
1668     my $type = $phash->{type} || 'string';
1669
1670     if ($phash->{typetext}) {
1671         return $phash->{typetext};
1672     } elsif ($phash->{format_description}) {
1673         return "<$phash->{format_description}>";
1674     } elsif ($phash->{enum}) {
1675         return "(" . join(' | ', sort @{$phash->{enum}}) . ")";
1676     } elsif ($phash->{pattern}) {
1677         return $phash->{pattern};
1678     } elsif ($type eq 'integer' || $type eq 'number') {
1679         # NOTE: always access values as number (avoid converion to string)
1680         if (defined($phash->{minimum}) && defined($phash->{maximum})) {
1681             return "$type (" . ($phash->{minimum} + 0) . " - " .
1682                 ($phash->{maximum} + 0) . ")";
1683         } elsif (defined($phash->{minimum})) {
1684             return "$type (" . ($phash->{minimum} + 0) . " - N)";
1685         } elsif (defined($phash->{maximum})) {
1686             return "$type (-N - " . ($phash->{maximum} + 0) . ")";
1687         }
1688     } elsif ($type eq 'string') {
1689         if (my $format = $phash->{format}) {
1690             $format = get_format($format) if ref($format) ne 'HASH';
1691             if (ref($format) eq 'HASH') {
1692                 return generate_typetext($format);
1693             }
1694         }
1695     }
1696
1697     return $type;
1698 }
1699
1700 1;