summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorYorhel <git@yorhel.nl>2018-04-15 10:11:09 +0200
committerYorhel <git@yorhel.nl>2018-04-15 10:11:11 +0200
commit1b0025f3140f5ef97a4222784cf2a38aa471d941 (patch)
tree3d4fa173d8ac1fd1d0bbce2415edf95ad4819bf9
parentfe5943688e9339e46cbec20a93f3ceb80d5d8f01 (diff)
Integrate TUWF::Validate with the rest of TUWF
- Add a 'custom_validations' setting - Add tuwf->compile() to compile with that setting - Add tuwf->validate() as alternative to formValidate() The new tuwf->validate() uses internal state of TUWF::Request, which had to be changed a bit to allow for more efficient validation. Nested schemas in TUWF::Validate now also accept compiled schemas. This stuff totally needs more documentation.
-rw-r--r--lib/TUWF.pm1
-rw-r--r--lib/TUWF.pod10
-rw-r--r--lib/TUWF/Misc.pm43
-rw-r--r--lib/TUWF/Misc.pod95
-rw-r--r--lib/TUWF/Request.pm33
-rw-r--r--lib/TUWF/Validate.pm3
6 files changed, 168 insertions, 17 deletions
diff --git a/lib/TUWF.pm b/lib/TUWF.pm
index 7487ab7..6818f9e 100644
--- a/lib/TUWF.pm
+++ b/lib/TUWF.pm
@@ -38,6 +38,7 @@ our $OBJ = bless {
sprintf "[%s] %s -> %s\n", scalar localtime(), $uri, $msg;
},
validate_templates => {},
+ custom_validations => {},
# No particular selection of MIME types
mime_types => {qw{
7z application/x-7z-compressed
diff --git a/lib/TUWF.pod b/lib/TUWF.pod
index 292bfe6..ff66282 100644
--- a/lib/TUWF.pod
+++ b/lib/TUWF.pod
@@ -404,6 +404,14 @@ all cookies not having the configured prefix never existed, and removes the
prefix when used in list context. C<resCookie()> will simply add the prefix to
all outgoing cookies. Default: undef (disabled).
+=item custom_validations
+
+Hashref, custom validations for the L<compile()|TUWF::Misc> and
+L<validate()|TUWF::Misc> functions. The recommended way to add new templates is
+to call C<TUWF::set()> with a single argument:
+
+ TUWF::set('custom_validations')->{$key} = \%schema;
+
=item db_login
Sets the login information for the L<TUWF::DB|TUWF::DB> functions. Can be set
@@ -829,7 +837,7 @@ FastCGI:
=head1 SEE ALSO
L<TUWF::Intro>, L<TUWF::DB>, L<TUWF::Misc>, L<TUWF::Request>, L<TUWF::Response>,
-L<TUWF::XML>.
+L<TUWF::XML>, L<TUWF::Validate>.
The homepage of TUWF can be found at
L<https://dev.yorhel.nl/tuwf|https://dev.yorhel.nl/tuwf>.
diff --git a/lib/TUWF/Misc.pm b/lib/TUWF/Misc.pm
index 91b3ae2..edea8de 100644
--- a/lib/TUWF/Misc.pm
+++ b/lib/TUWF/Misc.pm
@@ -13,7 +13,6 @@ use TUWF::Validate;
our $VERSION = '1.2';
-our @EXPORT = ('formValidate', 'mail');
our @EXPORT_OK = ('uri_escape', 'kv_validate');
@@ -148,7 +147,7 @@ sub _validate { # value, \%templates, \%rules
-sub formValidate {
+sub TUWF::Object::formValidate {
my($self, @fields) = @_;
return kv_validate(
{ post => sub { $self->reqPosts(shift) },
@@ -164,7 +163,7 @@ sub formValidate {
# A simple mail function, body and headers as arguments. Usage:
# $self->mail('body', header1 => 'value of header 1', ..);
-sub mail {
+sub TUWF::Object::mail {
my $self = shift;
my $body = shift;
my %hs = @_;
@@ -192,4 +191,42 @@ sub mail {
}
+sub TUWF::Object::compile {
+ TUWF::Validate::compile($_[0]{_TUWF}{custom_validations}, $_[1]);
+}
+
+
+sub _compile {
+ ref $_[0] eq 'TUWF::Validate' ? $_[0] : $TUWF::OBJ->compile($_[0]);
+}
+
+
+sub TUWF::Object::validate {
+ my $self = shift;
+ my $what = shift;
+
+ return _compile($_[0])->validate($self->reqJSON) if $what eq 'json';
+
+ # 'param' is special, and not really encouraged. Create a new hash based on
+ # reqParam() and cache the result.
+ $self->{_TUWF}{Req}{PARAM} ||= {
+ map { my @v = $self->reqParams($_); +($_, @v > 1 ? \@v : $v[0]) } $self->reqParams()
+ } if $what eq 'param';
+
+ my $source =
+ $what eq 'get' ? $self->{_TUWF}{Req}{GET} :
+ $what eq 'post' ? $self->{_TUWF}{Req}{POST} :
+ $what eq 'param' ? $self->{_TUWF}{Req}{PARAM}
+ : croak "Invalid source type '$what'";
+
+ # Multi-value, schema hash or object
+ return _compile($_[0])->validate($source) if @_ == 1;
+
+ # Single value
+ return _compile($_[1])->validate($source->{$_[0]}) if @_ == 2;
+
+ # Multi-value, separate params
+ _comile({ @_ })->validate($source);
+}
+
1;
diff --git a/lib/TUWF/Misc.pod b/lib/TUWF/Misc.pod
index 6e2b6ca..f2fd61d 100644
--- a/lib/TUWF/Misc.pod
+++ b/lib/TUWF/Misc.pod
@@ -28,6 +28,101 @@ Shorthand for calling C<kv_validate()> with the following sources:
The L<validate_templates|TUWF/validate_templates> configuration setting is
passed as the I<templates> option.
+=head2 compile($schema)
+
+I<Experimental.> Short-hand for calling
+L<TUWF::Validate::compile|TUWF::Validate/compile> with the
+L<custom_validations|TUWF/custom_validations> option. For example:
+
+ TUWF::set('custom_validations')->{username} = { length => [ 3, 32 ] };
+
+ my $val = tuwf->compile({ username => 1 })->validate('this is a username')->data;
+
+=head2 validate(what, @args)
+
+I<Experimental replacement for formValidate().> Validate and return request
+data using L<TUWF::Validate>. The first argument must be the source of the data
+to validate, the following sources are supported:
+
+ Argument Source
+ post reqPosts()
+ get reqGets()
+ param reqParams()
+ json reqJSON()
+
+This method takes several different forms for the further arguments (the
+examples below will perhaps make this more clear):
+
+=over
+
+=item Single value (C<< tuwf->validate($source, $param_name, $schema)> >>)
+
+In this form, only a single value is validated and returned.
+
+=item Hash value (C<< tuwf->validate($source, $schema) >>)
+
+In this form, the source is converted into a hash table and then validated. The
+C<$schema> then validates the entire hash.
+
+=item Multiple values (C<< tuwf->validate($source, $param1, $schema1, $param2, $schema2, ..) >>)
+
+This form uses the syntax of the I<Single value> form to validate multiple
+values. It is a convenient short-hand for the I<Hash value> form.
+
+=back
+
+The C<$schema> argument in the above description can be either a bare or
+compiled schema. A bare schema will be compiled with the
+L<custom_validations|TUWF/custom_validations> setting.
+
+The C<json> source only supports the I<Hash value> form. Using the C<param>
+source is discouraged, as it is slower than using the C<get> or C<post> source
+directly. And in almost all cases you only need to accept the data from either
+the query string or the POST data, not both.
+
+If a get/post/param parameter has multiple values, it is represented in the
+source data as an array. To handle parameters that may occur any number of
+times, use a C<< {type => 'array', scalar => 1} >> schema.
+
+Some examples:
+
+ # JSON, with custom error handling
+ my $validation_result = tuwf->validate(json => {
+ type => 'hash',
+ keys => {
+ username => { length => [ 3, 32 ] },
+ password => { },
+ }
+ });
+ if($validation_result) {
+ my $data = $validation_result->data;
+ check_login($data->{username}, $data->{password});
+ } else {
+ show_error();
+ }
+
+ # Single value
+ my $page_number = tuwf->validate(get => page => { uint => 1, max => 1000 })->data;
+
+ # Same, with a pre-compiled scheme (this is faster)
+ state $c = tuwf->compile({ uint => 1, max => 1000 });
+ my $page_number = tuwf->validate(get => page => $c)->data;
+
+ # Multiple values
+ my $data = tuwf->validate(post =>
+ username => { length => [ 3, 32 ] },
+ password => { },
+ )->data;
+
+ # Same, using the "Hash value" form
+ my $data = tuwf->validate(post => {
+ type => 'hash',
+ keys => {
+ username => { length => [ 3, 32 ] },
+ password => { },
+ }
+ })->data;
+
=head2 mail(body, header => value, ..)
Very simple email sending function. The C<Content-Type> header defaults to
diff --git a/lib/TUWF/Request.pm b/lib/TUWF/Request.pm
index 5d7647f..7ca545f 100644
--- a/lib/TUWF/Request.pm
+++ b/lib/TUWF/Request.pm
@@ -68,6 +68,12 @@ sub _check_control {
}
+sub _store {
+ return push @{$_[0]}, $_[1] if ref $_[0];
+ $_[0] = $_[0] ? [$_[0], $_[1]] : $_[1];
+}
+
+
sub _parse_urlencoded {
my %dat;
my $d = shift;
@@ -84,7 +90,7 @@ sub _parse_urlencoded {
s/%u([0-9a-fA-F]{4})/chr hex($1)/eg;
_check_control($_);
}
- push @{$dat{$key}}, $val;
+ _store $dat{$key}, $val;
}
return \%dat;
}
@@ -142,11 +148,11 @@ sub _parse_multipart {
# regular form element. The standards do not require the filename to be
# present, but I am not aware of any browser that does not send it.
if($filename) {
- push @{$nfo->{POST}{$name}}, _check_control decode_utf8 $filename, 1;
- push @{$nfo->{MIMES}{$name}}, _check_control decode_utf8 $mime, 1;
- push @{$nfo->{FILES}{$name}}, $value; # not decoded, can be binary
+ _store $nfo->{POST}{$name}, _check_control decode_utf8 $filename, 1;
+ _store $nfo->{MIMES}{$name}, _check_control decode_utf8 $mime, 1;
+ _store $nfo->{FILES}{$name}, $value; # not decoded, can be binary
} else {
- push @{$nfo->{POST}{$name}}, _check_control decode_utf8 $value, 1;
+ _store $nfo->{POST}{$name}, _check_control decode_utf8 $value, 1;
}
}
}
@@ -179,14 +185,15 @@ sub _tablegets {
my($k, $s, $n) = @_;
my $lst = $s->{_TUWF}{Req}{$k};
return keys %$lst if @_ == 2;
- return $lst->{$n} ? @{$lst->{$n}} : ();
+ my $v = $lst->{$n};
+ ref $v ? @$v : $v ? ($v) : ();
}
sub _tableget {
my($k, $s, $n) = @_;
my $v = $s->{_TUWF}{Req}{$k}{$n};
- return $v ? $v->[0] : undef;
+ ref $v ? $v->[0] : $v;
}
@@ -209,9 +216,11 @@ sub reqParams {
my %keys = map +($_,1), keys(%{$nfo->{GET}}), keys(%{$nfo->{POST}});
return keys %keys;
}
+ my $p = $nfo->{POST}{$n};
+ my $g = $nfo->{GET}{$n};
return (
- $nfo->{POST}{$n} ? @{$nfo->{POST}{$n}} : (),
- $nfo->{GET}{$n} ? @{$nfo->{GET}{$n}} : (),
+ ref $p ? @$p : $p ? ($p) : (),
+ ref $g ? @$g : $g ? ($g) : (),
);
}
@@ -220,10 +229,8 @@ sub reqParams {
sub reqParam {
my($s, $n) = @_;
my $nfo = $s->{_TUWF}{Req};
- return [
- $nfo->{POST}{$n} ? @{$nfo->{POST}{$n}} : (),
- $nfo->{GET}{$n} ? @{$nfo->{GET}{$n}} : (),
- ]->[0];
+ my $v = $nfo->{POST}{$n} || $nfo->{GET}{$n};
+ ref $v ? $v->[0] : $v;
}
diff --git a/lib/TUWF/Validate.pm b/lib/TUWF/Validate.pm
index 4c661a3..adeb1d6 100644
--- a/lib/TUWF/Validate.pm
+++ b/lib/TUWF/Validate.pm
@@ -167,6 +167,9 @@ sub _compile {
sub compile {
my($validations, $schema) = @_;
+
+ return $schema if ref $schema eq __PACKAGE__;
+
my $c = _compile $validations, $schema, 64;
$c->{schema}{type} //= 'scalar';