From: Matt S Trout Date: Mon, 3 Oct 2011 10:37:52 +0000 (+0000) Subject: experimental upload support X-Git-Tag: v0.009~9 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=05aafc1a964aa5c2e86690602d5c49a8329fb90c;hp=2bc99ccd7582eeb2970e3779bcd2833b95646700;p=catagits%2FWeb-Simple.git experimental upload support --- diff --git a/Changes b/Changes index 0bfbf7a..f86d70c 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,6 @@ Change log for Web::Simple + - Add experimental upload support - Update Plack usage to call ::Handler:: classes not ::Server:: - Assume FastCGI mode if STDIN is a socket (works some places env vars fail) - Change CLI mode to print status line and headers to STDERR and content diff --git a/lib/Web/Dispatch/ParamParser.pm b/lib/Web/Dispatch/ParamParser.pm index f70c366..90c62b1 100644 --- a/lib/Web/Dispatch/ParamParser.pm +++ b/lib/Web/Dispatch/ParamParser.pm @@ -5,6 +5,8 @@ use warnings FATAL => 'all'; sub UNPACKED_QUERY () { __PACKAGE__.'.unpacked_query' } sub UNPACKED_BODY () { __PACKAGE__.'.unpacked_body' } +sub UNPACKED_BODY_OBJECT () { __PACKAGE__.'.unpacked_body_object' } +sub UNPACKED_UPLOADS () { __PACKAGE__.'.unpacked_uploads' } sub get_unpacked_query_from { return $_[0]->{+UNPACKED_QUERY} ||= do { @@ -14,16 +16,72 @@ sub get_unpacked_query_from { sub get_unpacked_body_from { return $_[0]->{+UNPACKED_BODY} ||= do { - if (index(lc($_[0]->{CONTENT_TYPE}||''), 'application/x-www-form-urlencoded') >= 0 - and defined $_[0]->{CONTENT_LENGTH}) { + my $ct = lc($_[0]->{CONTENT_TYPE}||''); + if (!$_[0]->{CONTENT_LENGTH}) { + {} + } elsif (index($ct, 'application/x-www-form-urlencoded') >= 0) { $_[0]->{'psgi.input'}->read(my $buf, $_[0]->{CONTENT_LENGTH}); _unpack_params($buf); + } elsif (index($ct, 'multipart/form-data') >= 0) { + my $p = get_unpacked_body_object_from($_[0])->param; + # forcible arrayification + +{ + map +(ref($p->{$_}) eq 'ARRAY' + ? ($_ => $p->{$_}) + : ($_ => [ $p->{$_} ]) + ), keys %$p + }; } else { {} } }; } +sub get_unpacked_body_object_from { + # we may have no object at all - so use a single element arrayref for ||= + return ($_[0]->{+UNPACKED_BODY_OBJECT} ||= do { + if (!$_[0]->{CONTENT_LENGTH}) { + [ undef ] + } elsif (index(lc($_[0]->{CONTENT_TYPE}||''),'multipart/form-data')==-1) { + [ undef ] + } else { + [ _make_http_body($_[0]) ] + } + })->[0]; +} + +sub get_unpacked_uploads_from { + $_[0]->{+UNPACKED_UPLOADS} ||= do { + require Web::Dispatch::Upload; require HTTP::Headers; + my ($final, $reason) = ( + {}, "field %s exists with value %s but body was not multipart/form-data" + ); + if (my $body = get_unpacked_body_object_from($_[0])) { + my $u = $body->upload; + $reason = "field %s exists with value %s but was not an upload"; + foreach my $k (keys %$u) { + foreach my $v (ref($u->{$k}) eq 'ARRAY' ? @{$u->{$k}} : $u->{$k}) { + push(@{$final->{$k}||=[]}, Web::Dispatch::Upload->new( + %{$v}, + headers => HTTP::Headers->new($v->{headers}) + )); + } + } + } + my $b = get_unpacked_body_from($_[0]); + foreach my $k (keys %$b) { + next if $final->{$k}; + foreach my $v (@{$b->{$k}}) { + next unless $v; + push(@{$final->{$k}||=[]}, Web::Dispatch::NotAnUpload->new( + filename => $v, + reason => sprintf($reason, $k, $v) + )); + } + } + $final; + }; +} { # shamelessly stolen from HTTP::Body::UrlEncoded by Christian Hansen @@ -52,4 +110,39 @@ sub get_unpacked_body_from { } } +{ + # shamelessly stolen from Plack::Request by miyagawa + + sub _make_http_body { + + # Can't actually do this yet, since Plack::Request deletes the + # header structure out of the uploads in its copy of the body. + # I suspect I need to supply miyagawa with a failing test. + + #if (my $plack_body = $_[0]->{'plack.request.http.body'}) { + # # Plack already constructed one; probably wasteful to do it again + # return $plack_body; + #} + + require HTTP::Body; + my $body = HTTP::Body->new(@{$_[0]}{qw(CONTENT_TYPE CONTENT_LENGTH)}); + $body->cleanup(1); + my $spin = 0; + my $input = $_[0]->{'psgi.input'}; + my $cl = $_[0]->{CONTENT_LENGTH}; + while ($cl) { + $input->read(my $chunk, $cl < 8192 ? $cl : 8192); + my $read = length $chunk; + $cl -= $read; + $body->add($chunk); + + if ($read == 0 && $spin++ > 2000) { + require Carp; + Carp::croak("Bad Content-Length: maybe client disconnect? ($cl bytes remaining)"); + } + } + return $body; + } +} + 1; diff --git a/lib/Web/Dispatch/Parser.pm b/lib/Web/Dispatch/Parser.pm index a6b2332..8e66a05 100644 --- a/lib/Web/Dispatch/Parser.pm +++ b/lib/Web/Dispatch/Parser.pm @@ -115,6 +115,10 @@ sub _parse_spec_section { # % /\G\%/gc and return $self->_parse_param_handler($_, 'body'); + + # * + /\G\*/gc and + return $self->_parse_param_handler($_, 'uploads'); } return; # () will trigger the blam in our caller } diff --git a/lib/Web/Dispatch/Predicates.pm b/lib/Web/Dispatch/Predicates.pm index 758afed..db2ad88 100644 --- a/lib/Web/Dispatch/Predicates.pm +++ b/lib/Web/Dispatch/Predicates.pm @@ -5,7 +5,7 @@ use base qw(Exporter); our @EXPORT = qw( match_and match_or match_not match_method match_path match_path_strip - match_extension match_query match_body + match_extension match_query match_body match_uploads ); sub match_and { @@ -102,24 +102,23 @@ sub match_extension { } sub match_query { - my $spec = shift; - require Web::Dispatch::ParamParser; - sub { - _extract_params( - Web::Dispatch::ParamParser::get_unpacked_query_from($_[0]), - $spec - ) - }; + _param_matcher(query => $_[0]); } sub match_body { - my $spec = shift; + _param_matcher(body => $_[0]); +} + +sub match_uploads { + _param_matcher(uploads => $_[0]); +} + +sub _param_matcher { + my ($type, $spec) = @_; require Web::Dispatch::ParamParser; + my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from"); sub { - _extract_params( - Web::Dispatch::ParamParser::get_unpacked_body_from($_[0]), - $spec - ) + _extract_params($unpack->($_[0]), $spec) }; } diff --git a/lib/Web/Dispatch/Upload.pm b/lib/Web/Dispatch/Upload.pm new file mode 100644 index 0000000..8e5fdc6 --- /dev/null +++ b/lib/Web/Dispatch/Upload.pm @@ -0,0 +1,44 @@ +use strictures 1; + +{ + package Web::Dispatch::Upload; + use base qw(Plack::Request::Upload); + use overload '""' => 'tempname', fallback => 1; + + sub is_upload { 1 } + + sub reason { '' } +} + +{ + package Web::Dispatch::NotAnUpload; + + use overload '""' => '_explode', fallback => 1; + + sub new { + my ($class, %args) = @_; + bless { + filename => $args{filename}, + reason => $args{reason} + }, $class; + } + + sub is_upload { 0 } + + sub reason { $_[0]->{reason} } + + sub _explode { + die "Not actually an upload: ".$_[0]->{reason} + } + + sub filename { $_[0]->_explode } + sub headers { $_[0]->_explode } + sub size { $_[0]->_explode } + sub tempname { $_[0]->_explode } + sub path { $_[0]->_explode } + sub content_type { $_[0]->_explode } + sub type { $_[0]->_explode } + sub basename { $_[0]->_explode } +} + +1; diff --git a/lib/Web/Simple.pm b/lib/Web/Simple.pm index 31fa56a..891e115 100644 --- a/lib/Web/Simple.pm +++ b/lib/Web/Simple.pm @@ -34,19 +34,6 @@ sub _export_into { Web::Simple - A quick and easy way to build simple web applications -=head1 WARNING - -This is really quite new. If you're reading this on CPAN, it means the stuff -that's here we're probably happy with. But only probably. So we may have to -change stuff. And if you're reading this from git, come check with irc.perl.org -#web-simple that we're actually sure we're going to keep anything that's -different from the CPAN version. - -If we do find we have to change stuff we'll add to the -L section explaining how to switch your code across -to the new version, and we'll do our best to make it as painless as possible -because we've got Web::Simple applications too. But we can't promise not to -change things at all. Not yet. Sorry. =head1 SYNOPSIS @@ -441,6 +428,36 @@ hashref style, the arrayref and single parameters will appear in C<@_> in the order you defined them in the protoype, but all hashrefs will merge into a single C<$params>, as in the example above. +=head3 Upload matches (EXPERIMENTAL) + +Note: This feature is experimental. This means that it may not remain +100% in its current form. If we change it, notes on updating your code +will be added to the L section below. + + sub (*foo=) { # param specifier can be anything valid for query or body + +The upload match system functions exactly like a query/body match, except +that the values returned (if any) are C objects. + +Note that this match type will succeed in two circumstances where you might +not expect it to - first, when the field exists but is not an upload field +and second, when the field exists but the form is not an upload form (i.e. +content type "application/x-www-form-urlencoded" rather than +"multipart/form-data"). In either of these cases, what you'll get back is +a C object, which will C with an error +pointing out the problem if you try and use it. To be sure you have a real +upload object, call + + $upload->is_upload # returns 1 on a valid upload, 0 on a non-upload field + +and to get the reason why such an object is not an upload, call + + $upload->reason # returns a reason or '' on a valid upload. + +Other than these two methods, the upload object provides the same interface +as L with the addition of a stringify to the temporary +filename to make copying it somewhere else easier to handle. + =head3 Combining matches Matches may be combined with the + character - e.g. diff --git a/t/post.t b/t/post.t index f7d8d80..c908256 100644 --- a/t/post.t +++ b/t/post.t @@ -1,11 +1,7 @@ use strict; use warnings FATAL => 'all'; -use Test::More ( - eval { require HTTP::Request::AsCGI } - ? 'no_plan' - : (skip_all => 'No HTTP::Request::AsCGI') -); +use Test::More qw(no_plan); { use Web::Simple 'PostTest'; @@ -18,19 +14,25 @@ use Test::More ( [ join(' ',@{$_[1]}{qw(foo bar)}) ] ] }, + sub (*baz=) { + [ 200, + [ "Content-type" => "text/plain" ], + [ $_[1]->reason || $_[1]->filename ], + ] + }, } } +use Plack::Test; use HTTP::Request::Common qw(GET POST); my $app = PostTest->new; sub run_request { my $request = shift; - my $c = HTTP::Request::AsCGI->new($request)->setup; - $app->run; - $c->restore; - return $c->response; + my $response; + test_psgi($app->to_psgi_app, sub { $response = shift->($request) }); + return $response; } my $get = run_request(GET 'http://localhost/'); @@ -58,3 +60,56 @@ my $both = run_request( cmp_ok($both->code, '==', 200, '200 with both params'); is($both->content, 'FOO BAR', 'both params returned'); + +my $upload = run_request( + POST 'http://localhost' + => Content_Type => 'form-data' + => Content => [ + foo => 'FOO', + bar => 'BAR' + ] +); + +cmp_ok($upload->code, '==', 200, '200 with multipart'); + +is($upload->content, 'FOO BAR', 'both params returned'); + +my $upload_wrongtype = run_request( + POST 'http://localhost' + => [ baz => 'fleem' ] +); + +is( + $upload_wrongtype->content, + 'field baz exists with value fleem but body was not multipart/form-data', + 'error points out wrong body type' +); + +my $upload_notupload = run_request( + POST 'http://localhost' + => Content_Type => 'form-data' + => Content => [ baz => 'fleem' ] +); + +is( + $upload_notupload->content, + 'field baz exists with value fleem but was not an upload', + 'error points out field was not an upload' +); + +my $upload_isupload = run_request( + POST 'http://localhost' + => Content_Type => 'form-data' + => Content => [ + baz => [ + undef, 'TESTFILE', + Content => 'test content', 'Content-Type' => 'text/plain' + ], + ] +); + +is( + $upload_isupload->content, + 'TESTFILE', + 'Actual upload returns filename ok' +);