view release on metacpan or  search on metacpan

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

=cut


use Apache2::Const -compile => qw( OK SERVER_ERROR NOT_FOUND DECLINED
  REDIRECT LOG_DEBUG LOG_ERR LOG_INFO CONN_KEEPALIVE HTTP_BAD_REQUEST
  HTTP_UNAUTHORIZED HTTP_SEE_OTHER HTTP_MOVED_PERMANENTLY DONE
  HTTP_NO_CONTENT HTTP_PARTIAL_CONTENT HTTP_NOT_MODIFIED );
use Apache2::Connection  ();
use Apache2::Log         ();
use Apache2::RequestRec  ();
use Apache2::RequestUtil ();
use Apache2::RequestIO   ();
use Apache2::Response    ();
use Apache2::ServerRec   ();
use Apache2::ServerUtil  ();
use Apache2::URI         ();
use Apache2::Filter      ();
use APR::Table           ();

use Compress::Zlib ();
use Compress::Bzip2 ();
use Encode ();

use URI;
use Net::HTTP;
use HTTP::Response;
use HTTP::Headers;
use HTTP::Headers::Util ();
use Data::Dumper;
use Net::DNS;
our $Resolver = Net::DNS::Resolver->new;

use constant DEBUG         => 1;
use constant VERBOSE_DEBUG => 0;

use constant MAX_CONTENT_LENGTH => 131072;    # 128k

# firefox default headers
our %Headers = (
    'Accept-Encoding' => 'gzip,deflate',
    'Accept-Charset'  => 'ISO-8859-1,utf-8;q=0.7,*;q=0.7',
    'Accept-Lang'     => 'en-us,en;q=0.5',
    'Accept' =>
'text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5',
    'User-Agent' =>
'Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10.5; en-US; rv:1.9.0.10) Gecko/2009042315 Firefox/3.0.10',
);

our %Response = (
    200 => 'twohundred',
    204 => 'twoohfour',
    206 => 'twoohsix',
    301 => 'threeohone',
    302 => 'redirect',
    303 => 'redirect',
    304 => 'threeohfour',
    307 => 'redirect',
    400 => 'bsod',
    401 => 'bsod',
    403 => 'bsod',
    404 => 'bsod',
    410 => 'bsod',
    500 => 'bsod',
    502 => 'bsod',
    503 => 'bsod',
    504 => 'bsod',
);

# handles common proxy functions

# takes $r and returns the http headers

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

    my %headers;
    $r->headers_in->do(
        sub {
            my $k = shift;
            my $v = shift;

            if ( $k =~ m/^connection/i ) {
                $headers{$k} = 'keep-alive';
                return 1;
            }

            # pass this header onto the remote request
            $headers{$k} = $v;

            return 1;    # don't remove me or you will burn in hell baby
        }
    );

    # work around clients which don't support compression
    if ( !exists $headers{'Accept-Encoding'} ) {
        $r->log->debug(
            "$$ client DOES NOT support compression " . Dumper( \%headers ) )
          if VERBOSE_DEBUG;

        # set default outgoing compression headers
        $headers{'Accept-Encoding'} = 'gzip, deflate';
    }
    else {
        $r->log->debug(
            "$$ client supports compression " . $headers{'Accept-Encoding'} )
          if VERBOSE_DEBUG;
        $r->pnotes(
            client_supports_compression => $headers{'Accept-Encoding'} );
    }

    $r->log->debug( "$$ proxy request headers " . Dumper( \%headers ) )
      if DEBUG;

    return \%headers;
}

# Takes an HTTP::Response object, clears the response headers,
# adds cookie and auth headers, and additional headers
# Sets the Server header to sl if it is not defined.

sub set_response_headers {

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

    $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!