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.121 by root, Tue Apr 7 01:18:20 2015 UTC vs.
Revision 1.129 by root, Thu Aug 30 00:08:16 2018 UTC

… …
46use AnyEvent::Util (); 46use AnyEvent::Util ();
47use AnyEvent::Handle (); 47use AnyEvent::Handle ();
48 48
49use base Exporter::; 49use base Exporter::;
50 50
51our $VERSION = 2.21; 51our $VERSION = 2.25;
52 52
53our @EXPORT = qw(http_get http_post http_head http_request); 53our @EXPORT = qw(http_get http_post http_head http_request);
54 54
55our $USERAGENT = "Mozilla/5.0 (compatible; U; 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)";
56our $MAX_RECURSE = 10; 56our $MAX_RECURSE = 10;
… …
194 194
195C<$scheme> must be either missing or must be C<http> for HTTP. 195C<$scheme> must be either missing or must be C<http> for HTTP.
196 196
197If not specified, then the default proxy is used (see 197If not specified, then the default proxy is used (see
198C<AnyEvent::HTTP::set_proxy>). 198C<AnyEvent::HTTP::set_proxy>).
199
200Currently, if your proxy requires authorization, you have to specify an
201appropriate "Proxy-Authorization" header in every request.
199 202
200=item body => $string 203=item body => $string
201 204
202The 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
203this module might offer more options). 206this module might offer more options).
… …
770 773
771 my $uport = $uscheme eq "http" ? 80 774 my $uport = $uscheme eq "http" ? 80
772 : $uscheme eq "https" ? 443 775 : $uscheme eq "https" ? 443
773 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" }); 776 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
774 777
775 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 778 $uauthority =~ /^(?: .*\@ )? ([^\@]+?) (?: : (\d+) )?$/x
776 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" }); 779 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
777 780
778 my $uhost = lc $1; 781 my $uhost = lc $1;
779 $uport = $2 if defined $2; 782 $uport = $2 if defined $2;
780 783
… …
892 # we give our best and fall back to URI if available. 895 # we give our best and fall back to URI if available.
893 if (exists $hdr{location}) { 896 if (exists $hdr{location}) {
894 my $loc = $hdr{location}; 897 my $loc = $hdr{location};
895 898
896 if ($loc =~ m%^//%) { # // 899 if ($loc =~ m%^//%) { # //
897 $loc = "$rscheme:$loc"; 900 $loc = "$uscheme:$loc";
898 901
899 } elsif ($loc eq "") { 902 } elsif ($loc eq "") {
900 $loc = $url; 903 $loc = $url;
901 904
902 } elsif ($loc !~ /^(?: $ | [^:\/?\#]+ : )/x) { # anything "simple" 905 } elsif ($loc !~ /^(?: $ | [^:\/?\#]+ : )/x) { # anything "simple"
903 $loc =~ s/^\.\/+//; 906 $loc =~ s/^\.\/+//;
904 907
905 if ($loc !~ m%^[.?#]%) { 908 if ($loc !~ m%^[.?#]%) {
906 my $prefix = "$rscheme://$uhost:$uport"; 909 my $prefix = "$uscheme://$uauthority";
907 910
908 unless ($loc =~ s/^\///) { 911 unless ($loc =~ s/^\///) {
909 $prefix .= $upath; 912 $prefix .= $upath;
910 $prefix =~ s/\/[^\/]*$//; 913 $prefix =~ s/\/[^\/]*$//;
911 } 914 }
… …
936 # also, the UA should ask the user for 301 and 307 and POST, 939 # also, the UA should ask the user for 301 and 307 and POST,
937 # industry standard seems to be to simply follow. 940 # industry standard seems to be to simply follow.
938 # we go with the industry standard. 308 is defined 941 # we go with the industry standard. 308 is defined
939 # by rfc7538 942 # by rfc7538
940 if ($status == 301 or $status == 302 or $status == 303) { 943 if ($status == 301 or $status == 302 or $status == 303) {
944 $redirect = 1;
941 # HTTP/1.1 is unclear on how to mutate the method 945 # HTTP/1.1 is unclear on how to mutate the method
942 $method = "GET" unless $method eq "HEAD"; 946 unless ($method eq "HEAD") {
943 $redirect = 1; 947 $method = "GET";
948 delete $arg{body};
949 }
944 } elsif ($status == 307 or $status == 308) { 950 } elsif ($status == 307 or $status == 308) {
945 $redirect = 1; 951 $redirect = 1;
946 } 952 }
947 } 953 }
948 954
… …
1025 $finish->(delete $state{handle}); 1031 $finish->(delete $state{handle});
1026 1032
1027 } elsif ($chunked) { 1033 } elsif ($chunked) {
1028 my $cl = 0; 1034 my $cl = 0;
1029 my $body = ""; 1035 my $body = "";
1030 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 1036 my $on_body = (!$redirect && $arg{on_body}) || sub { $body .= shift; 1 };
1031 1037
1032 $state{read_chunk} = sub { 1038 $state{read_chunk} = sub {
1033 $_[1] =~ /^([0-9a-fA-F]+)/ 1039 $_[1] =~ /^([0-9a-fA-F]+)/
1034 or return $finish->(undef, $ae_error => "Garbled chunked transfer encoding"); 1040 or return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
1035 1041
… …
1068 } 1074 }
1069 }; 1075 };
1070 1076
1071 $_[0]->push_read (line => $state{read_chunk}); 1077 $_[0]->push_read (line => $state{read_chunk});
1072 1078
1073 } elsif ($arg{on_body}) { 1079 } elsif (!$redirect && $arg{on_body}) {
1074 if (defined $len) { 1080 if (defined $len) {
1075 $_[0]->on_read (sub { 1081 $_[0]->on_read (sub {
1076 $len -= length $_[0]{rbuf}; 1082 $len -= length $_[0]{rbuf};
1077 1083
1078 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 1084 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
… …
1117 _destroy_state %state; 1123 _destroy_state %state;
1118 1124
1119 %state = (); 1125 %state = ();
1120 $state{recurse} = 1126 $state{recurse} =
1121 http_request ( 1127 http_request (
1122 $method => $url, 1128 $method => $url,
1123 %arg, 1129 %arg,
1124 recurse => $recurse - 1, 1130 recurse => $recurse - 1,
1125 keepalive => 0, 1131 persistent => 0,
1126 sub { 1132 sub {
1127 %state = (); 1133 %state = ();
1128 &$cb 1134 &$cb
1129 } 1135 }
1130 ); 1136 );
… …
1176 1182
1177 # now handle proxy-CONNECT method 1183 # now handle proxy-CONNECT method
1178 if ($proxy && $uscheme eq "https") { 1184 if ($proxy && $uscheme eq "https") {
1179 # oh dear, we have to wrap it into a connect request 1185 # oh dear, we have to wrap it into a connect request
1180 1186
1187 my $auth = exists $hdr{"proxy-authorization"}
1188 ? "proxy-authorization: " . (delete $hdr{"proxy-authorization"}) . "\015\012"
1189 : "";
1190
1181 # maybe re-use $uauthority with patched port? 1191 # maybe re-use $uauthority with patched port?
1182 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012\015\012"); 1192 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012$auth\015\012");
1183 $state{handle}->push_read (line => $qr_nlnl, sub { 1193 $state{handle}->push_read (line => $qr_nlnl, sub {
1184 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 1194 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
1185 or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }; 1195 or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" };
1186 1196
1187 if ($2 == 200) { 1197 if ($2 == 200) {
… …
1190 } else { 1200 } else {
1191 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 }; 1201 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 };
1192 } 1202 }
1193 }); 1203 });
1194 } else { 1204 } else {
1205 delete $hdr{"proxy-authorization"} unless $proxy;
1206
1195 $handle_actual_request->(); 1207 $handle_actual_request->();
1196 } 1208 }
1197 }; 1209 };
1198 1210
1199 _get_slot $uhost, sub { 1211 _get_slot $uhost, sub {
… …
1205 # on a keepalive request (in theory, this should be a separate config option). 1217 # on a keepalive request (in theory, this should be a separate config option).
1206 if ($persistent && $KA_CACHE{$ka_key}) { 1218 if ($persistent && $KA_CACHE{$ka_key}) {
1207 $was_persistent = 1; 1219 $was_persistent = 1;
1208 1220
1209 $state{handle} = ka_fetch $ka_key; 1221 $state{handle} = ka_fetch $ka_key;
1210 $state{handle}->destroyed 1222# $state{handle}->destroyed
1211 and die "AnyEvent::HTTP: unexpectedly got a destructed handle (1), please report.";#d# 1223# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (1), please report.";#d#
1212 $prepare_handle->(); 1224 $prepare_handle->();
1213 $state{handle}->destroyed 1225# $state{handle}->destroyed
1214 and die "AnyEvent::HTTP: unexpectedly got a destructed handle (2), please report.";#d# 1226# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (2), please report.";#d#
1215 $handle_actual_request->(); 1227 $handle_actual_request->();
1216 1228
1217 } else { 1229 } else {
1218 my $tcp_connect = $arg{tcp_connect} 1230 my $tcp_connect = $arg{tcp_connect}
1219 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 1231 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
… …
1449 or die "$file: $!"; 1461 or die "$file: $!";
1450 1462
1451 my %hdr; 1463 my %hdr;
1452 my $ofs = 0; 1464 my $ofs = 0;
1453 1465
1454 warn stat $fh;
1455 warn -s _;
1456 if (stat $fh and -s _) { 1466 if (stat $fh and -s _) {
1457 $ofs = -s _; 1467 $ofs = -s _;
1458 warn "-s is ", $ofs; 1468 warn "-s is ", $ofs;
1459 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9]; 1469 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9];
1460 $hdr{"range"} = "bytes=$ofs-"; 1470 $hdr{"range"} = "bytes=$ofs-";
… …
1488 my (undef, $hdr) = @_; 1498 my (undef, $hdr) = @_;
1489 1499
1490 my $status = $hdr->{Status}; 1500 my $status = $hdr->{Status};
1491 1501
1492 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) { 1502 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) {
1493 utime $fh, $time, $time; 1503 utime $time, $time, $fh;
1494 } 1504 }
1495 1505
1496 if ($status == 200 || $status == 206 || $status == 416) { 1506 if ($status == 200 || $status == 206 || $status == 416) {
1497 # download ok || resume ok || file already fully downloaded 1507 # download ok || resume ok || file already fully downloaded
1498 $cb->(1, $hdr); 1508 $cb->(1, $hdr);

Diff Legend

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