FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $conf
   5              $dir_prefix @shells $usernamemin
   6              $usernamemax $passwordmin $passwordmax
   7              $username_ampersand $username_letter $username_letterfirst
   8              $username_noperiod $username_nounderscore $username_nodash
   9              $username_uppercase
  10              $welcome_template $welcome_from $welcome_subject $welcome_mimetype
  11              $smtpmachine
  12              $radius_password $radius_ip
  13              $dirhash
  14              @saltset @pw_set );
  15 use Carp;
  16 use Fcntl qw(:flock);
  17 use FS::UID qw( datasrc );
  18 use FS::Conf;
  19 use FS::Record qw( qsearch qsearchs fields dbh );
  20 use FS::svc_Common;
  21 use FS::cust_svc;
  22 use FS::part_svc;
  23 use FS::svc_acct_pop;
  24 use FS::cust_main_invoice;
  25 use FS::svc_domain;
  26 use FS::raddb;
  27 use FS::queue;
  28 use FS::radius_usergroup;
  29 use FS::export_svc;
  30 use FS::part_export;
  31 use FS::Msgcat qw(gettext);
  32
  33 @ISA = qw( FS::svc_Common );
  34
  35 $DEBUG = 0;
  36 $me = '[FS::svc_acct]';
  37
  38 #ask FS::UID to run this stuff for us later
  39 $FS::UID::callback{'FS::svc_acct'} = sub {
  40   $conf = new FS::Conf;
  41   $dir_prefix = $conf->config('home');
  42   @shells = $conf->config('shells');
  43   $usernamemin = $conf->config('usernamemin') || 2;
  44   $usernamemax = $conf->config('usernamemax');
  45   $passwordmin = $conf->config('passwordmin') || 6;
  46   $passwordmax = $conf->config('passwordmax') || 8;
  47   $username_letter = $conf->exists('username-letter');
  48   $username_letterfirst = $conf->exists('username-letterfirst');
  49   $username_noperiod = $conf->exists('username-noperiod');
  50   $username_nounderscore = $conf->exists('username-nounderscore');
  51   $username_nodash = $conf->exists('username-nodash');
  52   $username_uppercase = $conf->exists('username-uppercase');
  53   $username_ampersand = $conf->exists('username-ampersand');
  54   $dirhash = $conf->config('dirhash') || 0;
  55   if ( $conf->exists('welcome_email') ) {
  56     $welcome_template = new Text::Template (
  57       TYPE   => 'ARRAY',
  58       SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
  59     ) or warn "can't create welcome email template: $Text::Template::ERROR";
  60     $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
  61     $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
  62     $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
  63   } else {
  64     $welcome_template = '';
  65     $welcome_from = '';
  66     $welcome_subject = '';
  67     $welcome_mimetype = '';
  68   }
  69   $smtpmachine = $conf->config('smtpmachine');
  70   $radius_password = $conf->config('radius-password') || 'Password';
  71   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  72 };
  73
  74 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  75 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  76
  77 sub _cache {
  78   my $self = shift;
  79   my ( $hashref, $cache ) = @_;
  80   if ( $hashref->{'svc_acct_svcnum'} ) {
  81     $self->{'_domsvc'} = FS::svc_domain->new( {
  82       'svcnum'   => $hashref->{'domsvc'},
  83       'domain'   => $hashref->{'svc_acct_domain'},
  84       'catchall' => $hashref->{'svc_acct_catchall'},
  85     } );
  86   }
  87 }
  88
  89 =head1 NAME
  90
  91 FS::svc_acct - Object methods for svc_acct records
  92
  93 =head1 SYNOPSIS
  94
  95   use FS::svc_acct;
  96
  97   $record = new FS::svc_acct \%hash;
  98   $record = new FS::svc_acct { 'column' => 'value' };
  99
 100   $error = $record->insert;
 101
 102   $error = $new_record->replace($old_record);
 103
 104   $error = $record->delete;
 105
 106   $error = $record->check;
 107
 108   $error = $record->suspend;
 109
 110   $error = $record->unsuspend;
 111
 112   $error = $record->cancel;
 113
 114   %hash = $record->radius;
 115
 116   %hash = $record->radius_reply;
 117
 118   %hash = $record->radius_check;
 119
 120   $domain = $record->domain;
 121
 122   $svc_domain = $record->svc_domain;
 123
 124   $email = $record->email;
 125
 126   $seconds_since = $record->seconds_since($timestamp);
 127
 128 =head1 DESCRIPTION
 129
 130 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 131 FS::svc_Common.  The following fields are currently supported:
 132
 133 =over 4
 134
 135 =item svcnum - primary key (assigned automatcially for new accounts)
 136
 137 =item username
 138
 139 =item _password - generated if blank
 140
 141 =item sec_phrase - security phrase
 142
 143 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 144
 145 =item uid
 146
 147 =item gid
 148
 149 =item finger - GECOS
 150
 151 =item dir - set automatically if blank (and uid is not)
 152
 153 =item shell
 154
 155 =item quota - (unimplementd)
 156
 157 =item slipip - IP address
 158
 159 =item seconds -
 160
 161 =item domsvc - svcnum from svc_domain
 162
 163 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
 164
 165 =back
 166
 167 =head1 METHODS
 168
 169 =over 4
 170
 171 =item new HASHREF
 172
 173 Creates a new account.  To add the account to the database, see L<"insert">.
 174
 175 =cut
 176
 177 sub table { 'svc_acct'; }
 178
 179 =item insert
 180
 181 Adds this account to the database.  If there is an error, returns the error,
 182 otherwise returns false.
 183
 184 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 185 defined.  An FS::cust_svc record will be created and inserted.
 186
 187 The additional field I<usergroup> can optionally be defined; if so it should
 188 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 189 sqlradius export only)
 190
 191 (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   return "Can't delete an account which is a (svc_forward) source!"
 425     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 426
 427   return "Can't delete an account which is a (svc_forward) destination!"
 428     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 429
 430   return "Can't delete an account with (svc_www) web service!"
 431     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
 432
 433   # what about records in session ? (they should refer to history table)
 434
 435   local $SIG{HUP} = 'IGNORE';
 436   local $SIG{INT} = 'IGNORE';
 437   local $SIG{QUIT} = 'IGNORE';
 438   local $SIG{TERM} = 'IGNORE';
 439   local $SIG{TSTP} = 'IGNORE';
 440   local $SIG{PIPE} = 'IGNORE';
 441
 442   my $oldAutoCommit = $FS::UID::AutoCommit;
 443   local $FS::UID::AutoCommit = 0;
 444   my $dbh = dbh;
 445
 446   foreach my $cust_main_invoice (
 447     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 448   ) {
 449     unless ( defined($cust_main_invoice) ) {
 450       warn "WARNING: something's wrong with qsearch";
 451       next;
 452     }
 453     my %hash = $cust_main_invoice->hash;
 454     $hash{'dest'} = $self->email;
 455     my $new = new FS::cust_main_invoice \%hash;
 456     my $error = $new->replace($cust_main_invoice);
 457     if ( $error ) {
 458       $dbh->rollback if $oldAutoCommit;
 459       return $error;
 460     }
 461   }
 462
 463   foreach my $svc_domain (
 464     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 465   ) {
 466     my %hash = new FS::svc_domain->hash;
 467     $hash{'catchall'} = '';
 468     my $new = new FS::svc_domain \%hash;
 469     my $error = $new->replace($svc_domain);
 470     if ( $error ) {
 471       $dbh->rollback if $oldAutoCommit;
 472       return $error;
 473     }
 474   }
 475
 476   foreach my $radius_usergroup (
 477     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 478   ) {
 479     my $error = $radius_usergroup->delete;
 480     if ( $error ) {
 481       $dbh->rollback if $oldAutoCommit;
 482       return $error;
 483     }
 484   }
 485
 486   my $error = $self->SUPER::delete;
 487   if ( $error ) {
 488     $dbh->rollback if $oldAutoCommit;
 489     return $error;
 490   }
 491
 492   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 493   '';
 494 }
 495
 496 =item replace OLD_RECORD
 497
 498 Replaces OLD_RECORD with this one in the database.  If there is an error,
 499 returns the error, otherwise returns false.
 500
 501 The additional field I<usergroup> can optionally be defined; if so it should
 502 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 503 sqlradius export only)
 504
 505 =cut
 506
 507 sub replace {
 508   my ( $new, $old ) = ( shift, shift );
 509   my $error;
 510   warn "$me replacing $old with $new\n" if $DEBUG;
 511
 512   return "Username in use"
 513     if $old->username ne $new->username &&
 514       qsearchs( 'svc_acct', { 'username' => $new->username,
 515                                'domsvc'   => $new->domsvc,
 516                              } );
 517   {
 518     #no warnings 'numeric';  #alas, a 5.006-ism
 519     local($^W) = 0;
 520     return "Can't change uid!" if $old->uid != $new->uid;
 521   }
 522
 523   #change homdir when we change username
 524   $new->setfield('dir', '') if $old->username ne $new->username;
 525
 526   local $SIG{HUP} = 'IGNORE';
 527   local $SIG{INT} = 'IGNORE';
 528   local $SIG{QUIT} = 'IGNORE';
 529   local $SIG{TERM} = 'IGNORE';
 530   local $SIG{TSTP} = 'IGNORE';
 531   local $SIG{PIPE} = 'IGNORE';
 532
 533   my $oldAutoCommit = $FS::UID::AutoCommit;
 534   local $FS::UID::AutoCommit = 0;
 535   my $dbh = dbh;
 536
 537   # redundant, but so $new->usergroup gets set
 538   $error = $new->check;
 539   return $error if $error;
 540
 541   $old->usergroup( [ $old->radius_groups ] );
 542   warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
 543   warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
 544   if ( $new->usergroup ) {
 545     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 546     my @newgroups = @{$new->usergroup};
 547     foreach my $oldgroup ( @{$old->usergroup} ) {
 548       if ( grep { $oldgroup eq $_ } @newgroups ) {
 549         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 550         next;
 551       }
 552       my $radius_usergroup = qsearchs('radius_usergroup', {
 553         svcnum    => $old->svcnum,
 554         groupname => $oldgroup,
 555       } );
 556       my $error = $radius_usergroup->delete;
 557       if ( $error ) {
 558         $dbh->rollback if $oldAutoCommit;
 559         return "error deleting radius_usergroup $oldgroup: $error";
 560       }
 561     }
 562
 563     foreach my $newgroup ( @newgroups ) {
 564       my $radius_usergroup = new FS::radius_usergroup ( {
 565         svcnum    => $new->svcnum,
 566         groupname => $newgroup,
 567       } );
 568       my $error = $radius_usergroup->insert;
 569       if ( $error ) {
 570         $dbh->rollback if $oldAutoCommit;
 571         return "error adding radius_usergroup $newgroup: $error";
 572       }
 573     }
 574
 575   }
 576
 577   $error = $new->SUPER::replace($old);
 578   if ( $error ) {
 579     $dbh->rollback if $oldAutoCommit;
 580     return $error if $error;
 581   }
 582
 583   if ( $new->username ne $old->username ) {
 584     #false laziness with sub insert (and cust_main)
 585     my $queue = new FS::queue {
 586       'svcnum' => $new->svcnum,
 587       'job'    => 'FS::svc_acct::append_fuzzyfiles'
 588     };
 589     $error = $queue->insert($new->username);
 590     if ( $error ) {
 591       $dbh->rollback if $oldAutoCommit;
 592       return "queueing job (transaction rolled back): $error";
 593     }
 594   }
 595
 596   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 597   ''; #no error
 598 }
 599
 600 =item suspend
 601
 602 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 603 error, returns the error, otherwise returns false.
 604
 605 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 606
 607 Calls any export-specific suspend hooks.
 608
 609 =cut
 610
 611 sub suspend {
 612   my $self = shift;
 613   my %hash = $self->hash;
 614   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 615            || $hash{_password} eq '*'
 616          ) {
 617     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 618     my $new = new FS::svc_acct ( \%hash );
 619     my $error = $new->replace($self);
 620     return $error if $error;
 621   }
 622
 623   $self->SUPER::suspend;
 624 }
 625
 626 =item unsuspend
 627
 628 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 629 an error, returns the error, otherwise returns false.
 630
 631 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 632
 633 Calls any export-specific unsuspend hooks.
 634
 635 =cut
 636
 637 sub unsuspend {
 638   my $self = shift;
 639   my %hash = $self->hash;
 640   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 641     $hash{_password} = $1;
 642     my $new = new FS::svc_acct ( \%hash );
 643     my $error = $new->replace($self);
 644     return $error if $error;
 645   }
 646
 647   $self->SUPER::unsuspend;
 648 }
 649
 650 =item cancel
 651
 652 Just returns false (no error) for now.
 653
 654 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 655
 656 =item check
 657
 658 Checks all fields to make sure this is a valid service.  If there is an error,
 659 returns the error, otherwise returns false.  Called by the insert and replace
 660 methods.
 661
 662 Sets any fixed values; see L<FS::part_svc>.
 663
 664 =cut
 665
 666 sub check {
 667   my $self = shift;
 668
 669   my($recref) = $self->hashref;
 670
 671   my $x = $self->setfixed;
 672   return $x unless ref($x);
 673   my $part_svc = $x;
 674
 675   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 676     $self->usergroup(
 677       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 678   }
 679
 680   my $error = $self->ut_numbern('svcnum')
 681               #|| $self->ut_number('domsvc')
 682               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 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     if ( $recref->{slipip} eq '' ) {
 792       $recref->{slipip} = '';
 793     } elsif ( $recref->{slipip} eq '0e0' ) {
 794       $recref->{slipip} = '0e0';
 795     } else {
 796       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 797         or return "Illegal slipip: ". $self->slipip;
 798       $recref->{slipip} = $1;
 799     }
 800
 801   }
 802
 803   #arbitrary RADIUS stuff; allow ut_textn for now
 804   foreach ( grep /^radius_/, fields('svc_acct') ) {
 805     $self->ut_textn($_);
 806   }
 807
 808   #generate a password if it is blank
 809   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 810     unless ( $recref->{_password} );
 811
 812   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 813   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 814     $recref->{_password} = $1.$3;
 815     #uncomment this to encrypt password immediately upon entry, or run
 816     #bin/crypt_pw in cron to give new users a window during which their
 817     #password is available to techs, for faxing, etc.  (also be aware of
 818     #radius issues!)
 819     #$recref->{password} = $1.
 820     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 821     #;
 822   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 823     $recref->{_password} = $1.$3;
 824   } elsif ( $recref->{_password} eq '*' ) {
 825     $recref->{_password} = '*';
 826   } elsif ( $recref->{_password} eq '!' ) {
 827     $recref->{_password} = '!';
 828   } elsif ( $recref->{_password} eq '!!' ) {
 829     $recref->{_password} = '!!';
 830   } else {
 831     #return "Illegal password";
 832     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 833            FS::Msgcat::_gettext('illegal_password_characters').
 834            ": ". $recref->{_password};
 835   }
 836
 837   $self->SUPER::check;
 838 }
 839
 840 =item radius
 841
 842 Depriciated, use radius_reply instead.
 843
 844 =cut
 845
 846 sub radius {
 847   carp "FS::svc_acct::radius depriciated, use radius_reply";
 848   $_[0]->radius_reply;
 849 }
 850
 851 =item radius_reply
 852
 853 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 854 reply attributes of this record.
 855
 856 Note that this is now the preferred method for reading RADIUS attributes -
 857 accessing the columns directly is discouraged, as the column names are
 858 expected to change in the future.
 859
 860 =cut
 861
 862 sub radius_reply {
 863   my $self = shift;
 864   my %reply =
 865     map {
 866       /^(radius_(.*))$/;
 867       my($column, $attrib) = ($1, $2);
 868       #$attrib =~ s/_/\-/g;
 869       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 870     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 871   if ( $self->slipip && $self->slipip ne '0e0' ) {
 872     $reply{$radius_ip} = $self->slipip;
 873   }
 874   %reply;
 875 }
 876
 877 =item radius_check
 878
 879 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 880 check attributes of this record.
 881
 882 Note that this is now the preferred method for reading RADIUS attributes -
 883 accessing the columns directly is discouraged, as the column names are
 884 expected to change in the future.
 885
 886 =cut
 887
 888 sub radius_check {
 889   my $self = shift;
 890   my $password = $self->_password;
 891   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
 892   ( $pw_attrib => $password,
 893     map {
 894       /^(rc_(.*))$/;
 895       my($column, $attrib) = ($1, $2);
 896       #$attrib =~ s/_/\-/g;
 897       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 898     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 899   );
 900 }
 901
 902 =item domain
 903
 904 Returns the domain associated with this account.
 905
 906 =cut
 907
 908 sub domain {
 909   my $self = shift;
 910   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
 911   my $svc_domain = $self->svc_domain
 912     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 913   $svc_domain->domain;
 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 =cut
 935
 936 sub cust_svc {
 937   my $self = shift;
 938   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 939 }
 940
 941 =item email
 942
 943 Returns an email address associated with the account.
 944
 945 =cut
 946
 947 sub email {
 948   my $self = shift;
 949   $self->username. '@'. $self->domain;
 950 }
 951
 952 =item seconds_since TIMESTAMP
 953
 954 Returns the number of seconds this account has been online since TIMESTAMP,
 955 according to the session monitor (see L<FS::Session>).
 956
 957 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 958 L<Time::Local> and L<Date::Parse> for conversion functions.
 959
 960 =cut
 961
 962 #note: POD here, implementation in FS::cust_svc
 963 sub seconds_since {
 964   my $self = shift;
 965   $self->cust_svc->seconds_since(@_);
 966 }
 967
 968 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 969
 970 Returns the numbers of seconds this account has been online between
 971 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
 972 external SQL radacct table, specified via sqlradius export.  Sessions which
 973 started in the specified range but are still open are counted from session
 974 start to the end of the range (unless they are over 1 day old, in which case
 975 they are presumed missing their stop record and not counted).  Also, sessions
 976 which end in the range but started earlier are counted from the start of the
 977 range to session end.  Finally, sessions which start before the range but end
 978 after are counted for the entire range.
 979
 980 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 981 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 982 functions.
 983
 984 =cut
 985
 986 #note: POD here, implementation in FS::cust_svc
 987 sub seconds_since_sqlradacct {
 988   my $self = shift;
 989   $self->cust_svc->seconds_since_sqlradacct(@_);
 990 }
 991
 992 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 993
 994 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 995 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 996 TIMESTAMP_END (exclusive).
 997
 998 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 999 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1000 functions.
1001
1002 =cut
1003
1004 #note: POD here, implementation in FS::cust_svc
1005 sub attribute_since_sqlradacct {
1006   my $self = shift;
1007   $self->cust_svc->attribute_since_sqlradacct(@_);
1008 }
1009
1010 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1011
1012 Returns an array of hash references of this customers login history for the
1013 given time range.  (document this better)
1014
1015 =cut
1016
1017 sub get_session_history {
1018   my $self = shift;
1019   $self->cust_svc->get_session_history(@_);
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 This is the FS::svc_acct job-queue-able version.  It still uses
1049 FS::Misc::send_email under-the-hood.
1050
1051 =cut
1052
1053 sub send_email {
1054   my %opt = @_;
1055
1056   eval "use FS::Misc qw(send_email)";
1057   die $@ if $@;
1058
1059   $opt{mimetype} ||= 'text/plain';
1060   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1061
1062   my $error = send_email(
1063     'from'         => $opt{from},
1064     'to'           => $opt{to},
1065     'subject'      => $opt{subject},
1066     'content-type' => $opt{mimetype},
1067     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1068   );
1069   die $error if $error;
1070 }
1071
1072 =item check_and_rebuild_fuzzyfiles
1073
1074 =cut
1075
1076 sub check_and_rebuild_fuzzyfiles {
1077   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1078   -e "$dir/svc_acct.username"
1079     or &rebuild_fuzzyfiles;
1080 }
1081
1082 =item rebuild_fuzzyfiles
1083
1084 =cut
1085
1086 sub rebuild_fuzzyfiles {
1087
1088   use Fcntl qw(:flock);
1089
1090   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1091
1092   #username
1093
1094   open(USERNAMELOCK,">>$dir/svc_acct.username")
1095     or die "can't open $dir/svc_acct.username: $!";
1096   flock(USERNAMELOCK,LOCK_EX)
1097     or die "can't lock $dir/svc_acct.username: $!";
1098
1099   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1100
1101   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1102     or die "can't open $dir/svc_acct.username.tmp: $!";
1103   print USERNAMECACHE join("\n", @all_username), "\n";
1104   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1105
1106   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1107   close USERNAMELOCK;
1108
1109 }
1110
1111 =item all_username
1112
1113 =cut
1114
1115 sub all_username {
1116   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1117   open(USERNAMECACHE,"<$dir/svc_acct.username")
1118     or die "can't open $dir/svc_acct.username: $!";
1119   my @array = map { chomp; $_; } <USERNAMECACHE>;
1120   close USERNAMECACHE;
1121   \@array;
1122 }
1123
1124 =item append_fuzzyfiles USERNAME
1125
1126 =cut
1127
1128 sub append_fuzzyfiles {
1129   my $username = shift;
1130
1131   &check_and_rebuild_fuzzyfiles;
1132
1133   use Fcntl qw(:flock);
1134
1135   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1136
1137   open(USERNAME,">>$dir/svc_acct.username")
1138     or die "can't open $dir/svc_acct.username: $!";
1139   flock(USERNAME,LOCK_EX)
1140     or die "can't lock $dir/svc_acct.username: $!";
1141
1142   print USERNAME "$username\n";
1143
1144   flock(USERNAME,LOCK_UN)
1145     or die "can't unlock $dir/svc_acct.username: $!";
1146   close USERNAME;
1147
1148   1;
1149 }
1150
1151
1152
1153 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1154
1155 =cut
1156
1157 sub radius_usergroup_selector {
1158   my $sel_groups = shift;
1159   my %sel_groups = map { $_=>1 } @$sel_groups;
1160
1161   my $selectname = shift || 'radius_usergroup';
1162
1163   my $dbh = dbh;
1164   my $sth = $dbh->prepare(
1165     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1166   ) or die $dbh->errstr;
1167   $sth->execute() or die $sth->errstr;
1168   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1169
1170   my $html = <<END;
1171     <SCRIPT>
1172     function ${selectname}_doadd(object) {
1173       var myvalue = object.${selectname}_add.value;
1174       var optionName = new Option(myvalue,myvalue,false,true);
1175       var length = object.$selectname.length;
1176       object.$selectname.options[length] = optionName;
1177       object.${selectname}_add.value = "";
1178     }
1179     </SCRIPT>
1180     <SELECT MULTIPLE NAME="$selectname">
1181 END
1182
1183   foreach my $group ( @all_groups ) {
1184     $html .= '<OPTION';
1185     if ( $sel_groups{$group} ) {
1186       $html .= ' SELECTED';
1187       $sel_groups{$group} = 0;
1188     }
1189     $html .= ">$group</OPTION>\n";
1190   }
1191   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1192     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1193   };
1194   $html .= '</SELECT>';
1195
1196   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1197            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1198
1199   $html;
1200 }
1201
1202 =back
1203
1204 =head1 BUGS
1205
1206 The $recref stuff in sub check should be cleaned up.
1207
1208 The suspend, unsuspend and cancel methods update the database, but not the
1209 current object.  This is probably a bug as it's unexpected and
1210 counterintuitive.
1211
1212 radius_usergroup_selector?  putting web ui components in here?  they should
1213 probably live somewhere else...
1214
1215 =head1 SEE ALSO
1216
1217 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1218 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1219 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1220 L<freeside-queued>), L<FS::svc_acct_pop>,
1221 schema.html from the base documentation.
1222
1223 =cut
1224
1225 1;
1226