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 Devel::Cycle -quiet; # todo: remove?
   8 use PVE::Tools qw(split_list $IPV6RE $IPV4RE);
   9 use PVE::Exception qw(raise);
  10 use HTTP::Status qw(:constants);
  11 use Net::IP qw(:PROC);
  12
  13 use base 'Exporter';
  14
  15 our @EXPORT_OK = qw(
  16 register_standard_option
  17 get_standard_option
  18 );
  19
  20 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
  21 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
  22 # see: http://json-schema.org/
  23
  24 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
  25
  26 my $standard_options = {};
  27 sub register_standard_option {
  28     my ($name, $schema) = @_;
  29
  30     die "standard option '$name' already registered\n"
  31         if $standard_options->{$name};
  32
  33     $standard_options->{$name} = $schema;
  34 }
  35
  36 sub get_standard_option {
  37     my ($name, $base) = @_;
  38
  39     my $std =  $standard_options->{$name};
  40     die "no such standard option '$name'\n" if !$std;
  41
  42     my $res = $base || {};
  43
  44     foreach my $opt (keys %$std) {
  45         next if defined($res->{$opt});
  46         $res->{$opt} = $std->{$opt};
  47     }
  48
  49     return $res;
  50 };
  51
  52 register_standard_option('pve-vmid', {
  53     description => "The (unique) ID of the VM.",
  54     type => 'integer', format => 'pve-vmid',
  55     minimum => 1
  56 });
  57
  58 register_standard_option('pve-node', {
  59     description => "The cluster node name.",
  60     type => 'string', format => 'pve-node',
  61 });
  62
  63 register_standard_option('pve-node-list', {
  64     description => "List of cluster node names.",
  65     type => 'string', format => 'pve-node-list',
  66 });
  67
  68 register_standard_option('pve-iface', {
  69     description => "Network interface name.",
  70     type => 'string', format => 'pve-iface',
  71     minLength => 2, maxLength => 20,
  72 });
  73
  74 PVE::JSONSchema::register_standard_option('pve-storage-id', {
  75     description => "The storage identifier.",
  76     type => 'string', format => 'pve-storage-id',
  77 });
  78
  79 PVE::JSONSchema::register_standard_option('pve-config-digest', {
  80     description => 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.',
  81     type => 'string',
  82     optional => 1,
  83     maxLength => 40, # sha1 hex digest lenght is 40
  84 });
  85
  86 PVE::JSONSchema::register_standard_option('extra-args', {
  87     description => "Extra arguments as array",
  88     type => 'array',
  89     items => { type => 'string' },
  90     optional => 1
  91 });
  92
  93 my $format_list = {};
  94
  95 sub register_format {
  96     my ($format, $code) = @_;
  97
  98     die "JSON schema format '$format' already registered\n"
  99         if $format_list->{$format};
 100
 101     $format_list->{$format} = $code;
 102 }
 103
 104 sub get_format {
 105     my ($format) = @_;
 106     return $format_list->{$format};
 107 }
 108
 109 # register some common type for pve
 110
 111 register_format('string', sub {}); # allow format => 'string-list'
 112
 113 register_format('pve-configid', \&pve_verify_configid);
 114 sub pve_verify_configid {
 115     my ($id, $noerr) = @_;
 116
 117     if ($id !~ m/^[a-z][a-z0-9_]+$/i) {
 118         return undef if $noerr;
 119         die "invalid configuration ID '$id'\n";
 120     }
 121     return $id;
 122 }
 123
 124 PVE::JSONSchema::register_format('pve-storage-id', \&parse_storage_id);
 125 sub parse_storage_id {
 126     my ($storeid, $noerr) = @_;
 127
 128     if ($storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
 129         return undef if $noerr;
 130         die "storage ID '$storeid' contains illegal characters\n";
 131     }
 132     return $storeid;
 133 }
 134
 135
 136 register_format('pve-vmid', \&pve_verify_vmid);
 137 sub pve_verify_vmid {
 138     my ($vmid, $noerr) = @_;
 139
 140     if ($vmid !~ m/^[1-9][0-9]+$/) {
 141         return undef if $noerr;
 142         die "value does not look like a valid VM ID\n";
 143     }
 144     return $vmid;
 145 }
 146
 147 register_format('pve-node', \&pve_verify_node_name);
 148 sub pve_verify_node_name {
 149     my ($node, $noerr) = @_;
 150
 151     if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) {
 152         return undef if $noerr;
 153         die "value does not look like a valid node name\n";
 154     }
 155     return $node;
 156 }
 157
 158 register_format('ipv4', \&pve_verify_ipv4);
 159 sub pve_verify_ipv4 {
 160     my ($ipv4, $noerr) = @_;
 161
 162     if ($ipv4 !~ m/^(?:$IPV4RE)$/) {
 163         return undef if $noerr;
 164         die "value does not look like a valid IPv4 address\n";
 165     }
 166     return $ipv4;
 167 }
 168
 169 register_format('ipv6', \&pve_verify_ipv6);
 170 sub pve_verify_ipv6 {
 171     my ($ipv6, $noerr) = @_;
 172
 173     if ($ipv6 !~ m/^(?:$IPV6RE)$/) {
 174         return undef if $noerr;
 175         die "value does not look like a valid IPv6 address\n";
 176     }
 177     return $ipv6;
 178 }
 179
 180 register_format('ip', \&pve_verify_ip);
 181 sub pve_verify_ip {
 182     my ($ip, $noerr) = @_;
 183
 184     if ($ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/) {
 185         return undef if $noerr;
 186         die "value does not look like a valid IP address\n";
 187     }
 188     return $ip;
 189 }
 190
 191 my $ipv4_mask_hash = {
 192     '128.0.0.0' => 1,
 193     '192.0.0.0' => 2,
 194     '224.0.0.0' => 3,
 195     '240.0.0.0' => 4,
 196     '248.0.0.0' => 5,
 197     '252.0.0.0' => 6,
 198     '254.0.0.0' => 7,
 199     '255.0.0.0' => 8,
 200     '255.128.0.0' => 9,
 201     '255.192.0.0' => 10,
 202     '255.224.0.0' => 11,
 203     '255.240.0.0' => 12,
 204     '255.248.0.0' => 13,
 205     '255.252.0.0' => 14,
 206     '255.254.0.0' => 15,
 207     '255.255.0.0' => 16,
 208     '255.255.128.0' => 17,
 209     '255.255.192.0' => 18,
 210     '255.255.224.0' => 19,
 211     '255.255.240.0' => 20,
 212     '255.255.248.0' => 21,
 213     '255.255.252.0' => 22,
 214     '255.255.254.0' => 23,
 215     '255.255.255.0' => 24,
 216     '255.255.255.128' => 25,
 217     '255.255.255.192' => 26,
 218     '255.255.255.224' => 27,
 219     '255.255.255.240' => 28,
 220     '255.255.255.248' => 29,
 221     '255.255.255.252' => 30
 222 };
 223
 224 register_format('ipv4mask', \&pve_verify_ipv4mask);
 225 sub pve_verify_ipv4mask {
 226     my ($mask, $noerr) = @_;
 227
 228     if (!defined($ipv4_mask_hash->{$mask})) {
 229         return undef if $noerr;
 230         die "value does not look like a valid IP netmask\n";
 231     }
 232     return $mask;
 233 }
 234
 235 register_format('CIDRv6', \&pve_verify_cidrv6);
 236 sub pve_verify_cidrv6 {
 237     my ($cidr, $noerr) = @_;
 238
 239     if ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) &&  ($1 <= 120)) {
 240         return $cidr;
 241     }
 242
 243     return undef if $noerr;
 244     die "value does not look like a valid IPv6 CIDR network\n";
 245 }
 246
 247 register_format('CIDRv4', \&pve_verify_cidrv4);
 248 sub pve_verify_cidrv4 {
 249     my ($cidr, $noerr) = @_;
 250
 251     if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) &&  ($1 < 32)) {
 252         return $cidr;
 253     }
 254
 255     return undef if $noerr;
 256     die "value does not look like a valid IPv4 CIDR network\n";
 257 }
 258
 259 register_format('CIDR', \&pve_verify_cidr);
 260 sub pve_verify_cidr {
 261     my ($cidr, $noerr) = @_;
 262
 263     if (!(pve_verify_cidrv4($cidr, 1) ||
 264           pve_verify_cidrv6($cidr, 1)))
 265     {
 266         return undef if $noerr;
 267         die "value does not look like a valid CIDR network\n";
 268     }
 269
 270     return $cidr;
 271 }
 272
 273 register_format('pve-ipv4-config', \&pve_verify_ipv4_config);
 274 sub pve_verify_ipv4_config {
 275     my ($config, $noerr) = @_;
 276
 277     return $config if $config =~ /^(?:dhcp|manual)$/ ||
 278                       pve_verify_cidrv4($config, 1);
 279     return undef if $noerr;
 280     die "value does not look like a valid ipv4 network configuration\n";
 281 }
 282
 283 register_format('pve-ipv6-config', \&pve_verify_ipv6_config);
 284 sub pve_verify_ipv6_config {
 285     my ($config, $noerr) = @_;
 286
 287     return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
 288                       pve_verify_cidrv6($config, 1);
 289     return undef if $noerr;
 290     die "value does not look like a valid ipv6 network configuration\n";
 291 }
 292
 293 register_format('email', \&pve_verify_email);
 294 sub pve_verify_email {
 295     my ($email, $noerr) = @_;
 296
 297     # we use same regex as in Utils.js
 298     if ($email !~ /^(\w+)([\-+.][\w]+)*@(\w[\-\w]*\.){1,5}([A-Za-z]){2,63}$/) {
 299            return undef if $noerr;
 300            die "value does not look like a valid email address\n";
 301     }
 302     return $email;
 303 }
 304
 305 register_format('dns-name', \&pve_verify_dns_name);
 306 sub pve_verify_dns_name {
 307     my ($name, $noerr) = @_;
 308
 309     my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)";
 310
 311     if ($name !~ /^(${namere}\.)*${namere}$/) {
 312            return undef if $noerr;
 313            die "value does not look like a valid DNS name\n";
 314     }
 315     return $name;
 316 }
 317
 318 # network interface name
 319 register_format('pve-iface', \&pve_verify_iface);
 320 sub pve_verify_iface {
 321     my ($id, $noerr) = @_;
 322
 323     if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
 324         return undef if $noerr;
 325         die "invalid network interface name '$id'\n";
 326     }
 327     return $id;
 328 }
 329
 330 # general addresses by name or IP
 331 register_format('address', \&pve_verify_address);
 332 sub pve_verify_address {
 333     my ($addr, $noerr) = @_;
 334
 335     if (!(pve_verify_ip($addr, 1) ||
 336           pve_verify_dns_name($addr, 1)))
 337     {
 338            return undef if $noerr;
 339            die "value does not look like a valid address: $addr\n";
 340     }
 341     return $addr;
 342 }
 343
 344 register_format('disk-size', \&pve_verify_disk_size);
 345 sub pve_verify_disk_size {
 346     my ($size, $noerr) = @_;
 347     if (!defined(parse_size($size))) {
 348         return undef if $noerr;
 349         die "value does not look like a valid disk size: $size\n";
 350     }
 351     return $size;
 352 }
 353
 354 register_standard_option('spice-proxy', {
 355     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).",
 356     type => 'string', format => 'address',
 357 });
 358
 359 register_standard_option('remote-viewer-config', {
 360     description => "Returned values can be directly passed to the 'remote-viewer' application.",
 361     additionalProperties => 1,
 362     properties => {
 363         type => { type => 'string' },
 364         password => { type => 'string' },
 365         proxy => { type => 'string' },
 366         host => { type => 'string' },
 367         'tls-port' => { type => 'integer' },
 368     },
 369 });
 370
 371 register_format('pve-startup-order', \&pve_verify_startup_order);
 372 sub pve_verify_startup_order {
 373     my ($value, $noerr) = @_;
 374
 375     return $value if pve_parse_startup_order($value);
 376
 377     return undef if $noerr;
 378
 379     die "unable to parse startup options\n";
 380 }
 381
 382 sub pve_parse_startup_order {
 383     my ($value) = @_;
 384
 385     return undef if !$value;
 386
 387     my $res = {};
 388
 389     foreach my $p (split(/,/, $value)) {
 390         next if $p =~ m/^\s*$/;
 391
 392         if ($p =~ m/^(order=)?(\d+)$/) {
 393             $res->{order} = $2;
 394         } elsif ($p =~ m/^up=(\d+)$/) {
 395             $res->{up} = $1;
 396         } elsif ($p =~ m/^down=(\d+)$/) {
 397             $res->{down} = $1;
 398         } else {
 399             return undef;
 400         }
 401     }
 402
 403     return $res;
 404 }
 405
 406 PVE::JSONSchema::register_standard_option('pve-startup-order', {
 407     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.",
 408     optional => 1,
 409     type => 'string', format => 'pve-startup-order',
 410     typetext => '[[order=]\d+] [,up=\d+] [,down=\d+] ',
 411 });
 412
 413 sub check_format {
 414     my ($format, $value, $path) = @_;
 415
 416     return parse_property_string($format, $value, $path) if ref($format) eq 'HASH';
 417     return if $format eq 'regex';
 418
 419     if ($format =~ m/^(.*)-a?list$/) {
 420
 421         my $code = $format_list->{$1};
 422
 423         die "undefined format '$format'\n" if !$code;
 424
 425         # Note: we allow empty lists
 426         foreach my $v (split_list($value)) {
 427             &$code($v);
 428         }
 429
 430     } elsif ($format =~ m/^(.*)-opt$/) {
 431
 432         my $code = $format_list->{$1};
 433
 434         die "undefined format '$format'\n" if !$code;
 435
 436         return if !$value; # allow empty string
 437
 438         &$code($value);
 439
 440    } else {
 441
 442         my $code = $format_list->{$format};
 443
 444         die "undefined format '$format'\n" if !$code;
 445
 446         return parse_property_string($code, $value, $path) if ref($code) eq 'HASH';
 447         &$code($value);
 448     }
 449 }
 450
 451 sub parse_size {
 452     my ($value) = @_;
 453
 454     return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
 455     my ($size, $unit) = ($1, $3);
 456     if ($unit) {
 457         if ($unit eq 'K') {
 458             $size = $size * 1024;
 459         } elsif ($unit eq 'M') {
 460             $size = $size * 1024 * 1024;
 461         } elsif ($unit eq 'G') {
 462             $size = $size * 1024 * 1024 * 1024;
 463         } elsif ($unit eq 'T') {
 464             $size = $size * 1024 * 1024 * 1024 * 1024;
 465         }
 466     }
 467     return int($size);
 468 };
 469
 470 sub format_size {
 471     my ($size) = @_;
 472
 473     $size = int($size);
 474
 475     my $kb = int($size/1024);
 476     return $size if $kb*1024 != $size;
 477
 478     my $mb = int($kb/1024);
 479     return "${kb}K" if $mb*1024 != $kb;
 480
 481     my $gb = int($mb/1024);
 482     return "${mb}M" if $gb*1024 != $mb;
 483
 484     my $tb = int($gb/1024);
 485     return "${gb}G" if $tb*1024 != $gb;
 486
 487     return "${tb}T";
 488 };
 489
 490 sub parse_property_string {
 491     my ($format, $data, $path) = @_;
 492
 493     my $default_key;
 494
 495     my $res = {};
 496     foreach my $part (split(/,/, $data)) {
 497         next if $part =~ /^\s*$/;
 498
 499         if ($part =~ /^([^=]+)=(.+)$/) {
 500             my ($k, $v) = ($1, $2);
 501             die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
 502             my $schema = $format->{$k};
 503             if (my $alias = $schema->{alias}) {
 504                 $k = $alias;
 505                 $schema = $format->{$k};
 506             }
 507             die "invalid key in comma-separated list property: $k\n" if !$schema;
 508             if ($schema->{type} && $schema->{type} eq 'boolean') {
 509                 $v = 1 if $v =~ m/^(1|on|yes|true)$/i;
 510                 $v = 0 if $v =~ m/^(0|off|no|false)$/i;
 511             }
 512             $res->{$k} = $v;
 513         } elsif ($part !~ /=/) {
 514             die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
 515             foreach my $key (keys %$format) {
 516                 if ($format->{$key}->{default_key}) {
 517                     $default_key = $key;
 518                     if (!$res->{$default_key}) {
 519                         $res->{$default_key} = $part;
 520                         last;
 521                     }
 522                     die "duplicate key in comma-separated list property: $default_key\n";
 523                 }
 524             }
 525         } else {
 526             die "missing key in comma-separated list property\n";
 527         }
 528     }
 529
 530     my $errors = {};
 531     check_object($path, $format, $res, undef, $errors);
 532     if (scalar(%$errors)) {
 533         raise "format error\n", errors => $errors;
 534     }
 535
 536     return $res;
 537 }
 538
 539 sub print_property_string {
 540     my ($data, $format, $skip, $path) = @_;
 541
 542     if (ref($format) ne 'HASH') {
 543         my $schema = $format_list->{$format};
 544         die "not a valid format: $format" if !$schema;
 545         $format = $schema;
 546     }
 547
 548     my $errors = {};
 549     check_object($path, $format, $data, undef, $errors);
 550     if (scalar(%$errors)) {
 551         raise "format error", errors => $errors;
 552     }
 553
 554     my $default_key;
 555     my %skipped = map { $_ => 1 } @$skip;
 556     my %allowed;
 557     my %required; # this is a set, all present keys are required regardless of value
 558     foreach my $key (keys %$format) {
 559         $allowed{$key} = 1;
 560         if (!$format->{$key}->{optional} && !$format->{$key}->{alias} && !$skipped{$key}) {
 561             $required{$key} = 1;
 562         }
 563
 564         # Skip default keys
 565         if ($format->{$key}->{default_key}) {
 566             if ($default_key) {
 567                 warn "multiple default keys in schema ($default_key, $key)";
 568             } else {
 569                 $default_key = $key;
 570                 $skipped{$key} = 1;
 571             }
 572         }
 573     }
 574
 575     my ($text, $comma);
 576     if ($default_key) {
 577         $text = "$data->{$default_key}";
 578         $comma = ',';
 579     } else {
 580         $text = '';
 581         $comma = '';
 582     }
 583
 584     foreach my $key (sort keys %$data) {
 585         die "invalid key: $key" if !$allowed{$key};
 586         delete $required{$key};
 587         next if $skipped{$key};
 588
 589         my $typeformat = $format->{$key}->{format};
 590         my $value = $data->{$key};
 591         $text .= $comma;
 592         $comma = ',';
 593         if ($typeformat && $typeformat eq 'disk-size') {
 594             $text .= "$key=" . format_size($value);
 595         } else {
 596             $text .= "$key=$value";
 597         }
 598     }
 599
 600     if (my $missing = join(',', keys %required)) {
 601         die "missing properties: $missing";
 602     }
 603
 604     return $text;
 605 }
 606
 607 sub add_error {
 608     my ($errors, $path, $msg) = @_;
 609
 610     $path = '_root' if !$path;
 611
 612     if ($errors->{$path}) {
 613         $errors->{$path} = join ('\n', $errors->{$path}, $msg);
 614     } else {
 615         $errors->{$path} = $msg;
 616     }
 617 }
 618
 619 sub is_number {
 620     my $value = shift;
 621
 622     # see 'man perlretut'
 623     return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
 624 }
 625
 626 sub is_integer {
 627     my $value = shift;
 628
 629     return $value =~ m/^[+-]?\d+$/;
 630 }
 631
 632 sub check_type {
 633     my ($path, $type, $value, $errors) = @_;
 634
 635     return 1 if !$type;
 636
 637     if (!defined($value)) {
 638         return 1 if $type eq 'null';
 639         die "internal error"
 640     }
 641
 642     if (my $tt = ref($type)) {
 643         if ($tt eq 'ARRAY') {
 644             foreach my $t (@$type) {
 645                 my $tmperr = {};
 646                 check_type($path, $t, $value, $tmperr);
 647                 return 1 if !scalar(%$tmperr);
 648             }
 649             my $ttext = join ('|', @$type);
 650             add_error($errors, $path, "type check ('$ttext') failed");
 651             return undef;
 652         } elsif ($tt eq 'HASH') {
 653             my $tmperr = {};
 654             check_prop($value, $type, $path, $tmperr);
 655             return 1 if !scalar(%$tmperr);
 656             add_error($errors, $path, "type check failed");
 657             return undef;
 658         } else {
 659             die "internal error - got reference type '$tt'";
 660         }
 661
 662     } else {
 663
 664         return 1 if $type eq 'any';
 665
 666         if ($type eq 'null') {
 667             if (defined($value)) {
 668                 add_error($errors, $path, "type check ('$type') failed - value is not null");
 669                 return undef;
 670             }
 671             return 1;
 672         }
 673
 674         my $vt = ref($value);
 675
 676         if ($type eq 'array') {
 677             if (!$vt || $vt ne 'ARRAY') {
 678                 add_error($errors, $path, "type check ('$type') failed");
 679                 return undef;
 680             }
 681             return 1;
 682         } elsif ($type eq 'object') {
 683             if (!$vt || $vt ne 'HASH') {
 684                 add_error($errors, $path, "type check ('$type') failed");
 685                 return undef;
 686             }
 687             return 1;
 688         } elsif ($type eq 'coderef') {
 689             if (!$vt || $vt ne 'CODE') {
 690                 add_error($errors, $path, "type check ('$type') failed");
 691                 return undef;
 692             }
 693             return 1;
 694         } else {
 695             if ($vt) {
 696                 add_error($errors, $path, "type check ('$type') failed - got $vt");
 697                 return undef;
 698             } else {
 699                 if ($type eq 'string') {
 700                     return 1; # nothing to check ?
 701                 } elsif ($type eq 'boolean') {
 702                     #if ($value =~ m/^(1|true|yes|on)$/i) {
 703                     if ($value eq '1') {
 704                         return 1;
 705                     #} elsif ($value =~ m/^(0|false|no|off)$/i) {
 706                     } elsif ($value eq '0') {
 707                         return 0;
 708                     } else {
 709                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 710                         return undef;
 711                     }
 712                 } elsif ($type eq 'integer') {
 713                     if (!is_integer($value)) {
 714                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 715                         return undef;
 716                     }
 717                     return 1;
 718                 } elsif ($type eq 'number') {
 719                     if (!is_number($value)) {
 720                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 721                         return undef;
 722                     }
 723                     return 1;
 724                 } else {
 725                     return 1; # no need to verify unknown types
 726                 }
 727             }
 728         }
 729     }
 730
 731     return undef;
 732 }
 733
 734 sub check_object {
 735     my ($path, $schema, $value, $additional_properties, $errors) = @_;
 736
 737     # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
 738
 739     my $st = ref($schema);
 740     if (!$st || $st ne 'HASH') {
 741         add_error($errors, $path, "Invalid schema definition.");
 742         return;
 743     }
 744
 745     my $vt = ref($value);
 746     if (!$vt || $vt ne 'HASH') {
 747         add_error($errors, $path, "an object is required");
 748         return;
 749     }
 750
 751     foreach my $k (keys %$schema) {
 752         check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors);
 753     }
 754
 755     foreach my $k (keys %$value) {
 756
 757         my $newpath =  $path ? "$path.$k" : $k;
 758
 759         if (my $subschema = $schema->{$k}) {
 760             if (my $requires = $subschema->{requires}) {
 761                 if (ref($requires)) {
 762                     #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
 763                     check_prop($value, $requires, $path, $errors);
 764                 } elsif (!defined($value->{$requires})) {
 765                     add_error($errors, $path ? "$path.$requires" : $requires,
 766                               "missing property - '$newpath' requiers this property");
 767                 }
 768             }
 769
 770             next; # value is already checked above
 771         }
 772
 773         if (defined ($additional_properties) && !$additional_properties) {
 774             add_error($errors, $newpath, "property is not defined in schema " .
 775                       "and the schema does not allow additional properties");
 776             next;
 777         }
 778         check_prop($value->{$k}, $additional_properties, $newpath, $errors)
 779             if ref($additional_properties);
 780     }
 781 }
 782
 783 sub check_object_warn {
 784     my ($path, $schema, $value, $additional_properties) = @_;
 785     my $errors = {};
 786     check_object($path, $schema, $value, $additional_properties, $errors);
 787     if (scalar(%$errors)) {
 788         foreach my $k (keys %$errors) {
 789             warn "parse error: $k: $errors->{$k}\n";
 790         }
 791         return 0;
 792     }
 793     return 1;
 794 }
 795
 796 sub check_prop {
 797     my ($value, $schema, $path, $errors) = @_;
 798
 799     die "internal error - no schema" if !$schema;
 800     die "internal error" if !$errors;
 801
 802     #print "check_prop $path\n" if $value;
 803
 804     my $st = ref($schema);
 805     if (!$st || $st ne 'HASH') {
 806         add_error($errors, $path, "Invalid schema definition.");
 807         return;
 808     }
 809
 810     # if it extends another schema, it must pass that schema as well
 811     if($schema->{extends}) {
 812         check_prop($value, $schema->{extends}, $path, $errors);
 813     }
 814
 815     if (!defined ($value)) {
 816         return if $schema->{type} && $schema->{type} eq 'null';
 817         if (!$schema->{optional} && !$schema->{alias}) {
 818             add_error($errors, $path, "property is missing and it is not optional");
 819         }
 820         return;
 821     }
 822
 823     return if !check_type($path, $schema->{type}, $value, $errors);
 824
 825     if ($schema->{disallow}) {
 826         my $tmperr = {};
 827         if (check_type($path, $schema->{disallow}, $value, $tmperr)) {
 828             add_error($errors, $path, "disallowed value was matched");
 829             return;
 830         }
 831     }
 832
 833     if (my $vt = ref($value)) {
 834
 835         if ($vt eq 'ARRAY') {
 836             if ($schema->{items}) {
 837                 my $it = ref($schema->{items});
 838                 if ($it && $it eq 'ARRAY') {
 839                     #die "implement me $path: $vt " . Dumper($schema) ."\n".  Dumper($value);
 840                     die "not implemented";
 841                 } else {
 842                     my $ind = 0;
 843                     foreach my $el (@$value) {
 844                         check_prop($el, $schema->{items}, "${path}[$ind]", $errors);
 845                         $ind++;
 846                     }
 847                 }
 848             }
 849             return;
 850         } elsif ($schema->{properties} || $schema->{additionalProperties}) {
 851             check_object($path, defined($schema->{properties}) ? $schema->{properties} : {},
 852                          $value, $schema->{additionalProperties}, $errors);
 853             return;
 854         }
 855
 856     } else {
 857
 858         if (my $format = $schema->{format}) {
 859             eval { check_format($format, $value, $path); };
 860             if ($@) {
 861                 add_error($errors, $path, "invalid format - $@");
 862                 return;
 863             }
 864         }
 865
 866         if (my $pattern = $schema->{pattern}) {
 867             if ($value !~ m/^$pattern$/) {
 868                 add_error($errors, $path, "value does not match the regex pattern");
 869                 return;
 870             }
 871         }
 872
 873         if (defined (my $max = $schema->{maxLength})) {
 874             if (length($value) > $max) {
 875                 add_error($errors, $path, "value may only be $max characters long");
 876                 return;
 877             }
 878         }
 879
 880         if (defined (my $min = $schema->{minLength})) {
 881             if (length($value) < $min) {
 882                 add_error($errors, $path, "value must be at least $min characters long");
 883                 return;
 884             }
 885         }
 886
 887         if (is_number($value)) {
 888             if (defined (my $max = $schema->{maximum})) {
 889                 if ($value > $max) {
 890                     add_error($errors, $path, "value must have a maximum value of $max");
 891                     return;
 892                 }
 893             }
 894
 895             if (defined (my $min = $schema->{minimum})) {
 896                 if ($value < $min) {
 897                     add_error($errors, $path, "value must have a minimum value of $min");
 898                     return;
 899                 }
 900             }
 901         }
 902
 903         if (my $ea = $schema->{enum}) {
 904
 905             my $found;
 906             foreach my $ev (@$ea) {
 907                 if ($ev eq $value) {
 908                     $found = 1;
 909                     last;
 910                 }
 911             }
 912             if (!$found) {
 913                 add_error($errors, $path, "value '$value' does not have a value in the enumeration '" .
 914                           join(", ", @$ea) . "'");
 915             }
 916         }
 917     }
 918 }
 919
 920 sub validate {
 921     my ($instance, $schema, $errmsg) = @_;
 922
 923     my $errors = {};
 924     $errmsg = "Parameter verification failed.\n" if !$errmsg;
 925
 926     # todo: cycle detection is only needed for debugging, I guess
 927     # we can disable that in the final release
 928     # todo: is there a better/faster way to detect cycles?
 929     my $cycles = 0;
 930     find_cycle($instance, sub { $cycles = 1 });
 931     if ($cycles) {
 932         add_error($errors, undef, "data structure contains recursive cycles");
 933     } elsif ($schema) {
 934         check_prop($instance, $schema, '', $errors);
 935     }
 936
 937     if (scalar(%$errors)) {
 938         raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors;
 939     }
 940
 941     return 1;
 942 }
 943
 944 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
 945 my $default_schema_noref = {
 946     description => "This is the JSON Schema for JSON Schemas.",
 947     type => [ "object" ],
 948     additionalProperties => 0,
 949     properties => {
 950         type => {
 951             type => ["string", "array"],
 952             description => "This is a type definition value. This can be a simple type, or a union type",
 953             optional => 1,
 954             default => "any",
 955             items => {
 956                 type => "string",
 957                 enum => $schema_valid_types,
 958             },
 959             enum => $schema_valid_types,
 960         },
 961         optional => {
 962             type => "boolean",
 963             description => "This indicates that the instance property in the instance object is not required.",
 964             optional => 1,
 965             default => 0
 966         },
 967         properties => {
 968             type => "object",
 969             description => "This is a definition for the properties of an object value",
 970             optional => 1,
 971             default => {},
 972         },
 973         items => {
 974             type => "object",
 975             description => "When the value is an array, this indicates the schema to use to validate each item in an array",
 976             optional => 1,
 977             default => {},
 978         },
 979         additionalProperties => {
 980             type => [ "boolean", "object"],
 981             description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
 982             optional => 1,
 983             default => {},
 984         },
 985         minimum => {
 986             type => "number",
 987             optional => 1,
 988             description => "This indicates the minimum value for the instance property when the type of the instance value is a number.",
 989         },
 990         maximum => {
 991             type => "number",
 992             optional => 1,
 993             description => "This indicates the maximum value for the instance property when the type of the instance value is a number.",
 994         },
 995         minLength => {
 996             type => "integer",
 997             description => "When the instance value is a string, this indicates minimum length of the string",
 998             optional => 1,
 999             minimum => 0,
1000             default => 0,
1001         },
1002         maxLength => {
1003             type => "integer",
1004             description => "When the instance value is a string, this indicates maximum length of the string.",
1005             optional => 1,
1006         },
1007         typetext => {
1008             type => "string",
1009             optional => 1,
1010             description => "A text representation of the type (used to generate documentation).",
1011         },
1012         pattern => {
1013             type => "string",
1014             format => "regex",
1015             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.",
1016             optional => 1,
1017             default => ".*",
1018         },
1019
1020         enum => {
1021             type => "array",
1022             optional => 1,
1023             description => "This provides an enumeration of possible values that are valid for the instance property.",
1024         },
1025         description => {
1026             type => "string",
1027             optional => 1,
1028             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).",
1029         },
1030         format_description => {
1031             type => "string",
1032             optional => 1,
1033             description => "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1034         },
1035         title => {
1036             type => "string",
1037             optional => 1,
1038             description => "This provides the title of the property",
1039         },
1040         requires => {
1041             type => [ "string", "object" ],
1042             optional => 1,
1043             description => "indicates a required property or a schema that must be validated if this property is present",
1044         },
1045         format => {
1046             type => [ "string", "object" ],
1047             optional => 1,
1048             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",
1049         },
1050         default_key => {
1051             type => "boolean",
1052             optional => 1,
1053             description => "Whether this is the default key in a comma separated list property string.",
1054         },
1055         alias => {
1056             type => 'string',
1057             optional => 1,
1058             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.",
1059         },
1060         default => {
1061             type => "any",
1062             optional => 1,
1063             description => "This indicates the default for the instance property."
1064         },
1065         completion => {
1066             type => 'coderef',
1067             description => "Bash completion function. This function should return a list of possible values.",
1068             optional => 1,
1069         },
1070         disallow => {
1071             type => "object",
1072             optional => 1,
1073             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, than this instance is not valid.",
1074         },
1075         extends => {
1076             type => "object",
1077             optional => 1,
1078             description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1079             default => {},
1080         },
1081         # this is from hyper schema
1082         links => {
1083             type => "array",
1084             description => "This defines the link relations of the instance objects",
1085             optional => 1,
1086             items => {
1087                 type => "object",
1088                 properties => {
1089                     href => {
1090                         type => "string",
1091                         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",
1092                     },
1093                     rel => {
1094                         type => "string",
1095                         description => "This is the name of the link relation",
1096                         optional => 1,
1097                         default => "full",
1098                     },
1099                     method => {
1100                         type => "string",
1101                         description => "For submission links, this defines the method that should be used to access the target resource",
1102                         optional => 1,
1103                         default => "GET",
1104                     },
1105                 },
1106             },
1107         },
1108     }
1109 };
1110
1111 my $default_schema = Storable::dclone($default_schema_noref);
1112
1113 $default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
1114 $default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
1115
1116 $default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
1117 $default_schema->{properties}->{items}->{additionalProperties} = 0;
1118
1119 $default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
1120 $default_schema->{properties}->{disallow}->{additionalProperties} = 0;
1121
1122 $default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
1123 $default_schema->{properties}->{requires}->{additionalProperties} = 0;
1124
1125 $default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
1126 $default_schema->{properties}->{extends}->{additionalProperties} = 0;
1127
1128 my $method_schema = {
1129     type => "object",
1130     additionalProperties => 0,
1131     properties => {
1132         description => {
1133             description => "This a description of the method",
1134             optional => 1,
1135         },
1136         name => {
1137             type =>  'string',
1138             description => "This indicates the name of the function to call.",
1139             optional => 1,
1140             requires => {
1141                 additionalProperties => 1,
1142                 properties => {
1143                     name => {},
1144                     description => {},
1145                     code => {},
1146                     method => {},
1147                     parameters => {},
1148                     path => {},
1149                     parameters => {},
1150                     returns => {},
1151                 }
1152             },
1153         },
1154         method => {
1155             type =>  'string',
1156             description => "The HTTP method name.",
1157             enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
1158             optional => 1,
1159         },
1160         protected => {
1161             type => 'boolean',
1162             description => "Method needs special privileges - only pvedaemon can execute it",
1163             optional => 1,
1164         },
1165         proxyto => {
1166             type =>  'string',
1167             description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1168             optional => 1,
1169         },
1170         permissions => {
1171             type => 'object',
1172             description => "Required access permissions. By default only 'root' is allowed to access this method.",
1173             optional => 1,
1174             additionalProperties => 0,
1175             properties => {
1176                 description => {
1177                      description => "Describe access permissions.",
1178                      optional => 1,
1179                 },
1180                 user => {
1181                     description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1182                     type => 'string',
1183                     enum => ['all', 'world'],
1184                     optional => 1,
1185                 },
1186                 check => {
1187                     description => "Array of permission checks (prefix notation).",
1188                     type => 'array',
1189                     optional => 1
1190                 },
1191             },
1192         },
1193         match_name => {
1194             description => "Used internally",
1195             optional => 1,
1196         },
1197         match_re => {
1198             description => "Used internally",
1199             optional => 1,
1200         },
1201         path => {
1202             type =>  'string',
1203             description => "path for URL matching (uri template)",
1204         },
1205         fragmentDelimiter => {
1206             type => 'string',
1207             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.",
1208             optional => 1,
1209         },
1210         parameters => {
1211             type => 'object',
1212             description => "JSON Schema for parameters.",
1213             optional => 1,
1214         },
1215         formatter => {
1216             type => 'object',
1217             description => "Used to store page formatter information (set by PVE::RESTHandler->register_page_formatter).",
1218             optional => 1,
1219         },
1220         returns => {
1221             type => 'object',
1222             description => "JSON Schema for return value.",
1223             optional => 1,
1224         },
1225         code => {
1226             type => 'coderef',
1227             description => "method implementaion (code reference)",
1228             optional => 1,
1229         },
1230         subclass => {
1231             type => 'string',
1232             description => "Delegate call to this class (perl class string).",
1233             optional => 1,
1234             requires => {
1235                 additionalProperties => 0,
1236                 properties => {
1237                     subclass => {},
1238                     path => {},
1239                     match_name => {},
1240                     match_re => {},
1241                     fragmentDelimiter => { optional => 1 }
1242                 }
1243             },
1244         },
1245     },
1246
1247 };
1248
1249 sub validate_schema {
1250     my ($schema) = @_;
1251
1252     my $errmsg = "internal error - unable to verify schema\n";
1253     validate($schema, $default_schema, $errmsg);
1254 }
1255
1256 sub validate_method_info {
1257     my $info = shift;
1258
1259     my $errmsg = "internal error - unable to verify method info\n";
1260     validate($info, $method_schema, $errmsg);
1261
1262     validate_schema($info->{parameters}) if $info->{parameters};
1263     validate_schema($info->{returns}) if $info->{returns};
1264 }
1265
1266 # run a self test on load
1267 # make sure we can verify the default schema
1268 validate_schema($default_schema_noref);
1269 validate_schema($method_schema);
1270
1271 # and now some utility methods (used by pve api)
1272 sub method_get_child_link {
1273     my ($info) = @_;
1274
1275     return undef if !$info;
1276
1277     my $schema = $info->{returns};
1278     return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
1279
1280     my $links = $schema->{links};
1281     return undef if !$links;
1282
1283     my $found;
1284     foreach my $lnk (@$links) {
1285         if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
1286             $found = $lnk;
1287             last;
1288         }
1289     }
1290
1291     return $found;
1292 }
1293
1294 # a way to parse command line parameters, using a
1295 # schema to configure Getopt::Long
1296 sub get_options {
1297     my ($schema, $args, $arg_param, $fixed_param, $pwcallback) = @_;
1298
1299     if (!$schema || !$schema->{properties}) {
1300         raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1301             if scalar(@$args) != 0;
1302         return {};
1303     }
1304
1305     my $list_param;
1306     if ($arg_param && !ref($arg_param)) {
1307         my $pd = $schema->{properties}->{$arg_param};
1308         die "expected list format $pd->{format}"
1309             if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
1310         $list_param = $arg_param;
1311     }
1312
1313     my @getopt = ();
1314     foreach my $prop (keys %{$schema->{properties}}) {
1315         my $pd = $schema->{properties}->{$prop};
1316         next if $list_param && $prop eq $list_param;
1317         next if defined($fixed_param->{$prop});
1318
1319         if ($prop eq 'password' && $pwcallback) {
1320             # we do not accept plain password on input line, instead
1321             # we turn this into a boolean option and ask for password below
1322             # using $pwcallback() (for security reasons).
1323             push @getopt, "$prop";
1324         } elsif ($pd->{type} eq 'boolean') {
1325             push @getopt, "$prop:s";
1326         } else {
1327             if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
1328                 push @getopt, "$prop=s@";
1329             } else {
1330                 push @getopt, "$prop=s";
1331             }
1332         }
1333     }
1334
1335     Getopt::Long::Configure('prefix_pattern=(--|-)');
1336
1337     my $opts = {};
1338     raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
1339         if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
1340
1341     if (@$args) {
1342         if ($list_param) {
1343             $opts->{$list_param} = $args;
1344             $args = [];
1345         } elsif (ref($arg_param)) {
1346             foreach my $arg_name (@$arg_param) {
1347                 if ($opts->{'extra-args'}) {
1348                     raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
1349                 }
1350                 if ($arg_name eq 'extra-args') {
1351                     $opts->{'extra-args'} = $args;
1352                     $args = [];
1353                     next;
1354                 }
1355                 raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
1356                 $opts->{$arg_name} = shift @$args;
1357             }
1358             raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
1359         } else {
1360             raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1361                 if scalar(@$args) != 0;
1362         }
1363     }
1364
1365     if (my $pd = $schema->{properties}->{password}) {
1366         if ($pd->{type} ne 'boolean' && $pwcallback) {
1367             if ($opts->{password} || !$pd->{optional}) {
1368                 $opts->{password} = &$pwcallback();
1369             }
1370         }
1371     }
1372
1373     $opts = PVE::Tools::decode_utf8_parameters($opts);
1374
1375     foreach my $p (keys %$opts) {
1376         if (my $pd = $schema->{properties}->{$p}) {
1377             if ($pd->{type} eq 'boolean') {
1378                 if ($opts->{$p} eq '') {
1379                     $opts->{$p} = 1;
1380                 } elsif ($opts->{$p} =~ m/^(1|true|yes|on)$/i) {
1381                     $opts->{$p} = 1;
1382                 } elsif ($opts->{$p} =~ m/^(0|false|no|off)$/i) {
1383                     $opts->{$p} = 0;
1384                 } else {
1385                     raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
1386                 }
1387             } elsif ($pd->{format}) {
1388
1389                 if ($pd->{format} =~ m/-list/) {
1390                     # allow --vmid 100 --vmid 101 and --vmid 100,101
1391                     # allow --dow mon --dow fri and --dow mon,fri
1392                     $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1393                 } elsif ($pd->{format} =~ m/-alist/) {
1394                     # we encode array as \0 separated strings
1395                     # Note: CGI.pm also use this encoding
1396                     if (scalar(@{$opts->{$p}}) != 1) {
1397                         $opts->{$p} = join("\0", @{$opts->{$p}});
1398                     } else {
1399                         # st that split_list knows it is \0 terminated
1400                         my $v = $opts->{$p}->[0];
1401                         $opts->{$p} = "$v\0";
1402                     }
1403                 }
1404             }
1405         }
1406     }
1407
1408     foreach my $p (keys %$fixed_param) {
1409         $opts->{$p} = $fixed_param->{$p};
1410     }
1411
1412     return $opts;
1413 }
1414
1415 # A way to parse configuration data by giving a json schema
1416 sub parse_config {
1417     my ($schema, $filename, $raw) = @_;
1418
1419     # do fast check (avoid validate_schema($schema))
1420     die "got strange schema" if !$schema->{type} ||
1421         !$schema->{properties} || $schema->{type} ne 'object';
1422
1423     my $cfg = {};
1424
1425     while ($raw =~ /^\s*(.+?)\s*$/gm) {
1426         my $line = $1;
1427
1428         next if $line =~ /^#/;
1429
1430         if ($line =~ m/^(\S+?):\s*(.*)$/) {
1431             my $key = $1;
1432             my $value = $2;
1433             if ($schema->{properties}->{$key} &&
1434                 $schema->{properties}->{$key}->{type} eq 'boolean') {
1435
1436                 $value = 1 if $value =~ m/^(1|on|yes|true)$/i;
1437                 $value = 0 if $value =~ m/^(0|off|no|false)$/i;
1438             }
1439             $cfg->{$key} = $value;
1440         } else {
1441             warn "ignore config line: $line\n"
1442         }
1443     }
1444
1445     my $errors = {};
1446     check_prop($cfg, $schema, '', $errors);
1447
1448     foreach my $k (keys %$errors) {
1449         warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1450         delete $cfg->{$k};
1451     }
1452
1453     return $cfg;
1454 }
1455
1456 # generate simple key/value file
1457 sub dump_config {
1458     my ($schema, $filename, $cfg) = @_;
1459
1460     # do fast check (avoid validate_schema($schema))
1461     die "got strange schema" if !$schema->{type} ||
1462         !$schema->{properties} || $schema->{type} ne 'object';
1463
1464     validate($cfg, $schema, "validation error in '$filename'\n");
1465
1466     my $data = '';
1467
1468     foreach my $k (keys %$cfg) {
1469         $data .= "$k: $cfg->{$k}\n";
1470     }
1471
1472     return $data;
1473 }
1474
1475 1;