#!/usr/bin/perl -w
#
# blackberries - A multiplexer for DNS-based blacklists
#
# Copyright 1998,1999 by River of Stars, LLC
# All rights reserved.
#
# Automatic licensing for this software is available.  This software
# can be copied and used under the terms of the GNU Public License,
# version 1 or (at your option) any later version, or under the
# terms of the Artistic license.  Both of these can be found with
# the Perl distribution, which this software is intended to augment.
#
# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# ----------------------------------------------------------------------
# blackberries is:
#  A very simple (brain-dead) DNS server
#   Listens to UDP only
#   Handles one connection at a time only
#   Deals with 'A' RRs only
#   Authoritative for any lookups it's asked for
#  A very simple DNS resolver
#   Queries a list of DNS-based blacklist (RBL-like)
#   Queries a pattern blacklist service (EDUL-like)
#   Returns 'A' RR of 127.0.0.2 if any blacklist says it contains the
#    offending IP
#  Apparently runnable on Mac OS (Mac Perl 5.20r4 tested), OpenBSD
#   (Perl 5.004 tested) and Solaris (Perl 5.004 tested)
#
# How it works:
#  blackberries listens for DNS queries for the addresses of
#   RBL-like reverse IP names, e.g., for lookups of
#   names like "12.230.250.208.rbl.domain.tld"
#   (You must set up NS delegation to your blackberries server
#   for the domain 'rbl.domain.tld'.  If you don't understand this,
#   visit http://maps.vix.com/rbl/ and read until you do.)
#  If any of the blacklists to which blackberries passes the lookup
#   return an address of 127.0.0.2, blackberries returns an address
#   of 127.0.0.2 to whoever asked it about the name.
#
# To Do (in relative order of interest):
#   Support EDUL
#   Properly detect and report "format" and "not implemented" errors
#   Taint checks and cleanup - code is probably too insecure to run as
#    root on UNIX boxes
#   Allow requests only from specific IP ranges (private service) -
#    return "you smell bad" error for others who query it
#   Port Net::UDP (from Net-ext) to Mac Perl, and use it for our UDP
#    socket stuff
#   Port Net::DNS to Mac Perl, maybe extend it with a new Net::DNServer,
#    and use it instead of our brain-dead routines
#   Add optional syslog submission, rather than spewing everything to
#    STDOUT
#   Use a multi-threaded DNS server on Mac OS and a forking DNS server
#    on UNIX systems
#   Check returned IP address, and do different things depending on
#    whether it's 127.0.0.2, 127.0.0.3, etc. or an unrecognized IP
#
# ----------------------------------------------------------------------

# version history
# 0.00 - 1998-11-10 intial prototype
# 0.01 - 1998-11-11 working socket code with dummy lookups and responses
# 0.02 - 1998-11-13 rewrote name extraction and added real responses
# 0.03 - 1998-11-15 added exceptions
# 0.04 - 1998-11-20 built Mac Perl runtime, first public disclosure
# 0.05 - 1998-12-28 implemented config file
$version = 0.05;


use Socket;
#use Net::UDP;
#use Net::DNS;
#use Net::DNS::Resolver;
#use Sys::Hostname;


