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