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 calling export-specific suspend hooks.  If there is
 603 an 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 =cut
 608
 609 sub suspend {
 610   my $self = shift;
 611   my %hash = $self->hash;
 612   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 613            || $hash{_password} eq '*'
 614          ) {
 615     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 616     my $new = new FS::svc_acct ( \%hash );
 617     my $error = $new->replace($self);
 618     return $error if $error;
 619   }
 620
 621   $self->SUPER::suspend;
 622 }
 623
 624 =item unsuspend
 625
 626 Unsuspends this account by by calling export-specific suspend hooks.  If there
 627 is an error, returns the error, otherwise returns false.
 628
 629 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 630
 631 =cut
 632
 633 sub unsuspend {
 634   my $self = shift;
 635   my %hash = $self->hash;
 636   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 637     $hash{_password} = $1;
 638     my $new = new FS::svc_acct ( \%hash );
 639     my $error = $new->replace($self);
 640     return $error if $error;
 641   }
 642
 643   $self->SUPER::unsuspend;
 644 }
 645
 646 =item cancel
 647
 648 Just returns false (no error) for now.
 649
 650 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 651
 652 =item check
 653
 654 Checks all fields to make sure this is a valid service.  If there is an error,
 655 returns the error, otherwise returns false.  Called by the insert and replace
 656 methods.
 657
 658 Sets any fixed values; see L<FS::part_svc>.
 659
 660 =cut
 661
 662 sub check {
 663   my $self = shift;
 664
 665   my($recref) = $self->hashref;
 666
 667   my $x = $self->setfixed;
 668   return $x unless ref($x);
 669   my $part_svc = $x;
 670
 671   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 672     $self->usergroup(
 673       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 674   }
 675
 676   my $error = $self->ut_numbern('svcnum')
 677               #|| $self->ut_number('domsvc')
 678               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 679               || $self->ut_textn('sec_phrase')
 680   ;
 681   return $error if $error;
 682
 683   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 684   if ( $username_uppercase ) {
 685     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 686       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 687     $recref->{username} = $1;
 688   } else {
 689     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 690       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 691     $recref->{username} = $1;
 692   }
 693
 694   if ( $username_letterfirst ) {
 695     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 696   } elsif ( $username_letter ) {
 697     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 698   }
 699   if ( $username_noperiod ) {
 700     $recref->{username} =~ /\./ and return gettext('illegal_username');
 701   }
 702   if ( $username_nounderscore ) {
 703     $recref->{username} =~ /_/ and return gettext('illegal_username');
 704   }
 705   if ( $username_nodash ) {
 706     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 707   }
 708   unless ( $username_ampersand ) {
 709     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 710   }
 711
 712   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 713   $recref->{popnum} = $1;
 714   return "Unknown popnum" unless
 715     ! $recref->{popnum} ||
 716     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 717
 718   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 719
 720     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 721     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 722
 723     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 724     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 725     #not all systems use gid=uid
 726     #you can set a fixed gid in part_svc
 727
 728     return "Only root can have uid 0"
 729       if $recref->{uid} == 0
 730          && $recref->{username} ne 'root'
 731          && $recref->{username} ne 'toor';
 732
 733
 734     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 735       or return "Illegal directory: ". $recref->{dir};
 736     $recref->{dir} = $1;
 737     return "Illegal directory"
 738       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 739     return "Illegal directory"
 740       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 741     unless ( $recref->{dir} ) {
 742       $recref->{dir} = $dir_prefix . '/';
 743       if ( $dirhash > 0 ) {
 744         for my $h ( 1 .. $dirhash ) {
 745           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 746         }
 747       } elsif ( $dirhash < 0 ) {
 748         for my $h ( reverse $dirhash .. -1 ) {
 749           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 750         }
 751       }
 752       $recref->{dir} .= $recref->{username};
 753     ;
 754     }
 755
 756     unless ( $recref->{username} eq 'sync' ) {
 757       if ( grep $_ eq $recref->{shell}, @shells ) {
 758         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 759       } else {
 760         return "Illegal shell \`". $self->shell. "\'; ".
 761                $conf->dir. "/shells contains: @shells";
 762       }
 763     } else {
 764       $recref->{shell} = '/bin/sync';
 765     }
 766
 767   } else {
 768     $recref->{gid} ne '' ?
 769       return "Can't have gid without uid" : ( $recref->{gid}='' );
 770     $recref->{dir} ne '' ?
 771       return "Can't have directory without uid" : ( $recref->{dir}='' );
 772     $recref->{shell} ne '' ?
 773       return "Can't have shell without uid" : ( $recref->{shell}='' );
 774   }
 775
 776   #  $error = $self->ut_textn('finger');
 777   #  return $error if $error;
 778   $self->getfield('finger') =~
 779     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 780       or return "Illegal finger: ". $self->getfield('finger');
 781   $self->setfield('finger', $1);
 782
 783   $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
 784   $recref->{quota} = $1;
 785
 786   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 787     if ( $recref->{slipip} eq '' ) {
 788       $recref->{slipip} = '';
 789     } elsif ( $recref->{slipip} eq '0e0' ) {
 790       $recref->{slipip} = '0e0';
 791     } else {
 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     }
 796
 797   }
 798
 799   #arbitrary RADIUS stuff; allow ut_textn for now
 800   foreach ( grep /^radius_/, fields('svc_acct') ) {
 801     $self->ut_textn($_);
 802   }
 803
 804   #generate a password if it is blank
 805   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 806     unless ( $recref->{_password} );
 807
 808   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 809   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 810     $recref->{_password} = $1.$3;
 811     #uncomment this to encrypt password immediately upon entry, or run
 812     #bin/crypt_pw in cron to give new users a window during which their
 813     #password is available to techs, for faxing, etc.  (also be aware of
 814     #radius issues!)
 815     #$recref->{password} = $1.
 816     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 817     #;
 818   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 819     $recref->{_password} = $1.$3;
 820   } elsif ( $recref->{_password} eq '*' ) {
 821     $recref->{_password} = '*';
 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   $self->SUPER::check;
 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{$radius_ip} = $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 => $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   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
 907   my $svc_domain = $self->svc_domain
 908     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 909   $svc_domain->domain;
 910 }
 911
 912 =item svc_domain
 913
 914 Returns the FS::svc_domain record for this account's domain (see
 915 L<FS::svc_domain>).
 916
 917 =cut
 918
 919 sub svc_domain {
 920   my $self = shift;
 921   $self->{'_domsvc'}
 922     ? $self->{'_domsvc'}
 923     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 924 }
 925
 926 =item cust_svc
 927
 928 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 929
 930 =cut
 931
 932 sub cust_svc {
 933   my $self = shift;
 934   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 935 }
 936
 937 =item email
 938
 939 Returns an email address associated with the account.
 940
 941 =cut
 942
 943 sub email {
 944   my $self = shift;
 945   $self->username. '@'. $self->domain;
 946 }
 947
 948 =item seconds_since TIMESTAMP
 949
 950 Returns the number of seconds this account has been online since TIMESTAMP,
 951 according to the session monitor (see L<FS::Session>).
 952
 953 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 954 L<Time::Local> and L<Date::Parse> for conversion functions.
 955
 956 =cut
 957
 958 #note: POD here, implementation in FS::cust_svc
 959 sub seconds_since {
 960   my $self = shift;
 961   $self->cust_svc->seconds_since(@_);
 962 }
 963
 964 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 965
 966 Returns the numbers of seconds this account has been online between
 967 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
 968 external SQL radacct table, specified via sqlradius export.  Sessions which
 969 started in the specified range but are still open are counted from session
 970 start to the end of the range (unless they are over 1 day old, in which case
 971 they are presumed missing their stop record and not counted).  Also, sessions
 972 which end in the range but started earlier are counted from the start of the
 973 range to session end.  Finally, sessions which start before the range but end
 974 after are counted for the entire range.
 975
 976 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 977 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 978 functions.
 979
 980 =cut
 981
 982 #note: POD here, implementation in FS::cust_svc
 983 sub seconds_since_sqlradacct {
 984   my $self = shift;
 985   $self->cust_svc->seconds_since_sqlradacct(@_);
 986 }
 987
 988 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 989
 990 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 991 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 992 TIMESTAMP_END (exclusive).
 993
 994 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 995 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 996 functions.
 997
 998 =cut
 999
