source: trunk/DNSDB.pm@ 55

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

/trunk

Started adding logging calls
Fixed user add sub in DNSDB.pm so that it writes encrypted passwords
Added sub to check user credentials rather than keeping that process in the main program
  • Property svn:keywords set to Date Rev Author Id
File size: 32.1 KB
Line 
1# dns/trunk/DNSDB.pm
2# Abstraction functions for DNS administration
3###
4# SVN revision info
5# $Date: 2009-12-31 22:55:43 +0000 (Thu, 31 Dec 2009) $
6# SVN revision $Rev: 55 $
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 $pass = 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($pass,$1);
538 } else {
539 $loginfailed = 1 if $pass ne $pass;
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 from ".
686 (($def eq 'def' or $def eq 'y') ? 'default_' : '').
687 "records where record_id=$id";
688print "MDEBUG: $sql<br>\n";
689 my $sth = $dbh->prepare($sql);
690 $sth->execute;
691
692 my ($recid,$host,$rtype,$val,$distance,$weight,$port,$ttl) = $sth->fetchrow_array();
693
694 if ($sth->err) {
695 $errstr = $DBI::errstr;
696 return undef;
697 }
698 my %ret;
699 $ret{recid} = $recid;
700 $ret{host} = $host;
701 $ret{type} = $rtype;
702 $ret{val} = $val;
703 $ret{distance}= $distance;
704 $ret{weight} = $weight;
705 $ret{port} = $port;
706 $ret{ttl} = $ttl;
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
862 my $sth = $dbh->prepare("delete from ".($defrec eq 'y' ? 'default_' : '')."records where record_id=?");
863 $sth->execute($id);
864
865 return ('FAIL',"Couldn't remove record: ".$sth->errstr) if $sth->err;
866
867 return ('OK','OK');
868} # end delRec()
869
870
871## DNSDB::domStatus()
872# Sets and/or returns a domain's status
873# Takes a database handle, domain ID and optionally a status argument
874# Returns undef on errors.
875sub domStatus {
876 my $dbh = shift;
877 my $id = shift;
878 my $newstatus = shift;
879
880 return undef if $id !~ /^\d+$/;
881
882 my $sth;
883
884# ooo, fun! let's see what we were passed for status
885 if ($newstatus) {
886 $sth = $dbh->prepare("update domains set status=? where domain_id=?");
887 # ass-u-me caller knows what's going on in full
888 if ($newstatus =~ /^[01]$/) { # only two valid for now.
889 $sth->execute($newstatus,$id);
890 } elsif ($newstatus =~ /^domo(?:n|ff)$/) {
891 $sth->execute(($newstatus eq 'domon' ? 1 : 0),$id);
892 }
893 }
894
895 $sth = $dbh->prepare("select status from domains where domain_id=?");
896 $sth->execute($id);
897 my ($status) = $sth->fetchrow_array;
898 return $status;
899} # end domStatus()
900
901
902## DNSDB::importAXFR
903# Import a domain via AXFR
904# Takes AXFR host, domain to transfer, group to put the domain in,
905# and optionally:
906# - active/inactive state flag (defaults to active)
907# - overwrite-SOA flag (defaults to off)
908# - overwrite-NS flag (defaults to off, doesn't affect subdomain NS records)
909# Returns a status code (OK, WARN, or FAIL) and message - message should be blank
910# if status is OK, but WARN includes conditions that are not fatal but should
911# really be reported.
912sub importAXFR {
913 my $dbh = shift;
914 my $ifrom_in = shift;
915 my $domain = shift;
916 my $group = shift;
917 my $status = shift || 1;
918 my $rwsoa = shift || 0;
919 my $rwns = shift || 0;
920
921##fixme: add mode to delete&replace, merge+overwrite, merge new?
922
923 my $nrecs = 0;
924 my $soaflag = 0;
925 my $nsflag = 0;
926 my $warnmsg = '';
927 my $ifrom;
928
929 # choke on possible bad setting in ifrom
930 # IPv4 and v6, and valid hostnames!
931 ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i);
932 return ('FAIL', "Bad AXFR source host $ifrom")
933 unless ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i);
934
935 # Allow transactions, and raise an exception on errors so we can catch it later.
936 # Use local to make sure these get "reset" properly on exiting this block
937 local $dbh->{AutoCommit} = 0;
938 local $dbh->{RaiseError} = 1;
939
940 my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
941 my $dom_id;
942
943# quick check to start to see if we've already got one
944 $sth->execute($domain);
945 ($dom_id) = $sth->fetchrow_array;
946
947 return ('FAIL', "Domain already exists") if $dom_id;
948
949 eval {
950 # can't do this, can't nest transactions. sigh.
951 #my ($dcode, $dmsg) = addDomain(dbh, domain, group, status);
952
953##fixme: serial
954 my $sth = $dbh->prepare("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)");
955 $sth->execute($domain,$group,$status);
956
957## bizarre DBI<->Net::DNS interaction bug:
958## sometimes a zone will cause an immediate commit-and-exit (sort of) of the while()
959## fixed, apparently I was doing *something* odd, but not certain what it was that
960## caused a commit instead of barfing
961
962 # get domain id so we can do the records
963 $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
964 $sth->execute($domain);
965 ($dom_id) = $sth->fetchrow_array();
966
967 my $res = Net::DNS::Resolver->new;
968 $res->nameservers($ifrom);
969 $res->axfr_start($domain)
970 or die "Couldn't begin AXFR\n";
971
972 while (my $rr = $res->axfr_next()) {
973 my $type = $rr->type;
974
975 my $sql = "INSERT INTO records (domain_id,host,type,ttl,val";
976 my $vallen = "?,?,?,?,?";
977
978 $soaflag = 1 if $type eq 'SOA';
979 $nsflag = 1 if $type eq 'NS';
980
981 my @vallist = ($dom_id, $rr->name, $reverse_typemap{$type}, $rr->ttl);
982
983# "Primary" types:
984# A, NS, CNAME, SOA, PTR(warn in forward), MX, TXT, AAAA, SRV, A6(ob), SPF
985# maybe KEY
986
987# nasty big ugly case-like thing here, since we have to do *some* different
988# processing depending on the record. le sigh.
989
990 if ($type eq 'A') {
991 push @vallist, $rr->address;
992 } elsif ($type eq 'NS') {
993# hmm. should we warn here if subdomain NS'es are left alone?
994 next if ($rwns && ($rr->name eq $domain));
995 push @vallist, $rr->nsdname;
996 $nsflag = 1;
997 } elsif ($type eq 'CNAME') {
998 push @vallist, $rr->cname;
999 } elsif ($type eq 'SOA') {
1000 next if $rwsoa;
1001 $vallist[1] = $rr->mname.":".$rr->rname;
1002 push @vallist, ($rr->refresh.":".$rr->retry.":".$rr->expire.":".$rr->minimum);
1003 $soaflag = 1;
1004 } elsif ($type eq 'PTR') {
1005 # hmm. PTR records should not be in forward zones.
1006 } elsif ($type eq 'MX') {
1007 $sql .= ",distance";
1008 $vallen .= ",?";
1009 push @vallist, $rr->exchange;
1010 push @vallist, $rr->preference;
1011 } elsif ($type eq 'TXT') {
1012##fixme: Net::DNS docs say this should be deprecated for rdatastr() or char_str_list(),
1013## but don't really seem enthusiastic about it.
1014 push @vallist, $rr->txtdata;
1015 } elsif ($type eq 'SPF') {
1016##fixme: and the same caveat here, since it is apparently a clone of ::TXT
1017 push @vallist, $rr->txtdata;
1018 } elsif ($type eq 'AAAA') {
1019 push @vallist, $rr->address;
1020 } elsif ($type eq 'SRV') {
1021 $sql .= ",distance,weight,port" if $type eq 'SRV';
1022 $vallen .= ",?,?,?" if $type eq 'SRV';
1023 push @vallist, $rr->target;
1024 push @vallist, $rr->priority;
1025 push @vallist, $rr->weight;
1026 push @vallist, $rr->port;
1027 } elsif ($type eq 'KEY') {
1028 # we don't actually know what to do with these...
1029 push @vallist, ($rr->flags.":".$rr->protocol.":".$rr->algorithm.":".$rr->key.":".$rr->keytag.":".$rr->privatekeyname);
1030 } else {
1031 push @vallist, $rr->rdatastr;
1032 # Finding a different record type is not fatal.... just problematic.
1033 # We may not be able to export it correctly.
1034 $warnmsg .= "Unusual record ".$rr->name." ($type) found\n";
1035 }
1036
1037# BIND supports:
1038# A CNAME HINFO MB(ex) MD(ob) MF(ob) MG(ex) MINFO(ex) MR(ex) MX NS NULL
1039# PTR SOA TXT WKS AFSDB(ex) ISDN(ex) RP(ex) RT(ex) X25(ex) PX
1040# ... if one can ever find the right magic to format them correctly
1041
1042# Net::DNS supports:
1043# RRSIG SIG NSAP NS NIMLOC NAPTR MX MR MINFO MG MB LOC ISDN IPSECKEY HINFO
1044# EID DNAME CNAME CERT APL AFSDB AAAA A DS NXT NSEC3PARAM NSEC3 NSEC KEY
1045# DNSKEY DLV X25 TXT TSIG TKEY SSHFP SRV SPF SOA RT RP PX PTR NULL APL::AplItem
1046
1047 $sth = $dbh->prepare($sql.") VALUES (".$vallen.")") or die "problem preparing record insert SQL\n";
1048 $sth->execute(@vallist) or die "failed to insert ".$rr->string.": ".$sth->errstr."\n";
1049
1050 $nrecs++;
1051
1052 } # while axfr_next
1053
1054 # Overwrite SOA record
1055 if ($rwsoa) {
1056 $soaflag = 1;
1057 my $sthgetsoa = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?");
1058 my $sthputsoa = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)");
1059 $sthgetsoa->execute($group,$reverse_typemap{SOA});
1060 while (my ($host,$val,$ttl) = $sthgetsoa->fetchrow_array()) {
1061 $host =~ s/DOMAIN/$domain/g;
1062 $val =~ s/DOMAIN/$domain/g;
1063 $sthputsoa->execute($dom_id,$host,$reverse_typemap{SOA},$val,$ttl);
1064 }
1065 }
1066
1067 # Overwrite NS records
1068 if ($rwns) {
1069 $nsflag = 1;
1070 my $sthgetns = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?");
1071 my $sthputns = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)");
1072 $sthgetns->execute($group,$reverse_typemap{NS});
1073 while (my ($host,$val,$ttl) = $sthgetns->fetchrow_array()) {
1074 $host =~ s/DOMAIN/$domain/g;
1075 $val =~ s/DOMAIN/$domain/g;
1076 $sthputns->execute($dom_id,$host,$reverse_typemap{NS},$val,$ttl);
1077 }
1078 }
1079
1080 die "No records found; either $ifrom is not authoritative or doesn't allow transfers\n" if !$nrecs;
1081 die "Bad zone: No SOA record!\n" if !$soaflag;
1082 die "Bad zone: No NS records!\n" if !$nsflag;
1083
1084 $dbh->commit;
1085
1086 };
1087
1088 if ($@) {
1089 my $msg = $@;
1090 eval { $dbh->rollback; };
1091 return ('FAIL',$msg." $warnmsg");
1092 } else {
1093 return ('WARN', $warnmsg) if $warnmsg;
1094 return ('OK',"ook");
1095 }
1096
1097 # it should be impossible to get here.
1098 return ('WARN',"OOOK!");
1099} # end importAXFR()
1100
1101
1102# shut Perl up
11031;
Note: See TracBrowser for help on using the repository browser.