source: trunk/DNSDB.pm@ 63

Last change on this file since 63 was 62, checked in by Kris Deugau, 15 years ago

/trunk

checkpoint
dns.cgi:

Fix lurking rebuglet on removing search filter
Add logging on domain active/inactive
Make sure to propagate error messages on domain add/delete as required
Logging of domain add/delete should now be complete
Record add/delete/update logging should be complete (not completely tested)
Explicitly set $startwith, $filter, and $searchsubs in listdomains()

DNSDB.pm:

Remove debugging cruft in DNSDB
Return the parent ID for a record in getRecLine
Normalize some SQL formatting
  • Property svn:keywords set to Date Rev Author Id
File size: 32.2 KB
Line 
1# dns/trunk/DNSDB.pm
2# Abstraction functions for DNS administration
3###
4# SVN revision info
5# $Date: 2010-01-19 21:50:05 +0000 (Tue, 19 Jan 2010) $
6# SVN revision $Rev: 62 $
7# Last update by $Author: kdeugau $
8###
9# Copyright (C) 2008 - Kris Deugau <kdeugau@deepnet.cx>
10
11package DNSDB;
12
13use strict;
14use warnings;
15use Exporter;
16use DBI;
17use Net::DNS;
18#use Net::SMTP;
19#use NetAddr::IP qw( Compact );
20#use POSIX;
21use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
22
23$VERSION = 0.1;
24@ISA = qw(Exporter);
25@EXPORT_OK = qw(
26 &initGlobals &connectDB &finish
27 &addDomain &delDomain &domainName
28 &addGroup &delGroup &getChildren &groupName
29 &addUser &delUser &userFullName &userStatus
30 &getSOA &getRecLine &getDomRecs
31 &addRec &updateRec &delRec
32 &domStatus &importAXFR
33 %typemap %reverse_typemap
34 );
35
36@EXPORT = (); # Export nothing by default.
37%EXPORT_TAGS = ( ALL => [qw(
38 &initGlobals &connectDB &finish
39 &addDomain &delDomain &domainName
40 &addGroup &delGroup &getChildren &groupName
41 &addUser &delUser &userFullName &userStatus
42 &getSOA &getRecLine &getDomRecs
43 &addRec &updateRec &delRec
44 &domStatus &importAXFR
45 %typemap %reverse_typemap
46 )]
47 );
48
49our $group = 1;
50our $errstr = '';
51
52# Halfway sane defaults for SOA, TTL, etc.
53our %def = qw (
54 contact hostmaster.DOMAIN
55 prins ns1.myserver.com
56 soattl 86400
57 refresh 10800
58 retry 3600
59 expire 604800
60 minttl 10800
61 ttl 10800
62);
63
64# DNS record type map and reverse map.
65# loaded from the database, from http://www.iana.org/assignments/dns-parameters
66our %typemap;
67our %reverse_typemap;
68
69
70##
71## Initialization and cleanup subs
72##
73
74
75## DNSDB::connectDB()
76# Creates connection to DNS database.
77# Requires the database name, username, and password.
78# Returns a handle to the db.
79# Set up for a PostgreSQL db; could be any transactional DBMS with the
80# right changes.
81sub connectDB {
82 $errstr = '';
83 my $dbname = shift;
84 my $user = shift;
85 my $pass = shift;
86 my $dbh;
87 my $DSN = "DBI:Pg:dbname=$dbname";
88
89 my $host = shift;
90 $DSN .= ";host=$host" if $host;
91
92# Note that we want to autocommit by default, and we will turn it off locally as necessary.
93# We may not want to print gobbledygook errors; YMMV. Have to ponder that further.
94 $dbh = DBI->connect($DSN, $user, $pass, {
95 AutoCommit => 1,
96 PrintError => 0
97 })
98 or return (undef, $DBI::errstr) if(!$dbh);
99
100# Return here if we can't select. Note that this indicates a
101# problem executing the select.
102 my $sth = $dbh->prepare("select group_id from groups limit 1");
103 $sth->execute();
104 return (undef,$DBI::errstr) if ($sth->err);
105
106# See if the select returned anything (or null data). This should
107# succeed if the select executed, but...
108 $sth->fetchrow();
109 return (undef,$DBI::errstr) if ($sth->err);
110
111 $sth->finish;
112
113# If we get here, we should be OK.
114 return ($dbh,"DB connection OK");
115} # end connectDB
116
117
118## DNSDB::finish()
119# Cleans up after database handles and so on.
120# Requires a database handle
121sub finish {
122 my $dbh = $_[0];
123 $dbh->disconnect;
124} # end finish
125
126
127## DNSDB::initGlobals()
128# Initialize global variables
129# NB: this does NOT include web-specific session variables!
130# Requires a database handle
131sub initGlobals {
132 my $dbh = shift;
133
134# load system-wide site defaults and things from config file
135 if (open SYSDEFAULTS, "</etc/dnsdb.conf") {
136##fixme - error check!
137 while (<SYSDEFAULTS>) {
138 next if /^\s*#/;
139 $def{contact} = $1 if /contact ?= ?([a-z0-9_.-]+)/i;
140 $def{prins} = $1 if /prins ?= ?([a-z0-9_.-]+)/i;
141 $def{soattl} = $1 if /soattl ?= ?([a-z0-9_.-]+)/i;
142 $def{refresh} = $1 if /refresh ?= ?([a-z0-9_.-]+)/i;
143 $def{retry} = $1 if /retry ?= ?([a-z0-9_.-]+)/i;
144 $def{expire} = $1 if /expire ?= ?([a-z0-9_.-]+)/i;
145 $def{minttl} = $1 if /minttl ?= ?([a-z0-9_.-]+)/i;
146 $def{ttl} = $1 if /ttl ?= ?([a-z0-9_.-]+)/i;
147##fixme? load DB user/pass from config file?
148 }
149 }
150# load from database
151 my $sth = $dbh->prepare("select val,name from rectypes");
152 $sth->execute;
153 while (my ($recval,$recname) = $sth->fetchrow_array()) {
154 $typemap{$recval} = $recname;
155 $reverse_typemap{$recname} = $recval;
156 }
157} # end initGlobals
158
159
160## DNSDB::_log()
161# Log an action
162# Internal sub
163# Takes a database handle, <foo>, <bar>
164sub _log {
165} # end _log
166
167
168##
169## Processing subs
170##
171
172## DNSDB::addDomain()
173# Add a domain
174# Takes a database handle, domain name, numeric group, and boolean(ish) state (active/inactive)
175# Returns a status code and message
176sub addDomain {
177 $errstr = '';
178 my $dbh = shift;
179 return ('FAIL',"Need database handle") if !$dbh;
180 my $domain = shift;
181 return ('FAIL',"Need domain") if !defined($domain);
182 my $group = shift;
183 return ('FAIL',"Need group") if !defined($group);
184 my $state = shift;
185 return ('FAIL',"Need domain status") if !defined($state);
186
187 my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
188 my $dom_id;
189
190# quick check to start to see if we've already got one
191 $sth->execute($domain);
192 ($dom_id) = $sth->fetchrow_array;
193
194 return ('FAIL', "Domain already exists") if $dom_id;
195
196 # Allow transactions, and raise an exception on errors so we can catch it later.
197 # Use local to make sure these get "reset" properly on exiting this block
198 local $dbh->{AutoCommit} = 0;
199 local $dbh->{RaiseError} = 1;
200
201 # Wrap all the SQL in a transaction
202 eval {
203 # insert the domain...
204 my $sth = $dbh->prepare("insert into domains (domain,group_id,status) values (?,?,?)");
205 $sth->execute($domain,$group,$state);
206
207 # get the ID...
208 $sth = $dbh->prepare("select domain_id from domains where domain='$domain'");
209 $sth->execute;
210 ($dom_id) = $sth->fetchrow_array();
211
212 # ... and now we construct the standard records from the default set. NB: group should be variable.
213 $sth = $dbh->prepare("select host,type,val,distance,weight,port,ttl from default_records where group_id=$group");
214 my $sth_in = $dbh->prepare("insert into records (domain_id,host,type,val,distance,weight,port,ttl)".
215 " values ($dom_id,?,?,?,?,?,?,?)");
216 $sth->execute;
217 while (my ($host,$type,$val,$dist,$weight,$port,$ttl) = $sth->fetchrow_array()) {
218 $host =~ s/DOMAIN/$domain/g;
219 $val =~ s/DOMAIN/$domain/g;
220 $sth_in->execute($host,$type,$val,$dist,$weight,$port,$ttl);
221 }
222
223 # once we get here, we should have suceeded.
224 $dbh->commit;
225 }; # end eval
226
227 if ($@) {
228 my $msg = $@;
229 eval { $dbh->rollback; };
230 return ('FAIL',$msg);
231 } else {
232 return ('OK',$dom_id);
233 }
234} # end addDomain
235
236
237## DNSDB::delDomain()
238# Delete a domain.
239# for now, just delete the records, then the domain.
240# later we may want to archive it in some way instead (status code 2, for example?)
241sub delDomain {
242 my $dbh = shift;
243 my $domid = shift;
244
245 # Allow transactions, and raise an exception on errors so we can catch it later.
246 # Use local to make sure these get "reset" properly on exiting this block
247 local $dbh->{AutoCommit} = 0;
248 local $dbh->{RaiseError} = 1;
249
250 my $failmsg = '';
251
252 # Wrap all the SQL in a transaction
253 eval {
254 my $sth = $dbh->prepare("delete from records where domain_id=?");
255 $failmsg = "Failure removing domain records";
256 $sth->execute($domid);
257 $sth = $dbh->prepare("delete from domains where domain_id=?");
258 $failmsg = "Failure removing domain";
259 $sth->execute($domid);
260
261 # once we get here, we should have suceeded.
262 $dbh->commit;
263 }; # end eval
264
265 if ($@) {
266 my $msg = $@;
267 eval { $dbh->rollback; };
268 return ('FAIL',"$failmsg: $msg");
269 } else {
270 return ('OK','OK');
271 }
272
273} # end delDomain()
274
275
276## DNSDB::domainName()
277# Return the domain name based on a domain ID
278# Takes a database handle and the domain ID
279# Returns the domain name or undef on failure
280sub domainName {
281 $errstr = '';
282 my $dbh = shift;
283 my $domid = shift;
284 my $sth = $dbh->prepare("select domain from domains where domain_id=?");
285 $sth->execute($domid);
286 my ($domname) = $sth->fetchrow_array();
287 $errstr = $DBI::errstr if !$domname;
288 return $domname if $domname;
289} # end domainName
290
291
292## DNSDB::addGroup()
293# Add a group
294# Takes a database handle, group name, parent group, and template-vs-cloneme flag
295# Returns a status code and message
296sub addGroup {
297 $errstr = '';
298 my $dbh = shift;
299 my $groupname = shift;
300 my $pargroup = shift;
301
302 # 0 indicates "template", hardcoded.
303 # Any other value clones that group's default records, if it exists.
304 my $torc = shift || 0;
305
306 # Allow transactions, and raise an exception on errors so we can catch it later.
307 # Use local to make sure these get "reset" properly on exiting this block
308 local $dbh->{AutoCommit} = 0;
309 local $dbh->{RaiseError} = 1;
310
311 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE group_name=?");
312 my $group_id;
313
314# quick check to start to see if we've already got one
315 $sth->execute($groupname);
316 ($group_id) = $sth->fetchrow_array;
317
318 return ('FAIL', "Group already exists") if $group_id;
319
320 # Wrap all the SQL in a transaction
321 eval {
322 $sth = $dbh->prepare("INSERT INTO groups (parent_group_id,group_name) VALUES (?,?)");
323 $sth->execute($pargroup,$groupname);
324
325 $sth = $dbh->prepare("SELECT group_id FROM groups WHERE group_name=?");
326 $sth->execute($groupname);
327 my ($groupid) = $sth->fetchrow_array();
328
329 $sth = $dbh->prepare("INSERT INTO default_records (group_id,host,type,val,distance,weight,port,ttl) ".
330 "VALUES ($groupid,?,?,?,?,?,?,?)");
331 if ($torc) {
332 my $sth2 = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
333 while (my @clonedata = $sth2->fetchrow_array) {
334 $sth->execute(@clonedata);
335 }
336 } else {
337 # reasonable basic defaults for SOA, MX, NS, and minimal hosting
338 # could load from a config file, but somewhere along the line we need hardcoded bits.
339 $sth->execute('ns1.example.com:hostmaster.example.com', 6, '10800:3600:604800:10800', 0, 0, 0, 86400);
340 $sth->execute('DOMAIN', 1, '192.168.4.2', 0, 0, 0, 7200);
341 $sth->execute('DOMAIN', 15, 'mx.example.com', 10, 0, 0, 7200);
342 $sth->execute('DOMAIN', 2, 'ns1.example.com', 0, 0, 0, 7200);
343 $sth->execute('DOMAIN', 2, 'ns2.example.com', 0, 0, 0, 7200);
344 $sth->execute('www.DOMAIN', 5, 'DOMAIN', 0, 0, 0, 7200);
345 }
346
347 # once we get here, we should have suceeded.
348 $dbh->commit;
349 }; # end eval
350
351 if ($@) {
352 my $msg = $@;
353 eval { $dbh->rollback; };
354 return ('FAIL',$msg);
355 } else {
356 return ('OK','OK');
357 }
358
359} # end addGroup()
360
361
362## DNSDB::delGroup()
363# Delete a group.
364# Takes a group ID
365# Returns a status code and message
366sub delGroup {
367 my $dbh = shift;
368 my $groupid = shift;
369
370 # Allow transactions, and raise an exception on errors so we can catch it later.
371 # Use local to make sure these get "reset" properly on exiting this block
372 local $dbh->{AutoCommit} = 0;
373 local $dbh->{RaiseError} = 1;
374
375##fixme: locate "knowable" error conditions and deal with them before the eval
376# ... or inside, whatever.
377# -> domains still exist in group
378# -> ...
379 my $failmsg = '';
380
381 # Wrap all the SQL in a transaction
382 eval {
383 my $sth = $dbh->prepare("SELECT count(*) FROM domains WHERE group_id=?");
384 $sth->execute($groupid);
385 my ($domcnt) = $sth->fetchrow_array;
386 $failmsg = "Can't remove group ".groupName($dbh,$groupid);
387 die "$domcnt domains still in group\n" if $domcnt;
388
389 $sth = $dbh->prepare("delete from default_records where group_id=?");
390 $failmsg = "Failed to delete default records for ".groupName($dbh,$groupid);
391 $sth->execute($groupid);
392 $sth = $dbh->prepare("delete from groups where group_id=?");
393 $failmsg = "Failed to remove group ".groupName($dbh,$groupid);
394 $sth->execute($groupid);
395
396 # once we get here, we should have suceeded.
397 $dbh->commit;
398 }; # end eval
399
400 if ($@) {
401 my $msg = $@;
402 eval { $dbh->rollback; };
403 return ('FAIL',"$failmsg: $msg");
404 } else {
405 return ('OK','OK');
406 }
407} # end delGroup()
408
409
410## DNSDB::getChildren()
411# Get a list of all groups whose parent^n is group <n>
412# Takes a database handle, group ID, reference to an array to put the group IDs in,
413# and an optional flag to return only immediate children or all children-of-children
414# default to returning all children
415# Calls itself
416sub getChildren {
417 $errstr = '';
418 my $dbh = shift;
419 my $rootgroup = shift;
420 my $groupdest = shift;
421 my $immed = shift || 'all';
422
423 # special break for default group; otherwise we get stuck.
424 if ($rootgroup == 1) {
425 # by definition, group 1 is the Root Of All Groups
426 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE NOT (group_id=1)".
427 ($immed ne 'all' ? " AND parent_group_id=1" : ''));
428 $sth->execute;
429 while (my @this = $sth->fetchrow_array) {
430 push @$groupdest, @this;
431 }
432 } else {
433 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE parent_group_id=?");
434 $sth->execute($rootgroup);
435 return if $sth->rows == 0;
436 my @grouplist;
437 while (my ($group) = $sth->fetchrow_array) {
438 push @$groupdest, $group;
439 getChildren($dbh,$group,$groupdest) if $immed eq 'all';
440 }
441 }
442} # end getChildren()
443
444
445## DNSDB::groupName()
446# Return the group name based on a group ID
447# Takes a database handle and the group ID
448# Returns the group name or undef on failure
449sub groupName {
450 $errstr = '';
451 my $dbh = shift;
452 my $groupid = shift;
453 my $sth = $dbh->prepare("SELECT group_name FROM groups WHERE group_id=?");
454 $sth->execute($groupid);
455 my ($groupname) = $sth->fetchrow_array();
456 $errstr = $DBI::errstr if !$groupname;
457 return $groupname if $groupname;
458} # end groupName
459
460
461## DNSDB::addUser()
462#
463sub addUser {
464 $errstr = '';
465 my $dbh = shift;
466 return ('FAIL',"Need database handle") if !$dbh;
467 my $username = shift;
468 return ('FAIL',"Missing username") if !defined($username);
469 my $group = shift;
470 return ('FAIL',"Missing group") if !defined($group);
471 my $pass = shift;
472 return ('FAIL',"Missing password") if !defined($pass);
473 my $state = shift;
474 return ('FAIL',"Need account status") if !defined($state);
475
476 my $type = shift || 'u'; # create limited users by default - fwiw, not sure yet how this will interact with ACLs
477
478 my $fname = shift || $username;
479 my $lname = shift || '';
480 my $phone = shift || ''; # not going format-check
481
482 my $sth = $dbh->prepare("SELECT user_id FROM users WHERE username=?");
483 my $user_id;
484
485# quick check to start to see if we've already got one
486 $sth->execute($username);
487 ($user_id) = $sth->fetchrow_array;
488
489 return ('FAIL', "User already exists") if $user_id;
490
491 # Allow transactions, and raise an exception on errors so we can catch it later.
492 # Use local to make sure these get "reset" properly on exiting this block
493 local $dbh->{AutoCommit} = 0;
494 local $dbh->{RaiseError} = 1;
495
496 # Wrap all the SQL in a transaction
497 eval {
498 # insert the user...
499 my $sth = $dbh->prepare("INSERT INTO users (group_id,username,password,firstname,lastname,phone,type,status) ".
500 "VALUES (?,?,?,?,?,?,?,?)");
501 $sth->execute($group,$username,unix_md5_crypt($pass),$fname,$lname,$phone,$type,$state);
502
503 # get the ID...
504 $sth = $dbh->prepare("select user_id from users where username=?");
505 $sth->execute($username);
506 ($user_id) = $sth->fetchrow_array();
507
508##fixme: add another table to hold name/email for log table?
509
510 # once we get here, we should have suceeded.
511 $dbh->commit;
512 }; # end eval
513
514 if ($@) {
515 my $msg = $@;
516 eval { $dbh->rollback; };
517 return ('FAIL',$msg);
518 } else {
519 return ('OK',$user_id);
520 }
521} # end addUser
522
523
524## DNSDB::checkUser()
525# Check user/pass combo on login
526sub checkUser {
527 my $dbh = shift;
528 my $user = shift;
529 my $inpass = shift;
530
531 my $sth = $dbh->prepare("SELECT user_id,group_id,password,firstname,lastname FROM users WHERE username=?");
532 $sth->execute($user);
533 my ($uid,$gid,$pass,$fname,$lname) = $sth->fetchrow_array;
534 my $loginfailed = 1 if !defined($uid);
535
536 if ($pass =~ m|^\$1\$([A-Za-z0-9/.]+)\$|) {
537 $loginfailed = 1 if $pass ne unix_md5_crypt($inpass,$1);
538 } else {
539 $loginfailed = 1 if $pass ne $inpass;
540 }
541
542 # nnnngggg
543 return ($uid, $gid);
544} # end checkUser
545
546
547## DNSDB::delUser()
548#
549sub delUser {
550 my $dbh = shift;
551 return ('FAIL',"Need database handle") if !$dbh;
552 my $userid = shift;
553 return ('FAIL',"Missing userid") if !defined($userid);
554
555 my $sth = $dbh->prepare("delete from users where user_id=?");
556 $sth->execute($userid);
557
558 return ('FAIL',"Couldn't remove user: ".$sth->errstr) if $sth->err;
559
560 return ('OK','OK');
561
562} # end delUser
563
564
565## DNSDB::userFullName()
566# Return a pretty string!
567# Takes a user_id and optional printf-ish string to indicate which pieces where:
568# %u for the username
569# %f for the first name
570# %l for the last name
571# All other text in the passed string will be left as-is.
572##fixme: need a "smart" option too, so that missing/null/blank first/last names don't give funky output
573sub userFullName {
574 $errstr = '';
575 my $dbh = shift;
576 my $userid = shift;
577 my $fullformat = shift || '%f %l (%u)';
578 my $sth = $dbh->prepare("select username,firstname,lastname from users where user_id=?");
579 $sth->execute($userid);
580 my ($uname,$fname,$lname) = $sth->fetchrow_array();
581 $errstr = $DBI::errstr if !$uname;
582
583 $fullformat =~ s/\%u/$uname/g;
584 $fullformat =~ s/\%f/$fname/g;
585 $fullformat =~ s/\%l/$lname/g;
586
587 return $fullformat;
588} # end userFullName
589
590
591## DNSDB::userStatus()
592# Sets and/or returns a user's status
593# Takes a database handle, user ID and optionally a status argument
594# Returns undef on errors.
595sub userStatus {
596 my $dbh = shift;
597 my $id = shift;
598 my $newstatus = shift;
599
600 return undef if $id !~ /^\d+$/;
601
602 my $sth;
603
604# ooo, fun! let's see what we were passed for status
605 if ($newstatus) {
606 $sth = $dbh->prepare("update users set status=? where user_id=?");
607 # ass-u-me caller knows what's going on in full
608 if ($newstatus =~ /^[01]$/) { # only two valid for now.
609 $sth->execute($newstatus,$id);
610 } elsif ($newstatus =~ /^usero(?:n|ff)$/) {
611 $sth->execute(($newstatus eq 'useron' ? 1 : 0),$id);
612 }
613 }
614
615 $sth = $dbh->prepare("select status from users where user_id=?");
616 $sth->execute($id);
617 my ($status) = $sth->fetchrow_array;
618 return $status;
619} # end userStatus()
620
621
622## DNSDB::editRecord()
623# Change an existing record
624# Takes a database handle, default/live flag, record ID, and new data and updates the data fields for it
625sub editRecord {
626 $errstr = '';
627 my $dbh = shift;
628 my $defflag = shift;
629 my $recid = shift;
630 my $host = shift;
631 my $address = shift;
632 my $distance = shift;
633 my $weight = shift;
634 my $port = shift;
635 my $ttl = shift;
636}
637
638
639## DNSDB::getSOA()
640# Return all suitable fields from an SOA record in separate elements of a hash
641# Takes a database handle, default/live flag, and group (default) or domain (live) ID
642sub getSOA {
643 $errstr = '';
644 my $dbh = shift;
645 my $def = shift;
646 my $id = shift;
647 my %ret;
648
649 my $sql = "select record_id,host,val,ttl from";
650 if ($def eq 'def' or $def eq 'y') {
651 $sql .= " default_records where group_id=$id and type=$reverse_typemap{SOA}";
652 } else {
653 # we're editing a live SOA record; find based on domain
654 $sql .= " records where domain_id=$id and type=$reverse_typemap{SOA}";
655 }
656 my $sth = $dbh->prepare($sql);
657 $sth->execute;
658
659 my ($recid,$host,$val,$ttl) = $sth->fetchrow_array();
660 my ($prins,$contact) = split /:/, $host;
661 my ($refresh,$retry,$expire,$minttl) = split /:/, $val;
662
663 $ret{recid} = $recid;
664 $ret{ttl} = $ttl;
665 $ret{prins} = $prins;
666 $ret{contact} = $contact;
667 $ret{refresh} = $refresh;
668 $ret{retry} = $retry;
669 $ret{expire} = $expire;
670 $ret{minttl} = $minttl;
671
672 return %ret;
673} # end getSOA()
674
675
676## DNSDB::getRecLine()
677# Return all data fields for a zone record in separate elements of a hash
678# Takes a database handle, default/live flag, and record ID
679sub getRecLine {
680 $errstr = '';
681 my $dbh = shift;
682 my $def = shift;
683 my $id = shift;
684
685 my $sql = "SELECT record_id,host,type,val,distance,weight,port,ttl".
686 (($def eq 'def' or $def eq 'y') ? ',group_id FROM default_' : ',domain_id FROM ').
687 "records WHERE record_id=?";
688 my $sth = $dbh->prepare($sql);
689 $sth->execute($id);
690
691 my ($recid,$host,$rtype,$val,$distance,$weight,$port,$ttl,$parid) = $sth->fetchrow_array();
692
693 if ($sth->err) {
694 $errstr = $DBI::errstr;
695 return undef;
696 }
697 my %ret;
698 $ret{recid} = $recid;
699 $ret{host} = $host;
700 $ret{type} = $rtype;
701 $ret{val} = $val;
702 $ret{distance}= $distance;
703 $ret{weight} = $weight;
704 $ret{port} = $port;
705 $ret{ttl} = $ttl;
706 $ret{parid} = $parid;
707
708 return %ret;
709}
710
711
712##fixme: should use above (getRecLine()) to get lines for below?
713## DNSDB::getDomRecs()
714# Return records for a domain
715# Takes a database handle, default/live flag, group/domain ID, start,
716# number of records, sort field, and sort order
717# Returns a reference to an array of hashes
718sub getDomRecs {
719 $errstr = '';
720 my $dbh = shift;
721 my $type = shift;
722 my $id = shift;
723 my $nrecs = shift || 'all';
724 my $nstart = shift || 0;
725
726## for order, need to map input to column names
727 my $order = shift || 'host';
728
729 my $sql = "SELECT record_id,host,type,val,distance,weight,port,ttl FROM ";
730 if ($type eq 'def' or $type eq 'y') {
731 $sql .= " default_records where group_id=$id";
732 } else {
733 $sql .= " records where domain_id=$id";
734 }
735 $sql .= " and not type=$reverse_typemap{SOA} order by $order";
736##fixme: need to set nstart properly (offset is not internally multiplied with limit)
737 $sql .= " limit $nrecs offset ".($nstart*$nrecs) if $nstart ne 'all';
738
739 my $sth = $dbh->prepare($sql);
740 $sth->execute;
741
742 my @retbase;
743 while (my $ref = $sth->fetchrow_hashref()) {
744 push @retbase, $ref;
745 }
746
747 my $ret = \@retbase;
748 return $ret;
749} # end getDomRecs()
750
751
752## DNSDB::addRec()
753# Add a new record to a domain or a group's default records
754# Takes a database handle, default/live flag, group/domain ID,
755# host, type, value, and TTL
756# Some types require additional detail: "distance" for MX and SRV,
757# and weight/port for SRV
758# Returns a status code and detail message in case of error
759sub addRec {
760 $errstr = '';
761 my $dbh = shift;
762 my $defrec = shift;
763 my $id = shift;
764
765 my $host = shift;
766 my $rectype = shift;
767 my $val = shift;
768 my $ttl = shift;
769
770 my $fields = ($defrec eq 'y' ? 'group_id' : 'domain_id').",host,type,val,ttl";
771 my $vallen = "?,?,?,?,?";
772 my @vallist = ($id,$host,$rectype,$val,$ttl);
773
774 my $dist;
775 if ($rectype == $reverse_typemap{MX} or $rectype == $reverse_typemap{SRV}) {
776 $dist = shift;
777 return ('FAIL',"Need distance for $typemap{$rectype} record") if !defined($dist);
778 $fields .= ",distance";
779 $vallen .= ",?";
780 push @vallist, $dist;
781 }
782 my $weight;
783 my $port;
784 if ($rectype == $reverse_typemap{SRV}) {
785 # check for _service._protocol. NB: RFC2782 does not say "MUST"... nor "SHOULD"...
786 # it just says (paraphrased) "... is prepended with _ to prevent DNS collisions"
787 return ('FAIL',"SRV records must begin with _service._protocol")
788 if $host !~ /^_[A-Za-z]+\._[A-Za-z]+\.[a-z0-9-]+/;
789 $weight = shift;
790 $port = shift;
791 return ('FAIL',"Need weight and port for SRV record") if !defined($weight) or !defined($port);
792 $fields .= ",weight,port";
793 $vallen .= ",?,?";
794 push @vallist, ($weight,$port);
795 }
796
797 my $sql = "insert into ".($defrec eq 'y' ? 'default_' : '')."records ($fields) values ($vallen)";
798##fixme: use array for values, replace "vallist" with series of ?,?,? etc
799# something is bugging me about this...
800#warn "DEBUG: $sql";
801 my $sth = $dbh->prepare($sql);
802 $sth->execute(@vallist);
803
804 return ('FAIL',$sth->errstr) if $sth->err;
805
806 return ('OK','OK');
807} # end addRec()
808
809
810## DNSDB::updateRec()
811# Update a record
812sub updateRec {
813 $errstr = '';
814
815 my $dbh = shift;
816 my $defrec = shift;
817 my $id = shift;
818
819# all records have these
820 my $host = shift;
821 my $type = shift;
822 my $val = shift;
823 my $ttl = shift;
824
825 return('FAIL',"Missing standard argument(s)") if !defined($ttl);
826
827# only MX and SRV will use these
828 my $dist = 0;
829 my $weight = 0;
830 my $port = 0;
831
832 if ($type == $reverse_typemap{MX} || $type == $reverse_typemap{SRV}) {
833 $dist = shift;
834 return ('FAIL',"MX or SRV requires distance") if !defined($dist);
835 if ($type == $reverse_typemap{SRV}) {
836 $weight = shift;
837 return ('FAIL',"SRV requires weight") if !defined($weight);
838 $port = shift;
839 return ('FAIL',"SRV requires port") if !defined($port);
840 }
841 }
842
843 my $sth = $dbh->prepare("UPDATE ".($defrec eq 'y' ? 'default_' : '')."records ".
844 "SET host=?,type=?,val=?,ttl=?,distance=?,weight=?,port=? ".
845 "WHERE record_id=?");
846 $sth->execute($host,$type,$val,$ttl,$dist,$weight,$port,$id);
847
848 return ('FAIL',$sth->errstr."<br>\n$errstr<br>\n") if $sth->err;
849
850 return ('OK','OK');
851} # end updateRec()
852
853
854## DNSDB::delRec()
855# Delete a record.
856sub delRec {
857 $errstr = '';
858 my $dbh = shift;
859 my $defrec = shift;
860 my $id = shift;
861
862return "FAIL", "wakka wakka";
863 my $sth = $dbh->prepare("DELETE FROM ".($defrec eq 'y' ? 'default_' : '')."records WHERE record_id=?");
864 $sth->execute($id);
865
866 return ('FAIL',"Couldn't remove record: ".$sth->errstr) if $sth->err;
867
868 return ('OK','OK');
869} # end delRec()
870
871
872## DNSDB::domStatus()
873# Sets and/or returns a domain's status
874# Takes a database handle, domain ID and optionally a status argument
875# Returns undef on errors.
876sub domStatus {
877 my $dbh = shift;
878 my $id = shift;
879 my $newstatus = shift;
880
881 return undef if $id !~ /^\d+$/;
882
883 my $sth;
884
885# ooo, fun! let's see what we were passed for status
886 if ($newstatus) {
887 $sth = $dbh->prepare("update domains set status=? where domain_id=?");
888 # ass-u-me caller knows what's going on in full
889 if ($newstatus =~ /^[01]$/) { # only two valid for now.
890 $sth->execute($newstatus,$id);
891 } elsif ($newstatus =~ /^domo(?:n|ff)$/) {
892 $sth->execute(($newstatus eq 'domon' ? 1 : 0),$id);
893 }
894 }
895
896 $sth = $dbh->prepare("select status from domains where domain_id=?");
897 $sth->execute($id);
898 my ($status) = $sth->fetchrow_array;
899 return $status;
900} # end domStatus()
901
902
903## DNSDB::importAXFR
904# Import a domain via AXFR
905# Takes AXFR host, domain to transfer, group to put the domain in,
906# and optionally:
907# - active/inactive state flag (defaults to active)
908# - overwrite-SOA flag (defaults to off)
909# - overwrite-NS flag (defaults to off, doesn't affect subdomain NS records)
910# Returns a status code (OK, WARN, or FAIL) and message - message should be blank
911# if status is OK, but WARN includes conditions that are not fatal but should
912# really be reported.
913sub importAXFR {
914 my $dbh = shift;
915 my $ifrom_in = shift;
916 my $domain = shift;
917 my $group = shift;
918 my $status = shift || 1;
919 my $rwsoa = shift || 0;
920 my $rwns = shift || 0;
921
922##fixme: add mode to delete&replace, merge+overwrite, merge new?
923
924 my $nrecs = 0;
925 my $soaflag = 0;
926 my $nsflag = 0;
927 my $warnmsg = '';
928 my $ifrom;
929
930 # choke on possible bad setting in ifrom
931 # IPv4 and v6, and valid hostnames!
932 ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i);
933 return ('FAIL', "Bad AXFR source host $ifrom")
934 unless ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i);
935
936 # Allow transactions, and raise an exception on errors so we can catch it later.
937 # Use local to make sure these get "reset" properly on exiting this block
938 local $dbh->{AutoCommit} = 0;
939 local $dbh->{RaiseError} = 1;
940
941 my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
942 my $dom_id;
943
944# quick check to start to see if we've already got one
945 $sth->execute($domain);
946 ($dom_id) = $sth->fetchrow_array;
947
948 return ('FAIL', "Domain already exists") if $dom_id;
949
950 eval {
951 # can't do this, can't nest transactions. sigh.
952 #my ($dcode, $dmsg) = addDomain(dbh, domain, group, status);
953
954##fixme: serial
955 my $sth = $dbh->prepare("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)");
956 $sth->execute($domain,$group,$status);
957
958## bizarre DBI<->Net::DNS interaction bug:
959## sometimes a zone will cause an immediate commit-and-exit (sort of) of the while()
960## fixed, apparently I was doing *something* odd, but not certain what it was that
961## caused a commit instead of barfing
962
963 # get domain id so we can do the records
964 $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
965 $sth->execute($domain);
966 ($dom_id) = $sth->fetchrow_array();
967
968 my $res = Net::DNS::Resolver->new;
969 $res->nameservers($ifrom);
970 $res->axfr_start($domain)
971 or die "Couldn't begin AXFR\n";
972
973 while (my $rr = $res->axfr_next()) {
974 my $type = $rr->type;
975
976 my $sql = "INSERT INTO records (domain_id,host,type,ttl,val";
977 my $vallen = "?,?,?,?,?";
978
979 $soaflag = 1 if $type eq 'SOA';
980 $nsflag = 1 if $type eq 'NS';
981
982 my @vallist = ($dom_id, $rr->name, $reverse_typemap{$type}, $rr->ttl);
983
984# "Primary" types:
985# A, NS, CNAME, SOA, PTR(warn in forward), MX, TXT, AAAA, SRV, A6(ob), SPF
986# maybe KEY
987
988# nasty big ugly case-like thing here, since we have to do *some* different
989# processing depending on the record. le sigh.
990
991 if ($type eq 'A') {
992 push @vallist, $rr->address;
993 } elsif ($type eq 'NS') {
994# hmm. should we warn here if subdomain NS'es are left alone?
995 next if ($rwns && ($rr->name eq $domain));
996 push @vallist, $rr->nsdname;
997 $nsflag = 1;
998 } elsif ($type eq 'CNAME') {
999 push @vallist, $rr->cname;
1000 } elsif ($type eq 'SOA') {
1001 next if $rwsoa;
1002 $vallist[1] = $rr->mname.":".$rr->rname;
1003 push @vallist, ($rr->refresh.":".$rr->retry.":".$rr->expire.":".$rr->minimum);
1004 $soaflag = 1;
1005 } elsif ($type eq 'PTR') {
1006 # hmm. PTR records should not be in forward zones.
1007 } elsif ($type eq 'MX') {
1008 $sql .= ",distance";
1009 $vallen .= ",?";
1010 push @vallist, $rr->exchange;
1011 push @vallist, $rr->preference;
1012 } elsif ($type eq 'TXT') {
1013##fixme: Net::DNS docs say this should be deprecated for rdatastr() or char_str_list(),
1014## but don't really seem enthusiastic about it.
1015 push @vallist, $rr->txtdata;
1016 } elsif ($type eq 'SPF') {
1017##fixme: and the same caveat here, since it is apparently a clone of ::TXT
1018 push @vallist, $rr->txtdata;
1019 } elsif ($type eq 'AAAA') {
1020 push @vallist, $rr->address;
1021 } elsif ($type eq 'SRV') {
1022 $sql .= ",distance,weight,port" if $type eq 'SRV';
1023 $vallen .= ",?,?,?" if $type eq 'SRV';
1024 push @vallist, $rr->target;
1025 push @vallist, $rr->priority;
1026 push @vallist, $rr->weight;
1027 push @vallist, $rr->port;
1028 } elsif ($type eq 'KEY') {
1029 # we don't actually know what to do with these...
1030 push @vallist, ($rr->flags.":".$rr->protocol.":".$rr->algorithm.":".$rr->key.":".$rr->keytag.":".$rr->privatekeyname);
1031 } else {
1032 push @vallist, $rr->rdatastr;
1033 # Finding a different record type is not fatal.... just problematic.
1034 # We may not be able to export it correctly.
1035 $warnmsg .= "Unusual record ".$rr->name." ($type) found\n";
1036 }
1037
1038# BIND supports:
1039# A CNAME HINFO MB(ex) MD(ob) MF(ob) MG(ex) MINFO(ex) MR(ex) MX NS NULL
1040# PTR SOA TXT WKS AFSDB(ex) ISDN(ex) RP(ex) RT(ex) X25(ex) PX
1041# ... if one can ever find the right magic to format them correctly
1042
1043# Net::DNS supports:
1044# RRSIG SIG NSAP NS NIMLOC NAPTR MX MR MINFO MG MB LOC ISDN IPSECKEY HINFO
1045# EID DNAME CNAME CERT APL AFSDB AAAA A DS NXT NSEC3PARAM NSEC3 NSEC KEY
1046# DNSKEY DLV X25 TXT TSIG TKEY SSHFP SRV SPF SOA RT RP PX PTR NULL APL::AplItem
1047
1048 $sth = $dbh->prepare($sql.") VALUES (".$vallen.")") or die "problem preparing record insert SQL\n";
1049 $sth->execute(@vallist) or die "failed to insert ".$rr->string.": ".$sth->errstr."\n";
1050
1051 $nrecs++;
1052
1053 } # while axfr_next
1054
1055 # Overwrite SOA record
1056 if ($rwsoa) {
1057 $soaflag = 1;
1058 my $sthgetsoa = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?");
1059 my $sthputsoa = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)");
1060 $sthgetsoa->execute($group,$reverse_typemap{SOA});
1061 while (my ($host,$val,$ttl) = $sthgetsoa->fetchrow_array()) {
1062 $host =~ s/DOMAIN/$domain/g;
1063 $val =~ s/DOMAIN/$domain/g;
1064 $sthputsoa->execute($dom_id,$host,$reverse_typemap{SOA},$val,$ttl);
1065 }
1066 }
1067
1068 # Overwrite NS records
1069 if ($rwns) {
1070 $nsflag = 1;
1071 my $sthgetns = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?");
1072 my $sthputns = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)");
1073 $sthgetns->execute($group,$reverse_typemap{NS});
1074 while (my ($host,$val,$ttl) = $sthgetns->fetchrow_array()) {
1075 $host =~ s/DOMAIN/$domain/g;
1076 $val =~ s/DOMAIN/$domain/g;
1077 $sthputns->execute($dom_id,$host,$reverse_typemap{NS},$val,$ttl);
1078 }
1079 }
1080
1081 die "No records found; either $ifrom is not authoritative or doesn't allow transfers\n" if !$nrecs;
1082 die "Bad zone: No SOA record!\n" if !$soaflag;
1083 die "Bad zone: No NS records!\n" if !$nsflag;
1084
1085 $dbh->commit;
1086
1087 };
1088
1089 if ($@) {
1090 my $msg = $@;
1091 eval { $dbh->rollback; };
1092 return ('FAIL',$msg." $warnmsg");
1093 } else {
1094 return ('WARN', $warnmsg) if $warnmsg;
1095 return ('OK',"ook");
1096 }
1097
1098 # it should be impossible to get here.
1099 return ('WARN',"OOOK!");
1100} # end importAXFR()
1101
1102
1103# shut Perl up
11041;
Note: See TracBrowser for help on using the repository browser.