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