source: trunk/DNSDB.pm@ 450

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

/trunk

Fix caching glitch in reverse record export by simplifying the
caching mechanism so that new writes are always done to the cache,
then the cache is always streamed to the final target.

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