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.2 by root, Wed Jun 4 11:37:41 2008 UTC vs.
Revision 1.10 by root, Thu Jun 5 13:06:43 2008 UTC

… …
34our $VERSION = '1.0'; 34our $VERSION = '1.0';
35 35
36our @EXPORT = qw(http_get http_request); 36our @EXPORT = qw(http_get http_request);
37 37
38our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 38our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
39our $MAX_REDIRECTS = 10; 39our $MAX_RECURSE = 10;
40our $MAX_PERSISTENT = 8; 40our $MAX_PERSISTENT = 8;
41our $PERSISTENT_TIMEOUT = 2; 41our $PERSISTENT_TIMEOUT = 2;
42our $TIMEOUT = 300; 42our $TIMEOUT = 300;
43 43
44# changing these is evil 44# changing these is evil
… …
52=item http_get $url, key => value..., $cb->($data, $headers) 52=item http_get $url, key => value..., $cb->($data, $headers)
53 53
54Executes an HTTP-GET request. See the http_request function for details on 54Executes an HTTP-GET request. See the http_request function for details on
55additional parameters. 55additional parameters.
56 56
57=item http_head $url, key => value..., $cb->($data, $headers)
58
59Executes an HTTP-HEAD request. See the http_request function for details on
60additional parameters.
61
62=item http_post $url, $body, key => value..., $cb->($data, $headers)
63
64Executes an HTTP-POST request with a request body of C<$bod>. See the
65http_request function for details on additional parameters.
66
57=item http_request $method => $url, key => value..., $cb->($data, $headers) 67=item http_request $method => $url, key => value..., $cb->($data, $headers)
58 68
59Executes 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
60must be an absolute http or https URL. 70must be an absolute http or https URL.
61 71
62The callback will be called with the response data as first argument 72The callback will be called with the response data as first argument
63(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
64response headers as second argument. 74response headers as second argument.
65 75
66All 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
67headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and 77headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and
68C<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
69name. 79name. If the server sends a header multiple lines, then their contents
80will be joined together with C<\x00>.
70 81
71If 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,
72then 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>
73and the C<Reason> pseudo-header will contain an error message. 84and the C<Reason> pseudo-header will contain an error message.
74 85
86A typical callback might look like this:
87
88 sub {
89 my ($body, $hdr) = @_;
90
91 if ($hdr->{Status} =~ /^2/) {
92 ... everything should be ok
93 } else {
94 print "error, $hdr->{Status} $hdr->{Reason}\n";
95 }
96 }
97
75Additional parameters are key-value pairs, and are fully optional. They 98Additional parameters are key-value pairs, and are fully optional. They
76include: 99include:
77 100
78=over 4 101=over 4
79 102
80=item recurse => $boolean (default: true) 103=item recurse => $count (default: $MAX_RECURSE)
81 104
82Whether to recurse requests or not, e.g. on redirects, authentication 105Whether to recurse requests or not, e.g. on redirects, authentication
83retries and so on. 106retries and so on, and how often to do so.
84 107
85=item headers => hashref 108=item headers => hashref
86 109
87The request headers to use. 110The request headers to use.
88 111
… …
97default proxy (as specified by C<$ENV{http_proxy}>) is used. 120default proxy (as specified by C<$ENV{http_proxy}>) is used.
98 121
99C<$scheme> must be either missing or C<http> for HTTP, or C<https> for 122C<$scheme> must be either missing or C<http> for HTTP, or C<https> for
100HTTPS. 123HTTPS.
101 124
125=item body => $string
126
127The request body, usually empty. Will be-sent as-is (future versions of
128this module might offer more options).
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
102=back 146=back
103 147
104=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 ;
105 167
106=cut 168=cut
107 169
108sub http_request($$$;@) { 170sub http_request($$$;@) {
109 my $cb = pop; 171 my $cb = pop;
110 my ($method, $url, %arg) = @_; 172 my ($method, $url, %arg) = @_;
111 173
112 my %hdr; 174 my %hdr;
113 175
176 $method = uc $method;
177
114 if (my $hdr = delete $arg{headers}) { 178 if (my $hdr = $arg{headers}) {
115 while (my ($k, $v) = each %$hdr) { 179 while (my ($k, $v) = each %$hdr) {
116 $hdr{lc $k} = $v; 180 $hdr{lc $k} = $v;
117 } 181 }
118 } 182 }
119 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
120 my $proxy = $arg{proxy} || $PROXY; 189 my $proxy = $arg{proxy} || $PROXY;
121 my $timeout = $arg{timeout} || $TIMEOUT; 190 my $timeout = $arg{timeout} || $TIMEOUT;
122 191
123 $hdr{"user-agent"} ||= $USERAGENT; 192 $hdr{"user-agent"} ||= $USERAGENT;
124 193
125 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
126 239
127 if ($proxy) { 240 if ($proxy) {
128 ($host, $port, $scheme) = @$proxy; 241 ($rhost, $rport, $scheme) = @$proxy;
129 $path = $url; 242 $rpath = $url;
130 } else { 243 } else {
131 ($scheme, my $authority, $path, my $query, my $fragment) = 244 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath);
132 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
133
134 $port = $scheme eq "http" ? 80
135 : $scheme eq "https" ? 443
136 : croak "$url: only http and https URLs supported";
137
138 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
139 or croak "$authority: unparsable URL";
140
141 $host = $1;
142 $port = $2 if defined $2;
143
144 $host =~ s/^\[(.*)\]$/$1/;
145 $path .= "?$query" if length $query;
146
147 $path = "/" unless $path;
148
149 $hdr{host} = $host = lc $host; 245 $hdr{host} = $uhost;
150 } 246 }
151 247
152 $scheme = lc $scheme; 248 $hdr{"content-length"} = length $arg{body};
153 249
154 my %state; 250 my %state;
155 251
156 my $body = "";
157 $state{body} = $body;
158
159 $hdr{"content-length"} = length $body;
160
161 $state{connect_guard} = AnyEvent::Socket::tcp_connect $host, $port, sub { 252 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
162 $state{fh} = shift 253 $state{fh} = shift
163 or return $cb->(undef, { Status => 599, Reason => "$!" }); 254 or return $cb->(undef, { Status => 599, Reason => "$!" });
164 255
165 delete $state{connect_guard}; # reduce memory usage, save a tree 256 delete $state{connect_guard}; # reduce memory usage, save a tree
166 257
… …
190 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" }); 281 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });
191 }); 282 });
192 283
193 # send request 284 # send request
194 $state{handle}->push_write ( 285 $state{handle}->push_write (
195 "\U$method\E $path HTTP/1.0\015\012" 286 "$method $rpath HTTP/1.0\015\012"
196 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr) 287 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
197 . "\015\012" 288 . "\015\012"
198 . (delete $state{body}) 289 . (delete $arg{body})
199 ); 290 );
200 291
201 %hdr = (); # reduce memory usage, save a kitten 292 %hdr = (); # reduce memory usage, save a kitten
202 293
203 # status line 294 # status line
204 $state{handle}->push_read (line => qr/\015?\012/, sub { 295 $state{handle}->push_read (line => qr/\015?\012/, sub {
205 $_[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
206 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])" }));
207 298
208 my %hdr = ( # response headers 299 my %hdr = ( # response headers
209 HTTPVersion => ",$1", 300 HTTPVersion => "\x00$1",
210 Status => ",$2", 301 Status => "\x00$2",
211 Reason => ",$3", 302 Reason => "\x00$3",
212 ); 303 );
213 304
214 # headers, could be optimized a bit 305 # headers, could be optimized a bit
215 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { 306 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
216 for ("$_[1]\012") { 307 for ("$_[1]\012") {
217 # we support spaces in field names, as lotus domino 308 # we support spaces in field names, as lotus domino
218 # creates them. 309 # creates them.
219 $hdr{lc $1} .= ",$2" 310 $hdr{lc $1} .= "\x00$2"
220 while /\G 311 while /\G
221 ([^:\000-\037]+): 312 ([^:\000-\037]+):
222 [\011\040]* 313 [\011\040]*
223 ((?: [^\015\012]+ | \015?\012[\011\040] )*) 314 ((?: [^\015\012]+ | \015?\012[\011\040] )*)
224 \015?\012 315 \015?\012
225 /gxc; 316 /gxc;
226 317
227 /\G$/ 318 /\G$/
228 or return $cb->(undef, { Status => 599, Reason => "garbled response headers" }); 319 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers" }));
229 } 320 }
230 321
231 substr $_, 0, 1, "" 322 substr $_, 0, 1, ""
232 for values %hdr; 323 for values %hdr;
233 324
234 if (exists $hdr{"content-length"}) { 325 my $finish = sub {
235 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub { 326 %state = ();
236 # could cache persistent connection now 327
237 if ($hdr{connection} =~ /\bkeep-alive\b/i) { 328 # set-cookie processing
238 # but we don't, due to misdesigns, this is annoyingly complex 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;
239 }; 346 }
240
241 %state = ();
242 $cb->($_[1], \%hdr);
243 }); 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") {
361 $finish->(undef, \%hdr);
244 } else { 362 } else {
363 if (exists $hdr{"content-length"}) {
364 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
365 # could cache persistent connection now
366 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
367 # but we don't, due to misdesigns, this is annoyingly complex
368 };
369
370 $finish->($_[1], \%hdr);
371 });
372 } else {
245 # 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,
246 # no way to detect winged data. 374 # no way to detect winged data.
247 $_[0]->on_error (sub { 375 $_[0]->on_error (sub {
248 %state = ();
249 $cb->($_[0]{rbuf}, \%hdr); 376 $finish->($_[0]{rbuf}, \%hdr);
250 }); 377 });
251 $_[0]->on_eof (undef); 378 $_[0]->on_eof (undef);
252 $_[0]->on_read (sub { }); 379 $_[0]->on_read (sub { });
380 }
253 } 381 }
254 }); 382 });
255 }); 383 });
256 }, sub { 384 }, sub {
257 $timeout 385 $timeout
… …
263sub http_get($$;@) { 391sub http_get($$;@) {
264 unshift @_, "GET"; 392 unshift @_, "GET";
265 &http_request 393 &http_request
266} 394}
267 395
396sub http_head($$;@) {
397 unshift @_, "HEAD";
398 &http_request
399}
400
401sub http_post($$$;@) {
402 unshift @_, "POST", "body";
403 &http_request
404}
405
406=back
407
268=head2 GLOBAL FUNCTIONS AND VARIABLES 408=head2 GLOBAL FUNCTIONS AND VARIABLES
269 409
270=over 4 410=over 4
271 411
272=item AnyEvent::HTTP::set_proxy "proxy-url" 412=item AnyEvent::HTTP::set_proxy "proxy-url"
273 413
274Sets the default proxy server to use. The proxy-url must begin with a 414Sets the default proxy server to use. The proxy-url must begin with a
275string of the form C<http://host:port> (optionally C<https:...>). 415string of the form C<http://host:port> (optionally C<https:...>).
276 416
277=item $AnyEvent::HTTP::MAX_REDIRECTS 417=item $AnyEvent::HTTP::MAX_RECURSE
278 418
279The default value for the C<max_redirects> request parameter 419The default value for the C<recurse> request parameter (default: C<10>).
280(default: C<10>).
281 420
282=item $AnyEvent::HTTP::USERAGENT 421=item $AnyEvent::HTTP::USERAGENT
283 422
284The default value for the C<User-Agent> header (the default is 423The default value for the C<User-Agent> header (the default is
285C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 424C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
286 425
287=item $AnyEvent::HTTP::MAX_PERSISTENT 426=item $AnyEvent::HTTP::MAX_PERSISTENT
288 427
289The maximum number of persistent connections to keep open (default: 8). 428The maximum number of persistent connections to keep open (default: 8).
290 429
430Not implemented currently.
431
291=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 432=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
292 433
293The maximum time to cache a persistent connection, in seconds (default: 2). 434The maximum time to cache a persistent connection, in seconds (default: 2).
435
436Not implemented currently.
294 437
295=back 438=back
296 439
297=cut 440=cut
298 441

Diff Legend

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