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