From 39ec19f50ed1e99e7ea174bbbd7f47bda53367eb Mon Sep 17 00:00:00 2001 From: Yorhel Date: Mon, 5 Feb 2018 16:59:43 +0100 Subject: 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. --- lib/TUWF.pm | 149 +++++++++++++++++++++++++++++++++----------------- lib/TUWF.pod | 68 +++++++++++++++++++---- lib/TUWF/Request.pm | 23 ++++---- lib/TUWF/Response.pod | 3 +- 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 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 handlers and request handlers +will not be called. This replaces the L 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 hook has -returned false or if a route handler threw an exception. +to the client. This hook is B called, even if a I hook has +called C<< tuwf->done >> or if a route handler threw an exception. (The only +time an I hook may not be called is when a preceding I hook threw +an exception). This replaces the L setting. @@ -587,15 +587,18 @@ The default MIME type for extensions not covered in L. =item pre_request_handler -(Deprecated) Equivalent to a I hook, see -L. +(Deprecated) Similar to a I hook, see +L. Unlike the I 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 hook, see L. One notable difference is that this -callback will B run when a I hook returned false or if a route -handler threw an exception. +callback will B run when a I 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 setting. +=head2 done() + +Calling this method will immediately abort the current handler, run the +I hooks, and output the response. When called from a I hook, +this will prevent running any further I 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 hook has no effect other than prematurely +aborting that particular hook. + +This method calls C, 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. 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 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, then any +response data is discarded and a 404 response is generated instead. + +Calling this method from a I hook has no effect other than prematurely +aborting that particular hook. +This method calls C, 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 -- cgit v1.2.3