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,34})$/ ) {
 823     $recref->{_password} = $1.$3;
 824   } elsif ( $recref->{_password} eq '*' ) {
 825     $recref->{_password} = '*';
 826   } elsif ( $recref->{_password} eq '!!' ) {
 827     $recref->{_password} = '!!';
 828   } else {
 829     #return "Illegal password";
 830     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 831            FS::Msgcat::_gettext('illegal_password_characters').
 832            ": ". $recref->{_password};
 833   }
 834
 835   ''; #no error
 836 }
 837
 838 =item radius
 839
 840 Depriciated, use radius_reply instead.
 841
 842 =cut
 843
 844 sub radius {
 845   carp "FS::svc_acct::radius depriciated, use radius_reply";
 846   $_[0]->radius_reply;
 847 }
 848
 849 =item radius_reply
 850
 851 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 852 reply attributes of this record.
 853
 854 Note that this is now the preferred method for reading RADIUS attributes -
 855 accessing the columns directly is discouraged, as the column names are
 856 expected to change in the future.
 857
 858 =cut
 859
 860 sub radius_reply {
 861   my $self = shift;
 862   my %reply =
 863     map {
 864       /^(radius_(.*))$/;
 865       my($column, $attrib) = ($1, $2);
 866       #$attrib =~ s/_/\-/g;
 867       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 868     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 869   if ( $self->slipip && $self->slipip ne '0e0' ) {
 870     $reply{$radius_ip} = $self->slipip;
 871   }
 872   %reply;
 873 }
 874
 875 =item radius_check
 876
 877 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 878 check attributes of this record.
 879
 880 Note that this is now the preferred method for reading RADIUS attributes -
 881 accessing the columns directly is discouraged, as the column names are
 882 expected to change in the future.
 883
 884 =cut
 885
 886 sub radius_check {
 887   my $self = shift;
 888   my $password = $self->_password;
 889   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
 890   ( $pw_attrib => $password,
 891     map {
 892       /^(rc_(.*))$/;
 893       my($column, $attrib) = ($1, $2);
 894       #$attrib =~ s/_/\-/g;
 895       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 896     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 897   );
 898 }
 899
 900 =item domain
 901
 902 Returns the domain associated with this account.
 903
 904 =cut
 905
 906 sub domain {
 907   my $self = shift;
 908   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
 909   my $svc_domain = $self->svc_domain
 910     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 911   $svc_domain->domain;
 912 }
 913
 914 =item svc_domain
 915
 916 Returns the FS::svc_domain record for this account's domain (see
 917 L<FS::svc_domain>).
 918
 919 =cut
 920
 921 sub svc_domain {
 922   my $self = shift;
 923   $self->{'_domsvc'}
 924     ? $self->{'_domsvc'}
 925     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 926 }
 927
 928 =item cust_svc
 929
 930 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 931
 932 =cut
 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 therange 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 =item radius_groups
1009
1010 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1011
1012 =cut
1013
1014 sub radius_groups {
1015   my $self = shift;
1016   if ( $self->usergroup ) {
1017     #when provisioning records, export callback runs in svc_Common.pm before
1018     #radius_usergroup records can be inserted...
1019     @{$self->usergroup};
1020   } else {
1021     map { $_->groupname }
1022       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1023   }
1024 }
1025
1026 =back
1027
1028 =head1 SUBROUTINES
1029
1030 =over 4
1031
1032 =item send_email
1033
1034 This is the FS::svc_acct job-queue-able version.  It still uses
1035 FS::Misc::send_email under-the-hood.
1036
1037 =cut
1038
1039 sub send_email {
1040   my %opt = @_;
1041
1042   eval "use FS::Misc qw(send_email)";
1043   die $@ if $@;
1044
1045   $opt{mimetype} ||= 'text/plain';
1046   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1047
1048   my $error = send_email(
1049     'from'         => $opt{from},
1050     'to'           => $opt{to},
1051     'subject'      => $opt{subject},
1052     'content-type' => $opt{mimetype},
1053     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1054   );
1055   die $error if $error;
1056 }
1057
1058 =item check_and_rebuild_fuzzyfiles
1059
1060 =cut
1061
1062 sub check_and_rebuild_fuzzyfiles {
1063   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1064   -e "$dir/svc_acct.username"
1065     or &rebuild_fuzzyfiles;
1066 }
1067
1068 =item rebuild_fuzzyfiles
1069
1070 =cut
1071
1072 sub rebuild_fuzzyfiles {
1073
1074   use Fcntl qw(:flock);
1075
1076   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1077
1078   #username
1079
1080   open(USERNAMELOCK,">>$dir/svc_acct.username")
1081     or die "can't open $dir/svc_acct.username: $!";
1082   flock(USERNAMELOCK,LOCK_EX)
1083     or die "can't lock $dir/svc_acct.username: $!";
1084
1085   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1086
1087   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1088     or die "can't open $dir/svc_acct.username.tmp: $!";
1089   print USERNAMECACHE join("\n", @all_username), "\n";
1090   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1091
1092   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1093   close USERNAMELOCK;
1094
1095 }
1096
1097 =item all_username
1098
1099 =cut
1100
1101 sub all_username {
1102   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1103   open(USERNAMECACHE,"<$dir/svc_acct.username")
1104     or die "can't open $dir/svc_acct.username: $!";
1105   my @array = map { chomp; $_; } <USERNAMECACHE>;
1106   close USERNAMECACHE;
1107   \@array;
1108 }
1109
1110 =item append_fuzzyfiles USERNAME
1111
1112 =cut
1113
1114 sub append_fuzzyfiles {
1115   my $username = shift;
1116
1117   &check_and_rebuild_fuzzyfiles;
1118
1119   use Fcntl qw(:flock);
1120
1121   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1122
1123   open(USERNAME,">>$dir/svc_acct.username")
1124     or die "can't open $dir/svc_acct.username: $!";
1125   flock(USERNAME,LOCK_EX)
1126     or die "can't lock $dir/svc_acct.username: $!";
1127
1128   print USERNAME "$username\n";
1129
1130   flock(USERNAME,LOCK_UN)
1131     or die "can't unlock $dir/svc_acct.username: $!";
1132   close USERNAME;
1133
1134   1;
1135 }
1136
1137
1138
1139 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1140
1141 =cut
1142
1143 sub radius_usergroup_selector {
1144   my $sel_groups = shift;
1145   my %sel_groups = map { $_=>1 } @$sel_groups;
1146
1147   my $selectname = shift || 'radius_usergroup';
1148
1149   my $dbh = dbh;
1150   my $sth = $dbh->prepare(
1151     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1152   ) or die $dbh->errstr;
1153   $sth->execute() or die $sth->errstr;
1154   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1155
1156   my $html = <<END;
1157     <SCRIPT>
1158     function ${selectname}_doadd(object) {
1159       var myvalue = object.${selectname}_add.value;
1160       var optionName = new Option(myvalue,myvalue,false,true);
1161       var length = object.$selectname.length;
1162       object.$selectname.options[length] = optionName;
1163       object.${selectname}_add.value = "";
1164     }
1165     </SCRIPT>
1166     <SELECT MULTIPLE NAME="$selectname">
1167 END
1168
1169   foreach my $group ( @all_groups ) {
1170     $html .= '<OPTION';
1171     if ( $sel_groups{$group} ) {
1172       $html .= ' SELECTED';
1173       $sel_groups{$group} = 0;
1174     }
1175     $html .= ">$group</OPTION>\n";
1176   }
1177   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1178     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1179   };
1180   $html .= '</SELECT>';
1181
1182   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1183            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1184
1185   $html;
1186 }
1187
1188 =back
1189
1190 =head1 BUGS
1191
1192 The $recref stuff in sub check should be cleaned up.
1193
1194 The suspend, unsuspend and cancel methods update the database, but not the
1195 current object.  This is probably a bug as it's unexpected and
1196 counterintuitive.
1197
1198 radius_usergroup_selector?  putting web ui components in here?  they should
1199 probably live somewhere else...
1200
1201 =head1 SEE ALSO
1202
1203 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1204 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1205 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1206 L<freeside-queued>), L<FS::svc_acct_pop>,
1207 schema.html from the base documentation.
1208
1209 =cut
1210
1211 1;
1212