#!/usr/bin/env perl
# $Header: /ncc/cvsroot/science/ipv6ripeness/ipv6ripeness.pl,v 1.1 2010/08/16 09:47:32 eaben Exp $
use strict;
use warnings;
#use lib qw(/home/inrdb/perl);
use POSIX qw(strftime);
use IO::Socket;
use Date::Parse qw(str2time);
use YAML::Syck qw(DumpFile Dump);
$|=1;

my $DEBUG=1;

=cut
$Header: /ncc/cvsroot/science/ipv6ripeness/ipv6ripeness.pl,v 1.1 2010/08/16 09:47:32 eaben Exp $

Goal: provide IPv6-readiness information from LIRs

Input:
  - ARGV[0]: date (in YYYY-MM-DD format), date for which to do the run, default is yesterday
  - ARGV[1]: optional dir where extra information will be put

Output: CSV of IPv6-readiness factors. Fields:
  - regid
  - no. of IPv6 allocation/assignments
  - route6 object
  - route in RIS (in the last month)
  - reverse dns in RIPE DB
  - reverse dns reachable

Possible extra output:
  - IPv6 route policy (via regid-> ASN -> ripe_db)

=cut

#my $QHOST="localhost";
my $QHOST="guru.ripe.net";
#my $QHOST="yoda.ripe.net";
my $QPORT=5555;
my $SEP="\t";

my $t = str2time($ARGV[0]);
if ( ! $t ) {
   $t = time() - 3600 * 24; # RIPE_DB is late
   #$t = time(); #  script runs at 9:17, so around midnight
}

my $extradir = $ARGV[1];

my $date = strftime("%Y-%m-%d", gmtime( $t )); #yesterday midnight
my $date_month_ago = strftime("%Y-%m-%d", gmtime( $t - 3600*24*31 ) );

my $ipv6i; #cummulator
my $classes = {}; #cummulator

my $INRDB = inrdb_open($QHOST,$QPORT);

my $q_all_rirs = "+xT $date +dc REG +ds reg_file +q regid~ +M +T +oc";
inrdb_cmd($INRDB, $q_all_rirs);
my $regs;
my @remove_regs=();
while (<$INRDB>) {
   if (/^SUM \d/) { last };
   if (/BLOB:/) {
      chomp($_);
      my $regid = undef;
      foreach my $line (split(/\x07/,$_)) {
         my ($key,$val) = ($line =~ /^(.*?)\s*:\s*(.*)$/);
         next unless ($key);
         next unless ($val);

         if ($key eq 'BLOB') {
            $val =~ s/\s*regid:\s*//;
            $regid = $val;
         } elsif ($key eq 'type') {
            if ( $val =~ /^(DIRECT_ASSIGNMENT|PROVIDER)$/) {
               $regs->{$regid}{type} = $val;
            } elsif ( $val =~ /^(CLOSED|FYI|PENDING_CLOSURE|PENDING)$/) {
               push @remove_regs, $regid;
            } else {
               warn "unknown LIR TYPE '$val' for LIR '$regid'\n";
            }
         } elsif ($key eq 'industry') {
            $val =~ s/\s+NONE.*//;
            push @{ $regs->{$regid}{industry} }, $val;
         } elsif ($key eq 'bill-categ') {
            $regs->{$regid}{'bill-categ'} = $val;
         } elsif ($key eq 'country') {
            $val =~ s/^\s+//; $val =~ s/\s+^//;
            foreach my $country ( split(/\s/,$val)) {
               push @{ $regs->{$regid}{country} }, $country;
            }
         } elsif ($key eq 'commit' || $key eq 'rnacommit') {
            $val =~ s/(\d{4})\d+.*/$1/;
            if ( $regs->{$regid}{age} && $regs->{$regid}{age} > $val ) {
               $regs->{$regid}{age} = $val;
            } else {
               $regs->{$regid}{age} = $val;
            }
         }
            
=cut
         if ($f[3] =~ /^(DIRECT_ASSIGNMENT|PROVIDER)$/) {
            $regs->{$f[1]}{type} = $f[3];
         } elsif ( $f[3] =~ /^(CLOSED|FYI|PENDING_CLOSURE|PENDING)$/) {
            # do nothing
         } else {
            warn "unknown LIR TYPE '$f[3]' for LIR '$f[1]'\n";
         }
=cut
      }
   }
}

