source: trunk/DNSDB.pm@ 509

Last change on this file since 509 was 509, checked in by Kris Deugau, 11 years ago

/trunk

Add fences around curgroup and childlist arguments in several get*List
methods to prevent SQL injection. Unlike the sortorder and sortby
updates in r508, curgroup has no fallback, and arguably childlist has
no reasonable one, so the methods fail outright instead of continuing.
  • Property svn:keywords set to Date Rev Author Id
File size: 192.6 KB
Line 
1# dns/trunk/DNSDB.pm
2# Abstraction functions for DNS administration
3##
4# $Id: DNSDB.pm 509 2013-05-09 22:05:52Z kdeugau $
5# Copyright 2008-2013 Kris Deugau <kdeugau@deepnet.cx>
6#
7# This program is free software: you can redistribute it and/or modify
8# it under the terms of the GNU General Public License as published by
9# the Free Software Foundation, either version 3 of the License, or
10# (at your option) any later version.
11#
12# This program is distributed in the hope that it will be useful,
13# but WITHOUT ANY WARRANTY; without even the implied warranty of
14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15# GNU General Public License for more details.
16#
17# You should have received a copy of the GNU General Public License
18# along with this program. If not, see <http://www.gnu.org/licenses/>.
19##
20
21package DNSDB;
22
23use strict;
24use warnings;
25use Exporter;
26use DBI;
27use Net::DNS;
28use Crypt::PasswdMD5;
29use Net::SMTP;
30use NetAddr::IP qw(:lower);
31use POSIX;
32use Fcntl qw(:flock);
33
34use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
35
36$VERSION = 1.1; ##VERSION##
37@ISA = qw(Exporter);
38@EXPORT_OK = qw(
39 &initGlobals &login &initActionLog
40 &getPermissions &changePermissions &comparePermissions
41 &changeGroup
42 &loadConfig &connectDB &finish
43 &addDomain &delZone &domainName &revName &domainID &revID &addRDNS
44 &getZoneCount &getZoneList &getZoneLocation
45 &addGroup &delGroup &getChildren &groupName
46 &getGroupCount &getGroupList
47 &addUser &updateUser &delUser &userFullName &userStatus &getUserData
48 &getUserCount &getUserList &getUserDropdown
49 &addLoc &updateLoc &delLoc &getLoc
50 &getLocCount &getLocList &getLocDropdown
51 &getSOA &updateSOA &getRecLine &getRecList &getRecCount
52 &addRec &updateRec &delRec
53 &getLogCount &getLogEntries
54 &getRevPattern
55 &getTypelist
56 &parentID
57 &isParent
58 &zoneStatus &getZonesByCIDR &importAXFR
59 &export
60 &mailNotify
61 %typemap %reverse_typemap %config
62 @permtypes $permlist %permchains
63 );
64
65@EXPORT = qw(%typemap %reverse_typemap @permtypes $permlist %permchains);
66%EXPORT_TAGS = ( ALL => [qw(
67 &initGlobals &login &initActionLog
68 &getPermissions &changePermissions &comparePermissions
69 &changeGroup
70 &loadConfig &connectDB &finish
71 &addDomain &delZone &domainName &revName &domainID &revID &addRDNS
72 &getZoneCount &getZoneList &getZoneLocation
73 &addGroup &delGroup &getChildren &groupName
74 &getGroupCount &getGroupList
75 &addUser &updateUser &delUser &userFullName &userStatus &getUserData
76 &getUserCount &getUserList &getUserDropdown
77 &addLoc &updateLoc &delLoc &getLoc
78 &getLocCount &getLocList &getLocDropdown
79 &getSOA &updateSOA &getRecLine &getRecList &getRecCount
80 &addRec &updateRec &delRec
81 &getLogCount &getLogEntries
82 &getRevPattern
83 &getTypelist
84 &parentID
85 &isParent
86 &zoneStatus &getZonesByCIDR &importAXFR
87 &export
88 &mailNotify
89 %typemap %reverse_typemap %config
90 @permtypes $permlist %permchains
91 )]
92 );
93
94our $errstr = '';
95our $resultstr = '';
96
97# Halfway sane defaults for SOA, TTL, etc.
98# serial defaults to 0 for convenience.
99# value will be either YYYYMMDDNN for BIND/etc, or auto-internal for tinydns
100our %def = qw (
101 contact hostmaster.DOMAIN
102 prins ns1.myserver.com
103 serial 0
104 soattl 86400
105 refresh 10800
106 retry 3600
107 expire 604800
108 minttl 10800
109 ttl 10800
110);
111
112# Arguably defined wholly in the db, but little reason to change without supporting code changes
113# group_view, user_view permissions? separate rDNS permission(s)?
114our @permtypes = qw (
115 group_edit group_create group_delete
116 user_edit user_create user_delete
117 domain_edit domain_create domain_delete
118 record_edit record_create record_delete record_locchg
119 location_edit location_create location_delete location_view
120 self_edit admin
121);
122our $permlist = join(',',@permtypes);
123
124# Some permissions more or less require certain others.
125our %permchains = (
126 user_edit => 'self_edit',
127 location_edit => 'location_view',
128 location_create => 'location_view',
129 location_delete => 'location_view',
130 record_locchg => 'location_view',
131);
132
133# DNS record type map and reverse map.
134# loaded from the database, from http://www.iana.org/assignments/dns-parameters
135our %typemap;
136our %reverse_typemap;
137
138# Prepopulate a basic config. Note some of these *will* cause errors if left unset.
139# note: add appropriate stanzas in loadConfig to parse these
140our %config = (
141 # Database connection info
142 dbname => 'dnsdb',
143 dbuser => 'dnsdb',
144 dbpass => 'secret',
145 dbhost => '',
146
147 # Email notice settings
148 mailhost => 'smtp.example.com',
149 mailnotify => 'dnsdb@example.com', # to
150 mailsender => 'dnsdb@example.com', # from
151 mailname => 'DNS Administration',
152 orgname => 'Example Corp',
153 domain => 'example.com',
154
155 # Template directory
156 templatedir => 'templates/',
157# fmeh. this is a real web path, not a logical internal one. hm..
158# cssdir => 'templates/',
159 sessiondir => 'session/',
160 exportcache => 'cache/',
161
162 # Session params
163 timeout => '3600', # 1 hour default
164
165 # Other miscellanea
166 log_failures => 1, # log all evarthing by default
167 perpage => 15,
168 maxfcgi => 100, # reasonable default?
169 );
170
171## (Semi)private variables
172
173# Hash of functions for validating record types. Filled in initGlobals() since
174# it relies on visibility flags from the rectypes table in the DB
175my %validators;
176
177# Entity-relationship reference hashes.
178my %par_tbl = (
179 group => 'groups',
180 user => 'users',
181 defrec => 'default_records',
182 defrevrec => 'default_rev_records',
183 domain => 'domains',
184 revzone => 'revzones',
185 record => 'records'
186 );
187my %id_col = (
188 group => 'group_id',
189 user => 'user_id',
190 defrec => 'record_id',
191 defrevrec => 'record_id',
192 domain => 'domain_id',
193 revzone => 'rdns_id',
194 record => 'record_id'
195 );
196my %par_col = (
197 group => 'parent_group_id',
198 user => 'group_id',
199 defrec => 'group_id',
200 defrevrec => 'group_id',
201 domain => 'group_id',
202 revzone => 'group_id',
203 record => 'domain_id'
204 );
205my %par_type = (
206 group => 'group',
207 user => 'group',
208 defrec => 'group',
209 defrevrec => 'group',
210 domain => 'group',
211 revzone => 'group',
212 record => 'domain'
213 );
214
215##
216## Constructor and destructor
217##
218
219sub new {
220 my $this = shift;
221 my $class = ref($this) || $this;
222 my %args = @_;
223##fixme? to ponder: do we do some magic if the caller sets eg dbname to prevent parsing of the config file?
224 if (!loadConfig(basename => $args{configfile})) {
225 warn "Using default configuration; unable to load custom settings: $errstr\n";
226 }
227 my $self = \%config;
228 $self->{configfile} = $args{configfile};
229 bless $self, $class;
230 $self->{dbh} = connectDB($self->{dbname}, $self->{dbuser}, $self->{dbpass}, $self->{dbhost}) or return;
231 $self->initGlobals();
232
233 return $self;
234}
235
236sub DESTROY {
237 my $self = shift;
238 $self->{dbh}->disconnect;
239}
240
241sub errstr { $DNSDB::errstr; }
242
243##
244## utility functions
245##
246
247## DNSDB::_rectable()
248# Takes default+rdns flags, returns appropriate table name
249sub _rectable {
250 my $def = shift;
251 my $rev = shift;
252
253 return 'records' if $def ne 'y';
254 return 'default_records' if $rev ne 'y';
255 return 'default_rev_records';
256} # end _rectable()
257
258## DNSDB::_recparent()
259# Takes default+rdns flags, returns appropriate parent-id column name
260sub _recparent {
261 my $def = shift;
262 my $rev = shift;
263
264 return 'group_id' if $def eq 'y';
265 return 'rdns_id' if $rev eq 'y';
266 return 'domain_id';
267} # end _recparent()
268
269## DNSDB::_ipparent()
270# Check an IP to be added in a reverse zone to see if it's really in the requested parent.
271# Takes default and reverse flags, IP (fragment) to check, parent zone ID,
272# and a reference to a NetAddr::IP object (also used to pass back a fully-reconstructed IP for
273# database insertion)
274sub _ipparent {
275 my $self = shift;
276 my $dbh = $self->{dbh};
277 my $defrec = shift;
278 my $revrec = shift;
279 my $val = shift;
280 my $id = shift;
281 my $addr = shift;
282
283 return if $revrec ne 'y'; # this sub not useful in forward zones
284
285 $$addr = NetAddr::IP->new($$val); #necessary?
286
287 # subsub to split, reverse, and overlay an IP fragment on a netblock
288 sub __rev_overlay {
289 my $splitme = shift; # ':' or '.', m'lud?
290 my $parnet = shift;
291 my $val = shift;
292 my $addr = shift;
293
294 my $joinme = $splitme;
295 $splitme = '\.' if $splitme eq '.';
296 my @working = reverse(split($splitme, $parnet->addr));
297 my @parts = reverse(split($splitme, $$val));
298 for (my $i = 0; $i <= $#parts; $i++) {
299 $working[$i] = $parts[$i];
300 }
301 my $checkme = NetAddr::IP->new(join($joinme, reverse(@working))) or return 0;
302 return 0 unless $checkme->within($parnet);
303 $$addr = $checkme; # force "correct" IP to be recorded.
304 return 1;
305 }
306
307 my ($parstr) = $dbh->selectrow_array("SELECT revnet FROM revzones WHERE rdns_id = ?", undef, ($id));
308 my $parnet = NetAddr::IP->new($parstr);
309
310 # Fail early on v6-in-v4 or v4-in-v6. We're not accepting these ATM.
311 return 0 if $parnet->addr =~ /\./ && $$val =~ /:/;
312 return 0 if $parnet->addr =~ /:/ && $$val =~ /\./;
313
314 if ($$addr && ($$val =~ /^[\da-fA-F][\da-fA-F:]+[\da-fA-F]$/ || $$val =~ m|/\d+$|)) {
315 # the only case where NetAddr::IP's acceptance of legitimate IPs is "correct" is for a proper IPv6 address,
316 # or a netblock (only expected on templates)
317 # the rest we have to restructure before fiddling. *sigh*
318 return 1 if $$addr->within($parnet);
319 } else {
320 # We don't have a complete IP in $$val (yet)... unless we have a netblock
321 if ($parnet->addr =~ /:/) {
322 $$val =~ s/^:+//; # gotta strip'em all...
323 return __rev_overlay(':', $parnet, $val, $addr);
324 }
325 if ($parnet->addr =~ /\./) {
326 $$val =~ s/^\.+//;
327 return __rev_overlay('.', $parnet, $val, $addr);
328 }
329 # should be impossible to get here...
330 }
331 # ... and here.
332 # can't do nuttin' in forward zones
333} # end _ipparent()
334
335## DNSDB::_hostparent()
336# A little different than _ipparent above; this tries to *find* the parent zone of a hostname
337# Takes a hostname.
338# Returns the domain ID of the parent domain if one was found.
339sub _hostparent {
340 my $self = shift;
341 my $dbh = $self->{dbh};
342 my $hname = shift;
343
344 $hname =~ s/^\*\.//; # this should be impossible to find in the domains table.
345 my @hostbits = split /\./, $hname;
346 my $sth = $dbh->prepare("SELECT count(*),domain_id FROM domains WHERE lower(domain) = lower(?) GROUP BY domain_id");
347 foreach (@hostbits) {
348 $sth->execute($hname);
349 my ($found, $parid) = $sth->fetchrow_array;
350 if ($found) {
351 return $parid;
352 }
353 $hname =~ s/^$_\.//;
354 }
355} # end _hostparent()
356
357## DNSDB::_log()
358# Log an action
359# Takes a log entry hash containing at least:
360# group_id, log entry
361# and optionally one or more of:
362# domain_id, rdns_id
363# The %userdata hash provides the user ID, username, and fullname
364sub _log {
365 my $self = shift;
366 my $dbh = $self->{dbh};
367
368 my %args = @_;
369
370 $args{rdns_id} = 0 if !$args{rdns_id};
371 $args{domain_id} = 0 if !$args{domain_id};
372
373##fixme: farm out the actual logging to different subs for file, syslog, internal, etc based on config
374# if ($config{log_channel} eq 'sql') {
375 $dbh->do("INSERT INTO log (domain_id,rdns_id,group_id,entry,user_id,email,name) VALUES (?,?,?,?,?,?,?)",
376 undef,
377 ($args{domain_id}, $args{rdns_id}, $args{group_id}, $args{entry},
378 $self->{loguserid}, $self->{logusername}, $self->{logfullname}) );
379# } elsif ($config{log_channel} eq 'file') {
380# } elsif ($config{log_channel} eq 'syslog') {
381# }
382} # end _log
383
384
385##
386## Record validation subs.
387##
388
389## All of these subs take substantially the same arguments:
390# a hash containing at least the following keys:
391# - defrec (default/live flag)
392# - revrec (forward/reverse flag)
393# - id (parent entity ID)
394# - host (hostname)
395# - rectype
396# - val (IP, hostname [CNAME/MX/SRV] or text)
397# - addr (NetAddr::IP object from val. May be undef.)
398# MX and SRV record validation also expect distance, and SRV records expect weight and port as well.
399# host, rectype, and addr should be references as these may be modified in validation
400
401# A record
402sub _validate_1 {
403 my $self = shift;
404 my $dbh = $self->{dbh};
405
406 my %args = @_;
407
408 return ('FAIL', 'Reverse zones cannot contain A records') if $args{revrec} eq 'y';
409
410 # Coerce all hostnames to end in ".DOMAIN" for group/default records,
411 # or the intended parent domain for live records.
412 my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id}));
413 ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
414
415 # Check IP is well-formed, and that it's a v4 address
416 # Fail on "compact" IPv4 variants, because they are not consistent and predictable.
417 return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv4 address")
418 unless ${$args{val}} =~ /^\d+\.\d+\.\d+\.\d+$/;
419 return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv4 address")
420 unless $args{addr} && !$args{addr}->{isv6};
421 # coerce IP/value to normalized form for storage
422 ${$args{val}} = $args{addr}->addr;
423
424 return ('OK','OK');
425} # done A record
426
427# NS record
428sub _validate_2 {
429 my $self = shift;
430 my $dbh = $self->{dbh};
431
432 my %args = @_;
433
434 # Check that the target of the record is within the parent.
435 # Yes, host<->val are mixed up here; can't see a way to avoid it. :(
436 if ($args{defrec} eq 'n') {
437 # Check if IP/address/zone/"subzone" is within the parent
438 if ($args{revrec} eq 'y') {
439 my $tmpip = NetAddr::IP->new(${$args{val}});
440 my $pname = $self->revName($args{id});
441 return ('FAIL',"${$args{val}} not within $pname")
442 unless $self->_ipparent($args{defrec}, $args{revrec}, $args{val}, $args{id}, \$tmpip);
443 # Sub the returned thing for ZONE? This could get stupid if you have typos...
444 ${$args{val}} =~ s/ZONE/$tmpip->address/;
445 } else {
446 my $pname = $self->domainName($args{id});
447 ${$args{host}} = $pname if ${$args{host}} !~ /\.$pname$/;
448 }
449 } else {
450 # Default reverse NS records should always refer to the implied parent
451 ${$args{host}} = 'DOMAIN' if $args{revrec} eq 'n';
452 ${$args{val}} = 'ZONE' if $args{revrec} eq 'y';
453 }
454
455# Let this lie for now. Needs more magic.
456# # Check IP is well-formed, and that it's a v4 address
457# return ('FAIL',"A record must be a valid IPv4 address")
458# unless $addr && !$addr->{isv6};
459# # coerce IP/value to normalized form for storage
460# $$val = $addr->addr;
461
462 return ('OK','OK');
463} # done NS record
464
465# CNAME record
466sub _validate_5 {
467 my $self = shift;
468 my $dbh = $self->{dbh};
469
470 my %args = @_;
471
472# Not really true, but these are only useful for delegating smaller-than-/24 IP blocks.
473# This is fundamentally a messy operation and should really just be taken care of by the
474# export process, not manual maintenance of the necessary records.
475 return ('FAIL', 'Reverse zones cannot contain CNAME records') if $args{revrec} eq 'y';
476
477 # Coerce all hostnames to end in ".DOMAIN" for group/default records,
478 # or the intended parent domain for live records.
479 my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id}));
480 ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
481
482 return ('OK','OK');
483} # done CNAME record
484
485# SOA record
486sub _validate_6 {
487 # Smart monkeys won't stick their fingers in here; we have
488 # separate dedicated routines to deal with SOA records.
489 return ('OK','OK');
490} # done SOA record
491
492# PTR record
493sub _validate_12 {
494 my $self = shift;
495 my $dbh = $self->{dbh};
496
497 my %args = @_;
498
499 if ($args{revrec} eq 'y') {
500 if ($args{defrec} eq 'n') {
501 return ('FAIL', "IP or IP fragment ${$args{val}} is not within ".$self->revName($args{id}))
502 unless $self->_ipparent($args{defrec}, $args{revrec}, $args{val}, $args{id}, \$args{addr});
503 ${$args{val}} = $args{addr}->addr;
504 } else {
505 if (${$args{val}} =~ /\./) {
506 # looks like a v4 or fragment
507 if (${$args{val}} =~ /^\d+\.\d+\.\d+\.\d+$/) {
508 # woo! a complete IP! validate it and normalize, or fail.
509 $args{addr} = NetAddr::IP->new(${$args{val}})
510 or return ('FAIL', "IP/value looks like IPv4 but isn't valid");
511 ${$args{val}} = $args{addr}->addr;
512 } else {
513 ${$args{val}} =~ s/^\.*/ZONE./ unless ${$args{val}} =~ /^ZONE/;
514 }
515 } elsif (${$args{val}} =~ /[a-f:]/) {
516 # looks like a v6 or fragment
517 ${$args{val}} =~ s/^:*/ZONE::/ if !$args{addr} && ${$args{val}} !~ /^ZONE/;
518 if ($args{addr}) {
519 if ($args{addr}->addr =~ /^0/) {
520 ${$args{val}} =~ s/^:*/ZONE::/ unless ${$args{val}} =~ /^ZONE/;
521 } else {
522 ${$args{val}} = $args{addr}->addr;
523 }
524 }
525 } else {
526 # bare number (probably). These could be v4 or v6, so we'll
527 # expand on these on creation of a reverse zone.
528 ${$args{val}} = "ZONE,${$args{val}}" unless ${$args{val}} =~ /^ZONE/;
529 }
530 ${$args{host}} =~ s/\.*$/\.$config{domain}/ if ${$args{host}} !~ /(?:$config{domain}|ADMINDOMAIN)$/;
531 }
532
533# Multiple PTR records do NOT generally do what most people believe they do,
534# and tend to fail in the most awkward way possible. Check and warn.
535# We use $val instead of $addr->addr since we may be in a defrec, and may have eg "ZONE::42" or "ZONE.12"
536
537 my @checkvals = (${$args{val}});
538 if (${$args{val}} =~ /,/) {
539 # push . and :: variants into checkvals if val has ,
540 my $tmp;
541 ($tmp = ${$args{val}}) =~ s/,/./;
542 push @checkvals, $tmp;
543 ($tmp = ${$args{val}}) =~ s/,/::/;
544 push @checkvals, $tmp;
545 }
546 my $pcsth = $dbh->prepare("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec})." WHERE val = ?");
547 foreach my $checkme (@checkvals) {
548 if ($args{update}) {
549 # Record update. There should usually be an existing PTR (the record being updated)
550 my @ptrs = @{ $dbh->selectcol_arrayref("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}).
551 " WHERE val = ?", undef, ($checkme)) };
552 return ('WARN', "PTR record for $checkme already exists; adding another will probably not do what you want")
553 if @ptrs && (!grep /^$args{update}$/, @ptrs);
554 } else {
555 # New record. Always warn if a PTR exists
556 my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}).
557 " WHERE val = ?", undef, ($checkme));
558 return ('WARN', "PTR record for $checkme already exists; adding another will probably not do what you want")
559 if $ptrcount;
560 }
561 }
562
563 } else {
564 # Not absolutely true but only useful if you hack things up for sub-/24 v4 reverse delegations
565 # Simpler to just create the reverse zone and grant access for the customer to edit it, and create direct
566 # PTR records on export
567 return ('FAIL',"Forward zones cannot contain PTR records");
568 }
569
570 return ('OK','OK');
571} # done PTR record
572
573# MX record
574sub _validate_15 {
575 my $self = shift;
576 my $dbh = $self->{dbh};
577
578 my %args = @_;
579
580# Not absolutely true but WTF use is an MX record for a reverse zone?
581 return ('FAIL', 'Reverse zones cannot contain MX records') if $args{revrec} eq 'y';
582
583 return ('FAIL', "Distance is required for MX records") unless defined(${$args{dist}});
584 ${$args{dist}} =~ s/\s*//g;
585 return ('FAIL',"Distance is required, and must be numeric") unless ${$args{dist}} =~ /^\d+$/;
586
587 ${$args{fields}} = "distance,";
588 push @{$args{vallist}}, ${$args{dist}};
589
590 # Coerce all hostnames to end in ".DOMAIN" for group/default records,
591 # or the intended parent domain for live records.
592 my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id}));
593 ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
594
595# hmm.. this might work. except possibly for something pointing to "deadbeef.ca". <g>
596# if ($type == $reverse_typemap{NS} || $type == $reverse_typemap{MX} || $type == $reverse_typemap{SRV}) {
597# if ($val =~ /^\s*[\da-f:.]+\s*$/) {
598# return ('FAIL',"$val is not a valid IP address") if !$addr;
599# }
600# }
601
602 return ('OK','OK');
603} # done MX record
604
605# TXT record
606sub _validate_16 {
607 # Could arguably put a WARN return here on very long (>512) records
608 return ('OK','OK');
609} # done TXT record
610
611# RP record
612sub _validate_17 {
613 # Probably have to validate these some day
614 return ('OK','OK');
615} # done RP record
616
617# AAAA record
618sub _validate_28 {
619 my $self = shift;
620 my $dbh = $self->{dbh};
621
622 my %args = @_;
623
624 return ('FAIL', 'Reverse zones cannot contain AAAA records') if $args{revrec} eq 'y';
625
626 # Coerce all hostnames to end in ".DOMAIN" for group/default records,
627 # or the intended parent domain for live records.
628 my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id}));
629 ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
630
631 # Check IP is well-formed, and that it's a v6 address
632 return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv6 address")
633 unless $args{addr} && $args{addr}->{isv6};
634 # coerce IP/value to normalized form for storage
635 ${$args{val}} = $args{addr}->addr;
636
637 return ('OK','OK');
638} # done AAAA record
639
640# SRV record
641sub _validate_33 {
642 my $self = shift;
643 my $dbh = $self->{dbh};
644
645 my %args = @_;
646
647# Not absolutely true but WTF use is an SRV record for a reverse zone?
648 return ('FAIL', 'Reverse zones cannot contain SRV records') if $args{revrec} eq 'y';
649
650 return ('FAIL', "Distance is required for SRV records") unless defined(${$args{dist}});
651 ${$args{dist}} =~ s/\s*//g;
652 return ('FAIL',"Distance is required, and must be numeric") unless ${$args{dist}} =~ /^\d+$/;
653
654 return ('FAIL',"SRV records must begin with _service._protocol [${$args{host}}]")
655 unless ${$args{host}} =~ /^_[A-Za-z]+\._[A-Za-z]+\.[a-zA-Z0-9-]+/;
656 return ('FAIL',"Port and weight are required for SRV records")
657 unless defined(${$args{weight}}) && defined(${$args{port}});
658 ${$args{weight}} =~ s/\s*//g;
659 ${$args{port}} =~ s/\s*//g;
660
661 return ('FAIL',"Port and weight are required, and must be numeric")
662 unless ${$args{weight}} =~ /^\d+$/ && ${$args{port}} =~ /^\d+$/;
663
664 ${$args{fields}} = "distance,weight,port,";
665 push @{$args{vallist}}, (${$args{dist}}, ${$args{weight}}, ${$args{port}});
666
667 # Coerce all hostnames to end in ".DOMAIN" for group/default records,
668 # or the intended parent domain for live records.
669 my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id}));
670 ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
671
672 return ('OK','OK');
673} # done SRV record
674
675# Now the custom types
676
677# A+PTR record. With a very little bit of magic we can also use this sub to validate AAAA+PTR. Whee!
678sub _validate_65280 {
679 my $self = shift;
680 my $dbh = $self->{dbh};
681
682 my %args = @_;
683
684 my $code = 'OK';
685 my $msg = 'OK';
686
687 if ($args{defrec} eq 'n') {
688 # live record; revrec determines whether we validate the PTR or A component first.
689
690 if ($args{revrec} eq 'y') {
691 ($code,$msg) = $self->_validate_12(%args);
692 return ($code,$msg) if $code eq 'FAIL';
693
694 # check A+PTR is really v4
695 return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv4 address")
696 if ${$args{rectype}} == 65280 && $args{addr}->{isv6};
697 # check AAAA+PTR is really v6
698 return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv6 address")
699 if ${$args{rectype}} == 65281 && !$args{addr}->{isv6};
700
701 # Check if the reqested domain exists. If not, coerce the type down to PTR and warn.
702 if (!(${$args{domid}} = $self->_hostparent(${$args{host}}))) {
703 my $addmsg = "Record ".($args{update} ? 'updated' : 'added').
704 " as PTR instead of $typemap{${$args{rectype}}}; domain not found for ${$args{host}}";
705 $msg .= "\n$addmsg" if $code eq 'WARN';
706 $msg = $addmsg if $code eq 'OK';
707 ${$args{rectype}} = $reverse_typemap{PTR};
708 return ('WARN', $msg);
709 }
710
711 # Add domain ID to field list and values
712 ${$args{fields}} .= "domain_id,";
713 push @{$args{vallist}}, ${$args{domid}};
714
715 } else {
716 ($code,$msg) = $self->_validate_1(%args) if ${$args{rectype}} == 65280;
717 ($code,$msg) = $self->_validate_28(%args) if ${$args{rectype}} == 65281;
718 return ($code,$msg) if $code eq 'FAIL';
719
720 # Check if the requested reverse zone exists - note, an IP fragment won't
721 # work here since we don't *know* which parent to put it in.
722 # ${$args{val}} has been validated as a valid IP by now, in one of the above calls.
723 my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?".
724 " ORDER BY masklen(revnet) DESC", undef, (${$args{val}}));
725 if (!$revid) {
726 $msg = "Record ".($args{update} ? 'updated' : 'added')." as ".(${$args{rectype}} == 65280 ? 'A' : 'AAAA').
727 " instead of $typemap{${$args{rectype}}}; reverse zone not found for ${$args{val}}";
728 ${$args{rectype}} = (${$args{rectype}} == 65280 ? $reverse_typemap{A} : $reverse_typemap{AAAA});
729 return ('WARN', $msg);
730 }
731
732 # Check for duplicate PTRs. Note we don't have to play games with $code and $msg, because
733 # by definition there can't be duplicate PTRs if the reverse zone isn't managed here.
734 if ($args{update}) {
735 # Record update. There should usually be an existing PTR (the record being updated)
736 my @ptrs = @{ $dbh->selectcol_arrayref("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}).
737 " WHERE val = ?", undef, (${$args{val}})) };
738 if (@ptrs && (!grep /^$args{update}$/, @ptrs)) {
739 $msg = "PTR record for ${$args{val}} already exists; adding another will probably not do what you want";
740 $code = 'WARN';
741 }
742 } else {
743 # New record. Always warn if a PTR exists
744 my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}).
745 " WHERE val = ?", undef, (${$args{val}}));
746 $msg = "PTR record for ${$args{val}} already exists; adding another will probably not do what you want"
747 if $ptrcount;
748 $code = 'WARN' if $ptrcount;
749 }
750
751# my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}).
752# " WHERE val = ?", undef, ${$args{val}});
753# if ($ptrcount) {
754# my $curid = $dbh->selectrow_array("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}).
755# " WHERE val = ?
756# $msg = "PTR record for ${$args{val}} already exists; adding another will probably not do what you want";
757# $code = 'WARN';
758# }
759
760 ${$args{fields}} .= "rdns_id,";
761 push @{$args{vallist}}, $revid;
762 }
763
764 } else { # defrec eq 'y'
765 if ($args{revrec} eq 'y') {
766 ($code,$msg) = $self->_validate_12(%args);
767 return ($code,$msg) if $code eq 'FAIL';
768 if (${$args{rectype}} == 65280) {
769 return ('FAIL',"A+PTR record must be a valid IPv4 address or fragment")
770 if ${$args{val}} =~ /:/;
771 ${$args{val}} =~ s/^ZONE,/ZONE./; # Clean up after uncertain IP-fragment-type from _validate_12
772 } elsif (${$args{rectype}} == 65281) {
773 return ('FAIL',"AAAA+PTR record must be a valid IPv6 address or fragment")
774 if ${$args{val}} =~ /\./;
775 ${$args{val}} =~ s/^ZONE,/ZONE::/; # Clean up after uncertain IP-fragment-type from _validate_12
776 }
777 } else {
778 # This is easy. I also can't see a real use-case for A/AAAA+PTR in *all* forward
779 # domains, since you wouldn't be able to substitute both domain and reverse zone
780 # sanely, and you'd end up with guaranteed over-replicated PTR records that would
781 # confuse the hell out of pretty much anything that uses them.
782##fixme: make this a config flag?
783 return ('FAIL', "$typemap{${$args{rectype}}} records not allowed in default domains");
784 }
785 }
786
787 return ($code, $msg);
788} # done A+PTR record
789
790# AAAA+PTR record
791# A+PTR above has been magicked to handle AAAA+PTR as well.
792sub _validate_65281 {
793 return _validate_65280(@_);
794} # done AAAA+PTR record
795
796# PTR template record
797sub _validate_65282 {
798 my $self = shift;
799 my $dbh = $self->{dbh};
800
801 my %args = @_;
802
803 # we're *this* >.< close to being able to just call _validate_12... unfortunately we can't, quite.
804 if ($args{revrec} eq 'y') {
805 if ($args{defrec} eq 'n') {
806 return ('FAIL', "Template block ${$args{val}} is not within ".$self->revName($args{id}))
807 unless $self->_ipparent($args{defrec}, $args{revrec}, $args{val}, $args{id}, \$args{addr});
808##fixme: warn if $args{val} is not /31 or larger block?
809 ${$args{val}} = "$args{addr}";
810 } else {
811 if (${$args{val}} =~ /\./) {
812 # looks like a v4 or fragment
813 if (${$args{val}} =~ m|^\d+\.\d+\.\d+\.\d+(?:/\d+)?$|) {
814 # woo! a complete IP! validate it and normalize, or fail.
815 $args{addr} = NetAddr::IP->new(${$args{val}})
816 or return ('FAIL', "IP/value looks like IPv4 but isn't valid");
817 ${$args{val}} = "$args{addr}";
818 } else {
819 ${$args{val}} =~ s/^\.*/ZONE./ unless ${$args{val}} =~ /^ZONE/;
820 }
821 } elsif (${$args{val}} =~ /[a-f:]/) {
822 # looks like a v6 or fragment
823 ${$args{val}} =~ s/^:*/ZONE::/ if !$args{addr} && ${$args{val}} !~ /^ZONE/;
824 if ($args{addr}) {
825 if ($args{addr}->addr =~ /^0/) {
826 ${$args{val}} =~ s/^:*/ZONE::/ unless ${$args{val}} =~ /^ZONE/;
827 } else {
828 ${$args{val}} = "$args{addr}";
829 }
830 }
831 } else {
832 # bare number (probably). These could be v4 or v6, so we'll
833 # expand on these on creation of a reverse zone.
834 ${$args{val}} = "ZONE,${$args{val}}" unless ${$args{val}} =~ /^ZONE/;
835 }
836 }
837##fixme: validate %-patterns?
838
839# Unlike single PTR records, there is absolutely no way to sanely support multiple
840# PTR templates for the same block, since they expect to expand to all the individual
841# IPs on export. Nested templates should be supported though.
842
843 my @checkvals = (${$args{val}});
844 if (${$args{val}} =~ /,/) {
845 # push . and :: variants into checkvals if val has ,
846 my $tmp;
847 ($tmp = ${$args{val}}) =~ s/,/./;
848 push @checkvals, $tmp;
849 ($tmp = ${$args{val}}) =~ s/,/::/;
850 push @checkvals, $tmp;
851 }
852##fixme: this feels wrong still - need to restrict template pseudorecords to One Of Each
853# Per Netblock such that they don't conflict on export
854 my $typeck;
855# type 65282 -> ptr template -> look for any of 65282, 65283, 65284
856 $typeck = 'type=65283 OR type=65284' if ${$args{rectype}} == 65282;
857# type 65283 -> a+ptr template -> v4 -> look for 65282 or 65283
858 $typeck = 'type=65283' if ${$args{rectype}} == 65282;
859# type 65284 -> aaaa+ptr template -> v6 -> look for 65282 or 65284
860 $typeck = 'type=65284' if ${$args{rectype}} == 65282;
861 my $pcsth = $dbh->prepare("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec})." WHERE val = ? ".
862 "AND (type=65282 OR $typeck)");
863 foreach my $checkme (@checkvals) {
864 $pcsth->execute($checkme);
865 my ($rc) = $pcsth->fetchrow_array;
866 return ('FAIL', "Only one template pseudorecord may exist for a given IP block") if $rc > 1;
867 }
868
869 } else {
870 return ('FAIL', "Forward zones cannot contain PTR records");
871 }
872
873 return ('OK','OK');
874} # done PTR template record
875
876# A+PTR template record
877sub _validate_65283 {
878 my $self = shift;
879 my $dbh = $self->{dbh};
880
881 my %args = @_;
882
883 my ($code,$msg) = ('OK','OK');
884
885##fixme: need to fiddle things since A+PTR templates are acceptable in live
886# forward zones but not default records
887 if ($args{defrec} eq 'n') {
888 if ($args{revrec} eq 'n') {
889 ($code,$msg) = $self->_validate_1(%args) if ${$args{rectype}} == 65280;
890 ($code,$msg) = $self->_validate_28(%args) if ${$args{rectype}} == 65281;
891 return ($code,$msg) if $code eq 'FAIL';
892
893 # Check if the requested reverse zone exists - note, an IP fragment won't
894 # work here since we don't *know* which parent to put it in.
895 # ${$args{val}} has been validated as a valid IP by now, in one of the above calls.
896 my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?".
897 " ORDER BY masklen(revnet) DESC", undef, (${$args{val}}));
898 # Fail if no match; we can't coerce a PTR-template type down to not include the PTR bit currently.
899 if (!$revid) {
900 $msg = "Can't ".($args{update} ? 'update' : 'add')." ${$args{host}}/${$args{val}} as ".
901 "$typemap{${$args{rectype}}}: reverse zone not found for ${$args{val}}";
902##fixme: add A template, AAAA template types?
903# ${$args{rectype}} = (${$args{rectype}} == 65280 ? $reverse_typemap{A} : $reverse_typemap{AAAA});
904 return ('FAIL', $msg);
905 }
906
907 # Add reverse zone ID to field list and values
908 ${$args{fields}} .= "rdns_id,";
909 push @{$args{vallist}}, $revid;
910
911 } else {
912 return ('FAIL', "IP or IP fragment ${$args{val}} is not within ".$self->revName($args{id}))
913 unless $self->_ipparent($args{defrec}, $args{revrec}, $args{val}, $args{id}, \$args{addr});
914 ${$args{val}} = "$args{addr}";
915
916 if (!(${$args{domid}} = $self->_hostparent(${$args{host}}))) {
917 my $addmsg = "Record ".($args{update} ? 'updated' : 'added').
918 " as PTR template instead of $typemap{${$args{rectype}}}; domain not found for ${$args{host}}";
919 $msg .= "\n$addmsg" if $code eq 'WARN';
920 $msg = $addmsg if $code eq 'OK';
921 ${$args{rectype}} = 65282;
922 return ('WARN', $msg);
923 }
924
925 # Add domain ID to field list and values
926 ${$args{fields}} .= "domain_id,";
927 push @{$args{vallist}}, ${$args{domid}};
928 }
929
930 } else {
931 my ($code,$msg) = $self->_validate_65282(%args);
932 return ($code, $msg) if $code eq 'FAIL';
933 # get domain, check against ${$args{name}}
934 }
935
936 return ('OK','OK');
937} # done AAAA+PTR template record
938
939# AAAA+PTR template record
940sub _validate_65284 {
941 return ('OK','OK');
942} # done AAAA+PTR template record
943
944# Delegation record
945# This is essentially a specialized clone of the NS record, primarily useful
946# for delegating IPv4 sub-/24 reverse blocks
947sub _validate_65285 {
948 my $self = shift;
949 my $dbh = $self->{dbh};
950
951 my %args = @_;
952
953# Almost, but not quite, identical to NS record validation.
954
955 # Check that the target of the record is within the parent.
956 # Yes, host<->val are mixed up here; can't see a way to avoid it. :(
957 if ($args{defrec} eq 'n') {
958 # Check if IP/address/zone/"subzone" is within the parent
959 if ($args{revrec} eq 'y') {
960 my $tmpip = NetAddr::IP->new(${$args{val}});
961 my $pname = $self->revName($args{id});
962 return ('FAIL',"${$args{val}} not within $pname")
963 unless $self->_ipparent($args{defrec}, $args{revrec}, $args{val}, $args{id}, \$tmpip);
964 # Normalize
965 ${$args{val}} = "$tmpip";
966 } else {
967 my $pname = $self->domainName($args{id});
968 ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
969 }
970 } else {
971 return ('FAIL',"Delegation records are not permitted in default record sets");
972 }
973 return ('OK','OK');
974}
975
976
977##
978## Record data substitution subs
979##
980
981# Replace ZONE in hostname, or create (most of) the actual proper zone name
982sub _ZONE {
983 my $zone = shift;
984 my $string = shift;
985 my $fr = shift || 'f'; # flag for forward/reverse order? nb: ignored for IP
986 my $sep = shift || '-'; # Separator character - unlikely we'll ever need more than . or -
987
988 my $prefix;
989
990 $string =~ s/,/./ if !$zone->{isv6};
991 $string =~ s/,/::/ if $zone->{isv6};
992
993 # Subbing ZONE in the host. We need to properly ID the netblock range
994 # The subbed text should have "network IP with trailing zeros stripped" for
995 # blocks lined up on octet (for v4) or hex-quad (for v6) boundaries
996 # For blocks that do NOT line up on these boundaries, we take the most
997 # significant octet or 16-bit chunk of the "broadcast" IP and append it
998 # after a double-dash
999 # ie:
1000 # 8.0.0.0/6 -> 8.0.0.0 -> 11.255.255.255; sub should be 8--11
1001 # 10.0.0.0/12 -> 10.0.0.0 -> 10.0.0.0 -> 10.15.255.255; sub should be 10-0--15
1002 # 192.168.4.0/22 -> 192.168.4.0 -> 192.168.7.255; sub should be 192-168-4--7
1003 # 192.168.0.8/29 -> 192.168.0.8 -> 192.168.0.15; sub should be 192-168-0-8--15
1004 # Similar for v6
1005
1006 if (!$zone->{isv6}) { # IPv4
1007
1008 $prefix = $zone->network->addr; # Just In Case someone managed to slip in
1009 # a funky subnet that had host bits set.
1010 my $bc = $zone->broadcast->addr;
1011
1012 if ($zone->masklen > 24) {
1013 $bc =~ s/^\d+\.\d+\.\d+\.//;
1014 } elsif ($zone->masklen > 16) {
1015 $prefix =~ s/\.0$//;
1016 $bc =~ s/^\d+\.\d+\.//;
1017 } elsif ($zone->masklen > 8) {
1018 $bc =~ s/^\d+\.//;
1019 $prefix =~ s/\.0\.0$//;
1020 } else {
1021 $prefix =~ s/\.0\.0\.0$//;
1022 }
1023 if ($zone->masklen % 8) {
1024 $bc =~ s/(\.255)+$//;
1025 $prefix .= "--$bc"; #"--".zone->masklen; # use range or mask length?
1026 }
1027 if ($fr eq 'f') {
1028 $prefix =~ s/\.+/$sep/g;
1029 } else {
1030 $prefix = join($sep, reverse(split(/\./, $prefix)));
1031 }
1032
1033 } else { # IPv6
1034
1035 if ($fr eq 'f') {
1036
1037 $prefix = $zone->network->addr; # Just In Case someone managed to slip in
1038 # a funky subnet that had host bits set.
1039 my $bc = $zone->broadcast->addr;
1040 if (($zone->masklen % 16) != 0) {
1041 # Strip trailing :0 off $prefix, and :ffff off the broadcast IP
1042 for (my $i=0; $i<(7-int($zone->masklen / 16)); $i++) {
1043 $prefix =~ s/:0$//;
1044 $bc =~ s/:ffff$//;
1045 }
1046 # Strip the leading 16-bit chunks off the front of the broadcast IP
1047 $bc =~ s/^([a-f0-9]+:)+//;
1048 # Append the remaining 16-bit chunk to the prefix after "--"
1049 $prefix .= "--$bc";
1050 } else {
1051 # Strip off :0 from the end until we reach the netblock length.
1052 for (my $i=0; $i<(8-$zone->masklen / 16); $i++) {
1053 $prefix =~ s/:0$//;
1054 }
1055 }
1056 # Actually deal with the separator
1057 $prefix =~ s/:/$sep/g;
1058
1059 } else { # $fr eq 'f'
1060
1061 $prefix = $zone->network->full; # Just In Case someone managed to slip in
1062 # a funky subnet that had host bits set.
1063 my $bc = $zone->broadcast->full;
1064 $prefix =~ s/://g; # clean these out since they're not spaced right for this case
1065 $bc =~ s/://g;
1066 # Strip trailing 0 off $prefix, and f off the broadcast IP, to match the mask length
1067 for (my $i=0; $i<(31-int($zone->masklen / 4)); $i++) {
1068 $prefix =~ s/0$//;
1069 $bc =~ s/f$//;
1070 }
1071 # Split and reverse the order of the nibbles in the network/broadcast IPs
1072 # trim another 0 for nibble-aligned blocks first, but only if we really have a block, not an IP
1073 $prefix =~ s/0$// if $zone->masklen % 4 == 0 && $zone->masklen != 128;
1074 my @nbits = reverse split //, $prefix;
1075 my @bbits = reverse split //, $bc;
1076 # Handle the sub-nibble case. Eww. I feel dirty supporting this...
1077 $nbits[0] = "$nbits[0]-$bbits[0]" if ($zone->masklen % 4) != 0;
1078 # Glue it back together
1079 $prefix = join($sep, @nbits);
1080
1081 } # $fr ne 'f'
1082
1083 } # $zone->{isv6}
1084
1085 # Do the substitution, finally
1086 $string =~ s/ZONE/$prefix/;
1087 $string =~ s/--/-/ if $sep ne '-'; # - as separator needs extra help for sub-octet v4 netblocks
1088 return $string;
1089} # done _ZONE()
1090
1091# Not quite a substitution sub, but placed here as it's basically the inverse of above;
1092# given the .arpa zone name, return the CIDR netblock the zone is for.
1093# Supports v4 non-octet/non-classful netblocks as per the method outlined in the Grasshopper Book (2nd Ed p217-218)
1094# Does NOT support non-quad v6 netblocks via the same scheme; it shouldn't ever be necessary.
1095# Takes a nominal .arpa zone name, returns a success code and NetAddr::IP, or a fail code and message
1096sub _zone2cidr {
1097 my $zone = shift;
1098
1099 my $cidr;
1100 my $tmpcidr;
1101 my $warnmsg = '';
1102
1103 if ($zone =~ /\.in-addr\.arpa\.?$/) {
1104 # v4 revzone, formal zone name type
1105 my $tmpzone = $zone;
1106 $tmpzone =~ s/\.in-addr\.arpa\.?//;
1107 return ('FAIL', "Non-numerics in apparent IPv4 reverse zone name") if $tmpzone !~ /^(?:\d+-)?[\d\.]+$/;
1108
1109 # Snag the octet pieces
1110 my @octs = split /\./, $tmpzone;
1111
1112 # Map result of a range manipulation to a mask length change. Cheaper than finding the 2-root of $octets[0]+1.
1113 # Note we will not support /31 blocks, mostly due to issues telling "24-31" -> .24/29 apart from
1114 # "24-31" -> .24/31", with a litte bit of "/31 is icky".
1115 my %maskmap = ( 3 => 2, 7 => 3, 15 => 4, 31 => 5, 63 => 6, 127 => 7,
1116 30 => 2, 29 => 3, 28 => 4, 27 => 5, 26 => 6, 25 => 7
1117 );
1118
1119 # Handle "range" blocks, eg, 80-83.168.192.in-addr.arpa (192.168.80.0/22)
1120 # Need to take the size of the range to offset the basic octet-based mask length,
1121 # and make sure the first number in the range gets used as the network address for the block
1122 # Alternate form: The second number is actually the real netmask, not the end of the range.
1123 my $masklen = 0;
1124 if ($octs[0] =~ /^((\d+)-(\d+))$/) { # take the range...
1125 if (24 < $3 && $3 < 31) {
1126 # we have a real netmask
1127 $masklen = -$maskmap{$3};
1128 } else {
1129 # we have a range. NB: only real CIDR ranges are supported
1130 $masklen -= $maskmap{-(eval $1)}; # find the mask base...
1131 }
1132 $octs[0] = $2; # set the base octet of the range...
1133 }
1134 @octs = reverse @octs; # We can reverse the octet pieces now that we've extracted and munged any ranges
1135
1136# arguably we should only allow sub-octet range/mask in-addr.arpa
1137# specifications in the least significant octet, but the code is
1138# simpler if we deal with sub-octet delegations at any level.
1139
1140 # Now we find the "true" mask with the aid of the "base" calculated above
1141 if ($#octs == 0) {
1142 $masklen += 8;
1143 $tmpcidr = "$octs[0].0.0.0/$masklen"; # really hope we don't see one of these very often.
1144 } elsif ($#octs == 1) {
1145 $masklen += 16;
1146 $tmpcidr = "$octs[0].$octs[1].0.0/$masklen";
1147 } elsif ($#octs == 2) {
1148 $masklen += 24;
1149 $tmpcidr = "$octs[0].$octs[1].$octs[2].0/$masklen";
1150 } else {
1151 $masklen += 32;
1152 $tmpcidr = "$octs[0].$octs[1].$octs[2].$octs[3]/$masklen";
1153 }
1154
1155 } elsif ($zone =~ /\.ip6\.arpa$/) {
1156 # v6 revzone, formal zone name type
1157 my $tmpzone = $zone;
1158 $tmpzone =~ s/\.ip6\.arpa\.?//;
1159##fixme: if-n-when we decide we can support sub-nibble v6 zone names, we'll need to change this segment
1160 return ('FAIL', "Non-hexadecimals in apparent IPv6 reverse zone name") if $tmpzone !~ /^[a-fA-F\d\.]+$/;
1161 my @quads = reverse(split(/\./, $tmpzone));
1162 $warnmsg .= "Apparent sub-/64 IPv6 reverse zone\n" if $#quads > 15;
1163 my $nc;
1164 foreach (@quads) {
1165 $tmpcidr .= $_;
1166 $tmpcidr .= ":" if ++$nc % 4 == 0;
1167 }
1168 my $nq = 1 if $nc % 4 != 0;
1169 my $mask = $nc * 4; # need to do this here because we probably increment it below
1170 while ($nc++ % 4 != 0) {
1171 $tmpcidr .= "0";
1172 }
1173 $tmpcidr .= ($nq ? '::' : ':')."/$mask";
1174 }
1175
1176 # Just to be sure, use NetAddr::IP to validate. Saves a lot of nasty regex watching for valid octet values.
1177 return ('FAIL', "Invalid zone $zone (apparent netblock $tmpcidr)")
1178 unless $cidr = NetAddr::IP->new($tmpcidr);
1179
1180 if ($warnmsg) {
1181 $errstr = $warnmsg;
1182 return ('WARN', $cidr);
1183 }
1184 return ('OK', $cidr);
1185} # done _zone2cidr()
1186
1187# Record template %-parameter expansion, IPv4. Note that IPv6 doesn't
1188# really have a sane way to handle this type of expansion at the moment
1189# due to the size of the address space.
1190# Takes a reference to a template string to be expanded, and an IP to use in the replacement.
1191sub _template4_expand {
1192 my $tmpl = shift;
1193 my $ip = shift;
1194
1195 my @ipparts = split /\./, $ip;
1196 my @iphex;
1197 my @ippad;
1198 for (@ipparts) {
1199 push @iphex, sprintf("%x", $_);
1200 push @ippad, sprintf("%0.3u", $_);
1201 }
1202
1203 # IP substitutions in template records:
1204 #major patterns:
1205 #dashed IP, forward and reverse
1206 #dotted IP, forward and reverse (even if forward is... dumb)
1207 # -> %r for reverse, %i for forward, leading - or . to indicate separator, defaults to -
1208 # %r or %-r => %4d-%3d-%2d-%1d
1209 # %.r => %4d.%3d.%2d.%1d
1210 # %i or %-i => %1d-%2d-%3d-%4d
1211 # %.i => %1d.%2d.%3d.%4d
1212 $$tmpl =~ s/\%r/\%4d-\%3d-\%2d-\%1d/g;
1213 $$tmpl =~ s/\%([-.])r/\%4d$1\%3d$1\%2d$1\%1d/g;
1214 $$tmpl =~ s/\%i/\%1d-\%2d-\%3d-\%4d/g;
1215 $$tmpl =~ s/\%([-.])i/\%1d$1\%2d$1\%3d$1\%4d/g;
1216
1217 #hex-coded IP
1218 # %h
1219 $$tmpl =~ s/\%h/$iphex[0]$iphex[1]$iphex[2]$iphex[3]/g;
1220
1221 #IP as decimal-coded 32-bit value
1222 # %d
1223 my $iptmp = $ipparts[0]*256*256*256 + $ipparts[1]*256*256 + $ipparts[2]*256 + $ipparts[3];
1224 $$tmpl =~ s/\%d/$iptmp/g;
1225
1226 #minor patterns (per-octet)
1227 # %[1234][dh0]
1228 #octet
1229 #hex-coded octet
1230 #0-padded octet
1231 $$tmpl =~ s/\%([1234])d/$ipparts[$1-1]/g;
1232 $$tmpl =~ s/\%([1234])h/$iphex[$1-1]/g;
1233 $$tmpl =~ s/\%([1234])0/$ippad[$1-1]/g;
1234} # _template4_expand()
1235
1236
1237##
1238## Initialization and cleanup subs
1239##
1240
1241## DNSDB::loadConfig()
1242# Load the minimum required initial state (DB connect info) from a config file
1243# Load misc other bits while we're at it.
1244# Takes an optional hash that may contain:
1245# - basename and config path to look for
1246# Populates the %config and %def hashes
1247sub loadConfig {
1248 my %args = @_;
1249 $args{configfile} = '' if !$args{configfile};
1250
1251##fixme this is *intended* to load a system-default config template, and allow
1252# overriding on a per-tool or per-web-UI-instance basis with a secondary config
1253# file. The "default" config file can't be deleted in the current form.
1254
1255 my $deferr = ''; # place to put error from default config file in case we can't find either one
1256
1257 my $configroot = "/etc/dnsdb"; ##CFG_LEAF##
1258 $configroot = '' if $args{configfile} =~ m|^/|; # allow passed siteconfig to specify an arbitrary absolute path
1259 $args{configfile} .= ".conf" if $args{configfile} !~ /\.conf$/;
1260 my $defconfig = "$configroot/dnsdb.conf";
1261 my $siteconfig = "$configroot/$args{configfile}";
1262
1263 # System defaults
1264 __cfgload("$defconfig") or $deferr = $errstr;
1265
1266 # Per-site-ish settings.
1267 if ($args{configfile} ne '.conf') {
1268 unless (__cfgload("$siteconfig")) {
1269 $errstr = ($deferr ? "Error opening default config file $defconfig: $deferr\n" : '').
1270 "Error opening site config file $siteconfig";
1271 return;
1272 }
1273 }
1274
1275 # Munge log_failures.
1276 if ($config{log_failures} ne '1' && $config{log_failures} ne '0') {
1277 # true/false, on/off, yes/no all valid.
1278 if ($config{log_failures} =~ /^(?:true|false|on|off|yes|no)$/) {
1279 if ($config{log_failures} =~ /(?:true|on|yes)/) {
1280 $config{log_failures} = 1;
1281 } else {
1282 $config{log_failures} = 0;
1283 }
1284 } else {
1285 $errstr = "Bad log_failures setting $config{log_failures}";
1286 $config{log_failures} = 1;
1287 # Bad setting shouldn't be fatal.
1288 # return 2;
1289 }
1290 }
1291
1292 # All good, clear the error and go home.
1293 $errstr = '';
1294 return 1;
1295} # end loadConfig()
1296
1297
1298## DNSDB::__cfgload()
1299# Private sub to parse a config file and load it into %config
1300# Takes a filename
1301sub __cfgload {
1302 $errstr = '';
1303 my $cfgfile = shift;
1304
1305 if (open CFG, "<$cfgfile") {
1306 while (<CFG>) {
1307 chomp;
1308 s/^\s*//;
1309 next if /^#/;
1310 next if /^$/;
1311# hmm. more complex bits in this file might require [heading] headers, maybe?
1312# $mode = $1 if /^\[(a-z)+]/;
1313 # DB connect info
1314 $config{dbname} = $1 if /^dbname\s*=\s*([a-z0-9_.-]+)/i;
1315 $config{dbuser} = $1 if /^dbuser\s*=\s*([a-z0-9_.-]+)/i;
1316 $config{dbpass} = $1 if /^dbpass\s*=\s*([a-z0-9_.-]+)/i;
1317 $config{dbhost} = $1 if /^dbhost\s*=\s*([a-z0-9_.-]+)/i;
1318 # SOA defaults
1319 $def{contact} = $1 if /^contact\s*=\s*([a-z0-9_.-]+)/i;
1320 $def{prins} = $1 if /^prins\s*=\s*([a-z0-9_.-]+)/i;
1321 $def{soattl} = $1 if /^soattl\s*=\s*(\d+)/i;
1322 $def{refresh} = $1 if /^refresh\s*=\s*(\d+)/i;
1323 $def{retry} = $1 if /^retry\s*=\s*(\d+)/i;
1324 $def{expire} = $1 if /^expire\s*=\s*(\d+)/i;
1325 $def{minttl} = $1 if /^minttl\s*=\s*(\d+)/i;
1326 $def{ttl} = $1 if /^ttl\s*=\s*(\d+)/i;
1327 # Mail settings
1328 $config{mailhost} = $1 if /^mailhost\s*=\s*([a-z0-9_.-]+)/i;
1329 $config{mailnotify} = $1 if /^mailnotify\s*=\s*([a-z0-9_.\@-]+)/i;
1330 $config{mailsender} = $1 if /^mailsender\s*=\s*([a-z0-9_.\@-]+)/i;
1331 $config{mailname} = $1 if /^mailname\s*=\s*([a-z0-9\s_.-]+)/i;
1332 $config{orgname} = $1 if /^orgname\s*=\s*([a-z0-9\s_.,'-]+)/i;
1333 $config{domain} = $1 if /^domain\s*=\s*([a-z0-9_.-]+)/i;
1334 # session - note this is fed directly to CGI::Session
1335 $config{timeout} = $1 if /^[tT][iI][mM][eE][oO][uU][tT]\s*=\s*(\d+[smhdwMy]?)/;
1336 $config{sessiondir} = $1 if m{^sessiondir\s*=\s*([a-z0-9/_.-]+)}i;
1337 # misc
1338 $config{log_failures} = $1 if /^log_failures\s*=\s*([a-z01]+)/i;
1339 $config{perpage} = $1 if /^perpage\s*=\s*(\d+)/i;
1340 $config{exportcache} = $1 if m{^exportcache\s*=\s*([a-z0-9/_.-]+)}i;
1341 # RPC options
1342 $config{rpcmode} = $1 if /^rpc_mode\s*=\s*(socket|HTTP|XMLRPC)\s*$/i;
1343 $config{maxfcgi} = $1 if /^max_fcgi_requests\s*=\s*(\d+)\s*$/i;
1344 if (my ($tmp) = /^rpc_iplist\s*=\s*(.+)/i) {
1345 my @ips = split /[,\s]+/, $tmp;
1346 my $rpcsys = shift @ips;
1347 push @{$config{rpcacl}{$rpcsys}}, @ips;
1348 }
1349 }
1350 close CFG;
1351 } else {
1352 $errstr = $!;
1353 return;
1354 }
1355 return 1;
1356} # end __cfgload()
1357
1358
1359## DNSDB::connectDB()
1360# Creates connection to DNS database.
1361# Requires the database name, username, and password.
1362# Returns a handle to the db or undef on failure.
1363# Set up for a PostgreSQL db; could be any transactional DBMS with the
1364# right changes.
1365# Called by new(); not intended to be called publicly.
1366sub connectDB {
1367 $errstr = '';
1368 my $dbname = shift;
1369 my $user = shift;
1370 my $pass = shift;
1371 my $dbh;
1372 my $DSN = "DBI:Pg:dbname=$dbname";
1373
1374 my $host = shift;
1375 $DSN .= ";host=$host" if $host;
1376
1377# Note that we want to autocommit by default, and we will turn it off locally as necessary.
1378# We may not want to print gobbledygook errors; YMMV. Have to ponder that further.
1379 $dbh = DBI->connect($DSN, $user, $pass, {
1380 AutoCommit => 1,
1381 PrintError => 0
1382 });
1383 if (!$dbh) {
1384 $errstr = $DBI::errstr;
1385 return;
1386 }
1387#) if(!$dbh);
1388
1389 local $dbh->{RaiseError} = 1;
1390
1391 eval {
1392##fixme: initialize the DB if we can't find the table (since, by definition, there's
1393# nothing there if we can't select from it...)
1394 my $tblsth = $dbh->prepare("SELECT count(*) FROM pg_catalog.pg_class WHERE relkind='r' AND relname=?");
1395 my ($tblcount) = $dbh->selectrow_array($tblsth, undef, ('misc'));
1396# return (undef,$DBI::errstr) if $dbh->err;
1397
1398#if ($tblcount == 0) {
1399# # create tables one at a time, checking for each.
1400# return (undef, "check table misc missing");
1401#}
1402
1403# Return here if we can't select.
1404# This should retrieve the dbversion key.
1405 my $sth = $dbh->prepare("SELECT key,value FROM misc WHERE misc_id=1");
1406 $sth->execute();
1407# return (undef,$DBI::errstr) if ($sth->err);
1408
1409##fixme: do stuff to the DB on version mismatch
1410# x.y series should upgrade on $DNSDB::VERSION > misc(key=>version)
1411# DB should be downward-compatible; column defaults should give sane (if possibly
1412# useless-and-needs-help) values in columns an older software stack doesn't know about.
1413
1414# See if the select returned anything (or null data). This should
1415# succeed if the select executed, but...
1416 $sth->fetchrow();
1417# return (undef,$DBI::errstr) if ($sth->err);
1418
1419 $sth->finish;
1420
1421 }; # wrapped DB checks
1422 if ($@) {
1423 $errstr = $@;
1424 return;
1425 }
1426
1427# If we get here, we should be OK.
1428 return $dbh;
1429} # end connectDB
1430
1431
1432## DNSDB::finish()
1433# Cleans up after database handles and so on.
1434# Requires a database handle
1435sub finish {
1436 my $self = shift;
1437 $self->{dbh}->disconnect;
1438} # end finish
1439
1440
1441## DNSDB::initGlobals()
1442# Initialize global variables
1443# NB: this does NOT include web-specific session variables!
1444sub initGlobals {
1445 my $self = shift;
1446 my $dbh = $self->{dbh};
1447
1448# load record types from database
1449 my $sth = $dbh->prepare("SELECT val,name,stdflag FROM rectypes");
1450 $sth->execute;
1451 while (my ($recval,$recname,$stdflag) = $sth->fetchrow_array()) {
1452 $typemap{$recval} = $recname;
1453 $reverse_typemap{$recname} = $recval;
1454 # now we fill the record validation function hash
1455 if ($stdflag < 5) {
1456 my $fn = "_validate_$recval";
1457 $validators{$recval} = \&$fn;
1458 } else {
1459 my $fn = "sub { return ('FAIL','Type $recval ($recname) not supported'); }";
1460 $validators{$recval} = eval $fn;
1461 }
1462 }
1463} # end initGlobals
1464
1465
1466## DNSDB::initRPC()
1467# Takes a remote username and remote fullname.
1468# Sets up the RPC logging-pseudouser if needed.
1469# Sets the %userdata hash for logging.
1470# Returns undef on failure
1471sub initRPC {
1472 my $self = shift;
1473 my $dbh = $self->{dbh};
1474 my %args = @_;
1475
1476 return if !$args{username};
1477 return if !$args{fullname};
1478
1479 $args{username} = "$args{username}/$args{rpcsys}";
1480
1481 my $tmpuser = $dbh->selectrow_hashref("SELECT username,user_id AS userid,group_id,firstname,lastname,status".
1482 " FROM users WHERE username=?", undef, ($args{username}) );
1483 if (!$tmpuser) {
1484 $dbh->do("INSERT INTO users (username,password,firstname,type) VALUES (?,'RPC',?,'R')", undef,
1485 ($args{username}, $args{fullname}) );
1486 $tmpuser = $dbh->selectrow_hashref("SELECT username,user_id AS userid,group_id,firstname,lastname,status".
1487 " FROM users WHERE username=?", undef, ($args{username}) );
1488 }
1489 $tmpuser->{lastname} = '' if !$tmpuser->{lastname};
1490 $self->{loguserid} = $tmpuser->{userid};
1491 $self->{logusername} = $tmpuser->{username};
1492 $self->{logfullname} = "$tmpuser->{firstname} $tmpuser->{lastname} ($args{rpcsys})";
1493 return 1 if $tmpuser;
1494} # end initRPC()
1495
1496
1497## DNSDB::login()
1498# Takes a database handle, username and password
1499# Returns a userdata hash (UID, GID, username, fullname parts) if username exists,
1500# password matches the one on file, and account is not disabled
1501# Returns undef otherwise
1502sub login {
1503 my $self = shift;
1504 my $dbh = $self->{dbh};
1505 my $user = shift;
1506 my $pass = shift;
1507
1508 my $userinfo = $dbh->selectrow_hashref("SELECT user_id,group_id,password,firstname,lastname,status".
1509 " FROM users WHERE username=?",
1510 undef, ($user) );
1511 return if !$userinfo;
1512 return if !$userinfo->{status};
1513
1514 if ($userinfo->{password} =~ m|^\$1\$([A-Za-z0-9/.]+)\$|) {
1515 # native passwords (crypt-md5)
1516 return if $userinfo->{password} ne unix_md5_crypt($pass,$1);
1517 } elsif ($userinfo->{password} =~ /^[0-9a-f]{32}$/) {
1518 # VegaDNS import (hex-coded MD5)
1519 return if $userinfo->{password} ne md5_hex($pass);
1520 } else {
1521 # plaintext (convenient now and then)
1522 return if $userinfo->{password} ne $pass;
1523 }
1524
1525 return $userinfo;
1526} # end login()
1527
1528
1529## DNSDB::initActionLog()
1530# Set up action logging. Takes a database handle and user ID
1531# Sets some internal globals and Does The Right Thing to set up a logging channel.
1532# This sets up _log() to spew out log entries to the defined channel without worrying
1533# about having to open a file or a syslog channel
1534##fixme Need to call _initActionLog_blah() for various logging channels, configured
1535# via dnsdb.conf, in $config{log_channel} or something
1536# See https://secure.deepnet.cx/trac/dnsadmin/ticket/21
1537sub initActionLog {
1538 my $self = shift;
1539 my $dbh = $self->{dbh};
1540 my $uid = shift;
1541
1542 return if !$uid;
1543
1544 # snag user info for logging. there's got to be a way to not have to pass this back
1545 # and forth from a caller, but web usage means no persistence we can rely on from
1546 # the server side.
1547 my ($username,$fullname) = $dbh->selectrow_array("SELECT username, firstname || ' ' || lastname".
1548 " FROM users WHERE user_id=?", undef, ($uid));
1549##fixme: errors are unpossible!
1550
1551 $self->{logusername} = $username;
1552 $self->{loguserid} = $uid;
1553 $self->{logfullname} = $fullname;
1554
1555 # convert to real check once we have other logging channels
1556 # if ($config{log_channel} eq 'sql') {
1557 # Open Log, Sez Me!
1558 # }
1559
1560} # end initActionLog
1561
1562
1563## DNSDB::getPermissions()
1564# Get permissions from DB
1565# Requires DB handle, group or user flag, ID, and hashref.
1566sub getPermissions {
1567 my $self = shift;
1568 my $dbh = $self->{dbh};
1569
1570 my $type = shift;
1571 my $id = shift;
1572 my $hash = shift;
1573
1574 my $sql = qq(
1575 SELECT
1576 p.admin,p.self_edit,
1577 p.group_create,p.group_edit,p.group_delete,
1578 p.user_create,p.user_edit,p.user_delete,
1579 p.domain_create,p.domain_edit,p.domain_delete,
1580 p.record_create,p.record_edit,p.record_delete,p.record_locchg,
1581 p.location_create,p.location_edit,p.location_delete,p.location_view
1582 FROM permissions p
1583 );
1584 if ($type eq 'group') {
1585 $sql .= qq(
1586 JOIN groups g ON g.permission_id=p.permission_id
1587 WHERE g.group_id=?
1588 );
1589 } else {
1590 $sql .= qq(
1591 JOIN users u ON u.permission_id=p.permission_id
1592 WHERE u.user_id=?
1593 );
1594 }
1595
1596 my $sth = $dbh->prepare($sql);
1597
1598 $sth->execute($id) or die "argh: ".$sth->errstr;
1599
1600# my $permref = $sth->fetchrow_hashref;
1601# return $permref;
1602# $hash = $permref;
1603# Eww. Need to learn how to forcibly drop a hashref onto an existing hash.
1604 ($hash->{admin},$hash->{self_edit},
1605 $hash->{group_create},$hash->{group_edit},$hash->{group_delete},
1606 $hash->{user_create},$hash->{user_edit},$hash->{user_delete},
1607 $hash->{domain_create},$hash->{domain_edit},$hash->{domain_delete},
1608 $hash->{record_create},$hash->{record_edit},$hash->{record_delete},$hash->{record_locchg},
1609 $hash->{location_create},$hash->{location_edit},$hash->{location_delete},$hash->{location_view}
1610 ) = $sth->fetchrow_array;
1611
1612} # end getPermissions()
1613
1614
1615## DNSDB::changePermissions()
1616# Update an ACL entry
1617# Takes a db handle, type, owner-id, and hashref for the changed permissions.
1618sub changePermissions {
1619 my $self = shift;
1620 my $dbh = $self->{dbh};
1621 my $type = shift;
1622 my $id = shift;
1623 my $newperms = shift;
1624 my $inherit = shift || 0;
1625
1626 my $resultmsg = '';
1627
1628 # see if we're switching from inherited to custom. for bonus points,
1629 # snag the permid and parent permid anyway, since we'll need the permid
1630 # to set/alter custom perms, and both if we're switching from custom to
1631 # inherited.
1632 my $sth = $dbh->prepare("SELECT (u.permission_id=g.permission_id) AS was_inherited,u.permission_id,g.permission_id,".
1633 ($type eq 'user' ? 'u.group_id,u.username' : 'u.parent_group_id,u.group_name').
1634 " FROM ".($type eq 'user' ? 'users' : 'groups')." u ".
1635 " JOIN groups g ON u.".($type eq 'user' ? '' : 'parent_')."group_id=g.group_id ".
1636 " WHERE u.".($type eq 'user' ? 'user' : 'group')."_id=?");
1637 $sth->execute($id);
1638
1639 my ($wasinherited,$permid,$parpermid,$parid,$name) = $sth->fetchrow_array;
1640
1641# hack phtoui
1642# group id 1 is "special" in that it's it's own parent (err... possibly.)
1643# may make its parent id 0 which doesn't exist, and as a bonus is Perl-false.
1644 $wasinherited = 0 if ($type eq 'group' && $id == 1);
1645
1646 local $dbh->{AutoCommit} = 0;
1647 local $dbh->{RaiseError} = 1;
1648
1649 # Wrap all the SQL in a transaction
1650 eval {
1651 if ($inherit) {
1652
1653 $dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='t',permission_id=? ".
1654 "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($parpermid, $id) );
1655 $dbh->do("DELETE FROM permissions WHERE permission_id=?", undef, ($permid) );
1656
1657 } else {
1658
1659 if ($wasinherited) { # munge new permission entry in if we're switching from inherited perms
1660##fixme: need to add semirecursive bit to properly munge inherited permission ID on subgroups and users
1661# ... if'n'when we have groups with fully inherited permissions.
1662 # SQL is coo
1663 $dbh->do("INSERT INTO permissions ($permlist,".($type eq 'user' ? 'user' : 'group')."_id) ".
1664 "SELECT $permlist,? FROM permissions WHERE permission_id=?", undef, ($id,$permid) );
1665 ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions ".
1666 "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($id) );
1667 $dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='f',permission_id=? ".
1668 "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($permid, $id) );
1669 }
1670
1671 # and now set the permissions we were passed
1672 foreach (@permtypes) {
1673 if (defined ($newperms->{$_})) {
1674 $dbh->do("UPDATE permissions SET $_=? WHERE permission_id=?", undef, ($newperms->{$_},$permid) );
1675 }
1676 }
1677
1678 } # (inherited->)? custom
1679
1680 if ($type eq 'user') {
1681 $resultmsg = "Updated permissions for user $name";
1682 } else {
1683 $resultmsg = "Updated default permissions for group $name";
1684 }
1685 $self->_log(group_id => ($type eq 'user' ? $parid : $id), entry => $resultmsg);
1686 $dbh->commit;
1687 }; # end eval
1688 if ($@) {
1689 my $msg = $@;
1690 eval { $dbh->rollback; };
1691 return ('FAIL',"Error changing permissions: $msg");
1692 }
1693
1694 return ('OK',$resultmsg);
1695} # end changePermissions()
1696
1697
1698## DNSDB::comparePermissions()
1699# Compare two permission hashes
1700# Returns '>', '<', '=', '!'
1701sub comparePermissions {
1702 my $p1 = shift;
1703 my $p2 = shift;
1704
1705 my $retval = '='; # assume equality until proven otherwise
1706
1707 no warnings "uninitialized";
1708
1709 foreach (@permtypes) {
1710 next if $p1->{$_} == $p2->{$_}; # equal is good
1711 if ($p1->{$_} && !$p2->{$_}) {
1712 if ($retval eq '<') { # if we've already found an unequal pair where
1713 $retval = '!'; # $p2 has more access, and we now find a pair
1714 last; # where $p1 has more access, the overall access
1715 } # is neither greater or lesser, it's unequal.
1716 $retval = '>';
1717 }
1718 if (!$p1->{$_} && $p2->{$_}) {
1719 if ($retval eq '>') { # if we've already found an unequal pair where
1720 $retval = '!'; # $p1 has more access, and we now find a pair
1721 last; # where $p2 has more access, the overall access
1722 } # is neither greater or lesser, it's unequal.
1723 $retval = '<';
1724 }
1725 }
1726 return $retval;
1727} # end comparePermissions()
1728
1729
1730## DNSDB::changeGroup()
1731# Change group ID of an entity
1732# Takes a database handle, entity type, entity ID, and new group ID
1733sub changeGroup {
1734 my $self = shift;
1735 my $dbh = $self->{dbh};
1736 my $type = shift;
1737 my $id = shift;
1738 my $newgrp = shift;
1739
1740##fixme: fail on not enough args
1741 #return ('FAIL', "Missing
1742
1743 return ('FAIL', "Can't change the group of a $type")
1744 unless grep /^$type$/, ('domain','revzone','user','group'); # could be extended for defrecs?
1745
1746 # Collect some names for logging and messages
1747 my $entname;
1748 if ($type eq 'domain') {
1749 $entname = $self->domainName($id);
1750 } elsif ($type eq 'revzone') {
1751 $entname = $self->revName($id);
1752 } elsif ($type eq 'user') {
1753 $entname = $self->userFullName($id, '%u');
1754 } elsif ($type eq 'group') {
1755 $entname = $self->groupName($id);
1756 }
1757
1758 my ($oldgid) = $dbh->selectrow_array("SELECT group_id FROM $par_tbl{$type} WHERE $id_col{$type}=?",
1759 undef, ($id));
1760 my $oldgname = $self->groupName($oldgid);
1761 my $newgname = $self->groupName($newgrp);
1762
1763 return ('FAIL', "Can't move things into a group that doesn't exist") if !$newgname;
1764
1765 return ('WARN', "Nothing to do, new group is the same as the old group") if $oldgid == $newgrp;
1766
1767 # Allow transactions, and raise an exception on errors so we can catch it later.
1768 # Use local to make sure these get "reset" properly on exiting this block
1769 local $dbh->{AutoCommit} = 0;
1770 local $dbh->{RaiseError} = 1;
1771
1772 eval {
1773 $dbh->do("UPDATE $par_tbl{$type} SET group_id=? WHERE $id_col{$type}=?", undef, ($newgrp, $id));
1774 # Log the change in both the old and new groups
1775 $self->_log(group_id => $oldgid, entry => "Moved $type $entname from $oldgname to $newgname");
1776 $self->_log(group_id => $newgrp, entry => "Moved $type $entname from $oldgname to $newgname");
1777 $dbh->commit;
1778 };
1779 if ($@) {
1780 my $msg = $@;
1781 eval { $dbh->rollback; };
1782 if ($config{log_failures}) {
1783 $self->_log(group_id => $oldgid, entry => "Error moving $type $entname to $newgname: $msg");
1784 $dbh->commit; # since we enabled transactions earlier
1785 }
1786 return ('FAIL',"Error moving $type $entname to $newgname: $msg");
1787 }
1788
1789 return ('OK',"Moved $type $entname from $oldgname to $newgname");
1790} # end changeGroup()
1791
1792
1793##
1794## Processing subs
1795##
1796
1797## DNSDB::addDomain()
1798# Add a domain
1799# Takes a database handle, domain name, numeric group, boolean(ish) state (active/inactive),
1800# and user info hash (for logging).
1801# Returns a status code and message
1802sub addDomain {
1803 $errstr = '';
1804 my $self = shift;
1805 my $dbh = $self->{dbh};
1806 my $domain = shift;
1807 return ('FAIL',"Domain must not be blank\n") if !$domain;
1808 my $group = shift;
1809 return ('FAIL',"Group must be specified\n") if !defined($group);
1810 my $state = shift;
1811 return ('FAIL',"Domain status must be specified\n") if !defined($state);
1812
1813 $state = 1 if $state =~ /^active$/;
1814 $state = 1 if $state =~ /^on$/;
1815 $state = 0 if $state =~ /^inactive$/;
1816 $state = 0 if $state =~ /^off$/;
1817
1818 return ('FAIL',"Invalid domain status") if $state !~ /^\d+$/;
1819
1820 return ('FAIL', "Invalid characters in domain") if $domain !~ /^[a-zA-Z0-9_.-]+$/;
1821
1822 my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)");
1823 my $dom_id;
1824
1825# quick check to start to see if we've already got one
1826 $sth->execute($domain);
1827 ($dom_id) = $sth->fetchrow_array;
1828
1829 return ('FAIL', "Domain already exists") if $dom_id;
1830
1831 # Allow transactions, and raise an exception on errors so we can catch it later.
1832 # Use local to make sure these get "reset" properly on exiting this block
1833 local $dbh->{AutoCommit} = 0;
1834 local $dbh->{RaiseError} = 1;
1835
1836 # Wrap all the SQL in a transaction
1837 eval {
1838 # insert the domain...
1839 $dbh->do("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)", undef, ($domain, $group, $state));
1840
1841 # get the ID...
1842 ($dom_id) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)",
1843 undef, ($domain));
1844
1845 $self->_log(domain_id => $dom_id, group_id => $group,
1846 entry => "Added ".($state ? 'active' : 'inactive')." domain $domain");
1847
1848 # ... and now we construct the standard records from the default set. NB: group should be variable.
1849 my $sth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
1850 my $sth_in = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,distance,weight,port,ttl)".
1851 " VALUES ($dom_id,?,?,?,?,?,?,?)");
1852 $sth->execute($group);
1853 while (my ($host,$type,$val,$dist,$weight,$port,$ttl) = $sth->fetchrow_array()) {
1854 $host =~ s/DOMAIN/$domain/g;
1855 $val =~ s/DOMAIN/$domain/g;
1856 $sth_in->execute($host,$type,$val,$dist,$weight,$port,$ttl);
1857 if ($typemap{$type} eq 'SOA') {
1858 my @tmp1 = split /:/, $host;
1859 my @tmp2 = split /:/, $val;
1860 $self->_log(domain_id => $dom_id, group_id => $group,
1861 entry => "[new $domain] Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ".
1862 "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl");
1863 } else {
1864 my $logentry = "[new $domain] Added record '$host $typemap{$type}";
1865 $logentry .= " [distance $dist]" if $typemap{$type} eq 'MX';
1866 $logentry .= " [priority $dist] [weight $weight] [port $port]" if $typemap{$type} eq 'SRV';
1867 $self->_log(domain_id => $dom_id, group_id => $group,
1868 entry => $logentry." $val', TTL $ttl");
1869 }
1870 }
1871
1872 # once we get here, we should have suceeded.
1873 $dbh->commit;
1874 }; # end eval
1875
1876 if ($@) {
1877 my $msg = $@;
1878 eval { $dbh->rollback; };
1879 $self->_log(group_id => $group, entry => "Failed adding domain $domain ($msg)")
1880 if $config{log_failures};
1881 $dbh->commit; # since we enabled transactions earlier
1882 return ('FAIL',$msg);
1883 } else {
1884 return ('OK',$dom_id);
1885 }
1886} # end addDomain
1887
1888
1889## DNSDB::delZone()
1890# Delete a forward or reverse zone.
1891# Takes a database handle, zone ID, and forward/reverse flag.
1892# for now, just delete the records, then the domain.
1893# later we may want to archive it in some way instead (status code 2, for example?)
1894sub delZone {
1895 my $self = shift;
1896 my $dbh = $self->{dbh};
1897 my $zoneid = shift;
1898 my $revrec = shift;
1899
1900 # Allow transactions, and raise an exception on errors so we can catch it later.
1901 # Use local to make sure these get "reset" properly on exiting this block
1902 local $dbh->{AutoCommit} = 0;
1903 local $dbh->{RaiseError} = 1;
1904
1905 my $msg = '';
1906 my $failmsg = '';
1907 my $zone = ($revrec eq 'n' ? $self->domainName($zoneid) : $self->revName($zoneid));
1908
1909 return ('FAIL', ($revrec eq 'n' ? 'Domain' : 'Reverse zone')." ID $zoneid doesn't exist") if !$zone;
1910
1911 # Set this up here since we may use if if $config{log_failures} is enabled
1912 my %loghash;
1913 $loghash{domain_id} = $zoneid if $revrec eq 'n';
1914 $loghash{rdns_id} = $zoneid if $revrec eq 'y';
1915 $loghash{group_id} = $self->parentID(
1916 id => $zoneid, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec);
1917
1918 # Wrap all the SQL in a transaction
1919 eval {
1920 # Disentangle custom record types before removing the
1921 # ones that are only in the zone to be deleted
1922 if ($revrec eq 'n') {
1923 my $sth = $dbh->prepare("UPDATE records SET type=?,domain_id=0 WHERE domain_id=? AND type=?");
1924 $failmsg = "Failure converting multizone types to single-zone";
1925 $sth->execute($reverse_typemap{PTR}, $zoneid, 65280);
1926 $sth->execute($reverse_typemap{PTR}, $zoneid, 65281);
1927 $sth->execute(65282, $zoneid, 65283);
1928 $sth->execute(65282, $zoneid, 65284);
1929 $failmsg = "Failure removing domain records";
1930 $dbh->do("DELETE FROM records WHERE domain_id=?", undef, ($zoneid));
1931 $failmsg = "Failure removing domain";
1932 $dbh->do("DELETE FROM domains WHERE domain_id=?", undef, ($zoneid));
1933 } else {
1934 my $sth = $dbh->prepare("UPDATE records SET type=?,rdns_id=0 WHERE rdns_id=? AND type=?");
1935 $failmsg = "Failure converting multizone types to single-zone";
1936 $sth->execute($reverse_typemap{A}, $zoneid, 65280);
1937 $sth->execute($reverse_typemap{AAAA}, $zoneid, 65281);
1938# We don't have an "A template" or "AAAA template" type, although it might be useful for symmetry.
1939# $sth->execute(65286?, $zoneid, 65283);
1940# $sth->execute(65286?, $zoneid, 65284);
1941 $failmsg = "Failure removing reverse records";
1942 $dbh->do("DELETE FROM records WHERE rdns_id=?", undef, ($zoneid));
1943 $failmsg = "Failure removing reverse zone";
1944 $dbh->do("DELETE FROM revzones WHERE rdns_id=?", undef, ($zoneid));
1945 }
1946
1947 $msg = "Deleted ".($revrec eq 'n' ? 'domain' : 'reverse zone')." $zone";
1948 $loghash{entry} = $msg;
1949 $self->_log(%loghash);
1950
1951 # once we get here, we should have suceeded.
1952 $dbh->commit;
1953 }; # end eval
1954
1955 if ($@) {
1956 $msg = $@;
1957 eval { $dbh->rollback; };
1958 $loghash{entry} = "Error deleting $zone: $msg ($failmsg)";
1959 if ($config{log_failures}) {
1960 $self->_log(%loghash);
1961 $dbh->commit; # since we enabled transactions earlier
1962 }
1963 return ('FAIL', $loghash{entry});
1964 } else {
1965 return ('OK', $msg);
1966 }
1967
1968} # end delZone()
1969
1970
1971## DNSDB::domainName()
1972# Return the domain name based on a domain ID
1973# Takes a database handle and the domain ID
1974# Returns the domain name or undef on failure
1975sub domainName {
1976 $errstr = '';
1977 my $self = shift;
1978 my $dbh = $self->{dbh};
1979 my $domid = shift;
1980 my ($domname) = $dbh->selectrow_array("SELECT domain FROM domains WHERE domain_id=?", undef, ($domid) );
1981 $errstr = $DBI::errstr if !$domname;
1982 return $domname if $domname;
1983} # end domainName()
1984
1985
1986## DNSDB::revName()
1987# Return the reverse zone name based on an rDNS ID
1988# Takes a database handle and the rDNS ID
1989# Returns the reverse zone name or undef on failure
1990sub revName {
1991 $errstr = '';
1992 my $self = shift;
1993 my $dbh = $self->{dbh};
1994 my $revid = shift;
1995 my ($revname) = $dbh->selectrow_array("SELECT revnet FROM revzones WHERE rdns_id=?", undef, ($revid) );
1996 $errstr = $DBI::errstr if !$revname;
1997 return $revname if $revname;
1998} # end revName()
1999
2000
2001## DNSDB::domainID()
2002# Takes a database handle and domain name
2003# Returns the domain ID number
2004sub domainID {
2005 $errstr = '';
2006 my $self = shift;
2007 my $dbh = $self->{dbh};
2008 my $domain = shift;
2009 my ($domid) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)",
2010 undef, ($domain) );
2011 if (!$domid) {
2012 if ($dbh->err) {
2013 $errstr = $DBI::errstr;
2014 } else {
2015 $errstr = "Domain $domain not present";
2016 }
2017 }
2018 return $domid if $domid;
2019} # end domainID()
2020
2021
2022## DNSDB::revID()
2023# Takes a database handle and reverse zone name
2024# Returns the rDNS ID number
2025sub revID {
2026 $errstr = '';
2027 my $self = shift;
2028 my $dbh = $self->{dbh};
2029 my $revzone = shift;
2030 my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet=?", undef, ($revzone) );
2031 if (!$revid) {
2032 if ($dbh->err) {
2033 $errstr = $DBI::errstr;
2034 } else {
2035 $errstr = "Reverse zone $revzone not present";
2036 }
2037 }
2038 return $revid if $revid;
2039} # end revID()
2040
2041
2042## DNSDB::addRDNS
2043# Adds a reverse DNS zone
2044# Takes a database handle, CIDR block, reverse DNS pattern, numeric group,
2045# and boolean(ish) state (active/inactive)
2046# Returns a status code and message
2047sub addRDNS {
2048 my $self = shift;
2049 my $dbh = $self->{dbh};
2050 my $zone = NetAddr::IP->new(shift);
2051
2052 return ('FAIL',"Zone name must be a valid CIDR netblock") unless ($zone && $zone->addr !~ /^0/);
2053 my $revpatt = shift; # construct a custom (A/AAAA+)? PTR template record
2054 my $group = shift;
2055 my $state = shift;
2056 my $defloc = shift || '';
2057
2058 $state = 1 if $state =~ /^active$/;
2059 $state = 1 if $state =~ /^on$/;
2060 $state = 0 if $state =~ /^inactive$/;
2061 $state = 0 if $state =~ /^off$/;
2062
2063 return ('FAIL',"Invalid zone status") if $state !~ /^\d+$/;
2064
2065# quick check to start to see if we've already got one
2066 my ($rdns_id) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet=?", undef, ("$zone"));
2067
2068 return ('FAIL', "Zone already exists") if $rdns_id;
2069
2070 # Allow transactions, and raise an exception on errors so we can catch it later.
2071 # Use local to make sure these get "reset" properly on exiting this block
2072 local $dbh->{AutoCommit} = 0;
2073 local $dbh->{RaiseError} = 1;
2074
2075 my $warnstr = '';
2076 my $defttl = 3600; # 1 hour should be reasonable. And unless things have gone horribly
2077 # wrong, we should have a value to override this anyway.
2078
2079 # Wrap all the SQL in a transaction
2080 eval {
2081 # insert the zone...
2082 $dbh->do("INSERT INTO revzones (revnet,group_id,status,default_location) VALUES (?,?,?,?)", undef,
2083 ($zone, $group, $state, $defloc) );
2084
2085 # get the ID...
2086 ($rdns_id) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')");
2087
2088 $self->_log(rdns_id => $rdns_id, group_id => $group,
2089 entry => "Added ".($state ? 'active' : 'inactive')." reverse zone $zone");
2090
2091 # ... and now we construct the standard records from the default set. NB: group should be variable.
2092 my $sth = $dbh->prepare("SELECT host,type,val,ttl FROM default_rev_records WHERE group_id=?");
2093 my $sth_in = $dbh->prepare("INSERT INTO records (rdns_id,domain_id,host,type,val,ttl,location)".
2094 " VALUES ($rdns_id,?,?,?,?,?,?)");
2095 $sth->execute($group);
2096 while (my ($host,$type,$val,$ttl) = $sth->fetchrow_array()) {
2097 # Silently skip v4/v6 mismatches. This is not an error, this is expected.
2098 if ($zone->{isv6}) {
2099 next if ($type == 65280 || $type == 65283);
2100 } else {
2101 next if ($type == 65281 || $type == 65284);
2102 }
2103
2104 $host =~ s/ADMINDOMAIN/$config{domain}/g;
2105
2106 # Check to make sure the IP stubs will fit in the zone. Under most usage failures here should be rare.
2107 # On failure, tack a note on to a warning string and continue without adding this record.
2108 # While we're at it, we substitute $zone for ZONE in the value.
2109 if ($val eq 'ZONE') {
2110 # If we've got a pattern, we skip the default record version on (A+)PTR-template types
2111 next if $revpatt && ($type == 65282 || $type == 65283);
2112##fixme? do we care if we have multiple whole-zone templates?
2113 $val = $zone->network;
2114 } elsif ($val =~ /ZONE/) {
2115 my $tmpval = $val;
2116 $tmpval =~ s/ZONE//;
2117 # Bend the rules and allow single-trailing-number PTR or PTR template records to be inserted
2118 # as either v4 or v6. May make this an off-by-default config flag
2119 # Note that the origin records that may trigger this **SHOULD** already have ZONE,\d
2120 if ($type == 12 || $type == 65282) {
2121 $tmpval =~ s/[,.]/::/ if ($tmpval =~ /^[,.]\d+$/ && $zone->{isv6});
2122 $tmpval =~ s/[,:]+/./ if ($tmpval =~ /^(?:,|::)\d+$/ && !$zone->{isv6});
2123 }
2124 my $addr;
2125 if ($self->_ipparent('n', 'y', \$tmpval, $rdns_id, \$addr)) {
2126 $val = $addr->addr;
2127 } else {
2128 $warnstr .= "\nDefault record '$val $typemap{$type} $host' doesn't fit in $zone, skipping";
2129 next;
2130 }
2131 }
2132
2133 # Substitute $zone for ZONE in the hostname, but only for non-NS records.
2134 # NS records get this substitution on the value instead.
2135 $host = _ZONE($zone, $host) if $type != 2;
2136
2137 # Fill in the forward domain ID if we can find it, otherwise:
2138 # Coerce type down to PTR or PTR template if we can't
2139 my $domid = 0;
2140 if ($type >= 65280) {
2141 if (!($domid = $self->_hostparent($host))) {
2142 $warnstr .= "\nRecord added as PTR instead of $typemap{$type}; domain not found for $host";
2143 $type = $reverse_typemap{PTR};
2144 $domid = 0; # just to be explicit.
2145 }
2146 }
2147
2148 $sth_in->execute($domid,$host,$type,$val,$ttl,$defloc);
2149
2150 if ($typemap{$type} eq 'SOA') {
2151 my @tmp1 = split /:/, $host;
2152 my @tmp2 = split /:/, $val;
2153 $self->_log(rdns_id => $rdns_id, group_id => $group,
2154 entry => "[new $zone] Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ".
2155 "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl");
2156 $defttl = $tmp2[3];
2157 } else {
2158 my $logentry = "[new $zone] Added record '$host $typemap{$type} $val', TTL $ttl";
2159 $logentry .= ", default location ".$self->getLoc($defloc)->{description} if $defloc;
2160 $self->_log(rdns_id => $rdns_id, domain_id => $domid, group_id => $group, entry => $logentry);
2161 }
2162 }
2163
2164 # Generate record based on provided pattern.
2165 if ($revpatt) {
2166 my $host;
2167 my $type = ($zone->{isv6} ? 65284 : 65283);
2168 my $val = $zone->network;
2169
2170 # Substitute $zone for ZONE in the hostname.
2171 $host = _ZONE($zone, $revpatt);
2172
2173 my $domid = 0;
2174 if (!($domid = $self->_hostparent($host))) {
2175 $warnstr .= "\nDefault pattern added as PTR template instead of $typemap{$type}; domain not found for $host";
2176 $type = 65282;
2177 $domid = 0; # just to be explicit.
2178 }
2179
2180 $sth_in->execute($domid,$host,$type,$val,$defttl,$defloc);
2181 my $logentry = "[new $zone] Added record '$host $typemap{$type}";
2182 $self->_log(rdns_id => $rdns_id, domain_id => $domid, group_id => $group,
2183 entry => $logentry." $val', TTL $defttl from pattern");
2184 }
2185
2186 # If there are warnings (presumably about default records skipped for cause) log them
2187 $self->_log(rdns_id => $rdns_id, group_id => $group, entry => "Warning(s) adding $zone:$warnstr")
2188 if $warnstr;
2189
2190 # once we get here, we should have suceeded.
2191 $dbh->commit;
2192 }; # end eval
2193
2194 if ($@) {
2195 my $msg = $@;
2196 eval { $dbh->rollback; };
2197 $self->_log(group_id => $group, entry => "Failed adding reverse zone $zone ($msg)")
2198 if $config{log_failures};
2199 $dbh->commit; # since we enabled transactions earlier
2200 return ('FAIL',$msg);
2201 } else {
2202 my $retcode = 'OK';
2203 if ($warnstr) {
2204 $resultstr = $warnstr;
2205 $retcode = 'WARN';
2206 }
2207 return ($retcode, $rdns_id);
2208 }
2209
2210} # end addRDNS()
2211
2212
2213## DNSDB::getZoneCount
2214# Get count of zones in group or groups
2215# Takes a database handle and hash containing:
2216# - the "current" group
2217# - an array of "acceptable" groups
2218# - a flag for forward/reverse zones
2219# - Optionally accept a "starts with" and/or "contains" filter argument
2220# Returns an integer count of the resulting zone list.
2221sub getZoneCount {
2222 my $self = shift;
2223 my $dbh = $self->{dbh};
2224
2225 my %args = @_;
2226
2227 # Fail on bad curgroup argument. There's no sane fallback on this one.
2228 if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) {
2229 $errstr = "Bad or missing curgroup argument";
2230 return;
2231 }
2232 # Fail on bad childlist argument. This could be sanely ignored if bad, maybe.
2233 if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) {
2234 $errstr = "Bad childlist argument";
2235 return;
2236 }
2237
2238 my @filterargs;
2239 $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
2240 push @filterargs, "^$args{startwith}" if $args{startwith};
2241 $args{filter} =~ s/\./\[\.\]/g if $args{filter}; # only match literal dots, usually in reverse zones
2242 push @filterargs, $args{filter} if $args{filter};
2243
2244 my $sql;
2245 # Not as compact, and fix-me-twice if the common bits get wrong, but much easier to read
2246 if ($args{revrec} eq 'n') {
2247 $sql = "SELECT count(*) FROM domains".
2248 " WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
2249 ($args{startwith} ? " AND domain ~* ?" : '').
2250 ($args{filter} ? " AND domain ~* ?" : '');
2251 } else {
2252 $sql = "SELECT count(*) FROM revzones".
2253 " WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
2254 ($args{startwith} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '').
2255 ($args{filter} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '');
2256 }
2257 my ($count) = $dbh->selectrow_array($sql, undef, @filterargs);
2258 return $count;
2259} # end getZoneCount()
2260
2261
2262## DNSDB::getZoneList()
2263# Get a list of zones in the specified group(s)
2264# Takes the same arguments as getZoneCount() above
2265# Returns a reference to an array of hashrefs suitable for feeding to HTML::Template
2266sub getZoneList {
2267 my $self = shift;
2268 my $dbh = $self->{dbh};
2269
2270 my %args = @_;
2271
2272 my @zonelist;
2273
2274 $args{sortorder} = 'ASC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC');
2275 $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
2276
2277 # Fail on bad curgroup argument. There's no sane fallback on this one.
2278 if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) {
2279 $errstr = "Bad or missing curgroup argument";
2280 return;
2281 }
2282 # Fail on bad childlist argument. This could be sanely ignored if bad, maybe.
2283 if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) {
2284 $errstr = "Bad childlist argument";
2285 return;
2286 }
2287
2288 my @filterargs;
2289 $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
2290 push @filterargs, "^$args{startwith}" if $args{startwith};
2291 $args{filter} =~ s/\./\[\.\]/g if $args{filter}; # only match literal dots, usually in reverse zones
2292 push @filterargs, $args{filter} if $args{filter};
2293
2294 my $sql;
2295 # Not as compact, and fix-me-twice if the common bits get wrong, but much easier to read
2296 if ($args{revrec} eq 'n') {
2297 $args{sortby} = 'domain' if !$args{sortby} || !grep /^$args{sortby}$/, ('domain','group','status');
2298 $sql = "SELECT domain_id,domain,status,groups.group_name AS group FROM domains".
2299 " INNER JOIN groups ON domains.group_id=groups.group_id".
2300 " WHERE domains.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
2301 ($args{startwith} ? " AND domain ~* ?" : '').
2302 ($args{filter} ? " AND domain ~* ?" : '');
2303 } else {
2304##fixme: arguably startwith here is irrelevant. depends on the UI though.
2305 $args{sortby} = 'revnet' if !$args{sortby} || !grep /^$args{sortby}$/, ('revnet','group','status');
2306 $sql = "SELECT rdns_id,revnet,status,groups.group_name AS group FROM revzones".
2307 " INNER JOIN groups ON revzones.group_id=groups.group_id".
2308 " WHERE revzones.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
2309 ($args{startwith} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '').
2310 ($args{filter} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '');
2311 }
2312 # A common tail.
2313 $sql .= " ORDER BY ".($args{sortby} eq 'group' ? 'groups.group_name' : $args{sortby})." $args{sortorder} ".
2314 ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage}".
2315 " OFFSET ".$args{offset}*$config{perpage});
2316 my $sth = $dbh->prepare($sql);
2317 $sth->execute(@filterargs);
2318 my $rownum = 0;
2319
2320 while (my @data = $sth->fetchrow_array) {
2321 my %row;
2322 $row{domain_id} = $data[0];
2323 $row{domain} = $data[1];
2324 $row{status} = $data[2];
2325 $row{group} = $data[3];
2326 push @zonelist, \%row;
2327 }
2328
2329 return \@zonelist;
2330} # end getZoneList()
2331
2332
2333## DNSDB::getZoneLocation()
2334# Retrieve the default location for a zone.
2335# Takes a database handle, forward/reverse flag, and zone ID
2336sub getZoneLocation {
2337 my $self = shift;
2338 my $dbh = $self->{dbh};
2339 my $revrec = shift;
2340 my $zoneid = shift;
2341
2342 my ($loc) = $dbh->selectrow_array("SELECT default_location FROM ".
2343 ($revrec eq 'n' ? 'domains WHERE domain_id = ?' : 'revzones WHERE rdns_id = ?'),
2344 undef, ($zoneid));
2345 return $loc;
2346} # end getZoneLocation()
2347
2348
2349## DNSDB::addGroup()
2350# Add a group
2351# Takes a database handle, group name, parent group, hashref for permissions,
2352# and optional template-vs-cloneme flag for the default records
2353# Returns a status code and message
2354sub addGroup {
2355 $errstr = '';
2356 my $self = shift;
2357 my $dbh = $self->{dbh};
2358 my $groupname = shift;
2359 my $pargroup = shift;
2360 my $permissions = shift;
2361
2362 # 0 indicates "custom", hardcoded.
2363 # Any other value clones that group's default records, if it exists.
2364 my $inherit = shift || 0;
2365##fixme: need a flag to indicate clone records or <?> ?
2366
2367 # Allow transactions, and raise an exception on errors so we can catch it later.
2368 # Use local to make sure these get "reset" properly on exiting this block
2369 local $dbh->{AutoCommit} = 0;
2370 local $dbh->{RaiseError} = 1;
2371
2372 my ($group_id) = $dbh->selectrow_array("SELECT group_id FROM groups WHERE group_name=?", undef, ($groupname));
2373
2374 return ('FAIL', "Group already exists") if $group_id;
2375
2376 # Wrap all the SQL in a transaction
2377 eval {
2378 $dbh->do("INSERT INTO groups (parent_group_id,group_name) VALUES (?,?)", undef, ($pargroup, $groupname) );
2379
2380 my ($groupid) = $dbh->selectrow_array("SELECT currval('groups_group_id_seq')");
2381
2382 # We work through the whole set of permissions instead of specifying them so
2383 # that when we add a new permission, we don't have to change the code anywhere
2384 # that doesn't explicitly deal with that specific permission.
2385 my @permvals;
2386 foreach (@permtypes) {
2387 if (!defined ($permissions->{$_})) {
2388 push @permvals, 0;
2389 } else {
2390 push @permvals, $permissions->{$_};
2391 }
2392 }
2393 $dbh->do("INSERT INTO permissions (group_id,$permlist) values (?".',?'x($#permtypes+1).")",
2394 undef, ($groupid, @permvals) );
2395 my ($permid) = $dbh->selectrow_array("SELECT currval('permissions_permission_id_seq')");
2396 $dbh->do("UPDATE groups SET permission_id=$permid WHERE group_id=$groupid");
2397
2398 # Default records
2399 my $sthf = $dbh->prepare("INSERT INTO default_records (group_id,host,type,val,distance,weight,port,ttl) ".
2400 "VALUES ($groupid,?,?,?,?,?,?,?)");
2401 my $sthr = $dbh->prepare("INSERT INTO default_rev_records (group_id,host,type,val,ttl) ".
2402 "VALUES ($groupid,?,?,?,?)");
2403 if ($inherit) {
2404 # Duplicate records from parent. Actually relying on inherited records feels
2405 # very fragile, and it would be problematic to roll over at a later time.
2406 my $sth2 = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
2407 $sth2->execute($pargroup);
2408 while (my @clonedata = $sth2->fetchrow_array) {
2409 $sthf->execute(@clonedata);
2410 }
2411 # And now the reverse records
2412 $sth2 = $dbh->prepare("SELECT host,type,val,ttl FROM default_rev_records WHERE group_id=?");
2413 $sth2->execute($pargroup);
2414 while (my @clonedata = $sth2->fetchrow_array) {
2415 $sthr->execute(@clonedata);
2416 }
2417 } else {
2418##fixme: Hardcoding is Bad, mmmmkaaaay?
2419 # reasonable basic defaults for SOA, MX, NS, and minimal hosting
2420 # could load from a config file, but somewhere along the line we need hardcoded bits.
2421 $sthf->execute('ns1.example.com:hostmaster.example.com', 6, '10800:3600:604800:10800', 0, 0, 0, 86400);
2422 $sthf->execute('DOMAIN', 1, '192.168.4.2', 0, 0, 0, 7200);
2423 $sthf->execute('DOMAIN', 15, 'mx.example.com', 10, 0, 0, 7200);
2424 $sthf->execute('DOMAIN', 2, 'ns1.example.com', 0, 0, 0, 7200);
2425 $sthf->execute('DOMAIN', 2, 'ns2.example.com', 0, 0, 0, 7200);
2426 $sthf->execute('www.DOMAIN', 5, 'DOMAIN', 0, 0, 0, 7200);
2427 # reasonable basic defaults for generic reverse zone. Same as initial SQL tabledef.
2428 $sthr->execute('hostmaster.ADMINDOMAIN:ns1.ADMINDOMAIN', 6, '10800:3600:604800:10800', 86400);
2429 $sthr->execute('unused-%r.ADMINDOMAIN', 65283, 'ZONE', 3600);
2430 }
2431
2432 $self->_log(group_id => $pargroup, entry => "Added group $groupname");
2433
2434 # once we get here, we should have suceeded.
2435 $dbh->commit;
2436 }; # end eval
2437
2438 if ($@) {
2439 my $msg = $@;
2440 eval { $dbh->rollback; };
2441 if ($config{log_failures}) {
2442 $self->_log(group_id => $pargroup, entry => "Failed to add group $groupname: $msg");
2443 $dbh->commit;
2444 }
2445 return ('FAIL',$msg);
2446 }
2447
2448 return ('OK','OK');
2449} # end addGroup()
2450
2451
2452## DNSDB::delGroup()
2453# Delete a group.
2454# Takes a group ID
2455# Returns a status code and message
2456sub delGroup {
2457 my $self = shift;
2458 my $dbh = $self->{dbh};
2459 my $groupid = shift;
2460
2461 # Allow transactions, and raise an exception on errors so we can catch it later.
2462 # Use local to make sure these get "reset" properly on exiting this block
2463 local $dbh->{AutoCommit} = 0;
2464 local $dbh->{RaiseError} = 1;
2465
2466##fixme: locate "knowable" error conditions and deal with them before the eval
2467# ... or inside, whatever.
2468# -> domains still exist in group
2469# -> ...
2470 my $failmsg = '';
2471 my $resultmsg = '';
2472
2473 # collect some pieces for logging and error messages
2474 my $groupname = $self->groupName($groupid);
2475 my $parid = $self->parentID(id => $groupid, type => 'group');
2476
2477 # Wrap all the SQL in a transaction
2478 eval {
2479 # Check for Things in the group
2480 $failmsg = "Can't remove group $groupname";
2481 my ($grpcnt) = $dbh->selectrow_array("SELECT count(*) FROM groups WHERE parent_group_id=?", undef, ($groupid));
2482 die "$grpcnt groups still in group\n" if $grpcnt;
2483 my ($domcnt) = $dbh->selectrow_array("SELECT count(*) FROM domains WHERE group_id=?", undef, ($groupid));
2484 die "$domcnt domains still in group\n" if $domcnt;
2485 my ($usercnt) = $dbh->selectrow_array("SELECT count(*) FROM users WHERE group_id=?", undef, ($groupid));
2486 die "$usercnt users still in group\n" if $usercnt;
2487
2488 $failmsg = "Failed to delete default records for $groupname";
2489 $dbh->do("DELETE from default_records WHERE group_id=?", undef, ($groupid));
2490 $failmsg = "Failed to delete default reverse records for $groupname";
2491 $dbh->do("DELETE from default_rev_records WHERE group_id=?", undef, ($groupid));
2492 $failmsg = "Failed to remove group $groupname";
2493 $dbh->do("DELETE from groups WHERE group_id=?", undef, ($groupid));
2494
2495 $self->_log(group_id => $parid, entry => "Deleted group $groupname");
2496 $resultmsg = "Deleted group $groupname";
2497
2498 # once we get here, we should have suceeded.
2499 $dbh->commit;
2500 }; # end eval
2501
2502 if ($@) {
2503 my $msg = $@;
2504 eval { $dbh->rollback; };
2505 if ($config{log_failures}) {
2506 $self->_log(group_id => $parid, entry => "$failmsg: $msg");
2507 $dbh->commit; # since we enabled transactions earlier
2508 }
2509 return ('FAIL',"$failmsg: $msg");
2510 }
2511
2512 return ('OK',$resultmsg);
2513} # end delGroup()
2514
2515
2516## DNSDB::getChildren()
2517# Get a list of all groups whose parent^n is group <n>
2518# Takes a database handle, group ID, reference to an array to put the group IDs in,
2519# and an optional flag to return only immediate children or all children-of-children
2520# default to returning all children
2521# Calls itself
2522sub getChildren {
2523 $errstr = '';
2524 my $self = shift;
2525 my $dbh = $self->{dbh};
2526 my $rootgroup = shift;
2527 my $groupdest = shift;
2528 my $immed = shift || 'all';
2529
2530 # special break for default group; otherwise we get stuck.
2531 if ($rootgroup == 1) {
2532 # by definition, group 1 is the Root Of All Groups
2533 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE NOT (group_id=1)".
2534 ($immed ne 'all' ? " AND parent_group_id=1" : '')." ORDER BY group_name");
2535 $sth->execute;
2536 while (my @this = $sth->fetchrow_array) {
2537 push @$groupdest, @this;
2538 }
2539 } else {
2540 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE parent_group_id=? ORDER BY group_name");
2541 $sth->execute($rootgroup);
2542 return if $sth->rows == 0;
2543 my @grouplist;
2544 while (my ($group) = $sth->fetchrow_array) {
2545 push @$groupdest, $group;
2546 $self->getChildren($group, $groupdest) if $immed eq 'all';
2547 }
2548 }
2549} # end getChildren()
2550
2551
2552## DNSDB::groupName()
2553# Return the group name based on a group ID
2554# Takes a database handle and the group ID
2555# Returns the group name or undef on failure
2556sub groupName {
2557 $errstr = '';
2558 my $self = shift;
2559 my $dbh = $self->{dbh};
2560 my $groupid = shift;
2561 my $sth = $dbh->prepare("SELECT group_name FROM groups WHERE group_id=?");
2562 $sth->execute($groupid);
2563 my ($groupname) = $sth->fetchrow_array();
2564 $errstr = $DBI::errstr if !$groupname;
2565 return $groupname if $groupname;
2566} # end groupName
2567
2568
2569## DNSDB::getGroupCount()
2570# Get count of subgroups in group or groups
2571# Takes a database handle and hash containing:
2572# - the "current" group
2573# - an array of "acceptable" groups
2574# - Optionally accept a "starts with" and/or "contains" filter argument
2575# Returns an integer count of the resulting group list.
2576sub getGroupCount {
2577 my $self = shift;
2578 my $dbh = $self->{dbh};
2579
2580 my %args = @_;
2581
2582 # Fail on bad curgroup argument. There's no sane fallback on this one.
2583 if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) {
2584 $errstr = "Bad or missing curgroup argument";
2585 return;
2586 }
2587 # Fail on bad childlist argument. This could be sanely ignored if bad, maybe.
2588 if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) {
2589 $errstr = "Bad childlist argument";
2590 return;
2591 }
2592
2593 my @filterargs;
2594 $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
2595 push @filterargs, "^$args{startwith}" if $args{startwith};
2596 push @filterargs, $args{filter} if $args{filter};
2597
2598 my $sql = "SELECT count(*) FROM groups ".
2599 "WHERE parent_group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
2600 ($args{startwith} ? " AND group_name ~* ?" : '').
2601 ($args{filter} ? " AND group_name ~* ?" : '');
2602 my ($count) = $dbh->selectrow_array($sql, undef, (@filterargs) );
2603 $errstr = $dbh->errstr if !$count;
2604 return $count;
2605} # end getGroupCount
2606
2607
2608## DNSDB::getGroupList()
2609# Get a list of sub^n-groups in the specified group(s)
2610# Takes the same arguments as getGroupCount() above
2611# Returns an arrayref containing hashrefs suitable for feeding straight to HTML::Template
2612sub getGroupList {
2613 my $self = shift;
2614 my $dbh = $self->{dbh};
2615
2616 my %args = @_;
2617
2618 # Fail on bad curgroup argument. There's no sane fallback on this one.
2619 if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) {
2620 $errstr = "Bad or missing curgroup argument";
2621 return;
2622 }
2623 # Fail on bad childlist argument. This could be sanely ignored if bad, maybe.
2624 if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) {
2625 $errstr = "Bad childlist argument";
2626 return;
2627 }
2628
2629 my @filterargs;
2630 $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
2631 push @filterargs, "^$args{startwith}" if $args{startwith};
2632 push @filterargs, $args{filter} if $args{filter};
2633
2634 # protection against bad or missing arguments
2635 $args{sortorder} = 'ASC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC');
2636 $args{sortby} = 'group' if !$args{sortby} || $args{sortby} !~ /^[\w_.]+$/;
2637 $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
2638
2639 # munge sortby for columns in database
2640 $args{sortby} = 'g.group_name' if $args{sortby} eq 'group';
2641 $args{sortby} = 'g2.group_name' if $args{sortby} eq 'parent';
2642
2643 my $sql = q(SELECT g.group_id AS groupid, g.group_name AS groupname, g2.group_name AS pgroup
2644 FROM groups g
2645 INNER JOIN groups g2 ON g2.group_id=g.parent_group_id
2646 ).
2647 " WHERE g.parent_group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
2648 ($args{startwith} ? " AND g.group_name ~* ?" : '').
2649 ($args{filter} ? " AND g.group_name ~* ?" : '').
2650 " GROUP BY g.group_id, g.group_name, g2.group_name ".
2651 " ORDER BY $args{sortby} $args{sortorder} ".
2652 ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage} OFFSET ".$args{offset}*$config{perpage});
2653 my $glist = $dbh->selectall_arrayref($sql, { Slice => {} }, (@filterargs) );
2654 $errstr = $dbh->errstr if !$glist;
2655
2656 # LEFT JOINs make the result set balloon beyond sanity just to include counts;
2657 # this means there's lots of crunching needed to trim the result set back down.
2658 # So instead we track the order of the groups, and push the counts into the
2659 # arrayref result separately.
2660##fixme: put this whole sub in a transaction? might be
2661# needed for accurate results on very busy systems.
2662##fixme: large group lists need prepared statements?
2663#my $ucsth = $dbh->prepare("SELECT count(*) FROM users WHERE group_id=?");
2664#my $dcsth = $dbh->prepare("SELECT count(*) FROM domains WHERE group_id=?");
2665#my $rcsth = $dbh->prepare("SELECT count(*) FROM revzones WHERE group_id=?");
2666 foreach (@{$glist}) {
2667 my ($ucnt) = $dbh->selectrow_array("SELECT count(*) FROM users WHERE group_id=?", undef, ($$_{groupid}));
2668 $$_{nusers} = $ucnt;
2669 my ($dcnt) = $dbh->selectrow_array("SELECT count(*) FROM domains WHERE group_id=?", undef, ($$_{groupid}));
2670 $$_{ndomains} = $dcnt;
2671 my ($rcnt) = $dbh->selectrow_array("SELECT count(*) FROM revzones WHERE group_id=?", undef, ($$_{groupid}));
2672 $$_{nrevzones} = $rcnt;
2673 }
2674
2675 return $glist;
2676} # end getGroupList
2677
2678
2679## DNSDB::groupID()
2680# Return the group ID based on the group name
2681# Takes a database handle and the group name
2682# Returns the group ID or undef on failure
2683sub groupID {
2684 $errstr = '';
2685 my $self = shift;
2686 my $dbh = $self->{dbh};
2687 my $group = shift;
2688 my ($grpid) = $dbh->selectrow_array("SELECT group_id FROM groups WHERE group_name=?", undef, ($group) );
2689 $errstr = $DBI::errstr if !$grpid;
2690 return $grpid if $grpid;
2691} # end groupID()
2692
2693
2694## DNSDB::addUser()
2695# Add a user.
2696# Takes a DB handle, username, group ID, password, state (active/inactive).
2697# Optionally accepts:
2698# user type (user/admin) - defaults to user
2699# permissions string - defaults to inherit from group
2700# three valid forms:
2701# i - Inherit permissions
2702# c:<user_id> - Clone permissions from <user_id>
2703# C:<permission list> - Set these specific permissions
2704# first name - defaults to username
2705# last name - defaults to blank
2706# phone - defaults to blank (could put other data within column def)
2707# Returns (OK,<uid>) on success, (FAIL,<message>) on failure
2708sub addUser {
2709 $errstr = '';
2710 my $self = shift;
2711 my $dbh = $self->{dbh};
2712 my $username = shift;
2713 my $group = shift;
2714 my $pass = shift;
2715 my $state = shift;
2716
2717 return ('FAIL', "Missing one or more required entries") if !defined($state);
2718 return ('FAIL', "Username must not be blank") if !$username;
2719
2720 # Munge in some alternate state values
2721 $state = 1 if $state =~ /^active$/;
2722 $state = 1 if $state =~ /^on$/;
2723 $state = 0 if $state =~ /^inactive$/;
2724 $state = 0 if $state =~ /^off$/;
2725
2726 my $type = shift || 'u'; # create limited users by default - fwiw, not sure yet how this will interact with ACLs
2727
2728 my $permstring = shift || 'i'; # default is to inhert permissions from group
2729
2730 my $fname = shift || $username;
2731 my $lname = shift || '';
2732 my $phone = shift || ''; # not going format-check
2733
2734 my $sth = $dbh->prepare("SELECT user_id FROM users WHERE username=?");
2735 my $user_id;
2736
2737# quick check to start to see if we've already got one
2738 $sth->execute($username);
2739 ($user_id) = $sth->fetchrow_array;
2740
2741 return ('FAIL', "User already exists") if $user_id;
2742
2743 # Allow transactions, and raise an exception on errors so we can catch it later.
2744 # Use local to make sure these get "reset" properly on exiting this block
2745 local $dbh->{AutoCommit} = 0;
2746 local $dbh->{RaiseError} = 1;
2747
2748 # Wrap all the SQL in a transaction
2749 eval {
2750 # insert the user... note we set inherited perms by default since
2751 # it's simple and cleans up some other bits of state
2752 my $sth = $dbh->prepare("INSERT INTO users ".
2753 "(group_id,username,password,firstname,lastname,phone,type,status,permission_id,inherit_perm) ".
2754 "VALUES (?,?,?,?,?,?,?,?,(SELECT permission_id FROM permissions WHERE group_id=?),'t')");
2755 $sth->execute($group,$username,unix_md5_crypt($pass),$fname,$lname,$phone,$type,$state,$group);
2756
2757 # get the ID...
2758 ($user_id) = $dbh->selectrow_array("SELECT currval('users_user_id_seq')");
2759
2760# Permissions! Gotta set'em all!
2761 die "Invalid permission string $permstring\n"
2762 if $permstring !~ /^(?:
2763 i # inherit
2764 |c:\d+ # clone
2765 # custom. no, the leading , is not a typo
2766 |C:(?:,(?:group|user|domain|record|location|self)_(?:edit|create|delete|locchg|view))*
2767 )$/x;
2768# bleh. I'd call another function to do my dirty work, but we're in the middle of a transaction already.
2769 if ($permstring ne 'i') {
2770 # for cloned or custom permissions, we have to create a new permissions entry.
2771 my $clonesrc = $group;
2772 if ($permstring =~ /^c:(\d+)/) { $clonesrc = $1; }
2773 $dbh->do("INSERT INTO permissions ($permlist,user_id) ".
2774 "SELECT $permlist,? FROM permissions WHERE permission_id=".
2775 "(SELECT permission_id FROM permissions WHERE ".($permstring =~ /^c:/ ? 'user' : 'group')."_id=?)",
2776 undef, ($user_id,$clonesrc) );
2777 $dbh->do("UPDATE users SET permission_id=".
2778 "(SELECT permission_id FROM permissions WHERE user_id=?) ".
2779 "WHERE user_id=?", undef, ($user_id, $user_id) );
2780 }
2781 if ($permstring =~ /^C:/) {
2782 # finally for custom permissions, we set the passed-in permissions (and unset
2783 # any that might have been brought in by the clone operation above)
2784 my ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions WHERE user_id=?",
2785 undef, ($user_id) );
2786 foreach (@permtypes) {
2787 if ($permstring =~ /,$_/) {
2788 $dbh->do("UPDATE permissions SET $_='t' WHERE permission_id=?", undef, ($permid) );
2789 } else {
2790 $dbh->do("UPDATE permissions SET $_='f' WHERE permission_id=?", undef, ($permid) );
2791 }
2792 }
2793 }
2794
2795 $dbh->do("UPDATE users SET inherit_perm='n' WHERE user_id=?", undef, ($user_id) );
2796
2797##fixme: add another table to hold name/email for log table?
2798
2799 $self->_log(group_id => $group, entry => "Added user $username ($fname $lname)");
2800 # once we get here, we should have suceeded.
2801 $dbh->commit;
2802 }; # end eval
2803
2804 if ($@) {
2805 my $msg = $@;
2806 eval { $dbh->rollback; };
2807 if ($config{log_failures}) {
2808 $self->_log(group_id => $group, entry => "Error adding user $username: $msg");
2809 $dbh->commit; # since we enabled transactions earlier
2810 }
2811 return ('FAIL',"Error adding user $username: $msg");
2812 }
2813
2814 return ('OK',"User $username ($fname $lname) added");
2815} # end addUser
2816
2817
2818## DNSDB::getUserCount()
2819# Get count of users in group
2820# Takes a database handle and hash containing at least the current group, and optionally:
2821# - a reference list of secondary groups
2822# - a filter string
2823# - a "Starts with" string
2824sub getUserCount {
2825 my $self = shift;
2826 my $dbh = $self->{dbh};
2827
2828 my %args = @_;
2829
2830 # Fail on bad curgroup argument. There's no sane fallback on this one.
2831 if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) {
2832 $errstr = "Bad or missing curgroup argument";
2833 return;
2834 }
2835 # Fail on bad childlist argument. This could be sanely ignored if bad, maybe.
2836 if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) {
2837 $errstr = "Bad childlist argument";
2838 return;
2839 }
2840
2841 my @filterargs;
2842 $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
2843 push @filterargs, "^$args{startwith}" if $args{startwith};
2844 push @filterargs, $args{filter} if $args{filter};
2845
2846 my $sql = "SELECT count(*) FROM users ".
2847 "WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
2848 ($args{startwith} ? " AND username ~* ?" : '').
2849 ($args{filter} ? " AND username ~* ?" : '');
2850 my ($count) = $dbh->selectrow_array($sql, undef, (@filterargs) );
2851 $errstr = $dbh->errstr if !$count;
2852 return $count;
2853} # end getUserCount()
2854
2855
2856## DNSDB::getUserList()
2857# Get list of users
2858# Takes the same arguments as getUserCount() above, plus optional:
2859# - sort field
2860# - sort order
2861# - offset/return-all-everything flag (defaults to $perpage records)
2862sub getUserList {
2863 my $self = shift;
2864 my $dbh = $self->{dbh};
2865
2866 my %args = @_;
2867
2868 # Fail on bad curgroup argument. There's no sane fallback on this one.
2869 if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) {
2870 $errstr = "Bad or missing curgroup argument";
2871 return;
2872 }
2873 # Fail on bad childlist argument. This could be sanely ignored if bad, maybe.
2874 if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) {
2875 $errstr = "Bad childlist argument";
2876 return;
2877 }
2878
2879 my @filterargs;
2880 $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
2881 push @filterargs, "^$args{startwith}" if $args{startwith};
2882 push @filterargs, $args{filter} if $args{filter};
2883
2884 # better to request sorts on "simple" names, but it means we need to map it to real columns
2885 my %sortmap = (user => 'u.username', type => 'u.type', group => 'g.group_name', status => 'u.status',
2886 fname => 'fname');
2887 $args{sortby} = $sortmap{$args{sortby}};
2888
2889 # protection against bad or missing arguments
2890 $args{sortorder} = 'ASC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC');
2891 $args{sortby} = 'u.username' if !$args{sortby} || $args{sortby} !~ /^[\w_.]+$/;
2892 $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
2893
2894 my $sql = "SELECT u.user_id, u.username, u.firstname || ' ' || u.lastname AS fname, u.type, g.group_name, u.status ".
2895 "FROM users u ".
2896 "INNER JOIN groups g ON u.group_id=g.group_id ".
2897 "WHERE u.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
2898 ($args{startwith} ? " AND u.username ~* ?" : '').
2899 ($args{filter} ? " AND u.username ~* ?" : '').
2900 " AND NOT u.type = 'R' ".
2901 " ORDER BY $args{sortby} $args{sortorder} ".
2902 ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage} OFFSET ".$args{offset}*$config{perpage});
2903 my $ulist = $dbh->selectall_arrayref($sql, { Slice => {} }, (@filterargs) );
2904 $errstr = $dbh->errstr if !$ulist;
2905 return $ulist;
2906} # end getUserList()
2907
2908
2909## DNSDB::getUserDropdown()
2910# Get a list of usernames for use in a dropdown menu.
2911# Takes a database handle, current group, and optional "tag this as selected" flag.
2912# Returns a reference to a list of hashrefs suitable to feeding to HTML::Template
2913sub getUserDropdown {
2914 my $self = shift;
2915 my $dbh = $self->{dbh};
2916 my $grp = shift;
2917 my $sel = shift || 0;
2918
2919 my $sth = $dbh->prepare("SELECT username,user_id FROM users WHERE group_id=?");
2920 $sth->execute($grp);
2921
2922 my @userlist;
2923 while (my ($username,$uid) = $sth->fetchrow_array) {
2924 my %row = (
2925 username => $username,
2926 uid => $uid,
2927 selected => ($sel == $uid ? 1 : 0)
2928 );
2929 push @userlist, \%row;
2930 }
2931 return \@userlist;
2932} # end getUserDropdown()
2933
2934
2935## DNSDB:: updateUser()
2936# Update general data about user
2937sub updateUser {
2938 my $self = shift;
2939 my $dbh = $self->{dbh};
2940
2941##fixme: tweak calling convention so that we can update any given bit of data
2942 my $uid = shift;
2943 my $username = shift;
2944 my $group = shift;
2945 my $pass = shift;
2946 my $state = shift;
2947 my $type = shift || 'u';
2948 my $fname = shift || $username;
2949 my $lname = shift || '';
2950 my $phone = shift || ''; # not going format-check
2951
2952 my $resultmsg = '';
2953
2954 # Munge in some alternate state values
2955 $state = 1 if $state =~ /^active$/;
2956 $state = 1 if $state =~ /^on$/;
2957 $state = 0 if $state =~ /^inactive$/;
2958 $state = 0 if $state =~ /^off$/;
2959
2960 # Allow transactions, and raise an exception on errors so we can catch it later.
2961 # Use local to make sure these get "reset" properly on exiting this block
2962 local $dbh->{AutoCommit} = 0;
2963 local $dbh->{RaiseError} = 1;
2964
2965 my $sth;
2966
2967 # Password can be left blank; if so we assume there's one on file.
2968 # Actual blank passwords are bad, mm'kay?
2969 if (!$pass) {
2970 ($pass) = $dbh->selectrow_array("SELECT password FROM users WHERE user_id=?", undef, ($uid));
2971 } else {
2972 $pass = unix_md5_crypt($pass);
2973 }
2974
2975 eval {
2976 $dbh->do("UPDATE users SET username=?, password=?, firstname=?, lastname=?, phone=?, type=?, status=?".
2977 " WHERE user_id=?", undef, ($username, $pass, $fname, $lname, $phone, $type, $state, $uid));
2978 $resultmsg = "Updated user info for $username ($fname $lname)";
2979 $self->_log(group_id => $group, entry => $resultmsg);
2980 $dbh->commit;
2981 };
2982 if ($@) {
2983 my $msg = $@;
2984 eval { $dbh->rollback; };
2985 if ($config{log_failures}) {
2986 $self->_log(group_id => $group, entry => "Error updating user $username: $msg");
2987 $dbh->commit; # since we enabled transactions earlier
2988 }
2989 return ('FAIL',"Error updating user $username: $msg");
2990 }
2991
2992 return ('OK',$resultmsg);
2993} # end updateUser()
2994
2995
2996## DNSDB::delUser()
2997# Delete a user.
2998# Takes a database handle and user ID
2999# Returns a success/failure code and matching message
3000sub delUser {
3001 my $self = shift;
3002 my $dbh = $self->{dbh};
3003 my $userid = shift;
3004
3005 return ('FAIL',"Bad userid") if !defined($userid);
3006
3007 my $userdata = $self->getUserData($userid);
3008
3009 # Allow transactions, and raise an exception on errors so we can catch it later.
3010 # Use local to make sure these get "reset" properly on exiting this block
3011 local $dbh->{AutoCommit} = 0;
3012 local $dbh->{RaiseError} = 1;
3013
3014 eval {
3015 $dbh->do("DELETE FROM users WHERE user_id=?", undef, ($userid));
3016 $self->_log(group_id => $userdata->{group_id},
3017 entry => "Deleted user ID $userid/".$userdata->{username}.
3018 " (".$userdata->{firstname}." ".$userdata->{lastname}.")");
3019 $dbh->commit;
3020 };
3021 if ($@) {
3022 my $msg = $@;
3023 eval { $dbh->rollback; };
3024 if ($config{log_failures}) {
3025 $self->_log(group_id => $userdata->{group_id}, entry => "Error deleting user ID ".
3026 "$userid/".$userdata->{username}.": $msg");
3027 $dbh->commit;
3028 }
3029 return ('FAIL',"Error deleting user $userid/".$userdata->{username}.": $msg");
3030 }
3031
3032 return ('OK',"Deleted user ".$userdata->{username}." (".$userdata->{firstname}." ".$userdata->{lastname}.")");
3033} # end delUser
3034
3035
3036## DNSDB::userFullName()
3037# Return a pretty string!
3038# Takes a user_id and optional printf-ish string to indicate which pieces where:
3039# %u for the username
3040# %f for the first name
3041# %l for the last name
3042# All other text in the passed string will be left as-is.
3043##fixme: need a "smart" option too, so that missing/null/blank first/last names don't give funky output
3044sub userFullName {
3045 $errstr = '';
3046 my $self = shift;
3047 my $dbh = $self->{dbh};
3048 my $userid = shift;
3049 my $fullformat = shift || '%f %l (%u)';
3050 my $sth = $dbh->prepare("select username,firstname,lastname from users where user_id=?");
3051 $sth->execute($userid);
3052 my ($uname,$fname,$lname) = $sth->fetchrow_array();
3053 $errstr = $DBI::errstr if !$uname;
3054
3055 $fullformat =~ s/\%u/$uname/g;
3056 $fullformat =~ s/\%f/$fname/g;
3057 $fullformat =~ s/\%l/$lname/g;
3058
3059 return $fullformat;
3060} # end userFullName
3061
3062
3063## DNSDB::userStatus()
3064# Sets and/or returns a user's status
3065# Takes a database handle, user ID and optionally a status argument
3066# Returns undef on errors.
3067sub userStatus {
3068 my $self = shift;
3069 my $dbh = $self->{dbh};
3070 my $id = shift;
3071 my $newstatus = shift || 'mu';
3072
3073 return undef if $id !~ /^\d+$/;
3074
3075 my $userdata = $self->getUserData($id);
3076
3077 # Allow transactions, and raise an exception on errors so we can catch it later.
3078 # Use local to make sure these get "reset" properly on exiting this block
3079 local $dbh->{AutoCommit} = 0;
3080 local $dbh->{RaiseError} = 1;
3081
3082 if ($newstatus ne 'mu') {
3083 # ooo, fun! let's see what we were passed for status
3084 eval {
3085 $newstatus = 0 if $newstatus eq 'useroff';
3086 $newstatus = 1 if $newstatus eq 'useron';
3087 $dbh->do("UPDATE users SET status=? WHERE user_id=?", undef, ($newstatus, $id));
3088
3089 $resultstr = ($newstatus ? 'Enabled' : 'Disabled')." user ".$userdata->{username}.
3090 " (".$userdata->{firstname}." ".$userdata->{lastname}.")";
3091
3092 my %loghash;
3093 $loghash{group_id} = $self->parentID(id => $id, type => 'user');
3094 $loghash{entry} = $resultstr;
3095 $self->_log(%loghash);
3096
3097 $dbh->commit;
3098 };
3099 if ($@) {
3100 my $msg = $@;
3101 eval { $dbh->rollback; };
3102 $resultstr = '';
3103 $errstr = $msg;
3104##fixme: failure logging?
3105 return;
3106 }
3107 }
3108
3109 my ($status) = $dbh->selectrow_array("SELECT status FROM users WHERE user_id=?", undef, ($id));
3110 return $status;
3111} # end userStatus()
3112
3113
3114## DNSDB::getUserData()
3115# Get misc user data for display
3116sub getUserData {
3117 my $self = shift;
3118 my $dbh = $self->{dbh};
3119 my $uid = shift;
3120
3121 my $sth = $dbh->prepare("SELECT group_id,username,firstname,lastname,phone,type,status,inherit_perm ".
3122 "FROM users WHERE user_id=?");
3123 $sth->execute($uid);
3124 return $sth->fetchrow_hashref();
3125} # end getUserData()
3126
3127
3128## DNSDB::addLoc()
3129# Add a new location.
3130# Takes a database handle, group ID, short and long description, and a comma-separated
3131# list of IP addresses.
3132# Returns ('OK',<location>) on success, ('FAIL',<failmsg>) on failure
3133sub addLoc {
3134 my $self = shift;
3135 my $dbh = $self->{dbh};
3136 my $grp = shift;
3137 my $shdesc = shift;
3138 my $comments = shift;
3139 my $iplist = shift;
3140
3141 # $shdesc gets set to the generated location ID if possible, but these can be de-undefined here.
3142 $comments = '' if !$comments;
3143 $iplist = '' if !$iplist;
3144
3145 my $loc;
3146
3147 # Generate a location ID. This is, by spec, a two-character widget. We'll use [a-z][a-z]
3148 # for now; 676 locations should satisfy all but the largest of the huge networks.
3149 # Not sure whether these are case-sensitive, or what other rules might apply - in any case
3150 # the absolute maximum is 16K (256*256) since it's parsed by tinydns as a two-character field.
3151
3152# add just after "my $origloc = $loc;":
3153# # These expand the possible space from 26^2 to 52^2 [* note in testing only 2052 were achieved],
3154# # and wrap it around.
3155# # Yes, they skip a couple of possibles. No, I don't care.
3156# $loc = 'aA' if $loc eq 'zz';
3157# $loc = 'Aa' if $loc eq 'zZ';
3158# $loc = 'ZA' if $loc eq 'Zz';
3159# $loc = 'aa' if $loc eq 'ZZ';
3160
3161 # Allow transactions, and raise an exception on errors so we can catch it later.
3162 # Use local to make sure these get "reset" properly on exiting this block
3163 local $dbh->{AutoCommit} = 0;
3164 local $dbh->{RaiseError} = 1;
3165
3166##fixme: There is probably a far better way to do this. Sequential increments
3167# are marginally less stupid that pure random generation though, and the existence
3168# check makes sure we don't stomp on an imported one.
3169
3170 eval {
3171 # Get the "last" location. Note this is the only use for loc_id, because selecting on location Does Funky Things
3172 ($loc) = $dbh->selectrow_array("SELECT location FROM locations ORDER BY loc_id DESC LIMIT 1");
3173 ($loc) = ($loc =~ /^(..)/) if $loc;
3174 my $origloc = $loc;
3175 $loc = 'aa' if !$loc;
3176 # Make a change...
3177 $loc++;
3178 # ... and keep changing if it exists
3179 while ($dbh->selectrow_array("SELECT count(*) FROM locations WHERE location LIKE ?", undef, ($loc.'%'))) {
3180 $loc++;
3181 ($loc) = ($loc =~ /^(..)/);
3182 die "too many locations in use, can't add another one\n" if $loc eq $origloc;
3183##fixme: really need to handle this case faster somehow
3184#if $loc eq $origloc die "<thwap> bad admin: all locations used, your network is too fragmented";
3185 }
3186 # And now we should have a unique location. tinydns fundamentally limits the
3187 # number of these but there's no doc on what characters are valid.
3188 $shdesc = $loc if !$shdesc;
3189 $dbh->do("INSERT INTO locations (location, group_id, iplist, description, comments) VALUES (?,?,?,?,?)",
3190 undef, ($loc, $grp, $iplist, $shdesc, $comments) );
3191 $self->_log(entry => "Added location ($shdesc, '$iplist')");
3192 $dbh->commit;
3193 };
3194 if ($@) {
3195 my $msg = $@;
3196 eval { $dbh->rollback; };
3197 if ($config{log_failures}) {
3198 $shdesc = $loc if !$shdesc;
3199 $self->_log(entry => "Failed adding location ($shdesc, '$iplist'): $msg");
3200 $dbh->commit;
3201 }
3202 return ('FAIL',$msg);
3203 }
3204
3205 return ('OK',$loc);
3206} # end addLoc()
3207
3208
3209## DNSDB::updateLoc()
3210# Update details of a location.
3211# Takes a database handle, location ID, group ID, short description,
3212# long comments/notes, and comma/space-separated IP list
3213# Returns a result code and message
3214sub updateLoc {
3215 my $self = shift;
3216 my $dbh = $self->{dbh};
3217 my $loc = shift;
3218 my $grp = shift;
3219 my $shdesc = shift;
3220 my $comments = shift;
3221 my $iplist = shift;
3222
3223 $shdesc = '' if !$shdesc;
3224 $comments = '' if !$comments;
3225 $iplist = '' if !$iplist;
3226
3227 # Allow transactions, and raise an exception on errors so we can catch it later.
3228 # Use local to make sure these get "reset" properly on exiting this block
3229 local $dbh->{AutoCommit} = 0;
3230 local $dbh->{RaiseError} = 1;
3231
3232 my $oldloc = $self->getLoc($loc);
3233 my $okmsg = "Updated location (".$oldloc->{description}.", '".$oldloc->{iplist}."') to ($shdesc, '$iplist')";
3234
3235 eval {
3236 $dbh->do("UPDATE locations SET group_id=?,iplist=?,description=?,comments=? WHERE location=?",
3237 undef, ($grp, $iplist, $shdesc, $comments, $loc) );
3238 $self->_log(entry => $okmsg);
3239 $dbh->commit;
3240 };
3241 if ($@) {
3242 my $msg = $@;
3243 eval { $dbh->rollback; };
3244 if ($config{log_failures}) {
3245 $shdesc = $loc if !$shdesc;
3246 $self->_log(entry => "Failed updating location ($shdesc, '$iplist'): $msg");
3247 $dbh->commit;
3248 }
3249 return ('FAIL',$msg);
3250 }
3251
3252 return ('OK',$okmsg);
3253} # end updateLoc()
3254
3255
3256## DNSDB::delLoc()
3257sub delLoc {
3258 my $self = shift;
3259 my $dbh = $self->{dbh};
3260 my $loc = shift;
3261
3262 # Allow transactions, and raise an exception on errors so we can catch it later.
3263 # Use local to make sure these get "reset" properly on exiting this block
3264 local $dbh->{AutoCommit} = 0;
3265 local $dbh->{RaiseError} = 1;
3266
3267 my $oldloc = $self->getLoc($loc);
3268 my $olddesc = ($oldloc->{description} ? $oldloc->{description} : $loc);
3269 my $okmsg = "Deleted location ($olddesc, '".$oldloc->{iplist}."')";
3270
3271 eval {
3272 # Check for records with this location first. Deleting a location without deleting records
3273 # tagged for that location will render them unpublished without other warning.
3274 my ($r) = $dbh->selectrow_array("SELECT record_id FROM records WHERE location=? LIMIT 1", undef, ($loc) );
3275 die "Records still exist in location $olddesc\n" if $r;
3276 $dbh->do("DELETE FROM locations WHERE location=?", undef, ($loc) );
3277 $self->_log(entry => $okmsg);
3278 $dbh->commit;
3279 };
3280 if ($@) {
3281 my $msg = $@;
3282 eval { $dbh->rollback; };
3283 if ($config{log_failures}) {
3284 $self->_log(entry => "Failed to delete location ($olddesc, '$oldloc->{iplist}'): $msg");
3285 $dbh->commit;
3286 }
3287 return ('FAIL', "Failed to delete location ($olddesc, '$oldloc->{iplist}'): $msg");
3288 }
3289
3290 return ('OK',$okmsg);
3291} # end delLoc()
3292
3293
3294## DNSDB::getLoc()
3295# Get details about a location/view
3296# Takes a database handle and location ID.
3297# Returns a reference to a hash containing the group ID, IP list, description, and comments/notes
3298sub getLoc {
3299 my $self = shift;
3300 my $dbh = $self->{dbh};
3301 my $loc = shift;
3302
3303 my $sth = $dbh->prepare("SELECT group_id,iplist,description,comments FROM locations WHERE location=?");
3304 $sth->execute($loc);
3305 return $sth->fetchrow_hashref();
3306} # end getLoc()
3307
3308
3309## DNSDB::getLocCount()
3310# Get count of locations/views
3311# Takes a database handle and hash containing at least the current group, and optionally:
3312# - a reference list of secondary groups
3313# - a filter string
3314# - a "Starts with" string
3315sub getLocCount {
3316 my $self = shift;
3317 my $dbh = $self->{dbh};
3318
3319 my %args = @_;
3320
3321 # Fail on bad curgroup argument. There's no sane fallback on this one.
3322 if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) {
3323 $errstr = "Bad or missing curgroup argument";
3324 return;
3325 }
3326 # Fail on bad childlist argument. This could be sanely ignored if bad, maybe.
3327 if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) {
3328 $errstr = "Bad childlist argument";
3329 return;
3330 }
3331
3332 my @filterargs;
3333 $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
3334 push @filterargs, "^$args{startwith}" if $args{startwith};
3335 push @filterargs, $args{filter} if $args{filter};
3336
3337 my $sql = "SELECT count(*) FROM locations ".
3338 "WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
3339 ($args{startwith} ? " AND description ~* ?" : '').
3340 ($args{filter} ? " AND description ~* ?" : '');
3341 my ($count) = $dbh->selectrow_array($sql, undef, (@filterargs) );
3342 $errstr = $dbh->errstr if !$count;
3343 return $count;
3344} # end getLocCount()
3345
3346
3347## DNSDB::getLocList()
3348sub getLocList {
3349 my $self = shift;
3350 my $dbh = $self->{dbh};
3351
3352 my %args = @_;
3353
3354 # Fail on bad curgroup argument. There's no sane fallback on this one.
3355 if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) {
3356 $errstr = "Bad or missing curgroup argument";
3357 return;
3358 }
3359 # Fail on bad childlist argument. This could be sanely ignored if bad, maybe.
3360 if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) {
3361 $errstr = "Bad childlist argument";
3362 return;
3363 }
3364
3365 my @filterargs;
3366 $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
3367 push @filterargs, "^$args{startwith}" if $args{startwith};
3368 push @filterargs, $args{filter} if $args{filter};
3369
3370 # better to request sorts on "simple" names, but it means we need to map it to real columns
3371# my %sortmap = (user => 'u.username', type => 'u.type', group => 'g.group_name', status => 'u.status',
3372# fname => 'fname');
3373# $args{sortby} = $sortmap{$args{sortby}};
3374
3375 # protection against bad or missing arguments
3376 $args{sortorder} = 'ASC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC');
3377 $args{sortby} = 'l.description' if !$args{sortby} || $args{sortby} !~ /^[\w_.]+$/;
3378 $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
3379
3380 my $sql = "SELECT l.location, l.description, l.iplist, g.group_name ".
3381 "FROM locations l ".
3382 "INNER JOIN groups g ON l.group_id=g.group_id ".
3383 "WHERE l.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
3384 ($args{startwith} ? " AND l.description ~* ?" : '').
3385 ($args{filter} ? " AND l.description ~* ?" : '').
3386 " ORDER BY $args{sortby} $args{sortorder} ".
3387 ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage} OFFSET ".$args{offset}*$config{perpage});
3388 my $ulist = $dbh->selectall_arrayref($sql, { Slice => {} }, (@filterargs) );
3389 $errstr = $dbh->errstr if !$ulist;
3390 return $ulist;
3391} # end getLocList()
3392
3393
3394## DNSDB::getLocDropdown()
3395# Get a list of location names for use in a dropdown menu.
3396# Takes a database handle, current group, and optional "tag this as selected" flag.
3397# Returns a reference to a list of hashrefs suitable to feeding to HTML::Template
3398sub getLocDropdown {
3399 my $self = shift;
3400 my $dbh = $self->{dbh};
3401 my $grp = shift;
3402 my $sel = shift || '';
3403
3404 my $sth = $dbh->prepare(qq(
3405 SELECT description,location FROM locations
3406 WHERE group_id=?
3407 ORDER BY description
3408 ) );
3409 $sth->execute($grp);
3410
3411 my @loclist;
3412 push @loclist, { locname => "(Default/All)", loc => '', selected => ($sel ? 0 : ($sel eq '' ? 1 : 0)) };
3413 while (my ($locname, $loc) = $sth->fetchrow_array) {
3414 my %row = (
3415 locname => $locname,
3416 loc => $loc,
3417 selected => ($sel eq $loc ? 1 : 0)
3418 );
3419 push @loclist, \%row;
3420 }
3421 return \@loclist;
3422} # end getLocDropdown()
3423
3424
3425## DNSDB::getSOA()
3426# Return all suitable fields from an SOA record in separate elements of a hash
3427# Takes a database handle, default/live flag, domain/reverse flag, and parent ID
3428sub getSOA {
3429 $errstr = '';
3430 my $self = shift;
3431 my $dbh = $self->{dbh};
3432 my $def = shift;
3433 my $rev = shift;
3434 my $id = shift;
3435
3436 # (ab)use distance and weight columns to store SOA data? can't for default_rev_records...
3437 # - should really attach serial to the zone parent somewhere
3438
3439 my $sql = "SELECT record_id,host,val,ttl from "._rectable($def,$rev).
3440 " WHERE "._recparent($def,$rev)." = ? AND type=$reverse_typemap{SOA}";
3441 my $ret = $dbh->selectrow_hashref($sql, undef, ($id) );
3442 return if !$ret;
3443##fixme: stick a flag somewhere if the record doesn't exist. by the API, this is an impossible case, but...
3444
3445 ($ret->{contact},$ret->{prins}) = split /:/, $ret->{host};
3446 delete $ret->{host};
3447 ($ret->{refresh},$ret->{retry},$ret->{expire},$ret->{minttl}) = split /:/, $ret->{val};
3448 delete $ret->{val};
3449
3450 return $ret;
3451} # end getSOA()
3452
3453
3454## DNSDB::updateSOA()
3455# Update the specified SOA record
3456# Takes a database handle, default/live flag, forward/reverse flag, and SOA data hash
3457# Returns a two-element list with a result code and message
3458sub updateSOA {
3459 my $self = shift;
3460 my $dbh = $self->{dbh};
3461 my $defrec = shift;
3462 my $revrec = shift;
3463
3464 my %soa = @_;
3465
3466 my $oldsoa = $self->getSOA($defrec, $revrec, $soa{id});
3467
3468 my $msg;
3469 my %logdata;
3470 if ($defrec eq 'n') {
3471 $logdata{domain_id} = $soa{id} if $revrec eq 'n';
3472 $logdata{rdns_id} = $soa{id} if $revrec eq 'y';
3473 $logdata{group_id} = $self->parentID(id => $soa{id}, revrec => $revrec,
3474 type => ($revrec eq 'n' ? 'domain' : 'revzone') );
3475 } else {
3476 $logdata{group_id} = $soa{id};
3477 }
3478 my $parname = ($defrec eq 'y' ? $self->groupName($soa{id}) :
3479 ($revrec eq 'n' ? $self->domainName($soa{id}) : $self->revName($soa{id})) );
3480
3481 # Allow transactions, and raise an exception on errors so we can catch it later.
3482 # Use local to make sure these get "reset" properly on exiting this block
3483 local $dbh->{AutoCommit} = 0;
3484 local $dbh->{RaiseError} = 1;
3485
3486 eval {
3487 my $sql = "UPDATE "._rectable($defrec, $revrec)." SET host=?, val=?, ttl=? WHERE record_id=? AND type=6";
3488 $dbh->do($sql, undef, ("$soa{contact}:$soa{prins}", "$soa{refresh}:$soa{retry}:$soa{expire}:$soa{minttl}",
3489 $soa{ttl}, $oldsoa->{record_id}) );
3490 $msg = "Updated ".($defrec eq 'y' ? ($revrec eq 'y' ? 'default reverse ' : 'default ') : '').
3491 "SOA for $parname: ".
3492 "(ns $oldsoa->{prins}, contact $oldsoa->{contact}, refresh $oldsoa->{refresh},".
3493 " retry $oldsoa->{retry}, expire $oldsoa->{expire}, minTTL $oldsoa->{minttl}, TTL $oldsoa->{ttl}) to ".
3494 "(ns $soa{prins}, contact $soa{contact}, refresh $soa{refresh},".
3495 " retry $soa{retry}, expire $soa{expire}, minTTL $soa{minttl}, TTL $soa{ttl})";
3496
3497 $logdata{entry} = $msg;
3498 $self->_log(%logdata);
3499
3500 $dbh->commit;
3501 };
3502 if ($@) {
3503 $msg = $@;
3504 eval { $dbh->rollback; };
3505 $logdata{entry} = "Error updating ".($defrec eq 'y' ? ($revrec eq 'y' ? 'default reverse zone ' : 'default ') : '').
3506 "SOA record for $parname: $msg";
3507 if ($config{log_failures}) {
3508 $self->_log(%logdata);
3509 $dbh->commit;
3510 }
3511 return ('FAIL', $logdata{entry});
3512 } else {
3513 return ('OK', $msg);
3514 }
3515} # end updateSOA()
3516
3517
3518## DNSDB::getRecLine()
3519# Return all data fields for a zone record in separate elements of a hash
3520# Takes a database handle, default/live flag, forward/reverse flag, and record ID
3521sub getRecLine {
3522 $errstr = '';
3523 my $self = shift;
3524 my $dbh = $self->{dbh};
3525 my $defrec = shift;
3526 my $revrec = shift;
3527 my $id = shift;
3528
3529 my $sql = "SELECT record_id,host,type,val,ttl".
3530 ($defrec eq 'n' ? ',location' : '').
3531 ($revrec eq 'n' ? ',distance,weight,port' : '').
3532 (($defrec eq 'y') ? ',group_id FROM ' : ',domain_id,rdns_id FROM ').
3533 _rectable($defrec,$revrec)." WHERE record_id=?";
3534 my $ret = $dbh->selectrow_hashref($sql, undef, ($id) );
3535
3536 if ($dbh->err) {
3537 $errstr = $DBI::errstr;
3538 return undef;
3539 }
3540
3541 if (!$ret) {
3542 $errstr = "No such record";
3543 return undef;
3544 }
3545
3546 # explicitly set a parent id
3547 if ($defrec eq 'y') {
3548 $ret->{parid} = $ret->{group_id};
3549 } else {
3550 $ret->{parid} = (($revrec eq 'n') ? $ret->{domain_id} : $ret->{rdns_id});
3551 # and a secondary if we have a custom type that lives in both a forward and reverse zone
3552 $ret->{secid} = (($revrec eq 'y') ? $ret->{domain_id} : $ret->{rdns_id}) if $ret->{type} > 65279;
3553 }
3554 $ret->{address} = $ret->{val}; # because.
3555
3556 return $ret;
3557}
3558
3559
3560##fixme: should use above (getRecLine()) to get lines for below?
3561## DNSDB::getRecList()
3562# Return records for a group or zone
3563# Takes a default/live flag, group or zone ID, start,
3564# number of records, sort field, and sort order
3565# Returns a reference to an array of hashes
3566sub getRecList {
3567 $errstr = '';
3568 my $self = shift;
3569 my $dbh = $self->{dbh};
3570
3571 my %args = @_;
3572
3573 my @filterargs;
3574
3575 push @filterargs, $args{filter} if $args{filter};
3576
3577 # protection against bad or missing arguments
3578 $args{sortorder} = 'ASC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC');
3579 my $defsort = 'host' if $args{revrec} eq 'n'; # default sort by host on domain record list
3580 my $defsort = 'val' if $args{revrec} eq 'y'; # default sort by IP on revzone record list
3581 $args{sortby} = $defsort if !$args{revrec};
3582 $args{sortby} = $defsort if $args{sortby} !~ /^[\w_.]+$/;
3583 $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
3584 my $perpage = ($args{nrecs} ? $args{nrecs} : $config{perpage});
3585
3586 # sort reverse zones on IP, correctly
3587 # do other fiddling with $args{sortby} while we're at it.
3588 # whee! multisort means just passing comma-separated fields in sortby!
3589 my $newsort = '';
3590 foreach my $sf (split /,/, $args{sortby}) {
3591 $sf = "r.$sf";
3592 $sf =~ s/r\.val/CAST (r.val AS inet)/
3593 if $args{revrec} eq 'y' && $args{defrec} eq 'n';
3594 $sf =~ s/r\.type/t.alphaorder/;
3595 $newsort .= ",$sf";
3596 }
3597 $newsort =~ s/^,//;
3598
3599 my $sql = "SELECT r.record_id,r.host,r.type,r.val,r.ttl";
3600 $sql .= ",l.description AS locname" if $args{defrec} eq 'n';
3601 $sql .= ",r.distance,r.weight,r.port" if $args{revrec} eq 'n';
3602 $sql .= " FROM "._rectable($args{defrec},$args{revrec})." r ";
3603 $sql .= "INNER JOIN rectypes t ON r.type=t.val "; # for sorting by type alphabetically
3604 $sql .= "LEFT JOIN locations l ON r.location=l.location " if $args{defrec} eq 'n';
3605 $sql .= "WHERE "._recparent($args{defrec},$args{revrec})." = ?";
3606 $sql .= " AND NOT r.type=$reverse_typemap{SOA}";
3607 $sql .= " AND (r.host ~* ? OR r.val ~* ?)" if $args{filter};
3608 $sql .= " ORDER BY $newsort $args{sortorder}";
3609 # ensure consistent ordering by sorting on record_id too
3610 $sql .= ", record_id $args{sortorder}";
3611 $sql .= ($args{offset} eq 'all' ? '' : " LIMIT $perpage OFFSET ".$args{offset}*$perpage);
3612
3613 my @bindvars = ($args{id});
3614 push @bindvars, ($args{filter},$args{filter}) if $args{filter};
3615
3616 my $ret = $dbh->selectall_arrayref($sql, { Slice => {} }, (@bindvars) );
3617 $errstr = "Error retrieving records: ".$dbh->errstr if !$ret;
3618 return $ret;
3619} # end getRecList()
3620
3621
3622## DNSDB::getRecCount()
3623# Return count of non-SOA records in zone (or default records in a group)
3624# Takes a database handle, default/live flag, reverse/forward flag, group/domain ID,
3625# and optional filtering modifier
3626# Returns the count
3627sub getRecCount {
3628 my $self = shift;
3629 my $dbh = $self->{dbh};
3630 my $defrec = shift;
3631 my $revrec = shift;
3632 my $id = shift;
3633 my $filter = shift || '';
3634
3635 # keep the nasties down, since we can't ?-sub this bit. :/
3636 # note this is chars allowed in DNS hostnames
3637 $filter =~ s/[^a-zA-Z0-9_.:-]//g;
3638
3639 my @bindvars = ($id);
3640 push @bindvars, $filter if $filter;
3641 my $sql = "SELECT count(*) FROM ".
3642 _rectable($defrec,$revrec).
3643 " WHERE "._recparent($defrec,$revrec)."=? ".
3644 "AND NOT type=$reverse_typemap{SOA}".
3645 ($filter ? " AND host ~* ?" : '');
3646 my ($count) = $dbh->selectrow_array($sql, undef, (@bindvars) );
3647
3648 return $count;
3649
3650} # end getRecCount()
3651
3652
3653## DNSDB::addRec()
3654# Add a new record to a domain or a group's default records
3655# Takes a database handle, default/live flag, group/domain ID,
3656# host, type, value, and TTL
3657# Some types require additional detail: "distance" for MX and SRV,
3658# and weight/port for SRV
3659# Returns a status code and detail message in case of error
3660##fixme: pass a hash with the record data, not a series of separate values
3661sub addRec {
3662 $errstr = '';
3663 my $self = shift;
3664 my $dbh = $self->{dbh};
3665 my $defrec = shift;
3666 my $revrec = shift;
3667 my $id = shift; # parent (group_id for defrecs, rdns_id for reverse records,
3668 # domain_id for domain records)
3669
3670 my $host = shift;
3671 my $rectype = shift; # reference so we can coerce it if "+"-types can't find both zones
3672 my $val = shift;
3673 my $ttl = shift;
3674 my $location = shift;
3675 $location = '' if !$location;
3676
3677 # Spaces are evil.
3678 $$host =~ s/^\s+//;
3679 $$host =~ s/\s+$//;
3680 if ($typemap{$$rectype} ne 'TXT') {
3681 # Leading or trailng spaces could be legit in TXT records.
3682 $$val =~ s/^\s+//;
3683 $$val =~ s/\s+$//;
3684 }
3685
3686 # prep for validation
3687 my $addr = NetAddr::IP->new($$val);
3688 $$host =~ s/\.+$//; # FQDNs ending in . are an internal detail, and really shouldn't be exposed in the UI.
3689
3690 my $domid = 0;
3691 my $revid = 0;
3692
3693 my $retcode = 'OK'; # assume everything will go OK
3694 my $retmsg = '';
3695
3696 # do simple validation first
3697 return ('FAIL', "TTL must be numeric") unless $ttl =~ /^\d+$/;
3698
3699 # Quick check on hostname parts. Note the regex is more forgiving than the error message;
3700 # domain names technically are case-insensitive, and we use printf-like % codes for a couple
3701 # of types. Other things may also be added to validate default records of several flavours.
3702 return ('FAIL', "Hostnames may not contain anything other than (0-9 a-z . _)")
3703 if $defrec eq 'n' && ($revrec eq 'y' ? $$rectype != $reverse_typemap{TXT} : 1) &&
3704 $$host !~ /^[0-9a-z_%.-]+$/i;
3705
3706 # Collect these even if we're only doing a simple A record so we can call *any* validation sub
3707 my $dist = shift;
3708 my $weight = shift;
3709 my $port = shift;
3710
3711 my $fields;
3712 my @vallist;
3713
3714 # Call the validation sub for the type requested.
3715 ($retcode,$retmsg) = $validators{$$rectype}($self, defrec => $defrec, revrec => $revrec, id => $id,
3716 host => $host, rectype => $rectype, val => $val, addr => $addr,
3717 dist => \$dist, port => \$port, weight => \$weight,
3718 fields => \$fields, vallist => \@vallist);
3719
3720 return ($retcode,$retmsg) if $retcode eq 'FAIL';
3721
3722 # Set up database fields and bind parameters
3723 $fields .= "host,type,val,ttl,"._recparent($defrec,$revrec);
3724 push @vallist, ($$host,$$rectype,$$val,$ttl,$id);
3725
3726 # locations are not for default records, silly coder!
3727 if ($defrec eq 'n') {
3728 $fields .= ",location";
3729 push @vallist, $location;
3730 }
3731 my $vallen = '?'.(',?'x$#vallist);
3732
3733 # Put together the success log entry. We have to use this horrible kludge
3734 # because domain_id and rdns_id may or may not be present, and if they are,
3735 # they're not at a guaranteed consistent index in the array. wheee!
3736 my %logdata;
3737 my @ftmp = split /,/, $fields;
3738 for (my $i=0; $i <= $#vallist; $i++) {
3739 $logdata{domain_id} = $vallist[$i] if $ftmp[$i] eq 'domain_id';
3740 $logdata{rdns_id} = $vallist[$i] if $ftmp[$i] eq 'rdns_id';
3741 }
3742 $logdata{group_id} = $id if $defrec eq 'y';
3743 $logdata{group_id} = $self->parentID(id => $id, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec)
3744 if $defrec eq 'n';
3745 $logdata{entry} = "Added ".($defrec eq 'y' ? 'default record' : 'record');
3746 # NS records for revzones get special treatment
3747 if ($revrec eq 'y' && $$rectype == 2) {
3748 $logdata{entry} .= " '$$val $typemap{$$rectype} $$host";
3749 } else {
3750 $logdata{entry} .= " '$$host $typemap{$$rectype} $$val";
3751 }
3752
3753 $logdata{entry} .= " [distance $dist]" if $typemap{$$rectype} eq 'MX';
3754 $logdata{entry} .= " [priority $dist] [weight $weight] [port $port]"
3755 if $typemap{$$rectype} eq 'SRV';
3756 $logdata{entry} .= "', TTL $ttl";
3757 $logdata{entry} .= ", location ".$self->getLoc($location)->{description} if $location;
3758
3759 # Allow transactions, and raise an exception on errors so we can catch it later.
3760 # Use local to make sure these get "reset" properly on exiting this block
3761 local $dbh->{AutoCommit} = 0;
3762 local $dbh->{RaiseError} = 1;
3763
3764 eval {
3765 $dbh->do("INSERT INTO "._rectable($defrec, $revrec)." ($fields) VALUES ($vallen)",
3766 undef, @vallist);
3767 $self->_log(%logdata);
3768 $dbh->commit;
3769 };
3770 if ($@) {
3771 my $msg = $@;
3772 eval { $dbh->rollback; };
3773 if ($config{log_failures}) {
3774 $logdata{entry} = "Failed adding ".($defrec eq 'y' ? 'default ' : '').
3775 "record '$$host $typemap{$$rectype} $$val', TTL $ttl ($msg)";
3776 $self->_log(%logdata);
3777 $dbh->commit;
3778 }
3779 return ('FAIL',$msg);
3780 }
3781
3782 $resultstr = $logdata{entry};
3783 return ($retcode, $retmsg);
3784
3785} # end addRec()
3786
3787
3788## DNSDB::updateRec()
3789# Update a record
3790# Takes a database handle, default and reverse flags, record ID, immediate parent ID, and new record data.
3791# Returns a status code and message
3792sub updateRec {
3793 $errstr = '';
3794
3795 my $self = shift;
3796 my $dbh = $self->{dbh};
3797 my $defrec = shift;
3798 my $revrec = shift;
3799 my $id = shift;
3800 my $parid = shift; # immediate parent entity that we're descending from to update the record
3801
3802 # all records have these
3803 my $host = shift;
3804 my $hostbk = $$host; # Keep a backup copy of the original, so we can WARN if the update mangles the domain
3805 my $rectype = shift;
3806 my $val = shift;
3807 my $ttl = shift;
3808 my $location = shift; # may be empty/null/undef depending on caller
3809 $location = '' if !$location;
3810
3811 # Spaces are evil.
3812 $$host =~ s/^\s+//;
3813 $$host =~ s/\s+$//;
3814 if ($typemap{$$rectype} ne 'TXT') {
3815 # Leading or trailng spaces could be legit in TXT records.
3816 $$val =~ s/^\s+//;
3817 $$val =~ s/\s+$//;
3818 }
3819
3820 # prep for validation
3821 my $addr = NetAddr::IP->new($$val);
3822 $$host =~ s/\.+$//; # FQDNs ending in . are an internal detail, and really shouldn't be exposed in the UI.
3823
3824 my $domid = 0;
3825 my $revid = 0;
3826
3827 my $retcode = 'OK'; # assume everything will go OK
3828 my $retmsg = '';
3829
3830 # do simple validation first
3831 return ('FAIL', "TTL must be numeric") unless $ttl =~ /^\d+$/;
3832
3833 # Quick check on hostname parts. Note the regex is more forgiving than the error message;
3834 # domain names technically are case-insensitive, and we use printf-like % codes for a couple
3835 # of types. Other things may also be added to validate default records of several flavours.
3836 return ('FAIL', "Hostnames may not contain anything other than (0-9 a-z - . _)")
3837 if $defrec eq 'n' && ($revrec eq 'y' ? $$rectype != $reverse_typemap{TXT} : 1) &&
3838 $$host !~ /^[0-9a-z_%.-]+$/i;
3839
3840 # only MX and SRV will use these
3841 my $dist = shift || 0;
3842 my $weight = shift || 0;
3843 my $port = shift || 0;
3844
3845 my $fields;
3846 my @vallist;
3847
3848 # get old record data so we have the right parent ID
3849 # and for logging (eventually)
3850 my $oldrec = $self->getRecLine($defrec, $revrec, $id);
3851
3852 # Call the validation sub for the type requested.
3853 # Note the ID to pass here is the *parent*, not the record
3854 ($retcode,$retmsg) = $validators{$$rectype}($self, defrec => $defrec, revrec => $revrec,
3855 id => ($defrec eq 'y' ? $oldrec->{group_id} : ($revrec eq 'n' ? $oldrec->{domain_id} : $oldrec->{rdns_id})),
3856 host => $host, rectype => $rectype, val => $val, addr => $addr,
3857 dist => \$dist, port => \$port, weight => \$weight,
3858 fields => \$fields, vallist => \@vallist,
3859 update => $id);
3860
3861 return ($retcode,$retmsg) if $retcode eq 'FAIL';
3862
3863 # Set up database fields and bind parameters. Note only the optional fields
3864 # (distance, weight, port, secondary parent ID) are added in the validation call above
3865 $fields .= "host,type,val,ttl,"._recparent($defrec,$revrec);
3866 push @vallist, ($$host,$$rectype,$$val,$ttl,
3867 ($defrec eq 'y' ? $oldrec->{group_id} : ($revrec eq 'n' ? $oldrec->{domain_id} : $oldrec->{rdns_id})) );
3868
3869 # locations are not for default records, silly coder!
3870 if ($defrec eq 'n') {
3871 $fields .= ",location";
3872 push @vallist, $location;
3873 }
3874
3875 # hack hack PTHUI
3876 # need to forcibly make sure we disassociate a record with a parent it's no longer related to.
3877 # eg, PTR records may not have a domain parent, or A/AAAA records may not have a revzone parent.
3878 # mainly needed for crossover types that got coerced down to "standard" types
3879 if ($defrec eq 'n') {
3880 if ($$rectype == $reverse_typemap{PTR}) {
3881 $fields .= ",domain_id";
3882 push @vallist, 0;
3883 }
3884 if ($$rectype == $reverse_typemap{A} || $$rectype == $reverse_typemap{AAAA}) {
3885 $fields .= ",rdns_id";
3886 push @vallist, 0;
3887 }
3888 }
3889 # fix fat-finger-originated record type changes
3890 if ($$rectype == 65285) {
3891 $fields .= ",rdns_id" if $revrec eq 'n';
3892 $fields .= ",domain_id" if $revrec eq 'y';
3893 push @vallist, 0;
3894 }
3895 if ($defrec eq 'n') {
3896 $domid = $parid if $revrec eq 'n';
3897 $revid = $parid if $revrec eq 'y';
3898 }
3899
3900 # Put together the success log entry. Horrible kludge from addRec() copied as-is since
3901 # we don't know whether the passed arguments or retrieved values for domain_id and rdns_id
3902 # will be maintained (due to "not-in-zone" validation changes)
3903 my %logdata;
3904 $logdata{domain_id} = $domid;
3905 $logdata{rdns_id} = $revid;
3906 my @ftmp = split /,/, $fields;
3907 for (my $i=0; $i <= $#vallist; $i++) {
3908 $logdata{domain_id} = $vallist[$i] if $ftmp[$i] eq 'domain_id';
3909 $logdata{rdns_id} = $vallist[$i] if $ftmp[$i] eq 'rdns_id';
3910 }
3911 $logdata{group_id} = $parid if $defrec eq 'y';
3912 $logdata{group_id} = $self->parentID(id => $parid, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec)
3913 if $defrec eq 'n';
3914 $logdata{entry} = "Updated ".($defrec eq 'y' ? 'default record' : 'record')." from\n";
3915 # NS records for revzones get special treatment
3916 if ($revrec eq 'y' && $$rectype == 2) {
3917 $logdata{entry} .= " '$oldrec->{val} $typemap{$oldrec->{type}} $oldrec->{host}";
3918 } else {
3919 $logdata{entry} .= " '$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}";
3920 }
3921 $logdata{entry} .= " [distance $oldrec->{distance}]" if $typemap{$oldrec->{type}} eq 'MX';
3922 $logdata{entry} .= " [priority $oldrec->{distance}] [weight $oldrec->{weight}] [port $oldrec->{port}]"
3923 if $typemap{$oldrec->{type}} eq 'SRV';
3924 $logdata{entry} .= "', TTL $oldrec->{ttl}";
3925 $logdata{entry} .= ", location ".$self->getLoc($oldrec->{location})->{description} if $oldrec->{location};
3926 $logdata{entry} .= "\nto\n";
3927 # More NS special
3928 if ($revrec eq 'y' && $$rectype == 2) {
3929 $logdata{entry} .= "'$$val $typemap{$$rectype} $$host";
3930 } else {
3931 $logdata{entry} .= "'$$host $typemap{$$rectype} $$val";
3932 }
3933 $logdata{entry} .= " [distance $dist]" if $typemap{$$rectype} eq 'MX';
3934 $logdata{entry} .= " [priority $dist] [weight $weight] [port $port]" if $typemap{$$rectype} eq 'SRV';
3935 $logdata{entry} .= "', TTL $ttl";
3936 $logdata{entry} .= ", location ".$self->getLoc($location)->{description} if $location;
3937
3938 local $dbh->{AutoCommit} = 0;
3939 local $dbh->{RaiseError} = 1;
3940
3941 # Fiddle the field list into something suitable for updates
3942 $fields =~ s/,/=?,/g;
3943 $fields .= "=?";
3944
3945 eval {
3946 $dbh->do("UPDATE "._rectable($defrec,$revrec)." SET $fields WHERE record_id=?", undef, (@vallist, $id) );
3947 $self->_log(%logdata);
3948 $dbh->commit;
3949 };
3950 if ($@) {
3951 my $msg = $@;
3952 eval { $dbh->rollback; };
3953 if ($config{log_failures}) {
3954 $logdata{entry} = "Failed updating ".($defrec eq 'y' ? 'default ' : '').
3955 "record '$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}', TTL $oldrec->{ttl} ($msg)";
3956 $self->_log(%logdata);
3957 $dbh->commit;
3958 }
3959 return ('FAIL', $msg);
3960 }
3961
3962 $resultstr = $logdata{entry};
3963 return ($retcode, $retmsg);
3964} # end updateRec()
3965
3966
3967## DNSDB::downconvert()
3968# A mostly internal (not exported) semiutilty sub to downconvert from pseudotype <x>
3969# to a compatible component type. Only a handful of operations are valid, anything
3970# else is a null-op.
3971# Takes the record ID and the new type. Returns boolean.
3972sub downconvert {
3973 my $self = shift;
3974 my $dbh = $self->{dbh};
3975 my $recid = shift;
3976 my $newtype = shift;
3977
3978 # also, only work on live records; little to no value trying to do this on default records.
3979 my $rec = $self->getRecLine('n', 'y', $recid);
3980
3981 # hm?
3982 #return 1 if !$rec;
3983
3984 return 1 if $rec->{type} < 65000; # Only the reverse-record pseudotypes can be downconverted
3985 return 1 if $rec->{type} == 65282; # Nowhere to go
3986
3987 my $delpar;
3988 my @sqlargs;
3989 if ($rec->{type} == 65280) {
3990 return 1 if $newtype != 1 && $newtype != 12;
3991 $delpar = ($newtype == 1 ? 'rdns_id' : 'domain_id');
3992 push @sqlargs, 0, $newtype, $recid;
3993 } elsif ($rec->{type} == 65281) {
3994 return 1 if $newtype != 28 && $newtype != 12;
3995 $delpar = ($newtype == 28 ? 'rdns_id' : 'domain_id');
3996 push @sqlargs, 0, $newtype, $recid;
3997 } elsif ($rec->{type} == 65283) {
3998 return 1 if $newtype != 65282;
3999 $delpar = 'rdns_id';
4000 } elsif ($rec->{type} == 65284) {
4001 return 1 if $newtype != 65282;
4002 $delpar = 'rdns_id';
4003 } else {
4004 # Your llama is on fire.
4005 }
4006
4007 local $dbh->{AutoCommit} = 0;
4008 local $dbh->{RaiseError} = 1;
4009
4010 eval {
4011 $dbh->do("UPDATE records SET $delpar = ?, type = ? WHERE record_id = ?", undef, @sqlargs);
4012 $dbh->commit;
4013 };
4014 if ($@) {
4015 $errstr = $@;
4016 eval { $dbh->rollback; };
4017 return 0;
4018 }
4019 return 1;
4020} # end downconvert()
4021
4022
4023## DNSDB::delRec()
4024# Delete a record.
4025sub delRec {
4026 $errstr = '';
4027 my $self = shift;
4028 my $dbh = $self->{dbh};
4029 my $defrec = shift;
4030 my $revrec = shift;
4031 my $id = shift;
4032
4033 my $oldrec = $self->getRecLine($defrec, $revrec, $id);
4034
4035 # Allow transactions, and raise an exception on errors so we can catch it later.
4036 # Use local to make sure these get "reset" properly on exiting this block
4037 local $dbh->{AutoCommit} = 0;
4038 local $dbh->{RaiseError} = 1;
4039
4040 # Put together the log entry
4041 my %logdata;
4042 $logdata{domain_id} = $oldrec->{domain_id};
4043 $logdata{rdns_id} = $oldrec->{rdns_id};
4044 $logdata{group_id} = $oldrec->{group_id} if $defrec eq 'y';
4045 $logdata{group_id} = $self->parentID(id => $oldrec->{domain_id}, type => ($revrec eq 'n' ? 'domain' : 'revzone'),
4046 revrec => $revrec)
4047 if $defrec eq 'n';
4048 $logdata{entry} = "Deleted ".($defrec eq 'y' ? 'default record ' : 'record ').
4049 "'$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}";
4050 $logdata{entry} .= " [distance $oldrec->{distance}]" if $typemap{$oldrec->{type}} eq 'MX';
4051 $logdata{entry} .= " [priority $oldrec->{distance}] [weight $oldrec->{weight}] [port $oldrec->{port}]"
4052 if $typemap{$oldrec->{type}} eq 'SRV';
4053 $logdata{entry} .= "', TTL $oldrec->{ttl}";
4054 $logdata{entry} .= ", location ".$self->getLoc($oldrec->{location})->{description} if $oldrec->{location};
4055
4056 eval {
4057 my $sth = $dbh->do("DELETE FROM "._rectable($defrec,$revrec)." WHERE record_id=?", undef, ($id));
4058 $self->_log(%logdata);
4059 $dbh->commit;
4060 };
4061 if ($@) {
4062 my $msg = $@;
4063 eval { $dbh->rollback; };
4064 if ($config{log_failures}) {
4065 $logdata{entry} = "Error deleting ".($defrec eq 'y' ? 'default record' : 'record').
4066 " '$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}', TTL $oldrec->{ttl} ($msg)";
4067 $self->_log(%logdata);
4068 $dbh->commit;
4069 }
4070 return ('FAIL', $msg);
4071 }
4072
4073 return ('OK',$logdata{entry});
4074} # end delRec()
4075
4076
4077## DNSDB::getLogCount()
4078# Get a count of log entries
4079# Takes a database handle and a hash containing at least:
4080# - Entity ID and entity type as the primary log "slice"
4081sub getLogCount {
4082 my $self = shift;
4083 my $dbh = $self->{dbh};
4084
4085 my %args = @_;
4086
4087 my @filterargs;
4088##fixme: which fields do we want to filter on?
4089# push @filterargs,
4090
4091 $errstr = 'Missing primary parent ID and/or type';
4092 # fail early if we don't have a "prime" ID to look for log entries for
4093 return if !$args{id};
4094
4095 # or if the prime id type is missing or invalid
4096 return if !$args{logtype};
4097 $args{logtype} = 'revzone' if $args{logtype} eq 'rdns'; # hack pthui
4098 $args{logtype} = 'domain' if $args{logtype} eq 'dom'; # hack pthui
4099 return if !grep /^$args{logtype}$/, ('group', 'domain', 'revzone', 'user');
4100
4101 $args{logtype} = 'revzone' if $args{logtype} eq 'rdns'; # hack pthui
4102
4103 my $sql = "SELECT count(*) FROM log ".
4104 "WHERE $id_col{$args{logtype}}=?".
4105 ($args{filter} ? " AND entry ~* ?" : '');
4106 my ($count) = $dbh->selectrow_array($sql, undef, ($args{id}, @filterargs) );
4107 $errstr = $dbh->errstr if !$count;
4108 return $count;
4109} # end getLogCount()
4110
4111
4112## DNSDB::getLogEntries()
4113# Get a list of log entries
4114# Takes arguments as with getLogCount() above, plus optional:
4115# - sort field
4116# - sort order
4117# - offset for pagination
4118sub getLogEntries {
4119 my $self = shift;
4120 my $dbh = $self->{dbh};
4121
4122 my %args = @_;
4123
4124 my @filterargs;
4125
4126 # fail early if we don't have a "prime" ID to look for log entries for
4127 return if !$args{id};
4128
4129 # or if the prime id type is missing or invalid
4130 return if !$args{logtype};
4131 $args{logtype} = 'revzone' if $args{logtype} eq 'rdns'; # hack pthui
4132 $args{logtype} = 'domain' if $args{logtype} eq 'dom'; # hack pthui
4133 return if !grep /^$args{logtype}$/, ('group', 'domain', 'revzone', 'user');
4134
4135 # Sorting defaults
4136 $args{sortorder} = 'DESC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC');
4137 $args{sortby} = 'stamp' if !$args{sortby} || $args{sortby} !~ /^[\w_.]+$/;
4138 $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
4139
4140 my %sortmap = (fname => 'name', username => 'email', entry => 'entry', stamp => 'stamp');
4141 $args{sortby} = $sortmap{$args{sortby}};
4142
4143 my $sql = "SELECT user_id AS userid, email AS useremail, name AS userfname, entry AS logentry, ".
4144 "date_trunc('second',stamp) AS logtime ".
4145 "FROM log ".
4146 "WHERE $id_col{$args{logtype}}=?".
4147 ($args{filter} ? " AND entry ~* ?" : '').
4148 " ORDER BY $args{sortby} $args{sortorder}, log_id $args{sortorder}".
4149 ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage} OFFSET ".$args{offset}*$config{perpage});
4150 my $loglist = $dbh->selectall_arrayref($sql, { Slice => {} }, ($args{id}, @filterargs) );
4151 $errstr = $dbh->errstr if !$loglist;
4152 return $loglist;
4153} # end getLogEntries()
4154
4155
4156## IPDB::getRevPattern()
4157# Get the narrowest template pattern applicable to a passed CIDR address (may be a netblock or an IP)
4158sub getRevPattern {
4159 my $self = shift;
4160 my $dbh = $self->{dbh};
4161 my $cidr = shift;
4162 my $group = shift || 1; # just in case
4163
4164 # for speed! Casting and comparing even ~7K records takes ~2.5s, so narrow it down to one revzone first.
4165 my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >>= ? AND group_id = ?",
4166 undef, ($cidr, $group) );
4167
4168##fixme? may need to narrow things down more by octet-chopping and doing text comparisons before casting.
4169 my ($revpatt) = $dbh->selectrow_array("SELECT host FROM records ".
4170 "WHERE (type in (12,65280,65281,65282,65283,65284)) AND rdns_id = ? AND CAST (val AS inet) >>= ? ".
4171 "ORDER BY CAST (val AS inet) DESC LIMIT 1", undef, ($revid, $cidr) );
4172 return $revpatt;
4173} # end getRevPattern()
4174
4175
4176## DNSDB::getTypelist()
4177# Get a list of record types for various UI dropdowns
4178# Takes database handle, forward/reverse/lookup flag, and optional "tag as selected" indicator (defaults to A)
4179# Returns an arrayref to list of hashrefs perfect for HTML::Template
4180sub getTypelist {
4181 my $self = shift;
4182 my $dbh = $self->{dbh};
4183 my $recgroup = shift;
4184 my $type = shift || $reverse_typemap{A};
4185
4186 # also accepting $webvar{revrec}!
4187 $recgroup = 'f' if $recgroup eq 'n';
4188 $recgroup = 'r' if $recgroup eq 'y';
4189
4190 my $sql = "SELECT val,name FROM rectypes WHERE ";
4191 if ($recgroup eq 'r') {
4192 # reverse zone types
4193 $sql .= "stdflag=2 OR stdflag=3";
4194 } elsif ($recgroup eq 'l') {
4195 # DNS lookup types. Note we avoid our custom types >= 65280, since those are entirely internal.
4196 $sql .= "(stdflag=1 OR stdflag=2 OR stdflag=3) AND val < 65280";
4197 } else {
4198 # default; forward zone types. technically $type eq 'f' but not worth the error message.
4199 $sql .= "stdflag=1 OR stdflag=2";
4200 $sql .= " AND val < 65280" if $recgroup eq 'fo'; # An extra flag to trim off the pseudotypes as well.
4201 }
4202 $sql .= " ORDER BY listorder";
4203
4204 my $sth = $dbh->prepare($sql);
4205 $sth->execute;
4206 my @typelist;
4207 while (my ($rval,$rname) = $sth->fetchrow_array()) {
4208 my %row = ( recval => $rval, recname => $rname );
4209 $row{tselect} = 1 if $rval == $type;
4210 push @typelist, \%row;
4211 }
4212
4213 # Add SOA on lookups since it's not listed in other dropdowns.
4214 if ($recgroup eq 'l') {
4215 my %row = ( recval => $reverse_typemap{SOA}, recname => 'SOA' );
4216 $row{tselect} = 1 if $reverse_typemap{SOA} == $type;
4217 push @typelist, \%row;
4218 }
4219
4220 return \@typelist;
4221} # end getTypelist()
4222
4223
4224## DNSDB::parentID()
4225# Get ID of entity that is nearest parent to requested id
4226# Takes a database handle and a hash of entity ID, entity type, optional parent type flag
4227# (domain/reverse zone or group), and optional default/live and forward/reverse flags
4228# Returns the ID or undef on failure
4229sub parentID {
4230 my $self = shift;
4231 my $dbh = $self->{dbh};
4232
4233 my %args = @_;
4234
4235 # clean up the parent-type. Set it to group if not set; coerce revzone to domain for simpler logic
4236 $args{partype} = 'group' if !$args{partype};
4237 $args{partype} = 'domain' if $args{partype} eq 'revzone';
4238
4239 # clean up defrec and revrec. default to live record, forward zone
4240 $args{defrec} = 'n' if !$args{defrec};
4241 $args{revrec} = 'n' if !$args{revrec};
4242
4243 if ($par_type{$args{partype}} eq 'domain') {
4244 # only live records can have a domain/zone parent
4245 return unless ($args{type} eq 'record' && $args{defrec} eq 'n');
4246 my $result = $dbh->selectrow_hashref("SELECT ".($args{revrec} eq 'n' ? 'domain_id' : 'rdns_id').
4247 " FROM records WHERE record_id = ?",
4248 undef, ($args{id}) ) or return;
4249 return $result;
4250 } else {
4251 # snag some arguments that will either fall through or be overwritten to save some code duplication
4252 my $tmpid = $args{id};
4253 my $type = $args{type};
4254 if ($type eq 'record' && $args{defrec} eq 'n') {
4255 # Live records go through the records table first.
4256 ($tmpid) = $dbh->selectrow_array("SELECT ".($args{revrec} eq 'n' ? 'domain_id' : 'rdns_id').
4257 " FROM records WHERE record_id = ?",
4258 undef, ($args{id}) ) or return;
4259 $type = ($args{revrec} eq 'n' ? 'domain' : 'revzone');
4260 }
4261 my ($result) = $dbh->selectrow_array("SELECT $par_col{$type} FROM $par_tbl{$type} WHERE $id_col{$type} = ?",
4262 undef, ($tmpid) );
4263 return $result;
4264 }
4265# should be impossible to get here with even remotely sane arguments
4266 return;
4267} # end parentID()
4268
4269
4270## DNSDB::isParent()
4271# Returns true if $id1 is a parent of $id2, false otherwise
4272sub isParent {
4273 my $self = shift;
4274 my $dbh = $self->{dbh};
4275 my $id1 = shift;
4276 my $type1 = shift;
4277 my $id2 = shift;
4278 my $type2 = shift;
4279##todo: immediate, secondary, full (default)
4280
4281 # Return false on invalid types
4282 return 0 if !grep /^$type1$/, ('record','defrec','defrevrec','user','domain','revzone','group');
4283 return 0 if !grep /^$type2$/, ('record','defrec','defrevrec','user','domain','revzone','group');
4284
4285 # Return false on impossible relations
4286 return 0 if $type1 eq 'record'; # nothing may be a child of a record
4287 return 0 if $type1 eq 'defrec'; # nothing may be a child of a record
4288 return 0 if $type1 eq 'defrevrec'; # nothing may be a child of a record
4289 return 0 if $type1 eq 'user'; # nothing may be child of a user
4290 return 0 if $type1 eq 'domain' && $type2 ne 'record'; # domain may not be a parent of anything other than a record
4291 return 0 if $type1 eq 'revzone' && $type2 ne 'record';# reverse zone may not be a parent of anything other than a record
4292
4293 # ennnhhhh.... if we're passed an id of 0, it will never be found. usual
4294 # case would be the UI creating a new <thing>, and so we don't have an ID for
4295 # <thing> to look up yet. in that case the UI should check the parent as well.
4296 return 0 if $id1 == 0; # nothing can have a parent id of 0
4297 return 1 if $id2 == 0; # anything could have a child id of 0 (or "unknown")
4298
4299 # group 1 is the ultimate root parent
4300 return 1 if $type1 eq 'group' && $id1 == 1;
4301
4302 # groups are always (a) parent of themselves
4303 return 1 if $type1 eq 'group' && $type2 eq 'group' && $id1 == $id2;
4304
4305 my $id = $id2;
4306 my $type = $type2;
4307 my $foundparent = 0;
4308
4309 # Records are the only entity with two possible parents. We need to split the parent checks on
4310 # domain/rdns.
4311 if ($type eq 'record') {
4312 my ($dom,$rdns) = $dbh->selectrow_array("SELECT domain_id,rdns_id FROM records WHERE record_id=?",
4313 undef, ($id));
4314 # check immediate parent against request
4315 return 1 if $type1 eq 'domain' && $id1 == $dom;
4316 return 1 if $type1 eq 'revzone' && $id1 == $rdns;
4317 # if request is group, check *both* parents. Only check if the parent is nonzero though.
4318 return 1 if $dom && $self->isParent($id1, $type1, $dom, 'domain');
4319 return 1 if $rdns && $self->isParent($id1, $type1, $rdns, 'revzone');
4320 # exit here since we've executed the loop below by proxy in the above recursive calls.
4321 return 0;
4322 }
4323
4324# almost the same loop as getParents() above
4325 my $limiter = 0;
4326 while (1) {
4327 my $sql = "SELECT $par_col{$type} FROM $par_tbl{$type} WHERE $id_col{$type} = ?";
4328 my $result = $dbh->selectrow_hashref($sql,
4329 undef, ($id) );
4330 if (!$result) {
4331 $limiter++;
4332##fixme: how often will this happen on a live site? fail at max limiter <n>?
4333 warn "no results looking for $sql with id $id (depth $limiter)\n";
4334 last;
4335 }
4336 if ($result && $result->{$par_col{$type}} == $id1) {
4337 $foundparent = 1;
4338 last;
4339 } else {
4340##fixme: do we care about trying to return a "no such record/domain/user/group" error?
4341# should be impossible to create an inconsistent DB just with API calls.
4342 warn $dbh->errstr." $sql, $id" if $dbh->errstr;
4343 }
4344 # group 1 is its own parent. need this here more to break strange loops than for detecting a parent
4345 last if $result->{$par_col{$type}} == 1;
4346 $id = $result->{$par_col{$type}};
4347 $type = $par_type{$type};
4348 }
4349
4350 return $foundparent;
4351} # end isParent()
4352
4353
4354## DNSDB::zoneStatus()
4355# Returns and optionally sets a zone's status
4356# Takes a database handle, domain/revzone ID, forward/reverse flag, and optionally a status argument
4357# Returns status, or undef on errors.
4358sub zoneStatus {
4359 my $self = shift;
4360 my $dbh = $self->{dbh};
4361 my $id = shift;
4362 my $revrec = shift;
4363 my $newstatus = shift || 'mu';
4364
4365 return undef if $id !~ /^\d+$/;
4366
4367 # Allow transactions, and raise an exception on errors so we can catch it later.
4368 # Use local to make sure these get "reset" properly on exiting this block
4369 local $dbh->{AutoCommit} = 0;
4370 local $dbh->{RaiseError} = 1;
4371
4372 if ($newstatus ne 'mu') {
4373 # ooo, fun! let's see what we were passed for status
4374 eval {
4375 $newstatus = 0 if $newstatus eq 'domoff';
4376 $newstatus = 1 if $newstatus eq 'domon';
4377 $dbh->do("UPDATE ".($revrec eq 'n' ? 'domains' : 'revzones')." SET status=? WHERE ".
4378 ($revrec eq 'n' ? 'domain_id' : 'rdns_id')."=?", undef, ($newstatus,$id) );
4379
4380##fixme switch to more consise "Enabled <domain"/"Disabled <domain>" as with users?
4381 $resultstr = "Changed ".($revrec eq 'n' ? $self->domainName($id) : $self->revName($id)).
4382 " state to ".($newstatus ? 'active' : 'inactive');
4383
4384 my %loghash;
4385 $loghash{domain_id} = $id if $revrec eq 'n';
4386 $loghash{rdns_id} = $id if $revrec eq 'y';
4387 $loghash{group_id} = $self->parentID(id => $id, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec);
4388 $loghash{entry} = $resultstr;
4389 $self->_log(%loghash);
4390
4391 $dbh->commit;
4392 };
4393 if ($@) {
4394 my $msg = $@;
4395 eval { $dbh->rollback; };
4396 $resultstr = '';
4397 $errstr = $msg;
4398 return;
4399 }
4400 }
4401
4402 my ($status) = $dbh->selectrow_array("SELECT status FROM ".
4403 ($revrec eq 'n' ? "domains WHERE domain_id=?" : "revzones WHERE rdns_id=?"),
4404 undef, ($id) );
4405 return $status;
4406} # end zoneStatus()
4407
4408
4409## DNSDB::getZonesByCIDR()
4410# Get a list of zone names and IDs that records for a passed CIDR block are within.
4411sub getZonesByCIDR {
4412 my $self = shift;
4413 my $dbh = $self->{dbh};
4414 my %args = @_;
4415
4416 my $result = $dbh->selectall_arrayref("SELECT rdns_id,revnet FROM revzones WHERE revnet >>= ? OR revnet <<= ?",
4417 { Slice => {} }, ($args{cidr}, $args{cidr}) );
4418 return $result;
4419} # end getZonesByCIDR()
4420
4421
4422## DNSDB::importAXFR
4423# Import a domain via AXFR
4424# Takes AXFR host, domain to transfer, group to put the domain in,
4425# and an optional hash containing:
4426# status - active/inactive state flag (defaults to active)
4427# rwsoa - overwrite-SOA flag (defaults to off)
4428# rwns - overwrite-NS flag (defaults to off, doesn't affect subdomain NS records)
4429# merge - flag to automerge A or AAAA records with matching PTR records
4430# Returns a status code (OK, WARN, or FAIL) and message - message should be blank
4431# if status is OK, but WARN includes conditions that are not fatal but should
4432# really be reported.
4433sub importAXFR {
4434 my $self = shift;
4435 my $dbh = $self->{dbh};
4436 my $ifrom_in = shift;
4437 my $zone = shift;
4438 my $group = shift;
4439
4440 my %args = @_;
4441
4442##fixme: add mode to delete&replace, merge+overwrite, merge new?
4443
4444 $args{status} = (defined($args{status}) ? $args{status} : 0);
4445 $args{status} = 1 if $args{status} eq 'on';
4446
4447 my $nrecs = 0;
4448 my $soaflag = 0;
4449 my $nsflag = 0;
4450 my $warnmsg = '';
4451 my $ifrom;
4452
4453 my $rev = 'n';
4454 my $code = 'OK';
4455 my $msg = 'foobar?';
4456
4457 # choke on possible bad setting in ifrom
4458 # IPv4 and v6, and valid hostnames!
4459 ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i);
4460 return ('FAIL', "Bad AXFR source host $ifrom")
4461 unless ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i);
4462
4463 my $errmsg;
4464
4465 my $zone_id;
4466 my $domain_id = 0;
4467 my $rdns_id = 0;
4468 my $cidr;
4469
4470# magic happens! detect if we're importing a domain or a reverse zone
4471# while we're at it, figure out what the CIDR netblock is (if we got a .arpa)
4472# or what the formal .arpa zone is (if we got a CIDR netblock)
4473# Handles sub-octet v4 zones in the format specified in the Cricket Book, 2nd Ed, p217-218
4474
4475 if ($zone =~ m{(?:\.arpa\.?|/\d+)$}) {
4476 # we seem to have a reverse zone
4477 $rev = 'y';
4478
4479 if ($zone =~ /\.arpa\.?$/) {
4480 # we have a formal reverse zone. call _zone2cidr and get the CIDR block.
4481 ($code,$msg) = _zone2cidr($zone);
4482 return ($code, $msg) if $code eq 'FAIL';
4483 $cidr = $msg;
4484 } elsif ($zone =~ m|^[\d.]+/\d+$|) {
4485 # v4 revzone, CIDR netblock
4486 $cidr = NetAddr::IP->new($zone) or return ('FAIL',"$zone is not a valid CIDR block");
4487 $zone = _ZONE($cidr, 'ZONE.in-addr.arpa', 'r', '.');
4488 } elsif ($zone =~ m|^[a-fA-F\d:]+/\d+$|) {
4489 # v6 revzone, CIDR netblock
4490 $cidr = NetAddr::IP->new($zone) or return ('FAIL',"$zone is not a valid CIDR block");
4491 return ('FAIL', "$zone is not a nibble-aligned block") if $cidr->masklen % 4 != 0;
4492 $zone = _ZONE($cidr, 'ZONE.ip6.arpa', 'r', '.');
4493 } else {
4494 # there is. no. else!
4495 return ('FAIL', "Unknown zone name format");
4496 }
4497
4498 # quick check to start to see if we've already got one
4499
4500 ($zone_id) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet=?",
4501 undef, ("$cidr"));
4502 $rdns_id = $zone_id;
4503 } else {
4504 # default to domain
4505 ($zone_id) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)",
4506 undef, ($zone));
4507 $domain_id = $zone_id;
4508 }
4509
4510 return ('FAIL', ($rev eq 'n' ? 'Domain' : 'Reverse zone')." already exists") if $zone_id;
4511
4512 # little local utility sub to swap $val and $host for revzone records.
4513 sub _revswap {
4514 my $rechost = shift;
4515 my $recdata = shift;
4516
4517 if ($rechost =~ /\.in-addr\.arpa\.?$/) {
4518 $rechost =~ s/\.in-addr\.arpa\.?$//;
4519 $rechost = join '.', reverse split /\./, $rechost;
4520 } else {
4521 $rechost =~ s/\.ip6\.arpa\.?$//;
4522 my @nibs = reverse split /\./, $rechost;
4523 $rechost = '';
4524 my $nc;
4525 foreach (@nibs) {
4526 $rechost.= $_;
4527 $rechost .= ":" if ++$nc % 4 == 0 && $nc < 32;
4528 }
4529 $rechost .= ":" if $nc < 32 && $rechost !~ /\*$/; # close netblock records?
4530##fixme: there's a case that ends up with a partial entry here:
4531# ip:add:re:ss::
4532# can't reproduce after letting it sit overnight after discovery. :(
4533#print "$rechost\n";
4534 # canonicalize with NetAddr::IP
4535 $rechost = NetAddr::IP->new($rechost)->addr unless $rechost =~ /\*$/;
4536 }
4537 return ($recdata,$rechost)
4538 }
4539
4540
4541 # Allow transactions, and raise an exception on errors so we can catch it later.
4542 # Use local to make sure these get "reset" properly on exiting this block
4543 local $dbh->{AutoCommit} = 0;
4544 local $dbh->{RaiseError} = 1;
4545
4546 my $sth;
4547 eval {
4548
4549 if ($rev eq 'n') {
4550##fixme: serial
4551 $dbh->do("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)", undef,
4552 ($zone, $group, $args{status}) );
4553 # get domain id so we can do the records
4554 ($zone_id) = $dbh->selectrow_array("SELECT currval('domains_domain_id_seq')");
4555 $domain_id = $zone_id;
4556 $self->_log(group_id => $group, domain_id => $domain_id,
4557 entry => "[Added ".($args{status} ? 'active' : 'inactive')." domain $zone via AXFR]");
4558 } else {
4559##fixme: serial
4560 $dbh->do("INSERT INTO revzones (revnet,group_id,status) VALUES (?,?,?)", undef,
4561 ($cidr,$group,$args{status}) );
4562 # get revzone id so we can do the records
4563 ($zone_id) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')");
4564 $rdns_id = $zone_id;
4565 $self->_log(group_id => $group, rdns_id => $rdns_id,
4566 entry => "[Added ".($args{status} ? 'active' : 'inactive')." reverse zone $cidr via AXFR]");
4567 }
4568
4569## bizarre DBI<->Net::DNS interaction bug:
4570## sometimes a zone will cause an immediate commit-and-exit (sort of) of the while()
4571## fixed, apparently I was doing *something* odd, but not certain what it was that
4572## caused a commit instead of barfing
4573
4574 my $res = Net::DNS::Resolver->new;
4575 $res->nameservers($ifrom);
4576 $res->axfr_start($zone)
4577 or die "Couldn't begin AXFR\n";
4578
4579 $sth = $dbh->prepare("INSERT INTO records (domain_id,rdns_id,host,type,val,distance,weight,port,ttl)".
4580 " VALUES (?,?,?,?,?,?,?,?,?)");
4581
4582 # Stash info about sub-octet v4 revzones here so we don't have
4583 # to store the CNAMEs used to delegate a suboctet zone
4584 # $suboct{zone}{ns}[] -> array of nameservers
4585 # $suboct{zone}{cname}[] -> array of extant CNAMEs (Just In Case someone did something bizarre)
4586## commented pending actual use of this data. for now, we'll just
4587## auto-(re)create the CNAMEs in revzones on export
4588# my %suboct;
4589
4590 while (my $rr = $res->axfr_next()) {
4591
4592 my $val;
4593 my $distance = 0;
4594 my $weight = 0;
4595 my $port = 0;
4596 my $logfrag = '';
4597
4598 my $type = $rr->type;
4599 my $host = $rr->name;
4600 my $ttl = ($args{newttl} ? $args{newttl} : $rr->ttl); # allow force-override TTLs
4601
4602 $soaflag = 1 if $type eq 'SOA';
4603 $nsflag = 1 if $type eq 'NS';
4604
4605# "Primary" types:
4606# A, NS, CNAME, SOA, PTR(warn in forward), MX, TXT, AAAA, SRV, A6(ob), SPF
4607# maybe KEY
4608
4609# BIND supports:
4610# [standard]
4611# A AAAA CNAME MX NS PTR SOA TXT
4612# [variously experimental, obsolete, or obscure]
4613# HINFO MB(ex) MD(ob) MF(ob) MG(ex) MINFO(ex) MR(ex) NULL WKS AFSDB(ex) ISDN(ex) RP(ex) RT(ex) X25(ex) PX
4614# ... if one can ever find the right magic to format them correctly
4615
4616# Net::DNS supports:
4617# RRSIG SIG NSAP NS NIMLOC NAPTR MX MR MINFO MG MB LOC ISDN IPSECKEY HINFO
4618# EID DNAME CNAME CERT APL AFSDB AAAA A DS NXT NSEC3PARAM NSEC3 NSEC KEY
4619# DNSKEY DLV X25 TXT TSIG TKEY SSHFP SRV SPF SOA RT RP PX PTR NULL APL::AplItem
4620
4621# nasty big ugly case-like thing here, since we have to do *some* different
4622# processing depending on the record. le sigh.
4623
4624##fixme: what record types other than TXT can/will have >255-byte payloads?
4625
4626 if ($type eq 'A') {
4627 $val = $rr->address;
4628 } elsif ($type eq 'NS') {
4629# hmm. should we warn here if subdomain NS'es are left alone?
4630 next if ($args{rwns} && ($rr->name eq $zone));
4631 if ($rev eq 'y') {
4632 # revzones have records more or less reversed from forward zones.
4633 my ($tmpcode,$tmpmsg) = _zone2cidr($host);
4634 die "Error converting NS record: $tmpmsg\n" if $tmpcode eq 'FAIL'; # hmm. may not make sense...
4635 $val = "$tmpmsg";
4636 $host = $rr->nsdname;
4637 $logfrag = "Added record '$val $type $host', TTL $ttl";
4638# Tag and preserve. For now this is commented for a no-op, but we have Ideas for
4639# another custom storage type ("DELEGATE") that will use these subzone-delegation records
4640#if ($val ne "$cidr") {
4641# push @{$suboct{$val}{ns}}, $host;
4642#}
4643 } else {
4644 $val = $rr->nsdname;
4645 }
4646 $nsflag = 1;
4647 } elsif ($type eq 'CNAME') {
4648 if ($rev eq 'y') {
4649 # hmm. do we even want to bother with storing these at this level? Sub-octet delegation
4650 # by CNAME is essentially a record-publication hack, and we want to just represent the
4651 # "true" logical intentions as far down the stack as we can from the UI.
4652 ($host,$val) = _revswap($host,$rr->cname);
4653 $logfrag = "Added record '$val $type $host', TTL $ttl";
4654# Tag and preserve in case we want to commit them as-is later, but mostly we don't care.
4655# Commented pending actually doing something with possibly new type DELEGATE
4656#my $tmprev = $host;
4657#$tmprev =~ s/^\d+\.//;
4658#($code,$tmprev) = _zone2cidr($tmprev);
4659#push @{$suboct{"$tmprev"}{cname}}, $val;
4660 # Silently skip CNAMEs in revzones.
4661 next;
4662 } else {
4663 $val = $rr->cname;
4664 }
4665 } elsif ($type eq 'SOA') {
4666 next if $args{rwsoa};
4667 $host = $rr->rname.":".$rr->mname;
4668 $val = $rr->refresh.":".$rr->retry.":".$rr->expire.":".$rr->minimum;
4669 $soaflag = 1;
4670 } elsif ($type eq 'PTR') {
4671 ($host,$val) = _revswap($host,$rr->ptrdname);
4672 $logfrag = "Added record '$val $type $host', TTL $ttl";
4673 # hmm. PTR records should not be in forward zones.
4674 } elsif ($type eq 'MX') {
4675 $val = $rr->exchange;
4676 $distance = $rr->preference;
4677 } elsif ($type eq 'TXT') {
4678##fixme: Net::DNS docs say this should be deprecated for rdatastr() or char_str_list(),
4679## but don't really seem enthusiastic about it.
4680#print "should use rdatastr:\n\t".$rr->rdatastr."\n or char_str_list:\n\t".join(' ',$rr->char_str_list())."\n";
4681# rdatastr returns a BIND-targetted logical string, including opening and closing quotes
4682# char_str_list returns a list of the individual string fragments in the record
4683# txtdata returns the more useful all-in-one form (since we want to push such protocol
4684# details as far down the stack as we can)
4685# NB: this may turn out to be more troublesome if we ever have need of >512-byte TXT records.
4686 if ($rev eq 'y') {
4687 ($host,$val) = _revswap($host,$rr->txtdata);
4688 $logfrag = "Added record '$val $type $host', TTL $ttl";
4689 } else {
4690 $val = $rr->txtdata;
4691 }
4692 } elsif ($type eq 'SPF') {
4693##fixme: and the same caveat here, since it is apparently a clone of ::TXT
4694 $val = $rr->txtdata;
4695 } elsif ($type eq 'AAAA') {
4696 $val = $rr->address;
4697 } elsif ($type eq 'SRV') {
4698 $val = $rr->target;
4699 $distance = $rr->priority;
4700 $weight = $rr->weight;
4701 $port = $rr->port;
4702 } elsif ($type eq 'KEY') {
4703 # we don't actually know what to do with these...
4704 $val = $rr->flags.":".$rr->protocol.":".$rr->algorithm.":".$rr->key.":".$rr->keytag.":".$rr->privatekeyname;
4705 } else {
4706 $val = $rr->rdatastr;
4707 # Finding a different record type is not fatal.... just problematic.
4708 # We may not be able to export it correctly.
4709 $warnmsg .= "Unusual record ".$rr->name." ($type) found\n";
4710 }
4711
4712 my $logentry = "[AXFR ".($rev eq 'n' ? $zone : $cidr)."] ";
4713
4714 if ($args{merge}) {
4715 if ($rev eq 'n') {
4716 # importing a domain; we have A and AAAA records that could be merged with matching PTR records
4717 my $etype;
4718 my ($erdns,$erid,$ettl) = $dbh->selectrow_array("SELECT rdns_id,record_id,ttl FROM records ".
4719 "WHERE host=? AND val=? AND type=12",
4720 undef, ($host, $val) );
4721 if ($erid) {
4722 if ($type eq 'A') { # PTR -> A+PTR
4723 $etype = 65280;
4724 $logentry .= "Merged A record with existing PTR record '$host A+PTR $val', TTL $ettl";
4725 }
4726 if ($type eq 'AAAA') { # PTR -> AAAA+PTR
4727 $etype = 65281;
4728 $logentry .= "Merged AAAA record with existing PTR record '$host AAAA+PTR $val', TTL $ettl";
4729 }
4730 $ettl = ($ettl < $ttl ? $ettl : $ttl); # use lower TTL
4731 $dbh->do("UPDATE records SET domain_id=?,ttl=?,type=? WHERE record_id=?", undef,
4732 ($domain_id, $ettl, $etype, $erid));
4733 $nrecs++;
4734 $self->_log(group_id => $group, domain_id => $domain_id, rdns_id => $erdns, entry => $logentry);
4735 next; # while axfr_next
4736 }
4737 } # $rev eq 'n'
4738 else {
4739 # importing a revzone, we have PTR records that could be merged with matching A/AAAA records
4740 my ($domid,$erid,$ettl,$etype) = $dbh->selectrow_array("SELECT domain_id,record_id,ttl,type FROM records ".
4741 "WHERE host=? AND val=? AND (type=1 OR type=28)",
4742 undef, ($host, $val) );
4743 if ($erid) {
4744 if ($etype == 1) { # A -> A+PTR
4745 $etype = 65280;
4746 $logentry .= "Merged PTR record with existing matching A record '$host A+PTR $val', TTL $ettl";
4747 }
4748 if ($etype == 28) { # AAAA -> AAAA+PTR
4749 $etype = 65281;
4750 $logentry .= "Merged PTR record with existing matching AAAA record '$host AAAA+PTR $val', TTL $ettl";
4751 }
4752 $ettl = ($ettl < $ttl ? $ettl : $ttl); # use lower TTL
4753 $dbh->do("UPDATE records SET rdns_id=?,ttl=?,type=? WHERE record_id=?", undef,
4754 ($rdns_id, $ettl, $etype, $erid));
4755 $nrecs++;
4756 $self->_log(group_id => $group, domain_id => $domid, rdns_id => $rdns_id, entry => $logentry);
4757 next; # while axfr_next
4758 }
4759 } # $rev eq 'y'
4760 } # if $args{merge}
4761
4762 # Insert the new record
4763 $sth->execute($domain_id, $rdns_id, $host, $reverse_typemap{$type}, $val,
4764 $distance, $weight, $port, $ttl);
4765
4766 $nrecs++;
4767
4768 if ($type eq 'SOA') {
4769 # also !$args{rwsoa}, but if that's set, it should be impossible to get here.
4770 my @tmp1 = split /:/, $host;
4771 my @tmp2 = split /:/, $val;
4772 $logentry .= "Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ".
4773 "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl";
4774 } elsif ($logfrag) {
4775 # special case for log entries we need to meddle with a little.
4776 $logentry .= $logfrag;
4777 } else {
4778 $logentry .= "Added record '$host $type";
4779 $logentry .= " [distance $distance]" if $type eq 'MX';
4780 $logentry .= " [priority $distance] [weight $weight] [port $port]" if $type eq 'SRV';
4781 $logentry .= " $val', TTL $ttl";
4782 }
4783 $self->_log(group_id => $group, domain_id => $domain_id, rdns_id => $rdns_id, entry => $logentry);
4784
4785 } # while axfr_next
4786
4787# Detect and handle delegated subzones
4788# Placeholder for when we decide what to actually do with this, see previous comments in NS and CNAME handling.
4789#foreach (keys %suboct) {
4790# print "found ".($suboct{$_}{ns} ? @{$suboct{$_}{ns}} : '0')." NS records and ".
4791# ($suboct{$_}{cname} ? @{$suboct{$_}{cname}} : '0')." CNAMEs for $_\n";
4792#}
4793
4794 # Overwrite SOA record
4795 if ($args{rwsoa}) {
4796 $soaflag = 1;
4797 my $sthgetsoa = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?");
4798 my $sthputsoa = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)");
4799 $sthgetsoa->execute($group,$reverse_typemap{SOA});
4800 while (my ($host,$val,$ttl) = $sthgetsoa->fetchrow_array()) {
4801 $host =~ s/DOMAIN/$zone/g;
4802 $val =~ s/DOMAIN/$zone/g;
4803 $sthputsoa->execute($zone_id,$host,$reverse_typemap{SOA},$val,$ttl);
4804 }
4805 }
4806
4807 # Overwrite NS records
4808 if ($args{rwns}) {
4809 $nsflag = 1;
4810 my $sthgetns = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?");
4811 my $sthputns = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)");
4812 $sthgetns->execute($group,$reverse_typemap{NS});
4813 while (my ($host,$val,$ttl) = $sthgetns->fetchrow_array()) {
4814 $host =~ s/DOMAIN/$zone/g;
4815 $val =~ s/DOMAIN/$zone/g;
4816 $sthputns->execute($zone_id,$host,$reverse_typemap{NS},$val,$ttl);
4817 }
4818 }
4819
4820 die "No records found; either $ifrom is not authoritative or doesn't allow transfers\n" if !$nrecs;
4821 die "Bad zone: No SOA record!\n" if !$soaflag;
4822 die "Bad zone: No NS records!\n" if !$nsflag;
4823
4824 $dbh->commit;
4825
4826 };
4827
4828 if ($@) {
4829 my $msg = $@;
4830 eval { $dbh->rollback; };
4831 return ('FAIL',$msg." $warnmsg");
4832 } else {
4833 return ('WARN', $warnmsg) if $warnmsg;
4834 return ('OK',"Imported OK");
4835 }
4836
4837 # it should be impossible to get here.
4838 return ('WARN',"OOOK!");
4839} # end importAXFR()
4840
4841
4842## DNSDB::importBIND()
4843sub importBIND {
4844} # end importBIND()
4845
4846
4847## DNSDB::import_tinydns()
4848sub import_tinydns {
4849} # end import_tinydns()
4850
4851
4852## DNSDB::export()
4853# Export the DNS database, or a part of it
4854# Takes a string indicating the export type, plus optional arguments depending on type
4855# Writes zone data to targets as appropriate for type
4856sub export {
4857 my $self = shift;
4858 my $target = shift;
4859
4860 if ($target eq 'tiny') {
4861 $self->__export_tiny(@_);
4862 }
4863# elsif ($target eq 'foo') {
4864# __export_foo(@_);
4865#}
4866# etc
4867
4868} # end export()
4869
4870
4871## DNSDB::__export_tiny
4872# Internal sub to implement tinyDNS (compatible) export
4873# Takes filehandle to write export to, optional argument(s)
4874# to determine which data gets exported
4875sub __export_tiny {
4876 my $self = shift;
4877 my $dbh = $self->{dbh};
4878 my $datafile = shift;
4879
4880##fixme: slurp up further options to specify particular zone(s) to export
4881
4882##fixme: fail if $datafile isn't an open, writable file
4883
4884 # easy case - export all evarything
4885 # not-so-easy case - export item(s) specified
4886 # todo: figure out what kind of list we use to export items
4887
4888# raw packet in unknown format: first byte indicates length
4889# of remaining data, allows up to 255 raw bytes
4890
4891 # Locations/views - worth including in the caching setup?
4892 my $lochash = $dbh->selectall_hashref("SELECT location,iplist FROM locations", 'location');
4893 foreach my $location (keys %$lochash) {
4894 foreach my $ipprefix (split /[,\s]+/, $lochash->{$location}{iplist}) {
4895 $ipprefix =~ s/\s+//g;
4896 $ipprefix = new NetAddr::IP $ipprefix;
4897##fixme: how to handle IPv6?
4898next if $ipprefix->{isv6};
4899 # have to account for /nn CIDR entries. tinydns only speaks octet-sliced prefix.
4900 if ($ipprefix->masklen <= 8) {
4901 foreach ($ipprefix->split(8)) {
4902 my $tmp = $_->addr;
4903 $tmp =~ s/\.\d+\.\d+\.\d+$//;
4904 print $datafile "%$location:$tmp\n";
4905 }
4906 } elsif ($ipprefix->masklen <= 16) {
4907 foreach ($ipprefix->split(16)) {
4908 my $tmp = $_->addr;
4909 $tmp =~ s/\.\d+\.\d+$//;
4910 print $datafile "%$location:$tmp\n";
4911 }
4912 } elsif ($ipprefix->masklen <= 24) {
4913 foreach ($ipprefix->split(24)) {
4914 my $tmp = $_->addr;
4915 $tmp =~ s/\.\d+$//;
4916 print $datafile "%$location:$tmp\n";
4917 }
4918 } else {
4919 foreach ($ipprefix->split(32)) {
4920 print $datafile "%$location:".$_->addr."\n";
4921 }
4922 }
4923 }
4924 print $datafile "%$location\n" if !$lochash->{$location}{iplist};
4925 }
4926
4927 # tracking hash so we don't double-export A+PTR or AAAA+PTR records.
4928 my %recflags;
4929
4930 my $domsth = $dbh->prepare("SELECT domain_id,domain,status,changed FROM domains WHERE status=1");
4931 my $recsth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl,record_id,location ".
4932 "FROM records WHERE domain_id=? AND type < 65280"); # Just exclude all types relating to rDNS
4933 my $zonesth = $dbh->prepare("UPDATE domains SET changed='n' WHERE domain_id=?");
4934 $domsth->execute();
4935 while (my ($domid,$dom,$domstat,$changed) = $domsth->fetchrow_array) {
4936##fixme: need to find a way to block opening symlinked files without introducing a race.
4937# O_NOFOLLOW
4938# If pathname is a symbolic link, then the open fails. This is a FreeBSD extension, which was
4939# added to Linux in version 2.1.126. Symbolic links in earlier components of the pathname will
4940# still be followed.
4941# but that doesn't help other platforms. :/
4942 sysopen(ZONECACHE, "$config{exportcache}/$dom", O_RDWR|O_CREAT);
4943 flock(ZONECACHE, LOCK_EX);
4944 if ($changed || -s "$config{exportcache}/$dom" == 0) {
4945 $recsth->execute($domid);
4946 while (my ($host,$type,$val,$dist,$weight,$port,$ttl,$recid,$loc) = $recsth->fetchrow_array) {
4947 next if $recflags{$recid};
4948
4949 $loc = '' if !$loc; # de-nullify - just in case
4950##fixme: handle case of record-with-location-that-doesn't-exist better.
4951# note this currently fails safe (tested) - records with a location that
4952# doesn't exist will not be sent to any client
4953# $loc = '' if !$lochash->{$loc};
4954
4955##fixme: record validity timestamp. tinydns supports fiddling with timestamps.
4956# note $ttl must be set to 0 if we want to use tinydns's auto-expiring timestamps.
4957# timestamps are TAI64
4958# ~~ 2^62 + time()
4959 my $stamp = '';
4960
4961 # support tinydns' auto-TTL
4962 $ttl = '' if $ttl == '0';
4963
4964 # Spaces are evil.
4965 $host =~ s/^\s+//;
4966 $host =~ s/\s+$//;
4967 if ($typemap{$type} ne 'TXT') {
4968 # Leading or trailng spaces could be legit in TXT records.
4969 $val =~ s/^\s+//;
4970 $val =~ s/\s+$//;
4971 }
4972
4973 _printrec_tiny(*ZONECACHE, 'n', \%recflags,
4974 $dom, $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp)
4975 if *ZONECACHE;
4976
4977 # in case the zone shrunk, get rid of garbage at the end of the file.
4978 truncate(ZONECACHE, tell(ZONECACHE));
4979
4980 $recflags{$recid} = 1;
4981 } # while ($recsth)
4982 }
4983 # stream from cache, whether freshly created or existing
4984 print $datafile $_ while <ZONECACHE>;
4985 close ZONECACHE;
4986 # mark domain as unmodified
4987 $zonesth->execute($domid);
4988 } # while ($domsth)
4989
4990 my $revsth = $dbh->prepare("SELECT rdns_id,revnet,status,changed FROM revzones WHERE status=1 ".
4991 "ORDER BY masklen(revnet) DESC");
4992
4993# For reasons unknown, we can't sanely UNION these statements. Feh.
4994# Supposedly it should work though (note last 3 lines):
4995## PG manual
4996#UNION Clause
4997#
4998#The UNION clause has this general form:
4999#
5000# select_statement UNION [ ALL ] select_statement
5001#
5002#select_statement is any SELECT statement without an ORDER BY, LIMIT, FOR UPDATE, or FOR SHARE clause. (ORDER BY
5003#and LIMIT can be attached to a subexpression if it is enclosed in parentheses. Without parentheses, these
5004#clauses will be taken to apply to the result of the UNION, not to its right-hand input expression.)
5005 my $soasth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl,record_id,location ".
5006 "FROM records WHERE rdns_id=? AND type=6");
5007 $recsth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl,record_id,location ".
5008 "FROM records WHERE rdns_id=? AND not type=6 ".
5009 "ORDER BY masklen(CAST(val AS inet)) DESC, CAST(val AS inet)");
5010 $zonesth = $dbh->prepare("UPDATE revzones SET changed='n' WHERE rdns_id=?");
5011 $revsth->execute();
5012 while (my ($revid,$revzone,$revstat,$changed) = $revsth->fetchrow_array) {
5013##fixme: need to find a way to block opening symlinked files without introducing a race.
5014# O_NOFOLLOW
5015# If pathname is a symbolic link, then the open fails. This is a FreeBSD extension, which was
5016# added to Linux in version 2.1.126. Symbolic links in earlier components of the pathname will
5017# still be followed.
5018# but that doesn't help other platforms. :/
5019 my $tmpzone = NetAddr::IP->new($revzone);
5020 sysopen(ZONECACHE, "$config{exportcache}/".$tmpzone->network->addr, O_RDWR|O_CREAT);
5021 flock(ZONECACHE, LOCK_EX);
5022 if ($changed || -s "$config{exportcache}/".$tmpzone->network->addr == 0) {
5023 # need to fetch this separately since the rest of the records all (should) have real IPs in val
5024 $soasth->execute($revid);
5025 my (@zsoa) = $soasth->fetchrow_array();
5026 _printrec_tiny(*ZONECACHE,'y',\%recflags,$revzone,
5027 $zsoa[0],$zsoa[1],$zsoa[2],$zsoa[3],$zsoa[4],$zsoa[5],$zsoa[6],$zsoa[8],'');
5028
5029 $recsth->execute($revid);
5030 while (my ($host,$type,$val,$dist,$weight,$port,$ttl,$recid,$loc) = $recsth->fetchrow_array) {
5031 next if $recflags{$recid};
5032
5033 $loc = '' if !$loc; # de-nullify - just in case
5034##fixme: handle case of record-with-location-that-doesn't-exist better.
5035# note this currently fails safe (tested) - records with a location that
5036# doesn't exist will not be sent to any client
5037# $loc = '' if !$lochash->{$loc};
5038
5039##fixme: record validity timestamp. tinydns supports fiddling with timestamps.
5040# note $ttl must be set to 0 if we want to use tinydns's auto-expiring timestamps.
5041# timestamps are TAI64
5042# ~~ 2^62 + time()
5043 my $stamp = '';
5044
5045 # support tinydns' auto-TTL
5046 $ttl = '' if $ttl == '0';
5047
5048 _printrec_tiny(*ZONECACHE, 'y', \%recflags, $revzone,
5049 $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp)
5050 if *ZONECACHE;
5051
5052 # in case the zone shrunk, get rid of garbage at the end of the file.
5053 truncate(ZONECACHE, tell(ZONECACHE));
5054
5055 $recflags{$recid} = 1;
5056 } # while ($recsth)
5057 }
5058 # stream from cache, whether freshly created or existing
5059 print $datafile $_ while <ZONECACHE>;
5060 close ZONECACHE;
5061 # mark zone as unmodified
5062 $zonesth->execute($revid);
5063 } # while ($domsth)
5064
5065} # end __export_tiny()
5066
5067
5068# Utility sub for __export_tiny above
5069sub _printrec_tiny {
5070 my ($datafile,$revrec,$recflags,$zone,$host,$type,$val,$dist,$weight,$port,$ttl,$loc,$stamp) = @_;
5071
5072 ## Convert a bare number into an octal-coded pair of octets.
5073 # Take optional arg to indicate a decimal or hex input. Defaults to hex.
5074 sub octalize {
5075 my $tmp = shift;
5076 my $srctype = shift || 'h'; # default assumes hex string
5077 $tmp = sprintf "%0.4x", hex($tmp) if $srctype eq 'h'; # 0-pad hex to 4 digits
5078 $tmp = sprintf "%0.4x", $tmp if $srctype eq 'd'; # 0-pad decimal to 4 hex digits
5079 my @o = ($tmp =~ /^(..)(..)$/); # split into octets
5080 return sprintf "\\%0.3o\\%0.3o", hex($o[0]), hex($o[1]);;
5081 }
5082
5083## WARNING: This works to export even the whole Internet's worth of IP space...
5084## if you have the disk/RAM to handle the dataset, and you call this sub based on /16-sized chunks
5085## A /16 took ~3 seconds with a handful of separate records; adding a /8 pushed export time out to ~13m:40s
5086## 0/0 is estimated to take ~54 hours and ~256G of disk
5087## RAM usage depends on how many non-template entries you have in the set.
5088## This should probably be done on record addition rather than export; large blocks may need to be done in a
5089## forked process
5090 sub __publish_subnet {
5091 my $sub = shift;
5092 my $recflags = shift;
5093 my $hpat = shift;
5094 my $fh = shift;
5095 my $ttl = shift;
5096 my $stamp = shift;
5097 my $loc = shift;
5098 my $ptronly = shift || 0;
5099
5100 my $iplist = $sub->splitref(32);
5101 foreach (@$iplist) {
5102 my $ip = $_->addr;
5103 # make as if we split the non-octet-aligned block into octet-aligned blocks as with SOA
5104 next if $ip =~ /\.(0|255)$/;
5105 next if $$recflags{$ip};
5106 $$recflags{$ip}++;
5107 next if $hpat eq '%blank%'; # Allows blanking a subnet so no records are published.
5108 my $rec = $hpat; # start fresh with the template for each IP
5109 _template4_expand(\$rec, $ip);
5110 print $fh ($ptronly ? "^"._ZONE($_, 'ZONE.in-addr.arpa', 'r', '.').":$rec" : "=$rec:$ip").
5111 ":$ttl:$stamp:$loc\n";
5112 }
5113 }
5114
5115##fixme? append . to all host/val hostnames
5116 if ($typemap{$type} eq 'SOA') {
5117
5118 # host contains pri-ns:responsible
5119 # val is abused to contain refresh:retry:expire:minttl
5120##fixme: "manual" serial vs tinydns-autoserial
5121 # let's be explicit about abusing $host and $val
5122 my ($email, $primary) = (split /:/, $host)[0,1];
5123 my ($refresh, $retry, $expire, $min_ttl) = (split /:/, $val)[0,1,2,3];
5124 if ($revrec eq 'y') {
5125##fixme: have to publish SOA records for each v4 /24 in sub-/16, and each /16 in sub-/8
5126# what about v6?
5127# -> only need SOA for local chunks offset from reverse delegation boundaries, so v6 is fine
5128 $zone = NetAddr::IP->new($zone);
5129 # handle split-n-multiply SOA for off-octet (8 < mask < 16) or (16 < mask < 24) v4 zones
5130 if (!$zone->{isv6} && ($zone->masklen < 24) && ($zone->masklen % 8 != 0)) {
5131 foreach my $szone ($zone->split($zone->masklen + (8 - $zone->masklen % 8))) {
5132 $szone = _ZONE($szone, 'ZONE.in-addr.arpa', 'r', '.');
5133 print $datafile "Z$szone:$primary:$email"."::$refresh:$retry:$expire:$min_ttl:$ttl:$stamp:$loc\n";
5134 }
5135 return; # skips "default" bits just below
5136 }
5137 $zone = _ZONE($zone, 'ZONE', 'r', '.').($zone->{isv6} ? '.ip6.arpa' : '.in-addr.arpa');
5138 }
5139 print $datafile "Z$zone:$primary:$email"."::$refresh:$retry:$expire:$min_ttl:$ttl:$stamp:$loc\n";
5140
5141 } elsif ($typemap{$type} eq 'A') {
5142
5143 print $datafile "+$host:$val:$ttl:$stamp:$loc\n";
5144
5145 } elsif ($typemap{$type} eq 'NS') {
5146
5147 if ($revrec eq 'y') {
5148 $val = NetAddr::IP->new($val);
5149 # handle split-n-multiply SOA for off-octet (8 < mask < 16) or (16 < mask < 24) v4 zones
5150 if (!$val->{isv6} && ($val->masklen < 24) && ($val->masklen % 8 != 0)) {
5151 foreach my $szone ($val->split($val->masklen + (8 - $val->masklen % 8))) {
5152 my $szone2 = _ZONE($szone, 'ZONE.in-addr.arpa', 'r', '.');
5153 next if $$recflags{$szone2} && $$recflags{$szone2} > $val->masklen;
5154 print $datafile "\&$szone2"."::$host:$ttl:$stamp:$loc\n";
5155 $$recflags{$szone2} = $val->masklen;
5156 }
5157 } elsif ($val->{isv6} && ($val->masklen < 64) && ($val->masklen % 4 !=0)) {
5158 foreach my $szone ($val->split($val->masklen + (4 - $val->masklen % 4))) {
5159 my $szone2 = _ZONE($szone, 'ZONE.ip6.arpa', 'r', '.');
5160 next if $$recflags{$szone2} && $$recflags{$szone2} > $val->masklen;
5161 print $datafile "\&$szone2"."::$host:$ttl:$stamp:$loc\n";
5162 $$recflags{$szone2} = $val->masklen;
5163 }
5164 } else {
5165 my $val2 = _ZONE($val, 'ZONE', 'r', '.').($val->{isv6} ? '.ip6.arpa' : '.in-addr.arpa');
5166 print $datafile "\&$val2"."::$host:$ttl:$stamp:$loc\n";
5167 $$recflags{$val2} = $val->masklen;
5168 }
5169 } else {
5170 print $datafile "\&$host"."::$val:$ttl:$stamp:$loc\n";
5171 }
5172
5173 } elsif ($typemap{$type} eq 'AAAA') {
5174
5175 print $datafile ":$host:28:";
5176 my $altgrp = 0;
5177 my @altconv;
5178 # Split in to up to 8 groups of hex digits (allows for IPv6 :: 0-collapsing)
5179 foreach (split /:/, $val) {
5180 if (/^$/) {
5181 # flag blank entry; this is a series of 0's of (currently) unknown length
5182 $altconv[$altgrp++] = 's';
5183 } else {
5184 # call sub to convert 1-4 hex digits to 2 string-rep octal bytes
5185 $altconv[$altgrp++] = octalize($_)
5186 }
5187 }
5188 foreach my $octet (@altconv) {
5189 # if not 's', output
5190 print $datafile $octet unless $octet =~ /^s$/;
5191 # if 's', output (9-array length)x literal '\000\000'
5192 print $datafile '\000\000'x(9-$altgrp) if $octet =~ /^s$/;
5193 }
5194 print $datafile ":$ttl:$stamp:$loc\n";
5195
5196 } elsif ($typemap{$type} eq 'MX') {
5197
5198 print $datafile "\@$host"."::$val:$dist:$ttl:$stamp:$loc\n";
5199
5200 } elsif ($typemap{$type} eq 'TXT') {
5201
5202##fixme: split v-e-r-y long TXT strings? will need to do so for BIND export, at least
5203 if ($revrec eq 'n') {
5204 $val =~ s/:/\\072/g; # may need to replace other symbols
5205 print $datafile "'$host:$val:$ttl:$stamp:$loc\n";
5206 } else {
5207 $host =~ s/:/\\072/g; # may need to replace other symbols
5208 my $val2 = NetAddr::IP->new($val);
5209 print $datafile "'"._ZONE($val2, 'ZONE', 'r', '.').($val2->{isv6} ? '.ip6.arpa' : '.in-addr.arpa').
5210 ":$host:$ttl:$stamp:$loc\n";
5211 }
5212
5213# by-hand TXT
5214#:deepnet.cx:16:2v\075spf1\040a\040a\072bacon.deepnet.cx\040a\072home.deepnet.cx\040-all:3600
5215#@ IN TXT "v=spf1 a a:bacon.deepnet.cx a:home.deepnet.cx -all"
5216#'deepnet.cx:v=spf1 a a\072bacon.deepnet.cx a\072home.deepnet.cx -all:3600
5217
5218#txttest IN TXT "v=foo bar:bob kn;ob' \" !@#$%^&*()-=_+[]{}<>?"
5219#:txttest.deepnet.cx:16:\054v\075foo\040bar\072bob\040kn\073ob\047\040\042\040\041\100\043\044\045\136\046\052\050\051-\075\137\053\133\135\173\175\074\076\077:3600
5220
5221# very long TXT record as brought in by axfr-get
5222# note tinydns does not support >512-byte RR data, need axfr-dns (for TCP support) for that
5223# also note, tinydns does not seem to support <512, >256-byte RRdata from axfr-get either. :/
5224#:longtxt.deepnet.cx:16:
5225#\170this is a very long txt record. it is really long. long. very long. really very long. this is a very long txt record.
5226#\263 it is really long. long. very long. really very long. this is a very long txt record. it is really long. long. very long. really very long. this is a very long txt record.
5227#\351 it is really long. long. very long. really very long.this is a very long txt record. it is really long. long. very long. really very long. this is a very long txt record. it is really long. long. very long. really very long.
5228#:3600
5229
5230 } elsif ($typemap{$type} eq 'CNAME') {
5231
5232 if ($revrec eq 'n') {
5233 print $datafile "C$host:$val:$ttl:$stamp:$loc\n";
5234 } else {
5235 my $val2 = NetAddr::IP->new($val);
5236 print $datafile "C"._ZONE($val2, 'ZONE', 'r', '.').($val2->{isv6} ? '.ip6.arpa' : '.in-addr.arpa').
5237 ":$host:$ttl:$stamp:$loc\n";
5238 }
5239
5240 } elsif ($typemap{$type} eq 'SRV') {
5241
5242 # data is two-byte values for priority, weight, port, in that order,
5243 # followed by length/string data
5244
5245 print $datafile ":$host:33:".octalize($dist,'d').octalize($weight,'d').octalize($port,'d');
5246
5247 $val .= '.' if $val !~ /\.$/;
5248 foreach (split /\./, $val) {
5249 printf $datafile "\\%0.3o%s", length($_), $_;
5250 }
5251 print $datafile "\\000:$ttl:$stamp:$loc\n";
5252
5253 } elsif ($typemap{$type} eq 'RP') {
5254
5255 # RP consists of two mostly free-form strings.
5256 # The first is supposed to be an email address with @ replaced by . (as with the SOA contact)
5257 # The second is the "hostname" of a TXT record with more info.
5258 print $datafile ":$host:17:";
5259 my ($who,$what) = split /\s/, $val;
5260 foreach (split /\./, $who) {
5261 printf $datafile "\\%0.3o%s", length($_), $_;
5262 }
5263 print $datafile '\000';
5264 foreach (split /\./, $what) {
5265 printf $datafile "\\%0.3o%s", length($_), $_;
5266 }
5267 print $datafile "\\000:$ttl:$stamp:$loc\n";
5268
5269 } elsif ($typemap{$type} eq 'PTR') {
5270
5271 $zone = NetAddr::IP->new($zone);
5272 $$recflags{$val}++;
5273 if (!$zone->{isv6} && $zone->masklen > 24) {
5274 ($val) = ($val =~ /\.(\d+)$/);
5275 print $datafile "^$val."._ZONE($zone, 'ZONE', 'r', '.').'.in-addr.arpa'.
5276 ":$host:ttl:$stamp:$loc\n";
5277 } else {
5278 $val = NetAddr::IP->new($val);
5279 print $datafile "^".
5280 _ZONE($val, 'ZONE', 'r', '.').($val->{isv6} ? '.ip6.arpa' : '.in-addr.arpa').
5281 ":$host:$ttl:$stamp:$loc\n";
5282 }
5283
5284 } elsif ($type == 65280) { # A+PTR
5285
5286 $$recflags{$val}++;
5287 print $datafile "=$host:$val:$ttl:$stamp:$loc\n";
5288
5289 } elsif ($type == 65281) { # AAAA+PTR
5290
5291#$$recflags{$val}++;
5292 # treat these as two separate records. since tinydns doesn't have
5293 # a native combined type, we have to create them separately anyway.
5294 if ($revrec eq 'n') {
5295 $type = 28;
5296 } else {
5297 $type = 12;
5298 }
5299 _printrec_tiny($datafile,$revrec,$recflags,$zone,$host,$type,$val,$dist,$weight,$port,$ttl,$loc,$stamp);
5300##fixme: add a config flag to indicate use of the patch from http://www.fefe.de/dns/
5301# type 6 is for AAAA+PTR, type 3 is for AAAA
5302
5303 } elsif ($type == 65282) { # PTR template
5304
5305 # only useful for v4 with standard DNS software, since this expands all
5306 # IPs in $zone (or possibly $val?) with autogenerated records
5307 $val = NetAddr::IP->new($val);
5308 return if $val->{isv6};
5309
5310 if ($val->masklen <= 16) {
5311 foreach my $sub ($val->split(16)) {
5312 __publish_subnet($sub, $recflags, $host, $datafile, $ttl, $stamp, $loc, 1);
5313 }
5314 } else {
5315 __publish_subnet($val, $recflags, $host, $datafile, $ttl, $stamp, $loc, 1);
5316 }
5317
5318 } elsif ($type == 65283) { # A+PTR template
5319
5320 $val = NetAddr::IP->new($val);
5321 # Just In Case. An A+PTR should be impossible to add to a v6 revzone via API.
5322 return if $val->{isv6};
5323
5324 if ($val->masklen <= 16) {
5325 foreach my $sub ($val->split(16)) {
5326 __publish_subnet($sub, $recflags, $host, $datafile, $ttl, $stamp, $loc, 0);
5327 }
5328 } else {
5329 __publish_subnet($val, $recflags, $host, $datafile, $ttl, $stamp, $loc, 0);
5330 }
5331
5332 } elsif ($type == 65284) { # AAAA+PTR template
5333 # Stub for completeness. Could be exported to DNS software that supports
5334 # some degree of internal automagic in generic-record-creation
5335 # (eg http://search.cpan.org/dist/AllKnowingDNS/ )
5336
5337 } elsif ($type == 65285) { # Delegation
5338 # This is intended for reverse zones, but may prove useful in forward zones.
5339
5340 # All delegations need to create one or more NS records. The NS record handler knows what to do.
5341 _printrec_tiny($datafile,$revrec,$recflags,$zone,$host,$reverse_typemap{'NS'},
5342 $val,$dist,$weight,$port,$ttl,$loc,$stamp);
5343 if ($revrec eq 'y') {
5344 # In the case of a sub-/24 v4 reverse delegation, we need to generate CNAMEs
5345 # to redirect all of the individual IP lookups as well.
5346 # Not sure how this would actually resolve if a /24 or larger was delegated
5347 # one way, and a sub-/24 in that >=/24 was delegated elsewhere...
5348 my $dblock = NetAddr::IP->new($val);
5349 if (!$dblock->{isv6} && $dblock->masklen > 24) {
5350 my @subs = $dblock->split;
5351 foreach (@subs) {
5352 next if $$recflags{"$_"};
5353 my ($oct) = ($_->addr =~ /(\d+)$/);
5354 print $datafile "C"._ZONE($_, 'ZONE.in-addr.arpa', 'r', '.').":$oct.".
5355 _ZONE($dblock, 'ZONE.in-addr.arpa', 'r', '.').":$ttl:$stamp:$loc\n";
5356 $$recflags{"$_"}++;
5357 }
5358 }
5359 }
5360
5361##
5362## Uncommon types. These will need better UI support Any Day Sometime Maybe(TM).
5363##
5364
5365 } elsif ($type == 44) { # SSHFP
5366 my ($algo,$fpt,$fp) = split /\s+/, $val;
5367
5368 my $rec = sprintf ":$host:44:\\%0.3o\\%0.3o", $algo, $fpt;
5369 while (my ($byte) = ($fp =~ /^(..)/) ) {
5370 $rec .= sprintf "\\%0.3o", hex($byte);
5371 $fp =~ s/^..//;
5372 }
5373 print $datafile "$rec:$ttl:$stamp:$loc\n";
5374
5375 } else {
5376 # raw record. we don't know what's in here, so we ASS-U-ME the user has
5377 # put it in correctly, since either the user is messing directly with the
5378 # database, or the record was imported via AXFR
5379 # <split by char>
5380 # convert anything not a-zA-Z0-9.- to octal coding
5381
5382##fixme: add flag to export "unknown" record types - note we'll probably end up
5383# mangling them since they were written to the DB from Net::DNS::RR::<type>->rdatastr.
5384 #print $datafile ":$host:$type:$val:$ttl:$stamp:$loc\n";
5385
5386 } # record type if-else
5387
5388} # end _printrec_tiny()
5389
5390
5391## DNSDB::mailNotify()
5392# Sends notification mail to recipients regarding a DNSDB operation
5393sub mailNotify {
5394 my $self = shift;
5395 my $dbh = $self->{dbh};
5396 my ($subj,$message) = @_;
5397
5398 return if $config{mailhost} eq 'smtp.example.com'; # do nothing if still using default SMTP host.
5399
5400 my $mailer = Net::SMTP->new($config{mailhost}, Hello => "dnsadmin.$config{domain}");
5401
5402 my $mailsender = ($config{mailsender} ? $config{mailsender} : $config{mailnotify});
5403
5404 $mailer->mail($mailsender);
5405 $mailer->to($config{mailnotify});
5406 $mailer->data("From: \"$config{mailname}\" <$mailsender>\n",
5407 "To: <$config{mailnotify}>\n",
5408 "Date: ".strftime("%a, %d %b %Y %H:%M:%S %z",localtime)."\n",
5409 "Subject: $subj\n",
5410 "X-Mailer: DNSAdmin Notify v".sprintf("%.1d",$DNSDB::VERSION)."\n",
5411 "Organization: $config{orgname}\n",
5412 "\n$message\n");
5413 $mailer->quit;
5414}
5415
5416# shut Perl up
54171;
Note: See TracBrowser for help on using the repository browser.