source: trunk/DNSDB.pm@ 4

# dns/trunk/DNSDB.pm
# Abstraction functions for DNS administration
###
# SVN revision info
# $Date: 2009-08-31 20:16:27 +0000 (Mon, 31 Aug 2009) $
# SVN revision $Rev: 4 $
# Last update by $Author: kdeugau $
###
# Copyright (C) 2008 - Kris Deugau <kdeugau@deepnet.cx>

package DNSDB;

use strict;
use warnings;
use Exporter;
use DBI;
#use Net::SMTP;
#use NetAddr::IP qw( Compact );
#use POSIX;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

$VERSION        = 0.1;
@ISA            = qw(Exporter);
@EXPORT_OK      = qw(
        &initGlobals &connectDB &finish &addDomain &delDomain &domainName &getSOA &getRecLine &getDomRecs
        &addRec &delRec &domStatus
        %typemap %reverse_typemap
        );

@EXPORT         = (); # Export nothing by default.
%EXPORT_TAGS    = ( ALL => [qw(
                &initGlobals &connectDB &finish &addDomain &delDomain &domainName &getSOA &getRecLine &getDomRecs
                &addRec &delRec &domStatus
                %typemap %reverse_typemap
                )]
        );

our $group = 1;
our $errstr = '';

# Halfway sane defaults for SOA, TTL, etc.
our %def = qw (
        contact hostmaster.DOMAIN
        prins   ns1.myserver.com
        soattl  86400
        refresh 10800
        retry   3600
        expire  604800
        minttl  10800
        ttl     10800
);

# DNS record type map and reverse map.
# loaded from the database, from http://www.iana.org/assignments/dns-parameters
our %typemap;
our %reverse_typemap;

##
## Initialization and cleanup subs
##

## DNSDB::connectDB()
# Creates connection to DNS database.
# Requires the database name, username, and password.
# Returns a handle to the db.
# Set up for a PostgreSQL db;  could be any transactional DBMS with the
# right changes.
sub connectDB {
  $errstr = '';
  my ($dbname,$user,$pass) = @_;
  my $dbh;
  my $DSN = "DBI:Pg:dbname=$dbname";

  my $host = shift;
  $DSN .= ";host=$host" if $host;

# Note that we want to autocommit by default, and we will turn it off locally as necessary.
# We may not want to print gobbledygook errors;  YMMV.  Have to ponder that further.
  $dbh = DBI->connect($DSN, $user, $pass, {
        AutoCommit => 1,
        PrintError => 0
        })
    or return (undef, $DBI::errstr) if(!$dbh);

# Return here if we can't select.  Note that this indicates a
# problem executing the select.
  my $sth = $dbh->prepare("select group_id from groups limit 1");
  $sth->execute();
  return (undef,$DBI::errstr) if ($sth->err);

# See if the select returned anything (or null data).  This should
# succeed if the select executed, but...
  $sth->fetchrow();
  return (undef,$DBI::errstr)  if ($sth->err);

  $sth->finish;

# If we get here, we should be OK.
  return ($dbh,"DB connection OK");
} # end connectDB


## DNSDB::finish()
# Cleans up after database handles and so on.
# Requires a database handle
sub finish {
  my $dbh = $_[0];
  $dbh->disconnect;
} # end finish


