# $Id: DNS.pm,v 1.10 2009/08/02 21:24:40 dk Exp $
package IO::Lambda::DNS;
use vars qw($DEBUG $TIMEOUT $RETRIES @ISA);
@ISA = qw(Exporter);
@EXPORT_OK = qw(dns);
%EXPORT_TAGS = ( all => \@EXPORT_OK);
$TIMEOUT = 4.0; # seconds
$RETRIES = 4;   # times

use strict;
use Socket;
use Net::DNS::Resolver;
use IO::Lambda qw(:all);

# given the options, returns new dns lambda
sub new
{
	shift;

	# get the options
	my @ctx;
	my $timeout  = $TIMEOUT;
	my $retries  = $RETRIES;
	my %opt;
	for ( my $i = 0; $i < @_; $i++) {
		if ( $i == 0 or $i == $#_ or not defined($_[$i])) {
			# first or last or undef parameter in no way can be an option
			push @ctx, $_[$i];
		} elsif ( $_[$i] =~ /^(timeout|deadline)$/) {
			$timeout  = $_[++$i];
		} elsif ( $_[$i] eq 'retry') {
			$retries  = $_[++$i];
		} elsif ( $_[$i] =~ /^(
			nameservers|recurse|debug|config_file|
			domain|port|srcaddr|srcport|retrans|
			usevc|stayopen|igntc|defnames|dnsrch|
			persistent_tcp|persistent_udp|dnssec
		)$/x) {
			$opt{$_[$i]} = $_[$i + 1];
			$i++;
		} else {
			push @ctx, $_[$i];
		}
	}

	my $simple_query = (( 1 == @ctx) and not ref($ctx[0]));

	# proceed
lambda {
	my $obj  = Net::DNS::Resolver-> new( %opt);
	my $bg_obj = $obj-> bgsend( @ctx);
	return "send error: " . $obj-> errorstring unless $bg_obj;

	my $sock;
	if ( $Net::DNS::VERSION > 1.02 ) {
		# this is a IO::Select object
		my @handles = $bg_obj->handles;
		if ( 1 != @handles ) {
			warn "There's something wrong with Net::DNS version $Net::DNS::VERSION, please notify the author\n";
			return "panic: Net::DNS returned not 1 socket\n";
		}
		$sock = $handles[0]->[0];
	} else {
		$sock = $bg_obj;
	}

	context $sock, $timeout;
readable {
	unless ( shift) {
		return 'connect timeout' if $retries-- <= 0;
		return this-> start; # restart the whole lambda
	}

	my $err = unpack('i', getsockopt($sock, SOL_SOCKET, SO_ERROR));
	if ( $err) {
		$! = $err;
		return "socket error: $!";
	}
	return again unless $obj-> bgisready($bg_obj);

	my $packet = $obj-> bgread( $bg_obj);
	undef $sock;
	undef $bg_obj;
	
	return "recv error: " . $obj-> errorstring unless $packet;

	if ( $simple_query) {
		# behave like inet_aton, return single IP address
		for ( $packet-> answer) {
			return $_-> address if $_-> type eq 'A';
		}
		return 'response doesn\'t contain an IP address';
	}

	return $packet;
}}}

sub dns(&) { IO::Lambda::DNS-> new(context)-> condition(shift, \&dns, 'dns') }

1;

__DATA__

=pod

=head1 NAME

IO::Lambda::DNS - DNS queries lambda style

=head1 DESCRIPTION

The module provides access to asynchronous DNS queries through L<Net::DNS>.
Two function doing the same operation are featured: constructor C<new> and
condition C<dns>.

=head1 SYNOPSIS

   use strict;
   use IO::Lambda::DNS qw(:all);
   use IO::Lambda qw(:all);
   
   # simple async query
   my $reply = IO::Lambda::DNS-> new( "www.site.com" )-> wait;
   print (($reply =~ /^\d/) ? "Resolved to $reply\n" : "Error: $reply\n");

   # parallel async queries
   lambda {
      for my $site ( map { "www.$_.com" } qw(google yahoo perl)) { 
         context $site, 'MX', timeout => 0.25; 
         dns { print shift-> string if ref($_[0]) }
      }
   }-> wait;

=head2 OPTIONS

Accepted options specific to the module are C<timeout> or C<deadline> (in
seconds) and C<retry> (in times).  All other options, such as C<nameservers>,
C<dnssec> etc etc are passed as is to the C<Net::DNS::Resolver> constructor.
See its man page for details.

=head2 USAGE

=over

=item new

Constructor C<new> accepts Net::DNS-specific options (see L<OPTIONS> above) and
query, and returns a lambda. The lambda accepts no parameters, and returns
either an IP address or a response object (depending on the call syntax, see
below), or an error string.

   new ($CLASS, %OPTIONS, $HOSTNAME) :: () -> ($IP_ADDRESS|$ERROR)

In the simple case, accepts C<$HOSTNAME> string, and returns also a string, either
an IP address or an error. To distinguish between these use C< /^\d/ > regexp,
because it is guaranteed that no error message will begin with a digit, and no IP
address will begin with anything other than a digit.

   new (%OPTIONS, ($PACKET | $HOSTNAME, $TYPE)) :: () -> ($RESPONSE|$ERROR)

In the complex case, accepts either C<Net::DNS::Packet> object, or C<$HOSTNAME>
and C<$TYPE> strings, where the latter can be one of C<A>, C<MX>, etc DNS query
type. See L<Net::DNS::Resolver/bgsend> for the exact syntax.

Returns either a C<Net::DNS::RR> object or an error string.

=item dns

Condition wrapper over C<new>.

   dns (%OPTIONS, $HOSTNAME) -> $IP_ADDRESS|$ERROR
   dns (%OPTIONS, ($PACKET | $HOSTNAME $TYPE)) -> $RESPONSE|$ERROR

=back

=head1 SEE ALSO

L<IO::Lambda>, L<Net::DNS::Resolver>.

=head1 AUTHOR

Dmitry Karasik, E<lt>dmitry@karasik.eu.orgE<gt>.

=cut