#!/usr/bin/perl -w
#
# dnsdhcpgen -- make dns zone files and dhcpd configuration files
#
# $Version: etc/namedb/dnsdhcpgen,v 1.7 2001/09/25 21:35:20 fanf Exp $
#

use strict;
use Getopt::Long;                                                               
use IO::File;

my %option;
Getopt::Long::Configure 'bundling';
GetOptions (\%option, "test|t!", "verbose|v!")
    and @ARGV == 1
    or die "usage: dnsdhcpgen [-tv] configfile\n",
           "\t-t\tgenerate test files\n",
           "\t-v\tverbose\n";

$option{verbose} = 1 if $option{test};                                          

my $infile = $ARGV[0];
my $linenum = 0;

#
# Data structures
#
                    # each element is:
use vars '@zone';   #  { name =>, soa => $name, ns => [] }
use vars '@router'; #  IP address
use vars '@named';  #  IP address
use vars '@dhcpd';  #  IP address
use vars '@dhcp';   #  { min =>, max =>, zone => }
use vars '@net';    #  { base =>, len =>, mask =>, name =>, soa =>, ns => [] }
use vars '@host';   #  { name =>, ip =>, ether =>, aliases => [] }
use vars '@rr';     #  { name =>, type =>, data => }

my %soa;            # {refresh =>, retry =>, expire =>, minimum => }

$soa{serial} = time;

#
# A few random things
#

sub untab ($$) {
	my $count = shift;
	my $string = shift;
	$string =~ s/^\t{$count}//mg;
	return $string;
}

my $output;
sub say (@) { $output->print(@_,"\n"); }

#
# Functions for reporting things to the user
#

sub report ($) {
	my $message = shift;
	warn "$0: $infile:$linenum: $message\n";
	return undef;
}

sub debug ($) {
	my $message = shift;
	report "debug: $message" if $option{verbose};
}

sub gripe ($) {
	my $message = shift;
	if ($option{verbose}) {
		report "error: $message";
	} else {
		report $message;
	}
}

sub show ($) {
	my $it = shift;
	if (ref $it eq "HASH") {
		return join " ", "{",
			(map { "$_=" . show($it->{$_}) } sort keys %$it), "}";
	} elsif (ref $it eq "ARRAY") {
		return join " ", "[", (map { show($_) } @$it), "]";
	} elsif (ref $it eq "SCALAR") {
		return show($$it);
	} elsif (defined $it) {
		return $it;
	} else {
		return "";
	}
}

#
# Functions for manipulating addresses
#

sub octets ($) {
	my $addr = shift;
	return split /\./, $addr;
}

sub unoctets (@) {
	return join '.', @_;
}

sub intaddr ($) {
	return unpack "N", pack "CCCC", octets shift;
}

sub addrint ($) {
	return unoctets unpack "CCCC", pack "N", shift;
}

sub netmask ($) {
	my $len = shift;
	my @mask;
	for my $i (0..3) {
		$mask[$i] = ($len > 7) ? 255
			: [0, 1, 3, 7, 15, 31, 63, 127]->[$len];
		$len -= 8;
	}
	return unoctets @mask;
}

sub broadcast ($) {
	my $net = shift;
	my $ibase = intaddr $net->{base};
	my $imask = intaddr $net->{mask};
	return addrint $ibase + ~$imask;
}

sub mask ($$) {
	my $mask = intaddr shift;
	my $addr = intaddr shift;
	return addrint ($addr & $mask);
}

sub in_net ($$) {
	my $net = shift;
	my $addr = shift;
	return $net->{base} eq mask $net->{mask}, $addr;
}

sub ip_range ($$) {
	my $min = "0" . intaddr shift;
	my $max = "0" . intaddr shift;
	return map { addrint $_ } $min .. $max;
}

sub ipdns ($) {
	my $addr = shift;
	my @addr = reverse octets $addr;
	return join '.', @addr, "in-addr.arpa";
}

sub net_zone ($) {
	my $net = shift;
	my $len = $net->{len};
	die "bad net zone prefix length for $net->{base}: $len"
		if $len < 24 && $len % 8 != 0;
	my $octets = 4 - $len / 8;
	my $name = ipdns $net->{base};
	$net->{name} = substr $name, $octets * 2;
	return $net;
}

