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