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