source: trunk/DNSDB.pm@ 23

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

/trunk

checkpoint

  • basic group management functional
  • add readable failure messages on domain/group delete
  • Property svn:keywords set to Date Rev Author Id
File size: 19.3 KB
Line 
1# dns/trunk/DNSDB.pm
2# Abstraction functions for DNS administration
3###
4# SVN revision info
5# $Date: 2009-10-20 18:47:36 +0000 (Tue, 20 Oct 2009) $
6# SVN revision $Rev: 23 $
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;
17#use Net::SMTP;
18#use NetAddr::IP qw( Compact );
19#use POSIX;
20use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
21
22$VERSION = 0.1;
23@ISA = qw(Exporter);
24@EXPORT_OK = qw(
25 &initGlobals &connectDB &finish
26 &addDomain &delDomain &domainName
27 &addGroup &delGroup &getChildren &groupName
28 &getSOA &getRecLine &getDomRecs
29 &addRec &updateRec &delRec
30 &domStatus
31 %typemap %reverse_typemap
32 );
33
34@EXPORT = (); # Export nothing by default.
35%EXPORT_TAGS = ( ALL => [qw(
36 &initGlobals &connectDB &finish
37 &addDomain &delDomain &domainName
38 &addGroup &delGroup &getChildren &groupName
39 &getSOA &getRecLine &getDomRecs
40 &addRec &updateRec &delRec
41 &domStatus
42 %typemap %reverse_typemap
43 )]
44 );
45
46our $group = 1;
47our $errstr = '';
48
49# Halfway sane defaults for SOA, TTL, etc.
50our %def = qw (
51 contact hostmaster.DOMAIN
52 prins ns1.myserver.com
53 soattl 86400
54 refresh 10800
55 retry 3600
56 expire 604800
57 minttl 10800
58 ttl 10800
59);
60
61# DNS record type map and reverse map.
62# loaded from the database, from http://www.iana.org/assignments/dns-parameters
63our %typemap;
64our %reverse_typemap;
65
66##
67## Initialization and cleanup subs
68##
69
70## DNSDB::connectDB()
71# Creates connection to DNS database.
72# Requires the database name, username, and password.
73# Returns a handle to the db.
74# Set up for a PostgreSQL db; could be any transactional DBMS with the
75# right changes.
76sub connectDB {
77 $errstr = '';
78 my $dbname = shift;
79 my $user = shift;
80 my $pass = shift;
81 my $dbh;
82 my $DSN = "DBI:Pg:dbname=$dbname";
83
84 my $host = shift;
85 $DSN .= ";host=$host" if $host;
86
87# Note that we want to autocommit by default, and we will turn it off locally as necessary.
88# We may not want to print gobbledygook errors; YMMV. Have to ponder that further.
89 $dbh = DBI->connect($DSN, $user, $pass, {
90 AutoCommit => 1,
91 PrintError => 0
92 })
93 or return (undef, $DBI::errstr) if(!$dbh);
94
95# Return here if we can't select. Note that this indicates a
96# problem executing the select.
97 my $sth = $dbh->prepare("select group_id from groups limit 1");
98 $sth->execute();
99 return (undef,$DBI::errstr) if ($sth->err);
100
101# See if the select returned anything (or null data). This should
102# succeed if the select executed, but...
103 $sth->fetchrow();
104 return (undef,$DBI::errstr) if ($sth->err);
105
106 $sth->finish;
107
108# If we get here, we should be OK.
109 return ($dbh,"DB connection OK");
110} # end connectDB
111
112
113## DNSDB::finish()
114# Cleans up after database handles and so on.
115# Requires a database handle
116sub finish {
117 my $dbh = $_[0];
118 $dbh->disconnect;
119} # end finish
120
121
122## DNSDB::initGlobals()
123# Initialize global variables
124# NB: this does NOT include web-specific session variables!
125# Requires a database handle
126sub initGlobals {
127 my $dbh = shift;
128
129# load system-wide site defaults and things from config file
130 open SYSDEFAULTS, "</etc/dnsdb.conf";
131##fixme - error check!
132 while (<SYSDEFAULTS>) {
133 next if /^\s*#/;
134 $def{contact} = $1 if /contact ?= ?([a-z0-9_.-]+)/i;
135 $def{prins} = $1 if /prins ?= ?([a-z0-9_.-]+)/i;
136 $def{soattl} = $1 if /soattl ?= ?([a-z0-9_.-]+)/i;
137 $def{refresh} = $1 if /refresh ?= ?([a-z0-9_.-]+)/i;
138 $def{retry} = $1 if /retry ?= ?([a-z0-9_.-]+)/i;
139 $def{expire} = $1 if /expire ?= ?([a-z0-9_.-]+)/i;
140 $def{minttl} = $1 if /minttl ?= ?([a-z0-9_.-]+)/i;
141 $def{ttl} = $1 if /ttl ?= ?([a-z0-9_.-]+)/i;
142##fixme? load DB user/pass from config file?
143 }
144# load from database
145 my $sth = $dbh->prepare("select val,name from rectypes");
146 $sth->execute;
147 while (my ($recval,$recname) = $sth->fetchrow_array()) {
148 $typemap{$recval} = $recname;
149 $reverse_typemap{$recname} = $recval;
150 }
151} # end initGlobals
152
153
154##
155## Processing subs
156##
157
158## DNSDB::addDomain()
159# Add a domain
160# Takes a database handle, domain name, numeric group, and boolean(ish) state (active/inactive)
161# Returns a status code and message
162sub addDomain {
163 $errstr = '';
164 my $dbh = shift;
165 return ('FAIL',"Need database handle") if !$dbh;
166 my $domain = shift;
167 return ('FAIL',"Need domain") if !defined($domain);
168 my $group = shift;
169 return ('FAIL',"Need group") if !defined($group);
170 my $state = shift;
171 return ('FAIL',"Need domain status") if !defined($state);
172
173 my $dom_id;
174
175 # Allow transactions, and raise an exception on errors so we can catch it later.
176 # Use local to make sure these get "reset" properly on exiting this block
177 local $dbh->{AutoCommit} = 0;
178 local $dbh->{RaiseError} = 1;
179
180 # Wrap all the SQL in a transaction
181 eval {
182 # insert the domain...
183 my $sth = $dbh->prepare("insert into domains (domain,group_id,status) values (?,?,?)");
184 $sth->execute($domain,$group,$state);
185
186 # get the ID...
187 $sth = $dbh->prepare("select domain_id from domains where domain='$domain'");
188 $sth->execute;
189 ($dom_id) = $sth->fetchrow_array();
190
191 # ... and now we construct the standard records from the default set. NB: group should be variable.
192 $sth = $dbh->prepare("select host,type,val,distance,weight,port,ttl from default_records where group_id=$group");
193 my $sth_in = $dbh->prepare("insert into records (domain_id,host,type,val,distance,weight,port,ttl)".
194 " values ($dom_id,?,?,?,?,?,?,?)");
195 $sth->execute;
196 while (my ($host,$type,$val,$dist,$weight,$port,$ttl) = $sth->fetchrow_array()) {
197 $host =~ s/DOMAIN/$domain/g;
198 $sth_in->execute($host,$type,$val,$dist,$weight,$port,$ttl);
199 }
200
201 # once we get here, we should have suceeded.
202 $dbh->commit;
203 }; # end eval
204
205 if ($@) {
206 my $msg = $@;
207 eval { $dbh->rollback; };
208 return ('FAIL',$msg);
209 } else {
210 return ('OK',$dom_id);
211 }
212} # end addDomain
213
214
215## DNSDB::delDomain()
216# Delete a domain.
217# for now, just delete the records, then the domain.
218# later we may want to archive it in some way instead (status code 2, for example?)
219sub delDomain {
220 my $dbh = shift;
221 my $domid = shift;
222
223 # Allow transactions, and raise an exception on errors so we can catch it later.
224 # Use local to make sure these get "reset" properly on exiting this block
225 local $dbh->{AutoCommit} = 0;
226 local $dbh->{RaiseError} = 1;
227
228 my $failmsg = '';
229
230 # Wrap all the SQL in a transaction
231 eval {
232 my $sth = $dbh->prepare("delete from records where domain_id=?");
233 $failmsg = "Failure removing domain records";
234 $sth->execute($domid);
235 $sth = $dbh->prepare("delete from domains where domain_id=?");
236 $failmsg = "Failure removing domain";
237 $sth->execute($domid);
238
239 # once we get here, we should have suceeded.
240 $dbh->commit;
241 }; # end eval
242
243 if ($@) {
244 my $msg = $@;
245 eval { $dbh->rollback; };
246 return ('FAIL',"$failmsg: $msg");
247 } else {
248 return ('OK','OK');
249 }
250
251} # end delDomain()
252
253
254## DNSDB::domainName()
255# Return the domain name based on a domain ID
256# Takes a database handle and the domain ID
257# Returns the domain name or undef on failure
258sub domainName {
259 $errstr = '';
260 my $dbh = shift;
261 my $domid = shift;
262 my $sth = $dbh->prepare("select domain from domains where domain_id=?");
263 $sth->execute($domid);
264 my ($domname) = $sth->fetchrow_array();
265 $errstr = $DBI::errstr if !$domname;
266 return $domname if $domname;
267} # end domainName
268
269
270## DNSDB::addGroup()
271# Add a group
272# Takes a database handle, group name, parent group, and template-vs-cloneme flag
273# Returns a status code and message
274sub addGroup {
275 $errstr = '';
276 my $dbh = shift;
277 my $groupname = shift;
278 my $pargroup = shift;
279
280 # 0 indicates "template", hardcoded.
281 # Any other value clones that group's default records, if it exists.
282 my $torc = shift || 0;
283
284 # Allow transactions, and raise an exception on errors so we can catch it later.
285 # Use local to make sure these get "reset" properly on exiting this block
286 local $dbh->{AutoCommit} = 0;
287 local $dbh->{RaiseError} = 1;
288
289 # Wrap all the SQL in a transaction
290 eval {
291 my $sth = $dbh->prepare("INSERT INTO groups (parent_group_id,group_name) VALUES (?,?)");
292 $sth->execute($pargroup,$groupname);
293
294 $sth = $dbh->prepare("SELECT group_id FROM groups WHERE group_name=?");
295 $sth->execute($groupname);
296 my ($groupid) = $sth->fetchrow_array();
297
298 $sth = $dbh->prepare("INSERT INTO default_records (group_id,host,type,val,distance,weight,port,ttl) ".
299 "VALUES ($groupid,?,?,?,?,?,?,?)");
300 if ($torc) {
301 my $sth2 = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
302 while (my @clonedata = $sth2->fetchrow_array) {
303 $sth->execute(@clonedata);
304 }
305 } else {
306 # reasonable basic defaults for SOA, MX, NS, and minimal hosting
307 # could load from a config file, but somewhere along the line we need hardcoded bits.
308 $sth->execute('ns1.example.com:hostmaster.example.com', 6, '10800:3600:604800:10800', 0, 0, 0, 86400);
309 $sth->execute('DOMAIN', 1, '192.168.4.2', 0, 0, 0, 7200);
310 $sth->execute('DOMAIN', 15, 'mx.example.com', 10, 0, 0, 7200);
311 $sth->execute('DOMAIN', 2, 'ns1.example.com', 0, 0, 0, 7200);
312 $sth->execute('DOMAIN', 2, 'ns2.example.com', 0, 0, 0, 7200);
313 $sth->execute('www.DOMAIN', 5, 'DOMAIN', 0, 0, 0, 7200);
314 }
315
316 # once we get here, we should have suceeded.
317 $dbh->commit;
318 }; # end eval
319
320 if ($@) {
321 my $msg = $@;
322 eval { $dbh->rollback; };
323 return ('FAIL',$msg);
324 } else {
325 return ('OK','OK');
326 }
327
328} # end addGroup()
329
330
331## DNSDB::delGroup()
332# Delete a group.
333# Takes a group ID
334# Returns a status code and message
335sub delGroup {
336 my $dbh = shift;
337 my $groupid = shift;
338
339 # Allow transactions, and raise an exception on errors so we can catch it later.
340 # Use local to make sure these get "reset" properly on exiting this block
341 local $dbh->{AutoCommit} = 0;
342 local $dbh->{RaiseError} = 1;
343
344##fixme: locate "knowable" error conditions and deal with them before the eval
345# ... or inside, whatever.
346# -> domains still exist in group
347# -> ...
348 my $failmsg = '';
349
350 # Wrap all the SQL in a transaction
351 eval {
352 my $sth = $dbh->prepare("SELECT count(*) FROM domains WHERE group_id=?");
353 $sth->execute($groupid);
354 my ($domcnt) = $sth->fetchrow_array;
355 $failmsg = "Can't remove group ".groupName($dbh,$groupid);
356 die "$domcnt domains still in group\n" if $domcnt;
357
358 $sth = $dbh->prepare("delete from default_records where group_id=?");
359 $failmsg = "Failed to delete default records for ".groupName($dbh,$groupid);
360 $sth->execute($groupid);
361 $sth = $dbh->prepare("delete from groups where group_id=?");
362 $failmsg = "Failed to remove group ".groupName($dbh,$groupid);
363 $sth->execute($groupid);
364
365 # once we get here, we should have suceeded.
366 $dbh->commit;
367 }; # end eval
368
369 if ($@) {
370 my $msg = $@;
371 eval { $dbh->rollback; };
372 return ('FAIL',"$failmsg: $msg");
373 } else {
374 return ('OK','OK');
375 }
376} # end delGroup()
377
378
379## DNSDB::getChildren()
380# Get a list of all groups whose parent^n is group <n>
381# Takes a database handle, group ID, and reference to an array to put the group IDs in
382# Calls itself
383sub getChildren {
384 $errstr = '';
385 my $dbh = shift;
386 my $rootgroup = shift;
387 my $groupdest = shift;
388
389 # special break for default group; otherwise we get stuck.
390 if ($rootgroup == 1) {
391 # by definition, group 1 is the Root Of All Groups
392 my $sth = $dbh->prepare("SELECT group_id FROM groups");
393 $sth->execute;
394 my @grouplist;
395 while (my @this = $sth->fetchrow_array) {
396 push @$groupdest, @this;
397 }
398 } else {
399 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE parent_group_id=?");
400 $sth->execute($rootgroup);
401 return if $sth->rows == 0;
402 my @grouplist;
403 while (my ($group) = $sth->fetchrow_array) {
404 push @$groupdest, $group;
405 getChildren($dbh,$group,$groupdest);
406 }
407 }
408} # end getChildren()
409
410
411## DNSDB::groupName()
412# Return the group name based on a group ID
413# Takes a database handle and the group ID
414# Returns the group name or undef on failure
415sub groupName {
416 $errstr = '';
417 my $dbh = shift;
418 my $groupid = shift;
419 my $sth = $dbh->prepare("SELECT group_name FROM groups WHERE group_id=?");
420 $sth->execute($groupid);
421 my ($groupname) = $sth->fetchrow_array();
422 $errstr = $DBI::errstr if !$groupname;
423 return $groupname if $groupname;
424} # end groupName
425
426
427## DNSDB::editRecord()
428# Change an existing record
429# Takes a database handle, default/live flag, record ID, and new data and updates the data fields for it
430sub editRecord {
431 $errstr = '';
432 my $dbh = shift;
433 my $defflag = shift;
434 my $recid = shift;
435 my $host = shift;
436 my $address = shift;
437 my $distance = shift;
438 my $weight = shift;
439 my $port = shift;
440 my $ttl = shift;
441}
442
443
444## DNSDB::getSOA()
445# Return all suitable fields from an SOA record in separate elements of a hash
446# Takes a database handle, default/live flag, and group (default) or domain (live) ID
447sub getSOA {
448 $errstr = '';
449 my $dbh = shift;
450 my $def = shift;
451 my $id = shift;
452 my %ret;
453
454 my $sql = "select record_id,host,val,ttl from";
455 if ($def eq 'def' or $def eq 'y') {
456 $sql .= " default_records where group_id=$id and type=$reverse_typemap{SOA}";
457 } else {
458 # we're editing a live SOA record; find based on domain
459 $sql .= " records where domain_id=$id and type=$reverse_typemap{SOA}";
460 }
461 my $sth = $dbh->prepare($sql);
462 $sth->execute;
463
464 my ($recid,$host,$val,$ttl) = $sth->fetchrow_array();
465 my ($prins,$contact) = split /:/, $host;
466 my ($refresh,$retry,$expire,$minttl) = split /:/, $val;
467
468 $ret{recid} = $recid;
469 $ret{ttl} = $ttl;
470 $ret{prins} = $prins;
471 $ret{contact} = $contact;
472 $ret{refresh} = $refresh;
473 $ret{retry} = $retry;
474 $ret{expire} = $expire;
475 $ret{minttl} = $minttl;
476
477 return %ret;
478} # end getSOA()
479
480
481## DNSDB::getRecLine()
482# Return all data fields for a zone record in separate elements of a hash
483# Takes a database handle, default/live flag, and record ID
484sub getRecLine {
485 $errstr = '';
486 my $dbh = shift;
487 my $def = shift;
488 my $id = shift;
489
490 my $sql = "select record_id,host,type,val,distance,weight,port,ttl from ".
491 (($def eq 'def' or $def eq 'y') ? 'default_' : '').
492 "records where record_id=$id";
493print "MDEBUG: $sql<br>\n";
494 my $sth = $dbh->prepare($sql);
495 $sth->execute;
496
497 my ($recid,$host,$rtype,$val,$distance,$weight,$port,$ttl) = $sth->fetchrow_array();
498
499 if ($sth->err) {
500 $errstr = $DBI::errstr;
501 return undef;
502 }
503 my %ret;
504 $ret{recid} = $recid;
505 $ret{host} = $host;
506 $ret{type} = $rtype;
507 $ret{val} = $val;
508 $ret{distance}= $distance;
509 $ret{weight} = $weight;
510 $ret{port} = $port;
511 $ret{ttl} = $ttl;
512
513 return %ret;
514}
515
516
517##fixme: should use above (getRecLine()) to get lines for below?
518## DNSDB::getDomRecs()
519# Return records for a domain
520# Takes a database handle, default/live flag, group/domain ID, start,
521# number of records, sort field, and sort order
522# Returns a reference to an array of hashes
523sub getDomRecs {
524 $errstr = '';
525 my $dbh = shift;
526 my $type = shift;
527 my $id = shift;
528 my $nrecs = shift || 'all';
529 my $nstart = shift || 0;
530
531## for order, need to map input to column names
532 my $order = shift || 'host';
533
534 my $sql = "select record_id,host,type,val,distance,weight,port,ttl from";
535 if ($type eq 'def' or $type eq 'y') {
536 $sql .= " default_records where group_id=$id";
537 } else {
538 $sql .= " records where domain_id=$id";
539 }
540 $sql .= " and not type=$reverse_typemap{SOA} order by $order";
541##fixme: need to set nstart properly (offset is not internally multiplied with limit)
542 $sql .= " limit $nrecs offset ".($nstart*$nrecs) if $nstart ne 'all';
543
544 my $sth = $dbh->prepare($sql);
545 $sth->execute;
546
547 my @retbase;
548 while (my $ref = $sth->fetchrow_hashref()) {
549 push @retbase, $ref;
550 }
551
552 my $ret = \@retbase;
553 return $ret;
554} # end getDomRecs()
555
556
557## DNSDB::addRec()
558# Add a new record to a domain or a group's default records
559# Takes a database handle, default/live flag, group/domain ID,
560# host, type, value, and TTL
561# Some types require additional detail: "distance" for MX and SRV,
562# and weight/port for SRV
563# Returns a status code and detail message in case of error
564sub addRec {
565 $errstr = '';
566 my $dbh = shift;
567 my $defrec = shift;
568 my $id = shift;
569
570 my $host = shift;
571 my $rectype = shift;
572 my $val = shift;
573 my $ttl = shift;
574
575 my $fields = ($defrec eq 'y' ? 'group_id' : 'domain_id').",host,type,val,ttl";
576 my $vallist = "$id,'$host',$rectype,'$val',$ttl";
577
578 my $dist;
579 if ($rectype == $reverse_typemap{MX} or $rectype == $reverse_typemap{SRV}) {
580 $dist = shift;
581 return ('FAIL',"Need distance for $typemap{$rectype} record") if !defined($dist);
582 $fields .= ",distance";
583 $vallist .= ",$dist";
584 }
585 my $weight;
586 my $port;
587 if ($rectype == $reverse_typemap{SRV}) {
588 $weight = shift;
589 $port = shift;
590 return ('FAIL',"Need weight and port for SRV record") if !defined($weight) or !defined($port);
591 $fields .= ",weight,port";
592 $vallist .= ",$weight,$port";
593 }
594
595 my $sql = "insert into ".($defrec eq 'y' ? 'default_' : '')."records ($fields) values ($vallist)";
596# something is bugging me about this...
597#warn "DEBUG: $sql";
598 my $sth = $dbh->prepare($sql);
599 $sth->execute;
600
601 return ('FAIL',$sth->errstr) if $sth->err;
602
603 return ('OK','OK');
604} # end addRec()
605
606
607## DNSDB::updateRec()
608# Update a record
609sub updateRec {
610 $errstr = '';
611
612 my $dbh = shift;
613 my $defrec = shift;
614 my $id = shift;
615
616# all records have these
617 my $host = shift;
618 my $type = shift;
619 my $val = shift;
620 my $ttl = shift;
621
622 return('FAIL',"Missing standard argument(s)") if !defined($ttl);
623
624# only MX and SRV will use these
625 my $dist = 0;
626 my $weight = 0;
627 my $port = 0;
628
629 if ($type == $reverse_typemap{MX} || $type == $reverse_typemap{SRV}) {
630 $dist = shift;
631 return ('FAIL',"MX or SRV requires distance") if !defined($dist);
632 if ($type == $reverse_typemap{SRV}) {
633 $weight = shift;
634 return ('FAIL',"SRV requires weight") if !defined($weight);
635 $port = shift;
636 return ('FAIL',"SRV requires port") if !defined($port);
637 }
638 }
639
640 my $sth = $dbh->prepare("UPDATE ".($defrec eq 'y' ? 'default_' : '')."records ".
641 "SET host=?,type=?,val=?,ttl=?,distance=?,weight=?,port=? ".
642 "WHERE record_id=?");
643 $sth->execute($host,$type,$val,$ttl,$dist,$weight,$port,$id);
644
645 return ('FAIL',$sth->errstr."<br>\n$errstr<br>\n") if $sth->err;
646
647 return ('OK','OK');
648} # end updateRec()
649
650
651## DNSDB::delRec()
652# Delete a record.
653sub delRec {
654 $errstr = '';
655 my $dbh = shift;
656 my $defrec = shift;
657 my $id = shift;
658
659 my $sth = $dbh->prepare("delete from ".($defrec eq 'y' ? 'default_' : '')."records where record_id=?");
660 $sth->execute($id);
661
662 return ('FAIL',"Couldn't remove record: ".$sth->errstr) if $sth->err;
663
664 return ('OK','OK');
665} # end delRec()
666
667
668## DNSDB::domStatus()
669# Sets and/or returns a domain's status
670# Takes a database handle, domain ID and optionally a status argument
671# Returns undef on errors.
672sub domStatus {
673 my $dbh = shift;
674 my $id = shift;
675 my $newstatus = shift;
676
677 return undef if $id !~ /^\d+$/;
678
679 my $sth;
680
681# ooo, fun! let's see what we were passed for status
682 if ($newstatus) {
683 $sth = $dbh->prepare("update domains set status=? where domain_id=?");
684 # ass-u-me caller knows what's going on in full
685 if ($newstatus =~ /^[01]$/) { # only two valid for now.
686 $sth->execute($newstatus,$id);
687 } elsif ($newstatus =~ /^domo(?:n|ff)$/) {
688 $sth->execute(($newstatus eq 'domon' ? 1 : 0),$id);
689 }
690 }
691
692 $sth = $dbh->prepare("select status from domains where domain_id=?");
693 $sth->execute($id);
694 my ($status) = $sth->fetchrow_array;
695 return $status;
696} # end domStatus()
697
698
699# shut Perl up
7001;
Note: See TracBrowser for help on using the repository browser.