sub net_zones ($) {
	my $net = shift;
	my @base = octets $net->{base};
	my @mask = octets $net->{mask};
	my @nets;

	my $i = -1;
	return net_zone $net if $mask[$i] != 0;

	--$i while $mask[$i] == 0;
	return net_zone $net if $mask[$i] == 255;

	$mask[$i] = 255;
	my $mask = unoctets @mask;
	my $len = $net->{len} + 7 & ~7;

	for (;;) {
		my $base = unoctets @base;
		last unless in_net $net, $base;
		push @nets, net_zone { soa => $net->{soa}, ns => $net->{ns},
			base => $base, mask => $mask, len => $len };
		$base[$i]++;
	}

	return @nets;
}

sub in_zone ($$) {
	my $zone = shift;
	my $host = shift;
	my $val = $zone->{name} eq substr $host, rindex $host, $zone->{name}; 
#	print "in_zone $zone->{name} $host ", $val ? "yes\n" : "no\n";
	return $val;
}

sub zones_of ($) {
	my $host = shift;
	return sort { length $b->{name} <=> length $a->{name} }
		grep { in_zone $_, $host } @zone;
}

sub zone_of ($) {
	my $host = shift;
	my @zone = zones_of $host;
	return $zone[0] || "";
}

#
# Lexical syntax checking
#

sub is_hostname ($) {
	my $arg = shift;
	$arg =~ s/[^.]$/$&./;
	return undef unless $arg =~ /^([a-z0-9]([a-z0-9-]*[a-z0-9])?\.)+$/i;
	$arg =~ s/\.$//;
	return $arg;
}

sub is_address ($) {
	my $arg = shift;
	return $arg =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
		&& $1 < 256 && $2 < 256 && $3 < 256 && $4 < 256
		? $arg : undef;
}

sub is_ether ($) {
	my $arg = shift;
	return $arg =~ /^([0-9a-fA-F]{1,2}:){5}[0-9a-fA-F]{1,2}$/
		? $arg : undef;
}

sub is_addrrange ($) {
	my $arg = shift;
	return $arg =~ /^([0-9.]+)-([0-9.]+)$/
		&& is_address $1 && is_address $2
		? { min => $1, max => $2 } : undef;
}

sub is_network ($) {
	my $arg = shift;
	return $arg =~ /^([0-9.]+)\/([0-9]+)$/
		&& is_address $1 && $2 < 33
		? { base => $1, len => $2, mask => netmask $2 } : undef;
}

sub is_rr_raw ($$) {
	my $types = shift;
	my $arg = shift;
	return $arg =~ /^($types)=(.*)$/i
		? { type => uc $1, data => $2 } : undef;
}

sub is_rr ($;$) {
	my $arg = $_[-1];
	my $types = (@_ == 2) ? $_[0]: "[A-Z]+";
	my $val = is_rr_raw $types, $arg;
	return $val && is_hostname $val->{data}
		? $val : undef;
}

sub is_rr_mx ($) {
	my $arg = shift;
	my $val = is_rr_raw "mx", $arg;
	return $val && $val->{data} =~ s/^([0-9]+),(.*)$/$1\t$2/
		&& is_hostname $2
		? $val : undef;
}


#
# Noisy versions of the above
#

sub check_hostname ($) {
	my $arg = shift;
	my $val = is_hostname $arg;
	return $val || gripe "malformed hostname: $arg";
}

sub check_address ($) {
	my $arg = shift;
	my $val = is_address $arg;
	return $val || gripe "malformed IP address: $arg";
}

sub check_ether ($) {
	my $arg = shift;
	my $val = is_ether $arg;
	return $val || gripe "malformed ethernet address: $arg";
}

sub check_addrrange ($) {
	my $arg = shift;
	my $val = is_addrrange $arg;
	return $val || gripe "malformed address range: $arg";
}

sub check_network ($) {
	my $arg = shift;
	my $val = is_network $arg;
	return $val || gripe "malformed network spec: $arg";
}

sub check_rr ($$) {
	my $type = shift;
	my $arg = shift;
	my $val = is_rr $type, $arg;
	return $val || gripe "malformed DNS $type RR spec: $arg";
}


#
# Statement syntax checking
#

sub check_dhcp (@) {
	my $zone = check_hostname shift or return;
	my $range = check_addrrange shift or return;
	my @zone = grep { $zone eq $_->{name} } @zone;
	return gripe "unknown zone: $zone" unless @zone == 1;
	$range->{zone} = $zone[0];
	return $range;
}

