FS/FS/svc_acct.pm

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