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