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         delete $required{$key};
 586         next if $skipped{$key};
 587         die "invalid key: $key" if !$allowed{$key};
 588
 589         my $typeformat = $format->{$key}->{format};
 590         my $value = $data->{$key};
 591         next if !defined($value);
 592         $text .= $comma;
 593         $comma = ',';
 594         if ($typeformat && $typeformat eq 'disk-size') {
 595             $text .= "$key=" . format_size($value);
 596         } else {
 597             $text .= "$key=$value";
 598         }
 599     }
 600
 601     if (my $missing = join(',', keys %required)) {
 602         die "missing properties: $missing";
 603     }
 604
 605     return $text;
 606 }
 607
 608 sub add_error {
 609     my ($errors, $path, $msg) = @_;
 610
 611     $path = '_root' if !$path;
 612
 613     if ($errors->{$path}) {
 614         $errors->{$path} = join ('\n', $errors->{$path}, $msg);
 615     } else {
 616         $errors->{$path} = $msg;
 617     }
 618 }
 619
 620 sub is_number {
 621     my $value = shift;
 622
 623     # see 'man perlretut'
 624     return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
 625 }
 626
 627 sub is_integer {
 628     my $value = shift;
 629
 630     return $value =~ m/^[+-]?\d+$/;
 631 }
 632
 633 sub check_type {
 634     my ($path, $type, $value, $errors) = @_;
 635
 636     return 1 if !$type;
 637
 638     if (!defined($value)) {
 639         return 1 if $type eq 'null';
 640         die "internal error"
 641     }
 642
 643     if (my $tt = ref($type)) {
 644         if ($tt eq 'ARRAY') {
 645             foreach my $t (@$type) {
 646                 my $tmperr = {};
 647                 check_type($path, $t, $value, $tmperr);
 648                 return 1 if !scalar(%$tmperr);
 649             }
 650             my $ttext = join ('|', @$type);
 651             add_error($errors, $path, "type check ('$ttext') failed");
 652             return undef;
 653         } elsif ($tt eq 'HASH') {
 654             my $tmperr = {};
 655             check_prop($value, $type, $path, $tmperr);
 656             return 1 if !scalar(%$tmperr);
 657             add_error($errors, $path, "type check failed");
 658             return undef;
 659         } else {
 660             die "internal error - got reference type '$tt'";
 661         }
 662
 663     } else {
 664
 665         return 1 if $type eq 'any';
 666
 667         if ($type eq 'null') {
 668             if (defined($value)) {
 669                 add_error($errors, $path, "type check ('$type') failed - value is not null");
 670                 return undef;
 671             }
 672             return 1;
 673         }
 674
 675         my $vt = ref($value);
 676
 677         if ($type eq 'array') {
 678             if (!$vt || $vt ne 'ARRAY') {
 679                 add_error($errors, $path, "type check ('$type') failed");
 680                 return undef;
 681             }
 682             return 1;
 683         } elsif ($type eq 'object') {
 684             if (!$vt || $vt ne 'HASH') {
 685                 add_error($errors, $path, "type check ('$type') failed");
 686                 return undef;
 687             }
 688             return 1;
 689         } elsif ($type eq 'coderef') {
 690             if (!$vt || $vt ne 'CODE') {
 691                 add_error($errors, $path, "type check ('$type') failed");
 692                 return undef;
 693             }
 694             return 1;
 695         } else {
 696             if ($vt) {
 697                 add_error($errors, $path, "type check ('$type') failed - got $vt");
 698                 return undef;
 699             } else {
 700                 if ($type eq 'string') {
 701                     return 1; # nothing to check ?
 702                 } elsif ($type eq 'boolean') {
 703                     #if ($value =~ m/^(1|true|yes|on)$/i) {
 704                     if ($value eq '1') {
 705                         return 1;
 706                     #} elsif ($value =~ m/^(0|false|no|off)$/i) {
 707                     } elsif ($value eq '0') {
 708                         return 0;
 709                     } else {
 710                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 711                         return undef;
 712                     }
 713                 } elsif ($type eq 'integer') {
 714                     if (!is_integer($value)) {
 715                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 716                         return undef;
 717                     }
 718                     return 1;
 719                 } elsif ($type eq 'number') {
 720                     if (!is_number($value)) {
 721                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 722                         return undef;
 723                     }
 724                     return 1;
 725                 } else {
 726                     return 1; # no need to verify unknown types
 727                 }
 728             }
 729         }
 730     }
 731
 732     return undef;
 733 }
 734
 735 sub check_object {
 736     my ($path, $schema, $value, $additional_properties, $errors) = @_;
 737
 738     # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
 739
 740     my $st = ref($schema);
 741     if (!$st || $st ne 'HASH') {
 742         add_error($errors, $path, "Invalid schema definition.");
 743         return;
 744     }
 745
 746     my $vt = ref($value);
 747     if (!$vt || $vt ne 'HASH') {
 748         add_error($errors, $path, "an object is required");
 749         return;
 750     }
 751
 752     foreach my $k (keys %$schema) {
 753         check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors);
 754     }
 755
 756     foreach my $k (keys %$value) {
 757
 758         my $newpath =  $path ? "$path.$k" : $k;
 759
 760         if (my $subschema = $schema->{$k}) {
 761             if (my $requires = $subschema->{requires}) {
 762                 if (ref($requires)) {
 763                     #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
 764                     check_prop($value, $requires, $path, $errors);
 765                 } elsif (!defined($value->{$requires})) {
 766                     add_error($errors, $path ? "$path.$requires" : $requires,
 767                               "missing property - '$newpath' requiers this property");
 768                 }
 769             }
 770
 771             next; # value is already checked above
 772         }
 773
 774         if (defined ($additional_properties) && !$additional_properties) {
 775             add_error($errors, $newpath, "property is not defined in schema " .
 776                       "and the schema does not allow additional properties");
 777             next;
 778         }
 779         check_prop($value->{$k}, $additional_properties, $newpath, $errors)
 780             if ref($additional_properties);
 781     }
 782 }
 783
 784 sub check_object_warn {
 785     my ($path, $schema, $value, $additional_properties) = @_;
 786     my $errors = {};
 787     check_object($path, $schema, $value, $additional_properties, $errors);
 788     if (scalar(%$errors)) {
 789         foreach my $k (keys %$errors) {
 790             warn "parse error: $k: $errors->{$k}\n";
 791         }
 792         return 0;
 793     }
 794     return 1;
 795 }
 796
 797 sub check_prop {
 798     my ($value, $schema, $path, $errors) = @_;
 799
 800     die "internal error - no schema" if !$schema;
 801     die "internal error" if !$errors;
 802
 803     #print "check_prop $path\n" if $value;
 804
 805     my $st = ref($schema);
 806     if (!$st || $st ne 'HASH') {
 807         add_error($errors, $path, "Invalid schema definition.");
 808         return;
 809     }
 810
 811     # if it extends another schema, it must pass that schema as well
 812     if($schema->{extends}) {
 813         check_prop($value, $schema->{extends}, $path, $errors);
 814     }
 815
 816     if (!defined ($value)) {
 817         return if $schema->{type} && $schema->{type} eq 'null';
 818         if (!$schema->{optional} && !$schema->{alias}) {
 819             add_error($errors, $path, "property is missing and it is not optional");
 820         }
 821         return;
 822     }
 823
 824     return if !check_type($path, $schema->{type}, $value, $errors);
 825
 826     if ($schema->{disallow}) {
 827         my $tmperr = {};
 828         if (check_type($path, $schema->{disallow}, $value, $tmperr)) {
 829             add_error($errors, $path, "disallowed value was matched");
 830             return;
 831         }
 832     }
 833
 834     if (my $vt = ref($value)) {
 835
 836         if ($vt eq 'ARRAY') {
 837             if ($schema->{items}) {
 838                 my $it = ref($schema->{items});
 839                 if ($it && $it eq 'ARRAY') {
 840                     #die "implement me $path: $vt " . Dumper($schema) ."\n".  Dumper($value);
 841                     die "not implemented";
 842                 } else {
 843                     my $ind = 0;
 844                     foreach my $el (@$value) {
 845                         check_prop($el, $schema->{items}, "${path}[$ind]", $errors);
 846                         $ind++;
 847                     }
 848                 }
 849             }
 850             return;
 851         } elsif ($schema->{properties} || $schema->{additionalProperties}) {
 852             check_object($path, defined($schema->{properties}) ? $schema->{properties} : {},
 853                          $value, $schema->{additionalProperties}, $errors);
 854             return;
 855         }
 856
 857     } else {
 858
 859         if (my $format = $schema->{format}) {
 860             eval { check_format($format, $value, $path); };
 861             if ($@) {
 862                 add_error($errors, $path, "invalid format - $@");
 863                 return;
 864             }
 865         }
 866
 867         if (my $pattern = $schema->{pattern}) {
 868             if ($value !~ m/^$pattern$/) {
 869                 add_error($errors, $path, "value does not match the regex pattern");
 870                 return;
 871             }
 872         }
 873
 874         if (defined (my $max = $schema->{maxLength})) {
 875             if (length($value) > $max) {
 876                 add_error($errors, $path, "value may only be $max characters long");
 877                 return;
 878             }
 879         }
 880
 881         if (defined (my $min = $schema->{minLength})) {
 882             if (length($value) < $min) {
 883                 add_error($errors, $path, "value must be at least $min characters long");
 884                 return;
 885             }
 886         }
 887
 888         if (is_number($value)) {
 889             if (defined (my $max = $schema->{maximum})) {
 890                 if ($value > $max) {
 891                     add_error($errors, $path, "value must have a maximum value of $max");
 892                     return;
 893                 }
 894             }
 895
 896             if (defined (my $min = $schema->{minimum})) {
 897                 if ($value < $min) {
 898                     add_error($errors, $path, "value must have a minimum value of $min");
 899                     return;
 900                 }
 901             }
 902         }
 903
 904         if (my $ea = $schema->{enum}) {
 905
 906             my $found;
 907             foreach my $ev (@$ea) {
 908                 if ($ev eq $value) {
 909                     $found = 1;
 910                     last;
 911                 }
 912             }
 913             if (!$found) {
 914                 add_error($errors, $path, "value '$value' does not have a value in the enumeration '" .
 915                           join(", ", @$ea) . "'");
 916             }
 917         }
 918     }
 919 }
 920
 921 sub validate {
 922     my ($instance, $schema, $errmsg) = @_;
 923
 924     my $errors = {};
 925     $errmsg = "Parameter verification failed.\n" if !$errmsg;
 926
 927     # todo: cycle detection is only needed for debugging, I guess
 928     # we can disable that in the final release
 929     # todo: is there a better/faster way to detect cycles?
 930     my $cycles = 0;
 931     find_cycle($instance, sub { $cycles = 1 });
 932     if ($cycles) {
 933         add_error($errors, undef, "data structure contains recursive cycles");
 934     } elsif ($schema) {
 935         check_prop($instance, $schema, '', $errors);
 936     }
 937
 938     if (scalar(%$errors)) {
 939         raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors;
 940     }
 941
 942     return 1;
 943 }
 944
 945 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
 946 my $default_schema_noref = {
 947     description => "This is the JSON Schema for JSON Schemas.",
 948     type => [ "object" ],
 949     additionalProperties => 0,
 950     properties => {
 951         type => {
 952             type => ["string", "array"],
 953             description => "This is a type definition value. This can be a simple type, or a union type",
 954             optional => 1,
 955             default => "any",
 956             items => {
 957                 type => "string",
 958                 enum => $schema_valid_types,
 959             },
 960             enum => $schema_valid_types,
 961         },
 962         optional => {
 963             type => "boolean",
 964             description => "This indicates that the instance property in the instance object is not required.",
 965             optional => 1,
 966             default => 0
 967         },
 968         properties => {
 969             type => "object",
 970             description => "This is a definition for the properties of an object value",
 971             optional => 1,
 972             default => {},
 973         },
 974         items => {
 975             type => "object",
 976             description => "When the value is an array, this indicates the schema to use to validate each item in an array",
 977             optional => 1,
 978             default => {},
 979         },
 980         additionalProperties => {
 981             type => [ "boolean", "object"],
 982             description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
 983             optional => 1,
 984             default => {},
 985         },
 986         minimum => {
 987             type => "number",
 988             optional => 1,
 989             description => "This indicates the minimum value for the instance property when the type of the instance value is a number.",
 990         },
 991         maximum => {
 992             type => "number",
 993             optional => 1,
 994             description => "This indicates the maximum value for the instance property when the type of the instance value is a number.",
 995         },
 996         minLength => {
 997             type => "integer",
 998             description => "When the instance value is a string, this indicates minimum length of the string",
 999             optional => 1,
1000             minimum => 0,
1001             default => 0,
1002         },
1003         maxLength => {
1004             type => "integer",
1005             description => "When the instance value is a string, this indicates maximum length of the string.",
1006             optional => 1,
1007         },
1008         typetext => {
1009             type => "string",
1010             optional => 1,
1011             description => "A text representation of the type (used to generate documentation).",
1012         },
1013         pattern => {
1014             type => "string",
1015             format => "regex",
1016             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.",
1017             optional => 1,
1018             default => ".*",
1019         },
1020
1021         enum => {
1022             type => "array",
1023             optional => 1,
1024             description => "This provides an enumeration of possible values that are valid for the instance property.",
1025         },
1026         description => {
1027             type => "string",
1028             optional => 1,
1029             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).",
1030         },
1031         format_description => {
1032             type => "string",
1033             optional => 1,
1034             description => "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1035         },
1036         title => {
1037             type => "string",
1038             optional => 1,
1039             description => "This provides the title of the property",
1040         },
1041         requires => {
1042             type => [ "string", "object" ],
1043             optional => 1,
1044             description => "indicates a required property or a schema that must be validated if this property is present",
1045         },
1046         format => {
1047             type => [ "string", "object" ],
1048             optional => 1,
1049             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",
1050         },
1051         default_key => {
1052             type => "boolean",
1053             optional => 1,
1054             description => "Whether this is the default key in a comma separated list property string.",
1055         },
1056         alias => {
1057             type => 'string',
1058             optional => 1,
1059             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.",
1060         },
1061         default => {
1062             type => "any",
1063             optional => 1,
1064             description => "This indicates the default for the instance property."
1065         },
1066         completion => {
1067             type => 'coderef',
1068             description => "Bash completion function. This function should return a list of possible values.",
1069             optional => 1,
1070         },
1071         disallow => {
1072             type => "object",
1073             optional => 1,
1074             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.",
1075         },
1076         extends => {
1077             type => "object",
1078             optional => 1,
1079             description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1080             default => {},
1081         },
1082         # this is from hyper schema
1083         links => {
1084             type => "array",
1085             description => "This defines the link relations of the instance objects",
1086             optional => 1,
1087             items => {
1088                 type => "object",
1089                 properties => {
1090                     href => {
1091                         type => "string",
1092                         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",
1093                     },
1094                     rel => {
1095                         type => "string",
1096                         description => "This is the name of the link relation",
1097                         optional => 1,
1098                         default => "full",
1099                     },
1100                     method => {
1101                         type => "string",
1102                         description => "For submission links, this defines the method that should be used to access the target resource",
1103                         optional => 1,
1104                         default => "GET",
1105                     },
1106                 },
1107             },
1108         },
1109     }
1110 };
1111
1112 my $default_schema = Storable::dclone($default_schema_noref);
1113
1114 $default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
1115 $default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
1116
1117 $default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
1118 $default_schema->{properties}->{items}->{additionalProperties} = 0;
1119
1120 $default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
1121 $default_schema->{properties}->{disallow}->{additionalProperties} = 0;
1122
1123 $default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
1124 $default_schema->{properties}->{requires}->{additionalProperties} = 0;
1125
1126 $default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
1127 $default_schema->{properties}->{extends}->{additionalProperties} = 0;
1128
1129 my $method_schema = {
1130     type => "object",
1131     additionalProperties => 0,
1132     properties => {
1133         description => {
1134             description => "This a description of the method",
1135             optional => 1,
1136         },
1137         name => {
1138             type =>  'string',
1139             description => "This indicates the name of the function to call.",
1140             optional => 1,
1141             requires => {
1142                 additionalProperties => 1,
1143                 properties => {
1144                     name => {},
1145                     description => {},
1146                     code => {},
1147                     method => {},
1148                     parameters => {},
1149                     path => {},
1150                     parameters => {},
1151                     returns => {},
1152                 }
1153             },
1154         },
1155         method => {
1156             type =>  'string',
1157             description => "The HTTP method name.",
1158             enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
1159             optional => 1,
1160         },
1161         protected => {
1162             type => 'boolean',
1163             description => "Method needs special privileges - only pvedaemon can execute it",
1164             optional => 1,
1165         },
1166         proxyto => {
1167             type =>  'string',
1168             description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1169             optional => 1,
1170         },
1171         permissions => {
1172             type => 'object',
1173             description => "Required access permissions. By default only 'root' is allowed to access this method.",
1174             optional => 1,
1175             additionalProperties => 0,
1176             properties => {
1177                 description => {
1178                      description => "Describe access permissions.",
1179                      optional => 1,
1180                 },
1181                 user => {
1182                     description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1183                     type => 'string',
1184                     enum => ['all', 'world'],
1185                     optional => 1,
1186                 },
1187                 check => {
1188                     description => "Array of permission checks (prefix notation).",
1189                     type => 'array',
1190                     optional => 1
1191                 },
1192             },
1193         },
1194         match_name => {
1195             description => "Used internally",
1196             optional => 1,
1197         },
1198         match_re => {
1199             description => "Used internally",
1200             optional => 1,
1201         },
1202         path => {
1203             type =>  'string',
1204             description => "path for URL matching (uri template)",
1205         },
1206         fragmentDelimiter => {
1207             type => 'string',
1208             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.",
1209             optional => 1,
1210         },
1211         parameters => {
1212             type => 'object',
1213             description => "JSON Schema for parameters.",
1214             optional => 1,
1215         },
1216         formatter => {
1217             type => 'object',
1218             description => "Used to store page formatter information (set by PVE::RESTHandler->register_page_formatter).",
1219             optional => 1,
1220         },
1221         returns => {
1222             type => 'object',
1223             description => "JSON Schema for return value.",
1224             optional => 1,
1225         },
1226         code => {
1227             type => 'coderef',
1228             description => "method implementaion (code reference)",
1229             optional => 1,
1230         },
1231         subclass => {
1232             type => 'string',
1233             description => "Delegate call to this class (perl class string).",
1234             optional => 1,
1235             requires => {
1236                 additionalProperties => 0,
1237                 properties => {
1238                     subclass => {},
1239                     path => {},
1240                     match_name => {},
1241                     match_re => {},
1242                     fragmentDelimiter => { optional => 1 }
1243                 }
1244             },
1245         },
1246     },
1247
1248 };
1249
1250 sub validate_schema {
1251     my ($schema) = @_;
1252
1253     my $errmsg = "internal error - unable to verify schema\n";
1254     validate($schema, $default_schema, $errmsg);
1255 }
1256
1257 sub validate_method_info {
1258     my $info = shift;
1259
1260     my $errmsg = "internal error - unable to verify method info\n";
1261     validate($info, $method_schema, $errmsg);
1262
1263     validate_schema($info->{parameters}) if $info->{parameters};
1264     validate_schema($info->{returns}) if $info->{returns};
1265 }
1266
1267 # run a self test on load
1268 # make sure we can verify the default schema
1269 validate_schema($default_schema_noref);
1270 validate_schema($method_schema);
1271
1272 # and now some utility methods (used by pve api)
1273 sub method_get_child_link {
1274     my ($info) = @_;
1275
1276     return undef if !$info;
1277
1278     my $schema = $info->{returns};
1279     return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
1280
1281     my $links = $schema->{links};
1282     return undef if !$links;
1283
1284     my $found;
1285     foreach my $lnk (@$links) {
1286         if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
1287             $found = $lnk;
1288             last;
1289         }
1290     }
1291
1292     return $found;
1293 }
1294
1295 # a way to parse command line parameters, using a
1296 # schema to configure Getopt::Long
1297 sub get_options {
1298     my ($schema, $args, $arg_param, $fixed_param, $pwcallback) = @_;
1299
1300     if (!$schema || !$schema->{properties}) {
1301         raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1302             if scalar(@$args) != 0;
1303         return {};
1304     }
1305
1306     my $list_param;
1307     if ($arg_param && !ref($arg_param)) {
1308         my $pd = $schema->{properties}->{$arg_param};
1309         die "expected list format $pd->{format}"
1310             if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
1311         $list_param = $arg_param;
1312     }
1313
1314     my @getopt = ();
1315     foreach my $prop (keys %{$schema->{properties}}) {
1316         my $pd = $schema->{properties}->{$prop};
1317         next if $list_param && $prop eq $list_param;
1318         next if defined($fixed_param->{$prop});
1319
1320         if ($prop eq 'password' && $pwcallback) {
1321             # we do not accept plain password on input line, instead
1322             # we turn this into a boolean option and ask for password below
1323             # using $pwcallback() (for security reasons).
1324             push @getopt, "$prop";
1325         } elsif ($pd->{type} eq 'boolean') {
1326             push @getopt, "$prop:s";
1327         } else {
1328             if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
1329                 push @getopt, "$prop=s@";
1330             } else {
1331                 push @getopt, "$prop=s";
1332             }
1333         }
1334     }
1335
1336     Getopt::Long::Configure('prefix_pattern=(--|-)');
1337
1338     my $opts = {};
1339     raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
1340         if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
1341
1342     if (@$args) {
1343         if ($list_param) {
1344             $opts->{$list_param} = $args;
1345             $args = [];
1346         } elsif (ref($arg_param)) {
1347             foreach my $arg_name (@$arg_param) {
1348                 if ($opts->{'extra-args'}) {
1349                     raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
1350                 }
1351                 if ($arg_name eq 'extra-args') {
1352                     $opts->{'extra-args'} = $args;
1353                     $args = [];
1354                     next;
1355                 }
1356                 raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
1357                 $opts->{$arg_name} = shift @$args;
1358             }
1359             raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
1360         } else {
1361             raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1362                 if scalar(@$args) != 0;
1363         }
1364     }
1365
1366     if (my $pd = $schema->{properties}->{password}) {
1367         if ($pd->{type} ne 'boolean' && $pwcallback) {
1368             if ($opts->{password} || !$pd->{optional}) {
1369                 $opts->{password} = &$pwcallback();
1370             }
1371         }
1372     }
1373
1374     $opts = PVE::Tools::decode_utf8_parameters($opts);
1375
1376     foreach my $p (keys %$opts) {
1377         if (my $pd = $schema->{properties}->{$p}) {
1378             if ($pd->{type} eq 'boolean') {
1379                 if ($opts->{$p} eq '') {
1380                     $opts->{$p} = 1;
1381                 } elsif ($opts->{$p} =~ m/^(1|true|yes|on)$/i) {
1382                     $opts->{$p} = 1;
1383                 } elsif ($opts->{$p} =~ m/^(0|false|no|off)$/i) {
1384                     $opts->{$p} = 0;
1385                 } else {
1386                     raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
1387                 }
1388             } elsif ($pd->{format}) {
1389
1390                 if ($pd->{format} =~ m/-list/) {
1391                     # allow --vmid 100 --vmid 101 and --vmid 100,101
1392                     # allow --dow mon --dow fri and --dow mon,fri
1393                     $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1394                 } elsif ($pd->{format} =~ m/-alist/) {
1395                     # we encode array as \0 separated strings
1396                     # Note: CGI.pm also use this encoding
1397                     if (scalar(@{$opts->{$p}}) != 1) {
1398                         $opts->{$p} = join("\0", @{$opts->{$p}});
1399                     } else {
1400                         # st that split_list knows it is \0 terminated
1401                         my $v = $opts->{$p}->[0];
1402                         $opts->{$p} = "$v\0";
1403                     }
1404                 }
1405             }
1406         }
1407     }
1408
1409     foreach my $p (keys %$fixed_param) {
1410         $opts->{$p} = $fixed_param->{$p};
1411     }
1412
1413     return $opts;
1414 }
1415
1416 # A way to parse configuration data by giving a json schema
1417 sub parse_config {
1418     my ($schema, $filename, $raw) = @_;
1419
1420     # do fast check (avoid validate_schema($schema))
1421     die "got strange schema" if !$schema->{type} ||
1422         !$schema->{properties} || $schema->{type} ne 'object';
1423
1424     my $cfg = {};
1425
1426     while ($raw =~ /^\s*(.+?)\s*$/gm) {
1427         my $line = $1;
1428
1429         next if $line =~ /^#/;
1430
1431         if ($line =~ m/^(\S+?):\s*(.*)$/) {
1432             my $key = $1;
1433             my $value = $2;
1434             if ($schema->{properties}->{$key} &&
1435                 $schema->{properties}->{$key}->{type} eq 'boolean') {
1436
1437                 $value = 1 if $value =~ m/^(1|on|yes|true)$/i;
1438                 $value = 0 if $value =~ m/^(0|off|no|false)$/i;
1439             }
1440             $cfg->{$key} = $value;
1441         } else {
1442             warn "ignore config line: $line\n"
1443         }
1444     }
1445
1446     my $errors = {};
1447     check_prop($cfg, $schema, '', $errors);
1448
1449     foreach my $k (keys %$errors) {
1450         warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1451         delete $cfg->{$k};
1452     }
1453
1454     return $cfg;
1455 }
1456
1457 # generate simple key/value file
1458 sub dump_config {
1459     my ($schema, $filename, $cfg) = @_;
1460
1461     # do fast check (avoid validate_schema($schema))
1462     die "got strange schema" if !$schema->{type} ||
1463         !$schema->{properties} || $schema->{type} ne 'object';
1464
1465     validate($cfg, $schema, "validation error in '$filename'\n");
1466
1467     my $data = '';
1468
1469     foreach my $k (keys %$cfg) {
1470         $data .= "$k: $cfg->{$k}\n";
1471     }
1472
1473     return $data;
1474 }
1475
1476 1;