#! /usr/bin/perl
#
# $Id$
# Copyright (C) 2004 Jan Kratochvil <project-harpy@jankratochvil.net>
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; exactly version 2 of June 1991 is required
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# /etc/inittab:
# ha:2345:respawn:/usr/local/sbin/harpy >>/var/log/harpy.log eth1 eth2
# or
# ha:2345:respawn:/usr/local/sbin/harpy >>/var/log/harpy.log eth_intra


use bytes;
sub __KERNEL__ { 1; }	# for "linux/socket.ph"
use strict;
use warnings;
use Socket;
require "linux/if_ether.ph";
require "linux/socket.ph";
require "linux/sockios.ph";
require "linux/if_arp.ph";
use Data::Dumper;
sub SOCKADDR_SIZEOF { 16; }
require POSIX;
use Getopt::Long;


my $V=1;	# 2
my $opt_timeout=0.5;	# [sec]
die if !GetOptions(
		"t|timeout=s",\$opt_timeout,
		"v|verbose+",\$V,
		);


$|=1;

sub hw_ntoa($)
{
my($n)=@_;

	my $a=unpack("H*",$n);
	$a=~s/..(?=.)/$&:/g;
	return $a;
}

sub hw_aton($)
{
my($a)=@_;

	$a=~tr/://d;
	return pack "H*",$a;
}

sub sock($)
{
my($ifname)=@_;

	my $sock;
	socket $sock,AF_PACKET(),SOCK_RAW(),ETH_P_ARP() or die "No ARP socket: $!";

local *ioctl_ifhwaddr=sub($)
{
my($ifname)=@_;

	my $buf=$ifname.("\x00"x0x1000);
	ioctl $sock,SIOCGIFHWADDR(),$buf or die "ioctl($ifname,SIOCGIFHWADDR): $!";
	my($trash,$sockaddr)=unpack("a16a16",$buf);
	my($sa_len,$sa_data)=unpack("a2a6",$sockaddr);
	return $sa_data;
};

local *ioctl_ifipaddr=sub($)
{
my($ifname)=@_;

	my $buf=$ifname.("\x00"x0x1000);
	ioctl $sock,SIOCGIFADDR(),$buf or die "ioctl($ifname,SIOCGIFADDR): $!";
	my($trash,$sockaddr)=unpack("a16a16",$buf);
	my($sa_len,$sin_port,$sin_addr)=unpack("a2a2a4",$sockaddr);
	return $sin_addr;
};

local *ioctl_ifindex=sub($)
{
my($ifname)=@_;

	my $buf=$ifname.("\x00"x0x1000);
	ioctl $sock,SIOCGIFINDEX(),$buf or die "ioctl($ifname,SIOCGIFINDEX): $!";
	my($trash,$ifindex)=unpack("a16i",$buf);
	return $ifindex;
};

	my $hw=ioctl_ifhwaddr($ifname);
	my $ip=ioctl_ifipaddr($ifname);
	my $sockaddr_ll=pack "SniSCCa8",		# struct sockaddr_ll:
			AF_PACKET(),			# unsigned short int sll_family;
			ETH_P_ARP(),			# unsigned short int sll_protocol;
			ioctl_ifindex($ifname),		# int sll_ifindex;
			ARPHRD_ETHER(),			# unsigned short int sll_hatype;
			PACKET_BROADCAST(),		# unsigned char sll_pkttype;
			ETH_ALEN(),			# unsigned char sll_halen;
			$hw;				# unsigned char sll_addr[8];

	bind $sock,$sockaddr_ll or die "bind($ifname): $!";

	return $sock,hw_ntoa($hw),inet_ntoa($ip);
}

