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 radius_groups
1023
1024 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1025
1026 =cut
1027
1028 sub radius_groups {
1029   my $self = shift;
1030   if ( $self->usergroup ) {
1031     #when provisioning records, export callback runs in svc_Common.pm before
1032     #radius_usergroup records can be inserted...
1033     @{$self->usergroup};
1034   } else {
1035     map { $_->groupname }
1036       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1037   }
1038 }
1039
1040 =back
1041
1042 =head1 SUBROUTINES
1043
1044 =over 4
1045
1046 =item send_email
1047
1048 =cut
1049
1050 sub send_email {
1051   my %opt = @_;
1052
1053   use Date::Format;
1054   use Mail::Internet 1.44;
1055   use Mail::Header;
1056
1057   $opt{mimetype} ||= 'text/plain';
1058   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1059
1060   $ENV{MAILADDRESS} = $opt{from};
1061   my $header = new Mail::Header ( [
1062     "From: $opt{from}",
1063     "To: $opt{to}",
1064     "Sender: $opt{from}",
1065     "Reply-To: $opt{from}",
1066     "Date: ". time2str("%a, %d %b %Y %X %z", time),
1067     "Subject: $opt{subject}",
1068     "Content-Type: $opt{mimetype}",
1069   ] );
1070   my $message = new Mail::Internet (
1071     'Header' => $header,
1072     'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1073   );
1074   $!=0;
1075   $message->smtpsend( Host => $smtpmachine )
1076     or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1077       or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1078 }
1079
1080 =item check_and_rebuild_fuzzyfiles
1081
1082 =cut
1083
1084 sub check_and_rebuild_fuzzyfiles {
1085   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1086   -e "$dir/svc_acct.username"
1087     or &rebuild_fuzzyfiles;
1088 }
1089
1090 =item rebuild_fuzzyfiles
1091
1092 =cut
1093
1094 sub rebuild_fuzzyfiles {
1095
1096   use Fcntl qw(:flock);
1097
1098   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1099
1100   #username
1101
1102   open(USERNAMELOCK,">>$dir/svc_acct.username")
1103     or die "can't open $dir/svc_acct.username: $!";
1104   flock(USERNAMELOCK,LOCK_EX)
1105     or die "can't lock $dir/svc_acct.username: $!";
1106
1107   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1108
1109   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1110     or die "can't open $dir/svc_acct.username.tmp: $!";
1111   print USERNAMECACHE join("\n", @all_username), "\n";
1112   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1113
1114   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1115   close USERNAMELOCK;
1116
1117 }
1118
1119 =item all_username
1120
1121 =cut
1122
1123 sub all_username {
1124   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1125   open(USERNAMECACHE,"<$dir/svc_acct.username")
1126     or die "can't open $dir/svc_acct.username: $!";
1127   my @array = map { chomp; $_; } <USERNAMECACHE>;
1128   close USERNAMECACHE;
1129   \@array;
1130 }
1131
1132 =item append_fuzzyfiles USERNAME
1133
1134 =cut
1135
1136 sub append_fuzzyfiles {
1137   my $username = shift;
1138
1139   &check_and_rebuild_fuzzyfiles;
1140
1141   use Fcntl qw(:flock);
1142
1143   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1144
1145   open(USERNAME,">>$dir/svc_acct.username")
1146     or die "can't open $dir/svc_acct.username: $!";
1147   flock(USERNAME,LOCK_EX)
1148     or die "can't lock $dir/svc_acct.username: $!";
1149
1150   print USERNAME "$username\n";
1151
1152   flock(USERNAME,LOCK_UN)
1153     or die "can't unlock $dir/svc_acct.username: $!";
1154   close USERNAME;
1155
1156   1;
1157 }
1158
1159
1160
1161 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1162
1163 =cut
1164
1165 sub radius_usergroup_selector {
1166   my $sel_groups = shift;
1167   my %sel_groups = map { $_=>1 } @$sel_groups;
1168
1169   my $selectname = shift || 'radius_usergroup';
1170
1171   my $dbh = dbh;
1172   my $sth = $dbh->prepare(
1173     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1174   ) or die $dbh->errstr;
1175   $sth->execute() or die $sth->errstr;
1176   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1177
1178   my $html = <<END;
1179     <SCRIPT>
1180     function ${selectname}_doadd(object) {
1181       var myvalue = object.${selectname}_add.value;
1182       var optionName = new Option(myvalue,myvalue,false,true);
1183       var length = object.$selectname.length;
1184       object.$selectname.options[length] = optionName;
1185       object.${selectname}_add.value = "";
1186     }
1187     </SCRIPT>
1188     <SELECT MULTIPLE NAME="$selectname">
1189 END
1190
1191   foreach my $group ( @all_groups ) {
1192     $html .= '<OPTION';
1193     if ( $sel_groups{$group} ) {
1194       $html .= ' SELECTED';
1195       $sel_groups{$group} = 0;
1196     }
1197     $html .= ">$group</OPTION>\n";
1198   }
1199   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1200     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1201   };
1202   $html .= '</SELECT>';
1203
1204   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1205            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1206
1207   $html;
1208 }
1209
1210 =back
1211
1212 =head1 BUGS
1213
1214 The $recref stuff in sub check should be cleaned up.
1215
1216 The suspend, unsuspend and cancel methods update the database, but not the
1217 current object.  This is probably a bug as it's unexpected and
1218 counterintuitive.
1219
1220 radius_usergroup_selector?  putting web ui components in here?  they should
1221 probably live somewhere else...
1222
1223 =head1 SEE ALSO
1224
1225 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1226 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1227 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1228 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1229 schema.html from the base documentation.
1230
1231 =cut
1232
1233 1;
1234