# remove what we don't want to analyze
foreach my $regid (@remove_regs) {
   delete $regs->{$regid};
}

# concat <1997
foreach my $regid (keys %$regs) {
   if ( ! $regs->{$regid}{age} || $regs->{$regid}{age} <= 1997 ) {
      $regs->{$regid}{age} = '<=1997';
   } 
}


#print Dump($regs);

=cut 
# test regs
my $regs = { 
   'fr.telecom' => { type => 'PROVIDER' },
   'de.space' => { type => 'PROVIDER' },
   'nl.xs4all' => { type => 'PROVIDER' },
   'nl.surfnet' => { type => 'PROVIDER' },
   'nl.ams-ix' => { type => 'PROVIDER' },
};
=cut

my @fields = qw(has_v6_space has_ris_route has_route_object has_rdns_object);
print join($SEP,"#regid","score",@fields);
print "\n";
my $i=0;
foreach my $r (sort {$a cmp $b} keys %$regs) {

   warn "processing $r\n";

   my(@pfxs) = ipv6_space($r,$date);
   $regs->{$r}{has_v6_space} = scalar(@pfxs);
   foreach my $pfx (@pfxs) {
      # tests
      has_ris_route($pfx,$date,$date_month_ago) && $regs->{$r}{has_ris_route}++;
      has_route_object($pfx,$date) && $regs->{$r}{has_route_object}++;
      has_rdns_object($pfx,$date) && $regs->{$r}{has_rdns_object}++;
   }

   warn "tests done for $r\n";

   foreach my $f (@fields) {
      if ($regs->{$r}{$f}) { $regs->{$r}{stars}++ };
   }
   #print Dump( $regs->{$r} ); #DEBUG
   my @counts;
   foreach my $field ("stars",@fields) {
      my $v = $regs->{$r}{$field} ? $regs->{$r}{$field} : 0;
      push @counts,$v;
   }
   print join($SEP,$r, @counts);
   print "\n";

   #### add to 'bill-categ' and 'industry'
   my $stars = $regs->{$r}{stars} ? $regs->{$r}{stars} : 0;

   my $billcat = $regs->{$r}{'bill-categ'};
   $classes->{'bill-categ'}{$billcat}{$stars}++;
   $classes->{'bill-categ'}{$billcat}{count}++;

   my $age = $regs->{$r}{'age'};
   $classes->{age}{$age}{$stars}++;
   $classes->{age}{$age}{count}++;

   foreach my $industry (@{ $regs->{$r}{industry} } ) {
      $classes->{'industry'}{$industry}{$stars}++;
      $classes->{'industry'}{$industry}{count}++;
   }

   if (@{ $regs->{$r}{industry}} == 1 ) {
      my $industry = $regs->{$r}{industry}[0];
      $classes->{'exclusive_industry'}{$industry}{$stars}++;
      $classes->{'exclusive_industry'}{$industry}{count}++;
   }


   foreach my $country (@{ $regs->{$r}{country} } ) {
      $classes->{'country'}{$country}{$stars}++;
      $classes->{'country'}{$country}{count}++;
   }
}

if ($extradir) {
	system("mkdir -p $extradir");
	foreach my $class (sort keys %$classes) {
	   open (F,'>', "$extradir/classification.$class.txt");
	   print F join("\t","#label (count)","0star_fract","1star_fract","2star_fract","3star_fract","4star_fract");
	   print F "\n";
	   foreach my $label (sort keys %{$classes->{$class}} ) {
	      print F join("\t","$label (". $classes->{$class}{$label}{count} ." LIRs)",
		 map { $classes->{$class}{$label}{$_} ? sprintf("%.04f",$classes->{$class}{$label}{$_} / $classes->{$class}{$label}{count}) : 0 } ( 0 .. 4 )
		 );
	      print F "\n";
	   }
	   close F;
	}
}

