#!/usr/bin/perl -Tw
#
# A DNS server for pre-authentication wireless users
#
# rdr them to this server with NAT until they authenticate
#
# This server will answer with an authoritative A record for the
# wireless gateway, and respond with 'unsupported' for other lookup
# attempts.
#
# Copyright 1998, 1999, 2000 by an obvious alias,
# "Pink Plague Dog" <ppdog@localmx.com>
# All rights reserved.
# Copyright 2001 River of Stars, LLC
# Copyright 2001 University Corporation for Atmospheric Research
#
# Automatic licensing for this software is available.  This software
# can be copied and used under the terms of the GNU Public License,
# version 1 or (at your option) any later version, or under the
# terms of the Artistic license.  Both of these can be found with
# the Perl distribution, which this software is intended to augment.
#
# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
BEGIN {
    push(@INC, '/usr/local/libexec/authhb');
    $ENV{PATH} = '/usr/bin:/bin';
}

my $DEBUG = 0;	# how verbose is our debug logging?
				# 0 => all to syslog, all but debug level to stderr
				# 1 => all to syslog, debug also to stderr
				# 2 => even the packet dumps to syslog & stderr
my $VERSION = "0.0.1";

require 5.002;	# Simply haven't tested it with anything earlier than 5.002
use strict;
use Socket;
#use Carp;
use Net::DNS;	# See <http://www.fuhr.org/~mfuhr/perldns/>, <http://www.engelschall.com/ar/perldoc/pages/module/Net::DNS.html>
use Getopt::Std;
use Sys::Hostname;
use Sys::Syslog;
use hbu;


# function forward declarations, for clarity
# network control functions
sub init_net;				# bind up sockets for listening and responding
sub send_response;			# send a response packet to the source addr
# operations functions
sub spawner;				# fork to process queries received, if response needed
sub process_query;			# generate an answer to the query
sub make_response_authoritative;	# set header flags to indicate a normal authoritative response
#sub build_recursive_response;	# look up real info elswhere and put it in our response
sub make_response_unsupported;	# set header flags to indicate authoritative "no answer"
sub add_address_rrs;		# add A RRs to response
# utility functions
sub log_message;			# spit diagnostics and status to stderr or syslog


# set constants
my $PROTO = getprotobyname ('udp');
# dns packet size is 512 bytes
#$PACKETSZ = 1024;
my $PACKETSZ = 512;	# not enforced -- need to enforce -- need to enforce
my $TTL = 120;	# default TTL (in seconds) for records

# errors
my $NOERR = 1;
my $ERR_BOGUSPACKET = 2;
my $ERR_ALREADYANSWER = 3;
my $ERR_NOQUERY = 4;
my $ERR_NORESP = 5;
my $ERR_UNSUPP = 6;
my $ERR_MISSINGMX = 7;
my $ERR_MISSINGA = 8;

# declarations for command line options
use vars qw($opt_l $opt_s $opt_a $opt_n $opt_g);		# getopt::std stuff
my ($listenaddr, $listenport, $sendaddr, $sendport);	# IP address and port options
my ($arec, $aname);		# A record options
my $syslogyes;	# syslog or print to STDERR?

# defaults for command line options
#$listenaddr = INADDR_ANY;
$listenaddr = gethostbyname(hostname());
$sendaddr = gethostbyname(hostname());
#$listenport = getservbyname('domain', 'udp');
$listenport = 50053;
$sendport = $listenport;
$arec = '300 IN A 127.0.0.1';
$aname = 'wireless';
$syslogyes = 0;

