#!/usr/bin/perl -w

=pod

=head1 	NAME

dhis-dns9-engine - Actualizacin dinmica de bind9 para dhis-server

=head1	SYNOPSIS

	dhis-dns9-engine 

=head1 	DESCRIPTION

Este programa sirve como auxiliar para un servidor dhis-server, versin 5,
de manera que ste pueda actualizar un servidor bind9.

Est diseado siguiendo las directrices encontradas en el documento
F<MODULES> de los fuentes de dhis-server, en el apartado de comunicacin con
los procesos hijo.

El programa arranca y lee el archivo de configuracin (por defecto
F</etc/dhis-server/dns9-engine.conf>) el cual puede contener los siguientes
campos:

=over 4

=item * offline_ip: Direccin IP para usar cuando un host est desconectado,
de manera que el servidor de nombres responda por l y no aparezca como
desconocido. Por defecto es I<192.168.255.0>.

=item * dyn_ttl: Tiempo de vida (TTL) de la informacin en el cach DNS para
las entradas dinmicas. Por defecto son I<60> segundos.

=item * nameserver: Direccin IP del servidor de nombres a actualizar. Por
defecto es I<127.0.0.1>.

=item * domain: Nombre del dominio de nombres bajo el que residen los hosts
dinmicos. Por defecto est sin definir, por lo que es muy conveniente
incluir ste valor.

=item * keyname: Nombre de la clave a usar para acceder al servidor de
nombres. Por defecto est sin definir, y slo es necesaria cuando el DNS
tiene protegidas las actualizaciones (lo que es muy recomendable).

=item * secret: Valor de la clave a usar, junto con el anterior I<keyname> en
el servidor DNS.

=item * dhis_db: Ruta a la base de datos de host dinmicos del servidor dhis;
obligatorio disponer de ella porque es la nica forma de obtener el nombre
del host para actualizar. Si no existe o no contiene un campo I<HostName> en
la entrada, el programa rechaza la actualizacin. Por defecto es
F</etc/dhis-server/dhis.db>.

=item * logfile: Ruta al archivo donde registrar las operaciones y cualquier
evento concreto. Por defecto es F</var/log/dhis-dns9-engine.log>.

=item * debug: Habilita el indicador de depuracin para las comunicaciones
con el servidor DNS. Muy til para saber qu demonios fall en el proceso,
aunque a veces la librera L<Net::DNS> es algo crptica en sus mensajes.

=back

Despus procede a cargar la base de datos de dhis (F<dhis.db>) y entra en un
bucle de lectura de rdenes y sigue el siguiente algoritmo:

=over 4

=item * Lee de la entrada estndar y decodifica la rden recibida

=item * Si la orden es B<exit> termina la ejecucin.

=item * Si la orden es B<reload> vuelve a leer la base de datos de hosts
(F<dhis.db>).

=item * Si la orden es B<add> aade un registro A para el host indicado.

=item * Si la orden es B<delete> aade un registro A para el host indicado con
una IP concreta (por defecto es I<192.168.255.0>).

=item * Si la orden es B<update> borra toda la informacin referente al host y
actualiza su registro con la nueva informacin.

=back

=head2 Actualizacin del DNS

Para actualizar el servidor bind utiliza el mdulo Perl L<Net::DNS>. Carga
siempre un registro de zona, otro de borrado de host y finalmente un
registro de asignacin de IP (aunque est sea interna).

La conexin se realiza mediante TCP y tiene la depuracin activa si est
definido el valor B<debug> en el archivo de configuracin.

=cut

use strict;
use warnings;

use FileHandle;
use Config::General;
use Net::DNS;

use constant {
	DYN_TTL		=>	60,
	OFFLINE_IP	=>	q(192.168.255.0),
	DHIS_DB		=>	q(/etc/dhis-server/dhis.db),
	CONFIG		=>	q(/etc/dhis-server/dns9-engine.conf),
	LOGFILE		=>	q(/var/log/dhis-dns9-engine.log),
	FAIL		=>	0,
	SUCCESS		=>	1
};

#
#	Catlogos de mensajes
#
use POSIX qw(setlocale);
use Locale::Messages qw(LC_MESSAGES);
use Locale::TextDomain qw( dhis-dns9-engine /usr/share/locale );
setlocale(LC_MESSAGES,"");

#
#	Variables globales
#

our $VERSION = '0.06';

