package PVE::DHCPServer;

use strict;
use warnings;
use Carp qw(croak);
use Sys::Hostname;
use Socket;
use Socket6;
use Net::DHCP::Packet;
use Net::DHCP::Constants;
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 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);

our @EXPORT_OK = (
	'DEBUG',
	'INFO',
	'NOTICE',
	'WARNING',
	'ERROR',
	'CRITICAL',
	'ALERT',
	'EMERGENCY'
);

our %EXPORT_TAGS = ( constants => [
	'DEBUG',
	'INFO',
	'NOTICE',
	'WARNING',
	'ERROR',
	'CRITICAL',
	'ALERT',
	'EMERGENCY'
]);

our $VERSION = '0.01';
our $NAME = 'PVE::DHCPServer';
my $time_to_die = 0;

# 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->{_transaction_ip4} = 0;
	$self->{_transaction_ip6} = 0;

	# public
	$self->{log_file}		||= 'syslog';
    $self->{lease_time}		||= 7200;
    $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;
	$self->{NODAEMON}		||= 0;
	$self->{DEBUG}			||= 0;
	$self->{timeout}		||= 10;
	$self->{lease_file}		||= '/tmp/dhcpd.leases';

    return $self;
}

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

	$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);
	}

	my $res = $self->read_lease_file();
	do {
		$self->logger("Couldn't read leases file '$self->{lease_file}'", ERROR);
		die "Couldn't read leases file '$self->{lease_file}'";
	} unless $res;

	$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);
						}


						my $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 $ipaddr;

						$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);
							$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($ipaddr, $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);
}

sub run_with_timeout {
    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;
}

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

	my $mode = $shared ? LOCK_SH : LOCK_EX;

	my $lock_func = sub {
		if ($mode == LOCK_SH) {
			$self->{file_handle} = new IO::File ("<$self->{lease_file}") ||
                die "can't open file for read - $!";
		} else {
			$self->{file_handle} = new IO::File (">$self->{lease_file}") ||
                die "can't open file write - $!";
		}
        $self->logger("trying to aquire lock on '$self->{lease_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 '$self->{lease_file}' - $@", ERROR);
		$self->{file_handle} = undef;
		return undef;
    }

    return $res;
}

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

	return '' unless($self->{file_handle});
	my $unlock_func = sub {
        $self->logger("trying to unlock '$self->{lease_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 '$self->{lease_file}' - $@", ERROR);
		$self->{file_handle} = undef;
		$res = undef;
    }

    return $res;
}

sub convert_timestamp {
	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: 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{
		if ($timestamp !~ /^\d+$/) {
			$self->logger("$timestamp: 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;
}


sub add_lease {
	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->{_reverse}->{$mac} = $ip;
	$self->logger("$mac =>\n" . Dumper($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"
#}
sub read_lease_file {
	my ($self) = @_;
	my ($res, $key, $lease);
	my $error = 0;

	$self->lock(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*$/);
				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();
		$res = 1;
	} else {
		$self->logger("Could not read leases file", ERROR);
		$res = 0;
	}

	return $res;
}

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

	$res = $self->lock(0);
	if ($self->{file_handle}) {
		my $fh = $self->{file_handle};
		while ((my $lease, my $elems) = each $self->{_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();
		$res = 1;
	} else {
		$self->logger("Could not write leases file", ERROR);
		$res = 0;
	}

	return $res;
}

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

	$level = DEBUG unless ($level);
	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\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;
	}
}

sub add_options {
	my ($self, $dhcpresp) = @_;

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

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

	# 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";
	};

	$req_addr = $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS());
	$req_addr = '' unless $req_addr;
	$self->logger("Requested IP: $req_addr", INFO);

	$res = $self->read_lease_file();
	$res = $self->write_lease_file();
	if ($res && ($req_addr =~ /^$/ || $calc_ip eq $req_addr)) {
		$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($dhcpresp);
	} 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";
}

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

	$calc_ip = "192.168.9.2";

	$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";
	};

	# compare calculated address with requested address
	if ($calc_ip eq $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS())) {
		# 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($dhcpresp);
		$result = 'ACK';
	} else {
		# bad request, we send a NAK
		$self->write_lease_file();
		$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";
}

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

	$self->logger($dhcpreq->toString());
	$self->write_lease_file();
}

sub excuse_me_ip6 {
	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";
}

1;