## DNSDB::initGlobals()
# Initialize global variables
# NB: this does NOT include web-specific session variables!
# Requires a database handle
sub initGlobals {
  my $dbh = shift;

# load system-wide site defaults and things from config file
  open SYSDEFAULTS, "</etc/dnsdb.conf";
##fixme - error check!
  while (<SYSDEFAULTS>) {
    next if /^\s*#/;
    $def{contact}       = $1 if /contact ?= ?([a-z0-9_.-]+)/i;
    $def{prins}         = $1 if /prins ?= ?([a-z0-9_.-]+)/i;
    $def{soattl}        = $1 if /soattl ?= ?([a-z0-9_.-]+)/i;
    $def{refresh}       = $1 if /refresh ?= ?([a-z0-9_.-]+)/i;
    $def{retry}         = $1 if /retry ?= ?([a-z0-9_.-]+)/i;
    $def{expire}        = $1 if /expire ?= ?([a-z0-9_.-]+)/i;
    $def{minttl}        = $1 if /minttl ?= ?([a-z0-9_.-]+)/i;
    $def{ttl}           = $1 if /ttl ?= ?([a-z0-9_.-]+)/i;
##fixme?  load DB user/pass from config file?
  }
# load from database
  my $sth = $dbh->prepare("select val,name from rectypes");
  $sth->execute;
  while (my ($recval,$recname) = $sth->fetchrow_array()) {
    $typemap{$recval} = $recname;
    $reverse_typemap{$recname} = $recval;
  }
} # end initGlobals


##
## Processing subs
##

## DNSDB::addDomain()
# Add a domain
# Takes a database handle, domain name, numeric group, and boolean(ish) state (active/inactive)
# Returns a status code and message
sub addDomain {
  $errstr = '';
  my $dbh = shift;
  return ('FAIL',"Need database handle") if !$dbh;
  my $domain = shift;
  return ('FAIL',"Need domain") if !defined($domain);
  my $group = shift;
  return ('FAIL',"Need group") if !defined($group);
  my $state = shift;
  return ('FAIL',"Need domain status") if !defined($state);

  my $dom_id;

  # Allow transactions, and raise an exception on errors so we can catch it later.
  # Use local to make sure these get "reset" properly on exiting this block
  local $dbh->{AutoCommit} = 0;
  local $dbh->{RaiseError} = 1;

  # Wrap all the SQL in a transaction
  eval {
    # insert the domain...
    my $sth = $dbh->prepare("insert into domains (domain,group_id,status) values (?,?,?)");
    $sth->execute($domain,$group,$state);

    # get the ID...
    $sth = $dbh->prepare("select domain_id from domains where domain='$domain'");
    $sth->execute;
    ($dom_id) = $sth->fetchrow_array();

    # ... and now we construct the standard records from the default set.  NB:  group should be variable.
    $sth = $dbh->prepare("select host,type,val,distance,weight,port,ttl from default_records where group_id=$group");
    my $sth_in = $dbh->prepare("insert into records (domain_id,host,type,val,distance,weight,port,ttl)".
        " values ($dom_id,?,?,?,?,?,?,?)");
    $sth->execute;
    while (my ($host,$type,$val,$dist,$weight,$port,$ttl) = $sth->fetchrow_array()) {
      $host =~ s/DOMAIN/$domain/g;
      $sth_in->execute($host,$type,$val,$dist,$weight,$port,$ttl);
    }

    # once we get here, we should have suceeded.
    $dbh->commit;
  }; # end eval

  if ($@) {
    my $msg = $@;
    eval { $dbh->rollback; };
    return ('FAIL',$msg);
  } else {
    return ('OK',$dom_id);
  }
} # end addDomain


## DNSDB::delDomain()
# Delete a domain.
# for now, just delete the records, then the domain.
# later we may want to archive it in some way instead (status code 2, for example?)
sub delDomain {
  my $dbh = shift;
  my $domain = shift;

  # Allow transactions, and raise an exception on errors so we can catch it later.
  # Use local to make sure these get "reset" properly on exiting this block
  local $dbh->{AutoCommit} = 0;
  local $dbh->{RaiseError} = 1;

  # Wrap all the SQL in a transaction
  eval {
    # brute force.
    my $sth = $dbh->prepare("select domain_id from domains where domain=?");
    $sth->execute($domain);
    die "Domain not found, can't delete\n" if $sth->rows < 1;
    my ($id) = $sth->fetchrow_array;

    $sth = $dbh->prepare("delete from records where domain_id=$id");
    $sth->execute;
    $sth = $dbh->prepare("delete from domains where domain=?");
    $sth->execute($domain);

    # once we get here, we should have suceeded.
    $dbh->commit;
  }; # end eval

  if ($@) {
    my $msg = $@;
    eval { $dbh->rollback; };
    return ('FAIL',$msg);
  } else {
    return ('OK','OK');
  }

} # end delDomain()


