RT#71513: Card tokenization in v4+
[freeside.git] / 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