src/PVE/JSONSchema.pm

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