#	Archivos y ajustes segn estemos depurando o no 
our $ConfigFile = CONFIG;
our $DhisDb = DHIS_DB;
our $LogFile = LOGFILE;
our $DEBUG_LEVEL = 0;

(my $DEBUG = 'DEBUG_' . $0) =~ tr/-/_/;
do {
	$ConfigFile 	= q(./examples/dns-engine.conf);
	$LogFile 		= q(./dhis-dns-engine.log);
	$DhisDb 		= q(./examples/dhis.db);
	$DEBUG_LEVEL 	= 1;
} if defined($ENV{uc($DEBUG)});

#	Configuracin
our %Config = ( 
	'offline_ip'	=>	OFFLINE_IP,
	'dyn_ttl'		=>	DYN_TTL,
	'nameserver'	=>	q(127.0.0.1),
	'domain'		=>	undef,
	'keyname'		=>	undef,
	'secret'		=>	undef,
	'dhis_db'		=>	$DhisDb,
	'logfile'		=>	$LogFile,
	'debug'			=>	0
);

#	Lista de Hosts clientes del servidor DHIS
our $DHIS_DB = { };

#	Seal de proceso recibida
our $SIGNAL = undef;

#	Redirigimos todas las salidas hacia el archivo de registro (dejamos de
#	utilizar Log::Dispatch porque no se trata de enviar a varios destinos,
#	sino de reunificar fuentes :-)
_init_log();
				
#
#	Comienzo del programa
#

_log('Comenzando ...');

#	Lectura de archivos de configuracin
_log(__ 'Cargando archivos de configuracin');
_reload();

#
#	Bucle de lectura de rdenes
#
my $command = {
	'operation'	=>	undef,
	'service'	=>	undef,
	'id'		=>	undef,
	'ip'		=>	undef
};
	
# Establecemos gestores de seales 
my %old_signal = _set_signal_handlers();

while (_read_command($command)) {
	do {
		_log(__x ('Recibida seal de proceso {signal}',
			'signal' => $SIGNAL) );
		last;
	} if defined($SIGNAL);

	do {
		_log(__ 'Proceso finalizado por orden recibida ...');
		last;
	} if $command->{operation} eq 'exit';

	do {
		_log(__ 'Releyendo bases de datos y configuracin');
		_reload();
		next;
	} if $command->{operation} eq 'reload';

	# En cualquier otro caso efectuamos la actualizacin ...
	_update_nameserver($command);
}	# while

#	 Fin de los datos ledos ?
if (not defined($command->{operation}) and not $SIGNAL) {
	_log(__ 'Proceso finalizado por fin de datos ...');
}

#
#	Final del programa
#

exit(0);

#
#	Funciones
#

sub _update_nameserver {
	my $cmd = shift;
	my $ret = FAIL;
	my $domain = $Config{domain};
	
	# Obtenemos el nombre del host segn el identificador ...
	my $hostname = _id2hostname($cmd->{id});

	# Intentamos extraer el nombre del dominio
	if ($hostname =~ /\./) {
		my $host;
		($host, $domain) = split(/\./, $hostname, 2);
	}
		
	# y la IP segn la operacin 
	my $ip = $cmd->{operation} eq 'delete' ? $Config{offline_ip} :
				$cmd->{ip};
		
	# Registro de operaciones ...
	_log(__x ('Actualizando servidor de nombres: operacion = {operacion}, ' .
		 ' id = {id}, ip = {ip} ', operacion => $cmd->{operation},
		 id => $cmd->{id}, ip => $cmd->{ip}) );
		 
	if ($hostname) {
		# Preparamos el registro de actualizacin ...
		my $update = Net::DNS::Update->new($domain);

		if (not defined($update)) {
			_log('no puedo crear un objeto en {module}',
					'module' => 'Net::DNS::Update');
		} else {
			# Construmos la lnea con la direccin IP, el TTL, el tipo de
			# registro y el nombre del host
			my $line = sprintf('%s %d A %s', $hostname, $Config{dyn_ttl},
								$ip);
				
			# Aadimos un registro para borrar el valor anterior. Esto nos
			# vale para todas las operaciones
			$update->push(update => rr_del($hostname));
			
			# Aadimos el registro que fija la IP nueva
			$update->push(update => rr_add($line));

			# y la contrasea para conectar con el servidor
			$update->sign_tsig($Config{keyname}, $Config{secret});
				
			# Conectamos con el servidor de nombres y ...
			_log('Conectando con el servidor de nombres {servidor} ...',
					'servidor' => $Config{nameserver});
			# Redireccionamos la salida estndar de errores hacia nuestro
			# archivo de registro !!! 
			#open (OLDERR,">&STDERR");	# duplicamos stderr
			
			#
			#	Para la conexin usamos tcp y pedimos un registro de
			#	actividad si estamos depurando ...
			my $res = Net::DNS::Resolver->new();
			$res->nameserver($Config{nameserver});
			$res->usevc(1);
			$res->debug($Config{debug});
			my $reply = $res->send($update);
			my $error = undef;
			
			# Comprobamos el resultado 
			if ($reply) {
			     if ($reply->header->rcode ne 'NOERROR') {
					$error = $reply->header->rcode;
				}
			} else {
	 			$error = $res->errorstring;
			}
			
			# Registramos el resutado
			if (not $error) {
				_log('{hostname} cambia la IP a {IP}',
					'hostname'	=>	$hostname, 'IP' => $ip);
				$ret = SUCCESS;
			} else {
				_log('error en cambio de IP de {hostname} a {IP}: {error}',
					'hostname'	=>	$hostname,
					'IP'		=>	$ip,
					'error'		=>	$error );
			}
		} # Net::DNS::Update->new
	}

	return $ret;
}

