FS/FS/svc_acct.pm

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