#DumpFile("extra.yaml",$classes);

### SUBS

sub has_route_object {
   my ($pfx,$date) = @_;
   my $ans = undef;
   # determine if exact 'route6' object exists for this range
   my $q_route6_in_db = "+dc RIPE_DB +ds route6 +xT $date -x $pfx";
   inrdb_cmd($INRDB,$q_route6_in_db );
   while (<$INRDB>) {
      last if (/Finished/);
      if ( /(BLOB:\s+|^)route6:\s+(\S+)/ ) {
         $ans=1;
      } 
   }
   if (! $ans ) {
      my $q_route6_MS_in_db = "+dc RIPE_DB +ds route6 +xT $date -m $pfx";
      inrdb_cmd($INRDB,$q_route6_MS_in_db );
      while (<$INRDB>) {
        last if (/Finished/);
        if ( /(BLOB:\s+|^)route6:\s+(\S+)/ ) {
           warn "route6_object: no -x, but -m matches for $pfx\n";
           $ans=1;
        } 
      }
   }

   return $ans;
}

sub has_rdns_object {
   my ($ipv6_pfx,$date) = @_;
   my $ans = undef;
   foreach my $x_or_m qw(x m) {
      my $q_reverse_in_db = "+dc RIPE_DB +ds domain +xT $date -$x_or_m $ipv6_pfx";
      inrdb_cmd( $INRDB, $q_reverse_in_db );
      while (<$INRDB>) {
         last if (/Finished/);
         my $l = lc($_);
         if ($l =~ /(blob:\s+|^)domain:\s+([0-9a-fip\.]+.arpa)/) {
            $ans=1;
            if ( $x_or_m eq 'm' ) {
               warn "rdns_object: no -x, but -m matches for $ipv6_pfx\n";
            }
         } elsif ($l =~ /domain:\s+(.*)/) {
            warn "domain regex problems: $l\n";
         } 
      }
   }
   return $ans;
}

sub has_ris_route {
   my ($ipv6_pfx,$date,$date_month_ago) = @_;
   my $q_route_in_ris = "+dc RIS_RIB_V +sT $date_month_ago -x $ipv6_pfx +T +M +B";
   inrdb_cmd( $INRDB, $q_route_in_ris );
   my $count=undef;
   while (<$INRDB>) {
      if (/^Finished: total of (\d+) matches/) {
         $count=$1;
         last;
      }
   }
   if ($count) { 
      return $count;
   } else {
      my $q_route_in_ris_ms = "+dc RIS_RIB_V +sT $date_month_ago -m $ipv6_pfx +T +M +B";
      inrdb_cmd( $INRDB, $q_route_in_ris_ms );
      while (<$INRDB>) {
         if (/^Finished: total of (\d+) matches/) {
            $count=$1;
            if ( $count > 0 ) {
               warn "has_ris_route: no exact match but more specifics for $ipv6_pfx\n";
            }
            last;
         }
      }
   }
   return $count;
}


# get ipv6 pfxs, includes /35-hack
sub ipv6_space {
   my ($r,$date) = @_;
   my @pfxs = ();
   my $q_v6_space = "+dc REG -m ::/0 +xT $date +T +M +R +B +q regid=$r";
   inrdb_cmd($INRDB,$q_v6_space);
   while (<$INRDB>) {
      last if (/^Finished:/);
      if (/^RES:\s+(\S+)/) {
         push @pfxs, $1;
      }
   }
   if (scalar @pfxs > 0) {
      @pfxs = old_slash_35_hack(@pfxs);
   }
   return @pfxs;
}

