FS/FS/domain_record.pm

   1 package FS::domain_record;
   2
   3 use strict;
   4 use vars qw( @ISA $noserial_hack $DEBUG $me );
   5 use FS::Conf;
   6 use FS::Record qw( qsearchs dbh ); #qsearch
   7 use FS::svc_domain;
   8 use FS::svc_www;
   9
  10 @ISA = qw(FS::Record);
  11
  12 $DEBUG = 0;
  13 $me = '[FS::domain_record]';
  14
  15 =head1 NAME
  16
  17 FS::domain_record - Object methods for domain_record records
  18
  19 =head1 SYNOPSIS
  20
  21   use FS::domain_record;
  22
  23   $record = new FS::domain_record \%hash;
  24   $record = new FS::domain_record { 'column' => 'value' };
  25
  26   $error = $record->insert;
  27
  28   $error = $new_record->replace($old_record);
  29
  30   $error = $record->delete;
  31
  32   $error = $record->check;
  33
  34 =head1 DESCRIPTION
  35
  36 An FS::domain_record object represents an entry in a DNS zone.
  37 FS::domain_record inherits from FS::Record.  The following fields are currently
  38 supported:
  39
  40 =over 4
  41
  42 =item recnum - primary key
  43
  44 =item svcnum - Domain (see L<FS::svc_domain>) of this entry
  45
  46 =item reczone - partial (or full) zone for this entry
  47
  48 =item recaf - address family for this entry, currently only `IN' is recognized.
  49
  50 =item rectype - record type for this entry (A, MX, etc.)
  51
  52 =item recdata - data for this entry
  53
  54 =item ttl - time to live
  55
  56 =back
  57
  58 =head1 METHODS
  59
  60 =over 4
  61
  62 =item new HASHREF
  63
  64 Creates a new entry.  To add the entry to the database, see L<"insert">.
  65
  66 Note that this stores the hash reference, not a distinct copy of the hash it
  67 points to.  You can ask the object for a copy with the I<hash> method.
  68
  69 =cut
  70
  71 sub table { 'domain_record'; }
  72
  73 =item insert
  74
  75 Adds this record to the database.  If there is an error, returns the error,
  76 otherwise returns false.
  77
  78 =cut
  79
  80 sub insert {
  81   my $self = shift;
  82
  83   local $SIG{HUP} = 'IGNORE';
  84   local $SIG{INT} = 'IGNORE';
  85   local $SIG{QUIT} = 'IGNORE';
  86   local $SIG{TERM} = 'IGNORE';
  87   local $SIG{TSTP} = 'IGNORE';
  88   local $SIG{PIPE} = 'IGNORE';
  89
  90   my $oldAutoCommit = $FS::UID::AutoCommit;
  91   local $FS::UID::AutoCommit = 0;
  92   my $dbh = dbh;
  93
  94   if ( $self->rectype eq '_mstr' ) { #delete all other records
  95     foreach my $domain_record ( reverse $self->svc_domain->domain_record ) {
  96       my $error = $domain_record->delete;
  97       if ( $error ) {
  98         $dbh->rollback if $oldAutoCommit;
  99         return $error;
 100       }
 101     }
 102   }
 103
 104   my $error = $self->SUPER::insert;
 105   if ( $error ) {
 106     $dbh->rollback if $oldAutoCommit;
 107     return $error;
 108   }
 109
 110   unless ( $self->rectype =~ /^(SOA|_mstr)$/ ) {
 111     my $error = $self->increment_serial;
 112     if ( $error ) {
 113       $dbh->rollback if $oldAutoCommit;
 114       return $error;
 115     }
 116   }
 117
 118   my $conf = new FS::Conf;
 119   if ( $self->rectype =~ /^A$/ && ! $conf->exists('disable_autoreverse') ) {
 120     my $reverse = $self->reverse_record;
 121     if ( $reverse && ! $reverse->recnum ) {
 122       my $error = $reverse->insert;
 123       if ( $error ) {
 124         $dbh->rollback if $oldAutoCommit;
 125         return "error adding corresponding reverse-ARPA record: $error";
 126       }
 127     }
 128   }
 129
 130   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 131
 132   '';
 133
 134 }
 135
 136 =item delete
 137
 138 Delete this record from the database.
 139
 140 =cut
 141
 142 sub delete {
 143   my $self = shift;
 144
 145   return "Can't delete a domain record which has a website!"
 146     if qsearchs( 'svc_www', { 'recnum' => $self->recnum } );
 147
 148   local $SIG{HUP} = 'IGNORE';
 149   local $SIG{INT} = 'IGNORE';
 150   local $SIG{QUIT} = 'IGNORE';
 151   local $SIG{TERM} = 'IGNORE';
 152   local $SIG{TSTP} = 'IGNORE';
 153   local $SIG{PIPE} = 'IGNORE';
 154
 155   my $oldAutoCommit = $FS::UID::AutoCommit;
 156   local $FS::UID::AutoCommit = 0;
 157   my $dbh = dbh;
 158
 159   my $error = $self->SUPER::delete;
 160   if ( $error ) {
 161     $dbh->rollback if $oldAutoCommit;
 162     return $error;
 163   }
 164
 165   unless ( $self->rectype =~ /^(SOA|_mstr)$/ ) {
 166     my $error = $self->increment_serial;
 167     if ( $error ) {
 168       $dbh->rollback if $oldAutoCommit;
 169       return $error;
 170     }
 171   }
 172
 173   my $conf = new FS::Conf;
 174   if ( $self->rectype =~ /^A$/ && ! $conf->exists('disable_autoreverse') ) {
 175     my $reverse = $self->reverse_record;
 176     if ( $reverse && $reverse->recnum && $reverse->recdata eq $self->zone.'.' ){
 177       my $error = $reverse->delete;
 178       if ( $error ) {
 179         $dbh->rollback if $oldAutoCommit;
 180         return "error removing corresponding reverse-ARPA record: $error";
 181       }
 182     }
 183   }
 184
 185   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 186
 187   '';
 188
 189 }
 190
 191 =item replace OLD_RECORD
 192
 193 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 194 returns the error, otherwise returns false.
 195
 196 =cut
 197
 198 sub replace {
 199   my $self = shift;
 200
 201   local $SIG{HUP} = 'IGNORE';
 202   local $SIG{INT} = 'IGNORE';
 203   local $SIG{QUIT} = 'IGNORE';
 204   local $SIG{TERM} = 'IGNORE';
 205   local $SIG{TSTP} = 'IGNORE';
 206   local $SIG{PIPE} = 'IGNORE';
 207
 208   my $oldAutoCommit = $FS::UID::AutoCommit;
 209   local $FS::UID::AutoCommit = 0;
 210   my $dbh = dbh;
 211
 212   my $error = $self->SUPER::replace(@_);
 213   if ( $error ) {
 214     $dbh->rollback if $oldAutoCommit;
 215     return $error;
 216   }
 217
 218   unless ( $self->rectype eq 'SOA' ) {
 219     my $error = $self->increment_serial;
 220     if ( $error ) {
 221       $dbh->rollback if $oldAutoCommit;
 222       return $error;
 223     }
 224   }
 225
 226   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 227
 228   '';
 229
 230 }
 231
 232 =item check
 233
 234 Checks all fields to make sure this is a valid entry.  If there is
 235 an error, returns the error, otherwise returns false.  Called by the insert
 236 and replace methods.
 237
 238 =cut
 239
 240 # the check method should currently be supplied - FS::Record contains some
 241 # data checking routines
 242
 243 sub check {
 244   my $self = shift;
 245
 246   my $error =
 247     $self->ut_numbern('recnum')
 248     || $self->ut_number('svcnum')
 249   ;
 250   return $error if $error;
 251
 252   return "Unknown svcnum (in svc_domain)"
 253     unless qsearchs('svc_domain', { 'svcnum' => $self->svcnum } );
 254
 255   my $conf = new FS::Conf;
 256
 257   if ( $conf->exists('zone-underscore') ) {
 258     $self->reczone =~ /^(@|[a-z0-9_\.\-\*]+)$/i
 259       or return "Illegal reczone: ". $self->reczone;
 260     $self->reczone($1);
 261   } else {
 262     $self->reczone =~ /^(@|[a-z0-9\.\-\*]+)$/i
 263       or return "Illegal reczone: ". $self->reczone;
 264     $self->reczone($1);
 265   }
 266
 267   $self->recaf =~ /^(IN)$/ or return "Illegal recaf: ". $self->recaf;
 268   $self->recaf($1);
 269
 270   $self->ttl =~ /^([0-9]{0,6})$/ or return "Illegal ttl: ". $self->ttl;
 271   $self->ttl($1);
 272
 273   my %rectypes = map { $_=>1 } ( @{ $self->rectypes }, '_mstr' );
 274   return 'Illegal rectype: '. $self->rectype
 275     unless exists $rectypes{$self->rectype} && $rectypes{$self->rectype};
 276
 277   return "Illegal reczone for ". $self->rectype. ": ". $self->reczone
 278     if $self->rectype !~ /^MX$/i && $self->reczone =~ /\*/;
 279
 280   if ( $self->rectype eq 'SOA' ) {
 281     my $recdata = $self->recdata;
 282     $recdata =~ s/\s+/ /g;
 283     $recdata =~ /^([a-z0-9\.\-]+ [\w\-\+]+\.[a-z0-9\.\-]+ \( ((\d+|((\d+[WDHMS])+)) ){5}\))$/i
 284       or return "Illegal data for SOA record: $recdata";
 285     $self->recdata($1);
 286   } elsif ( $self->rectype eq 'NS' ) {
 287     $self->recdata =~ /^([a-z0-9\.\-]+)$/i
 288       or return "Illegal data for NS record: ". $self->recdata;
 289     $self->recdata($1);
 290   } elsif ( $self->rectype eq 'MX' ) {
 291     $self->recdata =~ /^(\d+)\s+([a-z0-9\.\-]+)$/i
 292       or return "Illegal data for MX record: ". $self->recdata;
 293     $self->recdata("$1 $2");
 294   } elsif ( $self->rectype eq 'A' ) {
 295     $self->recdata =~ /^((\d{1,3}\.){3}\d{1,3})$/
 296       or return "Illegal data for A record: ". $self->recdata;
 297     $self->recdata($1);
 298   } elsif ( $self->rectype eq 'AAAA' ) {
 299     $self->recdata =~ /^([\da-z:]+)$/
 300       or return "Illegal data for AAAA record: ". $self->recdata;
 301     $self->recdata($1);
 302   } elsif ( $self->rectype eq 'PTR' ) {
 303     if ( $conf->exists('zone-underscore') ) {
 304       $self->recdata =~ /^([a-z0-9_\.\-]+)$/i
 305         or return "Illegal data for PTR record: ". $self->recdata;
 306       $self->recdata($1);
 307     } else {
 308       $self->recdata =~ /^([a-z0-9\.\-]+)$/i
 309         or return "Illegal data for PTR record: ". $self->recdata;
 310       $self->recdata($1);
 311     }
 312   } elsif ( $self->rectype eq 'CNAME' ) {
 313     $self->recdata =~ /^([a-z0-9\.\-]+|\@)$/i
 314       or return "Illegal data for CNAME record: ". $self->recdata;
 315     $self->recdata($1);
 316   } elsif ( $self->rectype eq 'TXT' ) {
 317     if ( $self->recdata =~ /^((?:\S+)|(?:".+"))$/ ) {
 318       $self->recdata($1);
 319     } else {
 320       $self->recdata('"'. $self->recdata. '"'); #?
 321     }
 322     #  or return "Illegal data for TXT record: ". $self->recdata;
 323   } elsif ( $self->rectype eq 'SRV' ) {
 324     $self->recdata =~ /^(\d+)\s+(\d+)\s+(\d+)\s+([a-z0-9\.\-]+)$/i
 325       or return "Illegal data for SRV record: ". $self->recdata;
 326     $self->recdata("$1 $2 $3 $4");
 327   } elsif ( $self->rectype eq '_mstr' ) {
 328     $self->recdata =~ /^((\d{1,3}\.){3}\d{1,3})$/
 329       or return "Illegal data for _master pseudo-record: ". $self->recdata;
 330   } else {
 331     warn "$me no specific check for ". $self->rectype. " records yet";
 332     $error = $self->ut_text('recdata');
 333     return $error if $error;
 334   }
 335
 336   $self->SUPER::check;
 337 }
 338
 339 =item increment_serial
 340
 341 =cut
 342
 343 sub increment_serial {
 344   return '' if $noserial_hack;
 345   my $self = shift;
 346
 347   my $soa = qsearchs('domain_record', {
 348     svcnum  => $self->svcnum,
 349     reczone => '@',
 350     recaf   => 'IN',
 351     rectype => 'SOA', } )
 352   || qsearchs('domain_record', {
 353     svcnum  => $self->svcnum,
 354     reczone => $self->svc_domain->domain.'.',
 355     recaf   => 'IN',
 356     rectype => 'SOA',
 357   } )
 358   or return "soa record not found; can't increment serial";
 359
 360   my $data = $soa->recdata;
 361   $data =~ s/(\(\D*)(\d+)/$1.($2+1)/e; #well, it works.
 362
 363   my %hash = $soa->hash;
 364   $hash{recdata} = $data;
 365   my $new = new FS::domain_record \%hash;
 366   $new->replace($soa);
 367 }
 368
 369 =item svc_domain
 370
 371 Returns the domain (see L<FS::svc_domain>) for this record.
 372
 373 =cut
 374
 375 sub svc_domain {
 376   my $self = shift;
 377   qsearchs('svc_domain', { svcnum => $self->svcnum } );
 378 }
 379
 380 =item zone
 381
 382 Returns the canonical zone name.
 383
 384 =cut
 385
 386 sub zone {
 387   my $self = shift;
 388   my $zone = $self->reczone; # or die ?
 389   if ( $zone =~ /\.$/ ) {
 390     $zone =~ s/\.$//;
 391   } else {
 392     my $svc_domain = $self->svc_domain; # or die ?
 393     $zone .= '.'. $svc_domain->domain;
 394     $zone =~ s/^\@\.//;
 395   }
 396   $zone;
 397 }
 398
 399 =item reverse_record
 400
 401 Returns the corresponding reverse-ARPA record as another FS::domain_record
 402 object.  If the specific record does not exist in the database but the
 403 reverse-ARPA zone itself does, an appropriate new record is created.  If no
 404 reverse-ARPA zone is available at all, returns false.
 405
 406 (You can test whether or not record itself exists in the database or is a new
 407 object that might need to be inserted by checking the recnum field)
 408
 409 Mostly used by the insert and delete methods - probably should see them for
 410 examples.
 411
 412 =cut
 413
 414 sub reverse_record {
 415   my $self = shift;
 416   warn "reverse_record called\n" if $DEBUG;
 417   #should support classless reverse-ARPA ala rfc2317 too
 418   $self->recdata =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/
 419     or return '';
 420   my $domain = "$3.$2.$1.in-addr.arpa";
 421   my $ptr_reczone = $4;
 422   warn "reverse_record: searching for domain: $domain\n" if $DEBUG;
 423   my $svc_domain = qsearchs('svc_domain', { 'domain' => $domain } )
 424     or return '';
 425   warn "reverse_record: found domain: $domain\n" if $DEBUG;
 426   my %hash = (
 427     'svcnum'  => $svc_domain->svcnum,
 428     'reczone' => $ptr_reczone,
 429     'recaf'   => 'IN',
 430     'rectype' => 'PTR',
 431   );
 432   qsearchs('domain_record', \%hash )
 433     or new FS::domain_record { %hash, 'recdata' => $self->zone.'.' };
 434 }
 435
 436 =item rectypes
 437
 438 =cut
 439 #http://en.wikipedia.org/wiki/List_of_DNS_record_types
 440 #DHCID?  other things?
 441 sub rectypes {
 442   [ qw(SOA A AAAA CNAME MX NS PTR SPF SRV TXT), #most common types
 443     #qw(DNAME), #uncommon types
 444     qw(DLV DNSKEY DS NSEC NSEC3 NSEC3PARAM RRSIG), #DNSSEC types
 445   ];
 446 }
 447
 448 =back
 449
 450 =head1 BUGS
 451
 452 The data validation doesn't check everything it could.  In particular,
 453 there is no protection against bad data that passes the regex, duplicate
 454 SOA records, forgetting the trailing `.', impossible IP addersses, etc.  Of
 455 course, it's still better than editing the zone files directly.  :)
 456
 457 =head1 SEE ALSO
 458
 459 L<FS::Record>, schema.html from the base documentation.
 460
 461 =cut
 462
 463 1;
 464