Context Navigation

source: trunk/DNSDB.pm@ 117

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

/trunk

Add getParents (untested) and isParent (tested) subs
Add some supporting hashes for entity -> parent(entity)

relationships in the database - private to DNSDB.pm

Rename tmp_ruri to uri_self for clarity and reuse
Move uri_self munging from ##common area so that more

subs can use it

Update group tree to change the current group by clicking

the group name. Working comments need to be cleaned up
and choose-a-group dropdown removed from the menu

Property svn:keywords set to Date Rev Author Id

File size: 58.9 KB

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

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

Download in other formats: