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