AnyEvent-UWSGI

 view release on metacpan or  search on metacpan

lib/AnyEvent/UWSGI.pm  view on Meta::CPAN

our $ACTIVE = 0;

my %KA_CACHE; # indexed by uhost currently, points to [$handle...] array
my %CO_SLOT;  # number of open connections, and wait queue, per host


#############################################################################
# wait queue/slots

sub _slot_schedule;
sub _slot_schedule($) {
   my $host = shift;

   while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
      if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
         # somebody wants that slot
         ++$CO_SLOT{$host}[0];
         ++$ACTIVE;

         $cb->(AnyEvent::Util::guard {
            --$ACTIVE;

lib/AnyEvent/UWSGI.pm  view on Meta::CPAN

         });
      } else {
         # nobody wants the slot, maybe we can forget about it
         delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
         last;
      }
   }
}

# wait for a free slot on host, call callback
sub _get_slot($$) {
   push @{ $CO_SLOT{$_[0]}[1] }, $_[1];

   _slot_schedule $_[0];
}

#############################################################################
# cookie handling

# expire cookies
sub cookie_jar_expire($;$) {
   my ($jar, $session_end) = @_;

   %$jar = () if $jar->{version} != 1;

   my $anow = AE::now;

   while (my ($chost, $paths) = each %$jar) {
      next unless ref $paths;

      while (my ($cpath, $cookies) = each %$paths) {

lib/AnyEvent/UWSGI.pm  view on Meta::CPAN

         delete $paths->{$cpath}
            unless %$cookies;
      }

      delete $jar->{$chost}
         unless %$paths;
   }
}
 
# extract cookies from jar
sub cookie_jar_extract($$$$) {
   my ($jar, $scheme, $host, $path) = @_;

   %$jar = () if $jar->{version} != 1;

   my @cookies;

   while (my ($chost, $paths) = each %$jar) {
      next unless ref $paths;

      if ($chost =~ /^\./) {

lib/AnyEvent/UWSGI.pm  view on Meta::CPAN

            push @cookies, "$cookie=$value";
         }
      }
   }

   \@cookies
}
 
# parse set_cookie header into jar
sub cookie_jar_set_cookie($$$$) {
   my ($jar, $set_cookie, $host, $date) = @_;

   my $anow = int AE::now;
   my $snow; # server-now

   for ($set_cookie) {
      # parse NAME=VALUE
      my @kv;

      # expires is not http-compliant in the original cookie-spec,

lib/AnyEvent/UWSGI.pm  view on Meta::CPAN

      $jar->{lc $cdom}{$cpath}{$name} = \%kv;

      redo if /\G\s*,/gc;
   }
}

#############################################################################
# keepalive/persistent connection cache

# fetch a connection from the keepalive cache
sub ka_fetch($) {
   my $ka_key = shift;

   my $hdl = pop @{ $KA_CACHE{$ka_key} }; # currently we reuse the MOST RECENTLY USED connection
   delete $KA_CACHE{$ka_key}
      unless @{ $KA_CACHE{$ka_key} };

   $hdl
}

sub ka_store($$) {
   my ($ka_key, $hdl) = @_;

   my $kaa = $KA_CACHE{$ka_key} ||= [];

   my $destroy = sub {
      my @ka = grep $_ != $hdl, @{ $KA_CACHE{$ka_key} };

      $hdl->destroy;

      @ka

lib/AnyEvent/UWSGI.pm  view on Meta::CPAN

   $hdl->timeout  ($PERSISTENT_TIMEOUT);

   push @$kaa, $hdl;
   shift @$kaa while @$kaa > $MAX_PER_HOST;
}

#############################################################################
# utilities

# continue to parse $_ for headers and place them into the arg
sub _parse_hdr() {
   my %hdr;

   # things seen, not parsed:
   # p3pP="NON CUR OTPi OUR NOR UNI"

   $hdr{lc $1} .= ",$2"
      while /\G
            ([^:\000-\037]*):
            [\011\040]*
            ((?: [^\012]+ | \012[\011\040] )*)

lib/AnyEvent/UWSGI.pm  view on Meta::CPAN

      for values %hdr;

   \%hdr
}

#############################################################################
our $qr_nlnl = qr{(?<![^\012])\015?\012};

# maybe it should just become a normal object :/

sub _destroy_state(\%) {
   my ($state) = @_;

   $state->{handle}->destroy if $state->{handle};
   %$state = ();
}

sub _error(\%$$) {
   my ($state, $cb, $hdr) = @_;

   &_destroy_state ($state);

   $cb->(undef, $hdr);
   ()
}

our %IDEMPOTENT = (
   DELETE		=> 1,

lib/AnyEvent/UWSGI.pm  view on Meta::CPAN

   UPDATEREDIRECTREF	=> 1,
   "VERSION-CONTROL"	=> 1,
);

=item uwsgi_request

Like C<AnyEvent::HTTP::http_request>
Also accepts C<modifier1> and C<modifier2> in C<%args>

=cut
sub uwsgi_request($$@) {
   my $cb = pop;
   my ($method, $url, %arg) = @_;

   my %hdr;

   $method = uc $method;

   if (my $hdr = $arg{headers}) {
      while (my ($k, $v) = each %$hdr) {
         $hdr{lc $k} = $v;

lib/AnyEvent/UWSGI.pm  view on Meta::CPAN

   };

   defined wantarray && AnyEvent::Util::guard { _destroy_state %state }
}

=item uwsgi_get

Like C<AnyEvent::HTTP::http_get>

=cut
sub uwsgi_get($@) {
   unshift @_, "GET";
   &uwsgi_request
}

=item uwsgi_head

Like C<AnyEvent::HTTP::http_head>

=cut
sub uwsgi_head($@) {
   unshift @_, "HEAD";
   &uwsgi_request
}

=item uwsgi_post

Like C<AnyEvent::HTTP::http_post>

=cut
sub uwsgi_post($$@) {
   my $url = shift;
   unshift @_, "POST", $url, "body";
   &uwsgi_request
}

our @month   = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);

sub format_date($) {
   my ($time) = @_;

   # RFC 822/1123 format
   my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;

   sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
      $weekday[$wday], $mday, $month[$mon], $year + 1900,
      $H, $M, $S;
}

sub parse_date($) {
   my ($date) = @_;

   my ($d, $m, $y, $H, $M, $S);

   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$/) {
      # RFC 822/1123, required by RFC 2616 (with " ")
      # cookie dates (with "-")

      ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);

lib/AnyEvent/UWSGI.pm  view on Meta::CPAN

   for (0..11) {
      if ($m eq $month[$_]) {
         require Time::Local;
         return eval { Time::Local::timegm ($S, $M, $H, $d, $_, $y) };
      }
   }

   undef
}

sub set_proxy($) {
   if (length $_[0]) {
      $_[0] =~ m%^(uwsgi):// ([^:/]+) (?: : (\d*) )?%ix
         or Carp::croak "$_[0]: invalid proxy URL";
      $PROXY = [$2, $3 || 3128, $1]
   } else {
      undef $PROXY;
   }
}

# initialise proxy from environment