Context Navigation

source: trunk/DNSDB.pm@ 171

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

/trunk

Session management

expire sessions properly
remove session ID from login page
load session timeout value from config file

Remove some more stale comments
Fix centering of login box on login page

Property svn:keywords set to Date Rev Author Id

File size: 60.1 KB

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

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

Download in other formats: