src/PVE/JSONSchema.pm

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