sub check_soa_ns ($@) {
	my $it = shift;
	my $soa = check_rr "soa", shift or return;
	my @ns = map { check_rr "ns", $_ or return } @_;
	$it->{soa} = $soa->{data};
	$it->{ns} = [map { $_->{data} } @ns];
	return $it;
}

sub check_net (@) {
	my $net = check_network shift or return;
	return check_soa_ns $net, @_;
}

sub check_zone (@) {
	my $name = check_hostname shift or return;
	return check_soa_ns { name => $name }, @_;
}

#
# Functions for adding information to the data structures
#

sub statement ($$$@) {
	my $check = shift;
	my $min = shift;
	my $max = shift;
	my $keyword = shift;
	return gripe "not enough args for $keyword statement"
		if @_ < $min;
	return gripe "too many args for $keyword statement"
		if $max && @_ > $max;
	my $it = $check->(@_);
	if ($it) {
		push @{$::{$keyword}}, $it;
		debug "$keyword " . show $it;
	}
}

sub router (@) { statement \&check_address,   1, 1, @_; }
sub named  (@) { statement \&check_address,   1, 1, @_; }
sub dhcpd  (@) { statement \&check_address,   1, 1, @_; }
sub dhcp   (@) { statement \&check_dhcp,      2, 2, @_; }
sub net    (@) { statement \&check_net,       2, 0, @_; }
sub zone   (@) { statement \&check_zone,      2, 0, @_; }

sub host (@) {
	my $name = check_hostname shift or return;
	my $ip;
	my $ether;
	my @aliases;
	for my $addr (@_) {
		my $val;
		if ($val = is_address $addr) {
			if (defined $ip) {
				gripe "extra IP address: $val";
			} else {
				$ip = $val;
			}
		} elsif ($val = is_ether $addr) {
			if (defined $ether) {
				gripe "extra ether address: $val";
			} else {
				$ether = $val;
			}
		} elsif ($val = is_hostname $addr) {
			push @aliases, $val;
		} elsif ($val = is_rr "ns", $addr
				or $val = is_rr_mx $addr) {
			$val->{name} = $name;
			push @rr, $val;
			debug "rr " . show $val;
		} else {
			gripe "malformed address: $addr";
		}
	}
	push @host, { name => $name, ip => $ip, ether => $ether,
			aliases => \@aliases };
	debug "host " . show $host[-1];
}

sub soa (@) {
	my $keyword = shift;
	for my $arg (@_) {
		unless ($arg =~ /^([a-z]+)=([a-z0-9]+)$/) {
			gripe "malformed soa argument: $arg";
			next;
		}
		my $param = $1;
		my $spec = $2;
		my $time = 0;
		if ($spec =~ /^[0-9]+$/) {
			$time = $spec;
		} elsif ($spec =~ /^(([0-9]+)w)?(([0-9]+)d)?
			(([0-9]+)h)?(([0-9]+)m)?(([0-9]+)s)?$/x) {
			$time += $2 * 60 * 60 * 24 * 7 if $2;
			$time += $4 * 60 * 60 * 24     if $4;
			$time += $6 * 60 * 60          if $6;
			$time += $8 * 60               if $8;
			$time += $10                   if $10;
		} else {
			return gripe "malformed soa time spec: $spec";
		}
		unless ($param =~ /^(refresh|retry|expire|minimum)$/) {
			gripe "unknown soa parameter: $param";
			next;
		}
		if ($soa{$param}) {
			gripe "repeated soa parameter: $param";
		}
		$soa{$param} = $time;
	}
	debug "soa " . show \%soa;
}

#
# Read the configuration file
#

my $input = new IO::File $infile, "r"
	or die "$0: open $infile: $!\n";

while (my $line = <$input>) {
	$linenum++;
	chomp $line;
	$line =~ s/#.*//;
	next if $line =~ /^\s*$/;
	my @words = split /\s+/, $line;
	my $sub = $::{$words[0]};
	if ($sub) {
		$sub->(@words);
	} else {
		host @words;
	}
}

undef $input;

#
# Create dhcpd.conf
#

my $outfile = $option{test} ? "test/dhcpd.conf" : "../dhcpd.conf";
$output = new IO::File $outfile, "w"
	or die "$0: open $outfile: $!\n";

