… | |
… | |
350 | # wait for a free slot on host, call callback |
350 | # wait for a free slot on host, call callback |
351 | sub _get_slot($$) { |
351 | sub _get_slot($$) { |
352 | push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; |
352 | push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; |
353 | |
353 | |
354 | _slot_schedule $_[0]; |
354 | _slot_schedule $_[0]; |
|
|
355 | } |
|
|
356 | |
|
|
357 | # continue to parse $_ for headers and place them into the arg |
|
|
358 | sub parse_hdr() { |
|
|
359 | my %hdr; |
|
|
360 | |
|
|
361 | # things seen, not parsed: |
|
|
362 | # p3pP="NON CUR OTPi OUR NOR UNI" |
|
|
363 | |
|
|
364 | $hdr{lc $1} .= ",$2" |
|
|
365 | while /\G |
|
|
366 | ([^:\000-\037]*): |
|
|
367 | [\011\040]* |
|
|
368 | ((?: [^\012]+ | \012[\011\040] )*) |
|
|
369 | \012 |
|
|
370 | /gxc; |
|
|
371 | |
|
|
372 | /\G$/ |
|
|
373 | or return; |
|
|
374 | |
|
|
375 | # remove the "," prefix we added to all headers above |
|
|
376 | substr $_, 0, 1, "" |
|
|
377 | for values %hdr; |
|
|
378 | |
|
|
379 | \%hdr |
355 | } |
380 | } |
356 | |
381 | |
357 | our $qr_nlnl = qr{(?<![^\012])\015?\012}; |
382 | our $qr_nlnl = qr{(?<![^\012])\015?\012}; |
358 | |
383 | |
359 | our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; |
384 | our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; |
… | |
… | |
455 | } else { |
480 | } else { |
456 | ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); |
481 | ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); |
457 | } |
482 | } |
458 | |
483 | |
459 | # leave out fragment and query string, just a heuristic |
484 | # leave out fragment and query string, just a heuristic |
460 | $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; |
485 | $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer}; |
461 | $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; |
486 | $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"}; |
462 | |
487 | |
463 | $hdr{"content-length"} = length $arg{body} |
488 | $hdr{"content-length"} = length $arg{body} |
464 | if length $arg{body} || $method ne "GET"; |
489 | if length $arg{body} || $method ne "GET"; |
|
|
490 | |
|
|
491 | $hdr{connection} = "close TE"; |
|
|
492 | $hdr{te} = "trailers" unless exists $hdr{te}; |
465 | |
493 | |
466 | my %state = (connect_guard => 1); |
494 | my %state = (connect_guard => 1); |
467 | |
495 | |
468 | _get_slot $uhost, sub { |
496 | _get_slot $uhost, sub { |
469 | $state{slot_guard} = shift; |
497 | $state{slot_guard} = shift; |
… | |
… | |
506 | # $state{handle}{ka_count_guard} = AnyEvent::Util::guard { |
534 | # $state{handle}{ka_count_guard} = AnyEvent::Util::guard { |
507 | # --$KA_COUNT{$_[1]} |
535 | # --$KA_COUNT{$_[1]} |
508 | # }; |
536 | # }; |
509 | # $hdr{connection} = "keep-alive"; |
537 | # $hdr{connection} = "keep-alive"; |
510 | # } else { |
538 | # } else { |
511 | delete $hdr{connection}; |
539 | # delete $hdr{connection}; |
512 | # } |
540 | # } |
513 | |
541 | |
514 | $state{handle}->starttls ("connect") if $rscheme eq "https"; |
542 | $state{handle}->starttls ("connect") if $rscheme eq "https"; |
515 | |
543 | |
516 | # handle actual, non-tunneled, request |
544 | # handle actual, non-tunneled, request |
517 | my $handle_actual_request = sub { |
545 | my $handle_actual_request = sub { |
518 | $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; |
546 | $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; |
519 | |
547 | |
520 | # send request |
548 | # send request |
521 | $state{handle}->push_write ( |
549 | $state{handle}->push_write ( |
522 | "$method $rpath HTTP/1.0\015\012" |
550 | "$method $rpath HTTP/1.1\015\012" |
523 | . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) |
551 | . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) |
524 | . "\015\012" |
552 | . "\015\012" |
525 | . (delete $arg{body}) |
553 | . (delete $arg{body}) |
526 | ); |
554 | ); |
527 | |
555 | |
… | |
… | |
535 | my $keepalive = pop; |
563 | my $keepalive = pop; |
536 | |
564 | |
537 | for ("$_[1]") { |
565 | for ("$_[1]") { |
538 | y/\015//d; # weed out any \015, as they show up in the weirdest of places. |
566 | y/\015//d; # weed out any \015, as they show up in the weirdest of places. |
539 | |
567 | |
540 | /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc |
568 | /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc |
541 | or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" })); |
569 | or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" })); |
542 | |
570 | |
543 | push @pseudo, |
571 | push @pseudo, |
544 | HTTPVersion => $1, |
572 | HTTPVersion => $1, |
545 | Status => $2, |
573 | Status => $2, |
546 | Reason => $3, |
574 | Reason => $3, |
547 | ; |
575 | ; |
548 | |
576 | |
549 | # things seen, not parsed: |
577 | my $hdr = parse_hdr |
550 | # p3pP="NON CUR OTPi OUR NOR UNI" |
|
|
551 | |
|
|
552 | $hdr{lc $1} .= ",$2" |
|
|
553 | while /\G |
|
|
554 | ([^:\000-\037]*): |
|
|
555 | [\011\040]* |
|
|
556 | ((?: [^\012]+ | \012[\011\040] )*) |
|
|
557 | \012 |
|
|
558 | /gxc; |
|
|
559 | |
|
|
560 | /\G$/ |
|
|
561 | or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" })); |
578 | or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" })); |
|
|
579 | |
|
|
580 | %hdr = (%$hdr, @pseudo); |
562 | } |
581 | } |
563 | |
|
|
564 | # remove the "," prefix we added to all headers above |
|
|
565 | substr $_, 0, 1, "" |
|
|
566 | for values %hdr; |
|
|
567 | |
|
|
568 | # patch in all pseudo headers |
|
|
569 | %hdr = (%hdr, @pseudo); |
|
|
570 | |
582 | |
571 | # redirect handling |
583 | # redirect handling |
572 | # microsoft and other shitheads don't give a shit for following standards, |
584 | # microsoft and other shitheads don't give a shit for following standards, |
573 | # try to support some common forms of broken Location headers. |
585 | # try to support some common forms of broken Location headers. |
574 | if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { |
586 | if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { |
… | |
… | |
687 | or (defined $len && !$len) |
699 | or (defined $len && !$len) |
688 | ) { |
700 | ) { |
689 | # no body |
701 | # no body |
690 | $finish->("", undef, undef, 1); |
702 | $finish->("", undef, undef, 1); |
691 | } else { |
703 | } else { |
692 | # body handling, four different code paths |
704 | # body handling, many different code paths |
693 | # for want_body_handle, on_body (2x), normal (2x) |
705 | # - no body expected |
694 | # we might read too much here, but it does not matter yet (no pipelining) |
706 | # - want_body_handle |
|
|
707 | # - te chunked |
|
|
708 | # - 2x length known (with or without on_body) |
|
|
709 | # - 2x length not known (with or without on_body) |
695 | if (!$redirect && $arg{want_body_handle}) { |
710 | if (!$redirect && $arg{want_body_handle}) { |
696 | $_[0]->on_eof (undef); |
711 | $_[0]->on_eof (undef); |
697 | $_[0]->on_error (undef); |
712 | $_[0]->on_error (undef); |
698 | $_[0]->on_read (undef); |
713 | $_[0]->on_read (undef); |
699 | |
714 | |
700 | $finish->(delete $state{handle}); |
715 | $finish->(delete $state{handle}); |
701 | |
716 | |
|
|
717 | } elsif ($hdr{"transfer-encoding"} =~ /chunked/) { |
|
|
718 | my $body = undef; |
|
|
719 | my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; |
|
|
720 | |
|
|
721 | $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) }); |
|
|
722 | |
|
|
723 | my $read_chunk; $read_chunk = sub { |
|
|
724 | $_[1] =~ /^([0-9a-fA-F]+)/ |
|
|
725 | or $finish->(undef, 599 => "Garbled chunked transfer encoding"); |
|
|
726 | |
|
|
727 | my $len = hex $1; |
|
|
728 | |
|
|
729 | if ($len) { |
|
|
730 | $_[0]->push_read (chunk => hex $1, sub { |
|
|
731 | $on_body->($_[1], \%hdr) |
|
|
732 | or return $finish->(undef, 598 => "Request cancelled by on_body"); |
|
|
733 | |
|
|
734 | $_[0]->push_read (line => sub { |
|
|
735 | length $_[1] |
|
|
736 | and return $finish->(undef, 599 => "Garbled chunked transfer encoding"); |
|
|
737 | $_[0]->push_read (line => $read_chunk); |
|
|
738 | }); |
|
|
739 | }); |
|
|
740 | } else { |
|
|
741 | $_[0]->push_read (line => $qr_nlnl, sub { |
|
|
742 | if (length $_[1]) { |
|
|
743 | for ("$_[1]") { |
|
|
744 | y/\015//d; # weed out any \015, as they show up in the weirdest of places. |
|
|
745 | |
|
|
746 | my $hdr = parse_hdr |
|
|
747 | or return $finish->(undef, 599 => "Garbled response trailers"); |
|
|
748 | |
|
|
749 | %hdr = (%hdr, %$hdr); |
|
|
750 | } |
|
|
751 | } |
|
|
752 | |
|
|
753 | $finish->($body, undef, undef, 1); |
|
|
754 | }); |
|
|
755 | } |
|
|
756 | }; |
|
|
757 | |
|
|
758 | $_[0]->push_read (line => $read_chunk); |
|
|
759 | |
702 | } elsif ($arg{on_body}) { |
760 | } elsif ($arg{on_body}) { |
703 | $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) }); |
761 | $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) }); |
|
|
762 | |
704 | if ($len) { |
763 | if ($len) { |
705 | $_[0]->on_read (sub { |
764 | $_[0]->on_read (sub { |
706 | $len -= length $_[0]{rbuf}; |
765 | $len -= length $_[0]{rbuf}; |
707 | |
766 | |
708 | $arg{on_body}(delete $_[0]{rbuf}, \%hdr) |
767 | $arg{on_body}(delete $_[0]{rbuf}, \%hdr) |
709 | or $finish->(undef, 598 => "Request cancelled by on_body"); |
768 | or return $finish->(undef, 598 => "Request cancelled by on_body"); |
710 | |
769 | |
711 | $len > 0 |
770 | $len > 0 |
712 | or $finish->("", undef, undef, 1); |
771 | or $finish->("", undef, undef, 1); |
713 | }); |
772 | }); |
714 | } else { |
773 | } else { |