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,34})$/ ) {
 830     $recref->{_password} = $1.$3;
 831   } elsif ( $recref->{_password} eq '*' ) {
 832     $recref->{_password} = '*';
 833   } elsif ( $recref->{_password} eq '!!' ) {
 834     $recref->{_password} = '!!';
 835   } else {
 836     #return "Illegal password";
 837     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 838            FS::Msgcat::_gettext('illegal_password_characters').
 839            ": ". $recref->{_password};
 840   }
 841
 842   ''; #no error
 843 }
 844
 845 =item radius
 846
 847 Depriciated, use radius_reply instead.
 848
 849 =cut
 850
 851 sub radius {
 852   carp "FS::svc_acct::radius depriciated, use radius_reply";
 853   $_[0]->radius_reply;
 854 }
 855
 856 =item radius_reply
 857
 858 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 859 reply attributes of this record.
 860
 861 Note that this is now the preferred method for reading RADIUS attributes -
 862 accessing the columns directly is discouraged, as the column names are
 863 expected to change in the future.
 864
 865 =cut
 866
 867 sub radius_reply {
 868   my $self = shift;
 869   my %reply =
 870     map {
 871       /^(radius_(.*))$/;
 872       my($column, $attrib) = ($1, $2);
 873       #$attrib =~ s/_/\-/g;
 874       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 875     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 876   if ( $self->slipip && $self->slipip ne '0e0' ) {
 877     $reply{$radius_ip} = $self->slipip;
 878   }
 879   %reply;
 880 }
 881
 882 =item radius_check
 883
 884 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 885 check attributes of this record.
 886
 887 Note that this is now the preferred method for reading RADIUS attributes -
 888 accessing the columns directly is discouraged, as the column names are
 889 expected to change in the future.
 890
 891 =cut
 892
 893 sub radius_check {
 894   my $self = shift;
 895   my $password = $self->_password;
 896   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
 897   ( $pw_attrib => $self->_password,
 898     map {
 899       /^(rc_(.*))$/;
 900       my($column, $attrib) = ($1, $2);
 901       #$attrib =~ s/_/\-/g;
 902       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 903     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 904   );
 905 }
 906
 907 =item domain
 908
 909 Returns the domain associated with this account.
 910
 911 =cut
 912
 913 sub domain {
 914   my $self = shift;
 915   if ( $self->domsvc ) {
 916     #$self->svc_domain->domain;
 917     my $svc_domain = $self->svc_domain
 918       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 919     $svc_domain->domain;
 920   } else {
 921     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
 922   }
 923 }
 924
 925 =item svc_domain
 926
 927 Returns the FS::svc_domain record for this account's domain (see
 928 L<FS::svc_domain>).
 929
 930 =cut
 931
 932 sub svc_domain {
 933   my $self = shift;
 934   $self->{'_domsvc'}
 935     ? $self->{'_domsvc'}
 936     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 937 }
 938
 939 =item cust_svc
 940
 941 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 942
 943 =cut
 944
 945 sub cust_svc {
 946   my $self = shift;
 947   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 948 }
 949
 950 =item email
 951
 952 Returns an email address associated with the account.
 953
 954 =cut
 955
 956 sub email {
 957   my $self = shift;
 958   $self->username. '@'. $self->domain;
 959 }
 960
 961 =item seconds_since TIMESTAMP
 962
 963 Returns the number of seconds this account has been online since TIMESTAMP,
 964 according to the session monitor (see L<FS::Session>).
 965
 966 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 967 L<Time::Local> and L<Date::Parse> for conversion functions.
 968
 969 =cut
 970
 971 #note: POD here, implementation in FS::cust_svc
 972 sub seconds_since {
 973   my $self = shift;
 974   $self->cust_svc->seconds_since(@_);
 975 }
 976
 977 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 978
 979 Returns the numbers of seconds this account has been online between
 980 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
 981 external SQL radacct table, specified via sqlradius export.  Sessions which
 982 started in the specified range but are still open are counted from session
 983 start to the end of the range (unless they are over 1 day old, in which case
 984 they are presumed missing their stop record and not counted).  Also, sessions
 985 which end in the range but started earlier are counted from the start of the
 986 range to session end.  Finally, sessions which start before the range but end
 987 after are counted for the entire range.
 988
 989 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 990 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 991 functions.
 992
 993 =cut
 994
 995 #note: POD here, implementation in FS::cust_svc
 996 sub seconds_since_sqlradacct {
 997   my $self = shift;
 998   $self->cust_svc->seconds_since_sqlradacct(@_);
 999 }
1000
1001 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1002
1003 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1004 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1005 TIMESTAMP_END (exclusive).
1006
1007 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1008 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1009 functions.
1010
1011 =cut
1012
1013 #note: POD here, implementation in FS::cust_svc
1014 sub attribute_since_sqlradacct {
1015   my $self = shift;
1016   $self->cust_svc->attribute_since_sqlradacct(@_);
1017 }
1018
1019
1020 =item radius_groups
1021
1022 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1023
1024 =cut
1025
1026 sub radius_groups {
1027   my $self = shift;
1028   if ( $self->usergroup ) {
1029     #when provisioning records, export callback runs in svc_Common.pm before
1030     #radius_usergroup records can be inserted...
1031     @{$self->usergroup};
1032   } else {
1033     map { $_->groupname }
1034       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1035   }
1036 }
1037
1038 =back
1039
1040 =head1 SUBROUTINES
1041
1042 =over 4
1043
1044 =item send_email
1045
1046 =cut
1047
1048 sub send_email {
1049   my %opt = @_;
1050
1051   use Date::Format;
1052   use Mail::Internet 1.44;
1053   use Mail::Header;
1054
1055   $opt{mimetype} ||= 'text/plain';
1056   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1057
1058   $ENV{MAILADDRESS} = $opt{from};
1059   my $header = new Mail::Header ( [
1060     "From: $opt{from}",
1061     "To: $opt{to}",
1062     "Sender: $opt{from}",
1063     "Reply-To: $opt{from}",
1064     "Date: ". time2str("%a, %d %b %Y %X %z", time),
1065     "Subject: $opt{subject}",
1066     "Content-Type: $opt{mimetype}",
1067   ] );
1068   my $message = new Mail::Internet (
1069     'Header' => $header,
1070     'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1071   );
1072   $!=0;
1073   $message->smtpsend( Host => $smtpmachine )
1074     or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1075       or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1076 }
1077
1078 =item check_and_rebuild_fuzzyfiles
1079
1080 =cut
1081
1082 sub check_and_rebuild_fuzzyfiles {
1083   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1084   -e "$dir/svc_acct.username"
1085     or &rebuild_fuzzyfiles;
1086 }
1087
1088 =item rebuild_fuzzyfiles
1089
1090 =cut
1091
1092 sub rebuild_fuzzyfiles {
1093
1094   use Fcntl qw(:flock);
1095
1096   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1097
1098   #username
1099
1100   open(USERNAMELOCK,">>$dir/svc_acct.username")
1101     or die "can't open $dir/svc_acct.username: $!";
1102   flock(USERNAMELOCK,LOCK_EX)
1103     or die "can't lock $dir/svc_acct.username: $!";
1104
1105   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1106
1107   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1108     or die "can't open $dir/svc_acct.username.tmp: $!";
1109   print USERNAMECACHE join("\n", @all_username), "\n";
1110   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1111
1112   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1113   close USERNAMELOCK;
1114
1115 }
1116
1117 =item all_username
1118
1119 =cut
1120
1121 sub all_username {
1122   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1123   open(USERNAMECACHE,"<$dir/svc_acct.username")
1124     or die "can't open $dir/svc_acct.username: $!";
1125   my @array = map { chomp; $_; } <USERNAMECACHE>;
1126   close USERNAMECACHE;
1127   \@array;
1128 }
1129
1130 =item append_fuzzyfiles USERNAME
1131
1132 =cut
1133
1134 sub append_fuzzyfiles {
1135   my $username = shift;
1136
1137   &check_and_rebuild_fuzzyfiles;
1138
1139   use Fcntl qw(:flock);
1140
1141   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1142
1143   open(USERNAME,">>$dir/svc_acct.username")
1144     or die "can't open $dir/svc_acct.username: $!";
1145   flock(USERNAME,LOCK_EX)
1146     or die "can't lock $dir/svc_acct.username: $!";
1147
1148   print USERNAME "$username\n";
1149
1150   flock(USERNAME,LOCK_UN)
1151     or die "can't unlock $dir/svc_acct.username: $!";
1152   close USERNAME;
1153
1154   1;
1155 }
1156
1157
1158
1159 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1160
1161 =cut
1162
1163 sub radius_usergroup_selector {
1164   my $sel_groups = shift;
1165   my %sel_groups = map { $_=>1 } @$sel_groups;
1166
1167   my $selectname = shift || 'radius_usergroup';
1168
1169   my $dbh = dbh;
1170   my $sth = $dbh->prepare(
1171     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1172   ) or die $dbh->errstr;
1173   $sth->execute() or die $sth->errstr;
1174   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1175
1176   my $html = <<END;
1177     <SCRIPT>
1178     function ${selectname}_doadd(object) {
1179       var myvalue = object.${selectname}_add.value;
1180       var optionName = new Option(myvalue,myvalue,false,true);
1181       var length = object.$selectname.length;
1182       object.$selectname.options[length] = optionName;
1183       object.${selectname}_add.value = "";
1184     }
1185     </SCRIPT>
1186     <SELECT MULTIPLE NAME="$selectname">
1187 END
1188
1189   foreach my $group ( @all_groups ) {
1190     $html .= '<OPTION';
1191     if ( $sel_groups{$group} ) {
1192       $html .= ' SELECTED';
1193       $sel_groups{$group} = 0;
1194     }
1195     $html .= ">$group</OPTION>\n";
1196   }
1197   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1198     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1199   };
1200   $html .= '</SELECT>';
1201
1202   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1203            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1204
1205   $html;
1206 }
1207
1208 =back
1209
1210 =head1 BUGS
1211
1212 The $recref stuff in sub check should be cleaned up.
1213
1214 The suspend, unsuspend and cancel methods update the database, but not the
1215 current object.  This is probably a bug as it's unexpected and
1216 counterintuitive.
1217
1218 radius_usergroup_selector?  putting web ui components in here?  they should
1219 probably live somewhere else...
1220
1221 =head1 SEE ALSO
1222
1223 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1224 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1225 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1226 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1227 schema.html from the base documentation.
1228
1229 =cut
1230
1231 1;
1232