FS/FS/svc_acct.pm

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