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 attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 964
 965 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 966 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 967 TIMESTAMP_END (exclusive).
 968
 969 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 970 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 971 functions.
 972
 973 =cut
 974
 975 #note: POD here, implementation in FS::cust_svc
 976 sub attribute_since_sqlradacct {
 977   my $self = shift;
 978   $self->cust_svc->attribute_since_sqlradacct(@_);
 979 }
 980
 981 =item radius_groups
 982
 983 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
 984
 985 =cut
 986
 987 sub radius_groups {
 988   my $self = shift;
 989   if ( $self->usergroup ) {
 990     #when provisioning records, export callback runs in svc_Common.pm before
 991     #radius_usergroup records can be inserted...
 992     @{$self->usergroup};
 993   } else {
 994     map { $_->groupname }
 995       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
 996   }
 997 }
 998
 999 =back
1000
1001 =head1 SUBROUTINES
1002
1003 =over 4
1004
1005 =item send_email
1006
1007 =cut
1008
1009 sub send_email {
1010   my %opt = @_;
1011
1012   use Date::Format;
1013   use Mail::Internet 1.44;
1014   use Mail::Header;
1015
1016   $opt{mimetype} ||= 'text/plain';
1017   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1018
1019   $ENV{MAILADDRESS} = $opt{from};
1020   my $header = new Mail::Header ( [
1021     "From: $opt{from}",
1022     "To: $opt{to}",
1023     "Sender: $opt{from}",
1024     "Reply-To: $opt{from}",
1025     "Date: ". time2str("%a, %d %b %Y %X %z", time),
1026     "Subject: $opt{subject}",
1027     "Content-Type: $opt{mimetype}",
1028   ] );
1029   my $message = new Mail::Internet (
1030     'Header' => $header,
1031     'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1032   );
1033   $!=0;
1034   $message->smtpsend( Host => $smtpmachine )
1035     or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1036       or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1037 }
1038
1039 =item check_and_rebuild_fuzzyfiles
1040
1041 =cut
1042
1043 sub check_and_rebuild_fuzzyfiles {
1044   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1045   -e "$dir/svc_acct.username"
1046     or &rebuild_fuzzyfiles;
1047 }
1048
1049 =item rebuild_fuzzyfiles
1050
1051 =cut
1052
1053 sub rebuild_fuzzyfiles {
1054
1055   use Fcntl qw(:flock);
1056
1057   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1058
1059   #username
1060
1061   open(USERNAMELOCK,">>$dir/svc_acct.username")
1062     or die "can't open $dir/svc_acct.username: $!";
1063   flock(USERNAMELOCK,LOCK_EX)
1064     or die "can't lock $dir/svc_acct.username: $!";
1065
1066   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1067
1068   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1069     or die "can't open $dir/svc_acct.username.tmp: $!";
1070   print USERNAMECACHE join("\n", @all_username), "\n";
1071   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1072
1073   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1074   close USERNAMELOCK;
1075
1076 }
1077
1078 =item all_username
1079
1080 =cut
1081
1082 sub all_username {
1083   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1084   open(USERNAMECACHE,"<$dir/svc_acct.username")
1085     or die "can't open $dir/svc_acct.username: $!";
1086   my @array = map { chomp; $_; } <USERNAMECACHE>;
1087   close USERNAMECACHE;
1088   \@array;
1089 }
1090
1091 =item append_fuzzyfiles USERNAME
1092
1093 =cut
1094
1095 sub append_fuzzyfiles {
1096   my $username = shift;
1097
1098   &check_and_rebuild_fuzzyfiles;
1099
1100   use Fcntl qw(:flock);
1101
1102   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1103
1104   open(USERNAME,">>$dir/svc_acct.username")
1105     or die "can't open $dir/svc_acct.username: $!";
1106   flock(USERNAME,LOCK_EX)
1107     or die "can't lock $dir/svc_acct.username: $!";
1108
1109   print USERNAME "$username\n";
1110
1111   flock(USERNAME,LOCK_UN)
1112     or die "can't unlock $dir/svc_acct.username: $!";
1113   close USERNAME;
1114
1115   1;
1116 }
1117
1118
1119
1120 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1121
1122 =cut
1123
1124 sub radius_usergroup_selector {
1125   my $sel_groups = shift;
1126   my %sel_groups = map { $_=>1 } @$sel_groups;
1127
1128   my $selectname = shift || 'radius_usergroup';
1129
1130   my $dbh = dbh;
1131   my $sth = $dbh->prepare(
1132     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1133   ) or die $dbh->errstr;
1134   $sth->execute() or die $sth->errstr;
1135   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1136
1137   my $html = <<END;
1138     <SCRIPT>
1139     function ${selectname}_doadd(object) {
1140       var myvalue = object.${selectname}_add.value;
1141       var optionName = new Option(myvalue,myvalue,false,true);
1142       var length = object.$selectname.length;
1143       object.$selectname.options[length] = optionName;
1144       object.${selectname}_add.value = "";
1145     }
1146     </SCRIPT>
1147     <SELECT MULTIPLE NAME="$selectname">
1148 END
1149
1150   foreach my $group ( @all_groups ) {
1151     $html .= '<OPTION';
1152     if ( $sel_groups{$group} ) {
1153       $html .= ' SELECTED';
1154       $sel_groups{$group} = 0;
1155     }
1156     $html .= ">$group</OPTION>\n";
1157   }
1158   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1159     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1160   };
1161   $html .= '</SELECT>';
1162
1163   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1164            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1165
1166   $html;
1167 }
1168
1169 =back
1170
1171 =head1 BUGS
1172
1173 The $recref stuff in sub check should be cleaned up.
1174
1175 The suspend, unsuspend and cancel methods update the database, but not the
1176 current object.  This is probably a bug as it's unexpected and
1177 counterintuitive.
1178
1179 radius_usergroup_selector?  putting web ui components in here?  they should
1180 probably live somewhere else...
1181
1182 =head1 SEE ALSO
1183
1184 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1185 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1186 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1187 L<freeside-queued>), L<FS::svc_acct_pop>,
1188 schema.html from the base documentation.
1189
1190 =cut
1191
1192 1;
1193