Finish requst code. Implemented release code. Complete code ready for the public

[pve-dhcp-server.git] / DHCPServer.pm

package PVE::DHCPServer;

use strict;
use warnings;
use Carp qw(croak);
use Sys::Hostname;
use Socket;
use Socket6;
use NetAddr::IP;
use IO::Socket::IP;
use IO::File;
use IO::Select;
use Sys::Syslog;
use Fcntl qw(:DEFAULT :flock SEEK_END);
use POSIX qw(EINTR setsid strftime);
use Data::Dumper;
use Time::Local;

use Net::DHCP::Packet;
use Net::DHCP::Constants;

use constant {
	DEBUG => 0,
	INFO => 1,
	NOTICE => 2,
	WARNING => 3,
	ERROR => 4,
	CRITICAL => 5,
	ALERT => 6,
	EMERGENCY => 7,
};

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(
	run
	DEBUG
	INFO
	NOTICE
	WARNING
	ERROR
	CRITICAL
	ALERT
	EMERGENCY
);

our $VERSION = '0.01';
our $NAME = 'PVE::DHCPServer';
our $DEFAULT_LEASE = 7200;
our $DEFAULT_LEASE_RENEW = 5400;
my $time_to_die = 0;

#########################################################################
# Private methods
#########################################################################

my $logger = sub {
	my ($self, $message, $level) = @_;

	$level ||= DEBUG;
	return unless ($level >= $self->{LOG_LEVEL});

	$level = "debug" if $level eq DEBUG;
	$level = "info" if $level eq INFO;
	$level = "notice" if $level eq NOTICE;
	$level = "warning" if $level eq WARNING;
	$level = "err" if $level eq ERROR;
	$level = "crit" if $level eq CRITICAL;
	$level = "alert" if $level eq ALERT;
	$level = "emerg" if $level eq EMERGENCY;

	if ($self->{DEBUG}) {
		print STDOUT strftime "[%d/%b/%Y:%H:%M:%S] ", localtime;
		print STDOUT "$level: " . ($message ? $message : 'No message') . "\n";
	} elsif ($self->{log_file} eq 'syslog') {
		openlog($NAME, 'ndelay,pid', 'user');
		syslog($level, $message);
		closelog();
	} else {
		my $fh = new IO::File;
		if (! $fh->open("> $self->{log_file}")) {
			croak "$self->{log_file}: $!";
		}
		print $fh strftime "[%d/%b/%Y:%H:%M:%S] ", localtime;
		print $fh "$level: $message\n";
		undef $fh;
	}
};

my $run_with_timeout = sub {
    my ($self, $code, @param) = @_;

    die "got timeout" if $self->{timeout} <= 0;

    my $prev_alarm;

    my $sigcount = 0;

    my $res;

    local $SIG{ALRM} = sub { $sigcount++; }; # catch alarm outside eval

    eval {
		local $SIG{ALRM} = sub { $sigcount++; die "got timeout"; };
		local $SIG{PIPE} = sub { $sigcount++; die "broken pipe" };
		local $SIG{__DIE__};   # see SA bug 4631

		$prev_alarm = alarm($self->{timeout});

		$res = &$code(@param);

		alarm(0); # avoid race conditions
    };

    my $err = $@;

    alarm($prev_alarm) if defined($prev_alarm);

    die "unknown error" if $sigcount && !$err; # seems to happen sometimes

    die $err if $err;

    return $res;
};

my $lock = sub {
	my ($self, $file, $shared) = @_;

	my $mode = $shared ? LOCK_SH : LOCK_EX;

	my $lock_func = sub {
		if ($mode == LOCK_SH) {
			$self->{file_handle} = new IO::File ("<$file") ||
                die "can't open file '$file' for read - $!";
		} else {
			$self->{file_handle} = new IO::File (">$file") ||
                die "can't open file '$file' for write - $!";
		}
        $self->$logger("trying to aquire lock on '$file'...");
        if (!flock ($self->{file_handle}, $mode|LOCK_NB)) {
			my $success;
			while(1) {
				$success = flock($self->{file_handle}, $mode);
				# try again on EINTR (see bug #273)
				if ($success || ($! != EINTR)) {
					last;
				}
			}
			if ($mode == LOCK_SH) {
				seek($self->{file_handle}, 0, SEEK_END) or $success = 0;
			}
			if (!$success) {
				$self->$logger(" failed");
				die "can't aquire lock - $!";
			}
        }
		$self->$logger(" OK");
    };

    my $res;
    my $err = undef;

    eval {
		$res = $self->$run_with_timeout($lock_func);
	};
    if ($@) {
		$self->$logger("can't lock file '$file' - $@", ERROR);
		$self->{file_handle} = undef;
		return undef;
    }

    return $res;
};

