# -*- perl -*-

# Copyright (c) 2003 by Jeff Weisberg
# Author: Jeff Weisberg <argus @ tcp4me.com>
# Date: 2003-May-22 21:46 (EDT)
# Function: caching async resolver + re-resolver
#
# $Id: Resolv.pm,v 1.18 2005/12/13 02:10:15 jaw Exp jaw $

# Wise to resolve, and patient to perform.
#   -- Homer, Odyssey

# runs as a standard argus Service, can have several instances


package Resolv;
@ISA = qw(Service);

use Socket;
BEGIN{ eval{ require Socket6; import Socket6; $HAVE_S6 = 1; }}

use strict qw(refs vars);
use vars qw(@ISA $doc $HAVE_S6 $enable_p);

$enable_p = 0;
my $TOOLONG   = 300;
my $MAXFREQ   = 60;
my $OLD_AGE   = 60;
my $PROTO_UDP = getprotobyname('udp');
my $DNS_PORT  = 53;

my $qid       = $^T & 0xFFFF;
my $n_resolv  = 0;
my %cache     = ();		# cache{hostname} = { addr, expire, }
my @todo      = ();		# hostnames to be looked up
my %pending   = ();		# pending queries

$doc = {
    package => __PACKAGE__,
    file    => __FILE__,
    isa     => [qw(Service MonEl BaseIO)],
    methods => {},
    versn => '3.4',
    html  => 'resolv',
    fields => {
	resolv::conf => {
	    descr => 'location of resolv.conf',
	    attrs => ['config', 'inherit'],
	    default => '/etc/resolv.conf',
	},
	resolv::ttl_min => {
	    descr => 'minimum ttl',
	    attrs => ['config', 'inherit'],
	    default => 300,
	},
	resolv::ttl_max => {
	    descr => 'maximum ttl',
	    attrs => ['config', 'inherit'],
	    default => 14 * 24 * 3600, # 2 weeks
	},
	resolv::ttl_nxdomain => {
	    descr => 'nxdomain caching ttl',
	    attrs => ['config', 'inherit'],
	    default => 600,
	},
	resolv::ttl_error => {
	    descr => 'error caching ttl',
	    attrs => ['config', 'inherit'],
	    default => 60,
	},
	resolv::max_queries => {
	    descr => 'maximum number of queries per session',
	    attrs => ['config', 'inherit'],
	    default => 1000,
	},
	resolv::nameservers => {
	    descr => 'list of nameservers to use in addition to those from resolv.conf',
	    attrs => ['config', 'inherit'],
	    exmpl => '192.168.7.11',
	},
	resolv::search => {
	    descr => 'domains to use for non-fully-qualified hostnames, overrides resolv.conf',
	    attrs => ['config', 'inherit'],
	    exmpl => 'example.com',
	},

	resolv_timeout => {
	    descr => 'timeout for resolver lookups',
	    attrs => ['config', 'top'],
	},
	  
	resolv::domlist     => { descr => 'list of search domains' },
	resolv::ns_all      => { descr => 'list of nameservers' },	# for debugging
	resolv::nslist      => { descr => 'list of nameservers' },
	resolv::nameserver  => { descr => 'current nameserver' },
	resolv::ns_i        => { descr => 'index of current nameserver' },
	resolv::pending     => { descr => 'queries currently pending' },
	resolv::n_queries   => { descr => 'number of outstanding queries' },
	resolv::n_responses => { descr => 'number of responses in this session' },
    },
};


################################################################
# these 2 funcs provide the public interface
#
# both will return either an addr or undef
################################################################
sub resolv_defer {
    my $host = shift;
    my( $ip );

    $host = normalize( $host );

    # check for dotted quad
    if( $host =~ /^\d+\.\d+\.\d+\.\d+$/ ){
	$ip = inet_aton( $host );
    }
    # check for cologned octopus
    elsif( $host =~ /^[a-f\d:]+$/i && $HAVE_S6 ){
	$ip = inet_pton(AF_INET6, $host);
    }

    if( $ip ){
	$cache{$host} = {
	    addr   => $ip,
	    expire => 0,
	};

	return $ip;
    }
    
    if( $cache{$host} && $cache{$host}{addr} ){
	return $cache{$host}{addr};
    }
    
    return undef if $pending{$host};

    print STDERR "resolv defer $host\n" if $::opt_d;

    add_todo( $host );
    return undef;
}

sub resolv_check {
    my $host = shift;
    $host = normalize( $host );

    print STDERR "resolv check $host\n" if $::opt_d;

    if( $cache{$host} ){
	# expire = 0 => never expires
	if( $cache{$host}{expire} && $cache{$host}{expire} < $^T  && !$pending{$host} ){
	    add_todo( $host );
	}
	
	return $cache{$host}{addr};
    }

    undef;
}

