FS/FS/svc_acct.pm

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