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