Created json_validate() for JSON form data, used for Staff alias editor

The intention is to move more JS editing forms to use JSON, but manually
verifying JSON objects is both painful and likely to introduce errors or
vulnerabilities. json_validate() is a bit of a hack, but has the
advantage that its validation syntax is the same as for normal forms,
and it automatically strips whitespace. I intent to give kv_validate()
an upgrade to be more flexible/modular so it can do more custom
normalization. But that's for later.

I've been meaning to rewrite the JS forms anyway together with the large
JS rewrite, but I'm rather lazy. This is one small step in the right
direction anyway.

Note that json_validate() assumes that the JS code will provide
user-friendly messages on bad input, but the staff alias editor doesn't
quite do this yet.

1 files changed, 28 insertions, 2 deletions

diff --git a/lib/VNDB/Func.pm b/lib/VNDB/Func.pm
index ac9fdd58..dd3f292e 100644
--- a/lib/VNDB/Func.pm
+++ b/lib/VNDB/Func.pm
@@ -3,7 +3,7 @@ package VNDB::Func;
 
 use strict;
 use warnings;
-use TUWF ':html';
+use TUWF ':html', 'kv_validate';
 use Exporter 'import';
 use POSIX 'strftime', 'ceil', 'floor';
 use JSON::XS;
@@ -11,7 +11,7 @@ use VNDBUtil;
 our @EXPORT = (@VNDBUtil::EXPORT, qw|
   clearfloat cssicon tagscore mt minage fil_parse fil_serialize parenttags
   childtags charspoil imgpath imgurl fmtvote
-  jsonEncode jsonDecode script_json
+  jsonEncode jsonDecode script_json json_validate
   mtvoiced mtani mtvnlen mtrlstat mtvnlstat mtbloodt
 |);
 
@@ -228,6 +228,32 @@ sub script_json {
 }
 
 
+# Special validation function for simple JSON structures as form fields. It can
+# only validate arrays of key-value objects. The key-value objects are then
+# validated using kv_validate.
+# Returns the parsed json object on success, undef on error and sets $frm->{_err}.
+# Doesn't provide a user-friendly error message if validation fails. It's the
+# responsibility of the JS code to handle the interface with the user.
+sub json_validate {
+  my($frm, $name, @fields) = @_;
+  my $data = eval { jsonDecode $frm->{$name} };
+  goto error if $@ || ref $data ne 'ARRAY';
+  my %known_fields = map +($_->{field},1), @fields;
+  for my $i (0..$#$data) {
+    goto error if ref $data->[$i] ne 'HASH';
+    # Require that all keys are known and have a scalar value.
+    goto error if grep !$known_fields{$_} || ref($data->[$i]{$_}), keys %{$data->[$i]};
+    $data->[$i] = kv_validate({ field => sub { $data->[$i]{shift()} } }, $TUWF::OBJ->{_TUWF}{validate_templates}, \@fields);
+    goto error if $data->[$i]{_err};
+  }
+
+  return $data;
+error:
+  push @{$frm->{_err}}, [ 'aliases', 'template', 'json' ] ;
+  return undef;
+}
+
+
 # mt() wrappers for data-dependent translation strings that have a special
 # value for 'unknown'.
 sub mtvoiced { !$_[0] ? mt '_unknown' : mt '_voiced_'.$_[0]; }