site_perl/svc_domain.pm

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