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