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