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;
