src/PVE/JSONSchema.pm

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