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