sub _id2hostname {
	my $id = shift;
	my $hostname = undef;
	
	# Si existe el ID en nuestra base de datos ...
	if (exists($DHIS_DB->{$id})) {
		# Si dispone de nombre de host ...
		$hostname = $DHIS_DB->{$id}->{hostname};

		if (not defined($hostname)) {
			_log('el elemento {ID} existe pero no tiene nombre de host',
					'ID' => $id);
		} 
	} else {
		_log('no tengo informacin del elemento {ID}', 
				'ID' => defined($id) ? $id : q(undef) );
	}
	
	return $hostname;
}

sub _read_command {
	my $cmd = shift;
	my $line = undef;
	my $ret = FAIL;
	
	# Inicializamos el retorno ...
	grep { $cmd->{$_} = undef; } keys( %{$cmd} );
	
	# Leemos una lnea de la entrada estndar
	while ($line = <STDIN>) {
		chomp($line);
		my $backup = $line;
		
		# si hemos recibido una seal abortamos
		last if defined($SIGNAL);
		
		# Si est en blanco la descartamos inmediatamente 
		next if $line =~ /^$/;

		# Si es una orden de salida ...
		if ($line =~ /^exit/) {
			$cmd->{operation} = 'exit';
			$ret = SUCCESS;
			last;
		
		#	Si debemos releer las bases de datos ...
		} elsif ($line =~ /^reload/) {
			$cmd->{operation} = 'reload';
			$ret = SUCCESS;
			last;
		
		# 	Si debemos actuar sobre un host ...
		} elsif ($line =~ /^(add|update|delete)\s+(\w+)\s+(\w+)\s+([\d.]+)/) {
			$cmd->{operation} = $1;
			$cmd->{service} = $2;
			$cmd->{id} = $3;
			$cmd->{ip} = $4;
			$ret = SUCCESS;
			last;

		#	Cualquier otra cosa no es reconocible por ahora ...
		} else {
			_log('error: orden no vlida {orden}', 'orden' => $backup);
		}
	}

	return $ret;
}

sub _init_log {
	my $file = shift;
	
	# Determinamos el archivo de registro a abrir
	$file = $LogFile if not defined($file);

	# Abrimos la salida estndar hacia l (aadiendo)
	open STDOUT, '>>', $file;

	# Duplicamos la salida estndar de errores sobre l
	open STDERR, ">&STDOUT";

	# y marcamos las dos como escritura inmediata
	select STDOUT; $| = 1;
	select STDERR; $| = 1;
	
	return;
}

sub _set_signal_handlers {
	my %ret = ();

	# Salvamos los anteriores y ponemos los nuevos
	@ret{qw(INT QUIT)} = @SIG{qw(INT QUIT)};
	
	$SIG{INT} = sub { $SIGNAL = 'SIGINT'; };
	$SIG{QUIT} = sub { $SIGNAL = 'SIGQUIT'; };

	return %ret;
}

sub _restore_signal_handlers {
	my %sig = @_;

	foreach my $k (keys (%sig)) {
		$SIG{$k} = $sig{$k} ? $sig{$k} : undef;
	}

	return;
}

