FS/FS/svc_acct.pm

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