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