better serialization on debugging data, RT#7514
[freeside.git] / 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 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->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