my $unlock = sub {
	my ($self, $file) = @_;

	return '' unless($self->{file_handle});
	my $unlock_func = sub {
        $self->$logger("trying to unlock '$file'...");
        if (!flock($self->{file_handle}, LOCK_UN)) {

			my $success;
			while(1) {
				$success = flock($self->{file_handle}, LOCK_UN);
				# try again on EINTR (see bug #273)
				if ($success || ($! != EINTR)) {
					last;
				}
			}
			if (!$success) {
				$self->$logger(" failed");
				die "can't unlock - $!";
			}
        }
		$self->$logger(" OK");
    };

    my $res;
    my $err = undef;

    eval {
		$res = $self->$run_with_timeout($unlock_func);
	};
    if ($@) {
		$self->$logger("can't lock file '$file' - $@", ERROR);
		$self->{file_handle} = undef;
		$res = undef;
    }

    return $res;
};

my $convert_timestamp = sub {
	my ($self, $timestamp, $strtotime) = @_;
	my ($res, $mday, $mon, $year, $hour, $min, $sec);

	$self->$logger("Timestamp: $timestamp");
	if ($strtotime) {
		if ($timestamp !~ /^\d{4}\/\d{2}\/\d{2}\s+\d{2}:\d{2}:\d{2}$/) {
			$self->$logger("$timestamp: (strtotime) Bad format", ERROR);
			$res = undef;
		} else {
			($year,$mon,$mday,$hour,$min,$sec) = split(/[\s\/:]+/, $timestamp);
			$res = timelocal($sec,$min,$hour,$mday,$mon-1,$year);
		}
	} else{
		$self->$logger($timestamp);
		if ($timestamp !~ /^\d+$/) {
			$self->$logger("$timestamp: (timetostr) Bad format", ERROR);
			$res = undef;
		} else {
			($sec,$min,$hour,$mday,$mon,$year) = localtime($timestamp);
			$self->$logger("Timestamp: $sec,$min,$hour,$mday,$mon,$year");
			$res = sprintf("%d/%02d/%02d %02d:%02d:%02d", ($year+1900),($mon+1),$mday,$hour,$min,$sec);
			$self->$logger("Timestamp: $res");
		}
	}

	return $res;
};


my $add_lease = sub {
	my ($self, $ip, $lease) = @_;
	my $ts;

	my $mac = $lease->{'hardware ethernet'};
	$mac =~ tr/://d;
	$lease->{'hardware ethernet'} = $mac;
	$ts = $self->$convert_timestamp($lease->{starts}, 1);
	return unless $ts;
	$lease->{starts} = $ts;
	$ts = $self->$convert_timestamp($lease->{ends}, 1);
	return unless $ts;
	$lease->{ends} = $ts;

	$self->{_leases}->{$ip} = $lease;
	$self->$logger(Dumper($self->{_leases}->{$ip}));
	$self->{_reverse}->{$mac} = $ip;
	$self->$logger("$mac => $self->{_reverse}->{$mac}");
};