#struct ether_arp_frame {
#	struct ether_header {
#		u_int8_t  ether_dhost[ETH_ALEN];	/* destination eth addr */
#		u_int8_t  ether_shost[ETH_ALEN];	/* source ether addr    */
#		u_int16_t ether_type;			/* packet type ID field */
#		} ether_hdr;
#	struct ether_arp {
#		struct arphdr {		/* fixed-size header */
#			unsigned short int ar_hrd;	/* Format of hardware address.  */
#			unsigned short int ar_pro;	/* Format of protocol address.  */
#			unsigned char ar_hln;		/* Length of hardware address.  */
#			unsigned char ar_pln;		/* Length of protocol address.  */
#			unsigned short int ar_op;	/* ARP opcode (command).  */
#			} ea_hdr;
#		u_int8_t arp_sha[ETH_ALEN];	/* sender hardware address */
#		u_int8_t arp_spa[4];		/* sender protocol address */
#		u_int8_t arp_tha[ETH_ALEN];	/* target hardware address */
#		u_int8_t arp_tpa[4];		/* target protocol address */
#		} arp;
#	};

sub arp_pack($$$$$)
{
my($dst_hw,$src_hw,$dst,$src,$type)=@_;

	my $type_bin;
	$type_bin=ARPOP_REQUEST() if $type eq "REQUEST";
	$type_bin=ARPOP_REPLY()   if $type eq "REPLY";
	die "INTERNAL" if !defined $type_bin;
	my $msg=pack "a6a6nnnCCna6a4a6a4",
		hw_aton($dst_hw),	# $ether_dhost
		hw_aton($src_hw),	# $ether_shost
		2054,			# $ether_type
		1,			# $ar_hrd
		2048,			# $ar_pro
		6,			# $ar_hln
		4,			# $ar_pln
		$type_bin,		# $ar_op
		hw_aton($src_hw),	# $arp_sha
		inet_aton($src),	# $arp_spa
		hw_aton($dst_hw),	# $arp_tha
		inet_aton($dst);	# $arp_tpa
	return $msg;
}

sub arp_unpack($)
{
my($msg)=@_;

	return if 42>length $msg;
	my(
		$ether_dhost,
		$ether_shost,
		$ether_type,
		$ar_hrd,
		$ar_pro,
		$ar_hln,
		$ar_pln,
		$ar_op,
		$arp_sha,
		$arp_spa,
		$arp_tha,
		$arp_tpa,
		)=unpack "a6a6nnnCCna6a4a6a4",$msg;
	$V>=3 and print Data::Dumper->Dump([
			$ether_dhost,
			$ether_shost,
			$ether_type,
			$ar_hrd,
			$ar_pro,
			$ar_hln,
			$ar_pln,
			$ar_op,
			$arp_sha,
			$arp_spa,
			$arp_tha,
			$arp_tpa,
		],[
			"ether_dhost",
			"ether_shost",
			"ether_type",
			"ar_hrd",
			"ar_pro",
			"ar_hln",
			"ar_pln",
			"ar_op",
			"arp_sha",
			"arp_spa",
			"arp_tha",
			"arp_tpa",
		]);
	my $type;
	$type="REQUEST" if $ar_op==ARPOP_REQUEST();
	$type="REPLY"   if $ar_op==ARPOP_REPLY();
	return if !$type;
	return if $ar_hln!=6;
	return if $ar_pln!=4;
	my $tell=inet_ntoa $arp_spa;
	my $who_has=inet_ntoa $arp_tpa;
	my $tell_hw=hw_ntoa $ether_shost;
	return $tell,$who_has,$tell_hw,$type;
}

my $clock_ticks=POSIX::sysconf(&POSIX::_SC_CLK_TCK);
sub now()
{
	return (POSIX::times())[0]/$clock_ticks;
}


