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