src/PVE/JSONSchema.pm

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