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 # used for pve-tag-list in e.g., guest configs
 503 register_format('pve-tag', \&pve_verify_tag);
 504 sub pve_verify_tag {
 505     my ($value, $noerr) = @_;
 506
 507     return $value if $value =~ m/^[a-z0-9_][a-z0-9_\-\+\.]*$/i;
 508
 509     return undef if $noerr;
 510
 511     die "invalid characters in tag\n";
 512 }
 513
 514 sub pve_parse_startup_order {
 515     my ($value) = @_;
 516
 517     return undef if !$value;
 518
 519     my $res = {};
 520
 521     foreach my $p (split(/,/, $value)) {
 522         next if $p =~ m/^\s*$/;
 523
 524         if ($p =~ m/^(order=)?(\d+)$/) {
 525             $res->{order} = $2;
 526         } elsif ($p =~ m/^up=(\d+)$/) {
 527             $res->{up} = $1;
 528         } elsif ($p =~ m/^down=(\d+)$/) {
 529             $res->{down} = $1;
 530         } else {
 531             return undef;
 532         }
 533     }
 534
 535     return $res;
 536 }
 537
 538 PVE::JSONSchema::register_standard_option('pve-startup-order', {
 539     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.",
 540     optional => 1,
 541     type => 'string', format => 'pve-startup-order',
 542     typetext => '[[order=]\d+] [,up=\d+] [,down=\d+] ',
 543 });
 544
 545 register_format('pve-tfa-secret', \&pve_verify_tfa_secret);
 546 sub pve_verify_tfa_secret {
 547     my ($key, $noerr) = @_;
 548
 549     # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
 550     # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
 551     # format to support arbitrary lengths properly:
 552     if ($key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
 553         $key =~ /^v2-[A-Z2-7=]{16,128}$/ ||     # base32
 554         $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/) # and the old pattern copy&pasted
 555     {
 556         return $key;
 557     }
 558
 559     return undef if $noerr;
 560
 561     die "unable to decode TFA secret\n";
 562 }
 563
 564 sub check_format {
 565     my ($format, $value, $path) = @_;
 566
 567     return parse_property_string($format, $value, $path) if ref($format) eq 'HASH';
 568     return if $format eq 'regex';
 569
 570     if ($format =~ m/^(.*)-a?list$/) {
 571
 572         my $code = $format_list->{$1};
 573
 574         die "undefined format '$format'\n" if !$code;
 575
 576         # Note: we allow empty lists
 577         foreach my $v (split_list($value)) {
 578             &$code($v);
 579         }
 580
 581     } elsif ($format =~ m/^(.*)-opt$/) {
 582
 583         my $code = $format_list->{$1};
 584
 585         die "undefined format '$format'\n" if !$code;
 586
 587         return if !$value; # allow empty string
 588
 589         &$code($value);
 590
 591    } else {
 592
 593         my $code = $format_list->{$format};
 594
 595         die "undefined format '$format'\n" if !$code;
 596
 597         return parse_property_string($code, $value, $path) if ref($code) eq 'HASH';
 598         &$code($value);
 599     }
 600 }
 601
 602 sub parse_size {
 603     my ($value) = @_;
 604
 605     return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
 606     my ($size, $unit) = ($1, $3);
 607     if ($unit) {
 608         if ($unit eq 'K') {
 609             $size = $size * 1024;
 610         } elsif ($unit eq 'M') {
 611             $size = $size * 1024 * 1024;
 612         } elsif ($unit eq 'G') {
 613             $size = $size * 1024 * 1024 * 1024;
 614         } elsif ($unit eq 'T') {
 615             $size = $size * 1024 * 1024 * 1024 * 1024;
 616         }
 617     }
 618     return int($size);
 619 };
 620
 621 sub format_size {
 622     my ($size) = @_;
 623
 624     $size = int($size);
 625
 626     my $kb = int($size/1024);
 627     return $size if $kb*1024 != $size;
 628
 629     my $mb = int($kb/1024);
 630     return "${kb}K" if $mb*1024 != $kb;
 631
 632     my $gb = int($mb/1024);
 633     return "${mb}M" if $gb*1024 != $mb;
 634
 635     my $tb = int($gb/1024);
 636     return "${gb}G" if $tb*1024 != $gb;
 637
 638     return "${tb}T";
 639 };
 640
 641 sub parse_boolean {
 642     my ($bool) = @_;
 643     return 1 if $bool =~ m/^(1|on|yes|true)$/i;
 644     return 0 if $bool =~ m/^(0|off|no|false)$/i;
 645     return undef;
 646 }
 647
 648 sub parse_property_string {
 649     my ($format, $data, $path, $additional_properties) = @_;
 650
 651     # In property strings we default to not allowing additional properties
 652     $additional_properties = 0 if !defined($additional_properties);
 653
 654     # Support named formats here, too:
 655     if (!ref($format)) {
 656         if (my $desc = $format_list->{$format}) {
 657             $format = $desc;
 658         } else {
 659             die "unknown format: $format\n";
 660         }
 661     } elsif (ref($format) ne 'HASH') {
 662         die "unexpected format value of type ".ref($format)."\n";
 663     }
 664
 665     my $default_key;
 666
 667     my $res = {};
 668     foreach my $part (split(/,/, $data)) {
 669         next if $part =~ /^\s*$/;
 670
 671         if ($part =~ /^([^=]+)=(.+)$/) {
 672             my ($k, $v) = ($1, $2);
 673             die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
 674             my $schema = $format->{$k};
 675             if (my $alias = $schema->{alias}) {
 676                 if (my $key_alias = $schema->{keyAlias}) {
 677                     die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
 678                     $res->{$key_alias} = $k;
 679                 }
 680                 $k = $alias;
 681                 $schema = $format->{$k};
 682             }
 683
 684             die "invalid key in comma-separated list property: $k\n" if !$schema;
 685             if ($schema->{type} && $schema->{type} eq 'boolean') {
 686                 $v = parse_boolean($v) // $v;
 687             }
 688             $res->{$k} = $v;
 689         } elsif ($part !~ /=/) {
 690             die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
 691             foreach my $key (keys %$format) {
 692                 if ($format->{$key}->{default_key}) {
 693                     $default_key = $key;
 694                     if (!$res->{$default_key}) {
 695                         $res->{$default_key} = $part;
 696                         last;
 697                     }
 698                     die "duplicate key in comma-separated list property: $default_key\n";
 699                 }
 700             }
 701             die "value without key, but schema does not define a default key\n" if !$default_key;
 702         } else {
 703             die "missing key in comma-separated list property\n";
 704         }
 705     }
 706
 707     my $errors = {};
 708     check_object($path, $format, $res, $additional_properties, $errors);
 709     if (scalar(%$errors)) {
 710         raise "format error\n", errors => $errors;
 711     }
 712
 713     return $res;
 714 }
 715
 716 sub add_error {
 717     my ($errors, $path, $msg) = @_;
 718
 719     $path = '_root' if !$path;
 720
 721     if ($errors->{$path}) {
 722         $errors->{$path} = join ('\n', $errors->{$path}, $msg);
 723     } else {
 724         $errors->{$path} = $msg;
 725     }
 726 }
 727
 728 sub is_number {
 729     my $value = shift;
 730
 731     # see 'man perlretut'
 732     return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
 733 }
 734
 735 sub is_integer {
 736     my $value = shift;
 737
 738     return $value =~ m/^[+-]?\d+$/;
 739 }
 740
 741 sub check_type {
 742     my ($path, $type, $value, $errors) = @_;
 743
 744     return 1 if !$type;
 745
 746     if (!defined($value)) {
 747         return 1 if $type eq 'null';
 748         die "internal error"
 749     }
 750
 751     if (my $tt = ref($type)) {
 752         if ($tt eq 'ARRAY') {
 753             foreach my $t (@$type) {
 754                 my $tmperr = {};
 755                 check_type($path, $t, $value, $tmperr);
 756                 return 1 if !scalar(%$tmperr);
 757             }
 758             my $ttext = join ('|', @$type);
 759             add_error($errors, $path, "type check ('$ttext') failed");
 760             return undef;
 761         } elsif ($tt eq 'HASH') {
 762             my $tmperr = {};
 763             check_prop($value, $type, $path, $tmperr);
 764             return 1 if !scalar(%$tmperr);
 765             add_error($errors, $path, "type check failed");
 766             return undef;
 767         } else {
 768             die "internal error - got reference type '$tt'";
 769         }
 770
 771     } else {
 772
 773         return 1 if $type eq 'any';
 774
 775         if ($type eq 'null') {
 776             if (defined($value)) {
 777                 add_error($errors, $path, "type check ('$type') failed - value is not null");
 778                 return undef;
 779             }
 780             return 1;
 781         }
 782
 783         my $vt = ref($value);
 784
 785         if ($type eq 'array') {
 786             if (!$vt || $vt ne 'ARRAY') {
 787                 add_error($errors, $path, "type check ('$type') failed");
 788                 return undef;
 789             }
 790             return 1;
 791         } elsif ($type eq 'object') {
 792             if (!$vt || $vt ne 'HASH') {
 793                 add_error($errors, $path, "type check ('$type') failed");
 794                 return undef;
 795             }
 796             return 1;
 797         } elsif ($type eq 'coderef') {
 798             if (!$vt || $vt ne 'CODE') {
 799                 add_error($errors, $path, "type check ('$type') failed");
 800                 return undef;
 801             }
 802             return 1;
 803         } elsif ($type eq 'string' && $vt eq 'Regexp') {
 804             # qr// regexes can be used as strings and make sense for format=regex
 805             return 1;
 806         } else {
 807             if ($vt) {
 808                 add_error($errors, $path, "type check ('$type') failed - got $vt");
 809                 return undef;
 810             } else {
 811                 if ($type eq 'string') {
 812                     return 1; # nothing to check ?
 813                 } elsif ($type eq 'boolean') {
 814                     #if ($value =~ m/^(1|true|yes|on)$/i) {
 815                     if ($value eq '1') {
 816                         return 1;
 817                     #} elsif ($value =~ m/^(0|false|no|off)$/i) {
 818                     } elsif ($value eq '0') {
 819                         return 1; # return success (not value)
 820                     } else {
 821                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 822                         return undef;
 823                     }
 824                 } elsif ($type eq 'integer') {
 825                     if (!is_integer($value)) {
 826                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 827                         return undef;
 828                     }
 829                     return 1;
 830                 } elsif ($type eq 'number') {
 831                     if (!is_number($value)) {
 832                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 833                         return undef;
 834                     }
 835                     return 1;
 836                 } else {
 837                     return 1; # no need to verify unknown types
 838                 }
 839             }
 840         }
 841     }
 842
 843     return undef;
 844 }
 845
 846 sub check_object {
 847     my ($path, $schema, $value, $additional_properties, $errors) = @_;
 848
 849     # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
 850
 851     my $st = ref($schema);
 852     if (!$st || $st ne 'HASH') {
 853         add_error($errors, $path, "Invalid schema definition.");
 854         return;
 855     }
 856
 857     my $vt = ref($value);
 858     if (!$vt || $vt ne 'HASH') {
 859         add_error($errors, $path, "an object is required");
 860         return;
 861     }
 862
 863     foreach my $k (keys %$schema) {
 864         check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors);
 865     }
 866
 867     foreach my $k (keys %$value) {
 868
 869         my $newpath =  $path ? "$path.$k" : $k;
 870
 871         if (my $subschema = $schema->{$k}) {
 872             if (my $requires = $subschema->{requires}) {
 873                 if (ref($requires)) {
 874                     #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
 875                     check_prop($value, $requires, $path, $errors);
 876                 } elsif (!defined($value->{$requires})) {
 877                     add_error($errors, $path ? "$path.$requires" : $requires,
 878                               "missing property - '$newpath' requires this property");
 879                 }
 880             }
 881
 882             next; # value is already checked above
 883         }
 884
 885         if (defined ($additional_properties) && !$additional_properties) {
 886             add_error($errors, $newpath, "property is not defined in schema " .
 887                       "and the schema does not allow additional properties");
 888             next;
 889         }
 890         check_prop($value->{$k}, $additional_properties, $newpath, $errors)
 891             if ref($additional_properties);
 892     }
 893 }
 894
 895 sub check_object_warn {
 896     my ($path, $schema, $value, $additional_properties) = @_;
 897     my $errors = {};
 898     check_object($path, $schema, $value, $additional_properties, $errors);
 899     if (scalar(%$errors)) {
 900         foreach my $k (keys %$errors) {
 901             warn "parse error: $k: $errors->{$k}\n";
 902         }
 903         return 0;
 904     }
 905     return 1;
 906 }
 907
 908 sub check_prop {
 909     my ($value, $schema, $path, $errors) = @_;
 910
 911     die "internal error - no schema" if !$schema;
 912     die "internal error" if !$errors;
 913
 914     #print "check_prop $path\n" if $value;
 915
 916     my $st = ref($schema);
 917     if (!$st || $st ne 'HASH') {
 918         add_error($errors, $path, "Invalid schema definition.");
 919         return;
 920     }
 921
 922     # if it extends another schema, it must pass that schema as well
 923     if($schema->{extends}) {
 924         check_prop($value, $schema->{extends}, $path, $errors);
 925     }
 926
 927     if (!defined ($value)) {
 928         return if $schema->{type} && $schema->{type} eq 'null';
 929         if (!$schema->{optional} && !$schema->{alias} && !$schema->{group}) {
 930             add_error($errors, $path, "property is missing and it is not optional");
 931         }
 932         return;
 933     }
 934
 935     return if !check_type($path, $schema->{type}, $value, $errors);
 936
 937     if ($schema->{disallow}) {
 938         my $tmperr = {};
 939         if (check_type($path, $schema->{disallow}, $value, $tmperr)) {
 940             add_error($errors, $path, "disallowed value was matched");
 941             return;
 942         }
 943     }
 944
 945     if (my $vt = ref($value)) {
 946
 947         if ($vt eq 'ARRAY') {
 948             if ($schema->{items}) {
 949                 my $it = ref($schema->{items});
 950                 if ($it && $it eq 'ARRAY') {
 951                     #die "implement me $path: $vt " . Dumper($schema) ."\n".  Dumper($value);
 952                     die "not implemented";
 953                 } else {
 954                     my $ind = 0;
 955                     foreach my $el (@$value) {
 956                         check_prop($el, $schema->{items}, "${path}[$ind]", $errors);
 957                         $ind++;
 958                     }
 959                 }
 960             }
 961             return;
 962         } elsif ($schema->{properties} || $schema->{additionalProperties}) {
 963             check_object($path, defined($schema->{properties}) ? $schema->{properties} : {},
 964                          $value, $schema->{additionalProperties}, $errors);
 965             return;
 966         }
 967
 968     } else {
 969
 970         if (my $format = $schema->{format}) {
 971             eval { check_format($format, $value, $path); };
 972             if ($@) {
 973                 add_error($errors, $path, "invalid format - $@");
 974                 return;
 975             }
 976         }
 977
 978         if (my $pattern = $schema->{pattern}) {
 979             if ($value !~ m/^$pattern$/) {
 980                 add_error($errors, $path, "value does not match the regex pattern");
 981                 return;
 982             }
 983         }
 984
 985         if (defined (my $max = $schema->{maxLength})) {
 986             if (length($value) > $max) {
 987                 add_error($errors, $path, "value may only be $max characters long");
 988                 return;
 989             }
 990         }
 991
 992         if (defined (my $min = $schema->{minLength})) {
 993             if (length($value) < $min) {
 994                 add_error($errors, $path, "value must be at least $min characters long");
 995                 return;
 996             }
 997         }
 998
 999         if (is_number($value)) {
1000             if (defined (my $max = $schema->{maximum})) {
1001                 if ($value > $max) {
1002                     add_error($errors, $path, "value must have a maximum value of $max");
1003                     return;
1004                 }
1005             }
1006
1007             if (defined (my $min = $schema->{minimum})) {
1008                 if ($value < $min) {
1009                     add_error($errors, $path, "value must have a minimum value of $min");
1010                     return;
1011                 }
1012             }
1013         }
1014
1015         if (my $ea = $schema->{enum}) {
1016
1017             my $found;
1018             foreach my $ev (@$ea) {
1019                 if ($ev eq $value) {
1020                     $found = 1;
1021                     last;
1022                 }
1023             }
1024             if (!$found) {
1025                 add_error($errors, $path, "value '$value' does not have a value in the enumeration '" .
1026                           join(", ", @$ea) . "'");
1027             }
1028         }
1029     }
1030 }
1031
1032 sub validate {
1033     my ($instance, $schema, $errmsg) = @_;
1034
1035     my $errors = {};
1036     $errmsg = "Parameter verification failed.\n" if !$errmsg;
1037
1038     # todo: cycle detection is only needed for debugging, I guess
1039     # we can disable that in the final release
1040     # todo: is there a better/faster way to detect cycles?
1041     my $cycles = 0;
1042     find_cycle($instance, sub { $cycles = 1 });
1043     if ($cycles) {
1044         add_error($errors, undef, "data structure contains recursive cycles");
1045     } elsif ($schema) {
1046         check_prop($instance, $schema, '', $errors);
1047     }
1048
1049     if (scalar(%$errors)) {
1050         raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors;
1051     }
1052
1053     return 1;
1054 }
1055
1056 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
1057 my $default_schema_noref = {
1058     description => "This is the JSON Schema for JSON Schemas.",
1059     type => [ "object" ],
1060     additionalProperties => 0,
1061     properties => {
1062         type => {
1063             type => ["string", "array"],
1064             description => "This is a type definition value. This can be a simple type, or a union type",
1065             optional => 1,
1066             default => "any",
1067             items => {
1068                 type => "string",
1069                 enum => $schema_valid_types,
1070             },
1071             enum => $schema_valid_types,
1072         },
1073         optional => {
1074             type => "boolean",
1075             description => "This indicates that the instance property in the instance object is not required.",
1076             optional => 1,
1077             default => 0
1078         },
1079         properties => {
1080             type => "object",
1081             description => "This is a definition for the properties of an object value",
1082             optional => 1,
1083             default => {},
1084         },
1085         items => {
1086             type => "object",
1087             description => "When the value is an array, this indicates the schema to use to validate each item in an array",
1088             optional => 1,
1089             default => {},
1090         },
1091         additionalProperties => {
1092             type => [ "boolean", "object"],
1093             description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
1094             optional => 1,
1095             default => {},
1096         },
1097         minimum => {
1098             type => "number",
1099             optional => 1,
1100             description => "This indicates the minimum value for the instance property when the type of the instance value is a number.",
1101         },
1102         maximum => {
1103             type => "number",
1104             optional => 1,
1105             description => "This indicates the maximum value for the instance property when the type of the instance value is a number.",
1106         },
1107         minLength => {
1108             type => "integer",
1109             description => "When the instance value is a string, this indicates minimum length of the string",
1110             optional => 1,
1111             minimum => 0,
1112             default => 0,
1113         },
1114         maxLength => {
1115             type => "integer",
1116             description => "When the instance value is a string, this indicates maximum length of the string.",
1117             optional => 1,
1118         },
1119         typetext => {
1120             type => "string",
1121             optional => 1,
1122             description => "A text representation of the type (used to generate documentation).",
1123         },
1124         pattern => {
1125             type => "string",
1126             format => "regex",
1127             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.",
1128             optional => 1,
1129             default => ".*",
1130         },
1131         enum => {
1132             type => "array",
1133             optional => 1,
1134             description => "This provides an enumeration of possible values that are valid for the instance property.",
1135         },
1136         description => {
1137             type => "string",
1138             optional => 1,
1139             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).",
1140         },
1141         verbose_description => {
1142             type => "string",
1143             optional => 1,
1144             description => "This provides a more verbose description.",
1145         },
1146         format_description => {
1147             type => "string",
1148             optional => 1,
1149             description => "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1150         },
1151         title => {
1152             type => "string",
1153             optional => 1,
1154             description => "This provides the title of the property",
1155         },
1156         renderer => {
1157             type => "string",
1158             optional => 1,
1159             description => "This is used to provide rendering hints to format cli command output.",
1160         },
1161         requires => {
1162             type => [ "string", "object" ],
1163             optional => 1,
1164             description => "indicates a required property or a schema that must be validated if this property is present",
1165         },
1166         format => {
1167             type => [ "string", "object" ],
1168             optional => 1,
1169             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",
1170         },
1171         default_key => {
1172             type => "boolean",
1173             optional => 1,
1174             description => "Whether this is the default key in a comma separated list property string.",
1175         },
1176         alias => {
1177             type => 'string',
1178             optional => 1,
1179             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.",
1180         },
1181         keyAlias => {
1182             type => 'string',
1183             optional => 1,
1184             description => "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1185             requires => 'alias',
1186         },
1187         default => {
1188             type => "any",
1189             optional => 1,
1190             description => "This indicates the default for the instance property."
1191         },
1192         completion => {
1193             type => 'coderef',
1194             description => "Bash completion function. This function should return a list of possible values.",
1195             optional => 1,
1196         },
1197         disallow => {
1198             type => "object",
1199             optional => 1,
1200             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.",
1201         },
1202         extends => {
1203             type => "object",
1204             optional => 1,
1205             description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1206             default => {},
1207         },
1208         # this is from hyper schema
1209         links => {
1210             type => "array",
1211             description => "This defines the link relations of the instance objects",
1212             optional => 1,
1213             items => {
1214                 type => "object",
1215                 properties => {
1216                     href => {
1217                         type => "string",
1218                         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",
1219                     },
1220                     rel => {
1221                         type => "string",
1222                         description => "This is the name of the link relation",
1223                         optional => 1,
1224                         default => "full",
1225                     },
1226                     method => {
1227                         type => "string",
1228                         description => "For submission links, this defines the method that should be used to access the target resource",
1229                         optional => 1,
1230                         default => "GET",
1231                     },
1232                 },
1233             },
1234         },
1235         print_width => {
1236             type => "integer",
1237             description => "For CLI context, this defines the maximal width to print before truncating",
1238             optional => 1,
1239         },
1240     }
1241 };
1242
1243 my $default_schema = Storable::dclone($default_schema_noref);
1244
1245 $default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
1246 $default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
1247
1248 $default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
1249 $default_schema->{properties}->{items}->{additionalProperties} = 0;
1250
1251 $default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
1252 $default_schema->{properties}->{disallow}->{additionalProperties} = 0;
1253
1254 $default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
1255 $default_schema->{properties}->{requires}->{additionalProperties} = 0;
1256
1257 $default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
1258 $default_schema->{properties}->{extends}->{additionalProperties} = 0;
1259
1260 my $method_schema = {
1261     type => "object",
1262     additionalProperties => 0,
1263     properties => {
1264         description => {
1265             description => "This a description of the method",
1266             optional => 1,
1267         },
1268         name => {
1269             type =>  'string',
1270             description => "This indicates the name of the function to call.",
1271             optional => 1,
1272             requires => {
1273                 additionalProperties => 1,
1274                 properties => {
1275                     name => {},
1276                     description => {},
1277                     code => {},
1278                     method => {},
1279                     parameters => {},
1280                     path => {},
1281                     parameters => {},
1282                     returns => {},
1283                 }
1284             },
1285         },
1286         method => {
1287             type =>  'string',
1288             description => "The HTTP method name.",
1289             enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
1290             optional => 1,
1291         },
1292         protected => {
1293             type => 'boolean',
1294             description => "Method needs special privileges - only pvedaemon can execute it",
1295             optional => 1,
1296         },
1297         allowtoken => {
1298             type => 'boolean',
1299             description => "Method is available for clients authenticated using an API token.",
1300             optional => 1,
1301             default => 1,
1302         },
1303         download => {
1304             type => 'boolean',
1305             description => "Method downloads the file content (filename is the return value of the method).",
1306             optional => 1,
1307         },
1308         proxyto => {
1309             type =>  'string',
1310             description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1311             optional => 1,
1312         },
1313         proxyto_callback => {
1314             type =>  'coderef',
1315             description => "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter.",
1316             optional => 1,
1317         },
1318         permissions => {
1319             type => 'object',
1320             description => "Required access permissions. By default only 'root' is allowed to access this method.",
1321             optional => 1,
1322             additionalProperties => 0,
1323             properties => {
1324                 description => {
1325                      description => "Describe access permissions.",
1326                      optional => 1,
1327                 },
1328                 user => {
1329                     description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1330                     type => 'string',
1331                     enum => ['all', 'world'],
1332                     optional => 1,
1333                 },
1334                 check => {
1335                     description => "Array of permission checks (prefix notation).",
1336                     type => 'array',
1337                     optional => 1
1338                 },
1339             },
1340         },
1341         match_name => {
1342             description => "Used internally",
1343             optional => 1,
1344         },
1345         match_re => {
1346             description => "Used internally",
1347             optional => 1,
1348         },
1349         path => {
1350             type =>  'string',
1351             description => "path for URL matching (uri template)",
1352         },
1353         fragmentDelimiter => {
1354             type => 'string',
1355             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.",
1356             optional => 1,
1357         },
1358         parameters => {
1359             type => 'object',
1360             description => "JSON Schema for parameters.",
1361             optional => 1,
1362         },
1363         returns => {
1364             type => 'object',
1365             description => "JSON Schema for return value.",
1366             optional => 1,
1367         },
1368         code => {
1369             type => 'coderef',
1370             description => "method implementation (code reference)",
1371             optional => 1,
1372         },
1373         subclass => {
1374             type => 'string',
1375             description => "Delegate call to this class (perl class string).",
1376             optional => 1,
1377             requires => {
1378                 additionalProperties => 0,
1379                 properties => {
1380                     subclass => {},
1381                     path => {},
1382                     match_name => {},
1383                     match_re => {},
1384                     fragmentDelimiter => { optional => 1 }
1385                 }
1386             },
1387         },
1388     },
1389
1390 };
1391
1392 sub validate_schema {
1393     my ($schema) = @_;
1394
1395     my $errmsg = "internal error - unable to verify schema\n";
1396     validate($schema, $default_schema, $errmsg);
1397 }
1398
1399 sub validate_method_info {
1400     my $info = shift;
1401
1402     my $errmsg = "internal error - unable to verify method info\n";
1403     validate($info, $method_schema, $errmsg);
1404
1405     validate_schema($info->{parameters}) if $info->{parameters};
1406     validate_schema($info->{returns}) if $info->{returns};
1407 }
1408
1409 # run a self test on load
1410 # make sure we can verify the default schema
1411 validate_schema($default_schema_noref);
1412 validate_schema($method_schema);
1413
1414 # and now some utility methods (used by pve api)
1415 sub method_get_child_link {
1416     my ($info) = @_;
1417
1418     return undef if !$info;
1419
1420     my $schema = $info->{returns};
1421     return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
1422
1423     my $links = $schema->{links};
1424     return undef if !$links;
1425
1426     my $found;
1427     foreach my $lnk (@$links) {
1428         if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
1429             $found = $lnk;
1430             last;
1431         }
1432     }
1433
1434     return $found;
1435 }
1436
1437 # a way to parse command line parameters, using a
1438 # schema to configure Getopt::Long
1439 sub get_options {
1440     my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
1441
1442     if (!$schema || !$schema->{properties}) {
1443         raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1444             if scalar(@$args) != 0;
1445         return {};
1446     }
1447
1448     my $list_param;
1449     if ($arg_param && !ref($arg_param)) {
1450         my $pd = $schema->{properties}->{$arg_param};
1451         die "expected list format $pd->{format}"
1452             if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
1453         $list_param = $arg_param;
1454     }
1455
1456     my @interactive = ();
1457     my @getopt = ();
1458     foreach my $prop (keys %{$schema->{properties}}) {
1459         my $pd = $schema->{properties}->{$prop};
1460         next if $list_param && $prop eq $list_param;
1461         next if defined($fixed_param->{$prop});
1462
1463         my $mapping = $param_mapping_hash->{$prop};
1464         if ($mapping && $mapping->{interactive}) {
1465             # interactive parameters such as passwords: make the argument
1466             # optional and call the mapping function afterwards.
1467             push @getopt, "$prop:s";
1468             push @interactive, [$prop, $mapping->{func}];
1469         } elsif ($pd->{type} eq 'boolean') {
1470             push @getopt, "$prop:s";
1471         } else {
1472             if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
1473                 push @getopt, "$prop=s@";
1474             } else {
1475                 push @getopt, "$prop=s";
1476             }
1477         }
1478     }
1479
1480     Getopt::Long::Configure('prefix_pattern=(--|-)');
1481
1482     my $opts = {};
1483     raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
1484         if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
1485
1486     if (@$args) {
1487         if ($list_param) {
1488             $opts->{$list_param} = $args;
1489             $args = [];
1490         } elsif (ref($arg_param)) {
1491             foreach my $arg_name (@$arg_param) {
1492                 if ($opts->{'extra-args'}) {
1493                     raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
1494                 }
1495                 if ($arg_name eq 'extra-args') {
1496                     $opts->{'extra-args'} = $args;
1497                     $args = [];
1498                     next;
1499                 }
1500                 raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
1501                 $opts->{$arg_name} = shift @$args;
1502             }
1503             raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
1504         } else {
1505             raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1506                 if scalar(@$args) != 0;
1507         }
1508     } else {
1509         if (ref($arg_param)) {
1510             foreach my $arg_name (@$arg_param) {
1511                 if ($arg_name eq 'extra-args') {
1512                     $opts->{'extra-args'} = [];
1513                 } else {
1514                     raise("not enough arguments\n", code => HTTP_BAD_REQUEST);
1515                 }
1516             }
1517         }
1518     }
1519
1520     foreach my $entry (@interactive) {
1521         my ($opt, $func) = @$entry;
1522         my $pd = $schema->{properties}->{$opt};
1523         my $value = $opts->{$opt};
1524         if (defined($value) || !$pd->{optional}) {
1525             $opts->{$opt} = $func->($value);
1526         }
1527     }
1528
1529     # decode after Getopt as we are not sure how well it handles unicode
1530     foreach my $p (keys %$opts) {
1531         if (!ref($opts->{$p})) {
1532             $opts->{$p} = decode('locale', $opts->{$p});
1533         } elsif (ref($opts->{$p}) eq 'ARRAY') {
1534             my $tmp = [];
1535             foreach my $v (@{$opts->{$p}}) {
1536                 push @$tmp, decode('locale', $v);
1537             }
1538             $opts->{$p} = $tmp;
1539         } elsif (ref($opts->{$p}) eq 'SCALAR') {
1540             $opts->{$p} = decode('locale', $$opts->{$p});
1541         } else {
1542             raise("decoding options failed, unknown reference\n", code => HTTP_BAD_REQUEST);
1543         }
1544     }
1545
1546     foreach my $p (keys %$opts) {
1547         if (my $pd = $schema->{properties}->{$p}) {
1548             if ($pd->{type} eq 'boolean') {
1549                 if ($opts->{$p} eq '') {
1550                     $opts->{$p} = 1;
1551                 } elsif (defined(my $bool = parse_boolean($opts->{$p}))) {
1552                     $opts->{$p} = $bool;
1553                 } else {
1554                     raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
1555                 }
1556             } elsif ($pd->{format}) {
1557
1558                 if ($pd->{format} =~ m/-list/) {
1559                     # allow --vmid 100 --vmid 101 and --vmid 100,101
1560                     # allow --dow mon --dow fri and --dow mon,fri
1561                     $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1562                 } elsif ($pd->{format} =~ m/-alist/) {
1563                     # we encode array as \0 separated strings
1564                     # Note: CGI.pm also use this encoding
1565                     if (scalar(@{$opts->{$p}}) != 1) {
1566                         $opts->{$p} = join("\0", @{$opts->{$p}});
1567                     } else {
1568                         # st that split_list knows it is \0 terminated
1569                         my $v = $opts->{$p}->[0];
1570                         $opts->{$p} = "$v\0";
1571                     }
1572                 }
1573             }
1574         }
1575     }
1576
1577     foreach my $p (keys %$fixed_param) {
1578         $opts->{$p} = $fixed_param->{$p};
1579     }
1580
1581     return $opts;
1582 }
1583
1584 # A way to parse configuration data by giving a json schema
1585 sub parse_config {
1586     my ($schema, $filename, $raw) = @_;
1587
1588     # do fast check (avoid validate_schema($schema))
1589     die "got strange schema" if !$schema->{type} ||
1590         !$schema->{properties} || $schema->{type} ne 'object';
1591
1592     my $cfg = {};
1593
1594     while ($raw =~ /^\s*(.+?)\s*$/gm) {
1595         my $line = $1;
1596
1597         next if $line =~ /^#/;
1598
1599         if ($line =~ m/^(\S+?):\s*(.*)$/) {
1600             my $key = $1;
1601             my $value = $2;
1602             if ($schema->{properties}->{$key} &&
1603                 $schema->{properties}->{$key}->{type} eq 'boolean') {
1604
1605                 $value = parse_boolean($value) // $value;
1606             }
1607             $cfg->{$key} = $value;
1608         } else {
1609             warn "ignore config line: $line\n"
1610         }
1611     }
1612
1613     my $errors = {};
1614     check_prop($cfg, $schema, '', $errors);
1615
1616     foreach my $k (keys %$errors) {
1617         warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1618         delete $cfg->{$k};
1619     }
1620
1621     return $cfg;
1622 }
1623
1624 # generate simple key/value file
1625 sub dump_config {
1626     my ($schema, $filename, $cfg) = @_;
1627
1628     # do fast check (avoid validate_schema($schema))
1629     die "got strange schema" if !$schema->{type} ||
1630         !$schema->{properties} || $schema->{type} ne 'object';
1631
1632     validate($cfg, $schema, "validation error in '$filename'\n");
1633
1634     my $data = '';
1635
1636     foreach my $k (sort keys %$cfg) {
1637         $data .= "$k: $cfg->{$k}\n";
1638     }
1639
1640     return $data;
1641 }
1642
1643 # helpers used to generate our manual pages
1644
1645 my $find_schema_default_key = sub {
1646     my ($format) = @_;
1647
1648     my $default_key;
1649     my $keyAliasProps = {};
1650
1651     foreach my $key (keys %$format) {
1652         my $phash = $format->{$key};
1653         if ($phash->{default_key}) {
1654             die "multiple default keys in schema ($default_key, $key)\n"
1655                 if defined($default_key);
1656             die "default key '$key' is an alias - this is not allowed\n"
1657                 if defined($phash->{alias});
1658             die "default key '$key' with keyAlias attribute is not allowed\n"
1659                 if $phash->{keyAlias};
1660             $default_key = $key;
1661         }
1662         my $key_alias = $phash->{keyAlias};
1663         die "found keyAlias without 'alias definition for '$key'\n"
1664             if $key_alias && !$phash->{alias};
1665
1666         if ($phash->{alias} && $key_alias) {
1667             die "inconsistent keyAlias '$key_alias' definition"
1668                 if defined($keyAliasProps->{$key_alias}) &&
1669                 $keyAliasProps->{$key_alias} ne $phash->{alias};
1670             $keyAliasProps->{$key_alias} = $phash->{alias};
1671         }
1672     }
1673
1674     return wantarray ? ($default_key, $keyAliasProps) : $default_key;
1675 };
1676
1677 sub generate_typetext {
1678     my ($format, $list_enums) = @_;
1679
1680     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1681
1682     my $res = '';
1683     my $add_sep = 0;
1684
1685     my $add_option_string = sub {
1686         my ($text, $optional) = @_;
1687
1688         if ($add_sep) {
1689             $text = ",$text";
1690             $res .= ' ';
1691         }
1692         $text = "[$text]" if $optional;
1693         $res .= $text;
1694         $add_sep = 1;
1695     };
1696
1697     my $format_key_value = sub {
1698         my ($key, $phash) = @_;
1699
1700         die "internal error" if defined($phash->{alias});
1701
1702         my $keytext = $key;
1703
1704         my $typetext = '';
1705
1706         if (my $desc = $phash->{format_description}) {
1707             $typetext .= "<$desc>";
1708         } elsif (my $text = $phash->{typetext}) {
1709             $typetext .= $text;
1710         } elsif (my $enum = $phash->{enum}) {
1711             if ($list_enums || (scalar(@$enum) <= 3)) {
1712                 $typetext .= '<' . join('|', @$enum) . '>';
1713             } else {
1714                 $typetext .= '<enum>';
1715             }
1716         } elsif ($phash->{type} eq 'boolean') {
1717             $typetext .= '<1|0>';
1718         } elsif ($phash->{type} eq 'integer') {
1719             $typetext .= '<integer>';
1720         } elsif ($phash->{type} eq 'number') {
1721             $typetext .= '<number>';
1722         } else {
1723             die "internal error: neither format_description nor typetext found for option '$key'";
1724         }
1725
1726         if (defined($default_key) && ($default_key eq $key)) {
1727             &$add_option_string("[$keytext=]$typetext", $phash->{optional});
1728         } else {
1729             &$add_option_string("$keytext=$typetext", $phash->{optional});
1730         }
1731     };
1732
1733     my $done = {};
1734
1735     my $cond_add_key = sub {
1736         my ($key) = @_;
1737
1738         return if $done->{$key}; # avoid duplicates
1739
1740         $done->{$key} = 1;
1741
1742         my $phash = $format->{$key};
1743
1744         return if !$phash; # should not happen
1745
1746         return if $phash->{alias};
1747
1748         &$format_key_value($key, $phash);
1749
1750     };
1751
1752     &$cond_add_key($default_key) if defined($default_key);
1753
1754     # add required keys first
1755     foreach my $key (sort keys %$format) {
1756         my $phash = $format->{$key};
1757         &$cond_add_key($key) if $phash && !$phash->{optional};
1758     }
1759
1760     # add the rest
1761     foreach my $key (sort keys %$format) {
1762         &$cond_add_key($key);
1763     }
1764
1765     foreach my $keyAlias (sort keys %$keyAliasProps) {
1766         &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
1767     }
1768
1769     return $res;
1770 }
1771
1772 sub print_property_string {
1773     my ($data, $format, $skip, $path) = @_;
1774
1775     if (ref($format) ne 'HASH') {
1776         my $schema = get_format($format);
1777         die "not a valid format: $format\n" if !$schema;
1778         $format = $schema;
1779     }
1780
1781     my $errors = {};
1782     check_object($path, $format, $data, undef, $errors);
1783     if (scalar(%$errors)) {
1784         raise "format error", errors => $errors;
1785     }
1786
1787     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1788
1789     my $res = '';
1790     my $add_sep = 0;
1791
1792     my $add_option_string = sub {
1793         my ($text) = @_;
1794
1795         $res .= ',' if $add_sep;
1796         $res .= $text;
1797         $add_sep = 1;
1798     };
1799
1800     my $format_value = sub {
1801         my ($key, $value, $format) = @_;
1802
1803         if (defined($format) && ($format eq 'disk-size')) {
1804             return format_size($value);
1805         } else {
1806             die "illegal value with commas for $key\n" if $value =~ /,/;
1807             return $value;
1808         }
1809     };
1810
1811     my $done = { map { $_ => 1 } @$skip };
1812
1813     my $cond_add_key = sub {
1814         my ($key, $isdefault) = @_;
1815
1816         return if $done->{$key}; # avoid duplicates
1817
1818         $done->{$key} = 1;
1819
1820         my $value = $data->{$key};
1821
1822         return if !defined($value);
1823
1824         my $phash = $format->{$key};
1825
1826         # try to combine values if we have key aliases
1827         if (my $combine = $keyAliasProps->{$key}) {
1828             if (defined(my $combine_value = $data->{$combine})) {
1829                 my $combine_format = $format->{$combine}->{format};
1830                 my $value_str = &$format_value($key, $value, $phash->{format});
1831                 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
1832                 &$add_option_string("${value_str}=${combine_str}");
1833                 $done->{$combine} = 1;
1834                 return;
1835             }
1836         }
1837
1838         if ($phash && $phash->{alias}) {
1839             $phash = $format->{$phash->{alias}};
1840         }
1841
1842         die "invalid key '$key'\n" if !$phash;
1843         die "internal error" if defined($phash->{alias});
1844
1845         my $value_str = &$format_value($key, $value, $phash->{format});
1846         if ($isdefault) {
1847             &$add_option_string($value_str);
1848         } else {
1849             &$add_option_string("$key=${value_str}");
1850         }
1851     };
1852
1853     # add default key first
1854     &$cond_add_key($default_key, 1) if defined($default_key);
1855
1856     # add required keys first
1857     foreach my $key (sort keys %$data) {
1858         my $phash = $format->{$key};
1859         &$cond_add_key($key) if $phash && !$phash->{optional};
1860     }
1861
1862     # add the rest
1863     foreach my $key (sort keys %$data) {
1864         &$cond_add_key($key);
1865     }
1866
1867     return $res;
1868 }
1869
1870 sub schema_get_type_text {
1871     my ($phash, $style) = @_;
1872
1873     my $type = $phash->{type} || 'string';
1874
1875     if ($phash->{typetext}) {
1876         return $phash->{typetext};
1877     } elsif ($phash->{format_description}) {
1878         return "<$phash->{format_description}>";
1879     } elsif ($phash->{enum}) {
1880         return "<" . join(' | ', sort @{$phash->{enum}}) . ">";
1881     } elsif ($phash->{pattern}) {
1882         return $phash->{pattern};
1883     } elsif ($type eq 'integer' || $type eq 'number') {
1884         # NOTE: always access values as number (avoid converion to string)
1885         if (defined($phash->{minimum}) && defined($phash->{maximum})) {
1886             return "<$type> (" . ($phash->{minimum} + 0) . " - " .
1887                 ($phash->{maximum} + 0) . ")";
1888         } elsif (defined($phash->{minimum})) {
1889             return "<$type> (" . ($phash->{minimum} + 0) . " - N)";
1890         } elsif (defined($phash->{maximum})) {
1891             return "<$type> (-N - " . ($phash->{maximum} + 0) . ")";
1892         }
1893     } elsif ($type eq 'string') {
1894         if (my $format = $phash->{format}) {
1895             $format = get_format($format) if ref($format) ne 'HASH';
1896             if (ref($format) eq 'HASH') {
1897                 my $list_enums = 0;
1898                 $list_enums = 1 if $style && $style eq 'config-sub';
1899                 return generate_typetext($format, $list_enums);
1900             }
1901         }
1902     }
1903
1904     return "<$type>";
1905 }
1906
1907 1;