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