Context Navigation

source: trunk/DNSDB.pm@ 161

Last change on this file since 161 was 160, checked in by Kris Deugau, 13 years ago

/trunk

Use bind parameters in DNSDB::getDomRecs for filter
Make sure A records get an IPv4 address, and AAAA records get

a v6 address in DNSDB::addRec

Normalize and clean up handling for filtering and starts-with

common ops now done along with the rest of the global ops
filtering arguments now pushed into a global
use bind parameters in SQL (this should transfer OK to subs in DNSDB.pm later)

Add a couple new ##fixme's for scope checks
Force appending of domain or DOMAIN on record or default record

respectively, if they don't already have that at the end

Retrieve "old" info for logging record changes
Remove some stale commented fragments and ##fixme's

Property svn:keywords set to Date Rev Author Id

File size: 59.9 KB

Rev	Line
[2]	1	# dns/trunk/DNSDB.pm
	2	# Abstraction functions for DNS administration
	3	###
	4	# SVN revision info
	5	# $Date: 2011-11-02 22:12:35 +0000 (Wed, 02 Nov 2011) $
	6	# SVN revision $Rev: 160 $
	7	# Last update by $Author: kdeugau $
	8	###
	9	# Copyright (C) 2008 - Kris Deugau <kdeugau@deepnet.cx>
	10
	11	package DNSDB;
	12
	13	use strict;
	14	use warnings;
	15	use Exporter;
	16	use DBI;
[33]	17	use Net::DNS;
[65]	18	use Crypt::PasswdMD5;
[2]	19	#use Net::SMTP;
[132]	20	use NetAddr::IP;
[2]	21	#use POSIX;
	22	use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
	23
	24	$VERSION = 0.1;
	25	@ISA = qw(Exporter);
	26	@EXPORT_OK = qw(
[67]	27	&initGlobals
	28	&initPermissions &getPermissions &changePermissions &comparePermissions
[112]	29	&changeGroup
[128]	30	&loadConfig &connectDB &finish
[91]	31	&addDomain &delDomain &domainName &domainID
[22]	32	&addGroup &delGroup &getChildren &groupName
[83]	33	&addUser &updateUser &delUser &userFullName &userStatus &getUserData
[91]	34	&getSOA &getRecLine &getDomRecs &getRecCount
[22]	35	&addRec &updateRec &delRec
[117]	36	&getParents
	37	&isParent
[34]	38	&domStatus &importAXFR
[103]	39	&export
[128]	40	%typemap %reverse_typemap %config
[66]	41	%permissions @permtypes $permlist
[2]	42	);
	43
	44	@EXPORT = (); # Export nothing by default.
	45	%EXPORT_TAGS = ( ALL => [qw(
[67]	46	&initGlobals
	47	&initPermissions &getPermissions &changePermissions &comparePermissions
[112]	48	&changeGroup
[128]	49	&loadConfig &connectDB &finish
[91]	50	&addDomain &delDomain &domainName &domainID
[22]	51	&addGroup &delGroup &getChildren &groupName
[83]	52	&addUser &updateUser &delUser &userFullName &userStatus &getUserData
[91]	53	&getSOA &getRecLine &getDomRecs &getRecCount
[22]	54	&addRec &updateRec &delRec
[117]	55	&getParents
	56	&isParent
[34]	57	&domStatus &importAXFR
[103]	58	&export
[128]	59	%typemap %reverse_typemap %config
[66]	60	%permissions @permtypes $permlist
[2]	61	)]
	62	);
	63
	64	our $group = 1;
	65	our $errstr = '';
	66
	67	# Halfway sane defaults for SOA, TTL, etc.
[101]	68	# serial defaults to 0 for convenience.
	69	# value will be either YYYYMMDDNN for BIND/etc, or auto-internal for tinydns
[2]	70	our %def = qw (
	71	contact hostmaster.DOMAIN
	72	prins ns1.myserver.com
[101]	73	serial 0
[2]	74	soattl 86400
	75	refresh 10800
	76	retry 3600
	77	expire 604800
	78	minttl 10800
	79	ttl 10800
	80	);
	81
[66]	82	# Arguably defined wholly in the db, but little reason to change without supporting code changes
	83	our @permtypes = qw (
	84	group_edit group_create group_delete
	85	user_edit user_create user_delete
	86	domain_edit domain_create domain_delete
	87	record_edit record_create record_delete
	88	self_edit admin
	89	);
	90	our $permlist = join(',',@permtypes);
	91
[2]	92	# DNS record type map and reverse map.
	93	# loaded from the database, from http://www.iana.org/assignments/dns-parameters
	94	our %typemap;
	95	our %reverse_typemap;
	96
[65]	97	our %permissions;
[55]	98
[128]	99	# Prepopulate a basic config. Note some of these will cause errors if left unset.
	100	our %config = (
	101	# Database connection info
	102	dbname => 'dnsdb',
	103	dbuser => 'dnsdb',
	104	dbpass => 'secret',
	105	dbhost => '',
	106
	107	# Email notice settings
	108	mailhost => 'smtp.example.com',
	109	mailsender => 'dnsdb@example.com',
	110	mailname => 'DNS Administration',
	111
	112	# Template directory
	113	templatedir => 'templates/',
	114	# fmeh. this is a real web path, not a logical internal one. hm..
	115	# cssdir => 'templates/';
	116	);
	117
	118
[2]	119	##
	120	## Initialization and cleanup subs
	121	##
	122
[55]	123
[128]	124	## DNSDB::loadConfig()
	125	# Load the minimum required initial state (DB connect info) from a config file
	126	# Load misc other bits while we're at it.
	127	# Takes an optional basename and config path to look for
	128	# Populates the %config and %def hashes
	129	sub loadConfig {
	130	my $basename = shift \|\| ''; # this will work OK
	131
	132	my $deferr = ''; # place to put error from default config file in case we can't find either one
	133
	134	my $configroot = '/etc/dnsdb';
	135	$configroot = '' if $basename =~ m\|^/\|;
	136	$basename .= ".conf" if $basename !~ /\.conf$/;
	137	my $defconfig = "$configroot/dnsdb.conf";
	138	my $siteconfig = "$configroot/$basename";
	139
	140	# System defaults
[131]	141	__cfgload("$defconfig") or $deferr = $errstr;
[128]	142
[131]	143	# Per-site-ish settings.
	144	if ($basename ne '.conf') {
	145	unless (__cfgload("$siteconfig")) {
	146	$errstr = ($deferr ? "Error opening default config file $defconfig: $deferr\n" : '').
[128]	147	"Error opening site config file $siteconfig";
[131]	148	return;
	149	}
[128]	150	}
	151
	152	# All good, clear the error and go home.
	153	$errstr = '';
	154	return 1;
	155	} # end loadConfig()
	156
	157
	158	## DNSDB::__cfgload()
	159	# Private sub to parse a config file and load it into %config
	160	# Takes a file handle on an open config file
	161	sub __cfgload {
	162	$errstr = '';
	163	my $cfgfile = shift;
[131]	164
[128]	165	if (open CFG, "<$cfgfile") {
	166	while (<CFG>) {
	167	chomp;
	168	s/^\s*//;
	169	next if /^#/;
	170	next if /^$/;
	171	# hmm. more complex bits in this file might require [heading] headers, maybe?
	172	# $mode = $1 if /^\[(a-z)+]/;
	173	# DB connect info
	174	$config{dbname} = $1 if /^dbname\s=\s([a-z0-9_.-]+)/i;
	175	$config{dbuser} = $1 if /^dbuser\s=\s([a-z0-9_.-]+)/i;
	176	$config{dbpass} = $1 if /^dbpass\s=\s([a-z0-9_.-]+)/i;
	177	$config{dbhost} = $1 if /^dbhost\s=\s([a-z0-9_.-]+)/i;
	178	# SOA defaults
	179	$def{contact} = $1 if /^contact\s=\s([a-z0-9_.-]+)/i;
	180	$def{prins} = $1 if /^prins\s=\s([a-z0-9_.-]+)/i;
	181	$def{soattl} = $1 if /^soattl\s=\s([a-z0-9_.-]+)/i;
	182	$def{refresh} = $1 if /^refresh\s=\s([a-z0-9_.-]+)/i;
	183	$def{retry} = $1 if /^retry\s=\s([a-z0-9_.-]+)/i;
	184	$def{expire} = $1 if /^expire\s=\s([a-z0-9_.-]+)/i;
	185	$def{minttl} = $1 if /^minttl\s=\s([a-z0-9_.-]+)/i;
	186	$def{ttl} = $1 if /^ttl\s=\s([a-z0-9_.-]+)/i;
	187	# Mail settings
	188	$config{mailhost} = $1 if /^mailhost\s=\s([a-z0-9_.-]+)/i;
	189	$config{mailsender} = $1 if /^mailsender\s=\s([a-z0-9_.@-]+)/i;
	190	$config{mailname} = $1 if /^mailname\s=\s([a-z0-9\s_.-]+)/i;
	191	}
	192	close CFG;
	193	} else {
	194	$errstr = $!;
	195	return;
	196	}
	197	return 1;
	198	} # end __cfgload()
	199
	200
