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