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