=head1 NAME

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

=head1 SYNOPSIS

 use Net::Whois::IP;

=head1 DESCRIPTION

=over 4

=cut

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";
}

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 "N*", (inet_aton $1) . (inet_aton $2);
   } else {
      die "$range: unable to parse ip range";
   }
}

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 {
      while () {
         eval { $self->_daemon };
         warn "restarting daemon for whois server $self->{name}: $@";
      }
   };
   $self->{daemon}->prio(1);
   $self->{cache} = Net::Whois::IP::new_btree "whois_" . lc $self->{name};
   $server{$self->{name}} = $self;
}

sub _failure {
   my ($self, $min) = shift;
   undef $self->{fh};
   $self->{retry} = $min if $self->{retry} < $min;
   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;

   $request->{response} =~ s/\015//g;
   $request->{response} =~ s/\012/\n/g if "\012" ne "\n";
   
   $response = time . "\x00" . $request->{response};

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

   $request->{response};
}

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

sub sanitize_ip_response {
   my ($self, $response) = @_;
   $response;
}

sub parse_ip_response {
   my ($self, $response, $tags, $res) = @_;
   $res->{whois_server} = $self->{name};
   while ($response =~ /^([^:]+):[ \t]*
                        (
                          .*
                          (?:\n[\t ].*)*
                        )
                       /mgx) {
      my ($tag, $val) = ($1, $2);
      if (exists $tags->{$tag}) {
         push @{$res->{$tags->{$tag}}}, $val if defined $tags->{$tag};
      } else {
         use Carp;
         confess "unknown tag $tag=$val";
      }
   }
   $res;
}

# check wether the given response is a referral to another server
# find out which one, and the ip range we were referred
sub is_ip_referral {
   my ($self, $response) = @_;
   # ($iprange, $server)
   ();
}

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

# plain whois, as used by ripe and apnic

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

sub _daemon {
   my $self = shift;
   my $request;
   while ($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;
      $request->{response} =~ /^% query rate limit exceeded/im and $self->_failure(9), redo;

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

sub sanitize_ip_response {
   my ($self, $response) = @_;
   $response = "" if $response =~ /^% not assigned/im;
   $response =~ s/^%.*//mg;
   $response =~ s/[ \t]+$//mg; # brnic, maybe others
   $response =~ s/^\n+//;
   $response =~ s/\n\n.*//s;
   $self->SUPER::sanitize_ip_response($response);
}

sub parse_ip_response {
   my ($self, $response, $tags) = @_;
   $self->SUPER::parse_ip_response($response, $tags || {
         inetnum   => "netblock",
         netname   => "netname",
         descr     => "description",
         owner     => "description",
         address   => "description",
         phone     => "description",
         country   => "country",
         ownerid   => "owner-c",
         "admin-c" => "admin-c",
         "tech-c"  => "tech-c",
         "owner-c" => "owner-c",
         "abuse-c" => "abuse-c",
         status    => "status",
         notify    => "notify",
         changed   => "changed",
         created   => "created",
         source    => "source",
         remarks   => "remarks",
         "mnt-by"  => "mnt-by",
         "mnt-irt" => "irt-c", # incident response team
         "rev-srv" => "nameserver",
         nserver   => "nameserver",
         "mnt-lower" => undef,
         "mnt-routes"=> undef,
         responsible => undef,
         nsstat      => undef,
         nslastaa    => undef,
         "aut-num"   => undef,
         inetrev     => undef, # nameserver-dependent
         "inetnum-up" => undef,
   });
}

sub is_ip_referral {
   my ($self, $response) = @_;
   $response =~ /^inetnum:\s+(.*)/m
      or return;
   my $iprange = $1;
   if ($response =~ /^remarks:\s+These addresses have been further assigned to Brazilian users./m) {
      return ($iprange, $server{BRNIC});
   }
   # ($iprange, $server)
   ();
}

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 sanitize_ip_response {
   my ($self, $response) = @_;
   $response =~ s/^\[\s.*//mg;
   $response =~ s/^(?:\w\.\ )? \[ ([^\]]+) \] (.*)/$1: $2/mgx;
   $self->SUPER::sanitize_ip_response($response);
}

sub parse_ip_response {
   my ($self, $response) = @_;
   $self->SUPER::parse_ip_response($response, {
         "Network Information"    => undef,
         "Network Number"         => "netblock",
         "Network Name"           => "netname",
         "Organization"           => "description",
         "Administrative Contact" => "admin-c",
         "Technical Contact"      => "tech-c",
         "Nameserver"             => "nameserver",
         "Reply Mail"             => undef,
         "Assigned Date"          => "created",
         "Return Date"            => "expires",
         "Last Update"            => "changed",
   }, {
         country => "JP",
   });
}

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;

   my $request;
   while ($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;
   }
}

sub sanitize_ip_response {
   my ($self, $response) = @_;
   $response = "" if $response =~ /^netname:\s+IANA-BLK$/m;
   $response = "" if $response =~ /This network range is not allocated to APNIC./;
   # $response = "" if $response =~ /^remarks:\s+.*the IP has not been allocated by APNIC./m;
   $self->SUPER::sanitize_ip_response($response);
}

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

# rwhois 1.5, of course, as usual arin's implementation is utterly broken
# and doesn't help very much

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]+$/\012/g;
      $response .= $line;
      $line =~ /^%(ok|error)/ and return $response;
   }
   return;
}