#lease vvv.xxx.yyy.zzz {
#	starts yyyy/mm/dd hh:mm:ss;
#	ends yyyy/mm/dd hh:mm:ss;
#	binding state active|free;
#	hardware ethernet MAC;
#	client-hostname "name"
#}
my $read_lease_file = sub {
	my ($self) = @_;
	my ($res, $key, $lease);
	my $error = 0;

	# Start with empty leases file?
	if (! -e $self->{lease_file}) {
		return 0;
	}

	$self->$lock($self->{lease_file}, 1);
	if ($self->{file_handle}) {
		my $fh = $self->{file_handle};
		my @lines = <$fh>;
		foreach (@lines) {
			$self->$logger("Read: $_");
			if ($_ =~ /^\s*lease\s+([\d\.]+)\s+{\s*/) {
				$self->$add_lease($key, $lease) if $lease;
				$key = $1;
				$lease = undef;
				$error = 0;
				$self->$logger("Key: $key");
			} else {
				next if $error;
				next if ($_ =~ /^\s*}\s*/ || $_ =~ /^\s*$/ || $_ =~ /^\s*#.*/);
				if ($_ =~ /^\s*(starts|ends|binding state|hardware ethernet|client-hostname)\s+(.+)\s*;/) {
					$lease->{$1} = $2;
					$self->$logger("Key: $1 Value: $2");
				} else {
					$key = 'UNDEF' unless $key;
					$self->$logger("$key: Bad format", ERROR);
					$key = undef;
					$lease = undef;
					$error = 1;
				}
			}
		}
		if ($lease && !$error) {
			$self->$logger("Key: $key");
			$self->$add_lease($key, $lease);
		}
		$self->$logger("Leases data structure: \n" . Dumper($self->{_leases}));
		$self->$unlock($self->{lease_file});
		$res = 1;
	} else {
		$self->$logger("Could not read leases file", ERROR);
		$res = 0;
	}

	return $res;
};

my $write_lease_file = sub {
	my ($self) = @_;
	my $res;

	$res = $self->$lock($self->{lease_file}, 0);
	if ($self->{file_handle}) {
		if ($self->{_leases}) {
			my $fh = $self->{file_handle};
			my %leases = %{$self->{_leases}};
			while ((my $lease, my $elems) = each (%leases)) {
				$self->$logger("Writing: $lease");
				print $fh "lease $lease {\n";
				while ((my $key, my $val) = each %$elems) {
					if ($key =~ /^(starts|ends)$/) {
						$val = $self->$convert_timestamp($val, 0);
					}
					$self->$logger("Writing: $key $val");
					print $fh "\t$key $val;\n";
				}
				print $fh "}\n";
			}
		}
		$self->$unlock($self->{lease_file});
		$res = 1;
	} else {
		$self->$logger("Could not write leases file", ERROR);
		$res = 0;
	}

	return $res;
};

#subnet 192.168.9.0 netmask 255.255.255.0 {
#	range 192.168.9.2 192.168.9.100;
#	ttl 7200;
#	rttl 3600;
#	router 192.168.9.254;
#	dns-servers 192.168.2.201;
#	ntp-servers 192.168.9.254;
#	broadcast 192.168.9.255;
#	domain-name "foo.bar";
#	{
#		allow 001cc0c33317,001cc0c33318,001cc0c33319,001cc0c33320;
#		static 001cc0c33317 192.168.9.100,001cc0c33318 192.168.9.200;
#	}
#}
my $read_config = sub {
	my ($self) = @_;
	my ($res, $key, $netmask, $config, $subopt);

	$self->$lock($self->{conf_file}, 1);
	if ($self->{file_handle}) {
		my $fh = $self->{file_handle};
		my @lines = <$fh>;
		$subopt = 0;
		foreach (@lines) {
			$self->$logger("Read: $_");
			if ($_ =~ /^\s*subnet\s+([\d\.]+)\s+netmask\s+([\d\.]+)\s+{\s*/) {
				$self->{_config}->{$key} = $config if $config;
				$key = $1;
				$config = undef;
				$config->{netmask} = $2;
				$self->$logger("Key: $key Netmask: $config->{netmask}");
			} else {
				next if (($_ =~ /^\s*}\s*/ && ! $subopt) || $_ =~ /^\s*$/ || $_ =~ /^\s*#.*/);
				if (! $subopt && $_ =~ /^\s*(range|ttl|rttl|router|dns-servers|ntp-servers|broadcast|domain-name)\s+(.+)\s*;/) {
					$config->{$1} = $2;
					$self->$logger("Key: $1 Value: $2");
				} elsif ($subopt &&$_ =~ /^\s*}\s*/) {
					$subopt = 0;
				} elsif ($subopt || $_ =~ /^\s*{\s*/) {
					if ($subopt) {
						if ($_ =~ /^\s*(allow|static)\s+(.+)\s*;/) {
							my @vals = split(/\s*,\s*/, $2);
							$config->{$1} = [@vals];
							$self->$logger("Key: $1 Value: $2");
						} else {
							$key = 'UNDEF' unless $key;
							my $err = "$key: 'suboptions' Bad format";
							$self->$logger($err, ERROR);
							$key = undef;
							$config = undef;
							die $err;
						}
					} else {
						$subopt = 1;
					}
				} else {
					$key = 'UNDEF' unless $key;
					my $err = "$key: Bad format";
					$self->$logger($err, ERROR);
					$key = undef;
					$config = undef;
					die $err;
				}
			}
		}
		if ($config) {
			$self->{_config}->{$key} = $config;
		}
		$self->$logger("Config data structure: \n" . Dumper($self->{_config}));
		$self->$unlock($self->{conf_file});
		if (!$self->{_config}) {
			die "Empty config file";
		}
	} else {
		die "Could not read config file";
	}
};

#########################################################################
#  Private methods which handle DHCP4 requests
#########################################################################

my $get_mac_ip4 = sub {
	my ($self, $dhcpreq) = @_;
	my $mac;

	$mac = $dhcpreq->chaddr();
	$mac =~ s/0+$//;

	return $mac;
};

my $can_client_use_net_ip4 = sub {
	my ($self, $dhcpreq, $network) = @_;
	my (@allow, $found);

	# Is client allowed to request IP?
	$found = 0;
	if ($self->{_config}->{$network}->{allow}) {
		@allow = $self->{_config}->{$network}->{allow};
		$self->$logger("Allow: " . Dumper(@allow));
		foreach (@allow) {
			if ($_ eq $self->$get_mac_ip4($dhcpreq)) {
				$found = 1;
				last;
			}
		}
	} else {
		$found = 1;
	}

	return $found;
};

my $create_new_lease_ip4 = sub {
	my ($self, $dhcpreq, $network, $lease) = @_;

	if (! $lease) {
		$lease = ();
		$lease->{'hardware ethernet'} = $self->$get_mac_ip4($dhcpreq);
	}
	my $client = $dhcpreq->getOptionValue(DHO_HOST_NAME());
	$lease->{'client-hostname'} = $client ? $client : $self->$get_mac_ip4($dhcpreq);
	$lease->{'binding state'} = 'active';
	my $start = time;
	my $end = $start + $self->{_config}->{$network}->{ttl};
	$lease->{starts} = $self->$convert_timestamp($start, 0);
	$lease->{ends} = $self->$convert_timestamp($end, 0);

	return $lease;
};

my $add_options_ip4 = sub {
	my ($self, $dhcpreq) = @_;

	if ($self->{lease_time}) {
		$dhcpreq->addOptionValue(DHO_DHCP_LEASE_TIME, $self->{lease_time});
	}
	if ($self->{lease_time_renew}) {
		$dhcpreq->addOptionValue(DHO_DHCP_RENEWAL_TIME, $self->{lease_time_renew});
	}
	if ($self->{subnet_mask}) {
		$dhcpreq->addOptionValue(DHO_SUBNET_MASK, $self->{subnet_mask});
	}
	if ($self->{routers}) {
		$dhcpreq->addOptionValue(DHO_ROUTERS, $self->{routers});
	}
	if ($self->{broadcast_addr}) {
		$dhcpreq->addOptionValue(DHO_BROADCAST_ADDRESS, $self->{broadcast_addr});
	}
	if ($self->{domain_name}) {
		$dhcpreq->addOptionValue(DHO_DOMAIN_NAME, $self->{domain_name});
	}
	if ($self->{ntp_servers}) {
		$dhcpreq->addOptionValue(DHO_NTP_SERVERS, $self->{ntp_servers});
	}
	if ($self->{dns_servers}) {
		$dhcpreq->addOptionValue(DHO_DOMAIN_NAME_SERVERS, $self->{dns_servers});
	}
};

my $calculate_net_ip4 = sub {
	my ($self, $dhcpreq) = @_;
	my ($req_addr, $network);

	$req_addr = $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS());
	$self->$logger("Req IP: " . ($req_addr ? $req_addr : 'None'));
	if ($req_addr) {
		my ($space, $test);
		my %config = %{$self->{_config}};
		while (my ($net, $opt) = each (%config)) {
			$self->$logger("Network: $net/$opt->{netmask}\n" . Dumper($opt));
			$space = NetAddr::IP->new($net, $opt->{netmask});
			$test = NetAddr::IP->new($req_addr);
			if ($space->contains($test)) {
				$network = $net if ($self->$can_client_use_net_ip4($dhcpreq, $net));
				last;
			}
		}
	} else {
		my ($space, $test);
		my %config = %{$self->{_config}};
		while (my ($net, $opt) = each (%config)) {
			$self->$logger("Network: $net/$opt->{netmask}\n" . Dumper($opt));
			my $can = $self->$can_client_use_net_ip4($dhcpreq, $net);
			$self->$logger("Network usable: $can");
			if ($can) {
				$network = $net;
				last;
			}
		}
	}

	$self->$logger("Network: " . ($network ? $network : 'None'));

	return $network;
};

my $renew_lease_ip4 = sub {
	my ($self, $dhcpreq, $network, $req_addr) = @_;
	my ($start, $end, $test, $ip, $lease);

	my $find_ip_and_lease = sub {
		my ($reqaddr) = @_;

		my @range_str = split(/\s+/, $self->{_config}->{$network}->{range});
		$self->$logger("Range: " . $range_str[0] . " - " . $range_str[1]);
		$start = NetAddr::IP->new($range_str[0]);
		$end = NetAddr::IP->new($range_str[1]);
		$self->$logger(Dumper($start) . Dumper($end));

		if ($reqaddr) {
			my $request = NetAddr::IP->new($reqaddr);
			if ($start <= $request && $request <= $start) {
				my $nip = $start->addr();
				$self->$logger("IP: $nip");
				if ($self->{_leases}->{$nip}) {
					$lease = $self->{_leases}->{$nip};
					if ($lease->{'binding state'} eq 'free') {
						$ip = $nip;
						$lease = $self->$create_new_lease_ip4($dhcpreq, $network, $lease);
					}
				}
			}
		} else {
			my $free = undef;
			for (; $start <= $end; $start++) {
				my $nip = $start->addr();
				$self->$logger("IP: $nip");
				if ($self->{_leases}->{$nip} && ! $free) {
					$lease = $self->{_leases}->{$nip};
					if ($lease->{'binding state'} eq 'free') {
						$free = ();
						$free->{$nip} = $lease;
					}
				} else {
					$lease = $self->$create_new_lease_ip4($dhcpreq, $network);
					$ip = $nip;
					last;
				}
			}
			if (! $ip && $free) {
				($ip, $lease) = each($free);
				$lease = $self->$create_new_lease_ip4($dhcpreq, $network, $lease);
			}
		}

		return ($ip, $lease);
	};

	if ($req_addr) {
		if ($self->{_leases}) {
			$lease = $self->{_leases}->{$req_addr};
			return undef if ($lease && $lease->{'hardware ethernet'} ne $self->$get_mac_ip4($dhcpreq));
			$lease = $self->$create_new_lease_ip4($dhcpreq, $network, $lease);
			$ip = $req_addr;
		} else {
			($ip, $lease) = $find_ip_and_lease->($req_addr);
		}
	} else {
		my $mac = $self->$get_mac_ip4($dhcpreq);
		$self->$logger("MAC: $mac");
		if ($self->{_reverse}->{$mac}) {
			$self->$logger("MAC: $mac IP: " . $self->{_reverse}->{$mac});
			$ip = $self->{_reverse}->{$mac};
			$lease = $self->{_leases}->{$ip};
			$lease = $self->$create_new_lease_ip4($dhcpreq, $network, $lease);
		} else {
			($ip, $lease) = $find_ip_and_lease->($req_addr);
		}
	}

	$self->$logger("IP: $ip lease:\n" . Dumper($lease));
	if ($ip && $lease) {
		$self->$add_lease($ip, $lease);
		if ($self->{_leases}->{$ip} && $self->{_leases}->{$ip}->{starts} ==	$lease->{starts}) {
			$self->{lease_time} = $DEFAULT_LEASE;
			if ($self->{_config}->{$network}->{ttl}) {
				$self->{lease_time}	= $self->{_config}->{$network}->{ttl};
			}
			$self->{lease_time_renew} = $DEFAULT_LEASE_RENEW;
			if ($self->{_config}->{$network}->{rttl}) {
				$self->{lease_time_renew} = $self->{_config}->{$network}->{rttl};
			}
			if ($self->{_config}->{$network}->{netmask}) {
				$self->{subnet_mask} = $self->{_config}->{$network}->{netmask};
			}
			if ($self->{_config}->{$network}->{router}) {
				$self->{routers} = $self->{_config}->{$network}->{router};
			}
			if ($self->{_config}->{$network}->{broadcast}) {
				$self->{broadcast_addr}	= $self->{_config}->{$network}->{broadcast};
			}
			if ($self->{_config}->{$network}->{'domain-name'}) {
				$self->{domain_name} = $self->{_config}->{$network}->{'domain-name'};
			}
			if ($self->{_config}->{$network}->{'dns-servers'}) {
				$self->{dns_servers} = $self->{_config}->{$network}->{'dns-servers'};
			}
			if ($self->{_config}->{$network}->{'ntp-servers'}) {
				$self->{ntp_servers} = $self->{_config}->{$network}->{'ntp-servers'};
			}
		} else {
			$ip = undef;
		}
	}

	return $ip;
};

my $calculate_ip_ip4 = sub {
	my ($self, $dhcpreq) = @_;
	my ($req_addr, $calc_ip, $network);

	return undef unless $dhcpreq->chaddr();
	$req_addr = $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS());
	$network = $self->$calculate_net_ip4($dhcpreq);
	return undef unless $network;

	if ($self->{_config}->{$network}->{static}) {
		my @static = $self->{_config}->{$network}->{static};
		foreach (@static) {
			my @mac = split(/\s+/, $_);
			if ($mac[0] == $self->$get_mac_ip4($dhcpreq)) {
				$calc_ip = $mac[1];
				last;
			}
		}
	}
	if ($req_addr) {
		if ($calc_ip && $req_addr != $calc_ip) {
			$calc_ip = undef;
		} else {
			$calc_ip = $self->$renew_lease_ip4($dhcpreq, $network, $req_addr);
		}
	} else {
		$calc_ip = $self->$renew_lease_ip4($dhcpreq, $network);
	}

	return $calc_ip;
};

