view release on metacpan or  search on metacpan

lib/Apache2/Proxy.pm  view on Meta::CPAN

        elsif (( grep { $_ eq 'gzip' } @h )
            || ( grep { $_ eq 'x-gzip' } @h ) )
        {    # some parts lifted from HTTP::Message

            # need a copy for memgzip, see HTTP::Message notes
            my $gzipped =
              eval { Compress::Zlib::memGzip($response_content_ref); };

            my $err = $@;
            if ($err) {
                $r->log->error("compression error: $err");
            } else {

                $r->log->debug("$$ compressed response from " . length($$response_content_ref) . " to " . length($gzipped)) if DEBUG;
                $$response_content_ref = $gzipped;
                $encoding              = 'gzip';
            }

        }
        elsif ( grep { $_ eq 'deflate' } @h ) {

            my $copy = $$response_content_ref;
            $$response_content_ref = Compress::Zlib::compress($copy);
            $encoding              = 'deflate';

        }
        else {
            $r->log->error( "$$ unknown content-encoding encountered:  "
                  . join( ',', @h ) );
        }
    }

    if ($encoding) {
        $r->log->debug("$$ setting content encoding to $encoding") if DEBUG;
        $r->content_encoding($encoding);
        delete $headers{'Transfer-Encoding'};    # don't want to be chunked here
    }
    delete $headers{'Content-Encoding'};

    ###########################
    # set the content length to the uncompressed content length
    $r->set_content_length( length($$response_content_ref) );
    delete $headers{'Content-Length'};

    ##########################################
    # this is for any additional headers, usually site specific
    $class->translate_remaining_headers( $r, \%headers );

    ###############################
    # possible through a nasty hack, set the server version
    $r->server->add_version_component( $headers{Server} || 'sl' );

    ###############################
    # maybe someday but not today, do not cache this response
    $r->no_cache(1);

    return 1;
}

# figure out what charset a response was made in, code adapted from
# HTTP::Message::decoded_content
sub response_charset {
    my ( $class, $r, $response ) = @_;

    # pull apart Content-Type header and extract charset
    my $charset;
    my @ct = HTTP::Headers::Util::split_header_words(
        $response->header("Content-Type") );
    if (@ct) {
        my ( undef, undef, %ct_param ) = @{ $ct[-1] };
        $charset = $ct_param{charset};
    }

    # if the charset wasn't in the http header look for meta-equiv
    unless ($charset) {

        # default charset for HTTP::Message - if it couldn't guess it will
        # have decoded as 8859-1, so we need to match that when
        # re-encoding
        return $charset || "ISO-8859-1";
    }
}

sub resolve {
    my ( $class, $hostname ) = @_;

    # run the dns query
    my $query = $Resolver->query($hostname);
    unless ($query) {

        die "dns resolution failed: " . $Resolver->errorstring;

    }
    else {

        foreach my $rr ( $query->answer ) {

            next unless $rr->type eq "A";

            # return the A record
            return $rr->address;
        }
    }

    die "could not resolve A record for $hostname";
}