[2]	201	## DNSDB::connectDB()
	202	# Creates connection to DNS database.
	203	# Requires the database name, username, and password.
	204	# Returns a handle to the db.
	205	# Set up for a PostgreSQL db; could be any transactional DBMS with the
	206	# right changes.
	207	sub connectDB {
	208	$errstr = '';
[15]	209	my $dbname = shift;
	210	my $user = shift;
	211	my $pass = shift;
[2]	212	my $dbh;
	213	my $DSN = "DBI:Pg:dbname=$dbname";
	214
	215	my $host = shift;
	216	$DSN .= ";host=$host" if $host;
	217
	218	# Note that we want to autocommit by default, and we will turn it off locally as necessary.
	219	# We may not want to print gobbledygook errors; YMMV. Have to ponder that further.
	220	$dbh = DBI->connect($DSN, $user, $pass, {
	221	AutoCommit => 1,
	222	PrintError => 0
	223	})
	224	or return (undef, $DBI::errstr) if(!$dbh);
	225
	226	# Return here if we can't select. Note that this indicates a
	227	# problem executing the select.
	228	my $sth = $dbh->prepare("select group_id from groups limit 1");
	229	$sth->execute();
	230	return (undef,$DBI::errstr) if ($sth->err);
	231
	232	# See if the select returned anything (or null data). This should
	233	# succeed if the select executed, but...
	234	$sth->fetchrow();
	235	return (undef,$DBI::errstr) if ($sth->err);
	236
	237	$sth->finish;
	238
	239	# If we get here, we should be OK.
	240	return ($dbh,"DB connection OK");
	241	} # end connectDB
	242
	243
	244	## DNSDB::finish()
	245	# Cleans up after database handles and so on.
	246	# Requires a database handle
	247	sub finish {
	248	my $dbh = $_[0];
	249	$dbh->disconnect;
	250	} # end finish
	251
	252
	253	## DNSDB::initGlobals()
	254	# Initialize global variables
	255	# NB: this does NOT include web-specific session variables!
	256	# Requires a database handle
	257	sub initGlobals {
	258	my $dbh = shift;
	259
	260	# load system-wide site defaults and things from config file
[29]	261	if (open SYSDEFAULTS, "</etc/dnsdb.conf") {
[2]	262	##fixme - error check!
[29]	263	while (<SYSDEFAULTS>) {
	264	next if /^\s*#/;
	265	$def{contact} = $1 if /contact ?= ?([a-z0-9_.-]+)/i;
	266	$def{prins} = $1 if /prins ?= ?([a-z0-9_.-]+)/i;
	267	$def{soattl} = $1 if /soattl ?= ?([a-z0-9_.-]+)/i;
	268	$def{refresh} = $1 if /refresh ?= ?([a-z0-9_.-]+)/i;
	269	$def{retry} = $1 if /retry ?= ?([a-z0-9_.-]+)/i;
	270	$def{expire} = $1 if /expire ?= ?([a-z0-9_.-]+)/i;
	271	$def{minttl} = $1 if /minttl ?= ?([a-z0-9_.-]+)/i;
	272	$def{ttl} = $1 if /ttl ?= ?([a-z0-9_.-]+)/i;
[2]	273	##fixme? load DB user/pass from config file?
[29]	274	}
[2]	275	}
	276	# load from database
	277	my $sth = $dbh->prepare("select val,name from rectypes");
	278	$sth->execute;
	279	while (my ($recval,$recname) = $sth->fetchrow_array()) {
	280	$typemap{$recval} = $recname;
	281	$reverse_typemap{$recname} = $recval;
	282	}
	283	} # end initGlobals
	284
	285
