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