my $discover_ip4 = sub {
	my ($self, $dhcpreq) = @_;
	my ($res, $dhcpresp, $calc_ip, $req_addr);

	# calculate address
	# $calc_ip = "192.168.9.2";

	$self->$logger("Got request\n".$dhcpreq->toString());

	$self->{_sock_out_ip4} = IO::Socket::IP->new(
		Broadcast => 1,
		PeerPort => 68,
		PeerAddr => inet_ntoa(INADDR_BROADCAST),
		Proto    => 'udp'
	) || do {
		my $err = $@;
		$self->$logger("[discover_ip4] Socket creation error: $err", ERROR);
		die "[discover_ip4] Socket creation error: $err\n";
	};

	$res = $self->$read_lease_file();#$self->read_lease_file();

	if ($self->{LOG_LEVEL} <= INFO) {
		$req_addr = $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS());
		if ($req_addr) {
			$self->$logger("Requested IP: $req_addr", INFO);
		} else {
			$self->$logger("Requested IP: None", INFO);
		}
	}
	$calc_ip = $self->$calculate_ip_ip4($dhcpreq);
	$self->$logger("Offer: $calc_ip");
	if ($calc_ip) {
		$self->$logger("Creating lease for $calc_ip");
		$res = $self->$write_lease_file();
	}
	if ($res && $calc_ip) {
		$dhcpresp = new Net::DHCP::Packet(
			Comment => $dhcpreq->comment(),
			Op => BOOTREPLY(),
			Hops => $dhcpreq->hops(),
			Xid => $dhcpreq->xid(),
			Flags => $dhcpreq->flags(),
			Ciaddr => $dhcpreq->ciaddr(),
			Yiaddr => $calc_ip,
			Siaddr => $dhcpreq->siaddr(),
			Giaddr => $dhcpreq->giaddr(),
			Chaddr => $dhcpreq->chaddr(),
			DHO_DHCP_MESSAGE_TYPE() => DHCPOFFER(),
			DHO_DHCP_SERVER_IDENTIFIER() => $self->{_sock_out_ip4}->sockhost
		);
		$self->$add_options_ip4($dhcpreq);
	} else {
		# bad request, we send a NAK
		$dhcpresp = new Net::DHCP::Packet(
			Comment => $dhcpreq->comment(),
			Op => BOOTREPLY(),
			Hops => $dhcpreq->hops(),
			Xid => $dhcpreq->xid(),
			Flags => $dhcpreq->flags(),
			Ciaddr => $dhcpreq->ciaddr(),
			Yiaddr => "0.0.0.0",
			Siaddr => $dhcpreq->siaddr(),
			Giaddr => $dhcpreq->giaddr(),
			Chaddr => $dhcpreq->chaddr(),
			DHO_DHCP_MESSAGE_TYPE() => DHCPNAK(),
			DHO_DHCP_MESSAGE(), "Bad request...",
		);
	}

	$self->$logger("Sending response to " .
		$self->{_sock_out_ip4}->peerhost . ':' .
		$self->{_sock_out_ip4}->peerport, INFO);

	# Socket object keeps track of whom sent last packet
	# so we don't need to specify target address
	$self->$logger($dhcpresp->toString());
	$self->$logger("Sending OFFER tr=".$dhcpresp->comment(), INFO);
	$self->{_sock_out_ip4}->send($dhcpresp->serialize()) || die "Error sending OFFER: $!\n";
};

