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