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