source: trunk/DNSDB.pm@ 61

Last change on this file since 61 was 61, checked in by Kris Deugau, 14 years ago

/trunk

checkpoint, debugging logging/process on deleting domain
  • 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-15 22:48:50 +0000 (Fri, 15 Jan 2010) $
6# SVN revision $Rev: 61 $
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
245return "FAIL", "whee!";
246 # Allow transactions, and raise an exception on errors so we can catch it later.
247 # Use local to make sure these get "reset" properly on exiting this block
248 local $dbh->{AutoCommit} = 0;
249 local $dbh->{RaiseError} = 1;
250
251 my $failmsg = '';
252
253 # Wrap all the SQL in a transaction
254 eval {
255 my $sth = $dbh->prepare("delete from records where domain_id=?");
256 $failmsg = "Failure removing domain records";
257 $sth->execute($domid);
258 $sth = $dbh->prepare("delete from domains where domain_id=?");
259 $failmsg = "Failure removing domain";
260 $sth->execute($domid);
261
262 # once we get here, we should have suceeded.
263 $dbh->commit;
264 }; # end eval
265
266 if ($@) {
267 my $msg = $@;
268 eval { $dbh->rollback; };
269 return ('FAIL',"$failmsg: $msg");
270 } else {
271 return ('OK','OK');
272 }
273
274} # end delDomain()
275
276
277## DNSDB::domainName()
278# Return the domain name based on a domain ID
279# Takes a database handle and the domain ID
280# Returns the domain name or undef on failure
281sub domainName {
282 $errstr = '';
283 my $dbh = shift;
284 my $domid = shift;
285 my $sth = $dbh->prepare("select domain from domains where domain_id=?");
286 $sth->execute($domid);
287 my ($domname) = $sth->fetchrow_array();
288 $errstr = $DBI::errstr if !$domname;
289 return $domname if $domname;
290} # end domainName
291
292
293## DNSDB::addGroup()
294# Add a group
295# Takes a database handle, group name, parent group, and template-vs-cloneme flag
296# Returns a status code and message
297sub addGroup {
298 $errstr = '';
299 my $dbh = shift;
300 my $groupname = shift;
301 my $pargroup = shift;
302
303 # 0 indicates "template", hardcoded.
304 # Any other value clones that group's default records, if it exists.
305 my $torc = shift || 0;
306
307 # Allow transactions, and raise an exception on errors so we can catch it later.
308 # Use local to make sure these get "reset" properly on exiting this block
309 local $dbh->{AutoCommit} = 0;
310 local $dbh->{RaiseError} = 1;
311
312 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE group_name=?");
313 my $group_id;
314
315# quick check to start to see if we've already got one
316 $sth->execute($groupname);
317 ($group_id) = $sth->fetchrow_array;
318
319 return ('FAIL', "Group already exists") if $group_id;
320
321 # Wrap all the SQL in a transaction
322 eval {
323 $sth = $dbh->prepare("INSERT INTO groups (parent_group_id,group_name) VALUES (?,?)");
324 $sth->execute($pargroup,$groupname);
325
326 $sth = $dbh->prepare("SELECT group_id FROM groups WHERE group_name=?");
327 $sth->execute($groupname);
328 my ($groupid) = $sth->fetchrow_array();
329
330 $sth = $dbh->prepare("INSERT INTO default_records (group_id,host,type,val,distance,weight,port,ttl) ".
331 "VALUES ($groupid,?,?,?,?,?,?,?)");
332 if ($torc) {
333 my $sth2 = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
334 while (my @clonedata = $sth2->fetchrow_array) {
335 $sth->execute(@clonedata);
336 }
337 } else {
338 # reasonable basic defaults for SOA, MX, NS, and minimal hosting
339 # could load from a config file, but somewhere along the line we need hardcoded bits.
340 $sth->execute('ns1.example.com:hostmaster.example.com', 6, '10800:3600:604800:10800', 0, 0, 0, 86400);
341 $sth->execute('DOMAIN', 1, '192.168.4.2', 0, 0, 0, 7200);
342 $sth->execute('DOMAIN', 15, 'mx.example.com', 10, 0, 0, 7200);
343 $sth->execute('DOMAIN', 2, 'ns1.example.com', 0, 0, 0, 7200);
344 $sth->execute('DOMAIN', 2, 'ns2.example.com', 0, 0, 0, 7200);
345 $sth->execute('www.DOMAIN', 5, 'DOMAIN', 0, 0, 0, 7200);
346 }
347
348 # once we get here, we should have suceeded.
349 $dbh->commit;
350 }; # end eval
351
352 if ($@) {
353 my $msg = $@;
354 eval { $dbh->rollback; };
355 return ('FAIL',$msg);
356 } else {
357 return ('OK','OK');
358 }
359
360} # end addGroup()
361
362
363## DNSDB::delGroup()
364# Delete a group.
365# Takes a group ID
366# Returns a status code and message
367sub delGroup {
368 my $dbh = shift;
369 my $groupid = shift;
370
371 # Allow transactions, and raise an exception on errors so we can catch it later.
372 # Use local to make sure these get "reset" properly on exiting this block
373 local $dbh->{AutoCommit} = 0;
374 local $dbh->{RaiseError} = 1;
375
376##fixme: locate "knowable" error conditions and deal with them before the eval
377# ... or inside, whatever.
378# -> domains still exist in group
379# -> ...
380 my $failmsg = '';
381
382 # Wrap all the SQL in a transaction
383 eval {
384 my $sth = $dbh->prepare("SELECT count(*) FROM domains WHERE group_id=?");
385 $sth->execute($groupid);
386 my ($domcnt) = $sth->fetchrow_array;
387 $failmsg = "Can't remove group ".groupName($dbh,$groupid);
388 die "$domcnt domains still in group\n" if $domcnt;
389
390 $sth = $dbh->prepare("delete from default_records where group_id=?");
391 $failmsg = "Failed to delete default records for ".groupName($dbh,$groupid);
392 $sth->execute($groupid);
393 $sth = $dbh->prepare("delete from groups where group_id=?");
394 $failmsg = "Failed to remove group ".groupName($dbh,$groupid);
395 $sth->execute($groupid);
396
397 # once we get here, we should have suceeded.
398 $dbh->commit;
399 }; # end eval
400
401 if ($@) {
402 my $msg = $@;
403 eval { $dbh->rollback; };
404 return ('FAIL',"$failmsg: $msg");
405 } else {
406 return ('OK','OK');
407 }
408} # end delGroup()
409
410
411## DNSDB::getChildren()
412# Get a list of all groups whose parent^n is group <n>
413# Takes a database handle, group ID, reference to an array to put the group IDs in,
414# and an optional flag to return only immediate children or all children-of-children
415# default to returning all children
416# Calls itself
417sub getChildren {
418 $errstr = '';
419 my $dbh = shift;
420 my $rootgroup = shift;
421 my $groupdest = shift;
422 my $immed = shift || 'all';
423
424 # special break for default group; otherwise we get stuck.
425 if ($rootgroup == 1) {
426 # by definition, group 1 is the Root Of All Groups
427 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE NOT (group_id=1)".
428 ($immed ne 'all' ? " AND parent_group_id=1" : ''));
429 $sth->execute;
430 while (my @this = $sth->fetchrow_array) {
431 push @$groupdest, @this;
432 }
433 } else {
434 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE parent_group_id=?");
435 $sth->execute($rootgroup);
436 return if $sth->rows == 0;
437 my @grouplist;
438 while (my ($group) = $sth->fetchrow_array) {
439 push @$groupdest, $group;
440 getChildren($dbh,$group,$groupdest) if $immed eq 'all';
441 }
442 }
443} # end getChildren()
444
445
446## DNSDB::groupName()
447# Return the group name based on a group ID
448# Takes a database handle and the group ID
449# Returns the group name or undef on failure
450sub groupName {
451 $errstr = '';
452 my $dbh = shift;
453 my $groupid = shift;
454 my $sth = $dbh->prepare("SELECT group_name FROM groups WHERE group_id=?");
455 $sth->execute($groupid);
456 my ($groupname) = $sth->fetchrow_array();
457 $errstr = $DBI::errstr if !$groupname;
458 return $groupname if $groupname;
459} # end groupName
460
461
462## DNSDB::addUser()
463#
464sub addUser {
465 $errstr = '';
466 my $dbh = shift;
467 return ('FAIL',"Need database handle") if !$dbh;
468 my $username = shift;
469 return ('FAIL',"Missing username") if !defined($username);
470 my $group = shift;
471 return ('FAIL',"Missing group") if !defined($group);
472 my $pass = shift;
473 return ('FAIL',"Missing password") if !defined($pass);
474 my $state = shift;
475 return ('FAIL',"Need account status") if !defined($state);
476
477 my $type = shift || 'u'; # create limited users by default - fwiw, not sure yet how this will interact with ACLs
478
479 my $fname = shift || $username;
480 my $lname = shift || '';
481 my $phone = shift || ''; # not going format-check
482
483 my $sth = $dbh->prepare("SELECT user_id FROM users WHERE username=?");
484 my $user_id;
485
486# quick check to start to see if we've already got one
487 $sth->execute($username);
488 ($user_id) = $sth->fetchrow_array;
489
490 return ('FAIL', "User already exists") if $user_id;
491
492 # Allow transactions, and raise an exception on errors so we can catch it later.
493 # Use local to make sure these get "reset" properly on exiting this block
494 local $dbh->{AutoCommit} = 0;
495 local $dbh->{RaiseError} = 1;
496
497 # Wrap all the SQL in a transaction
498 eval {
499 # insert the user...
500 my $sth = $dbh->prepare("INSERT INTO users (group_id,username,password,firstname,lastname,phone,type,status) ".
501 "VALUES (?,?,?,?,?,?,?,?)");
502 $sth->execute($group,$username,unix_md5_crypt($pass),$fname,$lname,$phone,$type,$state);
503
504 # get the ID...
505 $sth = $dbh->prepare("select user_id from users where username=?");
506 $sth->execute($username);
507 ($user_id) = $sth->fetchrow_array();
508
509##fixme: add another table to hold name/email for log table?
510
511 # once we get here, we should have suceeded.
512 $dbh->commit;
513 }; # end eval
514
515 if ($@) {
516 my $msg = $@;
517 eval { $dbh->rollback; };
518 return ('FAIL',$msg);
519 } else {
520 return ('OK',$user_id);
521 }
522} # end addUser
523
524
525## DNSDB::checkUser()
526# Check user/pass combo on login
527sub checkUser {
528 my $dbh = shift;
529 my $user = shift;
530 my $inpass = shift;
531
532 my $sth = $dbh->prepare("SELECT user_id,group_id,password,firstname,lastname FROM users WHERE username=?");
533 $sth->execute($user);
534 my ($uid,$gid,$pass,$fname,$lname) = $sth->fetchrow_array;
535 my $loginfailed = 1 if !defined($uid);
536
537 if ($pass =~ m|^\$1\$([A-Za-z0-9/.]+)\$|) {
538 $loginfailed = 1 if $pass ne unix_md5_crypt($inpass,$1);
539 } else {
540 $loginfailed = 1 if $pass ne $inpass;
541 }
542
543 # nnnngggg
544 return ($uid, $gid);
545} # end checkUser
546
547
548## DNSDB::delUser()
549#
550sub delUser {
551 my $dbh = shift;
552 return ('FAIL',"Need database handle") if !$dbh;
553 my $userid = shift;
554 return ('FAIL',"Missing userid") if !defined($userid);
555
556 my $sth = $dbh->prepare("delete from users where user_id=?");
557 $sth->execute($userid);
558
559 return ('FAIL',"Couldn't remove user: ".$sth->errstr) if $sth->err;
560
561 return ('OK','OK');
562
563} # end delUser
564
565
566## DNSDB::userFullName()
567# Return a pretty string!
568# Takes a user_id and optional printf-ish string to indicate which pieces where:
569# %u for the username
570# %f for the first name
571# %l for the last name
572# All other text in the passed string will be left as-is.
573##fixme: need a "smart" option too, so that missing/null/blank first/last names don't give funky output
574sub userFullName {
575 $errstr = '';
576 my $dbh = shift;
577 my $userid = shift;
578 my $fullformat = shift || '%f %l (%u)';
579 my $sth = $dbh->prepare("select username,firstname,lastname from users where user_id=?");
580 $sth->execute($userid);
581 my ($uname,$fname,$lname) = $sth->fetchrow_array();
582 $errstr = $DBI::errstr if !$uname;
583
584 $fullformat =~ s/\%u/$uname/g;
585 $fullformat =~ s/\%f/$fname/g;
586 $fullformat =~ s/\%l/$lname/g;
587
588 return $fullformat;
589} # end userFullName
590
591
592## DNSDB::userStatus()
593# Sets and/or returns a user's status
594# Takes a database handle, user ID and optionally a status argument
595# Returns undef on errors.
596sub userStatus {
597 my $dbh = shift;
598 my $id = shift;
599 my $newstatus = shift;
600
601 return undef if $id !~ /^\d+$/;
602
603 my $sth;
604
605# ooo, fun! let's see what we were passed for status
606 if ($newstatus) {
607 $sth = $dbh->prepare("update users set status=? where user_id=?");
608 # ass-u-me caller knows what's going on in full
609 if ($newstatus =~ /^[01]$/) { # only two valid for now.
610 $sth->execute($newstatus,$id);
611 } elsif ($newstatus =~ /^usero(?:n|ff)$/) {
612 $sth->execute(($newstatus eq 'useron' ? 1 : 0),$id);
613 }
614 }
615
616 $sth = $dbh->prepare("select status from users where user_id=?");
617 $sth->execute($id);
618 my ($status) = $sth->fetchrow_array;
619 return $status;
620} # end userStatus()
621
622
623## DNSDB::editRecord()
624# Change an existing record
625# Takes a database handle, default/live flag, record ID, and new data and updates the data fields for it
626sub editRecord {
627 $errstr = '';
628 my $dbh = shift;
629 my $defflag = shift;
630 my $recid = shift;
631 my $host = shift;
632 my $address = shift;
633 my $distance = shift;
634 my $weight = shift;
635 my $port = shift;
636 my $ttl = shift;
637}
638
639
640## DNSDB::getSOA()
641# Return all suitable fields from an SOA record in separate elements of a hash
642# Takes a database handle, default/live flag, and group (default) or domain (live) ID
643sub getSOA {
644 $errstr = '';
645 my $dbh = shift;
646 my $def = shift;
647 my $id = shift;
648 my %ret;
649
650 my $sql = "select record_id,host,val,ttl from";
651 if ($def eq 'def' or $def eq 'y') {
652 $sql .= " default_records where group_id=$id and type=$reverse_typemap{SOA}";
653 } else {
654 # we're editing a live SOA record; find based on domain
655 $sql .= " records where domain_id=$id and type=$reverse_typemap{SOA}";
656 }
657 my $sth = $dbh->prepare($sql);
658 $sth->execute;
659
660 my ($recid,$host,$val,$ttl) = $sth->fetchrow_array();
661 my ($prins,$contact) = split /:/, $host;
662 my ($refresh,$retry,$expire,$minttl) = split /:/, $val;
663
664 $ret{recid} = $recid;
665 $ret{ttl} = $ttl;
666 $ret{prins} = $prins;
667 $ret{contact} = $contact;
668 $ret{refresh} = $refresh;
669 $ret{retry} = $retry;
670 $ret{expire} = $expire;
671 $ret{minttl} = $minttl;
672
673 return %ret;
674} # end getSOA()
675
676
677## DNSDB::getRecLine()
678# Return all data fields for a zone record in separate elements of a hash
679# Takes a database handle, default/live flag, and record ID
680sub getRecLine {
681 $errstr = '';
682 my $dbh = shift;
683 my $def = shift;
684 my $id = shift;
685
686 my $sql = "select record_id,host,type,val,distance,weight,port,ttl from ".
687 (($def eq 'def' or $def eq 'y') ? 'default_' : '').
688 "records where record_id=$id";
689print "MDEBUG: $sql<br>\n";
690 my $sth = $dbh->prepare($sql);
691 $sth->execute;
692
693 my ($recid,$host,$rtype,$val,$distance,$weight,$port,$ttl) = $sth->fetchrow_array();
694
695 if ($sth->err) {
696 $errstr = $DBI::errstr;
697 return undef;
698 }
699 my %ret;
700 $ret{recid} = $recid;
701 $ret{host} = $host;
702 $ret{type} = $rtype;
703 $ret{val} = $val;
704 $ret{distance}= $distance;
705 $ret{weight} = $weight;
706 $ret{port} = $port;
707 $ret{ttl} = $ttl;
708
709 return %ret;
710}
711
712
713##fixme: should use above (getRecLine()) to get lines for below?
714## DNSDB::getDomRecs()
715# Return records for a domain
716# Takes a database handle, default/live flag, group/domain ID, start,
717# number of records, sort field, and sort order
718# Returns a reference to an array of hashes
719sub getDomRecs {
720 $errstr = '';
721 my $dbh = shift;
722 my $type = shift;
723 my $id = shift;
724 my $nrecs = shift || 'all';
725 my $nstart = shift || 0;
726
727## for order, need to map input to column names
728 my $order = shift || 'host';
729
730 my $sql = "select record_id,host,type,val,distance,weight,port,ttl from";
731 if ($type eq 'def' or $type eq 'y') {
732 $sql .= " default_records where group_id=$id";
733 } else {
734 $sql .= " records where domain_id=$id";
735 }
736 $sql .= " and not type=$reverse_typemap{SOA} order by $order";
737##fixme: need to set nstart properly (offset is not internally multiplied with limit)
738 $sql .= " limit $nrecs offset ".($nstart*$nrecs) if $nstart ne 'all';
739
740 my $sth = $dbh->prepare($sql);
741 $sth->execute;
742
743 my @retbase;
744 while (my $ref = $sth->fetchrow_hashref()) {
745 push @retbase, $ref;
746 }
747
748 my $ret = \@retbase;
749 return $ret;
750} # end getDomRecs()
751
752
753## DNSDB::addRec()
754# Add a new record to a domain or a group's default records
755# Takes a database handle, default/live flag, group/domain ID,
756# host, type, value, and TTL
757# Some types require additional detail: "distance" for MX and SRV,
758# and weight/port for SRV
759# Returns a status code and detail message in case of error
760sub addRec {
761 $errstr = '';
762 my $dbh = shift;
763 my $defrec = shift;
764 my $id = shift;
765
766 my $host = shift;
767 my $rectype = shift;
768 my $val = shift;
769 my $ttl = shift;
770
771 my $fields = ($defrec eq 'y' ? 'group_id' : 'domain_id').",host,type,val,ttl";
772 my $vallen = "?,?,?,?,?";
773 my @vallist = ($id,$host,$rectype,$val,$ttl);
774
775 my $dist;
776 if ($rectype == $reverse_typemap{MX} or $rectype == $reverse_typemap{SRV}) {
777 $dist = shift;
778 return ('FAIL',"Need distance for $typemap{$rectype} record") if !defined($dist);
779 $fields .= ",distance";
780 $vallen .= ",?";
781 push @vallist, $dist;
782 }
783 my $weight;
784 my $port;
785 if ($rectype == $reverse_typemap{SRV}) {
786 # check for _service._protocol. NB: RFC2782 does not say "MUST"... nor "SHOULD"...
787 # it just says (paraphrased) "... is prepended with _ to prevent DNS collisions"
788 return ('FAIL',"SRV records must begin with _service._protocol")
789 if $host !~ /^_[A-Za-z]+\._[A-Za-z]+\.[a-z0-9-]+/;
790 $weight = shift;
791 $port = shift;
792 return ('FAIL',"Need weight and port for SRV record") if !defined($weight) or !defined($port);
793 $fields .= ",weight,port";
794 $vallen .= ",?,?";
795 push @vallist, ($weight,$port);
796 }
797
798 my $sql = "insert into ".($defrec eq 'y' ? 'default_' : '')."records ($fields) values ($vallen)";
799##fixme: use array for values, replace "vallist" with series of ?,?,? etc
800# something is bugging me about this...
801#warn "DEBUG: $sql";
802 my $sth = $dbh->prepare($sql);
803 $sth->execute(@vallist);
804
805 return ('FAIL',$sth->errstr) if $sth->err;
806
807 return ('OK','OK');
808} # end addRec()
809
810
811## DNSDB::updateRec()
812# Update a record
813sub updateRec {
814 $errstr = '';
815
816 my $dbh = shift;
817 my $defrec = shift;
818 my $id = shift;
819
820# all records have these
821 my $host = shift;
822 my $type = shift;
823 my $val = shift;
824 my $ttl = shift;
825
826 return('FAIL',"Missing standard argument(s)") if !defined($ttl);
827
828# only MX and SRV will use these
829 my $dist = 0;
830 my $weight = 0;
831 my $port = 0;
832
833 if ($type == $reverse_typemap{MX} || $type == $reverse_typemap{SRV}) {
834 $dist = shift;
835 return ('FAIL',"MX or SRV requires distance") if !defined($dist);
836 if ($type == $reverse_typemap{SRV}) {
837 $weight = shift;
838 return ('FAIL',"SRV requires weight") if !defined($weight);
839 $port = shift;
840 return ('FAIL',"SRV requires port") if !defined($port);
841 }
842 }
843
844 my $sth = $dbh->prepare("UPDATE ".($defrec eq 'y' ? 'default_' : '')."records ".
845 "SET host=?,type=?,val=?,ttl=?,distance=?,weight=?,port=? ".
846 "WHERE record_id=?");
847 $sth->execute($host,$type,$val,$ttl,$dist,$weight,$port,$id);
848
849 return ('FAIL',$sth->errstr."<br>\n$errstr<br>\n") if $sth->err;
850
851 return ('OK','OK');
852} # end updateRec()
853
854
855## DNSDB::delRec()
856# Delete a record.
857sub delRec {
858 $errstr = '';
859 my $dbh = shift;
860 my $defrec = shift;
861 my $id = shift;
862
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.