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