FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
   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 $username_percent
  10              $password_noampersand $password_noexclamation
  11              $welcome_template $welcome_from $welcome_subject $welcome_mimetype
  12              $smtpmachine
  13              $radius_password $radius_ip
  14              $dirhash
  15              @saltset @pw_set );
  16 use Carp;
  17 use Fcntl qw(:flock);
  18 use Date::Format;
  19 use Crypt::PasswdMD5 1.2;
  20 use FS::UID qw( datasrc );
  21 use FS::Conf;
  22 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  23 use FS::svc_Common;
  24 use FS::cust_svc;
  25 use FS::part_svc;
  26 use FS::svc_acct_pop;
  27 use FS::cust_main_invoice;
  28 use FS::svc_domain;
  29 use FS::raddb;
  30 use FS::queue;
  31 use FS::radius_usergroup;
  32 use FS::export_svc;
  33 use FS::part_export;
  34 use FS::Msgcat qw(gettext);
  35 use FS::svc_forward;
  36 use FS::svc_www;
  37
  38 @ISA = qw( FS::svc_Common );
  39
  40 $DEBUG = 0;
  41 $me = '[FS::svc_acct]';
  42
  43 #ask FS::UID to run this stuff for us later
  44 $FS::UID::callback{'FS::svc_acct'} = sub {
  45   $conf = new FS::Conf;
  46   $dir_prefix = $conf->config('home');
  47   @shells = $conf->config('shells');
  48   $usernamemin = $conf->config('usernamemin') || 2;
  49   $usernamemax = $conf->config('usernamemax');
  50   $passwordmin = $conf->config('passwordmin') || 6;
  51   $passwordmax = $conf->config('passwordmax') || 8;
  52   $username_letter = $conf->exists('username-letter');
  53   $username_letterfirst = $conf->exists('username-letterfirst');
  54   $username_noperiod = $conf->exists('username-noperiod');
  55   $username_nounderscore = $conf->exists('username-nounderscore');
  56   $username_nodash = $conf->exists('username-nodash');
  57   $username_uppercase = $conf->exists('username-uppercase');
  58   $username_ampersand = $conf->exists('username-ampersand');
  59   $username_percent = $conf->exists('username-percent');
  60   $password_noampersand = $conf->exists('password-noexclamation');
  61   $password_noexclamation = $conf->exists('password-noexclamation');
  62   $dirhash = $conf->config('dirhash') || 0;
  63   if ( $conf->exists('welcome_email') ) {
  64     $welcome_template = new Text::Template (
  65       TYPE   => 'ARRAY',
  66       SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
  67     ) or warn "can't create welcome email template: $Text::Template::ERROR";
  68     $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
  69     $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
  70     $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
  71   } else {
  72     $welcome_template = '';
  73     $welcome_from = '';
  74     $welcome_subject = '';
  75     $welcome_mimetype = '';
  76   }
  77   $smtpmachine = $conf->config('smtpmachine');
  78   $radius_password = $conf->config('radius-password') || 'Password';
  79   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  80 };
  81
  82 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  83 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  84
  85 sub _cache {
  86   my $self = shift;
  87   my ( $hashref, $cache ) = @_;
  88   if ( $hashref->{'svc_acct_svcnum'} ) {
  89     $self->{'_domsvc'} = FS::svc_domain->new( {
  90       'svcnum'   => $hashref->{'domsvc'},
  91       'domain'   => $hashref->{'svc_acct_domain'},
  92       'catchall' => $hashref->{'svc_acct_catchall'},
  93     } );
  94   }
  95 }
  96
  97 =head1 NAME
  98
  99 FS::svc_acct - Object methods for svc_acct records
 100
 101 =head1 SYNOPSIS
 102
 103   use FS::svc_acct;
 104
 105   $record = new FS::svc_acct \%hash;
 106   $record = new FS::svc_acct { 'column' => 'value' };
 107
 108   $error = $record->insert;
 109
 110   $error = $new_record->replace($old_record);
 111
 112   $error = $record->delete;
 113
 114   $error = $record->check;
 115
 116   $error = $record->suspend;
 117
 118   $error = $record->unsuspend;
 119
 120   $error = $record->cancel;
 121
 122   %hash = $record->radius;
 123
 124   %hash = $record->radius_reply;
 125
 126   %hash = $record->radius_check;
 127
 128   $domain = $record->domain;
 129
 130   $svc_domain = $record->svc_domain;
 131
 132   $email = $record->email;
 133
 134   $seconds_since = $record->seconds_since($timestamp);
 135
 136 =head1 DESCRIPTION
 137
 138 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 139 FS::svc_Common.  The following fields are currently supported:
 140
 141 =over 4
 142
 143 =item svcnum - primary key (assigned automatcially for new accounts)
 144
 145 =item username
 146
 147 =item _password - generated if blank
 148
 149 =item sec_phrase - security phrase
 150
 151 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 152
 153 =item uid
 154
 155 =item gid
 156
 157 =item finger - GECOS
 158
 159 =item dir - set automatically if blank (and uid is not)
 160
 161 =item shell
 162
 163 =item quota - (unimplementd)
 164
 165 =item slipip - IP address
 166
 167 =item seconds -
 168
 169 =item domsvc - svcnum from svc_domain
 170
 171 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
 172
 173 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
 174
 175 =back
 176
 177 =head1 METHODS
 178
 179 =over 4
 180
 181 =item new HASHREF
 182
 183 Creates a new account.  To add the account to the database, see L<"insert">.
 184
 185 =cut
 186
 187 sub table { 'svc_acct'; }
 188
 189 =item insert [ , OPTION => VALUE ... ]
 190
 191 Adds this account to the database.  If there is an error, returns the error,
 192 otherwise returns false.
 193
 194 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 195 defined.  An FS::cust_svc record will be created and inserted.
 196
 197 The additional field I<usergroup> can optionally be defined; if so it should
 198 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 199
 200 The additional field I<child_objects> can optionally be defined; if so it
 201 should contain an arrayref of FS::tablename objects.  They will have their
 202 svcnum fields set and will be inserted after this record, but before any
 203 exports are run.  Each element of the array can also optionally be a
 204 two-element array reference containing the child object and the name of an
 205 alternate field to be filled in with the newly-inserted svcnum, for example
 206 C<[ $svc_forward, 'srcsvc' ]>
 207
 208 Currently available options are: I<depend_jobnum>
 209
 210 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 211 jobnums), all provisioning jobs will have a dependancy on the supplied
 212 jobnum(s) (they will not run until the specific job(s) complete(s)).
 213
 214 (TODOC: L<FS::queue> and L<freeside-queued>)
 215
 216 (TODOC: new exports!)
 217
 218 =cut
 219
 220 sub insert {
 221   my $self = shift;
 222   my %options = @_;
 223   my $error;
 224
 225   local $SIG{HUP} = 'IGNORE';
 226   local $SIG{INT} = 'IGNORE';
 227   local $SIG{QUIT} = 'IGNORE';
 228   local $SIG{TERM} = 'IGNORE';
 229   local $SIG{TSTP} = 'IGNORE';
 230   local $SIG{PIPE} = 'IGNORE';
 231
 232   my $oldAutoCommit = $FS::UID::AutoCommit;
 233   local $FS::UID::AutoCommit = 0;
 234   my $dbh = dbh;
 235
 236   $error = $self->check;
 237   return $error if $error;
 238
 239   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 240     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 241     unless ( $cust_svc ) {
 242       $dbh->rollback if $oldAutoCommit;
 243       return "no cust_svc record found for svcnum ". $self->svcnum;
 244     }
 245     $self->pkgnum($cust_svc->pkgnum);
 246     $self->svcpart($cust_svc->svcpart);
 247   }
 248
 249   $error = $self->_check_duplicate;
 250   if ( $error ) {
 251     $dbh->rollback if $oldAutoCommit;
 252     return $error;
 253   }
 254
 255   my @jobnums;
 256   $error = $self->SUPER::insert(
 257     'jobnums'       => \@jobnums,
 258     'child_objects' => $self->child_objects,
 259     %options,
 260   );
 261   if ( $error ) {
 262     $dbh->rollback if $oldAutoCommit;
 263     return $error;
 264   }
 265
 266   if ( $self->usergroup ) {
 267     foreach my $groupname ( @{$self->usergroup} ) {
 268       my $radius_usergroup = new FS::radius_usergroup ( {
 269         svcnum    => $self->svcnum,
 270         groupname => $groupname,
 271       } );
 272       my $error = $radius_usergroup->insert;
 273       if ( $error ) {
 274         $dbh->rollback if $oldAutoCommit;
 275         return $error;
 276       }
 277     }
 278   }
 279
 280   unless ( $skip_fuzzyfiles ) {
 281     $error = $self->queue_fuzzyfiles_update;
 282     if ( $error ) {
 283       $dbh->rollback if $oldAutoCommit;
 284       return "updating fuzzy search cache: $error";
 285     }
 286   }
 287
 288   my $cust_pkg = $self->cust_svc->cust_pkg;
 289
 290   if ( $cust_pkg ) {
 291     my $cust_main = $cust_pkg->cust_main;
 292
 293     if ( $conf->exists('emailinvoiceauto') ) {
 294       my @invoicing_list = $cust_main->invoicing_list;
 295       push @invoicing_list, $self->email;
 296       $cust_main->invoicing_list(\@invoicing_list);
 297     }
 298
 299     #welcome email
 300     my $to = '';
 301     if ( $welcome_template && $cust_pkg ) {
 302       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 303       if ( $to ) {
 304         my $wqueue = new FS::queue {
 305           'svcnum' => $self->svcnum,
 306           'job'    => 'FS::svc_acct::send_email'
 307         };
 308         my $error = $wqueue->insert(
 309           'to'       => $to,
 310           'from'     => $welcome_from,
 311           'subject'  => $welcome_subject,
 312           'mimetype' => $welcome_mimetype,
 313           'body'     => $welcome_template->fill_in( HASH => {
 314                           'custnum'  => $self->custnum,
 315                           'username' => $self->username,
 316                           'password' => $self->_password,
 317                           'first'    => $cust_main->first,
 318                           'last'     => $cust_main->getfield('last'),
 319                           'pkg'      => $cust_pkg->part_pkg->pkg,
 320                         } ),
 321         );
 322         if ( $error ) {
 323           $dbh->rollback if $oldAutoCommit;
 324           return "error queuing welcome email: $error";
 325         }
 326
 327         if ( $options{'depend_jobnum'} ) {
 328           warn "$me depend_jobnum found; adding to welcome email dependancies"
 329             if $DEBUG;
 330           if ( ref($options{'depend_jobnum'}) ) {
 331             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 332                  "to welcome email dependancies"
 333               if $DEBUG;
 334             push @jobnums, @{ $options{'depend_jobnum'} };
 335           } else {
 336             warn "$me adding job $options{'depend_jobnum'} ".
 337                  "to welcome email dependancies"
 338               if $DEBUG;
 339             push @jobnums, $options{'depend_jobnum'};
 340           }
 341         }
 342
 343         foreach my $jobnum ( @jobnums ) {
 344           my $error = $wqueue->depend_insert($jobnum);
 345           if ( $error ) {
 346             $dbh->rollback if $oldAutoCommit;
 347             return "error queuing welcome email job dependancy: $error";
 348           }
 349         }
 350
 351       }
 352
 353     }
 354
 355   } # if ( $cust_pkg )
 356
 357   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 358   ''; #no error
 359 }
 360
 361 =item delete
 362
 363 Deletes this account from the database.  If there is an error, returns the
 364 error, otherwise returns false.
 365
 366 The corresponding FS::cust_svc record will be deleted as well.
 367
 368 (TODOC: new exports!)
 369
 370 =cut
 371
 372 sub delete {
 373   my $self = shift;
 374
 375   return "can't delete system account" if $self->_check_system;
 376
 377   return "Can't delete an account which is a (svc_forward) source!"
 378     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 379
 380   return "Can't delete an account which is a (svc_forward) destination!"
 381     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 382
 383   return "Can't delete an account with (svc_www) web service!"
 384     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 385
 386   # what about records in session ? (they should refer to history table)
 387
 388   local $SIG{HUP} = 'IGNORE';
 389   local $SIG{INT} = 'IGNORE';
 390   local $SIG{QUIT} = 'IGNORE';
 391   local $SIG{TERM} = 'IGNORE';
 392   local $SIG{TSTP} = 'IGNORE';
 393   local $SIG{PIPE} = 'IGNORE';
 394
 395   my $oldAutoCommit = $FS::UID::AutoCommit;
 396   local $FS::UID::AutoCommit = 0;
 397   my $dbh = dbh;
 398
 399   foreach my $cust_main_invoice (
 400     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 401   ) {
 402     unless ( defined($cust_main_invoice) ) {
 403       warn "WARNING: something's wrong with qsearch";
 404       next;
 405     }
 406     my %hash = $cust_main_invoice->hash;
 407     $hash{'dest'} = $self->email;
 408     my $new = new FS::cust_main_invoice \%hash;
 409     my $error = $new->replace($cust_main_invoice);
 410     if ( $error ) {
 411       $dbh->rollback if $oldAutoCommit;
 412       return $error;
 413     }
 414   }
 415
 416   foreach my $svc_domain (
 417     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 418   ) {
 419     my %hash = new FS::svc_domain->hash;
 420     $hash{'catchall'} = '';
 421     my $new = new FS::svc_domain \%hash;
 422     my $error = $new->replace($svc_domain);
 423     if ( $error ) {
 424       $dbh->rollback if $oldAutoCommit;
 425       return $error;
 426     }
 427   }
 428
 429   foreach my $radius_usergroup (
 430     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 431   ) {
 432     my $error = $radius_usergroup->delete;
 433     if ( $error ) {
 434       $dbh->rollback if $oldAutoCommit;
 435       return $error;
 436     }
 437   }
 438
 439   my $error = $self->SUPER::delete;
 440   if ( $error ) {
 441     $dbh->rollback if $oldAutoCommit;
 442     return $error;
 443   }
 444
 445   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 446   '';
 447 }
 448
 449 =item replace OLD_RECORD
 450
 451 Replaces OLD_RECORD with this one in the database.  If there is an error,
 452 returns the error, otherwise returns false.
 453
 454 The additional field I<usergroup> can optionally be defined; if so it should
 455 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 456
 457
 458 =cut
 459
 460 sub replace {
 461   my ( $new, $old ) = ( shift, shift );
 462   my $error;
 463   warn "$me replacing $old with $new\n" if $DEBUG;
 464
 465   return "can't modify system account" if $old->_check_system;
 466
 467   {
 468     #no warnings 'numeric';  #alas, a 5.006-ism
 469     local($^W) = 0;
 470
 471     foreach my $xid (qw( uid gid )) {
 472
 473       return "Can't change $xid!"
 474         if ! $conf->exists("svc_acct-edit_$xid")
 475            && $old->$xid() != $new->$xid()
 476            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 477     }
 478
 479   }
 480
 481   #change homdir when we change username
 482   $new->setfield('dir', '') if $old->username ne $new->username;
 483
 484   local $SIG{HUP} = 'IGNORE';
 485   local $SIG{INT} = 'IGNORE';
 486   local $SIG{QUIT} = 'IGNORE';
 487   local $SIG{TERM} = 'IGNORE';
 488   local $SIG{TSTP} = 'IGNORE';
 489   local $SIG{PIPE} = 'IGNORE';
 490
 491   my $oldAutoCommit = $FS::UID::AutoCommit;
 492   local $FS::UID::AutoCommit = 0;
 493   my $dbh = dbh;
 494
 495   # redundant, but so $new->usergroup gets set
 496   $error = $new->check;
 497   return $error if $error;
 498
 499   $old->usergroup( [ $old->radius_groups ] );
 500   warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
 501   warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
 502   if ( $new->usergroup ) {
 503     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 504     my @newgroups = @{$new->usergroup};
 505     foreach my $oldgroup ( @{$old->usergroup} ) {
 506       if ( grep { $oldgroup eq $_ } @newgroups ) {
 507         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 508         next;
 509       }
 510       my $radius_usergroup = qsearchs('radius_usergroup', {
 511         svcnum    => $old->svcnum,
 512         groupname => $oldgroup,
 513       } );
 514       my $error = $radius_usergroup->delete;
 515       if ( $error ) {
 516         $dbh->rollback if $oldAutoCommit;
 517         return "error deleting radius_usergroup $oldgroup: $error";
 518       }
 519     }
 520
 521     foreach my $newgroup ( @newgroups ) {
 522       my $radius_usergroup = new FS::radius_usergroup ( {
 523         svcnum    => $new->svcnum,
 524         groupname => $newgroup,
 525       } );
 526       my $error = $radius_usergroup->insert;
 527       if ( $error ) {
 528         $dbh->rollback if $oldAutoCommit;
 529         return "error adding radius_usergroup $newgroup: $error";
 530       }
 531     }
 532
 533   }
 534
 535   if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
 536     $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
 537     $error = $new->_check_duplicate;
 538     if ( $error ) {
 539       $dbh->rollback if $oldAutoCommit;
 540       return $error;
 541     }
 542   }
 543
 544   $error = $new->SUPER::replace($old);
 545   if ( $error ) {
 546     $dbh->rollback if $oldAutoCommit;
 547     return $error if $error;
 548   }
 549
 550   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 551     $error = $new->queue_fuzzyfiles_update;
 552     if ( $error ) {
 553       $dbh->rollback if $oldAutoCommit;
 554       return "updating fuzzy search cache: $error";
 555     }
 556   }
 557
 558   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 559   ''; #no error
 560 }
 561
 562 =item queue_fuzzyfiles_update
 563
 564 Used by insert & replace to update the fuzzy search cache
 565
 566 =cut
 567
 568 sub queue_fuzzyfiles_update {
 569   my $self = shift;
 570
 571   local $SIG{HUP} = 'IGNORE';
 572   local $SIG{INT} = 'IGNORE';
 573   local $SIG{QUIT} = 'IGNORE';
 574   local $SIG{TERM} = 'IGNORE';
 575   local $SIG{TSTP} = 'IGNORE';
 576   local $SIG{PIPE} = 'IGNORE';
 577
 578   my $oldAutoCommit = $FS::UID::AutoCommit;
 579   local $FS::UID::AutoCommit = 0;
 580   my $dbh = dbh;
 581
 582   my $queue = new FS::queue {
 583     'svcnum' => $self->svcnum,
 584     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 585   };
 586   my $error = $queue->insert($self->username);
 587   if ( $error ) {
 588     $dbh->rollback if $oldAutoCommit;
 589     return "queueing job (transaction rolled back): $error";
 590   }
 591
 592   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 593   '';
 594
 595 }
 596
 597
 598 =item suspend
 599
 600 Suspends this account by calling export-specific suspend hooks.  If there is
 601 an error, returns the error, otherwise returns false.
 602
 603 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 604
 605 =cut
 606
 607 sub suspend {
 608   my $self = shift;
 609   return "can't suspend system account" if $self->_check_system;
 610   $self->SUPER::suspend;
 611 }
 612
 613 =item unsuspend
 614
 615 Unsuspends this account by by calling export-specific suspend hooks.  If there
 616 is an error, returns the error, otherwise returns false.
 617
 618 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 619
 620 =cut
 621
 622 sub unsuspend {
 623   my $self = shift;
 624   my %hash = $self->hash;
 625   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 626     $hash{_password} = $1;
 627     my $new = new FS::svc_acct ( \%hash );
 628     my $error = $new->replace($self);
 629     return $error if $error;
 630   }
 631
 632   $self->SUPER::unsuspend;
 633 }
 634
 635 =item cancel
 636
 637 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 638
 639 If the B<auto_unset_catchall> configuration option is set, this method will
 640 automatically remove any references to the canceled service in the catchall
 641 field of svc_domain.  This allows packages that contain both a svc_domain and
 642 its catchall svc_acct to be canceled in one step.
 643
 644 =cut
 645
 646 sub cancel {
 647   # Only one thing to do at this level
 648   my $self = shift;
 649   foreach my $svc_domain (
 650       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 651     if($conf->exists('auto_unset_catchall')) {
 652       my %hash = $svc_domain->hash;
 653       $hash{catchall} = '';
 654       my $new = new FS::svc_domain ( \%hash );
 655       my $error = $new->replace($svc_domain);
 656       return $error if $error;
 657     } else {
 658       return "cannot unprovision svc_acct #".$self->svcnum.
 659           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 660     }
 661   }
 662
 663   $self->SUPER::cancel;
 664 }
 665
 666
 667 =item check
 668
 669 Checks all fields to make sure this is a valid service.  If there is an error,
 670 returns the error, otherwise returns false.  Called by the insert and replace
 671 methods.
 672
 673 Sets any fixed values; see L<FS::part_svc>.
 674
 675 =cut
 676
 677 sub check {
 678   my $self = shift;
 679
 680   my($recref) = $self->hashref;
 681
 682   my $x = $self->setfixed;
 683   return $x unless ref($x);
 684   my $part_svc = $x;
 685
 686   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 687     $self->usergroup(
 688       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 689   }
 690
 691   my $error = $self->ut_numbern('svcnum')
 692               #|| $self->ut_number('domsvc')
 693               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 694               || $self->ut_textn('sec_phrase')
 695   ;
 696   return $error if $error;
 697
 698   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 699   if ( $username_uppercase ) {
 700     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
 701       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 702     $recref->{username} = $1;
 703   } else {
 704     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
 705       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 706     $recref->{username} = $1;
 707   }
 708
 709   if ( $username_letterfirst ) {
 710     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 711   } elsif ( $username_letter ) {
 712     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 713   }
 714   if ( $username_noperiod ) {
 715     $recref->{username} =~ /\./ and return gettext('illegal_username');
 716   }
 717   if ( $username_nounderscore ) {
 718     $recref->{username} =~ /_/ and return gettext('illegal_username');
 719   }
 720   if ( $username_nodash ) {
 721     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 722   }
 723   unless ( $username_ampersand ) {
 724     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 725   }
 726   if ( $password_noampersand ) {
 727     $recref->{_password} =~ /\&/ and return gettext('illegal_password');
 728   }
 729   if ( $password_noexclamation ) {
 730     $recref->{_password} =~ /\!/ and return gettext('illegal_password');
 731   }
 732   unless ( $username_percent ) {
 733     $recref->{username} =~ /\%/ and return gettext('illegal_username');
 734   }
 735
 736   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 737   $recref->{popnum} = $1;
 738   return "Unknown popnum" unless
 739     ! $recref->{popnum} ||
 740     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 741
 742   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 743
 744     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 745     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 746
 747     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 748     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 749     #not all systems use gid=uid
 750     #you can set a fixed gid in part_svc
 751
 752     return "Only root can have uid 0"
 753       if $recref->{uid} == 0
 754          && $recref->{username} !~ /^(root|toor|smtp)$/;
 755
 756     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 757       or return "Illegal directory: ". $recref->{dir};
 758     $recref->{dir} = $1;
 759     return "Illegal directory"
 760       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 761     return "Illegal directory"
 762       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 763     unless ( $recref->{dir} ) {
 764       $recref->{dir} = $dir_prefix . '/';
 765       if ( $dirhash > 0 ) {
 766         for my $h ( 1 .. $dirhash ) {
 767           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 768         }
 769       } elsif ( $dirhash < 0 ) {
 770         for my $h ( reverse $dirhash .. -1 ) {
 771           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 772         }
 773       }
 774       $recref->{dir} .= $recref->{username};
 775     ;
 776     }
 777
 778     unless ( $recref->{username} eq 'sync' ) {
 779       if ( grep $_ eq $recref->{shell}, @shells ) {
 780         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 781       } else {
 782         return "Illegal shell \`". $self->shell. "\'; ".
 783                $conf->dir. "/shells contains: @shells";
 784       }
 785     } else {
 786       $recref->{shell} = '/bin/sync';
 787     }
 788
 789   } else {
 790     $recref->{gid} ne '' ?
 791       return "Can't have gid without uid" : ( $recref->{gid}='' );
 792     $recref->{dir} ne '' ?
 793       return "Can't have directory without uid" : ( $recref->{dir}='' );
 794     $recref->{shell} ne '' ?
 795       return "Can't have shell without uid" : ( $recref->{shell}='' );
 796   }
 797
 798   #  $error = $self->ut_textn('finger');
 799   #  return $error if $error;
 800   if ( $self->getfield('finger') eq '' ) {
 801     my $cust_pkg = $self->svcnum
 802       ? $self->cust_svc->cust_pkg
 803       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
 804     if ( $cust_pkg ) {
 805       my $cust_main = $cust_pkg->cust_main;
 806       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
 807     }
 808   }
 809   $self->getfield('finger') =~
 810     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 811       or return "Illegal finger: ". $self->getfield('finger');
 812   $self->setfield('finger', $1);
 813
 814   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
 815   $recref->{quota} = $1;
 816
 817   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 818     if ( $recref->{slipip} eq '' ) {
 819       $recref->{slipip} = '';
 820     } elsif ( $recref->{slipip} eq '0e0' ) {
 821       $recref->{slipip} = '0e0';
 822     } else {
 823       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 824         or return "Illegal slipip: ". $self->slipip;
 825       $recref->{slipip} = $1;
 826     }
 827
 828   }
 829
 830   #arbitrary RADIUS stuff; allow ut_textn for now
 831   foreach ( grep /^radius_/, fields('svc_acct') ) {
 832     $self->ut_textn($_);
 833   }
 834
 835   #generate a password if it is blank
 836   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 837     unless ( $recref->{_password} );
 838
 839   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 840   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 841     $recref->{_password} = $1.$3;
 842     #uncomment this to encrypt password immediately upon entry, or run
 843     #bin/crypt_pw in cron to give new users a window during which their
 844     #password is available to techs, for faxing, etc.  (also be aware of
 845     #radius issues!)
 846     #$recref->{password} = $1.
 847     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 848     #;
 849   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 850     $recref->{_password} = $1.$3;
 851   } elsif ( $recref->{_password} eq '*' ) {
 852     $recref->{_password} = '*';
 853   } elsif ( $recref->{_password} eq '!' ) {
 854     $recref->{_password} = '!';
 855   } elsif ( $recref->{_password} eq '!!' ) {
 856     $recref->{_password} = '!!';
 857   } else {
 858     #return "Illegal password";
 859     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 860            FS::Msgcat::_gettext('illegal_password_characters').
 861            ": ". $recref->{_password};
 862   }
 863
 864   $self->SUPER::check;
 865 }
 866
 867 =item _check_system
 868
 869 Internal function to check the username against the list of system usernames
 870 from the I<system_usernames> configuration value.  Returns true if the username
 871 is listed on the system username list.
 872
 873 =cut
 874
 875 sub _check_system {
 876   my $self = shift;
 877   scalar( grep { $self->username eq $_ || $self->email eq $_ }
 878                $conf->config('system_usernames')
 879         );
 880 }
 881
 882 =item _check_duplicate
 883
 884 Internal function to check for duplicates usernames, username@domain pairs and
 885 uids.
 886
 887 If the I<global_unique-username> configuration value is set to B<username> or
 888 B<username@domain>, enforces global username or username@domain uniqueness.
 889
 890 In all cases, check for duplicate uids and usernames or username@domain pairs
 891 per export and with identical I<svcpart> values.
 892
 893 =cut
 894
 895 sub _check_duplicate {
 896   my $self = shift;
 897
 898   #this is Pg-specific.  what to do for mysql etc?
 899   # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
 900   warn "$me locking svc_acct table for duplicate search" if $DEBUG;
 901   dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
 902     or die dbh->errstr;
 903   warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
 904
 905   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
 906   unless ( $part_svc ) {
 907     return 'unknown svcpart '. $self->svcpart;
 908   }
 909
 910   my $global_unique = $conf->config('global_unique-username') || 'none';
 911
 912   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 913                  qsearch( 'svc_acct', { 'username' => $self->username } );
 914   return gettext('username_in_use')
 915     if $global_unique eq 'username' && @dup_user;
 916
 917   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 918                        qsearch( 'svc_acct', { 'username' => $self->username,
 919                                               'domsvc'   => $self->domsvc } );
 920   return gettext('username_in_use')
 921     if $global_unique eq 'username@domain' && @dup_userdomain;
 922
 923   my @dup_uid;
 924   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
 925        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
 926     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 927                qsearch( 'svc_acct', { 'uid' => $self->uid } );
 928   } else {
 929     @dup_uid = ();
 930   }
 931
 932   if ( @dup_user || @dup_userdomain || @dup_uid ) {
 933     my $exports = FS::part_export::export_info('svc_acct');
 934     my %conflict_user_svcpart;
 935     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
 936
 937     foreach my $part_export ( $part_svc->part_export ) {
 938
 939       #this will catch to the same exact export
 940       my @svcparts = map { $_->svcpart } $part_export->export_svc;
 941
 942       #this will catch to exports w/same exporthost+type ???
 943       #my @other_part_export = qsearch('part_export', {
 944       #  'machine'    => $part_export->machine,
 945       #  'exporttype' => $part_export->exporttype,
 946       #} );
 947       #foreach my $other_part_export ( @other_part_export ) {
 948       #  push @svcparts, map { $_->svcpart }
 949       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 950       #}
 951
 952       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
 953       #silly kludge to avoid uninitialized value errors
 954       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
 955                      ? $exports->{$part_export->exporttype}{'nodomain'}
 956                      : '';
 957       if ( $nodomain =~ /^Y/i ) {
 958         $conflict_user_svcpart{$_} = $part_export->exportnum
 959           foreach @svcparts;
 960       } else {
 961         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
 962           foreach @svcparts;
 963       }
 964     }
 965
 966     foreach my $dup_user ( @dup_user ) {
 967       my $dup_svcpart = $dup_user->cust_svc->svcpart;
 968       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
 969         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
 970                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
 971       }
 972     }
 973
 974     foreach my $dup_userdomain ( @dup_userdomain ) {
 975       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
 976       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 977         return "duplicate username\@domain: conflicts with svcnum ".
 978                $dup_userdomain->svcnum. " via exportnum ".
 979                $conflict_userdomain_svcpart{$dup_svcpart};
 980       }
 981     }
 982
 983     foreach my $dup_uid ( @dup_uid ) {
 984       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
 985       if ( exists($conflict_user_svcpart{$dup_svcpart})
 986            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 987         return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
 988                " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
 989                                  || $conflict_userdomain_svcpart{$dup_svcpart};
 990       }
 991     }
 992
 993   }
 994
 995   return '';
 996
 997 }
 998
 999 =item radius