# process command line options
getopts('l:s:a:n:g');
# SYSLOG OR NOT?
if ($opt_g) {
	$syslogyes = 1;
	log_message('debug', "Will use syslog");
	openlog('authhb-dns', 'pid', 'local6');		# set specialized options for syslog
}
# LISTEN ADDRESS
if ( $opt_l ) {
	if ($opt_l =~ m/^([\d\.]+):(\d+)$/) {
		$listenaddr = ip4v($1) or die "Improper listening IP address: $1";
		$listenport = $2;
		if ( ($listenport < 1) or ($listenport > 65535) ) {
			die "listen port out of range: $listenport";
		}
	} elsif ($opt_l =~ m/^([\d\.]+)$/) {
		$listenaddr = ip4v($1) or die "Improper listening IP address: $1";
	} else {
		die "Improper listening IP address: $opt_l";
	}
	$listenaddr = inet_aton($listenaddr);
}
# SEND ADDRESS
if ( $opt_s ) {
	if ($opt_s =~ m/^([\d\.]+):(\d{1,5})$/) {
		$sendaddr = ip4v($1) or die "Improper sending IP address: $1";
		$sendport = $2;
		if ( ($sendport < 1) or ($sendport > 65535) ) {
			die "send port out of range: $sendport";
		}
	} elsif ($opt_s =~ m/^([\d\.]+)$/) {
		$sendaddr = ip4v($1) or die "Improper sending IP address: $1";
	} else {
		die "Improper sending IP address: $opt_l";
	}
	$sendaddr = inet_aton($sendaddr);
}
# IP FOR THE A RECORD
if ($opt_a) {
	$arec = ip4v($opt_a) or die "Improper IP address for A record: $opt_a";
	$arec = join(' ', $TTL, 'A', $arec);
}
log_message('debug', "Will return A record: $arec");
# THE NAME THAT RESOLVES TO OUR A RECORD
if ($opt_n) {
	if ($opt_n =~ m/^([a-z\.\*-]+)$/) {
		$aname = $1;
	} else {
		die "Improper hostname for A record: $opt_n";
	}
}
log_message('debug', "Will answer A record requests beginning with: $aname");

# fire up our network listener
init_net();

# signal handling defaults
my $waitedpid = 0;
sub REAPER {
	# sanctify the children's graves so they don't turn into zombies
	$waitedpid = wait;
	$SIG{CHLD} = \&REAPER;	# workaround
	if ($DEBUG > 1) {
		log_message ('debug', "reaped $waitedpid" . ($? ? " with exit $?" : ""));
	}
}
$SIG{CHLD} = \&REAPER;

# declarations for network communications
my ($packet, @question, $query, $qtype);	# DNS query and response packet
my ($rin, $rout, $nfound, $buffer);	# select() & recv() buffers, counters
my ($rempaddr, $remport, $remiaddr);	# remote query source address

# listen forever
until ( 0 ) {

	sleep 1;
	
	$rin=""; 
	vec ($rin, fileno(RECV), 1) = 1;

	$nfound = select($rout=$rin, undef, undef, undef);
	if ( $nfound > 0 ) {
		undef $buffer;
		if ( $rempaddr = recv(RECV, $buffer, $PACKETSZ, 0) ) {
			# who is calling?
			($remport, $remiaddr) = unpack_sockaddr_in($rempaddr);
			spawner();
		} else {
			log_message('warn', "$nfound waiting but recv: $!");
		}
	}
}

closelog();

exit 0;


################################################################################
# 
# network control functions

sub init_net {
	if ($DEBUG > 1) {
	 	log_message ('debug', "trying to listen on " . 
					  inet_ntoa($listenaddr) . ":$listenport");
	}
	if ( ! (socket (RECV, AF_INET, SOCK_DGRAM, $PROTO)) ) {
			log_message ('err', "receiving socket: $!");
			exit 1;
	}
	if ( ! (setsockopt (RECV, SOL_SOCKET, SO_REUSEADDR, 1)) ) {
			log_message ('err', "receiving setsockopt: $!");
			exit 1;
	}
	if ( ! (bind (RECV, pack_sockaddr_in ($listenport, $listenaddr))) ) {
			log_message ('err', "receiving bind: $!");
			exit 1;
	}
	
	# fire up our network responder as well, if different from our network listener
	if ( ($sendport == $listenport) and ($sendaddr eq $listenaddr) ) {
		log_message ('info', "server version " . $VERSION
			. " listening and sending on IP " . inet_ntoa($listenaddr)
			. ":" . $listenport);
	} else {
		log_message ('debug', "trying to send from " . 
					  inet_ntoa($sendaddr) . ":$sendport");
		if ( ! (socket (SEND, AF_INET, SOCK_DGRAM, $PROTO)) ) {
			log_message ('err', "sending socket: $!");
			exit 1;
		}
		if ( ! (setsockopt (SEND, SOL_SOCKET, SO_REUSEADDR, 1)) ) {
			log_message ('err', "sending setsockopt: $!");
			exit 1;
		}
		if ( ! (bind (SEND, pack_sockaddr_in ($sendport, $sendaddr))) ) {
			log_message ('err', "sending bind: $!");
			exit 1;
		}
		log_message ('info', "server version " . $VERSION . " listening on IP "
			. inet_ntoa($listenaddr) . ":" . $listenport);
		log_message ('info', "server version " . $VERSION . " sending from IP "
			. inet_ntoa($sendaddr) . ":" . $sendport);
	}
	return 1;
}

