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