## DNSDB::domainName()
# Return the domain name based on a domain ID
# Takes a database handle and the domain ID
# Returns the domain name or undef on failure
sub domainName {
  $errstr = '';
  my $dbh = shift;
  my $domid = shift;
  my $sth = $dbh->prepare("select domain from domains where domain_id=?");
  $sth->execute($domid);
  my ($domname) = $sth->fetchrow_array();
  $errstr = $DBI::errstr if !$domname;
  return $domname if $domname;
} # end domainName


## DNSDB::editRecord()
# Change an existing record
# Takes a database handle, default/live flag, record ID, and new data and updates the data fields for it
sub editRecord {
  $errstr = '';
  my $dbh = shift;
  my $defflag = shift;
  my $recid = shift;
  my $host = shift;
  my $address = shift;
  my $distance = shift;
  my $weight = shift;
  my $port = shift;
  my $ttl = shift;
}


## DNSDB::getSOA()
# Return all suitable fields from an SOA record in separate elements of a hash
# Takes a database handle, default/live flag, and group (default) or domain (live) ID
sub getSOA {
  $errstr = '';
  my $dbh = shift;
  my $def = shift;
  my $id = shift;
  my %ret;

  my $sql = "select record_id,host,val,ttl from";
  if ($def eq 'def' or $def eq 'y') {
    $sql .= " default_records where group_id=$id and type=$reverse_typemap{SOA}";
  } else {
    # we're editing a live SOA record;  find based on domain
    $sql .= " records where domain_id=$id and type=$reverse_typemap{SOA}";
  }
#print "getSOA DEBUG: $sql<br>\n";
  my $sth = $dbh->prepare($sql);
  $sth->execute;

  my ($recid,$host,$val,$ttl) = $sth->fetchrow_array();
  my ($prins,$contact) = split /:/, $host;
  my ($refresh,$retry,$expire,$minttl) = split /:/, $val;

  $ret{recid}   = $recid;
  $ret{ttl}     = $ttl;
  $ret{prins}   = $prins;
  $ret{contact} = $contact;
  $ret{refresh} = $refresh;
  $ret{retry}   = $retry;
  $ret{expire}  = $expire;
  $ret{minttl}  = $minttl;

  return %ret;
} # end getSOA()


## DNSDB::getRecLine()
# Return all data fields for a zone record in separate elements of a hash
# Takes a database handle, default/live flag, and record ID
sub getRecLine {
  $errstr = '';
  my $dbh = shift;
  my $def = shift;
  my $id = shift;

  my $sql = "select record_id,host,type,val,distance,weight,port,ttl from ".
        (($def eq 'def' or $def eq 'y') ? 'default_' : '').
        "records where record_id=$id";
print "MDEBUG: $sql<br>\n";
  my $sth = $dbh->prepare($sql);
  $sth->execute;

  my ($recid,$host,$rtype,$val,$distance,$weight,$port,$ttl) = $sth->fetchrow_array();

  if ($sth->err) {
    $errstr = $DBI::errstr;
    return undef;
  }
  my %ret;
  $ret{recid}   = $recid;
  $ret{host}    = $host;
  $ret{type}    = $rtype;
  $ret{val}     = $val;
  $ret{distance}= $distance;
  $ret{weight}  = $weight;
  $ret{port}    = $port;
  $ret{ttl}     = $ttl;

  return %ret;
}


