FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $conf
   5              $dir_prefix @shells $usernamemin
   6              $usernamemax $passwordmin $passwordmax
   7              $username_ampersand $username_letter $username_letterfirst
   8              $username_noperiod $username_nounderscore $username_nodash
   9              $username_uppercase
  10              $mydomain
  11              $welcome_template $welcome_from $welcome_subject $welcome_mimetype
  12              $smtpmachine
  13              $radius_password $radius_ip
  14              $dirhash
  15              @saltset @pw_set );
  16 use Carp;
  17 use Fcntl qw(:flock);
  18 use FS::UID qw( datasrc );
  19 use FS::Conf;
  20 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  21 use FS::svc_Common;
  22 use Net::SSH;
  23 use FS::cust_svc;
  24 use FS::part_svc;
  25 use FS::svc_acct_pop;
  26 use FS::svc_acct_sm;
  27 use FS::cust_main_invoice;
  28 use FS::svc_domain;
  29 use FS::raddb;
  30 use FS::queue;
  31 use FS::radius_usergroup;
  32 use FS::export_svc;
  33 use FS::part_export;
  34 use FS::Msgcat qw(gettext);
  35
  36 @ISA = qw( FS::svc_Common );
  37
  38 $DEBUG = 0;
  39 $me = '[FS::svc_acct]';
  40
  41 #ask FS::UID to run this stuff for us later
  42 $FS::UID::callback{'FS::svc_acct'} = sub {
  43   $conf = new FS::Conf;
  44   $dir_prefix = $conf->config('home');
  45   @shells = $conf->config('shells');
  46   $usernamemin = $conf->config('usernamemin') || 2;
  47   $usernamemax = $conf->config('usernamemax');
  48   $passwordmin = $conf->config('passwordmin') || 6;
  49   $passwordmax = $conf->config('passwordmax') || 8;
  50   $username_letter = $conf->exists('username-letter');
  51   $username_letterfirst = $conf->exists('username-letterfirst');
  52   $username_noperiod = $conf->exists('username-noperiod');
  53   $username_nounderscore = $conf->exists('username-nounderscore');
  54   $username_nodash = $conf->exists('username-nodash');
  55   $username_uppercase = $conf->exists('username-uppercase');
  56   $username_ampersand = $conf->exists('username-ampersand');
  57   $mydomain = $conf->config('domain');
  58   $dirhash = $conf->config('dirhash') || 0;
  59   if ( $conf->exists('welcome_email') ) {
  60     $welcome_template = new Text::Template (
  61       TYPE   => 'ARRAY',
  62       SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
  63     ) or warn "can't create welcome email template: $Text::Template::ERROR";
  64     $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
  65     $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
  66     $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
  67   } else {
  68     $welcome_template = '';
  69     $welcome_from = '';
  70     $welcome_subject = '';
  71     $welcome_mimetype = '';
  72   }
  73   $smtpmachine = $conf->config('smtpmachine');
  74   $radius_password = $conf->config('radius-password') || 'Password';
  75   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  76 };
  77
  78 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  79 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  80
  81 sub _cache {
  82   my $self = shift;
  83   my ( $hashref, $cache ) = @_;
  84   if ( $hashref->{'svc_acct_svcnum'} ) {
  85     $self->{'_domsvc'} = FS::svc_domain->new( {
  86       'svcnum'   => $hashref->{'domsvc'},
  87       'domain'   => $hashref->{'svc_acct_domain'},
  88       'catchall' => $hashref->{'svc_acct_catchall'},
  89     } );
  90   }
  91 }
  92
  93 =head1 NAME
  94
  95 FS::svc_acct - Object methods for svc_acct records
  96
  97 =head1 SYNOPSIS
  98
  99   use FS::svc_acct;
 100
 101   $record = new FS::svc_acct \%hash;
 102   $record = new FS::svc_acct { 'column' => 'value' };
 103
 104   $error = $record->insert;
 105
 106   $error = $new_record->replace($old_record);
 107
 108   $error = $record->delete;
 109
 110   $error = $record->check;
 111
 112   $error = $record->suspend;
 113
 114   $error = $record->unsuspend;
 115
 116   $error = $record->cancel;
 117
 118   %hash = $record->radius;
 119
 120   %hash = $record->radius_reply;
 121
 122   %hash = $record->radius_check;
 123
 124   $domain = $record->domain;
 125
 126   $svc_domain = $record->svc_domain;
 127
 128   $email = $record->email;
 129
 130   $seconds_since = $record->seconds_since($timestamp);
 131
 132 =head1 DESCRIPTION
 133
 134 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 135 FS::svc_Common.  The following fields are currently supported:
 136
 137 =over 4
 138
 139 =item svcnum - primary key (assigned automatcially for new accounts)
 140
 141 =item username
 142
 143 =item _password - generated if blank
 144
 145 =item sec_phrase - security phrase
 146
 147 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 148
 149 =item uid
 150
 151 =item gid
 152
 153 =item finger - GECOS
 154
 155 =item dir - set automatically if blank (and uid is not)
 156
 157 =item shell
 158
 159 =item quota - (unimplementd)
 160
 161 =item slipip - IP address
 162
 163 =item seconds -
 164
 165 =item domsvc - svcnum from svc_domain
 166
 167 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
 168
 169 =back
 170
 171 =head1 METHODS
 172
 173 =over 4
 174
 175 =item new HASHREF
 176
 177 Creates a new account.  To add the account to the database, see L<"insert">.
 178
 179 =cut
 180
 181 sub table { 'svc_acct'; }
 182
 183 =item insert
 184
 185 Adds this account to the database.  If there is an error, returns the error,
 186 otherwise returns false.
 187
 188 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 189 defined.  An FS::cust_svc record will be created and inserted.
 190
 191 The additional field I<usergroup> can optionally be defined; if so it should
 192 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 193 sqlradius export only)
 194
 195 The additional field I<child_objects> can optionally be defined; if so it
 196 should contain an arrayref of FS::tablename objects.  They will have their
 197 svcnum fields set and will be inserted after this record, but before any
 198 exports are run.
 199
 200 (TODOC: L<FS::queue> and L<freeside-queued>)
 201
 202 (TODOC: new exports!)
 203
 204
 205 =cut
 206
 207 sub insert {
 208   my $self = shift;
 209   my $error;
 210
 211   local $SIG{HUP} = 'IGNORE';
 212   local $SIG{INT} = 'IGNORE';
 213   local $SIG{QUIT} = 'IGNORE';
 214   local $SIG{TERM} = 'IGNORE';
 215   local $SIG{TSTP} = 'IGNORE';
 216   local $SIG{PIPE} = 'IGNORE';
 217
 218   my $oldAutoCommit = $FS::UID::AutoCommit;
 219   local $FS::UID::AutoCommit = 0;
 220   my $dbh = dbh;
 221
 222   $error = $self->check;
 223   return $error if $error;
 224
 225   #no, duplicate checking just got a whole lot more complicated
 226   #(perhaps keep this check with a config option to turn on?)
 227
 228   #return gettext('username_in_use'). ": ". $self->username
 229   #  if qsearchs( 'svc_acct', { 'username' => $self->username,
 230   #                             'domsvc'   => $self->domsvc,
 231   #                           } );
 232
 233   if ( $self->svcnum ) {
 234     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 235     unless ( $cust_svc ) {
 236       $dbh->rollback if $oldAutoCommit;
 237       return "no cust_svc record found for svcnum ". $self->svcnum;
 238     }
 239     $self->pkgnum($cust_svc->pkgnum);
 240     $self->svcpart($cust_svc->svcpart);
 241   }
 242
 243   #new duplicate username checking
 244
 245   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
 246   unless ( $part_svc ) {
 247     $dbh->rollback if $oldAutoCommit;
 248     return 'unknown svcpart '. $self->svcpart;
 249   }
 250
 251   my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
 252   my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
 253                                               'domsvc'   => $self->domsvc } );
 254   my @dup_uid;
 255   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
 256        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
 257     @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
 258   } else {
 259     @dup_uid = ();
 260   }
 261
 262   if ( @dup_user || @dup_userdomain || @dup_uid ) {
 263     my $exports = FS::part_export::export_info('svc_acct');
 264     my %conflict_user_svcpart;
 265     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
 266
 267     foreach my $part_export ( $part_svc->part_export ) {
 268
 269       #this will catch to the same exact export
 270       my @svcparts = map { $_->svcpart }
 271         qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 272
 273       #this will catch to exports w/same exporthost+type ???
 274       #my @other_part_export = qsearch('part_export', {
 275       #  'machine'    => $part_export->machine,
 276       #  'exporttype' => $part_export->exporttype,
 277       #} );
 278       #foreach my $other_part_export ( @other_part_export ) {
 279       #  push @svcparts, map { $_->svcpart }
 280       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 281       #}
 282
 283       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
 284       #silly kludge to avoid uninitialized value errors
 285       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
 286                      ? $exports->{$part_export->exporttype}{'nodomain'}
 287                      : '';
 288       if ( $nodomain =~ /^Y/i ) {
 289         $conflict_user_svcpart{$_} = $part_export->exportnum
 290           foreach @svcparts;
 291       } else {
 292         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
 293           foreach @svcparts;
 294       }
 295     }
 296
 297     foreach my $dup_user ( @dup_user ) {
 298       my $dup_svcpart = $dup_user->cust_svc->svcpart;
 299       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
 300         $dbh->rollback if $oldAutoCommit;
 301         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
 302                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
 303       }
 304     }
 305
 306     foreach my $dup_userdomain ( @dup_userdomain ) {
 307       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
 308       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 309         $dbh->rollback if $oldAutoCommit;
 310         return "duplicate username\@domain: conflicts with svcnum ".
 311                $dup_userdomain->svcnum. " via exportnum ".
 312                $conflict_userdomain_svcpart{$dup_svcpart};
 313       }
 314     }
 315
 316     foreach my $dup_uid ( @dup_uid ) {
 317       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
 318       if ( exists($conflict_user_svcpart{$dup_svcpart})
 319            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 320         $dbh->rollback if $oldAutoCommit;
 321         return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
 322                " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
 323                                  || $conflict_userdomain_svcpart{$dup_svcpart};
 324       }
 325     }
 326
 327   }
 328
 329   #see?  i told you it was more complicated
 330
 331   my @jobnums;
 332   $error = $self->SUPER::insert(\@jobnums, $self->child_objects || [] );
 333   if ( $error ) {
 334     $dbh->rollback if $oldAutoCommit;
 335     return $error;
 336   }
 337
 338   if ( $self->usergroup ) {
 339     foreach my $groupname ( @{$self->usergroup} ) {
 340       my $radius_usergroup = new FS::radius_usergroup ( {
 341         svcnum    => $self->svcnum,
 342         groupname => $groupname,
 343       } );
 344       my $error = $radius_usergroup->insert;
 345       if ( $error ) {
 346         $dbh->rollback if $oldAutoCommit;
 347         return $error;
 348       }
 349     }
 350   }
 351
 352   #false laziness with sub replace (and cust_main)
 353   my $queue = new FS::queue {
 354     'svcnum' => $self->svcnum,
 355     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 356   };
 357   $error = $queue->insert($self->username);
 358   if ( $error ) {
 359     $dbh->rollback if $oldAutoCommit;
 360     return "queueing job (transaction rolled back): $error";
 361   }
 362
 363   my $cust_pkg = $self->cust_svc->cust_pkg;
 364
 365   if ( $cust_pkg ) {
 366     my $cust_main = $cust_pkg->cust_main;
 367
 368     if ( $conf->exists('emailinvoiceauto') ) {
 369       my @invoicing_list = $cust_main->invoicing_list;
 370       push @invoicing_list, $self->email;
 371       $cust_main->invoicing_list(\@invoicing_list);
 372     }
 373
 374     #welcome email
 375     my $to = '';
 376     if ( $welcome_template && $cust_pkg ) {
 377       my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
 378       if ( $to ) {
 379         my $wqueue = new FS::queue {
 380           'svcnum' => $self->svcnum,
 381           'job'    => 'FS::svc_acct::send_email'
 382         };
 383         my $error = $wqueue->insert(
 384           'to'       => $to,
 385           'from'     => $welcome_from,
 386           'subject'  => $welcome_subject,
 387           'mimetype' => $welcome_mimetype,
 388           'body'     => $welcome_template->fill_in( HASH => {
 389                           'custnum'  => $self->custnum,
 390                           'username' => $self->username,
 391                           'password' => $self->_password,
 392                           'first'    => $cust_main->first,
 393                           'last'     => $cust_main->getfield('last'),
 394                           'pkg'      => $cust_pkg->part_pkg->pkg,
 395                         } ),
 396         );
 397         if ( $error ) {
 398           $dbh->rollback if $oldAutoCommit;
 399           return "error queuing welcome email: $error";
 400         }
 401
 402         foreach my $jobnum ( @jobnums ) {
 403           my $error = $wqueue->depend_insert($jobnum);
 404           if ( $error ) {
 405             $dbh->rollback if $oldAutoCommit;
 406             return "error queuing welcome email job dependancy: $error";
 407           }
 408         }
 409
 410       }
 411
 412     }
 413
 414   } # if ( $cust_pkg )
 415
 416   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 417   ''; #no error
 418 }
 419
 420 =item delete
 421
 422 Deletes this account from the database.  If there is an error, returns the
 423 error, otherwise returns false.
 424
 425 The corresponding FS::cust_svc record will be deleted as well.
 426
 427 (TODOC: new exports!)
 428
 429 =cut
 430
 431 sub delete {
 432   my $self = shift;
 433
 434   if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
 435     return "Can't delete an account which has (svc_acct_sm) mail aliases!"
 436       if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
 437   }
 438
 439   return "Can't delete an account which is a (svc_forward) source!"
 440     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 441
 442   return "Can't delete an account which is a (svc_forward) destination!"
 443     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 444
 445   return "Can't delete an account with (svc_www) web service!"
 446     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
 447
 448   # what about records in session ? (they should refer to history table)
 449
 450   local $SIG{HUP} = 'IGNORE';
 451   local $SIG{INT} = 'IGNORE';
 452   local $SIG{QUIT} = 'IGNORE';
 453   local $SIG{TERM} = 'IGNORE';
 454   local $SIG{TSTP} = 'IGNORE';
 455   local $SIG{PIPE} = 'IGNORE';
 456
 457   my $oldAutoCommit = $FS::UID::AutoCommit;
 458   local $FS::UID::AutoCommit = 0;
 459   my $dbh = dbh;
 460
 461   foreach my $cust_main_invoice (
 462     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 463   ) {
 464     unless ( defined($cust_main_invoice) ) {
 465       warn "WARNING: something's wrong with qsearch";
 466       next;
 467     }
 468     my %hash = $cust_main_invoice->hash;
 469     $hash{'dest'} = $self->email;
 470     my $new = new FS::cust_main_invoice \%hash;
 471     my $error = $new->replace($cust_main_invoice);
 472     if ( $error ) {
 473       $dbh->rollback if $oldAutoCommit;
 474       return $error;
 475     }
 476   }
 477
 478   foreach my $svc_domain (
 479     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 480   ) {
 481     my %hash = new FS::svc_domain->hash;
 482     $hash{'catchall'} = '';
 483     my $new = new FS::svc_domain \%hash;
 484     my $error = $new->replace($svc_domain);
 485     if ( $error ) {
 486       $dbh->rollback if $oldAutoCommit;
 487       return $error;
 488     }
 489   }
 490
 491   foreach my $radius_usergroup (
 492     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 493   ) {
 494     my $error = $radius_usergroup->delete;
 495     if ( $error ) {
 496       $dbh->rollback if $oldAutoCommit;
 497       return $error;
 498     }
 499   }
 500
 501   my $error = $self->SUPER::delete;
 502   if ( $error ) {
 503     $dbh->rollback if $oldAutoCommit;
 504     return $error;
 505   }
 506
 507   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 508   '';
 509 }
 510
 511 =item replace OLD_RECORD
 512
 513 Replaces OLD_RECORD with this one in the database.  If there is an error,
 514 returns the error, otherwise returns false.
 515
 516 The additional field I<usergroup> can optionally be defined; if so it should
 517 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 518 sqlradius export only)
 519
 520 =cut
 521
 522 sub replace {
 523   my ( $new, $old ) = ( shift, shift );
 524   my $error;
 525   warn "$me replacing $old with $new\n" if $DEBUG;
 526
 527   return "Username in use"
 528     if $old->username ne $new->username &&
 529       qsearchs( 'svc_acct', { 'username' => $new->username,
 530                                'domsvc'   => $new->domsvc,
 531                              } );
 532   {
 533     #no warnings 'numeric';  #alas, a 5.006-ism
 534     local($^W) = 0;
 535     return "Can't change uid!" if $old->uid != $new->uid;
 536   }
 537
 538   #change homdir when we change username
 539   $new->setfield('dir', '') if $old->username ne $new->username;
 540
 541   local $SIG{HUP} = 'IGNORE';
 542   local $SIG{INT} = 'IGNORE';
 543   local $SIG{QUIT} = 'IGNORE';
 544   local $SIG{TERM} = 'IGNORE';
 545   local $SIG{TSTP} = 'IGNORE';
 546   local $SIG{PIPE} = 'IGNORE';
 547
 548   my $oldAutoCommit = $FS::UID::AutoCommit;
 549   local $FS::UID::AutoCommit = 0;
 550   my $dbh = dbh;
 551
 552   # redundant, but so $new->usergroup gets set
 553   $error = $new->check;
 554   return $error if $error;
 555
 556   $old->usergroup( [ $old->radius_groups ] );
 557   warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
 558   warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
 559   if ( $new->usergroup ) {
 560     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 561     my @newgroups = @{$new->usergroup};
 562     foreach my $oldgroup ( @{$old->usergroup} ) {
 563       if ( grep { $oldgroup eq $_ } @newgroups ) {
 564         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 565         next;
 566       }
 567       my $radius_usergroup = qsearchs('radius_usergroup', {
 568         svcnum    => $old->svcnum,
 569         groupname => $oldgroup,
 570       } );
 571       my $error = $radius_usergroup->delete;
 572       if ( $error ) {
 573         $dbh->rollback if $oldAutoCommit;
 574         return "error deleting radius_usergroup $oldgroup: $error";
 575       }
 576     }
 577
 578     foreach my $newgroup ( @newgroups ) {
 579       my $radius_usergroup = new FS::radius_usergroup ( {
 580         svcnum    => $new->svcnum,
 581         groupname => $newgroup,
 582       } );
 583       my $error = $radius_usergroup->insert;
 584       if ( $error ) {
 585         $dbh->rollback if $oldAutoCommit;
 586         return "error adding radius_usergroup $newgroup: $error";
 587       }
 588     }
 589
 590   }
 591
 592   $error = $new->SUPER::replace($old);
 593   if ( $error ) {
 594     $dbh->rollback if $oldAutoCommit;
 595     return $error if $error;
 596   }
 597
 598   if ( $new->username ne $old->username ) {
 599     #false laziness with sub insert (and cust_main)
 600     my $queue = new FS::queue {
 601       'svcnum' => $new->svcnum,
 602       'job'    => 'FS::svc_acct::append_fuzzyfiles'
 603     };
 604     $error = $queue->insert($new->username);
 605     if ( $error ) {
 606       $dbh->rollback if $oldAutoCommit;
 607       return "queueing job (transaction rolled back): $error";
 608     }
 609   }
 610
 611   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 612   ''; #no error
 613 }
 614
 615 =item suspend
 616
 617 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 618 error, returns the error, otherwise returns false.
 619
 620 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 621
 622 Calls any export-specific suspend hooks.
 623
 624 =cut
 625
 626 sub suspend {
 627   my $self = shift;
 628   my %hash = $self->hash;
 629   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 630            || $hash{_password} eq '*'
 631          ) {
 632     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 633     my $new = new FS::svc_acct ( \%hash );
 634     my $error = $new->replace($self);
 635     return $error if $error;
 636   }
 637
 638   $self->SUPER::suspend;
 639 }
 640
 641 =item unsuspend
 642
 643 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 644 an error, returns the error, otherwise returns false.
 645
 646 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 647
 648 Calls any export-specific unsuspend hooks.
 649
 650 =cut
 651
 652 sub unsuspend {
 653   my $self = shift;
 654   my %hash = $self->hash;
 655   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 656     $hash{_password} = $1;
 657     my $new = new FS::svc_acct ( \%hash );
 658     my $error = $new->replace($self);
 659     return $error if $error;
 660   }
 661
 662   $self->SUPER::unsuspend;
 663 }
 664
 665 =item cancel
 666
 667 Just returns false (no error) for now.
 668
 669 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 670
 671 =item check
 672
 673 Checks all fields to make sure this is a valid service.  If there is an error,
 674 returns the error, otherwise returns false.  Called by the insert and replace
 675 methods.
 676
 677 Sets any fixed values; see L<FS::part_svc>.
 678
 679 =cut
 680
 681 sub check {
 682   my $self = shift;
 683
 684   my($recref) = $self->hashref;
 685
 686   my $x = $self->setfixed;
 687   return $x unless ref($x);
 688   my $part_svc = $x;
 689
 690   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 691     $self->usergroup(
 692       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 693   }
 694
 695   my $error = $self->ut_numbern('svcnum')
 696               #|| $self->ut_number('domsvc')
 697               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 698               || $self->ut_textn('sec_phrase')
 699   ;
 700   return $error if $error;
 701
 702   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 703   if ( $username_uppercase ) {
 704     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 705       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 706     $recref->{username} = $1;
 707   } else {
 708     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 709       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 710     $recref->{username} = $1;
 711   }
 712
 713   if ( $username_letterfirst ) {
 714     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 715   } elsif ( $username_letter ) {
 716     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 717   }
 718   if ( $username_noperiod ) {
 719     $recref->{username} =~ /\./ and return gettext('illegal_username');
 720   }
 721   if ( $username_nounderscore ) {
 722     $recref->{username} =~ /_/ and return gettext('illegal_username');
 723   }
 724   if ( $username_nodash ) {
 725     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 726   }
 727   unless ( $username_ampersand ) {
 728     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 729   }
 730
 731   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 732   $recref->{popnum} = $1;
 733   return "Unknown popnum" unless
 734     ! $recref->{popnum} ||
 735     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 736
 737   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 738
 739     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 740     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 741
 742     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 743     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 744     #not all systems use gid=uid
 745     #you can set a fixed gid in part_svc
 746
 747     return "Only root can have uid 0"
 748       if $recref->{uid} == 0
 749          && $recref->{username} ne 'root'
 750          && $recref->{username} ne 'toor';
 751
 752
 753     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 754       or return "Illegal directory: ". $recref->{dir};
 755     $recref->{dir} = $1;
 756     return "Illegal directory"
 757       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 758     return "Illegal directory"
 759       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 760     unless ( $recref->{dir} ) {
 761       $recref->{dir} = $dir_prefix . '/';
 762       if ( $dirhash > 0 ) {
 763         for my $h ( 1 .. $dirhash ) {
 764           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 765         }
 766       } elsif ( $dirhash < 0 ) {
 767         for my $h ( reverse $dirhash .. -1 ) {
 768           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 769         }
 770       }
 771       $recref->{dir} .= $recref->{username};
 772     ;
 773     }
 774
 775     unless ( $recref->{username} eq 'sync' ) {
 776       if ( grep $_ eq $recref->{shell}, @shells ) {
 777         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 778       } else {
 779         return "Illegal shell \`". $self->shell. "\'; ".
 780                $conf->dir. "/shells contains: @shells";
 781       }
 782     } else {
 783       $recref->{shell} = '/bin/sync';
 784     }
 785
 786   } else {
 787     $recref->{gid} ne '' ?
 788       return "Can't have gid without uid" : ( $recref->{gid}='' );
 789     $recref->{dir} ne '' ?
 790       return "Can't have directory without uid" : ( $recref->{dir}='' );
 791     $recref->{shell} ne '' ?
 792       return "Can't have shell without uid" : ( $recref->{shell}='' );
 793   }
 794
 795   #  $error = $self->ut_textn('finger');
 796   #  return $error if $error;
 797   $self->getfield('finger') =~
 798     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 799       or return "Illegal finger: ". $self->getfield('finger');
 800   $self->setfield('finger', $1);
 801
 802   $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
 803   $recref->{quota} = $1;
 804
 805   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 806     unless ( $recref->{slipip} eq '0e0' ) {
 807       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 808         or return "Illegal slipip". $self->slipip;
 809       $recref->{slipip} = $1;
 810     } else {
 811       $recref->{slipip} = '0e0';
 812     }
 813
 814   }
 815
 816   #arbitrary RADIUS stuff; allow ut_textn for now
 817   foreach ( grep /^radius_/, fields('svc_acct') ) {
 818     $self->ut_textn($_);
 819   }
 820
 821   #generate a password if it is blank
 822   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 823     unless ( $recref->{_password} );
 824
 825   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 826   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 827     $recref->{_password} = $1.$3;
 828     #uncomment this to encrypt password immediately upon entry, or run
 829     #bin/crypt_pw in cron to give new users a window during which their
 830     #password is available to techs, for faxing, etc.  (also be aware of
 831     #radius issues!)
 832     #$recref->{password} = $1.
 833     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 834     #;
 835   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 836     $recref->{_password} = $1.$3;
 837   } elsif ( $recref->{_password} eq '*' ) {
 838     $recref->{_password} = '*';
 839   } elsif ( $recref->{_password} eq '!' ) {
 840     $recref->{_password} = '!';
 841   } elsif ( $recref->{_password} eq '!!' ) {
 842     $recref->{_password} = '!!';
 843   } else {
 844     #return "Illegal password";
 845     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 846            FS::Msgcat::_gettext('illegal_password_characters').
 847            ": ". $recref->{_password};
 848   }
 849
 850   ''; #no error
 851 }
 852
 853 =item radius
 854
 855 Depriciated, use radius_reply instead.
 856
 857 =cut
 858
 859 sub radius {
 860   carp "FS::svc_acct::radius depriciated, use radius_reply";
 861   $_[0]->radius_reply;
 862 }
 863
 864 =item radius_reply
 865
 866 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 867 reply attributes of this record.
 868
 869 Note that this is now the preferred method for reading RADIUS attributes -
 870 accessing the columns directly is discouraged, as the column names are
 871 expected to change in the future.
 872
 873 =cut
 874
 875 sub radius_reply {
 876   my $self = shift;
 877   my %reply =
 878     map {
 879       /^(radius_(.*))$/;
 880       my($column, $attrib) = ($1, $2);
 881       #$attrib =~ s/_/\-/g;
 882       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 883     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 884   if ( $self->slipip && $self->slipip ne '0e0' ) {
 885     $reply{$radius_ip} = $self->slipip;
 886   }
 887   %reply;
 888 }
 889
 890 =item radius_check
 891
 892 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 893 check attributes of this record.
 894
 895 Note that this is now the preferred method for reading RADIUS attributes -
 896 accessing the columns directly is discouraged, as the column names are
 897 expected to change in the future.
 898
 899 =cut
 900
 901 sub radius_check {
 902   my $self = shift;
 903   my $password = $self->_password;
 904   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
 905   ( $pw_attrib => $self->_password,
 906     map {
 907       /^(rc_(.*))$/;
 908       my($column, $attrib) = ($1, $2);
 909       #$attrib =~ s/_/\-/g;
 910       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 911     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 912   );
 913 }
 914
 915 =item domain
 916
 917 Returns the domain associated with this account.
 918
 919 =cut
 920
 921 sub domain {
 922   my $self = shift;
 923   if ( $self->domsvc ) {
 924     #$self->svc_domain->domain;
 925     my $svc_domain = $self->svc_domain
 926       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 927     $svc_domain->domain;
 928   } else {
 929     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
 930   }
 931 }
 932
 933 =item svc_domain
 934
 935 Returns the FS::svc_domain record for this account's domain (see
 936 L<FS::svc_domain>).
 937
 938 =cut
 939
 940 sub svc_domain {
 941   my $self = shift;
 942   $self->{'_domsvc'}
 943     ? $self->{'_domsvc'}
 944     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 945 }
 946
 947 =item cust_svc
 948
 949 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 950
 951 =cut
 952
 953 sub cust_svc {
 954   my $self = shift;
 955   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 956 }
 957
 958 =item email
 959
 960 Returns an email address associated with the account.
 961
 962 =cut
 963
 964 sub email {
 965   my $self = shift;
 966   $self->username. '@'. $self->domain;
 967 }
 968
 969 =item acct_snarf
 970
 971 Returns an array of FS::acct_snarf records associated with the account.
 972 If the acct_snarf table does not exist or there are no associated records,
 973 an empty list is returned
 974
 975 =cut
 976
 977 sub acct_snarf {
 978   my $self = shift;
 979   return () unless dbdef->table('acct_snarf');
 980   eval "use FS::acct_snarf;";
 981   die $@ if $@;
 982   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
 983 }
 984
 985 =item seconds_since TIMESTAMP
 986
 987 Returns the number of seconds this account has been online since TIMESTAMP,
 988 according to the session monitor (see L<FS::Session>).
 989
 990 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 991 L<Time::Local> and L<Date::Parse> for conversion functions.
 992
 993 =cut
 994
 995 #note: POD here, implementation in FS::cust_svc
 996 sub seconds_since {
 997   my $self = shift;
 998   $self->cust_svc->seconds_since(@_);
 999 }
1000
1001 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1002
1003 Returns the numbers of seconds this account has been online between
1004 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1005 external SQL radacct table, specified via sqlradius export.  Sessions which
1006 started in the specified range but are still open are counted from session
1007 start to the end of the range (unless they are over 1 day old, in which case
1008 they are presumed missing their stop record and not counted).  Also, sessions
1009 which end in the range but started earlier are counted from the start of the
1010 range to session end.  Finally, sessions which start before the range but end
1011 after are counted for the entire range.
1012
1013 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1014 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1015 functions.
1016
1017 =cut
1018
1019 #note: POD here, implementation in FS::cust_svc
1020 sub seconds_since_sqlradacct {
1021   my $self = shift;
1022   $self->cust_svc->seconds_since_sqlradacct(@_);
1023 }
1024
1025 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1026
1027 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1028 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1029 TIMESTAMP_END (exclusive).
1030
1031 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1032 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1033 functions.
1034
1035 =cut
1036
1037 #note: POD here, implementation in FS::cust_svc
1038 sub attribute_since_sqlradacct {
1039   my $self = shift;
1040   $self->cust_svc->attribute_since_sqlradacct(@_);
1041 }
1042
1043
1044 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1045
1046 Returns an array of hash references of this customers login history for the
1047 given time range.  (document this better)
1048
1049 =cut
1050
1051 sub get_session_history_sqlradacct {
1052   my $self = shift;
1053   $self->cust_svc->get_session_history_sqlradacct(@_);
1054 }
1055
1056 =item radius_groups
1057
1058 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1059
1060 =cut
1061
1062 sub radius_groups {
1063   my $self = shift;
1064   if ( $self->usergroup ) {
1065     #when provisioning records, export callback runs in svc_Common.pm before
1066     #radius_usergroup records can be inserted...
1067     @{$self->usergroup};
1068   } else {
1069     map { $_->groupname }
1070       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1071   }
1072 }
1073
1074 =back
1075
1076 =head1 SUBROUTINES
1077
1078 =over 4
1079
1080 =item send_email
1081
1082 =cut
1083
1084 sub send_email {
1085   my %opt = @_;
1086
1087   use Date::Format;
1088   use Mail::Internet 1.44;
1089   use Mail::Header;
1090
1091   $opt{mimetype} ||= 'text/plain';
1092   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1093
1094   $ENV{MAILADDRESS} = $opt{from};
1095   my $header = new Mail::Header ( [
1096     "From: $opt{from}",
1097     "To: $opt{to}",
1098     "Sender: $opt{from}",
1099     "Reply-To: $opt{from}",
1100     "Date: ". time2str("%a, %d %b %Y %X %z", time),
1101     "Subject: $opt{subject}",
1102     "Content-Type: $opt{mimetype}",
1103   ] );
1104   my $message = new Mail::Internet (
1105     'Header' => $header,
1106     'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1107   );
1108   $!=0;
1109   $message->smtpsend( Host => $smtpmachine )
1110     or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1111       or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1112 }
1113
1114 =item check_and_rebuild_fuzzyfiles
1115
1116 =cut
1117
1118 sub check_and_rebuild_fuzzyfiles {
1119   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1120   -e "$dir/svc_acct.username"
1121     or &rebuild_fuzzyfiles;
1122 }
1123
1124 =item rebuild_fuzzyfiles
1125
1126 =cut
1127
1128 sub rebuild_fuzzyfiles {
1129
1130   use Fcntl qw(:flock);
1131
1132   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1133
1134   #username
1135
1136   open(USERNAMELOCK,">>$dir/svc_acct.username")
1137     or die "can't open $dir/svc_acct.username: $!";
1138   flock(USERNAMELOCK,LOCK_EX)
1139     or die "can't lock $dir/svc_acct.username: $!";
1140
1141   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1142
1143   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1144     or die "can't open $dir/svc_acct.username.tmp: $!";
1145   print USERNAMECACHE join("\n", @all_username), "\n";
1146   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1147
1148   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1149   close USERNAMELOCK;
1150
1151 }
1152
1153 =item all_username
1154
1155 =cut
1156
1157 sub all_username {
1158   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1159   open(USERNAMECACHE,"<$dir/svc_acct.username")
1160     or die "can't open $dir/svc_acct.username: $!";
1161   my @array = map { chomp; $_; } <USERNAMECACHE>;
1162   close USERNAMECACHE;
1163   \@array;
1164 }
1165
1166 =item append_fuzzyfiles USERNAME
1167
1168 =cut
1169
1170 sub append_fuzzyfiles {
1171   my $username = shift;
1172
1173   &check_and_rebuild_fuzzyfiles;
1174
1175   use Fcntl qw(:flock);
1176
1177   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1178
1179   open(USERNAME,">>$dir/svc_acct.username")
1180     or die "can't open $dir/svc_acct.username: $!";
1181   flock(USERNAME,LOCK_EX)
1182     or die "can't lock $dir/svc_acct.username: $!";
1183
1184   print USERNAME "$username\n";
1185
1186   flock(USERNAME,LOCK_UN)
1187     or die "can't unlock $dir/svc_acct.username: $!";
1188   close USERNAME;
1189
1190   1;
1191 }
1192
1193
1194
1195 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1196
1197 =cut
1198
1199 sub radius_usergroup_selector {
1200   my $sel_groups = shift;
1201   my %sel_groups = map { $_=>1 } @$sel_groups;
1202
1203   my $selectname = shift || 'radius_usergroup';
1204
1205   my $dbh = dbh;
1206   my $sth = $dbh->prepare(
1207     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1208   ) or die $dbh->errstr;
1209   $sth->execute() or die $sth->errstr;
1210   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1211
1212   my $html = <<END;
1213     <SCRIPT>
1214     function ${selectname}_doadd(object) {
1215       var myvalue = object.${selectname}_add.value;
1216       var optionName = new Option(myvalue,myvalue,false,true);
1217       var length = object.$selectname.length;
1218       object.$selectname.options[length] = optionName;
1219       object.${selectname}_add.value = "";
1220     }
1221     </SCRIPT>
1222     <SELECT MULTIPLE NAME="$selectname">
1223 END
1224
1225   foreach my $group ( @all_groups ) {
1226     $html .= '<OPTION';
1227     if ( $sel_groups{$group} ) {
1228       $html .= ' SELECTED';
1229       $sel_groups{$group} = 0;
1230     }
1231     $html .= ">$group</OPTION>\n";
1232   }
1233   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1234     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1235   };
1236   $html .= '</SELECT>';
1237
1238   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1239            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1240
1241   $html;
1242 }
1243
1244 =back
1245
1246 =head1 BUGS
1247
1248 The $recref stuff in sub check should be cleaned up.
1249
1250 The suspend, unsuspend and cancel methods update the database, but not the
1251 current object.  This is probably a bug as it's unexpected and
1252 counterintuitive.
1253
1254 radius_usergroup_selector?  putting web ui components in here?  they should
1255 probably live somewhere else...
1256
1257 =head1 SEE ALSO
1258
1259 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1260 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1261 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1262 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1263 schema.html from the base documentation.
1264
1265 =cut
1266
1267 1;
1268