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