Bot.pm
package Bot;
use strict;
use warnings;
use Module::Reload;
use POE qw(
Component::Client::DNS
);
use Socket;
use IO::Socket;
use IO::Socket::INET;
use Net::DNS;
my $dns_socket;
### direct subroutine, to setup listener that's possibly on fd3.
### so if you start the listener, with a UDP *:53 socket already open
### on fileno(3), you do not have to run this setuid root.
sub setup_listener {
$dns_socket = IO::Socket->new_from_fd(3, "r+");
my $sockname;
if ( $dns_socket and $dns_socket->opened ) {
### verify sanity
my $sotype = $dns_socket->sockopt(SO_TYPE);
$sockname = $dns_socket->sockname;
unless ( $sotype and $sotype == SOCK_DGRAM and $sockname ) {
undef $dns_socket;
}
} else {
undef $dns_socket;
}
if ( !defined $dns_socket ) {
print "Setting up UDP listener\n";
$dns_socket = IO::Socket::INET->new(
Proto => "udp",
LocalPort => 53,
)
or die "Cannot create socket: $!\n";
$sockname = $dns_socket->sockname;
}
my($port, $inet) = sockaddr_in($sockname);
print "Listening on ", inet_ntoa($inet), ":$port/udp\n";
}
### direct subroutine: setup extra stuff
sub init {
my($kernel, $heap) = @_;
### Register 'dns_resolve' state
$kernel->state('dns_resolve', 'Bot');
### create DNS resolver
$heap->{resolver} ||= POE::Component::Client::DNS->spawn();
### Register 'dns_incoming' and 'dns_err' states
$kernel->state('dns_incoming', 'Bot');
$kernel->state('dns_err', 'Bot');
### create the DNS translation Wheel, using custom driver and filter
$heap->{dnsrw} ||= POE::Wheel::ReadWrite->new(
Handle => $dns_socket,
Driver => Bot::Driver::SendRecv->new(),
Filter => Bot::Filter::UDPDNS->new(),
InputEvent => 'dns_incoming',
ErrorEvent => 'dns_err',
);
}
### direct subroutine
sub handle {
my($kernel, $heap, $dest, $prefix, $what) = @_;
### get list of valid Net::DNS::RR types
my @rr = keys %Net::DNS::RR::RR;
my $rr_regex = join("|", @rr);
my $response;
if ( $what =~ /^reload$/i ) {
Module::Reload->check;
$response = "OK, I reloaded";
Bot::init($kernel, $heap);
}
elsif ( $what =~ /^($rr_regex)\s+([\w.-]+)\?\s*$/ ) {
$heap->{resolver}->resolve(
type => $1,
host => $2,
event => 'dns_resolve',
context => { Dest => $dest, Prefix => $prefix },
timeout => 15,
);
}
elsif ( $what =~ /^([\w.-]+)(\s.*)/ ) {
### could be a hostname
my $host = $1;
my $rest = $2;
if ( exists $heap->{short}{$host} ) {
$host = $heap->{short}{$host};
$what = "$host$rest";
}
if ( $heap->{outstanding}{$host} ) {
### try and parse the line
my $answ = Net::DNS::RR->new($what);
if ( $answ ) {
my $type = $answ->type;
### fix TTL if necessary
$answ->ttl(3600) if !$answ->ttl;
if ( $heap->{outstanding}{$host}{$type} ) {
### send all replies
for my $q ( @{ $heap->{outstanding}{$host}{$type} } ) {
$heap->{dnsrw}->put( create_dns_reply($q, $answ) );
}
### clean up
delete $heap->{outstanding}{$host}{$type};
delete $heap->{outstanding}{$host}
unless %{ $heap->{outstanding}{$host} };
} elsif ( $type eq "CNAME" ) {
### CNAME is always OK
while ( my($type, $qs) =
each %{ $heap->{outstanding}{$host} } )
{
for my $q ( @$qs ) {
$heap->{dnsrw}->put( create_dns_reply($q, $answ) );
}
}
delete $heap->{outstanding}{$host};
} else {
### wrong type
$response = "Nobody asked for $host $type records!";
}
} else {
### cannot parse answ
$response = "sorry? what did you say about $host?";
}
} else {
### wrong host
$response = "Who cares about $host?";
}
} else {
$response = "are you talking to me? $what?";
}
$heap->{Irc}->yield( privmsg => $dest, "$prefix$response" )
if defined $response;
}
### a POE state: called when a question from irc is resolved
sub dns_resolve {
my($kernel, $heap, $response) = @_[KERNEL, HEAP, ARG0];
my $context = $response->{context};
my $dest = $context->{Dest};
my $prefix = $context->{Prefix};
my $irc = $heap->{Irc};
my $type = $response->{type};
my $host = $response->{host};
if ( my $pkt = $response->{response} ) {
my $rcode = $pkt->header->rcode;
my $aa = $pkt->header->aa;
$irc->yield( privmsg => $dest, $prefix .
"$type record for $host: got " .
($aa ? "" : "non-") . "authoritive answer" .
( $rcode eq "NOERROR" ? "" : ", $rcode"));
my @answ = $pkt->answer();
for my $a ( @answ ) {
my $astr = $a->string();
$astr =~ s/;.*$/ /gm;
$astr =~ s/[\t\n]/ /g;
$irc->yield( privmsg => $dest, $prefix . $astr );
}
}
else {
my $err = $response->{error};
$irc->yield( privmsg => $dest, $prefix .
"Cannot find $type records for $host: $err" );
}
}
### a POE state: called when a DNS packet is received
sub dns_incoming {
my($kernel, $heap, $dnsq) = @_[KERNEL, HEAP, ARG0];
my($q) = $dnsq->question();
return if !$q;
my $host = $q->qname();
(my $shorthost = $host) =~ s/\..*//;
my $type = $q->qtype();
my $again;
if ( exists $heap->{outstanding}{$host}{$type} ) {
$again++;
push @{ $heap->{outstanding}{$host}{$type} }, $dnsq;
} else {
$heap->{outstanding}{$host}{$type} = [ $dnsq ];
}
### keep aliases for only the hostname, to the FQDN
$heap->{short}{$shorthost} = $host;
my($fromaddr) = split /:/, $dnsq->answerfrom();
my $msg = "$fromaddr wants to know" . ($again ? ", again" : "")
. ": " . $q->string;
$msg =~ s/;.*$/ /gm;
$msg =~ s/\t/ /g;
$heap->{Irc}->yield( privmsg => $heap->{Channel}, $msg );
}
### a POE state: called when DNS reads go wrong
sub dns_err {
my($heap, $op, $errnum, $errstr) = @_[HEAP, ARG0..ARG2];
warn "DNS readwrite: $op generated error $errnum: $errstr\n";
delete $heap->{dnsrw};
}
### internal function: create a dns reply packet
sub create_dns_reply {
my($q, $answ) = @_;
$q->push(answer => $answ);
$q->header->qr(1);
$q->header->rcode("NOERROR");
$q->push(authority => Net::DNS::RR->new(
Name => "poe.cornet.org",
Type => "NS",
TTL => 3600,
Nsdname => "mobilens.cornet.org"
));
return $q;
}
package Bot::Driver::SendRecv;
use POE::Driver;
use Socket;
sub new {
my $class = shift;
my $self = []; # the output queue
bless $self, $class;
}
sub get {
my $self = shift;
my $fh = shift;
my @ret;
while (1) {
my $from = recv($fh, my $buffer = '', 4096, MSG_DONTWAIT);
last if !$from;
push @ret, [ $from, $buffer ];
}
return if !@ret;
return \@ret;
}
sub put {
my $self = shift;
my $data = shift;
push @$self, @$data;
my $sum = 0;
$sum += length( $_->[1] ) for @$self;
return $sum;
}
sub flush {
my $self = shift;
my $fh = shift;
while ( @$self ) {
my $n = send($fh, $self->[0][1], MSG_DONTWAIT, $self->[0][0])
or return;
$n == length($self->[0][1])
or die "Couldn't write complete message to socket: $!\n";
shift @$self;
}
}
package Bot::Filter::UDPDNS;
use POE::Filter;
use Socket;
use Net::DNS::Packet;
sub new {
my $class = shift;
bless {}, $class;
}
sub get {
my $self = shift;
my $data = shift;
my @ret;
for my $d ( @$data ) {
ref($d) eq "ARRAY"
or die "UDPDNS filter expected arrayrefs for input\n";
my($port, $inet) = sockaddr_in($d->[0]);
my $inetstr = inet_ntoa($inet);
my($p, $err) = Net::DNS::Packet->new(\$d->[1]);
if ( !$p ) {
warn "Cannot create DNS question for packet received from " .
"$inetstr: $err\n";
} else {
$p->answerfrom("$inetstr:$port");
push @ret, $p;
}
}
return \@ret;
}
sub put {
my $self = shift;
my $data = shift;
my @ret;
for my $d ( @$data ) {
my($inetstr, $port) = split /:/, $d->answerfrom();
if ( !defined $port ) {
warn "answerfrom not set in DNS packet, no destination known\n";
} else {
push @ret,
[ pack_sockaddr_in($port, inet_aton($inetstr)), $d->data ];
}
}
return \@ret;
}
1;