sub send_response {
	# spit response packet
	if ( ($sendport == $listenport) and ($sendaddr eq $listenaddr) ) {
	defined (send (RECV, $packet->data, 0, $rempaddr)) or
		log_message ('err', "Cannot send to " . inet_ntoa($remiaddr) . ": $!");
	} else {
	defined (send (SEND, $packet->data, 0, $rempaddr)) or
		log_message ('err', "Cannot send to " . inet_ntoa($remiaddr) . ": $!");
	}
}

################################################################################
# 
# operations functions

sub spawner {
	my $pid;
	my $res = 0;

	if ( ! defined ($pid = fork) ) {
		log_message ('warn', "ignoring request - cannot fork: $!");
		return;
	} elsif ($pid) {	# we are the parent
		if ($DEBUG > 1) {
			log_message ('debug', "forked and begat $pid");
		}
		return;
	} else	{	# we are the child
		# make some childlike signal handling changes
		$SIG{HUP} = sub {
			log_message ('warn', "child quitting on HUP signal");
			exit 1;
		};

		# parse DNS packet, do lookups, and answer the question
		$res = process_query();
		if ( $res == $NOERR ) {
			# we have an answer for them
			if ( $DEBUG > 1 ) {
				log_message ('debug', "response packet: \n" . $packet->string . "\n");
			}
			send_response();
		} elsif ( $res == $ERR_UNSUPP ) {
			# tell them to go away
			if ( $DEBUG > 1 ) {
				log_message ('debug', "response packet: \n" . $packet->string . "\n");
			}
			send_response();
		} elsif ( $res == $ERR_NOQUERY ) {
			# we have a response to their lack of query, for now
			if ( $DEBUG > 1 ) {
				log_message ('debug', "response packet: \n" . $packet->string . "\n");
			}
			send_response();
		} elsif ( $res == $ERR_ALREADYANSWER ) {
			# they are telling us something, which we will ignore
			# as bullshit
		} elsif ( $res == $ERR_NORESP ) {
			# we were unable or chose not to produce a response
			# drop the matter without responding
		} elsif ( $res == $ERR_MISSINGMX ) {
			# we scrood up
			# drop the matter without responding
		} else {
			# something bad happened
			# drop the matter without responding, and note the problem
			if (!defined($res)) {
				$res = 'UNDEF';
			}
			log_message ('err', "unexpected error producing response to query: $res");
		}
		exit; # exit child process
	}
}

