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