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