[pve-devel] r4953 - pve-common/trunk
svn-commits at proxmox.com
svn-commits at proxmox.com
Tue Aug 10 08:51:55 CEST 2010
Author: dietmar
Date: 2010-08-10 06:51:55 +0000 (Tue, 10 Aug 2010)
New Revision: 4953
Added:
pve-common/trunk/JSONSchema.pm
Modified:
pve-common/trunk/Makefile
Log:
added JSONSchema.pm
Added: pve-common/trunk/JSONSchema.pm
===================================================================
--- pve-common/trunk/JSONSchema.pm (rev 0)
+++ pve-common/trunk/JSONSchema.pm 2010-08-10 06:51:55 UTC (rev 4953)
@@ -0,0 +1,606 @@
+package PVE::JSONSchema;
+
+use warnings;
+use strict;
+use Storable; # for dclone
+use Devel::Cycle -quiet; # fixme: remove?
+use Data::Dumper; # fixme: remove
+
+# Note: This class implements something similar to JSON schema, but it is not 100% complete.
+# see: http://tools.ietf.org/html/draft-zyp-json-schema-02
+# see: http://json-schema.org/
+
+# the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
+
+# fixme: implement 'format' property
+
+sub add_error {
+ my ($errors, $path, $msg) = @_;
+
+ $path = '_root' if !$path;
+
+ if ($errors->{$path}) {
+ $errors->{$path} = join ('\n', $errors->{$path}, $msg);
+ } else {
+ $errors->{$path} = $msg;
+ }
+}
+
+sub is_number {
+ my $value = shift;
+
+ # see 'man perlretut'
+ return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
+}
+
+sub is_integer {
+ my $value = shift;
+
+ return $value =~ m/^[+-]?\d+$/;
+}
+
+sub check_type {
+ my ($path, $type, $value, $errors) = @_;
+
+ return 1 if !$type;
+
+ if (!defined($value)) {
+ return 1 if $type eq 'null';
+ die "internal error"
+ }
+
+ if (my $tt = ref($type)) {
+ if ($tt eq 'ARRAY') {
+ foreach my $t (@$type) {
+ my $tmperr = {};
+ check_type($path, $t, $value, $tmperr);
+ return 1 if !scalar(%$tmperr);
+ }
+ my $ttext = join ('|', @$type);
+ add_error($errors, $path, "type check ('$ttext') failed");
+ return undef;
+ } elsif ($tt eq 'HASH') {
+ my $tmperr = {};
+ check_prop($value, $type, $path, $tmperr);
+ return 1 if !scalar(%$tmperr);
+ add_error($errors, $path, "type check failed");
+ return undef;
+ } else {
+ die "internal error - got reference type '$tt'";
+ }
+
+ } else {
+
+ return 1 if $type eq 'any';
+
+ if ($type eq 'null') {
+ if (defined($value)) {
+ add_error($errors, $path, "type check ('$type') failed - value is not null");
+ return undef;
+ }
+ return 1;
+ }
+
+ my $vt = ref($value);
+
+ if ($type eq 'array') {
+ if (!$vt || $vt ne 'ARRAY') {
+ add_error($errors, $path, "type check ('$type') failed");
+ return undef;
+ }
+ return 1;
+ } elsif ($type eq 'object') {
+ if (!$vt || $vt ne 'HASH') {
+ add_error($errors, $path, "type check ('$type') failed");
+ return undef;
+ }
+ return 1;
+ } elsif ($type eq 'coderef') {
+ if (!$vt || $vt ne 'CODE') {
+ add_error($errors, $path, "type check ('$type') failed");
+ return undef;
+ }
+ return 1;
+ } else {
+ if ($vt) {
+ add_error($errors, $path, "type check ('$type') failed - got $vt");
+ return undef;
+ } else {
+ if ($type eq 'string') {
+ return 1; # nothing to check ?
+ } elsif ($type eq 'boolean') {
+ if ($value =~ m/^(1|yes|on)$/i) {
+ return 1;
+ } elsif ($value =~ m/^(0|no|off)$/i) {
+ return 0;
+ } else {
+ add_error($errors, $path, "type check ('$type') failed - got '$value'");
+ return undef;
+ }
+ } elsif ($type eq 'integer') {
+ if (!is_integer($value)) {
+ add_error($errors, $path, "type check ('$type') failed - got '$value'");
+ return undef;
+ }
+ return 1;
+ } elsif ($type eq 'number') {
+ if (!is_number($value)) {
+ add_error($errors, $path, "type check ('$type') failed - got '$value'");
+ return undef;
+ }
+ return 1;
+ } else {
+ return 1; # no need to verify unknown types
+ }
+ }
+ }
+ }
+
+ return undef;
+}
+
+sub check_object {
+ my ($path, $schema, $value, $additional_properties, $errors) = @_;
+
+ # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
+
+ my $st = ref($schema);
+ if (!$st || $st ne 'HASH') {
+ add_error($errors, $path, "Invalid schema definition.");
+ return;
+ }
+
+ my $vt = ref($value);
+ if (!$vt || $vt ne 'HASH') {
+ add_error($errors, $path, "an object is required");
+ return;
+ }
+
+ foreach my $k (keys %$schema) {
+ check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors);
+ }
+
+ foreach my $k (keys %$value) {
+
+ my $newpath = $path ? "$path.$k" : $k;
+
+ if (my $subschema = $schema->{$k}) {
+ if (my $requires = $subschema->{requires}) {
+ if (ref($requires)) {
+ #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
+ check_prop($value, $requires, $path, $errors);
+ } elsif (!defined($value->{$requires})) {
+ add_error($errors, $path ? "$path.$requires" : $requires,
+ "missing property - '$newpath' requiers this property");
+ }
+ }
+
+ next; # value is already checked above
+ }
+
+ if (defined ($additional_properties) && !$additional_properties) {
+ add_error($errors, $newpath, "property is not defined in schema " .
+ "and the schema does not allow additional properties");
+ next;
+ }
+ check_prop($value->{$k}, $additional_properties, $newpath, $errors)
+ if ref($additional_properties);
+ }
+}
+
+sub check_prop {
+ my ($value, $schema, $path, $errors) = @_;
+
+ die "internal error - no schema" if !$schema;
+ die "internal error" if !$errors;
+
+ #print "check_prop $path\n" if $value;
+
+ my $st = ref($schema);
+ if (!$st || $st ne 'HASH') {
+ add_error($errors, $path, "Invalid schema definition.");
+ return;
+ }
+
+ # if it extends another schema, it must pass that schema as well
+ if($schema->{extends}) {
+ check_prop($value, $schema->{extends}, $path, $errors);
+ }
+
+ if (!defined ($value)) {
+ return if $schema->{type} && $schema->{type} eq 'null';
+ if (!$schema->{optional}) {
+ add_error($errors, $path, "property is missing and it is not optional");
+ }
+ return;
+ }
+
+ return if !check_type($path, $schema->{type}, $value, $errors);
+
+ if ($schema->{disallow}) {
+ my $tmperr = {};
+ if (check_type($path, $schema->{disallow}, $value, $tmperr)) {
+ add_error($errors, $path, "disallowed value was matched");
+ return;
+ }
+ }
+
+ if (my $vt = ref($value)) {
+
+ if ($vt eq 'ARRAY') {
+ if ($schema->{items}) {
+ my $it = ref($schema->{items});
+ if ($it && $it eq 'ARRAY') {
+ die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
+ } else {
+ my $ind = 0;
+ foreach my $el (@$value) {
+ check_prop($el, $schema->{items}, "${path}[$ind]", $errors);
+ $ind++;
+ }
+ }
+ }
+ return;
+ } elsif ($schema->{properties} || $schema->{additionalProperties}) {
+ check_object($path, defined($schema->{properties}) ? $schema->{properties} : {},
+ $value, $schema->{additionalProperties}, $errors);
+ return;
+ }
+
+ } else {
+
+ if (my $pattern = $schema->{pattern}) {
+ if ($value !~ m/^$pattern$/) {
+ add_error($errors, $path, "value does not match the regex pattern");
+ return;
+ }
+ }
+
+ if (defined (my $max = $schema->{maxLength})) {
+ if (length($value) > $max) {
+ add_error($errors, $path, "value may only be $max characters long");
+ return;
+ }
+ }
+
+ if (defined (my $min = $schema->{minLength})) {
+ if (length($value) < $min) {
+ add_error($errors, $path, "value must be at least $min characters long");
+ return;
+ }
+ }
+
+ if (is_number($value)) {
+ if (defined (my $max = $schema->{maximum})) {
+ if ($value > $max) {
+ add_error($errors, $path, "value must have a maximum value of $max");
+ return;
+ }
+ }
+
+ if (defined (my $min = $schema->{minimum})) {
+ if ($value < $min) {
+ add_error($errors, $path, "value must have a minimum value of $min");
+ return;
+ }
+ }
+ }
+
+ if (my $ea = $schema->{enum}) {
+
+ my $found;
+ foreach my $ev (@$ea) {
+ if ($ev eq $value) {
+ $found = 1;
+ last;
+ }
+ }
+ if (!$found) {
+ add_error($errors, $path, "value '$value' does not have a value in the enumeration '" .
+ join(", ", @$ea) . "'");
+ }
+ }
+
+ }
+
+
+}
+
+sub validate {
+ my ($instance, $schema) = @_;
+
+ my $errors = {};
+
+ # fixme: cycle detection is only needed for debugging, I guess
+ # we can disable that in the final release
+ # fixme: is there a better/faster way to detect cycles?
+ my $cycles = 0;
+ find_cycle($instance, sub { $cycles = 1 });
+ if ($cycles) {
+ add_error($errors, undef, "data structure contains recursive cycles");
+ } elsif ($schema) {
+ check_prop($instance, $schema, '', $errors);
+ }
+
+ return {valid => !scalar(%$errors), errors => $errors};
+}
+
+my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
+my $default_schema_noref = {
+ description => "This is the JSON Schema for JSON Schemas.",
+ type => [ "object" ],
+ additionalProperties => 0,
+ properties => {
+ type => {
+ type => ["string", "array"],
+ description => "This is a type definition value. This can be a simple type, or a union type",
+ optional => 1,
+ default => "any",
+ items => {
+ type => "string",
+ enum => $schema_valid_types,
+ },
+ enum => $schema_valid_types,
+ },
+ optional => {
+ type => "boolean",
+ description => "This indicates that the instance property in the instance object is not required.",
+ optional => 1,
+ default => 0
+ },
+ properties => {
+ type => "object",
+ description => "This is a definition for the properties of an object value",
+ optional => 1,
+ default => {},
+ },
+ items => {
+ type => "object",
+ description => "When the value is an array, this indicates the schema to use to validate each item in an array",
+ optional => 1,
+ default => {},
+ },
+ additionalProperties => {
+ type => [ "boolean", "object"],
+ description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
+ optional => 1,
+ default => {},
+ },
+ minimum => {
+ type => "number",
+ optional => 1,
+ description => "This indicates the minimum value for the instance property when the type of the instance value is a number.",
+ },
+ maximum => {
+ type => "number",
+ optional => 1,
+ description => "This indicates the maximum value for the instance property when the type of the instance value is a number.",
+ },
+ pattern => {
+ type => "string",
+ format => "regex",
+ 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.",
+ optional => 1,
+ default => ".*",
+ },
+
+ enum => {
+ type => "array",
+ optional => 1,
+ description => "This provides an enumeration of possible values that are valid for the instance property.",
+ },
+ description => {
+ type => "string",
+ optional => 1,
+ 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).",
+ },
+ title => {
+ type => "string",
+ optional => 1,
+ description => "This provides the title of the property",
+ },
+ requires => {
+ type => [ "string", "object" ],
+ optional => 1,
+ description => "indicates a required property or a schema that must be validated if this property is present",
+ },
+ format => {
+ type => "string",
+ optional => 1,
+ 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",
+ },
+ default => {
+ type => "any",
+ optional => 1,
+ description => "This indicates the default for the instance property."
+ },
+ disallow => {
+ type => "object",
+ optional => 1,
+ 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.",
+ },
+ extends => {
+ type => "object",
+ optional => 1,
+ description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
+ default => {},
+ },
+ # this is from hyper schema
+ links => {
+ type => "array",
+ description => "This defines the link relations of the instance objects",
+ optional => 1,
+ items => {
+ type => "object",
+ properties => {
+ href => {
+ type => "string",
+ 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",
+ },
+ rel => {
+ type => "string",
+ description => "This is the name of the link relation",
+ optional => 1,
+ default => "full",
+ },
+ method => {
+ type => "string",
+ description => "For submission links, this defines the method that should be used to access the target resource",
+ optional => 1,
+ default => "GET",
+ },
+ },
+ },
+ },
+ }
+};
+
+my $default_schema = Storable::dclone($default_schema_noref);
+
+$default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
+$default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
+
+$default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
+$default_schema->{properties}->{items}->{additionalProperties} = 0;
+
+$default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
+$default_schema->{properties}->{disallow}->{additionalProperties} = 0;
+
+$default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
+$default_schema->{properties}->{requires}->{additionalProperties} = 0;
+
+$default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
+$default_schema->{properties}->{extends}->{additionalProperties} = 0;
+
+my $method_schema = {
+ type => "object",
+ additionalProperties => 0,
+ properties => {
+ description => {
+ description => "This a description of the method",
+ optional => 1,
+ },
+ name => {
+ type => 'string',
+ description => "This indicates the name of the function to call.",
+ optional => 1,
+ requires => {
+ additionalProperties => 1,
+ properties => {
+ name => {},
+ description => {},
+ code => {},
+ method => {},
+ parameters => {},
+ path => {},
+ parameters => {},
+ returns => {},
+ }
+ },
+ },
+ method => {
+ type => 'string',
+ description => "The HTTP method name.",
+ enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
+ optional => 1,
+ },
+ protected => {
+ type => 'boolean',
+ description => "method needs special privileges - only pvedaemon can execute it",
+ optional => 1,
+ },
+ path => {
+ type => 'string',
+ description => "path for URL matching (uri template)",
+ },
+ parameters => {
+ type => 'object',
+ description => "JSON Schema for parameters.",
+ optional => 1,
+ },
+ returns => {
+ type => 'object',
+ description => "JSON Schema for return value.",
+ optional => 1,
+ },
+ code => {
+ type => 'coderef',
+ description => "method implementaion (code reference)",
+ optional => 1,
+ },
+ subclass => {
+ type => 'string',
+ description => "Delegate call to this class (perl class string).",
+ optional => 1,
+ requires => {
+ additionalProperties => 0,
+ properties => {
+ subclass => {},
+ path => {},
+ }
+ },
+ },
+ },
+
+};
+
+sub validate_schema {
+ my ($schema, $pre) = @_;
+
+ $pre = '' if !$pre;
+
+ my $res = validate($schema, $default_schema);
+ if (!$res->{valid}) {
+ foreach my $e (keys %{$res->{errors}}) {
+ warn "$pre$e: $res->{errors}->{$e}\n";
+ }
+ die "internal error - unable to verify schema";
+ }
+
+ return 1;
+}
+
+sub validate_method_info {
+ my $info = shift;
+
+ my $res = validate($info, $method_schema);
+ if (!$res->{valid}) {
+ foreach my $e (keys %{$res->{errors}}) {
+ warn "$e: $res->{errors}->{$e}\n";
+ }
+ die "internal error - unable to verify method info";
+ }
+
+ validate_schema($info->{parameters}) if $info->{parameters};
+ validate_schema($info->{returns}) if $info->{returns};
+}
+
+# run a self test on load
+# make sure we can verify the default schema
+validate_schema($default_schema_noref);
+validate_schema($method_schema);
+
+# and now some utility methods (used by pve api)
+sub method_get_child_link {
+ my ($info) = @_;
+
+ return undef if !$info;
+
+ my $schema = $info->{returns};
+ return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
+
+ my $links = $schema->{links};
+ return undef if !$links;
+
+ my $found;
+ foreach my $lnk (@$links) {
+ if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
+ $found = $lnk;
+ last;
+ }
+ }
+
+ return $found;
+}
+
+1;
Modified: pve-common/trunk/Makefile
===================================================================
--- pve-common/trunk/Makefile 2010-08-10 06:29:00 UTC (rev 4952)
+++ pve-common/trunk/Makefile 2010-08-10 06:51:55 UTC (rev 4953)
@@ -18,6 +18,7 @@
DEB=${PACKAGE}_${VERSION}-${PKGREL}_${ARCH}.deb
LIB_SOURCES= \
+ JSONSchema.pm \
Exception.pm
all: ${DEB}
More information about the pve-devel
mailing list