#!/usr/bin/perl

use Net::DNS::Nameserver;
use strict;
use warnings;
use Tie::DBI;

my %data;

my %rate;

# remove the two tie commands to turn off the need for Tie::DBI and an SQL database

tie %rate, 'Tie::DBI', {
        db => 'mysql:spf',
        table => 'rate',
        key => 'domain',
        user => 'xxx',
        password => 'xxx',
        CLOBBER => 1,
    };

my %spf_record;

tie %spf_record, 'Tie::DBI', {
        db => 'mysql:spf',
        table => 'dns',
        key => 'name',
        user => 'xxx',
        password => 'xxx',
    };

my $inv2log2 = 1 / (2 * log(2));

sub update_rate {
    my ($rate, $period) = @_;

    my $old = time - $rate->{last_update};

    if ($old) {
        $rate->{last_update} = time;
        $rate->{'rate'} *= 2 ** (-$old / $period);
    }
}

sub getit {
    my ($amt, $name) = @_;

    return $name if ($amt == 1);
    return "$amt ${name}s";
}

sub rate_handler {
    my ($base, $qname, $qclass, $qtype, $peerhost) = @_;
    my ($rcode, @ans, @auth, @add);

    my $prefix = substr($qname, 0, - length $base);

    my ($junk, $domain, $maxrate, $period) = $prefix =~ /^(\d+)\.(\S+)\.(\d+)\/(\d+)$/;

    $rcode = "NXDOMAIN";

    if ($period) {
        my $rate;
        my $key = join('.', $domain, $maxrate, $period);

        $rate = $rate{$key};
        $rate ||= { 'rate' => 0, last_update => 0};

        update_rate($rate, $period);

        if ($maxrate < $rate->{rate}) {
            my $place;
            $rcode = "NOERROR";

            $place = ($qtype eq 'A' || $qtype eq 'ANY') ? \@ans : \@add;
            push @$place, Net::DNS::RR->new(name => $qname, type => 'A', address => "127.0.0.2");
            
            $place = ($qtype eq 'TXT' || $qtype eq 'ANY') ? \@ans : \@add;
            my $periodname;
            $periodname = getit($period, "second");
            $periodname = getit($period / 60, "minute") if (($period % 60) == 0);
            $periodname = getit($period / 3600, "hour") if (($period % 3600) == 0);
            $periodname = getit($period / 86400, "day") if (($period % 86400) == 0);
            push @$place, Net::DNS::RR->new(name => $qname, type => 'TXT', char_str_list => [ "Exceeded the message rate of $maxrate per $periodname" ]);
        } else {
            $rate->{rate} += $inv2log2;
            $rate{$key} = $rate;
        }
    }

# mark the answer as authoritive (by setting the 'aa' flag
    return ($rcode, \@ans, \@auth, \@add, { aa => 1 });
}

my %base = (
    '.rate.spf.gladstonefamily.net' => \&rate_handler,
);

sub reply_handler {
    my ($qname, $qclass, $qtype, $peerhost) = @_;
    my ($rcode, @ans, @auth, @add);
    my $spf;

    $rcode = "NXDOMAIN";

    if ($data{$qname}) {
        $rcode = "NOERROR";
        foreach my $rr (@{$data{$qname}}) {
            if ($qtype eq $rr->type || $qtype eq 'ANY') {
                push @ans, $rr;
            }
        }
    } elsif ($spf = $spf_record{$qname}) {
        $rcode = "NOERROR";
        if ($qtype eq 'TXT' || $qtype eq 'ANY') {
            push @ans, Net::DNS::RR->new(name => $qname, ttl => 600, type => 'TXT', char_str_list => [ $spf->{spf} ]);
        }
    } else {
        foreach my $base (sort { length $b <=> $a } (keys %base)) {
            if (substr($qname, -length $base) eq $base) {
                return $base{$base}->($base, @_);
            }
        }
    }

# mark the answer as authoritive (by setting the 'aa' flag
    return ($rcode, \@ans, \@auth, \@add, { aa => 1 });
}

sub add_record {
    my ($rr)  = @_;

    push @{$data{$rr->name}}, $rr;
}

my $ns = Net::DNS::Nameserver->new(
    LocalAddr    => $ENV{IP},
    LocalPort    => 53,
    ReplyHandler => \&reply_handler,
    Verbose      => 1,
    );

#add_record(Net::DNS::RR->new("spf.gladstonefamily.net 600 IN TXT 'v=spf1 mx:gladstonefamily.net ptr:rcn.net ptr:cisco.com ?all'")); 

if ($ns) {
    $ns->main_loop;
} else {
    die "couldn't create nameserver object\n";
}