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         download => {
1298             type => 'boolean',
1299             description => "Method downloads the file content (filename is the return value of the method).",
1300             optional => 1,
1301         },
1302         proxyto => {
1303             type =>  'string',
1304             description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1305             optional => 1,
1306         },
1307         proxyto_callback => {
1308             type =>  'coderef',
1309             description => "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter.",
1310             optional => 1,
1311         },
1312         permissions => {
1313             type => 'object',
1314             description => "Required access permissions. By default only 'root' is allowed to access this method.",
1315             optional => 1,
1316             additionalProperties => 0,
1317             properties => {
1318                 description => {
1319                      description => "Describe access permissions.",
1320                      optional => 1,
1321                 },
1322                 user => {
1323                     description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1324                     type => 'string',
1325                     enum => ['all', 'world'],
1326                     optional => 1,
1327                 },
1328                 check => {
1329                     description => "Array of permission checks (prefix notation).",
1330                     type => 'array',
1331                     optional => 1
1332                 },
1333             },
1334         },
1335         match_name => {
1336             description => "Used internally",
1337             optional => 1,
1338         },
1339         match_re => {
1340             description => "Used internally",
1341             optional => 1,
1342         },
1343         path => {
1344             type =>  'string',
1345             description => "path for URL matching (uri template)",
1346         },
1347         fragmentDelimiter => {
1348             type => 'string',
1349             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.",
1350             optional => 1,
1351         },
1352         parameters => {
1353             type => 'object',
1354             description => "JSON Schema for parameters.",
1355             optional => 1,
1356         },
1357         returns => {
1358             type => 'object',
1359             description => "JSON Schema for return value.",
1360             optional => 1,
1361         },
1362         code => {
1363             type => 'coderef',
1364             description => "method implementation (code reference)",
1365             optional => 1,
1366         },
1367         subclass => {
1368             type => 'string',
1369             description => "Delegate call to this class (perl class string).",
1370             optional => 1,
1371             requires => {
1372                 additionalProperties => 0,
1373                 properties => {
1374                     subclass => {},
1375                     path => {},
1376                     match_name => {},
1377                     match_re => {},
1378                     fragmentDelimiter => { optional => 1 }
1379                 }
1380             },
1381         },
1382     },
1383
1384 };
1385
1386 sub validate_schema {
1387     my ($schema) = @_;
1388
1389     my $errmsg = "internal error - unable to verify schema\n";
1390     validate($schema, $default_schema, $errmsg);
1391 }
1392
1393 sub validate_method_info {
1394     my $info = shift;
1395
1396     my $errmsg = "internal error - unable to verify method info\n";
1397     validate($info, $method_schema, $errmsg);
1398
1399     validate_schema($info->{parameters}) if $info->{parameters};
1400     validate_schema($info->{returns}) if $info->{returns};
1401 }
1402
1403 # run a self test on load
1404 # make sure we can verify the default schema
1405 validate_schema($default_schema_noref);
1406 validate_schema($method_schema);
1407
1408 # and now some utility methods (used by pve api)
1409 sub method_get_child_link {
1410     my ($info) = @_;
1411
1412     return undef if !$info;
1413
1414     my $schema = $info->{returns};
1415     return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
1416
1417     my $links = $schema->{links};
1418     return undef if !$links;
1419
1420     my $found;
1421     foreach my $lnk (@$links) {
1422         if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
1423             $found = $lnk;
1424             last;
1425         }
1426     }
1427
1428     return $found;
1429 }
1430
1431 # a way to parse command line parameters, using a
1432 # schema to configure Getopt::Long
1433 sub get_options {
1434     my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
1435
1436     if (!$schema || !$schema->{properties}) {
1437         raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1438             if scalar(@$args) != 0;
1439         return {};
1440     }
1441
1442     my $list_param;
1443     if ($arg_param && !ref($arg_param)) {
1444         my $pd = $schema->{properties}->{$arg_param};
1445         die "expected list format $pd->{format}"
1446             if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
1447         $list_param = $arg_param;
1448     }
1449
1450     my @interactive = ();
1451     my @getopt = ();
1452     foreach my $prop (keys %{$schema->{properties}}) {
1453         my $pd = $schema->{properties}->{$prop};
1454         next if $list_param && $prop eq $list_param;
1455         next if defined($fixed_param->{$prop});
1456
1457         my $mapping = $param_mapping_hash->{$prop};
1458         if ($mapping && $mapping->{interactive}) {
1459             # interactive parameters such as passwords: make the argument
1460             # optional and call the mapping function afterwards.
1461             push @getopt, "$prop:s";
1462             push @interactive, [$prop, $mapping->{func}];
1463         } elsif ($pd->{type} eq 'boolean') {
1464             push @getopt, "$prop:s";
1465         } else {
1466             if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
1467                 push @getopt, "$prop=s@";
1468             } else {
1469                 push @getopt, "$prop=s";
1470             }
1471         }
1472     }
1473
1474     Getopt::Long::Configure('prefix_pattern=(--|-)');
1475
1476     my $opts = {};
1477     raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
1478         if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
1479
1480     if (@$args) {
1481         if ($list_param) {
1482             $opts->{$list_param} = $args;
1483             $args = [];
1484         } elsif (ref($arg_param)) {
1485             foreach my $arg_name (@$arg_param) {
1486                 if ($opts->{'extra-args'}) {
1487                     raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
1488                 }
1489                 if ($arg_name eq 'extra-args') {
1490                     $opts->{'extra-args'} = $args;
1491                     $args = [];
1492                     next;
1493                 }
1494                 raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
1495                 $opts->{$arg_name} = shift @$args;
1496             }
1497             raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
1498         } else {
1499             raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1500                 if scalar(@$args) != 0;
1501         }
1502     } else {
1503         if (ref($arg_param)) {
1504             foreach my $arg_name (@$arg_param) {
1505                 if ($arg_name eq 'extra-args') {
1506                     $opts->{'extra-args'} = [];
1507                 } else {
1508                     raise("not enough arguments\n", code => HTTP_BAD_REQUEST);
1509                 }
1510             }
1511         }
1512     }
1513
1514     foreach my $entry (@interactive) {
1515         my ($opt, $func) = @$entry;
1516         my $pd = $schema->{properties}->{$opt};
1517         my $value = $opts->{$opt};
1518         if (defined($value) || !$pd->{optional}) {
1519             $opts->{$opt} = $func->($value);
1520         }
1521     }
1522
1523     # decode after Getopt as we are not sure how well it handles unicode
1524     foreach my $p (keys %$opts) {
1525         if (!ref($opts->{$p})) {
1526             $opts->{$p} = decode('locale', $opts->{$p});
1527         } elsif (ref($opts->{$p}) eq 'ARRAY') {
1528             my $tmp = [];
1529             foreach my $v (@{$opts->{$p}}) {
1530                 push @$tmp, decode('locale', $v);
1531             }
1532             $opts->{$p} = $tmp;
1533         } elsif (ref($opts->{$p}) eq 'SCALAR') {
1534             $opts->{$p} = decode('locale', $$opts->{$p});
1535         } else {
1536             raise("decoding options failed, unknown reference\n", code => HTTP_BAD_REQUEST);
1537         }
1538     }
1539
1540     foreach my $p (keys %$opts) {
1541         if (my $pd = $schema->{properties}->{$p}) {
1542             if ($pd->{type} eq 'boolean') {
1543                 if ($opts->{$p} eq '') {
1544                     $opts->{$p} = 1;
1545                 } elsif (defined(my $bool = parse_boolean($opts->{$p}))) {
1546                     $opts->{$p} = $bool;
1547                 } else {
1548                     raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
1549                 }
1550             } elsif ($pd->{format}) {
1551
1552                 if ($pd->{format} =~ m/-list/) {
1553                     # allow --vmid 100 --vmid 101 and --vmid 100,101
1554                     # allow --dow mon --dow fri and --dow mon,fri
1555                     $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1556                 } elsif ($pd->{format} =~ m/-alist/) {
1557                     # we encode array as \0 separated strings
1558                     # Note: CGI.pm also use this encoding
1559                     if (scalar(@{$opts->{$p}}) != 1) {
1560                         $opts->{$p} = join("\0", @{$opts->{$p}});
1561                     } else {
1562                         # st that split_list knows it is \0 terminated
1563                         my $v = $opts->{$p}->[0];
1564                         $opts->{$p} = "$v\0";
1565                     }
1566                 }
1567             }
1568         }
1569     }
1570
1571     foreach my $p (keys %$fixed_param) {
1572         $opts->{$p} = $fixed_param->{$p};
1573     }
1574
1575     return $opts;
1576 }
1577
1578 # A way to parse configuration data by giving a json schema
1579 sub parse_config {
1580     my ($schema, $filename, $raw) = @_;
1581
1582     # do fast check (avoid validate_schema($schema))
1583     die "got strange schema" if !$schema->{type} ||
1584         !$schema->{properties} || $schema->{type} ne 'object';
1585
1586     my $cfg = {};
1587
1588     while ($raw =~ /^\s*(.+?)\s*$/gm) {
1589         my $line = $1;
1590
1591         next if $line =~ /^#/;
1592
1593         if ($line =~ m/^(\S+?):\s*(.*)$/) {
1594             my $key = $1;
1595             my $value = $2;
1596             if ($schema->{properties}->{$key} &&
1597                 $schema->{properties}->{$key}->{type} eq 'boolean') {
1598
1599                 $value = parse_boolean($value) // $value;
1600             }
1601             $cfg->{$key} = $value;
1602         } else {
1603             warn "ignore config line: $line\n"
1604         }
1605     }
1606
1607     my $errors = {};
1608     check_prop($cfg, $schema, '', $errors);
1609
1610     foreach my $k (keys %$errors) {
1611         warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1612         delete $cfg->{$k};
1613     }
1614
1615     return $cfg;
1616 }
1617
1618 # generate simple key/value file
1619 sub dump_config {
1620     my ($schema, $filename, $cfg) = @_;
1621
1622     # do fast check (avoid validate_schema($schema))
1623     die "got strange schema" if !$schema->{type} ||
1624         !$schema->{properties} || $schema->{type} ne 'object';
1625
1626     validate($cfg, $schema, "validation error in '$filename'\n");
1627
1628     my $data = '';
1629
1630     foreach my $k (sort keys %$cfg) {
1631         $data .= "$k: $cfg->{$k}\n";
1632     }
1633
1634     return $data;
1635 }
1636
1637 # helpers used to generate our manual pages
1638
1639 my $find_schema_default_key = sub {
1640     my ($format) = @_;
1641
1642     my $default_key;
1643     my $keyAliasProps = {};
1644
1645     foreach my $key (keys %$format) {
1646         my $phash = $format->{$key};
1647         if ($phash->{default_key}) {
1648             die "multiple default keys in schema ($default_key, $key)\n"
1649                 if defined($default_key);
1650             die "default key '$key' is an alias - this is not allowed\n"
1651                 if defined($phash->{alias});
1652             die "default key '$key' with keyAlias attribute is not allowed\n"
1653                 if $phash->{keyAlias};
1654             $default_key = $key;
1655         }
1656         my $key_alias = $phash->{keyAlias};
1657         die "found keyAlias without 'alias definition for '$key'\n"
1658             if $key_alias && !$phash->{alias};
1659
1660         if ($phash->{alias} && $key_alias) {
1661             die "inconsistent keyAlias '$key_alias' definition"
1662                 if defined($keyAliasProps->{$key_alias}) &&
1663                 $keyAliasProps->{$key_alias} ne $phash->{alias};
1664             $keyAliasProps->{$key_alias} = $phash->{alias};
1665         }
1666     }
1667
1668     return wantarray ? ($default_key, $keyAliasProps) : $default_key;
1669 };
1670
1671 sub generate_typetext {
1672     my ($format, $list_enums) = @_;
1673
1674     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1675
1676     my $res = '';
1677     my $add_sep = 0;
1678
1679     my $add_option_string = sub {
1680         my ($text, $optional) = @_;
1681
1682         if ($add_sep) {
1683             $text = ",$text";
1684             $res .= ' ';
1685         }
1686         $text = "[$text]" if $optional;
1687         $res .= $text;
1688         $add_sep = 1;
1689     };
1690
1691     my $format_key_value = sub {
1692         my ($key, $phash) = @_;
1693
1694         die "internal error" if defined($phash->{alias});
1695
1696         my $keytext = $key;
1697
1698         my $typetext = '';
1699
1700         if (my $desc = $phash->{format_description}) {
1701             $typetext .= "<$desc>";
1702         } elsif (my $text = $phash->{typetext}) {
1703             $typetext .= $text;
1704         } elsif (my $enum = $phash->{enum}) {
1705             if ($list_enums || (scalar(@$enum) <= 3)) {
1706                 $typetext .= '<' . join('|', @$enum) . '>';
1707             } else {
1708                 $typetext .= '<enum>';
1709             }
1710         } elsif ($phash->{type} eq 'boolean') {
1711             $typetext .= '<1|0>';
1712         } elsif ($phash->{type} eq 'integer') {
1713             $typetext .= '<integer>';
1714         } elsif ($phash->{type} eq 'number') {
1715             $typetext .= '<number>';
1716         } else {
1717             die "internal error: neither format_description nor typetext found for option '$key'";
1718         }
1719
1720         if (defined($default_key) && ($default_key eq $key)) {
1721             &$add_option_string("[$keytext=]$typetext", $phash->{optional});
1722         } else {
1723             &$add_option_string("$keytext=$typetext", $phash->{optional});
1724         }
1725     };
1726
1727     my $done = {};
1728
1729     my $cond_add_key = sub {
1730         my ($key) = @_;
1731
1732         return if $done->{$key}; # avoid duplicates
1733
1734         $done->{$key} = 1;
1735
1736         my $phash = $format->{$key};
1737
1738         return if !$phash; # should not happen
1739
1740         return if $phash->{alias};
1741
1742         &$format_key_value($key, $phash);
1743
1744     };
1745
1746     &$cond_add_key($default_key) if defined($default_key);
1747
1748     # add required keys first
1749     foreach my $key (sort keys %$format) {
1750         my $phash = $format->{$key};
1751         &$cond_add_key($key) if $phash && !$phash->{optional};
1752     }
1753
1754     # add the rest
1755     foreach my $key (sort keys %$format) {
1756         &$cond_add_key($key);
1757     }
1758
1759     foreach my $keyAlias (sort keys %$keyAliasProps) {
1760         &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
1761     }
1762
1763     return $res;
1764 }
1765
1766 sub print_property_string {
1767     my ($data, $format, $skip, $path) = @_;
1768
1769     if (ref($format) ne 'HASH') {
1770         my $schema = get_format($format);
1771         die "not a valid format: $format\n" if !$schema;
1772         $format = $schema;
1773     }
1774
1775     my $errors = {};
1776     check_object($path, $format, $data, undef, $errors);
1777     if (scalar(%$errors)) {
1778         raise "format error", errors => $errors;
1779     }
1780
1781     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1782
1783     my $res = '';
1784     my $add_sep = 0;
1785
1786     my $add_option_string = sub {
1787         my ($text) = @_;
1788
1789         $res .= ',' if $add_sep;
1790         $res .= $text;
1791         $add_sep = 1;
1792     };
1793
1794     my $format_value = sub {
1795         my ($key, $value, $format) = @_;
1796
1797         if (defined($format) && ($format eq 'disk-size')) {
1798             return format_size($value);
1799         } else {
1800             die "illegal value with commas for $key\n" if $value =~ /,/;
1801             return $value;
1802         }
1803     };
1804
1805     my $done = { map { $_ => 1 } @$skip };
1806
1807     my $cond_add_key = sub {
1808         my ($key, $isdefault) = @_;
1809
1810         return if $done->{$key}; # avoid duplicates
1811
1812         $done->{$key} = 1;
1813
1814         my $value = $data->{$key};
1815
1816         return if !defined($value);
1817
1818         my $phash = $format->{$key};
1819
1820         # try to combine values if we have key aliases
1821         if (my $combine = $keyAliasProps->{$key}) {
1822             if (defined(my $combine_value = $data->{$combine})) {
1823                 my $combine_format = $format->{$combine}->{format};
1824                 my $value_str = &$format_value($key, $value, $phash->{format});
1825                 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
1826                 &$add_option_string("${value_str}=${combine_str}");
1827                 $done->{$combine} = 1;
1828                 return;
1829             }
1830         }
1831
1832         if ($phash && $phash->{alias}) {
1833             $phash = $format->{$phash->{alias}};
1834         }
1835
1836         die "invalid key '$key'\n" if !$phash;
1837         die "internal error" if defined($phash->{alias});
1838
1839         my $value_str = &$format_value($key, $value, $phash->{format});
1840         if ($isdefault) {
1841             &$add_option_string($value_str);
1842         } else {
1843             &$add_option_string("$key=${value_str}");
1844         }
1845     };
1846
1847     # add default key first
1848     &$cond_add_key($default_key, 1) if defined($default_key);
1849
1850     # add required keys first
1851     foreach my $key (sort keys %$data) {
1852         my $phash = $format->{$key};
1853         &$cond_add_key($key) if $phash && !$phash->{optional};
1854     }
1855
1856     # add the rest
1857     foreach my $key (sort keys %$data) {
1858         &$cond_add_key($key);
1859     }
1860
1861     return $res;
1862 }
1863
1864 sub schema_get_type_text {
1865     my ($phash, $style) = @_;
1866
1867     my $type = $phash->{type} || 'string';
1868
1869     if ($phash->{typetext}) {
1870         return $phash->{typetext};
1871     } elsif ($phash->{format_description}) {
1872         return "<$phash->{format_description}>";
1873     } elsif ($phash->{enum}) {
1874         return "<" . join(' | ', sort @{$phash->{enum}}) . ">";
1875     } elsif ($phash->{pattern}) {
1876         return $phash->{pattern};
1877     } elsif ($type eq 'integer' || $type eq 'number') {
1878         # NOTE: always access values as number (avoid converion to string)
1879         if (defined($phash->{minimum}) && defined($phash->{maximum})) {
1880             return "<$type> (" . ($phash->{minimum} + 0) . " - " .
1881                 ($phash->{maximum} + 0) . ")";
1882         } elsif (defined($phash->{minimum})) {
1883             return "<$type> (" . ($phash->{minimum} + 0) . " - N)";
1884         } elsif (defined($phash->{maximum})) {
1885             return "<$type> (-N - " . ($phash->{maximum} + 0) . ")";
1886         }
1887     } elsif ($type eq 'string') {
1888         if (my $format = $phash->{format}) {
1889             $format = get_format($format) if ref($format) ne 'HASH';
1890             if (ref($format) eq 'HASH') {
1891                 my $list_enums = 0;
1892                 $list_enums = 1 if $style && $style eq 'config-sub';
1893                 return generate_typetext($format, $list_enums);
1894             }
1895         }
1896     }
1897
1898     return "<$type>";
1899 }
1900
1901 1;