summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorYorhel <git@yorhel.nl>2018-02-05 16:59:43 +0100
committerYorhel <git@yorhel.nl>2018-02-05 16:59:45 +0100
commit39ec19f50ed1e99e7ea174bbbd7f47bda53367eb (patch)
treeb35191eedef4bdc6e443cb6355d91681791c7cd3
parent4d3c301576d41149b820821a790670abc4aba374 (diff)
Add tuwf->done and tuwf->pass, change error & before hook handling
This changes the way that before hooks signal whether to continue processing or not, and is a breaking change for code that uses before hooks with a false return value. This change does not affect the pre_request_handler, so only code using the git version of TUWF is affected. This more generic control flow handling now also permits request handlers for overlapping URL regexes, and tuwf->pass can be used to pass control to subsequent handlers.
-rw-r--r--lib/TUWF.pm149
-rw-r--r--lib/TUWF.pod68
-rw-r--r--lib/TUWF/Request.pm23
-rw-r--r--lib/TUWF/Response.pod3
4 files changed, 167 insertions, 76 deletions
diff --git a/lib/TUWF.pm b/lib/TUWF.pm
index 4d95135..1c67ab3 100644
--- a/lib/TUWF.pm
+++ b/lib/TUWF.pm
@@ -331,6 +331,9 @@ sub _handle_request {
my $start = [Time::HiRes::gettimeofday()] if $self->debug || $OBJ->{_TUWF}{log_slow_pages};
+ $self->{_TUWF}{captures_pos} = [];
+ $self->{_TUWF}{captures_named} = {};
+
# put everything in an eval to catch any error, even
# those caused by a TUWF core module
my $eval = eval {
@@ -345,15 +348,7 @@ sub _handle_request {
);
# initialize request
- my $err = $self->reqInit();
- if($err) {
- warn "Client sent non-UTF-8-encoded data. Generating HTTP 400 response.\n" if $err eq 'utf8';
- warn "Client sent an invalid JSON object. Generating HTTP 400 response.\n" if $err eq 'json';
- $self->{_TUWF}{error_400_handler}->($self) if $err eq 'utf8' || $err eq 'json';
- $self->{_TUWF}{error_405_handler}->($self) if $err eq 'method';
- $self->{_TUWF}{error_413_handler}->($self) if $err eq 'maxpost';
- return 1;
- }
+ $self->reqInit();
# make sure our DB connection is still there and start a new transaction
$self->dbCheck() if $self->{_TUWF}{db_login};
@@ -363,31 +358,40 @@ sub _handle_request {
# run 'before' hooks
for (@{$self->{_TUWF}{hooks}{before}}) {
- return 1 if !$_->();
+ my $ok = eval { $_->(); 1; };
+ next if $ok;
+ next if ref $@ eq 'TUWF::Exception' && ${$@} eq 'pass';
+ return 1 if ref $@ eq 'TUWF::Exception' && ${$@} eq 'done';
+ die $@;
}
# find the handler
my $loc = sprintf '%s %s', $self->reqMethod(), $self->reqPath();
study $loc;
- my $han = $self->{_TUWF}{error_404_handler};
- $self->{_TUWF}{captures_pos} = [];
- $self->{_TUWF}{captures_named} = {};
+ my $han = 0;
my $handlers = $self->{_TUWF}{route_handlers};
for (@$handlers ? 0..$#$handlers/2 : ()) {
if($loc =~ $handlers->[$_*2]) {
+ $han = 1;
$self->{_TUWF}{captures_pos} = [
map defined $-[$_] ? substr $loc, $-[$_], $+[$_]-$-[$_] : undef, 1..$#-
];
$self->{_TUWF}{captures_named} = { %+ };
- $han = $handlers->[$_*2+1];
- last;
+
+ my $ok = eval { $handlers->[$_*2+1]->($self); 1 };
+ last if $ok;
+ ($han = 0, next) if ref $@ eq 'TUWF::Exception' && ${$@} eq 'pass';
+ last if ref $@ eq 'TUWF::Exception' && ${$@} eq 'done';
+ die $@;
}
}
- # execute handler
- $han->($self);
+ die TUWF::Exception->new(404) if !$han;
- # execute post request handler, if any
+ # execute post request handler, if any (no need to bother doing this if the
+ # handler threw a TUWF::Exception like with the after hooks. The
+ # post_request_handler is deprecated and that mechanism didn't exist back
+ # then anyway).
$self->{_TUWF}{post_request_handler}->($self) if $self->{_TUWF}{post_request_handler};
1;
};
@@ -395,7 +399,13 @@ sub _handle_request {
# always run 'after' hooks
my $cleanup = eval {
- $_->() for (@{$self->{_TUWF}{hooks}{after}});
+ for (@{$self->{_TUWF}{hooks}{after}}) {
+ my $ok = eval { $_->(); 1 };
+ next if $ok;
+ next if ref $@ eq 'TUWF::Exception' && ${$@} eq 'pass';
+ next if ref $@ eq 'TUWF::Exception' && ${$@} eq 'done';
+ die $@;
+ }
1;
};
my $cleanuperr = $@;
@@ -410,35 +420,7 @@ sub _handle_request {
my $commiterr = $@;
# error handling
- if(!$eval || !$cleanup || !$commit) {
- chomp( my $err = $evalerr || $cleanuperr || $commiterr );
-
- # act as if the changes to the DB never happened
- warn $@ if $self->{_TUWF}{db_login} && !eval { $self->dbRollBack; 1 };
-
- # Call the error_500_handler
- # The handler should manually call dbCommit if it makes any changes to the DB
- my $eval500 = eval {
- $self->resInit;
- $self->{_TUWF}{error_500_handler}->($self, $err);
- 1;
- };
- if(!$eval500) {
- chomp( my $m = $@ );
- warn "Error handler died as well, something is seriously wrong with your code. ($m)\n";
- TUWF::_error_500($self, $err);
- }
-
- # write detailed information about this error to the log
- $self->log(
- "FATAL ERROR!\n".
- "HTTP Request Headers:\n".
- join('', map sprintf(" %s: %s\n", $_, $self->reqHeader($_)), $self->reqHeader).
- "POST dump:\n".
- join('', map sprintf(" %s: %s\n", $_, join "\n ", $self->reqPosts($_)), $self->reqPosts).
- "Error:\n $err\n"
- );
- }
+ $self->_handle_error($evalerr || $cleanuperr || $commiterr) if !$eval || !$cleanup || !$commit;
# finalize response (flush output, etc)
warn $@ if !eval { $self->resFinish; 1 };
@@ -459,6 +441,57 @@ sub _handle_request {
}
+sub _handle_error {
+ my($self, $err) = @_;
+ my $terr = ref $err eq 'TUWF::Exception' ? $$err : '';
+
+ # act as if the changes to the DB never happened
+ warn $@ if $self->{_TUWF}{db_login} && !eval { $self->dbRollBack; 1 };
+
+ warn "Client sent non-UTF-8-encoded data. Generating HTTP 400 response.\n" if $terr eq 'utf8';
+ warn "Client sent control characters in strings. Generating HTTP 400 response.\n" if $terr eq 'controlchar';
+ warn "Client sent an invalid JSON object. Generating HTTP 400 response.\n" if $terr eq 'json';
+
+ my $han = {
+ utf8 => 400,
+ json => 400,
+ controlchar => 400,
+ 404 => 404,
+ method => 405,
+ maxpost => 413,
+ }->{$terr} || '500';
+
+ my $ok = eval {
+ $self->resInit;
+ $self->{_TUWF}{"error_${han}_handler"}->($self, $err);
+ 1;
+ };
+ if(!$ok) {
+ $err = $@;
+ $ok = eval {
+ $self->resInit;
+ $self->{_TUWF}{error_500_handler}->($self, $err);
+ 1;
+ };
+ }
+ if(!$ok) {
+ $err = $@;
+ warn "Error handler died as well, something is seriously wrong with your code. ($err)\n";
+ TUWF::_error_500($self, $err);
+ }
+
+ # If this is an unexpected error, write detailed information to the log
+ $self->log(
+ "FATAL ERROR!\n".
+ "HTTP Request Headers:\n".
+ join('', map sprintf(" %s: %s\n", $_, $self->reqHeader($_)), $self->reqHeader).
+ "POST dump:\n".
+ join('', map sprintf(" %s: %s\n", $_, join "\n ", $self->reqPosts($_)), $self->reqPosts).
+ "Error:\n $err\n"
+ ) if ref $err ne 'TUWF::Exception';
+}
+
+
# convenience function
sub debug {
return shift->{_TUWF}{debug};
@@ -497,6 +530,16 @@ sub log {
}
+sub pass {
+ die TUWF::Exception->new('pass');
+}
+
+
+sub done {
+ die TUWF::Exception->new('done');
+}
+
+
# Minimal subclass of HTTP::Server::Simple with CGI environment variables.
package TUWF::http;
@@ -517,5 +560,13 @@ sub handler {
};
-1;
+
+# Objects for die() (just blessed strings)
+package TUWF::Exception;
+
+use overload '""' => sub { "TUWF::Exception: ${$_[0]}" };
+
+sub new { bless \"$_[1]", $_[0] }
+
+1;
diff --git a/lib/TUWF.pod b/lib/TUWF.pod
index 9dca171..c6b8e10 100644
--- a/lib/TUWF.pod
+++ b/lib/TUWF.pod
@@ -277,20 +277,20 @@ hooks are supported:
=item before
-Your subroutine will be called before the request handler. The subroutine
-B<must> return a true value to indicate that TUWF can continue processing the
-request as usual. If the subroutine returns false, TUWF will assume the
-subroutine has generated a response and will halt any further processing. This
-hook can be used used to initialize or reset request-specific data (such as
-authentication), or to perform some checks that should apply to every route.
+The subroutine will be called before the request handler. If this handler calls
+C<< tuwf->done >>, then TUWF will assume that the handler has generated a
+suitable response, and any subsequent I<before> handlers and request handlers
+will not be called.
This replaces the L<pre_request_handler|/pre_request_handler> setting.
=item after
Called after the request handler has run, but before the result has been sent
-to the client. This hook is always called, even if a I<before> hook has
-returned false or if a route handler threw an exception.
+to the client. This hook is B<always> called, even if a I<before> hook has
+called C<< tuwf->done >> or if a route handler threw an exception. (The only
+time an I<after> hook may not be called is when a preceding I<after> hook threw
+an exception).
This replaces the L<post_request_handler|/post_request_handler> setting.
@@ -587,15 +587,18 @@ The default MIME type for extensions not covered in L<mime_types|/mime_types>.
=item pre_request_handler
-(Deprecated) Equivalent to a I<before> hook, see
-L<TUWF::hook()|/TUWF::hook($hook, $sub)>.
+(Deprecated) Similar to a I<before> hook, see
+L<TUWF::hook()|/TUWF::hook($hook, $sub)>. Unlike the I<before> hook, this
+subroutine should not call C<< tuwf->done >> or C<< tuwf->pass >>, but instead
+return a false value to send the response and prevent further processing, or
+return a true value to continue processing further handlers.
=item post_request_handler
(Deprecated) Equivalent to an I<after> hook, see
L<TUWF::hook()|/TUWF::hook($hook, $sub)>. One notable difference is that this
-callback will B<not> run when a I<before> hook returned false or if a route
-handler threw an exception.
+callback will B<not> run when a I<before> hook or request handler threw an
+exception or called C<< tuwf->done() >>.
=item validate_templates
@@ -656,6 +659,36 @@ C<< tuwf->reqPath >>, save for the leading slash.
Returns the value of the I<debug> setting.
+=head2 done()
+
+Calling this method will immediately abort the current handler, run the
+I<after> hooks, and output the response. When called from a I<before> hook,
+this will prevent running any further I<before> hooks or request handlers.
+
+Calling this method from a request handler is equivalent to a normal return
+from the handler, but it can still be useful to force a response from a nested
+function call, e.g.:
+
+ sub require_admin {
+ if(!user_is_admin()) {
+ # Generate a friendly error page here.
+ # ...and send it to the client:
+ tuwf->done;
+ }
+ }
+
+ TUWF::get '/admin' => sub {
+ require_admin();
+ # At this point we can be sure that the user is an administrator, and
+ # continue to generate our page.
+ };
+
+Calling this method from a I<after> hook has no effect other than prematurely
+aborting that particular hook.
+
+This method calls C<die()>, so be sure to re-throw the error when run inside an
+eval block.
+
=head2 log(message)
Writes a message to the log file configured with I<logfile>. When no log file
@@ -669,7 +702,18 @@ This function is not used very often in practice, since it is easier to simply
use Perl's C<warn()> function instead. TUWF automatically writes all warnings
to the log file.
+=head2 pass()
+
+Calling this method will immediately abort the current handler and move on to
+the next handler (if any). Any side effects (e.g. setting response headers,
+generating output) will remain. If the final handler calls C<pass()>, then any
+response data is discarded and a 404 response is generated instead.
+
+Calling this method from a I<after> hook has no effect other than prematurely
+aborting that particular hook.
+This method calls C<die()>, so be sure to re-throw the error when run inside an
+eval block.
=head1 SERVER CONFIGURATION
diff --git a/lib/TUWF/Request.pm b/lib/TUWF/Request.pm
index d75a2f5..f77042c 100644
--- a/lib/TUWF/Request.pm
+++ b/lib/TUWF/Request.pm
@@ -25,29 +25,29 @@ sub reqInit {
if ($ENV{REQUEST_URI}||'') =~ /\?/;
}
- my $err = eval {
+ my $ok = eval {
$self->{_TUWF}{Req}{Cookies} = _parse_cookies($self, $ENV{HTTP_COOKIE} || $ENV{COOKIE});
$self->{_TUWF}{Req}{GET} = _parse_urlencoded($ENV{QUERY_STRING});
$self->reqPath(); # let it croak when the path isn't valid UTF-8
1;
};
- return 'utf8' if !$err && $@ && $@ =~ /does not map to Unicode/; # <- UGLY!
+ die TUWF::Exception->new('utf8') if !$ok && $@ && $@ =~ /does not map to Unicode/; # <- UGLY!
# re-throw if it wasn't a UTF-8 problem. I don't expect this to happen
- die $@ if !$err;
+ die $@ if !$ok;
my $meth = $self->reqMethod;
- return 'method' if $meth !~ /^(GET|POST|HEAD|DEL|OPTIONS|PUT|PATCH)$/;
+ die TUWF::Exception->new('method') if $meth !~ /^(GET|POST|HEAD|DEL|OPTIONS|PUT|PATCH)$/;
if($meth =~ /^(POST|PUT|PATCH)$/ && $ENV{CONTENT_LENGTH}) {
- return 'maxpost' if $self->{_TUWF}{max_post_body} && $ENV{CONTENT_LENGTH} > $self->{_TUWF}{max_post_body};
+ die TUWF::Exception->new('maxpost') if $self->{_TUWF}{max_post_body} && $ENV{CONTENT_LENGTH} > $self->{_TUWF}{max_post_body};
my $data;
die "Couldn't read all request data.\n" if $ENV{CONTENT_LENGTH} > read STDIN, $data, $ENV{CONTENT_LENGTH}, 0;
- $err = eval {
+ $ok = eval {
if(($ENV{'CONTENT_TYPE'}||'') =~ m{^application/json(?:;.*)?$}) {
$self->{_TUWF}{Req}{JSON} = _parse_json($data);
- return 'json' if !$self->{_TUWF}{Req}{JSON};
+ die TUWF::Exception->new('json') if !$self->{_TUWF}{Req}{JSON};
} elsif(($ENV{'CONTENT_TYPE'}||'') =~ m{^multipart/form-data; boundary=(.+)$}) {
_parse_multipart($self, $data, $1);
} else {
@@ -55,18 +55,15 @@ sub reqInit {
}
1;
};
- return 'utf8' if !$err && $@ && $@ =~ /does not map to Unicode/;
- die $@ if !$err;
+ die TUWF::Exception->new('utf8') if !$ok && $@ && $@ =~ /does not map to Unicode/;
+ die $@ if !$ok;
}
-
- return '';
}
sub _check_control {
# Disallow any control codes, except for x09 (tab), x0a (newline) and x0d (carriage return)
- # The error message is a hack to trigger the 'utf8' error code.
- die "Illegal control code (does not map to Unicode)" if $_[0] =~ /[\x00-\x08\x0b\x0c\x0e-\x1f]/;
+ die TUWF::Exception->new('controlchar') if $_[0] =~ /[\x00-\x08\x0b\x0c\x0e-\x1f]/;
$_[0]
}
diff --git a/lib/TUWF/Response.pod b/lib/TUWF/Response.pod
index fab404c..a6ef6ad 100644
--- a/lib/TUWF/Response.pod
+++ b/lib/TUWF/Response.pod
@@ -210,8 +210,7 @@ Examples:
# Serve a file in '/webroot/public' if it exists,
# otherwise handle the request as usual.
TUWF::hook before => sub {
- return 0 if tuwf->resFile('/webroot/public', tuwf->reqPath);
- return 1;
+ tuwf->done if tuwf->resFile('/webroot/public', tuwf->reqPath);
};
You might also want to set proper caching headers if the static files don't