say untab 1, <<HERE_DOC_END;
	#
	# dhcpd.conf automatically generated by $0 at $soa{serial}
	#
	
	default-lease-time 21600; # six hours
	max-lease-time    604800; # one week
	
	option domain-name ".";
HERE_DOC_END

for my $net (@net) {
	my $base = $net->{base};
	my $mask = $net->{mask};

	say "subnet $base netmask $mask {";

	say "	range $_->{min} $_->{max};"
		for (grep { in_net $net, $_->{min}
			and in_net $net, $_->{max} } @dhcp);

	say "	server-identifier $_;"
		for (grep { in_net $net, $_ } @dhcpd);

	say "	option domain-name-servers $_;"
		for (grep { in_net $net, $_ } @named);

	say "	option routers $_;"
		for (grep { in_net $net, $_ } @router);

	for my $host (@host) {
		next unless defined $host->{ether}
			and defined $host->{ip}
			and in_net $net, $host->{ip};
		my @zones = map {$_->{name} } map { zones_of $_ }
			$host->{name}, @{$host->{aliases}};
		say "	host $host->{name} {";
		say "		hardware ethernet $host->{ether};";
		say "		fixed-address $host->{ip};";
		say "		option domain-name \"@zones .\";" if @zones;
		say "	}";
	}
	say "}"; say "";
}

say "# EOF";

undef $output;

#
# Create forward DNS
#

sub zone_preamble ($) {
	my $zone = shift;
	say untab 2, <<HERE_DOC_END;
		;
		; zone file automatically generated by $0
		;
		
		\$ORIGIN $zone->{name}.

		\$TTL $soa{minimum}

		@	SOA	$zone->{soa}. dot.dotat.at. (
		\t\t	$soa{serial} ; serial number (generation time)
		\t\t	$soa{refresh}	   ; slave zone refresh period
		\t\t	$soa{retry}	   ; failed zone xfer retry period
		\t\t	$soa{expire}	   ; unrefreshed zone expire time
		\t\t	$soa{minimum} )	   ; minimum ttl
HERE_DOC_END

	say "	NS	$_." for (@{$zone->{ns}});

	say ""; say ";"; say "";
}

for my $zone (@zone) {

	my $outfile = $option{test} ? "test/$zone->{name}."
				     : "GEN/$zone->{name}.";
	$output = new IO::File $outfile, "w"
		or die "$0: open $outfile: $!\n";

	zone_preamble $zone;

	say "$_->{name}.	$_->{type}	$_->{data}."
		for (grep {$zone eq zone_of $_->{name}} @rr);

	say ""; say ";"; say "";

	for my $host (@host) {
		say "$host->{name}.	A	$host->{ip}"
			if $zone eq zone_of $host->{name}
			and defined $host->{ip};
		for my $alias (@{$host->{aliases}}) {
			say "$alias.	CNAME	$host->{name}."
				if $zone eq zone_of $alias;
		}
	}

	for my $dhcp (grep { $_->{zone} eq $zone } @dhcp) {
		for my $ip (ip_range $dhcp->{min}, $dhcp->{max}) {
			my @ip = octets $ip;
			say "dhcp-$ip[-1].$zone->{name}.	A	$ip";
		}
	}

	say ""; say "; EOF";

	undef $output;
}

#
# Create reverse DNS
#

for my $net (map { net_zones $_ } @net) {

	my $outfile = $option{test} ? "test/$net->{name}."
				     : "GEN/$net->{name}.";
	$output = new IO::File $outfile, "w"
		or die "$0: open $outfile: $!\n";

	zone_preamble $net;

	for my $host (grep { defined $_->{ip}
			and in_net $net, $_->{ip} } @host) {
		my $dns = ipdns $host->{ip};
		say "$dns.	PTR	$host->{name}.";
	}

	for my $dhcp (grep { in_net $net, $_->{min}
			and in_net $net, $_->{max} } @dhcp) {
		for my $ip (ip_range $dhcp->{min}, $dhcp->{max}) {
			my @ip = octets $ip;
			my $dns = ipdns $ip;
			say "$dns.\tPTR	dhcp-$ip[-1].$dhcp->{zone}->{name}.";
		}
	}

	say ""; say "; EOF";

	undef $output;
}


#
# That's all, folks!
#

exit 0;