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