FS/FS/svc_acct.pm

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