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   return %{ $self->{'radius_reply'} }
1025     if exists $self->{'radius_reply'};
1026
1027   my %reply =
1028     map {
1029       /^(radius_(.*))$/;
1030       my($column, $attrib) = ($1, $2);
1031       #$attrib =~ s/_/\-/g;
1032       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1033     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1034
1035   if ( $self->slipip && $self->slipip ne '0e0' ) {
1036     $reply{$radius_ip} = $self->slipip;
1037   }
1038
1039   if ( $self->seconds !~ /^$/ ) {
1040     $reply{'Session-Timeout'} = $self->seconds;
1041   }
1042
1043   %reply;
1044 }
1045
1046 =item radius_check
1047
1048 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1049 check attributes of this record.
1050
1051 Note that this is now the preferred method for reading RADIUS attributes -
1052 accessing the columns directly is discouraged, as the column names are
1053 expected to change in the future.
1054
1055 =cut
1056
1057 sub radius_check {
1058   my $self = shift;
1059
1060   return %{ $self->{'radius_check'} }
1061     if exists $self->{'radius_check'};
1062
1063   my %check =
1064     map {
1065       /^(rc_(.*))$/;
1066       my($column, $attrib) = ($1, $2);
1067       #$attrib =~ s/_/\-/g;
1068       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1069     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1070
1071   my $password = $self->_password;
1072   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';  $check{$pw_attrib} = $password;
1073
1074   my $cust_pkg = $self->cust_svc->cust_pkg;
1075   if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1076     $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1077   }
1078
1079   %check;
1080
1081 }
1082
1083 =item snapshot
1084
1085 This method instructs the object to "snapshot" or freeze RADIUS check and
1086 reply attributes to the current values.
1087
1088 =cut
1089
1090 #bah, my english is too broken this morning
1091 #Of note is the "Expiration" attribute, which, for accounts in prepaid packages, is typically defined on-the-fly as the associated packages cust_pkg.bill.  (This is used by
1092 #the FS::cust_pkg's replace method to trigger the correct export updates when
1093 #package dates change)
1094
1095 sub snapshot {
1096   my $self = shift;
1097
1098   $self->{$_} = { $self->$_() }
1099     foreach qw( radius_reply radius_check );
1100
1101 }
1102
1103 =item forget_snapshot
1104
1105 This methos instructs the object to forget any previously snapshotted
1106 RADIUS check and reply attributes.
1107
1108 =cut
1109
1110 sub forget_snapshot {
1111   my $self = shift;
1112
1113   delete $self->{$_}
1114     foreach qw( radius_reply radius_check );
1115
1116 }
1117
1118 =item domain
1119
1120 Returns the domain associated with this account.
1121
1122 =cut
1123
1124 sub domain {
1125   my $self = shift;
1126   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1127   my $svc_domain = $self->svc_domain(@_)
1128     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1129   $svc_domain->domain;
1130 }
1131
1132 =item svc_domain
1133
1134 Returns the FS::svc_domain record for this account's domain (see
1135 L<FS::svc_domain>).
1136
1137 =cut
1138
1139 sub svc_domain {
1140   my $self = shift;
1141   $self->{'_domsvc'}
1142     ? $self->{'_domsvc'}
1143     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1144 }
1145
1146 =item cust_svc
1147
1148 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1149
1150 =cut
1151
1152 #inherited from svc_Common
1153
1154 =item email
1155
1156 Returns an email address associated with the account.
1157
1158 =cut
1159
1160 sub email {
1161   my $self = shift;
1162   $self->username. '@'. $self->domain(@_);
1163 }
1164
1165 =item acct_snarf
1166
1167 Returns an array of FS::acct_snarf records associated with the account.
1168 If the acct_snarf table does not exist or there are no associated records,
1169 an empty list is returned
1170
1171 =cut
1172
1173 sub acct_snarf {
1174   my $self = shift;
1175   return () unless dbdef->table('acct_snarf');
1176   eval "use FS::acct_snarf;";
1177   die $@ if $@;
1178   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1179 }
1180
1181 =item decrement_seconds SECONDS
1182
1183 Decrements the I<seconds> field of this record by the given amount.  If there
1184 is an error, returns the error, otherwise returns false.
1185
1186 =cut
1187
1188 sub decrement_seconds {
1189   shift->_op_seconds('-', @_);
1190 }
1191
1192 =item increment_seconds SECONDS
1193
1194 Increments the I<seconds> field of this record by the given amount.  If there
1195 is an error, returns the error, otherwise returns false.
1196
1197 =cut
1198
1199 sub increment_seconds {
1200   shift->_op_seconds('+', @_);
1201 }
1202
1203
1204 my %op2action = (
1205   '-' => 'suspend',
1206   '+' => 'unsuspend',
1207 );
1208 my %op2condition = (
1209   '-' => sub { my($self, $seconds) = @_;
1210                $self->seconds - $seconds <= 0;
1211              },
1212   '+' => sub { my($self, $seconds) = @_;
1213                $self->seconds + $seconds > 0;
1214              },
1215 );
1216
1217 sub _op_seconds {
1218   my( $self, $op, $seconds ) = @_;
1219   warn "$me _op_seconds called for svcnum ". $self->svcnum.
1220        ' ('. $self->email. "): $op $seconds\n"
1221     if $DEBUG;
1222
1223   local $SIG{HUP} = 'IGNORE';
1224   local $SIG{INT} = 'IGNORE';
1225   local $SIG{QUIT} = 'IGNORE';
1226   local $SIG{TERM} = 'IGNORE';
1227   local $SIG{TSTP} = 'IGNORE';
1228   local $SIG{PIPE} = 'IGNORE';
1229
1230   my $oldAutoCommit = $FS::UID::AutoCommit;
1231   local $FS::UID::AutoCommit = 0;
1232   my $dbh = dbh;
1233
1234   my $sql = "UPDATE svc_acct SET seconds = ".
1235             " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0
1236             " $op ? WHERE svcnum = ?";
1237   warn "$me $sql\n"
1238     if $DEBUG;
1239
1240   my $sth = $dbh->prepare( $sql )
1241     or die "Error preparing $sql: ". $dbh->errstr;
1242   my $rv = $sth->execute($seconds, $self->svcnum);
1243   die "Error executing $sql: ". $sth->errstr
1244     unless defined($rv);
1245   die "Can't update seconds for svcnum". $self->svcnum
1246     if $rv == 0;
1247
1248   my $action = $op2action{$op};
1249
1250   if ( $conf->exists("svc_acct-usage_$action")
1251        && &{$op2condition{$op}}($self, $seconds)    ) {
1252     #my $error = $self->$action();
1253     my $error = $self->cust_svc->cust_pkg->$action();
1254     if ( $error ) {
1255       $dbh->rollback if $oldAutoCommit;
1256       return "Error ${action}ing: $error";
1257     }
1258   }
1259
1260   warn "$me update sucessful; committing\n"
1261     if $DEBUG;
1262   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1263   '';
1264
1265 }
1266
1267
1268 =item seconds_since TIMESTAMP
1269
1270 Returns the number of seconds this account has been online since TIMESTAMP,
1271 according to the session monitor (see L<FS::Session>).
1272
1273 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1274 L<Time::Local> and L<Date::Parse> for conversion functions.
1275
1276 =cut
1277
1278 #note: POD here, implementation in FS::cust_svc
1279 sub seconds_since {
1280   my $self = shift;
1281   $self->cust_svc->seconds_since(@_);
1282 }
1283
1284 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1285
1286 Returns the numbers of seconds this account has been online between
1287 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1288 external SQL radacct table, specified via sqlradius export.  Sessions which
1289 started in the specified range but are still open are counted from session
1290 start to the end of the range (unless they are over 1 day old, in which case
1291 they are presumed missing their stop record and not counted).  Also, sessions
1292 which end in the range but started earlier are counted from the start of the
1293 range to session end.  Finally, sessions which start before the range but end
1294 after are counted for the entire range.
1295
1296 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1297 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1298 functions.
1299
1300 =cut
1301
1302 #note: POD here, implementation in FS::cust_svc
1303 sub seconds_since_sqlradacct {
1304   my $self = shift;
1305   $self->cust_svc->seconds_since_sqlradacct(@_);
1306 }
1307
1308 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1309
1310 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1311 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1312 TIMESTAMP_END (exclusive).
1313
1314 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1315 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1316 functions.
1317
1318 =cut
1319
1320 #note: POD here, implementation in FS::cust_svc
1321 sub attribute_since_sqlradacct {
1322   my $self = shift;
1323   $self->cust_svc->attribute_since_sqlradacct(@_);
1324 }
1325
1326 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1327
1328 Returns an array of hash references of this customers login history for the
1329 given time range.  (document this better)
1330
1331 =cut
1332
1333 sub get_session_history {
1334   my $self = shift;
1335   $self->cust_svc->get_session_history(@_);
1336 }
1337
1338 =item radius_groups
1339
1340 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1341
1342 =cut
1343
1344 sub radius_groups {
1345   my $self = shift;
1346   if ( $self->usergroup ) {
1347     #when provisioning records, export callback runs in svc_Common.pm before
1348     #radius_usergroup records can be inserted...
1349     @{$self->usergroup};
1350   } else {
1351     map { $_->groupname }
1352       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1353   }
1354 }
1355
1356 =item clone_suspended
1357
1358 Constructor used by FS::part_export::_export_suspend fallback.  Document
1359 better.
1360
1361 =cut
1362
1363 sub clone_suspended {
1364   my $self = shift;
1365   my %hash = $self->hash;
1366   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1367   new FS::svc_acct \%hash;
1368 }
1369
1370 =item clone_kludge_unsuspend
1371
1372 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1373 better.
1374
1375 =cut
1376
1377 sub clone_kludge_unsuspend {
1378   my $self = shift;
1379   my %hash = $self->hash;
1380   $hash{_password} = '';
1381   new FS::svc_acct \%hash;
1382 }
1383
1384 =item check_password
1385
1386 Checks the supplied password against the (possibly encrypted) password in the
1387 database.  Returns true for a sucessful authentication, false for no match.
1388
1389 Currently supported encryptions are: classic DES crypt() and MD5
1390
1391 =cut
1392
1393 sub check_password {
1394   my($self, $check_password) = @_;
1395
1396   #remove old-style SUSPENDED kludge, they should be allowed to login to
1397   #self-service and pay up
1398   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1399
1400   #eventually should check a "password-encoding" field
1401   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1402     return 0;
1403   } elsif ( length($password) < 13 ) { #plaintext
1404     $check_password eq $password;
1405   } elsif ( length($password) == 13 ) { #traditional DES crypt
1406     crypt($check_password, $password) eq $password;
1407   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1408     unix_md5_crypt($check_password, $password) eq $password;
1409   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1410     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1411          $self->svcnum. "\n";
1412     0;
1413   } else {
1414     warn "Can't check password: Unrecognized encryption for svcnum ".
1415          $self->svcnum. "\n";
1416     0;
1417   }
1418
1419 }
1420
1421 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1422
1423 Returns an encrypted password, either by passing through an encrypted password
1424 in the database or by encrypting a plaintext password from the database.
1425
1426 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1427 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1428 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1429 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
1430 encryption type is only used if the password is not already encrypted in the
1431 database.
1432
1433 =cut
1434
1435 sub crypt_password {
1436   my $self = shift;
1437   #eventually should check a "password-encoding" field
1438   if ( length($self->_password) == 13
1439        || $self->_password =~ /^\$(1|2a?)\$/
1440        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1441      )
1442   {
1443     $self->_password;
1444   } else {
1445     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1446     if ( $encryption eq 'crypt' ) {
1447       crypt(
1448         $self->_password,
1449         $saltset[int(rand(64))].$saltset[int(rand(64))]
1450       );
1451     } elsif ( $encryption eq 'md5' ) {
1452       unix_md5_crypt( $self->_password );
1453     } elsif ( $encryption eq 'blowfish' ) {
1454       die "unknown encryption method $encryption";
1455     } else {
1456       die "unknown encryption method $encryption";
1457     }
1458   }
1459 }
1460
1461 =item virtual_maildir
1462
1463 Returns $domain/maildirs/$username/
1464
1465 =cut
1466
1467 sub virtual_maildir {
1468   my $self = shift;
1469   $self->domain. '/maildirs/'. $self->username. '/';
1470 }
1471
1472 =back
1473
1474 =head1 SUBROUTINES
1475
1476 =over 4
1477
1478 =item send_email
1479
1480 This is the FS::svc_acct job-queue-able version.  It still uses
1481 FS::Misc::send_email under-the-hood.
1482
1483 =cut
1484
1485 sub send_email {
1486   my %opt = @_;
1487
1488   eval "use FS::Misc qw(send_email)";
1489   die $@ if $@;
1490
1491   $opt{mimetype} ||= 'text/plain';
1492   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1493
1494   my $error = send_email(
1495     'from'         => $opt{from},
1496     'to'           => $opt{to},
1497     'subject'      => $opt{subject},
1498     'content-type' => $opt{mimetype},
1499     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1500   );
1501   die $error if $error;
1502 }
1503
1504 =item check_and_rebuild_fuzzyfiles
1505
1506 =cut
1507
1508 sub check_and_rebuild_fuzzyfiles {
1509   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1510   -e "$dir/svc_acct.username"
1511     or &rebuild_fuzzyfiles;
1512 }
1513
1514 =item rebuild_fuzzyfiles
1515
1516 =cut
1517
1518 sub rebuild_fuzzyfiles {
1519
1520   use Fcntl qw(:flock);
1521
1522   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1523
1524   #username
1525
1526   open(USERNAMELOCK,">>$dir/svc_acct.username")
1527     or die "can't open $dir/svc_acct.username: $!";
1528   flock(USERNAMELOCK,LOCK_EX)
1529     or die "can't lock $dir/svc_acct.username: $!";
1530
1531   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1532
1533   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1534     or die "can't open $dir/svc_acct.username.tmp: $!";
1535   print USERNAMECACHE join("\n", @all_username), "\n";
1536   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1537
1538   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1539   close USERNAMELOCK;
1540
1541 }
1542
1543 =item all_username
1544
1545 =cut
1546
1547 sub all_username {
1548   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1549   open(USERNAMECACHE,"<$dir/svc_acct.username")
1550     or die "can't open $dir/svc_acct.username: $!";
1551   my @array = map { chomp; $_; } <USERNAMECACHE>;
1552   close USERNAMECACHE;
1553   \@array;
1554 }
1555
1556 =item append_fuzzyfiles USERNAME
1557
1558 =cut
1559
1560 sub append_fuzzyfiles {
1561   my $username = shift;
1562
1563   &check_and_rebuild_fuzzyfiles;
1564
1565   use Fcntl qw(:flock);
1566
1567   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1568
1569   open(USERNAME,">>$dir/svc_acct.username")
1570     or die "can't open $dir/svc_acct.username: $!";
1571   flock(USERNAME,LOCK_EX)
1572     or die "can't lock $dir/svc_acct.username: $!";
1573
1574   print USERNAME "$username\n";
1575
1576   flock(USERNAME,LOCK_UN)
1577     or die "can't unlock $dir/svc_acct.username: $!";
1578   close USERNAME;
1579
1580   1;
1581 }
1582
1583
1584
1585 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1586
1587 =cut
1588
1589 sub radius_usergroup_selector {
1590   my $sel_groups = shift;
1591   my %sel_groups = map { $_=>1 } @$sel_groups;
1592
1593   my $selectname = shift || 'radius_usergroup';
1594
1595   my $dbh = dbh;
1596   my $sth = $dbh->prepare(
1597     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1598   ) or die $dbh->errstr;
1599   $sth->execute() or die $sth->errstr;
1600   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1601
1602   my $html = <<END;
1603     <SCRIPT>
1604     function ${selectname}_doadd(object) {
1605       var myvalue = object.${selectname}_add.value;
1606       var optionName = new Option(myvalue,myvalue,false,true);
1607       var length = object.$selectname.length;
1608       object.$selectname.options[length] = optionName;
1609       object.${selectname}_add.value = "";
1610     }
1611     </SCRIPT>
1612     <SELECT MULTIPLE NAME="$selectname">
1613 END
1614
1615   foreach my $group ( @all_groups ) {
1616     $html .= qq(<OPTION VALUE="$group");
1617     if ( $sel_groups{$group} ) {
1618       $html .= ' SELECTED';
1619       $sel_groups{$group} = 0;
1620     }
1621     $html .= ">$group</OPTION>\n";
1622   }
1623   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1624     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1625   };
1626   $html .= '</SELECT>';
1627
1628   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1629            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1630
1631   $html;
1632 }
1633
1634 =back
1635
1636 =head1 BUGS
1637
1638 The $recref stuff in sub check should be cleaned up.
1639
1640 The suspend, unsuspend and cancel methods update the database, but not the
1641 current object.  This is probably a bug as it's unexpected and
1642 counterintuitive.
1643
1644 radius_usergroup_selector?  putting web ui components in here?  they should
1645 probably live somewhere else...
1646
1647 insertion of RADIUS group stuff in insert could be done with child_objects now
1648 (would probably clean up export of them too)
1649
1650 =head1 SEE ALSO
1651
1652 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1653 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1654 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1655 L<freeside-queued>), L<FS::svc_acct_pop>,
1656 schema.html from the base documentation.
1657
1658 =cut
1659
1660 1;
1661