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