#!/usr/bin/perl -wT
# A simple dynamic DNS application.
# 

use Socket;
use FileHandle;
use strict;

BEGIN { $ENV{PATH} = "/bin:/usr/bin:/usr/local/bin" }

sub logmsg {
	my $message = join "\t", @_;
	print STDERR scalar localtime, ":$$: ", $message, "\n";
}

# Make sure a hostname ends with a .
sub absolutize { $_[0] .= "." unless $_[0] =~ /\.$/; }

sub readconfig {
	my ($filename) = @_;
	open CONFIG, $filename or die "Can't open $filename: $!";
	my %setup = (
		port => 5353,
		dbfile => "hosts.dyn.db",
		ownerfile => "hosts.dyn.auth",
		passfile => "hosts.dyn.pass",
		statefile => "hosts.dyn.state",
	);
	local $_;
	while (<CONFIG>) {
		s/^\s+//;
		next if /^#/;
		chomp;
		my ($command, $argstring);
		if (/(.*)\s+(.*)/) {
			($command, $argstring) = ($1, $2);
		} else {
			($command, $argstring) = ($_, "");
		}

		$setup{$command} = $argstring;  # Beautiful simplicity ;)
	}
	close CONFIG;
	if (not exists $setup{origin}) {
		$setup{origin} = `/bin/uname -n`;
		chomp $setup{origin};
	}
	if (not exists $setup{nameserver}) {
		$setup{nameserver} = $setup{origin};
	}
	if (not exists $setup{person}) {
		$setup{person} = "postmaster.$setup{origin}";
	}
	$setup{person} =~ s/\@/./;
	absolutize $setup{origin};
	absolutize $setup{nameserver};
	absolutize $setup{person};
	return %setup;
}

if ($#ARGV != 0) {
	print <<usage_end;
Usage:
$0 setupfile
setupfile contains comment lines beginning with # and name-value pairs.  The
	name is terminated by the first whitespace character; the value is
	begun by the next non-whitespace character.
Names include:
port -- the port to listen on, default 5353.
dbfile -- the name of the file to write for the benefit of named, default
	hosts.dyn.db.
ownerfile -- the name of the file that lists the owner of each hostname,
	default hosts.dyn.auth.
passfile -- the name of the file that lists the password of each owner, default
	hosts.dyn.pass.
statefile -- the name of the file in which to checkpoint state information
	so that if the server is shut down and restarted no info will be lost.
	default is hosts.dyn.state.
origin -- the name of the host on which this server runs, default `hostname`.
person -- the email of the person who should be emailed if something is wrong
	with the data, default postmaster.origin.
	You can use an @ if you like; it will get changed to a ., as it should
	be.
	You can also forget the . on the end.
nameserver -- the name of the (single? fix this later) nameserver for the
	domain.

Um, and that's it, for now.
usage_end
	exit 1;
}

my %setup = readconfig $ARGV[0];


sub setupserver {
	my ($setupref) = @_;
	my $port = $setupref->{port};
	my $proto = getprotobyname('tcp');
	socket(Server, PF_INET, SOCK_STREAM, $proto)   || die "socket: $!";
	setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
                                    pack("l", 1))      || die "setsockopt: $!";
	bind(Server, sockaddr_in($port, INADDR_ANY))   || die "bind: $!";
	listen(Server,SOMAXCONN)                       || die "listen: $!";

	logmsg "server started on port $port";
}

sub acceptconn { 
	my @x = accept (CLIENT_SOCKET, Server); 
	autoflush CLIENT_SOCKET 1; 
	return @x;
}

# This function authenticates that someone is who they say they are
sub client_auth_ok { 
	my ($name, $auth, $passwords) = @_;
	if ($auth->[0] eq $passwords->{$name}) {
		return "valid";
	} else {
		return 0;
	}
}

# This function returns whether someone owns a particular host.
sub client_priv_ok { 
	my ($name, $host, $hostsref) = @_;
	return (exists $hostsref->{$host} and $hostsref->{$host} eq $name) ;
}

