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.22 by root, Sat Jun 28 21:17:03 2008 UTC vs.
Revision 1.131 by root, Thu Aug 30 17:04:28 2018 UTC

15This module is an L<AnyEvent> user, you need to make sure that you use and 15This module is an L<AnyEvent> user, you need to make sure that you use and
16run a supported event loop. 16run a supported event loop.
17 17
18This module implements a simple, stateless and non-blocking HTTP 18This module implements a simple, stateless and non-blocking HTTP
19client. It supports GET, POST and other request methods, cookies and more, 19client. It supports GET, POST and other request methods, cookies and more,
20all on a very low level. It can follow redirects supports proxies and 20all on a very low level. It can follow redirects, supports proxies, and
21automatically limits the number of connections to the values specified in 21automatically limits the number of connections to the values specified in
22the RFC. 22the RFC.
23 23
24It should generally be a "good client" that is enough for most HTTP 24It should generally be a "good client" that is enough for most HTTP
25tasks. Simple tasks should be simple, but complex tasks should still be 25tasks. Simple tasks should be simple, but complex tasks should still be
36 36
37=cut 37=cut
38 38
39package AnyEvent::HTTP; 39package AnyEvent::HTTP;
40 40
41use strict; 41use common::sense;
42no warnings;
43 42
44use Carp; 43use Errno ();
45 44
46use AnyEvent (); 45use AnyEvent 5.0 ();
47use AnyEvent::Util (); 46use AnyEvent::Util ();
48use AnyEvent::Socket ();
49use AnyEvent::Handle (); 47use AnyEvent::Handle ();
50 48
51use base Exporter::; 49use base Exporter::;
52 50
53our $VERSION = '1.03'; 51our $VERSION = 2.24;
54 52
55our @EXPORT = qw(http_get http_post http_head http_request); 53our @EXPORT = qw(http_get http_post http_head http_request);
56 54
57our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 55our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
58our $MAX_RECURSE = 10; 56our $MAX_RECURSE = 10;
59our $MAX_PERSISTENT = 8;
60our $PERSISTENT_TIMEOUT = 2; 57our $PERSISTENT_TIMEOUT = 3;
61our $TIMEOUT = 300; 58our $TIMEOUT = 300;
62 59our $MAX_PER_HOST = 4; # changing this is evil
63# changing these is evil
64our $MAX_PERSISTENT_PER_HOST = 2;
65our $MAX_PER_HOST = 4;
66 60
67our $PROXY; 61our $PROXY;
68our $ACTIVE = 0; 62our $ACTIVE = 0;
69 63
70my %KA_COUNT; # number of open keep-alive connections per host 64my %KA_CACHE; # indexed by uhost currently, points to [$handle...] array
71my %CO_SLOT; # number of open connections, and wait queue, per host 65my %CO_SLOT; # number of open connections, and wait queue, per host
72 66
73=item http_get $url, key => value..., $cb->($data, $headers) 67=item http_get $url, key => value..., $cb->($data, $headers)
74 68
75Executes an HTTP-GET request. See the http_request function for details on 69Executes an HTTP-GET request. See the http_request function for details on
76additional parameters. 70additional parameters and the return value.
77 71
78=item http_head $url, key => value..., $cb->($data, $headers) 72=item http_head $url, key => value..., $cb->($data, $headers)
79 73
80Executes an HTTP-HEAD request. See the http_request function for details on 74Executes an HTTP-HEAD request. See the http_request function for details
81additional parameters. 75on additional parameters and the return value.
82 76
83=item http_post $url, $body, key => value..., $cb->($data, $headers) 77=item http_post $url, $body, key => value..., $cb->($data, $headers)
84 78
85Executes an HTTP-POST request with a request body of C<$bod>. See the 79Executes an HTTP-POST request with a request body of C<$body>. See the
86http_request function for details on additional parameters. 80http_request function for details on additional parameters and the return
81value.
87 82
88=item http_request $method => $url, key => value..., $cb->($data, $headers) 83=item http_request $method => $url, key => value..., $cb->($data, $headers)
89 84
90Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL 85Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
91must be an absolute http or https URL. 86must be an absolute http or https URL.
92 87
88When called in void context, nothing is returned. In other contexts,
89C<http_request> returns a "cancellation guard" - you have to keep the
90object at least alive until the callback get called. If the object gets
91destroyed before the callback is called, the request will be cancelled.
92
93The callback will be called with the response data as first argument 93The callback will be called with the response body data as first argument
94(or C<undef> if it wasn't available due to errors), and a hash-ref with 94(or C<undef> if an error occurred), and a hash-ref with response headers
95response headers as second argument. 95(and trailers) as second argument.
96 96
97All the headers in that hash are lowercased. In addition to the response 97All the headers in that hash are lowercased. In addition to the response
98headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason> 98headers, the "pseudo-headers" (uppercase to avoid clashing with possible
99response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
99contain the three parts of the HTTP Status-Line of the same name. The 100three parts of the HTTP Status-Line of the same name. If an error occurs
101during the body phase of a request, then the original C<Status> and
102C<Reason> values from the header are available as C<OrigStatus> and
103C<OrigReason>.
104
100pseudo-header C<URL> contains the original URL (which can differ from the 105The pseudo-header C<URL> contains the actual URL (which can differ from
101requested URL when following redirects). 106the requested URL when following redirects - for example, you might get
107an error that your URL scheme is not supported even though your URL is a
108valid http URL because it redirected to an ftp URL, in which case you can
109look at the URL pseudo header).
102 110
111The pseudo-header C<Redirect> only exists when the request was a result
112of an internal redirect. In that case it is an array reference with
113the C<($data, $headers)> from the redirect response. Note that this
114response could in turn be the result of a redirect itself, and C<<
115$headers->{Redirect}[1]{Redirect} >> will then contain the original
116response, and so on.
117
103If the server sends a header multiple lines, then their contents will be 118If the server sends a header multiple times, then their contents will be
104joined together with C<\x00>. 119joined together with a comma (C<,>), as per the HTTP spec.
105 120
106If an internal error occurs, such as not being able to resolve a hostname, 121If an internal error occurs, such as not being able to resolve a hostname,
107then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599> 122then C<$data> will be C<undef>, C<< $headers->{Status} >> will be
108and the C<Reason> pseudo-header will contain an error message. 123C<590>-C<599> and the C<Reason> pseudo-header will contain an error
124message. Currently the following status codes are used:
125
126=over 4
127
128=item 595 - errors during connection establishment, proxy handshake.
129
130=item 596 - errors during TLS negotiation, request sending and header processing.
131
132=item 597 - errors during body receiving or processing.
133
134=item 598 - user aborted request via C<on_header> or C<on_body>.
135
136=item 599 - other, usually nonretryable, errors (garbled URL etc.).
137
138=back
109 139
110A typical callback might look like this: 140A typical callback might look like this:
111 141
112 sub { 142 sub {
113 my ($body, $hdr) = @_; 143 my ($body, $hdr) = @_;
124 154
125=over 4 155=over 4
126 156
127=item recurse => $count (default: $MAX_RECURSE) 157=item recurse => $count (default: $MAX_RECURSE)
128 158
129Whether to recurse requests or not, e.g. on redirects, authentication 159Whether to recurse requests or not, e.g. on redirects, authentication and
130retries and so on, and how often to do so. 160other retries and so on, and how often to do so.
161
162Only redirects to http and https URLs are supported. While most common
163redirection forms are handled entirely within this module, some require
164the use of the optional L<URI> module. If it is required but missing, then
165the request will fail with an error.
131 166
132=item headers => hashref 167=item headers => hashref
133 168
134The request headers to use. Currently, C<http_request> may provide its 169The request headers to use. Currently, C<http_request> may provide its own
135own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers 170C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
136and will provide defaults for C<User-Agent:> and C<Referer:>. 171will provide defaults at least for C<TE:>, C<Referer:> and C<User-Agent:>
172(this can be suppressed by using C<undef> for these headers in which case
173they won't be sent at all).
174
175You really should provide your own C<User-Agent:> header value that is
176appropriate for your program - I wouldn't be surprised if the default
177AnyEvent string gets blocked by webservers sooner or later.
178
179Also, make sure that your headers names and values do not contain any
180embedded newlines.
137 181
138=item timeout => $seconds 182=item timeout => $seconds
139 183
140The time-out to use for various stages - each connect attempt will reset 184The time-out to use for various stages - each connect attempt will reset
141the timeout, as will read or write activity. Default timeout is 5 minutes. 185the timeout, as will read or write activity, i.e. this is not an overall
186timeout.
187
188Default timeout is 5 minutes.
142 189
143=item proxy => [$host, $port[, $scheme]] or undef 190=item proxy => [$host, $port[, $scheme]] or undef
144 191
145Use the given http proxy for all requests. If not specified, then the 192Use the given http proxy for all requests, or no proxy if C<undef> is
146default proxy (as specified by C<$ENV{http_proxy}>) is used. 193used.
147 194
148C<$scheme> must be either missing or C<http> for HTTP, or C<https> for 195C<$scheme> must be either missing or must be C<http> for HTTP.
149HTTPS. 196
197If not specified, then the default proxy is used (see
198C<AnyEvent::HTTP::set_proxy>).
199
200Currently, if your proxy requires authorization, you have to specify an
201appropriate "Proxy-Authorization" header in every request.
150 202
151=item body => $string 203=item body => $string
152 204
153The request body, usually empty. Will be-sent as-is (future versions of 205The request body, usually empty. Will be sent as-is (future versions of
154this module might offer more options). 206this module might offer more options).
155 207
156=item cookie_jar => $hash_ref 208=item cookie_jar => $hash_ref
157 209
158Passing this parameter enables (simplified) cookie-processing, loosely 210Passing this parameter enables (simplified) cookie-processing, loosely
159based on the original netscape specification. 211based on the original netscape specification.
160 212
161The C<$hash_ref> must be an (initially empty) hash reference which will 213The C<$hash_ref> must be an (initially empty) hash reference which
162get updated automatically. It is possible to save the cookie_jar to 214will get updated automatically. It is possible to save the cookie jar
163persistent storage with something like JSON or Storable, but this is not 215to persistent storage with something like JSON or Storable - see the
164recommended, as expire times are currently being ignored. 216C<AnyEvent::HTTP::cookie_jar_expire> function if you wish to remove
217expired or session-only cookies, and also for documentation on the format
218of the cookie jar.
165 219
166Note that this cookie implementation is not of very high quality, nor 220Note that this cookie implementation is not meant to be complete. If
167meant to be complete. If you want complete cookie management you have to 221you want complete cookie management you have to do that on your
168do that on your own. C<cookie_jar> is meant as a quick fix to get some 222own. C<cookie_jar> is meant as a quick fix to get most cookie-using sites
169cookie-using sites working. Cookies are a privacy disaster, do not use 223working. Cookies are a privacy disaster, do not use them unless required
170them unless required to. 224to.
225
226When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
227headers will be set and handled by this module, otherwise they will be
228left untouched.
229
230=item tls_ctx => $scheme | $tls_ctx
231
232Specifies the AnyEvent::TLS context to be used for https connections. This
233parameter follows the same rules as the C<tls_ctx> parameter to
234L<AnyEvent::Handle>, but additionally, the two strings C<low> or
235C<high> can be specified, which give you a predefined low-security (no
236verification, highest compatibility) and high-security (CA and common-name
237verification) TLS context.
238
239The default for this option is C<low>, which could be interpreted as "give
240me the page, no matter what".
241
242See also the C<sessionid> parameter.
243
244=item session => $string
245
246The module might reuse connections to the same host internally. Sometimes
247(e.g. when using TLS), you do not want to reuse connections from other
248sessions. This can be achieved by setting this parameter to some unique
249ID (such as the address of an object storing your state data, or the TLS
250context) - only connections using the same unique ID will be reused.
251
252=item on_prepare => $callback->($fh)
253
254In rare cases you need to "tune" the socket before it is used to
255connect (for example, to bind it on a given IP address). This parameter
256overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
257and behaves exactly the same way (e.g. it has to provide a
258timeout). See the description for the C<$prepare_cb> argument of
259C<AnyEvent::Socket::tcp_connect> for details.
260
261=item tcp_connect => $callback->($host, $service, $connect_cb, $prepare_cb)
262
263In even rarer cases you want total control over how AnyEvent::HTTP
264establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
265to do this, but you can provide your own C<tcp_connect> function -
266obviously, it has to follow the same calling conventions, except that it
267may always return a connection guard object.
268
269There are probably lots of weird uses for this function, starting from
270tracing the hosts C<http_request> actually tries to connect, to (inexact
271but fast) host => IP address caching or even socks protocol support.
272
273=item on_header => $callback->($headers)
274
275When specified, this callback will be called with the header hash as soon
276as headers have been successfully received from the remote server (not on
277locally-generated errors).
278
279It has to return either true (in which case AnyEvent::HTTP will continue),
280or false, in which case AnyEvent::HTTP will cancel the download (and call
281the finish callback with an error code of C<598>).
282
283This callback is useful, among other things, to quickly reject unwanted
284content, which, if it is supposed to be rare, can be faster than first
285doing a C<HEAD> request.
286
287The downside is that cancelling the request makes it impossible to re-use
288the connection. Also, the C<on_header> callback will not receive any
289trailer (headers sent after the response body).
290
291Example: cancel the request unless the content-type is "text/html".
292
293 on_header => sub {
294 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
295 },
296
297=item on_body => $callback->($partial_body, $headers)
298
299When specified, all body data will be passed to this callback instead of
300to the completion callback. The completion callback will get the empty
301string instead of the body data.
302
303It has to return either true (in which case AnyEvent::HTTP will continue),
304or false, in which case AnyEvent::HTTP will cancel the download (and call
305the completion callback with an error code of C<598>).
306
307The downside to cancelling the request is that it makes it impossible to
308re-use the connection.
309
310This callback is useful when the data is too large to be held in memory
311(so the callback writes it to a file) or when only some information should
312be extracted, or when the body should be processed incrementally.
313
314It is usually preferred over doing your own body handling via
315C<want_body_handle>, but in case of streaming APIs, where HTTP is
316only used to create a connection, C<want_body_handle> is the better
317alternative, as it allows you to install your own event handler, reducing
318resource usage.
319
320=item want_body_handle => $enable
321
322When enabled (default is disabled), the behaviour of AnyEvent::HTTP
323changes considerably: after parsing the headers, and instead of
324downloading the body (if any), the completion callback will be
325called. Instead of the C<$body> argument containing the body data, the
326callback will receive the L<AnyEvent::Handle> object associated with the
327connection. In error cases, C<undef> will be passed. When there is no body
328(e.g. status C<304>), the empty string will be passed.
329
330The handle object might or might not be in TLS mode, might be connected
331to a proxy, be a persistent connection, use chunked transfer encoding
332etc., and configured in unspecified ways. The user is responsible for this
333handle (it will not be used by this module anymore).
334
335This is useful with some push-type services, where, after the initial
336headers, an interactive protocol is used (typical example would be the
337push-style twitter API which starts a JSON/XML stream).
338
339If you think you need this, first have a look at C<on_body>, to see if
340that doesn't solve your problem in a better way.
341
342=item persistent => $boolean
343
344Try to create/reuse a persistent connection. When this flag is set
345(default: true for idempotent requests, false for all others), then
346C<http_request> tries to re-use an existing (previously-created)
347persistent connection to the host and, failing that, tries to create a new
348one.
349
350Requests failing in certain ways will be automatically retried once, which
351is dangerous for non-idempotent requests, which is why it defaults to off
352for them. The reason for this is because the bozos who designed HTTP/1.1
353made it impossible to distinguish between a fatal error and a normal
354connection timeout, so you never know whether there was a problem with
355your request or not.
356
357When reusing an existent connection, many parameters (such as TLS context)
358will be ignored. See the C<session> parameter for a workaround.
359
360=item keepalive => $boolean
361
362Only used when C<persistent> is also true. This parameter decides whether
363C<http_request> tries to handshake a HTTP/1.0-style keep-alive connection
364(as opposed to only a HTTP/1.1 persistent connection).
365
366The default is true, except when using a proxy, in which case it defaults
367to false, as HTTP/1.0 proxies cannot support this in a meaningful way.
368
369=item handle_params => { key => value ... }
370
371The key-value pairs in this hash will be passed to any L<AnyEvent::Handle>
372constructor that is called - not all requests will create a handle, and
373sometimes more than one is created, so this parameter is only good for
374setting hints.
375
376Example: set the maximum read size to 4096, to potentially conserve memory
377at the cost of speed.
378
379 handle_params => {
380 max_read_size => 4096,
381 },
171 382
172=back 383=back
173 384
174Example: make a simple HTTP GET request for http://www.nethype.de/ 385Example: do a simple HTTP GET request for http://www.nethype.de/ and print
386the response body.
175 387
176 http_request GET => "http://www.nethype.de/", sub { 388 http_request GET => "http://www.nethype.de/", sub {
177 my ($body, $hdr) = @_; 389 my ($body, $hdr) = @_;
178 print "$body\n"; 390 print "$body\n";
179 }; 391 };
180 392
181Example: make a HTTP HEAD request on https://www.google.com/, use a 393Example: do a HTTP HEAD request on https://www.google.com/, use a
182timeout of 30 seconds. 394timeout of 30 seconds.
183 395
184 http_request 396 http_request
185 GET => "https://www.google.com", 397 HEAD => "https://www.google.com",
398 headers => { "user-agent" => "MySearchClient 1.0" },
186 timeout => 30, 399 timeout => 30,
187 sub { 400 sub {
188 my ($body, $hdr) = @_; 401 my ($body, $hdr) = @_;
189 use Data::Dumper; 402 use Data::Dumper;
190 print Dumper $hdr; 403 print Dumper $hdr;
191 } 404 }
192 ; 405 ;
193 406
407Example: do another simple HTTP GET request, but immediately try to
408cancel it.
409
410 my $request = http_request GET => "http://www.nethype.de/", sub {
411 my ($body, $hdr) = @_;
412 print "$body\n";
413 };
414
415 undef $request;
416
194=cut 417=cut
418
419#############################################################################
420# wait queue/slots
195 421
196sub _slot_schedule; 422sub _slot_schedule;
197sub _slot_schedule($) { 423sub _slot_schedule($) {
198 my $host = shift; 424 my $host = shift;
199 425
221 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 447 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
222 448
223 _slot_schedule $_[0]; 449 _slot_schedule $_[0];
224} 450}
225 451
452#############################################################################
453# cookie handling
454
455# expire cookies
456sub cookie_jar_expire($;$) {
457 my ($jar, $session_end) = @_;
458
459 %$jar = () if $jar->{version} != 2;
460
461 my $anow = AE::now;
462
463 while (my ($chost, $paths) = each %$jar) {
464 next unless ref $paths;
465
466 while (my ($cpath, $cookies) = each %$paths) {
467 while (my ($cookie, $kv) = each %$cookies) {
468 if (exists $kv->{_expires}) {
469 delete $cookies->{$cookie}
470 if $anow > $kv->{_expires};
471 } elsif ($session_end) {
472 delete $cookies->{$cookie};
473 }
474 }
475
476 delete $paths->{$cpath}
477 unless %$cookies;
478 }
479
480 delete $jar->{$chost}
481 unless %$paths;
482 }
483}
484
485# extract cookies from jar
486sub cookie_jar_extract($$$$) {
487 my ($jar, $scheme, $host, $path) = @_;
488
489 %$jar = () if $jar->{version} != 2;
490
491 $host = AnyEvent::Util::idn_to_ascii $host
492 if $host =~ /[^\x00-\x7f]/;
493
494 my @cookies;
495
496 while (my ($chost, $paths) = each %$jar) {
497 next unless ref $paths;
498
499 # exact match or suffix including . match
500 $chost eq $host or ".$chost" eq substr $host, -1 - length $chost
501 or next;
502
503 while (my ($cpath, $cookies) = each %$paths) {
504 next unless $cpath eq substr $path, 0, length $cpath;
505
506 while (my ($cookie, $kv) = each %$cookies) {
507 next if $scheme ne "https" && exists $kv->{secure};
508
509 if (exists $kv->{_expires} and AE::now > $kv->{_expires}) {
510 delete $cookies->{$cookie};
511 next;
512 }
513
514 my $value = $kv->{value};
515
516 if ($value =~ /[=;,[:space:]]/) {
517 $value =~ s/([\\"])/\\$1/g;
518 $value = "\"$value\"";
519 }
520
521 push @cookies, "$cookie=$value";
522 }
523 }
524 }
525
526 \@cookies
527}
528
529# parse set_cookie header into jar
530sub cookie_jar_set_cookie($$$$) {
531 my ($jar, $set_cookie, $host, $date) = @_;
532
533 %$jar = () if $jar->{version} != 2;
534
535 my $anow = int AE::now;
536 my $snow; # server-now
537
538 for ($set_cookie) {
539 # parse NAME=VALUE
540 my @kv;
541
542 # expires is not http-compliant in the original cookie-spec,
543 # we support the official date format and some extensions
544 while (
545 m{
546 \G\s*
547 (?:
548 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+)
549 | ([^=;,[:space:]]+) (?: \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^;,[:space:]]*) ) )?
550 )
551 }gcxsi
552 ) {
553 my $name = $2;
554 my $value = $4;
555
556 if (defined $1) {
557 # expires
558 $name = "expires";
559 $value = $1;
560 } elsif (defined $3) {
561 # quoted
562 $value = $3;
563 $value =~ s/\\(.)/$1/gs;
564 }
565
566 push @kv, @kv ? lc $name : $name, $value;
567
568 last unless /\G\s*;/gc;
569 }
570
571 last unless @kv;
572
573 my $name = shift @kv;
574 my %kv = (value => shift @kv, @kv);
575
576 if (exists $kv{"max-age"}) {
577 $kv{_expires} = $anow + delete $kv{"max-age"};
578 } elsif (exists $kv{expires}) {
579 $snow ||= parse_date ($date) || $anow;
580 $kv{_expires} = $anow + (parse_date (delete $kv{expires}) - $snow);
581 } else {
582 delete $kv{_expires};
583 }
584
585 my $cdom;
586 my $cpath = (delete $kv{path}) || "/";
587
588 if (exists $kv{domain}) {
589 $cdom = $kv{domain};
590
591 $cdom =~ s/^\.?/./; # make sure it starts with a "."
592
593 next if $cdom =~ /\.$/;
594
595 # this is not rfc-like and not netscape-like. go figure.
596 my $ndots = $cdom =~ y/.//;
597 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
598
599 $cdom = substr $cdom, 1; # remove initial .
600 } else {
601 $cdom = $host;
602 }
603
604 # store it
605 $jar->{version} = 2;
606 $jar->{lc $cdom}{$cpath}{$name} = \%kv;
607
608 redo if /\G\s*,/gc;
609 }
610}
611
612#############################################################################
613# keepalive/persistent connection cache
614
615# fetch a connection from the keepalive cache
616sub ka_fetch($) {
617 my $ka_key = shift;
618
619 my $hdl = pop @{ $KA_CACHE{$ka_key} }; # currently we reuse the MOST RECENTLY USED connection
620 delete $KA_CACHE{$ka_key}
621 unless @{ $KA_CACHE{$ka_key} };
622
623 $hdl
624}
625
626sub ka_store($$) {
627 my ($ka_key, $hdl) = @_;
628
629 my $kaa = $KA_CACHE{$ka_key} ||= [];
630
631 my $destroy = sub {
632 my @ka = grep $_ != $hdl, @{ $KA_CACHE{$ka_key} };
633
634 $hdl->destroy;
635
636 @ka
637 ? $KA_CACHE{$ka_key} = \@ka
638 : delete $KA_CACHE{$ka_key};
639 };
640
641 # on error etc., destroy
642 $hdl->on_error ($destroy);
643 $hdl->on_eof ($destroy);
644 $hdl->on_read ($destroy);
645 $hdl->timeout ($PERSISTENT_TIMEOUT);
646
647 push @$kaa, $hdl;
648 shift @$kaa while @$kaa > $MAX_PER_HOST;
649}
650
651#############################################################################
652# utilities
653
654# continue to parse $_ for headers and place them into the arg
655sub _parse_hdr() {
656 my %hdr;
657
658 # things seen, not parsed:
659 # p3pP="NON CUR OTPi OUR NOR UNI"
660
661 $hdr{lc $1} .= ",$2"
662 while /\G
663 ([^:\000-\037]*):
664 [\011\040]*
665 ((?: [^\012]+ | \012[\011\040] )*)
666 \012
667 /gxc;
668
669 /\G$/
670 or return;
671
672 # remove the "," prefix we added to all headers above
673 substr $_, 0, 1, ""
674 for values %hdr;
675
676 \%hdr
677}
678
679#############################################################################
680# http_get
681
682our $qr_nlnl = qr{(?<![^\012])\015?\012};
683
684our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
685our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
686
687# maybe it should just become a normal object :/
688
689sub _destroy_state(\%) {
690 my ($state) = @_;
691
692 $state->{handle}->destroy if $state->{handle};
693 %$state = ();
694}
695
696sub _error(\%$$) {
697 my ($state, $cb, $hdr) = @_;
698
699 &_destroy_state ($state);
700
701 $cb->(undef, $hdr);
702 ()
703}
704
705our %IDEMPOTENT = (
706 DELETE => 1,
707 GET => 1,
708 HEAD => 1,
709 OPTIONS => 1,
710 PUT => 1,
711 TRACE => 1,
712
713 ACL => 1,
714 "BASELINE-CONTROL" => 1,
715 BIND => 1,
716 CHECKIN => 1,
717 CHECKOUT => 1,
718 COPY => 1,
719 LABEL => 1,
720 LINK => 1,
721 MERGE => 1,
722 MKACTIVITY => 1,
723 MKCALENDAR => 1,
724 MKCOL => 1,
725 MKREDIRECTREF => 1,
726 MKWORKSPACE => 1,
727 MOVE => 1,
728 ORDERPATCH => 1,
729 PROPFIND => 1,
730 PROPPATCH => 1,
731 REBIND => 1,
732 REPORT => 1,
733 SEARCH => 1,
734 UNBIND => 1,
735 UNCHECKOUT => 1,
736 UNLINK => 1,
737 UNLOCK => 1,
738 UPDATE => 1,
739 UPDATEREDIRECTREF => 1,
740 "VERSION-CONTROL" => 1,
741);
742
226sub http_request($$@) { 743sub http_request($$@) {
227 my $cb = pop; 744 my $cb = pop;
228 my ($method, $url, %arg) = @_; 745 my ($method, $url, %arg) = @_;
229 746
230 my %hdr; 747 my %hdr;
748
749 $arg{tls_ctx} = $TLS_CTX_LOW if $arg{tls_ctx} eq "low" || !exists $arg{tls_ctx};
750 $arg{tls_ctx} = $TLS_CTX_HIGH if $arg{tls_ctx} eq "high";
231 751
232 $method = uc $method; 752 $method = uc $method;
233 753
234 if (my $hdr = $arg{headers}) { 754 if (my $hdr = $arg{headers}) {
235 while (my ($k, $v) = each %$hdr) { 755 while (my ($k, $v) = each %$hdr) {
236 $hdr{lc $k} = $v; 756 $hdr{lc $k} = $v;
237 } 757 }
238 } 758 }
239 759
760 # pseudo headers for all subsequent responses
761 my @pseudo = (URL => $url);
762 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
763
240 my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE; 764 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
241 765
242 return $cb->(undef, { Status => 599, Reason => "recursion limit reached", URL => $url }) 766 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
243 if $recurse < 0; 767 if $recurse < 0;
244 768
245 my $proxy = $arg{proxy} || $PROXY; 769 my $proxy = exists $arg{proxy} ? $arg{proxy} : $PROXY;
246 my $timeout = $arg{timeout} || $TIMEOUT; 770 my $timeout = $arg{timeout} || $TIMEOUT;
247 771
248 $hdr{"user-agent"} ||= $USERAGENT;
249
250 my ($scheme, $authority, $upath, $query, $fragment) = 772 my ($uscheme, $uauthority, $upath, $query, undef) = # ignore fragment
251 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 773 $url =~ m|^([^:]+):(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?$|;
252 774
253 $scheme = lc $scheme; 775 $uscheme = lc $uscheme;
254 776
255 my $uport = $scheme eq "http" ? 80 777 my $uport = $uscheme eq "http" ? 80
256 : $scheme eq "https" ? 443 778 : $uscheme eq "https" ? 443
257 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported", URL => $url }); 779 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
258 780
259 $hdr{referer} ||= "$scheme://$authority$upath"; # leave out fragment and query string, just a heuristic
260
261 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 781 $uauthority =~ /^(?: .*\@ )? ([^\@]+?) (?: : (\d+) )?$/x
262 or return $cb->(undef, { Status => 599, Reason => "unparsable URL", URL => $url }); 782 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
263 783
264 my $uhost = $1; 784 my $uhost = lc $1;
265 $uport = $2 if defined $2; 785 $uport = $2 if defined $2;
266 786
787 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
788 unless exists $hdr{host};
789
267 $uhost =~ s/^\[(.*)\]$/$1/; 790 $uhost =~ s/^\[(.*)\]$/$1/;
268 $upath .= "?$query" if length $query; 791 $upath .= $query if length $query;
269 792
270 $upath =~ s%^/?%/%; 793 $upath =~ s%^/?%/%;
271 794
272 # cookie processing 795 # cookie processing
273 if (my $jar = $arg{cookie_jar}) { 796 if (my $jar = $arg{cookie_jar}) {
274 %$jar = () if $jar->{version} < 1; 797 my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;
275 798
799 $hdr{cookie} = join "; ", @$cookies
276 my @cookie; 800 if @$cookies;
277 801 }
278 while (my ($chost, $v) = each %$jar) { 802
279 next unless $chost eq substr $uhost, -length $chost; 803 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
280 next unless $chost =~ /^\./; 804
281 805 if ($proxy) {
282 while (my ($cpath, $v) = each %$v) { 806 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
283 next unless $cpath eq substr $upath, 0, length $cpath; 807
284 808 $rscheme = "http" unless defined $rscheme;
285 while (my ($k, $v) = each %$v) { 809
286 next if $scheme ne "https" && exists $v->{secure}; 810 # don't support https requests over https-proxy transport,
287 push @cookie, "$k=$v->{value}"; 811 # can't be done with tls as spec'ed, unless you double-encrypt.
812 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
813
814 $rhost = lc $rhost;
815 $rscheme = lc $rscheme;
816 } else {
817 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
818 }
819
820 # leave out fragment and query string, just a heuristic
821 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
822 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
823
824 $hdr{"content-length"} = length $arg{body}
825 if length $arg{body} || $method ne "GET";
826
827 my $idempotent = $IDEMPOTENT{$method};
828
829 # default value for keepalive is true iff the request is for an idempotent method
830 my $persistent = exists $arg{persistent} ? !!$arg{persistent} : $idempotent;
831 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : !$proxy;
832 my $was_persistent; # true if this is actually a recycled connection
833
834 # the key to use in the keepalive cache
835 my $ka_key = "$uscheme\x00$uhost\x00$uport\x00$arg{sessionid}";
836
837 $hdr{connection} = ($persistent ? $keepalive ? "keep-alive, " : "" : "close, ") . "Te"; #1.1
838 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
839
840 my %state = (connect_guard => 1);
841
842 my $ae_error = 595; # connecting
843
844 # handle actual, non-tunneled, request
845 my $handle_actual_request = sub {
846 $ae_error = 596; # request phase
847
848 my $hdl = $state{handle};
849
850 $hdl->starttls ("connect") if $uscheme eq "https" && !exists $hdl->{tls};
851
852 # send request
853 $hdl->push_write (
854 "$method $rpath HTTP/1.1\015\012"
855 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
856 . "\015\012"
857 . $arg{body}
858 );
859
860 # return if error occurred during push_write()
861 return unless %state;
862
863 # reduce memory usage, save a kitten, also re-use it for the response headers.
864 %hdr = ();
865
866 # status line and headers
867 $state{read_response} = sub {
868 return unless %state;
869
870 for ("$_[1]") {
871 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
872
873 /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
874 or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid server response" };
875
876 # 100 Continue handling
877 # should not happen as we don't send expect: 100-continue,
878 # but we handle it just in case.
879 # since we send the request body regardless, if we get an error
880 # we are out of-sync, which we currently do NOT handle correctly.
881 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
882 if $2 eq 100;
883
884 push @pseudo,
885 HTTPVersion => $1,
886 Status => $2,
887 Reason => $3,
888 ;
889
890 my $hdr = _parse_hdr
891 or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Garbled response headers" };
892
893 %hdr = (%$hdr, @pseudo);
894 }
895
896 # redirect handling
897 # relative uri handling forced by microsoft and other shitheads.
898 # we give our best and fall back to URI if available.
899 if (exists $hdr{location}) {
900 my $loc = $hdr{location};
901
902 if ($loc =~ m%^//%) { # //
903 $loc = "$uscheme:$loc";
904
905 } elsif ($loc eq "") {
906 $loc = $url;
907
908 } elsif ($loc !~ /^(?: $ | [^:\/?\#]+ : )/x) { # anything "simple"
909 $loc =~ s/^\.\/+//;
910
911 if ($loc !~ m%^[.?#]%) {
912 my $prefix = "$uscheme://$uauthority";
913
914 unless ($loc =~ s/^\///) {
915 $prefix .= $upath;
916 $prefix =~ s/\/[^\/]*$//;
917 }
918
919 $loc = "$prefix/$loc";
920
921 } elsif (eval { require URI }) { # uri
922 $loc = URI->new_abs ($loc, $url)->as_string;
923
924 } else {
925 return _error %state, $cb, { @pseudo, Status => 599, Reason => "Cannot parse Location (URI module missing)" };
926 #$hdr{Status} = 599;
927 #$hdr{Reason} = "Unparsable Redirect (URI module missing)";
928 #$recurse = 0;
929 }
930 }
931
932 $hdr{location} = $loc;
933 }
934
935 my $redirect;
936
937 if ($recurse) {
938 my $status = $hdr{Status};
939
940 # industry standard is to redirect POST as GET for
941 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
942 # also, the UA should ask the user for 301 and 307 and POST,
943 # industry standard seems to be to simply follow.
944 # we go with the industry standard. 308 is defined
945 # by rfc7538
946 if ($status == 301 or $status == 302 or $status == 303) {
947 $redirect = 1;
948 # HTTP/1.1 is unclear on how to mutate the method
949 unless ($method eq "HEAD") {
950 $method = "GET";
951 delete $arg{body};
952 }
953 } elsif ($status == 307 or $status == 308) {
954 $redirect = 1;
288 } 955 }
289 } 956 }
957
958 my $finish = sub { # ($data, $err_status, $err_reason[, $persistent])
959 if ($state{handle}) {
960 # handle keepalive
961 if (
962 $persistent
963 && $_[3]
964 && ($hdr{HTTPVersion} < 1.1
965 ? $hdr{connection} =~ /\bkeep-?alive\b/i
966 : $hdr{connection} !~ /\bclose\b/i)
967 ) {
968 ka_store $ka_key, delete $state{handle};
969 } else {
970 # no keepalive, destroy the handle
971 $state{handle}->destroy;
972 }
973 }
974
975 %state = ();
976
977 if (defined $_[1]) {
978 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
979 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
980 }
981
982 # set-cookie processing
983 if ($arg{cookie_jar}) {
984 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost, $hdr{date};
985 }
986
987 if ($redirect && exists $hdr{location}) {
988 # we ignore any errors, as it is very common to receive
989 # Content-Length != 0 but no actual body
990 # we also access %hdr, as $_[1] might be an erro
991 $state{recurse} =
992 http_request (
993 $method => $hdr{location},
994 %arg,
995 recurse => $recurse - 1,
996 Redirect => [$_[0], \%hdr],
997 sub {
998 %state = ();
999 &$cb
1000 },
1001 );
1002 } else {
1003 $cb->($_[0], \%hdr);
1004 }
1005 };
1006
1007 $ae_error = 597; # body phase
1008
1009 my $chunked = $hdr{"transfer-encoding"} =~ /\bchunked\b/i; # not quite correct...
1010
1011 my $len = $chunked ? undef : $hdr{"content-length"};
1012
1013 # body handling, many different code paths
1014 # - no body expected
1015 # - want_body_handle
1016 # - te chunked
1017 # - 2x length known (with or without on_body)
1018 # - 2x length not known (with or without on_body)
1019 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
1020 $finish->(undef, 598 => "Request cancelled by on_header");
1021 } elsif (
1022 $hdr{Status} =~ /^(?:1..|204|205|304)$/
1023 or $method eq "HEAD"
1024 or (defined $len && $len == 0) # == 0, not !, because "0 " is true
1025 ) {
1026 # no body
1027 $finish->("", undef, undef, 1);
1028
1029 } elsif (!$redirect && $arg{want_body_handle}) {
1030 $_[0]->on_eof (undef);
1031 $_[0]->on_error (undef);
1032 $_[0]->on_read (undef);
1033
1034 $finish->(delete $state{handle});
1035
1036 } elsif ($chunked) {
1037 my $cl = 0;
1038 my $body = "";
1039 my $on_body = (!$redirect && $arg{on_body}) || sub { $body .= shift; 1 };
1040
1041 $state{read_chunk} = sub {
1042 $_[1] =~ /^([0-9a-fA-F]+)/
1043 or return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
1044
1045 my $len = hex $1;
1046
1047 if ($len) {
1048 $cl += $len;
1049
1050 $_[0]->push_read (chunk => $len, sub {
1051 $on_body->($_[1], \%hdr)
1052 or return $finish->(undef, 598 => "Request cancelled by on_body");
1053
1054 $_[0]->push_read (line => sub {
1055 length $_[1]
1056 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
1057 $_[0]->push_read (line => $state{read_chunk});
1058 });
1059 });
1060 } else {
1061 $hdr{"content-length"} ||= $cl;
1062
1063 $_[0]->push_read (line => $qr_nlnl, sub {
1064 if (length $_[1]) {
1065 for ("$_[1]") {
1066 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
1067
1068 my $hdr = _parse_hdr
1069 or return $finish->(undef, $ae_error => "Garbled response trailers");
1070
1071 %hdr = (%hdr, %$hdr);
1072 }
1073 }
1074
1075 $finish->($body, undef, undef, 1);
1076 });
1077 }
1078 };
1079
1080 $_[0]->push_read (line => $state{read_chunk});
1081
1082 } elsif (!$redirect && $arg{on_body}) {
1083 if (defined $len) {
1084 $_[0]->on_read (sub {
1085 $len -= length $_[0]{rbuf};
1086
1087 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
1088 or return $finish->(undef, 598 => "Request cancelled by on_body");
1089
1090 $len > 0
1091 or $finish->("", undef, undef, 1);
1092 });
1093 } else {
1094 $_[0]->on_eof (sub {
1095 $finish->("");
1096 });
1097 $_[0]->on_read (sub {
1098 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
1099 or $finish->(undef, 598 => "Request cancelled by on_body");
1100 });
1101 }
1102 } else {
1103 $_[0]->on_eof (undef);
1104
1105 if (defined $len) {
1106 $_[0]->on_read (sub {
1107 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
1108 if $len <= length $_[0]{rbuf};
1109 });
1110 } else {
1111 $_[0]->on_error (sub {
1112 ($! == Errno::EPIPE || !$!)
1113 ? $finish->(delete $_[0]{rbuf})
1114 : $finish->(undef, $ae_error => $_[2]);
1115 });
1116 $_[0]->on_read (sub { });
1117 }
1118 }
1119 };
1120
1121 # if keepalive is enabled, then the server closing the connection
1122 # before a response can happen legally - we retry on idempotent methods.
1123 if ($was_persistent && $idempotent) {
1124 my $old_eof = $hdl->{on_eof};
1125 $hdl->{on_eof} = sub {
1126 _destroy_state %state;
1127
1128 %state = ();
1129 $state{recurse} =
1130 http_request (
1131 $method => $url,
1132 %arg,
1133 recurse => $recurse - 1,
1134 persistent => 0,
1135 sub {
1136 %state = ();
1137 &$cb
1138 }
1139 );
1140 };
1141 $hdl->on_read (sub {
1142 return unless %state;
1143
1144 # as soon as we receive something, a connection close
1145 # once more becomes a hard error
1146 $hdl->{on_eof} = $old_eof;
1147 $hdl->push_read (line => $qr_nlnl, $state{read_response});
1148 });
1149 } else {
1150 $hdl->push_read (line => $qr_nlnl, $state{read_response});
290 } 1151 }
291
292 $hdr{cookie} = join "; ", @cookie
293 if @cookie;
294 } 1152 };
295 1153
296 my ($rhost, $rport, $rpath); # request host, port, path 1154 my $prepare_handle = sub {
1155 my ($hdl) = $state{handle};
297 1156
298 if ($proxy) { 1157 $hdl->on_error (sub {
299 ($rhost, $rport, $scheme) = @$proxy; 1158 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] };
300 $rpath = $url; 1159 });
301 } else { 1160 $hdl->on_eof (sub {
302 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath); 1161 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" };
303 $hdr{host} = $uhost; 1162 });
1163 $hdl->timeout_reset;
1164 $hdl->timeout ($timeout);
304 } 1165 };
305 1166
306 $hdr{"content-length"} = length $arg{body}; 1167 # connected to proxy (or origin server)
1168 my $connect_cb = sub {
1169 my $fh = shift
1170 or return _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "$!" };
307 1171
308 my %state = (connect_guard => 1); 1172 return unless delete $state{connect_guard};
1173
1174 # get handle
1175 $state{handle} = new AnyEvent::Handle
1176 %{ $arg{handle_params} },
1177 fh => $fh,
1178 peername => $uhost,
1179 tls_ctx => $arg{tls_ctx},
1180 ;
1181
1182 $prepare_handle->();
1183
1184 #$state{handle}->starttls ("connect") if $rscheme eq "https";
1185
1186 # now handle proxy-CONNECT method
1187 if ($proxy && $uscheme eq "https") {
1188 # oh dear, we have to wrap it into a connect request
1189
1190 my $auth = exists $hdr{"proxy-authorization"}
1191 ? "proxy-authorization: " . (delete $hdr{"proxy-authorization"}) . "\015\012"
1192 : "";
1193
1194 # maybe re-use $uauthority with patched port?
1195 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012$auth\015\012");
1196 $state{handle}->push_read (line => $qr_nlnl, sub {
1197 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
1198 or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" };
1199
1200 if ($2 == 200) {
1201 $rpath = $upath;
1202 $handle_actual_request->();
1203 } else {
1204 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 };
1205 }
1206 });
1207 } else {
1208 delete $hdr{"proxy-authorization"} unless $proxy;
1209
1210 $handle_actual_request->();
1211 }
1212 };
309 1213
310 _get_slot $uhost, sub { 1214 _get_slot $uhost, sub {
311 $state{slot_guard} = shift; 1215 $state{slot_guard} = shift;
312 1216
313 return unless $state{connect_guard}; 1217 return unless $state{connect_guard};
314 1218
315 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 1219 # try to use an existing keepalive connection, but only if we, ourselves, plan
316 $state{fh} = shift 1220 # on a keepalive request (in theory, this should be a separate config option).
317 or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url }); 1221 if ($persistent && $KA_CACHE{$ka_key}) {
1222 $was_persistent = 1;
318 1223
319 delete $state{connect_guard}; # reduce memory usage, save a tree 1224 $state{handle} = ka_fetch $ka_key;
1225# $state{handle}->destroyed
1226# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (1), please report.";#d#
1227 $prepare_handle->();
1228# $state{handle}->destroyed
1229# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (2), please report.";#d#
1230 $handle_actual_request->();
320 1231
321 # get handle
322 $state{handle} = new AnyEvent::Handle
323 fh => $state{fh},
324 ($scheme eq "https" ? (tls => "connect") : ());
325
326 # limit the number of persistent connections
327 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
328 ++$KA_COUNT{$_[1]};
329 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} };
330 $hdr{connection} = "keep-alive";
331 delete $hdr{connection}; # keep-alive not yet supported
332 } else { 1232 } else {
333 delete $hdr{connection}; 1233 my $tcp_connect = $arg{tcp_connect}
334 } 1234 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
335 1235
336 # (re-)configure handle 1236 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
337 $state{handle}->timeout ($timeout);
338 $state{handle}->on_error (sub {
339 my $errno = "$!";
340 %state = ();
341 $cb->(undef, { Status => 599, Reason => $errno, URL => $url });
342 });
343 $state{handle}->on_eof (sub {
344 %state = ();
345 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file", URL => $url });
346 });
347
348 # send request
349 $state{handle}->push_write (
350 "$method $rpath HTTP/1.0\015\012"
351 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
352 . "\015\012"
353 . (delete $arg{body})
354 );
355
356 %hdr = (); # reduce memory usage, save a kitten
357
358 # status line
359 $state{handle}->push_read (line => qr/\015?\012/, sub {
360 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
361 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url }));
362
363 my %hdr = ( # response headers
364 HTTPVersion => "\x00$1",
365 Status => "\x00$2",
366 Reason => "\x00$3",
367 URL => "\x00$url"
368 );
369
370 # headers, could be optimized a bit
371 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
372 for ("$_[1]\012") {
373 # we support spaces in field names, as lotus domino
374 # creates them.
375 $hdr{lc $1} .= "\x00$2"
376 while /\G
377 ([^:\000-\037]+):
378 [\011\040]*
379 ((?: [^\015\012]+ | \015?\012[\011\040] )*)
380 \015?\012
381 /gxc;
382
383 /\G$/
384 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers", URL => $url }));
385 }
386
387 substr $_, 0, 1, ""
388 for values %hdr;
389
390 my $finish = sub {
391 %state = ();
392
393 # set-cookie processing
394 if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
395 for (split /\x00/, $hdr{"set-cookie"}) {
396 my ($cookie, @arg) = split /;\s*/;
397 my ($name, $value) = split /=/, $cookie, 2;
398 my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
399
400 my $cdom = (delete $kv{domain}) || $uhost;
401 my $cpath = (delete $kv{path}) || "/";
402
403 $cdom =~ s/^.?/./; # make sure it starts with a "."
404
405 next if $cdom =~ /\.$/;
406
407 # this is not rfc-like and not netscape-like. go figure.
408 my $ndots = $cdom =~ y/.//;
409 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
410
411 # store it
412 $arg{cookie_jar}{version} = 1;
413 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
414 }
415 }
416
417 if ($_[1]{Status} =~ /^30[12]$/ && $recurse) {
418 # microsoft and other assholes don't give a shit for following standards,
419 # try to support a common form of broken Location header.
420 $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
421
422 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
423 } else {
424 $cb->($_[0], $_[1]);
425 }
426 };
427
428 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") {
429 $finish->(undef, \%hdr);
430 } else {
431 if (exists $hdr{"content-length"}) {
432 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
433 # could cache persistent connection now
434 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
435 # but we don't, due to misdesigns, this is annoyingly complex
436 };
437
438 $finish->($_[1], \%hdr);
439 });
440 } else {
441 # too bad, need to read until we get an error or EOF,
442 # no way to detect winged data.
443 $_[0]->on_error (sub {
444 $finish->($_[0]{rbuf}, \%hdr);
445 });
446 $_[0]->on_eof (undef);
447 $_[0]->on_read (sub { });
448 }
449 }
450 });
451 });
452 }, sub {
453 $timeout
454 }; 1237 }
455 }; 1238 };
456 1239
457 defined wantarray && AnyEvent::Util::guard { %state = () } 1240 defined wantarray && AnyEvent::Util::guard { _destroy_state %state }
458} 1241}
459 1242
460sub http_get($@) { 1243sub http_get($@) {
461 unshift @_, "GET"; 1244 unshift @_, "GET";
462 &http_request 1245 &http_request
473 &http_request 1256 &http_request
474} 1257}
475 1258
476=back 1259=back
477 1260
1261=head2 DNS CACHING
1262
1263AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
1264the actual connection, which in turn uses AnyEvent::DNS to resolve
1265hostnames. The latter is a simple stub resolver and does no caching
1266on its own. If you want DNS caching, you currently have to provide
1267your own default resolver (by storing a suitable resolver object in
1268C<$AnyEvent::DNS::RESOLVER>) or your own C<tcp_connect> callback.
1269
478=head2 GLOBAL FUNCTIONS AND VARIABLES 1270=head2 GLOBAL FUNCTIONS AND VARIABLES
479 1271
480=over 4 1272=over 4
481 1273
482=item AnyEvent::HTTP::set_proxy "proxy-url" 1274=item AnyEvent::HTTP::set_proxy "proxy-url"
483 1275
484Sets the default proxy server to use. The proxy-url must begin with a 1276Sets the default proxy server to use. The proxy-url must begin with a
485string of the form C<http://host:port> (optionally C<https:...>). 1277string of the form C<http://host:port>, croaks otherwise.
1278
1279To clear an already-set proxy, use C<undef>.
1280
1281When AnyEvent::HTTP is loaded for the first time it will query the
1282default proxy from the operating system, currently by looking at
1283C<$ENV{http_proxy>}.
1284
1285=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
1286
1287Remove all cookies from the cookie jar that have been expired. If
1288C<$session_end> is given and true, then additionally remove all session
1289cookies.
1290
1291You should call this function (with a true C<$session_end>) before you
1292save cookies to disk, and you should call this function after loading them
1293again. If you have a long-running program you can additionally call this
1294function from time to time.
1295
1296A cookie jar is initially an empty hash-reference that is managed by this
1297module. Its format is subject to change, but currently it is as follows:
1298
1299The key C<version> has to contain C<2>, otherwise the hash gets
1300cleared. All other keys are hostnames or IP addresses pointing to
1301hash-references. The key for these inner hash references is the
1302server path for which this cookie is meant, and the values are again
1303hash-references. Each key of those hash-references is a cookie name, and
1304the value, you guessed it, is another hash-reference, this time with the
1305key-value pairs from the cookie, except for C<expires> and C<max-age>,
1306which have been replaced by a C<_expires> key that contains the cookie
1307expiry timestamp. Session cookies are indicated by not having an
1308C<_expires> key.
1309
1310Here is an example of a cookie jar with a single cookie, so you have a
1311chance of understanding the above paragraph:
1312
1313 {
1314 version => 1,
1315 "10.0.0.1" => {
1316 "/" => {
1317 "mythweb_id" => {
1318 _expires => 1293917923,
1319 value => "ooRung9dThee3ooyXooM1Ohm",
1320 },
1321 },
1322 },
1323 }
1324
1325=item $date = AnyEvent::HTTP::format_date $timestamp
1326
1327Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
1328Date (RFC 2616).
1329
1330=item $timestamp = AnyEvent::HTTP::parse_date $date
1331
1332Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) or a
1333bunch of minor variations of those, and returns the corresponding POSIX
1334timestamp, or C<undef> if the date cannot be parsed.
486 1335
487=item $AnyEvent::HTTP::MAX_RECURSE 1336=item $AnyEvent::HTTP::MAX_RECURSE
488 1337
489The default value for the C<recurse> request parameter (default: C<10>). 1338The default value for the C<recurse> request parameter (default: C<10>).
490 1339
1340=item $AnyEvent::HTTP::TIMEOUT
1341
1342The default timeout for connection operations (default: C<300>).
1343
491=item $AnyEvent::HTTP::USERAGENT 1344=item $AnyEvent::HTTP::USERAGENT
492 1345
493The default value for the C<User-Agent> header (the default is 1346The default value for the C<User-Agent> header (the default is
494C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 1347C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
495 1348
496=item $AnyEvent::HTTP::MAX_PERSISTENT 1349=item $AnyEvent::HTTP::MAX_PER_HOST
497 1350
498The maximum number of persistent connections to keep open (default: 8). 1351The maximum number of concurrent connections to the same host (identified
1352by the hostname). If the limit is exceeded, then additional requests
1353are queued until previous connections are closed. Both persistent and
1354non-persistent connections are counted in this limit.
499 1355
500Not implemented currently. 1356The default value for this is C<4>, and it is highly advisable to not
1357increase it much.
1358
1359For comparison: the RFC's recommend 4 non-persistent or 2 persistent
1360connections, older browsers used 2, newer ones (such as firefox 3)
1361typically use 6, and Opera uses 8 because like, they have the fastest
1362browser and give a shit for everybody else on the planet.
501 1363
502=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 1364=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
503 1365
504The maximum time to cache a persistent connection, in seconds (default: 2). 1366The time after which idle persistent connections get closed by
505 1367AnyEvent::HTTP (default: C<3>).
506Not implemented currently.
507 1368
508=item $AnyEvent::HTTP::ACTIVE 1369=item $AnyEvent::HTTP::ACTIVE
509 1370
510The number of active connections. This is not the number of currently 1371The number of active connections. This is not the number of currently
511running requests, but the number of currently open and non-idle TCP 1372running requests, but the number of currently open and non-idle TCP
512connections. This number of can be useful for load-leveling. 1373connections. This number can be useful for load-leveling.
513 1374
514=back 1375=back
515 1376
516=cut 1377=cut
517 1378
1379our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
1380our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
1381
1382sub format_date($) {
1383 my ($time) = @_;
1384
1385 # RFC 822/1123 format
1386 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
1387
1388 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
1389 $weekday[$wday], $mday, $month[$mon], $year + 1900,
1390 $H, $M, $S;
1391}
1392
1393sub parse_date($) {
1394 my ($date) = @_;
1395
1396 my ($d, $m, $y, $H, $M, $S);
1397
1398 if ($date =~ /^[A-Z][a-z][a-z]+, ([0-9][0-9]?)[\- ]([A-Z][a-z][a-z])[\- ]([0-9][0-9][0-9][0-9]) ([0-9][0-9]?):([0-9][0-9]?):([0-9][0-9]?) GMT$/) {
1399 # RFC 822/1123, required by RFC 2616 (with " ")
1400 # cookie dates (with "-")
1401
1402 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
1403
1404 } elsif ($date =~ /^[A-Z][a-z][a-z]+, ([0-9][0-9]?)-([A-Z][a-z][a-z])-([0-9][0-9]) ([0-9][0-9]?):([0-9][0-9]?):([0-9][0-9]?) GMT$/) {
1405 # RFC 850
1406 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
1407
1408 } elsif ($date =~ /^[A-Z][a-z][a-z]+ ([A-Z][a-z][a-z]) ([0-9 ]?[0-9]) ([0-9][0-9]?):([0-9][0-9]?):([0-9][0-9]?) ([0-9][0-9][0-9][0-9])$/) {
1409 # ISO C's asctime
1410 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
1411 }
1412 # other formats fail in the loop below
1413
1414 for (0..11) {
1415 if ($m eq $month[$_]) {
1416 require Time::Local;
1417 return eval { Time::Local::timegm ($S, $M, $H, $d, $_, $y) };
1418 }
1419 }
1420
1421 undef
1422}
1423
518sub set_proxy($) { 1424sub set_proxy($) {
519 $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix; 1425 if (length $_[0]) {
1426 $_[0] =~ m%^(http):// ([^:/]+) (?: : (\d*) )?%ix
1427 or Carp::croak "$_[0]: invalid proxy URL";
1428 $PROXY = [$2, $3 || 3128, $1]
1429 } else {
1430 undef $PROXY;
1431 }
520} 1432}
521 1433
522# initialise proxy from environment 1434# initialise proxy from environment
1435eval {
523set_proxy $ENV{http_proxy}; 1436 set_proxy $ENV{http_proxy};
1437};
1438
1439=head2 SHOWCASE
1440
1441This section contains some more elaborate "real-world" examples or code
1442snippets.
1443
1444=head2 HTTP/1.1 FILE DOWNLOAD
1445
1446Downloading files with HTTP can be quite tricky, especially when something
1447goes wrong and you want to resume.
1448
1449Here is a function that initiates and resumes a download. It uses the
1450last modified time to check for file content changes, and works with many
1451HTTP/1.0 servers as well, and usually falls back to a complete re-download
1452on older servers.
1453
1454It calls the completion callback with either C<undef>, which means a
1455nonretryable error occurred, C<0> when the download was partial and should
1456be retried, and C<1> if it was successful.
1457
1458 use AnyEvent::HTTP;
1459
1460 sub download($$$) {
1461 my ($url, $file, $cb) = @_;
1462
1463 open my $fh, "+<", $file
1464 or die "$file: $!";
1465
1466 my %hdr;
1467 my $ofs = 0;
1468
1469 if (stat $fh and -s _) {
1470 $ofs = -s _;
1471 warn "-s is ", $ofs;
1472 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9];
1473 $hdr{"range"} = "bytes=$ofs-";
1474 }
1475
1476 http_get $url,
1477 headers => \%hdr,
1478 on_header => sub {
1479 my ($hdr) = @_;
1480
1481 if ($hdr->{Status} == 200 && $ofs) {
1482 # resume failed
1483 truncate $fh, $ofs = 0;
1484 }
1485
1486 sysseek $fh, $ofs, 0;
1487
1488 1
1489 },
1490 on_body => sub {
1491 my ($data, $hdr) = @_;
1492
1493 if ($hdr->{Status} =~ /^2/) {
1494 length $data == syswrite $fh, $data
1495 or return; # abort on write errors
1496 }
1497
1498 1
1499 },
1500 sub {
1501 my (undef, $hdr) = @_;
1502
1503 my $status = $hdr->{Status};
1504
1505 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) {
1506 utime $time, $time, $fh;
1507 }
1508
1509 if ($status == 200 || $status == 206 || $status == 416) {
1510 # download ok || resume ok || file already fully downloaded
1511 $cb->(1, $hdr);
1512
1513 } elsif ($status == 412) {
1514 # file has changed while resuming, delete and retry
1515 unlink $file;
1516 $cb->(0, $hdr);
1517
1518 } elsif ($status == 500 or $status == 503 or $status =~ /^59/) {
1519 # retry later
1520 $cb->(0, $hdr);
1521
1522 } else {
1523 $cb->(undef, $hdr);
1524 }
1525 }
1526 ;
1527 }
1528
1529 download "http://server/somelargefile", "/tmp/somelargefile", sub {
1530 if ($_[0]) {
1531 print "OK!\n";
1532 } elsif (defined $_[0]) {
1533 print "please retry later\n";
1534 } else {
1535 print "ERROR\n";
1536 }
1537 };
1538
1539=head3 SOCKS PROXIES
1540
1541Socks proxies are not directly supported by AnyEvent::HTTP. You can
1542compile your perl to support socks, or use an external program such as
1543F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
1544transparently.
1545
1546Alternatively, for AnyEvent::HTTP only, you can use your own
1547C<tcp_connect> function that does the proxy handshake - here is an example
1548that works with socks4a proxies:
1549
1550 use Errno;
1551 use AnyEvent::Util;
1552 use AnyEvent::Socket;
1553 use AnyEvent::Handle;
1554
1555 # host, port and username of/for your socks4a proxy
1556 my $socks_host = "10.0.0.23";
1557 my $socks_port = 9050;
1558 my $socks_user = "";
1559
1560 sub socks4a_connect {
1561 my ($host, $port, $connect_cb, $prepare_cb) = @_;
1562
1563 my $hdl = new AnyEvent::Handle
1564 connect => [$socks_host, $socks_port],
1565 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
1566 on_error => sub { $connect_cb->() },
1567 ;
1568
1569 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
1570
1571 $hdl->push_read (chunk => 8, sub {
1572 my ($hdl, $chunk) = @_;
1573 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
1574
1575 if ($status == 0x5a) {
1576 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
1577 } else {
1578 $! = Errno::ENXIO; $connect_cb->();
1579 }
1580 });
1581
1582 $hdl
1583 }
1584
1585Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
1586possibly after switching off other proxy types:
1587
1588 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
1589
1590 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
1591 my ($data, $headers) = @_;
1592 ...
1593 };
524 1594
525=head1 SEE ALSO 1595=head1 SEE ALSO
526 1596
527L<AnyEvent>. 1597L<AnyEvent>.
528 1598
529=head1 AUTHOR 1599=head1 AUTHOR
530 1600
531 Marc Lehmann <schmorp@schmorp.de> 1601 Marc Lehmann <schmorp@schmorp.de>
532 http://home.schmorp.de/ 1602 http://home.schmorp.de/
533 1603
1604With many thanks to Дмитрий Шалашов, who provided countless
1605testcases and bugreports.
1606
534=cut 1607=cut
535 1608
5361 16091
537 1610

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines