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