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