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