[RFC pve-common v2 02/17] jsonschema: support 'patternProperties' and allow 'x-' keywords

["Max R. Carrara" <m.carrara@proxmox.com>]

by adding the necessary validation code before the
`additionalProperties` handling in `check_object()` and extending the
default schema (the schema for JSON schemas).

At the same time, allow all keywords beginning with 'x-' to be
included in a given schema. This makes it possible specify custom
extension keywords that can be used for e.g. hints, flags, and other
things.

Signed-off-by: Max R. Carrara <m.carrara@proxmox.com>
---
NOTE: This patch is experimental and thus marked as RFC.

 src/PVE/JSONSchema.pm    | 61 +++++++++++++++++++++++++++++++++++-----
 test/json-schema-test.pl |  2 +-
 2 files changed, 55 insertions(+), 8 deletions(-)

diff --git a/src/PVE/JSONSchema.pm b/src/PVE/JSONSchema.pm
index 49f6aa6..1bfa5f6 100644
--- a/src/PVE/JSONSchema.pm
+++ b/src/PVE/JSONSchema.pm
@@ -1073,6 +1073,9 @@ sub parse_property_string {
     # In property strings we default to not allowing additional properties
     $additional_properties = 0 if !defined($additional_properties);

+    # In property strings we do not allow pattern properties at all
+    my $pattern_properties = 0;
+
     # Support named formats here, too:
     my $validator;
     if (!ref($format)) {
@@ -1141,7 +1144,7 @@ sub parse_property_string {
     }

     my $errors = {};
-    check_object($path, $format, $res, $additional_properties, $errors);
+    check_object($path, $format, $res, $pattern_properties, $additional_properties, $errors);
     if (scalar(%$errors)) {
         raise "format error\n", errors => $errors;
     }
@@ -1294,7 +1297,7 @@ my sub get_instance_type {
 }

 sub check_object {
-    my ($path, $schema, $value, $additional_properties, $errors) = @_;
+    my ($path, $schema, $value, $pattern_properties, $additional_properties, $errors) = @_;

     # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);

@@ -1367,6 +1370,23 @@ sub check_object {
             next if $matched_type; # value is already checked above
         }

+        if (defined($pattern_properties) && $pattern_properties) {
+            my $has_err = 0;
+            my $pattern_schema = undef;
+
+            for my $pattern (keys $pattern_properties->%*) {
+                if ($k =~ $pattern) {
+                    $pattern_schema = $pattern_properties->{$pattern};
+                    last;
+                }
+            }
+
+            next if $has_err;
+
+            check_prop($value->{$k}, $pattern_schema, $newpath, $errors);
+            next;
+        }
+
         if (defined($additional_properties) && !$additional_properties) {
             add_error(
                 $errors,
@@ -1382,9 +1402,9 @@ sub check_object {
 }

 sub check_object_warn {
-    my ($path, $schema, $value, $additional_properties) = @_;
+    my ($path, $schema, $value, $pattern_properties, $additional_properties) = @_;
     my $errors = {};
-    check_object($path, $schema, $value, $additional_properties, $errors);
+    check_object($path, $schema, $value, $pattern_properties, $additional_properties, $errors);
     if (scalar(%$errors)) {
         foreach my $k (keys %$errors) {
             warn "parse error: $k: $errors->{$k}\n";
@@ -1503,11 +1523,16 @@ sub check_prop {
                 }
             }
             return;
-        } elsif ($schema->{properties} || $schema->{additionalProperties}) {
+        } elsif (
+            $schema->{properties}
+            || $schema->{patternProperties}
+            || $schema->{additionalProperties}
+        ) {
             check_object(
                 $path,
                 defined($schema->{properties}) ? $schema->{properties} : {},
                 $value,
+                $schema->{patternProperties},
                 $schema->{additionalProperties},
                 $errors,
             );
@@ -1617,6 +1642,16 @@ my $schema_valid_types =
 my $default_schema_noref = {
     description => "This is the JSON Schema for JSON Schemas.",
     type => ["object"],
+    patternProperties => {
+        # Extension properties that are not part of the JSON Schema specification.
+        # This allows properties prefixed with 'x-' to be defined.
+        #
+        # Note that because such properties are not validated any further, they
+        # should be used sparingly.
+        qr/^x-/ => {
+            type => "any",
+        },
+    },
     additionalProperties => 0,
     properties => {
         type => {
@@ -1674,10 +1709,21 @@ my $default_schema_noref = {
             optional => 1,
             default => {},
         },
+        patternProperties => {
+            type => "object",
+            optional => 1,
+            description =>
+                "This provides property definitions for each property that matches the corresponding"
+                . " property name in this object. Each property name of this object should be a"
+                . " valid regular expression. Each property value of this object must be a valid"
+                . " JSON Schema.",
+        },
         additionalProperties => {
             type => ["boolean", "object"],
             description =>
-                "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
+                "This provides a default property definition for all properties that are not"
+                . " explicitly defined in an object type's 'properties' definition or match a"
+                . " pattern in 'patternProperties'.",
             optional => 1,
             default => {},
         },
@@ -1852,6 +1898,7 @@ 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}->{patternProperties}->{properties} = $default_schema->{properties};
 $default_schema->{properties}->{oneOf}->{items}->{properties} = $default_schema->{properties};

 $default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
@@ -2452,7 +2499,7 @@ sub print_property_string {
     }

     my $errors = {};
-    check_object($path, $format, $data, undef, $errors);
+    check_object($path, $format, $data, undef, undef, $errors);
     if (scalar(%$errors)) {
         raise "format error", errors => $errors;
     }
diff --git a/test/json-schema-test.pl b/test/json-schema-test.pl
index cb3ea66..f92fedb 100755
--- a/test/json-schema-test.pl
+++ b/test/json-schema-test.pl
@@ -197,7 +197,7 @@ for my $test ($check_object_alias_tests->@*) {
             my $value = { $subtest->{in}->%* }; # shallow clone

             my $errors = {};
-            PVE::JSONSchema::check_object('test', $test->{schema}, $value, 0, $errors);
+            PVE::JSONSchema::check_object('test', $test->{schema}, $value, undef, 0, $errors);
             my $err_str = join("\n", map { "$_: $errors->{$_}" } sort keys %$errors);

             if ($subtest->{must_fail}) {
--
2.47.3