FS/FS/svc_acct.pm

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