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