Bot.pm.v8
package Bot;
use strict;
use warnings;
use Module::Reload;
use Socket;
use IO::Socket;
use IO::Socket::INET;
use Net::DNS;
use POE qw(
Component::Client::DNS
Component::Client::TCP
Wheel::Run
Wheel::SocketFactory
Wheel::ReadWrite
Filter::Line
);
### direct subroutine: setup extra stuff
sub new {
my($class, $kernel, $heap) = @_;
$class = ref $class if ref $class;
my $self = {
Kernel => $kernel,
Heap => $heap,
};
bless $self, $class;
### register "dns_resolve' state
$kernel->state('dns_resolve', 'Bot');
### state to send back irc answers
$kernel->state('send_reply', 'Bot');
### states to handle 'date' external command
$kernel->state('date_closed', 'Bot');
$kernel->state('date_output', 'Bot');
### create DNS resolver
$heap->{resolver} ||= POE::Component::Client::DNS->spawn();
### create listening socket on port 12345
$heap->{listener} ||= POE::Wheel::SocketFactory->new(
BindPort => 12345,
SuccessEvent => 'telnet_incoming',
FailureEvent => 'telnet_failure',
);
$kernel->state('telnet_incoming', 'Bot');
$kernel->state('telnet_failure', 'Bot');
### and more states to handle traffic to/from the clients
$kernel->state('telnet_speaks', 'Bot');
$kernel->state('telnet_closing', 'Bot');
$kernel->state('say_telnet_clients', 'Bot');
$kernel->state('set_telnet_timeout', 'Bot');
$kernel->state('channel_message', 'Bot');
### default idle time
$heap->{Idletime} = 5*60;
### setup UDP listener on port 53
if ( ! $heap->{dnsrw} ) {
my $dns_socket = IO::Socket::INET->new(
Proto => "udp",
LocalPort => 53,
)
or die "Cannot create socket: $!\n";
my $sockname = $dns_socket->sockname;
my($port, $inet) = sockaddr_in($sockname);
print "Listening on ", inet_ntoa($inet), ":$port/udp\n";
$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',
);
}
### register extra states for incoming DNS
$kernel->state('dns_incoming', 'Bot');
$kernel->state('dns_err', 'Bot');
return $self;
}
### hash containing all connected telnet sessions
my %telnet_clients;
### method invoked on Bot object
sub handle {
my($self, $dest, $prefix, $what) = @_;
my $heap = $self->{Heap};
my $kernel = $self->{Kernel};
### get list of valid Net::DNS::RR types
my @rr = keys %Net::DNS::RR::RR;
my $rr_regex = join("|", @rr);
### how to send back replies: using a postback
my $session = $kernel->get_active_session;
my $sendreply = $session->postback( send_reply => $dest, $prefix );
### inform telnet clients of incoming request
if ( $prefix ) {
### it's a channel message
$kernel->yield( say_telnet_clients => "Thus spoketh $prefix$what" );
} else {
### it's a private message
$kernel->yield( say_telnet_clients => "$dest tells me: $what" );
}
my $response;
if ( $what =~ /^reload$/i ) {
Module::Reload->check;
$response = "OK, I reloaded";
$self = $self->new( $kernel, $heap );
}
elsif ( $what =~ /^($rr_regex)\s+([\w.-]+)\?\s*$/ ) {
$heap->{resolver}->resolve(
type => $1,
host => $2,
event => 'dns_resolve',
context => $sendreply,
timeout => 15,
);
}
elsif ( $what =~ /^nettime\s+([\w.-]+)\??\s*$/ ) {
my $remotehost = $1;
POE::Component::Client::TCP->new(
RemoteAddress => $remotehost,
RemotePort => 'time',
Filter => 'Bot::Filter::Nettime',
ServerInput => sub {
my($time) = $_[ARG0];
my $response = "According to $remotehost, it is " .
localtime($time);
$sendreply->($response);
},
ConnectTimeout => 15,
ConnectError => sub {
my($call, $why) = @_[ARG0, ARG2];
my $response = "Doing $call to $remotehost failed: $why";
$sendreply->($response);
},
);
}
elsif ( $what =~ /^date\??\s*$/ ) {
my $wheel = POE::Wheel::Run->new(
Program => 'date',
CloseEvent => 'date_closed',
StdoutEvent => 'date_output',
);
my $wheel_id = $wheel->ID;
$heap->{Wheels}{$wheel_id} = {
Wheel => $wheel,
Sendreply => $sendreply,
};
}
elsif ( $what =~ /^Idletime\s+(\d+)\s*$/ ) {
my $idletime = $1;
$heap->{Idletime} = $idletime;
$response = "Maximum telnet idle time is now $idletime";
$kernel->yield( set_telnet_timeout => $idletime );
}
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?";
}
$sendreply->($response) if defined $response;
}
sub channel_message {
my($kernel, $heap, $str) = @_[KERNEL, HEAP, ARG0];
$heap->{Irc}->yield( privmsg => $heap->{Channel}, $str );
$kernel->yield( say_telnet_clients => $str );
}
sub send_reply {
my($kernel, $heap, $passtru, $passback) = @_[KERNEL, HEAP, ARG0, ARG1];
my($dest, $prefix) = @$passtru;
my($response) = @$passback;
$heap->{Irc}->yield( privmsg => $dest, "$prefix$response" );
$kernel->yield( say_telnet_clients => "Telling $dest: $prefix$response" );
}
### a POE state: called when a question from irc is resolved
sub dns_resolve {
my($kernel, $heap, $response) = @_[KERNEL, HEAP, ARG0];
my $sendreply = $response->{context};
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;
$sendreply->( "$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;
$sendreply->($astr);
}
}
else {
my $err = $response->{error};
$sendreply->( "Cannot find $type records for $host: $err" );
}
}
sub date_closed {
my($heap, $wheel_id) = @_[HEAP, ARG0];
delete $heap->{Wheels}{$wheel_id};
return;
}
sub date_output {
my($heap, $str, $wheel_id) = @_[HEAP, ARG0, ARG1];
$str =~ s/\r?\n//g;
my $sendreply = $heap->{Wheels}{$wheel_id}{Sendreply};
$sendreply->($str);
return;
}
sub telnet_failure {
my($what, $why) = @_[ARG0, ARG2];
warn "Incoming connection $what failed: $why\n";
}
sub telnet_incoming {
my($kernel, $heap, $socket, $remote_addr, $remote_port) =
@_[KERNEL, HEAP, ARG0, ARG1, ARG2];
$remote_addr = inet_ntoa($remote_addr);
my $who = "$remote_addr:$remote_port";
my $ses = POE::Session->create(
package_states => [
'Bot::Telnet' => [ qw(_start telnet_input telnet_death say
telnet_flushed idle settimeout) ],
],
args => [ $socket, $who, $heap->{Idletime} ],
);
$telnet_clients{$who} = $ses->ID;
$kernel->yield( channel_message => "$who connects" );
}
sub telnet_closing {
my($kernel, $who) = @_[KERNEL, ARG0];
if ( $telnet_clients{$who} ) {
delete $telnet_clients{$who};
$kernel->yield( channel_message => "$who closed connection" );
}
}
sub telnet_speaks {
my($kernel, $who, $str) = @_[KERNEL, ARG0, ARG1];
$kernel->yield( channel_message => "$who says: $str" );
}
sub say_telnet_clients {
my($kernel, $str) = @_[KERNEL, ARG0];
while ( my($who, $ses) = each %telnet_clients ) {
$kernel->post( $ses, say => $str );
}
}
sub set_telnet_timeout {
my($kernel, $timeout) = @_[KERNEL, ARG0];
while ( my($who, $ses) = each %telnet_clients ) {
$kernel->post( $ses, settimeout => $timeout );
}
}
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;
$kernel->yield( channel_message => $msg );
}
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::Telnet;
use POE;
sub _start {
my($kernel, $heap, $parent, $socket, $who, $timeout) =
@_[KERNEL, HEAP, SENDER, ARG0, ARG1, ARG2];
$heap->{socket_wheel} = POE::Wheel::ReadWrite->new(
Handle => $socket,
Filter => POE::Filter::Line->new,
InputEvent => 'telnet_input',
ErrorEvent => 'telnet_death',
FlushedEvent => 'telnet_flushed',
);
$heap->{who} = $who;
$heap->{parent} = $parent;
$kernel->yield( say => "Welcome, $who.\n" );
$kernel->yield( settimeout => $timeout );
}
sub say {
my($heap, $str) = @_[HEAP, ARG0];
$heap->{socket_wheel}->put($str);
}
sub telnet_input {
my($kernel, $heap, $str) = @_[KERNEL, HEAP, ARG0];
$kernel->delay(idle => $heap->{timeout});
$kernel->post( $heap->{parent}, telnet_speaks => $heap->{who}, $str );
}
sub telnet_death {
my($kernel, $heap, $what, $why) = @_[KERNEL, HEAP, ARG0, ARG2];
warn "telnet connection from $heap->{who} $what failed: $why\n";
delete $heap->{socket_wheel};
$kernel->post( $heap->{parent}, telnet_closing => $heap->{who} );
}
sub settimeout {
my($kernel, $heap, $timeout) = @_[KERNEL, HEAP, ARG0];
$heap->{timeout} = $timeout;
$kernel->delay( idle => $timeout );
}
sub idle {
my($heap) = $_[HEAP];
$heap->{socket_wheel}->put( "You're idling too long! Bye!" );
$heap->{closing} = 1;
}
sub telnet_flushed {
my($kernel, $heap) = @_[KERNEL, HEAP];
if ( $heap->{closing} ) {
$kernel->yield( telnet_death => "input", 0, "Idle too long" );
}
}
package Bot::Filter::Nettime;
use POE::Filter;
our @ISA = 'POE::Filter';
sub new {
my $class = shift;
my $self = { buffer => '' };
bless $self, $class;
}
sub get {
my($self, $data) = @_;
for my $d ( @$data ) {
$self->{buffer} .= $d;
}
my @ret;
while ( length $self->{buffer} >= 4 ) {
my $nettime_pkt = substr($self->{buffer}, 0, 4, '');
### rfc868 (nettime) returns seconds since 1-jan-1900.
### so we need to substract number of seconds before unix epoch,
### 1-jan-1970: 70 years, and 17 leap days, or: (70*365+17)*86400
push @ret, unpack("N", $nettime_pkt) - (70*365+17)*86400;
}
return \@ret;
}
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;