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