[ViewVC] Diff of: cvs/AnyEvent-HTTP/HTTP.pm

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.9 by root, Wed Jun 4 13:51:53 2008 UTC vs.
Revision 1.11 by root, Thu Jun 5 15:34:00 2008 UTC

 =head1 DESCRIPTION
 This module is an L<AnyEvent> user, you need to make sure that you use and
 run a supported event loop.
+This module implements a simple, stateless and non-blocking HTTP
+client. It supports GET, POST and other request methods, cookies and more,
+all on a very low level. It can follow redirects supports proxies and
+automatically limits the number of connections to the values specified in
+the RFC.
+It should generally be a "good client" that is enough for most HTTP
+tasks. Simple tasks should be simple, but complex tasks should still be
+possible as the user retains control over request and response headers.
+The caller is responsible for authentication management, cookies (if
+the simplistic implementation in this module doesn't suffice), referer
+and other high-level protocol details for which this module offers only
+limited support.
 =head2 METHODS
 =over 4
 our $PERSISTENT_TIMEOUT =   2;
 our $TIMEOUT            = 300;
 # changing these is evil
 our $MAX_PERSISTENT_PER_HOST = 2;
-our $MAX_PER_HOST       = 4; # not respected yet :(
+our $MAX_PER_HOST       = 4;
 our $PROXY;
 my %KA_COUNT; # number of open keep-alive connections per host
+my %CO_SLOT;  # number of open connections, and wait queue, per host
 =item http_get $url, key => value..., $cb->($data, $headers)
 Executes an HTTP-GET request. See the http_request function for details on
 additional parameters.
 response headers as second argument.
 All the headers in that hash are lowercased. In addition to the response
 headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and
 C<Reason> contain the three parts of the HTTP Status-Line of the same
-name.
+name. If the server sends a header multiple lines, then their contents
+will be joined together with C<\x00>.
 If an internal error occurs, such as not being able to resolve a hostname,
 then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599>
 and the C<Reason> pseudo-header will contain an error message.
 =item body => $string
 The request body, usually empty. Will be-sent as-is (future versions of
 this module might offer more options).
+=item cookie_jar => $hash_ref
+Passing this parameter enables (simplified) cookie-processing, loosely
+based on the original netscape specification.
+The C<$hash_ref> must be an (initially empty) hash reference which will
+get updated automatically. It is possible to save the cookie_jar to
+persistent storage with something like JSON or Storable, but this is not
+recommended, as expire times are currently being ignored.
+Note that this cookie implementation is not of very high quality, nor
+meant to be complete. If you want complete cookie management you have to
+do that on your own. C<cookie_jar> is meant as a quick fix to get some
+cookie-using sites working. Cookies are a privacy disaster, do not use
+them unless required to.
 =back
 Example: make a simple HTTP GET request for http://www.nethype.de/
       }
    ;
 =cut
