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