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