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 =cut
 148
 149 sub insert {
 150   my($self)=@_;
 151   my($error);
 152
 153   local $SIG{HUP} = 'IGNORE';
 154   local $SIG{INT} = 'IGNORE';
 155   local $SIG{QUIT} = 'IGNORE';
 156   local $SIG{TERM} = 'IGNORE';
 157   local $SIG{TSTP} = 'IGNORE';
 158
 159   $error=$self->check;
 160   return $error if $error;
 161
 162   return "Domain in use (here)"
 163     if qsearchs('svc_domain',{'domain'=> $self->domain } );
 164
 165   my($whois)=(($self->_whois)[0]);
 166   return "Domain in use (see whois)"
 167     if ( $self->action eq "N" && $whois !~ /^No match for/ );
 168   return "Domain not found (see whois)"
 169     if ( $self->action eq "M" && $whois =~ /^No match for/ );
 170
 171   my($svcnum)=$self->getfield('svcnum');
 172   my($cust_svc);
 173   unless ( $svcnum ) {
 174     $cust_svc=create FS::cust_svc ( {
 175       'svcnum'  => $svcnum,
 176       'pkgnum'  => $self->getfield('pkgnum'),
 177       'svcpart' => $self->getfield('svcpart'),
 178     } );
 179     my($error) = $cust_svc->insert;
 180     return $error if $error;
 181     $svcnum = $self->setfield('svcnum',$cust_svc->getfield('svcnum'));
 182   }
 183
 184   $error = $self->add;
 185   if ($error) {
 186     $cust_svc->del if $cust_svc;
 187     return $error;
 188   }
 189
 190   $self->submit_internic unless $whois_hack;
 191
 192   ''; #no error
 193 }
 194
 195 =item delete
 196
 197 Deletes this domain from the database.  If there is an error, returns the
 198 error, otherwise returns false.
 199
 200 The corresponding FS::cust_svc record will be deleted as well.
 201
 202 =cut
 203
 204 sub delete {
 205   my($self)=@_;
 206   my($error);
 207
 208   my($svcnum)=$self->getfield('svcnum');
 209
 210   $error = $self->del;
 211   return $error if $error;
 212
 213   my($cust_svc)=qsearchs('cust_svc',{'svcnum'=>$svcnum});
 214   $error = $cust_svc->del;
 215   return $error if $error;
 216
 217   '';
 218 }
 219
 220 =item replace OLD_RECORD
 221
 222 Replaces OLD_RECORD with this one in the database.  If there is an error,
 223 returns the error, otherwise returns false.
 224
 225 =cut
 226
 227 sub replace {
 228   my($new,$old)=@_;
 229   my($error);
 230
 231   return "(Old) Not a svc_domain record!" unless $old->table eq "svc_domain";
 232   return "Can't change svcnum!"
 233     unless $old->getfield('svcnum') eq $new->getfield('svcnum');
 234
 235   return "Can't change domain - reorder."
 236     if $old->getfield('domain') ne $new->getfield('domain');
 237
 238   $error=$new->check;
 239   return $error if $error;
 240
 241   local $SIG{HUP} = 'IGNORE';
 242   local $SIG{INT} = 'IGNORE';
 243   local $SIG{QUIT} = 'IGNORE';
 244   local $SIG{TERM} = 'IGNORE';
 245   local $SIG{TSTP} = 'IGNORE';
 246
 247   $error = $new->rep($old);
 248   return $error if $error;
 249
 250   '';
 251
 252 }
 253
 254 =item suspend
 255
 256 Just returns false (no error) for now.
 257
 258 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 259
 260 =cut
 261
 262 sub suspend {
 263   ''; #no error (stub)
 264 }
 265
 266 =item unsuspend
 267
 268 Just returns false (no error) for now.
 269
 270 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 271
 272 =cut
 273
 274 sub unsuspend {
 275   ''; #no error (stub)
 276 }
 277
 278 =item cancel
 279
 280 Just returns false (no error) for now.
 281
 282 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 283
 284 =cut
 285
 286 sub cancel {
 287   ''; #no error (stub)
 288 }
 289
 290 =item check
 291
 292 Checks all fields to make sure this is a valid domain.  If there is an error,
 293 returns the error, otherwise returns false.  Called by the insert and replace
 294 methods.
 295
 296 Sets any fixed values; see L<FS::part_svc>.
 297
 298 =cut
 299
 300 sub check {
 301   my($self)=@_;
 302   return "Not a svc_domain record!" unless $self->table eq "svc_domain";
 303   my($recref) = $self->hashref;
 304
 305   $recref->{svcnum} =~ /^(\d*)$/ or return "Illegal svcnum";
 306   $recref->{svcnum} = $1;
 307
 308   #get part_svc (and pkgnum)
 309   my($svcpart,$pkgnum);
 310   my($svcnum)=$self->getfield('svcnum');
 311   if ($svcnum) {
 312     my($cust_svc)=qsearchs('cust_svc',{'svcnum'=>$svcnum});
 313     return "Unknown svcnum" unless $cust_svc;
 314     $svcpart=$cust_svc->svcpart;
 315     $pkgnum=$cust_svc->pkgnum;
 316   } else {
 317     $svcpart=$self->svcpart;
 318     $pkgnum=$self->pkgnum;
 319   }
 320   my($part_svc)=qsearchs('part_svc',{'svcpart'=>$svcpart});
 321   return "Unkonwn svcpart" unless $part_svc;
 322
 323   #set fixed fields from part_svc
 324   my($field);
 325   foreach $field ( fields('svc_acct') ) {
 326     if ( $part_svc->getfield('svc_domain__'. $field. '_flag') eq 'F' ) {
 327       $self->setfield($field,$part_svc->getfield('svc_domain__'. $field) );
 328     }
 329   }
 330
 331   unless ( $whois_hack ) {
 332     unless ( $self->email ) { #find out an email address
 333       my(@svc_acct);
 334       foreach ( qsearch('cust_svc',{'pkgnum'=>$pkgnum}) ) {
 335         my($svc_acct)=qsearchs('svc_acct',{'svcnum'=>$_->svcnum});
 336         push @svc_acct, $svc_acct if $svc_acct;
 337       }
 338
 339       if ( scalar(@svc_acct) == 0 ) {
 340         return "Must order an account first";
 341       } elsif ( scalar(@svc_acct) > 1 ) {
 342         return "More than one account in package ". $pkgnum. ": specify admin contact email";
 343       } else {
 344         $self->email($svc_acct[0]->username. '@'. $mydomain);
 345       }
 346     }
 347   }
 348
 349   #if ( $recref->{domain} =~ /^([\w\-\.]{1,22})\.(com|net|org|edu)$/ ) {
 350   if ( $recref->{domain} =~ /^([\w\-]{1,22})\.(com|net|org|edu)$/ ) {
 351     $recref->{domain} = "$1.$2";
 352   # hmmmmmmmm.
 353   } elsif ( $whois_hack && $recref->{domain} =~ /^([\w\-\.]+)$/ ) {
 354     $recref->{domain} = $1;
 355   } else {
 356     return "Illegal domain ". $recref->{domain}.
 357            " (or unknown registry - try \$whois_hack)";
 358   }
 359
 360   $recref->{action} =~ /^(M|N)$/ or return "Illegal action";
 361   $recref->{action} = $1;
 362
 363   $self->ut_textn('purpose');
 364
 365 }
 366
 367 =item _whois
 368
 369 Executes the command:
 370
 371   whois do $domain
 372
 373 and returns the output.
 374
 375 (Always returns I<No match for domian "$domain".> if
 376 $FS::svc_domain::whois_hack is set true.)
 377
 378 =cut
 379
 380 sub _whois {
 381   my($self)=@_;
 382   my($domain)=$self->domain;
 383   return ( "No match for domain \"$domain\"." ) if $whois_hack;
 384   open(WHOIS,"whois do $domain |");
 385   return <WHOIS>;
 386 }
 387
 388 =item submit_internic
 389
 390 Submits a registration email for this domain.
 391
 392 =cut
 393
 394 sub submit_internic {
 395   my($self)=@_;
 396
 397   my($cust_pkg)=qsearchs('cust_pkg',{'pkgnum'=>$self->pkgnum});
 398   return unless $cust_pkg;
 399   my($cust_main)=qsearchs('cust_main',{'custnum'=>$cust_pkg->custnum});
 400   return unless $cust_main;
 401
 402   my(%subs)=(
 403     'action'       => $self->action,
 404     'purpose'      => $self->purpose,
 405     'domain'       => $self->domain,
 406     'company'      => $cust_main->company
 407                         || $cust_main->getfield('first'). ' '.
 408                            $cust_main->getfield('last')
 409                       ,
 410     'city'         => $cust_main->city,
 411     'state'        => $cust_main->state,
 412     'zip'          => $cust_main->zip,
 413     'country'      => $cust_main->country,
 414     'last'         => $cust_main->getfield('last'),
 415     'first'        => $cust_main->getfield('first'),
 416     'daytime'      => $cust_main->daytime,
 417     'fax'          => $cust_main->fax,
 418     'email'        => $self->email,
 419     'tech_contact' => $tech_contact,
 420     'primary'      => shift @nameservers,
 421     'primary_ip'   => shift @nameserver_ips,
 422   );
 423
 424   #yuck
 425   my(@xtemplate)=@template;
 426   my(@body);
 427   my($line);
 428   OLOOP: while ( defined($line = shift @xtemplate) ) {
 429
 430     if ( $line =~ /^###LOOP###$/ ) {
 431       my(@buffer);
 432       LOADBUF: while ( defined($line = shift @xtemplate) ) {
 433         last LOADBUF if ( $line =~ /^###ENDLOOP###$/ );
 434         push @buffer, $line;
 435       }
 436       my(%lubs)=(
 437         'address'      => $cust_main->address2
 438                             ? [ $cust_main->address1, $cust_main->address2 ]
 439                             : [ $cust_main->address1 ]
 440                           ,
 441         'secondary'    => [ @nameservers ],
 442         'secondary_ip' => [ @nameserver_ips ],
 443       );
 444       LOOP: while (1) {
 445         my(@xbuffer)=@buffer;
 446         SUBLOOP: while ( defined($line = shift @xbuffer) ) {
 447           if ( $line =~ /###(\w+)###/ ) {
 448             #last LOOP unless my($lub)=shift@{$lubs{$1}};
 449             next OLOOP unless my $lub = shift @{$lubs{$1}};
 450             $line =~ s/###(\w+)###/$lub/e;
 451             redo SUBLOOP;
 452           } else {
 453             push @body, $line;
 454           }
 455         } #SUBLOOP
 456       } #LOOP
 457
 458     }
 459
 460     if ( $line =~ /###(\w+)###/ ) {
 461       #$line =~ s/###(\w+)###/$subs{$1}/eg;
 462       $line =~ s/###(\w+)###/$subs{$1}/e;
 463       redo OLOOP;
 464     } else {
 465       push @body, $line;
 466     }
 467
 468   } #OLOOP
 469
 470   my($subject);
 471   if ( $self->action eq "M" ) {
 472     $subject = "MODIFY DOMAIN ". $self->domain;
 473   } elsif ($self->action eq "N" ) {
 474     $subject = "NEW DOMAIN ". $self->domain;
 475   } else {
 476     croak "submit_internic called with action ". $self->action;
 477   }
 478
 479   $ENV{SMTPHOSTS}=$smtpmachine;
 480   $ENV{MAILADDRESS}=$from;
 481   my($header)=Mail::Header->new( [
 482     "From: $from",
 483     "To: $to",
 484     "Sender: $from",
 485     "Reply-To: $from",
 486     "Date: ". time2str("%a, %d %b %Y %X %z",time),
 487     "Subject: $subject",
 488   ] );
 489
 490   my($msg)=Mail::Internet->new(
 491     'Header' => $header,
 492     'Body' => \@body,
 493   );
 494
 495   $msg->smtpsend or die "Can't send registration email"; #die? warn?
 496
 497 }
 498
 499 =back
 500
 501 =head1 BUGS
 502
 503 It doesn't properly override FS::Record yet.
 504
 505 All BIND/DNS fields should be included (and exported).
 506
 507 All registries should be supported.
 508
 509 Not all configuration access is through FS::Conf!
 510
 511 Should change action to a real field.
 512
 513 =head1 SEE ALSO
 514
 515 L<FS::Record>, L<FS::Conf>, L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>,
 516 L<FS::SSH>, L<ssh>, L<dot-qmail>, schema.html from the base documentation,
 517 config.html from the base documentation.
 518
 519 =head1 HISTORY
 520
 521 ivan@voicenet.com 97-jul-21
 522
 523 rewrite ivan@sisd.com 98-mar-10
 524
 525 add internic bits ivan@sisd.com 98-mar-14
 526
 527 Changed 'day' to 'daytime' because Pg6.3 reserves the day word
 528         bmccane@maxbaud.net     98-apr-3
 529
 530 /var/spool/freeside/conf/registries/internic/, Mail::Internet, etc.
 531 ivan@sisd.com 98-jul-17-19
 532
 533 pod, some FS::Conf (not complete) ivan@sisd.com 98-sep-23
 534
 535 =cut
 536
 537 1;
 538
 539