my $request_ip4 = sub {
	my ($self, $dhcpreq) = @_;
	my ($calc_ip, $dhcpresp, $peeraddr, $result);

	$self->$logger("Got request\n".$dhcpreq->toString());

	$peeraddr = $dhcpreq->ciaddr() ? $dhcpreq->ciaddr() : inet_ntoa(INADDR_BROADCAST);
	$self->{_sock_out_ip4} = IO::Socket::IP->new(
		Broadcast => 1,
		PeerPort => 68,
		PeerAddr => $peeraddr,
		Proto    => 'udp',
	) || do {
		my $err = $@;
		$self->$logger("[request_ip4] Socket creation error: $err", ERROR);
		die "[request_ip4] Socket creation error: $err\n";
	};

	my $network = $self->$calculate_net_ip4($dhcpreq);
	if ($network) {
		my $req_addr = $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS());
		$calc_ip = $self->$renew_lease_ip4($dhcpreq, $network, $req_addr);
	}

	# compare calculated address with requested address
	if ($calc_ip) {
		# address is correct, we send an ACK
		$dhcpresp = new Net::DHCP::Packet(
			Comment => $dhcpreq->comment(),
			Op => BOOTREPLY(),
			Hops => $dhcpreq->hops(),
			Xid => $dhcpreq->xid(),
			Flags => $dhcpreq->flags(),
			Ciaddr => $dhcpreq->ciaddr(),
			Yiaddr => $calc_ip,
			Siaddr => $dhcpreq->siaddr(),
			Giaddr => $dhcpreq->giaddr(),
			Chaddr => $dhcpreq->chaddr(),
			DHO_DHCP_MESSAGE_TYPE() => DHCPACK(),
			DHO_DHCP_SERVER_IDENTIFIER() => $self->{_sock_out_ip4}->sockhost,
		);
		$self->$add_options_ip4($dhcpreq);
		$result = 'ACK';
	} else {
		# bad request, we send a NAK
		$dhcpresp = new Net::DHCP::Packet(
			Comment => $dhcpreq->comment(),
			Op => BOOTREPLY(),
			Hops => $dhcpreq->hops(),
			Xid => $dhcpreq->xid(),
			Flags => $dhcpreq->flags(),
			Ciaddr => $dhcpreq->ciaddr(),
			Yiaddr => "0.0.0.0",
			Siaddr => $dhcpreq->siaddr(),
			Giaddr => $dhcpreq->giaddr(),
			Chaddr => $dhcpreq->chaddr(),
			DHO_DHCP_MESSAGE_TYPE() => DHCPNAK(),
			DHO_DHCP_MESSAGE(), "Bad request...",
		);
		$result = 'NAK';
	}

	$self->$logger("Sending response to " .
		$self->{_sock_out_ip4}->peerhost . ':' .
		$self->{_sock_out_ip4}->peerport, INFO);

	# Socket object keeps track of whom sent last packet
	# so we don't need to specify target address
	$self->$logger($dhcpresp->toString());
	$self->$logger("Sending $result tr=".$dhcpresp->comment(), INFO);
	$self->{_sock_out_ip4}->send($dhcpresp->serialize()) || die "Error sending ACK/NAK: $!\n";
};

