File Coverage

blib/lib/LWPx/ParanoidAgent.pm

Criterion	Covered	Total	%
statement	181	228	79.3
branch	84	140	60.0
condition	53	91	58.2
subroutine	18	20	90.0
pod	5	7	71.4
total	341	486	70.1

package LWPx::ParanoidAgent;
require LWP::UserAgent;

use vars qw(@ISA $VERSION);
@ISA = qw(LWP::UserAgent);
$VERSION = '1.08_02';

require HTTP::Request;
require HTTP::Response;

use HTTP::Status ();
use strict;
use Net::DNS;
use LWP::Debug ();

sub new {
    my $class = shift;
    my %opts = @_;

    my $blocked_hosts     = delete $opts{blocked_hosts}     || [];
    my $whitelisted_hosts = delete $opts{whitelisted_hosts} || [];
    my $resolver          = delete $opts{resolver};
    my $paranoid_proxy    = delete $opts{paranoid_proxy};
    $opts{timeout}      ||= 15;

    my $self = LWP::UserAgent->new( %opts );

    $self->{'blocked_hosts'}     = $blocked_hosts;
    $self->{'whitelisted_hosts'} = $whitelisted_hosts;
    $self->{'resolver'}          = $resolver;
    $self->{'paranoid_proxy'}    = $paranoid_proxy;

    $self = bless $self, $class;
    return $self;
}

# returns seconds remaining given a request
sub _time_remain {
    my $self = shift;
    my $req = shift;

    my $now = time();
    my $start_time = $req->{_time_begin} || $now;
    return $start_time + $self->{timeout} - $now;
}

sub _resolve {
    my ($self, $host, $request, $timeout, $depth) = @_;
    my $res = $self->resolver;
    $depth ||= 0;

    die "CNAME recursion depth limit exceeded.\n" if $depth > 10;
    die "DNS lookup resulted in bad host." if $self->_bad_host($host);

    # return the IP address if it looks like one and wasn't marked bad
    return ($host) if $host =~ /^\d+\.\d+\.\d+\.\d+$/;

    my $sock = $res->bgsend($host)
        or die "No sock from bgsend";

    # wait for the socket to become readable, unless this is from our test
    # mock resolver.
    unless ($sock && $sock eq "MOCK") {
        my $rin = '';
        vec($rin, fileno($sock), 1) = 1;
        my $nf = select($rin, undef, undef, $self->_time_remain($request));
        die "DNS lookup timeout" unless $nf;
    }

    my $packet = $res->bgread($sock)
        or die "DNS bgread failure";
    $sock = undef;

    my @addr;
    my $cname;
    foreach my $rr ($packet->answer) {
        if ($rr->type eq "A") {
            die "Suspicious DNS results from A record\n" if $self->_bad_host($rr->address);
            # untaints the address:
            push @addr, join(".", ($rr->address =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/));
        } elsif ($rr->type eq "CNAME") {
            # will be checked for validity in the recursion path
            $cname = $rr->cname;
        }
    }

    return @addr if @addr;
    return () unless $cname;
    return $self->_resolve($cname, $request, $timeout, $depth + 1);
}

sub _host_list_match {
    my $self = shift;
    my $list_name = shift;
    my $host = shift;

    foreach my $rule (@{ $self->{$list_name} || [] }) {
        if (ref $rule eq "CODE") {
            return 1 if $rule->($host);
        } elsif (ref $rule) {
            # assume regexp
            return 1 if $host =~ /$rule/;
        } else {
            return 1 if $host eq $rule;
        }
    }
}