# constants
# 
# DNS message format info pulled from http://www.crynwr.com/crynwr/rfc1035/
# sizes
$PACKETSZ = 512;    # DNS UDP packets are 512 bytes long
$HEADERSZ = 12;     # header section is 12 bytes
#$QSZ = 4;
#$RRSZ = 10;
# classes
$CLASSANY = 256;    # query class for 'Anything'
$CLASSINET = 1;     # query class for Internet
# types
$TYPEA = 1;         # query type for A RR
$TYPEANY = 0;       # query type for 'Anything'
# flag masks and shifts
$QRMASK = 0x8000;   # '1000 0000 0000 0000' QR - Query 0 or response 1
$QRSHFT = 15;       # 'x543 2109 8765 4321' shift 15 bits right to normalize QR
$OPMASK = 0x7800;   # '0111 1000 0000 0000' OPCODE - Type of query
$OPSHFT = 11;       # 'xxxx x109 8765 4321' shift 11 bits right to normalize QR
$AAMASK = 0x0400;   # '0000 0100 0000 0000' AA - Authoritative Answer bit
#$AASHFT = 10;      # 'xxxx xx09 8765 4321' shift 10 bits right to normalize AA
#$TCMASK = 0x0200;  # '0000 0010 0000 0000' TC - TrunCation bit
#$TCSHFT = 9;       # 'xxxx xxx9 8765 4321' shift 9 bits right to normalize TC
#$RDMASK = 0x0100;  # '0000 0001 0000 0000' RD - Recursion Desired bit
#$RDSHFT = 8;       # 'xxxx xxxx 8765 4321' shift 8 bits right to normalize RD
#$RAMASK = 0x0080;  # '0000 0000 1000 0000' RA - Recursion Available bit
#$RASHFT = 7;       # 'xxxx xxxx x765 4321' shift 7 bits right to normalize RA
#$ZZMASK = 0x0070;  # '0000 0000 0111 0000' Reserved
#$RCMASK = 0x000f;  # '0000 0000 0000 1111' RCODE - Response code
# opcodes
$QUERY = 0;         # standard query
$IQUERY = 1;        # inverse query
# response codes
$NOERROR = 0;       # no error condition
#$FORMATERR = 1;        # query was uninterpretable
#$SERVFAIL = 2;     # lookup failed due to problem with the server
$NXDOMAIN = 3;      # no such host or domain - lookup failed authoritatively
#$NOTIMPL = 4;      # query type not supported
#$REFUSED = 5;      # server doesn't like the way you smell - go away

# we're talking UDP DNS (UDP port 53)
my $port = 53;
my $proto = getprotobyname ('udp');

# no confusion about network line termination allowed
#$cr = "\015";
#$lf = "\012";
#$/ = $crlf = "$cr$lf";
## avoid warning in case we don't use $crlf anywhere for real yet
#$usingcrlf = FALSE; if ( $usingcrlf ) { print $crlf; }


sub log_message {
#   print scalar localtime, " $0 $$: @_\n";
    print scalar localtime, " @_\n";
}

sub answer_request {
    local (*buffer) = @_;
    my $ptr = 0;
    
    # check for runt, bail if we've been handed a shortie
    if ( ($len = length ($buffer)) <= $HEADERSZ ) {
        log_message "error: answer_request - BAILING with a runt of length: $len" if $ERRORS;
        return 0;
    }
    
    # cut into request to get at header and body
    $header = substr ($buffer, 0, $HEADERSZ);
    $body = substr ($buffer, $HEADERSZ);
    
    # decompose header
    ($id, $flags, $qdcount, $ancount, $nscount, $arcount) = unpack ("n6 C*", $header);
    log_message "debug: answer_request - header info - ID: $id, flags: $flags, counts: $qdcount, $ancount, $nscount, $arcount" if $DEBUG;

    # pull out the values of the flags we care about
    $qr = ($flags & $QRMASK) >> $QRSHFT;
    $op = ($flags & $OPMASK) >> $OPSHFT;
    log_message "debug: answer_request - flag info - qr: $qr, opcode: $op" if $DEBUG;
    # is it a query?  if not ($qr is 1 to indicate it's a response), dry up and blow away
    if ( $qr ) {
        log_message "error: answer_request - BAILING with bad query status: $qr" if $ERRORS;
        return 0;
    }
    # is it a standard query?  if not ($op is anything but 0), dry up and blow away
    if ( ! ($op == $QUERY) || ($op == $IQUERY) ) {
        log_message "error: answer_request - BAILING with bad opcode: $op" if $ERRORS;
        return 0;
    }
    # does it say it contains at least 1 query?  if not, dry up and blow away
    if ( $qdcount < 1 ) {
        log_message "error: answer_request - BAILING with bad qdcount: $qdcount" if $ERRORS;
        return 0;
    }
    # we ignore the other header item counts.  if they are set, something is probably wrong, but we deliberately won't care (we're brain-dead)
    
    # inflate the name, returning only the first query
    ($qname, $qtype, $qclass, $ptr) = &inflate_name (*body, 0);
    log_message "debug: answer_request - name info - name: $qname, type: $qtype, class: $qclass" if $DEBUG;

    # is the class "Internet" or "any"?  if not, dry up and blow away
    if ( ($qclass != $CLASSANY) && ($qclass != $CLASSINET) ) {
        log_message "error: answer_request - BAILING with bad class: $qclass" if $ERRORS;
        return 0;
    }
    # is it a request for an A RR or for 'any' RR available?  if so, look it up and return the results.
    if ( ($qtype == $TYPEA) || ($qtype == $TYPEANY) ) {
        ($black, $forwardname) = &lookup_name ($qname);
        if ( (! $black) && $VERBOSE ) {
            if ( $forwardname ) {
                log_message "clean IP: $forwardname";
            } else {
                log_message "clean failure - No lookup done for: $qname";
            }
        }
        $packet = &build_response ($id, $flags, $black, $qdcount, $body);
        return $packet;
    }
    return 0;
}