+sub _slot_schedule($) {
+   my $host = shift;
+   while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
+      if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
+         # somebody wnats that slot
+         ++$CO_SLOT{$host}[0];
+         $cb->(AnyEvent::Util::guard {
+            --$CO_SLOT{$host}[0];
+            _slot_schedule $host;
+         });
+      } else {
+         # nobody wants the slot, maybe we can forget about it
+         delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
+         warn "$host deleted" unless $CO_SLOT{$host}[0];#d#
+         last;
+      }
+   }
+}
+# wait for a free slot on host, call callback
+sub _get_slot($$) {
+   push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
+   _slot_schedule $_[0];
+}
 sub http_request($$$;@) {
    my $cb = pop;
    my ($method, $url, %arg) = @_;
    my %hdr;
    my $proxy   = $arg{proxy}   || $PROXY;
    my $timeout = $arg{timeout} || $TIMEOUT;
    $hdr{"user-agent"} ||= $USERAGENT;
-   my ($host, $port, $path, $scheme);
+   my ($scheme, $authority, $upath, $query, $fragment) =
+      $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
+   $scheme = lc $scheme;
+   my $uport = $scheme eq "http"  ?  80
+             : $scheme eq "https" ? 443
+             : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported" });
+   $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
+      or return $cb->(undef, { Status => 599, Reason => "unparsable URL" });
+   my $uhost = $1;
+   $uport = $2 if defined $2;
+   $uhost =~ s/^\[(.*)\]$/$1/;
+   $upath .= "?$query" if length $query;
+   $upath =~ s%^/?%/%;
+   # cookie processing
+   if (my $jar = $arg{cookie_jar}) {
+      %$jar = () if $jar->{version} < 1;
+      my @cookie;
+      while (my ($chost, $v) = each %$jar) {
+         next unless $chost eq substr $uhost, -length $chost;
+         next unless $chost =~ /^\./;
+         while (my ($cpath, $v) = each %$v) {
+            next unless $cpath eq substr $upath, 0, length $cpath;
+            while (my ($k, $v) = each %$v) {
+               next if $scheme ne "https" && exists $v->{secure};
+               push @cookie, "$k=$v->{value}";
+            }
+         }
+      }
+      $hdr{cookie} = join "; ", @cookie
+         if @cookie;
+   }
+   my ($rhost, $rport, $rpath); # request host, port, path
    if ($proxy) {
-      ($host, $port, $scheme) = @$proxy;
+      ($rhost, $rport, $scheme) = @$proxy;
-      $path = $url;
+      $rpath = $url;
    } else {
-      ($scheme, my $authority, $path, my $query, my $fragment) =
+      ($rhost, $rport, $rpath) = ($uhost, $uport, $upath);
-         $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
-      $port = $scheme eq "http"  ?  80
-            : $scheme eq "https" ? 443
-            : return $cb->(undef, { Status => 599, Reason => "$url: only http and https URLs supported" });
-      $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
-         or return $cb->(undef, { Status => 599, Reason => "$url: unparsable URL" });
-      $host = $1;
-      $port = $2 if defined $2;
-      $host =~ s/^\[(.*)\]$/$1/;
-      $path .= "?$query" if length $query;
-      $path = "/" unless $path;
-      $hdr{host} = $host = lc $host;
+      $hdr{host} = $uhost;
    }
-   $scheme = lc $scheme;
-   my %state;
    $hdr{"content-length"} = length $arg{body};
+   my %state = (connect_guard => 1);
+   _get_slot $uhost, sub {
+      $state{slot_guard} = shift;
+      return unless $state{connect_guard};
-   $state{connect_guard} = AnyEvent::Socket::tcp_connect $host, $port, sub {
+      $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
-      $state{fh} = shift
+         $state{fh} = shift
-         or return $cb->(undef, { Status => 599, Reason => "$!" });
+            or return $cb->(undef, { Status => 599, Reason => "$!" });
-      delete $state{connect_guard}; # reduce memory usage, save a tree
+         delete $state{connect_guard}; # reduce memory usage, save a tree
-      # get handle
+         # get handle
-      $state{handle} = new AnyEvent::Handle
+         $state{handle} = new AnyEvent::Handle
-         fh => $state{fh},
+            fh => $state{fh},
-         ($scheme eq "https" ? (tls => "connect") : ());
+            ($scheme eq "https" ? (tls => "connect") : ());
-      # limit the number of persistent connections
+         # limit the number of persistent connections
-      if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
+         if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
-         ++$KA_COUNT{$_[1]};
+            ++$KA_COUNT{$_[1]};
-         $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} };
+            $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} };
-         $hdr{connection} = "keep-alive";
+            $hdr{connection} = "keep-alive";
-         delete $hdr{connection}; # keep-alive not yet supported
+            delete $hdr{connection}; # keep-alive not yet supported
-      } else {
+         } else {
-         delete $hdr{connection};
+            delete $hdr{connection};
-      }
+         }
-      # (re-)configure handle
+         # (re-)configure handle
-      $state{handle}->timeout ($timeout);
+         $state{handle}->timeout ($timeout);
-      $state{handle}->on_error (sub {
+         $state{handle}->on_error (sub {
-         %state = ();
+            %state = ();
-         $cb->(undef, { Status => 599, Reason => "$!" });
+            $cb->(undef, { Status => 599, Reason => "$!" });
-      });
+         });
-      $state{handle}->on_eof (sub {
+         $state{handle}->on_eof (sub {
-         %state = ();
+            %state = ();
-         $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });
+            $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });
-      });
+         });
-      # send request
+         # send request
-      $state{handle}->push_write (
+         $state{handle}->push_write (
-         "$method $path HTTP/1.0\015\012"
+            "$method $rpath HTTP/1.0\015\012"
-         . (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
+            . (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
-         . "\015\012"
+            . "\015\012"
-         . (delete $arg{body})
+            . (delete $arg{body})
-      );
-      %hdr = (); # reduce memory usage, save a kitten
-      # status line
-      $state{handle}->push_read (line => qr/\015?\012/, sub {
-         $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
-            or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
-         my %hdr = ( # response headers
-            HTTPVersion => ",$1",
-            Status      => ",$2",
-            Reason      => ",$3",
          );
+         %hdr = (); # reduce memory usage, save a kitten
+         # status line
+         $state{handle}->push_read (line => qr/\015?\012/, sub {
+            $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
+               or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
+            my %hdr = ( # response headers
+               HTTPVersion => "\x00$1",
+               Status      => "\x00$2",
+               Reason      => "\x00$3",
+            );
-         # headers, could be optimized a bit
+            # headers, could be optimized a bit
-         $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
+            $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
-            for ("$_[1]\012") {
+               for ("$_[1]\012") {
-               # we support spaces in field names, as lotus domino
+                  # we support spaces in field names, as lotus domino
-               # creates them.
+                  # creates them.
-               $hdr{lc $1} .= ",$2"
+                  $hdr{lc $1} .= "\x00$2"
-                  while /\G
+                     while /\G
-                        ([^:\000-\037]+):
+                           ([^:\000-\037]+):
-                        [\011\040]*
+                           [\011\040]*
-                        ((?: [^\015\012]+ | \015?\012[\011\040] )*)
+                           ((?: [^\015\012]+ | \015?\012[\011\040] )*)
-                        \015?\012
+                           \015?\012
-                     /gxc;
+                        /gxc;
-               /\G$/
+                  /\G$/
-                 or return $cb->(undef, { Status => 599, Reason => "garbled response headers" });
+                    or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers" }));
-            }
+               }
-            substr $_, 0, 1, ""
+               substr $_, 0, 1, ""
-               for values %hdr;
+                  for values %hdr;
-            my $finish = sub {
+               my $finish = sub {
+                  %state = ();
+                  # set-cookie processing
+                  if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
+                     for (split /\x00/, $hdr{"set-cookie"}) {
+                        my ($cookie, @arg) = split /;\s*/;
+                        my ($name, $value) = split /=/, $cookie, 2;
+                        my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
+                        my $cdom  = (delete $kv{domain}) || $uhost;
+                        my $cpath = (delete $kv{path})   || "/";
+                        $cdom =~ s/^.?/./; # make sure it starts with a "."
+                        next if $cdom =~ /\.$/;
+                        # this is not rfc-like and not netscape-like. go figure.
+                        my $ndots = $cdom =~ y/.//;
+                        next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
+                        # store it
+                        $arg{cookie_jar}{version} = 1;
+                        $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
+                     }
+                  }
-               if ($_[1]{Status} =~ /^30[12]$/ && $recurse) {
+                  if ($_[1]{Status} =~ /^x30[12]$/ && $recurse) {
+                     # microsoft and other assholes don't give a shit for following standards,
+                     # try to support a common form of broken Location header.
+                     $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
-                  http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
+                     http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
+                  } else {
+                     $cb->($_[0], $_[1]);
+                  }
+               };
+               if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") {
+                  $finish->(undef, \%hdr);
                } else {
-                  $cb->($_[0], $_[1]);
+                  if (exists $hdr{"content-length"}) {
+                     $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
+                        # could cache persistent connection now
+                        if ($hdr{connection} =~ /\bkeep-alive\b/i) {
+                           # but we don't, due to misdesigns, this is annoyingly complex
+                        };
+                        $finish->($_[1], \%hdr);
+                     });
+                  } else {
+                     # too bad, need to read until we get an error or EOF,
+                     # no way to detect winged data.
+                     $_[0]->on_error (sub {
+                        $finish->($_[0]{rbuf}, \%hdr);
+                     });
+                     $_[0]->on_eof (undef);
+                     $_[0]->on_read (sub { });
+                  }
                }
-            };
+            });
-            if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") {
-               %state = ();
-               $finish->(undef, \%hdr);
-            } else {
-               if (exists $hdr{"content-length"}) {
-                  $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
-                     # could cache persistent connection now
-                     if ($hdr{connection} =~ /\bkeep-alive\b/i) {
-                        # but we don't, due to misdesigns, this is annoyingly complex
-                     };
-                     %state = ();
-                     $finish->($_[1], \%hdr);
-                  });
-               } else {
-                  # too bad, need to read until we get an error or EOF,
-                  # no way to detect winged data.
-                  $_[0]->on_error (sub {
-                     %state = ();
-                     $finish->($_[0]{rbuf}, \%hdr);
-                  });
-                  $_[0]->on_eof (undef);
-                  $_[0]->on_read (sub { });
-               }
-            }
          });
+      }, sub {
+         $timeout
-      });
+      };
-   }, sub {
-      $timeout
    };
    defined wantarray && AnyEvent::Util::guard { %state = () }
 }

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.9 by root, Wed Jun 4 13:51:53 2008 UTC vs. Revision 1.11 by root, Thu Jun 5 15:34:00 2008 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.9 by root, Wed Jun 4 13:51:53 2008 UTC vs.
Revision 1.11 by root, Thu Jun 5 15:34:00 2008 UTC