sub _bad_host {
    my $self = shift;
    my $host = lc(shift);

    return 0 if $self->_host_list_match("whitelisted_hosts", $host);
    return 1 if $self->_host_list_match("blocked_hosts", $host);
    return 1 if
        $host =~ /^localhost$/i ||    # localhost is bad.  even though it'd be stopped in
                                      #    a later call to _bad_host with the IP address
        $host =~ /\s/i;               # any whitespace is questionable

    # Let's assume it's an IP address now, and get it into 32 bits.
    # Uf at any time something doesn't look like a number, then it's
    # probably a hostname and we've already either whitelisted or
    # blacklisted those, so we'll just say it's okay and it'll come
    # back here later when the resolver finds an IP address.
    my @parts = split(/\./, $host);
    return 0 if @parts > 4;

    # un-octal/un-hex the parts, or return if there's a non-numeric part
    my $overflow_flag = 0;
    foreach (@parts) {
        return 0 unless /^\d+$/ || /^0x[a-f\d]+$/;
        local $SIG{__WARN__} = sub { $overflow_flag = 1; };
        $_ = oct($_) if /^0/;
    }

    # a purely numeric address shouldn't overflow.
    return 1 if $overflow_flag;

    my $addr;  # network order packed IP address

    if (@parts == 1) {
        # a - 32 bits
        return 1 if
            $parts[0] > 0xffffffff;
        $addr = pack("N", $parts[0]);
    } elsif (@parts == 2) {
        # a.b - 8.24 bits
        return 1 if
            $parts[0] > 0xff ||
            $parts[1] > 0xffffff;
        $addr = pack("N", $parts[0] << 24 | $parts[1]);
    } elsif (@parts == 3) {
        # a.b.c - 8.8.16 bits
        return 1 if
            $parts[0] > 0xff ||
            $parts[1] > 0xff ||
            $parts[2] > 0xffff;
        $addr = pack("N", $parts[0] << 24 | $parts[1] << 16 | $parts[2]);
    } elsif (@parts == 4) {
        # a.b.c.d - 8.8.8.8 bits
        return 1 if
            $parts[0] > 0xff ||
            $parts[1] > 0xff ||
            $parts[2] > 0xff ||
            $parts[3] > 0xff;
        $addr = pack("N", $parts[0] << 24 | $parts[1] << 16 | $parts[2] << 8 | $parts[3]);
    } else {
        return 1;
    }

    my $haddr = unpack("N", $addr); # host order IP address
    return 1 if
        ($haddr & 0xFF000000) == 0x00000000 || # 0.0.0.0/8
        ($haddr & 0xFF000000) == 0x0A000000 || # 10.0.0.0/8
        ($haddr & 0xFF000000) == 0x7F000000 || # 127.0.0.0/8
        ($haddr & 0xFFF00000) == 0xAC100000 || # 172.16.0.0/12
        ($haddr & 0xFFFF0000) == 0xA9FE0000 || # 169.254.0.0/16
        ($haddr & 0xFFFF0000) == 0xC0A80000 || # 192.168.0.0/16
        ($haddr & 0xFFFFFF00) == 0xC0000200 || # 192.0.2.0/24  "TEST-NET" docs/example code
        ($haddr & 0xFFFFFF00) == 0xC0586300 || # 192.88.99.0/24 6to4 relay anycast addresses
         $haddr               == 0xFFFFFFFF || # 255.255.255.255
        ($haddr & 0xF0000000) == 0xE0000000;  # multicast addresses

    # as final IP address check, pass in the canonical a.b.c.d decimal form
    # to the blacklisted host check to see if matches as bad there.
    my $can_ip = join(".", map { ord } split //, $addr);
    return 1 if $self->_host_list_match("blocked_hosts", $can_ip);

    # looks like an okay IP address
    return 0;
}

sub request {
    my ($self, $req, $arg, $size, $previous) = @_;

    # walk back to the first request, and set our _time_begin to its _time_begin, or if
    # we're the first, then use current time.  used by LWPx::Protocol::http_paranoid
    my $first_res = $previous;  # previous is the previous response that invoked this request
    $first_res = $first_res->previous while $first_res && $first_res->previous;
    $req->{_time_begin} = $first_res ? $first_res->request->{_time_begin} : time();

    my $host = $req->uri->host;
    if ($self->_bad_host($host)) {
        my $err_res = HTTP::Response->new(403, "Unauthorized access to blocked host");
        $err_res->request($req);
        $err_res->header("Client-Date" => HTTP::Date::time2str(time));
        $err_res->header("Client-Warning" => "Internal response");
        $err_res->header("Content-Type" => "text/plain");
        $err_res->content("403 Unauthorized access to blocked host\n");
        return $err_res;
    }

    if (my $pp = $self->{paranoid_proxy}) {
        $req->uri("$pp?url="   . eurl($req->uri) .
                  "&timeout="  . ($self->{timeout}  + 0) .
                  "&max_size=" . ($self->{max_size} + 0));
    }

    return $self->SUPER::request($req, $arg, $size, $previous);
}

# taken from LWP::UserAgent and modified slightly.  (proxy support removed,
# and map http and https schemes to separate protocol handlers)
sub send_request
{
    my ($self, $request, $arg, $size) = @_;
    $self->_request_sanity_check($request);

    my ($method, $url) = ($request->method, $request->uri);

    local($SIG{__DIE__});  # protect against user defined die handlers

    # Check that we have a METHOD and a URL first
    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "Method missing")
        unless $method;
    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "URL missing")
        unless $url;
    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "URL must be absolute")
        unless $url->scheme;
    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST,
                         "ParanoidAgent doesn't support going through proxies.  ".
                         "In that case, do your paranoia at your proxy instead.")
        if $self->_need_proxy($url);

    my $scheme = $url->scheme;
    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "Only http and https are supported by ParanoidAgent")
        unless $scheme eq "http" || $scheme eq "https";

    LWP::Debug::trace("$method $url");

    my $protocol;

    {
      # Honor object-specific restrictions by forcing protocol objects
      #  into class LWP::Protocol::nogo.
        my $x;
        if($x       = $self->protocols_allowed) {
            if(grep lc($_) eq $scheme, @$x) {
                LWP::Debug::trace("$scheme URLs are among $self\'s allowed protocols (@$x)");
              }
            else {
                LWP::Debug::trace("$scheme URLs aren't among $self\'s allowed protocols (@$x)");
                  require LWP::Protocol::nogo;
                  $protocol = LWP::Protocol::nogo->new;
              }
        }
        elsif ($x = $self->protocols_forbidden) {
            if(grep lc($_) eq $scheme, @$x) {
                LWP::Debug::trace("$scheme URLs are among $self\'s forbidden protocols (@$x)");
                  require LWP::Protocol::nogo;
                  $protocol = LWP::Protocol::nogo->new;
              }
            else {
                LWP::Debug::trace("$scheme URLs aren't among $self\'s forbidden protocols (@$x)");
              }
        }
      # else fall thru and create the protocol object normally
    }

    unless ($protocol) {
        LWP::Protocol::implementor("${scheme}_paranoid",  "LWPx::Protocol::${scheme}_paranoid");
        eval "require LWPx::Protocol::${scheme}_paranoid;";
        if ($@) {
            $@ =~ s/ at .* line \d+.*//s;  # remove file/line number
            my $response =  _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
            return $response;
        }

        $protocol = eval { LWP::Protocol::create($scheme eq "http" ? "http_paranoid" : "https_paranoid", $self) };
        if ($@) {
            $@ =~ s/ at .* line \d+.*//s;  # remove file/line number
            my $response =  _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
            if ($scheme eq "https") {
                $response->message($response->message . " (Crypt::SSLeay not installed)");
                $response->content_type("text/plain");
                $response->content(<
LWP will support https URLs if the Crypt::SSLeay module is installed.
More information at .
EOT
}
            return $response;
        }
    }

    # Extract fields that will be used below
    my ($timeout, $cookie_jar, $use_eval, $parse_head, $max_size) =
        @{$self}{qw(timeout cookie_jar use_eval parse_head max_size)};

    my $response;
    my $proxy = undef;
    if ($use_eval) {
        # we eval, and turn dies into responses below
        eval {
            $response = $protocol->request($request, $proxy,
                                           $arg, $size, $timeout);
        };
        my $error = $@ || $response->header( 'x-died' );
        if ($error) {
            $error =~ s/ at .* line \d+.*//s; # remove file/line number
            $response = _new_response($request,
                                      &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
                                      $error);
        }
    }
    else {
        $response = $protocol->request($request, $proxy,
                                       $arg, $size, $timeout);
        # XXX: Should we die unless $response->is_success ???
    }

    $response->request($request);  # record request for reference
    $cookie_jar->extract_cookies($response) if $cookie_jar;
    $response->header("Client-Date" => HTTP::Date::time2str(time));
    $self->run_handlers("response_done", $response) if $self->can('run_handlers');
    return $response;
}

