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