my %socks;
my @ifnames=@ARGV;
while (@ifnames) {
	my $ifname=shift @ifnames;
	if ($ifname=~/{(\d+)-(\d+)}/) {
		push @ifnames,$`.$_.$' for $1..$2;
		next;
		}
	my($sock,$hw,$ip)=sock($ifname);
	$socks{$ifname}={
			"sock"=>$sock,
			"hw"=>$hw,
			"ip"=>$ip,
			};
	}
$V>=2 and print Dumper(\%socks);

# $pending{$who_has}=[{"when"=>now()+$timeout,"sock"=>$hash->{"sock"},...}...];
my %pending;
$V and print localtime()." START\n";
for (;;) {
	my $rfds="";
	vec($rfds,fileno($_->{"sock"}),1)=1 for values(%socks);
	my $first;
	while (my($who_has,$arrayref)=each(%pending)) {
		my $deleted=0;
		for my $pendingi (0..$#$arrayref) {
			my $pending=$arrayref->[$pendingi-$deleted];
			my $when=$pending->{"when"};
			if ($when<=now()) {
				my $sock_hash=$socks{$pending->{"ifname"}};
				my $msg_reply=arp_pack(
						$pending->{"tell_hw"},	# dst_hw
						$sock_hash->{"hw"},	# src_hw
						$pending->{"tell"},	# dst
						$pending->{"who_has"},	# src
						"REPLY",		# type
						);
				send $sock_hash->{"sock"},$msg_reply,0,$pending->{"from_addr"}
						or die "send(".$pending->{"ifname"}."): $!";
				splice @$arrayref,$pendingi-$deleted,1;
				$deleted++;
				$V and print localtime()." replied: type=REPLY,"
						.join(",",map(("$_=".$pending->{$_}),qw(tell who_has tell_hw)))."\n";
				}
			else {
				$first=$when if !$first || $when<=$first;
				}
			}
		delete $pending{$who_has} if !@$arrayref;
		}
	my $now=now();
	$first=$now if $first && $first<$now;
	$V>=3 and print Data::Dumper->Dump([\%pending],['\%pending']);
	my $got=select $rfds,undef(),undef(),(!$first ? undef() : $first-$now);
	die "Invalid select(2): ".Dumper($got) if !defined $got || $got<0;

	while (my($ifname,$hash)=each(%socks)) {
		next if !vec($rfds,fileno($hash->{"sock"}),1);
		$V>=2 and print localtime()." got packet: $ifname\n";
		my $msg;
		defined(my $from_addr=recv $hash->{"sock"},$msg,0x1000,0) or die "recv($ifname): $!";
		next if !(my($tell,$who_has,$tell_hw,$type)=arp_unpack($msg));
		$V and print localtime()." got: type=$type,tell=$tell,who_has=$who_has,tell_hw=$tell_hw\n";
		if ($type eq "REQUEST") {
			next if $tell eq $who_has;	# do not reply to self-detection queries
			next if $tell eq "0.0.0.0";	# self-detection by Red Hat 7.3
			my $msg_reply=arp_pack(
					"FF:FF:FF:FF:FF:FF",	# dst_hw
					$hash->{"hw"},		# src_hw
					$who_has,		# dst
					$hash->{"ip"},		# src
					"REQUEST",		# type
					);
			send $hash->{"sock"},$msg_reply,0,$from_addr or die "send($ifname): $!";
			$V and print localtime()." probing: type=REQUEST,"
					."tell=".$hash->{"ip"}.",who_has=$who_has,tell_hw=".$hash->{"hw"}."\n";
			push @{$pending{$who_has}},{
					"when"=>now()+$opt_timeout,
					"ifname"=>$ifname,
					"tell"   =>$tell,
					"who_has"=>$who_has,
					"tell_hw"=>$tell_hw,
					"from_addr"=>$from_addr,
					};
			}
		elsif ($type eq "REPLY") {
			# Rename the fields a bit for REPLY
			my($told,$who,$is_at_hw)=($who_has,$tell,$tell_hw);
			for my $pending (@{$pending{$who}}) {
				$V and print localtime()." discarded: "
						.join(",",map(("$_=".$pending->{$_}),qw(tell who_has tell_hw)))."\n";
				}
			delete $pending{$who};
			}
		else {
			die "NOTREACHED";
			}
		}
	}