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         verbose_description => {
 982             type => "string",
 983             optional => 1,
 984             description => "This provides a more verbose description.",
 985         },
 986         format_description => {
 987             type => "string",
 988             optional => 1,
 989             description => "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
 990         },
 991         title => {
 992             type => "string",
 993             optional => 1,
 994             description => "This provides the title of the property",
 995         },
 996         requires => {
 997             type => [ "string", "object" ],
 998             optional => 1,
 999             description => "indicates a required property or a schema that must be validated if this property is present",
1000         },
1001         format => {
1002             type => [ "string", "object" ],
1003             optional => 1,
1004             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",
1005         },
1006         default_key => {
1007             type => "boolean",
1008             optional => 1,
1009             description => "Whether this is the default key in a comma separated list property string.",
1010         },
1011         alias => {
1012             type => 'string',
1013             optional => 1,
1014             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.",
1015         },
1016         keyAlias => {
1017             type => 'string',
1018             optional => 1,
1019             description => "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1020             requires => 'alias',
1021         },
1022         default => {
1023             type => "any",
1024             optional => 1,
1025             description => "This indicates the default for the instance property."
1026         },
1027         completion => {
1028             type => 'coderef',
1029             description => "Bash completion function. This function should return a list of possible values.",
1030             optional => 1,
1031         },
1032         disallow => {
1033             type => "object",
1034             optional => 1,
1035             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.",
1036         },
1037         extends => {
1038             type => "object",
1039             optional => 1,
1040             description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1041             default => {},
1042         },
1043         # this is from hyper schema
1044         links => {
1045             type => "array",
1046             description => "This defines the link relations of the instance objects",
1047             optional => 1,
1048             items => {
1049                 type => "object",
1050                 properties => {
1051                     href => {
1052                         type => "string",
1053                         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",
1054                     },
1055                     rel => {
1056                         type => "string",
1057                         description => "This is the name of the link relation",
1058                         optional => 1,
1059                         default => "full",
1060                     },
1061                     method => {
1062                         type => "string",
1063                         description => "For submission links, this defines the method that should be used to access the target resource",
1064                         optional => 1,
1065                         default => "GET",
1066                     },
1067                 },
1068             },
1069         },
1070     }
1071 };
1072
1073 my $default_schema = Storable::dclone($default_schema_noref);
1074
1075 $default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
1076 $default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
1077
1078 $default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
1079 $default_schema->{properties}->{items}->{additionalProperties} = 0;
1080
1081 $default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
1082 $default_schema->{properties}->{disallow}->{additionalProperties} = 0;
1083
1084 $default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
1085 $default_schema->{properties}->{requires}->{additionalProperties} = 0;
1086
1087 $default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
1088 $default_schema->{properties}->{extends}->{additionalProperties} = 0;
1089
1090 my $method_schema = {
1091     type => "object",
1092     additionalProperties => 0,
1093     properties => {
1094         description => {
1095             description => "This a description of the method",
1096             optional => 1,
1097         },
1098         name => {
1099             type =>  'string',
1100             description => "This indicates the name of the function to call.",
1101             optional => 1,
1102             requires => {
1103                 additionalProperties => 1,
1104                 properties => {
1105                     name => {},
1106                     description => {},
1107                     code => {},
1108                     method => {},
1109                     parameters => {},
1110                     path => {},
1111                     parameters => {},
1112                     returns => {},
1113                 }
1114             },
1115         },
1116         method => {
1117             type =>  'string',
1118             description => "The HTTP method name.",
1119             enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
1120             optional => 1,
1121         },
1122         protected => {
1123             type => 'boolean',
1124             description => "Method needs special privileges - only pvedaemon can execute it",
1125             optional => 1,
1126         },
1127         proxyto => {
1128             type =>  'string',
1129             description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1130             optional => 1,
1131         },
1132         permissions => {
1133             type => 'object',
1134             description => "Required access permissions. By default only 'root' is allowed to access this method.",
1135             optional => 1,
1136             additionalProperties => 0,
1137             properties => {
1138                 description => {
1139                      description => "Describe access permissions.",
1140                      optional => 1,
1141                 },
1142                 user => {
1143                     description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1144                     type => 'string',
1145                     enum => ['all', 'world'],
1146                     optional => 1,
1147                 },
1148                 check => {
1149                     description => "Array of permission checks (prefix notation).",
1150                     type => 'array',
1151                     optional => 1
1152                 },
1153             },
1154         },
1155         match_name => {
1156             description => "Used internally",
1157             optional => 1,
1158         },
1159         match_re => {
1160             description => "Used internally",
1161             optional => 1,
1162         },
1163         path => {
1164             type =>  'string',
1165             description => "path for URL matching (uri template)",
1166         },
1167         fragmentDelimiter => {
1168             type => 'string',
1169             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.",
1170             optional => 1,
1171         },
1172         parameters => {
1173             type => 'object',
1174             description => "JSON Schema for parameters.",
1175             optional => 1,
1176         },
1177         formatter => {
1178             type => 'object',
1179             description => "Used to store page formatter information (set by PVE::RESTHandler->register_page_formatter).",
1180             optional => 1,
1181         },
1182         returns => {
1183             type => 'object',
1184             description => "JSON Schema for return value.",
1185             optional => 1,
1186         },
1187         code => {
1188             type => 'coderef',
1189             description => "method implementaion (code reference)",
1190             optional => 1,
1191         },
1192         subclass => {
1193             type => 'string',
1194             description => "Delegate call to this class (perl class string).",
1195             optional => 1,
1196             requires => {
1197                 additionalProperties => 0,
1198                 properties => {
1199                     subclass => {},
1200                     path => {},
1201                     match_name => {},
1202                     match_re => {},
1203                     fragmentDelimiter => { optional => 1 }
1204                 }
1205             },
1206         },
1207     },
1208
1209 };
1210
1211 sub validate_schema {
1212     my ($schema) = @_;
1213
1214     my $errmsg = "internal error - unable to verify schema\n";
1215     validate($schema, $default_schema, $errmsg);
1216 }
1217
1218 sub validate_method_info {
1219     my $info = shift;
1220
1221     my $errmsg = "internal error - unable to verify method info\n";
1222     validate($info, $method_schema, $errmsg);
1223
1224     validate_schema($info->{parameters}) if $info->{parameters};
1225     validate_schema($info->{returns}) if $info->{returns};
1226 }
1227
1228 # run a self test on load
1229 # make sure we can verify the default schema
1230 validate_schema($default_schema_noref);
1231 validate_schema($method_schema);
1232
1233 # and now some utility methods (used by pve api)
1234 sub method_get_child_link {
1235     my ($info) = @_;
1236
1237     return undef if !$info;
1238
1239     my $schema = $info->{returns};
1240     return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
1241
1242     my $links = $schema->{links};
1243     return undef if !$links;
1244
1245     my $found;
1246     foreach my $lnk (@$links) {
1247         if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
1248             $found = $lnk;
1249             last;
1250         }
1251     }
1252
1253     return $found;
1254 }
1255
1256 # a way to parse command line parameters, using a
1257 # schema to configure Getopt::Long
1258 sub get_options {
1259     my ($schema, $args, $arg_param, $fixed_param, $pwcallback) = @_;
1260
1261     if (!$schema || !$schema->{properties}) {
1262         raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1263             if scalar(@$args) != 0;
1264         return {};
1265     }
1266
1267     my $list_param;
1268     if ($arg_param && !ref($arg_param)) {
1269         my $pd = $schema->{properties}->{$arg_param};
1270         die "expected list format $pd->{format}"
1271             if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
1272         $list_param = $arg_param;
1273     }
1274
1275     my @getopt = ();
1276     foreach my $prop (keys %{$schema->{properties}}) {
1277         my $pd = $schema->{properties}->{$prop};
1278         next if $list_param && $prop eq $list_param;
1279         next if defined($fixed_param->{$prop});
1280
1281         if ($prop eq 'password' && $pwcallback) {
1282             # we do not accept plain password on input line, instead
1283             # we turn this into a boolean option and ask for password below
1284             # using $pwcallback() (for security reasons).
1285             push @getopt, "$prop";
1286         } elsif ($pd->{type} eq 'boolean') {
1287             push @getopt, "$prop:s";
1288         } else {
1289             if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
1290                 push @getopt, "$prop=s@";
1291             } else {
1292                 push @getopt, "$prop=s";
1293             }
1294         }
1295     }
1296
1297     Getopt::Long::Configure('prefix_pattern=(--|-)');
1298
1299     my $opts = {};
1300     raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
1301         if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
1302
1303     if (@$args) {
1304         if ($list_param) {
1305             $opts->{$list_param} = $args;
1306             $args = [];
1307         } elsif (ref($arg_param)) {
1308             foreach my $arg_name (@$arg_param) {
1309                 if ($opts->{'extra-args'}) {
1310                     raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
1311                 }
1312                 if ($arg_name eq 'extra-args') {
1313                     $opts->{'extra-args'} = $args;
1314                     $args = [];
1315                     next;
1316                 }
1317                 raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
1318                 $opts->{$arg_name} = shift @$args;
1319             }
1320             raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
1321         } else {
1322             raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1323                 if scalar(@$args) != 0;
1324         }
1325     }
1326
1327     if (my $pd = $schema->{properties}->{password}) {
1328         if ($pd->{type} ne 'boolean' && $pwcallback) {
1329             if ($opts->{password} || !$pd->{optional}) {
1330                 $opts->{password} = &$pwcallback();
1331             }
1332         }
1333     }
1334
1335     $opts = PVE::Tools::decode_utf8_parameters($opts);
1336
1337     foreach my $p (keys %$opts) {
1338         if (my $pd = $schema->{properties}->{$p}) {
1339             if ($pd->{type} eq 'boolean') {
1340                 if ($opts->{$p} eq '') {
1341                     $opts->{$p} = 1;
1342                 } elsif ($opts->{$p} =~ m/^(1|true|yes|on)$/i) {
1343                     $opts->{$p} = 1;
1344                 } elsif ($opts->{$p} =~ m/^(0|false|no|off)$/i) {
1345                     $opts->{$p} = 0;
1346                 } else {
1347                     raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
1348                 }
1349             } elsif ($pd->{format}) {
1350
1351                 if ($pd->{format} =~ m/-list/) {
1352                     # allow --vmid 100 --vmid 101 and --vmid 100,101
1353                     # allow --dow mon --dow fri and --dow mon,fri
1354                     $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1355                 } elsif ($pd->{format} =~ m/-alist/) {
1356                     # we encode array as \0 separated strings
1357                     # Note: CGI.pm also use this encoding
1358                     if (scalar(@{$opts->{$p}}) != 1) {
1359                         $opts->{$p} = join("\0", @{$opts->{$p}});
1360                     } else {
1361                         # st that split_list knows it is \0 terminated
1362                         my $v = $opts->{$p}->[0];
1363                         $opts->{$p} = "$v\0";
1364                     }
1365                 }
1366             }
1367         }
1368     }
1369
1370     foreach my $p (keys %$fixed_param) {
1371         $opts->{$p} = $fixed_param->{$p};
1372     }
1373
1374     return $opts;
1375 }
1376
1377 # A way to parse configuration data by giving a json schema
1378 sub parse_config {
1379     my ($schema, $filename, $raw) = @_;
1380
1381     # do fast check (avoid validate_schema($schema))
1382     die "got strange schema" if !$schema->{type} ||
1383         !$schema->{properties} || $schema->{type} ne 'object';
1384
1385     my $cfg = {};
1386
1387     while ($raw =~ /^\s*(.+?)\s*$/gm) {
1388         my $line = $1;
1389
1390         next if $line =~ /^#/;
1391
1392         if ($line =~ m/^(\S+?):\s*(.*)$/) {
1393             my $key = $1;
1394             my $value = $2;
1395             if ($schema->{properties}->{$key} &&
1396                 $schema->{properties}->{$key}->{type} eq 'boolean') {
1397
1398                 $value = 1 if $value =~ m/^(1|on|yes|true)$/i;
1399                 $value = 0 if $value =~ m/^(0|off|no|false)$/i;
1400             }
1401             $cfg->{$key} = $value;
1402         } else {
1403             warn "ignore config line: $line\n"
1404         }
1405     }
1406
1407     my $errors = {};
1408     check_prop($cfg, $schema, '', $errors);
1409
1410     foreach my $k (keys %$errors) {
1411         warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1412         delete $cfg->{$k};
1413     }
1414
1415     return $cfg;
1416 }
1417
1418 # generate simple key/value file
1419 sub dump_config {
1420     my ($schema, $filename, $cfg) = @_;
1421
1422     # do fast check (avoid validate_schema($schema))
1423     die "got strange schema" if !$schema->{type} ||
1424         !$schema->{properties} || $schema->{type} ne 'object';
1425
1426     validate($cfg, $schema, "validation error in '$filename'\n");
1427
1428     my $data = '';
1429
1430     foreach my $k (keys %$cfg) {
1431         $data .= "$k: $cfg->{$k}\n";
1432     }
1433
1434     return $data;
1435 }
1436
1437 # helpers used to generate our manual pages
1438
1439 my $find_schema_default_key = sub {
1440     my ($format) = @_;
1441
1442     my $default_key;
1443     my $keyAliasProps = {};
1444
1445     foreach my $key (keys %$format) {
1446         my $phash = $format->{$key};
1447         if ($phash->{default_key}) {
1448             die "multiple default keys in schema ($default_key, $key)\n"
1449                 if defined($default_key);
1450             die "default key '$key' is an alias - this is not allowed\n"
1451                 if defined($phash->{alias});
1452             die "default key '$key' with keyAlias attribute is not allowed\n"
1453                 if $phash->{keyAlias};
1454             $default_key = $key;
1455         }
1456         my $key_alias = $phash->{keyAlias};
1457         die "found keyAlias without 'alias definition for '$key'\n"
1458             if $key_alias && !$phash->{alias};
1459
1460         if ($phash->{alias} && $key_alias) {
1461             die "inconsistent keyAlias '$key_alias' definition"
1462                 if defined($keyAliasProps->{$key_alias}) &&
1463                 $keyAliasProps->{$key_alias} ne $phash->{alias};
1464             $keyAliasProps->{$key_alias} = $phash->{alias};
1465         }
1466     }
1467
1468     return wantarray ? ($default_key, $keyAliasProps) : $default_key;
1469 };
1470
1471 sub generate_typetext {
1472     my ($format) = @_;
1473
1474     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1475
1476     my $res = '';
1477     my $add_sep = 0;
1478
1479     my $add_option_string = sub {
1480         my ($text, $optional) = @_;
1481
1482         if ($add_sep) {
1483             $text = ",$text";
1484             $res .= ' ';
1485         }
1486         $text = "[$text]" if $optional;
1487         $res .= $text;
1488         $add_sep = 1;
1489     };
1490
1491     my $format_key_value = sub {
1492         my ($key, $phash) = @_;
1493
1494         die "internal error" if defined($phash->{alias});
1495
1496         my $keytext = $key;
1497
1498         my $typetext = '';
1499
1500         if (my $desc = $phash->{format_description}) {
1501             $typetext .= "<$desc>";
1502         } elsif (my $text = $phash->{typetext}) {
1503             $typetext .= $text;
1504         } elsif (my $enum = $phash->{enum}) {
1505             $typetext .= '<' . join('|', @$enum) . '>';
1506         } elsif ($phash->{type} eq 'boolean') {
1507             $typetext .= '<1|0>';
1508         } elsif ($phash->{type} eq 'integer') {
1509             $typetext .= '<integer>';
1510         } elsif ($phash->{type} eq 'number') {
1511             $typetext .= '<number>';
1512         } else {
1513             die "internal error: neither format_description nor typetext found for option '$key'";
1514         }
1515
1516         if (defined($default_key) && ($default_key eq $key)) {
1517             &$add_option_string("[$keytext=]$typetext", $phash->{optional});
1518         } else {
1519             &$add_option_string("$keytext=$typetext", $phash->{optional});
1520         }
1521     };
1522
1523     my $done = {};
1524
1525     my $cond_add_key = sub {
1526         my ($key) = @_;
1527
1528         return if $done->{$key}; # avoid duplicates
1529
1530         $done->{$key} = 1;
1531
1532         my $phash = $format->{$key};
1533
1534         return if !$phash; # should not happen
1535
1536         return if $phash->{alias};
1537
1538         &$format_key_value($key, $phash);
1539
1540     };
1541
1542     &$cond_add_key($default_key) if defined($default_key);
1543
1544     # add required keys first
1545     foreach my $key (sort keys %$format) {
1546         my $phash = $format->{$key};
1547         &$cond_add_key($key) if $phash && !$phash->{optional};
1548     }
1549
1550     # add the rest
1551     foreach my $key (sort keys %$format) {
1552         &$cond_add_key($key);
1553     }
1554
1555     foreach my $keyAlias (sort keys %$keyAliasProps) {
1556         &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
1557     }
1558
1559     return $res;
1560 }
1561
1562 sub print_property_string {
1563     my ($data, $format, $skip, $path) = @_;
1564
1565     if (ref($format) ne 'HASH') {
1566         my $schema = get_format($format);
1567         die "not a valid format: $format\n" if !$schema;
1568         $format = $schema;
1569     }
1570
1571     my $errors = {};
1572     check_object($path, $format, $data, undef, $errors);
1573     if (scalar(%$errors)) {
1574         raise "format error", errors => $errors;
1575     }
1576
1577     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1578
1579     my $res = '';
1580     my $add_sep = 0;
1581
1582     my $add_option_string = sub {
1583         my ($text) = @_;
1584
1585         $res .= ',' if $add_sep;
1586         $res .= $text;
1587         $add_sep = 1;
1588     };
1589
1590     my $format_value = sub {
1591         my ($key, $value, $format) = @_;
1592
1593         if (defined($format) && ($format eq 'disk-size')) {
1594             return format_size($value);
1595         } else {
1596             die "illegal value with commas for $key\n" if $value =~ /,/;
1597             return $value;
1598         }
1599     };
1600
1601     my $done = { map { $_ => 1 } @$skip };
1602
1603     my $cond_add_key = sub {
1604         my ($key) = @_;
1605
1606         return if $done->{$key}; # avoid duplicates
1607
1608         $done->{$key} = 1;
1609
1610         my $value = $data->{$key};
1611
1612         return if !defined($value);
1613
1614         my $phash = $format->{$key};
1615
1616         # try to combine values if we have key aliases
1617         if (my $combine = $keyAliasProps->{$key}) {
1618             if (defined(my $combine_value = $data->{$combine})) {
1619                 my $combine_format = $format->{$combine}->{format};
1620                 my $value_str = &$format_value($key, $value, $phash->{format});
1621                 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
1622                 &$add_option_string("${value_str}=${combine_str}");
1623                 $done->{$combine} = 1;
1624                 return;
1625             }
1626         }
1627
1628         if ($phash && $phash->{alias}) {
1629             $phash = $format->{$phash->{alias}};
1630         }
1631
1632         die "invalid key '$key'\n" if !$phash;
1633         die "internal error" if defined($phash->{alias});
1634
1635         my $value_str = &$format_value($key, $value, $phash->{format});
1636         &$add_option_string("$key=${value_str}");
1637     };
1638
1639     # add default key first
1640     &$cond_add_key($default_key) if defined($default_key);
1641
1642     # add required keys first
1643     foreach my $key (sort keys %$data) {
1644         my $phash = $format->{$key};
1645         &$cond_add_key($key) if $phash && !$phash->{optional};
1646     }
1647
1648     # add the rest
1649     foreach my $key (sort keys %$data) {
1650         &$cond_add_key($key);
1651     }
1652
1653     return $res;
1654 }
1655
1656 sub schema_get_type_text {
1657     my ($phash) = @_;
1658
1659     my $type = $phash->{type} || 'string';
1660
1661     if ($phash->{typetext}) {
1662         return $phash->{typetext};
1663     } elsif ($phash->{format_description}) {
1664         return "<$phash->{format_description}>";
1665     } elsif ($phash->{enum}) {
1666         return "(" . join(' | ', sort @{$phash->{enum}}) . ")";
1667     } elsif ($phash->{pattern}) {
1668         return $phash->{pattern};
1669     } elsif ($type eq 'integer' || $type eq 'number') {
1670         if (defined($phash->{minimum}) && defined($phash->{maximum})) {
1671             return "$type ($phash->{minimum} - $phash->{maximum})";
1672         } elsif (defined($phash->{minimum})) {
1673             return "$type ($phash->{minimum} - N)";
1674         } elsif (defined($phash->{maximum})) {
1675             return "$type (-N - $phash->{maximum})";
1676         }
1677     } elsif ($type eq 'string') {
1678         if (my $format = $phash->{format}) {
1679             $format = get_format($format) if ref($format) ne 'HASH';
1680             if (ref($format) eq 'HASH') {
1681                 return generate_typetext($format);
1682             }
1683         }
1684     }
1685
1686     return $type;
1687 }
1688
1689 1;