# -*- perl -*-

# Copyright (c) 2004 by Jeff Weisberg
# Author: Jeff Weisberg <argus @ tcp4me.com>
# Created: 2004-Sep-18 12:17 (EDT)
# Function: common IP functions
#
# $Id: Argus::IP.pm,v 1.7 2005/12/04 20:52:26 jaw Exp $

package Argus::IP;

use Socket;
BEGIN {
    eval { require Socket6; import Socket6; $HAVE_S6 = 1; };
}

use strict qw(refs vars);
use vars qw($doc $HAVE_S6);

my $IPPROTO_IP = 0;	# standard?
my $IPOPT_NOP  = 1;	# RFC 791
my $IPOPT_LSRR = 131;	# RFC 791
my $IPOPT_SSRR = 137;	# RFC 791

# NetBSD, FreeBSD, OpenBSD, Solaris, SunOS, Darwin, Windows, 
my $IP_OPTIONS = 1;
my $IP_TOS     = 3;
my $IP_TTL     = 4;

if( $^O eq 'linux' ){
    # linux has to be f***ing different...
    $IP_TOS     = 1;
    $IP_TTL     = 2;
    $IP_OPTIONS	= 4;
}

$doc = {
    package => __PACKAGE__,
    file    => __FILE__,
    isa     => [],
    methods => {},
    html   => 'services',
    versn  => '3.4',
    fields => {
      ip::ipopts  => {
	  descr => 'informational',
      },
      ip::hostname => {
	  descr => 'hostname or IP address to test',
	  attrs => ['config', 'inherit'],
      },
      ip::addr => {
	  descr => 'encoded IP address',
      },
      ip::srcaddr => {
	  descr => 'local IP address',
	  attrs => ['config', 'inherit'],
      },
      ip::srcip => {
	  descr => 'encoded local IP address',
      },
      ip::ttl => {
	  descr => 'numeric IP TTL',
	  attrs => ['config', 'inherit'],
      },
      ip::tos => {
	  descr => 'numeric IP TOS',
	  attrs => ['config', 'inherit'],
      },
      ip::lsrr => {
	  descr => 'IP loose source route',
	  exmpl => '1.2.3.4  2.3.4.5  4.5.6.7',
	  attrs => ['config', 'inherit'],
      },
      ip::ssrr => {
	  descr => 'IP strict source route',
	  exmpl => '1.2.3.4  2.3.4.5  4.5.6.7',
	  attrs => ['config', 'inherit'],
      },
	
      ip::resolvp => {},
      ip::resolvt => {},
	
    },
};

sub init {
    my $me = shift;
    my $cf = shift;

    $me->init_from_config( $doc, 'ip' );
}

sub config {
    my $me = shift;
    my $cf = shift;

    unless( $me->{ip}{hostname} ){
	return $cf->error( "Hostname not specified" );
    }

    if( $Resolv::enable_p ){
	$me->{ip}{addr} = Resolv::resolv_defer( $me->{ip}{hostname} );
	$me->{ip}{resolvp} = 1;
    }else{
    	$me->{ip}{addr} = ::resolve( $me->{ip}{hostname} );
	unless( $me->{ip}{addr} ){
	    return $cf->error( "cannot resolve host $me->{ip}{hostname}" );
	}
    }
    
    if( $me->{ip}{srcaddr} ){
	$me->{ip}{srcip} = ::resolve($me->{ip}{srcaddr});
	$cf->warning( "Cannot resolve $me->{ip}{srcaddr}" ) unless $me->{ip}{srcip};
	
	if( $me->{ip}{addr} && (length($me->{ip}{srcip}) != length($me->{ip}{addr})) ){
	    $cf->warning( "SRC + DST addresses have mismatched IP version" );
	    delete $me->{ip}{srcip};
	}
    }

    if( $me->{ip}{ssrr} ){
	$me->{ip}{ipopts} .= ' ssrr';
	my @a;

	foreach my $h (split /\s+/, $me->{ip}{ssrr}){
	    my $a = ::resolve($h);
	    unless( $a ){
		$cf->warning( "cannot resolve host $h" );
		next;
	    }
	    push @a, $a;
	    last if @a >= 7;
	}

	$me->{ip}{ssrr} = \@a;
	delete $me->{ip}{lsrr};		# cannot have both
    }
    
    
    if( $me->{ip}{lsrr} ){
	$me->{ip}{ipopts} .= ' lsrr';
	my @a;

	foreach my $h (split /\s+/, $me->{ip}{lsrr}){
	    my $a = ::resolve($h);
	    unless( $a ){
		$cf->warning( "cannot resolve host $h" );
		next;
	    }
	    push @a, $a;
	    last if @a >= 7;
	}

	$me->{ip}{lsrr} = \@a;
    }

    $me->{ip}{ipopts} .= ' tos' if $me->{ip}{tos};
    $me->{ip}{ipopts} .= ' ttl' if $me->{ip}{ttl};
    
    1;
}

