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 =back
1084
1085 =head1 SUBROUTINES
1086
1087 =over 4
1088
1089 =item send_email
1090
1091 =cut
1092
1093 sub send_email {
1094   my %opt = @_;
1095
1096   use Date::Format;
1097   use Mail::Internet 1.44;
1098   use Mail::Header;
1099
1100   $opt{mimetype} ||= 'text/plain';
1101   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1102
1103   $ENV{MAILADDRESS} = $opt{from};
1104   my $header = new Mail::Header ( [
1105     "From: $opt{from}",
1106     "To: $opt{to}",
1107     "Sender: $opt{from}",
1108     "Reply-To: $opt{from}",
1109     "Date: ". time2str("%a, %d %b %Y %X %z", time),
1110     "Subject: $opt{subject}",
1111     "Content-Type: $opt{mimetype}",
1112   ] );
1113   my $message = new Mail::Internet (
1114     'Header' => $header,
1115     'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1116   );
1117   $!=0;
1118   $message->smtpsend( Host => $smtpmachine )
1119     or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1120       or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1121 }
1122
1123 =item check_and_rebuild_fuzzyfiles
1124
1125 =cut
1126
1127 sub check_and_rebuild_fuzzyfiles {
1128   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1129   -e "$dir/svc_acct.username"
1130     or &rebuild_fuzzyfiles;
1131 }
1132
1133 =item rebuild_fuzzyfiles
1134
1135 =cut
1136
1137 sub rebuild_fuzzyfiles {
1138
1139   use Fcntl qw(:flock);
1140
1141   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1142
1143   #username
1144
1145   open(USERNAMELOCK,">>$dir/svc_acct.username")
1146     or die "can't open $dir/svc_acct.username: $!";
1147   flock(USERNAMELOCK,LOCK_EX)
1148     or die "can't lock $dir/svc_acct.username: $!";
1149
1150   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1151
1152   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1153     or die "can't open $dir/svc_acct.username.tmp: $!";
1154   print USERNAMECACHE join("\n", @all_username), "\n";
1155   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1156
1157   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1158   close USERNAMELOCK;
1159
1160 }
1161
1162 =item all_username
1163
1164 =cut
1165
1166 sub all_username {
1167   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1168   open(USERNAMECACHE,"<$dir/svc_acct.username")
1169     or die "can't open $dir/svc_acct.username: $!";
1170   my @array = map { chomp; $_; } <USERNAMECACHE>;
1171   close USERNAMECACHE;
1172   \@array;
1173 }
1174
1175 =item append_fuzzyfiles USERNAME
1176
1177 =cut
1178
1179 sub append_fuzzyfiles {
1180   my $username = shift;
1181
1182   &check_and_rebuild_fuzzyfiles;
1183
1184   use Fcntl qw(:flock);
1185
1186   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1187
1188   open(USERNAME,">>$dir/svc_acct.username")
1189     or die "can't open $dir/svc_acct.username: $!";
1190   flock(USERNAME,LOCK_EX)
1191     or die "can't lock $dir/svc_acct.username: $!";
1192
1193   print USERNAME "$username\n";
1194
1195   flock(USERNAME,LOCK_UN)
1196     or die "can't unlock $dir/svc_acct.username: $!";
1197   close USERNAME;
1198
1199   1;
1200 }
1201
1202
1203
1204 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1205
1206 =cut
1207
1208 sub radius_usergroup_selector {
1209   my $sel_groups = shift;
1210   my %sel_groups = map { $_=>1 } @$sel_groups;
1211
1212   my $selectname = shift || 'radius_usergroup';
1213
1214   my $dbh = dbh;
1215   my $sth = $dbh->prepare(
1216     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1217   ) or die $dbh->errstr;
1218   $sth->execute() or die $sth->errstr;
1219   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1220
1221   my $html = <<END;
1222     <SCRIPT>
1223     function ${selectname}_doadd(object) {
1224       var myvalue = object.${selectname}_add.value;
1225       var optionName = new Option(myvalue,myvalue,false,true);
1226       var length = object.$selectname.length;
1227       object.$selectname.options[length] = optionName;
1228       object.${selectname}_add.value = "";
1229     }
1230     </SCRIPT>
1231     <SELECT MULTIPLE NAME="$selectname">
1232 END
1233
1234   foreach my $group ( @all_groups ) {
1235     $html .= '<OPTION';
1236     if ( $sel_groups{$group} ) {
1237       $html .= ' SELECTED';
1238       $sel_groups{$group} = 0;
1239     }
1240     $html .= ">$group</OPTION>\n";
1241   }
1242   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1243     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1244   };
1245   $html .= '</SELECT>';
1246
1247   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1248            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1249
1250   $html;
1251 }
1252
1253 =back
1254
1255 =head1 BUGS
1256
1257 The $recref stuff in sub check should be cleaned up.
1258
1259 The suspend, unsuspend and cancel methods update the database, but not the
1260 current object.  This is probably a bug as it's unexpected and
1261 counterintuitive.
1262
1263 radius_usergroup_selector?  putting web ui components in here?  they should
1264 probably live somewhere else...
1265
1266 =head1 SEE ALSO
1267
1268 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1269 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1270 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1271 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1272 schema.html from the base documentation.
1273
1274 =cut
1275
1276 1;
1277