src/PVE/JSONSchema.pm

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