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