lib/Catalyst/Engine/HTTPEngine.pm

   1 package Catalyst::Engine::HTTPEngine;
   2
   3 # Experimental HTTP::Engine engine
   4
   5 # TODO:
   6 # * Lots of copying/reference going on between HTTP::Engine req/res and Catalyst req/res
   7 # * Body support
   8 # * Proxy checks
   9 # * Lots of test failures
  10
  11 use Moose;
  12
  13 use Data::Dump qw(dump);
  14 use HTTP::Engine;
  15 use Socket;
  16
  17 use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0;
  18
  19 sub run {
  20     my ( $self, $class, $port, $host, $options ) = @_;
  21
  22     $options ||= {};
  23
  24     $self->{appclass} = $class;
  25     $self->{options}  = $options;
  26
  27     my $addr = $host ? inet_aton($host) : INADDR_ANY;
  28     if ( $addr eq INADDR_ANY ) {
  29         require Sys::Hostname;
  30         $host = lc Sys::Hostname::hostname();
  31     }
  32     else {
  33         $host = gethostbyaddr( $addr, AF_INET ) || inet_ntoa($addr);
  34     }
  35
  36     my $engine = HTTP::Engine->new(
  37         interface => {
  38             module => 'Standalone',
  39             args   => {
  40                 host => inet_ntoa($addr),
  41                 port => $port,
  42             },
  43             request_handler => sub {
  44                 $self->handler( $_[0] );
  45             },
  46         },
  47     );
  48
  49     my $url = "http://$host";
  50     $url .= ":$port" unless $port == 80;
  51
  52     print "You can connect to your server at $url\n";
  53
  54     $engine->run;
  55 }
  56
  57 sub handler {
  58     my ( $self, $req ) = @_;
  59
  60     my $res = HTTP::Engine::Response->new;
  61
  62     # Pass control to Catalyst
  63     $self->{appclass}->handle_request(
  64         req => $req,
  65         res => $res,
  66     );
  67
  68     return $res;
  69 }
  70
  71 sub prepare_request {
  72     my ( $self, $c, %args ) = @_;
  73
  74     $c->{_ereq} = $args{req};
  75     $c->{_eres} = $args{res};
  76 }
  77
  78 sub prepare_connection {
  79     my ( $self, $c ) = @_;
  80
  81     my $ci      = $c->{_ereq}->connection_info;
  82     my $request = $c->request;
  83
  84     $request->address( $ci->{address} );
  85
  86     # XXX proxy check
  87
  88     $request->hostname( $ci->{address} );
  89     $request->protocol( $ci->{protocol} );
  90     $request->user( $ci->{user} );
  91     $request->method( $ci->{method} );
  92
  93     # XXX $request->secure
  94 }
  95
  96 sub prepare_query_parameters {
  97     my ( $self, $c ) = @_;
  98
  99     my $ereq = $c->{_ereq};
 100
 101     return unless defined $ereq->uri->query;
 102
 103     # Check for keywords (no = signs)
 104     # (yes, index() is faster than a regex :))
 105     if ( index( $ereq->uri->query, '=' ) < 0 ) {
 106         $c->request->query_keywords(
 107             $self->unescape_uri( $ereq->uri->query )
 108         );
 109         return;
 110     }
 111
 112     $c->request->query_parameters( $ereq->query_parameters );
 113 }
 114
 115 sub prepare_headers {
 116     my ( $self, $c ) = @_;
 117
 118     $c->request->headers( $c->{_ereq}->headers );
 119 }
 120
 121 sub prepare_cookies {
 122     my ( $self, $c ) = @_;
 123
 124     $c->request->cookies( $c->{_ereq}->cookies );
 125 }
 126
 127 sub prepare_path {
 128     my ( $self, $c ) = @_;
 129
 130     # XXX: proxy check
 131
 132     # XXX: cleaner way to get the main URI object?
 133     $c->request->uri( $c->{_ereq}->uri->[0] );
 134
 135     $c->request->base( $c->{_ereq}->uri->base );
 136 }
 137
 138 sub prepare_read { }
 139
 140 sub prepare_body {
 141     my ( $self, $c ) = @_;
 142
 143     if ( $c->request->content_length ) {
 144         $c->request->{_body} = $c->{_ereq}->http_body;
 145     }
 146     else {
 147         $c->request->{_body} = 0;
 148     }
 149 }
 150
 151 sub prepare_body_parameters {
 152     my ( $self, $c ) = @_;
 153
 154     return unless $c->request->{_body};
 155
 156     $c->request->body_parameters( $c->{_ereq}->body_parameters );
 157 }
 158
 159 sub prepare_parameters {
 160     my ( $self, $c ) = @_;
 161
 162     # XXX: HTTP::Engine loads HTTP::Body object when you call this,
 163     # even if no Content-Length
 164     $c->request->parameters( $c->{_ereq}->parameters );
 165 }
 166
 167 sub prepare_uploads {
 168     my ( $self, $c ) = @_;
 169
 170     return unless $c->request->{_body};
 171
 172     $c->request->uploads( $c->{_ereq}->uploads );
 173 }
 174
 175 sub finalize_uploads {
 176     my ( $self, $c ) = @_;
 177
 178     my $request = $c->request;
 179     foreach my $key (keys %{ $request->uploads }) {
 180         my $upload = $request->uploads->{$key};
 181         unlink grep { -e $_ } map { $_->tempname }
 182           (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
 183     }
 184 }
 185
 186 sub finalize_cookies {
 187     my ( $self, $c ) = @_;
 188
 189     $c->{_eres}->cookies( $c->response->cookies );
 190 }
 191
 192 sub finalize_headers {
 193     my ( $self, $c ) = @_;
 194
 195     $c->{_eres}->status( $c->response->status );
 196     $c->{_eres}->headers( $c->response->headers );
 197 }
 198
 199 sub finalize_body {
 200     my ( $self, $c ) = @_;
 201
 202     $c->{_eres}->body( $c->response->body );
 203 }
 204
 205 sub unescape_uri {
 206     my ( $self, $str ) = @_;
 207
 208     $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
 209
 210     return $str;
 211 }
 212
 213 1;