PageRenderTime 74ms CodeModel.GetById 8ms app.highlight 61ms RepoModel.GetById 1ms app.codeStats 0ms

/lib/HTTP/Engine/Request.pm

http://github.com/http-engine/HTTP-Engine
Perl | 626 lines | 461 code | 153 blank | 12 comment | 46 complexity | 816d20c022c9d992b830f2762572b23b MD5 | raw file
  1package HTTP::Engine::Request;
  2use Any::Moose;
  3use HTTP::Headers::Fast;
  4use HTTP::Engine::Types::Core qw( Uri Header );
  5use URI::QueryParam;
  6require Carp; # Carp->import is too heavy =(
  7
  8# Mouse, Moose role merging is borked with attributes
  9#with qw(HTTP::Engine::Request);
 10
 11# this object constructs all our lazy fields for us
 12has request_builder => (
 13    does     => "HTTP::Engine::Role::RequestBuilder",
 14    is       => "rw",
 15    required => 1,
 16);
 17
 18sub BUILD {
 19    my ( $self, $param ) = @_;
 20
 21    foreach my $field (qw/base path/) {
 22        if ( my $val = $param->{$field} ) {
 23            $self->$field($val);
 24        }
 25    }
 26}
 27
 28has _connection => (
 29    is => "ro",
 30    isa => 'HashRef',
 31    required => 1,
 32);
 33
 34has "_read_state" => (
 35    is => "rw",
 36    lazy_build => 1,
 37);
 38
 39sub _build__read_state {
 40    my $self = shift;
 41    $self->request_builder->_build_read_state($self);
 42}
 43
 44has connection_info => (
 45    is => "rw",
 46    isa => "HashRef",
 47    lazy_build => 1,
 48);
 49
 50sub _build_connection_info {
 51    my $self = shift;
 52    $self->request_builder->_build_connection_info($self);
 53}
 54
 55has cookies => (
 56    is      => 'rw',
 57    isa     => 'HashRef',
 58    lazy_build => 1,
 59);
 60
 61sub _build_cookies {
 62    my $self = shift;
 63    $self->request_builder->_build_cookies($self);
 64}
 65
 66foreach my $attr (qw/address method protocol user port _https_info request_uri/) {
 67    has $attr => (
 68        is => 'rw',
 69        # isa => "Str",
 70        lazy => 1,
 71        default => sub { shift->connection_info->{$attr} },
 72    );
 73}
 74has query_parameters => (
 75    is      => 'rw',
 76    isa     => 'HashRef',
 77    lazy_build => 1,
 78);
 79
 80sub _build_query_parameters {
 81    my $self = shift;
 82    $self->uri->query_form_hash;
 83}
 84
 85# https or not?
 86has secure => (
 87    is      => 'rw',
 88    isa     => 'Bool',
 89    lazy_build => 1,
 90);
 91
 92sub _build_secure {
 93    my $self = shift;
 94
 95    if ( my $https = $self->_https_info ) {
 96        return 1 if uc($https) eq 'ON';
 97    }
 98
 99    if ( my $port = $self->port ) {
100        return 1 if $port == 443;
101    }
102
103    return 0;
104}
105
106# proxy request?
107has proxy_request => (
108    is         => 'rw',
109    isa        => 'Str', # TODO: union(Uri, Undef) type
110#    coerce     => 1,
111    lazy_build => 1,
112);
113
114sub _build_proxy_request {
115    my $self = shift;
116    return '' unless $self->request_uri;                   # TODO: return undef
117    return '' unless $self->request_uri =~ m!^https?://!i; # TODO: return undef
118    return $self->request_uri;                             # TODO: return URI->new($self->request_uri);
119}
120
121has uri => (
122    is     => 'rw',
123    isa => Uri,
124    coerce => 1,
125    lazy_build => 1,
126    handles => [qw(base path)],
127);
128
129sub _build_uri {
130    my $self = shift;
131    $self->request_builder->_build_uri($self);
132}
133
134has builder_options => (
135    is      => 'rw',
136    isa     => 'HashRef',
137    default => sub {
138        +{
139            disable_raw_body => 0,
140            upload_tmp       => undef,
141        },
142    },
143);
144
145has raw_body => (
146    is      => 'rw',
147    isa     => 'Str',
148    lazy_build => 1,
149);
150
151sub _build_raw_body {
152    my $self = shift;
153    $self->request_builder->_build_raw_body($self);
154}
155
156has headers => (
157    is      => 'rw',
158    isa => Header,
159    coerce  => 1,
160    lazy_build => 1,
161    handles => [ qw(content_encoding content_length content_type header referer user_agent) ],
162);
163
164sub _build_headers {
165    my $self = shift;
166    $self->request_builder->_build_headers($self);
167}
168
169# Contains the URI base. This will always have a trailing slash.
170# If your application was queried with the URI C<http://localhost:3000/some/path> then C<base> is C<http://localhost:3000/>.
171
172has hostname => (
173    is      => 'rw',
174    isa     => 'Str',
175    lazy_build => 1,
176);
177
178sub _build_hostname {
179    my $self = shift;
180    $self->request_builder->_build_hostname($self);
181}
182
183has http_body => (
184    is         => 'rw',
185    isa        => 'HTTP::Body',
186    lazy_build => 1,
187    handles => {
188        body_parameters => 'param',
189        body            => 'body',
190    },
191);
192
193sub _build_http_body {
194    my $self = shift;
195    $self->request_builder->_build_http_body($self);
196}
197
198# contains body_params and query_params
199has parameters => (
200    is      => 'rw',
201    isa     => 'HashRef',
202    lazy_build => 1,
203);
204
205sub _build_parameters {
206    my $self = shift;
207
208    my $query = $self->query_parameters;
209    my $body = $self->body_parameters;
210
211    my %merged;
212
213    foreach my $hash ( $query, $body ) {
214        foreach my $name ( keys %$hash ) {
215            my $param = $hash->{$name};
216            push( @{ $merged{$name} ||= [] }, ( ref $param ? @$param : $param ) );
217        }
218    }
219
220    foreach my $param ( values %merged ) {
221        $param = $param->[0] if @$param == 1;
222    }
223
224    return \%merged;
225}
226
227has uploads => (
228    is      => 'rw',
229    isa     => 'HashRef',
230    lazy_build => 1,
231);
232
233sub _build_uploads {
234    my $self = shift;
235    $self->request_builder->_prepare_uploads($self);
236}
237
238# aliases
239*body_params  = \&body_parameters;
240*input        = \&body;
241*params       = \&parameters;
242*query_params = \&query_parameters;
243*path_info    = \&path;
244
245sub cookie {
246    my $self = shift;
247
248    return keys %{ $self->cookies } if @_ == 0;
249
250    if (@_ == 1) {
251        my $name = shift;
252        return undef unless exists $self->cookies->{$name}; ## no critic.
253        return $self->cookies->{$name};
254    }
255    return;
256}
257
258sub param {
259    my $self = shift;
260
261    return keys %{ $self->parameters } if @_ == 0;
262
263    if (@_ == 1) {
264        my $param = shift;
265        return wantarray ? () : undef unless exists $self->parameters->{$param};
266
267        if ( ref $self->parameters->{$param} eq 'ARRAY' ) {
268            return (wantarray)
269              ? @{ $self->parameters->{$param} }
270                  : $self->parameters->{$param}->[0];
271        } else {
272            return (wantarray)
273              ? ( $self->parameters->{$param} )
274                  : $self->parameters->{$param};
275        }
276    } else {
277        my $field = shift;
278        $self->parameters->{$field} = [@_];
279    }
280}
281
282sub upload {
283    my $self = shift;
284
285    return keys %{ $self->uploads } if @_ == 0;
286
287    if (@_ == 1) {
288        my $upload = shift;
289        return wantarray ? () : undef unless exists $self->uploads->{$upload};
290
291        if (ref $self->uploads->{$upload} eq 'ARRAY') {
292            return (wantarray)
293              ? @{ $self->uploads->{$upload} }
294          : $self->uploads->{$upload}->[0];
295        } else {
296            return (wantarray)
297              ? ( $self->uploads->{$upload} )
298          : $self->uploads->{$upload};
299        }
300    } else {
301        while ( my($field, $upload) = splice(@_, 0, 2) ) {
302            if ( exists $self->uploads->{$field} ) {
303                for ( $self->uploads->{$field} ) {
304                    $_ = [$_] unless ref($_) eq "ARRAY";
305                    push(@{ $_ }, $upload);
306                }
307            } else {
308                $self->uploads->{$field} = $upload;
309            }
310        }
311    }
312}
313
314sub uri_with {
315    my($self, $args) = @_;
316    
317    Carp::carp( 'No arguments passed to uri_with()' ) unless $args;
318
319    for my $value (values %{ $args }) {
320        next unless defined $value;
321        for ( ref $value eq 'ARRAY' ? @{ $value } : $value ) {
322            $_ = "$_";
323            utf8::encode( $_ );
324        }
325    };
326    
327    my $uri = $self->uri->clone;
328    
329    $uri->query_form( {
330        %{ $uri->query_form_hash },
331        %{ $args },
332    } );
333    return $uri;
334}
335
336sub as_http_request {
337    my $self = shift;
338    require 'HTTP/Request.pm'; ## no critic
339    HTTP::Request->new( $self->method, $self->uri, $self->headers, $self->raw_body );
340}
341
342sub absolute_url {
343    my ($self, $location) = @_;
344
345    unless ($location =~ m!^https?://!) {
346        return URI->new( $location )->abs( $self->base );
347    } else {
348        return $location;
349    }
350}
351
352sub content {
353    my ( $self, @args ) = @_;
354
355    if ( @args ) {
356        Carp::croak "The HTTP::Request method 'content' is unsupported when used as a writer, use HTTP::Engine::RequestBuilder";
357    } else {
358        return $self->raw_body;
359    }
360}
361
362sub as_string {
363    my $self = shift;
364    $self->as_http_request->as_string; # FIXME not efficient
365}
366
367sub parse {
368    Carp::croak "The HTTP::Request method 'parse' is unsupported, use HTTP::Engine::RequestBuilder";
369}
370
371no Any::Moose;
372__PACKAGE__->meta->make_immutable(inline_destructor => 1);
3731;
374__END__
375
376=for stopwords Stringifies URI http https param CGI.pm-compatible referer uri IP hostname API enviroments
377
378=head1 NAME
379
380HTTP::Engine::Request - Portable HTTP request object
381
382=head1 SYNOPSIS
383
384    # normally a request object is passed into your handler
385    sub handle_request {
386        my $req = shift;
387
388   };
389
390=head1 DESCRIPTION
391
392L<HTTP::Engine::Request> provides a consistent API for request objects across web
393server enviroments. 
394
395=head1 METHODS
396
397=head2 new
398
399    HTTP::Engine::Request->new(
400        request_builder => $BUILDER,
401        _connection => {
402            env           => \%ENV,
403            input_handle  => \*STDIN,
404            output_handle => \*STDOUT,
405        },
406        %args
407    );
408
409Normally, new() is not called directly, but a pre-built HTTP::Engine::Request
410object is passed for you into your request handler. You may build your own,
411following the example above. The C<$BUILDER> may be one of
412L<HTTP::Engine::RequestBuilder::CGI> or L<HTTP::Engine::RequestBuilder::NoEnv>.
413
414=head1 ATTRIBUTES
415
416=over 4
417
418=item builder_options
419
420configuration for control of HTTP::Engine::RequestBuilder.
421
422=over 4
423
424=item disable_raw_body
425
426$req->raw_body is not saved.
427
428When receiving upload of a big file, it uses in order to prevent raw_body becoming large.
429
430raw_body is enabled by the default. because of back compatibility.
431
432  $req->upload('file1');
433  is $req->raw_body, '...some contents...';
434
435  $req->builder_options->{disable_raw_body} = 1;
436  $req->upload('file2');
437  is $req->raw_body, '';
438
439  $req->builder_options->{disable_raw_body} = 0;
440  $req->upload('file1');
441  is $req->raw_body, '...some contents...';
442
443=item upload_tmp
444
445change temporarily directory to store upload file.
446It changes of default temporarily directory by L<HTTP::Body>.
447
448generally use L<File::Temp>.
449
450  $req->builder_options->{upload_tmp} = File::Temp->newdir;
451
452for lazy make directory
453
454  $req->builder_options->{upload_tmp} = sub { File::Temp->newdir };
455
456In these examples, if request processing finishes, upload files will be deleted.
457
458=back
459
460=item address
461
462Returns the IP address of the client.
463
464=item cookies
465
466Returns a reference to a hash containing the cookies
467
468=item method
469
470Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
471
472=item protocol
473
474Returns the protocol (HTTP/1.0 or HTTP/1.1) used for the current request.
475
476=item request_uri
477
478Returns the request uri (like $ENV{REQUEST_URI})
479
480=item query_parameters
481
482Returns a reference to a hash containing query string (GET) parameters. Values can                                                    
483be either a scalar or an arrayref containing scalars.
484
485=item secure
486
487Returns true or false, indicating whether the connection is secure (https).
488
489=item proxy_request
490
491Returns undef or uri, if it is proxy request, uri of a connection place is returned.
492
493=item uri
494
495Returns a URI object for the current request. Stringifies to the URI text.
496
497=item user
498
499Returns REMOTE_USER.
500
501=item raw_body
502
503Returns string containing body(POST).
504
505=item headers
506
507Returns an L<HTTP::Headers> object containing the headers for the current request.
508
509=item base
510
511Contains the URI base. This will always have a trailing slash.
512
513=item hostname
514
515Returns the hostname of the client.
516
517=item http_body
518
519Returns an L<HTTP::Body> object.
520
521=item parameters
522
523Returns a reference to a hash containing GET and POST parameters. Values can
524be either a scalar or an arrayref containing scalars.
525
526=item uploads
527
528Returns a reference to a hash containing uploads. Values can be either a
529L<HTTP::Engine::Request::Upload> object, or an arrayref of
530L<HTTP::Engine::Request::Upload> objects.
531
532=item content_encoding
533
534Shortcut to $req->headers->content_encoding.
535
536=item content_length
537
538Shortcut to $req->headers->content_length.
539
540=item content_type
541
542Shortcut to $req->headers->content_type.
543
544=item header
545
546Shortcut to $req->headers->header.
547
548=item referer
549
550Shortcut to $req->headers->referer.
551
552=item user_agent
553
554Shortcut to $req->headers->user_agent.
555
556=item cookie
557
558A convenient method to access $req->cookies.
559
560    $cookie  = $req->cookie('name');
561    @cookies = $req->cookie;
562
563=item param
564
565Returns GET and POST parameters with a CGI.pm-compatible param method. This 
566is an alternative method for accessing parameters in $req->parameters.
567
568    $value  = $req->param( 'foo' );
569    @values = $req->param( 'foo' );
570    @params = $req->param;
571
572Like L<CGI>, and B<unlike> earlier versions of Catalyst, passing multiple
573arguments to this method, like this:
574
575    $req->param( 'foo', 'bar', 'gorch', 'quxx' );
576
577will set the parameter C<foo> to the multiple values C<bar>, C<gorch> and
578C<quxx>. Previously this would have added C<bar> as another value to C<foo>
579(creating it if it didn't exist before), and C<quxx> as another value for
580C<gorch>.
581
582=item path
583
584Returns the path, i.e. the part of the URI after $req->base, for the current request.
585
586=item upload
587
588A convenient method to access $req->uploads.
589
590    $upload  = $req->upload('field');
591    @uploads = $req->upload('field');
592    @fields  = $req->upload;
593
594    for my $upload ( $req->upload('field') ) {
595        print $upload->filename;
596    }
597
598
599=item uri_with
600
601Returns a rewritten URI object for the current request. Key/value pairs
602passed in will override existing parameters. Unmodified pairs will be
603preserved.
604
605=item as_http_request
606
607convert HTTP::Engine::Request to HTTP::Request.
608
609=item $req->absolute_url($location)
610
611convert $location to absolute uri.
612
613=back
614
615=head1 AUTHORS
616
617Kazuhiro Osawa and HTTP::Engine Authors.
618
619=head1 THANKS TO
620
621L<Catalyst::Request>
622
623=head1 SEE ALSO
624
625L<HTTP::Request>, L<Catalyst::Request>
626