##fixme: should use above (getRecLine()) to get lines for below?
## DNSDB::getDomRecs()
# Return records for a domain
# Takes a database handle, default/live flag, group/domain ID, start,
# number of records, sort field, and sort order
# Returns a reference to an array of hashes
sub getDomRecs {
  $errstr = '';
  my $dbh = shift;
  my $type = shift;
  my $id = shift;
  my $nrecs = shift || 'all';
  my $nstart = shift || 0;

## for order, need to map input to column names
  my $order = shift || 'host';

  my $sql = "select record_id,host,type,val,distance,weight,port,ttl from";
  if ($type eq 'def' or $type eq 'y') {
    $sql .= " default_records where group_id=$id";
  } else {
    $sql .= " records where domain_id=$id";
  }
  $sql .= " and not type=$reverse_typemap{SOA} order by $order";
  $sql .= " limit $nrecs offset $nstart" if $nstart ne 'all';

  my $sth = $dbh->prepare($sql);
  $sth->execute;

  my @retbase;
  while (my $ref = $sth->fetchrow_hashref()) {
    push @retbase, $ref;
  }

  my $ret = \@retbase;
  return $ret;
} # end getDomRecs()


## DNSDB::addRec()
# Add a new record to a domain or a group's default records
# Takes a database handle, default/live flag, group/domain ID,
# host, type, value, and TTL
# Some types require additional detail: "distance" for MX and SRV,
# and weight/port for SRV
# Returns a status code and detail message in case of error
sub addRec {
  $errstr = '';
  my $dbh = shift;
  my $defrec = shift;
  my $id = shift;

  my $host = shift;
  my $rectype = shift;
  my $val = shift;
  my $ttl = shift;

  my $fields = ($defrec eq 'y' ? 'group_id' : 'domain_id').",host,type,val,ttl";
  my $vallist = "$id,'$host',$rectype,'$val',$ttl";

  my $dist;
  if ($rectype == $reverse_typemap{MX} or $rectype == $reverse_typemap{SRV}) {
    $dist = shift;
    return ('FAIL',"Need distance for $typemap{$rectype} record") if !defined($dist);
    $fields .= ",distance";
    $vallist .= ",$dist";
  }
  my $weight;
  my $port;
  if ($rectype == $reverse_typemap{SRV}) {
    $weight = shift;
    $port = shift;
    return ('FAIL',"Need weight and port for SRV record") if !defined($weight) or !defined($port);
    $fields .= ",weight,port";
    $vallist .= ",$weight,$port";
  }

  my $sql = "insert into ".($defrec eq 'y' ? 'default_' : '')."records ($fields) values ($vallist)";
# something is bugging me about this...
print "DEBUG: $sql<br>\n";
  my $sth = $dbh->prepare($sql);
  $sth->execute;

  return ('FAIL',$sth->errstr) if $sth->err;

  return ('OK','OK');
} # end addRec()


## DNSDB::delRec()
# Delete a record.  
sub delRec {
  $errstr = '';
  my $dbh = shift;
  my $defrec = shift;
  my $id = shift;

  my $sth = $dbh->prepare("delete from ".($defrec eq 'y' ? 'default_' : '')."records where record_id=?");
  $sth->execute($id);

  return ('FAIL',$sth->errstr) if $sth->err;

  return ('OK','OK');
} # end delRec()


## DNSDB::domStatus()
# Sets and/or returns a domain's status
# Takes a database handle, domain ID and optionally a status argument
# Returns undef on errors.
sub domStatus {
  my $dbh = shift;
  my $id = shift;
  my $newstatus = shift;

  return undef if $id !~ /^\d+$/;

  my $sth;

# ooo, fun!  let's see what we were passed for status
  if ($newstatus) {
    $sth = $dbh->prepare("update domains set status=? where domain_id=?");
    # ass-u-me caller knows what's going on in full
    if ($newstatus =~ /^[01]$/) {       # only two valid for now.
      $sth->execute($newstatus,$id);
    } elsif ($newstatus =~ /^domo(?:n|ff)$/) {
      $sth->execute(($newstatus eq 'domon' ? 1 : 0),$id);
    }
  }

  $sth = $dbh->prepare("select status from domains where domain_id=?");
  $sth->execute($id);
  my ($status) = $sth->fetchrow_array;
  return $status;
} # end domStatus()


# shut Perl up
1;