sub handler {
    my ( $class, $r ) = @_;

    unless ($r->hostname) {
        $r->log->error("$$ no hostname for req " . $r->as_string);
        return Apache2::Const::HTTP_BAD_REQUEST;
    }

    # Build the request headers
    my $headers = $class->get_request_headers($r);

    my $url = $r->construct_url($r->unparsed_uri);
    $r->pnotes('url' => $url);

    my %get = (
        headers      => $headers,
        url          => $url,
    );

    my $ip;
    if ($r->hostname !~ m/^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {

        $r->log->debug( "$$ resolving host " . $r->hostname ) if DEBUG;
        $ip = eval { $class->resolve( $r->hostname ) };
        if ($@) {

            # dns error
            $r->log->error( "$$ unable to resolve host " . $r->hostname );
            return &crazypage($r);    # haha this page is kwazy!

        }
    } else {
        $ip = $r->hostname
    }

    $get{host} = $ip;
    $r->log->debug( "$$ making proxy request " . Dumper( \%get ) ) if DEBUG;

    # Make the request to the remote server
    my $response = eval { $class->get( \%get ); };

    # socket timeout, give em the crazy page
    if ($@) {
        $r->log->error("$$ error fetching $url : $@") if DEBUG;
        return &crazypage($r);    # haha this page is kwazy!
    }

    $r->log->debug("$$ request to $url complete") if DEBUG;

    # no response means html too big
    # send it to perlbal to reproxy
    unless ($response) {

        $r->log->error("$$ no response") if DEBUG;
        return Apache2::Const::NOT_FOUND;
    }

    $r->log->debug( "$$ Response headers from url $url proxy request code\n" 
          . "code: "
          . $response->code . "\n"
          . Dumper( $response->headers ) )
      if VERBOSE_DEBUG;

    # Dispatch the response
    my $sub = $Response{ $response->code };
    unless ( defined $sub ) {
        $r->log->error(
            sprintf(
                "No handler for response code %d, url %s, ua %s",
                $response->code, $url, $r->pnotes('ua')
            )
        );
        $sub = $Response{'404'};
    }

    $r->log->debug(
        sprintf(
            "$$ Request returned %d response: %s",
            $response->code, Dumper( $response->decoded_content ),
        )
    ) if VERBOSE_DEBUG;

    no strict 'refs';
    return $class->$sub( $r, $response );
}

# this page handles invalid urls, we run ads there

sub crazypage {
    my $r = shift;

    $r->content_type('text/html');
    $r->print( "<html><body><h2>Sorry the url "
          . $r->construct_url($r->unparsed_uri)
          . ' is not a valid hostname, please try again.</h2></body></html>' );
    return Apache2::Const::OK;
}

sub twoohfour {
    my ( $class, $r, $res ) = @_;

    # status line 204 response
    $r->status( $res->code );

    # translate the headers from the remote response to the proxy response
    my $translated = $class->set_response_headers( $r, $res );

    # rflush() flushes the headers to the client
    # thanks to gozer's mod_perl for speed presentation
    $r->rflush();

    # no content sent for a 204
    return Apache2::Const::OK;
}

sub twoohsix {
    my ( $class, $r, $res ) = @_;

    # set the status line here and I will beat you with a stick

    my $content_type = $res->content_type;
    $r->content_type($content_type) if $content_type;

    # translate the headers from the remote response to the proxy response
    my $translated = $class->set_response_headers( $r, $res );

    # rflush() flushes the headers to the client
    # thanks to gozer's mod_perl for speed presentation
    $r->rflush();

    $r->print( $res->content );

    # we send a 200 here so don't change this or mess with the status line!
    return Apache2::Const::OK;
}

sub bsod {
    my ( $class, $r, $res ) = @_;

lib/Apache2/Proxy.pm  view on Meta::CPAN

    $r->print( $res->content );

    return Apache2::Const::OK;
}

sub threeohone {
    my ( $class, $r, $res ) = @_;

    my $content_type = $res->content_type;
    $r->content_type($content_type) if $content_type;

    # translate the headers from the remote response to the proxy response
    my $translated = $class->set_response_headers( $r, $res );

    # do not change this line
    return Apache2::Const::HTTP_MOVED_PERMANENTLY;
}

# 302, 303, 307
sub redirect {
    my ( $class, $r, $res ) = @_;

    # translate the headers from the remote response to the proxy response
    my $translated = $class->set_response_headers( $r, $res );

    # do not change this line
    return Apache2::Const::REDIRECT;
}

sub threeohfour {
    my ( $class, $r, $res ) = @_;

    # set the status line
    $r->status( $res->code );

    # translate the headers from the remote response to the proxy response
    my $translated = $class->set_response_headers( $r, $res );

    # do not change this line
    return Apache2::Const::OK;
}

# the big dog
sub twohundred {
    my ( $class, $r, $response, $subref ) = @_;

    my $url = $r->pnotes('url');

    if ( $response->is_html ) {

        #$Cache->add_known_html( $url => $response->content_type );

    }
    else {

        #$Cache->add_known_not_html( $url => $response->content_type );
    }

    $r->log->debug( "$$ 200 for $url, length "
          . length( $response->decoded_content )
          . " bytes" )
      if DEBUG;

    my $response_content_ref = \$response->decoded_content;

    # set the status line
    $r->status_line( $response->status_line );
    $r->log->debug( "$$ status line is " . $response->status_line )
      if DEBUG;

    # set the response headers
    my $set_ok =
      $class->set_twohundred_response_headers( $r, $response,
        $response_content_ref );

    if (VERBOSE_DEBUG) {
        $r->log->debug( "$$ Response content: " . $$response_content_ref );
    }

    # rflush() flushes the headers to the client
    # thanks to gozer's mod_perl for speed presentation
    $r->rflush();

    my $bytes_sent = $r->print($$response_content_ref);
    $r->log->debug("$$ bytes sent: $bytes_sent") if DEBUG;

    return Apache2::Const::DONE;
}

sub get {
    my ( $class, $args_ref ) = @_;
    unless ( $args_ref->{url} ) {
        warn("$$ no url passed, returning");
        return;
    }
    my $url  = $args_ref->{url};
    my $host = $args_ref->{host} || $args_ref->{headers}->{Host} || 'localhost';
    my $port = $args_ref->{port} || 80;

    $url = URI->new($url) or die("Unable to parse url '$url'.");

    my $headers = $args_ref->{headers} || \%Headers;

    # convert headers to array-ref if a hash-ref is passed
    $headers = [%$headers] if ( ref $headers eq 'HASH' );

    my $http = Net::HTTP->new(
        Host     => $url->host,
        PeerAddr => $host,
        PeerPort => $port
    ) || die $@;

    # set keep alive
    $http->keep_alive(1);

    # reinforce the point (Net::HTTP adds PeerPort to host during
    # new())
    $http->host( $url->host );

    # make the request
    my $req = $url->path_query || "/";
    my $ok = $http->write_request( GET => $req, @$headers );

    # get the result code, message and response headers