sub normalize {
    my $host = shift;

    $host = lc($host);
    # ...
    $host;
}

sub add_todo {
    my $h = shift;
    
    push @todo, $h unless grep {$_ eq $h} @todo;
}

sub remove_todo {
    my $h = shift;

    @todo = grep {$_ ne $h} @todo;
}

sub too_long {
    $Conf::Config{resolv_timeout} || $TOOLONG;
}

################################################################

sub probe {
    my $name = shift;

    return [6, \&config] if $name =~ /^Resolv/i;
}

sub config {
    my $me = shift;
    my $cf = shift;

    bless $me;
    $me->init_from_config( $doc, 'resolv' );
    
    $me->{web}{hidden}  = 1;
    $me->{passive}      = 1;
    $me->{nostats}      = 1;
    $me->{transient}    = 1;
    
    $me->{uname} = "Resolv_$n_resolv";
    $n_resolv++;

    # don't want to overflow a 16bit
    $me->{resolv}{max_queries} = 60000 if $me->{resolv}{max_queries} > 60000;
    $me->{resolv}{ns_all}  = $me->{resolv}{nameservers};
    $me->{resolv}{ns_all} .= ' ' if $me->{resolv}{ns_all};
    my @ns = map {
	inet_aton($_)
    } (split /\s+/, $me->{resolv}{ns_all});

    my @dom;
    
    # open resolv.conf
    my $f = $me->{resolv}{conf};
    if( $f ){
	open(R, $f) || return $cf->error("Cannot open '$f': $!");
	while(<R>){
	    my $ns;
	    chop;
	    if( /^domain/i | /^search/i ){
		my @d;
		(undef, @d) = split /\s+/;
		push @dom, @d;
		next;
	    }
	    next unless /^nameserver/i;
	    (undef, $ns) = split /\s+/;
	    push @ns, inet_aton($ns);
	    $me->{resolv}{ns_all} .= $ns . " ";
	}
	close R;
    }
    
    unless( @ns ){
	# because resolv.conf(5) says so
	push @ns, inet_aton('127.0.0.1');
	$me->{resolv}{ns_all} .= '127.0.0.1';
    }
    $me->{resolv}{nslist} = [ @ns ];
    $me->{resolv}{ns_i}   = 0;
    $me->{resolv}{nameserver} = $me->{resolv}{nslist}[ 0 ];

    if( @dom ){
	$me->{resolv}{search} .= ' ' . join(' ', @dom);
    }
    $me->{resolv}{domlist} = [ '', (split/\s+/, $me->{resolv}{search}) ];
    
    unless( $::opt_t ){
	::loggit( "Asynchronous Resolver enabled" ) unless $enable_p;
	$enable_p = 1;
    }
    
    $me;
}

sub configured {
    my $me = shift;

    if( $me->{srvc}{frequency} > $MAXFREQ ){
	$me->{srvc}{frequency} = $MAXFREQ;
	$me->{srvc}{phi}       = $MAXFREQ / 2;
    }

    $me->SUPER::configured();
}

sub next_ns {
    my $me = shift;

    $me->debug('RESOLV - switching nameserver');
    $me->{resolv}{ns_i} ++;
    $me->{resolv}{ns_i} %= @{ $me->{resolv}{nslist} };
    
    $me->{resolv}{nameserver} = $me->{resolv}{nslist}[ $me->{resolv}{ns_i} ];
}


sub start {
    my $me = shift;
    my( $fh, $ip );
    
    $me->Service::start();
    $me->debug("RESOLV start");

    unless(@todo){
	$me->debug('RESOLV - queue empty');
	return $me->done();
    }
    
    # open socket to ns
    $me->{fd} = $fh = BaseIO::anon_fh();
    $ip = $me->{resolv}{nameserver};

    my $i = socket($fh, PF_INET,  SOCK_DGRAM, $PROTO_UDP);
    unless($i){
	my $m = "socket failed: $!";
	::sysproblem( "RESOLV $m" );
	$me->debug( $m );
	return $me->done();
    }

    $me->baseio_init();

    $i = bind($fh, sockaddr_in(0, INADDR_ANY) );
    unless($i){
	my $m = "bind failed: $!";
	::sysproblem( "RESOLV $m" );
	$me->debug( $m );
	return $me->done();
    }
    
    $i = connect( $fh, sockaddr_in( $DNS_PORT, $ip) );
    unless($i){
	my $m = "connect failed: $!";
	::sysproblem( "RESOLV $m" );
	$me->debug( $m );
	$me->next_ns();
	return $me->done();
    }
    
    $me->wantread(1);
    $me->wantwrit(1);
    $me->settimeout( $me->{srvc}{timeout} );
    $me->{srvc}{state} = 'waiting';
    $me->{resolv}{n_queries}   = 0;
    $me->{resolv}{n_responses} = 0;    
}

