ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-HTTP/HTTP.pm
(Generate patch)

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.6 by root, Wed Jun 4 12:05:45 2008 UTC vs.
Revision 1.10 by root, Thu Jun 5 13:06:43 2008 UTC

… …
59Executes an HTTP-HEAD request. See the http_request function for details on 59Executes an HTTP-HEAD request. See the http_request function for details on
60additional parameters. 60additional parameters.
61 61
62=item http_post $url, $body, key => value..., $cb->($data, $headers) 62=item http_post $url, $body, key => value..., $cb->($data, $headers)
63 63
64Executes an HTTP-POST request with a requets body of C<$bod>. See the 64Executes an HTTP-POST request with a request body of C<$bod>. See the
65http_request function for details on additional parameters. 65http_request function for details on additional parameters.
66 66
67=item http_request $method => $url, key => value..., $cb->($data, $headers) 67=item http_request $method => $url, key => value..., $cb->($data, $headers)
68 68
69Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL 69Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
… …
71 71
72The callback will be called with the response data as first argument 72The callback will be called with the response data as first argument
73(or C<undef> if it wasn't available due to errors), and a hash-ref with 73(or C<undef> if it wasn't available due to errors), and a hash-ref with
74response headers as second argument. 74response headers as second argument.
75 75
76All the headers in that has are lowercased. In addition to the response 76All the headers in that hash are lowercased. In addition to the response
77headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and 77headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and
78C<Reason> contain the three parts of the HTTP Status-Line of the same 78C<Reason> contain the three parts of the HTTP Status-Line of the same
79name. 79name. If the server sends a header multiple lines, then their contents
80will be joined together with C<\x00>.
80 81
81If an internal error occurs, such as not being able to resolve a hostname, 82If an internal error occurs, such as not being able to resolve a hostname,
82then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599> 83then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599>
83and the C<Reason> pseudo-header will contain an error message. 84and the C<Reason> pseudo-header will contain an error message.
84 85
… …
124=item body => $string 125=item body => $string
125 126
126The request body, usually empty. Will be-sent as-is (future versions of 127The request body, usually empty. Will be-sent as-is (future versions of
127this module might offer more options). 128this module might offer more options).
128 129
130=item cookie_jar => $hash_ref
131
132Passing this parameter enables (simplified) cookie-processing, loosely
133based on the original netscape specification.
134
135The C<$hash_ref> must be an (initially empty) hash reference which will
136get updated automatically. It is possible to save the cookie_jar to
137persistent storage with something like JSON or Storable, but this is not
138recommended, as expire times are currently being ignored.
139
140Note that this cookie implementation is not of very high quality, nor
141meant to be complete. If you want complete cookie management you have to
142do that on your own. C<cookie_jar> is meant as a quick fix to get some
143cookie-using sites working. Cookies are a privacy disaster, do not use
144them unless required to.
145
129=back 146=back
130 147
131=back 148Example: make a simple HTTP GET request for http://www.nethype.de/
149
150 http_request GET => "http://www.nethype.de/", sub {
151 my ($body, $hdr) = @_;
152 print "$body\n";
153 };
154
155Example: make a HTTP HEAD request on https://www.google.com/, use a
156timeout of 30 seconds.
157
158 http_request
159 GET => "https://www.google.com",
160 timeout => 30,
161 sub {
162 my ($body, $hdr) = @_;
163 use Data::Dumper;
164 print Dumper $hdr;
165 }
166 ;
132 167
133=cut 168=cut
134 169
135sub http_request($$$;@) { 170sub http_request($$$;@) {
136 my $cb = pop; 171 my $cb = pop;
… …
138 173
139 my %hdr; 174 my %hdr;
140 175
141 $method = uc $method; 176 $method = uc $method;
142 177
143 if (my $hdr = delete $arg{headers}) { 178 if (my $hdr = $arg{headers}) {
144 while (my ($k, $v) = each %$hdr) { 179 while (my ($k, $v) = each %$hdr) {
145 $hdr{lc $k} = $v; 180 $hdr{lc $k} = $v;
146 } 181 }
147 } 182 }
148 183
184 my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE;
185
186 return $cb->(undef, { Status => 599, Reason => "recursion limit reached" })
187 if $recurse < 0;
188
149 my $proxy = $arg{proxy} || $PROXY; 189 my $proxy = $arg{proxy} || $PROXY;
150 my $timeout = $arg{timeout} || $TIMEOUT; 190 my $timeout = $arg{timeout} || $TIMEOUT;
151 my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE;
152 191
153 $hdr{"user-agent"} ||= $USERAGENT; 192 $hdr{"user-agent"} ||= $USERAGENT;
154 193
155 my ($host, $port, $path, $scheme); 194 my ($scheme, $authority, $upath, $query, $fragment) =
195 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
196
197 $scheme = lc $scheme;
198
199 my $uport = $scheme eq "http" ? 80
200 : $scheme eq "https" ? 443
201 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported" });
202
203 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
204 or return $cb->(undef, { Status => 599, Reason => "unparsable URL" });
205
206 my $uhost = $1;
207 $uport = $2 if defined $2;
208
209 $uhost =~ s/^\[(.*)\]$/$1/;
210 $upath .= "?$query" if length $query;
211
212 $upath =~ s%^/?%/%;
213
214 # cookie processing
215 if (my $jar = $arg{cookie_jar}) {
216 %$jar = () if $jar->{version} < 1;
217
218 my @cookie;
219
220 while (my ($chost, $v) = each %$jar) {
221 next unless $chost eq substr $uhost, -length $chost;
222 next unless $chost =~ /^\./;
223
224 while (my ($cpath, $v) = each %$v) {
225 next unless $cpath eq substr $upath, 0, length $cpath;
226
227 while (my ($k, $v) = each %$v) {
228 next if $scheme ne "https" && exists $v->{secure};
229 push @cookie, "$k=$v->{value}";
230 }
231 }
232 }
233
234 $hdr{cookie} = join "; ", @cookie
235 if @cookie;
236 }
237
238 my ($rhost, $rport, $rpath); # request host, port, path
156 239
157 if ($proxy) { 240 if ($proxy) {
158 ($host, $port, $scheme) = @$proxy; 241 ($rhost, $rport, $scheme) = @$proxy;
159 $path = $url; 242 $rpath = $url;
160 } else { 243 } else {
161 ($scheme, my $authority, $path, my $query, my $fragment) = 244 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath);
162 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
163
164 $port = $scheme eq "http" ? 80
165 : $scheme eq "https" ? 443
166 : croak "$url: only http and https URLs supported";
167
168 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
169 or croak "$authority: unparsable URL";
170
171 $host = $1;
172 $port = $2 if defined $2;
173
174 $host =~ s/^\[(.*)\]$/$1/;
175 $path .= "?$query" if length $query;
176
177 $path = "/" unless $path;
178
179 $hdr{host} = $host = lc $host; 245 $hdr{host} = $uhost;
180 } 246 }
181 247
182 $scheme = lc $scheme; 248 $hdr{"content-length"} = length $arg{body};
183 249
184 my %state; 250 my %state;
185 251
186 $state{body} = delete $arg{body};
187
188 $hdr{"content-length"} = length $state{body};
189
190 $state{connect_guard} = AnyEvent::Socket::tcp_connect $host, $port, sub { 252 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
191 $state{fh} = shift 253 $state{fh} = shift
192 or return $cb->(undef, { Status => 599, Reason => "$!" }); 254 or return $cb->(undef, { Status => 599, Reason => "$!" });
193 255
194 delete $state{connect_guard}; # reduce memory usage, save a tree 256 delete $state{connect_guard}; # reduce memory usage, save a tree
195 257
… …
219 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" }); 281 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });
220 }); 282 });
221 283
222 # send request 284 # send request
223 $state{handle}->push_write ( 285 $state{handle}->push_write (
224 "$method $path HTTP/1.0\015\012" 286 "$method $rpath HTTP/1.0\015\012"
225 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr) 287 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
226 . "\015\012" 288 . "\015\012"
227 . (delete $state{body}) 289 . (delete $arg{body})
228 ); 290 );
229 291
230 %hdr = (); # reduce memory usage, save a kitten 292 %hdr = (); # reduce memory usage, save a kitten
231 293
232 # status line 294 # status line
233 $state{handle}->push_read (line => qr/\015?\012/, sub { 295 $state{handle}->push_read (line => qr/\015?\012/, sub {
234 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix 296 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
235 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" })); 297 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
236 298
237 my %hdr = ( # response headers 299 my %hdr = ( # response headers
238 HTTPVersion => ",$1", 300 HTTPVersion => "\x00$1",
239 Status => ",$2", 301 Status => "\x00$2",
240 Reason => ",$3", 302 Reason => "\x00$3",
241 ); 303 );
242 304
243 # headers, could be optimized a bit 305 # headers, could be optimized a bit
244 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { 306 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
245 for ("$_[1]\012") { 307 for ("$_[1]\012") {
246 # we support spaces in field names, as lotus domino 308 # we support spaces in field names, as lotus domino
247 # creates them. 309 # creates them.
248 $hdr{lc $1} .= ",$2" 310 $hdr{lc $1} .= "\x00$2"
249 while /\G 311 while /\G
250 ([^:\000-\037]+): 312 ([^:\000-\037]+):
251 [\011\040]* 313 [\011\040]*
252 ((?: [^\015\012]+ | \015?\012[\011\040] )*) 314 ((?: [^\015\012]+ | \015?\012[\011\040] )*)
253 \015?\012 315 \015?\012
254 /gxc; 316 /gxc;
255 317
256 /\G$/ 318 /\G$/
257 or return $cb->(undef, { Status => 599, Reason => "garbled response headers" }); 319 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers" }));
258 } 320 }
259 321
260 substr $_, 0, 1, "" 322 substr $_, 0, 1, ""
261 for values %hdr; 323 for values %hdr;
262 324
263 if ($method eq "HEAD") { 325 my $finish = sub {
264 %state = (); 326 %state = ();
327
328 # set-cookie processing
329 if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
330 for (split /\x00/, $hdr{"set-cookie"}) {
331 my ($cookie, @arg) = split /;\s*/;
332 my ($name, $value) = split /=/, $cookie, 2;
333 my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
334
335 my $cdom = (delete $kv{domain}) || $uhost;
336 my $cpath = (delete $kv{path}) || "/";
337
338 $cdom =~ s/^.?/./; # make sure it starts with a "."
339
340 my $ndots = $cdom =~ y/.//;
341 next if $ndots < ($cdom =~ /[^.]{3}$/ ? 2 : 3);
342
343 # store it
344 $arg{cookie_jar}{version} = 1;
345 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
346 }
347 }
348
349 if ($_[1]{Status} =~ /^x30[12]$/ && $recurse) {
350 # microsoft and other assholes don't give a shit for following standards,
351 # try to support a common form of broken Location header.
352 $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
353
354 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
355 } else {
356 $cb->($_[0], $_[1]);
357 }
358 };
359
360 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") {
265 $cb->(undef, \%hdr); 361 $finish->(undef, \%hdr);
266 } else { 362 } else {
267 if (exists $hdr{"content-length"}) { 363 if (exists $hdr{"content-length"}) {
268 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub { 364 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
269 # could cache persistent connection now 365 # could cache persistent connection now
270 if ($hdr{connection} =~ /\bkeep-alive\b/i) { 366 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
271 # but we don't, due to misdesigns, this is annoyingly complex 367 # but we don't, due to misdesigns, this is annoyingly complex
272 }; 368 };
273 369
274 %state = ();
275 $cb->($_[1], \%hdr); 370 $finish->($_[1], \%hdr);
276 }); 371 });
277 } else { 372 } else {
278 # too bad, need to read until we get an error or EOF, 373 # too bad, need to read until we get an error or EOF,
279 # no way to detect winged data. 374 # no way to detect winged data.
280 $_[0]->on_error (sub { 375 $_[0]->on_error (sub {
281 %state = ();
282 $cb->($_[0]{rbuf}, \%hdr); 376 $finish->($_[0]{rbuf}, \%hdr);
283 }); 377 });
284 $_[0]->on_eof (undef); 378 $_[0]->on_eof (undef);
285 $_[0]->on_read (sub { }); 379 $_[0]->on_read (sub { });
286 } 380 }
287 } 381 }
… …
307sub http_post($$$;@) { 401sub http_post($$$;@) {
308 unshift @_, "POST", "body"; 402 unshift @_, "POST", "body";
309 &http_request 403 &http_request
310} 404}
311 405
406=back
407
312=head2 GLOBAL FUNCTIONS AND VARIABLES 408=head2 GLOBAL FUNCTIONS AND VARIABLES
313 409
314=over 4 410=over 4
315 411
316=item AnyEvent::HTTP::set_proxy "proxy-url" 412=item AnyEvent::HTTP::set_proxy "proxy-url"

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines