view release on metacpan or  search on metacpan

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

   BIND			=> 1,
   CHECKIN		=> 1,
   CHECKOUT		=> 1,
   COPY			=> 1,
   LABEL		=> 1,
   LINK			=> 1,
   MERGE		=> 1,
   MKACTIVITY		=> 1,
   MKCALENDAR		=> 1,
   MKCOL		=> 1,
   MKREDIRECTREF	=> 1,
   MKWORKSPACE		=> 1,
   MOVE			=> 1,
   ORDERPATCH		=> 1,
   PROPFIND		=> 1,
   PROPPATCH		=> 1,
   REBIND		=> 1,
   REPORT		=> 1,
   SEARCH		=> 1,
   UNBIND		=> 1,
   UNCHECKOUT		=> 1,
   UNLINK		=> 1,
   UNLOCK		=> 1,
   UPDATE		=> 1,
   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;
      }
   }

   # pseudo headers for all subsequent responses
   my @pseudo = (URL => $url);
   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',