alive results from the CPAN

alive

AnyEvent-UWSGI

view release on metacpan or search on metacpan

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

         }gcxsi
      ) {
         my $name = $2;
         my $value = $4;

         if (defined $1) {
            # expires
            $name  = "expires";
            $value = $1;
         } elsif (defined $3) {
            # quoted
            $value = $3;
            $value =~ s/\\(.)/$1/gs;
         }

         push @kv, @kv ? lc $name : $name, $value;

         last unless /\G\s*;/gc;
      }

      last unless @kv;

      my $name = shift @kv;
      my %kv = (value => shift @kv, @kv);

      if (exists $kv{"max-age"}) {
         $kv{_expires} = $anow + delete $kv{"max-age"};
      } elsif (exists $kv{expires}) {
         $snow ||= parse_date ($date) || $anow;
         $kv{_expires} = $anow + (parse_date (delete $kv{expires}) - $snow);
      } else {
         delete $kv{_expires};
      }

      my $cdom;
      my $cpath = (delete $kv{path}) || "/";

      if (exists $kv{domain}) {
         $cdom = delete $kv{domain};

         $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);
      } else {
         $cdom = $host;
      }

      # store it
      $jar->{version} = 1;
      $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
         ? $KA_CACHE{$ka_key} = \@ka
         : delete $KA_CACHE{$ka_key};
   };

   # on error etc., destroy
   $hdl->on_error ($destroy);
   $hdl->on_eof   ($destroy);
   $hdl->on_read  ($destroy);
   $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] )*)
            \012
         /gxc;

   /\G$/
     or return;

   # remove the "," prefix we added to all headers above
   substr $_, 0, 1, ""
      for values %hdr;

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

   push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};

   my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;

   return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
      if $recurse < 0;

   my $proxy   = exists $arg{proxy} ? $arg{proxy} : $PROXY;
   my $timeout = $arg{timeout} || $TIMEOUT;

   my ($uscheme, $uauthority, $upath, $query, undef) = # ignore fragment
      $url =~ m|^([^:]+):(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?$|;

   $uscheme = lc $uscheme;

   my $uport = 3031;

   $uauthority =~ /^(?: .*\@ )? ([^\@]+?) (?: : (\d+) )?$/x
      or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });

   my $uhost = lc $1;
   $uport = $2 if defined $2;

   $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
      unless exists $hdr{host};

   $uhost =~ s/^\[(.*)\]$/$1/;
   $upath .= $query if length $query;

   $upath =~ s%^/?%/%;

   # cookie processing
   if (my $jar = $arg{cookie_jar}) {
      my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;

      $hdr{cookie} = join "; ", @$cookies
         if @$cookies;
   }

   my ($rhost, $rport, $rscheme, $rpath); # request host, port, path

   if ($proxy) {
      ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);

      $rscheme = "uwsgi" unless defined $rscheme;
      $rhost   = lc $rhost;
      $rscheme = lc $rscheme;
   } else {
      ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
   }

   # leave out fragment and query string, just a heuristic
   $hdr{referer}      = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
   $hdr{"user-agent"} = $USERAGENT                     unless exists $hdr{"user-agent"};

   $hdr{"content-length"} = length $arg{body}
      if length $arg{body} || $method ne "GET";

   my $idempotent = $IDEMPOTENT{$method};

   # default value for keepalive is true iff the request is for an idempotent method
   my $persistent = exists $arg{persistent} ? !!$arg{persistent} : $idempotent;
   my $keepalive  = exists $arg{keepalive}  ? !!$arg{keepalive}  : !$proxy;
   my $was_persistent; # true if this is actually a recycled connection

   # the key to use in the keepalive cache
   my $ka_key = "$uscheme\x00$uhost\x00$uport\x00$arg{sessionid}";

   $hdr{connection} = ($persistent ? $keepalive ? "keep-alive, " : "" : "close, ") . "Te"; #1.1
   $hdr{te}         = "trailers" unless exists $hdr{te}; #1.1

   my %state = (connect_guard => 1);

   my $ae_error = 595; # connecting

   # handle actual, non-tunneled, request
   my $handle_actual_request = sub {
      $ae_error = 596; # request phase

      my $hdl = $state{handle};
      my ($lport, $lhost) = AnyEvent::Socket::unpack_sockaddr getsockname $hdl->fh;


      my $env = {};
      $env->{QUERY_STRING}   = $query =~ m{^\?(.*)$} ? $1 : '';
      $env->{REQUEST_METHOD} = $method;
      $env->{CONTENT_LENGTH} = defined $hdr{"content-length"} ? $hdr{"content-length"} : '';
      $env->{CONTENT_TYPE}   = $method =~ /post/i ? 'application/x-www-form-urlencoded' : '';
      $env->{REQUEST_URI}    = $rpath;
      $env->{PATH_INFO}      = $rpath =~ m{^([^\?]+)} ? $1 : '';
      $env->{SERVER_PROTOCOL}= 'HTTP/1.1';
      $env->{REMOTE_ADDR}    = AnyEvent::Socket::format_address($lhost);
      $env->{REMOTE_PORT}    = $lport;
      $env->{SERVER_PORT}    = $rport;
      $env->{SERVER_NAME}    = $rhost;

      if ($hdr{'x-uwsgi-nginx-compatible-mode'}) {
          $env->{PATH_INFO} = Encode::decode('utf8', URI::Escape::XS::uri_unescape($env->{PATH_INFO}));
      }

      foreach my $k (keys %hdr) {
          (my $env_k = uc $k) =~ tr/-/_/;
          $env->{"HTTP_$env_k"} = defined $hdr{$k} ? $hdr{$k} : '';
      }

      my $data = '';
      foreach my $k (sort keys %$env) {
          die "Undef value found for $k" unless defined $env->{$k};
          $data .= pack 'v/a*v/a*', map { Encode::encode('utf8', $_) } $k, $env->{$k};
      }

      my $req_buf = pack('C1v1C1',
          defined $arg{modifier1} ? $arg{modifier1} : 5, # default PSGI_MODIFIER1,
          length($data),
          defined $arg{modifier2} ? $arg{modifier2} : 0, # default PSGI_MODIFIER2,
      ) . $data;

      # send request
      $hdl->push_write($req_buf);

      # return if error occurred during push_write()
      return unless %state;

      # reduce memory usage, save a kitten, also re-use it for the response headers.
      %hdr = ();

      # status line and headers
      $state{read_response} = sub {
         return unless %state;

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

         # relative uri handling forced by microsoft and other shitheads.
         # we give our best and fall back to URI if available.
         if (exists $hdr{location}) {
            my $loc = $hdr{location};

            if ($loc =~ m%^//%) { # //
               $loc = "$rscheme:$loc";

            } elsif ($loc eq "") {
               $loc = $url;

            } elsif ($loc !~ /^(?: $ | [^:\/?\#]+ : )/x) { # anything "simple"
               $loc =~ s/^\.\/+//;

               if ($loc !~ m%^[.?#]%) {
                  my $prefix = "$rscheme://$uhost:$uport";

                  unless ($loc =~ s/^\///) {
                     $prefix .= $upath;
                     $prefix =~ s/\/[^\/]*$//;
                  }

                  $loc = "$prefix/$loc";

               } elsif (eval { require URI }) { # uri
                  $loc = URI->new_abs ($loc, $url)->as_string;

               } else {
                  return _error %state, $cb, { @pseudo, Status => 599, Reason => "Cannot parse Location (URI module missing)" };
               }
            }

            $hdr{location} = $loc;
         }

         my $redirect;

         if ($recurse) {
            my $status = $hdr{Status};

            # industry standard is to redirect POST as GET for
            # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
            # also, the UA should ask the user for 301 and 307 and POST,
            # industry standard seems to be to simply follow.
            # we go with the industry standard. 308 is defined
            # by rfc7538
            if ($status == 301 or $status == 302 or $status == 303) {
               $redirect = 1;
               # HTTP/1.1 is unclear on how to mutate the method
               unless ($method eq "HEAD") {
                  $method = "GET";
                  delete $arg{body};
               }
            } elsif ($status == 307 or $status == 308) {
               $redirect = 1;
            }
         }

         my $finish = sub { # ($data, $err_status, $err_reason[, $persistent])
            if ($state{handle}) {
               # handle keepalive
               if (
                  $persistent
                  && $_[3]
                  && ($hdr{HTTPVersion} < 1.1
                      ? $hdr{connection} =~ /\bkeep-?alive\b/i
                      : $hdr{connection} !~ /\bclose\b/i)
               ) {
                  ka_store $ka_key, delete $state{handle};
               } else {
                  # no keepalive, destroy the handle
                  $state{handle}->destroy;
               }
            }

            %state = ();

            if (defined $_[1]) {
               $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
               $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
            }

            # set-cookie processing
            if ($arg{cookie_jar}) {
               cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost, $hdr{date};
            }

            if ($redirect && exists $hdr{location}) {
               # we ignore any errors, as it is very common to receive
               # Content-Length != 0 but no actual body
               # we also access %hdr, as $_[1] might be an erro
               $state{recurse} =
                  uwsgi_request (
                     $method  => $hdr{location},
                     %arg,
                     recurse  => $recurse - 1,
                     Redirect => [$_[0], \%hdr],
                     sub {
                        %state = ();
                        &$cb
                     },
                  );
            } else {
               $cb->($_[0], \%hdr);
            }
         };

         $ae_error = 597; # body phase

         my $chunked = $hdr{"transfer-encoding"} =~ /\bchunked\b/i; # not quite correct...

         my $len = $chunked ? undef : $hdr{"content-length"};

         # body handling, many different code paths
         # - no body expected
         # - want_body_handle
         # - te chunked
         # - 2x length known (with or without on_body)
         # - 2x length not known (with or without on_body)
         if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
            $finish->(undef, 598 => "Request cancelled by on_header");
         } elsif (
            $hdr{Status} =~ /^(?:1..|204|205|304)$/
            or $method eq "HEAD"
            or (defined $len && $len == 0) # == 0, not !, because "0   " is true
         ) {
            # no body
            $finish->("", undef, undef, 1);

         } elsif (!$redirect && $arg{want_body_handle}) {
            $_[0]->on_eof   (undef);

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

                  $hdr{"content-length"} ||= $cl;

                  $_[0]->push_read (line => $qr_nlnl, sub {
                     if (length $_[1]) {
                        for ("$_[1]") {
                           y/\015//d; # weed out any \015, as they show up in the weirdest of places.

                           my $hdr = _parse_hdr
                              or return $finish->(undef, $ae_error => "Garbled response trailers");

                           %hdr = (%hdr, %$hdr);
                        }
                     }

                     $finish->($body, undef, undef, 1);
                  });
               }
            };

            $_[0]->push_read (line => $state{read_chunk});

         } elsif ($arg{on_body}) {
            if (defined $len) {
               $_[0]->on_read (sub {
                  $len -= length $_[0]{rbuf};

                  $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
                     or return $finish->(undef, 598 => "Request cancelled by on_body");

                  $len > 0
                     or $finish->("", undef, undef, 1);
               });
            } else {
               $_[0]->on_eof (sub {
                  $finish->("");
               });
               $_[0]->on_read (sub {
                  $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
                     or $finish->(undef, 598 => "Request cancelled by on_body");
               });
            }
         } else {
            $_[0]->on_eof (undef);

            if (defined $len) {
               $_[0]->on_read (sub {
                  $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
                     if $len <= length $_[0]{rbuf};
               });
            } else {
               $_[0]->on_error (sub {
                  ($! == Errno::EPIPE || !$!)
                     ? $finish->(delete $_[0]{rbuf})
                     : $finish->(undef, $ae_error => $_[2]);
               });
               $_[0]->on_read (sub { });
            }
         }
      };

      # if keepalive is enabled, then the server closing the connection
      # before a response can happen legally - we retry on idempotent methods.
      if ($was_persistent && $idempotent) {
         my $old_eof = $hdl->{on_eof};
         $hdl->{on_eof} = sub {
            _destroy_state %state;

            %state = ();
            $state{recurse} =
               uwsgi_request (
                  $method    => $url,
                  %arg,
                  recurse    => $recurse - 1,
                  persistent => 0,
                  sub {
                     %state = ();
                     &$cb
                  }
               );
         };
         $hdl->on_read (sub {
            return unless %state;

            # as soon as we receive something, a connection close
            # once more becomes a hard error
            $hdl->{on_eof} = $old_eof;
            $hdl->push_read (line => $qr_nlnl, $state{read_response});
         });
      } else {
         $hdl->push_read (line => $qr_nlnl, $state{read_response});
      }
   };

   my $prepare_handle = sub {
      my ($hdl) = $state{handle};

      $hdl->on_error (sub {
         _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] };
      });
      $hdl->on_eof (sub {
         _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" };
      });
      $hdl->timeout_reset;
      $hdl->timeout ($timeout);
   };

   # connected to proxy (or origin server)
   my $connect_cb = sub {
      my $fh = shift
         or return _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "$!" };

      return unless delete $state{connect_guard};

      # get handle
      $state{handle} = new AnyEvent::Handle
         %{ $arg{handle_params} },
         fh       => $fh,
         peername => $uhost,
      ;

      $prepare_handle->();

      delete $hdr{"proxy-authorization"} unless $proxy;
      $handle_actual_request->();
   };

   _get_slot $uhost, sub {
      $state{slot_guard} = shift;

      return unless $state{connect_guard};

      # try to use an existing keepalive connection, but only if we, ourselves, plan
      # on a keepalive request (in theory, this should be a separate config option).
      if ($persistent && $KA_CACHE{$ka_key}) {
         $was_persistent = 1;

         $state{handle} = ka_fetch $ka_key;
         $state{handle}->destroyed
            and die "AnyEvent::UWSGI: unexpectedly got a destructed handle (1), please report.";#d#
         $prepare_handle->();
         $state{handle}->destroyed
            and die "AnyEvent::UWSGI: unexpectedly got a destructed handle (2), please report.";#d#
         $handle_actual_request->();

      } else {
         my $tcp_connect = $arg{tcp_connect}
                           || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };

         $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
      }
   };

   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

( run in 2.300 seconds using v1.01-cache-2.11-cpan-df04353d9ac )