source: trunk/DNSDB.pm@ 406

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

/trunk

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