=head1 NAME

Net::Whois::IP - find whois data for ip addresses

=head1 SYNOPSIS

 use Net::Whois::IP;

=head1 DESCRIPTION

=over 4

=cut

# http://www.irr.net/docs/rpsl.html

package Net::Whois::IP;

BEGIN {
   $VERSION = 0.01;
   @EXPORT_OK = qw();
}

use base Exporter;

use Carp;

use Socket;

use BerkeleyDB;

use Coro;
use Coro::Event;
use Coro::Semaphore;
use Coro::SemaphoreSet;
use Coro::Socket;
use Coro::Timer;
use Coro::Channel;

my %server;

sub new_btree {
   new BerkeleyDB::Btree
       -Env => $db_env,
       -Filename => $_[0],
       -Flags => DB_CREATE,
          or die "$_[0]: unable to create/open table";
}

package Net::Whois::IP::base;

sub new {
   my $class = shift;
   my $self = bless {
      name => @_,
   }, $class;
   $self->{request} ||= new Coro::Channel $self->{request_backlog} || 10;
   $self->{daemon} = Coro::async { shift->_daemon } $self;
   $self->{cache} = Net::Whois::IP::new_btree "whois_" . lc $self->{name};
   $server{$self->{name}} = $self;
}

sub _failure {
   my $self = shift;
   undef $self->{fh};
   Coro::Timer::sleep 1.5 ** $self->{retry} - 2 if $self->{retry};
   $self->{retry}++ if $self->{retry} < 17;
}

sub _ok {
   my $self = shift;
   $self->{retry} = 0;
}

sub _query {
   my ($self, $query) = @_;

   my $response;

   if (!$self->{cache}->db_get($query, $response)) {
      $response =~ s/^[^\x00]+\x00//;
      return $response;
   }

   my $request = {
      ready => (new Coro::Semaphore 0),
      query => $query,
   };

   $self->{request}->put($request);
   $request->{ready}->down;

   $response = time . "\x00" . $request->{response};

   $self->{cache}->db_put($query, $response);
   
   $request->{response};
}

sub ip_query {
   my ($self, $ip) = @_;
   $self->_query($ip);
}

sub parse_ip_response {
   my ($self, $response) = @_;
   my %response;
   while ($response =~ /^([^:]+):[ \t]*(.*)$/mg) {
      push @{$response{$1}}, $2;
   }
   \%response;
}

package Net::Whois::IP::whois;

# plain whois, as used by ripe and apnic

use base Net::Whois::IP::base;

sub _daemon {
   my $self = shift;
   while (my $request = $self->{request}->get) {
      my $fh = new Coro::Socket PeerHost => $self->{server}
         or $self->_failure, redo;

      $fh->print("$request->{query}\012");
      $fh->sysread($request->{response}, 16384);
      length $request->{response}
         or $self->_failure, redo;

      $self->_ok;
      $request->{ready}->up;
   }
}

sub ip_query {
   my ($self, $ip) = @_;
   $self->SUPER::ip_query($ip);
}

sub parse_ip_response {
   my ($self, $response) = @_;
   $response =~ s/^%.*//mg;
   $response =~ s/^\012+//;
   $response =~ s/\012\012.*//s;
   $self->SUPER::parse_ip_response($response);
}

package Net::Whois::IP::jpnic;

# totally different result format

use base Net::Whois::IP::whois;

sub ip_query {
   my ($self, $ip) = @_;
   $self->SUPER::ip_query("$ip/e");
}

sub parse_ip_response {
   my ($self, $response) = @_;
   $response =~ s/^\[\s.*//mg;
   $response =~ s/^(?:\w\.\ )? \[ ([^\]]+) \] (.*) (?:\012(?=\s))?/$1: $2/mgx;
   $self->SUPER::parse_ip_response($response);
}

package Net::Whois::IP::ripe;

# keepalive whois, as used by ripe and apnic

use base Net::Whois::IP::whois;

sub _daemon {
   my $self = shift;
   my $fh;

   while (my $request = $self->{request}->get) {
      unless ($self->{fh}) {
         $fh = new Coro::Socket PeerHost => $self->{server};
         $fh or $self->_failure, redo;
      }

      $fh->print("-k $request->{query}\012");
      $request->{response} = $fh->readline("\012\012\012");
      length $request->{response}
         or $self->_failure, redo;

      $self->_ok;
      $request->{ready}->up;
   }
}

package Net::Whois::IP::rwhois;

# rwhois 1.5

use base Net::Whois::IP::base;

sub _request {
   my $self = shift;
   my ($response, $error);

   $self->{fh}->print("$_[0]\015\012");
   while (defined (my $line = $self->{fh}->readline)) {
      $line =~ s/[\015\012]+$/\n/g;
      $response .= $line;
      $line =~ /^%(ok|error)/ and return $response;
   }
   return;
}

sub _daemon {
   my $self = shift;
   while (my $request = $self->{request}->get) {
      unless ($self->{fh}) {
         $self->{fh} = new Coro::Socket PeerHost => $self->{server};
         $self->{fh} or $self->_failure, redo;
         $self->{fh}->readline =~ /^%rwhois / or $self->_failure, redo;
         $self->_request("-rwhois V-1.5 Net::Whois::IP") or $self->_failure, redo;
         $self->_request("-forward off") or $self->_failure, redo;
         $self->_request("-holdconnect on") or $self->_failure, redo;
      }
      $request->{response} = $self->_request($request->{query})
         or $self->_failure, redo;
      $request->{response} =~ s/^%error 330.*/%ok/m;
      $self->_ok;
      $request->{ready}->up;
   }
}