sub old_slash_35_hack { #TODO generic merging?
   my (@pfxs) = @_;
   my $start=undef;
   my $tr;
   foreach my $pfx (@pfxs) {
      my ($base,$len) = split('/',$pfx);
      if ($base =~ m#^([0-9a-f]{1,4}:[0-9a-f]{1,4}):(|2000|4000|8000):#) {
         my ($start,$end) = ($1,$2);
         if ( $len == 35 && $end eq '' ) { $tr->{$start}{$end}=1 };
         if ( $len == 35 && $end eq '2000' ) { $tr->{$start}{$end}=1 };
         if ( $len == 34 && $end eq '4000' ) { $tr->{$start}{$end}=1 };
         if ( $len == 33 && $end eq '8000' ) { $tr->{$start}{$end}=1 };
      }
   }
   foreach my $start ( keys %$tr ) {
      if ( scalar keys %{$tr->{$start} } == 4 ) {
         @pfxs = grep {!/^$start/} @pfxs;
         push @pfxs, join('::',$start,'/32');
         warn "slash /35 hack for $start\n";
      }
   }
   return (@pfxs);
}

sub inrdb_cmd {
   my ($sock,$cmd) = @_;
   print $sock $cmd, "\n";
   return $sock;
}

sub inrdb_query {
   my ( $ddhost, $ddport, $cmd ) = @_;
   my $sock = new IO::Socket::INET (
      PeerAddr => $ddhost,
      PeerPort => $ddport,
      Proto => 'tcp',
   ) or die "Cannot connect to DD";
   print $sock $cmd , "\n";
   return $sock;
}

sub inrdb_open {
   my ($ddhost,$ddport) = @_;
   my $sock = new IO::Socket::INET (
      PeerAddr => $ddhost,
      PeerPort => $ddport,
      Proto => 'tcp',
      Timeout => "10",
   ) or return -1; #die "Cannot connect to DD";
   print $sock "-k\n";
   my $ok = <$sock>;
   if( $ok eq "OK\n" ) {
      return $sock;
   } else {
      return -2;
   }
}

__END__
   my $q_allipv6= "+dc REG -m ::/0 +xT $date +T +M +S +R";
   my $sock = query( $QHOST, $QPORT, $q_allipv6 );
   my $reg;
   while (<$sock>) {
      if (/BLOB: (\S+)\|/) {
         $reg=$1;
      }
      if (/RES: (\S+)/) {
         $ipv6i->{$reg}{$1}{have_alloc}=1;
      }
   }
   close $sock;
   @regs = sort keys %$ipv6i;
}

