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