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