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     # 'download' responses can contain a filehandle, don't cycle-check that as
1187     # it produces a warning
1188     my $is_download = ref($instance) eq 'HASH' && exists($instance->{download});
1189     find_cycle($instance, sub { $cycles = 1 }) if !$is_download;
1190     if ($cycles) {
1191         add_error($errors, undef, "data structure contains recursive cycles");
1192     } elsif ($schema) {
1193         check_prop($instance, $schema, '', $errors);
1194     }
1195
1196     if (scalar(%$errors)) {
1197         raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors;
1198     }
1199
1200     return 1;
1201 }
1202
1203 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
1204 my $default_schema_noref = {
1205     description => "This is the JSON Schema for JSON Schemas.",
1206     type => [ "object" ],
1207     additionalProperties => 0,
1208     properties => {
1209         type => {
1210             type => ["string", "array"],
1211             description => "This is a type definition value. This can be a simple type, or a union type",
1212             optional => 1,
1213             default => "any",
1214             items => {
1215                 type => "string",
1216                 enum => $schema_valid_types,
1217             },
1218             enum => $schema_valid_types,
1219         },
1220         optional => {
1221             type => "boolean",
1222             description => "This indicates that the instance property in the instance object is not required.",
1223             optional => 1,
1224             default => 0
1225         },
1226         properties => {
1227             type => "object",
1228             description => "This is a definition for the properties of an object value",
1229             optional => 1,
1230             default => {},
1231         },
1232         items => {
1233             type => "object",
1234             description => "When the value is an array, this indicates the schema to use to validate each item in an array",
1235             optional => 1,
1236             default => {},
1237         },
1238         additionalProperties => {
1239             type => [ "boolean", "object"],
1240             description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
1241             optional => 1,
1242             default => {},
1243         },
1244         minimum => {
1245             type => "number",
1246             optional => 1,
1247             description => "This indicates the minimum value for the instance property when the type of the instance value is a number.",
1248         },
1249         maximum => {
1250             type => "number",
1251             optional => 1,
1252             description => "This indicates the maximum value for the instance property when the type of the instance value is a number.",
1253         },
1254         minLength => {
1255             type => "integer",
1256             description => "When the instance value is a string, this indicates minimum length of the string",
1257             optional => 1,
1258             minimum => 0,
1259             default => 0,
1260         },
1261         maxLength => {
1262             type => "integer",
1263             description => "When the instance value is a string, this indicates maximum length of the string.",
1264             optional => 1,
1265         },
1266         typetext => {
1267             type => "string",
1268             optional => 1,
1269             description => "A text representation of the type (used to generate documentation).",
1270         },
1271         pattern => {
1272             type => "string",
1273             format => "regex",
1274             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.",
1275             optional => 1,
1276             default => ".*",
1277         },
1278         enum => {
1279             type => "array",
1280             optional => 1,
1281             description => "This provides an enumeration of possible values that are valid for the instance property.",
1282         },
1283         description => {
1284             type => "string",
1285             optional => 1,
1286             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).",
1287         },
1288         verbose_description => {
1289             type => "string",
1290             optional => 1,
1291             description => "This provides a more verbose description.",
1292         },
1293         format_description => {
1294             type => "string",
1295             optional => 1,
1296             description => "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1297         },
1298         title => {
1299             type => "string",
1300             optional => 1,
1301             description => "This provides the title of the property",
1302         },
1303         renderer => {
1304             type => "string",
1305             optional => 1,
1306             description => "This is used to provide rendering hints to format cli command output.",
1307         },
1308         requires => {
1309             type => [ "string", "object" ],
1310             optional => 1,
1311             description => "indicates a required property or a schema that must be validated if this property is present",
1312         },
1313         format => {
1314             type => [ "string", "object" ],
1315             optional => 1,
1316             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",
1317         },
1318         default_key => {
1319             type => "boolean",
1320             optional => 1,
1321             description => "Whether this is the default key in a comma separated list property string.",
1322         },
1323         alias => {
1324             type => 'string',
1325             optional => 1,
1326             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.",
1327         },
1328         keyAlias => {
1329             type => 'string',
1330             optional => 1,
1331             description => "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1332             requires => 'alias',
1333         },
1334         default => {
1335             type => "any",
1336             optional => 1,
1337             description => "This indicates the default for the instance property."
1338         },
1339         completion => {
1340             type => 'coderef',
1341             description => "Bash completion function. This function should return a list of possible values.",
1342             optional => 1,
1343         },
1344         disallow => {
1345             type => "object",
1346             optional => 1,
1347             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.",
1348         },
1349         extends => {
1350             type => "object",
1351             optional => 1,
1352             description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1353             default => {},
1354         },
1355         # this is from hyper schema
1356         links => {
1357             type => "array",
1358             description => "This defines the link relations of the instance objects",
1359             optional => 1,
1360             items => {
1361                 type => "object",
1362                 properties => {
1363                     href => {
1364                         type => "string",
1365                         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",
1366                     },
1367                     rel => {
1368                         type => "string",
1369                         description => "This is the name of the link relation",
1370                         optional => 1,
1371                         default => "full",
1372                     },
1373                     method => {
1374                         type => "string",
1375                         description => "For submission links, this defines the method that should be used to access the target resource",
1376                         optional => 1,
1377                         default => "GET",
1378                     },
1379                 },
1380             },
1381         },
1382         print_width => {
1383             type => "integer",
1384             description => "For CLI context, this defines the maximal width to print before truncating",
1385             optional => 1,
1386         },
1387     }
1388 };
1389
1390 my $default_schema = Storable::dclone($default_schema_noref);
1391
1392 $default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
1393 $default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
1394
1395 $default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
1396 $default_schema->{properties}->{items}->{additionalProperties} = 0;
1397
1398 $default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
1399 $default_schema->{properties}->{disallow}->{additionalProperties} = 0;
1400
1401 $default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
1402 $default_schema->{properties}->{requires}->{additionalProperties} = 0;
1403
1404 $default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
1405 $default_schema->{properties}->{extends}->{additionalProperties} = 0;
1406
1407 my $method_schema = {
1408     type => "object",
1409     additionalProperties => 0,
1410     properties => {
1411         description => {
1412             description => "This a description of the method",
1413             optional => 1,
1414         },
1415         name => {
1416             type =>  'string',
1417             description => "This indicates the name of the function to call.",
1418             optional => 1,
1419             requires => {
1420                 additionalProperties => 1,
1421                 properties => {
1422                     name => {},
1423                     description => {},
1424                     code => {},
1425                     method => {},
1426                     parameters => {},
1427                     path => {},
1428                     parameters => {},
1429                     returns => {},
1430                 }
1431             },
1432         },
1433         method => {
1434             type =>  'string',
1435             description => "The HTTP method name.",
1436             enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
1437             optional => 1,
1438         },
1439         protected => {
1440             type => 'boolean',
1441             description => "Method needs special privileges - only pvedaemon can execute it",
1442             optional => 1,
1443         },
1444         allowtoken => {
1445             type => 'boolean',
1446             description => "Method is available for clients authenticated using an API token.",
1447             optional => 1,
1448             default => 1,
1449         },
1450         download => {
1451             type => 'boolean',
1452             description => "Method downloads the file content (filename is the return value of the method).",
1453             optional => 1,
1454         },
1455         proxyto => {
1456             type =>  'string',
1457             description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1458             optional => 1,
1459         },
1460         proxyto_callback => {
1461             type =>  'coderef',
1462             description => "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter.",
1463             optional => 1,
1464         },
1465         permissions => {
1466             type => 'object',
1467             description => "Required access permissions. By default only 'root' is allowed to access this method.",
1468             optional => 1,
1469             additionalProperties => 0,
1470             properties => {
1471                 description => {
1472                      description => "Describe access permissions.",
1473                      optional => 1,
1474                 },
1475                 user => {
1476                     description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1477                     type => 'string',
1478                     enum => ['all', 'world'],
1479                     optional => 1,
1480                 },
1481                 check => {
1482                     description => "Array of permission checks (prefix notation).",
1483                     type => 'array',
1484                     optional => 1
1485                 },
1486             },
1487         },
1488         match_name => {
1489             description => "Used internally",
1490             optional => 1,
1491         },
1492         match_re => {
1493             description => "Used internally",
1494             optional => 1,
1495         },
1496         path => {
1497             type =>  'string',
1498             description => "path for URL matching (uri template)",
1499         },
1500         fragmentDelimiter => {
1501             type => 'string',
1502             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.",
1503             optional => 1,
1504         },
1505         parameters => {
1506             type => 'object',
1507             description => "JSON Schema for parameters.",
1508             optional => 1,
1509         },
1510         returns => {
1511             type => 'object',
1512             description => "JSON Schema for return value.",
1513             optional => 1,
1514         },
1515         code => {
1516             type => 'coderef',
1517             description => "method implementation (code reference)",
1518             optional => 1,
1519         },
1520         subclass => {
1521             type => 'string',
1522             description => "Delegate call to this class (perl class string).",
1523             optional => 1,
1524             requires => {
1525                 additionalProperties => 0,
1526                 properties => {
1527                     subclass => {},
1528                     path => {},
1529                     match_name => {},
1530                     match_re => {},
1531                     fragmentDelimiter => { optional => 1 }
1532                 }
1533             },
1534         },
1535     },
1536
1537 };
1538
1539 sub validate_schema {
1540     my ($schema) = @_;
1541
1542     my $errmsg = "internal error - unable to verify schema\n";
1543     validate($schema, $default_schema, $errmsg);
1544 }
1545
1546 sub validate_method_info {
1547     my $info = shift;
1548
1549     my $errmsg = "internal error - unable to verify method info\n";
1550     validate($info, $method_schema, $errmsg);
1551
1552     validate_schema($info->{parameters}) if $info->{parameters};
1553     validate_schema($info->{returns}) if $info->{returns};
1554 }
1555
1556 # run a self test on load
1557 # make sure we can verify the default schema
1558 validate_schema($default_schema_noref);
1559 validate_schema($method_schema);
1560
1561 # and now some utility methods (used by pve api)
1562 sub method_get_child_link {
1563     my ($info) = @_;
1564
1565     return undef if !$info;
1566
1567     my $schema = $info->{returns};
1568     return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
1569
1570     my $links = $schema->{links};
1571     return undef if !$links;
1572
1573     my $found;
1574     foreach my $lnk (@$links) {
1575         if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
1576             $found = $lnk;
1577             last;
1578         }
1579     }
1580
1581     return $found;
1582 }
1583
1584 # a way to parse command line parameters, using a
1585 # schema to configure Getopt::Long
1586 sub get_options {
1587     my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
1588
1589     if (!$schema || !$schema->{properties}) {
1590         raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1591             if scalar(@$args) != 0;
1592         return {};
1593     }
1594
1595     my $list_param;
1596     if ($arg_param && !ref($arg_param)) {
1597         my $pd = $schema->{properties}->{$arg_param};
1598         die "expected list format $pd->{format}"
1599             if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
1600         $list_param = $arg_param;
1601     }
1602
1603     my @interactive = ();
1604     my @getopt = ();
1605     foreach my $prop (keys %{$schema->{properties}}) {
1606         my $pd = $schema->{properties}->{$prop};
1607         next if $list_param && $prop eq $list_param;
1608         next if defined($fixed_param->{$prop});
1609
1610         my $mapping = $param_mapping_hash->{$prop};
1611         if ($mapping && $mapping->{interactive}) {
1612             # interactive parameters such as passwords: make the argument
1613             # optional and call the mapping function afterwards.
1614             push @getopt, "$prop:s";
1615             push @interactive, [$prop, $mapping->{func}];
1616         } elsif ($pd->{type} eq 'boolean') {
1617             push @getopt, "$prop:s";
1618         } else {
1619             if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
1620                 push @getopt, "$prop=s@";
1621             } else {
1622                 push @getopt, "$prop=s";
1623             }
1624         }
1625     }
1626
1627     Getopt::Long::Configure('prefix_pattern=(--|-)');
1628
1629     my $opts = {};
1630     raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
1631         if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
1632
1633     if (@$args) {
1634         if ($list_param) {
1635             $opts->{$list_param} = $args;
1636             $args = [];
1637         } elsif (ref($arg_param)) {
1638             for (my $i = 0; $i < scalar(@$arg_param); $i++) {
1639                 my $arg_name = $arg_param->[$i];
1640                 if ($opts->{'extra-args'}) {
1641                     raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
1642                 }
1643                 if ($arg_name eq 'extra-args') {
1644                     $opts->{'extra-args'} = $args;
1645                     $args = [];
1646                     next;
1647                 }
1648                 if (!@$args) {
1649                     # check if all left-over arg_param are optional, else we
1650                     # must die as the mapping is then ambigious
1651                     for (; $i < scalar(@$arg_param); $i++) {
1652                         my $prop = $arg_param->[$i];
1653                         raise("not enough arguments\n", code => HTTP_BAD_REQUEST)
1654                             if !$schema->{properties}->{$prop}->{optional};
1655                     }
1656                     if ($arg_param->[-1] eq 'extra-args') {
1657                         $opts->{'extra-args'} = [];
1658                     }
1659                     last;
1660                 }
1661                 $opts->{$arg_name} = shift @$args;
1662             }
1663             raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
1664         } else {
1665             raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1666                 if scalar(@$args) != 0;
1667         }
1668     } else {
1669         if (ref($arg_param)) {
1670             foreach my $arg_name (@$arg_param) {
1671                 if ($arg_name eq 'extra-args') {
1672                     $opts->{'extra-args'} = [];
1673                 } elsif (!$schema->{properties}->{$arg_name}->{optional}) {
1674                     raise("not enough arguments\n", code => HTTP_BAD_REQUEST);
1675                 }
1676             }
1677         }
1678     }
1679
1680     foreach my $entry (@interactive) {
1681         my ($opt, $func) = @$entry;
1682         my $pd = $schema->{properties}->{$opt};
1683         my $value = $opts->{$opt};
1684         if (defined($value) || !$pd->{optional}) {
1685             $opts->{$opt} = $func->($value);
1686         }
1687     }
1688
1689     # decode after Getopt as we are not sure how well it handles unicode
1690     foreach my $p (keys %$opts) {
1691         if (!ref($opts->{$p})) {
1692             $opts->{$p} = decode('locale', $opts->{$p});
1693         } elsif (ref($opts->{$p}) eq 'ARRAY') {
1694             my $tmp = [];
1695             foreach my $v (@{$opts->{$p}}) {
1696                 push @$tmp, decode('locale', $v);
1697             }
1698             $opts->{$p} = $tmp;
1699         } elsif (ref($opts->{$p}) eq 'SCALAR') {
1700             $opts->{$p} = decode('locale', $$opts->{$p});
1701         } else {
1702             raise("decoding options failed, unknown reference\n", code => HTTP_BAD_REQUEST);
1703         }
1704     }
1705
1706     foreach my $p (keys %$opts) {
1707         if (my $pd = $schema->{properties}->{$p}) {
1708             if ($pd->{type} eq 'boolean') {
1709                 if ($opts->{$p} eq '') {
1710                     $opts->{$p} = 1;
1711                 } elsif (defined(my $bool = parse_boolean($opts->{$p}))) {
1712                     $opts->{$p} = $bool;
1713                 } else {
1714                     raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
1715                 }
1716             } elsif ($pd->{format}) {
1717
1718                 if ($pd->{format} =~ m/-list/) {
1719                     # allow --vmid 100 --vmid 101 and --vmid 100,101
1720                     # allow --dow mon --dow fri and --dow mon,fri
1721                     $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1722                 } elsif ($pd->{format} =~ m/-alist/) {
1723                     # we encode array as \0 separated strings
1724                     # Note: CGI.pm also use this encoding
1725                     if (scalar(@{$opts->{$p}}) != 1) {
1726                         $opts->{$p} = join("\0", @{$opts->{$p}});
1727                     } else {
1728                         # st that split_list knows it is \0 terminated
1729                         my $v = $opts->{$p}->[0];
1730                         $opts->{$p} = "$v\0";
1731                     }
1732                 }
1733             }
1734         }
1735     }
1736
1737     foreach my $p (keys %$fixed_param) {
1738         $opts->{$p} = $fixed_param->{$p};
1739     }
1740
1741     return $opts;
1742 }
1743
1744 # A way to parse configuration data by giving a json schema
1745 sub parse_config {
1746     my ($schema, $filename, $raw) = @_;
1747
1748     # do fast check (avoid validate_schema($schema))
1749     die "got strange schema" if !$schema->{type} ||
1750         !$schema->{properties} || $schema->{type} ne 'object';
1751
1752     my $cfg = {};
1753
1754     while ($raw =~ /^\s*(.+?)\s*$/gm) {
1755         my $line = $1;
1756
1757         next if $line =~ /^#/;
1758
1759         if ($line =~ m/^(\S+?):\s*(.*)$/) {
1760             my $key = $1;
1761             my $value = $2;
1762             if ($schema->{properties}->{$key} &&
1763                 $schema->{properties}->{$key}->{type} eq 'boolean') {
1764
1765                 $value = parse_boolean($value) // $value;
1766             }
1767             $cfg->{$key} = $value;
1768         } else {
1769             warn "ignore config line: $line\n"
1770         }
1771     }
1772
1773     my $errors = {};
1774     check_prop($cfg, $schema, '', $errors);
1775
1776     foreach my $k (keys %$errors) {
1777         warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1778         delete $cfg->{$k};
1779     }
1780
1781     return $cfg;
1782 }
1783
1784 # generate simple key/value file
1785 sub dump_config {
1786     my ($schema, $filename, $cfg) = @_;
1787
1788     # do fast check (avoid validate_schema($schema))
1789     die "got strange schema" if !$schema->{type} ||
1790         !$schema->{properties} || $schema->{type} ne 'object';
1791
1792     validate($cfg, $schema, "validation error in '$filename'\n");
1793
1794     my $data = '';
1795
1796     foreach my $k (sort keys %$cfg) {
1797         $data .= "$k: $cfg->{$k}\n";
1798     }
1799
1800     return $data;
1801 }
1802
1803 # helpers used to generate our manual pages
1804
1805 my $find_schema_default_key = sub {
1806     my ($format) = @_;
1807
1808     my $default_key;
1809     my $keyAliasProps = {};
1810
1811     foreach my $key (keys %$format) {
1812         my $phash = $format->{$key};
1813         if ($phash->{default_key}) {
1814             die "multiple default keys in schema ($default_key, $key)\n"
1815                 if defined($default_key);
1816             die "default key '$key' is an alias - this is not allowed\n"
1817                 if defined($phash->{alias});
1818             die "default key '$key' with keyAlias attribute is not allowed\n"
1819                 if $phash->{keyAlias};
1820             $default_key = $key;
1821         }
1822         my $key_alias = $phash->{keyAlias};
1823         die "found keyAlias without 'alias definition for '$key'\n"
1824             if $key_alias && !$phash->{alias};
1825
1826         if ($phash->{alias} && $key_alias) {
1827             die "inconsistent keyAlias '$key_alias' definition"
1828                 if defined($keyAliasProps->{$key_alias}) &&
1829                 $keyAliasProps->{$key_alias} ne $phash->{alias};
1830             $keyAliasProps->{$key_alias} = $phash->{alias};
1831         }
1832     }
1833
1834     return wantarray ? ($default_key, $keyAliasProps) : $default_key;
1835 };
1836
1837 sub generate_typetext {
1838     my ($format, $list_enums) = @_;
1839
1840     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1841
1842     my $res = '';
1843     my $add_sep = 0;
1844
1845     my $add_option_string = sub {
1846         my ($text, $optional) = @_;
1847
1848         if ($add_sep) {
1849             $text = ",$text";
1850             $res .= ' ';
1851         }
1852         $text = "[$text]" if $optional;
1853         $res .= $text;
1854         $add_sep = 1;
1855     };
1856
1857     my $format_key_value = sub {
1858         my ($key, $phash) = @_;
1859
1860         die "internal error" if defined($phash->{alias});
1861
1862         my $keytext = $key;
1863
1864         my $typetext = '';
1865
1866         if (my $desc = $phash->{format_description}) {
1867             $typetext .= "<$desc>";
1868         } elsif (my $text = $phash->{typetext}) {
1869             $typetext .= $text;
1870         } elsif (my $enum = $phash->{enum}) {
1871             if ($list_enums || (scalar(@$enum) <= 3)) {
1872                 $typetext .= '<' . join('|', @$enum) . '>';
1873             } else {
1874                 $typetext .= '<enum>';
1875             }
1876         } elsif ($phash->{type} eq 'boolean') {
1877             $typetext .= '<1|0>';
1878         } elsif ($phash->{type} eq 'integer') {
1879             $typetext .= '<integer>';
1880         } elsif ($phash->{type} eq 'number') {
1881             $typetext .= '<number>';
1882         } else {
1883             die "internal error: neither format_description nor typetext found for option '$key'";
1884         }
1885
1886         if (defined($default_key) && ($default_key eq $key)) {
1887             &$add_option_string("[$keytext=]$typetext", $phash->{optional});
1888         } else {
1889             &$add_option_string("$keytext=$typetext", $phash->{optional});
1890         }
1891     };
1892
1893     my $done = {};
1894
1895     my $cond_add_key = sub {
1896         my ($key) = @_;
1897
1898         return if $done->{$key}; # avoid duplicates
1899
1900         $done->{$key} = 1;
1901
1902         my $phash = $format->{$key};
1903
1904         return if !$phash; # should not happen
1905
1906         return if $phash->{alias};
1907
1908         &$format_key_value($key, $phash);
1909
1910     };
1911
1912     &$cond_add_key($default_key) if defined($default_key);
1913
1914     # add required keys first
1915     foreach my $key (sort keys %$format) {
1916         my $phash = $format->{$key};
1917         &$cond_add_key($key) if $phash && !$phash->{optional};
1918     }
1919
1920     # add the rest
1921     foreach my $key (sort keys %$format) {
1922         &$cond_add_key($key);
1923     }
1924
1925     foreach my $keyAlias (sort keys %$keyAliasProps) {
1926         &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
1927     }
1928
1929     return $res;
1930 }
1931
1932 sub print_property_string {
1933     my ($data, $format, $skip, $path) = @_;
1934
1935     my $validator;
1936     if (ref($format) ne 'HASH') {
1937         my $schema = get_format($format);
1938         die "not a valid format: $format\n" if !$schema;
1939         # named formats can have validators attached
1940         $validator = $format_validators->{$format};
1941         $format = $schema;
1942     }
1943
1944     my $errors = {};
1945     check_object($path, $format, $data, undef, $errors);
1946     if (scalar(%$errors)) {
1947         raise "format error", errors => $errors;
1948     }
1949
1950     $data = $validator->($data) if $validator;
1951
1952     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1953
1954     my $res = '';
1955     my $add_sep = 0;
1956
1957     my $add_option_string = sub {
1958         my ($text) = @_;
1959
1960         $res .= ',' if $add_sep;
1961         $res .= $text;
1962         $add_sep = 1;
1963     };
1964
1965     my $format_value = sub {
1966         my ($key, $value, $format) = @_;
1967
1968         if (defined($format) && ($format eq 'disk-size')) {
1969             return format_size($value);
1970         } else {
1971             die "illegal value with commas for $key\n" if $value =~ /,/;
1972             return $value;
1973         }
1974     };
1975
1976     my $done = { map { $_ => 1 } @$skip };
1977
1978     my $cond_add_key = sub {
1979         my ($key, $isdefault) = @_;
1980
1981         return if $done->{$key}; # avoid duplicates
1982
1983         $done->{$key} = 1;
1984
1985         my $value = $data->{$key};
1986
1987         return if !defined($value);
1988
1989         my $phash = $format->{$key};
1990
1991         # try to combine values if we have key aliases
1992         if (my $combine = $keyAliasProps->{$key}) {
1993             if (defined(my $combine_value = $data->{$combine})) {
1994                 my $combine_format = $format->{$combine}->{format};
1995                 my $value_str = &$format_value($key, $value, $phash->{format});
1996                 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
1997                 &$add_option_string("${value_str}=${combine_str}");
1998                 $done->{$combine} = 1;
1999                 return;
2000             }
2001         }
2002
2003         if ($phash && $phash->{alias}) {
2004             $phash = $format->{$phash->{alias}};
2005         }
2006
2007         die "invalid key '$key'\n" if !$phash;
2008         die "internal error" if defined($phash->{alias});
2009
2010         my $value_str = &$format_value($key, $value, $phash->{format});
2011         if ($isdefault) {
2012             &$add_option_string($value_str);
2013         } else {
2014             &$add_option_string("$key=${value_str}");
2015         }
2016     };
2017
2018     # add default key first
2019     &$cond_add_key($default_key, 1) if defined($default_key);
2020
2021     # add required keys first
2022     foreach my $key (sort keys %$data) {
2023         my $phash = $format->{$key};
2024         &$cond_add_key($key) if $phash && !$phash->{optional};
2025     }
2026
2027     # add the rest
2028     foreach my $key (sort keys %$data) {
2029         &$cond_add_key($key);
2030     }
2031
2032     return $res;
2033 }
2034
2035 sub schema_get_type_text {
2036     my ($phash, $style) = @_;
2037
2038     my $type = $phash->{type} || 'string';
2039
2040     if ($phash->{typetext}) {
2041         return $phash->{typetext};
2042     } elsif ($phash->{format_description}) {
2043         return "<$phash->{format_description}>";
2044     } elsif ($phash->{enum}) {
2045         return "<" . join(' | ', sort @{$phash->{enum}}) . ">";
2046     } elsif ($phash->{pattern}) {
2047         return $phash->{pattern};
2048     } elsif ($type eq 'integer' || $type eq 'number') {
2049         # NOTE: always access values as number (avoid converion to string)
2050         if (defined($phash->{minimum}) && defined($phash->{maximum})) {
2051             return "<$type> (" . ($phash->{minimum} + 0) . " - " .
2052                 ($phash->{maximum} + 0) . ")";
2053         } elsif (defined($phash->{minimum})) {
2054             return "<$type> (" . ($phash->{minimum} + 0) . " - N)";
2055         } elsif (defined($phash->{maximum})) {
2056             return "<$type> (-N - " . ($phash->{maximum} + 0) . ")";
2057         }
2058     } elsif ($type eq 'string') {
2059         if (my $format = $phash->{format}) {
2060             $format = get_format($format) if ref($format) ne 'HASH';
2061             if (ref($format) eq 'HASH') {
2062                 my $list_enums = 0;
2063                 $list_enums = 1 if $style && $style eq 'config-sub';
2064                 return generate_typetext($format, $list_enums);
2065             }
2066         }
2067     }
2068
2069     return "<$type>";
2070 }
2071
2072 1;