src/PVE/JSONSchema.pm

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