Initial version deployed for: http://www.hotelsevendays.cz/

diff --git a/harpy b/harpy
new file mode 100755 (executable)
index 0000000..cb02bd2
--- /dev/null
+++ b/harpy
@@ -0,0 +1,212 @@
+#! /usr/bin/perl
+#
+# $Id$
+#
+# /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; }
+
+
+my $V=1;       # 2
+
+
+$|=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_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 $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);
+}
+
+#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)=@_;
+
+       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
+               ARPOP_REPLY(),          # $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",
+               ]);
+       return if $ar_op!=ARPOP_REQUEST();
+       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;
+}
+
+
+my %socks;
+for my $ifname (@ARGV) {
+       my($sock,$hw)=sock($ifname);
+       $socks{$ifname}={
+                       "sock"=>$sock,
+                       "hw"=>$hw,
+                       };
+       }
+
+$V and print localtime()." START\n";
+for (;;) {
+       my $rfds="";
+       vec($rfds,fileno($_->{"sock"}),1)=1 for values(%socks);
+       my $got=select $rfds,undef(),undef(),undef();
+       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)=arp_unpack($msg));
+               $V and print localtime()." got: tell=$tell,who_has=$who_has,tell_hw=$tell_hw\n";
+               next if $tell eq $who_has;      # do not reply to self-detection queries
+               my $msg_reply=arp_pack($tell_hw,$hash->{"hw"},$tell,$who_has);
+               send $hash->{"sock"},$msg_reply,0,$from_addr or die "send($ifname): $!";
+               }
+       }