sub inflate_name {
# expand the host name in the DNS query
#
    local (*query, $offset) = @_;
    my $querylength = length ($query);
    my ($qt, $qc, $length, $label);
    my $qn = '';
    
    if ( ($offset + 1) > $querylength ) {   # check for packet truncation
        return (0, 0, 0, $offset);
    }
    # walk through labels, appending each to the name, until we find a
    # null length
    while ( $length = unpack ("\@$offset C", $query) ) {
        # NOTE - this code does not handle pointers (length 0xc0,
        # also known as INDIRMASK)
        $offset++;
        if ( ($offset + $length) > $querylength ) { # check for packet truncation
            return (0, 0, 0, $offset);
        }
        $label = substr ($query, $offset, $length); # pull out the label
        $label =~ s/\./\\./g;   # escape any dots in the label (do some resolvers send one label with dots in it?)
        $qn .= "$label.";   # append the label to the growing name, with a trailing dot
        $offset += $length; # skip to the next length
    }
    $qn =~s/\.$//;  # chop any trailing dot left over from the last label append
    ($qt ,$qc) = unpack ("n n", substr($query, $offset, 4));    # what remains in the query is the type and class
    
    return ($qn, $qt, $qc, $offset);    # send back even the new offset, though we don't use the new offset anywhere (yet)
}

sub lookup_name {
# look up the host name in all our configured blacklists
#
    my ($name) = @_;
    
    # we only serve our own domain, not those created by resolvers glomming domain search path extensions onto them
    if ( ! ($name =~ m/$OURRBLMUXDOM$/) ) {
        log_message "error: lookup_name - lookup $name does not end in our domain $OURRBLMUXDOM" if $ERRORS;
        return (0, '');
    }
    $name =~ s/$OURRBLMUXDOM.*$//i; # nuke our mux domain from the name to leave just the octets
    # pull out the reverse IP on which we're going to multiplex our lookups.  there must be exactly four octets
    @ddoctets = split /\./, $name;
    $name = join ('.', @ddoctets);
    $forwardname = join ('.', reverse (@ddoctets));
    log_message "debug: lookup_name - lookup on: $forwardname" if $DEBUG;
    if ( ($numoctets = @ddoctets) != 4) {
        log_message "error: lookup_name - BAILING with address $forwardname containing $numoctets octets, not 4 octets" if $ERRORS;
        return (0, $forwardname);
    }
    
    # check for whether we want to make an exception for this IP address
    if ( $EXCEPTIONS =~ m/$forwardname/ ) {
        log_message "EXCEPTION: $forwardname" if $VERBOSE;
        return (0, $forwardname);
    }
    
    # check each of the blacklists
    foreach $list (@BLACKLISTDOMAINS) {
        $rql = join ('.', $name, $list);    # build the reverse query name for this blacklist
        $addr = gethostbyname ($rql);   # look up address only - scalar context
        if ( $addr ) {
            # it's blacklisted - we got ourselves a live one, so further lookups in remaining lists are pointless
            $blackIP = join ('.', unpack ("C4", $addr));
            log_message "BLACKLISTED: $forwardname => $blackIP at $list" if $VERBOSE;
            return ($addr, $forwardname);
            # NOTE - we just assumed any A return is a blacklisting.  this
            # can be considered a bug.
        } else {
            log_message "debug: lookup_name - $list: IP clean (or lookup failed)" if $DEBUG;
        }
    }
    return (0, $forwardname);
}

