FS/FS/domain_record.pm

   1 package FS::domain_record;
   2
   3 use strict;
   4 use vars qw( @ISA $noserial_hack $DEBUG );
   5 use FS::Conf;
   6 #use FS::Record qw( qsearch qsearchs );
   7 use FS::Record qw( qsearchs dbh );
   8 use FS::svc_domain;
   9 use FS::svc_www;
  10
  11 @ISA = qw(FS::Record);
  12
  13 $DEBUG = 0;
  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 =back
  55
  56 =head1 METHODS
  57
  58 =over 4
  59
  60 =item new HASHREF
  61
  62 Creates a new entry.  To add the example 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 example.  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->rectype =~ /^(SOA|NS|MX|A|PTR|CNAME|TXT|_mstr)$/
 269     or return "Illegal rectype (only SOA NS MX A PTR CNAME TXT recognized): ".
 270               $self->rectype;
 271   $self->rectype($1);
 272
 273   return "Illegal reczone for ". $self->rectype. ": ". $self->reczone
 274     if $self->rectype !~ /^MX$/i && $self->reczone =~ /\*/;
 275
 276   if ( $self->rectype eq 'SOA' ) {
 277     my $recdata = $self->recdata;
 278     $recdata =~ s/\s+/ /g;
 279     $recdata =~ /^([a-z0-9\.\-]+ [\w\-\+]+\.[a-z0-9\.\-]+ \( ((\d+|((\d+[WDHMS])+)) ){5}\))$/i
 280       or return "Illegal data for SOA record: $recdata";
 281     $self->recdata($1);
 282   } elsif ( $self->rectype eq 'NS' ) {
 283     $self->recdata =~ /^([a-z0-9\.\-]+)$/i
 284       or return "Illegal data for NS record: ". $self->recdata;
 285     $self->recdata($1);
 286   } elsif ( $self->rectype eq 'MX' ) {
 287     $self->recdata =~ /^(\d+)\s+([a-z0-9\.\-]+)$/i
 288       or return "Illegal data for MX record: ". $self->recdata;
 289     $self->recdata("$1 $2");
 290   } elsif ( $self->rectype eq 'A' ) {
 291     $self->recdata =~ /^((\d{1,3}\.){3}\d{1,3})$/
 292       or return "Illegal data for A record: ". $self->recdata;
 293     $self->recdata($1);
 294   } elsif ( $self->rectype eq 'PTR' ) {
 295     if ( $conf->exists('zone-underscore') ) {
 296       $self->recdata =~ /^([a-z0-9_\.\-]+)$/i
 297         or return "Illegal data for PTR record: ". $self->recdata;
 298       $self->recdata($1);
 299     } else {
 300       $self->recdata =~ /^([a-z0-9\.\-]+)$/i
 301         or return "Illegal data for PTR record: ". $self->recdata;
 302       $self->recdata($1);
 303     }
 304   } elsif ( $self->rectype eq 'CNAME' ) {
 305     $self->recdata =~ /^([a-z0-9\.\-]+|\@)$/i
 306       or return "Illegal data for CNAME record: ". $self->recdata;
 307     $self->recdata($1);
 308   } elsif ( $self->rectype eq 'TXT' ) {
 309     if ( $self->recdata =~ /^((?:\S+)|(?:".+"))$/ ) {
 310       $self->recdata($1);
 311     } else {
 312       $self->recdata('"'. $self->recdata. '"'); #?
 313     }
 314     #  or return "Illegal data for TXT record: ". $self->recdata;
 315   } elsif ( $self->rectype eq '_mstr' ) {
 316     $self->recdata =~ /^((\d{1,3}\.){3}\d{1,3})$/
 317       or return "Illegal data for _master pseudo-record: ". $self->recdata;
 318   } else {
 319     die "ack!";
 320   }
 321
 322   $self->SUPER::check;
 323 }
 324
 325 =item increment_serial
 326
 327 =cut
 328
 329 sub increment_serial {
 330   return '' if $noserial_hack;
 331   my $self = shift;
 332
 333   my $soa = qsearchs('domain_record', {
 334     svcnum  => $self->svcnum,
 335     reczone => '@',
 336     recaf   => 'IN',
 337     rectype => 'SOA', } )
 338   || qsearchs('domain_record', {
 339     svcnum  => $self->svcnum,
 340     reczone => $self->svc_domain->domain.'.',
 341     recaf   => 'IN',
 342     rectype => 'SOA',
 343   } )
 344   or return "soa record not found; can't increment serial";
 345
 346   my $data = $soa->recdata;
 347   $data =~ s/(\(\D*)(\d+)/$1.($2+1)/e; #well, it works.
 348
 349   my %hash = $soa->hash;
 350   $hash{recdata} = $data;
 351   my $new = new FS::domain_record \%hash;
 352   $new->replace($soa);
 353 }
 354
 355 =item svc_domain
 356
 357 Returns the domain (see L<FS::svc_domain>) for this record.
 358
 359 =cut
 360
 361 sub svc_domain {
 362   my $self = shift;
 363   qsearchs('svc_domain', { svcnum => $self->svcnum } );
 364 }
 365
 366 =item zone
 367
 368 Returns the canonical zone name.
 369
 370 =cut
 371
 372 sub zone {
 373   my $self = shift;
 374   my $zone = $self->reczone; # or die ?
 375   if ( $zone =~ /\.$/ ) {
 376     $zone =~ s/\.$//;
 377   } else {
 378     my $svc_domain = $self->svc_domain; # or die ?
 379     $zone .= '.'. $svc_domain->domain;
 380     $zone =~ s/^\@\.//;
 381   }
 382   $zone;
 383 }
 384
 385 =item reverse_record
 386
 387 Returns the corresponding reverse-ARPA record as another FS::domain_record
 388 object.  If the specific record does not exist in the database but the
 389 reverse-ARPA zone itself does, an appropriate new record is created.  If no
 390 reverse-ARPA zone is available at all, returns false.
 391
 392 (You can test whether or not record itself exists in the database or is a new
 393 object that might need to be inserted by checking the recnum field)
 394
 395 Mostly used by the insert and delete methods - probably should see them for
 396 examples.
 397
 398 =cut
 399
 400 sub reverse_record {
 401   my $self = shift;
 402   warn "reverse_record called\n" if $DEBUG;
 403   #should support classless reverse-ARPA ala rfc2317 too
 404   $self->recdata =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/
 405     or return '';
 406   my $domain = "$3.$2.$1.in-addr.arpa";
 407   my $ptr_reczone = $4;
 408   warn "reverse_record: searching for domain: $domain\n" if $DEBUG;
 409   my $svc_domain = qsearchs('svc_domain', { 'domain' => $domain } )
 410     or return '';
 411   warn "reverse_record: found domain: $domain\n" if $DEBUG;
 412   my %hash = (
 413     'svcnum'  => $svc_domain->svcnum,
 414     'reczone' => $ptr_reczone,
 415     'recaf'   => 'IN',
 416     'rectype' => 'PTR',
 417   );
 418   qsearchs('domain_record', \%hash )
 419     or new FS::domain_record { %hash, 'recdata' => $self->zone.'.' };
 420 }
 421
 422 =back
 423
 424 =head1 BUGS
 425
 426 The data validation doesn't check everything it could.  In particular,
 427 there is no protection against bad data that passes the regex, duplicate
 428 SOA records, forgetting the trailing `.', impossible IP addersses, etc.  Of
 429 course, it's still better than editing the zone files directly.  :)
 430
 431 =head1 SEE ALSO
 432
 433 L<FS::Record>, schema.html from the base documentation.
 434
 435 =cut
 436
 437 1;
 438