sub _daemon {
   my $self = shift;
   my $request;
   while ($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 sanitize_ip_response {
   my ($self, $response) = @_;
   $response =~ s/^% referral/REFERRAL:/mg;
   $response =~ s/^%.*//mg;
   $response =~ s/\n\n.*//s;
   $response = "" if $response =~ /^network:Org-Name:Various Registries \(Maintained by ARIN\)/m;
   $response =~ s/^([^:]+):([^:]+):/$1-\L$2: /mg;
   $response;
}

sub parse_ip_response {
   my ($self, $response) = @_;
   $self->SUPER::parse_ip_response($response, {
         "network-class-name"        => undef,
         "network-auth-area"         => "auth-area",
         "network-id"                => "id",
         "network-handle"            => "handle",
         "network-network-name"      => "netname",
         "network-ip-network"        => undef,
         "network-ip-network-block"  => "netblock",
         "network-org-name"          => "description",
         "network-street-address"    => "address",
         "network-city"              => "address",
         "network-state"             => "address",
         "network-postal-code"       => "address",
         "network-country-code"      => "country",
         "network-tech-contact;i"    => "tech-c",
         "network-admin-contact;i"   => "admin-c",
         "network-created"           => "created",
         "network-updated"           => "changed",
   });
}

sub is_ip_referral {
   my ($self, $response) = @_;
   $response =~ /^network-ip-network-block:(.*)$/m
      or return ();
   my $iprange = $1;
   if ($response =~ /^REFERRAL: rwhois:\/\/([^\/]+)/m) {
      my $server = $1;
      if ($server =~ /^whois.ripe.net/) {
         return ($iprange, $server{RIPE});
      } elsif ($server =~ /^rwhois.nic.ad.jp/) {
         return ($iprange, $server{JPNIC});
      } elsif ($server =~ /^r?whois.apnic.net/) {
         return ($iprange, $server{APNIC});
      } elsif ($server =~ /^rwhois.lacnic.net/) {
         return ($iprange, $server{LACNIC}); # not yet seen, hope it will be implemented like this
      } elsif ($server =~ /^rwhois.internex.net/) {
         # alive(!)
         return ();
      } elsif ($server =~ /^rwhois.nstar.net/) {
         return ();
      } elsif ($server =~ /^rwhois.sesqui.net/) {
         return ();
      } elsif ($server =~ /^nic.ddn.mil/) {
         # whois.nic.mil (the actual address) only supports the antique
         # nonparsable arin whois format
         return ();
      } else {
         die "$response\nreferral to whois server $server";
      }
      die "$server $iprange";
   } elsif ($response =~ /^network-org-name: Latin American and Caribbean IP address Regional Registry/m) {
      return ($iprange, $server{LACNIC});
   } elsif ($response =~ /^network-org-name: Asia Pacific Network Information Centre/m) {
      return ($iprange, $server{APNIC});
   } elsif ($response =~ /^network-org-name: RIPE Network Coordination Centre/m) {
      return ($iprange, $server{RIPE});
   }
   ();
}

package Net::Whois::IP;

# 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",
         $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;
   }
}

