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