do not merge comma separated lists with zero separated lists
[pve-common.git] / data / PVE / JSONSchema.pm
CommitLineData
e143e9d8
DM
1package PVE::JSONSchema;
2
3use warnings;
4use strict;
5use Storable; # for dclone
6use Getopt::Long;
7use Devel::Cycle -quiet; # todo: remove?
8use PVE::Tools qw(split_list);
9use PVE::Exception qw(raise);
10use HTTP::Status qw(:constants);
11
12use base 'Exporter';
13
14our @EXPORT_OK = qw(
15register_standard_option
16get_standard_option
17);
18
19# Note: This class implements something similar to JSON schema, but it is not 100% complete.
20# see: http://tools.ietf.org/html/draft-zyp-json-schema-02
21# see: http://json-schema.org/
22
23# the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
24
25my $standard_options = {};
26sub register_standard_option {
27 my ($name, $schema) = @_;
28
29 die "standard option '$name' already registered\n"
30 if $standard_options->{$name};
31
32 $standard_options->{$name} = $schema;
33}
34
35sub get_standard_option {
36 my ($name, $base) = @_;
37
38 my $std = $standard_options->{$name};
39 die "no such standard option\n" if !$std;
40
41 my $res = $base || {};
42
43 foreach my $opt (keys %$std) {
44 next if $res->{$opt};
45 $res->{$opt} = $std->{$opt};
46 }
47
48 return $res;
49};
50
51register_standard_option('pve-vmid', {
52 description => "The (unique) ID of the VM.",
53 type => 'integer', format => 'pve-vmid',
54 minimum => 1
55});
56
57register_standard_option('pve-node', {
58 description => "The cluster node name.",
59 type => 'string', format => 'pve-node',
60});
61
62register_standard_option('pve-node-list', {
63 description => "List of cluster node names.",
64 type => 'string', format => 'pve-node-list',
65});
66
67register_standard_option('pve-iface', {
68 description => "Network interface name.",
69 type => 'string', format => 'pve-iface',
70 minLength => 2, maxLength => 20,
71});
72
73my $format_list = {};
74
75sub register_format {
76 my ($format, $code) = @_;
77
78 die "JSON schema format '$format' already registered\n"
79 if $format_list->{$format};
80
81 $format_list->{$format} = $code;
82}
83
84# register some common type for pve
85register_format('pve-configid', \&pve_verify_configid);
86sub pve_verify_configid {
87 my ($id, $noerr) = @_;
88
89 if ($id !~ m/^[a-z][a-z0-9_]+$/i) {
90 return undef if $noerr;
91 die "invalid cofiguration ID '$id'\n";
92 }
93 return $id;
94}
95
96register_format('pve-vmid', \&pve_verify_vmid);
97sub pve_verify_vmid {
98 my ($vmid, $noerr) = @_;
99
100 if ($vmid !~ m/^[1-9][0-9]+$/) {
101 return undef if $noerr;
102 die "value does not look like a valid VM ID\n";
103 }
104 return $vmid;
105}
106
107register_format('pve-node', \&pve_verify_node_name);
108sub pve_verify_node_name {
109 my ($node, $noerr) = @_;
110
111 # todo: use better regex ?
112 if ($node !~ m/^[A-Za-z][[:alnum:]\-]*[[:alnum:]]+$/) {
113 return undef if $noerr;
114 die "value does not look like a valid node name\n";
115 }
116 return $node;
117}
118
119register_format('ipv4', \&pve_verify_ipv4);
120sub pve_verify_ipv4 {
121 my ($ipv4, $noerr) = @_;
122
123 if ($ipv4 !~ m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ ||
124 !(($1 > 0) && ($1 < 255) &&
125 ($2 <= 255) && ($3 <= 255) &&
126 ($4 > 0) && ($4 < 255))) {
127 return undef if $noerr;
128 die "value does not look like a valid IP address\n";
129 }
130 return $ipv4;
131}
132register_format('ipv4mask', \&pve_verify_ipv4mask);
133sub pve_verify_ipv4mask {
134 my ($mask, $noerr) = @_;
135
136 if ($mask !~ m/^255\.255\.(\d{1,3})\.(\d{1,3})$/ ||
137 !(($1 <= 255) && ($2 <= 255))) {
138 return undef if $noerr;
139 die "value does not look like a valid IP netmask\n";
140 }
141 return $mask;
142}
143
144register_format('email', \&pve_verify_email);
145sub pve_verify_email {
146 my ($email, $noerr) = @_;
147
148 # we use same regex as extjs Ext.form.VTypes.email
149 if ($email !~ /^(\w+)([\-+.][\w]+)*@(\w[\-\w]*\.){1,5}([A-Za-z]){2,6}$/) {
150 return undef if $noerr;
151 die "value does not look like a valid email address\n";
152 }
153 return $email;
154}
155
156# network interface name
157register_format('pve-iface', \&pve_verify_iface);
158sub pve_verify_iface {
159 my ($id, $noerr) = @_;
160
161 if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
162 return undef if $noerr;
163 die "invalid network interface name '$id'\n";
164 }
165 return $id;
166}
167
168sub check_format {
169 my ($format, $value) = @_;
170
171 return if $format eq 'regex';
172
173 if ($format =~ m/^(.*)-list$/) {
174
175 my $code = $format_list->{$1};
176
177 die "undefined format '$format'\n" if !$code;
178
179 # Note: we allow empty lists
180 foreach my $v (split_list($value)) {
181 &$code($v);
182 }
183
184 } elsif ($format =~ m/^(.*)-opt$/) {
185
186 my $code = $format_list->{$1};
187
188 die "undefined format '$format'\n" if !$code;
189
190 return if !$value; # allow empty string
191
192 &$code($value);
193
194 } else {
195
196 my $code = $format_list->{$format};
197
198 die "undefined format '$format'\n" if !$code;
199
200 &$code($value);
201 }
202}
203
204sub add_error {
205 my ($errors, $path, $msg) = @_;
206
207 $path = '_root' if !$path;
208
209 if ($errors->{$path}) {
210 $errors->{$path} = join ('\n', $errors->{$path}, $msg);
211 } else {
212 $errors->{$path} = $msg;
213 }
214}
215
216sub is_number {
217 my $value = shift;
218
219 # see 'man perlretut'
220 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
221}
222
223sub is_integer {
224 my $value = shift;
225
226 return $value =~ m/^[+-]?\d+$/;
227}
228
229sub check_type {
230 my ($path, $type, $value, $errors) = @_;
231
232 return 1 if !$type;
233
234 if (!defined($value)) {
235 return 1 if $type eq 'null';
236 die "internal error"
237 }
238
239 if (my $tt = ref($type)) {
240 if ($tt eq 'ARRAY') {
241 foreach my $t (@$type) {
242 my $tmperr = {};
243 check_type($path, $t, $value, $tmperr);
244 return 1 if !scalar(%$tmperr);
245 }
246 my $ttext = join ('|', @$type);
247 add_error($errors, $path, "type check ('$ttext') failed");
248 return undef;
249 } elsif ($tt eq 'HASH') {
250 my $tmperr = {};
251 check_prop($value, $type, $path, $tmperr);
252 return 1 if !scalar(%$tmperr);
253 add_error($errors, $path, "type check failed");
254 return undef;
255 } else {
256 die "internal error - got reference type '$tt'";
257 }
258
259 } else {
260
261 return 1 if $type eq 'any';
262
263 if ($type eq 'null') {
264 if (defined($value)) {
265 add_error($errors, $path, "type check ('$type') failed - value is not null");
266 return undef;
267 }
268 return 1;
269 }
270
271 my $vt = ref($value);
272
273 if ($type eq 'array') {
274 if (!$vt || $vt ne 'ARRAY') {
275 add_error($errors, $path, "type check ('$type') failed");
276 return undef;
277 }
278 return 1;
279 } elsif ($type eq 'object') {
280 if (!$vt || $vt ne 'HASH') {
281 add_error($errors, $path, "type check ('$type') failed");
282 return undef;
283 }
284 return 1;
285 } elsif ($type eq 'coderef') {
286 if (!$vt || $vt ne 'CODE') {
287 add_error($errors, $path, "type check ('$type') failed");
288 return undef;
289 }
290 return 1;
291 } else {
292 if ($vt) {
293 add_error($errors, $path, "type check ('$type') failed - got $vt");
294 return undef;
295 } else {
296 if ($type eq 'string') {
297 return 1; # nothing to check ?
298 } elsif ($type eq 'boolean') {
299 #if ($value =~ m/^(1|true|yes|on)$/i) {
300 if ($value eq '1') {
301 return 1;
302 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
303 } elsif ($value eq '0') {
304 return 0;
305 } else {
306 add_error($errors, $path, "type check ('$type') failed - got '$value'");
307 return undef;
308 }
309 } elsif ($type eq 'integer') {
310 if (!is_integer($value)) {
311 add_error($errors, $path, "type check ('$type') failed - got '$value'");
312 return undef;
313 }
314 return 1;
315 } elsif ($type eq 'number') {
316 if (!is_number($value)) {
317 add_error($errors, $path, "type check ('$type') failed - got '$value'");
318 return undef;
319 }
320 return 1;
321 } else {
322 return 1; # no need to verify unknown types
323 }
324 }
325 }
326 }
327
328 return undef;
329}
330
331sub check_object {
332 my ($path, $schema, $value, $additional_properties, $errors) = @_;
333
334 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
335
336 my $st = ref($schema);
337 if (!$st || $st ne 'HASH') {
338 add_error($errors, $path, "Invalid schema definition.");
339 return;
340 }
341
342 my $vt = ref($value);
343 if (!$vt || $vt ne 'HASH') {
344 add_error($errors, $path, "an object is required");
345 return;
346 }
347
348 foreach my $k (keys %$schema) {
349 check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors);
350 }
351
352 foreach my $k (keys %$value) {
353
354 my $newpath = $path ? "$path.$k" : $k;
355
356 if (my $subschema = $schema->{$k}) {
357 if (my $requires = $subschema->{requires}) {
358 if (ref($requires)) {
359 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
360 check_prop($value, $requires, $path, $errors);
361 } elsif (!defined($value->{$requires})) {
362 add_error($errors, $path ? "$path.$requires" : $requires,
363 "missing property - '$newpath' requiers this property");
364 }
365 }
366
367 next; # value is already checked above
368 }
369
370 if (defined ($additional_properties) && !$additional_properties) {
371 add_error($errors, $newpath, "property is not defined in schema " .
372 "and the schema does not allow additional properties");
373 next;
374 }
375 check_prop($value->{$k}, $additional_properties, $newpath, $errors)
376 if ref($additional_properties);
377 }
378}
379
380sub check_prop {
381 my ($value, $schema, $path, $errors) = @_;
382
383 die "internal error - no schema" if !$schema;
384 die "internal error" if !$errors;
385
386 #print "check_prop $path\n" if $value;
387
388 my $st = ref($schema);
389 if (!$st || $st ne 'HASH') {
390 add_error($errors, $path, "Invalid schema definition.");
391 return;
392 }
393
394 # if it extends another schema, it must pass that schema as well
395 if($schema->{extends}) {
396 check_prop($value, $schema->{extends}, $path, $errors);
397 }
398
399 if (!defined ($value)) {
400 return if $schema->{type} && $schema->{type} eq 'null';
401 if (!$schema->{optional}) {
402 add_error($errors, $path, "property is missing and it is not optional");
403 }
404 return;
405 }
406
407 return if !check_type($path, $schema->{type}, $value, $errors);
408
409 if ($schema->{disallow}) {
410 my $tmperr = {};
411 if (check_type($path, $schema->{disallow}, $value, $tmperr)) {
412 add_error($errors, $path, "disallowed value was matched");
413 return;
414 }
415 }
416
417 if (my $vt = ref($value)) {
418
419 if ($vt eq 'ARRAY') {
420 if ($schema->{items}) {
421 my $it = ref($schema->{items});
422 if ($it && $it eq 'ARRAY') {
423 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
424 die "not implemented";
425 } else {
426 my $ind = 0;
427 foreach my $el (@$value) {
428 check_prop($el, $schema->{items}, "${path}[$ind]", $errors);
429 $ind++;
430 }
431 }
432 }
433 return;
434 } elsif ($schema->{properties} || $schema->{additionalProperties}) {
435 check_object($path, defined($schema->{properties}) ? $schema->{properties} : {},
436 $value, $schema->{additionalProperties}, $errors);
437 return;
438 }
439
440 } else {
441
442 if (my $format = $schema->{format}) {
443 eval { check_format($format, $value); };
444 if ($@) {
445 add_error($errors, $path, "invalid format - $@");
446 return;
447 }
448 }
449
450 if (my $pattern = $schema->{pattern}) {
451 if ($value !~ m/^$pattern$/) {
452 add_error($errors, $path, "value does not match the regex pattern");
453 return;
454 }
455 }
456
457 if (defined (my $max = $schema->{maxLength})) {
458 if (length($value) > $max) {
459 add_error($errors, $path, "value may only be $max characters long");
460 return;
461 }
462 }
463
464 if (defined (my $min = $schema->{minLength})) {
465 if (length($value) < $min) {
466 add_error($errors, $path, "value must be at least $min characters long");
467 return;
468 }
469 }
470
471 if (is_number($value)) {
472 if (defined (my $max = $schema->{maximum})) {
473 if ($value > $max) {
474 add_error($errors, $path, "value must have a maximum value of $max");
475 return;
476 }
477 }
478
479 if (defined (my $min = $schema->{minimum})) {
480 if ($value < $min) {
481 add_error($errors, $path, "value must have a minimum value of $min");
482 return;
483 }
484 }
485 }
486
487 if (my $ea = $schema->{enum}) {
488
489 my $found;
490 foreach my $ev (@$ea) {
491 if ($ev eq $value) {
492 $found = 1;
493 last;
494 }
495 }
496 if (!$found) {
497 add_error($errors, $path, "value '$value' does not have a value in the enumeration '" .
498 join(", ", @$ea) . "'");
499 }
500 }
501 }
502}
503
504sub validate {
505 my ($instance, $schema, $errmsg) = @_;
506
507 my $errors = {};
508 $errmsg = "Parameter verification failed.\n" if !$errmsg;
509
510 # todo: cycle detection is only needed for debugging, I guess
511 # we can disable that in the final release
512 # todo: is there a better/faster way to detect cycles?
513 my $cycles = 0;
514 find_cycle($instance, sub { $cycles = 1 });
515 if ($cycles) {
516 add_error($errors, undef, "data structure contains recursive cycles");
517 } elsif ($schema) {
518 check_prop($instance, $schema, '', $errors);
519 }
520
521 if (scalar(%$errors)) {
522 raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors;
523 }
524
525 return 1;
526}
527
528my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
529my $default_schema_noref = {
530 description => "This is the JSON Schema for JSON Schemas.",
531 type => [ "object" ],
532 additionalProperties => 0,
533 properties => {
534 type => {
535 type => ["string", "array"],
536 description => "This is a type definition value. This can be a simple type, or a union type",
537 optional => 1,
538 default => "any",
539 items => {
540 type => "string",
541 enum => $schema_valid_types,
542 },
543 enum => $schema_valid_types,
544 },
545 optional => {
546 type => "boolean",
547 description => "This indicates that the instance property in the instance object is not required.",
548 optional => 1,
549 default => 0
550 },
551 properties => {
552 type => "object",
553 description => "This is a definition for the properties of an object value",
554 optional => 1,
555 default => {},
556 },
557 items => {
558 type => "object",
559 description => "When the value is an array, this indicates the schema to use to validate each item in an array",
560 optional => 1,
561 default => {},
562 },
563 additionalProperties => {
564 type => [ "boolean", "object"],
565 description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
566 optional => 1,
567 default => {},
568 },
569 minimum => {
570 type => "number",
571 optional => 1,
572 description => "This indicates the minimum value for the instance property when the type of the instance value is a number.",
573 },
574 maximum => {
575 type => "number",
576 optional => 1,
577 description => "This indicates the maximum value for the instance property when the type of the instance value is a number.",
578 },
579 minLength => {
580 type => "integer",
581 description => "When the instance value is a string, this indicates minimum length of the string",
582 optional => 1,
583 minimum => 0,
584 default => 0,
585 },
586 maxLength => {
587 type => "integer",
588 description => "When the instance value is a string, this indicates maximum length of the string.",
589 optional => 1,
590 },
591 typetext => {
592 type => "string",
593 optional => 1,
594 description => "A text representation of the type (used to generate documentation).",
595 },
596 pattern => {
597 type => "string",
598 format => "regex",
599 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.",
600 optional => 1,
601 default => ".*",
602 },
603
604 enum => {
605 type => "array",
606 optional => 1,
607 description => "This provides an enumeration of possible values that are valid for the instance property.",
608 },
609 description => {
610 type => "string",
611 optional => 1,
612 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).",
613 },
614 title => {
615 type => "string",
616 optional => 1,
617 description => "This provides the title of the property",
618 },
619 requires => {
620 type => [ "string", "object" ],
621 optional => 1,
622 description => "indicates a required property or a schema that must be validated if this property is present",
623 },
624 format => {
625 type => "string",
626 optional => 1,
627 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",
628 },
629 default => {
630 type => "any",
631 optional => 1,
632 description => "This indicates the default for the instance property."
633 },
634 disallow => {
635 type => "object",
636 optional => 1,
637 description => "This attribute may take the same values as the \"type\" attribute, however if the instance matches the type or if this value is an array and the instance matches any type or schema in the array, than this instance is not valid.",
638 },
639 extends => {
640 type => "object",
641 optional => 1,
642 description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
643 default => {},
644 },
645 # this is from hyper schema
646 links => {
647 type => "array",
648 description => "This defines the link relations of the instance objects",
649 optional => 1,
650 items => {
651 type => "object",
652 properties => {
653 href => {
654 type => "string",
655 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",
656 },
657 rel => {
658 type => "string",
659 description => "This is the name of the link relation",
660 optional => 1,
661 default => "full",
662 },
663 method => {
664 type => "string",
665 description => "For submission links, this defines the method that should be used to access the target resource",
666 optional => 1,
667 default => "GET",
668 },
669 },
670 },
671 },
672 }
673};
674
675my $default_schema = Storable::dclone($default_schema_noref);
676
677$default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
678$default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
679
680$default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
681$default_schema->{properties}->{items}->{additionalProperties} = 0;
682
683$default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
684$default_schema->{properties}->{disallow}->{additionalProperties} = 0;
685
686$default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
687$default_schema->{properties}->{requires}->{additionalProperties} = 0;
688
689$default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
690$default_schema->{properties}->{extends}->{additionalProperties} = 0;
691
692my $method_schema = {
693 type => "object",
694 additionalProperties => 0,
695 properties => {
696 description => {
697 description => "This a description of the method",
698 optional => 1,
699 },
700 name => {
701 type => 'string',
702 description => "This indicates the name of the function to call.",
703 optional => 1,
704 requires => {
705 additionalProperties => 1,
706 properties => {
707 name => {},
708 description => {},
709 code => {},
710 method => {},
711 parameters => {},
712 path => {},
713 parameters => {},
714 returns => {},
715 }
716 },
717 },
718 method => {
719 type => 'string',
720 description => "The HTTP method name.",
721 enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
722 optional => 1,
723 },
724 protected => {
725 type => 'boolean',
726 description => "Method needs special privileges - only pvedaemon can execute it",
727 optional => 1,
728 },
729 proxyto => {
730 type => 'string',
731 description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
732 optional => 1,
733 },
734 permissions => {
735 type => 'object',
736 description => "Required access permissions. By default only 'root' is allowed to access this method.",
737 optional => 1,
738 additionalProperties => 0,
739 properties => {
740 user => {
741 description => "A simply way to allow access for 'all' users. The special value 'arg' allows access for the user specified in the 'username' parameter. This is useful to allow access to things owned by a user, like changing the user password. Value 'world' is used to allow access without credentials.",
742 type => 'string',
743 enum => ['all', 'arg', 'world'],
744 optional => 1,
745 },
746 path => { type => 'string', optional => 1, requires => 'privs' },
747 privs => { type => 'array', optional => 1, requires => 'path' },
748 },
749 },
750 match_name => {
751 description => "Used internally",
752 optional => 1,
753 },
754 match_re => {
755 description => "Used internally",
756 optional => 1,
757 },
758 path => {
759 type => 'string',
760 description => "path for URL matching (uri template)",
761 },
762 fragmentDelimiter => {
763 type => 'string',
764 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.",
765 optional => 1,
766 },
767 parameters => {
768 type => 'object',
769 description => "JSON Schema for parameters.",
770 optional => 1,
771 },
772 returns => {
773 type => 'object',
774 description => "JSON Schema for return value.",
775 optional => 1,
776 },
777 code => {
778 type => 'coderef',
779 description => "method implementaion (code reference)",
780 optional => 1,
781 },
782 subclass => {
783 type => 'string',
784 description => "Delegate call to this class (perl class string).",
785 optional => 1,
786 requires => {
787 additionalProperties => 0,
788 properties => {
789 subclass => {},
790 path => {},
791 match_name => {},
792 match_re => {},
793 fragmentDelimiter => { optional => 1 }
794 }
795 },
796 },
797 },
798
799};
800
801sub validate_schema {
802 my ($schema) = @_;
803
804 my $errmsg = "internal error - unable to verify schema\n";
805 validate($schema, $default_schema, $errmsg);
806}
807
808sub validate_method_info {
809 my $info = shift;
810
811 my $errmsg = "internal error - unable to verify method info\n";
812 validate($info, $method_schema, $errmsg);
813
814 validate_schema($info->{parameters}) if $info->{parameters};
815 validate_schema($info->{returns}) if $info->{returns};
816}
817
818# run a self test on load
819# make sure we can verify the default schema
820validate_schema($default_schema_noref);
821validate_schema($method_schema);
822
823# and now some utility methods (used by pve api)
824sub method_get_child_link {
825 my ($info) = @_;
826
827 return undef if !$info;
828
829 my $schema = $info->{returns};
830 return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
831
832 my $links = $schema->{links};
833 return undef if !$links;
834
835 my $found;
836 foreach my $lnk (@$links) {
837 if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
838 $found = $lnk;
839 last;
840 }
841 }
842
843 return $found;
844}
845
846# a way to parse command line parameters, using a
847# schema to configure Getopt::Long
848sub get_options {
849 my ($schema, $args, $uri_param, $pwcallback) = @_;
850
851 if (!$schema || !$schema->{properties}) {
852 raise("too many arguments\n", code => HTTP_BAD_REQUEST)
853 if scalar(@$args) != 0;
854 return {};
855 }
856
857 my @getopt = ();
858 foreach my $prop (keys %{$schema->{properties}}) {
859 my $pd = $schema->{properties}->{$prop};
860 next if defined($uri_param->{$prop});
861
862 if ($prop eq 'password' && $pwcallback) {
863 # we do not accept plain password on input line, instead
864 # we turn this into a boolean option and ask for password below
865 # using $pwcallback() (for security reasons).
866 push @getopt, "$prop";
867 } elsif ($pd->{type} eq 'boolean') {
868 push @getopt, "$prop:s";
869 } else {
870 push @getopt, "$prop=s";
871 }
872 }
873
874 my $opts = {};
875 raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
876 if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
877
878 raise("too many arguments\n", code => HTTP_BAD_REQUEST)
879 if scalar(@$args) != 0;
880
881 if (my $pd = $schema->{properties}->{password}) {
882 if ($pd->{type} ne 'boolean' && $pwcallback) {
883 if ($opts->{password} || !$pd->{optional}) {
884 $opts->{password} = &$pwcallback();
885 }
886 }
887 }
888
889 foreach my $p (keys %$opts) {
890 if (my $pd = $schema->{properties}->{$p}) {
891 if ($pd->{type} eq 'boolean') {
892 if ($opts->{$p} eq '') {
893 $opts->{$p} = 1;
894 } elsif ($opts->{$p} =~ m/^(1|true|yes|on)$/i) {
895 $opts->{$p} = 1;
896 } elsif ($opts->{$p} =~ m/^(0|false|no|off)$/i) {
897 $opts->{$p} = 0;
898 } else {
899 raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
900 }
901 }
902 }
903 }
904
905 foreach my $p (keys %$uri_param) {
906 $opts->{$p} = $uri_param->{$p};
907 }
908
909 return $opts;
910}
911
912# A way to parse configuration data by giving a json schema
913sub parse_config {
914 my ($schema, $filename, $raw) = @_;
915
916 # do fast check (avoid validate_schema($schema))
917 die "got strange schema" if !$schema->{type} ||
918 !$schema->{properties} || $schema->{type} ne 'object';
919
920 my $cfg = {};
921
922 while ($raw && $raw =~ s/^(.*?)(\n|$)//) {
923 my $line = $1;
924
925 next if $line =~ m/^\#/; # skip comment lines
926 next if $line =~ m/^\s*$/; # skip empty lines
927
928 if ($line =~ m/^(\S+):\s*(\S+)\s*$/) {
929 my $key = $1;
930 my $value = $2;
931 if ($schema->{properties}->{$key} &&
932 $schema->{properties}->{$key}->{type} eq 'boolean') {
933
934 $value = 1 if $value =~ m/^(1|on|yes|true)$/i;
935 $value = 0 if $value =~ m/^(0|off|no|false)$/i;
936 }
937 $cfg->{$key} = $value;
938 } else {
939 warn "ignore config line: $line\n"
940 }
941 }
942
943 my $errors = {};
944 check_prop($cfg, $schema, '', $errors);
945
946 foreach my $k (keys %$errors) {
947 warn "parse error in '$filename' - '$k': $errors->{$k}\n";
948 delete $cfg->{$k};
949 }
950
951 return $cfg;
952}
953
954# generate simple key/value file
955sub dump_config {
956 my ($schema, $filename, $cfg) = @_;
957
958 # do fast check (avoid validate_schema($schema))
959 die "got strange schema" if !$schema->{type} ||
960 !$schema->{properties} || $schema->{type} ne 'object';
961
962 validate($cfg, $schema, "validation error in '$filename'\n");
963
964 my $data = '';
965
966 foreach my $k (keys %$cfg) {
967 $data .= "$k: $cfg->{$k}\n";
968 }
969
970 return $data;
971}
972
9731;