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