FS/FS/svc_acct.pm

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