site_perl/svc_domain.pm

   1 package FS::svc_domain;
   2
   3 use strict;
   4 use vars qw( @ISA $whois_hack $conf $mydomain $smtpmachine
   5   $tech_contact $from $to @nameservers @nameserver_ips @template
   6 );
   7 use Carp;
   8 use Mail::Internet;
   9 use Mail::Header;
  10 use Date::Format;
  11 use FS::Record qw(fields qsearch qsearchs);
  12 use FS::cust_svc;
  13 use FS::Conf;
  14
  15 @ISA = qw(FS::Record Exporter);
  16
  17 #ask FS::UID to run this stuff for us later
  18 $FS::UID::callback{'FS::domain'} = sub {
  19   $conf = new FS::Conf;
  20
  21   $mydomain = $conf->config('domain');
  22   $smtpmachine = $conf->config('smtpmachine');
  23
  24   my($internic)="/registries/internic";
  25   $tech_contact = $conf->config("$internic/tech_contact");
  26   $from = $conf->config("$internic/from");
  27   $to = $conf->config("$internic/to");
  28   my(@ns) = $conf->config("$internic/nameservers");
  29   @nameservers=map {
  30     /^\s*\d+\.\d+\.\d+\.\d+\s+([^\s]+)\s*$/
  31       or die "Illegal line in $internic/nameservers";
  32     $1;
  33   } @ns;
  34   @nameserver_ips=map {
  35     /^\s*(\d+\.\d+\.\d+\.\d+)\s+([^\s]+)\s*$/
  36       or die "Illegal line in $internic/nameservers!";
  37     $1;
  38   } @ns;
  39   @template = map { $_. "\n" } $conf->config("$internic/template");
  40
  41 };
  42
  43 =head1 NAME
  44
  45 FS::svc_domain - Object methods for svc_domain records
  46
  47 =head1 SYNOPSIS
  48
  49   use FS::svc_domain;
  50
  51   $record = new FS::svc_domain \%hash;
  52   $record = new FS::svc_domain { 'column' => 'value' };
  53
  54   $error = $record->insert;
  55
  56   $error = $new_record->replace($old_record);
  57
  58   $error = $record->delete;
  59
  60   $error = $record->check;
  61
  62   $error = $record->suspend;
  63
  64   $error = $record->unsuspend;
  65
  66   $error = $record->cancel;
  67
  68 =head1 DESCRIPTION
  69
  70 An FS::svc_domain object represents a domain.  FS::svc_domain inherits from
  71 FS::Record.  The following fields are currently supported:
  72
  73 =over 4
  74
  75 =item svcnum - primary key (assigned automatically for new accounts)
  76
  77 =item domain
  78
  79 =back
  80
  81 =head1 METHODS
  82
  83 =over 4
  84
  85 =item new HASHREF
  86
  87 Creates a new domain.  To add the domain to the database, see L<"insert">.
  88
  89 =cut
  90
  91 sub table { 'svc_domain'; }
  92
  93 =item insert
  94
  95 Adds this domain to the database.  If there is an error, returns the error,
  96 otherwise returns false.
  97
  98 The additional fields I<pkgnum> and I<svcpart> (see L<FS::cust_svc>) should be
  99 defined.  An FS::cust_svc record will be created and inserted.
 100
 101 The additional field I<action> should be set to I<N> for new domains or I<M>
 102 for transfers.
 103
 104 A registration or transfer email will be submitted unless
 105 $FS::svc_domain::whois_hack is true.
 106
 107 The additional field I<email> can be used to manually set the admin contact
 108 email address on this email.  Otherwise, the svc_acct records for this package
 109 (see L<FS::cust_pkg>) are searched.  If there is exactly one svc_acct record
 110 in the same package, it is automatically used.  Otherwise an error is returned.
 111
 112 =cut
 113
 114 sub insert {
 115   my $self = shift;
 116   my $error;
 117
 118   local $SIG{HUP} = 'IGNORE';
 119   local $SIG{INT} = 'IGNORE';
 120   local $SIG{QUIT} = 'IGNORE';
 121   local $SIG{TERM} = 'IGNORE';
 122   local $SIG{TSTP} = 'IGNORE';
 123
 124   $error = $self->check;
 125   return $error if $error;
 126
 127   return "Domain in use (here)"
 128     if qsearchs( 'svc_domain', { 'domain' => $self->domain } );
 129
 130   my $whois = ($self->_whois)[0];
 131   return "Domain in use (see whois)"
 132     if ( $self->action eq "N" && $whois !~ /^No match for/ );
 133   return "Domain not found (see whois)"
 134     if ( $self->action eq "M" && $whois =~ /^No match for/ );
 135
 136   my $svcnum = $self->svcnum;
 137   my $cust_svc;
 138   unless ( $svcnum ) {
 139     $cust_svc = new FS::cust_svc ( {
 140       'svcnum'  => $svcnum,
 141       'pkgnum'  => $self->pkgnum,
 142       'svcpart' => $self->svcpart,
 143     } );
 144     my $error = $cust_svc->insert;
 145     return $error if $error;
 146     $svcnum = $self->setfield( 'svcnum', $cust_svc->svcnum );
 147   }
 148
 149   $error = $self->SUPER::insert;
 150   if ( $error ) {
 151     $cust_svc->delete if $cust_svc;
 152     return $error;
 153   }
 154
 155   $self->submit_internic unless $whois_hack;
 156
 157   ''; #no error
 158 }
 159
 160 =item delete
 161
 162 Deletes this domain from the database.  If there is an error, returns the
 163 error, otherwise returns false.
 164
 165 The corresponding FS::cust_svc record will be deleted as well.
 166
 167 =cut
 168
 169 sub delete {
 170   my $self = shift;
 171   my $error;
 172
 173   my $svcnum = $self->svcnum;
 174
 175   $error = $self->delete;
 176   return $error if $error;
 177
 178   my $cust_svc = qsearchs( 'cust_svc', { 'svcnum' => $svcnum } );
 179   $error = $cust_svc->delete;
 180   return $error if $error;
 181
 182   '';
 183 }
 184
 185 =item replace OLD_RECORD
 186
 187 Replaces OLD_RECORD with this one in the database.  If there is an error,
 188 returns the error, otherwise returns false.
 189
 190 =cut
 191
 192 sub replace {
 193   my ( $new, $old ) = ( shift, shift );
 194   my $error;
 195
 196   return "Can't change domain - reorder."
 197     if $old->getfield('domain') ne $new->getfield('domain');
 198
 199   $new->SUPER::replace($old);
 200
 201 }
 202
 203 =item suspend
 204
 205 Just returns false (no error) for now.
 206
 207 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 208
 209 =cut
 210
 211 sub suspend {
 212   ''; #no error (stub)
 213 }
 214
 215 =item unsuspend
 216
 217 Just returns false (no error) for now.
 218
 219 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 220
 221 =cut
 222
 223 sub unsuspend {
 224   ''; #no error (stub)
 225 }
 226
 227 =item cancel
 228
 229 Just returns false (no error) for now.
 230
 231 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 232
 233 =cut
 234
 235 sub cancel {
 236   ''; #no error (stub)
 237 }
 238
 239 =item check
 240
 241 Checks all fields to make sure this is a valid domain.  If there is an error,
 242 returns the error, otherwise returns false.  Called by the insert and replace
 243 methods.
 244
 245 Sets any fixed values; see L<FS::part_svc>.
 246
 247 =cut
 248
 249 sub check {
 250   my $self = shift;
 251
 252   my($recref) = $self->hashref;
 253
 254   my $error;
 255
 256   $error =
 257     $self->ut_numbern('svcnum')
 258   ;
 259   return $error if $error;
 260
 261   #get part_svc (and pkgnum)
 262   my($svcpart,$pkgnum);
 263   my($svcnum)=$self->getfield('svcnum');
 264   if ($svcnum) {
 265     my($cust_svc)=qsearchs('cust_svc',{'svcnum'=>$svcnum});
 266     return "Unknown svcnum" unless $cust_svc;
 267     $svcpart=$cust_svc->svcpart;
 268     $pkgnum=$cust_svc->pkgnum;
 269   } else {
 270     $svcpart=$self->svcpart;
 271     $pkgnum=$self->pkgnum;
 272   }
 273   my($part_svc)=qsearchs('part_svc',{'svcpart'=>$svcpart});
 274   return "Unkonwn svcpart" unless $part_svc;
 275
 276   #set fixed fields from part_svc
 277   my($field);
 278   foreach $field ( fields('svc_acct') ) {
 279     if ( $part_svc->getfield('svc_domain__'. $field. '_flag') eq 'F' ) {
 280       $self->setfield($field,$part_svc->getfield('svc_domain__'. $field) );
 281     }
 282   }
 283
 284   unless ( $whois_hack ) {
 285     unless ( $self->email ) { #find out an email address
 286       my(@svc_acct);
 287       foreach ( qsearch('cust_svc',{'pkgnum'=>$pkgnum}) ) {
 288         my($svc_acct)=qsearchs('svc_acct',{'svcnum'=>$_->svcnum});
 289         push @svc_acct, $svc_acct if $svc_acct;
 290       }
 291
 292       if ( scalar(@svc_acct) == 0 ) {
 293         return "Must order an account in package ". $pkgnum. " first";
 294       } elsif ( scalar(@svc_acct) > 1 ) {
 295         return "More than one account in package ". $pkgnum. ": specify admin contact email";
 296       } else {
 297         $self->email($svc_acct[0]->username. '@'. $mydomain);
 298       }
 299     }
 300   }
 301
 302   #if ( $recref->{domain} =~ /^([\w\-\.]{1,22})\.(com|net|org|edu)$/ ) {
 303   if ( $recref->{domain} =~ /^([\w\-]{1,22})\.(com|net|org|edu)$/ ) {
 304     $recref->{domain} = "$1.$2";
 305   # hmmmmmmmm.
 306   } elsif ( $whois_hack && $recref->{domain} =~ /^([\w\-\.]+)$/ ) {
 307     $recref->{domain} = $1;
 308   } else {
 309     return "Illegal domain ". $recref->{domain}.
 310            " (or unknown registry - try \$whois_hack)";
 311   }
 312
 313   $recref->{action} =~ /^(M|N)$/ or return "Illegal action";
 314   $recref->{action} = $1;
 315
 316   $self->ut_textn('purpose');
 317
 318 }
 319
 320 =item _whois
 321
 322 Executes the command:
 323
 324   whois do $domain
 325
 326 and returns the output.
 327
 328 (Always returns I<No match for domian "$domain".> if
 329 $FS::svc_domain::whois_hack is set true.)
 330
 331 =cut
 332
 333 sub _whois {
 334   my $self = shift;
 335   my $domain = $self->domain;
 336   return ( "No match for domain \"$domain\"." ) if $whois_hack;
 337   open(WHOIS, "whois do $domain |");
 338   return <WHOIS>;
 339 }
 340
 341 =item submit_internic
 342
 343 Submits a registration email for this domain.
 344
 345 =cut
 346
 347 sub submit_internic {
 348   my $self = shift;
 349
 350   my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 351   return unless $cust_pkg;
 352   my cust_main) = qsearchs( 'cust_main', { 'custnum' => $cust_pkg->custnum } );
 353   return unless $cust_main;
 354
 355   my %subs = (
 356     'action'       => $self->action,
 357     'purpose'      => $self->purpose,
 358     'domain'       => $self->domain,
 359     'company'      => $cust_main->company
 360                         || $cust_main->getfield('first'). ' '.
 361                            $cust_main->getfield('last')
 362                       ,
 363     'city'         => $cust_main->city,
 364     'state'        => $cust_main->state,
 365     'zip'          => $cust_main->zip,
 366     'country'      => $cust_main->country,
 367     'last'         => $cust_main->getfield('last'),
 368     'first'        => $cust_main->getfield('first'),
 369     'daytime'      => $cust_main->daytime,
 370     'fax'          => $cust_main->fax,
 371     'email'        => $self->email,
 372     'tech_contact' => $tech_contact,
 373     'primary'      => shift @nameservers,
 374     'primary_ip'   => shift @nameserver_ips,
 375   );
 376
 377   #yuck
 378   my @xtemplate = @template;
 379   my @body;
 380   my $line;
 381   OLOOP: while ( defined( $line = shift @xtemplate ) ) {
 382
 383     if ( $line =~ /^###LOOP###$/ ) {
 384       my(@buffer);
 385       LOADBUF: while ( defined( $line = shift @xtemplate ) ) {
 386         last LOADBUF if ( $line =~ /^###ENDLOOP###$/ );
 387         push @buffer, $line;
 388       }
 389       my %lubs = (
 390         'address'      => $cust_main->address2
 391                             ? [ $cust_main->address1, $cust_main->address2 ]
 392                             : [ $cust_main->address1 ]
 393                           ,
 394         'secondary'    => [ @nameservers ],
 395         'secondary_ip' => [ @nameserver_ips ],
 396       );
 397       LOOP: while (1) {
 398         my @xbuffer = @buffer;
 399         SUBLOOP: while ( defined( $line = shift @xbuffer ) ) {
 400           if ( $line =~ /###(\w+)###/ ) {
 401             #last LOOP unless my($lub)=shift@{$lubs{$1}};
 402             next OLOOP unless my $lub = shift @{$lubs{$1}};
 403             $line =~ s/###(\w+)###/$lub/e;
 404             redo SUBLOOP;
 405           } else {
 406             push @body, $line;
 407           }
 408         } #SUBLOOP
 409       } #LOOP
 410
 411     }
 412
 413     if ( $line =~ /###(\w+)###/ ) {
 414       #$line =~ s/###(\w+)###/$subs{$1}/eg;
 415       $line =~ s/###(\w+)###/$subs{$1}/e;
 416       redo OLOOP;
 417     } else {
 418       push @body, $line;
 419     }
 420
 421   } #OLOOP
 422
 423   my $subject;
 424   if ( $self->action eq "M" ) {
 425     $subject = "MODIFY DOMAIN ". $self->domain;
 426   } elsif ( $self->action eq "N" ) {
 427     $subject = "NEW DOMAIN ". $self->domain;
 428   } else {
 429     croak "submit_internic called with action ". $self->action;
 430   }
 431
 432   $ENV{SMTPHOSTS} = $smtpmachine;
 433   $ENV{MAILADDRESS} = $from;
 434   my $header = Mail::Header->new( [
 435     "From: $from",
 436     "To: $to",
 437     "Sender: $from",
 438     "Reply-To: $from",
 439     "Date: ". time2str("%a, %d %b %Y %X %z", time),
 440     "Subject: $subject",
 441   ] );
 442
 443   my($msg)=Mail::Internet->new(
 444     'Header' => $header,
 445     'Body' => \@body,
 446   );
 447
 448   $msg->smtpsend or die "Can't send registration email"; #die? warn?
 449
 450 }
 451
 452 =back
 453
 454 =head1 VERSION
 455
 456 $Id: svc_domain.pm,v 1.4 1998-12-29 11:59:55 ivan Exp $
 457
 458 =head1 BUGS
 459
 460 All BIND/DNS fields should be included (and exported).
 461
 462 Delete doesn't send a registration template.
 463
 464 All registries should be supported.
 465
 466 Should change action to a real field.
 467
 468 =head1 SEE ALSO
 469
 470 L<FS::Record>, L<FS::Conf>, L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>,
 471 L<FS::SSH>, L<ssh>, L<dot-qmail>, schema.html from the base documentation,
 472 config.html from the base documentation.
 473
 474 =head1 HISTORY
 475
 476 ivan@voicenet.com 97-jul-21
 477
 478 rewrite ivan@sisd.com 98-mar-10
 479
 480 add internic bits ivan@sisd.com 98-mar-14
 481
 482 Changed 'day' to 'daytime' because Pg6.3 reserves the day word
 483         bmccane@maxbaud.net     98-apr-3
 484
 485 /var/spool/freeside/conf/registries/internic/, Mail::Internet, etc.
 486 ivan@sisd.com 98-jul-17-19
 487
 488 pod, some FS::Conf (not complete) ivan@sisd.com 98-sep-23
 489
 490 $Log: svc_domain.pm,v $
 491 Revision 1.4  1998-12-29 11:59:55  ivan
 492 mostly properly OO, some work still to be done with svc_ stuff
 493
 494 Revision 1.3  1998/11/13 09:56:57  ivan
 495 change configuration file layout to support multiple distinct databases (with
 496 own set of config files, export, etc.)
 497
 498 Revision 1.2  1998/10/14 08:18:21  ivan
 499 More informative error messages and better doc for admin contact email stuff
 500
 501
 502 =cut
 503
 504 1;
 505
 506