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

… …
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
57=item http_get $url, $body, key => value..., $cb->($data, $headers) 62=item http_post $url, $body, key => value..., $cb->($data, $headers)
58 63
59Executes 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
60http_request function for details on additional parameters. 65http_request function for details on additional parameters.
61 66
62=item http_request $method => $url, key => value..., $cb->($data, $headers) 67=item http_request $method => $url, key => value..., $cb->($data, $headers)
63 68
64Executes 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
… …
66 71
67The callback will be called with the response data as first argument 72The callback will be called with the response data as first argument
68(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
69response headers as second argument. 74response headers as second argument.
70 75
71All 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
72headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and 77headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and
73C<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
74name. 79name. If the server sends a header multiple lines, then their contents
80will be joined together with C<\x00>.
75 81
76If 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,
77then 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>
78and the C<Reason> pseudo-header will contain an error message. 84and the C<Reason> pseudo-header will contain an error message.
79 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
80Additional parameters are key-value pairs, and are fully optional. They 98Additional parameters are key-value pairs, and are fully optional. They
81include: 99include:
82 100
83=over 4 101=over 4
84 102
… …
107=item body => $string 125=item body => $string
108 126
109The 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
110this module might offer more options). 128this module might offer more options).
111 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
112=back 146=back
113 147
114=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 ;
115 167
116=cut 168=cut
117 169
118sub http_request($$$;@) { 170sub http_request($$$;@) {
119 my $cb = pop; 171 my $cb = pop;
… …
121 173
122 my %hdr; 174 my %hdr;
123 175
124 $method = uc $method; 176 $method = uc $method;
125 177
126 if (my $hdr = delete $arg{headers}) { 178 if (my $hdr = $arg{headers}) {
127 while (my ($k, $v) = each %$hdr) { 179 while (my ($k, $v) = each %$hdr) {
128 $hdr{lc $k} = $v; 180 $hdr{lc $k} = $v;
129 } 181 }
130 } 182 }
131 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
132 my $proxy = $arg{proxy} || $PROXY; 189 my $proxy = $arg{proxy} || $PROXY;
133 my $timeout = $arg{timeout} || $TIMEOUT; 190 my $timeout = $arg{timeout} || $TIMEOUT;
134 my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE;
135 191
136 $hdr{"user-agent"} ||= $USERAGENT; 192 $hdr{"user-agent"} ||= $USERAGENT;
137 193
138 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
139 239
140 if ($proxy) { 240 if ($proxy) {
141 ($host, $port, $scheme) = @$proxy; 241 ($rhost, $rport, $scheme) = @$proxy;
142 $path = $url; 242 $rpath = $url;
143 } else { 243 } else {
144 ($scheme, my $authority, $path, my $query, my $fragment) = 244 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath);
145 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
146
147 $port = $scheme eq "http" ? 80
148 : $scheme eq "https" ? 443
149 : croak "$url: only http and https URLs supported";
150
151 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
152 or croak "$authority: unparsable URL";
153
154 $host = $1;
155 $port = $2 if defined $2;
156
157 $host =~ s/^\[(.*)\]$/$1/;
158 $path .= "?$query" if length $query;
159
160 $path = "/" unless $path;
161
162 $hdr{host} = $host = lc $host; 245 $hdr{host} = $uhost;
163 } 246 }
164 247
165 $scheme = lc $scheme; 248 $hdr{"content-length"} = length $arg{body};
166 249
167 my %state; 250 my %state;
168 251
169 $state{body} = delete $arg{body};
170
171 $hdr{"content-length"} = length $state{body};
172
173 $state{connect_guard} = AnyEvent::Socket::tcp_connect $host, $port, sub { 252 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
174 $state{fh} = shift 253 $state{fh} = shift
175 or return $cb->(undef, { Status => 599, Reason => "$!" }); 254 or return $cb->(undef, { Status => 599, Reason => "$!" });
176 255
177 delete $state{connect_guard}; # reduce memory usage, save a tree 256 delete $state{connect_guard}; # reduce memory usage, save a tree
178 257
… …
202 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" }); 281 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });
203 }); 282 });
204 283
205 # send request 284 # send request
206 $state{handle}->push_write ( 285 $state{handle}->push_write (
207 "$method $path HTTP/1.0\015\012" 286 "$method $rpath HTTP/1.0\015\012"
208 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr) 287 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
209 . "\015\012" 288 . "\015\012"
210 . (delete $state{body}) 289 . (delete $arg{body})
211 ); 290 );
212 291
213 %hdr = (); # reduce memory usage, save a kitten 292 %hdr = (); # reduce memory usage, save a kitten
214 293
215 # status line 294 # status line
216 $state{handle}->push_read (line => qr/\015?\012/, sub { 295 $state{handle}->push_read (line => qr/\015?\012/, sub {
217 $_[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
218 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])" }));
219 298
220 my %hdr = ( # response headers 299 my %hdr = ( # response headers
221 HTTPVersion => ",$1", 300 HTTPVersion => "\x00$1",
222 Status => ",$2", 301 Status => "\x00$2",
223 Reason => ",$3", 302 Reason => "\x00$3",
224 ); 303 );
225 304
226 # headers, could be optimized a bit 305 # headers, could be optimized a bit
227 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { 306 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
228 for ("$_[1]\012") { 307 for ("$_[1]\012") {
229 # we support spaces in field names, as lotus domino 308 # we support spaces in field names, as lotus domino
230 # creates them. 309 # creates them.
231 $hdr{lc $1} .= ",$2" 310 $hdr{lc $1} .= "\x00$2"
232 while /\G 311 while /\G
233 ([^:\000-\037]+): 312 ([^:\000-\037]+):
234 [\011\040]* 313 [\011\040]*
235 ((?: [^\015\012]+ | \015?\012[\011\040] )*) 314 ((?: [^\015\012]+ | \015?\012[\011\040] )*)
236 \015?\012 315 \015?\012
237 /gxc; 316 /gxc;
238 317
239 /\G$/ 318 /\G$/
240 or return $cb->(undef, { Status => 599, Reason => "garbled response headers" }); 319 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers" }));
241 } 320 }
242 321
243 substr $_, 0, 1, "" 322 substr $_, 0, 1, ""
244 for values %hdr; 323 for values %hdr;
245 324
246 if ($method ne "HEAD") { 325 my $finish = sub {
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") {
361 $finish->(undef, \%hdr);
362 } else {
247 if (exists $hdr{"content-length"}) { 363 if (exists $hdr{"content-length"}) {
248 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub { 364 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
249 # could cache persistent connection now 365 # could cache persistent connection now
250 if ($hdr{connection} =~ /\bkeep-alive\b/i) { 366 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
251 # but we don't, due to misdesigns, this is annoyingly complex 367 # but we don't, due to misdesigns, this is annoyingly complex
252 }; 368 };
253 369
254 %state = ();
255 $cb->($_[1], \%hdr); 370 $finish->($_[1], \%hdr);
256 }); 371 });
257 } else { 372 } else {
258 # 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,
259 # no way to detect winged data. 374 # no way to detect winged data.
260 $_[0]->on_error (sub { 375 $_[0]->on_error (sub {
261 %state = ();
262 $cb->($_[0]{rbuf}, \%hdr); 376 $finish->($_[0]{rbuf}, \%hdr);
263 }); 377 });
264 $_[0]->on_eof (undef); 378 $_[0]->on_eof (undef);
265 $_[0]->on_read (sub { }); 379 $_[0]->on_read (sub { });
266 } 380 }
267 } 381 }
… …
277sub http_get($$;@) { 391sub http_get($$;@) {
278 unshift @_, "GET"; 392 unshift @_, "GET";
279 &http_request 393 &http_request
280} 394}
281 395
396sub http_head($$;@) {
397 unshift @_, "HEAD";
398 &http_request
399}
400
282sub http_post($$$;@) { 401sub http_post($$$;@) {
283 unshift @_, "POST", "body"; 402 unshift @_, "POST", "body";
284 &http_request 403 &http_request
285} 404}
286 405
406=back
407
287=head2 GLOBAL FUNCTIONS AND VARIABLES 408=head2 GLOBAL FUNCTIONS AND VARIABLES
288 409
289=over 4 410=over 4
290 411
291=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