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