1000
1001 Depriciated, use radius_reply instead.
1002
1003 =cut
1004
1005 sub radius {
1006   carp "FS::svc_acct::radius depriciated, use radius_reply";
1007   $_[0]->radius_reply;
1008 }
1009
1010 =item radius_reply
1011
1012 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1013 reply attributes of this record.
1014
1015 Note that this is now the preferred method for reading RADIUS attributes -
1016 accessing the columns directly is discouraged, as the column names are
1017 expected to change in the future.
1018
1019 =cut
1020
1021 sub radius_reply {
1022   my $self = shift;
1023
1024   my %reply =
1025     map {
1026       /^(radius_(.*))$/;
1027       my($column, $attrib) = ($1, $2);
1028       #$attrib =~ s/_/\-/g;
1029       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1030     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1031
1032   if ( $self->slipip && $self->slipip ne '0e0' ) {
1033     $reply{$radius_ip} = $self->slipip;
1034   }
1035
1036   if ( $self->seconds !~ /^$/ ) {
1037     $reply{'Session-Timeout'} = $self->seconds;
1038   }
1039
1040   %reply;
1041 }
1042
1043 =item radius_check
1044
1045 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1046 check attributes of this record.
1047
1048 Note that this is now the preferred method for reading RADIUS attributes -
1049 accessing the columns directly is discouraged, as the column names are
1050 expected to change in the future.
1051
1052 =cut
1053
1054 sub radius_check {
1055   my $self = shift;
1056
1057   my %check =
1058     map {
1059       /^(rc_(.*))$/;
1060       my($column, $attrib) = ($1, $2);
1061       #$attrib =~ s/_/\-/g;
1062       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1063     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1064
1065   my $password = $self->_password;
1066   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';  $check{$pw_attrib} = $password;
1067
1068   my $cust_pkg = $self->cust_svc->cust_pkg;
1069   if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1070     $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1071   }
1072
1073   %check;
1074
1075 }
1076
1077 =item domain
1078
1079 Returns the domain associated with this account.
1080
1081 =cut
1082
1083 sub domain {
1084   my $self = shift;
1085   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1086   my $svc_domain = $self->svc_domain(@_)
1087     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1088   $svc_domain->domain;
1089 }
1090
1091 =item svc_domain
1092
1093 Returns the FS::svc_domain record for this account's domain (see
1094 L<FS::svc_domain>).
1095
1096 =cut
1097
1098 sub svc_domain {
1099   my $self = shift;
1100   $self->{'_domsvc'}
1101     ? $self->{'_domsvc'}
1102     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1103 }
1104
1105 =item cust_svc
1106
1107 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1108
1109 =cut
1110
1111 #inherited from svc_Common
1112
1113 =item email
1114
1115 Returns an email address associated with the account.
1116
1117 =cut
1118
1119 sub email {
1120   my $self = shift;
1121   $self->username. '@'. $self->domain(@_);
1122 }
1123
1124 =item acct_snarf
1125
1126 Returns an array of FS::acct_snarf records associated with the account.
1127 If the acct_snarf table does not exist or there are no associated records,
1128 an empty list is returned
1129
1130 =cut
1131
1132 sub acct_snarf {
1133   my $self = shift;
1134   return () unless dbdef->table('acct_snarf');
1135   eval "use FS::acct_snarf;";
1136   die $@ if $@;
1137   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1138 }
1139
1140 =item decrement_seconds SECONDS
1141
1142 Decrements the I<seconds> field of this record by the given amount.  If there
1143 is an error, returns the error, otherwise returns false.
1144
1145 =cut
1146
1147 sub decrement_seconds {
1148   shift->_op_seconds('-', @_);
1149 }
1150
1151 =item increment_seconds SECONDS
1152
1153 Increments the I<seconds> field of this record by the given amount.  If there
1154 is an error, returns the error, otherwise returns false.
1155
1156 =cut
1157
1158 sub increment_seconds {
1159   shift->_op_seconds('+', @_);
1160 }
1161
1162
1163 my %op2action = (
1164   '-' => 'suspend',
1165   '+' => 'unsuspend',
1166 );
1167 my %op2condition = (
1168   '-' => sub { my($self, $seconds) = @_;
1169                $self->seconds - $seconds <= 0;
1170              },
1171   '+' => sub { my($self, $seconds) = @_;
1172                $self->seconds + $seconds > 0;
1173              },
1174 );
1175
1176 sub _op_seconds {
1177   my( $self, $op, $seconds ) = @_;
1178   warn "$me _op_seconds called for svcnum ". $self->svcnum.
1179        ' ('. $self->email. "): $op $seconds\n"
1180     if $DEBUG;
1181
1182   local $SIG{HUP} = 'IGNORE';
1183   local $SIG{INT} = 'IGNORE';
1184   local $SIG{QUIT} = 'IGNORE';
1185   local $SIG{TERM} = 'IGNORE';
1186   local $SIG{TSTP} = 'IGNORE';
1187   local $SIG{PIPE} = 'IGNORE';
1188
1189   my $oldAutoCommit = $FS::UID::AutoCommit;
1190   local $FS::UID::AutoCommit = 0;
1191   my $dbh = dbh;
1192
1193   my $sql = "UPDATE svc_acct SET seconds = ".
1194             " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0
1195             " $op ? WHERE svcnum = ?";
1196   warn "$me $sql\n"
1197     if $DEBUG;
1198
1199   my $sth = $dbh->prepare( $sql )
1200     or die "Error preparing $sql: ". $dbh->errstr;
1201   my $rv = $sth->execute($seconds, $self->svcnum);
1202   die "Error executing $sql: ". $sth->errstr
1203     unless defined($rv);
1204   die "Can't update seconds for svcnum". $self->svcnum
1205     if $rv == 0;
1206
1207   my $action = $op2action{$op};
1208
1209   if ( $conf->exists("svc_acct-usage_$action")
1210        && &{$op2condition{$op}}($self, $seconds)    ) {
1211     #my $error = $self->$action();
1212     my $error = $self->cust_svc->cust_pkg->$action();
1213     if ( $error ) {
1214       $dbh->rollback if $oldAutoCommit;
1215       return "Error ${action}ing: $error";
1216     }
1217   }
1218
1219   warn "$me update sucessful; committing\n"
1220     if $DEBUG;
1221   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1222   '';
1223
1224 }
1225
1226
1227 =item seconds_since TIMESTAMP
1228
1229 Returns the number of seconds this account has been online since TIMESTAMP,
1230 according to the session monitor (see L<FS::Session>).
1231
1232 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1233 L<Time::Local> and L<Date::Parse> for conversion functions.
1234
1235 =cut
1236
1237 #note: POD here, implementation in FS::cust_svc
1238 sub seconds_since {
1239   my $self = shift;
1240   $self->cust_svc->seconds_since(@_);
1241 }
1242
1243 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1244
1245 Returns the numbers of seconds this account has been online between
1246 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1247 external SQL radacct table, specified via sqlradius export.  Sessions which
1248 started in the specified range but are still open are counted from session
1249 start to the end of the range (unless they are over 1 day old, in which case
1250 they are presumed missing their stop record and not counted).  Also, sessions
1251 which end in the range but started earlier are counted from the start of the
1252 range to session end.  Finally, sessions which start before the range but end
1253 after are counted for the entire range.
1254
1255 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1256 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1257 functions.
1258
1259 =cut
1260
1261 #note: POD here, implementation in FS::cust_svc
1262 sub seconds_since_sqlradacct {
1263   my $self = shift;
1264   $self->cust_svc->seconds_since_sqlradacct(@_);
1265 }
1266
1267 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1268
1269 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1270 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1271 TIMESTAMP_END (exclusive).
1272
1273 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1274 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1275 functions.
1276
1277 =cut
1278
1279 #note: POD here, implementation in FS::cust_svc
1280 sub attribute_since_sqlradacct {
1281   my $self = shift;
1282   $self->cust_svc->attribute_since_sqlradacct(@_);
1283 }
1284
1285 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1286
1287 Returns an array of hash references of this customers login history for the
1288 given time range.  (document this better)
1289
1290 =cut
1291
1292 sub get_session_history {
1293   my $self = shift;
1294   $self->cust_svc->get_session_history(@_);
1295 }
1296
1297 =item radius_groups
1298
1299 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1300
1301 =cut
1302
1303 sub radius_groups {
1304   my $self = shift;
1305   if ( $self->usergroup ) {
1306     #when provisioning records, export callback runs in svc_Common.pm before
1307     #radius_usergroup records can be inserted...
1308     @{$self->usergroup};
1309   } else {
1310     map { $_->groupname }
1311       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1312   }
1313 }
1314
1315 =item clone_suspended
1316
1317 Constructor used by FS::part_export::_export_suspend fallback.  Document
1318 better.
1319
1320 =cut
1321
1322 sub clone_suspended {
1323   my $self = shift;
1324   my %hash = $self->hash;
1325   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1326   new FS::svc_acct \%hash;
1327 }
1328
1329 =item clone_kludge_unsuspend
1330
1331 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1332 better.
1333
1334 =cut
1335
1336 sub clone_kludge_unsuspend {
1337   my $self = shift;
1338   my %hash = $self->hash;
1339   $hash{_password} = '';
1340   new FS::svc_acct \%hash;
1341 }
1342
1343 =item check_password
1344
1345 Checks the supplied password against the (possibly encrypted) password in the
1346 database.  Returns true for a sucessful authentication, false for no match.
1347
1348 Currently supported encryptions are: classic DES crypt() and MD5
1349
1350 =cut
1351
1352 sub check_password {
1353   my($self, $check_password) = @_;
1354
1355   #remove old-style SUSPENDED kludge, they should be allowed to login to
1356   #self-service and pay up
1357   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1358
1359   #eventually should check a "password-encoding" field
1360   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1361     return 0;
1362   } elsif ( length($password) < 13 ) { #plaintext
1363     $check_password eq $password;
1364   } elsif ( length($password) == 13 ) { #traditional DES crypt
1365     crypt($check_password, $password) eq $password;
1366   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1367     unix_md5_crypt($check_password, $password) eq $password;
1368   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1369     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1370          $self->svcnum. "\n";
1371     0;
1372   } else {
1373     warn "Can't check password: Unrecognized encryption for svcnum ".
1374          $self->svcnum. "\n";
1375     0;
1376   }
1377
1378 }
1379
1380 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1381
1382 Returns an encrypted password, either by passing through an encrypted password
1383 in the database or by encrypting a plaintext password from the database.
1384
1385 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1386 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1387 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1388 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
1389 encryption type is only used if the password is not already encrypted in the
1390 database.
1391
1392 =cut
1393
1394 sub crypt_password {
1395   my $self = shift;
1396   #eventually should check a "password-encoding" field
1397   if ( length($self->_password) == 13
1398        || $self->_password =~ /^\$(1|2a?)\$/
1399        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1400      )
1401   {
1402     $self->_password;
1403   } else {
1404     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1405     if ( $encryption eq 'crypt' ) {
1406       crypt(
1407         $self->_password,
1408         $saltset[int(rand(64))].$saltset[int(rand(64))]
1409       );
1410     } elsif ( $encryption eq 'md5' ) {
1411       unix_md5_crypt( $self->_password );
1412     } elsif ( $encryption eq 'blowfish' ) {
1413       die "unknown encryption method $encryption";
1414     } else {
1415       die "unknown encryption method $encryption";
1416     }
1417   }
1418 }
1419
1420 =item virtual_maildir
1421
1422 Returns $domain/maildirs/$username/
1423
1424 =cut
1425
1426 sub virtual_maildir {
1427   my $self = shift;
1428   $self->domain. '/maildirs/'. $self->username. '/';
1429 }
1430
1431 =back
1432
1433 =head1 SUBROUTINES
1434
1435 =over 4
1436
1437 =item send_email
1438
1439 This is the FS::svc_acct job-queue-able version.  It still uses
1440 FS::Misc::send_email under-the-hood.
1441
1442 =cut
1443
1444 sub send_email {
1445   my %opt = @_;
1446
1447   eval "use FS::Misc qw(send_email)";
1448   die $@ if $@;
1449
1450   $opt{mimetype} ||= 'text/plain';
1451   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1452
1453   my $error = send_email(
1454     'from'         => $opt{from},
1455     'to'           => $opt{to},
1456     'subject'      => $opt{subject},
1457     'content-type' => $opt{mimetype},
1458     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1459   );
1460   die $error if $error;
1461 }
1462
1463 =item check_and_rebuild_fuzzyfiles
1464
1465 =cut
1466
1467 sub check_and_rebuild_fuzzyfiles {
1468   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1469   -e "$dir/svc_acct.username"
1470     or &rebuild_fuzzyfiles;
1471 }
1472
1473 =item rebuild_fuzzyfiles
1474
1475 =cut
1476
1477 sub rebuild_fuzzyfiles {
1478
1479   use Fcntl qw(:flock);
1480
1481   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1482
1483   #username
1484
1485   open(USERNAMELOCK,">>$dir/svc_acct.username")
1486     or die "can't open $dir/svc_acct.username: $!";
1487   flock(USERNAMELOCK,LOCK_EX)
1488     or die "can't lock $dir/svc_acct.username: $!";
1489
1490   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1491
1492   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1493     or die "can't open $dir/svc_acct.username.tmp: $!";
1494   print USERNAMECACHE join("\n", @all_username), "\n";
1495   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1496
1497   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1498   close USERNAMELOCK;
1499
1500 }
1501
1502 =item all_username
1503
1504 =cut
1505
1506 sub all_username {
1507   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1508   open(USERNAMECACHE,"<$dir/svc_acct.username")
1509     or die "can't open $dir/svc_acct.username: $!";
1510   my @array = map { chomp; $_; } <USERNAMECACHE>;
1511   close USERNAMECACHE;
1512   \@array;
1513 }
1514
1515 =item append_fuzzyfiles USERNAME
1516
1517 =cut
1518
1519 sub append_fuzzyfiles {
1520   my $username = shift;
1521
1522   &check_and_rebuild_fuzzyfiles;
1523
1524   use Fcntl qw(:flock);
1525
1526   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1527
1528   open(USERNAME,">>$dir/svc_acct.username")
1529     or die "can't open $dir/svc_acct.username: $!";
1530   flock(USERNAME,LOCK_EX)
1531     or die "can't lock $dir/svc_acct.username: $!";
1532
1533   print USERNAME "$username\n";
1534
1535   flock(USERNAME,LOCK_UN)
1536     or die "can't unlock $dir/svc_acct.username: $!";
1537   close USERNAME;
1538
1539   1;
1540 }
1541
1542
1543
1544 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1545
1546 =cut
1547
1548 sub radius_usergroup_selector {
1549   my $sel_groups = shift;
1550   my %sel_groups = map { $_=>1 } @$sel_groups;
1551
1552   my $selectname = shift || 'radius_usergroup';
1553
1554   my $dbh = dbh;
1555   my $sth = $dbh->prepare(
1556     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1557   ) or die $dbh->errstr;
1558   $sth->execute() or die $sth->errstr;
1559   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1560
1561   my $html = <<END;
1562     <SCRIPT>
1563     function ${selectname}_doadd(object) {
1564       var myvalue = object.${selectname}_add.value;
1565       var optionName = new Option(myvalue,myvalue,false,true);
1566       var length = object.$selectname.length;
1567       object.$selectname.options[length] = optionName;
1568       object.${selectname}_add.value = "";
1569     }
1570     </SCRIPT>
1571     <SELECT MULTIPLE NAME="$selectname">
1572 END
1573
1574   foreach my $group ( @all_groups ) {
1575     $html .= qq(<OPTION VALUE="$group");
1576     if ( $sel_groups{$group} ) {
1577       $html .= ' SELECTED';
1578       $sel_groups{$group} = 0;
1579     }
1580     $html .= ">$group</OPTION>\n";
1581   }
1582   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1583     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1584   };
1585   $html .= '</SELECT>';
1586
1587   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1588            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1589
1590   $html;
1591 }
1592
1593 =back
1594
1595 =head1 BUGS
1596
1597 The $recref stuff in sub check should be cleaned up.
1598
1599 The suspend, unsuspend and cancel methods update the database, but not the
1600 current object.  This is probably a bug as it's unexpected and
1601 counterintuitive.
1602
1603 radius_usergroup_selector?  putting web ui components in here?  they should
1604 probably live somewhere else...
1605
1606 insertion of RADIUS group stuff in insert could be done with child_objects now
1607 (would probably clean up export of them too)
1608
1609 =head1 SEE ALSO
1610
1611 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1612 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1613 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1614 L<freeside-queued>), L<FS::svc_acct_pop>,
1615 schema.html from the base documentation.
1616
1617 =cut
1618
1619 1;
1620