FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $conf
   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
  10              $welcome_template $welcome_from $welcome_subject $welcome_mimetype
  11              $smtpmachine
  12              $radius_password $radius_ip
  13              $dirhash
  14              @saltset @pw_set );
  15 use Carp;
  16 use Fcntl qw(:flock);
  17 use FS::UID qw( datasrc );
  18 use FS::Conf;
  19 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  20 use FS::svc_Common;
  21 use FS::cust_svc;
  22 use FS::part_svc;
  23 use FS::svc_acct_pop;
  24 use FS::cust_main_invoice;
  25 use FS::svc_domain;
  26 use FS::raddb;
  27 use FS::queue;
  28 use FS::radius_usergroup;
  29 use FS::export_svc;
  30 use FS::part_export;
  31 use FS::Msgcat qw(gettext);
  32
  33 @ISA = qw( FS::svc_Common );
  34
  35 $DEBUG = 0;
  36 #$DEBUG = 1;
  37 $me = '[FS::svc_acct]';
  38
  39 #ask FS::UID to run this stuff for us later
  40 $FS::UID::callback{'FS::svc_acct'} = sub {
  41   $conf = new FS::Conf;
  42   $dir_prefix = $conf->config('home');
  43   @shells = $conf->config('shells');
  44   $usernamemin = $conf->config('usernamemin') || 2;
  45   $usernamemax = $conf->config('usernamemax');
  46   $passwordmin = $conf->config('passwordmin') || 6;
  47   $passwordmax = $conf->config('passwordmax') || 8;
  48   $username_letter = $conf->exists('username-letter');
  49   $username_letterfirst = $conf->exists('username-letterfirst');
  50   $username_noperiod = $conf->exists('username-noperiod');
  51   $username_nounderscore = $conf->exists('username-nounderscore');
  52   $username_nodash = $conf->exists('username-nodash');
  53   $username_uppercase = $conf->exists('username-uppercase');
  54   $username_ampersand = $conf->exists('username-ampersand');
  55   $dirhash = $conf->config('dirhash') || 0;
  56   if ( $conf->exists('welcome_email') ) {
  57     $welcome_template = new Text::Template (
  58       TYPE   => 'ARRAY',
  59       SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
  60     ) or warn "can't create welcome email template: $Text::Template::ERROR";
  61     $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
  62     $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
  63     $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
  64   } else {
  65     $welcome_template = '';
  66     $welcome_from = '';
  67     $welcome_subject = '';
  68     $welcome_mimetype = '';
  69   }
  70   $smtpmachine = $conf->config('smtpmachine');
  71   $radius_password = $conf->config('radius-password') || 'Password';
  72   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  73 };
  74
  75 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  76 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  77
  78 sub _cache {
  79   my $self = shift;
  80   my ( $hashref, $cache ) = @_;
  81   if ( $hashref->{'svc_acct_svcnum'} ) {
  82     $self->{'_domsvc'} = FS::svc_domain->new( {
  83       'svcnum'   => $hashref->{'domsvc'},
  84       'domain'   => $hashref->{'svc_acct_domain'},
  85       'catchall' => $hashref->{'svc_acct_catchall'},
  86     } );
  87   }
  88 }
  89
  90 =head1 NAME
  91
  92 FS::svc_acct - Object methods for svc_acct records
  93
  94 =head1 SYNOPSIS
  95
  96   use FS::svc_acct;
  97
  98   $record = new FS::svc_acct \%hash;
  99   $record = new FS::svc_acct { 'column' => 'value' };
 100
 101   $error = $record->insert;
 102
 103   $error = $new_record->replace($old_record);
 104
 105   $error = $record->delete;
 106
 107   $error = $record->check;
 108
 109   $error = $record->suspend;
 110
 111   $error = $record->unsuspend;
 112
 113   $error = $record->cancel;
 114
 115   %hash = $record->radius;
 116
 117   %hash = $record->radius_reply;
 118
 119   %hash = $record->radius_check;
 120
 121   $domain = $record->domain;
 122
 123   $svc_domain = $record->svc_domain;
 124
 125   $email = $record->email;
 126
 127   $seconds_since = $record->seconds_since($timestamp);
 128
 129 =head1 DESCRIPTION
 130
 131 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 132 FS::svc_Common.  The following fields are currently supported:
 133
 134 =over 4
 135
 136 =item svcnum - primary key (assigned automatcially for new accounts)
 137
 138 =item username
 139
 140 =item _password - generated if blank
 141
 142 =item sec_phrase - security phrase
 143
 144 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 145
 146 =item uid
 147
 148 =item gid
 149
 150 =item finger - GECOS
 151
 152 =item dir - set automatically if blank (and uid is not)
 153
 154 =item shell
 155
 156 =item quota - (unimplementd)
 157
 158 =item slipip - IP address
 159
 160 =item seconds -
 161
 162 =item domsvc - svcnum from svc_domain
 163
 164 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
 165
 166 =back
 167
 168 =head1 METHODS
 169
 170 =over 4
 171
 172 =item new HASHREF
 173
 174 Creates a new account.  To add the account to the database, see L<"insert">.
 175
 176 =cut
 177
 178 sub table { 'svc_acct'; }
 179
 180 =item insert [ , OPTION => VALUE ... ]
 181
 182 Adds this account to the database.  If there is an error, returns the error,
 183 otherwise returns false.
 184
 185 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 186 defined.  An FS::cust_svc record will be created and inserted.
 187
 188 The additional field I<usergroup> can optionally be defined; if so it should
 189 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 190 sqlradius export only)
 191
 192 The additional field I<child_objects> can optionally be defined; if so it
 193 should contain an arrayref of FS::tablename objects.  They will have their
 194 svcnum fields set and will be inserted after this record, but before any
 195 exports are run.
 196
 197 Currently available options are: I<depend_jobnum>
 198
 199 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 200 jobnums), all provisioning jobs will have a dependancy on the supplied
 201 jobnum(s) (they will not run until the specific job(s) complete(s)).
 202
 203 (TODOC: L<FS::queue> and L<freeside-queued>)
 204
 205 (TODOC: new exports!)
 206
 207 =cut
 208
 209 sub insert {
 210   my $self = shift;
 211   my %options = @_;
 212   my $error;
 213
 214   local $SIG{HUP} = 'IGNORE';
 215   local $SIG{INT} = 'IGNORE';
 216   local $SIG{QUIT} = 'IGNORE';
 217   local $SIG{TERM} = 'IGNORE';
 218   local $SIG{TSTP} = 'IGNORE';
 219   local $SIG{PIPE} = 'IGNORE';
 220
 221   my $oldAutoCommit = $FS::UID::AutoCommit;
 222   local $FS::UID::AutoCommit = 0;
 223   my $dbh = dbh;
 224
 225   $error = $self->check;
 226   return $error if $error;
 227
 228   #no, duplicate checking just got a whole lot more complicated
 229   #(perhaps keep this check with a config option to turn on?)
 230
 231   #return gettext('username_in_use'). ": ". $self->username
 232   #  if qsearchs( 'svc_acct', { 'username' => $self->username,
 233   #                             'domsvc'   => $self->domsvc,
 234   #                           } );
 235
 236   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 237     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 238     unless ( $cust_svc ) {
 239       $dbh->rollback if $oldAutoCommit;
 240       return "no cust_svc record found for svcnum ". $self->svcnum;
 241     }
 242     $self->pkgnum($cust_svc->pkgnum);
 243     $self->svcpart($cust_svc->svcpart);
 244   }
 245
 246   #new duplicate username checking
 247
 248   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
 249   unless ( $part_svc ) {
 250     $dbh->rollback if $oldAutoCommit;
 251     return 'unknown svcpart '. $self->svcpart;
 252   }
 253
 254   my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
 255   my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
 256                                               'domsvc'   => $self->domsvc } );
 257   my @dup_uid;
 258   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
 259        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
 260     @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
 261   } else {
 262     @dup_uid = ();
 263   }
 264
 265   if ( @dup_user || @dup_userdomain || @dup_uid ) {
 266     my $exports = FS::part_export::export_info('svc_acct');
 267     my %conflict_user_svcpart;
 268     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
 269
 270     foreach my $part_export ( $part_svc->part_export ) {
 271
 272       #this will catch to the same exact export
 273       my @svcparts = map { $_->svcpart }
 274         qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 275
 276       #this will catch to exports w/same exporthost+type ???
 277       #my @other_part_export = qsearch('part_export', {
 278       #  'machine'    => $part_export->machine,
 279       #  'exporttype' => $part_export->exporttype,
 280       #} );
 281       #foreach my $other_part_export ( @other_part_export ) {
 282       #  push @svcparts, map { $_->svcpart }
 283       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 284       #}
 285
 286       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
 287       #silly kludge to avoid uninitialized value errors
 288       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
 289                      ? $exports->{$part_export->exporttype}{'nodomain'}
 290                      : '';
 291       if ( $nodomain =~ /^Y/i ) {
 292         $conflict_user_svcpart{$_} = $part_export->exportnum
 293           foreach @svcparts;
 294       } else {
 295         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
 296           foreach @svcparts;
 297       }
 298     }
 299
 300     foreach my $dup_user ( @dup_user ) {
 301       my $dup_svcpart = $dup_user->cust_svc->svcpart;
 302       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
 303         $dbh->rollback if $oldAutoCommit;
 304         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
 305                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
 306       }
 307     }
 308
 309     foreach my $dup_userdomain ( @dup_userdomain ) {
 310       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
 311       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 312         $dbh->rollback if $oldAutoCommit;
 313         return "duplicate username\@domain: conflicts with svcnum ".
 314                $dup_userdomain->svcnum. " via exportnum ".
 315                $conflict_userdomain_svcpart{$dup_svcpart};
 316       }
 317     }
 318
 319     foreach my $dup_uid ( @dup_uid ) {
 320       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
 321       if ( exists($conflict_user_svcpart{$dup_svcpart})
 322            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 323         $dbh->rollback if $oldAutoCommit;
 324         return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
 325                "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
 326                                  || $conflict_userdomain_svcpart{$dup_svcpart};
 327       }
 328     }
 329
 330   }
 331
 332   #see?  i told you it was more complicated
 333
 334   my @jobnums;
 335   $error = $self->SUPER::insert(
 336     'jobnums'       => \@jobnums,
 337     'child_objects' => $self->child_objects,
 338     %options,
 339   );
 340   if ( $error ) {
 341     $dbh->rollback if $oldAutoCommit;
 342     return $error;
 343   }
 344
 345   if ( $self->usergroup ) {
 346     foreach my $groupname ( @{$self->usergroup} ) {
 347       my $radius_usergroup = new FS::radius_usergroup ( {
 348         svcnum    => $self->svcnum,
 349         groupname => $groupname,
 350       } );
 351       my $error = $radius_usergroup->insert;
 352       if ( $error ) {
 353         $dbh->rollback if $oldAutoCommit;
 354         return $error;
 355       }
 356     }
 357   }
 358
 359   #false laziness with sub replace (and cust_main)
 360   my $queue = new FS::queue {
 361     'svcnum' => $self->svcnum,
 362     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 363   };
 364   $error = $queue->insert($self->username);
 365   if ( $error ) {
 366     $dbh->rollback if $oldAutoCommit;
 367     return "queueing job (transaction rolled back): $error";
 368   }
 369
 370   my $cust_pkg = $self->cust_svc->cust_pkg;
 371
 372   if ( $cust_pkg ) {
 373     my $cust_main = $cust_pkg->cust_main;
 374
 375     if ( $conf->exists('emailinvoiceauto') ) {
 376       my @invoicing_list = $cust_main->invoicing_list;
 377       push @invoicing_list, $self->email;
 378       $cust_main->invoicing_list(\@invoicing_list);
 379     }
 380
 381     #welcome email
 382     my $to = '';
 383     if ( $welcome_template && $cust_pkg ) {
 384       my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
 385       if ( $to ) {
 386         my $wqueue = new FS::queue {
 387           'svcnum' => $self->svcnum,
 388           'job'    => 'FS::svc_acct::send_email'
 389         };
 390         my $error = $wqueue->insert(
 391           'to'       => $to,
 392           'from'     => $welcome_from,
 393           'subject'  => $welcome_subject,
 394           'mimetype' => $welcome_mimetype,
 395           'body'     => $welcome_template->fill_in( HASH => {
 396                           'custnum'  => $self->custnum,
 397                           'username' => $self->username,
 398                           'password' => $self->_password,
 399                           'first'    => $cust_main->first,
 400                           'last'     => $cust_main->getfield('last'),
 401                           'pkg'      => $cust_pkg->part_pkg->pkg,
 402                         } ),
 403         );
 404         if ( $error ) {
 405           $dbh->rollback if $oldAutoCommit;
 406           return "error queuing welcome email: $error";
 407         }
 408
 409         if ( $options{'depend_jobnum'} ) {
 410           warn "$me depend_jobnum found; adding to welcome email dependancies"
 411             if $DEBUG;
 412           if ( ref($options{'depend_jobnum'}) ) {
 413             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 414                  "to welcome email dependancies"
 415               if $DEBUG;
 416             push @jobnums, @{ $options{'depend_jobnum'} };
 417           } else {
 418             warn "$me adding job $options{'depend_jobnum'} ".
 419                  "to welcome email dependancies"
 420               if $DEBUG;
 421             push @jobnums, $options{'depend_jobnum'};
 422           }
 423         }
 424
 425         foreach my $jobnum ( @jobnums ) {
 426           my $error = $wqueue->depend_insert($jobnum);
 427           if ( $error ) {
 428             $dbh->rollback if $oldAutoCommit;
 429             return "error queuing welcome email job dependancy: $error";
 430           }
 431         }
 432
 433       }
 434
 435     }
 436
 437   } # if ( $cust_pkg )
 438
 439   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 440   ''; #no error
 441 }
 442
 443 =item delete
 444
 445 Deletes this account from the database.  If there is an error, returns the
 446 error, otherwise returns false.
 447
 448 The corresponding FS::cust_svc record will be deleted as well.
 449
 450 (TODOC: new exports!)
 451
 452 =cut
 453
 454 sub delete {
 455   my $self = shift;
 456
 457   return "can't delete system account" if $self->_check_system;
 458
 459   return "Can't delete an account which is a (svc_forward) source!"
 460     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 461
 462   return "Can't delete an account which is a (svc_forward) destination!"
 463     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 464
 465   return "Can't delete an account with (svc_www) web service!"
 466     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
 467
 468   # what about records in session ? (they should refer to history table)
 469
 470   local $SIG{HUP} = 'IGNORE';
 471   local $SIG{INT} = 'IGNORE';
 472   local $SIG{QUIT} = 'IGNORE';
 473   local $SIG{TERM} = 'IGNORE';
 474   local $SIG{TSTP} = 'IGNORE';
 475   local $SIG{PIPE} = 'IGNORE';
 476
 477   my $oldAutoCommit = $FS::UID::AutoCommit;
 478   local $FS::UID::AutoCommit = 0;
 479   my $dbh = dbh;
 480
 481   foreach my $cust_main_invoice (
 482     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 483   ) {
 484     unless ( defined($cust_main_invoice) ) {
 485       warn "WARNING: something's wrong with qsearch";
 486       next;
 487     }
 488     my %hash = $cust_main_invoice->hash;
 489     $hash{'dest'} = $self->email;
 490     my $new = new FS::cust_main_invoice \%hash;
 491     my $error = $new->replace($cust_main_invoice);
 492     if ( $error ) {
 493       $dbh->rollback if $oldAutoCommit;
 494       return $error;
 495     }
 496   }
 497
 498   foreach my $svc_domain (
 499     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 500   ) {
 501     my %hash = new FS::svc_domain->hash;
 502     $hash{'catchall'} = '';
 503     my $new = new FS::svc_domain \%hash;
 504     my $error = $new->replace($svc_domain);
 505     if ( $error ) {
 506       $dbh->rollback if $oldAutoCommit;
 507       return $error;
 508     }
 509   }
 510
 511   foreach my $radius_usergroup (
 512     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 513   ) {
 514     my $error = $radius_usergroup->delete;
 515     if ( $error ) {
 516       $dbh->rollback if $oldAutoCommit;
 517       return $error;
 518     }
 519   }
 520
 521   my $error = $self->SUPER::delete;
 522   if ( $error ) {
 523     $dbh->rollback if $oldAutoCommit;
 524     return $error;
 525   }
 526
 527   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 528   '';
 529 }
 530
 531 =item replace OLD_RECORD
 532
 533 Replaces OLD_RECORD with this one in the database.  If there is an error,
 534 returns the error, otherwise returns false.
 535
 536 The additional field I<usergroup> can optionally be defined; if so it should
 537 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 538 sqlradius export only)
 539
 540 =cut
 541
 542 sub replace {
 543   my ( $new, $old ) = ( shift, shift );
 544   my $error;
 545   warn "$me replacing $old with $new\n" if $DEBUG;
 546
 547   return "can't modify system account" if $old->_check_system;
 548
 549   return "Username in use"
 550     if $old->username ne $new->username &&
 551       qsearchs( 'svc_acct', { 'username' => $new->username,
 552                                'domsvc'   => $new->domsvc,
 553                              } );
 554   {
 555     #no warnings 'numeric';  #alas, a 5.006-ism
 556     local($^W) = 0;
 557     return "Can't change uid!" if $old->uid != $new->uid;
 558   }
 559
 560   #change homdir when we change username
 561   $new->setfield('dir', '') if $old->username ne $new->username;
 562
 563   local $SIG{HUP} = 'IGNORE';
 564   local $SIG{INT} = 'IGNORE';
 565   local $SIG{QUIT} = 'IGNORE';
 566   local $SIG{TERM} = 'IGNORE';
 567   local $SIG{TSTP} = 'IGNORE';
 568   local $SIG{PIPE} = 'IGNORE';
 569
 570   my $oldAutoCommit = $FS::UID::AutoCommit;
 571   local $FS::UID::AutoCommit = 0;
 572   my $dbh = dbh;
 573
 574   # redundant, but so $new->usergroup gets set
 575   $error = $new->check;
 576   return $error if $error;
 577
 578   $old->usergroup( [ $old->radius_groups ] );
 579   warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
 580   warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
 581   if ( $new->usergroup ) {
 582     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 583     my @newgroups = @{$new->usergroup};
 584     foreach my $oldgroup ( @{$old->usergroup} ) {
 585       if ( grep { $oldgroup eq $_ } @newgroups ) {
 586         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 587         next;
 588       }
 589       my $radius_usergroup = qsearchs('radius_usergroup', {
 590         svcnum    => $old->svcnum,
 591         groupname => $oldgroup,
 592       } );
 593       my $error = $radius_usergroup->delete;
 594       if ( $error ) {
 595         $dbh->rollback if $oldAutoCommit;
 596         return "error deleting radius_usergroup $oldgroup: $error";
 597       }
 598     }
 599
 600     foreach my $newgroup ( @newgroups ) {
 601       my $radius_usergroup = new FS::radius_usergroup ( {
 602         svcnum    => $new->svcnum,
 603         groupname => $newgroup,
 604       } );
 605       my $error = $radius_usergroup->insert;
 606       if ( $error ) {
 607         $dbh->rollback if $oldAutoCommit;
 608         return "error adding radius_usergroup $newgroup: $error";
 609       }
 610     }
 611
 612   }
 613
 614   $error = $new->SUPER::replace($old);
 615   if ( $error ) {
 616     $dbh->rollback if $oldAutoCommit;
 617     return $error if $error;
 618   }
 619
 620   if ( $new->username ne $old->username ) {
 621     #false laziness with sub insert (and cust_main)
 622     my $queue = new FS::queue {
 623       'svcnum' => $new->svcnum,
 624       'job'    => 'FS::svc_acct::append_fuzzyfiles'
 625     };
 626     $error = $queue->insert($new->username);
 627     if ( $error ) {
 628       $dbh->rollback if $oldAutoCommit;
 629       return "queueing job (transaction rolled back): $error";
 630     }
 631   }
 632
 633   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 634   ''; #no error
 635 }
 636
 637 =item suspend
 638
 639 Suspends this account by calling export-specific suspend hooks.  If there is
 640 an error, returns the error, otherwise returns false.
 641
 642 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 643
 644 =cut
 645
 646 sub suspend {
 647   my $self = shift;
 648   return "can't suspend system account" if $self->_check_system;
 649   $self->SUPER::suspend;
 650 }
 651
 652 =item unsuspend
 653
 654 Unsuspends this account by by calling export-specific suspend hooks.  If there
 655 is an error, returns the error, otherwise returns false.
 656
 657 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 658
 659 =cut
 660
 661 sub unsuspend {
 662   my $self = shift;
 663   my %hash = $self->hash;
 664   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 665     $hash{_password} = $1;
 666     my $new = new FS::svc_acct ( \%hash );
 667     my $error = $new->replace($self);
 668     return $error if $error;
 669   }
 670
 671   $self->SUPER::unsuspend;
 672 }
 673
 674 =item cancel
 675
 676 Just returns false (no error) for now.
 677
 678 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 679
 680 =item check
 681
 682 Checks all fields to make sure this is a valid service.  If there is an error,
 683 returns the error, otherwise returns false.  Called by the insert and replace
 684 methods.
 685
 686 Sets any fixed values; see L<FS::part_svc>.
 687
 688 =cut
 689
 690 sub check {
 691   my $self = shift;
 692
 693   my($recref) = $self->hashref;
 694
 695   my $x = $self->setfixed;
 696   return $x unless ref($x);
 697   my $part_svc = $x;
 698
 699   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 700     $self->usergroup(
 701       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 702   }
 703
 704   my $error = $self->ut_numbern('svcnum')
 705               #|| $self->ut_number('domsvc')
 706               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 707               || $self->ut_textn('sec_phrase')
 708   ;
 709   return $error if $error;
 710
 711   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 712   if ( $username_uppercase ) {
 713     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 714       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 715     $recref->{username} = $1;
 716   } else {
 717     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 718       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 719     $recref->{username} = $1;
 720   }
 721
 722   if ( $username_letterfirst ) {
 723     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 724   } elsif ( $username_letter ) {
 725     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 726   }
 727   if ( $username_noperiod ) {
 728     $recref->{username} =~ /\./ and return gettext('illegal_username');
 729   }
 730   if ( $username_nounderscore ) {
 731     $recref->{username} =~ /_/ and return gettext('illegal_username');
 732   }
 733   if ( $username_nodash ) {
 734     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 735   }
 736   unless ( $username_ampersand ) {
 737     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 738   }
 739
 740   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 741   $recref->{popnum} = $1;
 742   return "Unknown popnum" unless
 743     ! $recref->{popnum} ||
 744     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 745
 746   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 747
 748     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 749     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 750
 751     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 752     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 753     #not all systems use gid=uid
 754     #you can set a fixed gid in part_svc
 755
 756     return "Only root can have uid 0"
 757       if $recref->{uid} == 0
 758          && $recref->{username} ne 'root'
 759          && $recref->{username} ne 'toor';
 760
 761
 762     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 763       or return "Illegal directory: ". $recref->{dir};
 764     $recref->{dir} = $1;
 765     return "Illegal directory"
 766       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 767     return "Illegal directory"
 768       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 769     unless ( $recref->{dir} ) {
 770       $recref->{dir} = $dir_prefix . '/';
 771       if ( $dirhash > 0 ) {
 772         for my $h ( 1 .. $dirhash ) {
 773           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 774         }
 775       } elsif ( $dirhash < 0 ) {
 776         for my $h ( reverse $dirhash .. -1 ) {
 777           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 778         }
 779       }
 780       $recref->{dir} .= $recref->{username};
 781     ;
 782     }
 783
 784     unless ( $recref->{username} eq 'sync' ) {
 785       if ( grep $_ eq $recref->{shell}, @shells ) {
 786         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 787       } else {
 788         return "Illegal shell \`". $self->shell. "\'; ".
 789                $conf->dir. "/shells contains: @shells";
 790       }
 791     } else {
 792       $recref->{shell} = '/bin/sync';
 793     }
 794
 795   } else {
 796     $recref->{gid} ne '' ?
 797       return "Can't have gid without uid" : ( $recref->{gid}='' );
 798     $recref->{dir} ne '' ?
 799       return "Can't have directory without uid" : ( $recref->{dir}='' );
 800     $recref->{shell} ne '' ?
 801       return "Can't have shell without uid" : ( $recref->{shell}='' );
 802   }
 803
 804   #  $error = $self->ut_textn('finger');
 805   #  return $error if $error;
 806   $self->getfield('finger') =~
 807     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 808       or return "Illegal finger: ". $self->getfield('finger');
 809   $self->setfield('finger', $1);
 810
 811   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
 812   $recref->{quota} = $1;
 813
 814   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 815     if ( $recref->{slipip} eq '' ) {
 816       $recref->{slipip} = '';
 817     } elsif ( $recref->{slipip} eq '0e0' ) {
 818       $recref->{slipip} = '0e0';
 819     } else {
 820       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 821         or return "Illegal slipip: ". $self->slipip;
 822       $recref->{slipip} = $1;
 823     }
 824
 825   }
 826
 827   #arbitrary RADIUS stuff; allow ut_textn for now
 828   foreach ( grep /^radius_/, fields('svc_acct') ) {
 829     $self->ut_textn($_);
 830   }
 831
 832   #generate a password if it is blank
 833   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 834     unless ( $recref->{_password} );
 835
 836   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 837   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 838     $recref->{_password} = $1.$3;
 839     #uncomment this to encrypt password immediately upon entry, or run
 840     #bin/crypt_pw in cron to give new users a window during which their
 841     #password is available to techs, for faxing, etc.  (also be aware of
 842     #radius issues!)
 843     #$recref->{password} = $1.
 844     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 845     #;
 846   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 847     $recref->{_password} = $1.$3;
 848   } elsif ( $recref->{_password} eq '*' ) {
 849     $recref->{_password} = '*';
 850   } elsif ( $recref->{_password} eq '!' ) {
 851     $recref->{_password} = '!';
 852   } elsif ( $recref->{_password} eq '!!' ) {
 853     $recref->{_password} = '!!';
 854   } else {
 855     #return "Illegal password";
 856     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 857            FS::Msgcat::_gettext('illegal_password_characters').
 858            ": ". $recref->{_password};
 859   }
 860
 861   $self->SUPER::check;
 862 }
 863
 864 =item _check_system
 865
 866 =cut
 867
 868 sub _check_system {
 869   my $self = shift;
 870   scalar( grep { $self->username eq $_ || $self->email eq $_ }
 871                $conf->config('system_usernames')
 872         );
 873 }
 874
 875 =item radius
 876
 877 Depriciated, use radius_reply instead.
 878
 879 =cut
 880
 881 sub radius {
 882   carp "FS::svc_acct::radius depriciated, use radius_reply";
 883   $_[0]->radius_reply;
 884 }
 885
 886 =item radius_reply
 887
 888 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 889 reply attributes of this record.
 890
 891 Note that this is now the preferred method for reading RADIUS attributes -
 892 accessing the columns directly is discouraged, as the column names are
 893 expected to change in the future.
 894
 895 =cut
 896
 897 sub radius_reply {
 898   my $self = shift;
 899   my %reply =
 900     map {
 901       /^(radius_(.*))$/;
 902       my($column, $attrib) = ($1, $2);
 903       #$attrib =~ s/_/\-/g;
 904       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 905     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 906   if ( $self->slipip && $self->slipip ne '0e0' ) {
 907     $reply{$radius_ip} = $self->slipip;
 908   }
 909   %reply;
 910 }
 911
 912 =item radius_check
 913
 914 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 915 check attributes of this record.
 916
 917 Note that this is now the preferred method for reading RADIUS attributes -
 918 accessing the columns directly is discouraged, as the column names are
 919 expected to change in the future.
 920
 921 =cut
 922
 923 sub radius_check {
 924   my $self = shift;
 925   my $password = $self->_password;
 926   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
 927   ( $pw_attrib => $password,
 928     map {
 929       /^(rc_(.*))$/;
 930       my($column, $attrib) = ($1, $2);
 931       #$attrib =~ s/_/\-/g;
 932       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 933     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 934   );
 935 }
 936
 937 =item domain
 938
 939 Returns the domain associated with this account.
 940
 941 =cut
 942
 943 sub domain {
 944   my $self = shift;
 945   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
 946   my $svc_domain = $self->svc_domain
 947     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 948   $svc_domain->domain;
 949 }
 950
 951 =item svc_domain
 952
 953 Returns the FS::svc_domain record for this account's domain (see
 954 L<FS::svc_domain>).
 955
 956 =cut
 957
 958 sub svc_domain {
 959   my $self = shift;
 960   $self->{'_domsvc'}
 961     ? $self->{'_domsvc'}
 962     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 963 }
 964
 965 =item cust_svc
 966
 967 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 968
 969 =cut
 970
 971 sub cust_svc {
 972   my $self = shift;
 973   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 974 }
 975
 976 =item email
 977
 978 Returns an email address associated with the account.
 979
 980 =cut
 981
 982 sub email {
 983   my $self = shift;
 984   $self->username. '@'. $self->domain;
 985 }
 986
 987 =item acct_snarf
 988
 989 Returns an array of FS::acct_snarf records associated with the account.
 990 If the acct_snarf table does not exist or there are no associated records,
 991 an empty list is returned
 992
 993 =cut
 994
 995 sub acct_snarf {
 996   my $self = shift;
 997   return () unless dbdef->table('acct_snarf');
 998   eval "use FS::acct_snarf;";
 999   die $@ if $@;
1000   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1001 }
1002
1003 =item seconds_since TIMESTAMP
1004
1005 Returns the number of seconds this account has been online since TIMESTAMP,
1006 according to the session monitor (see L<FS::Session>).
1007
1008 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1009 L<Time::Local> and L<Date::Parse> for conversion functions.
1010
1011 =cut
1012
1013 #note: POD here, implementation in FS::cust_svc
1014 sub seconds_since {
1015   my $self = shift;
1016   $self->cust_svc->seconds_since(@_);
1017 }
1018
1019 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1020
1021 Returns the numbers of seconds this account has been online between
1022 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1023 external SQL radacct table, specified via sqlradius export.  Sessions which
1024 started in the specified range but are still open are counted from session
1025 start to the end of the range (unless they are over 1 day old, in which case
1026 they are presumed missing their stop record and not counted).  Also, sessions
1027 which end in the range but started earlier are counted from the start of the
1028 range to session end.  Finally, sessions which start before the range but end
1029 after are counted for the entire range.
1030
1031 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1032 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1033 functions.
1034
1035 =cut
1036
1037 #note: POD here, implementation in FS::cust_svc
1038 sub seconds_since_sqlradacct {
1039   my $self = shift;
1040   $self->cust_svc->seconds_since_sqlradacct(@_);
1041 }
1042
1043 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1044
1045 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1046 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1047 TIMESTAMP_END (exclusive).
1048
1049 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1050 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1051 functions.
1052
1053 =cut
1054
1055 #note: POD here, implementation in FS::cust_svc
1056 sub attribute_since_sqlradacct {
1057   my $self = shift;
1058   $self->cust_svc->attribute_since_sqlradacct(@_);
1059 }
1060
1061 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1062
1063 Returns an array of hash references of this customers login history for the
1064 given time range.  (document this better)
1065
1066 =cut
1067
1068 sub get_session_history_sqlradacct {
1069   my $self = shift;
1070   $self->cust_svc->get_session_history_sqlradacct(@_);
1071 }
1072
1073 =item radius_groups
1074
1075 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1076
1077 =cut
1078
1079 sub radius_groups {
1080   my $self = shift;
1081   if ( $self->usergroup ) {
1082     #when provisioning records, export callback runs in svc_Common.pm before
1083     #radius_usergroup records can be inserted...
1084     @{$self->usergroup};
1085   } else {
1086     map { $_->groupname }
1087       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1088   }
1089 }
1090
1091 =item clone_suspended
1092
1093 Constructor used by FS::part_export::_export_suspend fallback.  Document
1094 better.
1095
1096 =cut
1097
1098 sub clone_suspended {
1099   my $self = shift;
1100   my %hash = $self->hash;
1101   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1102   new FS::svc_acct \%hash;
1103 }
1104
1105 =item clone_kludge_unsuspend
1106
1107 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1108 better.
1109
1110 =cut
1111
1112 sub clone_kludge_unsuspend {
1113   my $self = shift;
1114   my %hash = $self->hash;
1115   $hash{_password} = '';
1116   new FS::svc_acct \%hash;
1117 }
1118
1119 =back
1120
1121 =head1 SUBROUTINES
1122
1123 =over 4
1124
1125 =item send_email
1126
1127 This is the FS::svc_acct job-queue-able version.  It still uses
1128 FS::Misc::send_email under-the-hood.
1129
1130 =cut
1131
1132 sub send_email {
1133   my %opt = @_;
1134
1135   eval "use FS::Misc qw(send_email)";
1136   die $@ if $@;
1137
1138   $opt{mimetype} ||= 'text/plain';
1139   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1140
1141   my $error = send_email(
1142     'from'         => $opt{from},
1143     'to'           => $opt{to},
1144     'subject'      => $opt{subject},
1145     'content-type' => $opt{mimetype},
1146     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1147   );
1148   die $error if $error;
1149 }
1150
1151 =item check_and_rebuild_fuzzyfiles
1152
1153 =cut
1154
1155 sub check_and_rebuild_fuzzyfiles {
1156   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1157   -e "$dir/svc_acct.username"
1158     or &rebuild_fuzzyfiles;
1159 }
1160
1161 =item rebuild_fuzzyfiles
1162
1163 =cut
1164
1165 sub rebuild_fuzzyfiles {
1166
1167   use Fcntl qw(:flock);
1168
1169   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1170
1171   #username
1172
1173   open(USERNAMELOCK,">>$dir/svc_acct.username")
1174     or die "can't open $dir/svc_acct.username: $!";
1175   flock(USERNAMELOCK,LOCK_EX)
1176     or die "can't lock $dir/svc_acct.username: $!";
1177
1178   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1179
1180   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1181     or die "can't open $dir/svc_acct.username.tmp: $!";
1182   print USERNAMECACHE join("\n", @all_username), "\n";
1183   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1184
1185   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1186   close USERNAMELOCK;
1187
1188 }
1189
1190 =item all_username
1191
1192 =cut
1193
1194 sub all_username {
1195   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1196   open(USERNAMECACHE,"<$dir/svc_acct.username")
1197     or die "can't open $dir/svc_acct.username: $!";
1198   my @array = map { chomp; $_; } <USERNAMECACHE>;
1199   close USERNAMECACHE;
1200   \@array;
1201 }
1202
1203 =item append_fuzzyfiles USERNAME
1204
1205 =cut
1206
1207 sub append_fuzzyfiles {
1208   my $username = shift;
1209
1210   &check_and_rebuild_fuzzyfiles;
1211
1212   use Fcntl qw(:flock);
1213
1214   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1215
1216   open(USERNAME,">>$dir/svc_acct.username")
1217     or die "can't open $dir/svc_acct.username: $!";
1218   flock(USERNAME,LOCK_EX)
1219     or die "can't lock $dir/svc_acct.username: $!";
1220
1221   print USERNAME "$username\n";
1222
1223   flock(USERNAME,LOCK_UN)
1224     or die "can't unlock $dir/svc_acct.username: $!";
1225   close USERNAME;
1226
1227   1;
1228 }
1229
1230
1231
1232 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1233
1234 =cut
1235
1236 sub radius_usergroup_selector {
1237   my $sel_groups = shift;
1238   my %sel_groups = map { $_=>1 } @$sel_groups;
1239
1240   my $selectname = shift || 'radius_usergroup';
1241
1242   my $dbh = dbh;
1243   my $sth = $dbh->prepare(
1244     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1245   ) or die $dbh->errstr;
1246   $sth->execute() or die $sth->errstr;
1247   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1248
1249   my $html = <<END;
1250     <SCRIPT>
1251     function ${selectname}_doadd(object) {
1252       var myvalue = object.${selectname}_add.value;
1253       var optionName = new Option(myvalue,myvalue,false,true);
1254       var length = object.$selectname.length;
1255       object.$selectname.options[length] = optionName;
1256       object.${selectname}_add.value = "";
1257     }
1258     </SCRIPT>
1259     <SELECT MULTIPLE NAME="$selectname">
1260 END
1261
1262   foreach my $group ( @all_groups ) {
1263     $html .= '<OPTION';
1264     if ( $sel_groups{$group} ) {
1265       $html .= ' SELECTED';
1266       $sel_groups{$group} = 0;
1267     }
1268     $html .= ">$group</OPTION>\n";
1269   }
1270   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1271     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1272   };
1273   $html .= '</SELECT>';
1274
1275   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1276            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1277
1278   $html;
1279 }
1280
1281 =back
1282
1283 =head1 BUGS
1284
1285 The $recref stuff in sub check should be cleaned up.
1286
1287 The suspend, unsuspend and cancel methods update the database, but not the
1288 current object.  This is probably a bug as it's unexpected and
1289 counterintuitive.
1290
1291 radius_usergroup_selector?  putting web ui components in here?  they should
1292 probably live somewhere else...
1293
1294 insertion of RADIUS group stuff in insert could be done with child_objects now
1295 (would probably clean up export of them too)
1296
1297 =head1 SEE ALSO
1298
1299 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1300 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1301 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1302 L<freeside-queued>), L<FS::svc_acct_pop>,
1303 schema.html from the base documentation.
1304
1305 =cut
1306
1307 1;
1308