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