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