=item init db_home => $path, ...

Initializes the module.

This function must be called before calling any of the other functions,
and the only required agrument is C<db_home>, the path where the module
will store it's cache (will be created if neccessary).

Other Arguments:

  db_home       database home directory
  db_env        the database env (should be created by the module itself)
  db_errfile    the file wheer the database will output and errors (/dev/fd/2)
  db_cachesize  size of the in-memory cache (1_000_000)

=cut

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_FATAL|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";

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

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

=item ip_query $ip

Queries the whois server for the given ip address (which must be something
inet_aton understands).

The return value currently is a hash, which looks slightly difefrent for
different registries, see examples.

=cut

sub ip_query {
   my $ip = shift;

   my $server = $arin;

   my ($prev_response, $prev_server);

referral:
   my $c = $db_referral->db_cursor;

   # iterate over all possibly matching referral ranges
   # and choose the one that fits tightest
   my ($k, $v) = (inet_aton $ip);
   if (!$c->c_get($k, $v, DB_SET_RANGE)) {
find: {
         do {
            my ($ip1, $ip0) = unpack "N*", $k ^ "\x00\x00\x00\x00\xff\xff\xff\xff";
            my $ipn = unpack "N", inet_aton $ip;
            0 && printf "Q=%15s < %15s < %15s, $v\n", 
                 (inet_ntoa  pack "N", $ip0),
                 (inet_ntoa  pack "N", $ipn),
                 (inet_ntoa  pack "N", $ip1);

            if ($ipn <= $ip1) {
               if ($ip0 <= $ipn) {
                  my ($name, $rip) = split /\t/, $v;
                  $server = $server{$name} if $server{$name};
                  $ip = $ip if $rip;
                  last;
               }
            } else {
               last;
            }
         } while !$c->c_get($k, $v, DB_NEXT);
      }
   }

   my $response = $server->ip_query($ip);
   if ($response) {
      if (my ($iprange, $refer) = $server->is_ip_referral($response)) {
         ($prev_server, $prev_response) = ($server, $response);
         $server = $refer;
         add_referral $iprange, $server;
         goto referral;
      }
   } else {
      ($server, $response) = ($prev_server, $prev_response);
   }

   if (!$response) {
      ($server, $response) = ($arin, $arin->ip_query($ip));
   }
   
   my $res = $server->parse_ip_response($response);
   for my $range (@{$res->{netblock} || []}) {
      if (my ($ip0, $ip1) = eval { ip_range $range }) {
         # limit to /24
         my $ipn = unpack "N", inet_aton $ip;
         $ip0 = $ipn        & 0xffffff00      if $ip0 < ($ipn       & 0xffffff00);
         $ip1 = ($ipn + 256 & 0xffffff00) - 1 if $ip1 > ($ipn + 256 & 0xffffff00);
         $db_referral->db_put(
               (pack "N*", $ip1, $ip0) ^ "\x00\x00\x00\x00\xff\xff\xff\xff",
               "$server->{name}\t$ip",
         );
      }
   }

   $db_env->txn_checkpoint(10,1,0);

   $res;
}

1;

=back

=head2 WHOIS EXAMPLES

=over 4

=item RIPE

   ip_query "129.13.162.91" =>
       (
         source => [ "RIPE" ],
         "mnt-by" => [ "DFN-NTFY" ],
         country => [ "DE" ],
         netname => [ "KLICK" ],
         status => [ "ASSIGNED PI" ],
         description => [ "Karlsruher Lichtleiter Kommunikationsnetz",
                          "University of Karlsruhe",
                          "Germany" ],
         nameserver => [ "netserv.rz.uni-karlsruhe.de",
                         "iraun1.ira.uka.de",
                         "deneb.dfn.de",
                         "ns.germany.eu.net" ],
         "tech-c" => [ "HUK2-RIPE" ],
         changed => [ "lortz\@rz.uni-karlsruhe.de 19910212",
                      "nipper\@ira.uka.de 19920422",
                      "nipper\@xlink.net 19930513",
                      "rv\@Informatik.Uni-Dortmund.DE 19931129",
                      "poldi\@dfn.de 19940309",
                      "dolderer\@nic.de 19940930",
                      "dolderer\@nic.de 19970821",
                      "schweikh\@noc 19990819" ],
         netblock => [ "129.13.0.0 - 129.13.255.255" ],
         "admin-c" => [ "BL118" ],
         notify => [ "guardian\@nic.de" ],
         whois_server => "RIPE"
       )

