implement some more stuff

mostly copied from Plack::Request

still need to do the body content handling

1 files changed, 85 insertions, 10 deletions

diff --git a/lib/Web/Request.pm b/lib/Web/Request.pm
index 13751c4..cecda74 100644
--- a/lib/Web/Request.pm
+++ b/lib/Web/Request.pm
@@ -2,8 +2,11 @@ package Web::Request;
 use Moose;
 
 use Encode ();
-use HTTP::Headers;
-use URI;
+use List::MoreUtils ();
+use HTTP::Headers ();
+use HTTP::Message::PSGI ();
+use URI ();
+use URI::Escape ();
 
 has env => (
     traits  => ['Hash'],
@@ -33,12 +36,63 @@ has env => (
     },
 );
 
+has _uri_base => (
+    is      => 'ro',
+    isa     => 'Str',
+    lazy    => 1,
+    default => sub {
+        my $self = shift;
+
+        my $env = $self->env;
+
+        my $scheme = $self->scheme || "http";
+        my $server = $env->{HTTP_HOST};
+        $server = ($env->{SERVER_NAME} || '') . ':'
+                . ($env->{SERVER_PORT} || 80)
+            unless defined $server;
+        my $path = $self->script_name || '/';
+
+        return "${scheme}://${server}${path}";
+    },
+);
+
+has uri_base => (
+    is      => 'ro',
+    isa     => 'URI',
+    lazy    => 1,
+    default => sub { URI->new(shift->_uri_base)->canonical },
+);
+
 has uri => (
     is      => 'ro',
     isa     => 'URI',
     lazy    => 1,
     default => sub {
-        ...
+        my $self = shift;
+
+        my $base = $self->_uri_base;
+
+        # We have to escape back PATH_INFO in case they include stuff
+        # like ? or # so that the URI parser won't be tricked. However
+        # we should preserve '/' since encoding them into %2f doesn't
+        # make sense. This means when a request like /foo%2fbar comes
+        # in, we recognize it as /foo/bar which is not ideal, but that's
+        # how the PSGI PATH_INFO spec goes and we can't do anything
+        # about it. See PSGI::FAQ for details.
+        # http://github.com/miyagawa/Plack/issues#issue/118
+        my $path_escape_class = '^A-Za-z0-9\-\._~/';
+
+        my $path = URI::Escape::uri_escape(
+            $self->path_info || '',
+            $path_escape_class
+        );
+        $path .= '?' . $self->env->{QUERY_STRING}
+            if defined $self->env->{QUERY_STRING}
+            && $self->env->{QUERY_STRING} ne '';
+
+        $base =~ s!/$!! if $path =~ m!^/!;
+
+        return URI->new($base . $path)->canonical;
     },
 );
 
@@ -47,7 +101,16 @@ has headers => (
     isa     => 'HTTP::Headers',
     lazy    => 1,
     default => sub {
-        ...
+        my $self = shift;
+        my $env = $self->env;
+        return HTTP::Headers->new(
+            map {
+                (my $field = $_) =~ s/^HTTPS?_//;
+                $field => $env->{$_}
+            } grep {
+                /^(?:HTTP|CONTENT)/i
+            } keys %$env
+        );
     },
     handles => ['header', 'content_encoding', 'referer', 'user_agent'],
 );
@@ -57,7 +120,21 @@ has cookies => (
     isa     => 'HashRef',
     lazy    => 1,
     default => sub {
-        ...
+        my $self = shift;
+
+        my $cookie_str = $self->env->{HTTP_COOKIE};
+        return {} unless defined $cookie_str;
+
+        my %results;
+        for my $pair (grep { /=/ } split /[;,] ?/, $cookie_str) {
+            $pair =~ s/^\s+|\s+$//g;
+            my ($key, $value) = map {
+                URI::Escape::uri_unescape($_)
+            } split(/=/, $pair, 2);
+            $results{$key} = $value unless exists $results{$key};
+        }
+
+        return \%results;
     },
 );
 
@@ -92,7 +169,7 @@ has all_query_parameters => (
         my $self = shift;
 
         my @params = $self->uri->query_form;
-        my $it = natatime 2, @params;
+        my $it = List::MoreUtils::natatime 2, @params;
         my $ret = {};
 
         while (my ($k, $v) = $it->()) {
@@ -155,7 +232,7 @@ sub new_from_request {
     my $class = shift;
     my ($req) = @_;
 
-    return $class->new_from_env(req_to_psgi($req));
+    return $class->new_from_env(HTTP::Message::PSGI::req_to_psgi($req));
 }
 
 sub response_class { 'Web::Response' }
@@ -169,9 +246,7 @@ sub path {
     return '/';
 }
 
-sub uri_base {
-    ...
-}
+sub uri_base { URI->new(shift->_uri_base)->canonical; }
 
 sub new_response {
     my $self = shift;