[65]	286	## DNSDB::initPermissions()
	287	# Set up permissions global
	288	# Takes database handle and UID
	289	sub initPermissions {
	290	my $dbh = shift;
	291	my $uid = shift;
	292
	293	# %permissions = $(getPermissions($dbh,'user',$uid));
	294	getPermissions($dbh, 'user', $uid, \%permissions);
	295
	296	} # end initPermissions()
	297
	298
	299	## DNSDB::getPermissions()
	300	# Get permissions from DB
	301	# Requires DB handle, group or user flag, ID, and hashref.
	302	sub getPermissions {
	303	my $dbh = shift;
	304	my $type = shift;
	305	my $id = shift;
	306	my $hash = shift;
	307
	308	my $sql = qq(
	309	SELECT
	310	p.admin,p.self_edit,
	311	p.group_create,p.group_edit,p.group_delete,
	312	p.user_create,p.user_edit,p.user_delete,
	313	p.domain_create,p.domain_edit,p.domain_delete,
	314	p.record_create,p.record_edit,p.record_delete
	315	FROM permissions p
	316	);
	317	if ($type eq 'group') {
	318	$sql .= qq(
	319	JOIN groups g ON g.permission_id=p.permission_id
	320	WHERE g.group_id=?
	321	);
	322	} else {
	323	$sql .= qq(
	324	JOIN users u ON u.permission_id=p.permission_id
	325	WHERE u.user_id=?
	326	);
	327	}
	328
	329	my $sth = $dbh->prepare($sql);
	330
	331	$sth->execute($id) or die "argh: ".$sth->errstr;
	332
	333	# my $permref = $sth->fetchrow_hashref;
	334	# return $permref;
	335	# $hash = $permref;
	336	# Eww. Need to learn how to forcibly drop a hashref onto an existing hash.
	337	($hash->{admin},$hash->{self_edit},
	338	$hash->{group_create},$hash->{group_edit},$hash->{group_delete},
	339	$hash->{user_create},$hash->{user_edit},$hash->{user_delete},
	340	$hash->{domain_create},$hash->{domain_edit},$hash->{domain_delete},
	341	$hash->{record_create},$hash->{record_edit},$hash->{record_delete})
	342	= $sth->fetchrow_array;
	343
	344	} # end getPermissions()
	345
	346
	347	## DNSDB::changePermissions()
	348	# Update an ACL entry
	349	# Takes a db handle, type, owner-id, and hashref for the changed permissions.
	350	sub changePermissions {
	351	my $dbh = shift;
	352	my $type = shift;
	353	my $id = shift;
	354	my $newperms = shift;
[87]	355	my $inherit = shift \|\| 0;
[65]	356
[78]	357	my $failmsg = '';
[66]	358
[87]	359	# see if we're switching from inherited to custom. for bonus points,
	360	# snag the permid and parent permid anyway, since we'll need the permid
	361	# to set/alter custom perms, and both if we're switching from custom to
	362	# inherited.
	363	my $sth = $dbh->prepare("SELECT (u.permission_id=g.permission_id) AS was_inherited,u.permission_id,g.permission_id".
[65]	364	" FROM ".($type eq 'user' ? 'users' : 'groups')." u ".
[66]	365	" JOIN groups g ON u.".($type eq 'user' ? '' : 'parent_')."group_id=g.group_id ".
[65]	366	" WHERE u.".($type eq 'user' ? 'user' : 'group')."_id=?");
	367	$sth->execute($id);
	368
[87]	369	my ($wasinherited,$permid,$parpermid) = $sth->fetchrow_array;
[66]	370
[78]	371	# hack phtoui
	372	# group id 1 is "special" in that it's it's own parent (err... possibly.)
	373	# may make its parent id 0 which doesn't exist, and as a bonus is Perl-false.
	374	$wasinherited = 0 if ($type eq 'group' && $id == 1);
	375
[66]	376	local $dbh->{AutoCommit} = 0;
	377	local $dbh->{RaiseError} = 1;
	378
	379	# Wrap all the SQL in a transaction
	380	eval {
[87]	381	if ($inherit) {
	382
	383	$dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='t',permission_id=? ".
	384	"WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($parpermid, $id) );
	385	$dbh->do("DELETE FROM permissions WHERE permission_id=?", undef, ($permid) );
	386
	387	} else {
	388
	389	if ($wasinherited) { # munge new permission entry in if we're switching from inherited perms
[66]	390	##fixme: need to add semirecursive bit to properly munge inherited permission ID on subgroups and users
[87]	391	# ... if'n'when we have groups with fully inherited permissions.
	392	# SQL is coo
	393	$dbh->do("INSERT INTO permissions ($permlist,".($type eq 'user' ? 'user' : 'group')."_id) ".
	394	"SELECT $permlist,? FROM permissions WHERE permission_id=?", undef, ($id,$permid) );
	395	($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions ".
	396	"WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($id) );
	397	$dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='f',permission_id=? ".
	398	"WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($permid, $id) );
[66]	399	}
[78]	400
[87]	401	# and now set the permissions we were passed
	402	foreach (@permtypes) {
	403	if (defined ($newperms->{$_})) {
	404	$dbh->do("UPDATE permissions SET $_=? WHERE permission_id=?", undef, ($newperms->{$_},$permid) );
	405	}
	406	}
	407
	408	} # (inherited->)? custom
	409
[66]	410	$dbh->commit;
	411	}; # end eval
	412	if ($@) {
	413	my $msg = $@;
	414	eval { $dbh->rollback; };
[87]	415	return ('FAIL',"$failmsg: $msg ($permid)");
[66]	416	} else {
	417	return ('OK',$permid);
	418	}
	419
[65]	420	} # end changePermissions()
	421
	422
[67]	423	## DNSDB::comparePermissions()
	424	# Compare two permission hashes
	425	# Returns '>', '<', '=', '!'
	426	sub comparePermissions {
	427	my $p1 = shift;
	428	my $p2 = shift;
	429
	430	my $retval = '='; # assume equality until proven otherwise
	431
	432	no warnings "uninitialized";
	433
	434	foreach (@permtypes) {
	435	next if $p1->{$_} == $p2->{$_}; # equal is good
	436	if ($p1->{$_} && !$p2->{$_}) {
	437	if ($retval eq '<') { # if we've already found an unequal pair where
	438	$retval = '!'; # $p2 has more access, and we now find a pair
	439	last; # where $p1 has more access, the overall access
	440	} # is neither greater or lesser, it's unequal.
	441	$retval = '>';
	442	}
	443	if (!$p1->{$_} && $p2->{$_}) {
	444	if ($retval eq '>') { # if we've already found an unequal pair where
	445	$retval = '!'; # $p1 has more access, and we now find a pair
	446	last; # where $p2 has more access, the overall access
	447	} # is neither greater or lesser, it's unequal.
	448	$retval = '<';
	449	}
	450	}
	451	return $retval;
	452	} # end comparePermissions()
	453
	454
[112]	455	## DNSDB::changeGroup()
	456	# Change group ID of an entity
	457	# Takes a database handle, entity type, entity ID, and new group ID
	458	sub changeGroup {
	459	my $dbh = shift;
	460	my $type = shift;
	461	my $id = shift;
	462	my $newgrp = shift;
	463
	464	##fixme: fail on not enough args
	465	#return ('FAIL', "Missing
	466
	467	if ($type eq 'domain') {
	468	$dbh->do("UPDATE domains SET group_id=? WHERE domain_id=?", undef, ($newgrp, $id))
	469	or return ('FAIL','Group change failed: '.$dbh->errstr);
	470	} elsif ($type eq 'user') {
	471	$dbh->do("UPDATE users SET group_id=? WHERE user_id=?", undef, ($newgrp, $id))
	472	or return ('FAIL','Group change failed: '.$dbh->errstr);
	473	} elsif ($type eq 'group') {
	474	$dbh->do("UPDATE groups SET parent_group_id=? WHERE group_id=?", undef, ($newgrp, $id))
	475	or return ('FAIL','Group change failed: '.$dbh->errstr);
	476	}
	477	return ('OK','OK');
	478	} # end changeGroup()
	479
	480
[55]	481	## DNSDB::_log()
	482	# Log an action
	483	# Internal sub
	484	# Takes a database handle, <foo>, <bar>
	485	sub _log {
	486	} # end _log
	487
	488
[2]	489	##
	490	## Processing subs
	491	##
	492
	493	## DNSDB::addDomain()
	494	# Add a domain
	495	# Takes a database handle, domain name, numeric group, and boolean(ish) state (active/inactive)
	496	# Returns a status code and message
	497	sub addDomain {
	498	$errstr = '';
	499	my $dbh = shift;
	500	return ('FAIL',"Need database handle") if !$dbh;
	501	my $domain = shift;
[91]	502	return ('FAIL',"Domain must not be blank") if !$domain;
[2]	503	my $group = shift;
	504	return ('FAIL',"Need group") if !defined($group);
	505	my $state = shift;
	506	return ('FAIL',"Need domain status") if !defined($state);
	507
[116]	508	$state = 1 if $state =~ /^active$/;
	509	$state = 1 if $state =~ /^on$/;
	510	$state = 0 if $state =~ /^inactive$/;
	511	$state = 0 if $state =~ /^off$/;
	512
	513	return ('FAIL',"Invalid domain status") if $state !~ /^\d+$/;
	514
[38]	515	my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
[3]	516	my $dom_id;
	517
[38]	518	# quick check to start to see if we've already got one
	519	$sth->execute($domain);
	520	($dom_id) = $sth->fetchrow_array;
	521
	522	return ('FAIL', "Domain already exists") if $dom_id;
	523
[2]	524	# Allow transactions, and raise an exception on errors so we can catch it later.
	525	# Use local to make sure these get "reset" properly on exiting this block
	526	local $dbh->{AutoCommit} = 0;
	527	local $dbh->{RaiseError} = 1;
	528
	529	# Wrap all the SQL in a transaction
	530	eval {
	531	# insert the domain...
	532	my $sth = $dbh->prepare("insert into domains (domain,group_id,status) values (?,?,?)");
	533	$sth->execute($domain,$group,$state);
	534
	535	# get the ID...
	536	$sth = $dbh->prepare("select domain_id from domains where domain='$domain'");
	537	$sth->execute;
[3]	538	($dom_id) = $sth->fetchrow_array();
[2]	539
	540	# ... and now we construct the standard records from the default set. NB: group should be variable.
[3]	541	$sth = $dbh->prepare("select host,type,val,distance,weight,port,ttl from default_records where group_id=$group");
	542	my $sth_in = $dbh->prepare("insert into records (domain_id,host,type,val,distance,weight,port,ttl)".
	543	" values ($dom_id,?,?,?,?,?,?,?)");
[2]	544	$sth->execute;
[3]	545	while (my ($host,$type,$val,$dist,$weight,$port,$ttl) = $sth->fetchrow_array()) {
[2]	546	$host =~ s/DOMAIN/$domain/g;
[37]	547	$val =~ s/DOMAIN/$domain/g;
[3]	548	$sth_in->execute($host,$type,$val,$dist,$weight,$port,$ttl);
[2]	549	}
	550
	551	# once we get here, we should have suceeded.
	552	$dbh->commit;
	553	}; # end eval
	554
	555	if ($@) {
	556	my $msg = $@;
	557	eval { $dbh->rollback; };
	558	return ('FAIL',$msg);
	559	} else {
[3]	560	return ('OK',$dom_id);
[2]	561	}
	562	} # end addDomain
	563
	564
[3]	565	## DNSDB::delDomain()
	566	# Delete a domain.
	567	# for now, just delete the records, then the domain.
	568	# later we may want to archive it in some way instead (status code 2, for example?)
	569	sub delDomain {
	570	my $dbh = shift;
[5]	571	my $domid = shift;
[3]	572
	573	# Allow transactions, and raise an exception on errors so we can catch it later.
	574	# Use local to make sure these get "reset" properly on exiting this block
	575	local $dbh->{AutoCommit} = 0;
	576	local $dbh->{RaiseError} = 1;
	577
[23]	578	my $failmsg = '';
	579
[3]	580	# Wrap all the SQL in a transaction
	581	eval {
[5]	582	my $sth = $dbh->prepare("delete from records where domain_id=?");
[23]	583	$failmsg = "Failure removing domain records";
[5]	584	$sth->execute($domid);
	585	$sth = $dbh->prepare("delete from domains where domain_id=?");
[23]	586	$failmsg = "Failure removing domain";
[5]	587	$sth->execute($domid);
[3]	588
	589	# once we get here, we should have suceeded.
[23]	590	$dbh->commit;
[3]	591	}; # end eval
	592
	593	if ($@) {
	594	my $msg = $@;
	595	eval { $dbh->rollback; };
[23]	596	return ('FAIL',"$failmsg: $msg");
[3]	597	} else {
	598	return ('OK','OK');
	599	}
	600
	601	} # end delDomain()
	602
	603
[2]	604	## DNSDB::domainName()
	605	# Return the domain name based on a domain ID
	606	# Takes a database handle and the domain ID
	607	# Returns the domain name or undef on failure
	608	sub domainName {
	609	$errstr = '';
	610	my $dbh = shift;
	611	my $domid = shift;
[91]	612	my ($domname) = $dbh->selectrow_array("SELECT domain FROM domains WHERE domain_id=?", undef, ($domid) );
[2]	613	$errstr = $DBI::errstr if !$domname;
	614	return $domname if $domname;
[91]	615	} # end domainName()
[2]	616
	617
[91]	618	## DNSDB::domainID()
	619	# Takes a database handle and domain name
	620	# Returns the domain ID number
	621	sub domainID {
	622	$errstr = '';
	623	my $dbh = shift;
	624	my $domain = shift;
	625	my ($domid) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE domain=?", undef, ($domain) );
	626	$errstr = $DBI::errstr if !$domid;
	627	return $domid if $domid;
	628	} # end domainID()
	629
	630
[18]	631	## DNSDB::addGroup()
	632	# Add a group
[66]	633	# Takes a database handle, group name, parent group, hashref for permissions,
	634	# and optional template-vs-cloneme flag
[18]	635	# Returns a status code and message
	636	sub addGroup {
	637	$errstr = '';
	638	my $dbh = shift;
[20]	639	my $groupname = shift;
	640	my $pargroup = shift;
[66]	641	my $permissions = shift;
[18]	642
[66]	643	# 0 indicates "custom", hardcoded.
[18]	644	# Any other value clones that group's default records, if it exists.
[66]	645	my $inherit = shift \|\| 0;
	646	##fixme: need a flag to indicate clone records or <?> ?
[18]	647
	648	# Allow transactions, and raise an exception on errors so we can catch it later.
	649	# Use local to make sure these get "reset" properly on exiting this block
	650	local $dbh->{AutoCommit} = 0;
	651	local $dbh->{RaiseError} = 1;
	652
[38]	653	my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE group_name=?");
	654	my $group_id;
	655
	656	# quick check to start to see if we've already got one
	657	$sth->execute($groupname);
	658	($group_id) = $sth->fetchrow_array;
	659
	660	return ('FAIL', "Group already exists") if $group_id;
	661
[18]	662	# Wrap all the SQL in a transaction
	663	eval {
[38]	664	$sth = $dbh->prepare("INSERT INTO groups (parent_group_id,group_name) VALUES (?,?)");
[20]	665	$sth->execute($pargroup,$groupname);
[18]	666
	667	$sth = $dbh->prepare("SELECT group_id FROM groups WHERE group_name=?");
[20]	668	$sth->execute($groupname);
	669	my ($groupid) = $sth->fetchrow_array();
[18]	670
[66]	671	# Permissions
	672	if ($inherit) {
	673	} else {
	674	my @permvals;
	675	foreach (@permtypes) {
	676	if (!defined ($permissions->{$_})) {
	677	push @permvals, 0;
	678	} else {
	679	push @permvals, $permissions->{$_};
	680	}
	681	}
	682
	683	$sth = $dbh->prepare("INSERT INTO permissions (group_id,$permlist) values (?".',?'x($#permtypes+1).")");
	684	$sth->execute($groupid,@permvals);
	685
	686	$sth = $dbh->prepare("SELECT permission_id FROM permissions WHERE group_id=?");
	687	$sth->execute($groupid);
	688	my ($permid) = $sth->fetchrow_array();
	689
	690	$dbh->do("UPDATE groups SET permission_id=$permid WHERE group_id=$groupid");
	691	} # done permission fiddling
	692
	693	# Default records
[18]	694	$sth = $dbh->prepare("INSERT INTO default_records (group_id,host,type,val,distance,weight,port,ttl) ".
[20]	695	"VALUES ($groupid,?,?,?,?,?,?,?)");
[66]	696	if ($inherit) {
[87]	697	# Duplicate records from parent. Actually relying on inherited records feels
	698	# very fragile, and it would be problematic to roll over at a later time.
[18]	699	my $sth2 = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
[87]	700	$sth2->execute($pargroup);
[18]	701	while (my @clonedata = $sth2->fetchrow_array) {
	702	$sth->execute(@clonedata);
	703	}
	704	} else {
[66]	705	##fixme: Hardcoding is Bad, mmmmkaaaay?
[18]	706	# reasonable basic defaults for SOA, MX, NS, and minimal hosting
	707	# could load from a config file, but somewhere along the line we need hardcoded bits.
	708	$sth->execute('ns1.example.com:hostmaster.example.com', 6, '10800:3600:604800:10800', 0, 0, 0, 86400);
	709	$sth->execute('DOMAIN', 1, '192.168.4.2', 0, 0, 0, 7200);
	710	$sth->execute('DOMAIN', 15, 'mx.example.com', 10, 0, 0, 7200);
	711	$sth->execute('DOMAIN', 2, 'ns1.example.com', 0, 0, 0, 7200);
	712	$sth->execute('DOMAIN', 2, 'ns2.example.com', 0, 0, 0, 7200);
	713	$sth->execute('www.DOMAIN', 5, 'DOMAIN', 0, 0, 0, 7200);
	714	}
	715
	716	# once we get here, we should have suceeded.
	717	$dbh->commit;
	718	}; # end eval
	719
	720	if ($@) {
	721	my $msg = $@;
	722	eval { $dbh->rollback; };
	723	return ('FAIL',$msg);
	724	} else {
	725	return ('OK','OK');
	726	}
	727
	728	} # end addGroup()
	729
	730
[22]	731	## DNSDB::delGroup()
	732	# Delete a group.
	733	# Takes a group ID
	734	# Returns a status code and message
	735	sub delGroup {
	736	my $dbh = shift;
	737	my $groupid = shift;
	738
	739	# Allow transactions, and raise an exception on errors so we can catch it later.
	740	# Use local to make sure these get "reset" properly on exiting this block
	741	local $dbh->{AutoCommit} = 0;
	742	local $dbh->{RaiseError} = 1;
	743
	744	##fixme: locate "knowable" error conditions and deal with them before the eval
[23]	745	# ... or inside, whatever.
[22]	746	# -> domains still exist in group
	747	# -> ...
[23]	748	my $failmsg = '';
[22]	749
	750	# Wrap all the SQL in a transaction
	751	eval {
[23]	752	my $sth = $dbh->prepare("SELECT count(*) FROM domains WHERE group_id=?");
[22]	753	$sth->execute($groupid);
[23]	754	my ($domcnt) = $sth->fetchrow_array;
	755	$failmsg = "Can't remove group ".groupName($dbh,$groupid);
	756	die "$domcnt domains still in group\n" if $domcnt;
	757
	758	$sth = $dbh->prepare("delete from default_records where group_id=?");
	759	$failmsg = "Failed to delete default records for ".groupName($dbh,$groupid);
	760	$sth->execute($groupid);
[22]	761	$sth = $dbh->prepare("delete from groups where group_id=?");
[23]	762	$failmsg = "Failed to remove group ".groupName($dbh,$groupid);
[22]	763	$sth->execute($groupid);
	764
	765	# once we get here, we should have suceeded.
	766	$dbh->commit;
	767	}; # end eval
	768
	769	if ($@) {
	770	my $msg = $@;
	771	eval { $dbh->rollback; };
[23]	772	return ('FAIL',"$failmsg: $msg");
[22]	773	} else {
	774	return ('OK','OK');
	775	}
	776	} # end delGroup()
	777
	778
[19]	779	## DNSDB::getChildren()
	780	# Get a list of all groups whose parent^n is group <n>
[24]	781	# Takes a database handle, group ID, reference to an array to put the group IDs in,
	782	# and an optional flag to return only immediate children or all children-of-children
	783	# default to returning all children
[19]	784	# Calls itself
	785	sub getChildren {
	786	$errstr = '';
	787	my $dbh = shift;
[20]	788	my $rootgroup = shift;
	789	my $groupdest = shift;
[24]	790	my $immed = shift \|\| 'all';
[19]	791
	792	# special break for default group; otherwise we get stuck.
[20]	793	if ($rootgroup == 1) {
[19]	794	# by definition, group 1 is the Root Of All Groups
[24]	795	my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE NOT (group_id=1)".
	796	($immed ne 'all' ? " AND parent_group_id=1" : ''));
[19]	797	$sth->execute;
	798	while (my @this = $sth->fetchrow_array) {
[20]	799	push @$groupdest, @this;
[19]	800	}
	801	} else {
	802	my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE parent_group_id=?");
[20]	803	$sth->execute($rootgroup);
[19]	804	return if $sth->rows == 0;
[20]	805	my @grouplist;
	806	while (my ($group) = $sth->fetchrow_array) {
	807	push @$groupdest, $group;
[24]	808	getChildren($dbh,$group,$groupdest) if $immed eq 'all';
[19]	809	}
	810	}
	811	} # end getChildren()
	812
	813
[20]	814	## DNSDB::groupName()
[17]	815	# Return the group name based on a group ID
	816	# Takes a database handle and the group ID
	817	# Returns the group name or undef on failure
[20]	818	sub groupName {
[13]	819	$errstr = '';
	820	my $dbh = shift;
[20]	821	my $groupid = shift;
	822	my $sth = $dbh->prepare("SELECT group_name FROM groups WHERE group_id=?");
	823	$sth->execute($groupid);
	824	my ($groupname) = $sth->fetchrow_array();
	825	$errstr = $DBI::errstr if !$groupname;
	826	return $groupname if $groupname;
	827	} # end groupName
[13]	828
	829
[118]	830	## DNSDB::groupID()
	831	# Return the group ID based on the group name
	832	# Takes a database handle and the group name
	833	# Returns the group ID or undef on failure
	834	sub groupID {
	835	$errstr = '';
	836	my $dbh = shift;
	837	my $group = shift;
	838	my ($grpid) = $dbh->selectrow_array("SELECT group_id FROM groups WHERE group=?", undef, ($group) );
	839	$errstr = $DBI::errstr if !$grpid;
	840	return $grpid if $grpid;
	841	} # end groupID()
	842
	843
[24]	844	## DNSDB::addUser()
[87]	845	# Add a user.
	846	# Takes a DB handle, username, group ID, password, state (active/inactive).
	847	# Optionally accepts:
	848	# user type (user/admin) - defaults to user
	849	# permissions string - defaults to inherit from group
	850	# three valid forms:
	851	# i - Inherit permissions
	852	# c:<user_id> - Clone permissions from <user_id>
	853	# C:<permission list> - Set these specific permissions
	854	# first name - defaults to username
	855	# last name - defaults to blank
	856	# phone - defaults to blank (could put other data within column def)
[90]	857	# Returns (OK,<uid>) on success, (FAIL,<message>) on failure
[24]	858	sub addUser {
	859	$errstr = '';
	860	my $dbh = shift;
	861	my $username = shift;
	862	my $group = shift;
	863	my $pass = shift;
	864	my $state = shift;
[25]	865
[90]	866	return ('FAIL', "Missing one or more required entries") if !defined($state);
	867	return ('FAIL', "Username must not be blank") if !$username;
[87]	868
[25]	869	my $type = shift \|\| 'u'; # create limited users by default - fwiw, not sure yet how this will interact with ACLs
	870
[67]	871	my $permstring = shift \|\| 'i'; # default is to inhert permissions from group
	872
[25]	873	my $fname = shift \|\| $username;
[24]	874	my $lname = shift \|\| '';
[25]	875	my $phone = shift \|\| ''; # not going format-check
[24]	876
[38]	877	my $sth = $dbh->prepare("SELECT user_id FROM users WHERE username=?");
[24]	878	my $user_id;
	879
[38]	880	# quick check to start to see if we've already got one
	881	$sth->execute($username);
	882	($user_id) = $sth->fetchrow_array;
	883
	884	return ('FAIL', "User already exists") if $user_id;
	885
[24]	886	# Allow transactions, and raise an exception on errors so we can catch it later.
	887	# Use local to make sure these get "reset" properly on exiting this block
	888	local $dbh->{AutoCommit} = 0;
	889	local $dbh->{RaiseError} = 1;
	890
[94]	891	my $failmsg = '';
	892
[24]	893	# Wrap all the SQL in a transaction
	894	eval {
[87]	895	# insert the user... note we set inherited perms by default since
	896	# it's simple and cleans up some other bits of state
	897	my $sth = $dbh->prepare("INSERT INTO users ".
	898	"(group_id,username,password,firstname,lastname,phone,type,status,permission_id,inherit_perm) ".
	899	"VALUES (?,?,?,?,?,?,?,?,(SELECT permission_id FROM permissions WHERE group_id=?),'t')");
	900	$sth->execute($group,$username,unix_md5_crypt($pass),$fname,$lname,$phone,$type,$state,$group);
[24]	901
	902	# get the ID...
[94]	903	($user_id) = $dbh->selectrow_array("SELECT currval('users_user_id_seq')");
[24]	904
[87]	905	# Permissions! Gotta set'em all!
	906	die "Invalid permission string $permstring"
	907	if $permstring !~ /^(?:
	908	i # inherit
	909	\|c:\d+ # clone
	910	# custom. no, the leading , is not a typo
[111]	911	\|C:(?:,(?:group\|user\|domain\|record\|self)_(?:edit\|create\|delete))*
[87]	912	)$/x;
	913	# bleh. I'd call another function to do my dirty work, but we're in the middle of a transaction already.
	914	if ($permstring ne 'i') {
	915	# for cloned or custom permissions, we have to create a new permissions entry.
	916	my $clonesrc = $group;
	917	if ($permstring =~ /^c:(\d+)/) { $clonesrc = $1; }
	918	$dbh->do("INSERT INTO permissions ($permlist,user_id) ".
	919	"SELECT $permlist,? FROM permissions WHERE permission_id=".
	920	"(SELECT permission_id FROM permissions WHERE ".($permstring =~ /^c:/ ? 'user' : 'group')."_id=?)",
	921	undef, ($user_id,$clonesrc) );
	922	$dbh->do("UPDATE users SET permission_id=".
	923	"(SELECT permission_id FROM permissions WHERE user_id=?) ".
	924	"WHERE user_id=?", undef, ($user_id, $user_id) );
	925	}
	926	if ($permstring =~ /^C:/) {
	927	# finally for custom permissions, we set the passed-in permissions (and unset
	928	# any that might have been brought in by the clone operation above)
	929	my ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions WHERE user_id=?",
	930	undef, ($user_id) );
	931	foreach (@permtypes) {
	932	if ($permstring =~ /,$_/) {
	933	$dbh->do("UPDATE permissions SET $_='t' WHERE permission_id=?", undef, ($permid) );
	934	} else {
	935	$dbh->do("UPDATE permissions SET $_='f' WHERE permission_id=?", undef, ($permid) );
	936	}
	937	}
	938	}
	939
	940	$dbh->do("UPDATE users SET inherit_perm='n' WHERE user_id=?", undef, ($user_id) );
	941
[25]	942	##fixme: add another table to hold name/email for log table?
	943
[24]	944	# once we get here, we should have suceeded.
	945	$dbh->commit;
	946	}; # end eval
	947
	948	if ($@) {
	949	my $msg = $@;
	950	eval { $dbh->rollback; };
[87]	951	return ('FAIL',$msg." $failmsg");
[24]	952	} else {
	953	return ('OK',$user_id);
	954	}
	955	} # end addUser
	956
	957
[55]	958	## DNSDB::checkUser()
	959	# Check user/pass combo on login
	960	sub checkUser {
	961	my $dbh = shift;
	962	my $user = shift;
[56]	963	my $inpass = shift;
[55]	964
	965	my $sth = $dbh->prepare("SELECT user_id,group_id,password,firstname,lastname FROM users WHERE username=?");
	966	$sth->execute($user);
	967	my ($uid,$gid,$pass,$fname,$lname) = $sth->fetchrow_array;
	968	my $loginfailed = 1 if !defined($uid);
	969
	970	if ($pass =~ m\|^\$1\$([A-Za-z0-9/.]+)\$\|) {
[56]	971	$loginfailed = 1 if $pass ne unix_md5_crypt($inpass,$1);
[55]	972	} else {
[56]	973	$loginfailed = 1 if $pass ne $inpass;
[55]	974	}
	975
	976	# nnnngggg
	977	return ($uid, $gid);
	978	} # end checkUser
	979
	980
[83]	981	## DNSDB:: updateUser()
[90]	982	# Update general data about user
[83]	983	sub updateUser {
	984	my $dbh = shift;
[118]	985
	986	##fixme: tweak calling convention so that we can update any given bit of data
[83]	987	my $uid = shift;
	988	my $username = shift;
	989	my $group = shift;
	990	my $pass = shift;
	991	my $state = shift;
[87]	992	my $type = shift \|\| 'u';
[83]	993	my $fname = shift \|\| $username;
	994	my $lname = shift \|\| '';
	995	my $phone = shift \|\| ''; # not going format-check
	996
	997	my $failmsg = '';
	998
	999	# Allow transactions, and raise an exception on errors so we can catch it later.
	1000	# Use local to make sure these get "reset" properly on exiting this block
	1001	local $dbh->{AutoCommit} = 0;
	1002	local $dbh->{RaiseError} = 1;
	1003
	1004	my $sth;
	1005
	1006	# Password can be left blank; if so we assume there's one on file.
	1007	# Actual blank passwords are bad, mm'kay?
	1008	if (!$pass) {
	1009	$sth = $dbh->prepare("SELECT password FROM users WHERE user_id=?");
	1010	$sth->execute($uid);
	1011	($pass) = $sth->fetchrow_array;
	1012	} else {
	1013	$pass = unix_md5_crypt($pass);
	1014	}
	1015
	1016	eval {
	1017	my $sth = $dbh->prepare(q(
	1018	UPDATE users
	1019	SET username=?, password=?, firstname=?, lastname=?, phone=?, type=?, status=?
	1020	WHERE user_id=?
	1021	)
	1022	);
	1023	$sth->execute($username, $pass, $fname, $lname, $phone, $type, $state, $uid);
	1024	$dbh->commit;
	1025	};
	1026	if ($@) {
	1027	my $msg = $@;
	1028	eval { $dbh->rollback; };
	1029	return ('FAIL',"$failmsg: $msg");
	1030	} else {
	1031	return ('OK','OK');
	1032	}
	1033	} # end updateUser()
	1034
	1035
[24]	1036	## DNSDB::delUser()
	1037	#
	1038	sub delUser {
[25]	1039	my $dbh = shift;
	1040	return ('FAIL',"Need database handle") if !$dbh;
	1041	my $userid = shift;
	1042	return ('FAIL',"Missing userid") if !defined($userid);
	1043
	1044	my $sth = $dbh->prepare("delete from users where user_id=?");
	1045	$sth->execute($userid);
	1046
	1047	return ('FAIL',"Couldn't remove user: ".$sth->errstr) if $sth->err;
	1048
	1049	return ('OK','OK');
	1050
[24]	1051	} # end delUser
	1052
	1053
[25]	1054	## DNSDB::userFullName()
	1055	# Return a pretty string!
	1056	# Takes a user_id and optional printf-ish string to indicate which pieces where:
	1057	# %u for the username
	1058	# %f for the first name
	1059	# %l for the last name
	1060	# All other text in the passed string will be left as-is.
	1061	##fixme: need a "smart" option too, so that missing/null/blank first/last names don't give funky output
	1062	sub userFullName {
	1063	$errstr = '';
	1064	my $dbh = shift;
	1065	my $userid = shift;
	1066	my $fullformat = shift \|\| '%f %l (%u)';
	1067	my $sth = $dbh->prepare("select username,firstname,lastname from users where user_id=?");
	1068	$sth->execute($userid);
	1069	my ($uname,$fname,$lname) = $sth->fetchrow_array();
	1070	$errstr = $DBI::errstr if !$uname;
	1071
	1072	$fullformat =~ s/\%u/$uname/g;
	1073	$fullformat =~ s/\%f/$fname/g;
	1074	$fullformat =~ s/\%l/$lname/g;
	1075
	1076	return $fullformat;
	1077	} # end userFullName
	1078
	1079
[51]	1080	## DNSDB::userStatus()
	1081	# Sets and/or returns a user's status
	1082	# Takes a database handle, user ID and optionally a status argument
	1083	# Returns undef on errors.
	1084	sub userStatus {
	1085	my $dbh = shift;
	1086	my $id = shift;
	1087	my $newstatus = shift;
	1088
	1089	return undef if $id !~ /^\d+$/;
	1090
	1091	my $sth;
	1092
	1093	# ooo, fun! let's see what we were passed for status
	1094	if ($newstatus) {
	1095	$sth = $dbh->prepare("update users set status=? where user_id=?");
	1096	# ass-u-me caller knows what's going on in full
	1097	if ($newstatus =~ /^[01]$/) { # only two valid for now.
	1098	$sth->execute($newstatus,$id);
	1099	} elsif ($newstatus =~ /^usero(?:n\|ff)$/) {
	1100	$sth->execute(($newstatus eq 'useron' ? 1 : 0),$id);
	1101	}
	1102	}
	1103
	1104	$sth = $dbh->prepare("select status from users where user_id=?");
	1105	$sth->execute($id);
	1106	my ($status) = $sth->fetchrow_array;
	1107	return $status;
	1108	} # end userStatus()
	1109
	1110
[83]	1111	## DNSDB::getUserData()
	1112	# Get misc user data for display
	1113	sub getUserData {
	1114	my $dbh = shift;
	1115	my $uid = shift;
	1116
	1117	my $sth = $dbh->prepare("SELECT group_id,username,firstname,lastname,phone,type,status,inherit_perm ".
	1118	"FROM users WHERE user_id=?");
	1119	$sth->execute($uid);
	1120	return $sth->fetchrow_hashref();
	1121
	1122	} # end getUserData()
	1123
	1124
[2]	1125	## DNSDB::getSOA()
	1126	# Return all suitable fields from an SOA record in separate elements of a hash
	1127	# Takes a database handle, default/live flag, and group (default) or domain (live) ID
	1128	sub getSOA {
	1129	$errstr = '';
	1130	my $dbh = shift;
	1131	my $def = shift;
	1132	my $id = shift;
	1133	my %ret;
	1134
[101]	1135	# (ab)use distance and weight columns to store SOA data
	1136
	1137	my $sql = "SELECT record_id,host,val,ttl,distance from";
[2]	1138	if ($def eq 'def' or $def eq 'y') {
[101]	1139	$sql .= " default_records WHERE group_id=? AND type=$reverse_typemap{SOA}";
[2]	1140	} else {
	1141	# we're editing a live SOA record; find based on domain
[101]	1142	$sql .= " records WHERE domain_id=? AND type=$reverse_typemap{SOA}";
[2]	1143	}
	1144	my $sth = $dbh->prepare($sql);
[101]	1145	$sth->execute($id);
[2]	1146
[121]	1147	my ($recid,$host,$val,$ttl,$serial) = $sth->fetchrow_array() or return;
[2]	1148	my ($prins,$contact) = split /:/, $host;
	1149	my ($refresh,$retry,$expire,$minttl) = split /:/, $val;
	1150
	1151	$ret{recid} = $recid;
	1152	$ret{ttl} = $ttl;
[101]	1153	$ret{serial} = $serial;
[2]	1154	$ret{prins} = $prins;
	1155	$ret{contact} = $contact;
	1156	$ret{refresh} = $refresh;
	1157	$ret{retry} = $retry;
	1158	$ret{expire} = $expire;
	1159	$ret{minttl} = $minttl;
	1160
	1161	return %ret;
	1162	} # end getSOA()
	1163
	1164
	1165	## DNSDB::getRecLine()
	1166	# Return all data fields for a zone record in separate elements of a hash
	1167	# Takes a database handle, default/live flag, and record ID
	1168	sub getRecLine {
	1169	$errstr = '';
	1170	my $dbh = shift;
	1171	my $def = shift;
	1172	my $id = shift;
	1173
[130]	1174	my $sql = "SELECT record_id,host,type,val,distance,weight,port,ttl".
	1175	(($def eq 'def' or $def eq 'y') ? ',group_id FROM default_' : ',domain_id FROM ').
	1176	"records WHERE record_id=?";
[123]	1177	my $ret = $dbh->selectrow_hashref($sql, undef, ($id) );
[2]	1178
[90]	1179	if ($dbh->err) {
[2]	1180	$errstr = $DBI::errstr;
	1181	return undef;
	1182	}
	1183
[123]	1184	if (!$ret) {
	1185	$errstr = "No such record";
	1186	return undef;
	1187	}
	1188
[107]	1189	$ret->{parid} = (($def eq 'def' or $def eq 'y') ? $ret->{group_id} : $ret->{domain_id});
[90]	1190
	1191	return $ret;
[2]	1192	}
	1193
	1194
	1195	##fixme: should use above (getRecLine()) to get lines for below?
	1196	## DNSDB::getDomRecs()
	1197	# Return records for a domain
	1198	# Takes a database handle, default/live flag, group/domain ID, start,
	1199	# number of records, sort field, and sort order
	1200	# Returns a reference to an array of hashes
	1201	sub getDomRecs {
	1202	$errstr = '';
	1203	my $dbh = shift;
	1204	my $type = shift;
	1205	my $id = shift;
[4]	1206	my $nrecs = shift \|\| 'all';
	1207	my $nstart = shift \|\| 0;
[2]	1208
[4]	1209	## for order, need to map input to column names
	1210	my $order = shift \|\| 'host';
[72]	1211	my $direction = shift \|\| 'ASC';
[4]	1212
[135]	1213	my $filter = shift \|\| '';
	1214
[90]	1215	$type = 'y' if $type eq 'def';
	1216
[130]	1217	my $sql = "SELECT r.record_id,r.host,r.type,r.val,r.distance,r.weight,r.port,r.ttl FROM ";
[90]	1218	$sql .= "default_" if $type eq 'y';
	1219	$sql .= "records r ";
[104]	1220	$sql .= "INNER JOIN rectypes t ON r.type=t.val "; # for sorting by type alphabetically
[90]	1221	if ($type eq 'y') {
	1222	$sql .= "WHERE r.group_id=?";
[2]	1223	} else {
[90]	1224	$sql .= "WHERE r.domain_id=?";
[2]	1225	}
[104]	1226	$sql .= " AND NOT r.type=$reverse_typemap{SOA}";
[160]	1227	$sql .= " AND host ~* ?" if $filter;
[104]	1228	# use alphaorder column for "correct" ordering of sort-by-type instead of DNS RR type number
	1229	$sql .= " ORDER BY ".($order eq 'type' ? 't.alphaorder' : "r.$order")." $direction";
[90]	1230	$sql .= " LIMIT $nrecs OFFSET ".($nstart*$nrecs) if $nstart ne 'all';
[4]	1231
[90]	1232	my $sth = $dbh->prepare($sql) or warn $dbh->errstr;
	1233	$sth->execute($id) or warn "$sql: ".$sth->errstr;
[2]	1234
	1235	my @retbase;
	1236	while (my $ref = $sth->fetchrow_hashref()) {
	1237	push @retbase, $ref;
	1238	}
	1239
	1240	my $ret = \@retbase;
	1241	return $ret;
	1242	} # end getDomRecs()
	1243
	1244
[91]	1245	## DNSDB::getRecCount()
	1246	# Return count of non-SOA records in domain (or default records in a group)
[135]	1247	# Takes a database handle, default/live flag, group/domain ID, and optional filtering modifier
[91]	1248	# Returns the count
	1249	sub getRecCount {
	1250	my $dbh = shift;
	1251	my $defrec = shift;
	1252	my $id = shift;
[135]	1253	my $filter = shift \|\| '';
[91]	1254
[135]	1255	# keep the nasties down, since we can't ?-sub this bit. :/
	1256	# note this is chars allowed in DNS hostnames
	1257	$filter =~ s/[^a-zA-Z0-9_.:-]//g;
	1258
[91]	1259	my ($count) = $dbh->selectrow_array("SELECT count(*) FROM ".
	1260	($defrec eq 'y' ? 'default_' : '')."records ".
	1261	"WHERE ".($defrec eq 'y' ? 'group' : 'domain')."_id=? ".
[135]	1262	"AND NOT type=$reverse_typemap{SOA}".
	1263	($filter ? " AND host ILIKE '%$filter%'" : ''),
	1264	undef, ($id) );
[91]	1265
	1266	return $count;
	1267
	1268	} # end getRecCount()
	1269
	1270
[3]	1271	## DNSDB::addRec()
[2]	1272	# Add a new record to a domain or a group's default records
	1273	# Takes a database handle, default/live flag, group/domain ID,
	1274	# host, type, value, and TTL
	1275	# Some types require additional detail: "distance" for MX and SRV,
	1276	# and weight/port for SRV
	1277	# Returns a status code and detail message in case of error
	1278	sub addRec {
	1279	$errstr = '';
	1280	my $dbh = shift;
	1281	my $defrec = shift;
	1282	my $id = shift;
	1283
	1284	my $host = shift;
	1285	my $rectype = shift;
	1286	my $val = shift;
	1287	my $ttl = shift;
	1288
[129]	1289	# Validation
[160]	1290	if ($rectype == $reverse_typemap{A}) {
	1291	return ("FAIL", "IPv4 addresses must be in the format n.n.n.n")
	1292	unless $val =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/;
	1293	}
	1294	if ($rectype == $reverse_typemap{AAAA}) {
	1295	return ("FAIL", "IPv6 addresses must be in the format h:h:h::h")
	1296	unless $val =~ /^[a-fA-F0-9:]+$/
	1297	}
[129]	1298	if ($rectype == $reverse_typemap{A} or $rectype == $reverse_typemap{AAAA}) {
	1299	my $tmpip = new NetAddr::IP $val or
	1300	return ("FAIL", "Address must be a valid IP address");
	1301	}
	1302
[2]	1303	my $fields = ($defrec eq 'y' ? 'group_id' : 'domain_id').",host,type,val,ttl";
[24]	1304	my $vallen = "?,?,?,?,?";
	1305	my @vallist = ($id,$host,$rectype,$val,$ttl);
[2]	1306
	1307	my $dist;
	1308	if ($rectype == $reverse_typemap{MX} or $rectype == $reverse_typemap{SRV}) {
	1309	$dist = shift;
	1310	return ('FAIL',"Need distance for $typemap{$rectype} record") if !defined($dist);
	1311	$fields .= ",distance";
[24]	1312	$vallen .= ",?";
	1313	push @vallist, $dist;
[2]	1314	}
	1315	my $weight;
	1316	my $port;
	1317	if ($rectype == $reverse_typemap{SRV}) {
[24]	1318	# check for _service._protocol. NB: RFC2782 does not say "MUST"... nor "SHOULD"...
	1319	# it just says (paraphrased) "... is prepended with _ to prevent DNS collisions"
	1320	return ('FAIL',"SRV records must begin with _service._protocol")
	1321	if $host !~ /^_[A-Za-z]+\._[A-Za-z]+\.[a-z0-9-]+/;
[2]	1322	$weight = shift;
	1323	$port = shift;
	1324	return ('FAIL',"Need weight and port for SRV record") if !defined($weight) or !defined($port);
	1325	$fields .= ",weight,port";
[24]	1326	$vallen .= ",?,?";
	1327	push @vallist, ($weight,$port);
[2]	1328	}
	1329
[90]	1330	# Allow transactions, and raise an exception on errors so we can catch it later.
	1331	# Use local to make sure these get "reset" properly on exiting this block
	1332	local $dbh->{AutoCommit} = 0;
	1333	local $dbh->{RaiseError} = 1;
[2]	1334
[90]	1335	eval {
	1336	$dbh->do("INSERT INTO ".($defrec eq 'y' ? 'default_' : '')."records ($fields) VALUES ($vallen)",
	1337	undef, @vallist);
	1338	$dbh->commit;
	1339	};
	1340	if ($@) {
	1341	my $msg = $@;
	1342	eval { $dbh->rollback; };
	1343	return ('FAIL',$msg);
	1344	}
[2]	1345
	1346	return ('OK','OK');
[90]	1347
[2]	1348	} # end addRec()
	1349
	1350
[16]	1351	## DNSDB::updateRec()
	1352	# Update a record
	1353	sub updateRec {
	1354	$errstr = '';
[17]	1355
[16]	1356	my $dbh = shift;
	1357	my $defrec = shift;
	1358	my $id = shift;
	1359
	1360	# all records have these
	1361	my $host = shift;
	1362	my $type = shift;
	1363	my $val = shift;
	1364	my $ttl = shift;
	1365
	1366	return('FAIL',"Missing standard argument(s)") if !defined($ttl);
	1367
	1368	# only MX and SRV will use these
	1369	my $dist = 0;
	1370	my $weight = 0;
	1371	my $port = 0;
	1372
	1373	if ($type == $reverse_typemap{MX} \|\| $type == $reverse_typemap{SRV}) {
[17]	1374	$dist = shift;
	1375	return ('FAIL',"MX or SRV requires distance") if !defined($dist);
[16]	1376	if ($type == $reverse_typemap{SRV}) {
[17]	1377	$weight = shift;
	1378	return ('FAIL',"SRV requires weight") if !defined($weight);
	1379	$port = shift;
	1380	return ('FAIL',"SRV requires port") if !defined($port);
[16]	1381	}
	1382	}
	1383
[90]	1384	local $dbh->{AutoCommit} = 0;
	1385	local $dbh->{RaiseError} = 1;
	1386
	1387	eval {
	1388	$dbh->do("UPDATE ".($defrec eq 'y' ? 'default_' : '')."records ".
[130]	1389	"SET host=?,val=?,type=?,ttl=?,distance=?,weight=?,port=? ".
	1390	"WHERE record_id=?", undef, ($host, $val, $type, $ttl, $dist, $weight, $port, $id) );
	1391	$dbh->commit;
[90]	1392	};
	1393	if ($@) {
	1394	my $msg = $@;
	1395	$dbh->rollback;
	1396	return ('FAIL', $msg);
	1397	}
	1398
[16]	1399	return ('OK','OK');
	1400	} # end updateRec()
	1401
	1402
[3]	1403	## DNSDB::delRec()
	1404	# Delete a record.
	1405	sub delRec {
	1406	$errstr = '';
	1407	my $dbh = shift;
	1408	my $defrec = shift;
	1409	my $id = shift;
	1410
[62]	1411	my $sth = $dbh->prepare("DELETE FROM ".($defrec eq 'y' ? 'default_' : '')."records WHERE record_id=?");
[3]	1412	$sth->execute($id);
	1413
[23]	1414	return ('FAIL',"Couldn't remove record: ".$sth->errstr) if $sth->err;
[3]	1415
	1416	return ('OK','OK');
	1417	} # end delRec()
	1418
	1419
[117]	1420	# Reference hashes.
	1421	my %par_tbl = (
	1422	group => 'groups',
	1423	user => 'users',
	1424	defrec => 'default_records',
	1425	domain => 'domains',
	1426	record => 'records'
	1427	);
	1428	my %id_col = (
	1429	group => 'group_id',
	1430	user => 'user_id',
	1431	defrec => 'record_id',
	1432	domain => 'domain_id',
	1433	record => 'record_id'
	1434	);
	1435	my %par_col = (
	1436	group => 'parent_group_id',
	1437	user => 'group_id',
	1438	defrec => 'group_id',
	1439	domain => 'group_id',
	1440	record => 'domain_id'
	1441	);
	1442	my %par_type = (
	1443	group => 'group',
	1444	user => 'group',
	1445	defrec => 'group',
	1446	domain => 'group',
	1447	record => 'domain'
	1448	);
	1449
[116]	1450	## DNSDB::getParents()
	1451	# Find out which entities are parent to the requested id
	1452	# Returns arrayref containing hash pairs of id/type
	1453	sub getParents {
	1454	my $dbh = shift;
	1455	my $id = shift;
	1456	my $type = shift;
[117]	1457	my $depth = shift \|\| 'all'; # valid values: 'all', 'immed', <int> (stop at this group ID)
[116]	1458
[117]	1459	my @parlist;
[116]	1460
[117]	1461	while (1) {
	1462	my $result = $dbh->selectrow_hashref("SELECT $par_col{$type} FROM $par_tbl{$type} WHERE $id_col{$type} = ?",
	1463	undef, ($id) );
[152]	1464	my %tmp = ($result->{$par_col{$type}} => $par_type{$type});
	1465	unshift @parlist, \%tmp;
[117]	1466	last if $result->{$par_col{$type}} == 1; # group 1 is its own parent
[152]	1467	$id = $result->{$par_col{$type}};
[117]	1468	$type = $par_type{$type};
[116]	1469	}
	1470
[117]	1471	return \@parlist;
[116]	1472
	1473	} # end getParents()
	1474
	1475
[117]	1476	## DNSDB::isParent()
	1477	# Returns true if $id1 is a parent of $id2, false otherwise
	1478	sub isParent {
	1479	my $dbh = shift;
	1480	my $id1 = shift;
	1481	my $type1 = shift;
	1482	my $id2 = shift;
	1483	my $type2 = shift;
	1484	##todo: immediate, secondary, full (default)
	1485
[157]	1486	# Return false on invalid types
	1487	return 0 if !grep /^$type1$/, ('record','defrec','user','domain','group');
	1488	return 0 if !grep /^$type2$/, ('record','defrec','user','domain','group');
	1489
[117]	1490	# Return false on impossible relations
	1491	return 0 if $type1 eq 'record'; # nothing may be a child of a record
	1492	return 0 if $type1 eq 'defrec'; # nothing may be a child of a record
	1493	return 0 if $type1 eq 'user'; # nothing may be child of a user
	1494	return 0 if $type1 eq 'domain' && $type2 ne 'record'; # domain may not be a parent of anything other than a record
	1495
	1496	# group 1 is the ultimate root parent
	1497	return 1 if $type1 eq 'group' && $id1 == 1;
	1498
[155]	1499	# groups are always (a) parent of themselves
	1500	return 1 if $type1 eq 'group' && $type2 eq 'group' && $id1 == $id2;
	1501
[117]	1502	# almost the same loop as getParents() above
	1503	my $id = $id2;
	1504	my $type = $type2;
	1505	my $foundparent = 0;
[155]	1506
[117]	1507	while (1) {
[155]	1508	my $sql = "SELECT $par_col{$type} FROM $par_tbl{$type} WHERE $id_col{$type} = ?";
[117]	1509	my $result = $dbh->selectrow_hashref($sql,
[157]	1510	undef, ($id) );
	1511	if ($result && $result->{$par_col{$type}} == $id1) {
[117]	1512	$foundparent = 1;
	1513	last;
[157]	1514	} else {
	1515	##fixme: do we care about trying to return a "no such record/domain/user/group" error?
	1516	warn $dbh->errstr." $sql, $id" if $dbh->errstr;
	1517	last;
[117]	1518	}
	1519	# group 1 is its own parent. need this here more to break strange loops than for detecting a parent
	1520	last if $result->{$par_col{$type}} == 1;
[152]	1521	$id = $result->{$par_col{$type}};
[117]	1522	$type = $par_type{$type};
	1523	}
	1524
	1525	return $foundparent;
	1526	} # end isParent()
	1527
	1528
[3]	1529	## DNSDB::domStatus()
	1530	# Sets and/or returns a domain's status
	1531	# Takes a database handle, domain ID and optionally a status argument
	1532	# Returns undef on errors.
	1533	sub domStatus {
	1534	my $dbh = shift;
	1535	my $id = shift;
	1536	my $newstatus = shift;
	1537
	1538	return undef if $id !~ /^\d+$/;
	1539
	1540	my $sth;
	1541
	1542	# ooo, fun! let's see what we were passed for status
	1543	if ($newstatus) {
	1544	$sth = $dbh->prepare("update domains set status=? where domain_id=?");
	1545	# ass-u-me caller knows what's going on in full
	1546	if ($newstatus =~ /^[01]$/) { # only two valid for now.
	1547	$sth->execute($newstatus,$id);
	1548	} elsif ($newstatus =~ /^domo(?:n\|ff)$/) {
	1549	$sth->execute(($newstatus eq 'domon' ? 1 : 0),$id);
	1550	}
	1551	}
	1552
	1553	$sth = $dbh->prepare("select status from domains where domain_id=?");
	1554	$sth->execute($id);
	1555	my ($status) = $sth->fetchrow_array;
	1556	return $status;
	1557	} # end domStatus()
	1558
	1559
[33]	1560	## DNSDB::importAXFR
	1561	# Import a domain via AXFR
[37]	1562	# Takes AXFR host, domain to transfer, group to put the domain in,
	1563	# and optionally:
	1564	# - active/inactive state flag (defaults to active)
	1565	# - overwrite-SOA flag (defaults to off)
	1566	# - overwrite-NS flag (defaults to off, doesn't affect subdomain NS records)
	1567	# Returns a status code (OK, WARN, or FAIL) and message - message should be blank
	1568	# if status is OK, but WARN includes conditions that are not fatal but should
	1569	# really be reported.
[33]	1570	sub importAXFR {
	1571	my $dbh = shift;
[35]	1572	my $ifrom_in = shift;
[33]	1573	my $domain = shift;
	1574	my $group = shift;
	1575	my $status = shift \|\| 1;
	1576	my $rwsoa = shift \|\| 0;
	1577	my $rwns = shift \|\| 0;
[37]	1578
[33]	1579	##fixme: add mode to delete&replace, merge+overwrite, merge new?
	1580
[37]	1581	my $nrecs = 0;
	1582	my $soaflag = 0;
	1583	my $nsflag = 0;
	1584	my $warnmsg = '';
	1585	my $ifrom;
[33]	1586
[35]	1587	# choke on possible bad setting in ifrom
[37]	1588	# IPv4 and v6, and valid hostnames!
[35]	1589	($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+\|[0-9a-z_.-]+)$/i);
	1590	return ('FAIL', "Bad AXFR source host $ifrom")
	1591	unless ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+\|[0-9a-z_.-]+)$/i);
	1592
