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                           'custnum'  => $self->custnum,
 377                           'username' => $self->username,
 378                           'password' => $self->_password,
 379                           'first'    => $cust_main->first,
 380                           'last'     => $cust_main->getfield('last'),
 381                           'pkg'      => $cust_pkg->part_pkg->pkg,
 382                         } ),
 383         );
 384         if ( $error ) {
 385           $dbh->rollback if $oldAutoCommit;
 386           return "queuing welcome email: $error";
 387         }
 388
 389         foreach my $jobnum ( @jobnums ) {
 390           my $error = $wqueue->depend_insert($jobnum);
 391           if ( $error ) {
 392             $dbh->rollback if $oldAutoCommit;
 393             return "queuing welcome email job dependancy: $error";
 394           }
 395         }
 396
 397       }
 398
 399     }
 400
 401   } # if ( $cust_pkg )
 402
 403   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 404   ''; #no error
 405 }
 406
 407 =item delete
 408
 409 Deletes this account from the database.  If there is an error, returns the
 410 error, otherwise returns false.
 411
 412 The corresponding FS::cust_svc record will be deleted as well.
 413
 414 (TODOC: new exports! $noexport_hack)
 415
 416 =cut
 417
 418 sub delete {
 419   my $self = shift;
 420
 421   if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
 422     return "Can't delete an account which has (svc_acct_sm) mail aliases!"
 423       if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
 424   }
 425
 426   return "Can't delete an account which is a (svc_forward) source!"
 427     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 428
 429   return "Can't delete an account which is a (svc_forward) destination!"
 430     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 431
 432   return "Can't delete an account with (svc_www) web service!"
 433     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
 434
 435   # what about records in session ? (they should refer to history table)
 436
 437   local $SIG{HUP} = 'IGNORE';
 438   local $SIG{INT} = 'IGNORE';
 439   local $SIG{QUIT} = 'IGNORE';
 440   local $SIG{TERM} = 'IGNORE';
 441   local $SIG{TSTP} = 'IGNORE';
 442   local $SIG{PIPE} = 'IGNORE';
 443
 444   my $oldAutoCommit = $FS::UID::AutoCommit;
 445   local $FS::UID::AutoCommit = 0;
 446   my $dbh = dbh;
 447
 448   foreach my $cust_main_invoice (
 449     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 450   ) {
 451     unless ( defined($cust_main_invoice) ) {
 452       warn "WARNING: something's wrong with qsearch";
 453       next;
 454     }
 455     my %hash = $cust_main_invoice->hash;
 456     $hash{'dest'} = $self->email;
 457     my $new = new FS::cust_main_invoice \%hash;
 458     my $error = $new->replace($cust_main_invoice);
 459     if ( $error ) {
 460       $dbh->rollback if $oldAutoCommit;
 461       return $error;
 462     }
 463   }
 464
 465   foreach my $svc_domain (
 466     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 467   ) {
 468     my %hash = new FS::svc_domain->hash;
 469     $hash{'catchall'} = '';
 470     my $new = new FS::svc_domain \%hash;
 471     my $error = $new->replace($svc_domain);
 472     if ( $error ) {
 473       $dbh->rollback if $oldAutoCommit;
 474       return $error;
 475     }
 476   }
 477
 478   foreach my $radius_usergroup (
 479     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 480   ) {
 481     my $error = $radius_usergroup->delete;
 482     if ( $error ) {
 483       $dbh->rollback if $oldAutoCommit;
 484       return $error;
 485     }
 486   }
 487
 488   my $error = $self->SUPER::delete;
 489   if ( $error ) {
 490     $dbh->rollback if $oldAutoCommit;
 491     return $error;
 492   }
 493
 494   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 495   '';
 496 }
 497
 498 =item replace OLD_RECORD
 499
 500 Replaces OLD_RECORD with this one in the database.  If there is an error,
 501 returns the error, otherwise returns false.
 502
 503 The additional field I<usergroup> can optionally be defined; if so it should
 504 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 505 sqlradius export only)
 506
 507 =cut
 508
 509 sub replace {
 510   my ( $new, $old ) = ( shift, shift );
 511   my $error;
 512   warn "$me replacing $old with $new\n" if $DEBUG;
 513
 514   return "Username in use"
 515     if $old->username ne $new->username &&
 516       qsearchs( 'svc_acct', { 'username' => $new->username,
 517                                'domsvc'   => $new->domsvc,
 518                              } );
 519   {
 520     #no warnings 'numeric';  #alas, a 5.006-ism
 521     local($^W) = 0;
 522     return "Can't change uid!" if $old->uid != $new->uid;
 523   }
 524
 525   #change homdir when we change username
 526   $new->setfield('dir', '') if $old->username ne $new->username;
 527
 528   local $SIG{HUP} = 'IGNORE';
 529   local $SIG{INT} = 'IGNORE';
 530   local $SIG{QUIT} = 'IGNORE';
 531   local $SIG{TERM} = 'IGNORE';
 532   local $SIG{TSTP} = 'IGNORE';
 533   local $SIG{PIPE} = 'IGNORE';
 534
 535   my $oldAutoCommit = $FS::UID::AutoCommit;
 536   local $FS::UID::AutoCommit = 0;
 537   my $dbh = dbh;
 538
 539   # redundant, but so $new->usergroup gets set
 540   $error = $new->check;
 541   return $error if $error;
 542
 543   $old->usergroup( [ $old->radius_groups ] );
 544   warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
 545   warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
 546   if ( $new->usergroup ) {
 547     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 548     my @newgroups = @{$new->usergroup};
 549     foreach my $oldgroup ( @{$old->usergroup} ) {
 550       if ( grep { $oldgroup eq $_ } @newgroups ) {
 551         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 552         next;
 553       }
 554       my $radius_usergroup = qsearchs('radius_usergroup', {
 555         svcnum    => $old->svcnum,
 556         groupname => $oldgroup,
 557       } );
 558       my $error = $radius_usergroup->delete;
 559       if ( $error ) {
 560         $dbh->rollback if $oldAutoCommit;
 561         return "error deleting radius_usergroup $oldgroup: $error";
 562       }
 563     }
 564
 565     foreach my $newgroup ( @newgroups ) {
 566       my $radius_usergroup = new FS::radius_usergroup ( {
 567         svcnum    => $new->svcnum,
 568         groupname => $newgroup,
 569       } );
 570       my $error = $radius_usergroup->insert;
 571       if ( $error ) {
 572         $dbh->rollback if $oldAutoCommit;
 573         return "error adding radius_usergroup $newgroup: $error";
 574       }
 575     }
 576
 577   }
 578
 579   $error = $new->SUPER::replace($old);
 580   if ( $error ) {
 581     $dbh->rollback if $oldAutoCommit;
 582     return $error if $error;
 583   }
 584
 585   if ( $new->username ne $old->username ) {
 586     #false laziness with sub insert (and cust_main)
 587     my $queue = new FS::queue {
 588       'svcnum' => $new->svcnum,
 589       'job'    => 'FS::svc_acct::append_fuzzyfiles'
 590     };
 591     $error = $queue->insert($new->username);
 592     if ( $error ) {
 593       $dbh->rollback if $oldAutoCommit;
 594       return "queueing job (transaction rolled back): $error";
 595     }
 596   }
 597
 598   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 599   ''; #no error
 600 }
 601
 602 =item suspend
 603
 604 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 605 error, returns the error, otherwise returns false.
 606
 607 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 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 =cut
 634
 635 sub unsuspend {
 636   my $self = shift;
 637   my %hash = $self->hash;
 638   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 639     $hash{_password} = $1;
 640     my $new = new FS::svc_acct ( \%hash );
 641     my $error = $new->replace($self);
 642     return $error if $error;
 643   }
 644
 645   $self->SUPER::unsuspend;
 646 }
 647
 648 =item cancel
 649
 650 Just returns false (no error) for now.
 651
 652 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 653
 654 =item check
 655
 656 Checks all fields to make sure this is a valid service.  If there is an error,
 657 returns the error, otherwise returns false.  Called by the insert and replace
 658 methods.
 659
 660 Sets any fixed values; see L<FS::part_svc>.
 661
 662 =cut
 663
 664 sub check {
 665   my $self = shift;
 666
 667   my($recref) = $self->hashref;
 668
 669   my $x = $self->setfixed;
 670   return $x unless ref($x);
 671   my $part_svc = $x;
 672
 673   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 674     $self->usergroup(
 675       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 676   }
 677
 678   my $error = $self->ut_numbern('svcnum')
 679               || $self->ut_number('domsvc')
 680               || $self->ut_textn('sec_phrase')
 681   ;
 682   return $error if $error;
 683
 684   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 685   if ( $username_uppercase ) {
 686     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 687       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 688     $recref->{username} = $1;
 689   } else {
 690     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 691       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 692     $recref->{username} = $1;
 693   }
 694
 695   if ( $username_letterfirst ) {
 696     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 697   } elsif ( $username_letter ) {
 698     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 699   }
 700   if ( $username_noperiod ) {
 701     $recref->{username} =~ /\./ and return gettext('illegal_username');
 702   }
 703   if ( $username_nounderscore ) {
 704     $recref->{username} =~ /_/ and return gettext('illegal_username');
 705   }
 706   if ( $username_nodash ) {
 707     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 708   }
 709   unless ( $username_ampersand ) {
 710     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 711   }
 712
 713   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 714   $recref->{popnum} = $1;
 715   return "Unknown popnum" unless
 716     ! $recref->{popnum} ||
 717     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 718
 719   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 720
 721     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 722     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 723
 724     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 725     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 726     #not all systems use gid=uid
 727     #you can set a fixed gid in part_svc
 728
 729     return "Only root can have uid 0"
 730       if $recref->{uid} == 0
 731          && $recref->{username} ne 'root'
 732          && $recref->{username} ne 'toor';
 733
 734
 735     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 736       or return "Illegal directory: ". $recref->{dir};
 737     $recref->{dir} = $1;
 738     return "Illegal directory"
 739       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 740     return "Illegal directory"
 741       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 742     unless ( $recref->{dir} ) {
 743       $recref->{dir} = $dir_prefix . '/';
 744       if ( $dirhash > 0 ) {
 745         for my $h ( 1 .. $dirhash ) {
 746           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 747         }
 748       } elsif ( $dirhash < 0 ) {
 749         for my $h ( reverse $dirhash .. -1 ) {
 750           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 751         }
 752       }
 753       $recref->{dir} .= $recref->{username};
 754     ;
 755     }
 756
 757     unless ( $recref->{username} eq 'sync' ) {
 758       if ( grep $_ eq $recref->{shell}, @shells ) {
 759         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 760       } else {
 761         return "Illegal shell \`". $self->shell. "\'; ".
 762                $conf->dir. "/shells contains: @shells";
 763       }
 764     } else {
 765       $recref->{shell} = '/bin/sync';
 766     }
 767
 768   } else {
 769     $recref->{gid} ne '' ?
 770       return "Can't have gid without uid" : ( $recref->{gid}='' );
 771     $recref->{dir} ne '' ?
 772       return "Can't have directory without uid" : ( $recref->{dir}='' );
 773     $recref->{shell} ne '' ?
 774       return "Can't have shell without uid" : ( $recref->{shell}='' );
 775   }
 776
 777   #  $error = $self->ut_textn('finger');
 778   #  return $error if $error;
 779   $self->getfield('finger') =~
 780     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 781       or return "Illegal finger: ". $self->getfield('finger');
 782   $self->setfield('finger', $1);
 783
 784   $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
 785   $recref->{quota} = $1;
 786
 787   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 788     unless ( $recref->{slipip} eq '0e0' ) {
 789       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 790         or return "Illegal slipip". $self->slipip;
 791       $recref->{slipip} = $1;
 792     } else {
 793       $recref->{slipip} = '0e0';
 794     }
 795
 796   }
 797
 798   #arbitrary RADIUS stuff; allow ut_textn for now
 799   foreach ( grep /^radius_/, fields('svc_acct') ) {
 800     $self->ut_textn($_);
 801   }
 802
 803   #generate a password if it is blank
 804   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 805     unless ( $recref->{_password} );
 806
 807   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 808   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 809     $recref->{_password} = $1.$3;
 810     #uncomment this to encrypt password immediately upon entry, or run
 811     #bin/crypt_pw in cron to give new users a window during which their
 812     #password is available to techs, for faxing, etc.  (also be aware of
 813     #radius issues!)
 814     #$recref->{password} = $1.
 815     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 816     #;
 817   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,34})$/ ) {
 818     $recref->{_password} = $1.$3;
 819   } elsif ( $recref->{_password} eq '*' ) {
 820     $recref->{_password} = '*';
 821   } elsif ( $recref->{_password} eq '!!' ) {
 822     $recref->{_password} = '!!';
 823   } else {
 824     #return "Illegal password";
 825     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 826            FS::Msgcat::_gettext('illegal_password_characters').
 827            ": ". $recref->{_password};
 828   }
 829
 830   ''; #no error
 831 }
 832
 833 =item radius
 834
 835 Depriciated, use radius_reply instead.
 836
 837 =cut
 838
 839 sub radius {
 840   carp "FS::svc_acct::radius depriciated, use radius_reply";
 841   $_[0]->radius_reply;
 842 }
 843
 844 =item radius_reply
 845
 846 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 847 reply attributes of this record.
 848
 849 Note that this is now the preferred method for reading RADIUS attributes -
 850 accessing the columns directly is discouraged, as the column names are
 851 expected to change in the future.
 852
 853 =cut
 854
 855 sub radius_reply {
 856   my $self = shift;
 857   my %reply =
 858     map {
 859       /^(radius_(.*))$/;
 860       my($column, $attrib) = ($1, $2);
 861       #$attrib =~ s/_/\-/g;
 862       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 863     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 864   if ( $self->slipip && $self->slipip ne '0e0' ) {
 865     $reply{'Framed-IP-Address'} = $self->slipip;
 866   }
 867   %reply;
 868 }
 869
 870 =item radius_check
 871
 872 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 873 check attributes of this record.
 874
 875 Note that this is now the preferred method for reading RADIUS attributes -
 876 accessing the columns directly is discouraged, as the column names are
 877 expected to change in the future.
 878
 879 =cut
 880
 881 sub radius_check {
 882   my $self = shift;
 883   my $password = $self->_password;
 884   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
 885   ( $pw_attrib => $self->_password,
 886     map {
 887       /^(rc_(.*))$/;
 888       my($column, $attrib) = ($1, $2);
 889       #$attrib =~ s/_/\-/g;
 890       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 891     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 892   );
 893 }
 894
 895 =item domain
 896
 897 Returns the domain associated with this account.
 898
 899 =cut
 900
 901 sub domain {
 902   my $self = shift;
 903   if ( $self->domsvc ) {
 904     #$self->svc_domain->domain;
 905     my $svc_domain = $self->svc_domain
 906       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 907     $svc_domain->domain;
 908   } else {
 909     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
 910   }
 911 }
 912
 913 =item svc_domain
 914
 915 Returns the FS::svc_domain record for this account's domain (see
 916 L<FS::svc_domain>).
 917
 918 =cut
 919
 920 sub svc_domain {
 921   my $self = shift;
 922   $self->{'_domsvc'}
 923     ? $self->{'_domsvc'}
 924     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 925 }
 926
 927 =item cust_svc
 928
 929 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 930
 931 sub cust_svc {
 932   my $self = shift;
 933   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 934 }
 935
 936 =item email
 937
 938 Returns an email address associated with the account.
 939
 940 =cut
 941
 942 sub email {
 943   my $self = shift;
 944   $self->username. '@'. $self->domain;
 945 }
 946
 947 =item seconds_since TIMESTAMP
 948
 949 Returns the number of seconds this account has been online since TIMESTAMP,
 950 according to the session monitor (see L<FS::Session>).
 951
 952 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 953 L<Time::Local> and L<Date::Parse> for conversion functions.
 954
 955 =cut
 956
 957 #note: POD here, implementation in FS::cust_svc
 958 sub seconds_since {
 959   my $self = shift;
 960   $self->cust_svc->seconds_since(@_);
 961 }
 962
 963 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 964
 965 Returns the numbers of seconds this account has been online between
 966 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
 967 external SQL radacct table, specified via sqlradius export.  Sessions which
 968 started in the specified range but are still open are counted from session
 969 start to the end of the range (unless they are over 1 day old, in which case
 970 they are presumed missing their stop record and not counted).  Also, sessions
 971 which end in the range but started earlier are counted from the start of the
 972 range to session end.  Finally, sessions which start before the range but end
 973 after are counted for the entire range.
 974
 975 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 976 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 977 functions.
 978
 979 =cut
 980
 981 #note: POD here, implementation in FS::cust_svc
 982 sub seconds_since_sqlradacct {
 983   my $self = shift;
 984   $self->cust_svc->seconds_since_sqlradacct(@_);
 985 }
 986
 987 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 988
 989 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 990 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 991 TIMESTAMP_END (exclusive).
 992
 993 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 994 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 995 functions.
 996
 997 =cut
 998
 999 #note: POD here, implementation in FS::cust_svc
1000 sub attribute_since_sqlradacct {
1001   my $self = shift;
1002   $self->cust_svc->attribute_since_sqlradacct(@_);
1003 }
1004
1005
1006 =item radius_groups
1007
1008 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1009
1010 =cut
1011
1012 sub radius_groups {
1013   my $self = shift;
1014   if ( $self->usergroup ) {
1015     #when provisioning records, export callback runs in svc_Common.pm before
1016     #radius_usergroup records can be inserted...
1017     @{$self->usergroup};
1018   } else {
1019     map { $_->groupname }
1020       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1021   }
1022 }
1023
1024 =back
1025
1026 =head1 SUBROUTINES
1027
1028 =over 4
1029
1030 =item send_email
1031
1032 =cut
1033
1034 sub send_email {
1035   my %opt = @_;
1036
1037   use Date::Format;
1038   use Mail::Internet 1.44;
1039   use Mail::Header;
1040
1041   $opt{mimetype} ||= 'text/plain';
1042   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1043
1044   $ENV{MAILADDRESS} = $opt{from};
1045   my $header = new Mail::Header ( [
1046     "From: $opt{from}",
1047     "To: $opt{to}",
1048     "Sender: $opt{from}",
1049     "Reply-To: $opt{from}",
1050     "Date: ". time2str("%a, %d %b %Y %X %z", time),
1051     "Subject: $opt{subject}",
1052     "Content-Type: $opt{mimetype}",
1053   ] );
1054   my $message = new Mail::Internet (
1055     'Header' => $header,
1056     'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1057   );
1058   $!=0;
1059   $message->smtpsend( Host => $smtpmachine )
1060     or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1061       or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1062 }
1063
1064 =item check_and_rebuild_fuzzyfiles
1065
1066 =cut
1067
1068 sub check_and_rebuild_fuzzyfiles {
1069   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1070   -e "$dir/svc_acct.username"
1071     or &rebuild_fuzzyfiles;
1072 }
1073
1074 =item rebuild_fuzzyfiles
1075
1076 =cut
1077
1078 sub rebuild_fuzzyfiles {
1079
1080   use Fcntl qw(:flock);
1081
1082   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1083
1084   #username
1085
1086   open(USERNAMELOCK,">>$dir/svc_acct.username")
1087     or die "can't open $dir/svc_acct.username: $!";
1088   flock(USERNAMELOCK,LOCK_EX)
1089     or die "can't lock $dir/svc_acct.username: $!";
1090
1091   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1092
1093   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1094     or die "can't open $dir/svc_acct.username.tmp: $!";
1095   print USERNAMECACHE join("\n", @all_username), "\n";
1096   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1097
1098   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1099   close USERNAMELOCK;
1100
1101 }
1102
1103 =item all_username
1104
1105 =cut
1106
1107 sub all_username {
1108   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1109   open(USERNAMECACHE,"<$dir/svc_acct.username")
1110     or die "can't open $dir/svc_acct.username: $!";
1111   my @array = map { chomp; $_; } <USERNAMECACHE>;
1112   close USERNAMECACHE;
1113   \@array;
1114 }
1115
1116 =item append_fuzzyfiles USERNAME
1117
1118 =cut
1119
1120 sub append_fuzzyfiles {
1121   my $username = shift;
1122
1123   &check_and_rebuild_fuzzyfiles;
1124
1125   use Fcntl qw(:flock);
1126
1127   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1128
1129   open(USERNAME,">>$dir/svc_acct.username")
1130     or die "can't open $dir/svc_acct.username: $!";
1131   flock(USERNAME,LOCK_EX)
1132     or die "can't lock $dir/svc_acct.username: $!";
1133
1134   print USERNAME "$username\n";
1135
1136   flock(USERNAME,LOCK_UN)
1137     or die "can't unlock $dir/svc_acct.username: $!";
1138   close USERNAME;
1139
1140   1;
1141 }
1142
1143
1144
1145 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1146
1147 =cut
1148
1149 sub radius_usergroup_selector {
1150   my $sel_groups = shift;
1151   my %sel_groups = map { $_=>1 } @$sel_groups;
1152
1153   my $selectname = shift || 'radius_usergroup';
1154
1155   my $dbh = dbh;
1156   my $sth = $dbh->prepare(
1157     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1158   ) or die $dbh->errstr;
1159   $sth->execute() or die $sth->errstr;
1160   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1161
1162   my $html = <<END;
1163     <SCRIPT>
1164     function ${selectname}_doadd(object) {
1165       var myvalue = object.${selectname}_add.value;
1166       var optionName = new Option(myvalue,myvalue,false,true);
1167       var length = object.$selectname.length;
1168       object.$selectname.options[length] = optionName;
1169       object.${selectname}_add.value = "";
1170     }
1171     </SCRIPT>
1172     <SELECT MULTIPLE NAME="$selectname">
1173 END
1174
1175   foreach my $group ( @all_groups ) {
1176     $html .= '<OPTION';
1177     if ( $sel_groups{$group} ) {
1178       $html .= ' SELECTED';
1179       $sel_groups{$group} = 0;
1180     }
1181     $html .= ">$group</OPTION>\n";
1182   }
1183   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1184     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1185   };
1186   $html .= '</SELECT>';
1187
1188   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1189            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1190
1191   $html;
1192 }
1193
1194 =back
1195
1196 =head1 BUGS
1197
1198 The $recref stuff in sub check should be cleaned up.
1199
1200 The suspend, unsuspend and cancel methods update the database, but not the
1201 current object.  This is probably a bug as it's unexpected and
1202 counterintuitive.
1203
1204 radius_usergroup_selector?  putting web ui components in here?  they should
1205 probably live somewhere else...
1206
1207 =head1 SEE ALSO
1208
1209 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1210 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1211 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1212 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1213 schema.html from the base documentation.
1214
1215 =cut
1216
1217 1;
1218