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