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   #false laziness with sub insert (and cust_main)
 566   my $queue = new FS::queue {
 567     'svcnum' => $new->svcnum,
 568     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 569   };
 570   $error = $queue->insert($new->username);
 571   if ( $error ) {
 572     $dbh->rollback if $oldAutoCommit;
 573     return "queueing job (transaction rolled back): $error";
 574   }
 575
 576
 577   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 578   ''; #no error
 579 }
 580
 581 =item suspend
 582
 583 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 584 error, returns the error, otherwise returns false.
 585
 586 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 587
 588 =cut
 589
 590 sub suspend {
 591   my $self = shift;
 592   my %hash = $self->hash;
 593   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 594            || $hash{_password} eq '*'
 595          ) {
 596     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 597     my $new = new FS::svc_acct ( \%hash );
 598     my $error = $new->replace($self);
 599     return $error if $error;
 600   }
 601
 602   $self->SUPER::suspend;
 603 }
 604
 605 =item unsuspend
 606
 607 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 608 an error, returns the error, otherwise returns false.
 609
 610 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 611
 612 =cut
 613
 614 sub unsuspend {
 615   my $self = shift;
 616   my %hash = $self->hash;
 617   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 618     $hash{_password} = $1;
 619     my $new = new FS::svc_acct ( \%hash );
 620     my $error = $new->replace($self);
 621     return $error if $error;
 622   }
 623
 624   $self->SUPER::unsuspend;
 625 }
 626
 627 =item cancel
 628
 629 Just returns false (no error) for now.
 630
 631 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 632
 633 =item check
 634
 635 Checks all fields to make sure this is a valid service.  If there is an error,
 636 returns the error, otherwise returns false.  Called by the insert and replace
 637 methods.
 638
 639 Sets any fixed values; see L<FS::part_svc>.
 640
 641 =cut
 642
 643 sub check {
 644   my $self = shift;
 645
 646   my($recref) = $self->hashref;
 647
 648   my $x = $self->setfixed;
 649   return $x unless ref($x);
 650   my $part_svc = $x;
 651
 652   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 653     $self->usergroup(
 654       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 655   }
 656
 657   my $error = $self->ut_numbern('svcnum')
 658               || $self->ut_number('domsvc')
 659               || $self->ut_textn('sec_phrase')
 660   ;
 661   return $error if $error;
 662
 663   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 664   if ( $username_uppercase ) {
 665     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 666       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 667     $recref->{username} = $1;
 668   } else {
 669     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 670       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 671     $recref->{username} = $1;
 672   }
 673
 674   if ( $username_letterfirst ) {
 675     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 676   } elsif ( $username_letter ) {
 677     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 678   }
 679   if ( $username_noperiod ) {
 680     $recref->{username} =~ /\./ and return gettext('illegal_username');
 681   }
 682   if ( $username_nounderscore ) {
 683     $recref->{username} =~ /_/ and return gettext('illegal_username');
 684   }
 685   if ( $username_nodash ) {
 686     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 687   }
 688   unless ( $username_ampersand ) {
 689     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 690   }
 691
 692   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 693   $recref->{popnum} = $1;
 694   return "Unknown popnum" unless
 695     ! $recref->{popnum} ||
 696     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 697
 698   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 699
 700     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 701     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 702
 703     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 704     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 705     #not all systems use gid=uid
 706     #you can set a fixed gid in part_svc
 707
 708     return "Only root can have uid 0"
 709       if $recref->{uid} == 0
 710          && $recref->{username} ne 'root'
 711          && $recref->{username} ne 'toor';
 712
 713
 714     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 715       or return "Illegal directory: ". $recref->{dir};
 716     $recref->{dir} = $1;
 717     return "Illegal directory"
 718       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 719     return "Illegal directory"
 720       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 721     unless ( $recref->{dir} ) {
 722       $recref->{dir} = $dir_prefix . '/';
 723       if ( $dirhash > 0 ) {
 724         for my $h ( 1 .. $dirhash ) {
 725           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 726         }
 727       } elsif ( $dirhash < 0 ) {
 728         for my $h ( reverse $dirhash .. -1 ) {
 729           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 730         }
 731       }
 732       $recref->{dir} .= $recref->{username};
 733     ;
 734     }
 735
 736     unless ( $recref->{username} eq 'sync' ) {
 737       if ( grep $_ eq $recref->{shell}, @shells ) {
 738         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 739       } else {
 740         return "Illegal shell \`". $self->shell. "\'; ".
 741                $conf->dir. "/shells contains: @shells";
 742       }
 743     } else {
 744       $recref->{shell} = '/bin/sync';
 745     }
 746
 747   } else {
 748     $recref->{gid} ne '' ?
 749       return "Can't have gid without uid" : ( $recref->{gid}='' );
 750     $recref->{dir} ne '' ?
 751       return "Can't have directory without uid" : ( $recref->{dir}='' );
 752     $recref->{shell} ne '' ?
 753       return "Can't have shell without uid" : ( $recref->{shell}='' );
 754   }
 755
 756   #  $error = $self->ut_textn('finger');
 757   #  return $error if $error;
 758   $self->getfield('finger') =~
 759     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 760       or return "Illegal finger: ". $self->getfield('finger');
 761   $self->setfield('finger', $1);
 762
 763   $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
 764   $recref->{quota} = $1;
 765
 766   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 767     unless ( $recref->{slipip} eq '0e0' ) {
 768       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 769         or return "Illegal slipip: ". $self->slipip;
 770       $recref->{slipip} = $1;
 771     } else {
 772       $recref->{slipip} = '0e0';
 773     }
 774
 775   }
 776
 777   #arbitrary RADIUS stuff; allow ut_textn for now
 778   foreach ( grep /^radius_/, fields('svc_acct') ) {
 779     $self->ut_textn($_);
 780   }
 781
 782   #generate a password if it is blank
 783   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 784     unless ( $recref->{_password} );
 785
 786   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 787   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 788     $recref->{_password} = $1.$3;
 789     #uncomment this to encrypt password immediately upon entry, or run
 790     #bin/crypt_pw in cron to give new users a window during which their
 791     #password is available to techs, for faxing, etc.  (also be aware of
 792     #radius issues!)
 793     #$recref->{password} = $1.
 794     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 795     #;
 796   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,34})$/ ) {
 797     $recref->{_password} = $1.$3;
 798   } elsif ( $recref->{_password} eq '*' ) {
 799     $recref->{_password} = '*';
 800   } elsif ( $recref->{_password} eq '!!' ) {
 801     $recref->{_password} = '!!';
 802   } else {
 803     #return "Illegal password";
 804     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 805            FS::Msgcat::_gettext('illegal_password_characters').
 806            ": ". $recref->{_password};
 807   }
 808
 809   ''; #no error
 810 }
 811
 812 =item radius
 813
 814 Depriciated, use radius_reply instead.
 815
 816 =cut
 817
 818 sub radius {
 819   carp "FS::svc_acct::radius depriciated, use radius_reply";
 820   $_[0]->radius_reply;
 821 }
 822
 823 =item radius_reply
 824
 825 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 826 reply attributes of this record.
 827
 828 Note that this is now the preferred method for reading RADIUS attributes -
 829 accessing the columns directly is discouraged, as the column names are
 830 expected to change in the future.
 831
 832 =cut
 833
 834 sub radius_reply {
 835   my $self = shift;
 836   my %reply =
 837     map {
 838       /^(radius_(.*))$/;
 839       my($column, $attrib) = ($1, $2);
 840       #$attrib =~ s/_/\-/g;
 841       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 842     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 843   if ( $self->slipip && $self->slipip ne '0e0' ) {
 844     $reply{'Framed-IP-Address'} = $self->slipip;
 845   }
 846   %reply;
 847 }
 848
 849 =item radius_check
 850
 851 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 852 check attributes of this record.
 853
 854 Note that this is now the preferred method for reading RADIUS attributes -
 855 accessing the columns directly is discouraged, as the column names are
 856 expected to change in the future.
 857
 858 =cut
 859
 860 sub radius_check {
 861   my $self = shift;
 862   my $password = $self->_password;
 863   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
 864   ( $pw_attrib => $password,
 865     map {
 866       /^(rc_(.*))$/;
 867       my($column, $attrib) = ($1, $2);
 868       #$attrib =~ s/_/\-/g;
 869       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 870     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 871   );
 872 }
 873
 874 =item domain
 875
 876 Returns the domain associated with this account.
 877
 878 =cut
 879
 880 sub domain {
 881   my $self = shift;
 882   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
 883   my $svc_domain = $self->svc_domain
 884     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 885   $svc_domain->domain;
 886 }
 887
 888 =item svc_domain
 889
 890 Returns the FS::svc_domain record for this account's domain (see
 891 L<FS::svc_domain>).
 892
 893 =cut
 894
 895 sub svc_domain {
 896   my $self = shift;
 897   $self->{'_domsvc'}
 898     ? $self->{'_domsvc'}
 899     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 900 }
 901
 902 =item cust_svc
 903
 904 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 905
 906 sub cust_svc {
 907   my $self = shift;
 908   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 909 }
 910
 911 =item email
 912
 913 Returns an email address associated with the account.
 914
 915 =cut
 916
 917 sub email {
 918   my $self = shift;
 919   $self->username. '@'. $self->domain;
 920 }
 921
 922 =item seconds_since TIMESTAMP
 923
 924 Returns the number of seconds this account has been online since TIMESTAMP.
 925 See L<FS::session>
 926
 927 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 928 L<Time::Local> and L<Date::Parse> for conversion functions.
 929
 930 =cut
 931
 932 #note: POD here, implementation in FS::cust_svc
 933 sub seconds_since {
 934   my $self = shift;
 935   $self->cust_svc->seconds_since(@_);
 936 }
 937
 938 =item radius_groups
 939
 940 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
 941
 942 =cut
 943
 944 sub radius_groups {
 945   my $self = shift;
 946   if ( $self->usergroup ) {
 947     #when provisioning records, export callback runs in svc_Common.pm before
 948     #radius_usergroup records can be inserted...
 949     @{$self->usergroup};
 950   } else {
 951     map { $_->groupname }
 952       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
 953   }
 954 }
 955
 956 =back
 957
 958 =head1 SUBROUTINES
 959
 960 =over 4
 961
 962 =item send_email
 963
 964 =cut
 965
 966 sub send_email {
 967   my %opt = @_;
 968
 969   use Date::Format;
 970   use Mail::Internet 1.44;
 971   use Mail::Header;
 972
 973   $opt{mimetype} ||= 'text/plain';
 974   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
 975
 976   $ENV{MAILADDRESS} = $opt{from};
 977   my $header = new Mail::Header ( [
 978     "From: $opt{from}",
 979     "To: $opt{to}",
 980     "Sender: $opt{from}",
 981     "Reply-To: $opt{from}",
 982     "Date: ". time2str("%a, %d %b %Y %X %z", time),
 983     "Subject: $opt{subject}",
 984     "Content-Type: $opt{mimetype}",
 985   ] );
 986   my $message = new Mail::Internet (
 987     'Header' => $header,
 988     'Body' => [ map "$_\n", split("\n", $opt{body}) ],
 989   );
 990   $!=0;
 991   $message->smtpsend( Host => $smtpmachine )
 992     or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
 993       or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
 994 }
 995
 996 =item check_and_rebuild_fuzzyfiles
 997
 998 =cut
 999
1000 sub check_and_rebuild_fuzzyfiles {
1001   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1002   -e "$dir/svc_acct.username"
1003     or &rebuild_fuzzyfiles;
1004 }
1005
1006 =item rebuild_fuzzyfiles
1007
1008 =cut
1009
1010 sub rebuild_fuzzyfiles {
1011
1012   use Fcntl qw(:flock);
1013
1014   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1015
1016   #username
1017
1018   open(USERNAMELOCK,">>$dir/svc_acct.username")
1019     or die "can't open $dir/svc_acct.username: $!";
1020   flock(USERNAMELOCK,LOCK_EX)
1021     or die "can't lock $dir/svc_acct.username: $!";
1022
1023   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1024
1025   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1026     or die "can't open $dir/svc_acct.username.tmp: $!";
1027   print USERNAMECACHE join("\n", @all_username), "\n";
1028   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1029
1030   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1031   close USERNAMELOCK;
1032
1033 }
1034
1035 =item all_username
1036
1037 =cut
1038
1039 sub all_username {
1040   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1041   open(USERNAMECACHE,"<$dir/svc_acct.username")
1042     or die "can't open $dir/svc_acct.username: $!";
1043   my @array = map { chomp; $_; } <USERNAMECACHE>;
1044   close USERNAMECACHE;
1045   \@array;
1046 }
1047
1048 =item append_fuzzyfiles USERNAME
1049
1050 =cut
1051
1052 sub append_fuzzyfiles {
1053   my $username = shift;
1054
1055   &check_and_rebuild_fuzzyfiles;
1056
1057   use Fcntl qw(:flock);
1058
1059   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1060
1061   open(USERNAME,">>$dir/svc_acct.username")
1062     or die "can't open $dir/svc_acct.username: $!";
1063   flock(USERNAME,LOCK_EX)
1064     or die "can't lock $dir/svc_acct.username: $!";
1065
1066   print USERNAME "$username\n";
1067
1068   flock(USERNAME,LOCK_UN)
1069     or die "can't unlock $dir/svc_acct.username: $!";
1070   close USERNAME;
1071
1072   1;
1073 }
1074
1075
1076
1077 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1078
1079 =cut
1080
1081 sub radius_usergroup_selector {
1082   my $sel_groups = shift;
1083   my %sel_groups = map { $_=>1 } @$sel_groups;
1084
1085   my $selectname = shift || 'radius_usergroup';
1086
1087   my $dbh = dbh;
1088   my $sth = $dbh->prepare(
1089     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1090   ) or die $dbh->errstr;
1091   $sth->execute() or die $sth->errstr;
1092   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1093
1094   my $html = <<END;
1095     <SCRIPT>
1096     function ${selectname}_doadd(object) {
1097       var myvalue = object.${selectname}_add.value;
1098       var optionName = new Option(myvalue,myvalue,false,true);
1099       var length = object.$selectname.length;
1100       object.$selectname.options[length] = optionName;
1101       object.${selectname}_add.value = "";
1102     }
1103     </SCRIPT>
1104     <SELECT MULTIPLE NAME="$selectname">
1105 END
1106
1107   foreach my $group ( @all_groups ) {
1108     $html .= '<OPTION';
1109     if ( $sel_groups{$group} ) {
1110       $html .= ' SELECTED';
1111       $sel_groups{$group} = 0;
1112     }
1113     $html .= ">$group</OPTION>\n";
1114   }
1115   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1116     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1117   };
1118   $html .= '</SELECT>';
1119
1120   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1121            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1122
1123   $html;
1124 }
1125
1126 =back
1127
1128 =head1 BUGS
1129
1130 The $recref stuff in sub check should be cleaned up.
1131
1132 The suspend, unsuspend and cancel methods update the database, but not the
1133 current object.  This is probably a bug as it's unexpected and
1134 counterintuitive.
1135
1136 radius_usergroup_selector?  putting web ui components in here?  they should
1137 probably live somewhere else...
1138
1139 =head1 SEE ALSO
1140
1141 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1142 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1143 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1144 L<freeside-queued>), L<FS::svc_acct_pop>,
1145 schema.html from the base documentation.
1146
1147 =cut
1148
1149 1;
1150