#my @statefields = qw(has_delegation has_route6 has_ris_route rdns_in_db rdns_answer);
my @statefields = qw(has_delegation has_route6 has_ris_route rdns_in_db);
print join("\t",'#regid', @statefields);
print "\n";
foreach my $reg (@regs) {
   my %reg_state;

   # determine ipv6 ranges (if not already determined above)
   if (! scalar keys %{ $ipv6i->{$reg} } ) {
      my $q_getipv6= "+dc REG -m ::/0 +xT $date +q regid=$reg +T +M +B +S +R";
      my $sock = query( $QHOST, $QPORT, $q_getipv6 );
      while (<$sock>) {
         if (/RES: (\S+)/) {
            $ipv6i->{$reg}{$1}{have_alloc} = 1;
         }
      }
      close $sock;
   }

   # special case
   # lots of /33 + /34 + 2 * /35 = /32 cases
   # see ripe-472 , section 5.7
   my @new_pfx = old_slash_35_hack( keys %{ $ipv6i->{$reg} } );
   if (@new_pfx) {
      warn "new pfx: " . join (",", @new_pfx) . "(reg $reg)\n";
      foreach my $p (@new_pfx) {
         delete $ipv6i->{$reg}; #replace or not?
         $ipv6i->{$reg}{$p}{slash_35_hack} = 1;
      }
   }

   if (! scalar keys %{ $ipv6i->{$reg} } ) {
      $reg_state{has_delegation} = 0;
   } else {
      $reg_state{has_delegation} = scalar keys %{ $ipv6i->{$reg} } ;
   }

   foreach my $ipv6_pfx (keys %{$ipv6i->{$reg} }) {

      # determine if exact 'route6' object exists for this range
      my $q_route6_in_db = "+dc RIPE_DB +ds route6 +xT $date -x $ipv6_pfx";
      my $sock = query( $QHOST, $QPORT, $q_route6_in_db );
      while (<$sock>) {
         if ( /(BLOB:\s+|^)route6:\s+(\S+)/ ) {
            $ipv6i->{$reg}{$ipv6_pfx}{route6_in_db} = $2;
            $reg_state{has_route6}++;
         } 
      }
      close $sock;

      # determine if exact prefix observed in RIS in the last month (only need a summary)
      my $q_route_in_ris = "+dc RIS_RIB_V +sT $date_month_ago -x $ipv6_pfx +T +M +B";
      my $sock2 = query( $QHOSTPUB, $QPORTPUB, $q_route_in_ris );
      while (<$sock2>) {
         if (/Finished: total of (\d+) matches/) {
            if ( $1 > 0 ) {
               $ipv6i->{$reg}{$ipv6_pfx}{route_in_ris} = 1;
               $reg_state{has_ris_route}++;
            }
         }
      }
		close $sock2;

      # find reverse_dns object in ripedb, have to ask for more specific if prefix % 4 > 0
      my ($pfx_len) =  ($ipv6_pfx =~ m#.*\/(\d+)# );
      my $x_or_m = 'x';
      $x_or_m = 'm';# if ($pfx_len % 4);
      my $q_reverse_in_db = "+dc RIPE_DB +ds domain +xT $date -$x_or_m $ipv6_pfx";
      my $sock3= query( $QHOST, $QPORT, $q_reverse_in_db );
      while (<$sock3>) {
         my $l = lc($_);
         if ($l =~ /(blob:\s+|^)domain:\s+([0-9a-fip\.]+.arpa)/) {
            $ipv6i->{$reg}{$ipv6_pfx}{rdns_in_db} = $2;
         } elsif ($l =~ /domain:\s+(.*)/) {
            warn "domain regex problems: $l\n";
         } elsif ($l =~ /^nserver:\s+(.*)/) {
            $ipv6i->{$reg}{$ipv6_pfx}{_nservers}{$1}=1;
         }
      }
      close $sock3;
      if ( exists $ipv6i->{$reg}{$ipv6_pfx}{rdns_in_db} ) {
         $reg_state{rdns_in_db}++;
      }

      # can we query reverse dns?
=cut
      if ( my $rdns = $ipv6i->{$reg}{$ipv6_pfx}{rdns_in_db} ) {
         if ( ref( $ipv6i->{$reg}{$ipv6_pfx}{_nservers} ) eq 'HASH' ) {
            foreach my $nserver ( keys %{ $ipv6i->{$reg}{$ipv6_pfx}{_nservers} } ) {
            my $cmd_reverse_dns_up = "dig +short $rdns NS \@$nserver";
               open (R, "$cmd_reverse_dns_up |") or die "can't open $cmd_reverse_dns_up\n";
               while (<R>) {
                  if (/$nserver/) {
                     $ipv6i->{$reg}{$ipv6_pfx}{rdns_answer}=1;
                  } else {
      #               warn "??: $_\n";
                  }
               }
               close R;
            }
         }
      }
      $reg_state{rdns_answer}++ if ( $ipv6i->{$reg}{$ipv6_pfx}{rdns_answer} );
=cut
   }
   # the verdict
   print "$reg\t";
   print join("\t", map { $reg_state{$_} ? $reg_state{$_} : 0 } @statefields ); 
   print "\n";
}


warn Dumper( $ipv6i );


################ subs

=cut

problem details:

1;
