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   $self->SUPER::suspend;
 634 }
 635
 636 =item unsuspend
 637
 638 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 639 an error, returns the error, otherwise returns false.
 640
 641 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 642
 643 Calls any export-specific unsuspend hooks.
 644
 645 =cut
 646
 647 sub unsuspend {
 648   my $self = shift;
 649   my %hash = $self->hash;
 650   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 651     $hash{_password} = $1;
 652     my $new = new FS::svc_acct ( \%hash );
 653     my $error = $new->replace($self);
 654     return $error if $error;
 655   }
 656
 657   $self->SUPER::unsuspend;
 658 }
 659
 660 =item cancel
 661
 662 Just returns false (no error) for now.
 663
 664 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 665
 666 =item check
 667
 668 Checks all fields to make sure this is a valid service.  If there is an error,
 669 returns the error, otherwise returns false.  Called by the insert and replace
 670 methods.
 671
 672 Sets any fixed values; see L<FS::part_svc>.
 673
 674 =cut
 675
 676 sub check {
 677   my $self = shift;
 678
 679   my($recref) = $self->hashref;
 680
 681   my $x = $self->setfixed;
 682   return $x unless ref($x);
 683   my $part_svc = $x;
 684
 685   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 686     $self->usergroup(
 687       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 688   }
 689
 690   my $error = $self->ut_numbern('svcnum')
 691               #|| $self->ut_number('domsvc')
 692               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 693               || $self->ut_textn('sec_phrase')
 694   ;
 695   return $error if $error;
 696
 697   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 698   if ( $username_uppercase ) {
 699     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 700       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 701     $recref->{username} = $1;
 702   } else {
 703     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 704       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 705     $recref->{username} = $1;
 706   }
 707
 708   if ( $username_letterfirst ) {
 709     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 710   } elsif ( $username_letter ) {
 711     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 712   }
 713   if ( $username_noperiod ) {
 714     $recref->{username} =~ /\./ and return gettext('illegal_username');
 715   }
 716   if ( $username_nounderscore ) {
 717     $recref->{username} =~ /_/ and return gettext('illegal_username');
 718   }
 719   if ( $username_nodash ) {
 720     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 721   }
 722   unless ( $username_ampersand ) {
 723     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 724   }
 725
 726   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 727   $recref->{popnum} = $1;
 728   return "Unknown popnum" unless
 729     ! $recref->{popnum} ||
 730     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 731
 732   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 733
 734     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 735     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 736
 737     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 738     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 739     #not all systems use gid=uid
 740     #you can set a fixed gid in part_svc
 741
 742     return "Only root can have uid 0"
 743       if $recref->{uid} == 0
 744          && $recref->{username} ne 'root'
 745          && $recref->{username} ne 'toor';
 746
 747
 748     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 749       or return "Illegal directory: ". $recref->{dir};
 750     $recref->{dir} = $1;
 751     return "Illegal directory"
 752       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 753     return "Illegal directory"
 754       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 755     unless ( $recref->{dir} ) {
 756       $recref->{dir} = $dir_prefix . '/';
 757       if ( $dirhash > 0 ) {
 758         for my $h ( 1 .. $dirhash ) {
 759           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 760         }
 761       } elsif ( $dirhash < 0 ) {
 762         for my $h ( reverse $dirhash .. -1 ) {
 763           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 764         }
 765       }
 766       $recref->{dir} .= $recref->{username};
 767     ;
 768     }
 769
 770     unless ( $recref->{username} eq 'sync' ) {
 771       if ( grep $_ eq $recref->{shell}, @shells ) {
 772         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 773       } else {
 774         return "Illegal shell \`". $self->shell. "\'; ".
 775                $conf->dir. "/shells contains: @shells";
 776       }
 777     } else {
 778       $recref->{shell} = '/bin/sync';
 779     }
 780
 781   } else {
 782     $recref->{gid} ne '' ?
 783       return "Can't have gid without uid" : ( $recref->{gid}='' );
 784     $recref->{dir} ne '' ?
 785       return "Can't have directory without uid" : ( $recref->{dir}='' );
 786     $recref->{shell} ne '' ?
 787       return "Can't have shell without uid" : ( $recref->{shell}='' );
 788   }
 789
 790   #  $error = $self->ut_textn('finger');
 791   #  return $error if $error;
 792   $self->getfield('finger') =~
 793     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 794       or return "Illegal finger: ". $self->getfield('finger');
 795   $self->setfield('finger', $1);
 796
 797   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
 798   $recref->{quota} = $1;
 799
 800   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 801     if ( $recref->{slipip} eq '' ) {
 802       $recref->{slipip} = '';
 803     } elsif ( $recref->{slipip} eq '0e0' ) {
 804       $recref->{slipip} = '0e0';
 805     } else {
 806       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 807         or return "Illegal slipip". $self->slipip;
 808       $recref->{slipip} = $1;
 809     }
 810
 811   }
 812
 813   #arbitrary RADIUS stuff; allow ut_textn for now
 814   foreach ( grep /^radius_/, fields('svc_acct') ) {
 815     $self->ut_textn($_);
 816   }
 817
 818   #generate a password if it is blank
 819   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 820     unless ( $recref->{_password} );
 821
 822   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 823   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 824     $recref->{_password} = $1.$3;
 825     #uncomment this to encrypt password immediately upon entry, or run
 826     #bin/crypt_pw in cron to give new users a window during which their
 827     #password is available to techs, for faxing, etc.  (also be aware of
 828     #radius issues!)
 829     #$recref->{password} = $1.
 830     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 831     #;
 832   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 833     $recref->{_password} = $1.$3;
 834   } elsif ( $recref->{_password} eq '*' ) {
 835     $recref->{_password} = '*';
 836   } elsif ( $recref->{_password} eq '!' ) {
 837     $recref->{_password} = '!';
 838   } elsif ( $recref->{_password} eq '!!' ) {
 839     $recref->{_password} = '!!';
 840   } else {
 841     #return "Illegal password";
 842     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 843            FS::Msgcat::_gettext('illegal_password_characters').
 844            ": ". $recref->{_password};
 845   }
 846
 847   ''; #no error
 848 }
 849
 850 =item _check_system
 851
 852 =cut
 853
 854 sub _check_system {
 855   my $self = shift;
 856   scalar( grep { $self->username eq $_ || $self->email eq $_ }
 857                $conf->config('system_usernames')
 858         );
 859 }
 860
 861
 862 =item radius
 863
 864 Depriciated, use radius_reply instead.
 865
 866 =cut
 867
 868 sub radius {
 869   carp "FS::svc_acct::radius depriciated, use radius_reply";
 870   $_[0]->radius_reply;
 871 }
 872
 873 =item radius_reply
 874
 875 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 876 reply attributes of this record.
 877
 878 Note that this is now the preferred method for reading RADIUS attributes -
 879 accessing the columns directly is discouraged, as the column names are
 880 expected to change in the future.
 881
 882 =cut
 883
 884 sub radius_reply {
 885   my $self = shift;
 886   my %reply =
 887     map {
 888       /^(radius_(.*))$/;
 889       my($column, $attrib) = ($1, $2);
 890       #$attrib =~ s/_/\-/g;
 891       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 892     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 893   if ( $self->slipip && $self->slipip ne '0e0' ) {
 894     $reply{$radius_ip} = $self->slipip;
 895   }
 896   %reply;
 897 }
 898
 899 =item radius_check
 900
 901 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 902 check attributes of this record.
 903
 904 Note that this is now the preferred method for reading RADIUS attributes -
 905 accessing the columns directly is discouraged, as the column names are
 906 expected to change in the future.
 907
 908 =cut
 909
 910 sub radius_check {
 911   my $self = shift;
 912   my $password = $self->_password;
 913   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
 914   ( $pw_attrib => $self->_password,
 915     map {
 916       /^(rc_(.*))$/;
 917       my($column, $attrib) = ($1, $2);
 918       #$attrib =~ s/_/\-/g;
 919       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 920     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 921   );
 922 }
 923
 924 =item domain
 925
 926 Returns the domain associated with this account.
 927
 928 =cut
 929
 930 sub domain {
 931   my $self = shift;
 932   if ( $self->domsvc ) {
 933     #$self->svc_domain->domain;
 934     my $svc_domain = $self->svc_domain
 935       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 936     $svc_domain->domain;
 937   } else {
 938     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
 939   }
 940 }
 941
 942 =item svc_domain
 943
 944 Returns the FS::svc_domain record for this account's domain (see
 945 L<FS::svc_domain>).
 946
 947 =cut
 948
 949 sub svc_domain {
 950   my $self = shift;
 951   $self->{'_domsvc'}
 952     ? $self->{'_domsvc'}
 953     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 954 }
 955
 956 =item cust_svc
 957
 958 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 959
 960 =cut
 961
 962 sub cust_svc {
 963   my $self = shift;
 964   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 965 }
 966
 967 =item email
 968
 969 Returns an email address associated with the account.
 970
 971 =cut
 972
 973 sub email {
 974   my $self = shift;
 975   $self->username. '@'. $self->domain;
 976 }
 977
 978 =item acct_snarf
 979
 980 Returns an array of FS::acct_snarf records associated with the account.
 981 If the acct_snarf table does not exist or there are no associated records,
 982 an empty list is returned
 983
 984 =cut
 985
 986 sub acct_snarf {
 987   my $self = shift;
 988   return () unless dbdef->table('acct_snarf');
 989   eval "use FS::acct_snarf;";
 990   die $@ if $@;
 991   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
 992 }
 993
 994 =item seconds_since TIMESTAMP
 995
 996 Returns the number of seconds this account has been online since TIMESTAMP,
 997 according to the session monitor (see L<FS::Session>).
 998
 999 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1000 L<Time::Local> and L<Date::Parse> for conversion functions.
1001
1002 =cut
1003
1004 #note: POD here, implementation in FS::cust_svc
1005 sub seconds_since {
1006   my $self = shift;
1007   $self->cust_svc->seconds_since(@_);
1008 }
1009
1010 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1011
1012 Returns the numbers of seconds this account has been online between
1013 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1014 external SQL radacct table, specified via sqlradius export.  Sessions which
1015 started in the specified range but are still open are counted from session
1016 start to the end of the range (unless they are over 1 day old, in which case
1017 they are presumed missing their stop record and not counted).  Also, sessions
1018 which end in the range but started earlier are counted from the start of the
1019 range to session end.  Finally, sessions which start before the range but end
1020 after are counted for the entire range.
1021
1022 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1023 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1024 functions.
1025
1026 =cut
1027
1028 #note: POD here, implementation in FS::cust_svc
1029 sub seconds_since_sqlradacct {
1030   my $self = shift;
1031   $self->cust_svc->seconds_since_sqlradacct(@_);
1032 }
1033
1034 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1035
1036 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1037 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1038 TIMESTAMP_END (exclusive).
1039
1040 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1041 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1042 functions.
1043
1044 =cut
1045
1046 #note: POD here, implementation in FS::cust_svc
1047 sub attribute_since_sqlradacct {
1048   my $self = shift;
1049   $self->cust_svc->attribute_since_sqlradacct(@_);
1050 }
1051
1052
1053 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1054
1055 Returns an array of hash references of this customers login history for the
1056 given time range.  (document this better)
1057
1058 =cut
1059
1060 sub get_session_history_sqlradacct {
1061   my $self = shift;
1062   $self->cust_svc->get_session_history_sqlradacct(@_);
1063 }
1064
1065 =item radius_groups
1066
1067 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1068
1069 =cut
1070
1071 sub radius_groups {
1072   my $self = shift;
1073   if ( $self->usergroup ) {
1074     #when provisioning records, export callback runs in svc_Common.pm before
1075     #radius_usergroup records can be inserted...
1076     @{$self->usergroup};
1077   } else {
1078     map { $_->groupname }
1079       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1080   }
1081 }
1082
1083 =item clone_suspended
1084
1085 Constructor used by FS::part_export::_export_suspend fallback.  Document
1086 better.
1087
1088 =cut
1089
1090 sub clone_suspended {
1091   my $self = shift;
1092   my %hash = $self->hash;
1093   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1094   new FS::svc_acct \%hash;
1095 }
1096
1097 =item clone_kludge_unsuspend
1098
1099 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1100 better.
1101
1102 =cut
1103
1104 sub clone_kludge_unsuspend {
1105   my $self = shift;
1106   my %hash = $self->hash;
1107   $hash{_password} = '';
1108   new FS::svc_acct \%hash;
1109 }
1110
1111 =back
1112
1113 =head1 SUBROUTINES
1114
1115 =over 4
1116
1117 =item send_email
1118
1119 =cut
1120
1121 sub send_email {
1122   my %opt = @_;
1123
1124   use Date::Format;
1125   use Mail::Internet 1.44;
1126   use Mail::Header;
1127
1128   $opt{mimetype} ||= 'text/plain';
1129   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1130
1131   $ENV{MAILADDRESS} = $opt{from};
1132   my $header = new Mail::Header ( [
1133     "From: $opt{from}",
1134     "To: $opt{to}",
1135     "Sender: $opt{from}",
1136     "Reply-To: $opt{from}",
1137     "Date: ". time2str("%a, %d %b %Y %X %z", time),
1138     "Subject: $opt{subject}",
1139     "Content-Type: $opt{mimetype}",
1140   ] );
1141   my $message = new Mail::Internet (
1142     'Header' => $header,
1143     'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1144   );
1145   $!=0;
1146   $message->smtpsend( Host => $smtpmachine )
1147     or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1148       or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1149 }
1150
1151 =item check_and_rebuild_fuzzyfiles
1152
1153 =cut
1154
1155 sub check_and_rebuild_fuzzyfiles {
1156   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1157   -e "$dir/svc_acct.username"
1158     or &rebuild_fuzzyfiles;
1159 }
1160
1161 =item rebuild_fuzzyfiles
1162
1163 =cut
1164
1165 sub rebuild_fuzzyfiles {
1166
1167   use Fcntl qw(:flock);
1168
1169   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1170
1171   #username
1172
1173   open(USERNAMELOCK,">>$dir/svc_acct.username")
1174     or die "can't open $dir/svc_acct.username: $!";
1175   flock(USERNAMELOCK,LOCK_EX)
1176     or die "can't lock $dir/svc_acct.username: $!";
1177
1178   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1179
1180   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1181     or die "can't open $dir/svc_acct.username.tmp: $!";
1182   print USERNAMECACHE join("\n", @all_username), "\n";
1183   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1184
1185   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1186   close USERNAMELOCK;
1187
1188 }
1189
1190 =item all_username
1191
1192 =cut
1193
1194 sub all_username {
1195   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1196   open(USERNAMECACHE,"<$dir/svc_acct.username")
1197     or die "can't open $dir/svc_acct.username: $!";
1198   my @array = map { chomp; $_; } <USERNAMECACHE>;
1199   close USERNAMECACHE;
1200   \@array;
1201 }
1202
1203 =item append_fuzzyfiles USERNAME
1204
1205 =cut
1206
1207 sub append_fuzzyfiles {
1208   my $username = shift;
1209
1210   &check_and_rebuild_fuzzyfiles;
1211
1212   use Fcntl qw(:flock);
1213
1214   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1215
1216   open(USERNAME,">>$dir/svc_acct.username")
1217     or die "can't open $dir/svc_acct.username: $!";
1218   flock(USERNAME,LOCK_EX)
1219     or die "can't lock $dir/svc_acct.username: $!";
1220
1221   print USERNAME "$username\n";
1222
1223   flock(USERNAME,LOCK_UN)
1224     or die "can't unlock $dir/svc_acct.username: $!";
1225   close USERNAME;
1226
1227   1;
1228 }
1229
1230
1231
1232 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1233
1234 =cut
1235
1236 sub radius_usergroup_selector {
1237   my $sel_groups = shift;
1238   my %sel_groups = map { $_=>1 } @$sel_groups;
1239
1240   my $selectname = shift || 'radius_usergroup';
1241
1242   my $dbh = dbh;
1243   my $sth = $dbh->prepare(
1244     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1245   ) or die $dbh->errstr;
1246   $sth->execute() or die $sth->errstr;
1247   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1248
1249   my $html = <<END;
1250     <SCRIPT>
1251     function ${selectname}_doadd(object) {
1252       var myvalue = object.${selectname}_add.value;
1253       var optionName = new Option(myvalue,myvalue,false,true);
1254       var length = object.$selectname.length;
1255       object.$selectname.options[length] = optionName;
1256       object.${selectname}_add.value = "";
1257     }
1258     </SCRIPT>
1259     <SELECT MULTIPLE NAME="$selectname">
1260 END
1261
1262   foreach my $group ( @all_groups ) {
1263     $html .= '<OPTION';
1264     if ( $sel_groups{$group} ) {
1265       $html .= ' SELECTED';
1266       $sel_groups{$group} = 0;
1267     }
1268     $html .= ">$group</OPTION>\n";
1269   }
1270   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1271     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1272   };
1273   $html .= '</SELECT>';
1274
1275   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1276            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1277
1278   $html;
1279 }
1280
1281 =back
1282
1283 =head1 BUGS
1284
1285 The $recref stuff in sub check should be cleaned up.
1286
1287 The suspend, unsuspend and cancel methods update the database, but not the
1288 current object.  This is probably a bug as it's unexpected and
1289 counterintuitive.
1290
1291 radius_usergroup_selector?  putting web ui components in here?  they should
1292 probably live somewhere else...
1293
1294 =head1 SEE ALSO
1295
1296 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1297 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1298 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1299 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1300 schema.html from the base documentation.
1301
1302 =cut
1303
1304 1;
1305