sub readable {
    my $me = shift;
    my( $fh, $i, $l );

    $fh = $me->{fd};
    $i = recv($fh, $l, 8192, 0);
    unless( defined $i ){
	my $m = "recv failed: $!";
	::sysproblem( "RESOLV $m" );
	$me->debug( $m );
	return $me->done();
    }
    
    $me->debug( 'RESOLV recv data' );
    $me->settimeout( $me->{srvc}{timeout} );
    
    # pull out qid, rcode
    my $id = unpack( 'n', $l );
    my $ec = unpack( 'x3 C', $l) & 0xF;

    # decode pkt
    my $r;
    unless( $ec ){
	eval{ $r = DNS::decode( $me, $l ); };
    }

    # find matching query
    my $d = $me->{resolv}{pending}{$id};
    my $h = $d->{host};
    my $z = $d->{zone};
    delete  $me->{resolv}{pending}{$id};

    $me->debug( "RESOLV - qid=$id, rcode=$ec" );

    unless($h){
	# un-expected response?
	$me->debug( "RESOLV - unexpected response id=$id" );
	return;
    }
    delete  $pending{$h};

    # what to do if we get an error?
    if( $ec || !$r || !$r->{na} ){
	
	my $et = ($ec == 3) ? $me->{resolv}{ttl_nxdomain} : $me->{resolv}{ttl_error};
	
	if( $cache{$h}{addr} ){
	    # if we have an addr, keep it
	    # if expired, update expire time

	    if( $cache{$h}{expire} < $^T ){
		$cache{$h}{expire} = $^T + $et;
	    }
	    $me->debug( "RESOLV keeping value for $h" );
	}

	else{
	    # error => cache failure
	    $me->debug( "RESOLV - ERROR($ec) for $z" );

	    $cache{$h}{addr}   = undef;
	    $cache{$h}{expire} = $^T + $et;
	    $cache{$h}{rcode}  = $ec;

	    if( $ec == 3 && $me->{resolv}{domlist} ){
		# nxdomain: try search domains
		$cache{$h}{srch} ||= $me->{resolv}{domlist};
		$cache{$h}{srch_i} = 1 unless defined $cache{$h}{srch_i};
		
		# go through the entire list, then delay ttl_nxdomain
		
		if( $cache{$h}{srch_i} % @{$cache{$h}{srch}} ){
		    $cache{$h}{expire} = $^T;
		    add_todo( $h );
		    $me->debug("RESOLV - nxdomain $h - retry now");
		};
	    }
	}

	# a valid response on a bad hostname, counts
	$me->{resolv}{n_responses} ++ if $ec;
	
	return;
    }

    # decode packet, find correct answer, there may be several...

    foreach my $a ( @{ $r->{answers} } ){
	$me->debug( "RESOLV: $a->{name} $a->{ttl} $a->{class} $a->{type} $a->{answer}" );

	next unless $a->{type} eq 'A' || $a->{type} eq 'AAAA';
	
	# if we have an answer, it always updates cache
	$me->debug( "RESOLV - caching $h = $a->{answer}" );

	my $t = $a->{xttl};
	$t = $me->{resolv}{ttl_min} if $t < $me->{resolv}{ttl_min};
	$t = $me->{resolv}{ttl_max} if $t > $me->{resolv}{ttl_max};
	
	$cache{$h} = {
	    fqdn   => $z,	# record fqdn
	    addr   => $a->{rdata},
	    expire => $^T + $t,
	};
    }

    $me->{resolv}{n_responses} ++;
}

