view release on metacpan or  search on metacpan

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

   }

   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;

         for ("$_[1]") {
            y/\015//d; # weed out any \015, as they show up in the weirdest of places.
            /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
                or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid server response" };

            # 100 Continue handling
            # should not happen as we don't send expect: 100-continue,
            # but we handle it just in case.
            # since we send the request body regardless, if we get an error
            # we are out of-sync, which we currently do NOT handle correctly.
            return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
               if $1 eq 100;

            push @pseudo,
               HTTPVersion => $1,
               Status      => $2,
               Reason      => $3,
            ;

            my $hdr = _parse_hdr
               or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Garbled response headers" };

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

         # redirect handling
         # 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/^\.\/+//;