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 && qsearchs('cust_svc',{'svcnum'=>$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} =~ /^(\w*)$/ or return "Illegal quota";
 803   $recref->{quota} = $1;
 804
 805   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 806     if ( $recref->{slipip} eq '' ) {
 807       $recref->{slipip} = '';
 808     } elsif ( $recref->{slipip} eq '0e0' ) {
 809       $recref->{slipip} = '0e0';
 810     } else {
 811       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 812         or return "Illegal slipip". $self->slipip;
 813       $recref->{slipip} = $1;
 814     }
 815
 816   }
 817
 818   #arbitrary RADIUS stuff; allow ut_textn for now
 819   foreach ( grep /^radius_/, fields('svc_acct') ) {
 820     $self->ut_textn($_);
 821   }
 822
 823   #generate a password if it is blank
 824   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 825     unless ( $recref->{_password} );
 826
 827   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 828   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 829     $recref->{_password} = $1.$3;
 830     #uncomment this to encrypt password immediately upon entry, or run
 831     #bin/crypt_pw in cron to give new users a window during which their
 832     #password is available to techs, for faxing, etc.  (also be aware of
 833     #radius issues!)
 834     #$recref->{password} = $1.
 835     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 836     #;
 837   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 838     $recref->{_password} = $1.$3;
 839   } elsif ( $recref->{_password} eq '*' ) {
 840     $recref->{_password} = '*';
 841   } elsif ( $recref->{_password} eq '!' ) {
 842     $recref->{_password} = '!';
 843   } elsif ( $recref->{_password} eq '!!' ) {
 844     $recref->{_password} = '!!';
 845   } else {
 846     #return "Illegal password";
 847     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 848            FS::Msgcat::_gettext('illegal_password_characters').
 849            ": ". $recref->{_password};
 850   }
 851
 852   ''; #no error
 853 }
 854
 855 =item radius
 856
 857 Depriciated, use radius_reply instead.
 858
 859 =cut
 860
 861 sub radius {
 862   carp "FS::svc_acct::radius depriciated, use radius_reply";
 863   $_[0]->radius_reply;
 864 }
 865
 866 =item radius_reply
 867
 868 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 869 reply attributes of this record.
 870
 871 Note that this is now the preferred method for reading RADIUS attributes -
 872 accessing the columns directly is discouraged, as the column names are
 873 expected to change in the future.
 874
 875 =cut
 876
 877 sub radius_reply {
 878   my $self = shift;
 879   my %reply =
 880     map {
 881       /^(radius_(.*))$/;
 882       my($column, $attrib) = ($1, $2);
 883       #$attrib =~ s/_/\-/g;
 884       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 885     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 886   if ( $self->slipip && $self->slipip ne '0e0' ) {
 887     $reply{$radius_ip} = $self->slipip;
 888   }
 889   %reply;
 890 }
 891
 892 =item radius_check
 893
 894 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 895 check attributes of this record.
 896
 897 Note that this is now the preferred method for reading RADIUS attributes -
 898 accessing the columns directly is discouraged, as the column names are
 899 expected to change in the future.
 900
 901 =cut
 902
 903 sub radius_check {
 904   my $self = shift;
 905   my $password = $self->_password;
 906   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
 907   ( $pw_attrib => $self->_password,
 908     map {
 909       /^(rc_(.*))$/;
 910       my($column, $attrib) = ($1, $2);
 911       #$attrib =~ s/_/\-/g;
 912       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 913     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 914   );
 915 }
 916
 917 =item domain
 918
 919 Returns the domain associated with this account.
 920
 921 =cut
 922
 923 sub domain {
 924   my $self = shift;
 925   if ( $self->domsvc ) {
 926     #$self->svc_domain->domain;
 927     my $svc_domain = $self->svc_domain
 928       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 929     $svc_domain->domain;
 930   } else {
 931     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
 932   }
 933 }
 934
 935 =item svc_domain
 936
 937 Returns the FS::svc_domain record for this account's domain (see
 938 L<FS::svc_domain>).
 939
 940 =cut
 941
 942 sub svc_domain {
 943   my $self = shift;
 944   $self->{'_domsvc'}
 945     ? $self->{'_domsvc'}
 946     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 947 }
 948
 949 =item cust_svc
 950
 951 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 952
 953 =cut
 954
 955 sub cust_svc {
 956   my $self = shift;
 957   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 958 }
 959
 960 =item email
 961
 962 Returns an email address associated with the account.
 963
 964 =cut
 965
 966 sub email {
 967   my $self = shift;
 968   $self->username. '@'. $self->domain;
 969 }
 970
 971 =item acct_snarf
 972
 973 Returns an array of FS::acct_snarf records associated with the account.
 974 If the acct_snarf table does not exist or there are no associated records,
 975 an empty list is returned
 976
 977 =cut
 978
 979 sub acct_snarf {
 980   my $self = shift;
 981   return () unless dbdef->table('acct_snarf');
 982   eval "use FS::acct_snarf;";
 983   die $@ if $@;
 984   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
 985 }
 986
 987 =item seconds_since TIMESTAMP
 988
 989 Returns the number of seconds this account has been online since TIMESTAMP,
 990 according to the session monitor (see L<FS::Session>).
 991
 992 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 993 L<Time::Local> and L<Date::Parse> for conversion functions.
 994
 995 =cut
 996
 997 #note: POD here, implementation in FS::cust_svc
 998 sub seconds_since {
 999   my $self = shift;
1000   $self->cust_svc->seconds_since(@_);
1001 }
1002
1003 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1004
1005 Returns the numbers of seconds this account has been online between
1006 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1007 external SQL radacct table, specified via sqlradius export.  Sessions which
1008 started in the specified range but are still open are counted from session
1009 start to the end of the range (unless they are over 1 day old, in which case
1010 they are presumed missing their stop record and not counted).  Also, sessions
1011 which end in the range but started earlier are counted from the start of the
1012 range to session end.  Finally, sessions which start before the range but end
1013 after are counted for the entire range.
1014
1015 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1016 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1017 functions.
1018
1019 =cut
1020
1021 #note: POD here, implementation in FS::cust_svc
1022 sub seconds_since_sqlradacct {
1023   my $self = shift;
1024   $self->cust_svc->seconds_since_sqlradacct(@_);
1025 }
1026
1027 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1028
1029 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1030 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1031 TIMESTAMP_END (exclusive).
1032
1033 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1034 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1035 functions.
1036
1037 =cut
1038
1039 #note: POD here, implementation in FS::cust_svc
1040 sub attribute_since_sqlradacct {
1041   my $self = shift;
1042   $self->cust_svc->attribute_since_sqlradacct(@_);
1043 }
1044
1045
1046 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1047
1048 Returns an array of hash references of this customers login history for the
1049 given time range.  (document this better)
1050
1051 =cut
1052
1053 sub get_session_history_sqlradacct {
1054   my $self = shift;
1055   $self->cust_svc->get_session_history_sqlradacct(@_);
1056 }
1057
1058 =item radius_groups
1059
1060 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1061
1062 =cut
1063
1064 sub radius_groups {
1065   my $self = shift;
1066   if ( $self->usergroup ) {
1067     #when provisioning records, export callback runs in svc_Common.pm before
1068     #radius_usergroup records can be inserted...
1069     @{$self->usergroup};
1070   } else {
1071     map { $_->groupname }
1072       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1073   }
1074 }
1075
1076 =back
1077
1078 =head1 SUBROUTINES
1079
1080 =over 4
1081
1082 =item send_email
1083
1084 =cut
1085
1086 sub send_email {
1087   my %opt = @_;
1088
1089   use Date::Format;
1090   use Mail::Internet 1.44;
1091   use Mail::Header;
1092
1093   $opt{mimetype} ||= 'text/plain';
1094   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1095
1096   $ENV{MAILADDRESS} = $opt{from};
1097   my $header = new Mail::Header ( [
1098     "From: $opt{from}",
1099     "To: $opt{to}",
1100     "Sender: $opt{from}",
1101     "Reply-To: $opt{from}",
1102     "Date: ". time2str("%a, %d %b %Y %X %z", time),
1103     "Subject: $opt{subject}",
1104     "Content-Type: $opt{mimetype}",
1105   ] );
1106   my $message = new Mail::Internet (
1107     'Header' => $header,
1108     'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1109   );
1110   $!=0;
1111   $message->smtpsend( Host => $smtpmachine )
1112     or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1113       or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1114 }
1115
1116 =item check_and_rebuild_fuzzyfiles
1117
1118 =cut
1119
1120 sub check_and_rebuild_fuzzyfiles {
1121   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1122   -e "$dir/svc_acct.username"
1123     or &rebuild_fuzzyfiles;
1124 }
1125
1126 =item rebuild_fuzzyfiles
1127
1128 =cut
1129
1130 sub rebuild_fuzzyfiles {
1131
1132   use Fcntl qw(:flock);
1133
1134   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1135
1136   #username
1137
1138   open(USERNAMELOCK,">>$dir/svc_acct.username")
1139     or die "can't open $dir/svc_acct.username: $!";
1140   flock(USERNAMELOCK,LOCK_EX)
1141     or die "can't lock $dir/svc_acct.username: $!";
1142
1143   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1144
1145   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1146     or die "can't open $dir/svc_acct.username.tmp: $!";
1147   print USERNAMECACHE join("\n", @all_username), "\n";
1148   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1149
1150   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1151   close USERNAMELOCK;
1152
1153 }
1154
1155 =item all_username
1156
1157 =cut
1158
1159 sub all_username {
1160   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1161   open(USERNAMECACHE,"<$dir/svc_acct.username")
1162     or die "can't open $dir/svc_acct.username: $!";
1163   my @array = map { chomp; $_; } <USERNAMECACHE>;
1164   close USERNAMECACHE;
1165   \@array;
1166 }
1167
1168 =item append_fuzzyfiles USERNAME
1169
1170 =cut
1171
1172 sub append_fuzzyfiles {
1173   my $username = shift;
1174
1175   &check_and_rebuild_fuzzyfiles;
1176
1177   use Fcntl qw(:flock);
1178
1179   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1180
1181   open(USERNAME,">>$dir/svc_acct.username")
1182     or die "can't open $dir/svc_acct.username: $!";
1183   flock(USERNAME,LOCK_EX)
1184     or die "can't lock $dir/svc_acct.username: $!";
1185
1186   print USERNAME "$username\n";
1187
1188   flock(USERNAME,LOCK_UN)
1189     or die "can't unlock $dir/svc_acct.username: $!";
1190   close USERNAME;
1191
1192   1;
1193 }
1194
1195
1196
1197 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1198
1199 =cut
1200
1201 sub radius_usergroup_selector {
1202   my $sel_groups = shift;
1203   my %sel_groups = map { $_=>1 } @$sel_groups;
1204
1205   my $selectname = shift || 'radius_usergroup';
1206
1207   my $dbh = dbh;
1208   my $sth = $dbh->prepare(
1209     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1210   ) or die $dbh->errstr;
1211   $sth->execute() or die $sth->errstr;
1212   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1213
1214   my $html = <<END;
1215     <SCRIPT>
1216     function ${selectname}_doadd(object) {
1217       var myvalue = object.${selectname}_add.value;
1218       var optionName = new Option(myvalue,myvalue,false,true);
1219       var length = object.$selectname.length;
1220       object.$selectname.options[length] = optionName;
1221       object.${selectname}_add.value = "";
1222     }
1223     </SCRIPT>
1224     <SELECT MULTIPLE NAME="$selectname">
1225 END
1226
1227   foreach my $group ( @all_groups ) {
1228     $html .= '<OPTION';
1229     if ( $sel_groups{$group} ) {
1230       $html .= ' SELECTED';
1231       $sel_groups{$group} = 0;
1232     }
1233     $html .= ">$group</OPTION>\n";
1234   }
1235   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1236     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1237   };
1238   $html .= '</SELECT>';
1239
1240   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1241            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1242
1243   $html;
1244 }
1245
1246 =back
1247
1248 =head1 BUGS
1249
1250 The $recref stuff in sub check should be cleaned up.
1251
1252 The suspend, unsuspend and cancel methods update the database, but not the
1253 current object.  This is probably a bug as it's unexpected and
1254 counterintuitive.
1255
1256 radius_usergroup_selector?  putting web ui components in here?  they should
1257 probably live somewhere else...
1258
1259 =head1 SEE ALSO
1260
1261 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1262 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1263 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1264 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1265 schema.html from the base documentation.
1266
1267 =cut
1268
1269 1;
1270