[33]	1593	# Allow transactions, and raise an exception on errors so we can catch it later.
	1594	# Use local to make sure these get "reset" properly on exiting this block
	1595	local $dbh->{AutoCommit} = 0;
	1596	local $dbh->{RaiseError} = 1;
	1597
[37]	1598	my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
[34]	1599	my $dom_id;
	1600
[35]	1601	# quick check to start to see if we've already got one
[37]	1602	$sth->execute($domain);
	1603	($dom_id) = $sth->fetchrow_array;
[35]	1604
	1605	return ('FAIL', "Domain already exists") if $dom_id;
	1606
[33]	1607	eval {
	1608	# can't do this, can't nest transactions. sigh.
[35]	1609	#my ($dcode, $dmsg) = addDomain(dbh, domain, group, status);
[33]	1610
	1611	##fixme: serial
[37]	1612	my $sth = $dbh->prepare("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)");
	1613	$sth->execute($domain,$group,$status);
[33]	1614
[35]	1615	## bizarre DBI<->Net::DNS interaction bug:
	1616	## sometimes a zone will cause an immediate commit-and-exit (sort of) of the while()
[37]	1617	## fixed, apparently I was doing something odd, but not certain what it was that
	1618	## caused a commit instead of barfing
[35]	1619
[33]	1620	# get domain id so we can do the records
[37]	1621	$sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
	1622	$sth->execute($domain);
	1623	($dom_id) = $sth->fetchrow_array();
[33]	1624
[34]	1625	my $res = Net::DNS::Resolver->new;
[35]	1626	$res->nameservers($ifrom);
	1627	$res->axfr_start($domain)
	1628	or die "Couldn't begin AXFR\n";
[34]	1629
[35]	1630	while (my $rr = $res->axfr_next()) {
[33]	1631	my $type = $rr->type;
[35]	1632
[34]	1633	my $sql = "INSERT INTO records (domain_id,host,type,ttl,val";
[33]	1634	my $vallen = "?,?,?,?,?";
	1635
[37]	1636	$soaflag = 1 if $type eq 'SOA';
	1637	$nsflag = 1 if $type eq 'NS';
[35]	1638
	1639	my @vallist = ($dom_id, $rr->name, $reverse_typemap{$type}, $rr->ttl);
[34]	1640
	1641	# "Primary" types:
	1642	# A, NS, CNAME, SOA, PTR(warn in forward), MX, TXT, AAAA, SRV, A6(ob), SPF
	1643	# maybe KEY
	1644
[35]	1645	# nasty big ugly case-like thing here, since we have to do some different
	1646	# processing depending on the record. le sigh.
	1647
[105]	1648	##fixme: what record types other than TXT can/will have >255-byte payloads?
	1649
[34]	1650	if ($type eq 'A') {
	1651	push @vallist, $rr->address;
	1652	} elsif ($type eq 'NS') {
[37]	1653	# hmm. should we warn here if subdomain NS'es are left alone?
	1654	next if ($rwns && ($rr->name eq $domain));
[34]	1655	push @vallist, $rr->nsdname;
[35]	1656	$nsflag = 1;
[34]	1657	} elsif ($type eq 'CNAME') {
	1658	push @vallist, $rr->cname;
	1659	} elsif ($type eq 'SOA') {
[37]	1660	next if $rwsoa;
[34]	1661	$vallist[1] = $rr->mname.":".$rr->rname;
	1662	push @vallist, ($rr->refresh.":".$rr->retry.":".$rr->expire.":".$rr->minimum);
[35]	1663	$soaflag = 1;
[34]	1664	} elsif ($type eq 'PTR') {
[105]	1665	push @vallist, $rr->ptrdname;
[34]	1666	# hmm. PTR records should not be in forward zones.
	1667	} elsif ($type eq 'MX') {
[33]	1668	$sql .= ",distance";
	1669	$vallen .= ",?";
[34]	1670	push @vallist, $rr->exchange;
	1671	push @vallist, $rr->preference;
	1672	} elsif ($type eq 'TXT') {
	1673	##fixme: Net::DNS docs say this should be deprecated for rdatastr() or char_str_list(),
	1674	## but don't really seem enthusiastic about it.
[105]	1675	my $rrdata = $rr->txtdata;
[130]	1676	push @vallist, $rrdata;
[34]	1677	} elsif ($type eq 'SPF') {
	1678	##fixme: and the same caveat here, since it is apparently a clone of ::TXT
[105]	1679	my $rrdata = $rr->txtdata;
[130]	1680	push @vallist, $rrdata;
[34]	1681	} elsif ($type eq 'AAAA') {
	1682	push @vallist, $rr->address;
	1683	} elsif ($type eq 'SRV') {
	1684	$sql .= ",distance,weight,port" if $type eq 'SRV';
	1685	$vallen .= ",?,?,?" if $type eq 'SRV';
[37]	1686	push @vallist, $rr->target;
[34]	1687	push @vallist, $rr->priority;
	1688	push @vallist, $rr->weight;
	1689	push @vallist, $rr->port;
	1690	} elsif ($type eq 'KEY') {
[35]	1691	# we don't actually know what to do with these...
[34]	1692	push @vallist, ($rr->flags.":".$rr->protocol.":".$rr->algorithm.":".$rr->key.":".$rr->keytag.":".$rr->privatekeyname);
[35]	1693	} else {
[105]	1694	my $rrdata = $rr->rdatastr;
[130]	1695	push @vallist, $rrdata;
[35]	1696	# Finding a different record type is not fatal.... just problematic.
[37]	1697	# We may not be able to export it correctly.
[35]	1698	$warnmsg .= "Unusual record ".$rr->name." ($type) found\n";
[33]	1699	}
	1700
[34]	1701	# BIND supports:
	1702	# A CNAME HINFO MB(ex) MD(ob) MF(ob) MG(ex) MINFO(ex) MR(ex) MX NS NULL
	1703	# PTR SOA TXT WKS AFSDB(ex) ISDN(ex) RP(ex) RT(ex) X25(ex) PX
	1704	# ... if one can ever find the right magic to format them correctly
	1705
	1706	# Net::DNS supports:
	1707	# RRSIG SIG NSAP NS NIMLOC NAPTR MX MR MINFO MG MB LOC ISDN IPSECKEY HINFO
	1708	# EID DNAME CNAME CERT APL AFSDB AAAA A DS NXT NSEC3PARAM NSEC3 NSEC KEY
	1709	# DNSKEY DLV X25 TXT TSIG TKEY SSHFP SRV SPF SOA RT RP PX PTR NULL APL::AplItem
	1710
[37]	1711	$sth = $dbh->prepare($sql.") VALUES (".$vallen.")") or die "problem preparing record insert SQL\n";
	1712	$sth->execute(@vallist) or die "failed to insert ".$rr->string.": ".$sth->errstr."\n";
[34]	1713
[37]	1714	$nrecs++;
[34]	1715
[37]	1716	} # while axfr_next
	1717
	1718	# Overwrite SOA record
	1719	if ($rwsoa) {
	1720	$soaflag = 1;
	1721	my $sthgetsoa = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?");
	1722	my $sthputsoa = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)");
	1723	$sthgetsoa->execute($group,$reverse_typemap{SOA});
	1724	while (my ($host,$val,$ttl) = $sthgetsoa->fetchrow_array()) {
	1725	$host =~ s/DOMAIN/$domain/g;
	1726	$val =~ s/DOMAIN/$domain/g;
	1727	$sthputsoa->execute($dom_id,$host,$reverse_typemap{SOA},$val,$ttl);
[34]	1728	}
[37]	1729	}
[34]	1730
[37]	1731	# Overwrite NS records
	1732	if ($rwns) {
	1733	$nsflag = 1;
	1734	my $sthgetns = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?");
	1735	my $sthputns = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)");
	1736	$sthgetns->execute($group,$reverse_typemap{NS});
	1737	while (my ($host,$val,$ttl) = $sthgetns->fetchrow_array()) {
	1738	$host =~ s/DOMAIN/$domain/g;
	1739	$val =~ s/DOMAIN/$domain/g;
	1740	$sthputns->execute($dom_id,$host,$reverse_typemap{NS},$val,$ttl);
	1741	}
	1742	}
