… | |
… | |
236 | sub _get_slot($$) { |
236 | sub _get_slot($$) { |
237 | push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; |
237 | push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; |
238 | |
238 | |
239 | _slot_schedule $_[0]; |
239 | _slot_schedule $_[0]; |
240 | } |
240 | } |
|
|
241 | |
|
|
242 | our $qr_nl = qr<\015?\012>; |
|
|
243 | our $qr_nlnl = qr<\015?\012\015?\012>; |
241 | |
244 | |
242 | sub http_request($$@) { |
245 | sub http_request($$@) { |
243 | my $cb = pop; |
246 | my $cb = pop; |
244 | my ($method, $url, %arg) = @_; |
247 | my ($method, $url, %arg) = @_; |
245 | |
248 | |
… | |
… | |
339 | return unless $state{connect_guard}; |
342 | return unless $state{connect_guard}; |
340 | |
343 | |
341 | $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { |
344 | $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { |
342 | $state{fh} = shift |
345 | $state{fh} = shift |
343 | or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url }); |
346 | or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url }); |
|
|
347 | pop; # free memory, save a tree |
344 | |
348 | |
345 | delete $state{connect_guard}; # reduce memory usage, save a tree |
349 | return unless delete $state{connect_guard}; |
346 | |
350 | |
347 | # get handle |
351 | # get handle |
348 | $state{handle} = new AnyEvent::Handle |
352 | $state{handle} = new AnyEvent::Handle |
349 | fh => $state{fh}; |
353 | fh => $state{fh}, |
|
|
354 | timeout => $timeout; |
350 | |
355 | |
351 | # limit the number of persistent connections |
356 | # limit the number of persistent connections |
|
|
357 | # keepalive not yet supported |
352 | if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { |
358 | if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { |
353 | ++$KA_COUNT{$_[1]}; |
359 | ++$KA_COUNT{$_[1]}; |
354 | $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} }; |
360 | $state{handle}{ka_count_guard} = AnyEvent::Util::guard { |
|
|
361 | --$KA_COUNT{$_[1]} |
|
|
362 | }; |
355 | $hdr{connection} = "keep-alive"; |
363 | $hdr{connection} = "keep-alive"; |
356 | delete $hdr{connection}; # keep-alive not yet supported |
|
|
357 | } else { |
364 | } else { |
358 | delete $hdr{connection}; |
365 | delete $hdr{connection}; |
359 | } |
366 | } |
360 | |
367 | |
361 | # (re-)configure handle |
368 | # (re-)configure handle |
362 | $state{handle}->timeout ($timeout); |
|
|
363 | $state{handle}->on_error (sub { |
369 | $state{handle}->on_error (sub { |
364 | my $errno = "$!"; |
370 | my $errno = "$!"; |
365 | %state = (); |
371 | %state = (); |
366 | $cb->(undef, { Status => 599, Reason => $errno, URL => $url }); |
372 | $cb->(undef, { Status => 599, Reason => $errno, URL => $url }); |
367 | }); |
373 | }); |
… | |
… | |
372 | |
378 | |
373 | $state{handle}->starttls ("connect") if $rscheme eq "https"; |
379 | $state{handle}->starttls ("connect") if $rscheme eq "https"; |
374 | |
380 | |
375 | # handle actual, non-tunneled, request |
381 | # handle actual, non-tunneled, request |
376 | my $handle_actual_request = sub { |
382 | my $handle_actual_request = sub { |
377 | $state{handle}->starttls ("connect") if $uscheme eq "https"; |
383 | $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; |
378 | |
384 | |
379 | # send request |
385 | # send request |
380 | $state{handle}->push_write ( |
386 | $state{handle}->push_write ( |
381 | "$method $rpath HTTP/1.0\015\012" |
387 | "$method $rpath HTTP/1.0\015\012" |
382 | . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr) |
388 | . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr) |
… | |
… | |
385 | ); |
391 | ); |
386 | |
392 | |
387 | %hdr = (); # reduce memory usage, save a kitten |
393 | %hdr = (); # reduce memory usage, save a kitten |
388 | |
394 | |
389 | # status line |
395 | # status line |
390 | $state{handle}->push_read (line => qr/\015?\012/, sub { |
396 | $state{handle}->push_read (line => $qr_nl, sub { |
391 | $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix |
397 | $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix |
392 | or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url })); |
398 | or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url })); |
393 | |
399 | |
394 | my %hdr = ( # response headers |
400 | my %hdr = ( # response headers |
395 | HTTPVersion => ",$1", |
401 | HTTPVersion => ",$1", |
… | |
… | |
397 | Reason => ",$3", |
403 | Reason => ",$3", |
398 | URL => ",$url" |
404 | URL => ",$url" |
399 | ); |
405 | ); |
400 | |
406 | |
401 | # headers, could be optimized a bit |
407 | # headers, could be optimized a bit |
402 | $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { |
408 | $state{handle}->unshift_read (line => $qr_nlnl, sub { |
403 | for ("$_[1]\012") { |
409 | for ("$_[1]\012") { |
404 | y/\015//d; # weed out any \015, as they show up in the weirdest of places. |
410 | y/\015//d; # weed out any \015, as they show up in the weirdest of places. |
405 | |
411 | |
406 | # we support spaces in field names, as lotus domino |
412 | # we support spaces in field names, as lotus domino |
407 | # creates them (actually spaces around seperators |
413 | # creates them (actually spaces around seperators |
… | |
… | |
538 | if ($proxy && $uscheme eq "https") { |
544 | if ($proxy && $uscheme eq "https") { |
539 | # oh dear, we have to wrap it into a connect request |
545 | # oh dear, we have to wrap it into a connect request |
540 | |
546 | |
541 | # maybe re-use $uauthority with patched port? |
547 | # maybe re-use $uauthority with patched port? |
542 | $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); |
548 | $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); |
543 | $state{handle}->push_read (line => qr/\015?\012\015?\012/, sub { |
549 | $state{handle}->push_read (line => $qr_nlnl, sub { |
544 | $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix |
550 | $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix |
545 | or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid proxy connect response ($_[1])", URL => $url })); |
551 | or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid proxy connect response ($_[1])", URL => $url })); |
546 | |
552 | |
547 | if ($2 == 200) { |
553 | if ($2 == 200) { |
548 | $rpath = $upath; |
554 | $rpath = $upath; |