FS/FS/svc_acct.pm

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