PVE/JSONSchema.pm

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