source: trunk/DNSDB.pm@ 344

Last change on this file since 344 was 344, checked in by Kris Deugau, 12 years ago

/trunk

Work around bizarre SQL un-bug where:

SELECT <stuff> UNION (SELECT <stuff> ORDER BY ...)

not only didn't essentially glue the results of the two SELECTs together
serially (mildly confusing but a nonissue), but the ORDER BY was not obeyed
properly and resulted in records returned in the wrong relative order
overall (a problem when further processing required that relative ordering
of the records from the second SELECT).

This caused PTR template entries in reverse zones to not stack/overlay/cascade
properly on export, because larger netblocks returned first (against the ORDER
BY) prevented the smaller, more specific blocks from being expanded.

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