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 FS::cust_svc;
  22 use FS::part_svc;
  23 use FS::svc_acct_pop;
  24 use FS::cust_main_invoice;
  25 use FS::svc_domain;
  26 use FS::raddb;
  27 use FS::queue;
  28 use FS::radius_usergroup;
  29 use FS::export_svc;
  30 use FS::part_export;
  31 use FS::Msgcat qw(gettext);
  32
  33 @ISA = qw( FS::svc_Common );
  34
  35 #ask FS::UID to run this stuff for us later
  36 $FS::UID::callback{'FS::svc_acct'} = sub {
  37   $conf = new FS::Conf;
  38   $dir_prefix = $conf->config('home');
  39   @shells = $conf->config('shells');
  40   $usernamemin = $conf->config('usernamemin') || 2;
  41   $usernamemax = $conf->config('usernamemax');
  42   $passwordmin = $conf->config('passwordmin') || 6;
  43   $passwordmax = $conf->config('passwordmax') || 8;
  44   $username_letter = $conf->exists('username-letter');
  45   $username_letterfirst = $conf->exists('username-letterfirst');
  46   $username_noperiod = $conf->exists('username-noperiod');
  47   $username_nounderscore = $conf->exists('username-nounderscore');
  48   $username_nodash = $conf->exists('username-nodash');
  49   $username_uppercase = $conf->exists('username-uppercase');
  50   $username_ampersand = $conf->exists('username-ampersand');
  51   $mydomain = $conf->config('domain');
  52   $dirhash = $conf->config('dirhash') || 0;
  53   if ( $conf->exists('welcome_email') ) {
  54     $welcome_template = new Text::Template (
  55       TYPE   => 'ARRAY',
  56       SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
  57     ) or warn "can't create welcome email template: $Text::Template::ERROR";
  58     $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
  59     $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
  60     $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
  61   } else {
  62     $welcome_template = '';
  63   }
  64   $smtpmachine = $conf->config('smtpmachine');
  65 };
  66
  67 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  68 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  69
  70 sub _cache {
  71   my $self = shift;
  72   my ( $hashref, $cache ) = @_;
  73   if ( $hashref->{'svc_acct_svcnum'} ) {
  74     $self->{'_domsvc'} = FS::svc_domain->new( {
  75       'svcnum'   => $hashref->{'domsvc'},
  76       'domain'   => $hashref->{'svc_acct_domain'},
  77       'catchall' => $hashref->{'svc_acct_catchall'},
  78     } );
  79   }
  80 }
  81
  82 =head1 NAME
  83
  84 FS::svc_acct - Object methods for svc_acct records
  85
  86 =head1 SYNOPSIS
  87
  88   use FS::svc_acct;
  89
  90   $record = new FS::svc_acct \%hash;
  91   $record = new FS::svc_acct { 'column' => 'value' };
  92
  93   $error = $record->insert;
  94
  95   $error = $new_record->replace($old_record);
  96
  97   $error = $record->delete;
  98
  99   $error = $record->check;
 100
 101   $error = $record->suspend;
 102
 103   $error = $record->unsuspend;
 104
 105   $error = $record->cancel;
 106
 107   %hash = $record->radius;
 108
 109   %hash = $record->radius_reply;
 110
 111   %hash = $record->radius_check;
 112
 113   $domain = $record->domain;
 114
 115   $svc_domain = $record->svc_domain;
 116
 117   $email = $record->email;
 118
 119   $seconds_since = $record->seconds_since($timestamp);
 120
 121 =head1 DESCRIPTION
 122
 123 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 124 FS::svc_Common.  The following fields are currently supported:
 125
 126 =over 4
 127
 128 =item svcnum - primary key (assigned automatcially for new accounts)
 129
 130 =item username
 131
 132 =item _password - generated if blank
 133
 134 =item sec_phrase - security phrase
 135
 136 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 137
 138 =item uid
 139
 140 =item gid
 141
 142 =item finger - GECOS
 143
 144 =item dir - set automatically if blank (and uid is not)
 145
 146 =item shell
 147
 148 =item quota - (unimplementd)
 149
 150 =item slipip - IP address
 151
 152 =item seconds -
 153
 154 =item domsvc - svcnum from svc_domain
 155
 156 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
 157
 158 =back
 159
 160 =head1 METHODS
 161
 162 =over 4
 163
 164 =item new HASHREF
 165
 166 Creates a new account.  To add the account to the database, see L<"insert">.
 167
 168 =cut
 169
 170 sub table { 'svc_acct'; }
 171
 172 =item insert
 173
 174 Adds this account to the database.  If there is an error, returns the error,
 175 otherwise returns false.
 176
 177 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 178 defined.  An FS::cust_svc record will be created and inserted.
 179
 180 The additional field I<usergroup> can optionally be defined; if so it should
 181 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 182 sqlradius export only)
 183
 184 (TODOC: L<FS::queue> and L<freeside-queued>)
 185
 186 (TODOC: new exports! $noexport_hack)
 187
 188 =cut
 189
 190 sub insert {
 191   my $self = shift;
 192   my $error;
 193
 194   local $SIG{HUP} = 'IGNORE';
 195   local $SIG{INT} = 'IGNORE';
 196   local $SIG{QUIT} = 'IGNORE';
 197   local $SIG{TERM} = 'IGNORE';
 198   local $SIG{TSTP} = 'IGNORE';
 199   local $SIG{PIPE} = 'IGNORE';
 200
 201   my $oldAutoCommit = $FS::UID::AutoCommit;
 202   local $FS::UID::AutoCommit = 0;
 203   my $dbh = dbh;
 204
 205   $error = $self->check;
 206   return $error if $error;
 207
 208   #no, duplicate checking just got a whole lot more complicated
 209   #(perhaps keep this check with a config option to turn on?)
 210
 211   #return gettext('username_in_use'). ": ". $self->username
 212   #  if qsearchs( 'svc_acct', { 'username' => $self->username,
 213   #                             'domsvc'   => $self->domsvc,
 214   #                           } );
 215
 216   if ( $self->svcnum ) {
 217     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 218     unless ( $cust_svc ) {
 219       $dbh->rollback if $oldAutoCommit;
 220       return "no cust_svc record found for svcnum ". $self->svcnum;
 221     }
 222     $self->pkgnum($cust_svc->pkgnum);
 223     $self->svcpart($cust_svc->svcpart);
 224   }
 225
 226   #new duplicate username checking
 227
 228   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
 229   unless ( $part_svc ) {
 230     $dbh->rollback if $oldAutoCommit;
 231     return 'unknown svcpart '. $self->svcpart;
 232   }
 233
 234   my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
 235   my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
 236                                               'domsvc'   => $self->domsvc } );
 237   my @dup_uid;
 238   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
 239        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
 240     @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
 241   } else {
 242     @dup_uid = ();
 243   }
 244
 245   if ( @dup_user || @dup_userdomain || @dup_uid ) {
 246     my $exports = FS::part_export::export_info('svc_acct');
 247     my %conflict_user_svcpart;
 248     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
 249
 250     foreach my $part_export ( $part_svc->part_export ) {
 251
 252       #this will catch to the same exact export
 253       my @svcparts = map { $_->svcpart }
 254         qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 255
 256       #this will catch to exports w/same exporthost+type ???
 257       #my @other_part_export = qsearch('part_export', {
 258       #  'machine'    => $part_export->machine,
 259       #  'exporttype' => $part_export->exporttype,
 260       #} );
 261       #foreach my $other_part_export ( @other_part_export ) {
 262       #  push @svcparts, map { $_->svcpart }
 263       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 264       #}
 265
 266       my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
 267       if ( $nodomain =~ /^Y/i ) {
 268         $conflict_user_svcpart{$_} = $part_export->exportnum
 269           foreach @svcparts;
 270       } else {
 271         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
 272           foreach @svcparts;
 273       }
 274     }
 275
 276     foreach my $dup_user ( @dup_user ) {
 277       my $dup_svcpart = $dup_user->cust_svc->svcpart;
 278       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
 279         $dbh->rollback if $oldAutoCommit;
 280         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
 281                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
 282       }
 283     }
 284
 285     foreach my $dup_userdomain ( @dup_userdomain ) {
 286       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
 287       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 288         $dbh->rollback if $oldAutoCommit;
 289         return "duplicate username\@domain: conflicts with svcnum ".
 290                $dup_userdomain->svcnum. " via exportnum ".
 291                $conflict_userdomain_svcpart{$dup_svcpart};
 292       }
 293     }
 294
 295     foreach my $dup_uid ( @dup_uid ) {
 296       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
 297       if ( exists($conflict_user_svcpart{$dup_svcpart})
 298            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 299         $dbh->rollback if $oldAutoCommit;
 300         return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
 301                "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
 302                                  || $conflict_userdomain_svcpart{$dup_svcpart};
 303       }
 304     }
 305
 306   }
 307
 308   #see?  i told you it was more complicated
 309
 310   my @jobnums;
 311   $error = $self->SUPER::insert(\@jobnums);
 312   if ( $error ) {
 313     $dbh->rollback if $oldAutoCommit;
 314     return $error;
 315   }
 316
 317   if ( $self->usergroup ) {
 318     foreach my $groupname ( @{$self->usergroup} ) {
 319       my $radius_usergroup = new FS::radius_usergroup ( {
 320         svcnum    => $self->svcnum,
 321         groupname => $groupname,
 322       } );
 323       my $error = $radius_usergroup->insert;
 324       if ( $error ) {
 325         $dbh->rollback if $oldAutoCommit;
 326         return $error;
 327       }
 328     }
 329   }
 330
 331   #false laziness with sub replace (and cust_main)
 332   my $queue = new FS::queue {
 333     'svcnum' => $self->svcnum,
 334     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 335   };
 336   $error = $queue->insert($self->username);
 337   if ( $error ) {
 338     $dbh->rollback if $oldAutoCommit;
 339     return "queueing job (transaction rolled back): $error";
 340   }
 341
 342   my $cust_pkg = $self->cust_svc->cust_pkg;
 343   my $cust_main = $cust_pkg->cust_main;
 344
 345   my $cust_pkg = $self->cust_svc->cust_pkg;
 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   return "Can't delete an account which is a (svc_forward) source!"
 412     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 413
 414   return "Can't delete an account which is a (svc_forward) destination!"
 415     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 416
 417   return "Can't delete an account with (svc_www) web service!"
 418     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
 419
 420   # what about records in session ? (they should refer to history table)
 421
 422   local $SIG{HUP} = 'IGNORE';
 423   local $SIG{INT} = 'IGNORE';
 424   local $SIG{QUIT} = 'IGNORE';
 425   local $SIG{TERM} = 'IGNORE';
 426   local $SIG{TSTP} = 'IGNORE';
 427   local $SIG{PIPE} = 'IGNORE';
 428
 429   my $oldAutoCommit = $FS::UID::AutoCommit;
 430   local $FS::UID::AutoCommit = 0;
 431   my $dbh = dbh;
 432
 433   foreach my $cust_main_invoice (
 434     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 435   ) {
 436     unless ( defined($cust_main_invoice) ) {
 437       warn "WARNING: something's wrong with qsearch";
 438       next;
 439     }
 440     my %hash = $cust_main_invoice->hash;
 441     $hash{'dest'} = $self->email;
 442     my $new = new FS::cust_main_invoice \%hash;
 443     my $error = $new->replace($cust_main_invoice);
 444     if ( $error ) {
 445       $dbh->rollback if $oldAutoCommit;
 446       return $error;
 447     }
 448   }
 449
 450   foreach my $svc_domain (
 451     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 452   ) {
 453     my %hash = new FS::svc_domain->hash;
 454     $hash{'catchall'} = '';
 455     my $new = new FS::svc_domain \%hash;
 456     my $error = $new->replace($svc_domain);
 457     if ( $error ) {
 458       $dbh->rollback if $oldAutoCommit;
 459       return $error;
 460     }
 461   }
 462
 463   foreach my $radius_usergroup (
 464     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 465   ) {
 466     my $error = $radius_usergroup->delete;
 467     if ( $error ) {
 468       $dbh->rollback if $oldAutoCommit;
 469       return $error;
 470     }
 471   }
 472
 473   my $error = $self->SUPER::delete;
 474   if ( $error ) {
 475     $dbh->rollback if $oldAutoCommit;
 476     return $error;
 477   }
 478
 479   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 480   '';
 481 }
 482
 483 =item replace OLD_RECORD
 484
 485 Replaces OLD_RECORD with this one in the database.  If there is an error,
 486 returns the error, otherwise returns false.
 487
 488 The additional field I<usergroup> can optionally be defined; if so it should
 489 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 490 sqlradius export only)
 491
 492 =cut
 493
 494 sub replace {
 495   my ( $new, $old ) = ( shift, shift );
 496   my $error;
 497
 498   return "Username in use"
 499     if $old->username ne $new->username &&
 500       qsearchs( 'svc_acct', { 'username' => $new->username,
 501                                'domsvc'   => $new->domsvc,
 502                              } );
 503   {
 504     #no warnings 'numeric';  #alas, a 5.006-ism
 505     local($^W) = 0;
 506     return "Can't change uid!" if $old->uid != $new->uid;
 507   }
 508
 509   #change homdir when we change username
 510   $new->setfield('dir', '') if $old->username ne $new->username;
 511
 512   local $SIG{HUP} = 'IGNORE';
 513   local $SIG{INT} = 'IGNORE';
 514   local $SIG{QUIT} = 'IGNORE';
 515   local $SIG{TERM} = 'IGNORE';
 516   local $SIG{TSTP} = 'IGNORE';
 517   local $SIG{PIPE} = 'IGNORE';
 518
 519   my $oldAutoCommit = $FS::UID::AutoCommit;
 520   local $FS::UID::AutoCommit = 0;
 521   my $dbh = dbh;
 522
 523   $old->usergroup( [ $old->radius_groups ] );
 524   if ( $new->usergroup ) {
 525     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 526     my @newgroups = @{$new->usergroup};
 527     foreach my $oldgroup ( @{$old->usergroup} ) {
 528       if ( grep { $oldgroup eq $_ } @newgroups ) {
 529         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 530         next;
 531       }
 532       my $radius_usergroup = qsearchs('radius_usergroup', {
 533         svcnum    => $old->svcnum,
 534         groupname => $oldgroup,
 535       } );
 536       my $error = $radius_usergroup->delete;
 537       if ( $error ) {
 538         $dbh->rollback if $oldAutoCommit;
 539         return "error deleting radius_usergroup $oldgroup: $error";
 540       }
 541     }
 542
 543     foreach my $newgroup ( @newgroups ) {
 544       my $radius_usergroup = new FS::radius_usergroup ( {
 545         svcnum    => $new->svcnum,
 546         groupname => $newgroup,
 547       } );
 548       my $error = $radius_usergroup->insert;
 549       if ( $error ) {
 550         $dbh->rollback if $oldAutoCommit;
 551         return "error adding radius_usergroup $newgroup: $error";
 552       }
 553     }
 554
 555   }
 556
 557   $error = $new->SUPER::replace($old);
 558   if ( $error ) {
 559     $dbh->rollback if $oldAutoCommit;
 560     return $error if $error;
 561   }
 562
 563   #false laziness with sub insert (and cust_main)
 564   my $queue = new FS::queue {
 565     'svcnum' => $new->svcnum,
 566     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 567   };
 568   $error = $queue->insert($new->username);
 569   if ( $error ) {
 570     $dbh->rollback if $oldAutoCommit;
 571     return "queueing job (transaction rolled back): $error";
 572   }
 573
 574
 575   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 576   ''; #no error
 577 }
 578
 579 =item suspend
 580
 581 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 582 error, returns the error, otherwise returns false.
 583
 584 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 585
 586 =cut
 587
 588 sub suspend {
 589   my $self = shift;
 590   my %hash = $self->hash;
 591   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 592            || $hash{_password} eq '*'
 593          ) {
 594     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 595     my $new = new FS::svc_acct ( \%hash );
 596     my $error = $new->replace($self);
 597     return $error if $error;
 598   }
 599
 600   $self->SUPER::suspend;
 601 }
 602
 603 =item unsuspend
 604
 605 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 606 an error, returns the error, otherwise returns false.
 607
 608 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 609
 610 =cut
 611
 612 sub unsuspend {
 613   my $self = shift;
 614   my %hash = $self->hash;
 615   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 616     $hash{_password} = $1;
 617     my $new = new FS::svc_acct ( \%hash );
 618     my $error = $new->replace($self);
 619     return $error if $error;
 620   }
 621
 622   $self->SUPER::unsuspend;
 623 }
 624
 625 =item cancel
 626
 627 Just returns false (no error) for now.
 628
 629 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 630
 631 =item check
 632
 633 Checks all fields to make sure this is a valid service.  If there is an error,
 634 returns the error, otherwise returns false.  Called by the insert and replace
 635 methods.
 636
 637 Sets any fixed values; see L<FS::part_svc>.
 638
 639 =cut
 640
 641 sub check {
 642   my $self = shift;
 643
 644   my($recref) = $self->hashref;
 645
 646   my $x = $self->setfixed;
 647   return $x unless ref($x);
 648   my $part_svc = $x;
 649
 650   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 651     $self->usergroup(
 652       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 653   }
 654
 655   my $error = $self->ut_numbern('svcnum')
 656               || $self->ut_number('domsvc')
 657               || $self->ut_textn('sec_phrase')
 658   ;
 659   return $error if $error;
 660
 661   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 662   if ( $username_uppercase ) {
 663     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 664       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 665     $recref->{username} = $1;
 666   } else {
 667     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 668       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 669     $recref->{username} = $1;
 670   }
 671
 672   if ( $username_letterfirst ) {
 673     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 674   } elsif ( $username_letter ) {
 675     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 676   }
 677   if ( $username_noperiod ) {
 678     $recref->{username} =~ /\./ and return gettext('illegal_username');
 679   }
 680   if ( $username_nounderscore ) {
 681     $recref->{username} =~ /_/ and return gettext('illegal_username');
 682   }
 683   if ( $username_nodash ) {
 684     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 685   }
 686   unless ( $username_ampersand ) {
 687     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 688   }
 689
 690   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 691   $recref->{popnum} = $1;
 692   return "Unknown popnum" unless
 693     ! $recref->{popnum} ||
 694     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 695
 696   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 697
 698     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 699     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 700
 701     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 702     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 703     #not all systems use gid=uid
 704     #you can set a fixed gid in part_svc
 705
 706     return "Only root can have uid 0"
 707       if $recref->{uid} == 0
 708          && $recref->{username} ne 'root'
 709          && $recref->{username} ne 'toor';
 710
 711
 712     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 713       or return "Illegal directory: ". $recref->{dir};
 714     $recref->{dir} = $1;
 715     return "Illegal directory"
 716       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 717     return "Illegal directory"
 718       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 719     unless ( $recref->{dir} ) {
 720       $recref->{dir} = $dir_prefix . '/';
 721       if ( $dirhash > 0 ) {
 722         for my $h ( 1 .. $dirhash ) {
 723           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 724         }
 725       } elsif ( $dirhash < 0 ) {
 726         for my $h ( reverse $dirhash .. -1 ) {
 727           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 728         }
 729       }
 730       $recref->{dir} .= $recref->{username};
 731     ;
 732     }
 733
 734     unless ( $recref->{username} eq 'sync' ) {
 735       if ( grep $_ eq $recref->{shell}, @shells ) {
 736         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 737       } else {
 738         return "Illegal shell \`". $self->shell. "\'; ".
 739                $conf->dir. "/shells contains: @shells";
 740       }
 741     } else {
 742       $recref->{shell} = '/bin/sync';
 743     }
 744
 745   } else {
 746     $recref->{gid} ne '' ?
 747       return "Can't have gid without uid" : ( $recref->{gid}='' );
 748     $recref->{dir} ne '' ?
 749       return "Can't have directory without uid" : ( $recref->{dir}='' );
 750     $recref->{shell} ne '' ?
 751       return "Can't have shell without uid" : ( $recref->{shell}='' );
 752   }
 753
 754   #  $error = $self->ut_textn('finger');
 755   #  return $error if $error;
 756   $self->getfield('finger') =~
 757     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 758       or return "Illegal finger: ". $self->getfield('finger');
 759   $self->setfield('finger', $1);
 760
 761   $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
 762   $recref->{quota} = $1;
 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<FS::svc_acct_pop>,
1145 schema.html from the base documentation.
1146
1147 =cut
1148
1149 1;
1150