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              $warning_template $warning_from $warning_subject $warning_mimetype
  12              $warning_cc
  13              $smtpmachine
  14              $radius_password $radius_ip
  15              $dirhash
  16              @saltset @pw_set );
  17 use Carp;
  18 use Fcntl qw(:flock);
  19 use Date::Format;
  20 use Crypt::PasswdMD5 1.2;
  21 use Data::Dumper;
  22 use Authen::Passphrase;
  23 use FS::UID qw( datasrc );
  24 use FS::Conf;
  25 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  26 use FS::Msgcat qw(gettext);
  27 use FS::svc_Common;
  28 use FS::cust_svc;
  29 use FS::part_svc;
  30 use FS::svc_acct_pop;
  31 use FS::cust_main_invoice;
  32 use FS::svc_domain;
  33 use FS::raddb;
  34 use FS::queue;
  35 use FS::radius_usergroup;
  36 use FS::export_svc;
  37 use FS::part_export;
  38 use FS::svc_forward;
  39 use FS::svc_www;
  40 use FS::cdr;
  41
  42 @ISA = qw( FS::svc_Common );
  43
  44 $DEBUG = 1;
  45 $me = '[FS::svc_acct]';
  46
  47 #ask FS::UID to run this stuff for us later
  48 $FS::UID::callback{'FS::svc_acct'} = sub {
  49   $conf = new FS::Conf;
  50   $dir_prefix = $conf->config('home');
  51   @shells = $conf->config('shells');
  52   $usernamemin = $conf->config('usernamemin') || 2;
  53   $usernamemax = $conf->config('usernamemax');
  54   $passwordmin = $conf->config('passwordmin') || 6;
  55   $passwordmax = $conf->config('passwordmax') || 8;
  56   $username_letter = $conf->exists('username-letter');
  57   $username_letterfirst = $conf->exists('username-letterfirst');
  58   $username_noperiod = $conf->exists('username-noperiod');
  59   $username_nounderscore = $conf->exists('username-nounderscore');
  60   $username_nodash = $conf->exists('username-nodash');
  61   $username_uppercase = $conf->exists('username-uppercase');
  62   $username_ampersand = $conf->exists('username-ampersand');
  63   $username_percent = $conf->exists('username-percent');
  64   $password_noampersand = $conf->exists('password-noexclamation');
  65   $password_noexclamation = $conf->exists('password-noexclamation');
  66   $dirhash = $conf->config('dirhash') || 0;
  67   if ( $conf->exists('warning_email') ) {
  68     $warning_template = new Text::Template (
  69       TYPE   => 'ARRAY',
  70       SOURCE => [ map "$_\n", $conf->config('warning_email') ]
  71     ) or warn "can't create warning email template: $Text::Template::ERROR";
  72     $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
  73     $warning_subject = $conf->config('warning_email-subject') || 'Warning';
  74     $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
  75     $warning_cc = $conf->config('warning_email-cc');
  76   } else {
  77     $warning_template = '';
  78     $warning_from = '';
  79     $warning_subject = '';
  80     $warning_mimetype = '';
  81     $warning_cc = '';
  82   }
  83   $smtpmachine = $conf->config('smtpmachine');
  84   $radius_password = $conf->config('radius-password') || 'Password';
  85   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  86 };
  87
  88 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  89 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  90
  91 sub _cache {
  92   my $self = shift;
  93   my ( $hashref, $cache ) = @_;
  94   if ( $hashref->{'svc_acct_svcnum'} ) {
  95     $self->{'_domsvc'} = FS::svc_domain->new( {
  96       'svcnum'   => $hashref->{'domsvc'},
  97       'domain'   => $hashref->{'svc_acct_domain'},
  98       'catchall' => $hashref->{'svc_acct_catchall'},
  99     } );
 100   }
 101 }
 102
 103 =head1 NAME
 104
 105 FS::svc_acct - Object methods for svc_acct records
 106
 107 =head1 SYNOPSIS
 108
 109   use FS::svc_acct;
 110
 111   $record = new FS::svc_acct \%hash;
 112   $record = new FS::svc_acct { 'column' => 'value' };
 113
 114   $error = $record->insert;
 115
 116   $error = $new_record->replace($old_record);
 117
 118   $error = $record->delete;
 119
 120   $error = $record->check;
 121
 122   $error = $record->suspend;
 123
 124   $error = $record->unsuspend;
 125
 126   $error = $record->cancel;
 127
 128   %hash = $record->radius;
 129
 130   %hash = $record->radius_reply;
 131
 132   %hash = $record->radius_check;
 133
 134   $domain = $record->domain;
 135
 136   $svc_domain = $record->svc_domain;
 137
 138   $email = $record->email;
 139
 140   $seconds_since = $record->seconds_since($timestamp);
 141
 142 =head1 DESCRIPTION
 143
 144 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 145 FS::svc_Common.  The following fields are currently supported:
 146
 147 =over 4
 148
 149 =item svcnum - primary key (assigned automatcially for new accounts)
 150
 151 =item username
 152
 153 =item _password - generated if blank
 154
 155 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
 156
 157 =item sec_phrase - security phrase
 158
 159 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 160
 161 =item uid
 162
 163 =item gid
 164
 165 =item finger - GECOS
 166
 167 =item dir - set automatically if blank (and uid is not)
 168
 169 =item shell
 170
 171 =item quota - (unimplementd)
 172
 173 =item slipip - IP address
 174
 175 =item seconds -
 176
 177 =item upbytes -
 178
 179 =item downbytes -
 180
 181 =item totalbytes -
 182
 183 =item domsvc - svcnum from svc_domain
 184
 185 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
 186
 187 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
 188
 189 =back
 190
 191 =head1 METHODS
 192
 193 =over 4
 194
 195 =item new HASHREF
 196
 197 Creates a new account.  To add the account to the database, see L<"insert">.
 198
 199 =cut
 200
 201 sub table_info {
 202   {
 203     'name'   => 'Account',
 204     'longname_plural' => 'Access accounts and mailboxes',
 205     'sorts' => [ 'username', 'uid', ],
 206     'display_weight' => 10,
 207     'cancel_weight'  => 50,
 208     'fields' => {
 209         'dir'       => 'Home directory',
 210         'uid'       => {
 211                          label     => 'UID',
 212                          def_label => 'UID (set to fixed and blank for no UIDs)',
 213                          type      => 'text',
 214                        },
 215         'slipip'    => 'IP address',
 216     #    'popnum'    => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
 217         'popnum'    => {
 218                          label => 'Access number',
 219                          type => 'select',
 220                          select_table => 'svc_acct_pop',
 221                          select_key   => 'popnum',
 222                          select_label => 'city',
 223                          disable_select => 1,
 224                        },
 225         'username'  => {
 226                          label => 'Username',
 227                          type => 'text',
 228                          disable_default => 1,
 229                          disable_fixed => 1,
 230                          disable_select => 1,
 231                        },
 232         'quota'     => {
 233                          label => 'Quota',
 234                          type => 'text',
 235                          disable_inventory => 1,
 236                          disable_select => 1,
 237                        },
 238         '_password' => 'Password',
 239         'gid'       => {
 240                          label     => 'GID',
 241                          def_label => 'GID (when blank, defaults to UID)',
 242                          type      => 'text',
 243                        },
 244         'shell'     => {
 245                          #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
 246                          label    => 'Shell',
 247                          def_label=> 'Shell (set to blank for no shell tracking)',
 248                          type     =>'select',
 249                          select_list => [ $conf->config('shells') ],
 250                          disable_inventory => 1,
 251                          disable_select => 1,
 252                        },
 253         'finger'    => 'Real name (GECOS)',
 254         'domsvc'    => {
 255                          label     => 'Domain',
 256                          #def_label => 'svcnum from svc_domain',
 257                          type      => 'select',
 258                          select_table => 'svc_domain',
 259                          select_key   => 'svcnum',
 260                          select_label => 'domain',
 261                          disable_inventory => 1,
 262
 263                        },
 264         'usergroup' => {
 265                          label => 'RADIUS groups',
 266                          type  => 'radius_usergroup_selector',
 267                          disable_inventory => 1,
 268                          disable_select => 1,
 269                        },
 270         'seconds'   => { label => 'Seconds',
 271                          type  => 'text',
 272                          disable_inventory => 1,
 273                          disable_select => 1,
 274                        },
 275     },
 276   };
 277 }
 278
 279 sub table { 'svc_acct'; }
 280
 281 sub _fieldhandlers {
 282   {
 283     #false laziness with edit/svc_acct.cgi
 284     'usergroup' => sub {
 285                          my( $self, $groups ) = @_;
 286                          if ( ref($groups) eq 'ARRAY' ) {
 287                            $groups;
 288                          } elsif ( length($groups) ) {
 289                            [ split(/\s*,\s*/, $groups) ];
 290                          } else {
 291                            [];
 292                          }
 293                        },
 294   };
 295 }
 296
 297 =item search_sql STRING
 298
 299 Class method which returns an SQL fragment to search for the given string.
 300
 301 =cut
 302
 303 sub search_sql {
 304   my( $class, $string ) = @_;
 305   if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
 306     my( $username, $domain ) = ( $1, $2 );
 307     my $q_username = dbh->quote($username);
 308     my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
 309     if ( @svc_domain ) {
 310       "svc_acct.username = $q_username AND ( ".
 311         join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
 312       " )";
 313     } else {
 314       '1 = 0'; #false
 315     }
 316   } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
 317     ' ( '.
 318       $class->search_sql_field('slipip',   $string ).
 319     ' OR '.
 320       $class->search_sql_field('username', $string ).
 321     ' ) ';
 322   } else {
 323     $class->search_sql_field('username', $string);
 324   }
 325 }
 326
 327 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 328
 329 Returns the "username@domain" string for this account.
 330
 331 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 332 history records.
 333
 334 =cut
 335
 336 sub label {
 337   my $self = shift;
 338   $self->email(@_);
 339 }
 340
 341 =cut
 342
 343 =item insert [ , OPTION => VALUE ... ]
 344
 345 Adds this account to the database.  If there is an error, returns the error,
 346 otherwise returns false.
 347
 348 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 349 defined.  An FS::cust_svc record will be created and inserted.
 350
 351 The additional field I<usergroup> can optionally be defined; if so it should
 352 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 353
 354 The additional field I<child_objects> can optionally be defined; if so it
 355 should contain an arrayref of FS::tablename objects.  They will have their
 356 svcnum fields set and will be inserted after this record, but before any
 357 exports are run.  Each element of the array can also optionally be a
 358 two-element array reference containing the child object and the name of an
 359 alternate field to be filled in with the newly-inserted svcnum, for example
 360 C<[ $svc_forward, 'srcsvc' ]>
 361
 362 Currently available options are: I<depend_jobnum>
 363
 364 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 365 jobnums), all provisioning jobs will have a dependancy on the supplied
 366 jobnum(s) (they will not run until the specific job(s) complete(s)).
 367
 368 (TODOC: L<FS::queue> and L<freeside-queued>)
 369
 370 (TODOC: new exports!)
 371
 372 =cut
 373
 374 sub insert {
 375   my $self = shift;
 376   my %options = @_;
 377
 378   if ( $DEBUG ) {
 379     warn "[$me] insert called on $self: ". Dumper($self).
 380          "\nwith options: ". Dumper(%options);
 381   }
 382
 383   local $SIG{HUP} = 'IGNORE';
 384   local $SIG{INT} = 'IGNORE';
 385   local $SIG{QUIT} = 'IGNORE';
 386   local $SIG{TERM} = 'IGNORE';
 387   local $SIG{TSTP} = 'IGNORE';
 388   local $SIG{PIPE} = 'IGNORE';
 389
 390   my $oldAutoCommit = $FS::UID::AutoCommit;
 391   local $FS::UID::AutoCommit = 0;
 392   my $dbh = dbh;
 393
 394   my $error = $self->check;
 395   return $error if $error;
 396
 397   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 398     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 399     unless ( $cust_svc ) {
 400       $dbh->rollback if $oldAutoCommit;
 401       return "no cust_svc record found for svcnum ". $self->svcnum;
 402     }
 403     $self->pkgnum($cust_svc->pkgnum);
 404     $self->svcpart($cust_svc->svcpart);
 405   }
 406
 407   $error = $self->_check_duplicate;
 408   if ( $error ) {
 409     $dbh->rollback if $oldAutoCommit;
 410     return $error;
 411   }
 412
 413   my @jobnums;
 414   $error = $self->SUPER::insert(
 415     'jobnums'       => \@jobnums,
 416     'child_objects' => $self->child_objects,
 417     %options,
 418   );
 419   if ( $error ) {
 420     $dbh->rollback if $oldAutoCommit;
 421     return $error;
 422   }
 423
 424   if ( $self->usergroup ) {
 425     foreach my $groupname ( @{$self->usergroup} ) {
 426       my $radius_usergroup = new FS::radius_usergroup ( {
 427         svcnum    => $self->svcnum,
 428         groupname => $groupname,
 429       } );
 430       my $error = $radius_usergroup->insert;
 431       if ( $error ) {
 432         $dbh->rollback if $oldAutoCommit;
 433         return $error;
 434       }
 435     }
 436   }
 437
 438   unless ( $skip_fuzzyfiles ) {
 439     $error = $self->queue_fuzzyfiles_update;
 440     if ( $error ) {
 441       $dbh->rollback if $oldAutoCommit;
 442       return "updating fuzzy search cache: $error";
 443     }
 444   }
 445
 446   my $cust_pkg = $self->cust_svc->cust_pkg;
 447
 448   if ( $cust_pkg ) {
 449     my $cust_main = $cust_pkg->cust_main;
 450     my $agentnum = $cust_main->agentnum;
 451
 452     if (   $conf->exists('emailinvoiceautoalways')
 453         || $conf->exists('emailinvoiceauto')
 454         && ! $cust_main->invoicing_list_emailonly
 455        ) {
 456       my @invoicing_list = $cust_main->invoicing_list;
 457       push @invoicing_list, $self->email;
 458       $cust_main->invoicing_list(\@invoicing_list);
 459     }
 460
 461     #welcome email
 462     my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
 463       = ('','','','','','');
 464
 465     if ( $conf->exists('welcome_email', $agentnum) ) {
 466       $welcome_template = new Text::Template (
 467         TYPE   => 'ARRAY',
 468         SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
 469       ) or warn "can't create welcome email template: $Text::Template::ERROR";
 470       $welcome_from = $conf->config('welcome_email-from', $agentnum);
 471         # || 'your-isp-is-dum'
 472       $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
 473         || 'Welcome';
 474       $welcome_subject_template = new Text::Template (
 475         TYPE   => 'STRING',
 476         SOURCE => $welcome_subject,
 477       ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
 478       $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
 479         || 'text/plain';
 480     }
 481     if ( $welcome_template && $cust_pkg ) {
 482       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 483       if ( $to ) {
 484
 485         my %hash = (
 486                      'custnum'  => $self->custnum,
 487                      'username' => $self->username,
 488                      'password' => $self->_password,
 489                      'first'    => $cust_main->first,
 490                      'last'     => $cust_main->getfield('last'),
 491                      'pkg'      => $cust_pkg->part_pkg->pkg,
 492                    );
 493         my $wqueue = new FS::queue {
 494           'svcnum' => $self->svcnum,
 495           'job'    => 'FS::svc_acct::send_email'
 496         };
 497         my $error = $wqueue->insert(
 498           'to'       => $to,
 499           'from'     => $welcome_from,
 500           'subject'  => $welcome_subject_template->fill_in( HASH => \%hash, ),
 501           'mimetype' => $welcome_mimetype,
 502           'body'     => $welcome_template->fill_in( HASH => \%hash, ),
 503         );
 504         if ( $error ) {
 505           $dbh->rollback if $oldAutoCommit;
 506           return "error queuing welcome email: $error";
 507         }
 508
 509         if ( $options{'depend_jobnum'} ) {
 510           warn "$me depend_jobnum found; adding to welcome email dependancies"
 511             if $DEBUG;
 512           if ( ref($options{'depend_jobnum'}) ) {
 513             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 514                  "to welcome email dependancies"
 515               if $DEBUG;
 516             push @jobnums, @{ $options{'depend_jobnum'} };
 517           } else {
 518             warn "$me adding job $options{'depend_jobnum'} ".
 519                  "to welcome email dependancies"
 520               if $DEBUG;
 521             push @jobnums, $options{'depend_jobnum'};
 522           }
 523         }
 524
 525         foreach my $jobnum ( @jobnums ) {
 526           my $error = $wqueue->depend_insert($jobnum);
 527           if ( $error ) {
 528             $dbh->rollback if $oldAutoCommit;
 529             return "error queuing welcome email job dependancy: $error";
 530           }
 531         }
 532
 533       }
 534
 535     }
 536
 537   } # if ( $cust_pkg )
 538
 539   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 540   ''; #no error
 541 }
 542
 543 =item delete
 544
 545 Deletes this account from the database.  If there is an error, returns the
 546 error, otherwise returns false.
 547
 548 The corresponding FS::cust_svc record will be deleted as well.
 549
 550 (TODOC: new exports!)
 551
 552 =cut
 553
 554 sub delete {
 555   my $self = shift;
 556
 557   return "can't delete system account" if $self->_check_system;
 558
 559   return "Can't delete an account which is a (svc_forward) source!"
 560     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 561
 562   return "Can't delete an account which is a (svc_forward) destination!"
 563     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 564
 565   return "Can't delete an account with (svc_www) web service!"
 566     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 567
 568   # what about records in session ? (they should refer to history table)
 569
 570   local $SIG{HUP} = 'IGNORE';
 571   local $SIG{INT} = 'IGNORE';
 572   local $SIG{QUIT} = 'IGNORE';
 573   local $SIG{TERM} = 'IGNORE';
 574   local $SIG{TSTP} = 'IGNORE';
 575   local $SIG{PIPE} = 'IGNORE';
 576
 577   my $oldAutoCommit = $FS::UID::AutoCommit;
 578   local $FS::UID::AutoCommit = 0;
 579   my $dbh = dbh;
 580
 581   foreach my $cust_main_invoice (
 582     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 583   ) {
 584     unless ( defined($cust_main_invoice) ) {
 585       warn "WARNING: something's wrong with qsearch";
 586       next;
 587     }
 588     my %hash = $cust_main_invoice->hash;
 589     $hash{'dest'} = $self->email;
 590     my $new = new FS::cust_main_invoice \%hash;
 591     my $error = $new->replace($cust_main_invoice);
 592     if ( $error ) {
 593       $dbh->rollback if $oldAutoCommit;
 594       return $error;
 595     }
 596   }
 597
 598   foreach my $svc_domain (
 599     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 600   ) {
 601     my %hash = new FS::svc_domain->hash;
 602     $hash{'catchall'} = '';
 603     my $new = new FS::svc_domain \%hash;
 604     my $error = $new->replace($svc_domain);
 605     if ( $error ) {
 606       $dbh->rollback if $oldAutoCommit;
 607       return $error;
 608     }
 609   }
 610
 611   foreach my $radius_usergroup (
 612     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 613   ) {
 614     my $error = $radius_usergroup->delete;
 615     if ( $error ) {
 616       $dbh->rollback if $oldAutoCommit;
 617       return $error;
 618     }
 619   }
 620
 621   my $error = $self->SUPER::delete;
 622   if ( $error ) {
 623     $dbh->rollback if $oldAutoCommit;
 624     return $error;
 625   }
 626
 627   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 628   '';
 629 }
 630
 631 =item replace OLD_RECORD
 632
 633 Replaces OLD_RECORD with this one in the database.  If there is an error,
 634 returns the error, otherwise returns false.
 635
 636 The additional field I<usergroup> can optionally be defined; if so it should
 637 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 638
 639
 640 =cut
 641
 642 sub replace {
 643   my ( $new, $old ) = ( shift, shift );
 644   my $error;
 645   warn "$me replacing $old with $new\n" if $DEBUG;
 646
 647   # We absolutely have to have an old vs. new record to make this work.
 648   if (!defined($old)) {
 649     $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
 650   }
 651
 652   return "can't modify system account" if $old->_check_system;
 653
 654   {
 655     #no warnings 'numeric';  #alas, a 5.006-ism
 656     local($^W) = 0;
 657
 658     foreach my $xid (qw( uid gid )) {
 659
 660       return "Can't change $xid!"
 661         if ! $conf->exists("svc_acct-edit_$xid")
 662            && $old->$xid() != $new->$xid()
 663            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 664     }
 665
 666   }
 667
 668   #change homdir when we change username
 669   $new->setfield('dir', '') if $old->username ne $new->username;
 670
 671   local $SIG{HUP} = 'IGNORE';
 672   local $SIG{INT} = 'IGNORE';
 673   local $SIG{QUIT} = 'IGNORE';
 674   local $SIG{TERM} = 'IGNORE';
 675   local $SIG{TSTP} = 'IGNORE';
 676   local $SIG{PIPE} = 'IGNORE';
 677
 678   my $oldAutoCommit = $FS::UID::AutoCommit;
 679   local $FS::UID::AutoCommit = 0;
 680   my $dbh = dbh;
 681
 682   # redundant, but so $new->usergroup gets set
 683   $error = $new->check;
 684   return $error if $error;
 685
 686   $old->usergroup( [ $old->radius_groups ] );
 687   if ( $DEBUG ) {
 688     warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
 689     warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
 690   }
 691   if ( $new->usergroup ) {
 692     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 693     my @newgroups = @{$new->usergroup};
 694     foreach my $oldgroup ( @{$old->usergroup} ) {
 695       if ( grep { $oldgroup eq $_ } @newgroups ) {
 696         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 697         next;
 698       }
 699       my $radius_usergroup = qsearchs('radius_usergroup', {
 700         svcnum    => $old->svcnum,
 701         groupname => $oldgroup,
 702       } );
 703       my $error = $radius_usergroup->delete;
 704       if ( $error ) {
 705         $dbh->rollback if $oldAutoCommit;
 706         return "error deleting radius_usergroup $oldgroup: $error";
 707       }
 708     }
 709
 710     foreach my $newgroup ( @newgroups ) {
 711       my $radius_usergroup = new FS::radius_usergroup ( {
 712         svcnum    => $new->svcnum,
 713         groupname => $newgroup,
 714       } );
 715       my $error = $radius_usergroup->insert;
 716       if ( $error ) {
 717         $dbh->rollback if $oldAutoCommit;
 718         return "error adding radius_usergroup $newgroup: $error";
 719       }
 720     }
 721
 722   }
 723
 724   if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
 725     $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
 726     $error = $new->_check_duplicate;
 727     if ( $error ) {
 728       $dbh->rollback if $oldAutoCommit;
 729       return $error;
 730     }
 731   }
 732
 733   $error = $new->SUPER::replace($old);
 734   if ( $error ) {
 735     $dbh->rollback if $oldAutoCommit;
 736     return $error if $error;
 737   }
 738
 739   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 740     $error = $new->queue_fuzzyfiles_update;
 741     if ( $error ) {
 742       $dbh->rollback if $oldAutoCommit;
 743       return "updating fuzzy search cache: $error";
 744     }
 745   }
 746
 747   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 748   ''; #no error
 749 }
 750
 751 =item queue_fuzzyfiles_update
 752
 753 Used by insert & replace to update the fuzzy search cache
 754
 755 =cut
 756
 757 sub queue_fuzzyfiles_update {
 758   my $self = shift;
 759
 760   local $SIG{HUP} = 'IGNORE';
 761   local $SIG{INT} = 'IGNORE';
 762   local $SIG{QUIT} = 'IGNORE';
 763   local $SIG{TERM} = 'IGNORE';
 764   local $SIG{TSTP} = 'IGNORE';
 765   local $SIG{PIPE} = 'IGNORE';
 766
 767   my $oldAutoCommit = $FS::UID::AutoCommit;
 768   local $FS::UID::AutoCommit = 0;
 769   my $dbh = dbh;
 770
 771   my $queue = new FS::queue {
 772     'svcnum' => $self->svcnum,
 773     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 774   };
 775   my $error = $queue->insert($self->username);
 776   if ( $error ) {
 777     $dbh->rollback if $oldAutoCommit;
 778     return "queueing job (transaction rolled back): $error";
 779   }
 780
 781   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 782   '';
 783
 784 }
 785
 786
 787 =item suspend
 788
 789 Suspends this account by calling export-specific suspend hooks.  If there is
 790 an error, returns the error, otherwise returns false.
 791
 792 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 793
 794 =cut
 795
 796 sub suspend {
 797   my $self = shift;
 798   return "can't suspend system account" if $self->_check_system;
 799   $self->SUPER::suspend;
 800 }
 801
 802 =item unsuspend
 803
 804 Unsuspends this account by by calling export-specific suspend hooks.  If there
 805 is an error, returns the error, otherwise returns false.
 806
 807 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 808
 809 =cut
 810
 811 sub unsuspend {
 812   my $self = shift;
 813   my %hash = $self->hash;
 814   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 815     $hash{_password} = $1;
 816     my $new = new FS::svc_acct ( \%hash );
 817     my $error = $new->replace($self);
 818     return $error if $error;
 819   }
 820
 821   $self->SUPER::unsuspend;
 822 }
 823
 824 =item cancel
 825
 826 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 827
 828 If the B<auto_unset_catchall> configuration option is set, this method will
 829 automatically remove any references to the canceled service in the catchall
 830 field of svc_domain.  This allows packages that contain both a svc_domain and
 831 its catchall svc_acct to be canceled in one step.
 832
 833 =cut
 834
 835 sub cancel {
 836   # Only one thing to do at this level
 837   my $self = shift;
 838   foreach my $svc_domain (
 839       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 840     if($conf->exists('auto_unset_catchall')) {
 841       my %hash = $svc_domain->hash;
 842       $hash{catchall} = '';
 843       my $new = new FS::svc_domain ( \%hash );
 844       my $error = $new->replace($svc_domain);
 845       return $error if $error;
 846     } else {
 847       return "cannot unprovision svc_acct #".$self->svcnum.
 848           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 849     }
 850   }
 851
 852   $self->SUPER::cancel;
 853 }
 854
 855
 856 =item check
 857
 858 Checks all fields to make sure this is a valid service.  If there is an error,
 859 returns the error, otherwise returns false.  Called by the insert and replace
 860 methods.
 861
 862 Sets any fixed values; see L<FS::part_svc>.
 863
 864 =cut
 865
 866 sub check {
 867   my $self = shift;
 868
 869   my($recref) = $self->hashref;
 870
 871   my $x = $self->setfixed( $self->_fieldhandlers );
 872   return $x unless ref($x);
 873   my $part_svc = $x;
 874
 875   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 876     $self->usergroup(
 877       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 878   }
 879
 880   my $error = $self->ut_numbern('svcnum')
 881               #|| $self->ut_number('domsvc')
 882               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 883               || $self->ut_textn('sec_phrase')
 884               || $self->ut_snumbern('seconds')
 885               || $self->ut_snumbern('upbytes')
 886               || $self->ut_snumbern('downbytes')
 887               || $self->ut_snumbern('totalbytes')
 888               || $self->ut_enum( '_password_encoding',
 889                                  [ '', qw( plain crypt ldap ) ]
 890                                )
 891   ;
 892   return $error if $error;
 893
 894   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 895   if ( $username_uppercase ) {
 896     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
 897       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 898     $recref->{username} = $1;
 899   } else {
 900     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
 901       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 902     $recref->{username} = $1;
 903   }
 904
 905   if ( $username_letterfirst ) {
 906     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 907   } elsif ( $username_letter ) {
 908     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 909   }
 910   if ( $username_noperiod ) {
 911     $recref->{username} =~ /\./ and return gettext('illegal_username');
 912   }
 913   if ( $username_nounderscore ) {
 914     $recref->{username} =~ /_/ and return gettext('illegal_username');
 915   }
 916   if ( $username_nodash ) {
 917     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 918   }
 919   unless ( $username_ampersand ) {
 920     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 921   }
 922   unless ( $username_percent ) {
 923     $recref->{username} =~ /\%/ and return gettext('illegal_username');
 924   }
 925
 926   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 927   $recref->{popnum} = $1;
 928   return "Unknown popnum" unless
 929     ! $recref->{popnum} ||
 930     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 931
 932   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 933
 934     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 935     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 936
 937     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 938     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 939     #not all systems use gid=uid
 940     #you can set a fixed gid in part_svc
 941
 942     return "Only root can have uid 0"
 943       if $recref->{uid} == 0
 944          && $recref->{username} !~ /^(root|toor|smtp)$/;
 945
 946     unless ( $recref->{username} eq 'sync' ) {
 947       if ( grep $_ eq $recref->{shell}, @shells ) {
 948         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 949       } else {
 950         return "Illegal shell \`". $self->shell. "\'; ".
 951                "shells configuration value contains: @shells";
 952       }
 953     } else {
 954       $recref->{shell} = '/bin/sync';
 955     }
 956
 957   } else {
 958     $recref->{gid} ne '' ?
 959       return "Can't have gid without uid" : ( $recref->{gid}='' );
 960     #$recref->{dir} ne '' ?
 961     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
 962     $recref->{shell} ne '' ?
 963       return "Can't have shell without uid" : ( $recref->{shell}='' );
 964   }
 965
 966   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
 967
 968     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 969       or return "Illegal directory: ". $recref->{dir};
 970     $recref->{dir} = $1;
 971     return "Illegal directory"
 972       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 973     return "Illegal directory"
 974       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 975     unless ( $recref->{dir} ) {
 976       $recref->{dir} = $dir_prefix . '/';
 977       if ( $dirhash > 0 ) {
 978         for my $h ( 1 .. $dirhash ) {
 979           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 980         }
 981       } elsif ( $dirhash < 0 ) {
 982         for my $h ( reverse $dirhash .. -1 ) {
 983           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 984         }
 985       }
 986       $recref->{dir} .= $recref->{username};
 987     ;
 988     }
 989
 990   }
 991
 992   #  $error = $self->ut_textn('finger');
 993   #  return $error if $error;
 994   if ( $self->getfield('finger') eq '' ) {
 995     my $cust_pkg = $self->svcnum
 996       ? $self->cust_svc->cust_pkg
 997       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
 998     if ( $cust_pkg ) {
 999       my $cust_main = $cust_pkg->cust_main;
1000       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1001     }
1002   }
1003   $self->getfield('finger') =~
1004     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1005       or return "Illegal finger: ". $self->getfield('finger');
1006   $self->setfield('finger', $1);
1007
1008   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1009   $recref->{quota} = $1;
1010
1011   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1012     if ( $recref->{slipip} eq '' ) {
1013       $recref->{slipip} = '';
1014     } elsif ( $recref->{slipip} eq '0e0' ) {
1015       $recref->{slipip} = '0e0';
1016     } else {
1017       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1018         or return "Illegal slipip: ". $self->slipip;
1019       $recref->{slipip} = $1;
1020     }
1021
1022   }
1023
1024   #arbitrary RADIUS stuff; allow ut_textn for now
1025   foreach ( grep /^radius_/, fields('svc_acct') ) {
1026     $self->ut_textn($_);
1027   }
1028
1029   if ( $recref->{_password_encoding} eq 'ldap' ) {
1030
1031     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1032       $recref->{_password} = uc($1).$2;
1033     } else {
1034       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1035     }
1036
1037   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1038
1039     if ( $recref->{_password} =~
1040            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1041            /^(!!?)?(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1042        ) {
1043
1044       $recref->{_password} = $1.$2;
1045
1046     } else {
1047       return 'Illegal (crypt-encoded) password';
1048     }
1049
1050   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1051
1052     #generate a password if it is blank
1053     $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1054       unless length( $recref->{_password} );
1055
1056     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1057       $recref->{_password} = $1;
1058     } else {
1059       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1060              FS::Msgcat::_gettext('illegal_password_characters').
1061              ": ". $recref->{_password};
1062     }
1063
1064     if ( $password_noampersand ) {
1065       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1066     }
1067     if ( $password_noexclamation ) {
1068       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1069     }
1070
1071   } else {
1072
1073     #carp "warning: _password_encoding unspecified\n";
1074
1075     #generate a password if it is blank
1076     unless ( length( $recref->{_password} ) ) {
1077
1078       $recref->{_password} =
1079         join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1080       $recref->{_password_encoding} = 'plain';
1081
1082     } else {
1083
1084       #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1085       if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1086         $recref->{_password} = $1.$3;
1087         $recref->{_password_encoding} = 'plain';
1088       } elsif ( $recref->{_password} =~
1089                   /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1090               ) {
1091         $recref->{_password} = $1.$3;
1092         $recref->{_password_encoding} = 'crypt';
1093       } elsif ( $recref->{_password} eq '*' ) {
1094         $recref->{_password} = '*';
1095         $recref->{_password_encoding} = 'crypt';
1096       } elsif ( $recref->{_password} eq '!' ) {
1097         $recref->{_password_encoding} = 'crypt';
1098         $recref->{_password} = '!';
1099       } elsif ( $recref->{_password} eq '!!' ) {
1100         $recref->{_password} = '!!';
1101         $recref->{_password_encoding} = 'crypt';
1102       } else {
1103         #return "Illegal password";
1104         return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1105                FS::Msgcat::_gettext('illegal_password_characters').
1106                ": ". $recref->{_password};
1107       }
1108
1109     }
1110
1111   }
1112
1113   $self->SUPER::check;
1114
1115 }
1116
1117 =item _check_system
1118
1119 Internal function to check the username against the list of system usernames
1120 from the I<system_usernames> configuration value.  Returns true if the username
1121 is listed on the system username list.
1122
1123 =cut
1124
1125 sub _check_system {
1126   my $self = shift;
1127   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1128                $conf->config('system_usernames')
1129         );
1130 }
1131
1132 =item _check_duplicate
1133
1134 Internal function to check for duplicates usernames, username@domain pairs and
1135 uids.
1136
1137 If the I<global_unique-username> configuration value is set to B<username> or
1138 B<username@domain>, enforces global username or username@domain uniqueness.
1139
1140 In all cases, check for duplicate uids and usernames or username@domain pairs
1141 per export and with identical I<svcpart> values.
1142
1143 =cut
1144
1145 sub _check_duplicate {
1146   my $self = shift;
1147
1148   my $global_unique = $conf->config('global_unique-username') || 'none';
1149   return '' if $global_unique eq 'disabled';
1150
1151   #this is Pg-specific.  what to do for mysql etc?
1152   # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
1153   warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1154   dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1155     or die dbh->errstr;
1156   warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1157
1158   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1159   unless ( $part_svc ) {
1160     return 'unknown svcpart '. $self->svcpart;
1161   }
1162
1163   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1164                  qsearch( 'svc_acct', { 'username' => $self->username } );
1165   return gettext('username_in_use')
1166     if $global_unique eq 'username' && @dup_user;
1167
1168   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1169                        qsearch( 'svc_acct', { 'username' => $self->username,
1170                                               'domsvc'   => $self->domsvc } );
1171   return gettext('username_in_use')
1172     if $global_unique eq 'username@domain' && @dup_userdomain;
1173
1174   my @dup_uid;
1175   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1176        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1177     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1178                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1179   } else {
1180     @dup_uid = ();
1181   }
1182
1183   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1184     my $exports = FS::part_export::export_info('svc_acct');
1185     my %conflict_user_svcpart;
1186     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1187
1188     foreach my $part_export ( $part_svc->part_export ) {
1189
1190       #this will catch to the same exact export
1191       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1192
1193       #this will catch to exports w/same exporthost+type ???
1194       #my @other_part_export = qsearch('part_export', {
1195       #  'machine'    => $part_export->machine,
1196       #  'exporttype' => $part_export->exporttype,
1197       #} );
1198       #foreach my $other_part_export ( @other_part_export ) {
1199       #  push @svcparts, map { $_->svcpart }
1200       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1201       #}
1202
1203       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1204       #silly kludge to avoid uninitialized value errors
1205       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1206                      ? $exports->{$part_export->exporttype}{'nodomain'}
1207                      : '';
1208       if ( $nodomain =~ /^Y/i ) {
1209         $conflict_user_svcpart{$_} = $part_export->exportnum
1210           foreach @svcparts;
1211       } else {
1212         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1213           foreach @svcparts;
1214       }
1215     }
1216
1217     foreach my $dup_user ( @dup_user ) {
1218       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1219       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1220         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1221                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1222       }
1223     }
1224
1225     foreach my $dup_userdomain ( @dup_userdomain ) {
1226       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1227       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1228         return "duplicate username\@domain: conflicts with svcnum ".
1229                $dup_userdomain->svcnum. " via exportnum ".
1230                $conflict_userdomain_svcpart{$dup_svcpart};
1231       }
1232     }
1233
1234     foreach my $dup_uid ( @dup_uid ) {
1235       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1236       if ( exists($conflict_user_svcpart{$dup_svcpart})
1237            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1238         return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1239                " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1240                                  || $conflict_userdomain_svcpart{$dup_svcpart};
1241       }
1242     }
1243
1244   }
1245
1246   return '';
1247
1248 }
1249
1250 =item radius
1251
1252 Depriciated, use radius_reply instead.
1253
1254 =cut
1255
1256 sub radius {
1257   carp "FS::svc_acct::radius depriciated, use radius_reply";
1258   $_[0]->radius_reply;
1259 }
1260
1261 =item radius_reply
1262
1263 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1264 reply attributes of this record.
1265
1266 Note that this is now the preferred method for reading RADIUS attributes -
1267 accessing the columns directly is discouraged, as the column names are
1268 expected to change in the future.
1269
1270 =cut
1271
1272 sub radius_reply {
1273   my $self = shift;
1274
1275   return %{ $self->{'radius_reply'} }
1276     if exists $self->{'radius_reply'};
1277
1278   my %reply =
1279     map {
1280       /^(radius_(.*))$/;
1281       my($column, $attrib) = ($1, $2);
1282       #$attrib =~ s/_/\-/g;
1283       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1284     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1285
1286   if ( $self->slipip && $self->slipip ne '0e0' ) {
1287     $reply{$radius_ip} = $self->slipip;
1288   }
1289
1290   if ( $self->seconds !~ /^$/ ) {
1291     $reply{'Session-Timeout'} = $self->seconds;
1292   }
1293
1294   %reply;
1295 }
1296
1297 =item radius_check
1298
1299 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1300 check attributes of this record.
1301
1302 Note that this is now the preferred method for reading RADIUS attributes -
1303 accessing the columns directly is discouraged, as the column names are
1304 expected to change in the future.
1305
1306 =cut
1307
1308 sub radius_check {
1309   my $self = shift;
1310
1311   return %{ $self->{'radius_check'} }
1312     if exists $self->{'radius_check'};
1313
1314   my %check =
1315     map {
1316       /^(rc_(.*))$/;
1317       my($column, $attrib) = ($1, $2);
1318       #$attrib =~ s/_/\-/g;
1319       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1320     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1321
1322   my $password = $self->_password;
1323   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';  $check{$pw_attrib} = $password;
1324
1325   my $cust_svc = $self->cust_svc;
1326   die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1327     unless $cust_svc;
1328   my $cust_pkg = $cust_svc->cust_pkg;
1329   if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1330     $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1331   }
1332
1333   %check;
1334
1335 }
1336
1337 =item snapshot
1338
1339 This method instructs the object to "snapshot" or freeze RADIUS check and
1340 reply attributes to the current values.
1341
1342 =cut
1343
1344 #bah, my english is too broken this morning
1345 #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
1346 #the FS::cust_pkg's replace method to trigger the correct export updates when
1347 #package dates change)
1348
1349 sub snapshot {
1350   my $self = shift;
1351
1352   $self->{$_} = { $self->$_() }
1353     foreach qw( radius_reply radius_check );
1354
1355 }
1356
1357 =item forget_snapshot
1358
1359 This methos instructs the object to forget any previously snapshotted
1360 RADIUS check and reply attributes.
1361
1362 =cut
1363
1364 sub forget_snapshot {
1365   my $self = shift;
1366
1367   delete $self->{$_}
1368     foreach qw( radius_reply radius_check );
1369
1370 }
1371
1372 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1373
1374 Returns the domain associated with this account.
1375
1376 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1377 history records.
1378
1379 =cut
1380
1381 sub domain {
1382   my $self = shift;
1383   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1384   my $svc_domain = $self->svc_domain(@_)
1385     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1386   $svc_domain->domain;
1387 }
1388
1389 =item svc_domain
1390
1391 Returns the FS::svc_domain record for this account's domain (see
1392 L<FS::svc_domain>).
1393
1394 =cut
1395
1396 # FS::h_svc_acct has a history-aware svc_domain override
1397
1398 sub svc_domain {
1399   my $self = shift;
1400   $self->{'_domsvc'}
1401     ? $self->{'_domsvc'}
1402     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1403 }
1404
1405 =item cust_svc
1406
1407 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1408
1409 =cut
1410
1411 #inherited from svc_Common
1412
1413 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1414
1415 Returns an email address associated with the account.
1416
1417 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1418 history records.
1419
1420 =cut
1421
1422 sub email {
1423   my $self = shift;
1424   $self->username. '@'. $self->domain(@_);
1425 }
1426
1427 =item acct_snarf
1428
1429 Returns an array of FS::acct_snarf records associated with the account.
1430 If the acct_snarf table does not exist or there are no associated records,
1431 an empty list is returned
1432
1433 =cut
1434
1435 sub acct_snarf {
1436   my $self = shift;
1437   return () unless dbdef->table('acct_snarf');
1438   eval "use FS::acct_snarf;";
1439   die $@ if $@;
1440   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1441 }
1442
1443 =item decrement_upbytes OCTETS
1444
1445 Decrements the I<upbytes> field of this record by the given amount.  If there
1446 is an error, returns the error, otherwise returns false.
1447
1448 =cut
1449
1450 sub decrement_upbytes {
1451   shift->_op_usage('-', 'upbytes', @_);
1452 }
1453
1454 =item increment_upbytes OCTETS
1455
1456 Increments the I<upbytes> field of this record by the given amount.  If there
1457 is an error, returns the error, otherwise returns false.
1458
1459 =cut
1460
1461 sub increment_upbytes {
1462   shift->_op_usage('+', 'upbytes', @_);
1463 }
1464
1465 =item decrement_downbytes OCTETS
1466
1467 Decrements the I<downbytes> field of this record by the given amount.  If there
1468 is an error, returns the error, otherwise returns false.
1469
1470 =cut
1471
1472 sub decrement_downbytes {
1473   shift->_op_usage('-', 'downbytes', @_);
1474 }
1475
1476 =item increment_downbytes OCTETS
1477
1478 Increments the I<downbytes> field of this record by the given amount.  If there
1479 is an error, returns the error, otherwise returns false.
1480
1481 =cut
1482
1483 sub increment_downbytes {
1484   shift->_op_usage('+', 'downbytes', @_);
1485 }
1486
1487 =item decrement_totalbytes OCTETS
1488
1489 Decrements the I<totalbytes> field of this record by the given amount.  If there
1490 is an error, returns the error, otherwise returns false.
1491
1492 =cut
1493
1494 sub decrement_totalbytes {
1495   shift->_op_usage('-', 'totalbytes', @_);
1496 }
1497
1498 =item increment_totalbytes OCTETS
1499
1500 Increments the I<totalbytes> field of this record by the given amount.  If there
1501 is an error, returns the error, otherwise returns false.
1502
1503 =cut
1504
1505 sub increment_totalbytes {
1506   shift->_op_usage('+', 'totalbytes', @_);
1507 }
1508
1509 =item decrement_seconds SECONDS
1510
1511 Decrements the I<seconds> field of this record by the given amount.  If there
1512 is an error, returns the error, otherwise returns false.
1513
1514 =cut
1515
1516 sub decrement_seconds {
1517   shift->_op_usage('-', 'seconds', @_);
1518 }
1519
1520 =item increment_seconds SECONDS
1521
1522 Increments the I<seconds> field of this record by the given amount.  If there
1523 is an error, returns the error, otherwise returns false.
1524
1525 =cut
1526
1527 sub increment_seconds {
1528   shift->_op_usage('+', 'seconds', @_);
1529 }
1530
1531
1532 my %op2action = (
1533   '-' => 'suspend',
1534   '+' => 'unsuspend',
1535 );
1536 my %op2condition = (
1537   '-' => sub { my($self, $column, $amount) = @_;
1538                $self->$column - $amount <= 0;
1539              },
1540   '+' => sub { my($self, $column, $amount) = @_;
1541                $self->$column + $amount > 0;
1542              },
1543 );
1544 my %op2warncondition = (
1545   '-' => sub { my($self, $column, $amount) = @_;
1546                my $threshold = $column . '_threshold';
1547                $self->$column - $amount <= $self->$threshold + 0;
1548              },
1549   '+' => sub { my($self, $column, $amount) = @_;
1550                $self->$column + $amount > 0;
1551              },
1552 );
1553
1554 sub _op_usage {
1555   my( $self, $op, $column, $amount ) = @_;
1556
1557   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1558        ' ('. $self->email. "): $op $amount\n"
1559     if $DEBUG;
1560
1561   return '' unless $amount;
1562
1563   local $SIG{HUP} = 'IGNORE';
1564   local $SIG{INT} = 'IGNORE';
1565   local $SIG{QUIT} = 'IGNORE';
1566   local $SIG{TERM} = 'IGNORE';
1567   local $SIG{TSTP} = 'IGNORE';
1568   local $SIG{PIPE} = 'IGNORE';
1569
1570   my $oldAutoCommit = $FS::UID::AutoCommit;
1571   local $FS::UID::AutoCommit = 0;
1572   my $dbh = dbh;
1573
1574   my $sql = "UPDATE svc_acct SET $column = ".
1575             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1576             " $op ? WHERE svcnum = ?";
1577   warn "$me $sql\n"
1578     if $DEBUG;
1579
1580   my $sth = $dbh->prepare( $sql )
1581     or die "Error preparing $sql: ". $dbh->errstr;
1582   my $rv = $sth->execute($amount, $self->svcnum);
1583   die "Error executing $sql: ". $sth->errstr
1584     unless defined($rv);
1585   die "Can't update $column for svcnum". $self->svcnum
1586     if $rv == 0;
1587
1588   my $action = $op2action{$op};
1589
1590   if ( &{$op2condition{$op}}($self, $column, $amount) ) {
1591     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1592       if ($part_export->option('overlimit_groups')) {
1593         my ($new,$old);
1594         my $other = new FS::svc_acct $self->hashref;
1595         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1596                        ($self, $part_export->option('overlimit_groups'));
1597         $other->usergroup( $groups );
1598         if ($action eq 'suspend'){
1599           $new = $other; $old = $self;
1600         }else{
1601           $new = $self; $old = $other;
1602         }
1603         my $error = $part_export->export_replace($new, $old);
1604         if ( $error ) {
1605           $dbh->rollback if $oldAutoCommit;
1606           return "Error replacing radius groups in export, ${op}: $error";
1607         }
1608       }
1609     }
1610   }
1611
1612   if ( $conf->exists("svc_acct-usage_$action")
1613        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1614     #my $error = $self->$action();
1615     my $error = $self->cust_svc->cust_pkg->$action();
1616     if ( $error ) {
1617       $dbh->rollback if $oldAutoCommit;
1618       return "Error ${action}ing: $error";
1619     }
1620   }
1621
1622   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1623     my $wqueue = new FS::queue {
1624       'svcnum' => $self->svcnum,
1625       'job'    => 'FS::svc_acct::reached_threshold',
1626     };
1627
1628     my $to = '';
1629     if ($op eq '-'){
1630       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1631     }
1632
1633     # x_threshold race
1634     my $error = $wqueue->insert(
1635       'svcnum' => $self->svcnum,
1636       'op'     => $op,
1637       'column' => $column,
1638       'to'     => $to,
1639     );
1640     if ( $error ) {
1641       $dbh->rollback if $oldAutoCommit;
1642       return "Error queuing threshold activity: $error";
1643     }
1644   }
1645
1646   warn "$me update successful; committing\n"
1647     if $DEBUG;
1648   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1649   '';
1650
1651 }
1652
1653 sub set_usage {
1654   my( $self, $valueref ) = @_;
1655
1656   warn "$me set_usage called for svcnum ". $self->svcnum.
1657        ' ('. $self->email. "): ".
1658        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1659     if $DEBUG;
1660
1661   local $SIG{HUP} = 'IGNORE';
1662   local $SIG{INT} = 'IGNORE';
1663   local $SIG{QUIT} = 'IGNORE';
1664   local $SIG{TERM} = 'IGNORE';
1665   local $SIG{TSTP} = 'IGNORE';
1666   local $SIG{PIPE} = 'IGNORE';
1667
1668   local $FS::svc_Common::noexport_hack = 1;
1669   my $oldAutoCommit = $FS::UID::AutoCommit;
1670   local $FS::UID::AutoCommit = 0;
1671   my $dbh = dbh;
1672
1673   my $reset = 0;
1674   my %handyhash = ();
1675   foreach my $field (keys %$valueref){
1676     $reset = 1 if $valueref->{$field};
1677     $self->setfield($field, $valueref->{$field});
1678     $self->setfield( $field.'_threshold',
1679                      int($self->getfield($field)
1680                          * ( $conf->exists('svc_acct-usage_threshold')
1681                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1682                              : 0.20
1683                            )
1684                        )
1685                      );
1686     $handyhash{$field} = $self->getfield($field);
1687     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1688   }
1689   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1690   #die $error if $error;         #services not explicity changed via the UI
1691
1692   my $sql = "UPDATE svc_acct SET " .
1693     join (',', map { "$_ =  ?" } (keys %handyhash) ).
1694     " WHERE svcnum = ?";
1695
1696   warn "$me $sql\n"
1697     if $DEBUG;
1698
1699   if (scalar(keys %handyhash)) {
1700     my $sth = $dbh->prepare( $sql )
1701       or die "Error preparing $sql: ". $dbh->errstr;
1702     my $rv = $sth->execute((grep{$_} values %handyhash), $self->svcnum);
1703     die "Error executing $sql: ". $sth->errstr
1704       unless defined($rv);
1705     die "Can't update usage for svcnum ". $self->svcnum
1706       if $rv == 0;
1707   }
1708
1709   if ( $conf->exists("svc_acct-usage_unsuspend") && $reset ) {
1710     my $error = $self->cust_svc->cust_pkg->unsuspend;
1711     if ( $error ) {
1712       $dbh->rollback if $oldAutoCommit;
1713       return "Error unsuspending: $error";
1714     }
1715   }
1716
1717   warn "$me update successful; committing\n"
1718     if $DEBUG;
1719   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1720   '';
1721
1722 }
1723
1724
1725 =item recharge HASHREF
1726
1727   Increments usage columns by the amount specified in HASHREF as
1728   column=>amount pairs.
1729
1730 =cut
1731
1732 sub recharge {
1733   my ($self, $vhash) = @_;
1734
1735   if ( $DEBUG ) {
1736     warn "[$me] recharge called on $self: ". Dumper($self).
1737          "\nwith vhash: ". Dumper($vhash);
1738   }
1739
1740   my $oldAutoCommit = $FS::UID::AutoCommit;
1741   local $FS::UID::AutoCommit = 0;
1742   my $dbh = dbh;
1743   my $error = '';
1744
1745   foreach my $column (keys %$vhash){
1746     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1747   }
1748
1749   if ( $error ) {
1750     $dbh->rollback if $oldAutoCommit;
1751   }else{
1752     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1753   }
1754   return $error;
1755 }
1756
1757 =item is_rechargeable
1758
1759 Returns true if this svc_account can be "recharged" and false otherwise.
1760
1761 =cut
1762
1763 sub is_rechargable {
1764   my $self = shift;
1765   $self->seconds ne ''
1766     || $self->upbytes ne ''
1767     || $self->downbytes ne ''
1768     || $self->totalbytes ne '';
1769 }
1770
1771 =item seconds_since TIMESTAMP
1772
1773 Returns the number of seconds this account has been online since TIMESTAMP,
1774 according to the session monitor (see L<FS::Session>).
1775
1776 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1777 L<Time::Local> and L<Date::Parse> for conversion functions.
1778
1779 =cut
1780
1781 #note: POD here, implementation in FS::cust_svc
1782 sub seconds_since {
1783   my $self = shift;
1784   $self->cust_svc->seconds_since(@_);
1785 }
1786
1787 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1788
1789 Returns the numbers of seconds this account has been online between
1790 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1791 external SQL radacct table, specified via sqlradius export.  Sessions which
1792 started in the specified range but are still open are counted from session
1793 start to the end of the range (unless they are over 1 day old, in which case
1794 they are presumed missing their stop record and not counted).  Also, sessions
1795 which end in the range but started earlier are counted from the start of the
1796 range to session end.  Finally, sessions which start before the range but end
1797 after are counted for the entire range.
1798
1799 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1800 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1801 functions.
1802
1803 =cut
1804
1805 #note: POD here, implementation in FS::cust_svc
1806 sub seconds_since_sqlradacct {
1807   my $self = shift;
1808   $self->cust_svc->seconds_since_sqlradacct(@_);
1809 }
1810
1811 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1812
1813 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1814 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1815 TIMESTAMP_END (exclusive).
1816
1817 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1818 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1819 functions.
1820
1821 =cut
1822
1823 #note: POD here, implementation in FS::cust_svc
1824 sub attribute_since_sqlradacct {
1825   my $self = shift;
1826   $self->cust_svc->attribute_since_sqlradacct(@_);
1827 }
1828
1829 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1830
1831 Returns an array of hash references of this customers login history for the
1832 given time range.  (document this better)
1833
1834 =cut
1835
1836 sub get_session_history {
1837   my $self = shift;
1838   $self->cust_svc->get_session_history(@_);
1839 }
1840
1841 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1842
1843 =cut
1844
1845 sub get_cdrs {
1846   my($self, $start, $end, %opt ) = @_;
1847
1848   my $did = $self->username; #yup
1849
1850   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1851
1852   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1853
1854   #SELECT $for_update * FROM cdr
1855   #  WHERE calldate >= $start #need a conversion
1856   #    AND calldate <  $end   #ditto
1857   #    AND (    charged_party = "$did"
1858   #          OR charged_party = "$prefix$did" #if length($prefix);
1859   #          OR ( ( charged_party IS NULL OR charged_party = '' )
1860   #               AND
1861   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1862   #             )
1863   #        )
1864   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
1865
1866   my $charged_or_src;
1867   if ( length($prefix) ) {
1868     $charged_or_src =
1869       " AND (    charged_party = '$did'
1870               OR charged_party = '$prefix$did'
1871               OR ( ( charged_party IS NULL OR charged_party = '' )
1872                    AND
1873                    ( src = '$did' OR src = '$prefix$did' )
1874                  )
1875             )
1876       ";
1877   } else {
1878     $charged_or_src =
1879       " AND (    charged_party = '$did'
1880               OR ( ( charged_party IS NULL OR charged_party = '' )
1881                    AND
1882                    src = '$did'
1883                  )
1884             )
1885       ";
1886
1887   }
1888
1889   qsearch(
1890     'select'    => "$for_update *",
1891     'table'     => 'cdr',
1892     'hashref'   => {
1893                      #( freesidestatus IS NULL OR freesidestatus = '' )
1894                      'freesidestatus' => '',
1895                    },
1896     'extra_sql' => $charged_or_src,
1897
1898   );
1899
1900 }
1901
1902 =item radius_groups
1903
1904 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1905
1906 =cut
1907
1908 sub radius_groups {
1909   my $self = shift;
1910   if ( $self->usergroup ) {
1911     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1912       unless ref($self->usergroup) eq 'ARRAY';
1913     #when provisioning records, export callback runs in svc_Common.pm before
1914     #radius_usergroup records can be inserted...
1915     @{$self->usergroup};
1916   } else {
1917     map { $_->groupname }
1918       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1919   }
1920 }
1921
1922 =item clone_suspended
1923
1924 Constructor used by FS::part_export::_export_suspend fallback.  Document
1925 better.
1926
1927 =cut
1928
1929 sub clone_suspended {
1930   my $self = shift;
1931   my %hash = $self->hash;
1932   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1933   new FS::svc_acct \%hash;
1934 }
1935
1936 =item clone_kludge_unsuspend
1937
1938 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1939 better.
1940
1941 =cut
1942
1943 sub clone_kludge_unsuspend {
1944   my $self = shift;
1945   my %hash = $self->hash;
1946   $hash{_password} = '';
1947   new FS::svc_acct \%hash;
1948 }
1949
1950 =item check_password
1951
1952 Checks the supplied password against the (possibly encrypted) password in the
1953 database.  Returns true for a successful authentication, false for no match.
1954
1955 Currently supported encryptions are: classic DES crypt() and MD5
1956
1957 =cut
1958
1959 sub check_password {
1960   my($self, $check_password) = @_;
1961
1962   #remove old-style SUSPENDED kludge, they should be allowed to login to
1963   #self-service and pay up
1964   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1965
1966   if ( $self->_password_encoding eq 'ldap' ) {
1967
1968     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
1969     return $auth->match($check_password);
1970
1971   } elsif ( $self->_password_encoding eq 'crypt' ) {
1972
1973     my $auth = from_crypt Authen::Passphrase $self->_password;
1974     return $auth->match($check_password);
1975
1976   } elsif ( $self->_password_encoding eq 'plain' ) {
1977
1978     return $check_password eq $password;
1979
1980   } else {
1981
1982     #XXX this could be replaced with Authen::Passphrase stuff
1983
1984     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1985       return 0;
1986     } elsif ( length($password) < 13 ) { #plaintext
1987       $check_password eq $password;
1988     } elsif ( length($password) == 13 ) { #traditional DES crypt
1989       crypt($check_password, $password) eq $password;
1990     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1991       unix_md5_crypt($check_password, $password) eq $password;
1992     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1993       warn "Can't check password: Blowfish encryption not yet supported, ".
1994            "svcnum ".  $self->svcnum. "\n";
1995       0;
1996     } else {
1997       warn "Can't check password: Unrecognized encryption for svcnum ".
1998            $self->svcnum. "\n";
1999       0;
2000     }
2001
2002   }
2003
2004 }
2005
2006 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2007
2008 Returns an encrypted password, either by passing through an encrypted password
2009 in the database or by encrypting a plaintext password from the database.
2010
2011 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2012 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2013 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2014 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2015 encryption type is only used if the password is not already encrypted in the
2016 database.
2017
2018 =cut
2019
2020 sub crypt_password {
2021   my $self = shift;
2022
2023   if ( $self->_password_encoding eq 'ldap' ) {
2024
2025     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2026       my $plain = $2;
2027
2028       #XXX this could be replaced with Authen::Passphrase stuff
2029
2030       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2031       if ( $encryption eq 'crypt' ) {
2032         crypt(
2033           $self->_password,
2034           $saltset[int(rand(64))].$saltset[int(rand(64))]
2035         );
2036       } elsif ( $encryption eq 'md5' ) {
2037         unix_md5_crypt( $self->_password );
2038       } elsif ( $encryption eq 'blowfish' ) {
2039         croak "unknown encryption method $encryption";
2040       } else {
2041         croak "unknown encryption method $encryption";
2042       }
2043
2044     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2045       $1;
2046     }
2047
2048   } elsif ( $self->_password_encoding eq 'crypt' ) {
2049
2050     return $self->_password;
2051
2052   } elsif ( $self->_password_encoding eq 'plain' ) {
2053
2054     #XXX this could be replaced with Authen::Passphrase stuff
2055
2056     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2057     if ( $encryption eq 'crypt' ) {
2058       crypt(
2059         $self->_password,
2060         $saltset[int(rand(64))].$saltset[int(rand(64))]
2061       );
2062     } elsif ( $encryption eq 'md5' ) {
2063       unix_md5_crypt( $self->_password );
2064     } elsif ( $encryption eq 'blowfish' ) {
2065       croak "unknown encryption method $encryption";
2066     } else {
2067       croak "unknown encryption method $encryption";
2068     }
2069
2070   } else {
2071
2072     if ( length($self->_password) == 13
2073          || $self->_password =~ /^\$(1|2a?)\$/
2074          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2075        )
2076     {
2077       $self->_password;
2078     } else {
2079
2080       #XXX this could be replaced with Authen::Passphrase stuff
2081
2082       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2083       if ( $encryption eq 'crypt' ) {
2084         crypt(
2085           $self->_password,
2086           $saltset[int(rand(64))].$saltset[int(rand(64))]
2087         );
2088       } elsif ( $encryption eq 'md5' ) {
2089         unix_md5_crypt( $self->_password );
2090       } elsif ( $encryption eq 'blowfish' ) {
2091         croak "unknown encryption method $encryption";
2092       } else {
2093         croak "unknown encryption method $encryption";
2094       }
2095
2096     }
2097
2098   }
2099
2100 }
2101
2102 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2103
2104 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2105 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2106 "{MD5}5426824942db4253f87a1009fd5d2d4".
2107
2108 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2109 to work the same as the B</crypt_password> method.
2110
2111 =cut
2112
2113 sub ldap_password {
2114   my $self = shift;
2115   #eventually should check a "password-encoding" field
2116
2117   if ( $self->_password_encoding eq 'ldap' ) {
2118
2119     return $self->_password;
2120
2121   } elsif ( $self->_password_encoding eq 'crypt' ) {
2122
2123     if ( length($self->_password) == 13 ) { #crypt
2124       return '{CRYPT}'. $self->_password;
2125     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2126       return '{MD5}'. $1;
2127     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2128     #  die "Blowfish encryption not supported in this context, svcnum ".
2129     #      $self->svcnum. "\n";
2130     } else {
2131       warn "encryption method not (yet?) supported in LDAP context";
2132       return '{CRYPT}*'; #unsupported, should not auth
2133     }
2134
2135   } elsif ( $self->_password_encoding eq 'plain' ) {
2136
2137     return '{PLAIN}'. $self->_password;
2138
2139     #return '{CLEARTEXT}'. $self->_password; #?
2140
2141   } else {
2142
2143     if ( length($self->_password) == 13 ) { #crypt
2144       return '{CRYPT}'. $self->_password;
2145     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2146       return '{MD5}'. $1;
2147     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2148       warn "Blowfish encryption not supported in this context, svcnum ".
2149           $self->svcnum. "\n";
2150       return '{CRYPT}*';
2151
2152     #are these two necessary anymore?
2153     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2154       return '{SSHA}'. $1;
2155     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2156       return '{NS-MTA-MD5}'. $1;
2157
2158     } else { #plaintext
2159       return '{PLAIN}'. $self->_password;
2160
2161       #return '{CLEARTEXT}'. $self->_password; #?
2162
2163       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2164       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2165       #if ( $encryption eq 'crypt' ) {
2166       #  return '{CRYPT}'. crypt(
2167       #    $self->_password,
2168       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2169       #  );
2170       #} elsif ( $encryption eq 'md5' ) {
2171       #  unix_md5_crypt( $self->_password );
2172       #} elsif ( $encryption eq 'blowfish' ) {
2173       #  croak "unknown encryption method $encryption";
2174       #} else {
2175       #  croak "unknown encryption method $encryption";
2176       #}
2177     }
2178
2179   }
2180
2181 }
2182
2183 =item domain_slash_username
2184
2185 Returns $domain/$username/
2186
2187 =cut
2188
2189 sub domain_slash_username {
2190   my $self = shift;
2191   $self->domain. '/'. $self->username. '/';
2192 }
2193
2194 =item virtual_maildir
2195
2196 Returns $domain/maildirs/$username/
2197
2198 =cut
2199
2200 sub virtual_maildir {
2201   my $self = shift;
2202   $self->domain. '/maildirs/'. $self->username. '/';
2203 }
2204
2205 =back
2206
2207 =head1 SUBROUTINES
2208
2209 =over 4
2210
2211 =item send_email
2212
2213 This is the FS::svc_acct job-queue-able version.  It still uses
2214 FS::Misc::send_email under-the-hood.
2215
2216 =cut
2217
2218 sub send_email {
2219   my %opt = @_;
2220
2221   eval "use FS::Misc qw(send_email)";
2222   die $@ if $@;
2223
2224   $opt{mimetype} ||= 'text/plain';
2225   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2226
2227   my $error = send_email(
2228     'from'         => $opt{from},
2229     'to'           => $opt{to},
2230     'subject'      => $opt{subject},
2231     'content-type' => $opt{mimetype},
2232     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2233   );
2234   die $error if $error;
2235 }
2236
2237 =item check_and_rebuild_fuzzyfiles
2238
2239 =cut
2240
2241 sub check_and_rebuild_fuzzyfiles {
2242   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2243   -e "$dir/svc_acct.username"
2244     or &rebuild_fuzzyfiles;
2245 }
2246
2247 =item rebuild_fuzzyfiles
2248
2249 =cut
2250
2251 sub rebuild_fuzzyfiles {
2252
2253   use Fcntl qw(:flock);
2254
2255   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2256
2257   #username
2258
2259   open(USERNAMELOCK,">>$dir/svc_acct.username")
2260     or die "can't open $dir/svc_acct.username: $!";
2261   flock(USERNAMELOCK,LOCK_EX)
2262     or die "can't lock $dir/svc_acct.username: $!";
2263
2264   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2265
2266   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2267     or die "can't open $dir/svc_acct.username.tmp: $!";
2268   print USERNAMECACHE join("\n", @all_username), "\n";
2269   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2270
2271   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2272   close USERNAMELOCK;
2273
2274 }
2275
2276 =item all_username
2277
2278 =cut
2279
2280 sub all_username {
2281   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2282   open(USERNAMECACHE,"<$dir/svc_acct.username")
2283     or die "can't open $dir/svc_acct.username: $!";
2284   my @array = map { chomp; $_; } <USERNAMECACHE>;
2285   close USERNAMECACHE;
2286   \@array;
2287 }
2288
2289 =item append_fuzzyfiles USERNAME
2290
2291 =cut
2292
2293 sub append_fuzzyfiles {
2294   my $username = shift;
2295
2296   &check_and_rebuild_fuzzyfiles;
2297
2298   use Fcntl qw(:flock);
2299
2300   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2301
2302   open(USERNAME,">>$dir/svc_acct.username")
2303     or die "can't open $dir/svc_acct.username: $!";
2304   flock(USERNAME,LOCK_EX)
2305     or die "can't lock $dir/svc_acct.username: $!";
2306
2307   print USERNAME "$username\n";
2308
2309   flock(USERNAME,LOCK_UN)
2310     or die "can't unlock $dir/svc_acct.username: $!";
2311   close USERNAME;
2312
2313   1;
2314 }
2315
2316
2317
2318 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2319
2320 =cut
2321
2322 sub radius_usergroup_selector {
2323   my $sel_groups = shift;
2324   my %sel_groups = map { $_=>1 } @$sel_groups;
2325
2326   my $selectname = shift || 'radius_usergroup';
2327
2328   my $dbh = dbh;
2329   my $sth = $dbh->prepare(
2330     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2331   ) or die $dbh->errstr;
2332   $sth->execute() or die $sth->errstr;
2333   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2334
2335   my $html = <<END;
2336     <SCRIPT>
2337     function ${selectname}_doadd(object) {
2338       var myvalue = object.${selectname}_add.value;
2339       var optionName = new Option(myvalue,myvalue,false,true);
2340       var length = object.$selectname.length;
2341       object.$selectname.options[length] = optionName;
2342       object.${selectname}_add.value = "";
2343     }
2344     </SCRIPT>
2345     <SELECT MULTIPLE NAME="$selectname">
2346 END
2347
2348   foreach my $group ( @all_groups ) {
2349     $html .= qq(<OPTION VALUE="$group");
2350     if ( $sel_groups{$group} ) {
2351       $html .= ' SELECTED';
2352       $sel_groups{$group} = 0;
2353     }
2354     $html .= ">$group</OPTION>\n";
2355   }
2356   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2357     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2358   };
2359   $html .= '</SELECT>';
2360
2361   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2362            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2363
2364   $html;
2365 }
2366
2367 =item reached_threshold
2368
2369 Performs some activities when svc_acct thresholds (such as number of seconds
2370 remaining) are reached.
2371
2372 =cut
2373
2374 sub reached_threshold {
2375   my %opt = @_;
2376
2377   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2378   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2379
2380   if ( $opt{'op'} eq '+' ){
2381     $svc_acct->setfield( $opt{'column'}.'_threshold',
2382                          int($svc_acct->getfield($opt{'column'})
2383                              * ( $conf->exists('svc_acct-usage_threshold')
2384                                  ? $conf->config('svc_acct-usage_threshold')/100
2385                                  : 0.80
2386                                )
2387                          )
2388                        );
2389     my $error = $svc_acct->replace;
2390     die $error if $error;
2391   }elsif ( $opt{'op'} eq '-' ){
2392
2393     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2394     return '' if ($threshold eq '' );
2395
2396     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2397     my $error = $svc_acct->replace;
2398     die $error if $error; # email next time, i guess
2399
2400     if ( $warning_template ) {
2401       eval "use FS::Misc qw(send_email)";
2402       die $@ if $@;
2403
2404       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2405       my $cust_main = $cust_pkg->cust_main;
2406
2407       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2408                                $cust_main->invoicing_list,
2409                                $svc_acct->email,
2410                                ($opt{'to'} ? $opt{'to'} : ())
2411                    );
2412
2413       my $mimetype = $warning_mimetype;
2414       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2415
2416       my $body       =  $warning_template->fill_in( HASH => {
2417                         'custnum'   => $cust_main->custnum,
2418                         'username'  => $svc_acct->username,
2419                         'password'  => $svc_acct->_password,
2420                         'first'     => $cust_main->first,
2421                         'last'      => $cust_main->getfield('last'),
2422                         'pkg'       => $cust_pkg->part_pkg->pkg,
2423                         'column'    => $opt{'column'},
2424                         'amount'    => $svc_acct->getfield($opt{'column'}),
2425                         'threshold' => $threshold,
2426                       } );
2427
2428
2429       my $error = send_email(
2430         'from'         => $warning_from,
2431         'to'           => $to,
2432         'subject'      => $warning_subject,
2433         'content-type' => $mimetype,
2434         'body'         => [ map "$_\n", split("\n", $body) ],
2435       );
2436       die $error if $error;
2437     }
2438   }else{
2439     die "unknown op: " . $opt{'op'};
2440   }
2441 }
2442
2443 =back
2444
2445 =head1 BUGS
2446
2447 The $recref stuff in sub check should be cleaned up.
2448
2449 The suspend, unsuspend and cancel methods update the database, but not the
2450 current object.  This is probably a bug as it's unexpected and
2451 counterintuitive.
2452
2453 radius_usergroup_selector?  putting web ui components in here?  they should
2454 probably live somewhere else...
2455
2456 insertion of RADIUS group stuff in insert could be done with child_objects now
2457 (would probably clean up export of them too)
2458
2459 =head1 SEE ALSO
2460
2461 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2462 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2463 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2464 L<freeside-queued>), L<FS::svc_acct_pop>,
2465 schema.html from the base documentation.
2466
2467 =cut
2468
2469 1;
2470