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