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