Ignore:
Timestamp:
12/10/13 17:47:44 (10 years ago)
Author:
Kris Deugau
Message:

/branches/stable

Merge reverse DNS and location work; 2 of mumble

Numerous conflicts due to hand-copy or partial merges

Location:
branches/stable
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • branches/stable

  • branches/stable/DNSDB.pm

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