my $release_ip4 = sub {
	my ($self, $dhcpreq) = @_;
	my ($ip, $mac);

	$self->$logger($dhcpreq->toString());
	$ip = $dhcpreq->ciaddr();
	$mac = $self->$get_mac_ip4($dhcpreq);
	$self->$logger("Release request for IP: $ip MAC: $mac", INFO);

	if ($self->{_leases}->{$ip}) {
		my $lease = $self->{_leases}->{$ip};
		if ($lease->{'hardware ethernet'} eq $mac) {
			$lease->{'binding state'} = 'free';
		}
		$self->$write_lease_file();
	}
};

#########################################################################
#  Private methods which handle DHCP6 requests
#########################################################################

my $excuse_me_ip6 = sub {
	my ($self, $addr, $dhcpreq) = @_;

	$self->$logger("IPv6 request from [$addr]: $dhcpreq", INFO);
	$self->{_sock_out_ip6} = IO::Socket::IP->new(
		Domain	  => PF_INET6,
		V6Only	  => 1,
		Broadcast => 1,
		PeerPort  => 546,
		PeerAddr  => $addr,
		Proto     => 'udp',
	) || do {
		my $err = $@;
		$self->$logger("[excuse_me_ip6] Socket creation error: $err", ERROR);
		die "[excuse_me_ip6] Socket creation error: $err\n";
	};
	$self->$logger("$addr: Not implemented here", INFO);
	$self->{_sock_out_ip6}->send("Not implemented here") || die "Error sending excuse: $!\n";
};

