harpy

   1 #! /usr/bin/perl
   2 #
   3 # $Id$
   4 # Copyright (C) 2004 Jan Kratochvil <project-harpy@jankratochvil.net>
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; exactly version 2 of June 1991 is required
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 #
  19 # /etc/inittab:
  20 # ha:2345:respawn:/usr/local/sbin/harpy >>/var/log/harpy.log eth1 eth2
  21 # or
  22 # ha:2345:respawn:/usr/local/sbin/harpy >>/var/log/harpy.log eth_intra
  23
  24
  25 use bytes;
  26 sub __KERNEL__ { 1; }   # for "linux/socket.ph"
  27 use strict;
  28 use warnings;
  29 use Socket;
  30 require "linux/if_ether.ph";
  31 require "linux/socket.ph";
  32 require "linux/sockios.ph";
  33 require "linux/if_arp.ph";
  34 use Data::Dumper;
  35 sub SOCKADDR_SIZEOF { 16; }
  36 require POSIX;
  37 use Getopt::Long;
  38
  39
  40 my $V=1;        # 2
  41 my $opt_timeout=0.5;    # [sec]
  42 die if !GetOptions(
  43                 "t|timeout=s",\$opt_timeout,
  44                 "v|verbose+",\$V,
  45                 );
  46
  47
  48 $|=1;
  49
  50 sub hw_ntoa($)
  51 {
  52 my($n)=@_;
  53
  54         my $a=unpack("H*",$n);
  55         $a=~s/..(?=.)/$&:/g;
  56         return $a;
  57 }
  58
  59 sub hw_aton($)
  60 {
  61 my($a)=@_;
  62
  63         $a=~tr/://d;
  64         return pack "H*",$a;
  65 }
  66
  67 sub sock($)
  68 {
  69 my($ifname)=@_;
  70
  71         my $sock;
  72         socket $sock,AF_PACKET(),SOCK_RAW(),ETH_P_ARP() or die "No ARP socket: $!";
  73
  74 local *ioctl_ifhwaddr=sub($)
  75 {
  76 my($ifname)=@_;
  77
  78         my $buf=$ifname.("\x00"x0x1000);
  79         ioctl $sock,SIOCGIFHWADDR(),$buf or die "ioctl($ifname,SIOCGIFHWADDR): $!";
  80         my($trash,$sockaddr)=unpack("a16a16",$buf);
  81         my($sa_len,$sa_data)=unpack("a2a6",$sockaddr);
  82         return $sa_data;
  83 };
  84
  85 local *ioctl_ifipaddr=sub($)
  86 {
  87 my($ifname)=@_;
  88
  89         my $buf=$ifname.("\x00"x0x1000);
  90         ioctl $sock,SIOCGIFADDR(),$buf or die "ioctl($ifname,SIOCGIFADDR): $!";
  91         my($trash,$sockaddr)=unpack("a16a16",$buf);
  92         my($sa_len,$sin_port,$sin_addr)=unpack("a2a2a4",$sockaddr);
  93         return $sin_addr;
  94 };
  95
  96 local *ioctl_ifindex=sub($)
  97 {
  98 my($ifname)=@_;
  99
 100         my $buf=$ifname.("\x00"x0x1000);
 101         ioctl $sock,SIOCGIFINDEX(),$buf or die "ioctl($ifname,SIOCGIFINDEX): $!";
 102         my($trash,$ifindex)=unpack("a16i",$buf);
 103         return $ifindex;
 104 };
 105
 106         my $hw=ioctl_ifhwaddr($ifname);
 107         my $ip=ioctl_ifipaddr($ifname);
 108         my $sockaddr_ll=pack "SniSCCa8",                # struct sockaddr_ll:
 109                         AF_PACKET(),                    # unsigned short int sll_family;
 110                         ETH_P_ARP(),                    # unsigned short int sll_protocol;
 111                         ioctl_ifindex($ifname),         # int sll_ifindex;
 112                         ARPHRD_ETHER(),                 # unsigned short int sll_hatype;
 113                         PACKET_BROADCAST(),             # unsigned char sll_pkttype;
 114                         ETH_ALEN(),                     # unsigned char sll_halen;
 115                         $hw;                            # unsigned char sll_addr[8];
 116
 117         bind $sock,$sockaddr_ll or die "bind($ifname): $!";
 118
 119         return $sock,hw_ntoa($hw),inet_ntoa($ip);
 120 }
 121
 122 #struct ether_arp_frame {
 123 #       struct ether_header {
 124 #               u_int8_t  ether_dhost[ETH_ALEN];        /* destination eth addr */
 125 #               u_int8_t  ether_shost[ETH_ALEN];        /* source ether addr    */
 126 #               u_int16_t ether_type;                   /* packet type ID field */
 127 #               } ether_hdr;
 128 #       struct ether_arp {
 129 #               struct arphdr {         /* fixed-size header */
 130 #                       unsigned short int ar_hrd;      /* Format of hardware address.  */
 131 #                       unsigned short int ar_pro;      /* Format of protocol address.  */
 132 #                       unsigned char ar_hln;           /* Length of hardware address.  */
 133 #                       unsigned char ar_pln;           /* Length of protocol address.  */
 134 #                       unsigned short int ar_op;       /* ARP opcode (command).  */
 135 #                       } ea_hdr;
 136 #               u_int8_t arp_sha[ETH_ALEN];     /* sender hardware address */
 137 #               u_int8_t arp_spa[4];            /* sender protocol address */
 138 #               u_int8_t arp_tha[ETH_ALEN];     /* target hardware address */
 139 #               u_int8_t arp_tpa[4];            /* target protocol address */
 140 #               } arp;
 141 #       };
 142
 143 sub arp_pack($$$$$)
 144 {
 145 my($dst_hw,$src_hw,$dst,$src,$type)=@_;
 146
 147         my $type_bin;
 148         $type_bin=ARPOP_REQUEST() if $type eq "REQUEST";
 149         $type_bin=ARPOP_REPLY()   if $type eq "REPLY";
 150         die "INTERNAL" if !defined $type_bin;
 151         my $msg=pack "a6a6nnnCCna6a4a6a4",
 152                 hw_aton($dst_hw),       # $ether_dhost
 153                 hw_aton($src_hw),       # $ether_shost
 154                 2054,                   # $ether_type
 155                 1,                      # $ar_hrd
 156                 2048,                   # $ar_pro
 157                 6,                      # $ar_hln
 158                 4,                      # $ar_pln
 159                 $type_bin,              # $ar_op
 160                 hw_aton($src_hw),       # $arp_sha
 161                 inet_aton($src),        # $arp_spa
 162                 hw_aton($dst_hw),       # $arp_tha
 163                 inet_aton($dst);        # $arp_tpa
 164         return $msg;
 165 }
 166
 167 sub arp_unpack($)
 168 {
 169 my($msg)=@_;
 170
 171         return if 42>length $msg;
 172         my(
 173                 $ether_dhost,
 174                 $ether_shost,
 175                 $ether_type,
 176                 $ar_hrd,
 177                 $ar_pro,
 178                 $ar_hln,
 179                 $ar_pln,
 180                 $ar_op,
 181                 $arp_sha,
 182                 $arp_spa,
 183                 $arp_tha,
 184                 $arp_tpa,
 185                 )=unpack "a6a6nnnCCna6a4a6a4",$msg;
 186         $V>=3 and print Data::Dumper->Dump([
 187                         $ether_dhost,
 188                         $ether_shost,
 189                         $ether_type,
 190                         $ar_hrd,
 191                         $ar_pro,
 192                         $ar_hln,
 193                         $ar_pln,
 194                         $ar_op,
 195                         $arp_sha,
 196                         $arp_spa,
 197                         $arp_tha,
 198                         $arp_tpa,
 199                 ],[
 200                         "ether_dhost",
 201                         "ether_shost",
 202                         "ether_type",
 203                         "ar_hrd",
 204                         "ar_pro",
 205                         "ar_hln",
 206                         "ar_pln",
 207                         "ar_op",
 208                         "arp_sha",
 209                         "arp_spa",
 210                         "arp_tha",
 211                         "arp_tpa",
 212                 ]);
 213         my $type;
 214         $type="REQUEST" if $ar_op==ARPOP_REQUEST();
 215         $type="REPLY"   if $ar_op==ARPOP_REPLY();
 216         return if !$type;
 217         return if $ar_hln!=6;
 218         return if $ar_pln!=4;
 219         my $tell=inet_ntoa $arp_spa;
 220         my $who_has=inet_ntoa $arp_tpa;
 221         my $tell_hw=hw_ntoa $ether_shost;
 222         return $tell,$who_has,$tell_hw,$type;
 223 }
 224
 225 my $clock_ticks=POSIX::sysconf(&POSIX::_SC_CLK_TCK);
 226 sub now()
 227 {
 228         return (POSIX::times())[0]/$clock_ticks;
 229 }
 230
 231
 232 my %socks;
 233 my @ifnames=@ARGV;
 234 while (@ifnames) {
 235         my $ifname=shift @ifnames;
 236         if ($ifname=~/{(\d+)-(\d+)}/) {
 237                 push @ifnames,$`.$_.$' for $1..$2;
 238                 next;
 239                 }
 240         my($sock,$hw,$ip)=sock($ifname);
 241         $socks{$ifname}={
 242                         "sock"=>$sock,
 243                         "hw"=>$hw,
 244                         "ip"=>$ip,
 245                         };
 246         }
 247 $V>=2 and print Dumper(\%socks);
 248
 249 # $pending{$who_has}=[{"when"=>now()+$timeout,"sock"=>$hash->{"sock"},...}...];
 250 my %pending;
 251 $V and print localtime()." START\n";
 252 for (;;) {
 253         my $rfds="";
 254         vec($rfds,fileno($_->{"sock"}),1)=1 for values(%socks);
 255         my $first;
 256         while (my($who_has,$arrayref)=each(%pending)) {
 257                 my $deleted=0;
 258                 for my $pendingi (0..$#$arrayref) {
 259                         my $pending=$arrayref->[$pendingi-$deleted];
 260                         my $when=$pending->{"when"};
 261                         if ($when<=now()) {
 262                                 my $sock_hash=$socks{$pending->{"ifname"}};
 263                                 my $msg_reply=arp_pack(
 264                                                 $pending->{"tell_hw"},  # dst_hw
 265                                                 $sock_hash->{"hw"},     # src_hw
 266                                                 $pending->{"tell"},     # dst
 267                                                 $pending->{"who_has"},  # src
 268                                                 "REPLY",                # type
 269                                                 );
 270                                 send $sock_hash->{"sock"},$msg_reply,0,$pending->{"from_addr"}
 271                                                 or die "send(".$pending->{"ifname"}."): $!";
 272                                 splice @$arrayref,$pendingi-$deleted,1;
 273                                 $deleted++;
 274                                 $V and print localtime()." replied: type=REPLY,"
 275                                                 .join(",",map(("$_=".$pending->{$_}),qw(tell who_has tell_hw)))."\n";
 276                                 }
 277                         else {
 278                                 $first=$when if !$first || $when<=$first;
 279                                 }
 280                         }
 281                 delete $pending{$who_has} if !@$arrayref;
 282                 }
 283         my $now=now();
 284         $first=$now if $first && $first<$now;
 285         $V>=3 and print Data::Dumper->Dump([\%pending],['\%pending']);
 286         my $got=select $rfds,undef(),undef(),(!$first ? undef() : $first-$now);
 287         die "Invalid select(2): ".Dumper($got) if !defined $got || $got<0;
 288
 289         while (my($ifname,$hash)=each(%socks)) {
 290                 next if !vec($rfds,fileno($hash->{"sock"}),1);
 291                 $V>=2 and print localtime()." got packet: $ifname\n";
 292                 my $msg;
 293                 defined(my $from_addr=recv $hash->{"sock"},$msg,0x1000,0) or die "recv($ifname): $!";
 294                 next if !(my($tell,$who_has,$tell_hw,$type)=arp_unpack($msg));
 295                 $V and print localtime()." got: type=$type,tell=$tell,who_has=$who_has,tell_hw=$tell_hw\n";
 296                 if ($type eq "REQUEST") {
 297                         next if $tell eq $who_has;      # do not reply to self-detection queries
 298                         next if $tell eq "0.0.0.0";     # self-detection by Red Hat 7.3
 299                         my $msg_reply=arp_pack(
 300                                         "FF:FF:FF:FF:FF:FF",    # dst_hw
 301                                         $hash->{"hw"},          # src_hw
 302                                         $who_has,               # dst
 303                                         $hash->{"ip"},          # src
 304                                         "REQUEST",              # type
 305                                         );
 306                         send $hash->{"sock"},$msg_reply,0,$from_addr or die "send($ifname): $!";
 307                         $V and print localtime()." probing: type=REQUEST,"
 308                                         ."tell=".$hash->{"ip"}.",who_has=$who_has,tell_hw=".$hash->{"hw"}."\n";
 309                         push @{$pending{$who_has}},{
 310                                         "when"=>now()+$opt_timeout,
 311                                         "ifname"=>$ifname,
 312                                         "tell"   =>$tell,
 313                                         "who_has"=>$who_has,
 314                                         "tell_hw"=>$tell_hw,
 315                                         "from_addr"=>$from_addr,
 316                                         };
 317                         }
 318                 elsif ($type eq "REPLY") {
 319                         # Rename the fields a bit for REPLY
 320                         my($told,$who,$is_at_hw)=($who_has,$tell,$tell_hw);
 321                         for my $pending (@{$pending{$who}}) {
 322                                 $V and print localtime()." discarded: "
 323                                                 .join(",",map(("$_=".$pending->{$_}),qw(tell who_has tell_hw)))."\n";
 324                                 }
 325                         delete $pending{$who};
 326                         }
 327                 else {
 328                         die "NOTREACHED";
 329                         }
 330                 }
 331         }