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