Commit | Line | Data |
919492ab |
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; |