source: trunk/DNSDB.pm@ 280

Last change on this file since 280 was 279, checked in by Kris Deugau, 13 years ago

/trunk

Moving login SQL into DNSDB.pm complete. See #1
Checkpoint, moving logging into DNSDB.pm. See #1, #35.

Still requires a bit of commented-old-code cleanup

  • Property svn:keywords set to Date Rev Author Id
File size: 110.6 KB
RevLine 
[2]1# dns/trunk/DNSDB.pm
2# Abstraction functions for DNS administration
[262]3##
4# $Id: DNSDB.pm 279 2012-03-21 22:04:51Z kdeugau $
5# Copyright 2008-2011 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##
[2]20
21package DNSDB;
22
23use strict;
24use warnings;
25use Exporter;
26use DBI;
[33]27use Net::DNS;
[65]28use Crypt::PasswdMD5;
[198]29use Net::SMTP;
[226]30use NetAddr::IP qw(:lower);
[198]31use POSIX;
[2]32use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
33
[200]34$VERSION = 0.1; ##VERSION##
[2]35@ISA = qw(Exporter);
36@EXPORT_OK = qw(
[279]37 &initGlobals &login &initActionLog
[67]38 &initPermissions &getPermissions &changePermissions &comparePermissions
[112]39 &changeGroup
[128]40 &loadConfig &connectDB &finish
[276]41 &addDomain &delZone &domainName &revName &domainID &revID &addRDNS
[237]42 &getZoneCount &getZoneList
[22]43 &addGroup &delGroup &getChildren &groupName
[83]44 &addUser &updateUser &delUser &userFullName &userStatus &getUserData
[277]45 &getSOA &updateSOA &getRecLine &getDomRecs &getRecCount
[22]46 &addRec &updateRec &delRec
[225]47 &getTypelist
[254]48 &parentID
[117]49 &isParent
[275]50 &zoneStatus &importAXFR
[103]51 &export
[197]52 &mailNotify
[128]53 %typemap %reverse_typemap %config
[66]54 %permissions @permtypes $permlist
[2]55 );
56
57@EXPORT = (); # Export nothing by default.
58%EXPORT_TAGS = ( ALL => [qw(
[279]59 &initGlobals &login &initActionLog
[67]60 &initPermissions &getPermissions &changePermissions &comparePermissions
[112]61 &changeGroup
[128]62 &loadConfig &connectDB &finish
[276]63 &addDomain &delZone &domainName &revName &domainID &revID &addRDNS
[237]64 &getZoneCount &getZoneList
[22]65 &addGroup &delGroup &getChildren &groupName
[83]66 &addUser &updateUser &delUser &userFullName &userStatus &getUserData
[277]67 &getSOA &updateSOA &getRecLine &getDomRecs &getRecCount
[22]68 &addRec &updateRec &delRec
[225]69 &getTypelist
[254]70 &parentID
[117]71 &isParent
[275]72 &zoneStatus &importAXFR
[103]73 &export
[197]74 &mailNotify
[128]75 %typemap %reverse_typemap %config
[66]76 %permissions @permtypes $permlist
[2]77 )]
78 );
79
80our $group = 1;
81our $errstr = '';
82
83# Halfway sane defaults for SOA, TTL, etc.
[101]84# serial defaults to 0 for convenience.
85# value will be either YYYYMMDDNN for BIND/etc, or auto-internal for tinydns
[2]86our %def = qw (
87 contact hostmaster.DOMAIN
88 prins ns1.myserver.com
[101]89 serial 0
[2]90 soattl 86400
91 refresh 10800
92 retry 3600
93 expire 604800
94 minttl 10800
95 ttl 10800
96);
97
[66]98# Arguably defined wholly in the db, but little reason to change without supporting code changes
99our @permtypes = qw (
100 group_edit group_create group_delete
101 user_edit user_create user_delete
102 domain_edit domain_create domain_delete
103 record_edit record_create record_delete
104 self_edit admin
105);
106our $permlist = join(',',@permtypes);
107
[2]108# DNS record type map and reverse map.
109# loaded from the database, from http://www.iana.org/assignments/dns-parameters
110our %typemap;
111our %reverse_typemap;
112
[65]113our %permissions;
[55]114
[128]115# Prepopulate a basic config. Note some of these *will* cause errors if left unset.
[195]116# note: add appropriate stanzas in loadConfig to parse these
[128]117our %config = (
118 # Database connection info
119 dbname => 'dnsdb',
120 dbuser => 'dnsdb',
121 dbpass => 'secret',
122 dbhost => '',
123
124 # Email notice settings
125 mailhost => 'smtp.example.com',
[195]126 mailnotify => 'dnsdb@example.com', # to
127 mailsender => 'dnsdb@example.com', # from
[128]128 mailname => 'DNS Administration',
[195]129 orgname => 'Example Corp',
130 domain => 'example.com',
[128]131
132 # Template directory
133 templatedir => 'templates/',
134# fmeh. this is a real web path, not a logical internal one. hm..
[163]135# cssdir => 'templates/',
[216]136 sessiondir => 'session/',
[163]137
138 # Session params
[195]139 timeout => '3600', # 1 hour default
140
141 # Other miscellanea
142 log_failures => 1, # log all evarthing by default
[201]143 perpage => 15,
[128]144 );
145
[228]146## (Semi)private variables
[278]147
[228]148# Hash of functions for validating record types. Filled in initGlobals() since
149# it relies on visibility flags from the rectypes table in the DB
150my %validators;
[128]151
[278]152# Username, full name, ID - mainly for logging
153my %userdata;
[228]154
[278]155
[2]156##
[225]157## utility functions
[224]158# _rectable()
159# Takes default+rdns flags, returns appropriate table name
160sub _rectable {
161 my $def = shift;
162 my $rev = shift;
163
164 return 'records' if $def ne 'y';
165 return 'default_records' if $rev ne 'y';
166 return 'default_rev_records';
167} # end _rectable()
168
169# _recparent()
170# Takes default+rdns flags, returns appropriate parent-id column name
171sub _recparent {
172 my $def = shift;
173 my $rev = shift;
174
175 return 'group_id' if $def eq 'y';
176 return 'rdns_id' if $rev eq 'y';
177 return 'domain_id';
178} # end _recparent()
179
[226]180# Check an IP to be added in a reverse zone to see if it's really in the requested parent.
181# Takes a database handle, default and reverse flags, IP (fragment) to check, parent zone ID,
182# and a reference to a NetAddr::IP object (also used to pass back a fully-reconstructed IP for
183# database insertion)
184sub _ipparent {
185 my $dbh = shift;
186 my $defrec = shift;
187 my $revrec = shift;
188 my $val = shift;
189 my $id = shift;
190 my $addr = shift;
[224]191
[232]192 return if $revrec ne 'y'; # this sub not useful in forward zones
193
194 $$addr = NetAddr::IP->new($$val); #necessary?
195
[226]196 # subsub to split, reverse, and overlay an IP fragment on a netblock
197 sub __rev_overlay {
198 my $splitme = shift; # ':' or '.', m'lud?
199 my $parnet = shift;
200 my $val = shift;
201 my $addr = shift;
202
203 my $joinme = $splitme;
204 $splitme = '\.' if $splitme eq '.';
[232]205 my @working = reverse(split($splitme, $parnet->addr));
206 my @parts = reverse(split($splitme, $$val));
[226]207 for (my $i = 0; $i <= $#parts; $i++) {
208 $working[$i] = $parts[$i];
209 }
[232]210 my $checkme = NetAddr::IP->new(join($joinme, reverse(@working))) or return 0;
211 return 0 unless $checkme->within($parnet);
[226]212 $$addr = $checkme; # force "correct" IP to be recorded.
213 return 1;
214 }
215
216 my ($parstr) = $dbh->selectrow_array("SELECT revnet FROM revzones WHERE rdns_id = ?", undef, ($id));
217 my $parnet = NetAddr::IP->new($parstr);
218
219 # Fail early on v6-in-v4 or v4-in-v6. We're not accepting these ATM.
[232]220 return 0 if $parnet->addr =~ /\./ && $$val =~ /:/;
221 return 0 if $parnet->addr =~ /:/ && $$val =~ /\./;
[226]222
[234]223 if ($$addr && $$val =~ /^[\da-fA-F][\da-fA-F:]+[\da-fA-F]$/) {
[232]224 # the only case where NetAddr::IP's acceptance of legitimate IPs is "correct" is for a proper IPv6 address.
225 # the rest we have to restructure before fiddling. *sigh*
226 return 1 if $$addr->within($parnet);
227 } else {
228 # We don't have a complete IP in $$val (yet)
229 if ($parnet->addr =~ /:/) {
230 $$val =~ s/^:+//; # gotta strip'em all...
[226]231 return __rev_overlay(':', $parnet, $val, $addr);
232 }
[232]233 if ($parnet->addr =~ /\./) {
234 $$val =~ s/^\.+//;
235 return __rev_overlay('.', $parnet, $val, $addr);
236 }
[226]237 # should be impossible to get here...
238 }
239 # ... and here.
240 # can't do nuttin' in forward zones
241} # end _ipparent()
242
[232]243# A little different than _ipparent above; this tries to *find* the parent zone of a hostname
244sub _hostparent {
245 my $dbh = shift;
246 my $hname = shift;
247
248 my @hostbits = split /\./, $hname;
249 my $sth = $dbh->prepare("SELECT count(*),domain_id FROM domains WHERE domain = ? GROUP BY domain_id");
250 foreach (@hostbits) {
251 $sth->execute($hname);
252 my ($found, $parid) = $sth->fetchrow_array;
253 if ($found) {
254 return $parid;
255 }
256 $hname =~ s/^$_\.//;
257 }
258} # end _hostparent()
[228]259
[224]260##
[228]261## Record validation subs.
262##
263
264# A record
265sub _validate_1 {
[229]266 my $dbh = shift;
267
[230]268 my %args = @_;
[229]269
[230]270 return ('FAIL', 'Reverse zones cannot contain A records') if $args{revrec} eq 'y';
[229]271
272 # Coerce all hostnames to end in ".DOMAIN" for group/default records,
273 # or the intended parent domain for live records.
[230]274 my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
275 ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
[229]276
277 # Check IP is well-formed, and that it's a v4 address
[234]278 # Fail on "compact" IPv4 variants, because they are not consistent and predictable.
[232]279 return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv4 address")
[234]280 unless ${$args{val}} =~ /^\d+\.\d+\.\d+\.\d+$/;
281 return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv4 address")
[230]282 unless $args{addr} && !$args{addr}->{isv6};
[229]283 # coerce IP/value to normalized form for storage
[230]284 ${$args{val}} = $args{addr}->addr;
[229]285
[228]286 return ('OK','OK');
287} # done A record
288
289# NS record
290sub _validate_2 {
[230]291 my $dbh = shift;
292
293 my %args = @_;
294
295 # Coerce the hostname to "DOMAIN" for forward default records, "ZONE" for reverse default records,
296 # or the intended parent zone for live records.
297##fixme: allow for delegating <subdomain>.DOMAIN?
298 if ($args{revrec} eq 'y') {
299 my $pname = ($args{defrec} eq 'y' ? 'ZONE' : revName($dbh,$args{id}));
300 ${$args{host}} = $pname if ${$args{host}} ne $pname;
301 } else {
302 my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
303 ${$args{host}} = $pname if ${$args{host}} ne $pname;
304 }
305
306# Let this lie for now. Needs more magic.
307# # Check IP is well-formed, and that it's a v4 address
308# return ('FAIL',"A record must be a valid IPv4 address")
309# unless $addr && !$addr->{isv6};
310# # coerce IP/value to normalized form for storage
311# $$val = $addr->addr;
312
[228]313 return ('OK','OK');
314} # done NS record
315
316# CNAME record
317sub _validate_5 {
[230]318 my $dbh = shift;
319
320 my %args = @_;
321
322# Not really true, but these are only useful for delegating smaller-than-/24 IP blocks.
323# This is fundamentally a messy operation and should really just be taken care of by the
324# export process, not manual maintenance of the necessary records.
325 return ('FAIL', 'Reverse zones cannot contain CNAME records') if $args{revrec} eq 'y';
326
327 # Coerce all hostnames to end in ".DOMAIN" for group/default records,
328 # or the intended parent domain for live records.
329 my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
330 ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
331
[228]332 return ('OK','OK');
333} # done CNAME record
334
335# SOA record
336sub _validate_6 {
[230]337 # Smart monkeys won't stick their fingers in here; we have
338 # separate dedicated routines to deal with SOA records.
[228]339 return ('OK','OK');
340} # done SOA record
341
342# PTR record
343sub _validate_12 {
[232]344 my $dbh = shift;
345
346 my %args = @_;
347
348 if ($args{revrec} eq 'y') {
349 if ($args{defrec} eq 'n') {
350 return ('FAIL', "IP or IP fragment ${$args{val}} is not within ".revName($dbh, $args{id}))
351 unless _ipparent($dbh, $args{defrec}, $args{revrec}, $args{val}, $args{id}, \$args{addr});
352 ${$args{val}} = $args{addr}->addr;
353 } else {
[234]354 if (${$args{val}} =~ /\./) {
355 # looks like a v4 or fragment
356 if (${$args{val}} =~ /^\d+\.\d+\.\d+\.\d+$/) {
357 # woo! a complete IP! validate it and normalize, or fail.
358 $args{addr} = NetAddr::IP->new(${$args{val}})
359 or return ('FAIL', "IP/value looks like IPv4 but isn't valid");
360 ${$args{val}} = $args{addr}->addr;
361 } else {
[249]362 ${$args{val}} =~ s/^\.*/ZONE./ unless ${$args{val}} =~ /^ZONE/;
[234]363 }
364 } elsif (${$args{val}} =~ /[a-f:]/) {
365 # looks like a v6 or fragment
[251]366 ${$args{val}} =~ s/^:*/ZONE::/ if !$args{addr} && ${$args{val}} !~ /^ZONE/;
[234]367 if ($args{addr}) {
368 if ($args{addr}->addr =~ /^0/) {
[251]369 ${$args{val}} =~ s/^:*/ZONE::/ unless ${$args{val}} =~ /^ZONE/;
[234]370 } else {
371 ${$args{val}} = $args{addr}->addr;
372 }
373 }
374 } else {
375 # bare number (probably). These could be v4 or v6, so we'll
376 # expand on these on creation of a reverse zone.
[251]377 ${$args{val}} = "ZONE,${$args{val}}" unless ${$args{val}} =~ /^ZONE/;
[234]378 }
[249]379 ${$args{host}} =~ s/\.*$/\.$config{domain}/ if ${$args{host}} !~ /(?:$config{domain}|ADMINDOMAIN)$/;
[232]380 }
381
382# Multiple PTR records do NOT generally do what most people believe they do,
383# and tend to fail in the most awkward way possible. Check and warn.
384# We use $val instead of $addr->addr since we may be in a defrec, and may have eg "ZONE::42" or "ZONE.12"
[249]385
386 my @checkvals = (${$args{val}});
387 if (${$args{val}} =~ /,/) {
388 # push . and :: variants into checkvals if val has ,
389 my $tmp;
390 ($tmp = ${$args{val}}) =~ s/,/./;
391 push @checkvals, $tmp;
392 ($tmp = ${$args{val}}) =~ s/,/::/;
393 push @checkvals, $tmp;
394 }
395 my $pcsth = $dbh->prepare("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec})." WHERE val = ?");
396 foreach my $checkme (@checkvals) {
[272]397 if ($args{update}) {
398 # Record update. There should usually be an existing PTR (the record being updated)
399 my @ptrs = @{ $dbh->selectcol_arrayref("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}).
400 " WHERE val = ?", undef, ($checkme)) };
401 return ('WARN', "PTR record for $checkme already exists; adding another will probably not do what you want")
[273]402 if @ptrs && (!grep /^$args{update}$/, @ptrs);
[272]403 } else {
404 # New record. Always warn if a PTR exists
405 my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}).
406 " WHERE val = ?", undef, ($checkme));
407 return ('WARN', "PTR record for $checkme already exists; adding another will probably not do what you want")
408 if $ptrcount;
409 }
[249]410 }
[272]411
[232]412 } else {
413 # Not absolutely true but only useful if you hack things up for sub-/24 v4 reverse delegations
414 # Simpler to just create the reverse zone and grant access for the customer to edit it, and create direct
415 # PTR records on export
416 return ('FAIL',"Forward zones cannot contain PTR records");
417 }
418
[228]419 return ('OK','OK');
420} # done PTR record
421
422# MX record
423sub _validate_15 {
[230]424 my $dbh = shift;
425
426 my %args = @_;
427
428# Not absolutely true but WTF use is an MX record for a reverse zone?
429 return ('FAIL', 'Reverse zones cannot contain MX records') if $args{revrec} eq 'y';
430
431 return ('FAIL', "Distance is required for MX records") unless defined(${$args{dist}});
432 ${$args{dist}} =~ s/\s*//g;
433 return ('FAIL',"Distance is required, and must be numeric") unless ${$args{dist}} =~ /^\d+$/;
434
435 ${$args{fields}} = "distance,";
436 push @{$args{vallist}}, ${$args{dist}};
437
438 # Coerce all hostnames to end in ".DOMAIN" for group/default records,
439 # or the intended parent domain for live records.
440 my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
441 ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
442
[273]443# hmm.. this might work. except possibly for something pointing to "deadbeef.ca". <g>
444# if ($type == $reverse_typemap{NS} || $type == $reverse_typemap{MX} || $type == $reverse_typemap{SRV}) {
445# if ($val =~ /^\s*[\da-f:.]+\s*$/) {
446# return ('FAIL',"$val is not a valid IP address") if !$addr;
447# }
448# }
449
[228]450 return ('OK','OK');
451} # done MX record
452
453# TXT record
454sub _validate_16 {
[231]455 # Could arguably put a WARN return here on very long (>512) records
[228]456 return ('OK','OK');
457} # done TXT record
458
459# RP record
460sub _validate_17 {
[231]461 # Probably have to validate these some day
[228]462 return ('OK','OK');
463} # done RP record
464
465# AAAA record
466sub _validate_28 {
[229]467 my $dbh = shift;
468
[230]469 my %args = @_;
[229]470
[230]471 return ('FAIL', 'Reverse zones cannot contain AAAA records') if $args{revrec} eq 'y';
[229]472
473 # Coerce all hostnames to end in ".DOMAIN" for group/default records,
474 # or the intended parent domain for live records.
[230]475 my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
476 ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
[229]477
478 # Check IP is well-formed, and that it's a v6 address
[232]479 return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv6 address")
[230]480 unless $args{addr} && $args{addr}->{isv6};
[229]481 # coerce IP/value to normalized form for storage
[230]482 ${$args{val}} = $args{addr}->addr;
[229]483
[228]484 return ('OK','OK');
485} # done AAAA record
486
487# SRV record
488sub _validate_33 {
[231]489 my $dbh = shift;
490
491 my %args = @_;
492
493# Not absolutely true but WTF use is an SRV record for a reverse zone?
494 return ('FAIL', 'Reverse zones cannot contain SRV records') if $args{revrec} eq 'y';
495
496 return ('FAIL', "Distance is required for SRV records") unless defined(${$args{dist}});
497 ${$args{dist}} =~ s/\s*//g;
498 return ('FAIL',"Distance is required, and must be numeric") unless ${$args{dist}} =~ /^\d+$/;
499
500 return ('FAIL',"SRV records must begin with _service._protocol [${$args{host}}]")
501 unless ${$args{host}} =~ /^_[A-Za-z]+\._[A-Za-z]+\.[a-zA-Z0-9-]+/;
502 return ('FAIL',"Port and weight are required for SRV records")
503 unless defined(${$args{weight}}) && defined(${$args{port}});
504 ${$args{weight}} =~ s/\s*//g;
505 ${$args{port}} =~ s/\s*//g;
506
507 return ('FAIL',"Port and weight are required, and must be numeric")
508 unless ${$args{weight}} =~ /^\d+$/ && ${$args{port}} =~ /^\d+$/;
509
510 ${$args{fields}} = "distance,weight,port,";
511 push @{$args{vallist}}, (${$args{dist}}, ${$args{weight}}, ${$args{port}});
512
513 # Coerce all hostnames to end in ".DOMAIN" for group/default records,
514 # or the intended parent domain for live records.
515 my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
516 ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
517
[228]518 return ('OK','OK');
519} # done SRV record
520
521# Now the custom types
522
[232]523# A+PTR record. With a very little bit of magic we can also use this sub to validate AAAA+PTR. Whee!
[228]524sub _validate_65280 {
[232]525 my $dbh = shift;
526
527 my %args = @_;
528
529 my $code = 'OK';
530 my $msg = 'OK';
531
532 if ($args{defrec} eq 'n') {
533 # live record; revrec determines whether we validate the PTR or A component first.
[233]534
[232]535 if ($args{revrec} eq 'y') {
536 ($code,$msg) = _validate_12($dbh, %args);
537 return ($code,$msg) if $code eq 'FAIL';
538
539 # Check if the reqested domain exists. If not, coerce the type down to PTR and warn.
540 if (!(${$args{domid}} = _hostparent($dbh, ${$args{host}}))) {
[272]541 my $addmsg = "Record ".($args{update} ? 'updated' : 'added').
542 " as PTR instead of $typemap{${$args{rectype}}}; domain not found for ${$args{host}}";
[232]543 $msg .= "\n$addmsg" if $code eq 'WARN';
544 $msg = $addmsg if $code eq 'OK';
545 ${$args{rectype}} = $reverse_typemap{PTR};
546 return ('WARN', $msg);
547 }
548
[242]549 # Add domain ID to field list and values
550 ${$args{fields}} .= "domain_id,";
551 push @{$args{vallist}}, ${$args{domid}};
552
[232]553 } else {
554 ($code,$msg) = _validate_1($dbh, %args) if ${$args{rectype}} == 65280;
555 ($code,$msg) = _validate_28($dbh, %args) if ${$args{rectype}} == 65281;
556 return ($code,$msg) if $code eq 'FAIL';
557
558 # Check if the requested reverse zone exists - note, an IP fragment won't
559 # work here since we don't *know* which parent to put it in.
[233]560 # ${$args{val}} has been validated as a valid IP by now, in one of the above calls.
[232]561 my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?".
562 " ORDER BY masklen(revnet) DESC", undef, (${$args{val}}));
563 if (!$revid) {
[272]564 $msg = "Record ".($args{update} ? 'updated' : 'added')." as ".(${$args{rectype}} == 65280 ? 'A' : 'AAAA').
[232]565 " instead of $typemap{${$args{rectype}}}; reverse zone not found for ${$args{val}}";
566 ${$args{rectype}} = (${$args{rectype}} == 65280 ? $reverse_typemap{A} : $reverse_typemap{AAAA});
567 return ('WARN', $msg);
568 }
569
570 # Check for duplicate PTRs. Note we don't have to play games with $code and $msg, because
571 # by definition there can't be duplicate PTRs if the reverse zone isn't managed here.
[272]572 if ($args{update}) {
573 # Record update. There should usually be an existing PTR (the record being updated)
574 my @ptrs = @{ $dbh->selectcol_arrayref("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}).
575 " WHERE val = ?", undef, (${$args{val}})) };
[273]576 if (@ptrs && (!grep /^$args{update}$/, @ptrs)) {
[272]577 $msg = "PTR record for ${$args{val}} already exists; adding another will probably not do what you want";
578 $code = 'WARN';
579 }
580 } else {
581 # New record. Always warn if a PTR exists
582 my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}).
583 " WHERE val = ?", undef, (${$args{val}}));
584 $msg = "PTR record for ${$args{val}} already exists; adding another will probably not do what you want"
585 if $ptrcount;
586 $code = 'WARN' if $ptrcount;
[232]587 }
588
[272]589# my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}).
590# " WHERE val = ?", undef, ${$args{val}});
591# if ($ptrcount) {
592# my $curid = $dbh->selectrow_array("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}).
593# " WHERE val = ?
594# $msg = "PTR record for ${$args{val}} already exists; adding another will probably not do what you want";
595# $code = 'WARN';
596# }
597
[232]598 ${$args{fields}} .= "rdns_id,";
599 push @{$args{vallist}}, $revid;
600 }
601
[233]602 } else { # defrec eq 'y'
603 if ($args{revrec} eq 'y') {
604 ($code,$msg) = _validate_12($dbh, %args);
605 return ($code,$msg) if $code eq 'FAIL';
606 if (${$args{rectype}} == 65280) {
607 return ('FAIL',"A+PTR record must be a valid IPv4 address or fragment")
608 if ${$args{val}} =~ /:/;
[234]609 ${$args{val}} =~ s/^ZONE,/ZONE./; # Clean up after uncertain IP-fragment-type from _validate_12
[233]610 } elsif (${$args{rectype}} == 65281) {
611 return ('FAIL',"AAAA+PTR record must be a valid IPv6 address or fragment")
612 if ${$args{val}} =~ /\./;
[234]613 ${$args{val}} =~ s/^ZONE,/ZONE::/; # Clean up after uncertain IP-fragment-type from _validate_12
[233]614 }
615 } else {
616 # This is easy. I also can't see a real use-case for A/AAAA+PTR in *all* forward
617 # domains, since you wouldn't be able to substitute both domain and reverse zone
618 # sanely, and you'd end up with guaranteed over-replicated PTR records that would
619 # confuse the hell out of pretty much anything that uses them.
[234]620##fixme: make this a config flag?
[233]621 return ('FAIL', "$typemap{${$args{rectype}}} records not allowed in default domains");
622 }
[232]623 }
624
625 return ($code, $msg);
[228]626} # done A+PTR record
627
628# AAAA+PTR record
[232]629# A+PTR above has been magicked to handle AAAA+PTR as well.
[228]630sub _validate_65281 {
[232]631 return _validate_65280(@_);
[228]632} # done AAAA+PTR record
633
634# PTR template record
635sub _validate_65282 {
636 return ('OK','OK');
637} # done PTR template record
638
639# A+PTR template record
640sub _validate_65283 {
641 return ('OK','OK');
642} # done AAAA+PTR template record
643
644# AAAA+PTR template record
645sub _validate_65284 {
646 return ('OK','OK');
647} # done AAAA+PTR template record
648
649
[265]650##
651## Record data substitution subs
652##
[228]653
[265]654# Replace ZONE in hostname
655sub _ZONE {
656 my $zone = shift;
657 my $string = shift;
658 my $fr = shift || 'f'; # flag for forward/reverse order? nb: ignored for IP
659
660 my $prefix = $zone->network->addr; # Just In Case someone managed to slip in
661 # a funky subnet that had host bits set.
662
663 $string =~ s/,/./ if !$zone->{isv6};
664 $string =~ s/,/::/ if $zone->{isv6};
665
666# if ($zone->{isv6} && ($zone->masklen % 4) != 0) {
667# # grumpyfail, non-nibble zone. shouldn't happen
668# return;
669# }
670
671 # Subbing ZONE in the host. We need to properly ID the netblock range
672 # The subbed text should have "network IP with trailing zeros stripped" for
673 # blocks lined up on octet (for v4) or 16-bit (for v6) boundaries
674 # For blocks that do NOT line up on these boundaries, we tack on an extra "-0",
675 # then take the most significant octet or 16-bit chunk of the "broadcast" IP and
676 # append it after a double-dash
677 # ie:
678 # 8.0.0.0/6 -> 8.0.0.0 -> 11.255.255.255; sub should be 8--11
679 # 10.0.0.0/12 -> 10.0.0.0 -> 10.0.0.0 -> 10.15.255.255; sub should be 10-0--15
680 # 192.168.4.0/22 -> 192.168.4.0 -> 192.168.7.255; sub should be 192-168-4--7
681 # 192.168.0.8/29 -> 192.168.0.8 -> 192.168.0.15; sub should be 192-168-0-8--15
682 # Similar for v6
683 if (!$zone->{isv6}) {
684 my $bc = $zone->broadcast->addr;
685 if ($zone->masklen > 24) {
686 $bc =~ s/^\d+\.\d+\.\d+\.//;
687 } elsif ($zone->masklen > 16) {
688 $prefix =~ s/\.0$//;
689 $bc =~ s/^\d+\.\d+\.//;
690 } elsif ($zone->masklen > 8) {
691 $bc =~ s/^\d+\.//;
692 $prefix =~ s/\.0\.0$//;
693 } else {
694 $prefix =~ s/\.0\.0\.0$//;
695 }
696 if ($zone->masklen % 8) {
697 $bc =~ s/(\.255)+$//;
698 $prefix .= "--$bc"; #"--".zone->masklen; # use range or mask length?
699 }
700 } else {
701 if (($zone->masklen % 16) != 0) {
702 # Strip trailing :0 off $prefix, and :ffff off the broadcast IP
703 # Strip the leading 16-bit chunks off the front of the broadcast IP
704 # Append the remaining 16-bit chunk to the prefix after "--"
705 my $bc = $zone->broadcast->addr;
706 for (my $i=0; $i<(7-int($zone->masklen / 16)); $i++) {
707 $prefix =~ s/:0$//;
708 $bc =~ s/:ffff$//;
709 }
710 $bc =~ s/^([a-f0-9]+:)+//;
711 $prefix .= "--$bc";
712 } else {
713 # Strip off :0 from the end until we reach the netblock length.
714 for (my $i=0; $i<(8-$zone->masklen / 16); $i++) {
715 $prefix =~ s/:0$//;
716 }
717 }
718 }
719
720 # Replace . and : with -
721 # If flagged for reverse-order, split on . or :, reverse, and join with -
722 if ($fr eq 'f') {
723 $prefix =~ s/[:.]+/-/g;
724 } else {
725 $prefix = join('-', reverse(split(/[:.]/, $prefix)));
726 }
727 $string =~ s/ZONE/$prefix/;
728# }
729 return $string;
730} # done _ZONE
731
732
733
[228]734##
[2]735## Initialization and cleanup subs
736##
737
[55]738
[128]739## DNSDB::loadConfig()
740# Load the minimum required initial state (DB connect info) from a config file
741# Load misc other bits while we're at it.
742# Takes an optional basename and config path to look for
743# Populates the %config and %def hashes
744sub loadConfig {
745 my $basename = shift || ''; # this will work OK
[218]746##fixme $basename isn't doing what I think I thought I was trying to do.
[128]747
748 my $deferr = ''; # place to put error from default config file in case we can't find either one
749
[219]750 my $configroot = "/etc/dnsdb"; ##CFG_LEAF##
[128]751 $configroot = '' if $basename =~ m|^/|;
752 $basename .= ".conf" if $basename !~ /\.conf$/;
753 my $defconfig = "$configroot/dnsdb.conf";
754 my $siteconfig = "$configroot/$basename";
755
756 # System defaults
[131]757 __cfgload("$defconfig") or $deferr = $errstr;
[128]758
[131]759 # Per-site-ish settings.
760 if ($basename ne '.conf') {
761 unless (__cfgload("$siteconfig")) {
762 $errstr = ($deferr ? "Error opening default config file $defconfig: $deferr\n" : '').
[128]763 "Error opening site config file $siteconfig";
[131]764 return;
765 }
[128]766 }
767
[195]768 # Munge log_failures.
769 if ($config{log_failures} ne '1' && $config{log_failures} ne '0') {
770 # true/false, on/off, yes/no all valid.
771 if ($config{log_failures} =~ /^(?:true|false|on|off|yes|no)$/) {
772 if ($config{log_failures} =~ /(?:true|on|yes)/) {
773 $config{log_failures} = 1;
774 } else {
775 $config{log_failures} = 0;
776 }
777 } else {
778 $errstr = "Bad log_failures setting $config{log_failures}";
779 $config{log_failures} = 1;
780 # Bad setting shouldn't be fatal.
781 # return 2;
782 }
783 }
784
[128]785 # All good, clear the error and go home.
786 $errstr = '';
787 return 1;
788} # end loadConfig()
789
790
791## DNSDB::__cfgload()
792# Private sub to parse a config file and load it into %config
793# Takes a file handle on an open config file
794sub __cfgload {
795 $errstr = '';
796 my $cfgfile = shift;
[131]797
[128]798 if (open CFG, "<$cfgfile") {
799 while (<CFG>) {
800 chomp;
801 s/^\s*//;
802 next if /^#/;
803 next if /^$/;
804# hmm. more complex bits in this file might require [heading] headers, maybe?
805# $mode = $1 if /^\[(a-z)+]/;
806 # DB connect info
807 $config{dbname} = $1 if /^dbname\s*=\s*([a-z0-9_.-]+)/i;
808 $config{dbuser} = $1 if /^dbuser\s*=\s*([a-z0-9_.-]+)/i;
809 $config{dbpass} = $1 if /^dbpass\s*=\s*([a-z0-9_.-]+)/i;
810 $config{dbhost} = $1 if /^dbhost\s*=\s*([a-z0-9_.-]+)/i;
811 # SOA defaults
812 $def{contact} = $1 if /^contact\s*=\s*([a-z0-9_.-]+)/i;
813 $def{prins} = $1 if /^prins\s*=\s*([a-z0-9_.-]+)/i;
[201]814 $def{soattl} = $1 if /^soattl\s*=\s*(\d+)/i;
815 $def{refresh} = $1 if /^refresh\s*=\s*(\d+)/i;
816 $def{retry} = $1 if /^retry\s*=\s*(\d+)/i;
817 $def{expire} = $1 if /^expire\s*=\s*(\d+)/i;
818 $def{minttl} = $1 if /^minttl\s*=\s*(\d+)/i;
819 $def{ttl} = $1 if /^ttl\s*=\s*(\d+)/i;
[128]820 # Mail settings
821 $config{mailhost} = $1 if /^mailhost\s*=\s*([a-z0-9_.-]+)/i;
[198]822 $config{mailnotify} = $1 if /^mailnotify\s*=\s*([a-z0-9_.\@-]+)/i;
823 $config{mailsender} = $1 if /^mailsender\s*=\s*([a-z0-9_.\@-]+)/i;
[128]824 $config{mailname} = $1 if /^mailname\s*=\s*([a-z0-9\s_.-]+)/i;
[195]825 $config{orgname} = $1 if /^orgname\s*=\s*([a-z0-9\s_.,'-]+)/i;
826 $config{domain} = $1 if /^domain\s*=\s*([a-z0-9_.-]+)/i;
[163]827 # session - note this is fed directly to CGI::Session
[216]828 $config{timeout} = $1 if /^[tT][iI][mM][eE][oO][uU][tT]\s*=\s*(\d+[smhdwMy]?)/;
829 $config{sessiondir} = $1 if m{^sessiondir\s*=\s*([a-z0-9/_.-]+)}i;
[201]830 # misc
[195]831 $config{log_failures} = $1 if /^log_failures\s*=\s*([a-z01]+)/i;
[201]832 $config{perpage} = $1 if /^perpage\s*=\s*(\d+)/i;
[128]833 }
834 close CFG;
835 } else {
836 $errstr = $!;
837 return;
838 }
839 return 1;
840} # end __cfgload()
841
842
[2]843## DNSDB::connectDB()
844# Creates connection to DNS database.
845# Requires the database name, username, and password.
846# Returns a handle to the db.
847# Set up for a PostgreSQL db; could be any transactional DBMS with the
848# right changes.
849sub connectDB {
850 $errstr = '';
[15]851 my $dbname = shift;
852 my $user = shift;
853 my $pass = shift;
[2]854 my $dbh;
855 my $DSN = "DBI:Pg:dbname=$dbname";
856
857 my $host = shift;
858 $DSN .= ";host=$host" if $host;
859
860# Note that we want to autocommit by default, and we will turn it off locally as necessary.
861# We may not want to print gobbledygook errors; YMMV. Have to ponder that further.
862 $dbh = DBI->connect($DSN, $user, $pass, {
863 AutoCommit => 1,
864 PrintError => 0
865 })
866 or return (undef, $DBI::errstr) if(!$dbh);
867
[212]868##fixme: initialize the DB if we can't find the table (since, by definition, there's
869# nothing there if we can't select from it...)
870 my $tblsth = $dbh->prepare("SELECT count(*) FROM pg_catalog.pg_class WHERE relkind='r' AND relname=?");
871 my ($tblcount) = $dbh->selectrow_array($tblsth, undef, ('misc'));
872 return (undef,$DBI::errstr) if $dbh->err;
873
874#if ($tblcount == 0) {
875# # create tables one at a time, checking for each.
876# return (undef, "check table misc missing");
877#}
878
879
880# Return here if we can't select.
881# This should retrieve the dbversion key.
882 my $sth = $dbh->prepare("SELECT key,value FROM misc WHERE misc_id=1");
[2]883 $sth->execute();
884 return (undef,$DBI::errstr) if ($sth->err);
885
[212]886##fixme: do stuff to the DB on version mismatch
887# x.y series should upgrade on $DNSDB::VERSION > misc(key=>version)
888# DB should be downward-compatible; column defaults should give sane (if possibly
889# useless-and-needs-help) values in columns an older software stack doesn't know about.
890
[2]891# See if the select returned anything (or null data). This should
892# succeed if the select executed, but...
893 $sth->fetchrow();
894 return (undef,$DBI::errstr) if ($sth->err);
895
896 $sth->finish;
897
898# If we get here, we should be OK.
899 return ($dbh,"DB connection OK");
900} # end connectDB
901
902
903## DNSDB::finish()
904# Cleans up after database handles and so on.
905# Requires a database handle
906sub finish {
907 my $dbh = $_[0];
908 $dbh->disconnect;
909} # end finish
910
911
912## DNSDB::initGlobals()
913# Initialize global variables
914# NB: this does NOT include web-specific session variables!
915# Requires a database handle
916sub initGlobals {
917 my $dbh = shift;
918
[208]919# load record types from database
[228]920 my $sth = $dbh->prepare("SELECT val,name,stdflag FROM rectypes");
[2]921 $sth->execute;
[228]922 while (my ($recval,$recname,$stdflag) = $sth->fetchrow_array()) {
[2]923 $typemap{$recval} = $recname;
924 $reverse_typemap{$recname} = $recval;
[228]925 # now we fill the record validation function hash
926 if ($stdflag < 5) {
927 my $fn = "_validate_$recval";
928 $validators{$recval} = \&$fn;
929 } else {
930 my $fn = "sub { return ('FAIL','Type $recval ($recname) not supported'); }";
931 $validators{$recval} = eval $fn;
932 }
[2]933 }
934} # end initGlobals
935
936
[278]937## DNSDB::login()
938# Takes a database handle, username and password
939# Returns a userdata hash (UID, GID, username, fullname parts) if username exists
940# and password matches the one on file
941# Returns undef otherwise
942sub login {
943 my $dbh = shift;
944 my $user = shift;
945 my $pass = shift;
946
[279]947 my $userinfo = $dbh->selectrow_hashref("SELECT user_id,group_id,password,firstname,lastname FROM users WHERE username=?",
948 undef, ($user) );
949 return if !$userinfo;
[278]950
[279]951 if ($userinfo->{password} =~ m|^\$1\$([A-Za-z0-9/.]+)\$|) {
[278]952 # native passwords (crypt-md5)
[279]953 return if $userinfo->{password} ne unix_md5_crypt($pass,$1);
954 } elsif ($userinfo->{password} =~ /^[0-9a-f]{32}$/) {
[278]955 # VegaDNS import (hex-coded MD5)
[279]956 return if $userinfo->{password} ne md5_hex($pass);
[278]957 } else {
958 # plaintext (convenient now and then)
[279]959 return if $userinfo->{password} ne $pass;
[278]960 }
961
[279]962 return $userinfo;
[278]963} # end login()
964
965
[279]966## DNSDB::initActionLog()
967# Set up action logging. Takes a database handle and user ID
968# Sets some internal globals and Does The Right Thing to set up a logging channel.
969# This sets up _log() to spew out log entries to the defined channel without worrying
970# about having to open a file or a syslog channel
971##fixme Need to call _initActionLog_blah() for various logging channels, configured
972# via dnsdb.conf, in $config{log_channel} or something
973# See https://secure.deepnet.cx/trac/dnsadmin/ticket/21
974sub initActionLog {
975 my $dbh = shift;
976 my $uid = shift;
977
978 return if !$uid;
979
980 # snag user info for logging. there's got to be a way to not have to pass this back
981 # and forth from a caller, but web usage means no persistence we can rely on from
982 # the server side.
983 my ($username,$fullname) = $dbh->selectrow_array("SELECT username, firstname || ' ' || lastname".
984 " FROM users WHERE user_id=?", undef, ($uid));
985##fixme: errors are unpossible!
986
987 $userdata{username} = $username;
988 $userdata{userid} = $uid;
989 $userdata{fullname} = $fullname;
990
991 # convert to real check once we have other logging channels
992 # if ($config{log_channel} eq 'sql') {
993 # Open Log, Sez Me!
994 # }
995
996} # end initActionLog
997
998
[65]999## DNSDB::initPermissions()
1000# Set up permissions global
1001# Takes database handle and UID
1002sub initPermissions {
1003 my $dbh = shift;
1004 my $uid = shift;
1005
1006# %permissions = $(getPermissions($dbh,'user',$uid));
1007 getPermissions($dbh, 'user', $uid, \%permissions);
1008
1009} # end initPermissions()
1010
1011
1012## DNSDB::getPermissions()
1013# Get permissions from DB
1014# Requires DB handle, group or user flag, ID, and hashref.
1015sub getPermissions {
1016 my $dbh = shift;
1017 my $type = shift;
1018 my $id = shift;
1019 my $hash = shift;
1020
1021 my $sql = qq(
1022 SELECT
1023 p.admin,p.self_edit,
1024 p.group_create,p.group_edit,p.group_delete,
1025 p.user_create,p.user_edit,p.user_delete,
1026 p.domain_create,p.domain_edit,p.domain_delete,
1027 p.record_create,p.record_edit,p.record_delete
1028 FROM permissions p
1029 );
1030 if ($type eq 'group') {
1031 $sql .= qq(
1032 JOIN groups g ON g.permission_id=p.permission_id
1033 WHERE g.group_id=?
1034 );
1035 } else {
1036 $sql .= qq(
1037 JOIN users u ON u.permission_id=p.permission_id
1038 WHERE u.user_id=?
1039 );
1040 }
1041
1042 my $sth = $dbh->prepare($sql);
1043
1044 $sth->execute($id) or die "argh: ".$sth->errstr;
1045
1046# my $permref = $sth->fetchrow_hashref;
1047# return $permref;
1048# $hash = $permref;
1049# Eww. Need to learn how to forcibly drop a hashref onto an existing hash.
1050 ($hash->{admin},$hash->{self_edit},
1051 $hash->{group_create},$hash->{group_edit},$hash->{group_delete},
1052 $hash->{user_create},$hash->{user_edit},$hash->{user_delete},
1053 $hash->{domain_create},$hash->{domain_edit},$hash->{domain_delete},
1054 $hash->{record_create},$hash->{record_edit},$hash->{record_delete})
1055 = $sth->fetchrow_array;
1056
1057} # end getPermissions()
1058
1059
1060## DNSDB::changePermissions()
1061# Update an ACL entry
1062# Takes a db handle, type, owner-id, and hashref for the changed permissions.
1063sub changePermissions {
1064 my $dbh = shift;
1065 my $type = shift;
1066 my $id = shift;
1067 my $newperms = shift;
[87]1068 my $inherit = shift || 0;
[65]1069
[78]1070 my $failmsg = '';
[66]1071
[87]1072 # see if we're switching from inherited to custom. for bonus points,
1073 # snag the permid and parent permid anyway, since we'll need the permid
1074 # to set/alter custom perms, and both if we're switching from custom to
1075 # inherited.
1076 my $sth = $dbh->prepare("SELECT (u.permission_id=g.permission_id) AS was_inherited,u.permission_id,g.permission_id".
[65]1077 " FROM ".($type eq 'user' ? 'users' : 'groups')." u ".
[66]1078 " JOIN groups g ON u.".($type eq 'user' ? '' : 'parent_')."group_id=g.group_id ".
[65]1079 " WHERE u.".($type eq 'user' ? 'user' : 'group')."_id=?");
1080 $sth->execute($id);
1081
[87]1082 my ($wasinherited,$permid,$parpermid) = $sth->fetchrow_array;
[66]1083
[78]1084# hack phtoui
1085# group id 1 is "special" in that it's it's own parent (err... possibly.)
1086# may make its parent id 0 which doesn't exist, and as a bonus is Perl-false.
1087 $wasinherited = 0 if ($type eq 'group' && $id == 1);
1088
[66]1089 local $dbh->{AutoCommit} = 0;
1090 local $dbh->{RaiseError} = 1;
1091
1092 # Wrap all the SQL in a transaction
1093 eval {
[87]1094 if ($inherit) {
1095
1096 $dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='t',permission_id=? ".
1097 "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($parpermid, $id) );
1098 $dbh->do("DELETE FROM permissions WHERE permission_id=?", undef, ($permid) );
1099
1100 } else {
1101
1102 if ($wasinherited) { # munge new permission entry in if we're switching from inherited perms
[66]1103##fixme: need to add semirecursive bit to properly munge inherited permission ID on subgroups and users
[87]1104# ... if'n'when we have groups with fully inherited permissions.
1105 # SQL is coo
1106 $dbh->do("INSERT INTO permissions ($permlist,".($type eq 'user' ? 'user' : 'group')."_id) ".
1107 "SELECT $permlist,? FROM permissions WHERE permission_id=?", undef, ($id,$permid) );
1108 ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions ".
1109 "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($id) );
1110 $dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='f',permission_id=? ".
1111 "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($permid, $id) );
[66]1112 }
[78]1113
[87]1114 # and now set the permissions we were passed
1115 foreach (@permtypes) {
1116 if (defined ($newperms->{$_})) {
1117 $dbh->do("UPDATE permissions SET $_=? WHERE permission_id=?", undef, ($newperms->{$_},$permid) );
1118 }
1119 }
1120
1121 } # (inherited->)? custom
1122
[66]1123 $dbh->commit;
1124 }; # end eval
1125 if ($@) {
1126 my $msg = $@;
1127 eval { $dbh->rollback; };
[87]1128 return ('FAIL',"$failmsg: $msg ($permid)");
[66]1129 } else {
1130 return ('OK',$permid);
1131 }
1132
[65]1133} # end changePermissions()
1134
1135
[67]1136## DNSDB::comparePermissions()
1137# Compare two permission hashes
1138# Returns '>', '<', '=', '!'
1139sub comparePermissions {
1140 my $p1 = shift;
1141 my $p2 = shift;
1142
1143 my $retval = '='; # assume equality until proven otherwise
1144
1145 no warnings "uninitialized";
1146
1147 foreach (@permtypes) {
1148 next if $p1->{$_} == $p2->{$_}; # equal is good
1149 if ($p1->{$_} && !$p2->{$_}) {
1150 if ($retval eq '<') { # if we've already found an unequal pair where
1151 $retval = '!'; # $p2 has more access, and we now find a pair
1152 last; # where $p1 has more access, the overall access
1153 } # is neither greater or lesser, it's unequal.
1154 $retval = '>';
1155 }
1156 if (!$p1->{$_} && $p2->{$_}) {
1157 if ($retval eq '>') { # if we've already found an unequal pair where
1158 $retval = '!'; # $p1 has more access, and we now find a pair
1159 last; # where $p2 has more access, the overall access
1160 } # is neither greater or lesser, it's unequal.
1161 $retval = '<';
1162 }
1163 }
1164 return $retval;
1165} # end comparePermissions()
1166
1167
[112]1168## DNSDB::changeGroup()
1169# Change group ID of an entity
1170# Takes a database handle, entity type, entity ID, and new group ID
1171sub changeGroup {
1172 my $dbh = shift;
1173 my $type = shift;
1174 my $id = shift;
1175 my $newgrp = shift;
1176
1177##fixme: fail on not enough args
1178 #return ('FAIL', "Missing
1179
1180 if ($type eq 'domain') {
1181 $dbh->do("UPDATE domains SET group_id=? WHERE domain_id=?", undef, ($newgrp, $id))
1182 or return ('FAIL','Group change failed: '.$dbh->errstr);
1183 } elsif ($type eq 'user') {
1184 $dbh->do("UPDATE users SET group_id=? WHERE user_id=?", undef, ($newgrp, $id))
1185 or return ('FAIL','Group change failed: '.$dbh->errstr);
1186 } elsif ($type eq 'group') {
1187 $dbh->do("UPDATE groups SET parent_group_id=? WHERE group_id=?", undef, ($newgrp, $id))
1188 or return ('FAIL','Group change failed: '.$dbh->errstr);
1189 }
1190 return ('OK','OK');
1191} # end changeGroup()
1192
1193
[55]1194## DNSDB::_log()
1195# Log an action
1196# Internal sub
[256]1197# Takes a database handle and log entry hash containing at least:
1198# user_id, group_id, log entry
1199# and optionally one or more of:
1200# username/email, user full name, domain_id, rdns_id
[193]1201##fixme: convert to trailing hash for user info
1202# User info must contain a (user ID OR username)+fullname
[55]1203sub _log {
[190]1204 my $dbh = shift;
1205
[256]1206 my %args = @_;
1207
1208 $args{rdns_id} = 0 if !$args{rdns_id};
1209 $args{domain_id} = 0 if !$args{domain_id};
1210
[193]1211##fixme: need better way(s?) to snag userinfo for log entries. don't want to have
1212# to pass around yet *another* constant (already passing $dbh, shouldn't need to)
[279]1213# my $fullname;
1214# if (!$args{user_id}) {
1215# ($args{user_id}, $fullname) = $dbh->selectrow_array("SELECT user_id, firstname || ' ' || lastname FROM users".
1216# " WHERE username=?", undef, ($args{username}));
1217# }
1218# if (!$args{username}) {
1219# ($args{username}, $fullname) = $dbh->selectrow_array("SELECT username, firstname || ' ' || lastname FROM users".
1220# " WHERE user_id=?", undef, ($args{user_id}));
1221# }
1222# if (!$args{fullname}) {
1223# ($fullname) = $dbh->selectrow_array("SELECT firstname || ' ' || lastname FROM users".
1224# " WHERE user_id=?", undef, ($args{user_id}));
1225# }
1226#
1227# $args{name} = $fullname if !$args{name};
[193]1228
[190]1229##fixme: farm out the actual logging to different subs for file, syslog, internal, etc based on config
[279]1230# if ($config{log_channel} eq 'sql') {
1231 $dbh->do("INSERT INTO log (domain_id,rdns_id,group_id,entry,user_id,email,name) VALUES (?,?,?,?,?,?,?)",
[256]1232 undef,
[279]1233 ($args{domain_id}, $args{rdns_id}, $args{group_id}, $args{entry},
1234 $userdata{userid}, $userdata{username}, $userdata{fullname}) );
1235# } elsif ($config{log_channel} eq 'file') {
1236# } elsif ($config{log_channel} eq 'syslog') {
1237# }
[256]1238
[55]1239} # end _log
1240
1241
[2]1242##
1243## Processing subs
1244##
1245
1246## DNSDB::addDomain()
1247# Add a domain
[190]1248# Takes a database handle, domain name, numeric group, boolean(ish) state (active/inactive),
1249# and user info hash (for logging).
[2]1250# Returns a status code and message
1251sub addDomain {
1252 $errstr = '';
1253 my $dbh = shift;
1254 return ('FAIL',"Need database handle") if !$dbh;
1255 my $domain = shift;
[91]1256 return ('FAIL',"Domain must not be blank") if !$domain;
[2]1257 my $group = shift;
1258 return ('FAIL',"Need group") if !defined($group);
1259 my $state = shift;
1260 return ('FAIL',"Need domain status") if !defined($state);
1261
[190]1262 my %userinfo = @_; # remaining bits.
1263# user ID, username, user full name
1264
[116]1265 $state = 1 if $state =~ /^active$/;
1266 $state = 1 if $state =~ /^on$/;
1267 $state = 0 if $state =~ /^inactive$/;
1268 $state = 0 if $state =~ /^off$/;
1269
1270 return ('FAIL',"Invalid domain status") if $state !~ /^\d+$/;
1271
[190]1272 return ('FAIL', "Invalid characters in domain") if $domain !~ /^[a-zA-Z0-9_.-]+$/;
1273
[38]1274 my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
[3]1275 my $dom_id;
1276
[38]1277# quick check to start to see if we've already got one
1278 $sth->execute($domain);
1279 ($dom_id) = $sth->fetchrow_array;
1280
1281 return ('FAIL', "Domain already exists") if $dom_id;
1282
[2]1283 # Allow transactions, and raise an exception on errors so we can catch it later.
1284 # Use local to make sure these get "reset" properly on exiting this block
1285 local $dbh->{AutoCommit} = 0;
1286 local $dbh->{RaiseError} = 1;
1287
1288 # Wrap all the SQL in a transaction
1289 eval {
1290 # insert the domain...
[190]1291 $dbh->do("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)", undef, ($domain, $group, $state));
[2]1292
1293 # get the ID...
[190]1294 ($dom_id) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE domain=?", undef, ($domain));
[2]1295
[259]1296 _log($dbh, (domain_id => $dom_id, user_id => $userinfo{id}, group_id => $group, username => $userinfo{username},
1297 entry => "Added ".($state ? 'active' : 'inactive')." domain $domain"));
[190]1298
[2]1299 # ... and now we construct the standard records from the default set. NB: group should be variable.
[190]1300 my $sth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
1301 my $sth_in = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,distance,weight,port,ttl)".
1302 " VALUES ($dom_id,?,?,?,?,?,?,?)");
1303 $sth->execute($group);
[3]1304 while (my ($host,$type,$val,$dist,$weight,$port,$ttl) = $sth->fetchrow_array()) {
[2]1305 $host =~ s/DOMAIN/$domain/g;
[37]1306 $val =~ s/DOMAIN/$domain/g;
[3]1307 $sth_in->execute($host,$type,$val,$dist,$weight,$port,$ttl);
[190]1308 if ($typemap{$type} eq 'SOA') {
1309 my @tmp1 = split /:/, $host;
1310 my @tmp2 = split /:/, $val;
[258]1311 _log($dbh, (domain_id => $dom_id, user_id => $userinfo{id}, group_id => $group,
[259]1312 username => $userinfo{username}, entry =>
[190]1313 "[new $domain] Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ".
[257]1314 "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl"));
[190]1315 } else {
1316 my $logentry = "[new $domain] Added record '$host $typemap{$type}";
1317 $logentry .= " [distance $dist]" if $typemap{$type} eq 'MX';
1318 $logentry .= " [priority $dist] [weight $weight] [port $port]" if $typemap{$type} eq 'SRV';
[258]1319 _log($dbh, (domain_id => $dom_id, user_id => $userinfo{id}, group_id => $group,
[259]1320 username => $userinfo{username}, entry =>
[257]1321 $logentry." $val', TTL $ttl"));
[190]1322 }
[2]1323 }
1324
1325 # once we get here, we should have suceeded.
1326 $dbh->commit;
1327 }; # end eval
1328
1329 if ($@) {
1330 my $msg = $@;
1331 eval { $dbh->rollback; };
[193]1332 return ('FAIL',$msg);
[2]1333 } else {
[3]1334 return ('OK',$dom_id);
[2]1335 }
1336} # end addDomain
1337
1338
[274]1339## DNSDB::delZone()
1340# Delete a forward or reverse zone.
1341# Takes a database handle, zone ID, and forward/reverse flag.
[3]1342# for now, just delete the records, then the domain.
1343# later we may want to archive it in some way instead (status code 2, for example?)
[274]1344sub delZone {
[3]1345 my $dbh = shift;
[274]1346 my $zoneid = shift;
1347 my $revrec = shift;
[3]1348
1349 # Allow transactions, and raise an exception on errors so we can catch it later.
1350 # Use local to make sure these get "reset" properly on exiting this block
1351 local $dbh->{AutoCommit} = 0;
1352 local $dbh->{RaiseError} = 1;
1353
[23]1354 my $failmsg = '';
1355
[3]1356 # Wrap all the SQL in a transaction
1357 eval {
[274]1358 # Disentangle custom record types before removing the
1359 # ones that are only in the zone to be deleted
1360 if ($revrec eq 'n') {
1361 my $sth = $dbh->prepare("UPDATE records SET type=?,domain_id=0 WHERE domain_id=? AND type=?");
1362 $failmsg = "Failure converting multizone types to single-zone";
1363 $sth->execute($reverse_typemap{PTR}, $zoneid, 65280);
1364 $sth->execute($reverse_typemap{PTR}, $zoneid, 65281);
1365 $sth->execute(65282, $zoneid, 65283);
1366 $sth->execute(65282, $zoneid, 65284);
1367 $failmsg = "Failure removing domain records";
1368 $dbh->do("DELETE FROM records WHERE domain_id=?", undef, ($zoneid));
1369 $failmsg = "Failure removing domain";
1370 $dbh->do("DELETE FROM domains WHERE domain_id=?", undef, ($zoneid));
1371 } else {
1372 my $sth = $dbh->prepare("UPDATE records SET type=?,rdns_id=0 WHERE rdns_id=? AND type=?");
1373 $failmsg = "Failure converting multizone types to single-zone";
1374 $sth->execute($reverse_typemap{A}, $zoneid, 65280);
1375 $sth->execute($reverse_typemap{AAAA}, $zoneid, 65281);
1376# We don't have an "A template" or "AAAA template" type, although it might be useful for symmetry.
1377# $sth->execute(65285?, $zoneid, 65283);
1378# $sth->execute(65285?, $zoneid, 65284);
1379 $failmsg = "Failure removing reverse records";
1380 $dbh->do("DELETE FROM records WHERE rdns_id=?", undef, ($zoneid));
1381 $failmsg = "Failure removing reverse zone";
1382 $dbh->do("DELETE FROM revzones WHERE rdns_id=?", undef, ($zoneid));
1383 }
[3]1384
1385 # once we get here, we should have suceeded.
[23]1386 $dbh->commit;
[3]1387 }; # end eval
1388
1389 if ($@) {
1390 my $msg = $@;
1391 eval { $dbh->rollback; };
[23]1392 return ('FAIL',"$failmsg: $msg");
[3]1393 } else {
1394 return ('OK','OK');
1395 }
1396
[274]1397} # end delZone()
[3]1398
1399
[2]1400## DNSDB::domainName()
1401# Return the domain name based on a domain ID
1402# Takes a database handle and the domain ID
1403# Returns the domain name or undef on failure
1404sub domainName {
1405 $errstr = '';
1406 my $dbh = shift;
1407 my $domid = shift;
[91]1408 my ($domname) = $dbh->selectrow_array("SELECT domain FROM domains WHERE domain_id=?", undef, ($domid) );
[2]1409 $errstr = $DBI::errstr if !$domname;
1410 return $domname if $domname;
[91]1411} # end domainName()
[2]1412
1413
[224]1414## DNSDB::revName()
1415# Return the reverse zone name based on an rDNS ID
1416# Takes a database handle and the rDNS ID
1417# Returns the reverse zone name or undef on failure
1418sub revName {
1419 $errstr = '';
1420 my $dbh = shift;
1421 my $revid = shift;
1422 my ($revname) = $dbh->selectrow_array("SELECT revnet FROM revzones WHERE rdns_id=?", undef, ($revid) );
1423 $errstr = $DBI::errstr if !$revname;
1424 return $revname if $revname;
1425} # end revName()
1426
1427
[91]1428## DNSDB::domainID()
1429# Takes a database handle and domain name
1430# Returns the domain ID number
1431sub domainID {
1432 $errstr = '';
1433 my $dbh = shift;
1434 my $domain = shift;
1435 my ($domid) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE domain=?", undef, ($domain) );
1436 $errstr = $DBI::errstr if !$domid;
1437 return $domid if $domid;
1438} # end domainID()
1439
1440
[276]1441## DNSDB::revID()
1442# Takes a database handle and reverse zone name
1443# Returns the rDNS ID number
1444sub revID {
1445 $errstr = '';
1446 my $dbh = shift;
1447 my $revzone = shift;
1448 my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet=?", undef, ($revzone) );
1449 $errstr = $DBI::errstr if !$revid;
1450 return $revid if $revid;
1451} # end revID()
1452
1453
[260]1454## DNSDB::addRDNS
1455# Adds a reverse DNS zone
1456# Takes a database handle, CIDR block, numeric group, boolean(ish) state (active/inactive),
1457# and user info hash (for logging).
1458# Returns a status code and message
1459sub addRDNS {
1460 my $dbh = shift;
1461 my $zone = NetAddr::IP->new(shift);
1462 return ('FAIL',"Zone name must be a valid CIDR netblock") unless ($zone && $zone->addr !~ /^0/);
[270]1463 my $revpatt = shift; # construct a custom (A/AAAA+)? PTR template record
[260]1464 my $group = shift;
1465 my $state = shift;
1466
1467 my %userinfo = @_; # remaining bits.
1468# user ID, username, user full name
1469
1470 $state = 1 if $state =~ /^active$/;
1471 $state = 1 if $state =~ /^on$/;
1472 $state = 0 if $state =~ /^inactive$/;
1473 $state = 0 if $state =~ /^off$/;
1474
1475 return ('FAIL',"Invalid zone status") if $state !~ /^\d+$/;
1476
1477# quick check to start to see if we've already got one
1478 my ($rdns_id) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revzone=?", undef, ("$zone"));
1479
1480 return ('FAIL', "Zone already exists") if $rdns_id;
1481
1482 # Allow transactions, and raise an exception on errors so we can catch it later.
1483 # Use local to make sure these get "reset" properly on exiting this block
1484 local $dbh->{AutoCommit} = 0;
1485 local $dbh->{RaiseError} = 1;
1486
[264]1487 my $warnstr = '';
[270]1488 my $defttl = 3600; # 1 hour should be reasonable. And unless things have gone horribly
1489 # wrong, we should have a value to override this anyway.
[264]1490
[260]1491 # Wrap all the SQL in a transaction
1492 eval {
1493 # insert the domain...
1494 $dbh->do("INSERT INTO revzones (revnet,group_id,status) VALUES (?,?,?)", undef, ($zone, $group, $state));
1495
1496 # get the ID...
1497 ($rdns_id) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')");
1498
1499 _log($dbh, (rdns_id => $rdns_id, user_id => $userinfo{id}, group_id => $group, username => $userinfo{name},
1500 entry => "Added ".($state ? 'active' : 'inactive')." reverse zone $zone"));
1501
1502 # ... and now we construct the standard records from the default set. NB: group should be variable.
1503 my $sth = $dbh->prepare("SELECT host,type,val,ttl FROM default_rev_records WHERE group_id=?");
[269]1504 my $sth_in = $dbh->prepare("INSERT INTO records (rdns_id,domain_id,host,type,val,ttl)".
1505 " VALUES ($rdns_id,?,?,?,?,?)");
[260]1506 $sth->execute($group);
1507 while (my ($host,$type,$val,$ttl) = $sth->fetchrow_array()) {
[264]1508 # Silently skip v4/v6 mismatches. This is not an error, this is expected.
1509 if ($zone->{isv6}) {
1510 next if ($type == 65280 || $type == 65283);
1511 } else {
1512 next if ($type == 65281 || $type == 65284);
1513 }
[269]1514
[260]1515 $host =~ s/ADMINDOMAIN/$config{domain}/g;
[264]1516
[265]1517 # Check to make sure the IP stubs will fit in the zone. Under most usage failures here should be rare.
1518 # On failure, tack a note on to a warning string and continue without adding this record.
1519 # While we're at it, we substitute $zone for ZONE in the value.
1520 if ($val eq 'ZONE') {
[270]1521 next if $revpatt; # If we've got a pattern, we skip the default record version.
[269]1522##fixme? do we care if we have multiple whole-zone templates?
[265]1523 $val = $zone->network;
1524 } elsif ($val =~ /ZONE/) {
1525 my $tmpval = $val;
1526 $tmpval =~ s/ZONE//;
[269]1527 # Bend the rules and allow single-trailing-number PTR or PTR template records to be inserted
1528 # as either v4 or v6. May make this an off-by-default config flag
1529 # Note that the origin records that may trigger this **SHOULD** already have ZONE,\d
1530 if ($type == 12 || $type == 65282) {
1531 $tmpval =~ s/[,.]/::/ if ($tmpval =~ /^[,.]\d+$/ && $zone->{isv6});
1532 $tmpval =~ s/[,:]+/./ if ($tmpval =~ /^(?:,|::)\d+$/ && !$zone->{isv6});
1533 }
[265]1534 my $addr;
1535 if (_ipparent($dbh, 'n', 'y', \$tmpval, $rdns_id, \$addr)) {
1536 $val = $addr->addr;
1537 } else {
[269]1538 $warnstr .= "\nDefault record '$val $typemap{$type} $host' doesn't fit in $zone, skipping";
[264]1539 next;
1540 }
1541 }
1542
[265]1543 # Substitute $zone for ZONE in the hostname.
1544 $host = _ZONE($zone, $host);
1545
[269]1546 # Fill in the forward domain ID if we can find it, otherwise:
1547 # Coerce type down to PTR or PTR template if we can't
1548 my $domid = 0;
1549 if ($type >= 65280) {
1550 if (!($domid = _hostparent($dbh, $host))) {
1551 $warnstr .= "\nRecord added as PTR instead of $typemap{$type}; domain not found for $host";
1552 $type = $reverse_typemap{PTR};
1553 $domid = 0; # just to be explicit.
1554 }
1555 }
1556
1557 $sth_in->execute($domid,$host,$type,$val,$ttl);
1558
[260]1559 if ($typemap{$type} eq 'SOA') {
1560 my @tmp1 = split /:/, $host;
1561 my @tmp2 = split /:/, $val;
1562 _log($dbh, (rdns_id => $rdns_id, user_id => $userinfo{id}, group_id => $group,
1563 username => $userinfo{name}, entry =>
1564 "[new $zone] Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ".
1565 "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl"));
[270]1566 $defttl = $tmp2[3];
[260]1567 } else {
1568 my $logentry = "[new $zone] Added record '$host $typemap{$type}";
[269]1569 _log($dbh, (rdns_id => $rdns_id, domain_id => $domid, user_id => $userinfo{id}, group_id => $group,
[260]1570 username => $userinfo{name}, entry =>
1571 $logentry." $val', TTL $ttl"));
1572 }
1573 }
1574
[270]1575 # Generate record based on provided pattern.
1576 if ($revpatt) {
1577 my $host;
1578 my $type = ($zone->{isv6} ? 65284 : 65283);
1579 my $val = $zone->network;
[269]1580
[270]1581 # Substitute $zone for ZONE in the hostname.
1582 $host = _ZONE($zone, $revpatt);
1583
1584 my $domid = 0;
1585 if (!($domid = _hostparent($dbh, $host))) {
1586 $warnstr .= "\nDefault pattern added as PTR template instead of $typemap{$type}; domain not found for $host";
1587 $type = 65282;
1588 $domid = 0; # just to be explicit.
1589 }
1590
1591 $sth_in->execute($domid,$host,$type,$val,$defttl);
1592 }
1593
[264]1594 # If there are warnings (presumably about default records skipped for cause) log them
1595 _log($dbh, (rdns_id => $rdns_id, user_id => $userinfo{id}, group_id => $group,
[269]1596 username => $userinfo{name}, entry => "Warning(s) adding $zone:$warnstr"))
[264]1597 if $warnstr;
[269]1598
[260]1599 # once we get here, we should have suceeded.
1600 $dbh->commit;
1601 }; # end eval
1602
1603 if ($@) {
1604 my $msg = $@;
1605 eval { $dbh->rollback; };
1606 return ('FAIL',$msg);
1607 } else {
1608 return ('OK',$rdns_id);
1609 }
1610
1611} # end addRDNS()
1612
1613
[237]1614## DNSDB::getZoneCount
1615# Get count of zones in group or groups
1616# Takes a database handle and hash containing:
1617# - the "current" group
1618# - an array of "acceptable" groups
1619# - a flag for forward/reverse zones
1620# - Optionally accept a "starts with" and/or "contains" filter argument
1621# Returns an integer count of the resulting zone list.
1622sub getZoneCount {
1623 my $dbh = shift;
1624
1625 my %args = @_;
1626
1627 my @filterargs;
[239]1628 $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
1629 push @filterargs, "^$args{startwith}" if $args{startwith};
1630 $args{filter} =~ s/\./\[\.\]/g if $args{filter}; # only match literal dots, usually in reverse zones
[237]1631 push @filterargs, $args{filter} if $args{filter};
1632
1633 my $sql;
1634 # Not as compact, and fix-me-twice if the common bits get wrong, but much easier to read
1635 if ($args{revrec} eq 'n') {
1636 $sql = "SELECT count(*) FROM domains".
1637 " WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
1638 ($args{startwith} ? " AND domain ~* ?" : '').
1639 ($args{filter} ? " AND domain ~* ?" : '');
1640 } else {
1641 $sql = "SELECT count(*) FROM revzones".
1642 " WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
1643 ($args{startwith} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '').
1644 ($args{filter} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '');
1645 }
1646 my ($count) = $dbh->selectrow_array($sql, undef, @filterargs);
1647 return $count;
1648} # end getZoneCount()
1649
1650
1651## DNSDB::getZoneList()
1652# Get a list of zones in the specified group(s)
1653# Takes the same arguments as getZoneCount() above
1654# Returns a reference to an array of hashrefs suitable for feeding to HTML::Template
1655sub getZoneList {
1656 my $dbh = shift;
1657
1658 my %args = @_;
1659
1660 my @zonelist;
1661
1662 $args{sortorder} = 'ASC' if !grep $args{sortorder}, ('ASC','DESC');
[239]1663 $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
[237]1664
1665 my @filterargs;
[239]1666 $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
1667 push @filterargs, "^$args{startwith}" if $args{startwith};
1668 $args{filter} =~ s/\./\[\.\]/g if $args{filter}; # only match literal dots, usually in reverse zones
[237]1669 push @filterargs, $args{filter} if $args{filter};
1670
1671 my $sql;
1672 # Not as compact, and fix-me-twice if the common bits get wrong, but much easier to read
1673 if ($args{revrec} eq 'n') {
1674 $args{sortby} = 'domain' if !grep $args{sortby}, ('revnet','group','status');
1675 $sql = "SELECT domain_id,domain,status,groups.group_name AS group FROM domains".
1676 " INNER JOIN groups ON domains.group_id=groups.group_id".
1677 " WHERE domains.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
1678 ($args{startwith} ? " AND domain ~* ?" : '').
1679 ($args{filter} ? " AND domain ~* ?" : '');
1680 } else {
[239]1681##fixme: arguably startwith here is irrelevant. depends on the UI though.
[237]1682 $args{sortby} = 'revnet' if !grep $args{sortby}, ('domain','group','status');
1683 $sql = "SELECT rdns_id,revnet,status,groups.group_name AS group FROM revzones".
1684 " INNER JOIN groups ON revzones.group_id=groups.group_id".
1685 " WHERE revzones.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
1686 ($args{startwith} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '').
1687 ($args{filter} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '');
1688 }
1689 # A common tail.
[239]1690 $sql .= " ORDER BY ".($args{sortby} eq 'group' ? 'groups.group_name' : $args{sortby})." $args{sortorder} ".
1691 ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage}".
[237]1692 " OFFSET ".$args{offset}*$config{perpage});
1693 my $sth = $dbh->prepare($sql);
1694 $sth->execute(@filterargs);
1695 my $rownum = 0;
1696
1697 while (my @data = $sth->fetchrow_array) {
1698 my %row;
1699 $row{domainid} = $data[0];
1700 $row{domain} = $data[1];
[239]1701 $row{status} = $data[2];
[237]1702 $row{group} = $data[3];
1703 push @zonelist, \%row;
1704 }
1705
1706 return \@zonelist;
1707} # end getZoneList()
1708
1709
[18]1710## DNSDB::addGroup()
1711# Add a group
[66]1712# Takes a database handle, group name, parent group, hashref for permissions,
1713# and optional template-vs-cloneme flag
[18]1714# Returns a status code and message
1715sub addGroup {
1716 $errstr = '';
1717 my $dbh = shift;
[20]1718 my $groupname = shift;
1719 my $pargroup = shift;
[66]1720 my $permissions = shift;
[18]1721
[66]1722 # 0 indicates "custom", hardcoded.
[18]1723 # Any other value clones that group's default records, if it exists.
[66]1724 my $inherit = shift || 0;
1725##fixme: need a flag to indicate clone records or <?> ?
[18]1726
1727 # Allow transactions, and raise an exception on errors so we can catch it later.
1728 # Use local to make sure these get "reset" properly on exiting this block
1729 local $dbh->{AutoCommit} = 0;
1730 local $dbh->{RaiseError} = 1;
1731
[38]1732 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE group_name=?");
1733 my $group_id;
1734
1735# quick check to start to see if we've already got one
1736 $sth->execute($groupname);
1737 ($group_id) = $sth->fetchrow_array;
1738
1739 return ('FAIL', "Group already exists") if $group_id;
1740
[18]1741 # Wrap all the SQL in a transaction
1742 eval {
[38]1743 $sth = $dbh->prepare("INSERT INTO groups (parent_group_id,group_name) VALUES (?,?)");
[20]1744 $sth->execute($pargroup,$groupname);
[18]1745
[255]1746 my ($groupid) = $dbh->selectrow_array("SELECT group_id FROM groups WHERE group_name=?", undef, ($groupname));
[18]1747
[66]1748# Permissions
1749 if ($inherit) {
1750 } else {
1751 my @permvals;
1752 foreach (@permtypes) {
1753 if (!defined ($permissions->{$_})) {
1754 push @permvals, 0;
1755 } else {
1756 push @permvals, $permissions->{$_};
1757 }
1758 }
1759
1760 $sth = $dbh->prepare("INSERT INTO permissions (group_id,$permlist) values (?".',?'x($#permtypes+1).")");
1761 $sth->execute($groupid,@permvals);
1762
1763 $sth = $dbh->prepare("SELECT permission_id FROM permissions WHERE group_id=?");
1764 $sth->execute($groupid);
1765 my ($permid) = $sth->fetchrow_array();
1766
1767 $dbh->do("UPDATE groups SET permission_id=$permid WHERE group_id=$groupid");
1768 } # done permission fiddling
1769
1770# Default records
[255]1771 my $sthf = $dbh->prepare("INSERT INTO default_records (group_id,host,type,val,distance,weight,port,ttl) ".
[20]1772 "VALUES ($groupid,?,?,?,?,?,?,?)");
[255]1773 my $sthr = $dbh->prepare("INSERT INTO default_rev_records (group_id,host,type,val,ttl) ".
1774 "VALUES ($groupid,?,?,?,?)");
[66]1775 if ($inherit) {
[87]1776 # Duplicate records from parent. Actually relying on inherited records feels
1777 # very fragile, and it would be problematic to roll over at a later time.
[18]1778 my $sth2 = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
[87]1779 $sth2->execute($pargroup);
[18]1780 while (my @clonedata = $sth2->fetchrow_array) {
[255]1781 $sthf->execute(@clonedata);
[18]1782 }
[255]1783 # And now the reverse records
1784 $sth2 = $dbh->prepare("SELECT group_id,host,type,val,ttl FROM default_rev_records WHERE group_id=?");
1785 $sth2->execute($pargroup);
1786 while (my @clonedata = $sth2->fetchrow_array) {
1787 $sthr->execute(@clonedata);
1788 }
[18]1789 } else {
[66]1790##fixme: Hardcoding is Bad, mmmmkaaaay?
[18]1791 # reasonable basic defaults for SOA, MX, NS, and minimal hosting
1792 # could load from a config file, but somewhere along the line we need hardcoded bits.
[255]1793 $sthf->execute('ns1.example.com:hostmaster.example.com', 6, '10800:3600:604800:10800', 0, 0, 0, 86400);
1794 $sthf->execute('DOMAIN', 1, '192.168.4.2', 0, 0, 0, 7200);
1795 $sthf->execute('DOMAIN', 15, 'mx.example.com', 10, 0, 0, 7200);
1796 $sthf->execute('DOMAIN', 2, 'ns1.example.com', 0, 0, 0, 7200);
1797 $sthf->execute('DOMAIN', 2, 'ns2.example.com', 0, 0, 0, 7200);
1798 $sthf->execute('www.DOMAIN', 5, 'DOMAIN', 0, 0, 0, 7200);
1799 # reasonable basic defaults for generic reverse zone. Same as initial SQL tabledef.
1800 $sthr->execute('hostmaster.ADMINDOMAIN:ns1.ADMINDOMAIN', 6, '10800:3600:604800:10800', 86400);
1801 $sthr->execute('unused-%r.ADMINDOMAIN', 65283, 'ZONE', 3600);
[18]1802 }
1803
1804 # once we get here, we should have suceeded.
1805 $dbh->commit;
1806 }; # end eval
1807
1808 if ($@) {
1809 my $msg = $@;
1810 eval { $dbh->rollback; };
1811 return ('FAIL',$msg);
1812 } else {
1813 return ('OK','OK');
1814 }
1815
1816} # end addGroup()
1817
1818
[22]1819## DNSDB::delGroup()
1820# Delete a group.
1821# Takes a group ID
1822# Returns a status code and message
1823sub delGroup {
1824 my $dbh = shift;
1825 my $groupid = shift;
1826
1827 # Allow transactions, and raise an exception on errors so we can catch it later.
1828 # Use local to make sure these get "reset" properly on exiting this block
1829 local $dbh->{AutoCommit} = 0;
1830 local $dbh->{RaiseError} = 1;
1831
1832##fixme: locate "knowable" error conditions and deal with them before the eval
[23]1833# ... or inside, whatever.
[22]1834# -> domains still exist in group
1835# -> ...
[23]1836 my $failmsg = '';
[22]1837
1838 # Wrap all the SQL in a transaction
1839 eval {
[23]1840 my $sth = $dbh->prepare("SELECT count(*) FROM domains WHERE group_id=?");
[22]1841 $sth->execute($groupid);
[23]1842 my ($domcnt) = $sth->fetchrow_array;
1843 $failmsg = "Can't remove group ".groupName($dbh,$groupid);
1844 die "$domcnt domains still in group\n" if $domcnt;
1845
1846 $sth = $dbh->prepare("delete from default_records where group_id=?");
1847 $failmsg = "Failed to delete default records for ".groupName($dbh,$groupid);
1848 $sth->execute($groupid);
[22]1849 $sth = $dbh->prepare("delete from groups where group_id=?");
[23]1850 $failmsg = "Failed to remove group ".groupName($dbh,$groupid);
[22]1851 $sth->execute($groupid);
1852
1853 # once we get here, we should have suceeded.
1854 $dbh->commit;
1855 }; # end eval
1856
1857 if ($@) {
1858 my $msg = $@;
1859 eval { $dbh->rollback; };
[23]1860 return ('FAIL',"$failmsg: $msg");
[22]1861 } else {
1862 return ('OK','OK');
1863 }
1864} # end delGroup()
1865
1866
[19]1867## DNSDB::getChildren()
1868# Get a list of all groups whose parent^n is group <n>
[24]1869# Takes a database handle, group ID, reference to an array to put the group IDs in,
1870# and an optional flag to return only immediate children or all children-of-children
1871# default to returning all children
[19]1872# Calls itself
1873sub getChildren {
1874 $errstr = '';
1875 my $dbh = shift;
[20]1876 my $rootgroup = shift;
1877 my $groupdest = shift;
[24]1878 my $immed = shift || 'all';
[19]1879
1880 # special break for default group; otherwise we get stuck.
[20]1881 if ($rootgroup == 1) {
[19]1882 # by definition, group 1 is the Root Of All Groups
[24]1883 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE NOT (group_id=1)".
1884 ($immed ne 'all' ? " AND parent_group_id=1" : ''));
[19]1885 $sth->execute;
1886 while (my @this = $sth->fetchrow_array) {
[20]1887 push @$groupdest, @this;
[19]1888 }
1889 } else {
1890 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE parent_group_id=?");
[20]1891 $sth->execute($rootgroup);
[19]1892 return if $sth->rows == 0;
[20]1893 my @grouplist;
1894 while (my ($group) = $sth->fetchrow_array) {
1895 push @$groupdest, $group;
[24]1896 getChildren($dbh,$group,$groupdest) if $immed eq 'all';
[19]1897 }
1898 }
1899} # end getChildren()
1900
1901
[20]1902## DNSDB::groupName()
[17]1903# Return the group name based on a group ID
1904# Takes a database handle and the group ID
1905# Returns the group name or undef on failure
[20]1906sub groupName {
[13]1907 $errstr = '';
1908 my $dbh = shift;
[20]1909 my $groupid = shift;
1910 my $sth = $dbh->prepare("SELECT group_name FROM groups WHERE group_id=?");
1911 $sth->execute($groupid);
1912 my ($groupname) = $sth->fetchrow_array();
1913 $errstr = $DBI::errstr if !$groupname;
1914 return $groupname if $groupname;
1915} # end groupName
[13]1916
1917
[118]1918## DNSDB::groupID()
1919# Return the group ID based on the group name
1920# Takes a database handle and the group name
1921# Returns the group ID or undef on failure
1922sub groupID {
1923 $errstr = '';
1924 my $dbh = shift;
1925 my $group = shift;
1926 my ($grpid) = $dbh->selectrow_array("SELECT group_id FROM groups WHERE group=?", undef, ($group) );
1927 $errstr = $DBI::errstr if !$grpid;
1928 return $grpid if $grpid;
1929} # end groupID()
1930
1931
[24]1932## DNSDB::addUser()
[87]1933# Add a user.
1934# Takes a DB handle, username, group ID, password, state (active/inactive).
1935# Optionally accepts:
1936# user type (user/admin) - defaults to user
1937# permissions string - defaults to inherit from group
1938# three valid forms:
1939# i - Inherit permissions
1940# c:<user_id> - Clone permissions from <user_id>
1941# C:<permission list> - Set these specific permissions
1942# first name - defaults to username
1943# last name - defaults to blank
1944# phone - defaults to blank (could put other data within column def)
[90]1945# Returns (OK,<uid>) on success, (FAIL,<message>) on failure
[24]1946sub addUser {
1947 $errstr = '';
1948 my $dbh = shift;
1949 my $username = shift;
1950 my $group = shift;
1951 my $pass = shift;
1952 my $state = shift;
[25]1953
[90]1954 return ('FAIL', "Missing one or more required entries") if !defined($state);
1955 return ('FAIL', "Username must not be blank") if !$username;
[87]1956
[25]1957 my $type = shift || 'u'; # create limited users by default - fwiw, not sure yet how this will interact with ACLs
1958
[67]1959 my $permstring = shift || 'i'; # default is to inhert permissions from group
1960
[25]1961 my $fname = shift || $username;
[24]1962 my $lname = shift || '';
[25]1963 my $phone = shift || ''; # not going format-check
[24]1964
[38]1965 my $sth = $dbh->prepare("SELECT user_id FROM users WHERE username=?");
[24]1966 my $user_id;
1967
[38]1968# quick check to start to see if we've already got one
1969 $sth->execute($username);
1970 ($user_id) = $sth->fetchrow_array;
1971
1972 return ('FAIL', "User already exists") if $user_id;
1973
[24]1974 # Allow transactions, and raise an exception on errors so we can catch it later.
1975 # Use local to make sure these get "reset" properly on exiting this block
1976 local $dbh->{AutoCommit} = 0;
1977 local $dbh->{RaiseError} = 1;
1978
[94]1979 my $failmsg = '';
1980
[24]1981 # Wrap all the SQL in a transaction
1982 eval {
[87]1983 # insert the user... note we set inherited perms by default since
1984 # it's simple and cleans up some other bits of state
1985 my $sth = $dbh->prepare("INSERT INTO users ".
1986 "(group_id,username,password,firstname,lastname,phone,type,status,permission_id,inherit_perm) ".
1987 "VALUES (?,?,?,?,?,?,?,?,(SELECT permission_id FROM permissions WHERE group_id=?),'t')");
1988 $sth->execute($group,$username,unix_md5_crypt($pass),$fname,$lname,$phone,$type,$state,$group);
[24]1989
1990 # get the ID...
[94]1991 ($user_id) = $dbh->selectrow_array("SELECT currval('users_user_id_seq')");
[24]1992
[87]1993# Permissions! Gotta set'em all!
1994 die "Invalid permission string $permstring"
1995 if $permstring !~ /^(?:
1996 i # inherit
1997 |c:\d+ # clone
1998 # custom. no, the leading , is not a typo
[111]1999 |C:(?:,(?:group|user|domain|record|self)_(?:edit|create|delete))*
[87]2000 )$/x;
2001# bleh. I'd call another function to do my dirty work, but we're in the middle of a transaction already.
2002 if ($permstring ne 'i') {
2003 # for cloned or custom permissions, we have to create a new permissions entry.
2004 my $clonesrc = $group;
2005 if ($permstring =~ /^c:(\d+)/) { $clonesrc = $1; }
2006 $dbh->do("INSERT INTO permissions ($permlist,user_id) ".
2007 "SELECT $permlist,? FROM permissions WHERE permission_id=".
2008 "(SELECT permission_id FROM permissions WHERE ".($permstring =~ /^c:/ ? 'user' : 'group')."_id=?)",
2009 undef, ($user_id,$clonesrc) );
2010 $dbh->do("UPDATE users SET permission_id=".
2011 "(SELECT permission_id FROM permissions WHERE user_id=?) ".
2012 "WHERE user_id=?", undef, ($user_id, $user_id) );
2013 }
2014 if ($permstring =~ /^C:/) {
2015 # finally for custom permissions, we set the passed-in permissions (and unset
2016 # any that might have been brought in by the clone operation above)
2017 my ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions WHERE user_id=?",
2018 undef, ($user_id) );
2019 foreach (@permtypes) {
2020 if ($permstring =~ /,$_/) {
2021 $dbh->do("UPDATE permissions SET $_='t' WHERE permission_id=?", undef, ($permid) );
2022 } else {
2023 $dbh->do("UPDATE permissions SET $_='f' WHERE permission_id=?", undef, ($permid) );
2024 }
2025 }
2026 }
2027
2028 $dbh->do("UPDATE users SET inherit_perm='n' WHERE user_id=?", undef, ($user_id) );
2029
[25]2030##fixme: add another table to hold name/email for log table?
2031
[24]2032 # once we get here, we should have suceeded.
2033 $dbh->commit;
2034 }; # end eval
2035
2036 if ($@) {
2037 my $msg = $@;
2038 eval { $dbh->rollback; };
[87]2039 return ('FAIL',$msg." $failmsg");
[24]2040 } else {
2041 return ('OK',$user_id);
2042 }
2043} # end addUser
2044
2045
[55]2046## DNSDB::checkUser()
2047# Check user/pass combo on login
2048sub checkUser {
2049 my $dbh = shift;
2050 my $user = shift;
[56]2051 my $inpass = shift;
[55]2052
2053 my $sth = $dbh->prepare("SELECT user_id,group_id,password,firstname,lastname FROM users WHERE username=?");
2054 $sth->execute($user);
2055 my ($uid,$gid,$pass,$fname,$lname) = $sth->fetchrow_array;
2056 my $loginfailed = 1 if !defined($uid);
2057
2058 if ($pass =~ m|^\$1\$([A-Za-z0-9/.]+)\$|) {
[56]2059 $loginfailed = 1 if $pass ne unix_md5_crypt($inpass,$1);
[55]2060 } else {
[56]2061 $loginfailed = 1 if $pass ne $inpass;
[55]2062 }
2063
2064 # nnnngggg
2065 return ($uid, $gid);
2066} # end checkUser
2067
2068
[83]2069## DNSDB:: updateUser()
[90]2070# Update general data about user
[83]2071sub updateUser {
2072 my $dbh = shift;
[118]2073
2074##fixme: tweak calling convention so that we can update any given bit of data
[83]2075 my $uid = shift;
2076 my $username = shift;
2077 my $group = shift;
2078 my $pass = shift;
2079 my $state = shift;
[87]2080 my $type = shift || 'u';
[83]2081 my $fname = shift || $username;
2082 my $lname = shift || '';
2083 my $phone = shift || ''; # not going format-check
2084
2085 my $failmsg = '';
2086
2087 # Allow transactions, and raise an exception on errors so we can catch it later.
2088 # Use local to make sure these get "reset" properly on exiting this block
2089 local $dbh->{AutoCommit} = 0;
2090 local $dbh->{RaiseError} = 1;
2091
2092 my $sth;
2093
2094 # Password can be left blank; if so we assume there's one on file.
2095 # Actual blank passwords are bad, mm'kay?
2096 if (!$pass) {
2097 $sth = $dbh->prepare("SELECT password FROM users WHERE user_id=?");
2098 $sth->execute($uid);
2099 ($pass) = $sth->fetchrow_array;
2100 } else {
2101 $pass = unix_md5_crypt($pass);
2102 }
2103
2104 eval {
2105 my $sth = $dbh->prepare(q(
2106 UPDATE users
2107 SET username=?, password=?, firstname=?, lastname=?, phone=?, type=?, status=?
2108 WHERE user_id=?
2109 )
2110 );
2111 $sth->execute($username, $pass, $fname, $lname, $phone, $type, $state, $uid);
2112 $dbh->commit;
2113 };
2114 if ($@) {
2115 my $msg = $@;
2116 eval { $dbh->rollback; };
2117 return ('FAIL',"$failmsg: $msg");
2118 } else {
2119 return ('OK','OK');
2120 }
2121} # end updateUser()
2122
2123
[24]2124## DNSDB::delUser()
2125#
2126sub delUser {
[25]2127 my $dbh = shift;
2128 return ('FAIL',"Need database handle") if !$dbh;
2129 my $userid = shift;
2130 return ('FAIL',"Missing userid") if !defined($userid);
2131
2132 my $sth = $dbh->prepare("delete from users where user_id=?");
2133 $sth->execute($userid);
2134
2135 return ('FAIL',"Couldn't remove user: ".$sth->errstr) if $sth->err;
2136
2137 return ('OK','OK');
2138
[24]2139} # end delUser
2140
2141
[25]2142## DNSDB::userFullName()
2143# Return a pretty string!
2144# Takes a user_id and optional printf-ish string to indicate which pieces where:
2145# %u for the username
2146# %f for the first name
2147# %l for the last name
2148# All other text in the passed string will be left as-is.
2149##fixme: need a "smart" option too, so that missing/null/blank first/last names don't give funky output
2150sub userFullName {
2151 $errstr = '';
2152 my $dbh = shift;
2153 my $userid = shift;
2154 my $fullformat = shift || '%f %l (%u)';
2155 my $sth = $dbh->prepare("select username,firstname,lastname from users where user_id=?");
2156 $sth->execute($userid);
2157 my ($uname,$fname,$lname) = $sth->fetchrow_array();
2158 $errstr = $DBI::errstr if !$uname;
2159
2160 $fullformat =~ s/\%u/$uname/g;
2161 $fullformat =~ s/\%f/$fname/g;
2162 $fullformat =~ s/\%l/$lname/g;
2163
2164 return $fullformat;
2165} # end userFullName
2166
2167
[51]2168## DNSDB::userStatus()
2169# Sets and/or returns a user's status
2170# Takes a database handle, user ID and optionally a status argument
2171# Returns undef on errors.
2172sub userStatus {
2173 my $dbh = shift;
2174 my $id = shift;
2175 my $newstatus = shift;
2176
2177 return undef if $id !~ /^\d+$/;
2178
2179 my $sth;
2180
2181# ooo, fun! let's see what we were passed for status
2182 if ($newstatus) {
2183 $sth = $dbh->prepare("update users set status=? where user_id=?");
2184 # ass-u-me caller knows what's going on in full
2185 if ($newstatus =~ /^[01]$/) { # only two valid for now.
2186 $sth->execute($newstatus,$id);
2187 } elsif ($newstatus =~ /^usero(?:n|ff)$/) {
2188 $sth->execute(($newstatus eq 'useron' ? 1 : 0),$id);
2189 }
2190 }
2191
2192 $sth = $dbh->prepare("select status from users where user_id=?");
2193 $sth->execute($id);
2194 my ($status) = $sth->fetchrow_array;
2195 return $status;
2196} # end userStatus()
2197
2198
[83]2199## DNSDB::getUserData()
2200# Get misc user data for display
2201sub getUserData {
2202 my $dbh = shift;
2203 my $uid = shift;
2204
2205 my $sth = $dbh->prepare("SELECT group_id,username,firstname,lastname,phone,type,status,inherit_perm ".
2206 "FROM users WHERE user_id=?");
2207 $sth->execute($uid);
2208 return $sth->fetchrow_hashref();
2209
2210} # end getUserData()
2211
2212
[2]2213## DNSDB::getSOA()
2214# Return all suitable fields from an SOA record in separate elements of a hash
[224]2215# Takes a database handle, default/live flag, domain/reverse flag, and parent ID
[2]2216sub getSOA {
2217 $errstr = '';
2218 my $dbh = shift;
2219 my $def = shift;
[224]2220 my $rev = shift;
[2]2221 my $id = shift;
2222 my %ret;
2223
[224]2224 # (ab)use distance and weight columns to store SOA data? can't for default_rev_records...
2225 # - should really attach serial to the zone parent somewhere
[101]2226
[224]2227 my $sql = "SELECT record_id,host,val,ttl from "._rectable($def,$rev).
2228 " WHERE "._recparent($def,$rev)." = ? AND type=$reverse_typemap{SOA}";
2229
[2]2230 my $sth = $dbh->prepare($sql);
[101]2231 $sth->execute($id);
[246]2232##fixme: stick a flag somewhere if the record doesn't exist. by the API, this is an impossible case, but...
[2]2233
[224]2234 my ($recid,$host,$val,$ttl) = $sth->fetchrow_array() or return;
[202]2235 my ($contact,$prins) = split /:/, $host;
[2]2236 my ($refresh,$retry,$expire,$minttl) = split /:/, $val;
2237
2238 $ret{recid} = $recid;
2239 $ret{ttl} = $ttl;
[224]2240# $ret{serial} = $serial; # ca't use distance for serial with default_rev_records
[2]2241 $ret{prins} = $prins;
2242 $ret{contact} = $contact;
2243 $ret{refresh} = $refresh;
2244 $ret{retry} = $retry;
2245 $ret{expire} = $expire;
2246 $ret{minttl} = $minttl;
2247
2248 return %ret;
2249} # end getSOA()
2250
2251
[246]2252## DNSDB::updateSOA()
2253# Update the specified SOA record
2254# Takes a database handle, default/live flag, forward/reverse flag, and SOA data hash
[277]2255# Returns a two-element list with a result code and message
[246]2256sub updateSOA {
2257 my $dbh = shift;
2258 my $defrec = shift;
[248]2259 my $revrec = shift;
[246]2260
2261 my %soa = @_;
2262
[277]2263 my %oldsoa = getSOA($dbh, $defrec, $revrec, $soa{recid});
2264
2265 # Allow transactions, and raise an exception on errors so we can catch it later.
2266 # Use local to make sure these get "reset" properly on exiting this block
2267 local $dbh->{AutoCommit} = 0;
2268 local $dbh->{RaiseError} = 1;
2269
2270 my $msg;
2271
2272 eval {
[246]2273##fixme: data validation: make sure {recid} is really the SOA for {parent}
[277]2274 my $sql = "UPDATE "._rectable($defrec, $revrec)." SET host=?, val=?, ttl=? WHERE record_id=? AND type=6";
2275 $dbh->do($sql, undef, ("$soa{contact}:$soa{prins}", "$soa{refresh}:$soa{retry}:$soa{expire}:$soa{minttl}",
2276 $soa{ttl}, $soa{recid}) );
[246]2277
[277]2278 $msg = "Updated ".($defrec eq 'y' ? 'default ' : '')."SOA for ".
2279 ($defrec eq 'y' ? groupName($dbh, $soa{recid}) :
2280 ($revrec eq 'n' ? domainName($dbh, $soa{recid}) : revName($dbh, $soa{recid}) ) ).
2281 ": (ns $oldsoa{prins}, contact $oldsoa{contact}, refresh $oldsoa{refresh},".
2282 " retry $oldsoa{retry}, expire $oldsoa{expire}, minTTL $oldsoa{minttl}, TTL $oldsoa{ttl}) to ".
2283 "(ns $soa{prins}, contact $soa{contact}, refresh $soa{refresh},".
2284 " retry $soa{retry}, expire $soa{expire}, minTTL $soa{minttl}, TTL $soa{ttl})";
2285
2286# _log($dbh, (rdns_id => $rdns_id, user_id => $userinfo{id}, group_id => $group,
2287# username => $userinfo{name}, entry => $msg) );
2288
2289 $dbh->commit;
2290 };
2291 if ($@) {
2292 $msg = $@;
2293 eval { $dbh->rollback; };
2294 return ('FAIL',$msg);
2295 } else {
2296 return ('OK', $msg);
2297 }
[246]2298} # end updateSOA()
2299
2300
[2]2301## DNSDB::getRecLine()
2302# Return all data fields for a zone record in separate elements of a hash
[243]2303# Takes a database handle, default/live flag, forward/reverse flag, and record ID
[2]2304sub getRecLine {
2305 $errstr = '';
2306 my $dbh = shift;
[243]2307 my $defrec = shift;
2308 my $revrec = shift;
[2]2309 my $id = shift;
2310
[243]2311 my $sql = "SELECT record_id,host,type,val,ttl".($revrec eq 'n' ? ',distance,weight,port' : '').
2312 (($defrec eq 'y') ? ',group_id FROM ' : ',domain_id,rdns_id FROM ').
2313 _rectable($defrec,$revrec)." WHERE record_id=?";
[123]2314 my $ret = $dbh->selectrow_hashref($sql, undef, ($id) );
[2]2315
[90]2316 if ($dbh->err) {
[2]2317 $errstr = $DBI::errstr;
2318 return undef;
2319 }
2320
[123]2321 if (!$ret) {
2322 $errstr = "No such record";
2323 return undef;
2324 }
2325
[243]2326 # explicitly set a parent id
2327 if ($defrec eq 'y') {
2328 $ret->{parid} = $ret->{group_id};
2329 } else {
2330 $ret->{parid} = (($revrec eq 'n') ? $ret->{domain_id} : $ret->{rdns_id});
2331 # and a secondary if we have a custom type that lives in both a forward and reverse zone
2332 $ret->{secid} = (($revrec eq 'y') ? $ret->{domain_id} : $ret->{rdns_id}) if $ret->{type} > 65279;
2333 }
[90]2334
2335 return $ret;
[2]2336}
2337
2338
2339##fixme: should use above (getRecLine()) to get lines for below?
2340## DNSDB::getDomRecs()
2341# Return records for a domain
2342# Takes a database handle, default/live flag, group/domain ID, start,
2343# number of records, sort field, and sort order
2344# Returns a reference to an array of hashes
2345sub getDomRecs {
2346 $errstr = '';
2347 my $dbh = shift;
[224]2348 my $def = shift;
2349 my $rev = shift;
[2]2350 my $id = shift;
[4]2351 my $nrecs = shift || 'all';
2352 my $nstart = shift || 0;
[2]2353
[4]2354## for order, need to map input to column names
2355 my $order = shift || 'host';
[72]2356 my $direction = shift || 'ASC';
[4]2357
[135]2358 my $filter = shift || '';
2359
[224]2360 my $sql = "SELECT r.record_id,r.host,r.type,r.val,r.ttl";
2361 $sql .= ",r.distance,r.weight,r.port" if $rev eq 'n';
2362 $sql .= " FROM "._rectable($def,$rev)." r ";
[104]2363 $sql .= "INNER JOIN rectypes t ON r.type=t.val "; # for sorting by type alphabetically
[224]2364 $sql .= "WHERE "._recparent($def,$rev)." = ?";
[104]2365 $sql .= " AND NOT r.type=$reverse_typemap{SOA}";
[160]2366 $sql .= " AND host ~* ?" if $filter;
[104]2367 # use alphaorder column for "correct" ordering of sort-by-type instead of DNS RR type number
2368 $sql .= " ORDER BY ".($order eq 'type' ? 't.alphaorder' : "r.$order")." $direction";
[4]2369
[222]2370 my @bindvars = ($id);
2371 push @bindvars, $filter if $filter;
[224]2372
2373 # just to be ultraparanoid about SQL injection vectors
2374 if ($nstart ne 'all') {
2375 $sql .= " LIMIT ? OFFSET ?";
2376 push @bindvars, $nrecs;
2377 push @bindvars, ($nstart*$nrecs);
2378 }
[90]2379 my $sth = $dbh->prepare($sql) or warn $dbh->errstr;
[222]2380 $sth->execute(@bindvars) or warn "$sql: ".$sth->errstr;
[2]2381
2382 my @retbase;
2383 while (my $ref = $sth->fetchrow_hashref()) {
2384 push @retbase, $ref;
2385 }
2386
2387 my $ret = \@retbase;
2388 return $ret;
2389} # end getDomRecs()
2390
2391
[91]2392## DNSDB::getRecCount()
[224]2393# Return count of non-SOA records in zone (or default records in a group)
2394# Takes a database handle, default/live flag, reverse/forward flag, group/domain ID,
2395# and optional filtering modifier
[91]2396# Returns the count
2397sub getRecCount {
2398 my $dbh = shift;
2399 my $defrec = shift;
[224]2400 my $revrec = shift;
[91]2401 my $id = shift;
[135]2402 my $filter = shift || '';
[91]2403
[135]2404 # keep the nasties down, since we can't ?-sub this bit. :/
2405 # note this is chars allowed in DNS hostnames
2406 $filter =~ s/[^a-zA-Z0-9_.:-]//g;
2407
[222]2408 my @bindvars = ($id);
2409 push @bindvars, $filter if $filter;
[224]2410 my $sql = "SELECT count(*) FROM ".
2411 _rectable($defrec,$revrec).
2412 " WHERE "._recparent($defrec,$revrec)."=? ".
2413 "AND NOT type=$reverse_typemap{SOA}".
2414 ($filter ? " AND host ~* ?" : '');
2415 my ($count) = $dbh->selectrow_array($sql, undef, (@bindvars) );
[91]2416
2417 return $count;
2418
2419} # end getRecCount()
2420
2421
[3]2422## DNSDB::addRec()
[2]2423# Add a new record to a domain or a group's default records
2424# Takes a database handle, default/live flag, group/domain ID,
2425# host, type, value, and TTL
2426# Some types require additional detail: "distance" for MX and SRV,
2427# and weight/port for SRV
2428# Returns a status code and detail message in case of error
[234]2429##fixme: pass a hash with the record data, not a series of separate values
[2]2430sub addRec {
2431 $errstr = '';
2432 my $dbh = shift;
2433 my $defrec = shift;
[226]2434 my $revrec = shift;
2435 my $id = shift; # parent (group_id for defrecs, rdns_id for reverse records,
2436 # domain_id for domain records)
[2]2437
2438 my $host = shift;
[234]2439 my $rectype = shift; # reference so we can coerce it if "+"-types can't find both zones
[2]2440 my $val = shift;
2441 my $ttl = shift;
2442
[226]2443 # prep for validation
[252]2444 my $addr = NetAddr::IP->new($$val);
2445 $$host =~ s/\.+$//; # FQDNs ending in . are an internal detail, and really shouldn't be exposed in the UI.
[226]2446
2447 my $domid = 0;
2448 my $revid = 0;
2449
2450 my $retcode = 'OK'; # assume everything will go OK
2451 my $retmsg = '';
2452
2453 # do simple validation first
2454 return ('FAIL', "TTL must be numeric") unless $ttl =~ /^\d+$/;
2455
[234]2456 # Quick check on hostname parts. Note the regex is more forgiving than the error message;
2457 # domain names technically are case-insensitive, and we use printf-like % codes for a couple
2458 # of types. Other things may also be added to validate default records of several flavours.
2459 return ('FAIL', "Hostnames may not contain anything other than (0-9 a-z . _)")
[272]2460 if $defrec eq 'n' && $$host !~ /^[0-9a-z_%.-]+$/i;
[226]2461
[234]2462 # Collect these even if we're only doing a simple A record so we can call *any* validation sub
2463 my $dist = shift;
2464 my $port = shift;
2465 my $weight = shift;
[226]2466
[234]2467 my $fields;
2468 my @vallist;
[226]2469
[234]2470 # Call the validation sub for the type requested.
2471 ($retcode,$retmsg) = $validators{$$rectype}($dbh, (defrec => $defrec, revrec => $revrec, id => $id,
[249]2472 host => $host, rectype => $rectype, val => $val, addr => $addr,
[234]2473 dist => \$dist, port => \$port, weight => \$weight,
2474 fields => \$fields, vallist => \@vallist) );
[129]2475
[234]2476 return ($retcode,$retmsg) if $retcode eq 'FAIL';
[209]2477
[234]2478 # Set up database fields and bind parameters
2479 $fields .= "host,type,val,ttl,"._recparent($defrec,$revrec);
[249]2480 push @vallist, ($$host,$$rectype,$$val,$ttl,$id);
[234]2481 my $vallen = '?'.(',?'x$#vallist);
[2]2482
[90]2483 # Allow transactions, and raise an exception on errors so we can catch it later.
2484 # Use local to make sure these get "reset" properly on exiting this block
2485 local $dbh->{AutoCommit} = 0;
2486 local $dbh->{RaiseError} = 1;
[2]2487
[90]2488 eval {
[236]2489 $dbh->do("INSERT INTO "._rectable($defrec, $revrec)." ($fields) VALUES ($vallen)",
[90]2490 undef, @vallist);
2491 $dbh->commit;
2492 };
2493 if ($@) {
2494 my $msg = $@;
2495 eval { $dbh->rollback; };
2496 return ('FAIL',$msg);
2497 }
[2]2498
[226]2499 return ($retcode, $retmsg);
[90]2500
[2]2501} # end addRec()
2502
2503
[16]2504## DNSDB::updateRec()
2505# Update a record
[273]2506# Takes a database handle, default and reverse flags, record ID, immediate parent ID, and new record data.
2507# Returns a status code and message
[16]2508sub updateRec {
2509 $errstr = '';
[17]2510
[16]2511 my $dbh = shift;
2512 my $defrec = shift;
[272]2513 my $revrec = shift;
[16]2514 my $id = shift;
[272]2515 my $parid = shift; # immediate parent entity that we're descending from to update the record
[16]2516
[273]2517 # all records have these
[16]2518 my $host = shift;
[272]2519 my $hostbk = $$host; # Keep a backup copy of the original, so we can WARN if the update mangles the domain
2520 my $rectype = shift;
[16]2521 my $val = shift;
2522 my $ttl = shift;
2523
[272]2524 # prep for validation
2525 my $addr = NetAddr::IP->new($$val);
2526 $$host =~ s/\.+$//; # FQDNs ending in . are an internal detail, and really shouldn't be exposed in the UI.
[16]2527
[272]2528 my $domid = 0;
2529 my $revid = 0;
2530
2531 my $retcode = 'OK'; # assume everything will go OK
2532 my $retmsg = '';
2533
[273]2534 # do simple validation first
[272]2535 return ('FAIL', "TTL must be numeric") unless $ttl =~ /^\d+$/;
2536
2537 # Quick check on hostname parts. Note the regex is more forgiving than the error message;
2538 # domain names technically are case-insensitive, and we use printf-like % codes for a couple
2539 # of types. Other things may also be added to validate default records of several flavours.
[273]2540 return ('FAIL', "Hostnames may not contain anything other than (0-9 a-z - . _)")
[272]2541 if $defrec eq 'n' && $$host !~ /^[0-9a-z_%.-]+$/i;
2542
[273]2543 # only MX and SRV will use these
[16]2544 my $dist = 0;
2545 my $weight = 0;
2546 my $port = 0;
2547
[272]2548 my $fields;
2549 my @vallist;
[16]2550
[273]2551 # get old record data so we have the right parent ID
2552 # and for logging (eventually)
2553 my $oldrec = getRecLine($dbh, $defrec, $revrec, $id);
[223]2554
[272]2555 # Call the validation sub for the type requested.
2556 # Note the ID to pass here is the *parent*, not the record
2557 ($retcode,$retmsg) = $validators{$$rectype}($dbh, (defrec => $defrec, revrec => $revrec,
2558 id => ($defrec eq 'y' ? $oldrec->{group_id} : ($revrec eq 'n' ? $oldrec->{domain_id} : $oldrec->{rdns_id})),
2559 host => $host, rectype => $rectype, val => $val, addr => $addr,
2560 dist => \$dist, port => \$port, weight => \$weight,
2561 fields => \$fields, vallist => \@vallist,
2562 update => $id) );
2563
2564 return ($retcode,$retmsg) if $retcode eq 'FAIL';
2565
[273]2566 # Set up database fields and bind parameters. Note only the optional fields
2567 # (distance, weight, port, secondary parent ID) are added in the validation call above
2568 $fields .= "host,type,val,ttl,"._recparent($defrec,$revrec);
2569 push @vallist, ($$host,$$rectype,$$val,$ttl,
2570 ($defrec eq 'y' ? $oldrec->{group_id} : ($revrec eq 'n' ? $oldrec->{domain_id} : $oldrec->{rdns_id})) );
[272]2571
[273]2572 # hack hack PTHUI
2573 # need to forcibly make sure we disassociate a record with a parent it's no longer related to.
2574 # eg, PTR records may not have a domain parent, or A/AAAA records may not have a revzone parent.
2575 # mainly needed for crossover types that got coerced down to "standard" types
2576 if ($defrec eq 'n') {
2577 if ($$rectype == $reverse_typemap{PTR}) {
2578 $fields .= ",domain_id";
2579 push @vallist, 0;
2580 }
2581 if ($$rectype == $reverse_typemap{A} || $$rectype == $reverse_typemap{AAAA}) {
2582 $fields .= ",rdns_id";
2583 push @vallist, 0;
2584 }
2585 }
[272]2586
[273]2587 # Fiddle the field list into something suitable for updates
2588 $fields =~ s/,/=?,/g;
2589 $fields .= "=?";
[272]2590
[90]2591 local $dbh->{AutoCommit} = 0;
2592 local $dbh->{RaiseError} = 1;
2593
2594 eval {
[273]2595 $dbh->do("UPDATE "._rectable($defrec,$revrec)." SET $fields WHERE record_id=?", undef, (@vallist, $id) );
[130]2596 $dbh->commit;
[90]2597 };
2598 if ($@) {
2599 my $msg = $@;
2600 $dbh->rollback;
2601 return ('FAIL', $msg);
2602 }
2603
[272]2604 return ($retcode, $retmsg);
[16]2605} # end updateRec()
2606
2607
[3]2608## DNSDB::delRec()
2609# Delete a record.
2610sub delRec {
2611 $errstr = '';
2612 my $dbh = shift;
2613 my $defrec = shift;
[243]2614 my $revrec = shift;
[3]2615 my $id = shift;
2616
[243]2617 my $sth = $dbh->prepare("DELETE FROM "._rectable($defrec,$revrec)." WHERE record_id=?");
[3]2618 $sth->execute($id);
2619
[23]2620 return ('FAIL',"Couldn't remove record: ".$sth->errstr) if $sth->err;
[3]2621
2622 return ('OK','OK');
2623} # end delRec()
2624
2625
[117]2626 # Reference hashes.
[244]2627my %par_tbl = (
[117]2628 group => 'groups',
2629 user => 'users',
2630 defrec => 'default_records',
[244]2631 defrevrec => 'default_rev_records',
[117]2632 domain => 'domains',
[244]2633 revzone => 'revzones',
[117]2634 record => 'records'
2635 );
[244]2636my %id_col = (
[117]2637 group => 'group_id',
2638 user => 'user_id',
2639 defrec => 'record_id',
[244]2640 defrevrec => 'record_id',
[117]2641 domain => 'domain_id',
[244]2642 revzone => 'rdns_id',
[117]2643 record => 'record_id'
2644 );
[244]2645my %par_col = (
[117]2646 group => 'parent_group_id',
2647 user => 'group_id',
2648 defrec => 'group_id',
[244]2649 defrevrec => 'group_id',
[117]2650 domain => 'group_id',
[244]2651 revzone => 'group_id',
[117]2652 record => 'domain_id'
2653 );
[244]2654my %par_type = (
[117]2655 group => 'group',
2656 user => 'group',
2657 defrec => 'group',
[244]2658 defrevrec => 'group',
[117]2659 domain => 'group',
[244]2660 revzone => 'group',
[117]2661 record => 'domain'
2662 );
2663
[225]2664
2665## DNSDB::getTypelist()
2666# Get a list of record types for various UI dropdowns
2667# Takes database handle, forward/reverse/lookup flag, and optional "tag as selected" indicator (defaults to A)
2668# Returns an arrayref to list of hashrefs perfect for HTML::Template
2669sub getTypelist {
2670 my $dbh = shift;
2671 my $recgroup = shift;
2672 my $type = shift || $reverse_typemap{A};
2673
2674 # also accepting $webvar{revrec}!
2675 $recgroup = 'f' if $recgroup eq 'n';
2676 $recgroup = 'r' if $recgroup eq 'y';
2677
2678 my $sql = "SELECT val,name FROM rectypes WHERE ";
2679 if ($recgroup eq 'r') {
2680 # reverse zone types
2681 $sql .= "stdflag=2 OR stdflag=3";
2682 } elsif ($recgroup eq 'l') {
2683 # DNS lookup types. Note we avoid our custom types >= 65280, since those are entirely internal.
2684 $sql .= "(stdflag=1 OR stdflag=2 OR stdflag=3) AND val < 65280";
2685 } else {
2686 # default; forward zone types. technically $type eq 'f' but not worth the error message.
2687 $sql .= "stdflag=1 OR stdflag=2";
2688 }
2689 $sql .= " ORDER BY listorder";
2690
2691 my $sth = $dbh->prepare($sql);
2692 $sth->execute;
2693 my @typelist;
2694 while (my ($rval,$rname) = $sth->fetchrow_array()) {
2695 my %row = ( recval => $rval, recname => $rname );
2696 $row{tselect} = 1 if $rval == $type;
2697 push @typelist, \%row;
2698 }
2699
2700 # Add SOA on lookups since it's not listed in other dropdowns.
2701 if ($recgroup eq 'l') {
2702 my %row = ( recval => $reverse_typemap{SOA}, recname => 'SOA' );
2703 $row{tselect} = 1 if $reverse_typemap{SOA} == $type;
2704 push @typelist, \%row;
2705 }
2706
2707 return \@typelist;
2708} # end getTypelist()
2709
2710
[254]2711## DNSDB::parentID()
2712# Get ID of entity that is nearest parent to requested id
2713# Takes a database handle and a hash of entity ID, entity type, optional parent type flag
2714# (domain/reverse zone or group), and optional default/live and forward/reverse flags
2715# Returns the ID or undef on failure
2716sub parentID {
[116]2717 my $dbh = shift;
2718
[254]2719 my %args = @_;
[116]2720
[254]2721 # clean up the parent-type. Set it to group if not set; coerce revzone to domain for simpler logic
2722 $args{partype} = 'group' if !$args{partype};
2723 $args{partype} = 'domain' if $args{partype} eq 'revzone';
[116]2724
[254]2725 # clean up defrec and revrec. default to live record, forward zone
2726 $args{defrec} = 'n' if !$args{defrec};
2727 $args{revrec} = 'n' if !$args{revrec};
[116]2728
[254]2729 if ($par_type{$args{partype}} eq 'domain') {
2730 # only live records can have a domain/zone parent
2731 return unless ($args{type} eq 'record' && $args{defrec} eq 'n');
2732 my $result = $dbh->selectrow_hashref("SELECT ".($args{revrec} eq 'n' ? 'domain_id' : 'rdns_id').
2733 " FROM records WHERE record_id = ?",
2734 undef, ($args{id}) ) or return;
2735 return $result;
2736 } else {
2737 # snag some arguments that will either fall through or be overwritten to save some code duplication
2738 my $tmpid = $args{id};
2739 my $type = $args{type};
2740 if ($type eq 'record' && $args{defrec} eq 'n') {
2741 # Live records go through the records table first.
2742 ($tmpid) = $dbh->selectrow_array("SELECT ".($args{revrec} eq 'n' ? 'domain_id' : 'rdns_id').
2743 " FROM records WHERE record_id = ?",
2744 undef, ($args{id}) ) or return;
2745 $type = ($args{revrec} eq 'n' ? 'domain' : 'revzone');
2746 }
2747 my ($result) = $dbh->selectrow_array("SELECT $par_col{$type} FROM $par_tbl{$type} WHERE $id_col{$type} = ?",
2748 undef, ($tmpid) );
2749 return $result;
2750 }
2751# should be impossible to get here with even remotely sane arguments
2752 return;
2753} # end parentID()
[116]2754
2755
[117]2756## DNSDB::isParent()
2757# Returns true if $id1 is a parent of $id2, false otherwise
2758sub isParent {
2759 my $dbh = shift;
2760 my $id1 = shift;
2761 my $type1 = shift;
2762 my $id2 = shift;
2763 my $type2 = shift;
2764##todo: immediate, secondary, full (default)
2765
[157]2766 # Return false on invalid types
[244]2767 return 0 if !grep /^$type1$/, ('record','defrec','defrevrec','user','domain','revzone','group');
2768 return 0 if !grep /^$type2$/, ('record','defrec','defrevrec','user','domain','revzone','group');
[157]2769
[117]2770 # Return false on impossible relations
2771 return 0 if $type1 eq 'record'; # nothing may be a child of a record
2772 return 0 if $type1 eq 'defrec'; # nothing may be a child of a record
[244]2773 return 0 if $type1 eq 'defrevrec'; # nothing may be a child of a record
[117]2774 return 0 if $type1 eq 'user'; # nothing may be child of a user
2775 return 0 if $type1 eq 'domain' && $type2 ne 'record'; # domain may not be a parent of anything other than a record
[244]2776 return 0 if $type1 eq 'revzone' && $type2 ne 'record';# reverse zone may not be a parent of anything other than a record
[117]2777
[186]2778 # ennnhhhh.... if we're passed an id of 0, it will never be found. usual
2779 # case would be the UI creating a new <thing>, and so we don't have an ID for
2780 # <thing> to look up yet. in that case the UI should check the parent as well.
2781 return 0 if $id1 == 0; # nothing can have a parent id of 0
2782 return 1 if $id2 == 0; # anything could have a child id of 0 (or "unknown")
2783
[117]2784 # group 1 is the ultimate root parent
2785 return 1 if $type1 eq 'group' && $id1 == 1;
2786
[155]2787 # groups are always (a) parent of themselves
2788 return 1 if $type1 eq 'group' && $type2 eq 'group' && $id1 == $id2;
2789
[117]2790 my $id = $id2;
2791 my $type = $type2;
2792 my $foundparent = 0;
[155]2793
[244]2794 # Records are the only entity with two possible parents. We need to split the parent checks on
2795 # domain/rdns.
2796 if ($type eq 'record') {
2797 my ($dom,$rdns) = $dbh->selectrow_array("SELECT domain_id,rdns_id FROM records WHERE record_id=?",
2798 undef, ($id));
2799 # check immediate parent against request
2800 return 1 if $type1 eq 'domain' && $id1 == $dom;
2801 return 1 if $type1 eq 'revzone' && $id1 == $rdns;
2802 # if request is group, check *both* parents. Only check if the parent is nonzero though.
2803 return 1 if $dom && isParent($dbh, $id1, $type1, $dom, 'domain');
2804 return 1 if $rdns && isParent($dbh, $id1, $type1, $rdns, 'revzone');
2805 # exit here since we've executed the loop below by proxy in the above recursive calls.
2806 return 0;
2807 }
2808
2809# almost the same loop as getParents() above
[186]2810 my $limiter = 0;
[117]2811 while (1) {
[155]2812 my $sql = "SELECT $par_col{$type} FROM $par_tbl{$type} WHERE $id_col{$type} = ?";
[117]2813 my $result = $dbh->selectrow_hashref($sql,
[157]2814 undef, ($id) );
[186]2815 if (!$result) {
2816 $limiter++;
[244]2817##fixme: how often will this happen on a live site? fail at max limiter <n>?
[186]2818 warn "no results looking for $sql with id $id (depth $limiter)\n";
2819 last;
2820 }
[157]2821 if ($result && $result->{$par_col{$type}} == $id1) {
[117]2822 $foundparent = 1;
2823 last;
[157]2824 } else {
2825##fixme: do we care about trying to return a "no such record/domain/user/group" error?
[244]2826# should be impossible to create an inconsistent DB just with API calls.
[157]2827 warn $dbh->errstr." $sql, $id" if $dbh->errstr;
[117]2828 }
2829 # group 1 is its own parent. need this here more to break strange loops than for detecting a parent
2830 last if $result->{$par_col{$type}} == 1;
[152]2831 $id = $result->{$par_col{$type}};
[117]2832 $type = $par_type{$type};
2833 }
2834
2835 return $foundparent;
2836} # end isParent()
2837
2838
[275]2839## DNSDB::zoneStatus()
2840# Returns and optionally sets a zone's status
2841# Takes a database handle, domain/revzone ID, forward/reverse flag, and optionally a status argument
2842# Returns status, or undef on errors.
2843sub zoneStatus {
[3]2844 my $dbh = shift;
2845 my $id = shift;
[275]2846 my $revrec = shift;
2847 my $newstatus = shift || 'mu';
[3]2848
2849 return undef if $id !~ /^\d+$/;
2850
2851# ooo, fun! let's see what we were passed for status
[275]2852 if ($newstatus ne 'mu') {
2853 $newstatus = 0 if $newstatus eq 'domoff';
2854 $newstatus = 1 if $newstatus eq 'domon';
2855 $dbh->do("UPDATE ".($revrec eq 'n' ? 'domains' : 'revzones')." SET status=? WHERE ".
2856 ($revrec eq 'n' ? 'domain_id' : 'rdns_id')."=?", undef, ($newstatus,$id) );
[3]2857 }
2858
[275]2859 my ($status) = $dbh->selectrow_array("SELECT status FROM ".
2860 ($revrec eq 'n' ? "domains WHERE domain_id=?" : "revzones WHERE rdns_id=?"),
2861 undef, ($id) );
[3]2862 return $status;
[275]2863} # end zoneStatus()
[3]2864
2865
[33]2866## DNSDB::importAXFR
2867# Import a domain via AXFR
[37]2868# Takes AXFR host, domain to transfer, group to put the domain in,
2869# and optionally:
2870# - active/inactive state flag (defaults to active)
2871# - overwrite-SOA flag (defaults to off)
2872# - overwrite-NS flag (defaults to off, doesn't affect subdomain NS records)
2873# Returns a status code (OK, WARN, or FAIL) and message - message should be blank
2874# if status is OK, but WARN includes conditions that are not fatal but should
2875# really be reported.
[33]2876sub importAXFR {
2877 my $dbh = shift;
[35]2878 my $ifrom_in = shift;
[33]2879 my $domain = shift;
2880 my $group = shift;
2881 my $status = shift || 1;
2882 my $rwsoa = shift || 0;
2883 my $rwns = shift || 0;
[37]2884
[33]2885##fixme: add mode to delete&replace, merge+overwrite, merge new?
2886
[37]2887 my $nrecs = 0;
2888 my $soaflag = 0;
2889 my $nsflag = 0;
2890 my $warnmsg = '';
2891 my $ifrom;
[33]2892
[35]2893 # choke on possible bad setting in ifrom
[37]2894 # IPv4 and v6, and valid hostnames!
[35]2895 ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i);
2896 return ('FAIL', "Bad AXFR source host $ifrom")
2897 unless ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i);
2898
[33]2899 # Allow transactions, and raise an exception on errors so we can catch it later.
2900 # Use local to make sure these get "reset" properly on exiting this block
2901 local $dbh->{AutoCommit} = 0;
2902 local $dbh->{RaiseError} = 1;
2903
[37]2904 my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
[34]2905 my $dom_id;
2906
[35]2907# quick check to start to see if we've already got one
[37]2908 $sth->execute($domain);
2909 ($dom_id) = $sth->fetchrow_array;
[35]2910
2911 return ('FAIL', "Domain already exists") if $dom_id;
2912
[33]2913 eval {
2914 # can't do this, can't nest transactions. sigh.
[35]2915 #my ($dcode, $dmsg) = addDomain(dbh, domain, group, status);
[33]2916
2917##fixme: serial
[37]2918 my $sth = $dbh->prepare("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)");
2919 $sth->execute($domain,$group,$status);
[33]2920
[35]2921## bizarre DBI<->Net::DNS interaction bug:
2922## sometimes a zone will cause an immediate commit-and-exit (sort of) of the while()
[37]2923## fixed, apparently I was doing *something* odd, but not certain what it was that
2924## caused a commit instead of barfing
[35]2925
[33]2926 # get domain id so we can do the records
[37]2927 $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
2928 $sth->execute($domain);
2929 ($dom_id) = $sth->fetchrow_array();
[33]2930
[34]2931 my $res = Net::DNS::Resolver->new;
[35]2932 $res->nameservers($ifrom);
2933 $res->axfr_start($domain)
2934 or die "Couldn't begin AXFR\n";
[34]2935
[35]2936 while (my $rr = $res->axfr_next()) {
[33]2937 my $type = $rr->type;
[35]2938
[34]2939 my $sql = "INSERT INTO records (domain_id,host,type,ttl,val";
[33]2940 my $vallen = "?,?,?,?,?";
2941
[37]2942 $soaflag = 1 if $type eq 'SOA';
2943 $nsflag = 1 if $type eq 'NS';
[35]2944
2945 my @vallist = ($dom_id, $rr->name, $reverse_typemap{$type}, $rr->ttl);
[34]2946
2947# "Primary" types:
2948# A, NS, CNAME, SOA, PTR(warn in forward), MX, TXT, AAAA, SRV, A6(ob), SPF
2949# maybe KEY
2950
[35]2951# nasty big ugly case-like thing here, since we have to do *some* different
2952# processing depending on the record. le sigh.
2953
[105]2954##fixme: what record types other than TXT can/will have >255-byte payloads?
2955
[34]2956 if ($type eq 'A') {
2957 push @vallist, $rr->address;
2958 } elsif ($type eq 'NS') {
[37]2959# hmm. should we warn here if subdomain NS'es are left alone?
2960 next if ($rwns && ($rr->name eq $domain));
[34]2961 push @vallist, $rr->nsdname;
[35]2962 $nsflag = 1;
[34]2963 } elsif ($type eq 'CNAME') {
2964 push @vallist, $rr->cname;
2965 } elsif ($type eq 'SOA') {
[37]2966 next if $rwsoa;
[34]2967 $vallist[1] = $rr->mname.":".$rr->rname;
2968 push @vallist, ($rr->refresh.":".$rr->retry.":".$rr->expire.":".$rr->minimum);
[35]2969 $soaflag = 1;
[34]2970 } elsif ($type eq 'PTR') {
[105]2971 push @vallist, $rr->ptrdname;
[34]2972 # hmm. PTR records should not be in forward zones.
2973 } elsif ($type eq 'MX') {
[33]2974 $sql .= ",distance";
2975 $vallen .= ",?";
[34]2976 push @vallist, $rr->exchange;
2977 push @vallist, $rr->preference;
2978 } elsif ($type eq 'TXT') {
2979##fixme: Net::DNS docs say this should be deprecated for rdatastr() or char_str_list(),
2980## but don't really seem enthusiastic about it.
[105]2981 my $rrdata = $rr->txtdata;
[130]2982 push @vallist, $rrdata;
[34]2983 } elsif ($type eq 'SPF') {
2984##fixme: and the same caveat here, since it is apparently a clone of ::TXT
[105]2985 my $rrdata = $rr->txtdata;
[130]2986 push @vallist, $rrdata;
[34]2987 } elsif ($type eq 'AAAA') {
2988 push @vallist, $rr->address;
2989 } elsif ($type eq 'SRV') {
2990 $sql .= ",distance,weight,port" if $type eq 'SRV';
2991 $vallen .= ",?,?,?" if $type eq 'SRV';
[37]2992 push @vallist, $rr->target;
[34]2993 push @vallist, $rr->priority;
2994 push @vallist, $rr->weight;
2995 push @vallist, $rr->port;
2996 } elsif ($type eq 'KEY') {
[35]2997 # we don't actually know what to do with these...
[34]2998 push @vallist, ($rr->flags.":".$rr->protocol.":".$rr->algorithm.":".$rr->key.":".$rr->keytag.":".$rr->privatekeyname);
[35]2999 } else {
[105]3000 my $rrdata = $rr->rdatastr;
[130]3001 push @vallist, $rrdata;
[35]3002 # Finding a different record type is not fatal.... just problematic.
[37]3003 # We may not be able to export it correctly.
[35]3004 $warnmsg .= "Unusual record ".$rr->name." ($type) found\n";
[33]3005 }
3006
[34]3007# BIND supports:
3008# A CNAME HINFO MB(ex) MD(ob) MF(ob) MG(ex) MINFO(ex) MR(ex) MX NS NULL
3009# PTR SOA TXT WKS AFSDB(ex) ISDN(ex) RP(ex) RT(ex) X25(ex) PX
3010# ... if one can ever find the right magic to format them correctly
3011
3012# Net::DNS supports:
3013# RRSIG SIG NSAP NS NIMLOC NAPTR MX MR MINFO MG MB LOC ISDN IPSECKEY HINFO
3014# EID DNAME CNAME CERT APL AFSDB AAAA A DS NXT NSEC3PARAM NSEC3 NSEC KEY
3015# DNSKEY DLV X25 TXT TSIG TKEY SSHFP SRV SPF SOA RT RP PX PTR NULL APL::AplItem
3016
[37]3017 $sth = $dbh->prepare($sql.") VALUES (".$vallen.")") or die "problem preparing record insert SQL\n";
3018 $sth->execute(@vallist) or die "failed to insert ".$rr->string.": ".$sth->errstr."\n";
[34]3019
[37]3020 $nrecs++;
[34]3021
[37]3022 } # while axfr_next
3023
3024 # Overwrite SOA record
3025 if ($rwsoa) {
3026 $soaflag = 1;
3027 my $sthgetsoa = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?");
3028 my $sthputsoa = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)");
3029 $sthgetsoa->execute($group,$reverse_typemap{SOA});
3030 while (my ($host,$val,$ttl) = $sthgetsoa->fetchrow_array()) {
3031 $host =~ s/DOMAIN/$domain/g;
3032 $val =~ s/DOMAIN/$domain/g;
3033 $sthputsoa->execute($dom_id,$host,$reverse_typemap{SOA},$val,$ttl);
[34]3034 }
[37]3035 }
[34]3036
[37]3037 # Overwrite NS records
3038 if ($rwns) {
3039 $nsflag = 1;
3040 my $sthgetns = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?");
3041 my $sthputns = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)");
3042 $sthgetns->execute($group,$reverse_typemap{NS});
3043 while (my ($host,$val,$ttl) = $sthgetns->fetchrow_array()) {
3044 $host =~ s/DOMAIN/$domain/g;
3045 $val =~ s/DOMAIN/$domain/g;
3046 $sthputns->execute($dom_id,$host,$reverse_typemap{NS},$val,$ttl);
3047 }
3048 }
[34]3049
[35]3050 die "No records found; either $ifrom is not authoritative or doesn't allow transfers\n" if !$nrecs;
3051 die "Bad zone: No SOA record!\n" if !$soaflag;
3052 die "Bad zone: No NS records!\n" if !$nsflag;
3053
[37]3054 $dbh->commit;
[35]3055
[33]3056 };
3057
3058 if ($@) {
3059 my $msg = $@;
3060 eval { $dbh->rollback; };
[34]3061 return ('FAIL',$msg." $warnmsg");
[33]3062 } else {
[35]3063 return ('WARN', $warnmsg) if $warnmsg;
[91]3064 return ('OK',"Imported OK");
[33]3065 }
3066
[37]3067 # it should be impossible to get here.
[34]3068 return ('WARN',"OOOK!");
[33]3069} # end importAXFR()
3070
3071
[103]3072## DNSDB::export()
3073# Export the DNS database, or a part of it
3074# Takes database handle, export type, optional arguments depending on type
3075# Writes zone data to targets as appropriate for type
3076sub export {
3077 my $dbh = shift;
3078 my $target = shift;
3079
3080 if ($target eq 'tiny') {
3081 __export_tiny($dbh,@_);
3082 }
3083# elsif ($target eq 'foo') {
3084# __export_foo($dbh,@_);
3085#}
3086# etc
3087
3088} # end export()
3089
3090
3091## DNSDB::__export_tiny
3092# Internal sub to implement tinyDNS (compatible) export
3093# Takes database handle, filehandle to write export to, optional argument(s)
3094# to determine which data gets exported
3095sub __export_tiny {
3096 my $dbh = shift;
3097 my $datafile = shift;
3098
3099##fixme: slurp up further options to specify particular zone(s) to export
3100
3101 ## Convert a bare number into an octal-coded pair of octets.
3102 # Take optional arg to indicate a decimal or hex input. Defaults to hex.
3103 sub octalize {
3104 my $tmp = shift;
3105 my $srctype = shift || 'h'; # default assumes hex string
3106 $tmp = sprintf "%0.4x", hex($tmp) if $srctype eq 'h'; # 0-pad hex to 4 digits
3107 $tmp = sprintf "%0.4x", $tmp if $srctype eq 'd'; # 0-pad decimal to 4 hex digits
3108 my @o = ($tmp =~ /^(..)(..)$/); # split into octets
3109 return sprintf "\\%0.3o\\%0.3o", hex($o[0]), hex($o[1]);;
3110 }
3111
3112##fixme: fail if $datafile isn't an open, writable file
3113
3114 # easy case - export all evarything
3115 # not-so-easy case - export item(s) specified
3116 # todo: figure out what kind of list we use to export items
3117
3118 my $domsth = $dbh->prepare("SELECT domain_id,domain,status FROM domains WHERE status=1");
[130]3119 my $recsth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl ".
3120 "FROM records WHERE domain_id=?");
[103]3121 $domsth->execute();
3122 while (my ($domid,$dom,$domstat) = $domsth->fetchrow_array) {
3123 $recsth->execute($domid);
[130]3124 while (my ($host,$type,$val,$dist,$weight,$port,$ttl) = $recsth->fetchrow_array) {
[108]3125##fixme: need to store location in the db, and retrieve it here.
3126# temporarily hardcoded to empty so we can include it further down.
3127my $loc = '';
3128
3129##fixme: record validity timestamp. tinydns supports fiddling with timestamps.
3130# note $ttl must be set to 0 if we want to use tinydns's auto-expiring timestamps.
3131# timestamps are TAI64
3132# ~~ 2^62 + time()
3133my $stamp = '';
3134
[103]3135# raw packet in unknown format: first byte indicates length
3136# of remaining data, allows up to 255 raw bytes
3137
3138##fixme? append . to all host/val hostnames
3139 if ($typemap{$type} eq 'SOA') {
3140
3141 # host contains pri-ns:responsible
3142 # val is abused to contain refresh:retry:expire:minttl
3143##fixme: "manual" serial vs tinydns-autoserial
[202]3144 # let's be explicit about abusing $host and $val
3145 my ($email, $primary) = (split /:/, $host)[0,1];
3146 my ($refresh, $retry, $expire, $min_ttl) = (split /:/, $val)[0,1,2,3];
3147 print $datafile "Z$dom:$primary:$email"."::$refresh:$retry:$expire:$min_ttl:$ttl:$stamp:$loc\n";
[103]3148
3149 } elsif ($typemap{$type} eq 'A') {
3150
[108]3151 print $datafile "+$host:$val:$ttl:$stamp:$loc\n";
[103]3152
3153 } elsif ($typemap{$type} eq 'NS') {
3154
[108]3155 print $datafile "\&$host"."::$val:$ttl:$stamp:$loc\n";
[103]3156
3157 } elsif ($typemap{$type} eq 'AAAA') {
3158
3159 print $datafile ":$host:28:";
3160 my $altgrp = 0;
3161 my @altconv;
[108]3162 # Split in to up to 8 groups of hex digits (allows for IPv6 :: 0-collapsing)
[103]3163 foreach (split /:/, $val) {
3164 if (/^$/) {
3165 # flag blank entry; this is a series of 0's of (currently) unknown length
3166 $altconv[$altgrp++] = 's';
3167 } else {
3168 # call sub to convert 1-4 hex digits to 2 string-rep octal bytes
3169 $altconv[$altgrp++] = octalize($_)
3170 }
3171 }
3172 foreach my $octet (@altconv) {
3173 # if not 's', output
3174 print $datafile $octet unless $octet =~ /^s$/;
3175 # if 's', output (9-array length)x literal '\000\000'
3176 print $datafile '\000\000'x(9-$altgrp) if $octet =~ /^s$/;
3177 }
[108]3178 print $datafile ":$ttl:$stamp:$loc\n";
[103]3179
3180 } elsif ($typemap{$type} eq 'MX') {
3181
[108]3182 print $datafile "\@$host"."::$val:$dist:$ttl:$stamp:$loc\n";
[103]3183
3184 } elsif ($typemap{$type} eq 'TXT') {
3185
3186##fixme: split v-e-r-y long TXT strings? will need to do so for BIND export, at least
3187 $val =~ s/:/\\072/g; # may need to replace other symbols
[108]3188 print $datafile "'$host:$val:$ttl:$stamp:$loc\n";
[103]3189
3190# by-hand TXT
3191#:deepnet.cx:16:2v\075spf1\040a\040a\072bacon.deepnet.cx\040a\072home.deepnet.cx\040-all:3600
3192#@ IN TXT "v=spf1 a a:bacon.deepnet.cx a:home.deepnet.cx -all"
3193#'deepnet.cx:v=spf1 a a\072bacon.deepnet.cx a\072home.deepnet.cx -all:3600
3194
3195#txttest IN TXT "v=foo bar:bob kn;ob' \" !@#$%^&*()-=_+[]{}<>?"
3196#: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
3197
3198# very long TXT record as brought in by axfr-get
3199# note tinydns does not support >512-byte RR data, need axfr-dns (for TCP support) for that
3200# also note, tinydns does not seem to support <512, >256-byte RRdata from axfr-get either. :/
3201#:longtxt.deepnet.cx:16:
3202#\170this is a very long txt record. it is really long. long. very long. really very long. this is a very long txt record.
3203#\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.
3204#\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.
3205#:3600
3206
3207 } elsif ($typemap{$type} eq 'CNAME') {
3208
[108]3209 print $datafile "C$host:$val:$ttl:$stamp:$loc\n";
[103]3210
3211 } elsif ($typemap{$type} eq 'SRV') {
3212
3213 # data is two-byte values for priority, weight, port, in that order,
3214 # followed by length/string data
3215
3216 print $datafile ":$host:33:".octalize($dist,'d').octalize($weight,'d').octalize($port,'d');
3217
3218 $val .= '.' if $val !~ /\.$/;
3219 foreach (split /\./, $val) {
3220 printf $datafile "\\%0.3o%s", length($_), $_;
3221 }
[108]3222 print $datafile "\\000:$ttl:$stamp:$loc\n";
[103]3223
3224 } elsif ($typemap{$type} eq 'RP') {
3225
3226 # RP consists of two mostly free-form strings.
3227 # The first is supposed to be an email address with @ replaced by . (as with the SOA contact)
3228 # The second is the "hostname" of a TXT record with more info.
3229 print $datafile ":$host:17:";
3230 my ($who,$what) = split /\s/, $val;
3231 foreach (split /\./, $who) {
3232 printf $datafile "\\%0.3o%s", length($_), $_;
3233 }
3234 print $datafile '\000';
3235 foreach (split /\./, $what) {
3236 printf $datafile "\\%0.3o%s", length($_), $_;
3237 }
[108]3238 print $datafile "\\000:$ttl:$stamp:$loc\n";
[103]3239
3240 } elsif ($typemap{$type} eq 'PTR') {
3241
3242 # must handle both IPv4 and IPv6
3243##work
[108]3244 # data should already be in suitable reverse order.
3245 print $datafile "^$host:$val:$ttl:$stamp:$loc\n";
[103]3246
[108]3247 } else {
3248 # raw record. we don't know what's in here, so we ASS-U-ME the user has
3249 # put it in correctly, since either the user is messing directly with the
3250 # database, or the record was imported via AXFR
3251 # <split by char>
3252 # convert anything not a-zA-Z0-9.- to octal coding
3253
3254##fixme: add flag to export "unknown" record types - note we'll probably end up
3255# mangling them since they were written to the DB from Net::DNS::RR::<type>->rdatastr.
3256 #print $datafile ":$host:$type:$val:$ttl:$stamp:$loc\n";
3257
[103]3258 } # record type if-else
3259
3260 } # while ($recsth)
3261 } # while ($domsth)
3262} # end __export_tiny()
3263
3264
[197]3265## DNSDB::mailNotify()
3266# Sends notification mail to recipients regarding an IPDB operation
3267sub mailNotify {
3268 my $dbh = shift;
3269 my ($subj,$message) = @_;
3270
3271 return if $config{mailhost} eq 'smtp.example.com'; # do nothing if still using default SMTP host.
3272
3273 my $mailer = Net::SMTP->new($config{mailhost}, Hello => "dnsadmin.$config{domain}");
3274
3275 my $mailsender = ($config{mailsender} ? $config{mailsender} : $config{mailnotify});
3276
3277 $mailer->mail($mailsender);
3278 $mailer->to($config{mailnotify});
[198]3279 $mailer->data("From: \"$config{mailname}\" <$mailsender>\n",
3280 "To: <$config{mailnotify}>\n",
[197]3281 "Date: ".strftime("%a, %d %b %Y %H:%M:%S %z",localtime)."\n",
3282 "Subject: $subj\n",
3283 "X-Mailer: DNSAdmin Notify v".sprintf("%.1d",$DNSDB::VERSION)."\n",
3284 "Organization: $config{orgname}\n",
3285 "\n$message\n");
3286 $mailer->quit;
3287}
3288
[2]3289# shut Perl up
32901;
Note: See TracBrowser for help on using the repository browser.