sub process_query {

	# rip into the received dns packet and process a single query, if one
	# is found at all
	
	my $res = 0;	# error response code
	my $ignerr;	# for sanity if we want to ignore an error
	my (@answered, $answer);

	# rip apart the packet and die immediately if it didn't work
#	($packet, $res) = new Net::DNS::Packet(\$buffer, $DEBUG);
	($packet, $res) = new Net::DNS::Packet(\$buffer);
	if ( $res ) {
		log_message ('err', "DNS packet decode problem: $res");
		return $ERR_BOGUSPACKET;
	}
	if ( $DEBUG > 1 ) {
		log_message ('debug', "supposed query packet: \n" . $packet->string . "\n");
	}

	# try to pull off the query
	@question = $packet->question;
	$query = shift @question;	# no-one sane sends more than one query per packet anyway

	# did we actually receive a query?
	if (defined($query) && $query) {
		if ( $DEBUG > 1 ) {
			log_message ('debug', "parsed DNS query - qname: " . $query->qname
				. ", qtype: " . $query->qtype . ", qclass: " . $query->qclass);
		}

		# is the query already answered?
		@answered = $packet->answer;
		$answer = shift @answered;
		if ($answer) {
			# this is already an answer to a previous query
			log_message ('info', "packet from " . inet_ntoa($remiaddr) .
						 " already has answer: " .
						 $query->qclass . " " . $query->qtype . " " .
						 $query->qname);
			return $ERR_ALREADYANSWER;
		} elsif ( !(($query->qclass eq "IN") or ($query->qclass eq "ANY")) ) {
			# it's not class "IN" or "ANY"
			$ignerr = make_response_unsupported();
			log_message ('notice', "unsupported query class by " .
						 inet_ntoa($remiaddr) . ": " .
						 $query->qclass .  " " . $query->qtype .
						 " " . $query->qname);
			return $ERR_UNSUPP;
		} elsif (($query->qtype eq "A") or ($query->qtype eq "ANY")) {
			# the q source wants an A record
			if (($query->qname =~ m/^$aname/) or ($query->qname =~ m/^www\.$aname/)) {
				# and it's our A record they want, or close enough
				log_message ('info', "answering to ".
							 inet_ntoa($remiaddr) . ": " .
							 $query->qclass . " " . $query->qtype .
							 " " . $query->qname);
				$res = add_address_rrs();
				return $res;
			} else {
				# it's something else unallowed they want
				log_message ('notice', "unsupported query name by ".
							 inet_ntoa($remiaddr) . ": " .
							 $query->qclass . " " . $query->qtype .
							 " " . $query->qname);
				$res = make_response_unsupported();
				return $res;
			}
#		} elsif ( recurse_P() ) {
#			# the q source is due an answer we pull from a real nameserver elsewhere
#			# (recurse)
#			log_message ('debug', "recursively answering to ". inet_ntoa($remiaddr)
#				. " for " . $query->qname);
#			$res = build_recursive_response();
		} else {
			# we were handed a q for something we don't know how to handle
			log_message ('notice', "unsupported query type by ".
						 inet_ntoa($remiaddr) . ": " .
						 $query->qclass . " " . $query->qtype .
						 " " . $query->qname);
			$res = make_response_unsupported();
			return $res;
		}
	} else { # the packet had no query
		# hsm, we don't know what the heck we were asked to do, but it
		# sure wasn't answer a question
		# for now we will build a 'go-away' response packet, rather than
		# dropping the matter silently
		# (this may be an inappropriate way to handle misdirected update
		# packets, and the like, but it will have to do for the present)
		$ignerr = make_response_unsupported();
		log_message ('warn', "packet without query from " . inet_ntoa($remiaddr));
		return $ERR_UNSUPP;
	}
#	return $res;
}

sub make_response_authoritative {

	# just your basic authoritative response boilerplate

	$packet->header->qr(1);	# this is a query response
	$packet->header->aa(1);	# authoritative answer
	$packet->header->ra(0);	# recursion not available
	$packet->header->rd(0);	# recursion no longer desired

	# what happens if any of the above methods fail?  tired, worry about it later

	return $NOERR;
}

sub make_response_unsupported {

	# build a response that says "we don't do that here, go away"

	my $res = 0;

	$res = make_response_authoritative();
	$packet->header->rcode("FORMERR");	# we will never have an answer
	# still need to check for errors after method invocation?

	return $res;
}

sub add_address_rrs {

	# select the As to report according to the config, and
	# cram them into the query response

	my $res = 0;
	my $rr;
	
	$res = make_response_authoritative();
	if ( $res == $NOERR ) {
		$rr = join (' ', $query->qname, $arec);
		$packet->push("answer", rr_add($rr));
		# still need to check for errors after push?
		$packet->header->rcode("NOERROR");	# alles ist gut
		# still need to check for errors after method invocation?
	}
	return $res;
}

#sub build_recursive_response {
#
#	# recursively look up domains we're supposed to answer for, and
#	# for which we want to return real data
#
#	# we ignore the query's "recursion desired" flag, since it is likely
#	# that localmx is the only authoritative nameserver reachable by the
#	# query originator, and do the lookup ourselves
#
#	log_message ('err', "recursion requested but recursion code not yet written");
#	return $ERR_NORESP;
#}

################################################################################
# 
# utility functions

sub log_message {
	my ($priority, $message) = @_;
	
	if ($syslogyes) {
		syslog ($priority, '%s', $message);
	} else {
		if ( $DEBUG or ($priority ne 'debug') ) {
			print STDERR scalar localtime, " $0 [$$] $priority: $message\n";
		}
	}
	return 1;
}