Context Navigation

source: trunk/DNSDB.pm@ 225

Last change on this file since 225 was 225, checked in by Kris Deugau, 12 years ago

/trunk

Move some SQL into DNSDB.pm (see #1):
fill_rectypes is now getTypelist, and updated for reverse zones
and the custom DNS record types
Also apply a couple of small nitpick fixes in formatting and spelling

Property svn:keywords set to Date Rev Author Id

File size: 69.2 KB

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

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

Download in other formats: