import version 1.04

7 files changed, 1406 insertions, 0 deletions

diff --git a/ChangeLog b/ChangeLog
new file mode 100644
index 0000000..1caea61
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,32 @@
+1.04:  2008-10-30
+	- fix tests to no longer rely on my DNS servers, which had since migrated
+	  to EasyDNS which doesn't allow the types of malicious records I was
+	  testing for.  instead, switch to a mock object resolver.
+	  (Brad Fitzpatrick, brad@danga.com)
+
+1.03:  2006-08-21
+	- run under taint mode (Curtis Jewell <perl@csjewell.fastmail.us>)
+
+        - block 192.0.2.0/24 and 192.88.99.0/24 (Robby Griffin <rmg@terc.edu>)
+
+1.02:  2005-05-24
+	- block 0.0.0.0/8 as well (Andy Thomas <andy.thomas2@gmail.com>)
+
+1.01:  2005-05-23
+	- more POD docs (constructor and method calls)
+
+	- be aware of all forms of IP address (a, a.b, a.b.c, a.b.c.d)
+	  where all of a, b, c, and d can be in decimal, octal, or hex.
+	  (thanks to Martin Atkins and Timwi for pointing this out) pass
+	  in the canonicalized version of the IP address to the bad hosts
+	  checker.
+
+1.00:  2005-05-20
+ 	- fix holes pointed out by Martin Atkins (led to me doing all the
+	  Net::DNS and manual resolving work)
+
+	- bundle the test script by adding a local webserver mode to it,
+	  rather than using an xinetd script
+
+0.99:  2005-05-19
+     - initial release
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..d6a2083
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,8 @@
+MANIFEST
+Makefile.PL
+ChangeLog
+lib/LWPx/Protocol/http_paranoid.pm
+lib/LWPx/Protocol/https_paranoid.pm
+lib/LWPx/ParanoidAgent.pm
+t/00-all.t
+META.yml                                 Module meta-data (added by MakeMaker)
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..90f8d9e
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,13 @@
+use ExtUtils::MakeMaker;
+WriteMakefile( 'NAME' => 'LWPx::ParanoidAgent',
+               'VERSION_FROM' => 'lib/LWPx/ParanoidAgent.pm',
+               'PREREQ_PM'		=> {
+                   'LWP::UserAgent' => 0,
+                   'Net::DNS'       => 0,
+                   'Time::HiRes'    => 0,
+               },
+               ($] >= 5.005 ?
+                (ABSTRACT_FROM => 'lib/LWPx/ParanoidAgent.pm',
+                 AUTHOR     => 'Brad Fitzpatrick <brad@danga.com>') : ()),
+               );
+
diff --git a/lib/LWPx/ParanoidAgent.pm b/lib/LWPx/ParanoidAgent.pm
new file mode 100644
index 0000000..bbd0d77
--- /dev/null
+++ b/lib/LWPx/ParanoidAgent.pm
@@ -0,0 +1,578 @@
+package LWPx::ParanoidAgent;
+require LWP::UserAgent;
+
+use vars qw(@ISA $VERSION);
+@ISA = qw(LWP::UserAgent);
+$VERSION = '1.04';
+
+require HTTP::Request;
+require HTTP::Response;
+
+use HTTP::Status ();
+use strict;
+use Net::DNS;
+
+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]);
+    } else {
+        # 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]);
+    }
+
+    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(<<EOT);
+LWP will support https URLs if the Crypt::SSLeay module is installed.
+More information at <http://www.linpro.no/lwp/libwww-perl/README.SSL>.
+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);
+        };
+        if ($@) {
+            $@ =~ s/ at .* line \d+.*//s;  # remove file/line number
+            $response = _new_response($request,
+                                      &HTTP::Status::RC_INTERNAL_SERVER_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));
+    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__
+
+=head1 NAME
+
+LWPx::ParanoidAgent - subclass of LWP::UserAgent that protects you from harm
+
+=head1 SYNOPSIS
+
+ require LWPx::ParanoidAgent;
+
+ my $ua = LWPx::ParanoidAgent->new;
+
+ # this is 10 seconds overall, from start to finish.  not just between
+ # socket reads.  and it includes all redirects.  so attackers telling
+ # you to download from a malicious tarpit webserver can only stall
+ # you for $n seconds
+
+ $ua->timeout(10);
+
+ # setup extra block lists, in addition to the always-enforced blocking
+ # of private IP addresses, loopbacks, and multicast addresses
+
+ $ua->blocked_hosts(
+    "foo.com",
+    qr/\.internal\.company\.com$/i,
+    sub { my $host = shift;  return 1 if is_bad($host); },
+ );
+
+ $ua->whitelisted_hosts(
+    "brad.lj",
+    qr/^192\.168\.64\.3?/,
+    sub { ... },
+ );
+
+ # get/set the DNS resolver object that's used
+ my $resolver = $ua->resolver;
+ $ua->resolver(Net::DNS::Resolver->new(...));
+
+ # and then just like a normal LWP::UserAgent, because it is one.
+ my $response = $ua->get('http://search.cpan.org/');
+ ...
+ if ($response->is_success) {
+     print $response->content;  # or whatever
+ }
+ else {
+     die $response->status_line;
+ }
+
+=head1 DESCRIPTION
+
+The C<LWPx::ParanoidAgent> is a class subclassing C<LWP::UserAgent>,
+but paranoid against attackers.  It's to be used when you're fetching
+a remote resource on behalf of a possibly malicious user.
+
+This class can do whatever C<LWP::UserAgent> can (callbacks, uploads from
+files, etc), except proxy support is explicitly removed, because in
+that case you should do your paranoia at your proxy.
+
+Also, the schemes are limited to http and https, which are mapped to
+C<LWPx::Protocol::http_paranoid> and
+C<LWPx::Protocol::https_paranoid>, respectively, which are forked
+versions of the same ones without the "_paranoid".  Subclassing them
+didn't look possible, as they were essentially just one huge function.
+
+This class protects you from connecting to internal IP ranges (unless you
+whitelist them), hostnames/IPs that you blacklist, remote webserver
+tarpitting your process (the timeout parameter is changed to be a global
+timeout over the entire process), and all combinations of redirects and
+DNS tricks to otherwise tarpit and/or connect to internal resources.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item C<new>
+
+my $ua = LWPx::ParanoidAgent->new([ %opts ]);
+
+In addition to any constructor options from L<LWP::UserAgent>, you may
+also set C<blocked_hosts> (to an arrayref), C<whitelisted_hosts> (also
+an arrayref), and C<resolver>, a Net::DNS::Resolver object.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $csr->B<resolver>($net_dns_resolver)
+
+=item $csr->B<resolver>
+
+Get/set the L<Net::DNS::Resolver> object used to lookup hostnames.
+
+=item $csr->B<blocked_hosts>(@host_list)
+
+=item $csr->B<blocked_hosts>
+
+Get/set the the list of blocked hosts.  The items in @host_list may be
+compiled regular expressions (with qr//), code blocks, or scalar
+literals.  In any case, the thing that is match, passed in, or
+compared (respectively), is all of the given hostname, given IP
+address, and IP address in canonical a.b.c.d decimal notation.  So if
+you want to block "1.2.3.4" and the user entered it in a mix of
+network/host form in a mix of decimal/octal/hex, you need only block
+"1.2.3.4" and not worry about the details.
+
+=item $csr->B<whitelisted_hosts>(@host_list)
+
+=item $csr->B<whitelisted_hosts>
+
+Like blocked hosts, but matching the hosts/IPs that bypass blocking
+checks.  The only difference is the IP address isn't canonicalized
+before being whitelisted-matched, mostly because it doesn't make sense
+for somebody to enter in a good address in a subversive way.
+
+=back
+
+=head1 SEE ALSO
+
+See L<LWP::UserAgent> to see how to use this class.
+
+=head1 WARRANTY
+
+This module is supplied "as-is" and comes with no warranty, expressed
+or implied.  It tries to protect you from harm, but maybe it will.
+Maybe it will destroy your data and your servers.  You'd better audit
+it and send me bug reports.
+
+=head1 BUGS
+
+Maybe.  See the warranty above.
+
+=head1 COPYRIGHT
+
+Copyright 2005 Brad Fitzpatrick
+
+Lot of code from the the base class, copyright 1995-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
diff --git a/lib/LWPx/Protocol/http_paranoid.pm b/lib/LWPx/Protocol/http_paranoid.pm
new file mode 100644
index 0000000..e45fa1e
--- /dev/null
+++ b/lib/LWPx/Protocol/http_paranoid.pm
@@ -0,0 +1,428 @@
+# $Id: http_paranoid.pm 2 2005-06-01 23:12:25Z bradfitz $
+#
+
+package LWPx::Protocol::http_paranoid;
+
+use strict;
+
+require LWP::Debug;
+require HTTP::Response;
+require HTTP::Status;
+require Net::HTTP;
+
+use vars qw(@ISA $TOO_LATE $TIME_REMAIN);
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+my $CRLF = "\015\012";
+
+# lame hack using globals in this package to communicate to sysread in the
+# package at bottom, but whatchya gonna do?  Don't want to go modify
+# Net::HTTP::* to pass explicit timeouts to all the sysreads.
+sub _set_time_remain {
+    my $now = time;
+    return unless defined $TOO_LATE;
+    $TIME_REMAIN = $TOO_LATE - $now;
+    $TIME_REMAIN = 0 if $TIME_REMAIN < 0;
+}
+
+sub _new_socket
+{
+    my($self, $host, $port, $timeout, $request) = @_;
+
+    my $conn_cache = $self->{ua}{conn_cache};
+    if ($conn_cache) {
+	if (my $sock = $conn_cache->withdraw("http", "$host:$port")) {
+	    return $sock if $sock && !$sock->can_read(0);
+	    # if the socket is readable, then either the peer has closed the
+	    # connection or there are some garbage bytes on it.  In either
+	    # case we abandon it.
+	    $sock->close;
+	}
+    }
+
+    my @addrs = $self->{ua}->_resolve($host, $request, $timeout);
+    unless (@addrs) {
+	die "Can't connect to $host:$port (No suitable addresses found)";
+    }
+
+    my $sock;
+    local($^W) = 0;  # IO::Socket::INET can be noisy
+
+    while (! $sock && @addrs) {
+        my $addr = shift @addrs;
+
+        my $conn_timeout = $request->{_timebegin} ?
+            (time() - $request->{_timebegin}) :
+            $timeout;
+
+        $sock = $self->socket_class->new(PeerAddr => $addr,
+                                         PeerPort => $port,
+                                         Proto    => 'tcp',
+                                         Timeout  => $conn_timeout,
+                                         KeepAlive => !!$conn_cache,
+                                         SendTE    => 1,
+                                         );
+    }
+
+    unless ($sock) {
+	# IO::Socket::INET leaves additional error messages in $@
+	$@ =~ s/^.*?: //;
+	die "Can't connect to $host:$port ($@)";
+    }
+
+    # perl 5.005's IO::Socket does not have the blocking method.
+    eval { $sock->blocking(0); };
+
+    $sock;
+}
+
+sub socket_class
+{
+    my $self = shift;
+    (ref($self) || $self) . "::Socket";
+}
+
+sub _get_sock_info
+{
+    my($self, $res, $sock) = @_;
+    if (defined(my $peerhost = $sock->peerhost)) {
+        $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
+    }
+}
+
+sub _fixup_header
+{
+    my($self, $h, $url, $proxy) = @_;
+
+    # Extract 'Host' header
+    my $hhost = $url->authority;
+    if ($hhost =~ s/^([^\@]*)\@//) {  # get rid of potential "user:pass@"
+	# add authorization header if we need them.  HTTP URLs do
+	# not really support specification of user and password, but
+	# we allow it.
+	if (defined($1) && not $h->header('Authorization')) {
+	    require URI::Escape;
+	    $h->authorization_basic(map URI::Escape::uri_unescape($_),
+				    split(":", $1, 2));
+	}
+    }
+    $h->init_header('Host' => $hhost);
+
+}
+
+sub hlist_remove {
+    my($hlist, $k) = @_;
+    $k = lc $k;
+    for (my $i = @$hlist - 2; $i >= 0; $i -= 2) {
+	next unless lc($hlist->[$i]) eq $k;
+	splice(@$hlist, $i, 2);
+    }
+}
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+    LWP::Debug::trace('()');
+
+    # paranoid:  now $timeout means total time, not just between bytes coming in.
+    # avoids attacker servers from tarpitting a service that fetches URLs.
+    $TOO_LATE     = undef;
+    $TIME_REMAIN  = undef;
+    if ($timeout) {
+        my $start_time = $request->{_time_begin} || time();
+        $TOO_LATE = $start_time + $timeout;
+    }
+
+    $size ||= 4096;
+
+    # check method
+    my $method = $request->method;
+    unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) {  # HTTP token
+	return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
+				  'Library does not allow method ' .
+				  "$method for 'http:' URLs";
+    }
+
+    my $url = $request->url;
+    my($host, $port, $fullpath);
+
+    $host = $url->host;
+    $port = $url->port;
+    $fullpath = $url->path_query;
+    $fullpath = "/$fullpath" unless $fullpath =~ m,^/,;
+
+    # connect to remote sites
+    my $socket = $self->_new_socket($host, $port, $timeout, $request);
+
+    my @h;
+    my $request_headers = $request->headers->clone;
+    $self->_fixup_header($request_headers, $url, $proxy);
+
+    $request_headers->scan(sub {
+			       my($k, $v) = @_;
+			       $k =~ s/^://;
+			       $v =~ s/\n/ /g;
+			       push(@h, $k, $v);
+			   });
+
+    my $content_ref = $request->content_ref;
+    $content_ref = $$content_ref if ref($$content_ref);
+    my $chunked;
+    my $has_content;
+
+    if (ref($content_ref) eq 'CODE') {
+	my $clen = $request_headers->header('Content-Length');
+	$has_content++ if $clen;
+	unless (defined $clen) {
+	    push(@h, "Transfer-Encoding" => "chunked");
+	    $has_content++;
+	    $chunked++;
+	}
+    }
+    else {
+	# Set (or override) Content-Length header
+	my $clen = $request_headers->header('Content-Length');
+	if (defined($$content_ref) && length($$content_ref)) {
+	    $has_content++;
+	    if (!defined($clen) || $clen ne length($$content_ref)) {
+		if (defined $clen) {
+		    warn "Content-Length header value was wrong, fixed";
+		    hlist_remove(\@h, 'Content-Length');
+		}
+		push(@h, 'Content-Length' => length($$content_ref));
+	    }
+	}
+	elsif ($clen) {
+	    warn "Content-Length set when there is not content, fixed";
+	    hlist_remove(\@h, 'Content-Length');
+	}
+    }
+
+    my $req_buf = $socket->format_request($method, $fullpath, @h);
+    #print "------\n$req_buf\n------\n";
+
+    # XXX need to watch out for write timeouts
+    # FIXME_BRAD: make it non-blocking and select during the write
+    {
+	my $n = $socket->syswrite($req_buf, length($req_buf));
+	die $! unless defined($n);
+	die "short write" unless $n == length($req_buf);
+	#LWP::Debug::conns($req_buf);
+    }
+
+    my($code, $mess, @junk);
+    my $drop_connection;
+
+    if ($has_content) {
+	my $write_wait = 0;
+	$write_wait = 2
+	    if ($request_headers->header("Expect") || "") =~ /100-continue/;
+
+	my $eof;
+	my $wbuf;
+	my $woffset = 0;
+	if (ref($content_ref) eq 'CODE') {
+	    my $buf = &$content_ref();
+	    $buf = "" unless defined($buf);
+	    $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
+		if $chunked;
+	    $wbuf = \$buf;
+	}
+	else {
+	    $wbuf = $content_ref;
+	    $eof = 1;
+	}
+
+	my $fbits = '';
+	vec($fbits, fileno($socket), 1) = 1;
+
+	while ($woffset < length($$wbuf)) {
+
+	    my $time_before;
+
+            my $now = time();
+            if ($now > $TOO_LATE) {
+                die "Request took too long.";
+            }
+
+	    my $sel_timeout = $TOO_LATE - $now;
+	    if ($write_wait) {
+		$time_before = time;
+		$sel_timeout = $write_wait if $write_wait < $sel_timeout;
+	    }
+
+	    my $rbits = $fbits;
+	    my $wbits = $write_wait ? undef : $fbits;
+	    my $nfound = select($rbits, $wbits, undef, $sel_timeout);
+	    unless (defined $nfound) {
+		die "select failed: $!";
+	    }
+
+	    if ($write_wait) {
+		$write_wait -= time - $time_before;
+		$write_wait = 0 if $write_wait < 0;
+	    }
+
+	    if (defined($rbits) && $rbits =~ /[^\0]/) {
+		# readable
+		my $buf = $socket->_rbuf;
+
+                _set_time_remain();
+
+		my $n = $socket->sysread($buf, 1024, length($buf));
+		unless ($n) {
+		    die "EOF";
+		}
+		$socket->_rbuf($buf);
+		if ($buf =~ /\015?\012\015?\012/) {
+		    # a whole response present
+		    ($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
+									junk_out => \@junk,
+								       );
+		    if ($code eq "100") {
+			$write_wait = 0;
+			undef($code);
+		    }
+		    else {
+			$drop_connection++;
+			last;
+			# XXX should perhaps try to abort write in a nice way too
+		    }
+		}
+	    }
+	    if (defined($wbits) && $wbits =~ /[^\0]/) {
+		my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
+		unless ($n) {
+		    die "syswrite: $!" unless defined $n;
+		    die "syswrite: no bytes written";
+		}
+		$woffset += $n;
+
+		if (!$eof && $woffset >= length($$wbuf)) {
+		    # need to refill buffer from $content_ref code
+		    my $buf = &$content_ref();
+		    $buf = "" unless defined($buf);
+		    $eof++ unless length($buf);
+		    $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
+			if $chunked;
+		    $wbuf = \$buf;
+		    $woffset = 0;
+		}
+	    }
+	}
+    }
+
+    _set_time_remain();
+    ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
+	unless $code;
+    ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
+	if $code eq "100";
+
+    my $response = HTTP::Response->new($code, $mess);
+    my $peer_http_version = $socket->peer_http_version;
+    $response->protocol("HTTP/$peer_http_version");
+    while (@h) {
+	my($k, $v) = splice(@h, 0, 2);
+	$response->push_header($k, $v);
+    }
+    $response->push_header("Client-Junk" => \@junk) if @junk;
+
+    $response->request($request);
+    $self->_get_sock_info($response, $socket);
+
+    if ($method eq "CONNECT") {
+	$response->{client_socket} = $socket;  # so it can be picked up
+	return $response;
+    }
+
+    if (my @te = $response->remove_header('Transfer-Encoding')) {
+	$response->push_header('Client-Transfer-Encoding', \@te);
+    }
+    $response->push_header('Client-Response-Num', $socket->increment_response_count);
+
+    my $complete;
+    $response = $self->collect($arg, $response, sub {
+	my $buf = ""; #prevent use of uninitialized value in SSLeay.xs
+	my $n;
+      READ:
+	{
+            _set_time_remain();
+	    $n = $socket->read_entity_body($buf, $size);
+	    die "Can't read entity body: $!" unless defined $n;
+	    redo READ if $n == -1;
+	}
+	$complete++ if !$n;
+        return \$buf;
+    } );
+    $drop_connection++ unless $complete;
+
+    _set_time_remain();
+    @h = $socket->get_trailers;
+    while (@h) {
+	my($k, $v) = splice(@h, 0, 2);
+	$response->push_header($k, $v);
+    }
+
+    # keep-alive support
+    unless ($drop_connection) {
+	if (my $conn_cache = $self->{ua}{conn_cache}) {
+	    my %connection = map { (lc($_) => 1) }
+		             split(/\s*,\s*/, ($response->header("Connection") || ""));
+	    if (($peer_http_version eq "1.1" && !$connection{close}) ||
+		$connection{"keep-alive"})
+	    {
+		LWP::Debug::debug("Keep the http connection to $host:$port");
+		$conn_cache->deposit("http", "$host:$port", $socket);
+	    }
+	}
+    }
+
+    $response;
+}
+
+
+#-----------------------------------------------------------
+package LWPx::Protocol::http_paranoid::SocketMethods;
+
+sub sysread {
+    my $self = shift;
+    my $timeout = $LWPx::Protocol::http_paranoid::TIME_REMAIN;
+
+    if (defined $timeout) {
+	die "read timeout" unless $self->can_read($timeout);
+    }
+    else {
+	# since we have made the socket non-blocking we
+	# use select to wait for some data to arrive
+	$self->can_read(undef) || die "Assert";
+    }
+    sysread($self, $_[0], $_[1], $_[2] || 0);
+}
+
+sub can_read {
+    my($self, $timeout) = @_;
+    my $fbits = '';
+    vec($fbits, fileno($self), 1) = 1;
+    my $nfound = select($fbits, undef, undef, $timeout);
+    die "select failed: $!" unless defined $nfound;
+    return $nfound > 0;
+}
+
+sub ping {
+    my $self = shift;
+    !$self->can_read(0);
+}
+
+sub increment_response_count {
+    my $self = shift;
+    return ++${*$self}{'myhttp_response_count'};
+}
+
+#-----------------------------------------------------------
+package LWPx::Protocol::http_paranoid::Socket;
+use vars qw(@ISA);
+@ISA = qw(LWPx::Protocol::http_paranoid::SocketMethods Net::HTTP);
+
+1;
diff --git a/lib/LWPx/Protocol/https_paranoid.pm b/lib/LWPx/Protocol/https_paranoid.pm
new file mode 100644
index 0000000..c291f75
--- /dev/null
+++ b/lib/LWPx/Protocol/https_paranoid.pm
@@ -0,0 +1,49 @@
+#
+package LWPx::Protocol::https_paranoid;
+
+# $Id: https_paranoid.pm 2 2005-06-01 23:12:25Z bradfitz $
+
+use strict;
+
+use vars qw(@ISA);
+require LWPx::Protocol::http_paranoid;
+@ISA = qw(LWPx::Protocol::http_paranoid);
+
+sub _check_sock
+{
+    my($self, $req, $sock) = @_;
+    my $check = $req->header("If-SSL-Cert-Subject");
+    if (defined $check) {
+	my $cert = $sock->get_peer_certificate ||
+	    die "Missing SSL certificate";
+	my $subject = $cert->subject_name;
+	die "Bad SSL certificate subject: '$subject' !~ /$check/"
+	    unless $subject =~ /$check/;
+	$req->remove_header("If-SSL-Cert-Subject");  # don't pass it on
+    }
+}
+
+sub _get_sock_info
+{
+    my $self = shift;
+    $self->SUPER::_get_sock_info(@_);
+    my($res, $sock) = @_;
+    $res->header("Client-SSL-Cipher" => $sock->get_cipher);
+    my $cert = $sock->get_peer_certificate;
+    if ($cert) {
+	$res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
+	$res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
+    }
+    if(! eval { $sock->get_peer_verify }) {
+       $res->header("Client-SSL-Warning" => "Peer certificate not verified");
+    }
+}
+
+#-----------------------------------------------------------
+package LWPx::Protocol::https_paranoid::Socket;
+
+use vars qw(@ISA);
+require Net::HTTPS;
+@ISA = qw(Net::HTTPS LWPx::Protocol::http_paranoid::SocketMethods);
+
+1;
diff --git a/t/00-all.t b/t/00-all.t
new file mode 100755
index 0000000..eddfb7c
--- /dev/null
+++ b/t/00-all.t
@@ -0,0 +1,298 @@
+#!/usr/bin/perl
+#
+
+use strict;
+use LWPx::ParanoidAgent;
+use Time::HiRes qw(time);
+use Test::More tests => 29;
+use Net::DNS;
+use IO::Socket::INET;
+
+my ($t1, $td);
+my $delta = sub { printf " %.03f secs\n", $td; };
+
+my $ua = LWPx::ParanoidAgent->new;
+ok((ref $ua) =~ /LWPx::ParanoidAgent/);
+
+my $mock_resolver = MockResolver->new;
+
+# Record pointing to localhost:
+{
+    my $packet = Net::DNS::Packet->new;
+    $packet->push(answer => Net::DNS::RR->new("localhost-fortest.danga.com. 86400 A 127.0.0.1"));
+    $mock_resolver->set_fake_record("localhost-fortest.danga.com", $packet);
+}
+
+# CNAME to blocked destination:
+{
+    my $packet = Net::DNS::Packet->new;
+    $packet->push(answer => Net::DNS::RR->new("bradlj-fortest.danga.com 300 IN CNAME brad.lj"));
+    $mock_resolver->set_fake_record("bradlj-fortest.danga.com", $packet);
+}
+
+$ua->resolver($mock_resolver);
+
+my ($HELPER_IP, $HELPER_PORT) = ("127.66.74.70", 9001);
+
+my $child_pid = fork;
+unless ($child_pid) {
+    web_server_mode();
+}
+END {
+    if ($child_pid) {
+        print STDERR "Killing child pid: $child_pid\n";
+        kill 9, $child_pid;
+    }
+}
+select undef, undef, undef, 0.5;
+
+my $HELPER_SERVER = "http://$HELPER_IP:$HELPER_PORT";
+
+
+$ua->whitelisted_hosts(
+                       $HELPER_IP,
+                       );
+
+$ua->blocked_hosts(
+                   qr/\.lj$/,
+                   "1.2.3.6",
+                   );
+
+my $res;
+
+# hostnames pointing to internal IPs
+$res = $ua->get("http://localhost-fortest.danga.com/");
+ok(! $res->is_success);
+like($res->status_line, qr/Suspicious DNS results/);
+$ua->resolver(Net::DNS::Resolver->new);
+
+# random IP address forms
+$res = $ua->get("http://0x7f.1/");
+ok(! $res->is_success && $res->status_line =~ /blocked/);
+$res = $ua->get("http://0x7f.0xffffff/");
+ok(! $res->is_success && $res->status_line =~ /blocked/);
+$res = $ua->get("http://037777777777/");
+ok(! $res->is_success && $res->status_line =~ /blocked/);
+$res = $ua->get("http://192.052000001/");
+ok(! $res->is_success && $res->status_line =~ /blocked/);
+$res = $ua->get("http://0x00.00/");
+ok(! $res->is_success && $res->status_line =~ /blocked/);
+
+# test the the blocked host above in decimal form is blocked by this non-decimal form:
+$res = $ua->get("http://0x01.02.0x306/");
+ok(! $res->is_success && $res->status_line =~ /blocked/);
+
+# more blocked spaces
+$res = $ua->get("http://192.0.2.13/");
+ok(! $res->is_success && $res->status_line =~ /blocked/);
+$res = $ua->get("http://192.88.99.77/");
+ok(! $res->is_success && $res->status_line =~ /blocked/);
+
+# hostnames doing CNAMEs (this one resolves to "brad.lj", which is verboten)
+my $old_resolver = $ua->resolver;
+$ua->resolver($mock_resolver);
+$res = $ua->get("http://bradlj-fortest.danga.com/");
+ok(! $res->is_success);
+like($res->status_line, qr/DNS lookup resulted in bad host/);
+$ua->resolver($old_resolver);
+
+# black-listed via blocked_hosts
+$res = $ua->get("http://brad.lj/");
+print $res->status_line, "\n";
+ok(! $res->is_success);
+
+# can't do octal in IPs
+$res = $ua->get("http://012.1.2.1/");
+print $res->status_line, "\n";
+ok(! $res->is_success);
+
+# can't do decimal/octal IPs
+$res = $ua->get("http://167838209/");
+print $res->status_line, "\n";
+ok(! $res->is_success);
+
+# checking that port isn't affected
+$res = $ua->get("http://brad.lj:80/");
+print $res->status_line, "\n";
+ok(! $res->is_success);
+
+# this domain is okay.  bradfitz.com isn't blocked
+$res = $ua->get("http://bradfitz.com/");
+print $res->status_line, "\n";
+ok(  $res->is_success);
+
+# SSL should still work, assuming it would work before.
+SKIP:
+{
+    my $has_ssleay = eval { require Crypt::SSLeay; 1;   };
+    my $has_iossl  = eval { require IO::Socket::SSL; 1; };
+
+    skip "Crypt::SSLeay or IO::Socket::SSL not installed", 1 unless $has_ssleay || $has_iossl;
+
+    $res = $ua->get("https://pause.perl.org/pause/query");
+    ok(  $res->is_success && $res->content =~ /Login|PAUSE|Edit/);
+}
+
+# internal. bad.  blocked by default by module.
+$res = $ua->get("http://10.2.3.4/");
+print $res->status_line, "\n";
+ok(! $res->is_success);
+
+# okay
+$res = $ua->get("http://danga.com/temp/");
+print $res->status_line, "\n";
+ok(  $res->is_success);
+
+# localhost is blocked, case insensitive
+$res = $ua->get("http://LOCALhost/temp/");
+print $res->status_line, "\n";
+ok(! $res->is_success);
+
+# redirecting to invalid host
+$res = $ua->get("$HELPER_SERVER/redir/http://10.2.3.4/");
+print $res->status_line, "\n";
+ok(! $res->is_success);
+
+# redirect with tarpitting
+print "4 second redirect tarpit (tolerance 2)...\n";
+$ua->timeout(2);
+$res = $ua->get("$HELPER_SERVER/redir-4/http://www.danga.com/");
+ok(! $res->is_success);
+
+# lots of slow redirects adding up to a lot of time
+print "Three 1-second redirect tarpits (tolerance 2)...\n";
+$ua->timeout(2);
+$t1 = time();
+$res = $ua->get("$HELPER_SERVER/redir-1/$HELPER_SERVER/redir-1/$HELPER_SERVER/redir-1/http://www.danga.com/");
+$td = time() - $t1;
+$delta->();
+ok($td < 2.5);
+ok(! $res->is_success);
+
+# redirecting a bunch and getting the final good host
+$res = $ua->get("$HELPER_SERVER/redir/$HELPER_SERVER/redir/$HELPER_SERVER/redir/http://www.danga.com/");
+ok( $res->is_success && $res->request->uri->host eq "www.danga.com");
+
+# dying in a tarpit
+print "5 second tarpit (tolerance 2)...\n";
+$ua->timeout(2);
+$res = $ua->get("$HELPER_SERVER/1.5");
+ok(!  $res->is_success);
+
+# making it out of a tarpit.
+print "3 second tarpit (tolerance 4)...\n";
+$ua->timeout(4);
+$res = $ua->get("$HELPER_SERVER/1.3");
+ok(  $res->is_success);
+
+kill 9, $child_pid;
+
+
+sub web_server_mode {
+    my $ssock = IO::Socket::INET->new(Listen    => 5,
+                                      LocalAddr => $HELPER_IP,
+                                      LocalPort => $HELPER_PORT,
+                                      ReuseAddr => 1,
+                                      Proto     => 'tcp')
+        or die "Couldn't start webserver: $!\n";
+
+    while (my $csock = $ssock->accept) {
+        exit 0 unless $csock;
+        fork and next;
+
+        my $eat = sub {
+            while (<$csock>) {
+                last if ! $_ || /^\r?\n/;
+            }
+        };
+
+        my $req = <$csock>;
+        print STDERR "    ####### GOT REQ:  $req" if $ENV{VERBOSE};
+
+        if ($req =~ m!^GET /(\d+)\.(\d+) HTTP/1\.\d+\r?\n?$!) {
+            my ($delay, $count) = ($1, $2);
+            $eat->();
+            print $csock
+                "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\n";
+            for (1..$count) {
+                print $csock "[$_/$count]\n";
+                sleep $delay;
+            }
+            exit 0;
+        }
+
+        if ($req =~ m!^GET /redir/(\S+) HTTP/1\.\d+\r?\n?$!) {
+            my $dest = $1;
+            $eat->();
+            print $csock
+                "HTTP/1.0 302 Found\r\nLocation: $dest\r\nContent-Length: 0\r\n\r\n";
+            exit 0;
+        }
+
+        if ($req =~ m!^GET /redir-(\d+)/(\S+) HTTP/1\.\d+\r?\n?$!) {
+            my $sleep = $1;
+            sleep $sleep;
+            my $dest = $2;
+            $eat->();
+            print $csock
+                "HTTP/1.0 302 Found\r\nLocation: $dest\r\nContent-Length: 0\r\n\r\n";
+            exit 0;
+        }
+
+        print $csock
+            "HTTP/1.0 500 Server Error\r\n" .
+            "Content-Length: 10\r\n\r\n" .
+            "bogus_req\n";
+        exit 0;
+    }
+    exit 0;
+}
+
+package MockResolver;
+use strict;
+use base 'Net::DNS::Resolver';
+
+sub new {
+    my $class = shift;
+    return bless {
+        proxy => Net::DNS::Resolver->new,
+        fake_record => {},
+    }, $class;
+}
+
+sub set_fake_record {
+    my ($self, $host, $packet) = @_;
+    $self->{fake_record}{$host} = $packet;
+}
+
+sub _make_proxy {
+    my $method = shift;
+    return sub {
+        my $self = shift;
+        my $fr = $self->{fake_record};
+        if ($method eq "bgsend" && $fr->{$_[0]}) {
+            $self->{next_fake_packet} = $fr->{$_[0]};
+            Test::More::diag("mock DNS resolver doing fake bgsend() of $_[0]\n")
+                if $ENV{VERBOSE};
+            return "MOCK";  # magic value that'll not be treated as a socket
+        }
+        if ($method eq "bgread" && $_[0] eq "MOCK") {
+            Test::More::diag("mock DNS resolver returning mock packet for bgread.")
+                if $ENV{VERBOSE};
+            return $self->{next_fake_packet};
+        }
+        # No verbose conditional on this one because it shouldn't happen:
+        Test::More::diag("Calling through to Net::DNS::Resolver proxy method '$method'");
+        return $self->{proxy}->$method(@_);
+    };
+}
+
+BEGIN {
+    *search = _make_proxy("search");
+    *query = _make_proxy("query");
+    *send = _make_proxy("send");
+    *bgsend = _make_proxy("bgsend");
+    *bgread = _make_proxy("bgread");
+}
+
+1;