src/PVE/JSONSchema.pm

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