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