[34]	1743
[35]	1744	die "No records found; either $ifrom is not authoritative or doesn't allow transfers\n" if !$nrecs;
	1745	die "Bad zone: No SOA record!\n" if !$soaflag;
	1746	die "Bad zone: No NS records!\n" if !$nsflag;
	1747
[37]	1748	$dbh->commit;
[35]	1749
[33]	1750	};
	1751
	1752	if ($@) {
	1753	my $msg = $@;
	1754	eval { $dbh->rollback; };
[34]	1755	return ('FAIL',$msg." $warnmsg");
[33]	1756	} else {
[35]	1757	return ('WARN', $warnmsg) if $warnmsg;
[91]	1758	return ('OK',"Imported OK");
[33]	1759	}
	1760
[37]	1761	# it should be impossible to get here.
[34]	1762	return ('WARN',"OOOK!");
[33]	1763	} # end importAXFR()
	1764
	1765
[103]	1766	## DNSDB::export()
	1767	# Export the DNS database, or a part of it
	1768	# Takes database handle, export type, optional arguments depending on type
	1769	# Writes zone data to targets as appropriate for type
	1770	sub export {
	1771	my $dbh = shift;
	1772	my $target = shift;
	1773
	1774	if ($target eq 'tiny') {
	1775	__export_tiny($dbh,@_);
	1776	}
	1777	# elsif ($target eq 'foo') {
	1778	# __export_foo($dbh,@_);
	1779	#}
	1780	# etc
	1781
	1782	} # end export()
	1783
	1784
	1785	## DNSDB::__export_tiny
	1786	# Internal sub to implement tinyDNS (compatible) export
	1787	# Takes database handle, filehandle to write export to, optional argument(s)
	1788	# to determine which data gets exported
	1789	sub __export_tiny {
	1790	my $dbh = shift;
	1791	my $datafile = shift;
	1792
	1793	##fixme: slurp up further options to specify particular zone(s) to export
	1794
	1795	## Convert a bare number into an octal-coded pair of octets.
	1796	# Take optional arg to indicate a decimal or hex input. Defaults to hex.
	1797	sub octalize {
	1798	my $tmp = shift;
	1799	my $srctype = shift \|\| 'h'; # default assumes hex string
	1800	$tmp = sprintf "%0.4x", hex($tmp) if $srctype eq 'h'; # 0-pad hex to 4 digits
	1801	$tmp = sprintf "%0.4x", $tmp if $srctype eq 'd'; # 0-pad decimal to 4 hex digits
	1802	my @o = ($tmp =~ /^(..)(..)$/); # split into octets
	1803	return sprintf "\\%0.3o\\%0.3o", hex($o[0]), hex($o[1]);;
	1804	}
	1805
	1806	##fixme: fail if $datafile isn't an open, writable file
	1807
	1808	# easy case - export all evarything
	1809	# not-so-easy case - export item(s) specified
	1810	# todo: figure out what kind of list we use to export items
	1811
	1812	my $domsth = $dbh->prepare("SELECT domain_id,domain,status FROM domains WHERE status=1");
[130]	1813	my $recsth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl ".
	1814	"FROM records WHERE domain_id=?");
