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