sub _log {
	my $msg = shift;
	my $texto = undef;

	# Obtenemos el texto en el lenguaje pretederminado ...
	$texto = __x ( $msg, @_ );
	
	# Y le aadimos la informacin que necesitamos
	$texto = sprintf('%s: %s[%d]: ', scalar(localtime), $0, $$). " " .
				$texto;
	$texto .= "\n" if not $texto =~ /\n$/;

	return print STDERR $texto;
}

sub _reload {
	if (_read_config_file($ConfigFile, \%Config)) {
		if ($Config{logfile} ne $LogFile) {
			_init_log($Config{logfile});
		}
	}
	$DHIS_DB = _read_dhis_file($Config{'dhis_db'});

	# Si tenemos activo el indicador de depuracin de datos ...
	if ($Config{debug}) {
		_dump_config();
	}
	
}

sub _dump_config {
	use Data::Dumper;

	print STDERR "-- Volcando configuracin interna ...\n";
	print STDERR Dumper(\%Config);

	print STDERR "-- Volcando base de datos del servidor ...\n";
	print STDERR Dumper($DHIS_DB);

	return;
}
	
sub _read_config_file {
	my $file = shift;
	my $values = shift;
	my $ret = SUCCESS;
	my ($config, %cfg);
	
	eval { 
		local $SIG{'__DIE__'};
		$config = Config::General->new($file); 
	};

	if ($@) {
		_log('error en archivo de configuracin {file}: {error}',
				'file'	=>	$file, 'error' => $@);
		$ret = FAIL;
	} elsif (defined($config)) {
		%cfg = $config->getall();

		foreach my $k (keys (%{$values})) {
			if (exists($cfg{$k})) {
				$values->{$k} = $cfg{$k};
			}
		}
	} else {
		_log("error leyendo el archivo de configuracin {config}",
			'config'	=>	$file);
		$ret = FAIL;
	}

	return $ret;
}
		
sub _read_rndc_key {
	my $file = shift;
	my $keyname = undef;
	my $secret = undef;
	
	my $fh = new FileHandle;

	if ($fh->open($file, "r")) {
		while (<$fh>) {
			next if /^#/ or /^$/;
			
			if (/^\s*key\s+\"(.+)\"\s*\{/) {
				$keyname = $1;
			} elsif (/^\s*secret\s+\"(.+)\"\s*;/) {
				$secret = $1;
				last;
			}
		}
	} else {
		die "no puedo leer $file - $!";
	}

	return sprintf("%s:%s", $keyname, $secret);
}

sub _read_dhis_file {
	my $file = shift;
	my $ret = {};
	my $ptr = undef;
	
	my $fh = new FileHandle;

	if ($fh->open($file, "r")) {
		while (<$fh>) {
			next if /^;/ or /^$/;
			
			if (/^\s*(\w+)\s*\{/) {
				$ptr = $1;
			} else {
				if (/^\s*(\w+)\s+(.+)/) {
					my $id = lc($1);
					
					#  existe ya el parmetro ? 
					if (exists($ret->{$ptr}->{$id})) {
						if (not ref($ret->{$ptr}->{$id}) eq 'ARRAY') {
							# lo convertimos en un array ...
							$ret->{$ptr}->{$id} = [ $ret->{$ptr}->{$id}, $2 ];
						} else {
							# es ya un array: se lo aadimos
							push(@{$ret->{$ptr}->{$id}}, $2);
						}
					} else {
						$ret->{$ptr}->{$id} = $2;
					}
				}
			}
		}
	} else {
		_log('no puedo leer el archivo {file}: {error}',
				'file'	=>	$file, 'error' => $!);
	}

	return $ret;
}

=pod 

=head1	BUGS

Puesto que est en desarrollo, hay dos aspectos de los que no estoy muy
seguro:

=over 4

=item * Tratamiento de seales del proceso. Debera salir limpiamente, pero
no est muy claro en qu punto existe control total sobre ellas. Actualmente
se centra en el bucle de lectura de rdenes.

=item * Actualizacin del servidor de nombres. Es tan fiable como puede
serlo el mdulo L<Net::DNS>, pero no ha sido probado con otro servidor que
no sea un bind9.

=back

=head1 AUTHOR

(c) Copyright Vctor Moral <victor@taquiones.net>

=head1 SEE ALSO

L<dhis-server> versin 5  superior, L<nsupdate> en el paquete F<dnsutils>
y, por supuesto, Bind versin 9  superior.

=head1 LICENSE

Este programa est bajo licencia GPL (ver L<perlgpl>) y puede distribuirse
y/ modificarse bajo los trminos en ella descritos.

=cut