=item LACNIC

   ip_query "200.5.0.0" =>
       (
         source => [ "ARIN-LACNIC-TRANSITION" ],
         created => [ 19960205 ],
         country => [ "PR" ],
         changed => [ 19960205 ],
         "owner-c" => [ "PR-PRMS-LACNIC",
                        "RS564-ARIN" ],
         netblock => [ "200.5.0/21" ],
         status => [ "assigned" ],
         description => [ "Puerto Rico Medical Services Administration",
                          "Management Information Systems Department",
                          "PO Box 2129",
                          "San Juan, PR 00922-2129",
                          "PR" ],
         whois_server => "LACNIC"
       )

=item BRNIC

   ip_query "200.128.0.0" =>
       (
         created => [ 20000215 ],
         "tech-c" => [ "ALG149" ],
         changed => [ 20001017 ],
         "owner-c" => [ "003.508.097/0001-36",
                        "ALG149" ],
         netblock => [ "200.128/16" ],
         "abuse-c" => [ "SIC128" ],
         description => [ "Associa\347\343o Rede Nacional de Ensino e Pesquisa",
                          "Estrada Dona Castorina, 110, 353",
                          "22460-320 - Rio de Janeiro - RJ",
                          "(021) 274-7445 []" ],
         whois_server => "BRNIC",
         nameserver => [ "NS.POP-BA.RNP.BR",
                         "SERVER1.POP-DF.RNP.BR",
                         "SERVER1.AGR.UFBA.BR",
                         "DNS.UFBA.BR" ]
       )

=item JPNIC

   ip_query "133.11.128.254" =>
       (
         created => [ "" ],
         "tech-c" => [ "AK003JP",
                       "MN010JP" ],
         netname => [ "UTSNET" ],
         changed => [ "2002/10/15 13:06:48 (JST)\n                                kato\@wide.ad.jp" ],
         netblock => [ "133.11.0.0" ],
         "admin-c" => [ "MN010JP" ],
         description => [ "University of Tokyo" ],
         whois_server => "JPNIC",
         expires => [ "" ],
         nameserver => [ "dns1.nc.u-tokyo.ac.jp",
                         "dns2.nc.u-tokyo.ac.jp",
                         "dns3.nc.u-tokyo.ac.jp",
                         "ns.nc.u-tokyo.ac.jp",
                         "ns.s.u-tokyo.ac.jp" ]
       )

=item APNIC

   ip_query "203.2.75.99" =>
       (
         source => [ "APNIC" ],
         "mnt-by" => [ "APNIC-HM" ],
         "tech-c" => [ "TN38-AP" ],
         country => [ "AU" ],
         netname => [ "OPTUSINTERNET-AU" ],
         changed => [ "nobody\@aunic.net 20010524",
                      "aunic-transfer\@apnic.net 20010525",
                      "hostmaster\@apnic.net 20011004" ],
         netblock => [ "203.2.75.0 - 203.2.75.255" ],
         status => [ "ALLOCATED PORTABLE" ],
         "admin-c" => [ "TN38-AP" ],
         description => [ "OPTUS INTERNET - RETAIL",
                          "INTERNET SERVICES",
                          "St Leonards, NSW" ],
         whois_server => "APNIC"
       )

=item ARIN

   ip_query "68.52.164.8" =>
       (
         country => [ "US" ],
         netname => [ "JUMPSTART-DC-5" ],
         "auth-area" => [ "0.0.0.0/0" ],
         description => [ "Comcast Cable Communications, Inc." ],
         created => [ "20200718050000000" ],
         "tech-c" => [ "FG200-ARIN.0.0.0.0/0" ],
         changed => [ "19200307050000000" ],
         handle => [ "NET-68-52-160-0-1" ],
         netblock => [ "68.52.160.0 - 68.52.175.255" ],
         id => [ "NET-68-52-160-0-1.0.0.0.0/0" ],
         address => [ "3 Executive Campus Cherry Hill",
                      "NJ",
                      "08002" ],
         whois_server => "ARIN"
       )

=back

=head1 AUTHOR

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

=cut