# This function returns whether or not a proposed A record is valid.
sub A_ok {
	my ($addr) = @_;
	if ($addr =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
		my @numbers = ($1, $2, $3, $4);
		my $number;
		foreach $number (@numbers) {
			return undef if $number > 255;
		}
		return "OK";
	} else {
		return undef;
	}
}

# This function returns whether or not a proposed domain name is valid.
sub name_ok {
	my ($name) = @_;
	absolutize $name;
	local $_;
	my $maxnamelen = 254;    # RFC-1034, line 420
	my $maxlabellen = 63;
	if (length $name > $maxnamelen) { return undef; }
	my @labels = split /\./, $name;
	for (@labels) {
		if (length > $maxlabellen) { return undef; }
		if (not /^[A-Za-z]/) { return undef; }  # rfc-1034, line 598
		if (not /[A-Za-z0-9]$/) { return undef; } # same line
		if (/[^-A-Za-z0-9]/) { return undef; } # line 599
	}
	return undef if $name =~ /\.\./;  # rfc-1034, lines 364-365
	return "OK";
}


# This takes a command from an authenticated client and processes it
# Returns a reply to send to the client.
sub process_cmd { 
	logmsg "command:", @_; 
	my ($state, $host, $cmd) = @_;
	my ($cmdname, @cmdargs) = split /\s+/, $cmd;
	if ($cmdname eq "A") {
		if (A_ok $cmdargs[0]) {
			$state->{$host}->{A} = $cmdargs[0];
			return "OK IP of $host set to $cmdargs[0]\n";
		} else {
			return "bad IP $cmdargs[0]\n";
		}
	} elsif ($cmdname eq "CNAME") {
		my $hostname = $cmdargs[0];
		# This is on the assumption that people will very rarely want
		# to alias to another host in the dynamic domain.
		absolutize $hostname;
		if (name_ok $hostname) {
			$state->{$host}->{CNAME} = $hostname;
			return "OK CNAME of $host set to $hostname\n";
		} else {
			return "bad CNAME $hostname\n";
		}
	} elsif ($cmdname eq "CLEAR") {
		$state->{$host} = {};
		return "OK CLEARed $host\n";
	} else {
		return "bad boy!  don't understand $cmdname\n";
		logmsg "unknown command", $cmdname;
	}
}

# This takes a domain and a host-state database and writes it to a file.
sub writedbfile {
	my ($setup, $database) = @_;
	my $dbfile = $setup->{dbfile};
	my $tempfile = "$dbfile.tmp.$$";
	open DBFILE, ">$tempfile" or do {
		logmsg "Cannot open $tempfile for write";
		return;  # fooey
	};
	print DBFILE "; Autogenerated ", scalar localtime, "\n";
	print DBFILE <<SOA_end;
;
; DNS data file, from version Toy-3 of Kragen's dynamic DNS server
; 'relocatable', in that everything is relative to the specified origin.
;

\@ IN SOA $setup->{origin} $setup->{person} (
		69	; serial number is currently not kept track of
		0	; secondaries not supported; see above
		0	; retry; same
		0	; same
		0	; TTL of zero; do not cache!
		)
   IN NS $setup->{nameserver}

;
; Dynamic host entries follow
;
SOA_end
	local $_;
	my $record;
	my $attribute;
	for (sort keys %$database) {
		$record = $database->{$_};
		for $attribute (sort keys %$record) {
			$attribute eq "A" and do {
				print DBFILE "$_ IN A $record->{A}\n";
				next;
			};
			$attribute eq "CNAME" and do {
				print DBFILE "$_ IN CNAME $record->{CNAME}\n";
				next;
			};
			logmsg "Weird attribute $attribute on $_";
		}
	}

	close DBFILE;
	rename ($tempfile,$dbfile) or logmsg "Can't rename", $tempfile, $dbfile;
	return;
}

# This tells the nameserver to reread the file.
sub sighup_named {
	autoflush STDOUT 1;
	print STDOUT "Please restart the nameserver\n";
}