[103]	1815	$domsth->execute();
	1816	while (my ($domid,$dom,$domstat) = $domsth->fetchrow_array) {
	1817	$recsth->execute($domid);
[130]	1818	while (my ($host,$type,$val,$dist,$weight,$port,$ttl) = $recsth->fetchrow_array) {
[108]	1819	##fixme: need to store location in the db, and retrieve it here.
	1820	# temporarily hardcoded to empty so we can include it further down.
	1821	my $loc = '';
	1822
	1823	##fixme: record validity timestamp. tinydns supports fiddling with timestamps.
	1824	# note $ttl must be set to 0 if we want to use tinydns's auto-expiring timestamps.
	1825	# timestamps are TAI64
	1826	# ~~ 2^62 + time()
	1827	my $stamp = '';
	1828
[103]	1829	# raw packet in unknown format: first byte indicates length
	1830	# of remaining data, allows up to 255 raw bytes
	1831
	1832	##fixme? append . to all host/val hostnames
	1833	if ($typemap{$type} eq 'SOA') {
	1834
	1835	# host contains pri-ns:responsible
	1836	# val is abused to contain refresh:retry:expire:minttl
	1837	##fixme: "manual" serial vs tinydns-autoserial
[108]	1838	print $datafile "Z$host"."::$val:$ttl:$stamp:$loc\n";
[103]	1839
	1840	} elsif ($typemap{$type} eq 'A') {
	1841
[108]	1842	print $datafile "+$host:$val:$ttl:$stamp:$loc\n";
[103]	1843
	1844	} elsif ($typemap{$type} eq 'NS') {
	1845
[108]	1846	print $datafile "\&$host"."::$val:$ttl:$stamp:$loc\n";
[103]	1847
	1848	} elsif ($typemap{$type} eq 'AAAA') {
	1849
	1850	print $datafile ":$host:28:";
	1851	my $altgrp = 0;
	1852	my @altconv;
[108]	1853	# Split in to up to 8 groups of hex digits (allows for IPv6 :: 0-collapsing)
[103]	1854	foreach (split /:/, $val) {
	1855	if (/^$/) {
	1856	# flag blank entry; this is a series of 0's of (currently) unknown length
	1857	$altconv[$altgrp++] = 's';
	1858	} else {
	1859	# call sub to convert 1-4 hex digits to 2 string-rep octal bytes
	1860	$altconv[$altgrp++] = octalize($_)
	1861	}
	1862	}
	1863	foreach my $octet (@altconv) {
	1864	# if not 's', output
	1865	print $datafile $octet unless $octet =~ /^s$/;
	1866	# if 's', output (9-array length)x literal '\000\000'
	1867	print $datafile '\000\000'x(9-$altgrp) if $octet =~ /^s$/;
	1868	}
[108]	1869	print $datafile ":$ttl:$stamp:$loc\n";
[103]	1870
	1871	} elsif ($typemap{$type} eq 'MX') {
	1872
[108]	1873	print $datafile "\@$host"."::$val:$dist:$ttl:$stamp:$loc\n";
[103]	1874
	1875	} elsif ($typemap{$type} eq 'TXT') {
	1876
	1877	##fixme: split v-e-r-y long TXT strings? will need to do so for BIND export, at least
	1878	$val =~ s/:/\\072/g; # may need to replace other symbols
[108]	1879	print $datafile "'$host:$val:$ttl:$stamp:$loc\n";
[103]	1880
	1881	# by-hand TXT
	1882	#:deepnet.cx:16:2v\075spf1\040a\040a\072bacon.deepnet.cx\040a\072home.deepnet.cx\040-all:3600
	1883	#@ IN TXT "v=spf1 a a:bacon.deepnet.cx a:home.deepnet.cx -all"
	1884	#'deepnet.cx:v=spf1 a a\072bacon.deepnet.cx a\072home.deepnet.cx -all:3600
	1885
	1886	#txttest IN TXT "v=foo bar:bob kn;ob' \" !@#$%^&*()-=_+[]{}<>?"
	1887	#:txttest.deepnet.cx:16:\054v\075foo\040bar\072bob\040kn\073ob\047\040\042\040\041\100\043\044\045\136\046\052\050\051-\075\137\053\133\135\173\175\074\076\077:3600
	1888
	1889	# very long TXT record as brought in by axfr-get
	1890	# note tinydns does not support >512-byte RR data, need axfr-dns (for TCP support) for that
	1891	# also note, tinydns does not seem to support <512, >256-byte RRdata from axfr-get either. :/
	1892	#:longtxt.deepnet.cx:16:
	1893	#\170this is a very long txt record. it is really long. long. very long. really very long. this is a very long txt record.
	1894	#\263 it is really long. long. very long. really very long. this is a very long txt record. it is really long. long. very long. really very long. this is a very long txt record.
	1895	#\351 it is really long. long. very long. really very long.this is a very long txt record. it is really long. long. very long. really very long. this is a very long txt record. it is really long. long. very long. really very long.
	1896	#:3600
	1897
	1898	} elsif ($typemap{$type} eq 'CNAME') {
	1899
[108]	1900	print $datafile "C$host:$val:$ttl:$stamp:$loc\n";
[103]	1901
	1902	} elsif ($typemap{$type} eq 'SRV') {
	1903
	1904	# data is two-byte values for priority, weight, port, in that order,
	1905	# followed by length/string data
	1906
	1907	print $datafile ":$host:33:".octalize($dist,'d').octalize($weight,'d').octalize($port,'d');
	1908
	1909	$val .= '.' if $val !~ /\.$/;
	1910	foreach (split /\./, $val) {
	1911	printf $datafile "\\%0.3o%s", length($_), $_;
	1912	}
[108]	1913	print $datafile "\\000:$ttl:$stamp:$loc\n";
[103]	1914
	1915	} elsif ($typemap{$type} eq 'RP') {
	1916
	1917	# RP consists of two mostly free-form strings.
	1918	# The first is supposed to be an email address with @ replaced by . (as with the SOA contact)
	1919	# The second is the "hostname" of a TXT record with more info.
	1920	print $datafile ":$host:17:";
	1921	my ($who,$what) = split /\s/, $val;
	1922	foreach (split /\./, $who) {
	1923	printf $datafile "\\%0.3o%s", length($_), $_;
	1924	}
	1925	print $datafile '\000';
	1926	foreach (split /\./, $what) {
	1927	printf $datafile "\\%0.3o%s", length($_), $_;
	1928	}
[108]	1929	print $datafile "\\000:$ttl:$stamp:$loc\n";
[103]	1930
	1931	} elsif ($typemap{$type} eq 'PTR') {
	1932
	1933	# must handle both IPv4 and IPv6
	1934	##work
[108]	1935	# data should already be in suitable reverse order.
	1936	print $datafile "^$host:$val:$ttl:$stamp:$loc\n";
[103]	1937
[108]	1938	} else {
	1939	# raw record. we don't know what's in here, so we ASS-U-ME the user has
	1940	# put it in correctly, since either the user is messing directly with the
	1941	# database, or the record was imported via AXFR
	1942	# <split by char>
	1943	# convert anything not a-zA-Z0-9.- to octal coding
	1944
	1945	##fixme: add flag to export "unknown" record types - note we'll probably end up
	1946	# mangling them since they were written to the DB from Net::DNS::RR::<type>->rdatastr.
	1947	#print $datafile ":$host:$type:$val:$ttl:$stamp:$loc\n";
	1948
[103]	1949	} # record type if-else
	1950
	1951	} # while ($recsth)
	1952	} # while ($domsth)
	1953	} # end __export_tiny()
	1954
	1955
[2]	1956	# shut Perl up
	1957	1;

Note: See TracBrowser for help on using the repository browser.

Download in other formats: