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