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_standard_option('spice-proxy', {
 345     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).",
 346     type => 'string', format => 'address',
 347 });
 348
 349 register_standard_option('remote-viewer-config', {
 350     description => "Returned values can be directly passed to the 'remote-viewer' application.",
 351     additionalProperties => 1,
 352     properties => {
 353         type => { type => 'string' },
 354         password => { type => 'string' },
 355         proxy => { type => 'string' },
 356         host => { type => 'string' },
 357         'tls-port' => { type => 'integer' },
 358     },
 359 });
 360
 361 register_format('pve-startup-order', \&pve_verify_startup_order);
 362 sub pve_verify_startup_order {
 363     my ($value, $noerr) = @_;
 364
 365     return $value if pve_parse_startup_order($value);
 366
 367     return undef if $noerr;
 368
 369     die "unable to parse startup options\n";
 370 }
 371
 372 sub pve_parse_startup_order {
 373     my ($value) = @_;
 374
 375     return undef if !$value;
 376
 377     my $res = {};
 378
 379     foreach my $p (split(/,/, $value)) {
 380         next if $p =~ m/^\s*$/;
 381
 382         if ($p =~ m/^(order=)?(\d+)$/) {
 383             $res->{order} = $2;
 384         } elsif ($p =~ m/^up=(\d+)$/) {
 385             $res->{up} = $1;
 386         } elsif ($p =~ m/^down=(\d+)$/) {
 387             $res->{down} = $1;
 388         } else {
 389             return undef;
 390         }
 391     }
 392
 393     return $res;
 394 }
 395
 396 PVE::JSONSchema::register_standard_option('pve-startup-order', {
 397     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.",
 398     optional => 1,
 399     type => 'string', format => 'pve-startup-order',
 400     typetext => '[[order=]\d+] [,up=\d+] [,down=\d+] ',
 401 });
 402
 403 sub check_format {
 404     my ($format, $value, $path) = @_;
 405
 406     return parse_property_string($format, $value, $path) if ref($format) eq 'HASH';
 407     return if $format eq 'regex';
 408
 409     if ($format =~ m/^(.*)-a?list$/) {
 410
 411         my $code = $format_list->{$1};
 412
 413         die "undefined format '$format'\n" if !$code;
 414
 415         # Note: we allow empty lists
 416         foreach my $v (split_list($value)) {
 417             &$code($v);
 418         }
 419
 420     } elsif ($format =~ m/^(.*)-opt$/) {
 421
 422         my $code = $format_list->{$1};
 423
 424         die "undefined format '$format'\n" if !$code;
 425
 426         return if !$value; # allow empty string
 427
 428         &$code($value);
 429
 430    } else {
 431
 432         my $code = $format_list->{$format};
 433
 434         die "undefined format '$format'\n" if !$code;
 435
 436         return parse_property_string($code, $value, $path) if ref($code) eq 'HASH';
 437         &$code($value);
 438     }
 439 }
 440
 441 sub parse_size {
 442     my ($value) = @_;
 443
 444     return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
 445     my ($size, $unit) = ($1, $3);
 446     if ($unit) {
 447         if ($unit eq 'K') {
 448             $size = $size * 1024;
 449         } elsif ($unit eq 'M') {
 450             $size = $size * 1024 * 1024;
 451         } elsif ($unit eq 'G') {
 452             $size = $size * 1024 * 1024 * 1024;
 453         } elsif ($unit eq 'T') {
 454             $size = $size * 1024 * 1024 * 1024 * 1024;
 455         }
 456     }
 457     return int($size);
 458 };
 459
 460 sub format_size {
 461     my ($size) = @_;
 462
 463     $size = int($size);
 464
 465     my $kb = int($size/1024);
 466     return $size if $kb*1024 != $size;
 467
 468     my $mb = int($kb/1024);
 469     return "${kb}K" if $mb*1024 != $kb;
 470
 471     my $gb = int($mb/1024);
 472     return "${mb}M" if $gb*1024 != $mb;
 473
 474     my $tb = int($gb/1024);
 475     return "${gb}G" if $tb*1024 != $gb;
 476
 477     return "${tb}T";
 478 };
 479
 480 sub parse_property_string {
 481     my ($format, $data, $path) = @_;
 482
 483     my $default_key;
 484
 485     my $res = {};
 486     foreach my $part (split(/,/, $data)) {
 487         next if $part =~ /^\s*$/;
 488
 489         if ($part =~ /^([^=]+)=(.+)$/) {
 490             my ($k, $v) = ($1, $2);
 491             die "duplicate key in comma-separated list property: $k" if defined($res->{$k});
 492             my $schema = $format->{$k};
 493             die "invalid key in comma-separated list property: $k" if !$schema;
 494             if ($schema->{type} && $schema->{type} eq 'boolean') {
 495                 $v = 1 if $v =~ m/^(1|on|yes|true)$/i;
 496                 $v = 0 if $v =~ m/^(0|off|no|false)$/i;
 497             }
 498             $res->{$k} = $v;
 499         } elsif ($part !~ /=/) {
 500             die "duplicate key in comma-separated list property: $default_key" if $default_key;
 501             foreach my $key (keys %$format) {
 502                 if ($format->{$key}->{default_key}) {
 503                     $default_key = $key;
 504                     if (!$res->{$default_key}) {
 505                         $res->{$default_key} = $part;
 506                         last;
 507                     }
 508                     die "duplicate key in comma-separated list property: $default_key";
 509                 }
 510             }
 511         } else {
 512             die "missing key in comma-separated list property";
 513         }
 514     }
 515
 516     my $errors = {};
 517     check_object($path, $format, $res, undef, $errors);
 518     if (scalar(%$errors)) {
 519         raise "format error", errors => $errors;
 520     }
 521
 522     return $res;
 523 }
 524
 525 sub add_error {
 526     my ($errors, $path, $msg) = @_;
 527
 528     $path = '_root' if !$path;
 529
 530     if ($errors->{$path}) {
 531         $errors->{$path} = join ('\n', $errors->{$path}, $msg);
 532     } else {
 533         $errors->{$path} = $msg;
 534     }
 535 }
 536
 537 sub is_number {
 538     my $value = shift;
 539
 540     # see 'man perlretut'
 541     return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
 542 }
 543
 544 sub is_integer {
 545     my $value = shift;
 546
 547     return $value =~ m/^[+-]?\d+$/;
 548 }
 549
 550 sub check_type {
 551     my ($path, $type, $value, $errors) = @_;
 552
 553     return 1 if !$type;
 554
 555     if (!defined($value)) {
 556         return 1 if $type eq 'null';
 557         die "internal error"
 558     }
 559
 560     if (my $tt = ref($type)) {
 561         if ($tt eq 'ARRAY') {
 562             foreach my $t (@$type) {
 563                 my $tmperr = {};
 564                 check_type($path, $t, $value, $tmperr);
 565                 return 1 if !scalar(%$tmperr);
 566             }
 567             my $ttext = join ('|', @$type);
 568             add_error($errors, $path, "type check ('$ttext') failed");
 569             return undef;
 570         } elsif ($tt eq 'HASH') {
 571             my $tmperr = {};
 572             check_prop($value, $type, $path, $tmperr);
 573             return 1 if !scalar(%$tmperr);
 574             add_error($errors, $path, "type check failed");
 575             return undef;
 576         } else {
 577             die "internal error - got reference type '$tt'";
 578         }
 579
 580     } else {
 581
 582         return 1 if $type eq 'any';
 583
 584         if ($type eq 'null') {
 585             if (defined($value)) {
 586                 add_error($errors, $path, "type check ('$type') failed - value is not null");
 587                 return undef;
 588             }
 589             return 1;
 590         }
 591
 592         my $vt = ref($value);
 593
 594         if ($type eq 'array') {
 595             if (!$vt || $vt ne 'ARRAY') {
 596                 add_error($errors, $path, "type check ('$type') failed");
 597                 return undef;
 598             }
 599             return 1;
 600         } elsif ($type eq 'object') {
 601             if (!$vt || $vt ne 'HASH') {
 602                 add_error($errors, $path, "type check ('$type') failed");
 603                 return undef;
 604             }
 605             return 1;
 606         } elsif ($type eq 'coderef') {
 607             if (!$vt || $vt ne 'CODE') {
 608                 add_error($errors, $path, "type check ('$type') failed");
 609                 return undef;
 610             }
 611             return 1;
 612         } else {
 613             if ($vt) {
 614                 add_error($errors, $path, "type check ('$type') failed - got $vt");
 615                 return undef;
 616             } else {
 617                 if ($type eq 'string') {
 618                     return 1; # nothing to check ?
 619                 } elsif ($type eq 'boolean') {
 620                     #if ($value =~ m/^(1|true|yes|on)$/i) {
 621                     if ($value eq '1') {
 622                         return 1;
 623                     #} elsif ($value =~ m/^(0|false|no|off)$/i) {
 624                     } elsif ($value eq '0') {
 625                         return 0;
 626                     } else {
 627                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 628                         return undef;
 629                     }
 630                 } elsif ($type eq 'integer') {
 631                     if (!is_integer($value)) {
 632                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 633                         return undef;
 634                     }
 635                     return 1;
 636                 } elsif ($type eq 'number') {
 637                     if (!is_number($value)) {
 638                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
 639                         return undef;
 640                     }
 641                     return 1;
 642                 } else {
 643                     return 1; # no need to verify unknown types
 644                 }
 645             }
 646         }
 647     }
 648
 649     return undef;
 650 }
 651
 652 sub check_object {
 653     my ($path, $schema, $value, $additional_properties, $errors) = @_;
 654
 655     # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
 656
 657     my $st = ref($schema);
 658     if (!$st || $st ne 'HASH') {
 659         add_error($errors, $path, "Invalid schema definition.");
 660         return;
 661     }
 662
 663     my $vt = ref($value);
 664     if (!$vt || $vt ne 'HASH') {
 665         add_error($errors, $path, "an object is required");
 666         return;
 667     }
 668
 669     foreach my $k (keys %$schema) {
 670         check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors);
 671     }
 672
 673     foreach my $k (keys %$value) {
 674
 675         my $newpath =  $path ? "$path.$k" : $k;
 676
 677         if (my $subschema = $schema->{$k}) {
 678             if (my $requires = $subschema->{requires}) {
 679                 if (ref($requires)) {
 680                     #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
 681                     check_prop($value, $requires, $path, $errors);
 682                 } elsif (!defined($value->{$requires})) {
 683                     add_error($errors, $path ? "$path.$requires" : $requires,
 684                               "missing property - '$newpath' requiers this property");
 685                 }
 686             }
 687
 688             next; # value is already checked above
 689         }
 690
 691         if (defined ($additional_properties) && !$additional_properties) {
 692             add_error($errors, $newpath, "property is not defined in schema " .
 693                       "and the schema does not allow additional properties");
 694             next;
 695         }
 696         check_prop($value->{$k}, $additional_properties, $newpath, $errors)
 697             if ref($additional_properties);
 698     }
 699 }
 700
 701 sub check_object_warn {
 702     my ($path, $schema, $value, $additional_properties) = @_;
 703     my $errors = {};
 704     check_object($path, $schema, $value, $additional_properties, $errors);
 705     if (scalar(%$errors)) {
 706         foreach my $k (keys %$errors) {
 707             warn "parse error: $k: $errors->{$k}\n";
 708         }
 709         return 0;
 710     }
 711     return 1;
 712 }
 713
 714 sub check_prop {
 715     my ($value, $schema, $path, $errors) = @_;
 716
 717     die "internal error - no schema" if !$schema;
 718     die "internal error" if !$errors;
 719
 720     #print "check_prop $path\n" if $value;
 721
 722     my $st = ref($schema);
 723     if (!$st || $st ne 'HASH') {
 724         add_error($errors, $path, "Invalid schema definition.");
 725         return;
 726     }
 727
 728     # if it extends another schema, it must pass that schema as well
 729     if($schema->{extends}) {
 730         check_prop($value, $schema->{extends}, $path, $errors);
 731     }
 732
 733     if (!defined ($value)) {
 734         return if $schema->{type} && $schema->{type} eq 'null';
 735         if (!$schema->{optional}) {
 736             add_error($errors, $path, "property is missing and it is not optional");
 737         }
 738         return;
 739     }
 740
 741     return if !check_type($path, $schema->{type}, $value, $errors);
 742
 743     if ($schema->{disallow}) {
 744         my $tmperr = {};
 745         if (check_type($path, $schema->{disallow}, $value, $tmperr)) {
 746             add_error($errors, $path, "disallowed value was matched");
 747             return;
 748         }
 749     }
 750
 751     if (my $vt = ref($value)) {
 752
 753         if ($vt eq 'ARRAY') {
 754             if ($schema->{items}) {
 755                 my $it = ref($schema->{items});
 756                 if ($it && $it eq 'ARRAY') {
 757                     #die "implement me $path: $vt " . Dumper($schema) ."\n".  Dumper($value);
 758                     die "not implemented";
 759                 } else {
 760                     my $ind = 0;
 761                     foreach my $el (@$value) {
 762                         check_prop($el, $schema->{items}, "${path}[$ind]", $errors);
 763                         $ind++;
 764                     }
 765                 }
 766             }
 767             return;
 768         } elsif ($schema->{properties} || $schema->{additionalProperties}) {
 769             check_object($path, defined($schema->{properties}) ? $schema->{properties} : {},
 770                          $value, $schema->{additionalProperties}, $errors);
 771             return;
 772         }
 773
 774     } else {
 775
 776         if (my $format = $schema->{format}) {
 777             eval { check_format($format, $value, $path); };
 778             if ($@) {
 779                 add_error($errors, $path, "invalid format - $@");
 780                 return;
 781             }
 782         }
 783
 784         if (my $pattern = $schema->{pattern}) {
 785             if ($value !~ m/^$pattern$/) {
 786                 add_error($errors, $path, "value does not match the regex pattern");
 787                 return;
 788             }
 789         }
 790
 791         if (defined (my $max = $schema->{maxLength})) {
 792             if (length($value) > $max) {
 793                 add_error($errors, $path, "value may only be $max characters long");
 794                 return;
 795             }
 796         }
 797
 798         if (defined (my $min = $schema->{minLength})) {
 799             if (length($value) < $min) {
 800                 add_error($errors, $path, "value must be at least $min characters long");
 801                 return;
 802             }
 803         }
 804
 805         if (is_number($value)) {
 806             if (defined (my $max = $schema->{maximum})) {
 807                 if ($value > $max) {
 808                     add_error($errors, $path, "value must have a maximum value of $max");
 809                     return;
 810                 }
 811             }
 812
 813             if (defined (my $min = $schema->{minimum})) {
 814                 if ($value < $min) {
 815                     add_error($errors, $path, "value must have a minimum value of $min");
 816                     return;
 817                 }
 818             }
 819         }
 820
 821         if (my $ea = $schema->{enum}) {
 822
 823             my $found;
 824             foreach my $ev (@$ea) {
 825                 if ($ev eq $value) {
 826                     $found = 1;
 827                     last;
 828                 }
 829             }
 830             if (!$found) {
 831                 add_error($errors, $path, "value '$value' does not have a value in the enumeration '" .
 832                           join(", ", @$ea) . "'");
 833             }
 834         }
 835     }
 836 }
 837
 838 sub validate {
 839     my ($instance, $schema, $errmsg) = @_;
 840
 841     my $errors = {};
 842     $errmsg = "Parameter verification failed.\n" if !$errmsg;
 843
 844     # todo: cycle detection is only needed for debugging, I guess
 845     # we can disable that in the final release
 846     # todo: is there a better/faster way to detect cycles?
 847     my $cycles = 0;
 848     find_cycle($instance, sub { $cycles = 1 });
 849     if ($cycles) {
 850         add_error($errors, undef, "data structure contains recursive cycles");
 851     } elsif ($schema) {
 852         check_prop($instance, $schema, '', $errors);
 853     }
 854
 855     if (scalar(%$errors)) {
 856         raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors;
 857     }
 858
 859     return 1;
 860 }
 861
 862 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
 863 my $default_schema_noref = {
 864     description => "This is the JSON Schema for JSON Schemas.",
 865     type => [ "object" ],
 866     additionalProperties => 0,
 867     properties => {
 868         type => {
 869             type => ["string", "array"],
 870             description => "This is a type definition value. This can be a simple type, or a union type",
 871             optional => 1,
 872             default => "any",
 873             items => {
 874                 type => "string",
 875                 enum => $schema_valid_types,
 876             },
 877             enum => $schema_valid_types,
 878         },
 879         optional => {
 880             type => "boolean",
 881             description => "This indicates that the instance property in the instance object is not required.",
 882             optional => 1,
 883             default => 0
 884         },
 885         properties => {
 886             type => "object",
 887             description => "This is a definition for the properties of an object value",
 888             optional => 1,
 889             default => {},
 890         },
 891         items => {
 892             type => "object",
 893             description => "When the value is an array, this indicates the schema to use to validate each item in an array",
 894             optional => 1,
 895             default => {},
 896         },
 897         additionalProperties => {
 898             type => [ "boolean", "object"],
 899             description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
 900             optional => 1,
 901             default => {},
 902         },
 903         minimum => {
 904             type => "number",
 905             optional => 1,
 906             description => "This indicates the minimum value for the instance property when the type of the instance value is a number.",
 907         },
 908         maximum => {
 909             type => "number",
 910             optional => 1,
 911             description => "This indicates the maximum value for the instance property when the type of the instance value is a number.",
 912         },
 913         minLength => {
 914             type => "integer",
 915             description => "When the instance value is a string, this indicates minimum length of the string",
 916             optional => 1,
 917             minimum => 0,
 918             default => 0,
 919         },
 920         maxLength => {
 921             type => "integer",
 922             description => "When the instance value is a string, this indicates maximum length of the string.",
 923             optional => 1,
 924         },
 925         typetext => {
 926             type => "string",
 927             optional => 1,
 928             description => "A text representation of the type (used to generate documentation).",
 929         },
 930         pattern => {
 931             type => "string",
 932             format => "regex",
 933             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.",
 934             optional => 1,
 935             default => ".*",
 936         },
 937
 938         enum => {
 939             type => "array",
 940             optional => 1,
 941             description => "This provides an enumeration of possible values that are valid for the instance property.",
 942         },
 943         description => {
 944             type => "string",
 945             optional => 1,
 946             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).",
 947         },
 948         format_description => {
 949             type => "string",
 950             optional => 1,
 951             description => "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
 952         },
 953         title => {
 954             type => "string",
 955             optional => 1,
 956             description => "This provides the title of the property",
 957         },
 958         requires => {
 959             type => [ "string", "object" ],
 960             optional => 1,
 961             description => "indicates a required property or a schema that must be validated if this property is present",
 962         },
 963         format => {
 964             type => [ "string", "object" ],
 965             optional => 1,
 966             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",
 967         },
 968         default_key => {
 969             type => "boolean",
 970             optional => 1,
 971             description => "Whether this is the default key in a comma separated list property string.",
 972         },
 973         default => {
 974             type => "any",
 975             optional => 1,
 976             description => "This indicates the default for the instance property."
 977         },
 978         completion => {
 979             type => 'coderef',
 980             description => "Bash completion function. This function should return a list of possible values.",
 981             optional => 1,
 982         },
 983         disallow => {
 984             type => "object",
 985             optional => 1,
 986             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.",
 987         },
 988         extends => {
 989             type => "object",
 990             optional => 1,
 991             description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
 992             default => {},
 993         },
 994         # this is from hyper schema
 995         links => {
 996             type => "array",
 997             description => "This defines the link relations of the instance objects",
 998             optional => 1,
 999             items => {
1000                 type => "object",
1001                 properties => {
1002                     href => {
1003                         type => "string",
1004                         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",
1005                     },
1006                     rel => {
1007                         type => "string",
1008                         description => "This is the name of the link relation",
1009                         optional => 1,
1010                         default => "full",
1011                     },
1012                     method => {
1013                         type => "string",
1014                         description => "For submission links, this defines the method that should be used to access the target resource",
1015                         optional => 1,
1016                         default => "GET",
1017                     },
1018                 },
1019             },
1020         },
1021     }
1022 };
1023
1024 my $default_schema = Storable::dclone($default_schema_noref);
1025
1026 $default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
1027 $default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
1028
1029 $default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
1030 $default_schema->{properties}->{items}->{additionalProperties} = 0;
1031
1032 $default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
1033 $default_schema->{properties}->{disallow}->{additionalProperties} = 0;
1034
1035 $default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
1036 $default_schema->{properties}->{requires}->{additionalProperties} = 0;
1037
1038 $default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
1039 $default_schema->{properties}->{extends}->{additionalProperties} = 0;
1040
1041 my $method_schema = {
1042     type => "object",
1043     additionalProperties => 0,
1044     properties => {
1045         description => {
1046             description => "This a description of the method",
1047             optional => 1,
1048         },
1049         name => {
1050             type =>  'string',
1051             description => "This indicates the name of the function to call.",
1052             optional => 1,
1053             requires => {
1054                 additionalProperties => 1,
1055                 properties => {
1056                     name => {},
1057                     description => {},
1058                     code => {},
1059                     method => {},
1060                     parameters => {},
1061                     path => {},
1062                     parameters => {},
1063                     returns => {},
1064                 }
1065             },
1066         },
1067         method => {
1068             type =>  'string',
1069             description => "The HTTP method name.",
1070             enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
1071             optional => 1,
1072         },
1073         protected => {
1074             type => 'boolean',
1075             description => "Method needs special privileges - only pvedaemon can execute it",
1076             optional => 1,
1077         },
1078         proxyto => {
1079             type =>  'string',
1080             description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1081             optional => 1,
1082         },
1083         permissions => {
1084             type => 'object',
1085             description => "Required access permissions. By default only 'root' is allowed to access this method.",
1086             optional => 1,
1087             additionalProperties => 0,
1088             properties => {
1089                 description => {
1090                      description => "Describe access permissions.",
1091                      optional => 1,
1092                 },
1093                 user => {
1094                     description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1095                     type => 'string',
1096                     enum => ['all', 'world'],
1097                     optional => 1,
1098                 },
1099                 check => {
1100                     description => "Array of permission checks (prefix notation).",
1101                     type => 'array',
1102                     optional => 1
1103                 },
1104             },
1105         },
1106         match_name => {
1107             description => "Used internally",
1108             optional => 1,
1109         },
1110         match_re => {
1111             description => "Used internally",
1112             optional => 1,
1113         },
1114         path => {
1115             type =>  'string',
1116             description => "path for URL matching (uri template)",
1117         },
1118         fragmentDelimiter => {
1119             type => 'string',
1120             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.",
1121             optional => 1,
1122         },
1123         parameters => {
1124             type => 'object',
1125             description => "JSON Schema for parameters.",
1126             optional => 1,
1127         },
1128         formatter => {
1129             type => 'object',
1130             description => "Used to store page formatter information (set by PVE::RESTHandler->register_page_formatter).",
1131             optional => 1,
1132         },
1133         returns => {
1134             type => 'object',
1135             description => "JSON Schema for return value.",
1136             optional => 1,
1137         },
1138         code => {
1139             type => 'coderef',
1140             description => "method implementaion (code reference)",
1141             optional => 1,
1142         },
1143         subclass => {
1144             type => 'string',
1145             description => "Delegate call to this class (perl class string).",
1146             optional => 1,
1147             requires => {
1148                 additionalProperties => 0,
1149                 properties => {
1150                     subclass => {},
1151                     path => {},
1152                     match_name => {},
1153                     match_re => {},
1154                     fragmentDelimiter => { optional => 1 }
1155                 }
1156             },
1157         },
1158     },
1159
1160 };
1161
1162 sub validate_schema {
1163     my ($schema) = @_;
1164
1165     my $errmsg = "internal error - unable to verify schema\n";
1166     validate($schema, $default_schema, $errmsg);
1167 }
1168
1169 sub validate_method_info {
1170     my $info = shift;
1171
1172     my $errmsg = "internal error - unable to verify method info\n";
1173     validate($info, $method_schema, $errmsg);
1174
1175     validate_schema($info->{parameters}) if $info->{parameters};
1176     validate_schema($info->{returns}) if $info->{returns};
1177 }
1178
1179 # run a self test on load
1180 # make sure we can verify the default schema
1181 validate_schema($default_schema_noref);
1182 validate_schema($method_schema);
1183
1184 # and now some utility methods (used by pve api)
1185 sub method_get_child_link {
1186     my ($info) = @_;
1187
1188     return undef if !$info;
1189
1190     my $schema = $info->{returns};
1191     return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
1192
1193     my $links = $schema->{links};
1194     return undef if !$links;
1195
1196     my $found;
1197     foreach my $lnk (@$links) {
1198         if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
1199             $found = $lnk;
1200             last;
1201         }
1202     }
1203
1204     return $found;
1205 }
1206
1207 # a way to parse command line parameters, using a
1208 # schema to configure Getopt::Long
1209 sub get_options {
1210     my ($schema, $args, $arg_param, $fixed_param, $pwcallback) = @_;
1211
1212     if (!$schema || !$schema->{properties}) {
1213         raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1214             if scalar(@$args) != 0;
1215         return {};
1216     }
1217
1218     my $list_param;
1219     if ($arg_param && !ref($arg_param)) {
1220         my $pd = $schema->{properties}->{$arg_param};
1221         die "expected list format $pd->{format}"
1222             if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
1223         $list_param = $arg_param;
1224     }
1225
1226     my @getopt = ();
1227     foreach my $prop (keys %{$schema->{properties}}) {
1228         my $pd = $schema->{properties}->{$prop};
1229         next if $list_param && $prop eq $list_param;
1230         next if defined($fixed_param->{$prop});
1231
1232         if ($prop eq 'password' && $pwcallback) {
1233             # we do not accept plain password on input line, instead
1234             # we turn this into a boolean option and ask for password below
1235             # using $pwcallback() (for security reasons).
1236             push @getopt, "$prop";
1237         } elsif ($pd->{type} eq 'boolean') {
1238             push @getopt, "$prop:s";
1239         } else {
1240             if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
1241                 push @getopt, "$prop=s@";
1242             } else {
1243                 push @getopt, "$prop=s";
1244             }
1245         }
1246     }
1247
1248     Getopt::Long::Configure('prefix_pattern=(--|-)');
1249
1250     my $opts = {};
1251     raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
1252         if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
1253
1254     if (@$args) {
1255         if ($list_param) {
1256             $opts->{$list_param} = $args;
1257             $args = [];
1258         } elsif (ref($arg_param)) {
1259             foreach my $arg_name (@$arg_param) {
1260                 if ($opts->{'extra-args'}) {
1261                     raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
1262                 }
1263                 if ($arg_name eq 'extra-args') {
1264                     $opts->{'extra-args'} = $args;
1265                     $args = [];
1266                     next;
1267                 }
1268                 raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
1269                 $opts->{$arg_name} = shift @$args;
1270             }
1271             raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
1272         } else {
1273             raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1274                 if scalar(@$args) != 0;
1275         }
1276     }
1277
1278     if (my $pd = $schema->{properties}->{password}) {
1279         if ($pd->{type} ne 'boolean' && $pwcallback) {
1280             if ($opts->{password} || !$pd->{optional}) {
1281                 $opts->{password} = &$pwcallback();
1282             }
1283         }
1284     }
1285
1286     $opts = PVE::Tools::decode_utf8_parameters($opts);
1287
1288     foreach my $p (keys %$opts) {
1289         if (my $pd = $schema->{properties}->{$p}) {
1290             if ($pd->{type} eq 'boolean') {
1291                 if ($opts->{$p} eq '') {
1292                     $opts->{$p} = 1;
1293                 } elsif ($opts->{$p} =~ m/^(1|true|yes|on)$/i) {
1294                     $opts->{$p} = 1;
1295                 } elsif ($opts->{$p} =~ m/^(0|false|no|off)$/i) {
1296                     $opts->{$p} = 0;
1297                 } else {
1298                     raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
1299                 }
1300             } elsif ($pd->{format}) {
1301
1302                 if ($pd->{format} =~ m/-list/) {
1303                     # allow --vmid 100 --vmid 101 and --vmid 100,101
1304                     # allow --dow mon --dow fri and --dow mon,fri
1305                     $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1306                 } elsif ($pd->{format} =~ m/-alist/) {
1307                     # we encode array as \0 separated strings
1308                     # Note: CGI.pm also use this encoding
1309                     if (scalar(@{$opts->{$p}}) != 1) {
1310                         $opts->{$p} = join("\0", @{$opts->{$p}});
1311                     } else {
1312                         # st that split_list knows it is \0 terminated
1313                         my $v = $opts->{$p}->[0];
1314                         $opts->{$p} = "$v\0";
1315                     }
1316                 }
1317             }
1318         }
1319     }
1320
1321     foreach my $p (keys %$fixed_param) {
1322         $opts->{$p} = $fixed_param->{$p};
1323     }
1324
1325     return $opts;
1326 }
1327
1328 # A way to parse configuration data by giving a json schema
1329 sub parse_config {
1330     my ($schema, $filename, $raw) = @_;
1331
1332     # do fast check (avoid validate_schema($schema))
1333     die "got strange schema" if !$schema->{type} ||
1334         !$schema->{properties} || $schema->{type} ne 'object';
1335
1336     my $cfg = {};
1337
1338     while ($raw =~ /^\s*(.+?)\s*$/gm) {
1339         my $line = $1;
1340
1341         next if $line =~ /^#/;
1342
1343         if ($line =~ m/^(\S+?):\s*(.*)$/) {
1344             my $key = $1;
1345             my $value = $2;
1346             if ($schema->{properties}->{$key} &&
1347                 $schema->{properties}->{$key}->{type} eq 'boolean') {
1348
1349                 $value = 1 if $value =~ m/^(1|on|yes|true)$/i;
1350                 $value = 0 if $value =~ m/^(0|off|no|false)$/i;
1351             }
1352             $cfg->{$key} = $value;
1353         } else {
1354             warn "ignore config line: $line\n"
1355         }
1356     }
1357
1358     my $errors = {};
1359     check_prop($cfg, $schema, '', $errors);
1360
1361     foreach my $k (keys %$errors) {
1362         warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1363         delete $cfg->{$k};
1364     }
1365
1366     return $cfg;
1367 }
1368
1369 # generate simple key/value file
1370 sub dump_config {
1371     my ($schema, $filename, $cfg) = @_;
1372
1373     # do fast check (avoid validate_schema($schema))
1374     die "got strange schema" if !$schema->{type} ||
1375         !$schema->{properties} || $schema->{type} ne 'object';
1376
1377     validate($cfg, $schema, "validation error in '$filename'\n");
1378
1379     my $data = '';
1380
1381     foreach my $k (keys %$cfg) {
1382         $data .= "$k: $cfg->{$k}\n";
1383     }
1384
1385     return $data;
1386 }
1387
1388 1;