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