1000 #note: POD here, implementation in FS::cust_svc
1001 sub attribute_since_sqlradacct {
1002   my $self = shift;
1003   $self->cust_svc->attribute_since_sqlradacct(@_);
1004 }
1005
1006 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1007
1008 Returns an array of hash references of this customers login history for the
1009 given time range.  (document this better)
1010
1011 =cut
1012
1013 sub get_session_history_sqlradacct {
1014   my $self = shift;
1015   $self->cust_svc->get_session_history_sqlradacct(@_);
1016 }
1017
1018 =item radius_groups
1019
1020 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1021
1022 =cut
1023
1024 sub radius_groups {
1025   my $self = shift;
1026   if ( $self->usergroup ) {
1027     #when provisioning records, export callback runs in svc_Common.pm before
1028     #radius_usergroup records can be inserted...
1029     @{$self->usergroup};
1030   } else {
1031     map { $_->groupname }
1032       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1033   }
1034 }
1035
1036 =back
1037
1038 =head1 SUBROUTINES
1039
1040 =over 4
1041
1042 =item send_email
1043
1044 This is the FS::svc_acct job-queue-able version.  It still uses
1045 FS::Misc::send_email under-the-hood.
1046
1047 =cut
1048
1049 sub send_email {
1050   my %opt = @_;
1051
1052   eval "use FS::Misc qw(send_email)";
1053   die $@ if $@;
1054
1055   $opt{mimetype} ||= 'text/plain';
1056   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1057
1058   my $error = send_email(
1059     'from'         => $opt{from},
1060     'to'           => $opt{to},
1061     'subject'      => $opt{subject},
1062     'content-type' => $opt{mimetype},
1063     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1064   );
1065   die $error if $error;
1066 }
1067
1068 =item check_and_rebuild_fuzzyfiles
1069
1070 =cut
1071
1072 sub check_and_rebuild_fuzzyfiles {
1073   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1074   -e "$dir/svc_acct.username"
1075     or &rebuild_fuzzyfiles;
1076 }
1077
1078 =item rebuild_fuzzyfiles
1079
1080 =cut
1081
1082 sub rebuild_fuzzyfiles {
1083
1084   use Fcntl qw(:flock);
1085
1086   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1087
1088   #username
1089
1090   open(USERNAMELOCK,">>$dir/svc_acct.username")
1091     or die "can't open $dir/svc_acct.username: $!";
1092   flock(USERNAMELOCK,LOCK_EX)
1093     or die "can't lock $dir/svc_acct.username: $!";
1094
1095   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1096
1097   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1098     or die "can't open $dir/svc_acct.username.tmp: $!";
1099   print USERNAMECACHE join("\n", @all_username), "\n";
1100   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1101
1102   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1103   close USERNAMELOCK;
1104
1105 }
1106
1107 =item all_username
1108
1109 =cut
1110
1111 sub all_username {
1112   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1113   open(USERNAMECACHE,"<$dir/svc_acct.username")
1114     or die "can't open $dir/svc_acct.username: $!";
1115   my @array = map { chomp; $_; } <USERNAMECACHE>;
1116   close USERNAMECACHE;
1117   \@array;
1118 }
1119
1120 =item append_fuzzyfiles USERNAME
1121
1122 =cut
1123
1124 sub append_fuzzyfiles {
1125   my $username = shift;
1126
1127   &check_and_rebuild_fuzzyfiles;
1128
1129   use Fcntl qw(:flock);
1130
1131   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1132
1133   open(USERNAME,">>$dir/svc_acct.username")
1134     or die "can't open $dir/svc_acct.username: $!";
1135   flock(USERNAME,LOCK_EX)
1136     or die "can't lock $dir/svc_acct.username: $!";
1137
1138   print USERNAME "$username\n";
1139
1140   flock(USERNAME,LOCK_UN)
1141     or die "can't unlock $dir/svc_acct.username: $!";
1142   close USERNAME;
1143
1144   1;
1145 }
1146
1147
1148
1149 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1150
1151 =cut
1152
1153 sub radius_usergroup_selector {
1154   my $sel_groups = shift;
1155   my %sel_groups = map { $_=>1 } @$sel_groups;
1156
1157   my $selectname = shift || 'radius_usergroup';
1158
1159   my $dbh = dbh;
1160   my $sth = $dbh->prepare(
1161     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1162   ) or die $dbh->errstr;
1163   $sth->execute() or die $sth->errstr;
1164   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1165
1166   my $html = <<END;
1167     <SCRIPT>
1168     function ${selectname}_doadd(object) {
1169       var myvalue = object.${selectname}_add.value;
1170       var optionName = new Option(myvalue,myvalue,false,true);
1171       var length = object.$selectname.length;
1172       object.$selectname.options[length] = optionName;
1173       object.${selectname}_add.value = "";
1174     }
1175     </SCRIPT>
1176     <SELECT MULTIPLE NAME="$selectname">
1177 END
1178
1179   foreach my $group ( @all_groups ) {
1180     $html .= '<OPTION';
1181     if ( $sel_groups{$group} ) {
1182       $html .= ' SELECTED';
1183       $sel_groups{$group} = 0;
1184     }
1185     $html .= ">$group</OPTION>\n";
1186   }
1187   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1188     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1189   };
1190   $html .= '</SELECT>';
1191
1192   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1193            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1194
1195   $html;
1196 }
1197
1198 =back
1199
1200 =head1 BUGS
1201
1202 The $recref stuff in sub check should be cleaned up.
1203
1204 The suspend, unsuspend and cancel methods update the database, but not the
1205 current object.  This is probably a bug as it's unexpected and
1206 counterintuitive.
1207
1208 radius_usergroup_selector?  putting web ui components in here?  they should
1209 probably live somewhere else...
1210
1211 =head1 SEE ALSO
1212
1213 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1214 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1215 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1216 L<freeside-queued>), L<FS::svc_acct_pop>,
1217 schema.html from the base documentation.
1218
1219 =cut
1220
1221 1;
1222