#########################################################################
# Public methods
#########################################################################

# generic signal handler to cause daemon to stop
sub signal_handler {
    $time_to_die = 1;
}
$SIG{INT} = $SIG{TERM} = $SIG{HUP} = \&signal_handler;

# ignore any PIPE signal: standard behaviour is to quit process
$SIG{PIPE} = 'IGNORE';

sub new {
    my ($class, %self) = @_;

    # OOP stuff
    $class = ref($class) || $class;
    my $self = \%self;
    bless $self, $class;

	# private
    $self->{_sock_in_ip4}	  	= undef;
    $self->{_sock_out_ip4}	  	= undef;
    $self->{_sock_in_ip6}	  	= undef;
    $self->{_sock_out_ip6}	  	= undef;
    $self->{_leases}		  	= undef;
    $self->{_reverse}		  	= undef;
    $self->{_config}		  	= undef;
	$self->{_transaction_ip4} 	= 0;
	$self->{_transaction_ip6} 	= 0;
	$self->{_dhpcp_ip4}			= undef;

	# public
	$self->{log_file}			||= 'syslog';
    $self->{lease_time}			||= $DEFAULT_LEASE;
    $self->{lease_time_renew}	||= $DEFAULT_LEASE_RENEW;
    $self->{subnet_mask}		||= undef;
    $self->{routers}			||= undef;
    $self->{broadcast_addr}		||= undef;
    $self->{domain_name}		||= undef;
    $self->{dns_servers}		||= undef;
	$self->{ntp_servers}		||= undef;
	$self->{LOG_LEVEL} 			= ERROR unless defined $self->{LOG_LEVEL};
	$self->{NODAEMON}			||= 0;
	$self->{DEBUG}				||= 0;
	$self->{timeout}			||= 10;
	$self->{lease_file}			||= '/tmp/dhcpd.leases';
	$self->{conf_file}			||= '/tmp/dhcpd.cfg';

    return $self;
}