sub build_response {
# create a response for the querying host
#
    my ($id, $flags, $addr, $qdcount, $qbody) = @_;
    
    # We didn't bother to get the TTL from the blacklist, so we
    # will assume something like 1 hr (3600 sec)
    $TTL = 3600;
    
    # set up flags, leaving opcode, truncation, recursion desired, and z alone (but we should probably zero z and recursion - fix later)
    $flags |= $QRMASK;  # it's a response
    $flags |= $AAMASK;  # we are always authoritative for our lookups
#   $flags |= ?     # make sure we don't say recursion is available

    # build the response A rec if necessary, and set the appropriate return code according to whether the lookup succeeded or not
    if ( $addr ) {
        $ancount = 1;   # we always give one answer
        $rdlength = 4;  # addresses are 4 bytes
        $rr = pack ("nnnNn", 0xc00c, $TYPEA, $CLASSINET, $TTL, $rdlength);
        $rr = join ('', $rr, $addr);    # stuff it all together
        $flags |= $NOERROR;
    } else {
        $ancount = 0;
        undef $rr;
        $flags |= $NXDOMAIN;
    }
#   if ( $DEBUG ) {
#       $qrR = ($flags & $QRMASK) >> $QRSHFT;
#       $aaR = ($flags & $AAMASK) >> $AASHFT;
#       $rcR = ($flags & $RCMASK);
#       log_message "build_response - header sanity check - ID: $id, qrR: $qrR, aaR: $aaR, rcR: $rcR, qdcount: $qdcount, ancount: $ancount, nscount: $nscount, arcount: $arcount"
#   }

    # build the response header
    $nscount = $arcount = 0;
    $header = pack ("nnnnnn", $id, $flags, $qdcount, $ancount, $nscount, $arcount);
    
    # add the rest to the packet
    $packet = join ('', $header, $qbody);
    if ( $rr ) {
        $packet = join ('', $packet, $rr);
    }
    
    return ($packet);
}


# set some defaults
$OURRBLMUXDOM = "rbl.ourdomain.tld";
@BLACKLISTDOMAINS = ("rbl.maps.vix.com", "dul.orca.bc.ca");
$EXCEPTIONS = "";
$ERRORS = 1;
$VERBOSE = 1;
$DEBUG = 0;

# read the config file
open (CONFIG, "<blackberries.conf") or die "conf file open failure: $!";
while (<CONFIG>) {
    next if /^#/;
    next if /^$/;
    chop;
    eval;   
}
close CONFIG;

# fire up the network listener
socket (Server, AF_INET, SOCK_DGRAM, $proto) or die "receiving socket failure: $!";
setsockopt (Server, SOL_SOCKET, SO_REUSEADDR, 1);
bind (Server, pack_sockaddr_in ($port, INADDR_ANY)) or die "receiving bind failure: $!";

log_message "$0\n\tserver version $version started on port $port";

my $paddr;
my $rout;
#my $myiaddr = gethostbyname (hostname());
my $myiaddr = gethostbyname ('localhost');
my $mypaddr;

# listen forever
until ( 0 ) {
    $rin=''; 
    vec($rin,fileno(Server),1) = 1;
    $nfound = select ($rout=$rin, undef, undef, undef);
    if ( $nfound > 0 ) {
        $paddr = recv (Server, $buffer, $PACKETSZ, 0) or die "Cannot receive: $!";
        
        my ($rport, $iaddr) = unpack_sockaddr_in ($paddr);
        my $name = gethostbyaddr ($iaddr, AF_INET);
        my $hname = inet_ntoa ($iaddr);
        log_message "connection from $name [$hname:$rport]" if $VERBOSE;
        
        $response = &answer_request (*buffer);
        if ( $response ) {
            # pick a sending address/port
            $mypaddr = pack_sockaddr_in ($port, $myiaddr);
            if ( $DEBUG ) {
                my ($myport, $myiaddr) = unpack_sockaddr_in ($mypaddr);
            }
            # spit the response packet
            defined (send (Server, $response, 0, $paddr)) or warn "Cannot send: $!";
        } else { # no $response
            # note the failure from answer_request
            log_message "error: main - BOGUS request from $name, port $port" if $ERRORS;
            # report error
            #
        }
    }
}