sub writable {
    my $me = shift;

    my( $host, $qhost, $opt );
    while( @todo && ! $host ){
	$host = shift @todo;
	$host = undef if $pending{$host};
    }
    unless( $host ){
	$me->debug( 'RESOLV - writable but queue empty' );
	$me->wantwrit(0);
	return;
    }

    $qhost = $host;
    # undocumented feature: '-4 www.example.com', '-6 www.example.com'
    if( $host =~ /^-(\S+)\s(.*)/ ){
        $opt   = $1;
        $qhost = $2;
    }
    $opt ||= '46';

    my $fh = $me->{fd};
    
    my @zone;
    if( $cache{$host} ){
	if( $cache{$host}{fqdn} ){
	    # use known correct fqdn
	    push @zone, $cache{$host}{fqdn};
	}elsif( $cache{$host}{srch} ){
	    # try next search domain
	    my $i = $cache{$host}{srch_i} ++;
	    $i %= @{ $cache{$host}{srch} };
	    my $srch = $cache{$host}{srch}[$i];

	    push @zone, ( $srch ? "$qhost.$srch" : $qhost );
	}else{
	    push @zone, $qhost;
	}
    }else{
	push @zone, $qhost;
	# ...
    }
    
    foreach my $zone (@zone) {
	# send Q - A and AAAA
	for my $qt ( 'A', ($::HAVE_S6 ? 'AAAA' : ()) ){

	    next if ($qt eq 'A')    && ($opt !~ /4/);
	    next if ($qt eq 'AAAA') && ($opt !~ /6/);
	    
	    my $q = DNS::build_packet( undef, undef, {
		query   => $qt,
		class   => 'IN',
		qid     => $qid,
		recurse => 1,
		zone    => $zone,
	    } );
	    
	    $me->debug( "RESOLV - sending query $qid $qt($zone)" );
	    
	    my $i = send( $fh, $q, 0 );
	    unless($i){
		my $m = "send failed: $!";
		::sysproblem( "RESOLV $m" );
		$me->debug( $m );
		$me->next_ns();
		add_todo( $host );
		return $me->done();
	    }

	    $me->{resolv}{n_queries} ++;
	    $me->{resolv}{pending}{$qid} = { host => $host, zone => $zone };
	    $pending{$host} = $^T;
	    $qid ++;
	    $qid &= 0xFFFF;
	}
    }

    if( $me->{resolv}{n_queries} >= $me->{resolv}{max_queries} ){
	# session full
	$me->wantwrit(0);
    }
    
    $me->wantread(1);
    $me->{srvc}{state} = 'resolving';
}

sub timeout {
    my $me = shift;

    $me->debug( 'RESOLV - TO' );
    
    # pick new ns
    $me->next_ns() unless $me->{resolv}{n_responses};
    $me->done();
}

sub done {
    my $me = shift;

    $me->debug( 'RESOLV - done' );
    
    # dump pending back to todo list
    foreach my $q ( sort keys %{ $me->{resolv}{pending} } ){
	my $h = $me->{resolv}{pending}{$q}{host};
	delete $pending{$h};
	
	$me->debug( "RESOLV - response never rcvd: $q - $h" );
	next if $cache{$h} && $cache{$h}{addr} && $cache{$h}{expire} > $^T;

	# no address yet, at least one pkt was dropped. -- force fast retry.
	add_todo( $h );
    }
    delete $me->{resolv}{pending};
    
    $me->Service::done();
}

################################################################

sub janitor {

    # in case there is a bug and someone gets trapped in the queue...
    # or a packet gets dropped
    foreach my $h ( keys %pending ){
	delete $pending{$h} if $pending{$h} + $OLD_AGE < $^T;
    }
}

sub about_more {
    my $me = shift;
    my $ctl = shift;
    my( $k, $v );

    $me->SUPER::about_more($ctl);
    $me->more_about_whom($ctl, 'resolv');
}

sub gen_conf_decl { 'Resolv' }

sub gen_confs {
    my $conf;
    
    foreach my $n (0 .. $n_resolv - 1 ){
	my $r = $MonEl::byname{"Resolv_$n"};
	$conf .= $r->gen_conf();
    }
    $conf = "\n$conf" if $conf;
    $conf;
}

################################################################

sub cmd_todo {
    my $ctl = shift;

    $ctl->ok();
    foreach my $h (@todo){
	$ctl->write("$h: 1\n");
    }
    $ctl->final();
}

sub cmd_pending {
    my $ctl = shift;
    
    $ctl->ok();
    foreach my $h (sort keys %pending){
	$ctl->write("$h: $pending{$h}\n");
    }
    $ctl->final();
}

sub cmd_cache {
    my $ctl = shift;

    $ctl->ok();
    foreach my $h (sort keys %cache){
	$ctl->write("$h addr: ". ::inet_ntoa($cache{$h}{addr}) . "\n")
	    if $cache{$h}{addr};
	foreach my $k (qw(expire rcode fqdn srch_i)){
	    $ctl->write("$h $k: $cache{$h}{$k}\n") if $cache{$h}{$k};
	}
	$ctl->write("$h srch: @{$cache{$h}{srch}}\n") if $cache{$h}{srch};
	
    }
    $ctl->final();
}

################################################################
Doc::register( $doc );
push @Service::probes, \&probe;

Control::command_install('resolv_todo',    \&cmd_todo);
Control::command_install('resolv_pending', \&cmd_pending);
Control::command_install('resolv_cache',   \&cmd_cache);


Cron->new( freq => 3600,
	   text => 'Resolv cleanup',
	   func => \&janitor,
	   );

1;
