source: trunk/DNSDB.pm@ 128

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

/trunk

Code review/cleanup

  • Move configuration of DB host, user, pass, name into an outside file.
  • Fail more gracefully on DB connection failure. Includes minor CSS tweak that probably doesn't really do what I think it's doing.
  • Property svn:keywords set to Date Rev Author Id
File size: 62.5 KB
Line 
1# dns/trunk/DNSDB.pm
2# Abstraction functions for DNS administration
3###
4# SVN revision info
5# $Date: 2011-09-21 22:13:16 +0000 (Wed, 21 Sep 2011) $
6# SVN revision $Rev: 128 $
7# Last update by $Author: kdeugau $
8###
9# Copyright (C) 2008 - Kris Deugau <kdeugau@deepnet.cx>
10
11package DNSDB;
12
13use strict;
14use warnings;
15use Exporter;
16use DBI;
17use Net::DNS;
18use Crypt::PasswdMD5;
19#use Net::SMTP;
20#use NetAddr::IP qw( Compact );
21#use POSIX;
22use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
23
24$VERSION = 0.1;
25@ISA = qw(Exporter);
26@EXPORT_OK = qw(
27 &initGlobals
28 &initPermissions &getPermissions &changePermissions &comparePermissions
29 &changeGroup
30 &loadConfig &connectDB &finish
31 &addDomain &delDomain &domainName &domainID
32 &addGroup &delGroup &getChildren &groupName
33 &addUser &updateUser &delUser &userFullName &userStatus &getUserData
34 &getSOA &getRecLine &getDomRecs &getRecCount
35 &addRec &updateRec &delRec
36 &getParents
37 &isParent
38 &domStatus &importAXFR
39 &export
40 %typemap %reverse_typemap %config
41 %permissions @permtypes $permlist
42 );
43
44@EXPORT = (); # Export nothing by default.
45%EXPORT_TAGS = ( ALL => [qw(
46 &initGlobals
47 &initPermissions &getPermissions &changePermissions &comparePermissions
48 &changeGroup
49 &loadConfig &connectDB &finish
50 &addDomain &delDomain &domainName &domainID
51 &addGroup &delGroup &getChildren &groupName
52 &addUser &updateUser &delUser &userFullName &userStatus &getUserData
53 &getSOA &getRecLine &getDomRecs &getRecCount
54 &addRec &updateRec &delRec
55 &getParents
56 &isParent
57 &domStatus &importAXFR
58 &export
59 %typemap %reverse_typemap %config
60 %permissions @permtypes $permlist
61 )]
62 );
63
64our $group = 1;
65our $errstr = '';
66
67# Halfway sane defaults for SOA, TTL, etc.
68# serial defaults to 0 for convenience.
69# value will be either YYYYMMDDNN for BIND/etc, or auto-internal for tinydns
70our %def = qw (
71 contact hostmaster.DOMAIN
72 prins ns1.myserver.com
73 serial 0
74 soattl 86400
75 refresh 10800
76 retry 3600
77 expire 604800
78 minttl 10800
79 ttl 10800
80);
81
82# Arguably defined wholly in the db, but little reason to change without supporting code changes
83our @permtypes = qw (
84 group_edit group_create group_delete
85 user_edit user_create user_delete
86 domain_edit domain_create domain_delete
87 record_edit record_create record_delete
88 self_edit admin
89);
90our $permlist = join(',',@permtypes);
91
92# DNS record type map and reverse map.
93# loaded from the database, from http://www.iana.org/assignments/dns-parameters
94our %typemap;
95our %reverse_typemap;
96
97our %permissions;
98
99# Prepopulate a basic config. Note some of these *will* cause errors if left unset.
100our %config = (
101 # Database connection info
102 dbname => 'dnsdb',
103 dbuser => 'dnsdb',
104 dbpass => 'secret',
105 dbhost => '',
106
107 # Email notice settings
108 mailhost => 'smtp.example.com',
109 mailsender => 'dnsdb@example.com',
110 mailname => 'DNS Administration',
111
112 # Template directory
113 templatedir => 'templates/',
114# fmeh. this is a real web path, not a logical internal one. hm..
115# cssdir => 'templates/';
116 );
117
118
119##
120## Initialization and cleanup subs
121##
122
123
124## DNSDB::loadConfig()
125# Load the minimum required initial state (DB connect info) from a config file
126# Load misc other bits while we're at it.
127# Takes an optional basename and config path to look for
128# Populates the %config and %def hashes
129sub loadConfig {
130 my $basename = shift || ''; # this will work OK
131
132 my $deferr = ''; # place to put error from default config file in case we can't find either one
133
134 my $configroot = '/etc/dnsdb';
135 $configroot = '' if $basename =~ m|^/|;
136 $basename .= ".conf" if $basename !~ /\.conf$/;
137 my $defconfig = "$configroot/dnsdb.conf";
138 my $siteconfig = "$configroot/$basename";
139
140 # System defaults
141 __cfgload("$configroot/dnsdb.conf") or $deferr = $errstr;
142
143 # Per-site-ish settings
144 unless (__cfgload("$configroot/$basename")) {
145 $errstr = ($deferr ? "Error opening default config file $defconfig: $deferr\n" : '').
146 "Error opening site config file $siteconfig";
147 return;
148 }
149
150 # All good, clear the error and go home.
151 $errstr = '';
152 return 1;
153} # end loadConfig()
154
155
156## DNSDB::__cfgload()
157# Private sub to parse a config file and load it into %config
158# Takes a file handle on an open config file
159sub __cfgload {
160 $errstr = '';
161 my $cfgfile = shift;
162 if (open CFG, "<$cfgfile") {
163# my $mode = '';
164 while (<CFG>) {
165 chomp;
166 s/^\s*//;
167 next if /^#/;
168 next if /^$/;
169# hmm. more complex bits in this file might require [heading] headers, maybe?
170# $mode = $1 if /^\[(a-z)+]/;
171 # DB connect info
172 $config{dbname} = $1 if /^dbname\s*=\s*([a-z0-9_.-]+)/i;
173 $config{dbuser} = $1 if /^dbuser\s*=\s*([a-z0-9_.-]+)/i;
174 $config{dbpass} = $1 if /^dbpass\s*=\s*([a-z0-9_.-]+)/i;
175 $config{dbhost} = $1 if /^dbhost\s*=\s*([a-z0-9_.-]+)/i;
176 # SOA defaults
177 $def{contact} = $1 if /^contact\s*=\s*([a-z0-9_.-]+)/i;
178 $def{prins} = $1 if /^prins\s*=\s*([a-z0-9_.-]+)/i;
179 $def{soattl} = $1 if /^soattl\s*=\s*([a-z0-9_.-]+)/i;
180 $def{refresh} = $1 if /^refresh\s*=\s*([a-z0-9_.-]+)/i;
181 $def{retry} = $1 if /^retry\s*=\s*([a-z0-9_.-]+)/i;
182 $def{expire} = $1 if /^expire\s*=\s*([a-z0-9_.-]+)/i;
183 $def{minttl} = $1 if /^minttl\s*=\s*([a-z0-9_.-]+)/i;
184 $def{ttl} = $1 if /^ttl\s*=\s*([a-z0-9_.-]+)/i;
185 # Mail settings
186 $config{mailhost} = $1 if /^mailhost\s*=\s*([a-z0-9_.-]+)/i;
187 $config{mailsender} = $1 if /^mailsender\s*=\s*([a-z0-9_.@-]+)/i;
188 $config{mailname} = $1 if /^mailname\s*=\s*([a-z0-9\s_.-]+)/i;
189 }
190 close CFG;
191 } else {
192 $errstr = $!;
193 return;
194 }
195 return 1;
196} # end __cfgload()
197
198
199## DNSDB::connectDB()
200# Creates connection to DNS database.
201# Requires the database name, username, and password.
202# Returns a handle to the db.
203# Set up for a PostgreSQL db; could be any transactional DBMS with the
204# right changes.
205sub connectDB {
206 $errstr = '';
207 my $dbname = shift;
208 my $user = shift;
209 my $pass = shift;
210 my $dbh;
211 my $DSN = "DBI:Pg:dbname=$dbname";
212
213 my $host = shift;
214 $DSN .= ";host=$host" if $host;
215
216# Note that we want to autocommit by default, and we will turn it off locally as necessary.
217# We may not want to print gobbledygook errors; YMMV. Have to ponder that further.
218 $dbh = DBI->connect($DSN, $user, $pass, {
219 AutoCommit => 1,
220 PrintError => 0
221 })
222 or return (undef, $DBI::errstr) if(!$dbh);
223
224# Return here if we can't select. Note that this indicates a
225# problem executing the select.
226 my $sth = $dbh->prepare("select group_id from groups limit 1");
227 $sth->execute();
228 return (undef,$DBI::errstr) if ($sth->err);
229
230# See if the select returned anything (or null data). This should
231# succeed if the select executed, but...
232 $sth->fetchrow();
233 return (undef,$DBI::errstr) if ($sth->err);
234
235 $sth->finish;
236
237# If we get here, we should be OK.
238 return ($dbh,"DB connection OK");
239} # end connectDB
240
241
242## DNSDB::finish()
243# Cleans up after database handles and so on.
244# Requires a database handle
245sub finish {
246 my $dbh = $_[0];
247 $dbh->disconnect;
248} # end finish
249
250
251## DNSDB::initGlobals()
252# Initialize global variables
253# NB: this does NOT include web-specific session variables!
254# Requires a database handle
255sub initGlobals {
256 my $dbh = shift;
257
258# load system-wide site defaults and things from config file
259 if (open SYSDEFAULTS, "</etc/dnsdb.conf") {
260##fixme - error check!
261 while (<SYSDEFAULTS>) {
262 next if /^\s*#/;
263 $def{contact} = $1 if /contact ?= ?([a-z0-9_.-]+)/i;
264 $def{prins} = $1 if /prins ?= ?([a-z0-9_.-]+)/i;
265 $def{soattl} = $1 if /soattl ?= ?([a-z0-9_.-]+)/i;
266 $def{refresh} = $1 if /refresh ?= ?([a-z0-9_.-]+)/i;
267 $def{retry} = $1 if /retry ?= ?([a-z0-9_.-]+)/i;
268 $def{expire} = $1 if /expire ?= ?([a-z0-9_.-]+)/i;
269 $def{minttl} = $1 if /minttl ?= ?([a-z0-9_.-]+)/i;
270 $def{ttl} = $1 if /ttl ?= ?([a-z0-9_.-]+)/i;
271##fixme? load DB user/pass from config file?
272 }
273 }
274# load from database
275 my $sth = $dbh->prepare("select val,name from rectypes");
276 $sth->execute;
277 while (my ($recval,$recname) = $sth->fetchrow_array()) {
278 $typemap{$recval} = $recname;
279 $reverse_typemap{$recname} = $recval;
280 }
281} # end initGlobals
282
283
284## DNSDB::initPermissions()
285# Set up permissions global
286# Takes database handle and UID
287sub initPermissions {
288 my $dbh = shift;
289 my $uid = shift;
290
291# %permissions = $(getPermissions($dbh,'user',$uid));
292 getPermissions($dbh, 'user', $uid, \%permissions);
293
294} # end initPermissions()
295
296
297## DNSDB::getPermissions()
298# Get permissions from DB
299# Requires DB handle, group or user flag, ID, and hashref.
300sub getPermissions {
301 my $dbh = shift;
302 my $type = shift;
303 my $id = shift;
304 my $hash = shift;
305
306 my $sql = qq(
307 SELECT
308 p.admin,p.self_edit,
309 p.group_create,p.group_edit,p.group_delete,
310 p.user_create,p.user_edit,p.user_delete,
311 p.domain_create,p.domain_edit,p.domain_delete,
312 p.record_create,p.record_edit,p.record_delete
313 FROM permissions p
314 );
315 if ($type eq 'group') {
316 $sql .= qq(
317 JOIN groups g ON g.permission_id=p.permission_id
318 WHERE g.group_id=?
319 );
320 } else {
321 $sql .= qq(
322 JOIN users u ON u.permission_id=p.permission_id
323 WHERE u.user_id=?
324 );
325 }
326
327 my $sth = $dbh->prepare($sql);
328
329 $sth->execute($id) or die "argh: ".$sth->errstr;
330
331# my $permref = $sth->fetchrow_hashref;
332# return $permref;
333# $hash = $permref;
334# Eww. Need to learn how to forcibly drop a hashref onto an existing hash.
335 ($hash->{admin},$hash->{self_edit},
336 $hash->{group_create},$hash->{group_edit},$hash->{group_delete},
337 $hash->{user_create},$hash->{user_edit},$hash->{user_delete},
338 $hash->{domain_create},$hash->{domain_edit},$hash->{domain_delete},
339 $hash->{record_create},$hash->{record_edit},$hash->{record_delete})
340 = $sth->fetchrow_array;
341
342} # end getPermissions()
343
344
345## DNSDB::changePermissions()
346# Update an ACL entry
347# Takes a db handle, type, owner-id, and hashref for the changed permissions.
348sub changePermissions {
349 my $dbh = shift;
350 my $type = shift;
351 my $id = shift;
352 my $newperms = shift;
353 my $inherit = shift || 0;
354
355 my $failmsg = '';
356
357 # see if we're switching from inherited to custom. for bonus points,
358 # snag the permid and parent permid anyway, since we'll need the permid
359 # to set/alter custom perms, and both if we're switching from custom to
360 # inherited.
361 my $sth = $dbh->prepare("SELECT (u.permission_id=g.permission_id) AS was_inherited,u.permission_id,g.permission_id".
362 " FROM ".($type eq 'user' ? 'users' : 'groups')." u ".
363 " JOIN groups g ON u.".($type eq 'user' ? '' : 'parent_')."group_id=g.group_id ".
364 " WHERE u.".($type eq 'user' ? 'user' : 'group')."_id=?");
365 $sth->execute($id);
366
367 my ($wasinherited,$permid,$parpermid) = $sth->fetchrow_array;
368
369# hack phtoui
370# group id 1 is "special" in that it's it's own parent (err... possibly.)
371# may make its parent id 0 which doesn't exist, and as a bonus is Perl-false.
372 $wasinherited = 0 if ($type eq 'group' && $id == 1);
373
374 local $dbh->{AutoCommit} = 0;
375 local $dbh->{RaiseError} = 1;
376
377 # Wrap all the SQL in a transaction
378 eval {
379 if ($inherit) {
380
381 $dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='t',permission_id=? ".
382 "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($parpermid, $id) );
383 $dbh->do("DELETE FROM permissions WHERE permission_id=?", undef, ($permid) );
384
385 } else {
386
387 if ($wasinherited) { # munge new permission entry in if we're switching from inherited perms
388##fixme: need to add semirecursive bit to properly munge inherited permission ID on subgroups and users
389# ... if'n'when we have groups with fully inherited permissions.
390 # SQL is coo
391 $dbh->do("INSERT INTO permissions ($permlist,".($type eq 'user' ? 'user' : 'group')."_id) ".
392 "SELECT $permlist,? FROM permissions WHERE permission_id=?", undef, ($id,$permid) );
393 ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions ".
394 "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($id) );
395 $dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='f',permission_id=? ".
396 "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($permid, $id) );
397 }
398
399 # and now set the permissions we were passed
400 foreach (@permtypes) {
401 if (defined ($newperms->{$_})) {
402 $dbh->do("UPDATE permissions SET $_=? WHERE permission_id=?", undef, ($newperms->{$_},$permid) );
403 }
404 }
405
406 } # (inherited->)? custom
407
408 $dbh->commit;
409 }; # end eval
410 if ($@) {
411 my $msg = $@;
412 eval { $dbh->rollback; };
413 return ('FAIL',"$failmsg: $msg ($permid)");
414 } else {
415 return ('OK',$permid);
416 }
417
418} # end changePermissions()
419
420
421## DNSDB::comparePermissions()
422# Compare two permission hashes
423# Returns '>', '<', '=', '!'
424sub comparePermissions {
425 my $p1 = shift;
426 my $p2 = shift;
427
428 my $retval = '='; # assume equality until proven otherwise
429
430 no warnings "uninitialized";
431
432 foreach (@permtypes) {
433 next if $p1->{$_} == $p2->{$_}; # equal is good
434 if ($p1->{$_} && !$p2->{$_}) {
435 if ($retval eq '<') { # if we've already found an unequal pair where
436 $retval = '!'; # $p2 has more access, and we now find a pair
437 last; # where $p1 has more access, the overall access
438 } # is neither greater or lesser, it's unequal.
439 $retval = '>';
440 }
441 if (!$p1->{$_} && $p2->{$_}) {
442 if ($retval eq '>') { # if we've already found an unequal pair where
443 $retval = '!'; # $p1 has more access, and we now find a pair
444 last; # where $p2 has more access, the overall access
445 } # is neither greater or lesser, it's unequal.
446 $retval = '<';
447 }
448 }
449 return $retval;
450} # end comparePermissions()
451
452
453## DNSDB::changeGroup()
454# Change group ID of an entity
455# Takes a database handle, entity type, entity ID, and new group ID
456sub changeGroup {
457 my $dbh = shift;
458 my $type = shift;
459 my $id = shift;
460 my $newgrp = shift;
461
462##fixme: fail on not enough args
463 #return ('FAIL', "Missing
464
465 if ($type eq 'domain') {
466 $dbh->do("UPDATE domains SET group_id=? WHERE domain_id=?", undef, ($newgrp, $id))
467 or return ('FAIL','Group change failed: '.$dbh->errstr);
468 } elsif ($type eq 'user') {
469 $dbh->do("UPDATE users SET group_id=? WHERE user_id=?", undef, ($newgrp, $id))
470 or return ('FAIL','Group change failed: '.$dbh->errstr);
471 } elsif ($type eq 'group') {
472 $dbh->do("UPDATE groups SET parent_group_id=? WHERE group_id=?", undef, ($newgrp, $id))
473 or return ('FAIL','Group change failed: '.$dbh->errstr);
474 }
475 return ('OK','OK');
476} # end changeGroup()
477
478
479## DNSDB::_log()
480# Log an action
481# Internal sub
482# Takes a database handle, <foo>, <bar>
483sub _log {
484} # end _log
485
486
487##
488## Processing subs
489##
490
491## DNSDB::addDomain()
492# Add a domain
493# Takes a database handle, domain name, numeric group, and boolean(ish) state (active/inactive)
494# Returns a status code and message
495sub addDomain {
496 $errstr = '';
497 my $dbh = shift;
498 return ('FAIL',"Need database handle") if !$dbh;
499 my $domain = shift;
500 return ('FAIL',"Domain must not be blank") if !$domain;
501 my $group = shift;
502 return ('FAIL',"Need group") if !defined($group);
503 my $state = shift;
504 return ('FAIL',"Need domain status") if !defined($state);
505
506 $state = 1 if $state =~ /^active$/;
507 $state = 1 if $state =~ /^on$/;
508 $state = 0 if $state =~ /^inactive$/;
509 $state = 0 if $state =~ /^off$/;
510
511 return ('FAIL',"Invalid domain status") if $state !~ /^\d+$/;
512
513 my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
514 my $dom_id;
515
516# quick check to start to see if we've already got one
517 $sth->execute($domain);
518 ($dom_id) = $sth->fetchrow_array;
519
520 return ('FAIL', "Domain already exists") if $dom_id;
521
522 # Allow transactions, and raise an exception on errors so we can catch it later.
523 # Use local to make sure these get "reset" properly on exiting this block
524 local $dbh->{AutoCommit} = 0;
525 local $dbh->{RaiseError} = 1;
526
527 # Wrap all the SQL in a transaction
528 eval {
529 # insert the domain...
530 my $sth = $dbh->prepare("insert into domains (domain,group_id,status) values (?,?,?)");
531 $sth->execute($domain,$group,$state);
532
533 # get the ID...
534 $sth = $dbh->prepare("select domain_id from domains where domain='$domain'");
535 $sth->execute;
536 ($dom_id) = $sth->fetchrow_array();
537
538 # ... and now we construct the standard records from the default set. NB: group should be variable.
539 $sth = $dbh->prepare("select host,type,val,distance,weight,port,ttl from default_records where group_id=$group");
540 my $sth_in = $dbh->prepare("insert into records (domain_id,host,type,val,distance,weight,port,ttl)".
541 " values ($dom_id,?,?,?,?,?,?,?)");
542 $sth->execute;
543 while (my ($host,$type,$val,$dist,$weight,$port,$ttl) = $sth->fetchrow_array()) {
544 $host =~ s/DOMAIN/$domain/g;
545 $val =~ s/DOMAIN/$domain/g;
546 $sth_in->execute($host,$type,$val,$dist,$weight,$port,$ttl);
547 }
548
549 # once we get here, we should have suceeded.
550 $dbh->commit;
551 }; # end eval
552
553 if ($@) {
554 my $msg = $@;
555 eval { $dbh->rollback; };
556 return ('FAIL',$msg);
557 } else {
558 return ('OK',$dom_id);
559 }
560} # end addDomain
561
562
563## DNSDB::delDomain()
564# Delete a domain.
565# for now, just delete the records, then the domain.
566# later we may want to archive it in some way instead (status code 2, for example?)
567sub delDomain {
568 my $dbh = shift;
569 my $domid = shift;
570
571 # Allow transactions, and raise an exception on errors so we can catch it later.
572 # Use local to make sure these get "reset" properly on exiting this block
573 local $dbh->{AutoCommit} = 0;
574 local $dbh->{RaiseError} = 1;
575
576 my $failmsg = '';
577
578 # Wrap all the SQL in a transaction
579 eval {
580 my $sth = $dbh->prepare("delete from records where domain_id=?");
581 $failmsg = "Failure removing domain records";
582 $sth->execute($domid);
583 $sth = $dbh->prepare("delete from domains where domain_id=?");
584 $failmsg = "Failure removing domain";
585 $sth->execute($domid);
586
587 # once we get here, we should have suceeded.
588 $dbh->commit;
589 }; # end eval
590
591 if ($@) {
592 my $msg = $@;
593 eval { $dbh->rollback; };
594 return ('FAIL',"$failmsg: $msg");
595 } else {
596 return ('OK','OK');
597 }
598
599} # end delDomain()
600
601
602## DNSDB::domainName()
603# Return the domain name based on a domain ID
604# Takes a database handle and the domain ID
605# Returns the domain name or undef on failure
606sub domainName {
607 $errstr = '';
608 my $dbh = shift;
609 my $domid = shift;
610 my ($domname) = $dbh->selectrow_array("SELECT domain FROM domains WHERE domain_id=?", undef, ($domid) );
611 $errstr = $DBI::errstr if !$domname;
612 return $domname if $domname;
613} # end domainName()
614
615
616## DNSDB::domainID()
617# Takes a database handle and domain name
618# Returns the domain ID number
619sub domainID {
620 $errstr = '';
621 my $dbh = shift;
622 my $domain = shift;
623 my ($domid) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE domain=?", undef, ($domain) );
624 $errstr = $DBI::errstr if !$domid;
625 return $domid if $domid;
626} # end domainID()
627
628
629## DNSDB::addGroup()
630# Add a group
631# Takes a database handle, group name, parent group, hashref for permissions,
632# and optional template-vs-cloneme flag
633# Returns a status code and message
634sub addGroup {
635 $errstr = '';
636 my $dbh = shift;
637 my $groupname = shift;
638 my $pargroup = shift;
639 my $permissions = shift;
640
641 # 0 indicates "custom", hardcoded.
642 # Any other value clones that group's default records, if it exists.
643 my $inherit = shift || 0;
644##fixme: need a flag to indicate clone records or <?> ?
645
646 # Allow transactions, and raise an exception on errors so we can catch it later.
647 # Use local to make sure these get "reset" properly on exiting this block
648 local $dbh->{AutoCommit} = 0;
649 local $dbh->{RaiseError} = 1;
650
651 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE group_name=?");
652 my $group_id;
653
654# quick check to start to see if we've already got one
655 $sth->execute($groupname);
656 ($group_id) = $sth->fetchrow_array;
657
658 return ('FAIL', "Group already exists") if $group_id;
659
660 # Wrap all the SQL in a transaction
661 eval {
662 $sth = $dbh->prepare("INSERT INTO groups (parent_group_id,group_name) VALUES (?,?)");
663 $sth->execute($pargroup,$groupname);
664
665 $sth = $dbh->prepare("SELECT group_id FROM groups WHERE group_name=?");
666 $sth->execute($groupname);
667 my ($groupid) = $sth->fetchrow_array();
668
669# Permissions
670 if ($inherit) {
671 } else {
672 my @permvals;
673 foreach (@permtypes) {
674 if (!defined ($permissions->{$_})) {
675 push @permvals, 0;
676 } else {
677 push @permvals, $permissions->{$_};
678 }
679 }
680
681 $sth = $dbh->prepare("INSERT INTO permissions (group_id,$permlist) values (?".',?'x($#permtypes+1).")");
682 $sth->execute($groupid,@permvals);
683
684 $sth = $dbh->prepare("SELECT permission_id FROM permissions WHERE group_id=?");
685 $sth->execute($groupid);
686 my ($permid) = $sth->fetchrow_array();
687
688 $dbh->do("UPDATE groups SET permission_id=$permid WHERE group_id=$groupid");
689 } # done permission fiddling
690
691# Default records
692 $sth = $dbh->prepare("INSERT INTO default_records (group_id,host,type,val,distance,weight,port,ttl) ".
693 "VALUES ($groupid,?,?,?,?,?,?,?)");
694 if ($inherit) {
695 # Duplicate records from parent. Actually relying on inherited records feels
696 # very fragile, and it would be problematic to roll over at a later time.
697 my $sth2 = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
698 $sth2->execute($pargroup);
699 while (my @clonedata = $sth2->fetchrow_array) {
700 $sth->execute(@clonedata);
701 }
702 } else {
703##fixme: Hardcoding is Bad, mmmmkaaaay?
704 # reasonable basic defaults for SOA, MX, NS, and minimal hosting
705 # could load from a config file, but somewhere along the line we need hardcoded bits.
706 $sth->execute('ns1.example.com:hostmaster.example.com', 6, '10800:3600:604800:10800', 0, 0, 0, 86400);
707 $sth->execute('DOMAIN', 1, '192.168.4.2', 0, 0, 0, 7200);
708 $sth->execute('DOMAIN', 15, 'mx.example.com', 10, 0, 0, 7200);
709 $sth->execute('DOMAIN', 2, 'ns1.example.com', 0, 0, 0, 7200);
710 $sth->execute('DOMAIN', 2, 'ns2.example.com', 0, 0, 0, 7200);
711 $sth->execute('www.DOMAIN', 5, 'DOMAIN', 0, 0, 0, 7200);
712 }
713
714 # once we get here, we should have suceeded.
715 $dbh->commit;
716 }; # end eval
717
718 if ($@) {
719 my $msg = $@;
720 eval { $dbh->rollback; };
721 return ('FAIL',$msg);
722 } else {
723 return ('OK','OK');
724 }
725
726} # end addGroup()
727
728
729## DNSDB::delGroup()
730# Delete a group.
731# Takes a group ID
732# Returns a status code and message
733sub delGroup {
734 my $dbh = shift;
735 my $groupid = shift;
736
737 # Allow transactions, and raise an exception on errors so we can catch it later.
738 # Use local to make sure these get "reset" properly on exiting this block
739 local $dbh->{AutoCommit} = 0;
740 local $dbh->{RaiseError} = 1;
741
742##fixme: locate "knowable" error conditions and deal with them before the eval
743# ... or inside, whatever.
744# -> domains still exist in group
745# -> ...
746 my $failmsg = '';
747
748 # Wrap all the SQL in a transaction
749 eval {
750 my $sth = $dbh->prepare("SELECT count(*) FROM domains WHERE group_id=?");
751 $sth->execute($groupid);
752 my ($domcnt) = $sth->fetchrow_array;
753 $failmsg = "Can't remove group ".groupName($dbh,$groupid);
754 die "$domcnt domains still in group\n" if $domcnt;
755
756 $sth = $dbh->prepare("delete from default_records where group_id=?");
757 $failmsg = "Failed to delete default records for ".groupName($dbh,$groupid);
758 $sth->execute($groupid);
759 $sth = $dbh->prepare("delete from groups where group_id=?");
760 $failmsg = "Failed to remove group ".groupName($dbh,$groupid);
761 $sth->execute($groupid);
762
763 # once we get here, we should have suceeded.
764 $dbh->commit;
765 }; # end eval
766
767 if ($@) {
768 my $msg = $@;
769 eval { $dbh->rollback; };
770 return ('FAIL',"$failmsg: $msg");
771 } else {
772 return ('OK','OK');
773 }
774} # end delGroup()
775
776
777## DNSDB::getChildren()
778# Get a list of all groups whose parent^n is group <n>
779# Takes a database handle, group ID, reference to an array to put the group IDs in,
780# and an optional flag to return only immediate children or all children-of-children
781# default to returning all children
782# Calls itself
783sub getChildren {
784 $errstr = '';
785 my $dbh = shift;
786 my $rootgroup = shift;
787 my $groupdest = shift;
788 my $immed = shift || 'all';
789
790 # special break for default group; otherwise we get stuck.
791 if ($rootgroup == 1) {
792 # by definition, group 1 is the Root Of All Groups
793 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE NOT (group_id=1)".
794 ($immed ne 'all' ? " AND parent_group_id=1" : ''));
795 $sth->execute;
796 while (my @this = $sth->fetchrow_array) {
797 push @$groupdest, @this;
798 }
799 } else {
800 my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE parent_group_id=?");
801 $sth->execute($rootgroup);
802 return if $sth->rows == 0;
803 my @grouplist;
804 while (my ($group) = $sth->fetchrow_array) {
805 push @$groupdest, $group;
806 getChildren($dbh,$group,$groupdest) if $immed eq 'all';
807 }
808 }
809} # end getChildren()
810
811
812## DNSDB::groupName()
813# Return the group name based on a group ID
814# Takes a database handle and the group ID
815# Returns the group name or undef on failure
816sub groupName {
817 $errstr = '';
818 my $dbh = shift;
819 my $groupid = shift;
820 my $sth = $dbh->prepare("SELECT group_name FROM groups WHERE group_id=?");
821 $sth->execute($groupid);
822 my ($groupname) = $sth->fetchrow_array();
823 $errstr = $DBI::errstr if !$groupname;
824 return $groupname if $groupname;
825} # end groupName
826
827
828## DNSDB::groupID()
829# Return the group ID based on the group name
830# Takes a database handle and the group name
831# Returns the group ID or undef on failure
832sub groupID {
833 $errstr = '';
834 my $dbh = shift;
835 my $group = shift;
836 my ($grpid) = $dbh->selectrow_array("SELECT group_id FROM groups WHERE group=?", undef, ($group) );
837 $errstr = $DBI::errstr if !$grpid;
838 return $grpid if $grpid;
839} # end groupID()
840
841
842## DNSDB::addUser()
843# Add a user.
844# Takes a DB handle, username, group ID, password, state (active/inactive).
845# Optionally accepts:
846# user type (user/admin) - defaults to user
847# permissions string - defaults to inherit from group
848# three valid forms:
849# i - Inherit permissions
850# c:<user_id> - Clone permissions from <user_id>
851# C:<permission list> - Set these specific permissions
852# first name - defaults to username
853# last name - defaults to blank
854# phone - defaults to blank (could put other data within column def)
855# Returns (OK,<uid>) on success, (FAIL,<message>) on failure
856sub addUser {
857 $errstr = '';
858 my $dbh = shift;
859 my $username = shift;
860 my $group = shift;
861 my $pass = shift;
862 my $state = shift;
863
864 return ('FAIL', "Missing one or more required entries") if !defined($state);
865 return ('FAIL', "Username must not be blank") if !$username;
866
867 my $type = shift || 'u'; # create limited users by default - fwiw, not sure yet how this will interact with ACLs
868
869 my $permstring = shift || 'i'; # default is to inhert permissions from group
870
871 my $fname = shift || $username;
872 my $lname = shift || '';
873 my $phone = shift || ''; # not going format-check
874
875 my $sth = $dbh->prepare("SELECT user_id FROM users WHERE username=?");
876 my $user_id;
877
878# quick check to start to see if we've already got one
879 $sth->execute($username);
880 ($user_id) = $sth->fetchrow_array;
881
882 return ('FAIL', "User already exists") if $user_id;
883
884 # Allow transactions, and raise an exception on errors so we can catch it later.
885 # Use local to make sure these get "reset" properly on exiting this block
886 local $dbh->{AutoCommit} = 0;
887 local $dbh->{RaiseError} = 1;
888
889 my $failmsg = '';
890
891 # Wrap all the SQL in a transaction
892 eval {
893 # insert the user... note we set inherited perms by default since
894 # it's simple and cleans up some other bits of state
895 my $sth = $dbh->prepare("INSERT INTO users ".
896 "(group_id,username,password,firstname,lastname,phone,type,status,permission_id,inherit_perm) ".
897 "VALUES (?,?,?,?,?,?,?,?,(SELECT permission_id FROM permissions WHERE group_id=?),'t')");
898 $sth->execute($group,$username,unix_md5_crypt($pass),$fname,$lname,$phone,$type,$state,$group);
899
900 # get the ID...
901 ($user_id) = $dbh->selectrow_array("SELECT currval('users_user_id_seq')");
902
903# Permissions! Gotta set'em all!
904 die "Invalid permission string $permstring"
905 if $permstring !~ /^(?:
906 i # inherit
907 |c:\d+ # clone
908 # custom. no, the leading , is not a typo
909 |C:(?:,(?:group|user|domain|record|self)_(?:edit|create|delete))*
910 )$/x;
911# bleh. I'd call another function to do my dirty work, but we're in the middle of a transaction already.
912 if ($permstring ne 'i') {
913 # for cloned or custom permissions, we have to create a new permissions entry.
914 my $clonesrc = $group;
915 if ($permstring =~ /^c:(\d+)/) { $clonesrc = $1; }
916 $dbh->do("INSERT INTO permissions ($permlist,user_id) ".
917 "SELECT $permlist,? FROM permissions WHERE permission_id=".
918 "(SELECT permission_id FROM permissions WHERE ".($permstring =~ /^c:/ ? 'user' : 'group')."_id=?)",
919 undef, ($user_id,$clonesrc) );
920 $dbh->do("UPDATE users SET permission_id=".
921 "(SELECT permission_id FROM permissions WHERE user_id=?) ".
922 "WHERE user_id=?", undef, ($user_id, $user_id) );
923 }
924 if ($permstring =~ /^C:/) {
925 # finally for custom permissions, we set the passed-in permissions (and unset
926 # any that might have been brought in by the clone operation above)
927 my ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions WHERE user_id=?",
928 undef, ($user_id) );
929 foreach (@permtypes) {
930 if ($permstring =~ /,$_/) {
931 $dbh->do("UPDATE permissions SET $_='t' WHERE permission_id=?", undef, ($permid) );
932 } else {
933 $dbh->do("UPDATE permissions SET $_='f' WHERE permission_id=?", undef, ($permid) );
934 }
935 }
936 }
937
938 $dbh->do("UPDATE users SET inherit_perm='n' WHERE user_id=?", undef, ($user_id) );
939
940##fixme: add another table to hold name/email for log table?
941
942 # once we get here, we should have suceeded.
943 $dbh->commit;
944 }; # end eval
945
946 if ($@) {
947 my $msg = $@;
948 eval { $dbh->rollback; };
949 return ('FAIL',$msg." $failmsg");
950 } else {
951 return ('OK',$user_id);
952 }
953} # end addUser
954
955
956## DNSDB::checkUser()
957# Check user/pass combo on login
958sub checkUser {
959 my $dbh = shift;
960 my $user = shift;
961 my $inpass = shift;
962
963 my $sth = $dbh->prepare("SELECT user_id,group_id,password,firstname,lastname FROM users WHERE username=?");
964 $sth->execute($user);
965 my ($uid,$gid,$pass,$fname,$lname) = $sth->fetchrow_array;
966 my $loginfailed = 1 if !defined($uid);
967
968 if ($pass =~ m|^\$1\$([A-Za-z0-9/.]+)\$|) {
969 $loginfailed = 1 if $pass ne unix_md5_crypt($inpass,$1);
970 } else {
971 $loginfailed = 1 if $pass ne $inpass;
972 }
973
974 # nnnngggg
975 return ($uid, $gid);
976} # end checkUser
977
978
979## DNSDB:: updateUser()
980# Update general data about user
981sub updateUser {
982 my $dbh = shift;
983
984##fixme: tweak calling convention so that we can update any given bit of data
985 my $uid = shift;
986 my $username = shift;
987 my $group = shift;
988 my $pass = shift;
989 my $state = shift;
990 my $type = shift || 'u';
991 my $fname = shift || $username;
992 my $lname = shift || '';
993 my $phone = shift || ''; # not going format-check
994
995 my $failmsg = '';
996
997 # Allow transactions, and raise an exception on errors so we can catch it later.
998 # Use local to make sure these get "reset" properly on exiting this block
999 local $dbh->{AutoCommit} = 0;
1000 local $dbh->{RaiseError} = 1;
1001
1002 my $sth;
1003
1004 # Password can be left blank; if so we assume there's one on file.
1005 # Actual blank passwords are bad, mm'kay?
1006 if (!$pass) {
1007 $sth = $dbh->prepare("SELECT password FROM users WHERE user_id=?");
1008 $sth->execute($uid);
1009 ($pass) = $sth->fetchrow_array;
1010 } else {
1011 $pass = unix_md5_crypt($pass);
1012 }
1013
1014 eval {
1015 my $sth = $dbh->prepare(q(
1016 UPDATE users
1017 SET username=?, password=?, firstname=?, lastname=?, phone=?, type=?, status=?
1018 WHERE user_id=?
1019 )
1020 );
1021 $sth->execute($username, $pass, $fname, $lname, $phone, $type, $state, $uid);
1022 $dbh->commit;
1023 };
1024 if ($@) {
1025 my $msg = $@;
1026 eval { $dbh->rollback; };
1027 return ('FAIL',"$failmsg: $msg");
1028 } else {
1029 return ('OK','OK');
1030 }
1031} # end updateUser()
1032
1033
1034## DNSDB::delUser()
1035#
1036sub delUser {
1037 my $dbh = shift;
1038 return ('FAIL',"Need database handle") if !$dbh;
1039 my $userid = shift;
1040 return ('FAIL',"Missing userid") if !defined($userid);
1041
1042 my $sth = $dbh->prepare("delete from users where user_id=?");
1043 $sth->execute($userid);
1044
1045 return ('FAIL',"Couldn't remove user: ".$sth->errstr) if $sth->err;
1046
1047 return ('OK','OK');
1048
1049} # end delUser
1050
1051
1052## DNSDB::userFullName()
1053# Return a pretty string!
1054# Takes a user_id and optional printf-ish string to indicate which pieces where:
1055# %u for the username
1056# %f for the first name
1057# %l for the last name
1058# All other text in the passed string will be left as-is.
1059##fixme: need a "smart" option too, so that missing/null/blank first/last names don't give funky output
1060sub userFullName {
1061 $errstr = '';
1062 my $dbh = shift;
1063 my $userid = shift;
1064 my $fullformat = shift || '%f %l (%u)';
1065 my $sth = $dbh->prepare("select username,firstname,lastname from users where user_id=?");
1066 $sth->execute($userid);
1067 my ($uname,$fname,$lname) = $sth->fetchrow_array();
1068 $errstr = $DBI::errstr if !$uname;
1069
1070 $fullformat =~ s/\%u/$uname/g;
1071 $fullformat =~ s/\%f/$fname/g;
1072 $fullformat =~ s/\%l/$lname/g;
1073
1074 return $fullformat;
1075} # end userFullName
1076
1077
1078## DNSDB::userStatus()
1079# Sets and/or returns a user's status
1080# Takes a database handle, user ID and optionally a status argument
1081# Returns undef on errors.
1082sub userStatus {
1083 my $dbh = shift;
1084 my $id = shift;
1085 my $newstatus = shift;
1086
1087 return undef if $id !~ /^\d+$/;
1088
1089 my $sth;
1090
1091# ooo, fun! let's see what we were passed for status
1092 if ($newstatus) {
1093 $sth = $dbh->prepare("update users set status=? where user_id=?");
1094 # ass-u-me caller knows what's going on in full
1095 if ($newstatus =~ /^[01]$/) { # only two valid for now.
1096 $sth->execute($newstatus,$id);
1097 } elsif ($newstatus =~ /^usero(?:n|ff)$/) {
1098 $sth->execute(($newstatus eq 'useron' ? 1 : 0),$id);
1099 }
1100 }
1101
1102 $sth = $dbh->prepare("select status from users where user_id=?");
1103 $sth->execute($id);
1104 my ($status) = $sth->fetchrow_array;
1105 return $status;
1106} # end userStatus()
1107
1108
1109## DNSDB::getUserData()
1110# Get misc user data for display
1111sub getUserData {
1112 my $dbh = shift;
1113 my $uid = shift;
1114
1115 my $sth = $dbh->prepare("SELECT group_id,username,firstname,lastname,phone,type,status,inherit_perm ".
1116 "FROM users WHERE user_id=?");
1117 $sth->execute($uid);
1118 return $sth->fetchrow_hashref();
1119
1120} # end getUserData()
1121
1122
1123## DNSDB::getSOA()
1124# Return all suitable fields from an SOA record in separate elements of a hash
1125# Takes a database handle, default/live flag, and group (default) or domain (live) ID
1126sub getSOA {
1127 $errstr = '';
1128 my $dbh = shift;
1129 my $def = shift;
1130 my $id = shift;
1131 my %ret;
1132
1133 # (ab)use distance and weight columns to store SOA data
1134
1135 my $sql = "SELECT record_id,host,val,ttl,distance from";
1136 if ($def eq 'def' or $def eq 'y') {
1137 $sql .= " default_records WHERE group_id=? AND type=$reverse_typemap{SOA}";
1138 } else {
1139 # we're editing a live SOA record; find based on domain
1140 $sql .= " records WHERE domain_id=? AND type=$reverse_typemap{SOA}";
1141 }
1142 my $sth = $dbh->prepare($sql);
1143 $sth->execute($id);
1144
1145 my ($recid,$host,$val,$ttl,$serial) = $sth->fetchrow_array() or return;
1146 my ($prins,$contact) = split /:/, $host;
1147 my ($refresh,$retry,$expire,$minttl) = split /:/, $val;
1148
1149 $ret{recid} = $recid;
1150 $ret{ttl} = $ttl;
1151 $ret{serial} = $serial;
1152 $ret{prins} = $prins;
1153 $ret{contact} = $contact;
1154 $ret{refresh} = $refresh;
1155 $ret{retry} = $retry;
1156 $ret{expire} = $expire;
1157 $ret{minttl} = $minttl;
1158
1159 return %ret;
1160} # end getSOA()
1161
1162
1163## DNSDB::getRecLine()
1164# Return all data fields for a zone record in separate elements of a hash
1165# Takes a database handle, default/live flag, and record ID
1166sub getRecLine {
1167 $errstr = '';
1168 my $dbh = shift;
1169 my $def = shift;
1170 my $id = shift;
1171
1172 my $sql = "SELECT r.record_id,r.host,r.type,r.val,r.distance,r.weight,r.port,r.ttl,r.longrec_id,l.recdata".
1173 (($def eq 'def' or $def eq 'y') ? ',r.group_id FROM default_' : ',r.domain_id FROM ').
1174 "records r LEFT OUTER JOIN longrecs l ON r.longrec_id=l.longrec_id WHERE record_id=?";
1175 my $ret = $dbh->selectrow_hashref($sql, undef, ($id) );
1176
1177 if ($dbh->err) {
1178 $errstr = $DBI::errstr;
1179 return undef;
1180 }
1181
1182 if (!$ret) {
1183 $errstr = "No such record";
1184 return undef;
1185 }
1186
1187 $ret->{val} = $ret->{recdata} if $ret->{longrec_id}; # put the long data in the real value space
1188 delete $ret->{longrec_id}; # remove these since they shouldn't be exposed - the caller
1189 delete $ret->{recdata}; # should not care about "long records" vs normal ones.
1190 $ret->{parid} = (($def eq 'def' or $def eq 'y') ? $ret->{group_id} : $ret->{domain_id});
1191
1192 return $ret;
1193}
1194
1195
1196##fixme: should use above (getRecLine()) to get lines for below?
1197## DNSDB::getDomRecs()
1198# Return records for a domain
1199# Takes a database handle, default/live flag, group/domain ID, start,
1200# number of records, sort field, and sort order
1201# Returns a reference to an array of hashes
1202sub getDomRecs {
1203 $errstr = '';
1204 my $dbh = shift;
1205 my $type = shift;
1206 my $id = shift;
1207 my $nrecs = shift || 'all';
1208 my $nstart = shift || 0;
1209
1210## for order, need to map input to column names
1211 my $order = shift || 'host';
1212 my $direction = shift || 'ASC';
1213
1214 $type = 'y' if $type eq 'def';
1215
1216 my $sql = "SELECT r.record_id,r.host,r.type,r.val,r.distance,r.weight,r.port,r.ttl,r.longrec_id,l.recdata FROM ";
1217 $sql .= "default_" if $type eq 'y';
1218 $sql .= "records r ";
1219 $sql .= "INNER JOIN rectypes t ON r.type=t.val "; # for sorting by type alphabetically
1220 $sql .= "LEFT OUTER JOIN longrecs l ON r.longrec_id=l.longrec_id ";
1221 if ($type eq 'y') {
1222 $sql .= "WHERE r.group_id=?";
1223 } else {
1224 $sql .= "WHERE r.domain_id=?";
1225 }
1226 $sql .= " AND NOT r.type=$reverse_typemap{SOA}";
1227 # use alphaorder column for "correct" ordering of sort-by-type instead of DNS RR type number
1228 $sql .= " ORDER BY ".($order eq 'type' ? 't.alphaorder' : "r.$order")." $direction";
1229 $sql .= " LIMIT $nrecs OFFSET ".($nstart*$nrecs) if $nstart ne 'all';
1230
1231 my $sth = $dbh->prepare($sql) or warn $dbh->errstr;
1232 $sth->execute($id) or warn "$sql: ".$sth->errstr;
1233
1234 my @retbase;
1235 while (my $ref = $sth->fetchrow_hashref()) {
1236 $ref->{val} = $ref->{recdata} if $ref->{longrec_id}; # put the long data in the real value space
1237 delete $ref->{longrec_id}; # remove these since they shouldn't be exposed - the caller
1238 delete $ref->{recdata}; # should not care about "long records" vs normal ones.
1239 push @retbase, $ref;
1240 }
1241
1242 my $ret = \@retbase;
1243 return $ret;
1244} # end getDomRecs()
1245
1246
1247## DNSDB::getRecCount()
1248# Return count of non-SOA records in domain (or default records in a group)
1249# Takes a database handle, default/live flag and group/domain ID
1250# Returns the count
1251sub getRecCount {
1252 my $dbh = shift;
1253 my $defrec = shift;
1254 my $id = shift;
1255
1256 my ($count) = $dbh->selectrow_array("SELECT count(*) FROM ".
1257 ($defrec eq 'y' ? 'default_' : '')."records ".
1258 "WHERE ".($defrec eq 'y' ? 'group' : 'domain')."_id=? ".
1259 "AND NOT type=$reverse_typemap{SOA}", undef, ($id) );
1260
1261 return $count;
1262
1263} # end getRecCount()
1264
1265
1266## DNSDB::addRec()
1267# Add a new record to a domain or a group's default records
1268# Takes a database handle, default/live flag, group/domain ID,
1269# host, type, value, and TTL
1270# Some types require additional detail: "distance" for MX and SRV,
1271# and weight/port for SRV
1272# Returns a status code and detail message in case of error
1273sub addRec {
1274 $errstr = '';
1275 my $dbh = shift;
1276 my $defrec = shift;
1277 my $id = shift;
1278
1279 my $host = shift;
1280 my $rectype = shift;
1281 my $val = shift;
1282 my $ttl = shift;
1283
1284 my $fields = ($defrec eq 'y' ? 'group_id' : 'domain_id').",host,type,val,ttl";
1285 my $vallen = "?,?,?,?,?";
1286 my @vallist = ($id,$host,$rectype,$val,$ttl);
1287
1288 my $dist;
1289 if ($rectype == $reverse_typemap{MX} or $rectype == $reverse_typemap{SRV}) {
1290 $dist = shift;
1291 return ('FAIL',"Need distance for $typemap{$rectype} record") if !defined($dist);
1292 $fields .= ",distance";
1293 $vallen .= ",?";
1294 push @vallist, $dist;
1295 }
1296 my $weight;
1297 my $port;
1298 if ($rectype == $reverse_typemap{SRV}) {
1299 # check for _service._protocol. NB: RFC2782 does not say "MUST"... nor "SHOULD"...
1300 # it just says (paraphrased) "... is prepended with _ to prevent DNS collisions"
1301 return ('FAIL',"SRV records must begin with _service._protocol")
1302 if $host !~ /^_[A-Za-z]+\._[A-Za-z]+\.[a-z0-9-]+/;
1303 $weight = shift;
1304 $port = shift;
1305 return ('FAIL',"Need weight and port for SRV record") if !defined($weight) or !defined($port);
1306 $fields .= ",weight,port";
1307 $vallen .= ",?,?";
1308 push @vallist, ($weight,$port);
1309 }
1310
1311 # Allow transactions, and raise an exception on errors so we can catch it later.
1312 # Use local to make sure these get "reset" properly on exiting this block
1313 local $dbh->{AutoCommit} = 0;
1314 local $dbh->{RaiseError} = 1;
1315
1316 eval {
1317 if (length($val) > 100 ) {
1318 # extralong records get an entry in a separate table.
1319 $dbh->do("INSERT INTO longrecs (recdata) VALUES (?)", undef, ($val) );
1320 my ($longid) = $dbh->selectrow_array("SELECT longrec_id FROM longrecs WHERE recdata=?", undef, ($val) );
1321 $fields .= ",longrec_id";
1322 $vallen .= ",?";
1323 push @vallist, $longid;
1324 $vallist[3] = ''; # so we don't barf when we insert the main record
1325 }
1326 $dbh->do("INSERT INTO ".($defrec eq 'y' ? 'default_' : '')."records ($fields) VALUES ($vallen)",
1327 undef, @vallist);
1328 $dbh->commit;
1329 };
1330 if ($@) {
1331 my $msg = $@;
1332 eval { $dbh->rollback; };
1333 return ('FAIL',$msg);
1334 }
1335
1336 return ('OK','OK');
1337
1338} # end addRec()
1339
1340
1341## DNSDB::updateRec()
1342# Update a record
1343sub updateRec {
1344 $errstr = '';
1345
1346 my $dbh = shift;
1347 my $defrec = shift;
1348 my $id = shift;
1349
1350# all records have these
1351 my $host = shift;
1352 my $type = shift;
1353 my $val = shift;
1354 my $ttl = shift;
1355
1356 return('FAIL',"Missing standard argument(s)") if !defined($ttl);
1357
1358# only MX and SRV will use these
1359 my $dist = 0;
1360 my $weight = 0;
1361 my $port = 0;
1362
1363 if ($type == $reverse_typemap{MX} || $type == $reverse_typemap{SRV}) {
1364 $dist = shift;
1365 return ('FAIL',"MX or SRV requires distance") if !defined($dist);
1366 if ($type == $reverse_typemap{SRV}) {
1367 $weight = shift;
1368 return ('FAIL',"SRV requires weight") if !defined($weight);
1369 $port = shift;
1370 return ('FAIL',"SRV requires port") if !defined($port);
1371 }
1372 }
1373
1374# my $sql = "SELECT r.record_id,r.host,r.type,r.val,r.distance,r.weight,r.port,r.ttl,r.longrec_id,l.recdata FROM ";
1375# $sql .= "default_" if $type eq 'y';
1376# $sql .= "records r ";
1377# $sql .= "LEFT OUTER JOIN longrecs l ON r.longrec_id=l.longrec_id ";
1378
1379 # get the long record ID, if any
1380 my ($longid) = $dbh->selectrow_array("SELECT longrec_id FROM ".($defrec eq 'y' ? 'default_' : '')."records ".
1381 "WHERE record_id=?", undef, ($id) );
1382
1383 local $dbh->{AutoCommit} = 0;
1384 local $dbh->{RaiseError} = 1;
1385
1386 eval {
1387 # there's really no tidy way to squash this down. :/
1388 if (length($val) > 100) {
1389 if ($longid) {
1390 $dbh->do("UPDATE longrecs SET recdata=? WHERE longrec_id=?", undef, ($val, $longid) );
1391 } else {
1392##fixme: has to be a better way to be sure we get the right recid back once inserted...
1393 $dbh->do("INSERT INTO longrecs (recdata) VALUES (?)", undef, ($val) );
1394 my ($newlongid) = $dbh->selectrow_array("SELECT currval('longrecs_longrec_id_seq')");
1395 $dbh->do("UPDATE ".($defrec eq 'y' ? 'default_' : '')."records SET val=?,longrec_id=? ".
1396 "WHERE record_id=?", undef, ('', $newlongid, $id) );
1397 }
1398 } else {
1399 if ($longid) {
1400 $dbh->do("DELETE FROM longrecs WHERE longrec_id=?", undef, ($longid) );
1401 $dbh->do("UPDATE ".($defrec eq 'y' ? 'default_' : '')."records SET val=?,longrec_id=NULL ".
1402 "WHERE record_id=?", undef, ($val, $id) );
1403 } else {
1404 $dbh->do("UPDATE ".($defrec eq 'y' ? 'default_' : '')."records SET val=? ".
1405 "WHERE record_id=?", undef, ($val, $id) );
1406 }
1407 }
1408
1409 $dbh->do("UPDATE ".($defrec eq 'y' ? 'default_' : '')."records ".
1410 "SET host=?,type=?,ttl=?,distance=?,weight=?,port=? ".
1411 "WHERE record_id=?", undef, ($host, $type, $ttl, $dist, $weight, $port, $id) );
1412
1413 };
1414 if ($@) {
1415 my $msg = $@;
1416 $dbh->rollback;
1417 return ('FAIL', $msg);
1418 }
1419# return ('FAIL',$sth->errstr."<br>\n$errstr<br>\n") if $sth->err;
1420
1421 return ('OK','OK');
1422} # end updateRec()
1423
1424
1425## DNSDB::delRec()
1426# Delete a record.
1427sub delRec {
1428 $errstr = '';
1429 my $dbh = shift;
1430 my $defrec = shift;
1431 my $id = shift;
1432
1433 my $sth = $dbh->prepare("DELETE FROM ".($defrec eq 'y' ? 'default_' : '')."records WHERE record_id=?");
1434 $sth->execute($id);
1435
1436 return ('FAIL',"Couldn't remove record: ".$sth->errstr) if $sth->err;
1437
1438 return ('OK','OK');
1439} # end delRec()
1440
1441
1442 # Reference hashes.
1443 my %par_tbl = (
1444 group => 'groups',
1445 user => 'users',
1446 defrec => 'default_records',
1447 domain => 'domains',
1448 record => 'records'
1449 );
1450 my %id_col = (
1451 group => 'group_id',
1452 user => 'user_id',
1453 defrec => 'record_id',
1454 domain => 'domain_id',
1455 record => 'record_id'
1456 );
1457 my %par_col = (
1458 group => 'parent_group_id',
1459 user => 'group_id',
1460 defrec => 'group_id',
1461 domain => 'group_id',
1462 record => 'domain_id'
1463 );
1464 my %par_type = (
1465 group => 'group',
1466 user => 'group',
1467 defrec => 'group',
1468 domain => 'group',
1469 record => 'domain'
1470 );
1471
1472## DNSDB::getParents()
1473# Find out which entities are parent to the requested id
1474# Returns arrayref containing hash pairs of id/type
1475sub getParents {
1476 my $dbh = shift;
1477 my $id = shift;
1478 my $type = shift;
1479 my $depth = shift || 'all'; # valid values: 'all', 'immed', <int> (stop at this group ID)
1480
1481 my @parlist;
1482
1483 while (1) {
1484 my $result = $dbh->selectrow_hashref("SELECT $par_col{$type} FROM $par_tbl{$type} WHERE $id_col{$type} = ?",
1485 undef, ($id) );
1486 unshift @parlist, ($result->{$par_col{$type}} => $par_type{$type});
1487 last if $result->{$par_col{$type}} == 1; # group 1 is its own parent
1488 $type = $par_type{$type};
1489 $id = $result->{$par_col{$type}};
1490 }
1491
1492 return \@parlist;
1493
1494} # end getParents()
1495
1496
1497## DNSDB::isParent()
1498# Returns true if $id1 is a parent of $id2, false otherwise
1499sub isParent {
1500 my $dbh = shift;
1501 my $id1 = shift;
1502 my $type1 = shift;
1503 my $id2 = shift;
1504 my $type2 = shift;
1505##todo: immediate, secondary, full (default)
1506
1507 # Return false on impossible relations
1508 return 0 if $type1 eq 'record'; # nothing may be a child of a record
1509 return 0 if $type1 eq 'defrec'; # nothing may be a child of a record
1510 return 0 if $type1 eq 'user'; # nothing may be child of a user
1511 return 0 if $type1 eq 'domain' && $type2 ne 'record'; # domain may not be a parent of anything other than a record
1512
1513 # group 1 is the ultimate root parent
1514 return 1 if $type1 eq 'group' && $id1 == 1;
1515
1516# almost the same loop as getParents() above
1517 my $id = $id2;
1518 my $type = $type2;
1519 my $foundparent = 0;
1520my $tmp = 0;
1521 while (1) {
1522my $sql = "SELECT $par_col{$type} FROM $par_tbl{$type} WHERE $id_col{$type} = ?";
1523 my $result = $dbh->selectrow_hashref($sql,
1524 undef, ($id) ) or warn $dbh->errstr." $sql";
1525 if ($result->{$par_col{$type}} == $id1) {
1526 $foundparent = 1;
1527 last;
1528 }
1529 # group 1 is its own parent. need this here more to break strange loops than for detecting a parent
1530 last if $result->{$par_col{$type}} == 1;
1531 $type = $par_type{$type};
1532 $id = $result->{$par_col{$type}};
1533last if $tmp++ > 10;
1534 }
1535
1536 return $foundparent;
1537} # end isParent()
1538
1539
1540## DNSDB::domStatus()
1541# Sets and/or returns a domain's status
1542# Takes a database handle, domain ID and optionally a status argument
1543# Returns undef on errors.
1544sub domStatus {
1545 my $dbh = shift;
1546 my $id = shift;
1547 my $newstatus = shift;
1548
1549 return undef if $id !~ /^\d+$/;
1550
1551 my $sth;
1552
1553# ooo, fun! let's see what we were passed for status
1554 if ($newstatus) {
1555 $sth = $dbh->prepare("update domains set status=? where domain_id=?");
1556 # ass-u-me caller knows what's going on in full
1557 if ($newstatus =~ /^[01]$/) { # only two valid for now.
1558 $sth->execute($newstatus,$id);
1559 } elsif ($newstatus =~ /^domo(?:n|ff)$/) {
1560 $sth->execute(($newstatus eq 'domon' ? 1 : 0),$id);
1561 }
1562 }
1563
1564 $sth = $dbh->prepare("select status from domains where domain_id=?");
1565 $sth->execute($id);
1566 my ($status) = $sth->fetchrow_array;
1567 return $status;
1568} # end domStatus()
1569
1570
1571## DNSDB::importAXFR
1572# Import a domain via AXFR
1573# Takes AXFR host, domain to transfer, group to put the domain in,
1574# and optionally:
1575# - active/inactive state flag (defaults to active)
1576# - overwrite-SOA flag (defaults to off)
1577# - overwrite-NS flag (defaults to off, doesn't affect subdomain NS records)
1578# Returns a status code (OK, WARN, or FAIL) and message - message should be blank
1579# if status is OK, but WARN includes conditions that are not fatal but should
1580# really be reported.
1581sub importAXFR {
1582 my $dbh = shift;
1583 my $ifrom_in = shift;
1584 my $domain = shift;
1585 my $group = shift;
1586 my $status = shift || 1;
1587 my $rwsoa = shift || 0;
1588 my $rwns = shift || 0;
1589
1590##fixme: add mode to delete&replace, merge+overwrite, merge new?
1591
1592 my $nrecs = 0;
1593 my $soaflag = 0;
1594 my $nsflag = 0;
1595 my $warnmsg = '';
1596 my $ifrom;
1597
1598 # choke on possible bad setting in ifrom
1599 # IPv4 and v6, and valid hostnames!
1600 ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i);
1601 return ('FAIL', "Bad AXFR source host $ifrom")
1602 unless ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i);
1603
1604 # Allow transactions, and raise an exception on errors so we can catch it later.
1605 # Use local to make sure these get "reset" properly on exiting this block
1606 local $dbh->{AutoCommit} = 0;
1607 local $dbh->{RaiseError} = 1;
1608
1609 my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
1610 my $dom_id;
1611
1612# quick check to start to see if we've already got one
1613 $sth->execute($domain);
1614 ($dom_id) = $sth->fetchrow_array;
1615
1616 return ('FAIL', "Domain already exists") if $dom_id;
1617
1618 eval {
1619 # can't do this, can't nest transactions. sigh.
1620 #my ($dcode, $dmsg) = addDomain(dbh, domain, group, status);
1621
1622##fixme: serial
1623 my $sth = $dbh->prepare("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)");
1624 $sth->execute($domain,$group,$status);
1625
1626## bizarre DBI<->Net::DNS interaction bug:
1627## sometimes a zone will cause an immediate commit-and-exit (sort of) of the while()
1628## fixed, apparently I was doing *something* odd, but not certain what it was that
1629## caused a commit instead of barfing
1630
1631 # get domain id so we can do the records
1632 $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
1633 $sth->execute($domain);
1634 ($dom_id) = $sth->fetchrow_array();
1635
1636 my $res = Net::DNS::Resolver->new;
1637 $res->nameservers($ifrom);
1638 $res->axfr_start($domain)
1639 or die "Couldn't begin AXFR\n";
1640
1641 while (my $rr = $res->axfr_next()) {
1642 my $type = $rr->type;
1643
1644 my $sql = "INSERT INTO records (domain_id,host,type,ttl,val";
1645 my $vallen = "?,?,?,?,?";
1646
1647 $soaflag = 1 if $type eq 'SOA';
1648 $nsflag = 1 if $type eq 'NS';
1649
1650 my @vallist = ($dom_id, $rr->name, $reverse_typemap{$type}, $rr->ttl);
1651
1652# "Primary" types:
1653# A, NS, CNAME, SOA, PTR(warn in forward), MX, TXT, AAAA, SRV, A6(ob), SPF
1654# maybe KEY
1655
1656# nasty big ugly case-like thing here, since we have to do *some* different
1657# processing depending on the record. le sigh.
1658
1659##fixme: what record types other than TXT can/will have >255-byte payloads?
1660
1661 if ($type eq 'A') {
1662 push @vallist, $rr->address;
1663 } elsif ($type eq 'NS') {
1664# hmm. should we warn here if subdomain NS'es are left alone?
1665 next if ($rwns && ($rr->name eq $domain));
1666 push @vallist, $rr->nsdname;
1667 $nsflag = 1;
1668 } elsif ($type eq 'CNAME') {
1669 push @vallist, $rr->cname;
1670 } elsif ($type eq 'SOA') {
1671 next if $rwsoa;
1672 $vallist[1] = $rr->mname.":".$rr->rname;
1673 push @vallist, ($rr->refresh.":".$rr->retry.":".$rr->expire.":".$rr->minimum);
1674 $soaflag = 1;
1675 } elsif ($type eq 'PTR') {
1676 push @vallist, $rr->ptrdname;
1677 # hmm. PTR records should not be in forward zones.
1678 } elsif ($type eq 'MX') {
1679 $sql .= ",distance";
1680 $vallen .= ",?";
1681 push @vallist, $rr->exchange;
1682 push @vallist, $rr->preference;
1683 } elsif ($type eq 'TXT') {
1684##fixme: Net::DNS docs say this should be deprecated for rdatastr() or char_str_list(),
1685## but don't really seem enthusiastic about it.
1686 my $rrdata = $rr->txtdata;
1687 if (length($rrdata) > 100 ) {
1688 # extralong records get an entry in a separate table.
1689 $dbh->do("INSERT INTO longrecs (recdata) VALUES (?)", undef, ($rrdata) );
1690 my ($longid) = $dbh->selectrow_array("SELECT longrec_id FROM longrecs WHERE recdata=?", undef, ($rrdata) );
1691 $sql .= ",longrec_id";
1692 $vallen .= ",?";
1693 push @vallist, '';
1694 push @vallist, $longid;
1695 } else {
1696 push @vallist, $rrdata;
1697 }
1698 } elsif ($type eq 'SPF') {
1699##fixme: and the same caveat here, since it is apparently a clone of ::TXT
1700 my $rrdata = $rr->txtdata;
1701 if (length($rrdata) > 100 ) {
1702 # extralong records get an entry in a separate table.
1703 $dbh->do("INSERT INTO longrecs (recdata) VALUES (?)", undef, ($rrdata) );
1704 my ($longid) = $dbh->selectrow_array("SELECT longrec_id FROM longrecs WHERE recdata=?", undef, ($rrdata) );
1705 $sql .= ",longrec_id";
1706 $vallen .= ",?";
1707 push @vallist, '';
1708 push @vallist, $longid;
1709 } else {
1710 push @vallist, $rrdata;
1711 }
1712 } elsif ($type eq 'AAAA') {
1713 push @vallist, $rr->address;
1714 } elsif ($type eq 'SRV') {
1715 $sql .= ",distance,weight,port" if $type eq 'SRV';
1716 $vallen .= ",?,?,?" if $type eq 'SRV';
1717 push @vallist, $rr->target;
1718 push @vallist, $rr->priority;
1719 push @vallist, $rr->weight;
1720 push @vallist, $rr->port;
1721 } elsif ($type eq 'KEY') {
1722 # we don't actually know what to do with these...
1723 push @vallist, ($rr->flags.":".$rr->protocol.":".$rr->algorithm.":".$rr->key.":".$rr->keytag.":".$rr->privatekeyname);
1724 } else {
1725 my $rrdata = $rr->rdatastr;
1726 if (length($rrdata) > 100 ) {
1727 # extralong records get an entry in a separate table.
1728 $dbh->do("INSERT INTO longrecs (recdata) VALUES (?)", undef, ($rrdata) );
1729 my ($longid) = $dbh->selectrow_array("SELECT longrec_id FROM longrecs WHERE recdata=?", undef, ($rrdata) );
1730 $sql .= ",longrec_id";
1731 $vallen .= ",?";
1732 push @vallist, '';
1733 push @vallist, $longid;
1734 } else {
1735 push @vallist, $rrdata;
1736 }
1737 # Finding a different record type is not fatal.... just problematic.
1738 # We may not be able to export it correctly.
1739 $warnmsg .= "Unusual record ".$rr->name." ($type) found\n";
1740 }
1741
1742# BIND supports:
1743# A CNAME HINFO MB(ex) MD(ob) MF(ob) MG(ex) MINFO(ex) MR(ex) MX NS NULL
1744# PTR SOA TXT WKS AFSDB(ex) ISDN(ex) RP(ex) RT(ex) X25(ex) PX
1745# ... if one can ever find the right magic to format them correctly
1746
1747# Net::DNS supports:
1748# RRSIG SIG NSAP NS NIMLOC NAPTR MX MR MINFO MG MB LOC ISDN IPSECKEY HINFO
1749# EID DNAME CNAME CERT APL AFSDB AAAA A DS NXT NSEC3PARAM NSEC3 NSEC KEY
1750# DNSKEY DLV X25 TXT TSIG TKEY SSHFP SRV SPF SOA RT RP PX PTR NULL APL::AplItem
1751
1752 $sth = $dbh->prepare($sql.") VALUES (".$vallen.")") or die "problem preparing record insert SQL\n";
1753 $sth->execute(@vallist) or die "failed to insert ".$rr->string.": ".$sth->errstr."\n";
1754
1755 $nrecs++;
1756
1757 } # while axfr_next
1758
1759 # Overwrite SOA record
1760 if ($rwsoa) {
1761 $soaflag = 1;
1762 my $sthgetsoa = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?");
1763 my $sthputsoa = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)");
1764 $sthgetsoa->execute($group,$reverse_typemap{SOA});
1765 while (my ($host,$val,$ttl) = $sthgetsoa->fetchrow_array()) {
1766 $host =~ s/DOMAIN/$domain/g;
1767 $val =~ s/DOMAIN/$domain/g;
1768 $sthputsoa->execute($dom_id,$host,$reverse_typemap{SOA},$val,$ttl);
1769 }
1770 }
1771
1772 # Overwrite NS records
1773 if ($rwns) {
1774 $nsflag = 1;
1775 my $sthgetns = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?");
1776 my $sthputns = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)");
1777 $sthgetns->execute($group,$reverse_typemap{NS});
1778 while (my ($host,$val,$ttl) = $sthgetns->fetchrow_array()) {
1779 $host =~ s/DOMAIN/$domain/g;
1780 $val =~ s/DOMAIN/$domain/g;
1781 $sthputns->execute($dom_id,$host,$reverse_typemap{NS},$val,$ttl);
1782 }
1783 }
1784
1785 die "No records found; either $ifrom is not authoritative or doesn't allow transfers\n" if !$nrecs;
1786 die "Bad zone: No SOA record!\n" if !$soaflag;
1787 die "Bad zone: No NS records!\n" if !$nsflag;
1788
1789 $dbh->commit;
1790
1791 };
1792
1793 if ($@) {
1794 my $msg = $@;
1795 eval { $dbh->rollback; };
1796 return ('FAIL',$msg." $warnmsg");
1797 } else {
1798 return ('WARN', $warnmsg) if $warnmsg;
1799 return ('OK',"Imported OK");
1800 }
1801
1802 # it should be impossible to get here.
1803 return ('WARN',"OOOK!");
1804} # end importAXFR()
1805
1806
1807## DNSDB::export()
1808# Export the DNS database, or a part of it
1809# Takes database handle, export type, optional arguments depending on type
1810# Writes zone data to targets as appropriate for type
1811sub export {
1812 my $dbh = shift;
1813 my $target = shift;
1814
1815 if ($target eq 'tiny') {
1816 __export_tiny($dbh,@_);
1817 }
1818# elsif ($target eq 'foo') {
1819# __export_foo($dbh,@_);
1820#}
1821# etc
1822
1823} # end export()
1824
1825
1826## DNSDB::__export_tiny
1827# Internal sub to implement tinyDNS (compatible) export
1828# Takes database handle, filehandle to write export to, optional argument(s)
1829# to determine which data gets exported
1830sub __export_tiny {
1831 my $dbh = shift;
1832 my $datafile = shift;
1833
1834##fixme: slurp up further options to specify particular zone(s) to export
1835
1836 ## Convert a bare number into an octal-coded pair of octets.
1837 # Take optional arg to indicate a decimal or hex input. Defaults to hex.
1838 sub octalize {
1839 my $tmp = shift;
1840 my $srctype = shift || 'h'; # default assumes hex string
1841 $tmp = sprintf "%0.4x", hex($tmp) if $srctype eq 'h'; # 0-pad hex to 4 digits
1842 $tmp = sprintf "%0.4x", $tmp if $srctype eq 'd'; # 0-pad decimal to 4 hex digits
1843 my @o = ($tmp =~ /^(..)(..)$/); # split into octets
1844 return sprintf "\\%0.3o\\%0.3o", hex($o[0]), hex($o[1]);;
1845 }
1846
1847##fixme: fail if $datafile isn't an open, writable file
1848
1849 # easy case - export all evarything
1850 # not-so-easy case - export item(s) specified
1851 # todo: figure out what kind of list we use to export items
1852
1853 my $domsth = $dbh->prepare("SELECT domain_id,domain,status FROM domains WHERE status=1");
1854 my $recsth = $dbh->prepare("SELECT r.host,r.type,r.val,r.distance,r.weight,r.port,r.ttl,l.recdata ".
1855 "FROM records r LEFT OUTER JOIN longrecs l ON r.longrec_id=l.longrec_id WHERE domain_id=?");
1856 $domsth->execute();
1857 while (my ($domid,$dom,$domstat) = $domsth->fetchrow_array) {
1858 $recsth->execute($domid);
1859 while (my ($host,$type,$val,$dist,$weight,$port,$ttl,$lval) = $recsth->fetchrow_array) {
1860##fixme: need to store location in the db, and retrieve it here.
1861# temporarily hardcoded to empty so we can include it further down.
1862my $loc = '';
1863
1864##fixme: record validity timestamp. tinydns supports fiddling with timestamps.
1865# note $ttl must be set to 0 if we want to use tinydns's auto-expiring timestamps.
1866# timestamps are TAI64
1867# ~~ 2^62 + time()
1868my $stamp = '';
1869
1870 $val = $lval if $lval;
1871
1872# raw packet in unknown format: first byte indicates length
1873# of remaining data, allows up to 255 raw bytes
1874
1875##fixme? append . to all host/val hostnames
1876 if ($typemap{$type} eq 'SOA') {
1877
1878 # host contains pri-ns:responsible
1879 # val is abused to contain refresh:retry:expire:minttl
1880##fixme: "manual" serial vs tinydns-autoserial
1881 print $datafile "Z$host"."::$val:$ttl:$stamp:$loc\n";
1882
1883 } elsif ($typemap{$type} eq 'A') {
1884
1885 print $datafile "+$host:$val:$ttl:$stamp:$loc\n";
1886
1887 } elsif ($typemap{$type} eq 'NS') {
1888
1889 print $datafile "\&$host"."::$val:$ttl:$stamp:$loc\n";
1890
1891 } elsif ($typemap{$type} eq 'AAAA') {
1892
1893 print $datafile ":$host:28:";
1894 my $altgrp = 0;
1895 my @altconv;
1896 # Split in to up to 8 groups of hex digits (allows for IPv6 :: 0-collapsing)
1897 foreach (split /:/, $val) {
1898 if (/^$/) {
1899 # flag blank entry; this is a series of 0's of (currently) unknown length
1900 $altconv[$altgrp++] = 's';
1901 } else {
1902 # call sub to convert 1-4 hex digits to 2 string-rep octal bytes
1903 $altconv[$altgrp++] = octalize($_)
1904 }
1905 }
1906 foreach my $octet (@altconv) {
1907 # if not 's', output
1908 print $datafile $octet unless $octet =~ /^s$/;
1909 # if 's', output (9-array length)x literal '\000\000'
1910 print $datafile '\000\000'x(9-$altgrp) if $octet =~ /^s$/;
1911 }
1912 print $datafile ":$ttl:$stamp:$loc\n";
1913
1914 } elsif ($typemap{$type} eq 'MX') {
1915
1916 print $datafile "\@$host"."::$val:$dist:$ttl:$stamp:$loc\n";
1917
1918 } elsif ($typemap{$type} eq 'TXT') {
1919
1920##fixme: split v-e-r-y long TXT strings? will need to do so for BIND export, at least
1921 $val =~ s/:/\\072/g; # may need to replace other symbols
1922 print $datafile "'$host:$val:$ttl:$stamp:$loc\n";
1923
1924# by-hand TXT
1925#:deepnet.cx:16:2v\075spf1\040a\040a\072bacon.deepnet.cx\040a\072home.deepnet.cx\040-all:3600
1926#@ IN TXT "v=spf1 a a:bacon.deepnet.cx a:home.deepnet.cx -all"
1927#'deepnet.cx:v=spf1 a a\072bacon.deepnet.cx a\072home.deepnet.cx -all:3600
1928
1929#txttest IN TXT "v=foo bar:bob kn;ob' \" !@#$%^&*()-=_+[]{}<>?"
1930#: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
1931
1932# very long TXT record as brought in by axfr-get
1933# note tinydns does not support >512-byte RR data, need axfr-dns (for TCP support) for that
1934# also note, tinydns does not seem to support <512, >256-byte RRdata from axfr-get either. :/
1935#:longtxt.deepnet.cx:16:
1936#\170this is a very long txt record. it is really long. long. very long. really very long. this is a very long txt record.
1937#\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.
1938#\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.
1939#:3600
1940
1941 } elsif ($typemap{$type} eq 'CNAME') {
1942
1943 print $datafile "C$host:$val:$ttl:$stamp:$loc\n";
1944
1945 } elsif ($typemap{$type} eq 'SRV') {
1946
1947 # data is two-byte values for priority, weight, port, in that order,
1948 # followed by length/string data
1949
1950 print $datafile ":$host:33:".octalize($dist,'d').octalize($weight,'d').octalize($port,'d');
1951
1952 $val .= '.' if $val !~ /\.$/;
1953 foreach (split /\./, $val) {
1954 printf $datafile "\\%0.3o%s", length($_), $_;
1955 }
1956 print $datafile "\\000:$ttl:$stamp:$loc\n";
1957
1958 } elsif ($typemap{$type} eq 'RP') {
1959
1960 # RP consists of two mostly free-form strings.
1961 # The first is supposed to be an email address with @ replaced by . (as with the SOA contact)
1962 # The second is the "hostname" of a TXT record with more info.
1963 print $datafile ":$host:17:";
1964 my ($who,$what) = split /\s/, $val;
1965 foreach (split /\./, $who) {
1966 printf $datafile "\\%0.3o%s", length($_), $_;
1967 }
1968 print $datafile '\000';
1969 foreach (split /\./, $what) {
1970 printf $datafile "\\%0.3o%s", length($_), $_;
1971 }
1972 print $datafile "\\000:$ttl:$stamp:$loc\n";
1973
1974 } elsif ($typemap{$type} eq 'PTR') {
1975
1976 # must handle both IPv4 and IPv6
1977##work
1978 # data should already be in suitable reverse order.
1979 print $datafile "^$host:$val:$ttl:$stamp:$loc\n";
1980
1981 } else {
1982 # raw record. we don't know what's in here, so we ASS-U-ME the user has
1983 # put it in correctly, since either the user is messing directly with the
1984 # database, or the record was imported via AXFR
1985 # <split by char>
1986 # convert anything not a-zA-Z0-9.- to octal coding
1987
1988##fixme: add flag to export "unknown" record types - note we'll probably end up
1989# mangling them since they were written to the DB from Net::DNS::RR::<type>->rdatastr.
1990 #print $datafile ":$host:$type:$val:$ttl:$stamp:$loc\n";
1991
1992 } # record type if-else
1993
1994 } # while ($recsth)
1995 } # while ($domsth)
1996} # end __export_tiny()
1997
1998
1999# shut Perl up
20001;
Note: See TracBrowser for help on using the repository browser.