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