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