sub resolv_timed_out {
    my $me = shift;

    $me->{ip}{resolvt} ||= $^T + Resolv->too_long();
    return 1 if $^T > $me->{ip}{resolvt};
}

sub set_src_addr {
    my $me  = shift;
    my $bp  = shift;
    my $i;
    
    my $fh  = $me->{fd};
    my $src = $me->{ip}{srcip};
    my $ip  = $me->{ip}{addr};
    
    if( $src && length($src) != length($ip) ){
	$me->loggit( msg => "cannot set requested src addr - version mismatch",
		     tag => 'IP',
		     lpf => 1 );
	$src = undef;
    }

    if( ! $src ){
	if( $bp ){
	    if( length($ip) == 4 ){
		$i = bind( $fh, sockaddr_in(0, INADDR_ANY) );
	    }elsif( $HAVE_S6 ){
		$i = bind($fh, pack_sockaddr_in6(0, in6addr_any) );
	    }else{
		$i = 1;
	    }
	}else{
	    $i = 1;
	}
    }elsif( length($src) == 4 ){
	$i = bind( $fh, sockaddr_in(0, $src) );
    }elsif( $HAVE_S6 ){
	$i = bind( $fh, pack_sockaddr_in6(0, $src) );
    }else{
	# don't bind
	$i = 1;
    }
    
    unless($i){
	my $m = "bind failed: $!";
	::sysproblem( "IP $m" );
	$me->debug( $m );
	return 0;
    }

    # set various ip options
    # if the setsockopt fails, just warn and continue, don't fail the test

    if( $me->{ip}{ttl} ){
	$i = setsockopt( $fh, $IPPROTO_IP, $IP_TTL, pack("I",$me->{ip}{ttl}) );
	unless($i){
	    my $m = "set ttl failed: $!";
	    ::sysproblem( "IP: $m");
	    $me->debug( $m );
	}
    }
	
    if( $me->{ip}{tos} ){
	$i = setsockopt( $fh, $IPPROTO_IP, $IP_TOS, pack("I",$me->{ip}{tos}) );
	unless($i){
	    my $m = "set tos failed: $!";
	    ::sysproblem( "IP: $m");
	    $me->debug( $m );
	}
    }

    # Routed were they, and turned into the bitter
    # Passes of flight; and I, the chase beholding,
    #   -- Dante, Divine Comedy
    
    if( $me->{ip}{lsrr} ){
	my $i = @{ $me->{ip}{lsrr} } + 1;
	my $opt = pack("CCCC", $IPOPT_NOP, $IPOPT_LSRR, $i * 4 + 3, 4);
	$opt .= $_ foreach @{ $me->{ip}{lsrr} };
	$opt .= $ip;
	
	$i = setsockopt( $fh, $IPPROTO_IP, $IP_OPTIONS, $opt );
	
	unless($i){
	    my $m = "set lsrr failed: $!";
	    ::sysproblem( "IP: $m");
	    $me->debug( $m );
	}
    }
    
    if( $me->{ip}{ssrr} ){
	my $i = @{ $me->{ip}{ssrr} } + 1;
	my $opt = pack("CCCC", $IPOPT_NOP, $IPOPT_SSRR, $i * 4 + 3, 4);
	$opt .= $_ foreach @{ $me->{ip}{ssrr} };
	$opt .= $ip;
	
	$i = setsockopt( $fh, $IPPROTO_IP, $IP_OPTIONS, $opt );
	
	unless($i){
	    my $m = "set ssrr failed: $!";
	    ::sysproblem( "IP: $m");
	    $me->debug( $m );
	}
    }

    1;
}

sub webpage_more {
    my $me = shift;
    my $fh = shift;

    print $fh "<TR><TD><L10N hostname></TD><TD>$me->{ip}{hostname}</TD></TR>\n";
    print $fh "<TR><TD><L10N ipopts></TD><TD>$me->{ip}{ipopts}</TD></TR>\n"
	if $me->{ip}{ipopts};
}



################################################################

Doc::register( $doc );

1;
