source: trunk/DNSDB.pm@ 350

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

/trunk

Tweak addRec() and updateRec() to allow "bad" hostnames so TXT records
can be used in reverse zones
Expand export of TXT records to properly export them in reverse zones

Thanks to Steve Atkins for pointing this out on the pgsql-general mailing list.

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