source: trunk/DNSDB.pm@ 611

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

/trunk

Move call to _check_hostname_form() into the individual validator subs;
it's easier to call it from those on the appropriate part(s) of the
record as needed rather than always calling it on just one part, and
then having to reproduce the per-record behaviours in _check_hostname_form().

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