# blocked hostnames, compiled patterns, or subrefs
sub blocked_hosts
{
    my $self = shift;
    if (@_) {
        my @hosts = @_;
        $self->{'blocked_hosts'} = \@hosts;
        return;
    }
    return @{ $self->{'blocked_hosts'} || [] };
}

# whitelisted hostnames, compiled patterns, or subrefs
sub whitelisted_hosts
{
    my $self = shift;
    if (@_) {
        my @hosts = @_;
        $self->{'whitelisted_hosts'} = \@hosts;
        return;
    }
    return @{ $self->{'whitelisted_hosts'} || [] };
}

# get/set Net::DNS resolver object
sub resolver
{
    my $self = shift;
    if (@_) {
        $self->{'resolver'} = shift;
        require UNIVERSAL ;
        die "Not a Net::DNS::Resolver object" unless
            UNIVERSAL::isa($self->{'resolver'}, "Net::DNS::Resolver");
    }
    return $self->{'resolver'} ||= Net::DNS::Resolver->new;
}

# Taken directly from LWP::UserAgent because it was private there, and we can't depend on it
# staying there in future versions:  needed by our modified version of send_request
sub _need_proxy
{
    my($self, $url) = @_;
    $url = $HTTP::URI_CLASS->new($url) unless ref $url;

    my $scheme = $url->scheme || return;
    if (my $proxy = $self->{'proxy'}{$scheme}) {
        if ($self->{'no_proxy'} && @{ $self->{'no_proxy'} }) {
            if (my $host = eval { $url->host }) {
                for my $domain (@{ $self->{'no_proxy'} }) {
                    if ($host =~ /\Q$domain\E$/) {
                        LWP::Debug::trace("no_proxy configured");
                          return;
                      }
                }
            }
        }
        LWP::Debug::debug("Proxied to $proxy");
        return $HTTP::URI_CLASS->new($proxy);
    }
    LWP::Debug::debug('Not proxied');
    undef;
}

# Taken directly from LWP::UserAgent because it was private there, and we can't depend on it
# staying there in future versions:  needed by our modified version of send_request
sub _request_sanity_check {
    my($self, $request) = @_;
    # some sanity checking
    if (defined $request) {
        if (ref $request) {
            Carp::croak("You need a request object, not a " . ref($request) . " object")
              if ref($request) eq 'ARRAY' or ref($request) eq 'HASH' or
              !$request->can('method') or !$request->can('uri');
          }
        else {
            Carp::croak("You need a request object, not '$request'");
          }
    }
    else {
        Carp::croak("No request object passed in");
      }
}

# Taken directly from LWP::UserAgent because it was private there, and we can't depend on it
# staying there in future versions:  needed by our modified version of send_request
sub _new_response {
    my($request, $code, $message) = @_;
    my $response = HTTP::Response->new($code, $message);
    $response->request($request);
    $response->header("Client-Date" => HTTP::Date::time2str(time));
    $response->header("Client-Warning" => "Internal response");
    $response->header("Content-Type" => "text/plain");
    $response->content("$code $message\n");
    return $response;
}

sub eurl {
    my $a = $_[0];
    $a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg;
    $a =~ tr/ /+/;
    return $a;
}

1;

__END__