sub run {
	my ($self) = @_;
	my ($sel, @ready, $socket, $res);

	eval {
		$self->$read_config();
	};
	if ($@) {
		my $err = $@;
		$self->$logger($err, ERROR);
		die $err;
	}
	$self->$logger("Starting dhcpd", INFO);
	if ($self->{NODAEMON} < 1) {
		$self->$logger("Entering Daemon mode");
		chdir '/'                 or die "Can't chdir to /: $!";
		umask 0;

		open STDIN, '/dev/null'   or die "Can't read /dev/null: $!";
		open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!";
		open STDERR, '>/dev/null' or die "Can't write to /dev/null: $!";

		my $pid = fork;
		exit if $pid;
		do {
			my $err = $!;
			$self->$logger("Couldn't fork: $err", ERROR);
			die "Couldn't fork: $err";
		} unless defined($pid);

		POSIX::setsid() || do {
			my $err = $!;
			$self->$logger("Can't start a new session: $err", ERROR);
			die "Can't start a new session: $err";
		};
		$self->$logger("Now in Daemon mode", INFO);
	}

	$res = $self->$read_lease_file();
	$self->$logger("Starting with empty leases file '$self->{lease_file}'", INFO)
		if (! $res || ! $self->{_leases});

	$self->$logger("Initialization complete", INFO);

	# open listening socket
	$self->{_sock_in_ip4} = IO::Socket::IP->new(
		Domain		=> PF_INET,
		LocalPort	=> 67,
		LocalAddr	=> inet_ntoa(INADDR_ANY),
		Proto		=> 'udp'
	) || do {
		my $err = $@;
		$self->$logger("IP4 Socket creation error: $err", ERROR);
		die "IP4 Socket creation error: $err\n";
	};
	$self->{_sock_in_ip6} = IO::Socket::IP->new(
		Domain		=> PF_INET6,
		V6Only		=> 1,
		LocalPort	=> 547,
		LocalAddr	=> '::',
		Proto		=> 'udp'
	) || do {
		my $err = $@;
		$self->$logger("IP6 Socket creation error: $err", ERROR);
		die "IP6 Socket creation error: $err\n";
	};

	$sel = IO::Select->new($self->{_sock_in_ip4});
	$sel->add($self->{_sock_in_ip6});

	until ($time_to_die) {
		my $buf = undef;
		my $fromaddr;
		my $dhcpreq;

		eval {	# catch fatal errors
			while (@ready = $sel->can_read) {
				$self->$logger("Waiting for incoming packet", INFO);
				foreach $socket (@ready) {
					if ($socket == $self->{_sock_in_ip4}) {
						# receive ipv4 packet
						$fromaddr = $self->{_sock_in_ip4}->recv($buf, 4096)
							|| $self->$logger("recv: $!", ERROR);
						next if ($!);	# continue loop if an error occured
						$self->{_transaction_ip4}++;	# transaction counter

						{
							use bytes;
							my ($port,$addr) = unpack_sockaddr_in($fromaddr);
							my $ipaddr = inet_ntoa($addr);
							$self->$logger("Got a packet tr=$self->{_transaction_ip4} src=$ipaddr:$port length=".length($buf), INFO);
						}

						$dhcpreq = new Net::DHCP::Packet($buf);
						$dhcpreq->comment($self->{_transaction_ip4});

						my $messagetype = $dhcpreq->getOptionValue(DHO_DHCP_MESSAGE_TYPE());

						if ($messagetype eq DHCPDISCOVER()) {
								$self->$discover_ip4($dhcpreq);
						} elsif ($messagetype eq DHCPREQUEST()) {
								$self->$request_ip4($dhcpreq);
						} elsif ($messagetype eq DHCPINFORM()) {
							$self->$logger("Not implemented: DHCPINFORM", WARNING);
						} elsif ($messagetype eq DHCPRELEASE()) {
								$self->$release_ip4($dhcpreq);
						} else {
							$self->$logger("Packet dropped", WARNING);
							# bad messagetype, we drop it
						}
					} else {
						# Receive ipv6 packet
						my $myaddr = $self->{_sock_in_ip6}->sockhost;

						$fromaddr = $self->{_sock_in_ip6}->recv($buf, 4096)
							|| $self->$logger("recv: $!", ERROR);
						next if ($!);	# continue loop if an error occured
						$self->{_transaction_ip6}++;	# transaction counter
						$self->$logger("recv: $buf", INFO);
						{
							use bytes;
							my ($port,$addr) = unpack_sockaddr_in6($fromaddr);
							my $ipaddr = inet_ntop(AF_INET6, $addr);
							$self->$logger("Got a packet tr=$self->{_transaction_ip6} src=$ipaddr:$port length=".length($buf), INFO);
						}
						$self->$excuse_me_ip6($myaddr, $buf);
					}
				}
			}
		};	# end of 'eval' blocks
		if ($@) {
			$self->$logger("Caught error in main loop: $@", ERROR);
		}
	}
	$self->{_sock_in_ip4}->close;
	$self->{_sock_in_ip6}->close;
	$self->$logger("Exiting dhcpd", INFO);
}

1;