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         renderer => {
1085             type => "string",
1086             optional => 1,
1087             description => "This is used to provide rendering hints to format cli command output.",
1088         },
1089         requires => {
1090             type => [ "string", "object" ],
1091             optional => 1,
1092             description => "indicates a required property or a schema that must be validated if this property is present",
1093         },
1094         format => {
1095             type => [ "string", "object" ],
1096             optional => 1,
1097             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",
1098         },
1099         default_key => {
1100             type => "boolean",
1101             optional => 1,
1102             description => "Whether this is the default key in a comma separated list property string.",
1103         },
1104         alias => {
1105             type => 'string',
1106             optional => 1,
1107             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.",
1108         },
1109         keyAlias => {
1110             type => 'string',
1111             optional => 1,
1112             description => "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1113             requires => 'alias',
1114         },
1115         default => {
1116             type => "any",
1117             optional => 1,
1118             description => "This indicates the default for the instance property."
1119         },
1120         completion => {
1121             type => 'coderef',
1122             description => "Bash completion function. This function should return a list of possible values.",
1123             optional => 1,
1124         },
1125         disallow => {
1126             type => "object",
1127             optional => 1,
1128             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.",
1129         },
1130         extends => {
1131             type => "object",
1132             optional => 1,
1133             description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1134             default => {},
1135         },
1136         # this is from hyper schema
1137         links => {
1138             type => "array",
1139             description => "This defines the link relations of the instance objects",
1140             optional => 1,
1141             items => {
1142                 type => "object",
1143                 properties => {
1144                     href => {
1145                         type => "string",
1146                         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",
1147                     },
1148                     rel => {
1149                         type => "string",
1150                         description => "This is the name of the link relation",
1151                         optional => 1,
1152                         default => "full",
1153                     },
1154                     method => {
1155                         type => "string",
1156                         description => "For submission links, this defines the method that should be used to access the target resource",
1157                         optional => 1,
1158                         default => "GET",
1159                     },
1160                 },
1161             },
1162         },
1163         print_width => {
1164             type => "integer",
1165             description => "For CLI context, this defines the maximal width to print before truncating",
1166             optional => 1,
1167         },
1168     }
1169 };
1170
1171 my $default_schema = Storable::dclone($default_schema_noref);
1172
1173 $default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
1174 $default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
1175
1176 $default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
1177 $default_schema->{properties}->{items}->{additionalProperties} = 0;
1178
1179 $default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
1180 $default_schema->{properties}->{disallow}->{additionalProperties} = 0;
1181
1182 $default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
1183 $default_schema->{properties}->{requires}->{additionalProperties} = 0;
1184
1185 $default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
1186 $default_schema->{properties}->{extends}->{additionalProperties} = 0;
1187
1188 my $method_schema = {
1189     type => "object",
1190     additionalProperties => 0,
1191     properties => {
1192         description => {
1193             description => "This a description of the method",
1194             optional => 1,
1195         },
1196         name => {
1197             type =>  'string',
1198             description => "This indicates the name of the function to call.",
1199             optional => 1,
1200             requires => {
1201                 additionalProperties => 1,
1202                 properties => {
1203                     name => {},
1204                     description => {},
1205                     code => {},
1206                     method => {},
1207                     parameters => {},
1208                     path => {},
1209                     parameters => {},
1210                     returns => {},
1211                 }
1212             },
1213         },
1214         method => {
1215             type =>  'string',
1216             description => "The HTTP method name.",
1217             enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
1218             optional => 1,
1219         },
1220         protected => {
1221             type => 'boolean',
1222             description => "Method needs special privileges - only pvedaemon can execute it",
1223             optional => 1,
1224         },
1225         download => {
1226             type => 'boolean',
1227             description => "Method downloads the file content (filename is the return value of the method).",
1228             optional => 1,
1229         },
1230         proxyto => {
1231             type =>  'string',
1232             description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1233             optional => 1,
1234         },
1235         proxyto_callback => {
1236             type =>  'coderef',
1237             description => "A function which is called to resolve the proxyto attribute. The default implementaion returns the value of the 'proxyto' parameter.",
1238             optional => 1,
1239         },
1240         permissions => {
1241             type => 'object',
1242             description => "Required access permissions. By default only 'root' is allowed to access this method.",
1243             optional => 1,
1244             additionalProperties => 0,
1245             properties => {
1246                 description => {
1247                      description => "Describe access permissions.",
1248                      optional => 1,
1249                 },
1250                 user => {
1251                     description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1252                     type => 'string',
1253                     enum => ['all', 'world'],
1254                     optional => 1,
1255                 },
1256                 check => {
1257                     description => "Array of permission checks (prefix notation).",
1258                     type => 'array',
1259                     optional => 1
1260                 },
1261             },
1262         },
1263         match_name => {
1264             description => "Used internally",
1265             optional => 1,
1266         },
1267         match_re => {
1268             description => "Used internally",
1269             optional => 1,
1270         },
1271         path => {
1272             type =>  'string',
1273             description => "path for URL matching (uri template)",
1274         },
1275         fragmentDelimiter => {
1276             type => 'string',
1277             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.",
1278             optional => 1,
1279         },
1280         parameters => {
1281             type => 'object',
1282             description => "JSON Schema for parameters.",
1283             optional => 1,
1284         },
1285         returns => {
1286             type => 'object',
1287             description => "JSON Schema for return value.",
1288             optional => 1,
1289         },
1290         code => {
1291             type => 'coderef',
1292             description => "method implementaion (code reference)",
1293             optional => 1,
1294         },
1295         subclass => {
1296             type => 'string',
1297             description => "Delegate call to this class (perl class string).",
1298             optional => 1,
1299             requires => {
1300                 additionalProperties => 0,
1301                 properties => {
1302                     subclass => {},
1303                     path => {},
1304                     match_name => {},
1305                     match_re => {},
1306                     fragmentDelimiter => { optional => 1 }
1307                 }
1308             },
1309         },
1310     },
1311
1312 };
1313
1314 sub validate_schema {
1315     my ($schema) = @_;
1316
1317     my $errmsg = "internal error - unable to verify schema\n";
1318     validate($schema, $default_schema, $errmsg);
1319 }
1320
1321 sub validate_method_info {
1322     my $info = shift;
1323
1324     my $errmsg = "internal error - unable to verify method info\n";
1325     validate($info, $method_schema, $errmsg);
1326
1327     validate_schema($info->{parameters}) if $info->{parameters};
1328     validate_schema($info->{returns}) if $info->{returns};
1329 }
1330
1331 # run a self test on load
1332 # make sure we can verify the default schema
1333 validate_schema($default_schema_noref);
1334 validate_schema($method_schema);
1335
1336 # and now some utility methods (used by pve api)
1337 sub method_get_child_link {
1338     my ($info) = @_;
1339
1340     return undef if !$info;
1341
1342     my $schema = $info->{returns};
1343     return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
1344
1345     my $links = $schema->{links};
1346     return undef if !$links;
1347
1348     my $found;
1349     foreach my $lnk (@$links) {
1350         if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
1351             $found = $lnk;
1352             last;
1353         }
1354     }
1355
1356     return $found;
1357 }
1358
1359 # a way to parse command line parameters, using a
1360 # schema to configure Getopt::Long
1361 sub get_options {
1362     my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
1363
1364     if (!$schema || !$schema->{properties}) {
1365         raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1366             if scalar(@$args) != 0;
1367         return {};
1368     }
1369
1370     my $list_param;
1371     if ($arg_param && !ref($arg_param)) {
1372         my $pd = $schema->{properties}->{$arg_param};
1373         die "expected list format $pd->{format}"
1374             if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
1375         $list_param = $arg_param;
1376     }
1377
1378     my @interactive = ();
1379     my @getopt = ();
1380     foreach my $prop (keys %{$schema->{properties}}) {
1381         my $pd = $schema->{properties}->{$prop};
1382         next if $list_param && $prop eq $list_param;
1383         next if defined($fixed_param->{$prop});
1384
1385         my $mapping = $param_mapping_hash->{$prop};
1386         if ($mapping && $mapping->{interactive}) {
1387             # interactive parameters such as passwords: make the argument
1388             # optional and call the mapping function afterwards.
1389             push @getopt, "$prop:s";
1390             push @interactive, [$prop, $mapping->{func}];
1391         } elsif ($pd->{type} eq 'boolean') {
1392             push @getopt, "$prop:s";
1393         } else {
1394             if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
1395                 push @getopt, "$prop=s@";
1396             } else {
1397                 push @getopt, "$prop=s";
1398             }
1399         }
1400     }
1401
1402     Getopt::Long::Configure('prefix_pattern=(--|-)');
1403
1404     my $opts = {};
1405     raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
1406         if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
1407
1408     if (@$args) {
1409         if ($list_param) {
1410             $opts->{$list_param} = $args;
1411             $args = [];
1412         } elsif (ref($arg_param)) {
1413             foreach my $arg_name (@$arg_param) {
1414                 if ($opts->{'extra-args'}) {
1415                     raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
1416                 }
1417                 if ($arg_name eq 'extra-args') {
1418                     $opts->{'extra-args'} = $args;
1419                     $args = [];
1420                     next;
1421                 }
1422                 raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
1423                 $opts->{$arg_name} = shift @$args;
1424             }
1425             raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
1426         } else {
1427             raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1428                 if scalar(@$args) != 0;
1429         }
1430     } else {
1431         if (ref($arg_param)) {
1432             foreach my $arg_name (@$arg_param) {
1433                 if ($arg_name eq 'extra-args') {
1434                     $opts->{'extra-args'} = [];
1435                 } else {
1436                     raise("not enough arguments\n", code => HTTP_BAD_REQUEST);
1437                 }
1438             }
1439         }
1440     }
1441
1442     foreach my $entry (@interactive) {
1443         my ($opt, $func) = @$entry;
1444         my $pd = $schema->{properties}->{$opt};
1445         my $value = $opts->{$opt};
1446         if (defined($value) || !$pd->{optional}) {
1447             $opts->{$opt} = $func->($value);
1448         }
1449     }
1450
1451     # decode after Getopt as we are not sure how well it handles unicode
1452     foreach my $p (keys %$opts) {
1453         if (!ref($opts->{$p})) {
1454             $opts->{$p} = decode('locale', $opts->{$p});
1455         } elsif (ref($opts->{$p}) eq 'ARRAY') {
1456             my $tmp = [];
1457             foreach my $v (@{$opts->{$p}}) {
1458                 push @$tmp, decode('locale', $v);
1459             }
1460             $opts->{$p} = $tmp;
1461         } elsif (ref($opts->{$p}) eq 'SCALAR') {
1462             $opts->{$p} = decode('locale', $$opts->{$p});
1463         } else {
1464             raise("decoding options failed, unknown reference\n", code => HTTP_BAD_REQUEST);
1465         }
1466     }
1467
1468     foreach my $p (keys %$opts) {
1469         if (my $pd = $schema->{properties}->{$p}) {
1470             if ($pd->{type} eq 'boolean') {
1471                 if ($opts->{$p} eq '') {
1472                     $opts->{$p} = 1;
1473                 } elsif (defined(my $bool = parse_boolean($opts->{$p}))) {
1474                     $opts->{$p} = $bool;
1475                 } else {
1476                     raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
1477                 }
1478             } elsif ($pd->{format}) {
1479
1480                 if ($pd->{format} =~ m/-list/) {
1481                     # allow --vmid 100 --vmid 101 and --vmid 100,101
1482                     # allow --dow mon --dow fri and --dow mon,fri
1483                     $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1484                 } elsif ($pd->{format} =~ m/-alist/) {
1485                     # we encode array as \0 separated strings
1486                     # Note: CGI.pm also use this encoding
1487                     if (scalar(@{$opts->{$p}}) != 1) {
1488                         $opts->{$p} = join("\0", @{$opts->{$p}});
1489                     } else {
1490                         # st that split_list knows it is \0 terminated
1491                         my $v = $opts->{$p}->[0];
1492                         $opts->{$p} = "$v\0";
1493                     }
1494                 }
1495             }
1496         }
1497     }
1498
1499     foreach my $p (keys %$fixed_param) {
1500         $opts->{$p} = $fixed_param->{$p};
1501     }
1502
1503     return $opts;
1504 }
1505
1506 # A way to parse configuration data by giving a json schema
1507 sub parse_config {
1508     my ($schema, $filename, $raw) = @_;
1509
1510     # do fast check (avoid validate_schema($schema))
1511     die "got strange schema" if !$schema->{type} ||
1512         !$schema->{properties} || $schema->{type} ne 'object';
1513
1514     my $cfg = {};
1515
1516     while ($raw =~ /^\s*(.+?)\s*$/gm) {
1517         my $line = $1;
1518
1519         next if $line =~ /^#/;
1520
1521         if ($line =~ m/^(\S+?):\s*(.*)$/) {
1522             my $key = $1;
1523             my $value = $2;
1524             if ($schema->{properties}->{$key} &&
1525                 $schema->{properties}->{$key}->{type} eq 'boolean') {
1526
1527                 $value = parse_boolean($value) // $value;
1528             }
1529             $cfg->{$key} = $value;
1530         } else {
1531             warn "ignore config line: $line\n"
1532         }
1533     }
1534
1535     my $errors = {};
1536     check_prop($cfg, $schema, '', $errors);
1537
1538     foreach my $k (keys %$errors) {
1539         warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1540         delete $cfg->{$k};
1541     }
1542
1543     return $cfg;
1544 }
1545
1546 # generate simple key/value file
1547 sub dump_config {
1548     my ($schema, $filename, $cfg) = @_;
1549
1550     # do fast check (avoid validate_schema($schema))
1551     die "got strange schema" if !$schema->{type} ||
1552         !$schema->{properties} || $schema->{type} ne 'object';
1553
1554     validate($cfg, $schema, "validation error in '$filename'\n");
1555
1556     my $data = '';
1557
1558     foreach my $k (keys %$cfg) {
1559         $data .= "$k: $cfg->{$k}\n";
1560     }
1561
1562     return $data;
1563 }
1564
1565 # helpers used to generate our manual pages
1566
1567 my $find_schema_default_key = sub {
1568     my ($format) = @_;
1569
1570     my $default_key;
1571     my $keyAliasProps = {};
1572
1573     foreach my $key (keys %$format) {
1574         my $phash = $format->{$key};
1575         if ($phash->{default_key}) {
1576             die "multiple default keys in schema ($default_key, $key)\n"
1577                 if defined($default_key);
1578             die "default key '$key' is an alias - this is not allowed\n"
1579                 if defined($phash->{alias});
1580             die "default key '$key' with keyAlias attribute is not allowed\n"
1581                 if $phash->{keyAlias};
1582             $default_key = $key;
1583         }
1584         my $key_alias = $phash->{keyAlias};
1585         die "found keyAlias without 'alias definition for '$key'\n"
1586             if $key_alias && !$phash->{alias};
1587
1588         if ($phash->{alias} && $key_alias) {
1589             die "inconsistent keyAlias '$key_alias' definition"
1590                 if defined($keyAliasProps->{$key_alias}) &&
1591                 $keyAliasProps->{$key_alias} ne $phash->{alias};
1592             $keyAliasProps->{$key_alias} = $phash->{alias};
1593         }
1594     }
1595
1596     return wantarray ? ($default_key, $keyAliasProps) : $default_key;
1597 };
1598
1599 sub generate_typetext {
1600     my ($format, $list_enums) = @_;
1601
1602     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1603
1604     my $res = '';
1605     my $add_sep = 0;
1606
1607     my $add_option_string = sub {
1608         my ($text, $optional) = @_;
1609
1610         if ($add_sep) {
1611             $text = ",$text";
1612             $res .= ' ';
1613         }
1614         $text = "[$text]" if $optional;
1615         $res .= $text;
1616         $add_sep = 1;
1617     };
1618
1619     my $format_key_value = sub {
1620         my ($key, $phash) = @_;
1621
1622         die "internal error" if defined($phash->{alias});
1623
1624         my $keytext = $key;
1625
1626         my $typetext = '';
1627
1628         if (my $desc = $phash->{format_description}) {
1629             $typetext .= "<$desc>";
1630         } elsif (my $text = $phash->{typetext}) {
1631             $typetext .= $text;
1632         } elsif (my $enum = $phash->{enum}) {
1633             if ($list_enums || (scalar(@$enum) <= 3)) {
1634                 $typetext .= '<' . join('|', @$enum) . '>';
1635             } else {
1636                 $typetext .= '<enum>';
1637             }
1638         } elsif ($phash->{type} eq 'boolean') {
1639             $typetext .= '<1|0>';
1640         } elsif ($phash->{type} eq 'integer') {
1641             $typetext .= '<integer>';
1642         } elsif ($phash->{type} eq 'number') {
1643             $typetext .= '<number>';
1644         } else {
1645             die "internal error: neither format_description nor typetext found for option '$key'";
1646         }
1647
1648         if (defined($default_key) && ($default_key eq $key)) {
1649             &$add_option_string("[$keytext=]$typetext", $phash->{optional});
1650         } else {
1651             &$add_option_string("$keytext=$typetext", $phash->{optional});
1652         }
1653     };
1654
1655     my $done = {};
1656
1657     my $cond_add_key = sub {
1658         my ($key) = @_;
1659
1660         return if $done->{$key}; # avoid duplicates
1661
1662         $done->{$key} = 1;
1663
1664         my $phash = $format->{$key};
1665
1666         return if !$phash; # should not happen
1667
1668         return if $phash->{alias};
1669
1670         &$format_key_value($key, $phash);
1671
1672     };
1673
1674     &$cond_add_key($default_key) if defined($default_key);
1675
1676     # add required keys first
1677     foreach my $key (sort keys %$format) {
1678         my $phash = $format->{$key};
1679         &$cond_add_key($key) if $phash && !$phash->{optional};
1680     }
1681
1682     # add the rest
1683     foreach my $key (sort keys %$format) {
1684         &$cond_add_key($key);
1685     }
1686
1687     foreach my $keyAlias (sort keys %$keyAliasProps) {
1688         &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
1689     }
1690
1691     return $res;
1692 }
1693
1694 sub print_property_string {
1695     my ($data, $format, $skip, $path) = @_;
1696
1697     if (ref($format) ne 'HASH') {
1698         my $schema = get_format($format);
1699         die "not a valid format: $format\n" if !$schema;
1700         $format = $schema;
1701     }
1702
1703     my $errors = {};
1704     check_object($path, $format, $data, undef, $errors);
1705     if (scalar(%$errors)) {
1706         raise "format error", errors => $errors;
1707     }
1708
1709     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1710
1711     my $res = '';
1712     my $add_sep = 0;
1713
1714     my $add_option_string = sub {
1715         my ($text) = @_;
1716
1717         $res .= ',' if $add_sep;
1718         $res .= $text;
1719         $add_sep = 1;
1720     };
1721
1722     my $format_value = sub {
1723         my ($key, $value, $format) = @_;
1724
1725         if (defined($format) && ($format eq 'disk-size')) {
1726             return format_size($value);
1727         } else {
1728             die "illegal value with commas for $key\n" if $value =~ /,/;
1729             return $value;
1730         }
1731     };
1732
1733     my $done = { map { $_ => 1 } @$skip };
1734
1735     my $cond_add_key = sub {
1736         my ($key, $isdefault) = @_;
1737
1738         return if $done->{$key}; # avoid duplicates
1739
1740         $done->{$key} = 1;
1741
1742         my $value = $data->{$key};
1743
1744         return if !defined($value);
1745
1746         my $phash = $format->{$key};
1747
1748         # try to combine values if we have key aliases
1749         if (my $combine = $keyAliasProps->{$key}) {
1750             if (defined(my $combine_value = $data->{$combine})) {
1751                 my $combine_format = $format->{$combine}->{format};
1752                 my $value_str = &$format_value($key, $value, $phash->{format});
1753                 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
1754                 &$add_option_string("${value_str}=${combine_str}");
1755                 $done->{$combine} = 1;
1756                 return;
1757             }
1758         }
1759
1760         if ($phash && $phash->{alias}) {
1761             $phash = $format->{$phash->{alias}};
1762         }
1763
1764         die "invalid key '$key'\n" if !$phash;
1765         die "internal error" if defined($phash->{alias});
1766
1767         my $value_str = &$format_value($key, $value, $phash->{format});
1768         if ($isdefault) {
1769             &$add_option_string($value_str);
1770         } else {
1771             &$add_option_string("$key=${value_str}");
1772         }
1773     };
1774
1775     # add default key first
1776     &$cond_add_key($default_key, 1) if defined($default_key);
1777
1778     # add required keys first
1779     foreach my $key (sort keys %$data) {
1780         my $phash = $format->{$key};
1781         &$cond_add_key($key) if $phash && !$phash->{optional};
1782     }
1783
1784     # add the rest
1785     foreach my $key (sort keys %$data) {
1786         &$cond_add_key($key);
1787     }
1788
1789     return $res;
1790 }
1791
1792 sub schema_get_type_text {
1793     my ($phash, $style) = @_;
1794
1795     my $type = $phash->{type} || 'string';
1796
1797     if ($phash->{typetext}) {
1798         return $phash->{typetext};
1799     } elsif ($phash->{format_description}) {
1800         return "<$phash->{format_description}>";
1801     } elsif ($phash->{enum}) {
1802         return "<" . join(' | ', sort @{$phash->{enum}}) . ">";
1803     } elsif ($phash->{pattern}) {
1804         return $phash->{pattern};
1805     } elsif ($type eq 'integer' || $type eq 'number') {
1806         # NOTE: always access values as number (avoid converion to string)
1807         if (defined($phash->{minimum}) && defined($phash->{maximum})) {
1808             return "<$type> (" . ($phash->{minimum} + 0) . " - " .
1809                 ($phash->{maximum} + 0) . ")";
1810         } elsif (defined($phash->{minimum})) {
1811             return "<$type> (" . ($phash->{minimum} + 0) . " - N)";
1812         } elsif (defined($phash->{maximum})) {
1813             return "<$type> (-N - " . ($phash->{maximum} + 0) . ")";
1814         }
1815     } elsif ($type eq 'string') {
1816         if (my $format = $phash->{format}) {
1817             $format = get_format($format) if ref($format) ne 'HASH';
1818             if (ref($format) eq 'HASH') {
1819                 my $list_enums = 0;
1820                 $list_enums = 1 if $style && $style eq 'config-sub';
1821                 return generate_typetext($format, $list_enums);
1822             }
1823         }
1824     }
1825
1826     return "<$type>";
1827 }
1828
1829 1;