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