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              $mydomain
  11              $welcome_template $welcome_from $welcome_subject $welcome_mimetype
  12              $smtpmachine
  13              $radius_password $radius_ip
  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 dbdef );
  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     $welcome_from = '';
  70     $welcome_subject = '';
  71     $welcome_mimetype = '';
  72   }
  73   $smtpmachine = $conf->config('smtpmachine');
  74   $radius_password = $conf->config('radius-password') || 'Password';
  75   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  76 };
  77
  78 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  79 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  80
  81 sub _cache {
  82   my $self = shift;
  83   my ( $hashref, $cache ) = @_;
  84   if ( $hashref->{'svc_acct_svcnum'} ) {
  85     $self->{'_domsvc'} = FS::svc_domain->new( {
  86       'svcnum'   => $hashref->{'domsvc'},
  87       'domain'   => $hashref->{'svc_acct_domain'},
  88       'catchall' => $hashref->{'svc_acct_catchall'},
  89     } );
  90   }
  91 }
  92
  93 =head1 NAME
  94
  95 FS::svc_acct - Object methods for svc_acct records
  96
  97 =head1 SYNOPSIS
  98
  99   use FS::svc_acct;
 100
 101   $record = new FS::svc_acct \%hash;
 102   $record = new FS::svc_acct { 'column' => 'value' };
 103
 104   $error = $record->insert;
 105
 106   $error = $new_record->replace($old_record);
 107
 108   $error = $record->delete;
 109
 110   $error = $record->check;
 111
 112   $error = $record->suspend;
 113
 114   $error = $record->unsuspend;
 115
 116   $error = $record->cancel;
 117
 118   %hash = $record->radius;
 119
 120   %hash = $record->radius_reply;
 121
 122   %hash = $record->radius_check;
 123
 124   $domain = $record->domain;
 125
 126   $svc_domain = $record->svc_domain;
 127
 128   $email = $record->email;
 129
 130   $seconds_since = $record->seconds_since($timestamp);
 131
 132 =head1 DESCRIPTION
 133
 134 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 135 FS::svc_Common.  The following fields are currently supported:
 136
 137 =over 4
 138
 139 =item svcnum - primary key (assigned automatcially for new accounts)
 140
 141 =item username
 142
 143 =item _password - generated if blank
 144
 145 =item sec_phrase - security phrase
 146
 147 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 148
 149 =item uid
 150
 151 =item gid
 152
 153 =item finger - GECOS
 154
 155 =item dir - set automatically if blank (and uid is not)
 156
 157 =item shell
 158
 159 =item quota - (unimplementd)
 160
 161 =item slipip - IP address
 162
 163 =item seconds -
 164
 165 =item domsvc - svcnum from svc_domain
 166
 167 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
 168
 169 =back
 170
 171 =head1 METHODS
 172
 173 =over 4
 174
 175 =item new HASHREF
 176
 177 Creates a new account.  To add the account to the database, see L<"insert">.
 178
 179 =cut
 180
 181 sub table { 'svc_acct'; }
 182
 183 =item insert
 184
 185 Adds this account to the database.  If there is an error, returns the error,
 186 otherwise returns false.
 187
 188 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 189 defined.  An FS::cust_svc record will be created and inserted.
 190
 191 The additional field I<usergroup> can optionally be defined; if so it should
 192 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 193 sqlradius export only)
 194
 195 The additional field I<child_objects> can optionally be defined; if so it
 196 should contain an arrayref of FS::tablename objects.  They will have their
 197 svcnum fields set and will be inserted after this record, but before any
 198 exports are run.
 199
 200 (TODOC: L<FS::queue> and L<freeside-queued>)
 201
 202 (TODOC: new exports!)
 203
 204
 205 =cut
 206
 207 sub insert {
 208   my $self = shift;
 209   my $error;
 210
 211   local $SIG{HUP} = 'IGNORE';
 212   local $SIG{INT} = 'IGNORE';
 213   local $SIG{QUIT} = 'IGNORE';
 214   local $SIG{TERM} = 'IGNORE';
 215   local $SIG{TSTP} = 'IGNORE';
 216   local $SIG{PIPE} = 'IGNORE';
 217
 218   my $oldAutoCommit = $FS::UID::AutoCommit;
 219   local $FS::UID::AutoCommit = 0;
 220   my $dbh = dbh;
 221
 222   $error = $self->check;
 223   return $error if $error;
 224
 225   #no, duplicate checking just got a whole lot more complicated
 226   #(perhaps keep this check with a config option to turn on?)
 227
 228   #return gettext('username_in_use'). ": ". $self->username
 229   #  if qsearchs( 'svc_acct', { 'username' => $self->username,
 230   #                             'domsvc'   => $self->domsvc,
 231   #                           } );
 232
 233   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 234     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 235     unless ( $cust_svc ) {
 236       $dbh->rollback if $oldAutoCommit;
 237       return "no cust_svc record found for svcnum ". $self->svcnum;
 238     }
 239     $self->pkgnum($cust_svc->pkgnum);
 240     $self->svcpart($cust_svc->svcpart);
 241   }
 242
 243   #new duplicate username checking
 244
 245   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
 246   unless ( $part_svc ) {
 247     $dbh->rollback if $oldAutoCommit;
 248     return 'unknown svcpart '. $self->svcpart;
 249   }
 250
 251   my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
 252   my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
 253                                               'domsvc'   => $self->domsvc } );
 254   my @dup_uid;
 255   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
 256        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
 257     @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
 258   } else {
 259     @dup_uid = ();
 260   }
 261
 262   if ( @dup_user || @dup_userdomain || @dup_uid ) {
 263     my $exports = FS::part_export::export_info('svc_acct');
 264     my %conflict_user_svcpart;
 265     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
 266
 267     foreach my $part_export ( $part_svc->part_export ) {
 268
 269       #this will catch to the same exact export
 270       my @svcparts = map { $_->svcpart }
 271         qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 272
 273       #this will catch to exports w/same exporthost+type ???
 274       #my @other_part_export = qsearch('part_export', {
 275       #  'machine'    => $part_export->machine,
 276       #  'exporttype' => $part_export->exporttype,
 277       #} );
 278       #foreach my $other_part_export ( @other_part_export ) {
 279       #  push @svcparts, map { $_->svcpart }
 280       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 281       #}
 282
 283       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
 284       #silly kludge to avoid uninitialized value errors
 285       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
 286                      ? $exports->{$part_export->exporttype}{'nodomain'}
 287                      : '';
 288       if ( $nodomain =~ /^Y/i ) {
 289         $conflict_user_svcpart{$_} = $part_export->exportnum
 290           foreach @svcparts;
 291       } else {
 292         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
 293           foreach @svcparts;
 294       }
 295     }
 296
 297     foreach my $dup_user ( @dup_user ) {
 298       my $dup_svcpart = $dup_user->cust_svc->svcpart;
 299       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
 300         $dbh->rollback if $oldAutoCommit;
 301         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
 302                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
 303       }
 304     }
 305
 306     foreach my $dup_userdomain ( @dup_userdomain ) {
 307       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
 308       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 309         $dbh->rollback if $oldAutoCommit;
 310         return "duplicate username\@domain: conflicts with svcnum ".
 311                $dup_userdomain->svcnum. " via exportnum ".
 312                $conflict_userdomain_svcpart{$dup_svcpart};
 313       }
 314     }
 315
 316     foreach my $dup_uid ( @dup_uid ) {
 317       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
 318       if ( exists($conflict_user_svcpart{$dup_svcpart})
 319            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 320         $dbh->rollback if $oldAutoCommit;
 321         return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
 322                " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
 323                                  || $conflict_userdomain_svcpart{$dup_svcpart};
 324       }
 325     }
 326
 327   }
 328
 329   #see?  i told you it was more complicated
 330
 331   my @jobnums;
 332   $error = $self->SUPER::insert(\@jobnums, $self->child_objects || [] );
 333   if ( $error ) {
 334     $dbh->rollback if $oldAutoCommit;
 335     return $error;
 336   }
 337
 338   if ( $self->usergroup ) {
 339     foreach my $groupname ( @{$self->usergroup} ) {
 340       my $radius_usergroup = new FS::radius_usergroup ( {
 341         svcnum    => $self->svcnum,
 342         groupname => $groupname,
 343       } );
 344       my $error = $radius_usergroup->insert;
 345       if ( $error ) {
 346         $dbh->rollback if $oldAutoCommit;
 347         return $error;
 348       }
 349     }
 350   }
 351
 352   #false laziness with sub replace (and cust_main)
 353   my $queue = new FS::queue {
 354     'svcnum' => $self->svcnum,
 355     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 356   };
 357   $error = $queue->insert($self->username);
 358   if ( $error ) {
 359     $dbh->rollback if $oldAutoCommit;
 360     return "queueing job (transaction rolled back): $error";
 361   }
 362
 363   my $cust_pkg = $self->cust_svc->cust_pkg;
 364
 365   if ( $cust_pkg ) {
 366     my $cust_main = $cust_pkg->cust_main;
 367
 368     if ( $conf->exists('emailinvoiceauto') ) {
 369       my @invoicing_list = $cust_main->invoicing_list;
 370       push @invoicing_list, $self->email;
 371       $cust_main->invoicing_list(\@invoicing_list);
 372     }
 373
 374     #welcome email
 375     my $to = '';
 376     if ( $welcome_template && $cust_pkg ) {
 377       my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
 378       if ( $to ) {
 379         my $wqueue = new FS::queue {
 380           'svcnum' => $self->svcnum,
 381           'job'    => 'FS::svc_acct::send_email'
 382         };
 383         my $error = $wqueue->insert(
 384           'to'       => $to,
 385           'from'     => $welcome_from,
 386           'subject'  => $welcome_subject,
 387           'mimetype' => $welcome_mimetype,
 388           'body'     => $welcome_template->fill_in( HASH => {
 389                           'custnum'  => $self->custnum,
 390                           'username' => $self->username,
 391                           'password' => $self->_password,
 392                           'first'    => $cust_main->first,
 393                           'last'     => $cust_main->getfield('last'),
 394                           'pkg'      => $cust_pkg->part_pkg->pkg,
 395                         } ),
 396         );
 397         if ( $error ) {
 398           $dbh->rollback if $oldAutoCommit;
 399           return "error queuing welcome email: $error";
 400         }
 401
 402         foreach my $jobnum ( @jobnums ) {
 403           my $error = $wqueue->depend_insert($jobnum);
 404           if ( $error ) {
 405             $dbh->rollback if $oldAutoCommit;
 406             return "error queuing welcome email job dependancy: $error";
 407           }
 408         }
 409
 410       }
 411
 412     }
 413
 414   } # if ( $cust_pkg )
 415
 416   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 417   ''; #no error
 418 }
 419
 420 =item delete
 421
 422 Deletes this account from the database.  If there is an error, returns the
 423 error, otherwise returns false.
 424
 425 The corresponding FS::cust_svc record will be deleted as well.
 426
 427 (TODOC: new exports!)
 428
 429 =cut
 430
 431 sub delete {
 432   my $self = shift;
 433
 434   if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
 435     return "Can't delete an account which has (svc_acct_sm) mail aliases!"
 436       if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
 437   }
 438
 439   return "can't delete system account" if $self->_check_system;
 440
 441   return "Can't delete an account which is a (svc_forward) source!"
 442     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 443
 444   return "Can't delete an account which is a (svc_forward) destination!"
 445     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 446
 447   return "Can't delete an account with (svc_www) web service!"
 448     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
 449
 450   # what about records in session ? (they should refer to history table)
 451
 452   local $SIG{HUP} = 'IGNORE';
 453   local $SIG{INT} = 'IGNORE';
 454   local $SIG{QUIT} = 'IGNORE';
 455   local $SIG{TERM} = 'IGNORE';
 456   local $SIG{TSTP} = 'IGNORE';
 457   local $SIG{PIPE} = 'IGNORE';
 458
 459   my $oldAutoCommit = $FS::UID::AutoCommit;
 460   local $FS::UID::AutoCommit = 0;
 461   my $dbh = dbh;
 462
 463   foreach my $cust_main_invoice (
 464     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 465   ) {
 466     unless ( defined($cust_main_invoice) ) {
 467       warn "WARNING: something's wrong with qsearch";
 468       next;
 469     }
 470     my %hash = $cust_main_invoice->hash;
 471     $hash{'dest'} = $self->email;
 472     my $new = new FS::cust_main_invoice \%hash;
 473     my $error = $new->replace($cust_main_invoice);
 474     if ( $error ) {
 475       $dbh->rollback if $oldAutoCommit;
 476       return $error;
 477     }
 478   }
 479
 480   foreach my $svc_domain (
 481     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 482   ) {
 483     my %hash = new FS::svc_domain->hash;
 484     $hash{'catchall'} = '';
 485     my $new = new FS::svc_domain \%hash;
 486     my $error = $new->replace($svc_domain);
 487     if ( $error ) {
 488       $dbh->rollback if $oldAutoCommit;
 489       return $error;
 490     }
 491   }
 492
 493   foreach my $radius_usergroup (
 494     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 495   ) {
 496     my $error = $radius_usergroup->delete;
 497     if ( $error ) {
 498       $dbh->rollback if $oldAutoCommit;
 499       return $error;
 500     }
 501   }
 502
 503   my $error = $self->SUPER::delete;
 504   if ( $error ) {
 505     $dbh->rollback if $oldAutoCommit;
 506     return $error;
 507   }
 508
 509   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 510   '';
 511 }
 512
 513 =item replace OLD_RECORD
 514
 515 Replaces OLD_RECORD with this one in the database.  If there is an error,
 516 returns the error, otherwise returns false.
 517
 518 The additional field I<usergroup> can optionally be defined; if so it should
 519 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 520 sqlradius export only)
 521
 522 =cut
 523
 524 sub replace {
 525   my ( $new, $old ) = ( shift, shift );
 526   my $error;
 527   warn "$me replacing $old with $new\n" if $DEBUG;
 528
 529   return "can't modify system account" if $old->_check_system;
 530
 531   return "Username in use"
 532     if $old->username ne $new->username &&
 533       qsearchs( 'svc_acct', { 'username' => $new->username,
 534                                'domsvc'   => $new->domsvc,
 535                              } );
 536   {
 537     #no warnings 'numeric';  #alas, a 5.006-ism
 538     local($^W) = 0;
 539     return "Can't change uid!" if $old->uid != $new->uid;
 540   }
 541
 542   #change homdir when we change username
 543   $new->setfield('dir', '') if $old->username ne $new->username;
 544
 545   local $SIG{HUP} = 'IGNORE';
 546   local $SIG{INT} = 'IGNORE';
 547   local $SIG{QUIT} = 'IGNORE';
 548   local $SIG{TERM} = 'IGNORE';
 549   local $SIG{TSTP} = 'IGNORE';
 550   local $SIG{PIPE} = 'IGNORE';
 551
 552   my $oldAutoCommit = $FS::UID::AutoCommit;
 553   local $FS::UID::AutoCommit = 0;
 554   my $dbh = dbh;
 555
 556   # redundant, but so $new->usergroup gets set
 557   $error = $new->check;
 558   return $error if $error;
 559
 560   $old->usergroup( [ $old->radius_groups ] );
 561   warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
 562   warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
 563   if ( $new->usergroup ) {
 564     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 565     my @newgroups = @{$new->usergroup};
 566     foreach my $oldgroup ( @{$old->usergroup} ) {
 567       if ( grep { $oldgroup eq $_ } @newgroups ) {
 568         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 569         next;
 570       }
 571       my $radius_usergroup = qsearchs('radius_usergroup', {
 572         svcnum    => $old->svcnum,
 573         groupname => $oldgroup,
 574       } );
 575       my $error = $radius_usergroup->delete;
 576       if ( $error ) {
 577         $dbh->rollback if $oldAutoCommit;
 578         return "error deleting radius_usergroup $oldgroup: $error";
 579       }
 580     }
 581
 582     foreach my $newgroup ( @newgroups ) {
 583       my $radius_usergroup = new FS::radius_usergroup ( {
 584         svcnum    => $new->svcnum,
 585         groupname => $newgroup,
 586       } );
 587       my $error = $radius_usergroup->insert;
 588       if ( $error ) {
 589         $dbh->rollback if $oldAutoCommit;
 590         return "error adding radius_usergroup $newgroup: $error";
 591       }
 592     }
 593
 594   }
 595
 596   $error = $new->SUPER::replace($old);
 597   if ( $error ) {
 598     $dbh->rollback if $oldAutoCommit;
 599     return $error if $error;
 600   }
 601
 602   if ( $new->username ne $old->username ) {
 603     #false laziness with sub insert (and cust_main)
 604     my $queue = new FS::queue {
 605       'svcnum' => $new->svcnum,
 606       'job'    => 'FS::svc_acct::append_fuzzyfiles'
 607     };
 608     $error = $queue->insert($new->username);
 609     if ( $error ) {
 610       $dbh->rollback if $oldAutoCommit;
 611       return "queueing job (transaction rolled back): $error";
 612     }
 613   }
 614
 615   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 616   ''; #no error
 617 }
 618
 619 =item suspend
 620
 621 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 622 error, returns the error, otherwise returns false.
 623
 624 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 625
 626 Calls any export-specific suspend hooks.
 627
 628 =cut
 629
 630 sub suspend {
 631   my $self = shift;
 632   return "can't suspend system account" if $self->_check_system;
 633   my %hash = $self->hash;
 634   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 635            || $hash{_password} eq '*'
 636          ) {
 637     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 638     my $new = new FS::svc_acct ( \%hash );
 639     my $error = $new->replace($self);
 640     return $error if $error;
 641   }
 642
 643   $self->SUPER::suspend;
 644 }
 645
 646 =item unsuspend
 647
 648 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 649 an error, returns the error, otherwise returns false.
 650
 651 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 652
 653 Calls any export-specific unsuspend hooks.
 654
 655 =cut
 656
 657 sub unsuspend {
 658   my $self = shift;
 659   my %hash = $self->hash;
 660   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 661     $hash{_password} = $1;
 662     my $new = new FS::svc_acct ( \%hash );
 663     my $error = $new->replace($self);
 664     return $error if $error;
 665   }
 666
 667   $self->SUPER::unsuspend;
 668 }
 669
 670 =item cancel
 671
 672 Just returns false (no error) for now.
 673
 674 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 675
 676 =item check
 677
 678 Checks all fields to make sure this is a valid service.  If there is an error,
 679 returns the error, otherwise returns false.  Called by the insert and replace
 680 methods.
 681
 682 Sets any fixed values; see L<FS::part_svc>.
 683
 684 =cut
 685
 686 sub check {
 687   my $self = shift;
 688
 689   my($recref) = $self->hashref;
 690
 691   my $x = $self->setfixed;
 692   return $x unless ref($x);
 693   my $part_svc = $x;
 694
 695   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 696     $self->usergroup(
 697       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 698   }
 699
 700   my $error = $self->ut_numbern('svcnum')
 701               #|| $self->ut_number('domsvc')
 702               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 703               || $self->ut_textn('sec_phrase')
 704   ;
 705   return $error if $error;
 706
 707   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 708   if ( $username_uppercase ) {
 709     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 710       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 711     $recref->{username} = $1;
 712   } else {
 713     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 714       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 715     $recref->{username} = $1;
 716   }
 717
 718   if ( $username_letterfirst ) {
 719     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 720   } elsif ( $username_letter ) {
 721     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 722   }
 723   if ( $username_noperiod ) {
 724     $recref->{username} =~ /\./ and return gettext('illegal_username');
 725   }
 726   if ( $username_nounderscore ) {
 727     $recref->{username} =~ /_/ and return gettext('illegal_username');
 728   }
 729   if ( $username_nodash ) {
 730     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 731   }
 732   unless ( $username_ampersand ) {
 733     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 734   }
 735
 736   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 737   $recref->{popnum} = $1;
 738   return "Unknown popnum" unless
 739     ! $recref->{popnum} ||
 740     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 741
 742   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 743
 744     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 745     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 746
 747     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 748     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 749     #not all systems use gid=uid
 750     #you can set a fixed gid in part_svc
 751
 752     return "Only root can have uid 0"
 753       if $recref->{uid} == 0
 754          && $recref->{username} ne 'root'
 755          && $recref->{username} ne 'toor';
 756
 757
 758     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 759       or return "Illegal directory: ". $recref->{dir};
 760     $recref->{dir} = $1;
 761     return "Illegal directory"
 762       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 763     return "Illegal directory"
 764       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 765     unless ( $recref->{dir} ) {
 766       $recref->{dir} = $dir_prefix . '/';
 767       if ( $dirhash > 0 ) {
 768         for my $h ( 1 .. $dirhash ) {
 769           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 770         }
 771       } elsif ( $dirhash < 0 ) {
 772         for my $h ( reverse $dirhash .. -1 ) {
 773           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 774         }
 775       }
 776       $recref->{dir} .= $recref->{username};
 777     ;
 778     }
 779
 780     unless ( $recref->{username} eq 'sync' ) {
 781       if ( grep $_ eq $recref->{shell}, @shells ) {
 782         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 783       } else {
 784         return "Illegal shell \`". $self->shell. "\'; ".
 785                $conf->dir. "/shells contains: @shells";
 786       }
 787     } else {
 788       $recref->{shell} = '/bin/sync';
 789     }
 790
 791   } else {
 792     $recref->{gid} ne '' ?
 793       return "Can't have gid without uid" : ( $recref->{gid}='' );
 794     $recref->{dir} ne '' ?
 795       return "Can't have directory without uid" : ( $recref->{dir}='' );
 796     $recref->{shell} ne '' ?
 797       return "Can't have shell without uid" : ( $recref->{shell}='' );
 798   }
 799
 800   #  $error = $self->ut_textn('finger');
 801   #  return $error if $error;
 802   $self->getfield('finger') =~
 803     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 804       or return "Illegal finger: ". $self->getfield('finger');
 805   $self->setfield('finger', $1);
 806
 807   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
 808   $recref->{quota} = $1;
 809
 810   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 811     if ( $recref->{slipip} eq '' ) {
 812       $recref->{slipip} = '';
 813     } elsif ( $recref->{slipip} eq '0e0' ) {
 814       $recref->{slipip} = '0e0';
 815     } else {
 816       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 817         or return "Illegal slipip". $self->slipip;
 818       $recref->{slipip} = $1;
 819     }
 820
 821   }
 822
 823   #arbitrary RADIUS stuff; allow ut_textn for now
 824   foreach ( grep /^radius_/, fields('svc_acct') ) {
 825     $self->ut_textn($_);
 826   }
 827
 828   #generate a password if it is blank
 829   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 830     unless ( $recref->{_password} );
 831
 832   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 833   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 834     $recref->{_password} = $1.$3;
 835     #uncomment this to encrypt password immediately upon entry, or run
 836     #bin/crypt_pw in cron to give new users a window during which their
 837     #password is available to techs, for faxing, etc.  (also be aware of
 838     #radius issues!)
 839     #$recref->{password} = $1.
 840     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 841     #;
 842   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 843     $recref->{_password} = $1.$3;
 844   } elsif ( $recref->{_password} eq '*' ) {
 845     $recref->{_password} = '*';
 846   } elsif ( $recref->{_password} eq '!' ) {
 847     $recref->{_password} = '!';
 848   } elsif ( $recref->{_password} eq '!!' ) {
 849     $recref->{_password} = '!!';
 850   } else {
 851     #return "Illegal password";
 852     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 853            FS::Msgcat::_gettext('illegal_password_characters').
 854            ": ". $recref->{_password};
 855   }
 856
 857   ''; #no error
 858 }
 859
 860 =item _check_system
 861
 862 =cut
 863
 864 sub _check_system {
 865   my $self = shift;
 866   scalar( grep { $self->username eq $_ || $self->email eq $_ }
 867                $conf->config('system_usernames')
 868         );
 869 }
 870
 871
 872 =item radius
 873
 874 Depriciated, use radius_reply instead.
 875
 876 =cut
 877
 878 sub radius {
 879   carp "FS::svc_acct::radius depriciated, use radius_reply";
 880   $_[0]->radius_reply;
 881 }
 882
 883 =item radius_reply
 884
 885 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 886 reply attributes of this record.
 887
 888 Note that this is now the preferred method for reading RADIUS attributes -
 889 accessing the columns directly is discouraged, as the column names are
 890 expected to change in the future.
 891
 892 =cut
 893
 894 sub radius_reply {
 895   my $self = shift;
 896   my %reply =
 897     map {
 898       /^(radius_(.*))$/;
 899       my($column, $attrib) = ($1, $2);
 900       #$attrib =~ s/_/\-/g;
 901       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 902     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 903   if ( $self->slipip && $self->slipip ne '0e0' ) {
 904     $reply{$radius_ip} = $self->slipip;
 905   }
 906   %reply;
 907 }
 908
 909 =item radius_check
 910
 911 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 912 check attributes of this record.
 913
 914 Note that this is now the preferred method for reading RADIUS attributes -
 915 accessing the columns directly is discouraged, as the column names are
 916 expected to change in the future.
 917
 918 =cut
 919
 920 sub radius_check {
 921   my $self = shift;
 922   my $password = $self->_password;
 923   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
 924   ( $pw_attrib => $self->_password,
 925     map {
 926       /^(rc_(.*))$/;
 927       my($column, $attrib) = ($1, $2);
 928       #$attrib =~ s/_/\-/g;
 929       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 930     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 931   );
 932 }
 933
 934 =item domain
 935
 936 Returns the domain associated with this account.
 937
 938 =cut
 939
 940 sub domain {
 941   my $self = shift;
 942   if ( $self->domsvc ) {
 943     #$self->svc_domain->domain;
 944     my $svc_domain = $self->svc_domain
 945       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 946     $svc_domain->domain;
 947   } else {
 948     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
 949   }
 950 }
 951
 952 =item svc_domain
 953
 954 Returns the FS::svc_domain record for this account's domain (see
 955 L<FS::svc_domain>).
 956
 957 =cut
 958
 959 sub svc_domain {
 960   my $self = shift;
 961   $self->{'_domsvc'}
 962     ? $self->{'_domsvc'}
 963     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 964 }
 965
 966 =item cust_svc
 967
 968 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 969
 970 =cut
 971
 972 sub cust_svc {
 973   my $self = shift;
 974   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 975 }
 976
 977 =item email
 978
 979 Returns an email address associated with the account.
 980
 981 =cut
 982
 983 sub email {
 984   my $self = shift;
 985   $self->username. '@'. $self->domain;
 986 }
 987
 988 =item acct_snarf
 989
 990 Returns an array of FS::acct_snarf records associated with the account.
 991 If the acct_snarf table does not exist or there are no associated records,
 992 an empty list is returned
 993
 994 =cut
 995
 996 sub acct_snarf {
 997   my $self = shift;
 998   return () unless dbdef->table('acct_snarf');
 999   eval "use FS::acct_snarf;";
1000   die $@ if $@;
1001   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1002 }
1003
1004 =item seconds_since TIMESTAMP
1005
1006 Returns the number of seconds this account has been online since TIMESTAMP,
1007 according to the session monitor (see L<FS::Session>).
1008
1009 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1010 L<Time::Local> and L<Date::Parse> for conversion functions.
1011
1012 =cut
1013
1014 #note: POD here, implementation in FS::cust_svc
1015 sub seconds_since {
1016   my $self = shift;
1017   $self->cust_svc->seconds_since(@_);
1018 }
1019
1020 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1021
1022 Returns the numbers of seconds this account has been online between
1023 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1024 external SQL radacct table, specified via sqlradius export.  Sessions which
1025 started in the specified range but are still open are counted from session
1026 start to the end of the range (unless they are over 1 day old, in which case
1027 they are presumed missing their stop record and not counted).  Also, sessions
1028 which end in the range but started earlier are counted from the start of the
1029 range to session end.  Finally, sessions which start before the range but end
1030 after are counted for the entire range.
1031
1032 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1033 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1034 functions.
1035
1036 =cut
1037
1038 #note: POD here, implementation in FS::cust_svc
1039 sub seconds_since_sqlradacct {
1040   my $self = shift;
1041   $self->cust_svc->seconds_since_sqlradacct(@_);
1042 }
1043
1044 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1045
1046 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1047 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1048 TIMESTAMP_END (exclusive).
1049
1050 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1051 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1052 functions.
1053
1054 =cut
1055
1056 #note: POD here, implementation in FS::cust_svc
1057 sub attribute_since_sqlradacct {
1058   my $self = shift;
1059   $self->cust_svc->attribute_since_sqlradacct(@_);
1060 }
1061
1062
1063 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1064
1065 Returns an array of hash references of this customers login history for the
1066 given time range.  (document this better)
1067
1068 =cut
1069
1070 sub get_session_history_sqlradacct {
1071   my $self = shift;
1072   $self->cust_svc->get_session_history_sqlradacct(@_);
1073 }
1074
1075 =item radius_groups
1076
1077 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1078
1079 =cut
1080
1081 sub radius_groups {
1082   my $self = shift;
1083   if ( $self->usergroup ) {
1084     #when provisioning records, export callback runs in svc_Common.pm before
1085     #radius_usergroup records can be inserted...
1086     @{$self->usergroup};
1087   } else {
1088     map { $_->groupname }
1089       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1090   }
1091 }
1092
1093 =back
1094
1095 =head1 SUBROUTINES
1096
1097 =over 4
1098
1099 =item send_email
1100
1101 =cut
1102
1103 sub send_email {
1104   my %opt = @_;
1105
1106   use Date::Format;
1107   use Mail::Internet 1.44;
1108   use Mail::Header;
1109
1110   $opt{mimetype} ||= 'text/plain';
1111   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1112
1113   $ENV{MAILADDRESS} = $opt{from};
1114   my $header = new Mail::Header ( [
1115     "From: $opt{from}",
1116     "To: $opt{to}",
1117     "Sender: $opt{from}",
1118     "Reply-To: $opt{from}",
1119     "Date: ". time2str("%a, %d %b %Y %X %z", time),
1120     "Subject: $opt{subject}",
1121     "Content-Type: $opt{mimetype}",
1122   ] );
1123   my $message = new Mail::Internet (
1124     'Header' => $header,
1125     'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1126   );
1127   $!=0;
1128   $message->smtpsend( Host => $smtpmachine )
1129     or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1130       or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1131 }
1132
1133 =item check_and_rebuild_fuzzyfiles
1134
1135 =cut
1136
1137 sub check_and_rebuild_fuzzyfiles {
1138   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1139   -e "$dir/svc_acct.username"
1140     or &rebuild_fuzzyfiles;
1141 }
1142
1143 =item rebuild_fuzzyfiles
1144
1145 =cut
1146
1147 sub rebuild_fuzzyfiles {
1148
1149   use Fcntl qw(:flock);
1150
1151   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1152
1153   #username
1154
1155   open(USERNAMELOCK,">>$dir/svc_acct.username")
1156     or die "can't open $dir/svc_acct.username: $!";
1157   flock(USERNAMELOCK,LOCK_EX)
1158     or die "can't lock $dir/svc_acct.username: $!";
1159
1160   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1161
1162   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1163     or die "can't open $dir/svc_acct.username.tmp: $!";
1164   print USERNAMECACHE join("\n", @all_username), "\n";
1165   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1166
1167   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1168   close USERNAMELOCK;
1169
1170 }
1171
1172 =item all_username
1173
1174 =cut
1175
1176 sub all_username {
1177   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1178   open(USERNAMECACHE,"<$dir/svc_acct.username")
1179     or die "can't open $dir/svc_acct.username: $!";
1180   my @array = map { chomp; $_; } <USERNAMECACHE>;
1181   close USERNAMECACHE;
1182   \@array;
1183 }
1184
1185 =item append_fuzzyfiles USERNAME
1186
1187 =cut
1188
1189 sub append_fuzzyfiles {
1190   my $username = shift;
1191
1192   &check_and_rebuild_fuzzyfiles;
1193
1194   use Fcntl qw(:flock);
1195
1196   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1197
1198   open(USERNAME,">>$dir/svc_acct.username")
1199     or die "can't open $dir/svc_acct.username: $!";
1200   flock(USERNAME,LOCK_EX)
1201     or die "can't lock $dir/svc_acct.username: $!";
1202
1203   print USERNAME "$username\n";
1204
1205   flock(USERNAME,LOCK_UN)
1206     or die "can't unlock $dir/svc_acct.username: $!";
1207   close USERNAME;
1208
1209   1;
1210 }
1211
1212
1213
1214 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1215
1216 =cut
1217
1218 sub radius_usergroup_selector {
1219   my $sel_groups = shift;
1220   my %sel_groups = map { $_=>1 } @$sel_groups;
1221
1222   my $selectname = shift || 'radius_usergroup';
1223
1224   my $dbh = dbh;
1225   my $sth = $dbh->prepare(
1226     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1227   ) or die $dbh->errstr;
1228   $sth->execute() or die $sth->errstr;
1229   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1230
1231   my $html = <<END;
1232     <SCRIPT>
1233     function ${selectname}_doadd(object) {
1234       var myvalue = object.${selectname}_add.value;
1235       var optionName = new Option(myvalue,myvalue,false,true);
1236       var length = object.$selectname.length;
1237       object.$selectname.options[length] = optionName;
1238       object.${selectname}_add.value = "";
1239     }
1240     </SCRIPT>
1241     <SELECT MULTIPLE NAME="$selectname">
1242 END
1243
1244   foreach my $group ( @all_groups ) {
1245     $html .= '<OPTION';
1246     if ( $sel_groups{$group} ) {
1247       $html .= ' SELECTED';
1248       $sel_groups{$group} = 0;
1249     }
1250     $html .= ">$group</OPTION>\n";
1251   }
1252   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1253     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1254   };
1255   $html .= '</SELECT>';
1256
1257   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1258            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1259
1260   $html;
1261 }
1262
1263 =back
1264
1265 =head1 BUGS
1266
1267 The $recref stuff in sub check should be cleaned up.
1268
1269 The suspend, unsuspend and cancel methods update the database, but not the
1270 current object.  This is probably a bug as it's unexpected and
1271 counterintuitive.
1272
1273 radius_usergroup_selector?  putting web ui components in here?  they should
1274 probably live somewhere else...
1275
1276 =head1 SEE ALSO
1277
1278 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1279 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1280 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1281 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1282 schema.html from the base documentation.
1283
1284 =cut
1285
1286 1;
1287