sub ip_query {
   my ($self, $ip) = @_;
   $self->SUPER::ip_query("network $ip");
}

sub parse_ip_response {
   my ($self, $response) = @_;
   $response =~ s/^([^:]+):([^:]+):/$1-\L$2: /mg;
   $response =~ s/^%.*//mg;
   $response =~ s/\012\012.*//s;
   $self->SUPER::parse_ip_response($response);
}

package Net::Whois::IP;

sub ip_range {
   my $range = $_[0];

   if ($range =~ /^
            (2[0-5][0-9]|1[0-9][0-9]|[1-9][0-9]|[0-9])
            (?:\.
               (2[0-5][0-9]|1[0-9][0-9]|[1-9][0-9]|[0-9])
               (?:\.
                  (2[0-5][0-9]|1[0-9][0-9]|[1-9][0-9]|[0-9])
                  (?:\.
                     (2[0-5][0-9]|1[0-9][0-9]|[1-9][0-9]|[0-9])
                  )?
               )?
            )?
            \/
            ([0-9]+)
         $/x) {
      my $ip   = inet_aton sprintf "%d.%d.%d.%d", $1, $2, $3, $4;
      my $net  = 1 << (31 - $5);
      my $mask = inet_aton 2 ** 32 - $net;

      my $ip1 = $ip & $mask;
      my $ip2 = $ip1 | inet_aton $net * 2 - 1;
      return unpack "N2", "$ip1$ip2";
   } elsif ($range =~ /^\s*([0-9.]+)\s*-\s*([0-9.]+)\s*$/) {
      unpack "N2", pack "N2", $1, $2;
   } else {
      die "$range: unable to parse ip range";
   }
}

# add a referral to a specific server
sub add_referral {
   my ($netblock, $server) = @_;
   my ($ip0, $ip1) = ip_range $netblock;
   $db_referral->db_put((pack "N*", $ip1, $ip0) ^ "\x00\x00\x00\x00\xff\xff\xff\xff", "S" . $server->{name});
}

# get all referrals
sub parse_referral {
   my ($query, $server) = @_;
   my $referral = $arin->_query("referral $query");

   while ($referral =~ /^referral:Referred-Auth-Area:([0-9.\/]+)$/mg) {
      add_referral $1, $server;
   }
}

sub init(;%) {
   my (%arg) = @_;
   $arg{db_home} or $arg{db_env} or Carp::croak "either db_home or db_env home must be set";
   $db_env = $arg{db_env} || do {
      mkdir $arg{db_home}, 0700;

      $db_env = new BerkeleyDB::Env
           -Home => $arg{db_home},
           -Cachesize => $arg{db_cachesize} || 1_000_000,
           -ErrFile => $arg{db_errfile} || "/dev/fd/2",
           -ErrPrefix => "NET-WHOIS-IP",
           -Verbose => 1,
           -Flags => DB_CREATE|DB_RECOVER|DB_INIT_MPOOL|DB_INIT_TXN
              or die "$arg{db_home}: unable to create database home";
   };

   $arin   = new Net::Whois::IP::rwhois "ARIN",   server => "rwhois.arin.net:rwhois(4321)";

   $ripe   = new Net::Whois::IP::ripe   "RIPE",   server => "whois.ripe.net:whois(43)";
   $lacnic = new Net::Whois::IP::whois  "LACNIC", server => "whois.lacnic.net:whois(43)";
   $brnic  = new Net::Whois::IP::whois  "BRNIC",  server => "whois.registro.br:whois(43)";
   $apnic  = new Net::Whois::IP::ripe   "APNIC",  server => "whois.apnic.net:whois(43)";
   $jpnic  = new Net::Whois::IP::jpnic  "JPNIC",  server => "whois.nic.ad.jp:whois(43)";

   $db_referral = new_btree "referral";

   add_referral "129.13.0.0/16", $ripe;
   add_referral "200.0.0.0/8", $lacnic;
   add_referral "200.128.0.0/9", $brnic;

   parse_referral "32.0.0.0", $ripe;
   parse_referral "202.0.0.0", $apnic;
   parse_referral "192.50.0.0", $apnic;

   add_referral "133.0.0.0/8", $jpnic;
}

###

init db_home => "/tmp/whois";

sub ip_query {
   my $ip = shift;

   print "Q?$ip ";

   my $server = $arin;

   my $c = $db_referral->db_cursor;

   my ($k, $v) = (inet_aton $ip);
   if (!$c->c_get($k, $v, DB_SET_RANGE)) {
      my ($ip1, $ip0) = unpack "N*", $k ^ "\x00\x00\x00\x00\xff\xff\xff\xff";
      my $ipn = unpack "N", inet_aton $ip;

      if ($ip0 <= $ipn && $ipn <= $ip1) {
         if ($v =~ s/^S//) {
            $server = $server{$v} if $server{$v};
         } elsif ($v =~ s/^I//) {
            die;
         } else {
            # database corrupted or newer
         }
      }
   }

   print "($ip,$server->{name})\n";
   $server->parse_ip_response($server->ip_query($ip));
}

for (qw(132.64.0.0 129.13.162.91 193.166.90.111 213.189.83.103 161.142.8.76 66.68.103.189 200.149.85.112 210.49.200.207 133.11.128.254)) {
   use PApp::Util;
   warn PApp::Util::dumpval ip_query($_);
}

exit;

__END__

1;

=back

=head1 AUTHOR

 Marc Lehmann <pcg@goof.com>
 http://www.goof.com/pcg/marc/

=cut