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