# Read a mapping of names to values from a file
# A copy of this code exists in the client code too
sub readmapfile {
	my @xxx;
	my ($filename) = @_;
	my @rv = ();
	open MAP, $filename or die "can't open $filename: $!";
	local $_;
	while (<MAP>) {
		s/#.*//;
		next if /^\s*$/;

		@xxx = split;
		if (@xxx == 2) {
			push @rv, $xxx[0] => $xxx[1];
		} elsif (@xxx == 0) {
			next;
		} else {
			warn "Can't understand $_\n";
		}
	}
	close MAP;
	return @rv;
}

# Read a checkpoint file, if it exists.
sub readstatefile {
	my @xxx;
	my ($filename) = @_;
	my %rv = ();
	return %rv if ( ! -f $filename);
	open STATEFILE, $filename or do {
		logmsg "Can't open statefile", $filename;
		return %rv;
	};
	local $_;
	while (<STATEFILE>) {
		chomp;
		@xxx = split;

		if (@xxx == 3) {
			$rv{$xxx[0]}->{$xxx[1]} = $xxx[2];
		} else {
			logmsg "Can't understand in statefile", $_;
		}
	}
	close STATEFILE;
	return %rv;
}

sub writestatefile {
	my ($setup, $state) = @_;
	my $statefile = $setup->{statefile};
	my $tempfile = "$statefile.tmp.$$";
	open STATEFILE, ">$tempfile" or do {
		logmsg "Can't open statefile $tempfile for write";
		return;  # shoot
	};
	my ($host, $attribute);
	foreach $host (keys %$state) {
		foreach $attribute (keys %{$state->{$host}}) {
			print STATEFILE "$host $attribute $state->{$host}->{$attribute}\n";
		}
	}
	close STATEFILE;
	rename ($tempfile,$statefile) 
		or logmsg "Can't rename statefile", $tempfile, $statefile;
}

sub talk_to_client {
	my ($hosts, $state, $passwords) = @_; # hash references
	# too IP-spoofable; should revise protocol
	my $workdone = undef;
	print CLIENT_SOCKET "Kragen Toy-3 dynamic DNS server\n";
	my $client_ver = <CLIENT_SOCKET>;
	if ($client_ver =~ "^Kragen Toy-3 dynamic DNS client\r?\n") {
		print CLIENT_SOCKET "OK\n";
	} else {
		print CLIENT_SOCKET "Server bad version\n";
		close CLIENT_SOCKET;
		return 0;
	}
	my $client_host = <CLIENT_SOCKET>;
	chomp $client_host;
	my $client_name = <CLIENT_SOCKET>;
	chomp $client_name;
	my @client_auth = ();
	my $ca;
	for (;;) {
		$ca = <CLIENT_SOCKET>;
		if ($ca =~ /^>(.*)/) {
			push @client_auth, $1;
		} else {
			# discard line; let it be blank
			last;
		}
	}
	if (client_auth_ok ($client_name, \@client_auth, $passwords) 
		and client_priv_ok ($client_name, $client_host, $hosts)) {
			print CLIENT_SOCKET "Auth OK\n";
			my $cmd;
			while ($cmd = <CLIENT_SOCKET>) {
				my $return = 
					process_cmd $state, $client_host, $cmd;
				print CLIENT_SOCKET $return;
				if ($return =~ /^OK/) { $workdone = "yes"; }
			}
	} else {
		logmsg "auth failed ", $client_host, $client_name, @client_auth;
		print CLIENT_SOCKET "Auth not valid\n";
		return 0;
	}
	return $workdone;
}

# hosts and owners
my %hosts = readmapfile $setup{ownerfile};
# Maps hostnames to their states
my %state = readstatefile $setup{statefile};
# Maps people to their (currently plaintext) passwords
my %passwords = readmapfile $setup{passfile};

setupserver \%setup;

while (acceptconn) {
	talk_to_client \%hosts, \%state, \%passwords and do {
		writestatefile \%setup, \%state;
		writedbfile \%setup, \%state;
		sighup_named;
	};
	close CLIENT_SOCKET;
}


