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