source: trunk/DNSDB.pm@ 603

Last change on this file since 603 was 603, checked in by Kris Deugau, 10 years ago

/trunk

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