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