first cut at dhcp and tftp servers in perl (gPXE boot works)

diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644 (file)
index 0000000..4f307b5
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,18 @@
+use lib './lib';
+use inc::Module::Install;
+
+name           'PXElator';
+version                '0.01';
+license                'GPL';
+
+requires       'Data::Dump';
+requires       'Net::DHCP::Packet';
+requires       'Net::TFTPd';
+#requires      'Getopt::Long';
+
+
+#build_requires 'Test::More';
+
+auto_install;
+
+WriteAll;

diff --git a/bin/dhcpd.pl b/bin/dhcpd.pl
new file mode 100755 (executable)
index 0000000..e5e16d1
--- /dev/null
+++ b/bin/dhcpd.pl
@@ -0,0 +1,112 @@
+#!/usr/bin/perl
+
+# based on http://www.perlmonks.org/index.pl?node_id=325248
+
+use strict;
+use warnings;
+
+use IO::Socket::INET;
+use Net::DHCP::Packet;
+use Net::DHCP::Constants;
+use Data::Dump qw/dump/;
+
+die "need to run $0 as root like this\nsudo $0\n" unless $< == 0;
+
+my $debug = shift @ARGV;
+
+my $ip_server = '10.0.0.100';
+
+my $sock = IO::Socket::INET->new(
+       LocalPort       => 67,
+#      LocalAddr       => 'localhost',
+#      LocalAddr       => '10.0.0.100',
+       LocalAddr       => '0.0.0.0',
+       Proto           => 'udp',
+       ReuseAddr       => 1,
+#      PeerPort        => getservbyname('bootpc', 'udp'),
+       Broadcast       => 1,
+       Type            => SOCK_DGRAM,
+) or die "Failed to bind to socket: $@";
+
+my $_ip = 10;
+my $_mac2ip;
+
+sub client_ip {
+       my ( $mac ) = @_;
+
+       my $ip = $_mac2ip->{$mac};
+       return $ip if $ip;
+
+       $ip = "10.0.0.$_ip";
+       $_mac2ip->{$mac} = $ip;
+
+       $_ip++;
+       if ( $_ip == 100 ) {
+               warn "IP roll-over to 10\n";
+               $_ip = 10;
+       }
+
+       return $ip;
+}
+
+while (1) {
+
+       print "waiting for DHCP requests on ",$sock->sockhost,":",$sock->sockport,"\n";
+
+       my $buf;
+       $sock->recv($buf, 1024);
+       print "<< peer:",$sock->peerhost,":",$sock->peerport,"\n";
+
+       if (defined $buf) {
+
+               my $dhcp;
+
+               eval { $dhcp = Net::DHCP::Packet->new($buf); };
+               die "can't use request", dump( $buf ) if $@;
+
+               if ( $debug ) {
+                       warn "recv: ", $dhcp->toString, "\n\n";
+               }
+
+               my $mac = substr($dhcp->chaddr(),0,$dhcp->hlen()*2);
+               my $ip = client_ip($mac);
+
+               my $packet = new Net::DHCP::Packet(
+                       Op              => BOOTREPLY(),
+                       Hops    => $dhcp->hops(),
+                       Xid             => $dhcp->xid(),
+                       Flags   => $dhcp->flags(),
+                       Ciaddr  => $dhcp->ciaddr(),
+                       Yiaddr  => $ip,
+                       Siaddr  => $ip_server,
+                       Giaddr  => $dhcp->giaddr(),
+                       Chaddr  => $dhcp->chaddr(),
+                       File    => 'undionly.kpxe',
+#                      DHO_DHCP_MESSAGE_TYPE() => DHCPACK(),
+               DHO_SUBNET_MASK() => '255.0.0.0',
+               );
+
+               warn ">> $mac == $ip server $ip_server\n";
+               
+               warn "## ",$packet->toString(),"\n" if $debug;
+
+               my $reply = IO::Socket::INET->new(
+                       LocalAddr => $ip_server,
+                       LocalPort => 67,
+                       Proto => "udp",
+                       Broadcast => 1,
+                       PeerAddr => '255.255.255.255',
+                       PeerPort => 68,
+                       Reuse => 1,
+               ) or die "socket: $@";
+
+               my $buff = $packet->serialize();
+               $reply->send( $buff, 0 ) or die "Error sending: $!\n";
+
+#              system("arp -s $ip $mac"),
+
+       } else {
+               print "No bootp request.\n";
+       }
+
+}

diff --git a/bin/install-debian.sh b/bin/install-debian.sh
new file mode 100755 (executable)
index 0000000..64e3aa0
--- /dev/null
+++ b/bin/install-debian.sh
@@ -0,0 +1 @@
+sudo apt-get install libnet-dhcp-perl libmodule-install-perl

diff --git a/bin/network-config.sh b/bin/network-config.sh
new file mode 100755 (executable)
index 0000000..f88e8b7
--- /dev/null
+++ b/bin/network-config.sh
@@ -0,0 +1,3 @@
+sudo ifconfig eth0 10.0.0.100 up
+sudo ifconfig eth0
+sudo ethtool eth0

diff --git a/bin/tftpd.pl b/bin/tftpd.pl
new file mode 100755 (executable)
index 0000000..0998828
--- /dev/null
+++ b/bin/tftpd.pl
@@ -0,0 +1,66 @@
+#!/usr/bin/perl
+use strict;
+use lib 'lib';
+use Net::TFTPd 0.03 qw(%OPCODES);
+
+die "need to run $0 as root like this\nsudo $0\n" unless $< == 0;
+
+# change ROOTDIR to your TFTP root directory
+my $rootdir = $ARGV[0] || 'tftp';
+
+unless(-d $rootdir)
+{
+       print "\nUsage: $0 path/to/rootdir\n\n";
+       exit 1;
+}
+
+# callback sub used to print transfer status
+sub callback
+{
+       my $req = shift;
+       if($req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'RRQ'})
+       {
+               # RRQ
+               printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTACK'}, $req->{'_REQUEST_'}{'LASTBLK'};
+       }
+       elsif($req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'WRQ'})
+       {
+               # WRQ
+               printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTBLK'}, $req->{'_REQUEST_'}{'LASTACK'};
+       }
+}
+
+# create the listener
+my $listener = Net::TFTPd->new(
+       'RootDir' => $rootdir,
+       'Writable' => 0,
+       'Timeout' => 3600, 
+       'CallBack' => \&callback,
+#      LocalAddr => '10.0.0.100',
+#      BlkSize => 8192,
+#      BlkSize => 512,
+       BlkSize => 1456,        # IBM GE seems to be picky
+       Debug => 99,
+) or die Net::TFTPd->error;
+printf "TFTP listener is bound to %s:%d\nTFTP listener is waiting %d seconds for a request\n", $listener->{'LocalAddr'} ? $listener->{'LocalAddr'} : "'any address'",  $listener->{'LocalPort'}, $listener->{'Timeout'};
+
+while(1) {
+
+       # wait for any request (RRQ or WRQ)
+       if(my $request = $listener->waitRQ()) {
+               # received request
+               printf "Received a %s for file '%s'\n", $OPCODES{$request->{'_REQUEST_'}{'OPCODE'}}, $request->{'_REQUEST_'}{'FileName'};
+
+               # process the request
+               if($request->processRQ()) {
+                       print "OK, transfer completed successfully\n";
+               } else {
+                       warn Net::TFTPd->error;
+                       $request->processRQ();
+               }
+       } else {
+               # request not received (timed out waiting for request etc.)
+               warn Net::TFTPd->error;
+       }
+
+}