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