FS/FS/domain_record.pm

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