FS/FS/svc_acct.pm

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