4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
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 $username_percent
10 $password_noampersand $password_noexclamation
11 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
13 $radius_password $radius_ip
18 use Crypt::PasswdMD5 1.2;
19 use FS::UID qw( datasrc );
21 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
26 use FS::cust_main_invoice;
30 use FS::radius_usergroup;
33 use FS::Msgcat qw(gettext);
37 @ISA = qw( FS::svc_Common );
40 $me = '[FS::svc_acct]';
42 #ask FS::UID to run this stuff for us later
43 $FS::UID::callback{'FS::svc_acct'} = sub {
45 $dir_prefix = $conf->config('home');
46 @shells = $conf->config('shells');
47 $usernamemin = $conf->config('usernamemin') || 2;
48 $usernamemax = $conf->config('usernamemax');
49 $passwordmin = $conf->config('passwordmin') || 6;
50 $passwordmax = $conf->config('passwordmax') || 8;
51 $username_letter = $conf->exists('username-letter');
52 $username_letterfirst = $conf->exists('username-letterfirst');
53 $username_noperiod = $conf->exists('username-noperiod');
54 $username_nounderscore = $conf->exists('username-nounderscore');
55 $username_nodash = $conf->exists('username-nodash');
56 $username_uppercase = $conf->exists('username-uppercase');
57 $username_ampersand = $conf->exists('username-ampersand');
58 $username_percent = $conf->exists('username-percent');
59 $password_noampersand = $conf->exists('password-noexclamation');
60 $password_noexclamation = $conf->exists('password-noexclamation');
61 $dirhash = $conf->config('dirhash') || 0;
62 if ( $conf->exists('welcome_email') ) {
63 $welcome_template = new Text::Template (
65 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
66 ) or warn "can't create welcome email template: $Text::Template::ERROR";
67 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
68 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
69 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
71 $welcome_template = '';
73 $welcome_subject = '';
74 $welcome_mimetype = '';
76 $smtpmachine = $conf->config('smtpmachine');
77 $radius_password = $conf->config('radius-password') || 'Password';
78 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
81 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
82 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
86 my ( $hashref, $cache ) = @_;
87 if ( $hashref->{'svc_acct_svcnum'} ) {
88 $self->{'_domsvc'} = FS::svc_domain->new( {
89 'svcnum' => $hashref->{'domsvc'},
90 'domain' => $hashref->{'svc_acct_domain'},
91 'catchall' => $hashref->{'svc_acct_catchall'},
98 FS::svc_acct - Object methods for svc_acct records
104 $record = new FS::svc_acct \%hash;
105 $record = new FS::svc_acct { 'column' => 'value' };
107 $error = $record->insert;
109 $error = $new_record->replace($old_record);
111 $error = $record->delete;
113 $error = $record->check;
115 $error = $record->suspend;
117 $error = $record->unsuspend;
119 $error = $record->cancel;
121 %hash = $record->radius;
123 %hash = $record->radius_reply;
125 %hash = $record->radius_check;
127 $domain = $record->domain;
129 $svc_domain = $record->svc_domain;
131 $email = $record->email;
133 $seconds_since = $record->seconds_since($timestamp);
137 An FS::svc_acct object represents an account. FS::svc_acct inherits from
138 FS::svc_Common. The following fields are currently supported:
142 =item svcnum - primary key (assigned automatcially for new accounts)
146 =item _password - generated if blank
148 =item sec_phrase - security phrase
150 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
158 =item dir - set automatically if blank (and uid is not)
162 =item quota - (unimplementd)
164 =item slipip - IP address
168 =item domsvc - svcnum from svc_domain
170 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
172 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
182 Creates a new account. To add the account to the database, see L<"insert">.
186 sub table { 'svc_acct'; }
188 =item insert [ , OPTION => VALUE ... ]
190 Adds this account to the database. If there is an error, returns the error,
191 otherwise returns false.
193 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
194 defined. An FS::cust_svc record will be created and inserted.
196 The additional field I<usergroup> can optionally be defined; if so it should
197 contain an arrayref of group names. See L<FS::radius_usergroup>.
199 The additional field I<child_objects> can optionally be defined; if so it
200 should contain an arrayref of FS::tablename objects. They will have their
201 svcnum fields set and will be inserted after this record, but before any
202 exports are run. Each element of the array can also optionally be a
203 two-element array reference containing the child object and the name of an
204 alternate field to be filled in with the newly-inserted svcnum, for example
205 C<[ $svc_forward, 'srcsvc' ]>
207 Currently available options are: I<depend_jobnum>
209 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
210 jobnums), all provisioning jobs will have a dependancy on the supplied
211 jobnum(s) (they will not run until the specific job(s) complete(s)).
213 (TODOC: L<FS::queue> and L<freeside-queued>)
215 (TODOC: new exports!)
224 local $SIG{HUP} = 'IGNORE';
225 local $SIG{INT} = 'IGNORE';
226 local $SIG{QUIT} = 'IGNORE';
227 local $SIG{TERM} = 'IGNORE';
228 local $SIG{TSTP} = 'IGNORE';
229 local $SIG{PIPE} = 'IGNORE';
231 my $oldAutoCommit = $FS::UID::AutoCommit;
232 local $FS::UID::AutoCommit = 0;
235 $error = $self->check;
236 return $error if $error;
238 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
239 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
240 unless ( $cust_svc ) {
241 $dbh->rollback if $oldAutoCommit;
242 return "no cust_svc record found for svcnum ". $self->svcnum;
244 $self->pkgnum($cust_svc->pkgnum);
245 $self->svcpart($cust_svc->svcpart);
248 $error = $self->_check_duplicate;
250 $dbh->rollback if $oldAutoCommit;
255 $error = $self->SUPER::insert(
256 'jobnums' => \@jobnums,
257 'child_objects' => $self->child_objects,
261 $dbh->rollback if $oldAutoCommit;
265 if ( $self->usergroup ) {
266 foreach my $groupname ( @{$self->usergroup} ) {
267 my $radius_usergroup = new FS::radius_usergroup ( {
268 svcnum => $self->svcnum,
269 groupname => $groupname,
271 my $error = $radius_usergroup->insert;
273 $dbh->rollback if $oldAutoCommit;
279 unless ( $skip_fuzzyfiles ) {
280 $error = $self->queue_fuzzyfiles_update;
282 $dbh->rollback if $oldAutoCommit;
283 return "updating fuzzy search cache: $error";
287 my $cust_pkg = $self->cust_svc->cust_pkg;
290 my $cust_main = $cust_pkg->cust_main;
292 if ( $conf->exists('emailinvoiceauto') ) {
293 my @invoicing_list = $cust_main->invoicing_list;
294 push @invoicing_list, $self->email;
295 $cust_main->invoicing_list(\@invoicing_list);
300 if ( $welcome_template && $cust_pkg ) {
301 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
303 my $wqueue = new FS::queue {
304 'svcnum' => $self->svcnum,
305 'job' => 'FS::svc_acct::send_email'
307 my $error = $wqueue->insert(
309 'from' => $welcome_from,
310 'subject' => $welcome_subject,
311 'mimetype' => $welcome_mimetype,
312 'body' => $welcome_template->fill_in( HASH => {
313 'custnum' => $self->custnum,
314 'username' => $self->username,
315 'password' => $self->_password,
316 'first' => $cust_main->first,
317 'last' => $cust_main->getfield('last'),
318 'pkg' => $cust_pkg->part_pkg->pkg,
322 $dbh->rollback if $oldAutoCommit;
323 return "error queuing welcome email: $error";
326 if ( $options{'depend_jobnum'} ) {
327 warn "$me depend_jobnum found; adding to welcome email dependancies"
329 if ( ref($options{'depend_jobnum'}) ) {
330 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
331 "to welcome email dependancies"
333 push @jobnums, @{ $options{'depend_jobnum'} };
335 warn "$me adding job $options{'depend_jobnum'} ".
336 "to welcome email dependancies"
338 push @jobnums, $options{'depend_jobnum'};
342 foreach my $jobnum ( @jobnums ) {
343 my $error = $wqueue->depend_insert($jobnum);
345 $dbh->rollback if $oldAutoCommit;
346 return "error queuing welcome email job dependancy: $error";
356 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
362 Deletes this account from the database. If there is an error, returns the
363 error, otherwise returns false.
365 The corresponding FS::cust_svc record will be deleted as well.
367 (TODOC: new exports!)
374 return "can't delete system account" if $self->_check_system;
376 return "Can't delete an account which is a (svc_forward) source!"
377 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
379 return "Can't delete an account which is a (svc_forward) destination!"
380 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
382 return "Can't delete an account with (svc_www) web service!"
383 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
385 # what about records in session ? (they should refer to history table)
387 local $SIG{HUP} = 'IGNORE';
388 local $SIG{INT} = 'IGNORE';
389 local $SIG{QUIT} = 'IGNORE';
390 local $SIG{TERM} = 'IGNORE';
391 local $SIG{TSTP} = 'IGNORE';
392 local $SIG{PIPE} = 'IGNORE';
394 my $oldAutoCommit = $FS::UID::AutoCommit;
395 local $FS::UID::AutoCommit = 0;
398 foreach my $cust_main_invoice (
399 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
401 unless ( defined($cust_main_invoice) ) {
402 warn "WARNING: something's wrong with qsearch";
405 my %hash = $cust_main_invoice->hash;
406 $hash{'dest'} = $self->email;
407 my $new = new FS::cust_main_invoice \%hash;
408 my $error = $new->replace($cust_main_invoice);
410 $dbh->rollback if $oldAutoCommit;
415 foreach my $svc_domain (
416 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
418 my %hash = new FS::svc_domain->hash;
419 $hash{'catchall'} = '';
420 my $new = new FS::svc_domain \%hash;
421 my $error = $new->replace($svc_domain);
423 $dbh->rollback if $oldAutoCommit;
428 foreach my $radius_usergroup (
429 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
431 my $error = $radius_usergroup->delete;
433 $dbh->rollback if $oldAutoCommit;
438 my $error = $self->SUPER::delete;
440 $dbh->rollback if $oldAutoCommit;
444 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
448 =item replace OLD_RECORD
450 Replaces OLD_RECORD with this one in the database. If there is an error,
451 returns the error, otherwise returns false.
453 The additional field I<usergroup> can optionally be defined; if so it should
454 contain an arrayref of group names. See L<FS::radius_usergroup>.
460 my ( $new, $old ) = ( shift, shift );
462 warn "$me replacing $old with $new\n" if $DEBUG;
464 return "can't modify system account" if $old->_check_system;
467 #no warnings 'numeric'; #alas, a 5.006-ism
469 return "Can't change uid!" if $old->uid != $new->uid;
472 #change homdir when we change username
473 $new->setfield('dir', '') if $old->username ne $new->username;
475 local $SIG{HUP} = 'IGNORE';
476 local $SIG{INT} = 'IGNORE';
477 local $SIG{QUIT} = 'IGNORE';
478 local $SIG{TERM} = 'IGNORE';
479 local $SIG{TSTP} = 'IGNORE';
480 local $SIG{PIPE} = 'IGNORE';
482 my $oldAutoCommit = $FS::UID::AutoCommit;
483 local $FS::UID::AutoCommit = 0;
486 # redundant, but so $new->usergroup gets set
487 $error = $new->check;
488 return $error if $error;
490 $old->usergroup( [ $old->radius_groups ] );
491 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
492 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
493 if ( $new->usergroup ) {
494 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
495 my @newgroups = @{$new->usergroup};
496 foreach my $oldgroup ( @{$old->usergroup} ) {
497 if ( grep { $oldgroup eq $_ } @newgroups ) {
498 @newgroups = grep { $oldgroup ne $_ } @newgroups;
501 my $radius_usergroup = qsearchs('radius_usergroup', {
502 svcnum => $old->svcnum,
503 groupname => $oldgroup,
505 my $error = $radius_usergroup->delete;
507 $dbh->rollback if $oldAutoCommit;
508 return "error deleting radius_usergroup $oldgroup: $error";
512 foreach my $newgroup ( @newgroups ) {
513 my $radius_usergroup = new FS::radius_usergroup ( {
514 svcnum => $new->svcnum,
515 groupname => $newgroup,
517 my $error = $radius_usergroup->insert;
519 $dbh->rollback if $oldAutoCommit;
520 return "error adding radius_usergroup $newgroup: $error";
526 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
527 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
528 $error = $new->_check_duplicate;
530 $dbh->rollback if $oldAutoCommit;
535 $error = $new->SUPER::replace($old);
537 $dbh->rollback if $oldAutoCommit;
538 return $error if $error;
541 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
542 $error = $new->queue_fuzzyfiles_update;
544 $dbh->rollback if $oldAutoCommit;
545 return "updating fuzzy search cache: $error";
549 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
553 =item queue_fuzzyfiles_update
555 Used by insert & replace to update the fuzzy search cache
559 sub queue_fuzzyfiles_update {
562 local $SIG{HUP} = 'IGNORE';
563 local $SIG{INT} = 'IGNORE';
564 local $SIG{QUIT} = 'IGNORE';
565 local $SIG{TERM} = 'IGNORE';
566 local $SIG{TSTP} = 'IGNORE';
567 local $SIG{PIPE} = 'IGNORE';
569 my $oldAutoCommit = $FS::UID::AutoCommit;
570 local $FS::UID::AutoCommit = 0;
573 my $queue = new FS::queue {
574 'svcnum' => $self->svcnum,
575 'job' => 'FS::svc_acct::append_fuzzyfiles'
577 my $error = $queue->insert($self->username);
579 $dbh->rollback if $oldAutoCommit;
580 return "queueing job (transaction rolled back): $error";
583 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
591 Suspends this account by calling export-specific suspend hooks. If there is
592 an error, returns the error, otherwise returns false.
594 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
600 return "can't suspend system account" if $self->_check_system;
601 $self->SUPER::suspend;
606 Unsuspends this account by by calling export-specific suspend hooks. If there
607 is an error, returns the error, otherwise returns false.
609 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
615 my %hash = $self->hash;
616 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
617 $hash{_password} = $1;
618 my $new = new FS::svc_acct ( \%hash );
619 my $error = $new->replace($self);
620 return $error if $error;
623 $self->SUPER::unsuspend;
628 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
630 If the B<auto_unset_catchall> configuration option is set, this method will
631 automatically remove any references to the canceled service in the catchall
632 field of svc_domain. This allows packages that contain both a svc_domain and
633 its catchall svc_acct to be canceled in one step.
638 # Only one thing to do at this level
640 foreach my $svc_domain (
641 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
642 if($conf->exists('auto_unset_catchall')) {
643 my %hash = $svc_domain->hash;
644 $hash{catchall} = '';
645 my $new = new FS::svc_domain ( \%hash );
646 my $error = $new->replace($svc_domain);
647 return $error if $error;
649 return "cannot unprovision svc_acct #".$self->svcnum.
650 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
654 $self->SUPER::cancel;
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
664 Sets any fixed values; see L<FS::part_svc>.
671 my($recref) = $self->hashref;
673 my $x = $self->setfixed;
674 return $x unless ref($x);
677 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
679 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
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')
687 return $error if $error;
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;
695 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
696 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
697 $recref->{username} = $1;
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');
705 if ( $username_noperiod ) {
706 $recref->{username} =~ /\./ and return gettext('illegal_username');
708 if ( $username_nounderscore ) {
709 $recref->{username} =~ /_/ and return gettext('illegal_username');
711 if ( $username_nodash ) {
712 $recref->{username} =~ /\-/ and return gettext('illegal_username');
714 unless ( $username_ampersand ) {
715 $recref->{username} =~ /\&/ and return gettext('illegal_username');
717 if ( $password_noampersand ) {
718 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
720 if ( $password_noexclamation ) {
721 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
723 unless ( $username_percent ) {
724 $recref->{username} =~ /\%/ and return gettext('illegal_username');
727 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
728 $recref->{popnum} = $1;
729 return "Unknown popnum" unless
730 ! $recref->{popnum} ||
731 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
733 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
735 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
736 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
738 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
739 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
740 #not all systems use gid=uid
741 #you can set a fixed gid in part_svc
743 return "Only root can have uid 0"
744 if $recref->{uid} == 0
745 && $recref->{username} !~ /^(root|toor|smtp)$/;
747 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
748 or return "Illegal directory: ". $recref->{dir};
750 return "Illegal directory"
751 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
752 return "Illegal directory"
753 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
754 unless ( $recref->{dir} ) {
755 $recref->{dir} = $dir_prefix . '/';
756 if ( $dirhash > 0 ) {
757 for my $h ( 1 .. $dirhash ) {
758 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
760 } elsif ( $dirhash < 0 ) {
761 for my $h ( reverse $dirhash .. -1 ) {
762 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
765 $recref->{dir} .= $recref->{username};
769 unless ( $recref->{username} eq 'sync' ) {
770 if ( grep $_ eq $recref->{shell}, @shells ) {
771 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
773 return "Illegal shell \`". $self->shell. "\'; ".
774 $conf->dir. "/shells contains: @shells";
777 $recref->{shell} = '/bin/sync';
781 $recref->{gid} ne '' ?
782 return "Can't have gid without uid" : ( $recref->{gid}='' );
783 $recref->{dir} ne '' ?
784 return "Can't have directory without uid" : ( $recref->{dir}='' );
785 $recref->{shell} ne '' ?
786 return "Can't have shell without uid" : ( $recref->{shell}='' );
789 # $error = $self->ut_textn('finger');
790 # return $error if $error;
791 if ( $self->getfield('finger') eq '' ) {
792 my $cust_pkg = $self->svcnum
793 ? $self->cust_svc->cust_pkg
794 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
796 my $cust_main = $cust_pkg->cust_main;
797 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
800 $self->getfield('finger') =~
801 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
802 or return "Illegal finger: ". $self->getfield('finger');
803 $self->setfield('finger', $1);
805 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
806 $recref->{quota} = $1;
808 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
809 if ( $recref->{slipip} eq '' ) {
810 $recref->{slipip} = '';
811 } elsif ( $recref->{slipip} eq '0e0' ) {
812 $recref->{slipip} = '0e0';
814 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
815 or return "Illegal slipip: ". $self->slipip;
816 $recref->{slipip} = $1;
821 #arbitrary RADIUS stuff; allow ut_textn for now
822 foreach ( grep /^radius_/, fields('svc_acct') ) {
826 #generate a password if it is blank
827 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
828 unless ( $recref->{_password} );
830 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
831 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
832 $recref->{_password} = $1.$3;
833 #uncomment this to encrypt password immediately upon entry, or run
834 #bin/crypt_pw in cron to give new users a window during which their
835 #password is available to techs, for faxing, etc. (also be aware of
837 #$recref->{password} = $1.
838 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
840 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
841 $recref->{_password} = $1.$3;
842 } elsif ( $recref->{_password} eq '*' ) {
843 $recref->{_password} = '*';
844 } elsif ( $recref->{_password} eq '!' ) {
845 $recref->{_password} = '!';
846 } elsif ( $recref->{_password} eq '!!' ) {
847 $recref->{_password} = '!!';
849 #return "Illegal password";
850 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
851 FS::Msgcat::_gettext('illegal_password_characters').
852 ": ". $recref->{_password};
860 Internal function to check the username against the list of system usernames
861 from the I<system_usernames> configuration value. Returns true if the username
862 is listed on the system username list.
868 scalar( grep { $self->username eq $_ || $self->email eq $_ }
869 $conf->config('system_usernames')
873 =item _check_duplicate
875 Internal function to check for duplicates usernames, username@domain pairs and
878 If the I<global_unique-username> configuration value is set to B<username> or
879 B<username@domain>, enforces global username or username@domain uniqueness.
881 In all cases, check for duplicate uids and usernames or username@domain pairs
882 per export and with identical I<svcpart> values.
886 sub _check_duplicate {
889 #this is Pg-specific. what to do for mysql etc?
890 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
891 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
892 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
894 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
896 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
897 unless ( $part_svc ) {
898 return 'unknown svcpart '. $self->svcpart;
901 my $global_unique = $conf->config('global_unique-username') || 'none';
903 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
904 qsearch( 'svc_acct', { 'username' => $self->username } );
905 return gettext('username_in_use')
906 if $global_unique eq 'username' && @dup_user;
908 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
909 qsearch( 'svc_acct', { 'username' => $self->username,
910 'domsvc' => $self->domsvc } );
911 return gettext('username_in_use')
912 if $global_unique eq 'username@domain' && @dup_userdomain;
915 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
916 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
917 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
918 qsearch( 'svc_acct', { 'uid' => $self->uid } );
923 if ( @dup_user || @dup_userdomain || @dup_uid ) {
924 my $exports = FS::part_export::export_info('svc_acct');
925 my %conflict_user_svcpart;
926 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
928 foreach my $part_export ( $part_svc->part_export ) {
930 #this will catch to the same exact export
931 my @svcparts = map { $_->svcpart } $part_export->export_svc;
933 #this will catch to exports w/same exporthost+type ???
934 #my @other_part_export = qsearch('part_export', {
935 # 'machine' => $part_export->machine,
936 # 'exporttype' => $part_export->exporttype,
938 #foreach my $other_part_export ( @other_part_export ) {
939 # push @svcparts, map { $_->svcpart }
940 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
943 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
944 #silly kludge to avoid uninitialized value errors
945 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
946 ? $exports->{$part_export->exporttype}{'nodomain'}
948 if ( $nodomain =~ /^Y/i ) {
949 $conflict_user_svcpart{$_} = $part_export->exportnum
952 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
957 foreach my $dup_user ( @dup_user ) {
958 my $dup_svcpart = $dup_user->cust_svc->svcpart;
959 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
960 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
961 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
965 foreach my $dup_userdomain ( @dup_userdomain ) {
966 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
967 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
968 return "duplicate username\@domain: conflicts with svcnum ".
969 $dup_userdomain->svcnum. " via exportnum ".
970 $conflict_userdomain_svcpart{$dup_svcpart};
974 foreach my $dup_uid ( @dup_uid ) {
975 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
976 if ( exists($conflict_user_svcpart{$dup_svcpart})
977 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
978 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
979 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
980 || $conflict_userdomain_svcpart{$dup_svcpart};
992 Depriciated, use radius_reply instead.
997 carp "FS::svc_acct::radius depriciated, use radius_reply";
1003 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1004 reply attributes of this record.
1006 Note that this is now the preferred method for reading RADIUS attributes -
1007 accessing the columns directly is discouraged, as the column names are
1008 expected to change in the future.
1017 my($column, $attrib) = ($1, $2);
1018 #$attrib =~ s/_/\-/g;
1019 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1020 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1021 if ( $self->slipip && $self->slipip ne '0e0' ) {
1022 $reply{$radius_ip} = $self->slipip;
1024 if ( $self->seconds !~ /^$/ ) {
1025 $reply{'Session-Timeout'} = $self->seconds;
1032 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1033 check attributes of this record.
1035 Note that this is now the preferred method for reading RADIUS attributes -
1036 accessing the columns directly is discouraged, as the column names are
1037 expected to change in the future.
1043 my $password = $self->_password;
1044 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1045 ( $pw_attrib => $password,
1048 my($column, $attrib) = ($1, $2);
1049 #$attrib =~ s/_/\-/g;
1050 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1051 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
1057 Returns the domain associated with this account.
1063 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1064 my $svc_domain = $self->svc_domain(@_)
1065 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1066 $svc_domain->domain;
1071 Returns the FS::svc_domain record for this account's domain (see
1079 ? $self->{'_domsvc'}
1080 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1085 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1091 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1096 Returns an email address associated with the account.
1102 $self->username. '@'. $self->domain(@_);
1107 Returns an array of FS::acct_snarf records associated with the account.
1108 If the acct_snarf table does not exist or there are no associated records,
1109 an empty list is returned
1115 return () unless dbdef->table('acct_snarf');
1116 eval "use FS::acct_snarf;";
1118 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1121 =item decrement_seconds SECONDS
1123 Decrements the I<seconds> field of this record by the given amount. If there
1124 is an error, returns the error, otherwise returns false.
1128 sub decrement_seconds {
1129 shift->_op_seconds('-', @_);
1132 =item increment_seconds SECONDS
1134 Increments the I<seconds> field of this record by the given amount. If there
1135 is an error, returns the error, otherwise returns false.
1139 sub increment_seconds {
1140 shift->_op_seconds('+', @_);
1148 my %op2condition = (
1149 '-' => sub { my($self, $seconds) = @_;
1150 $self->seconds - $seconds <= 0;
1152 '+' => sub { my($self, $seconds) = @_;
1153 $self->seconds + $seconds > 0;
1158 my( $self, $op, $seconds ) = @_;
1159 warn "$me _op_seconds called for svcnum ". $self->svcnum.
1160 ' ('. $self->email. "): $op $seconds\n"
1163 local $SIG{HUP} = 'IGNORE';
1164 local $SIG{INT} = 'IGNORE';
1165 local $SIG{QUIT} = 'IGNORE';
1166 local $SIG{TERM} = 'IGNORE';
1167 local $SIG{TSTP} = 'IGNORE';
1168 local $SIG{PIPE} = 'IGNORE';
1170 my $oldAutoCommit = $FS::UID::AutoCommit;
1171 local $FS::UID::AutoCommit = 0;
1174 my $sql = "UPDATE svc_acct SET seconds = ".
1175 " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0
1176 " $op ? WHERE svcnum = ?";
1180 my $sth = $dbh->prepare( $sql )
1181 or die "Error preparing $sql: ". $dbh->errstr;
1182 my $rv = $sth->execute($seconds, $self->svcnum);
1183 die "Error executing $sql: ". $sth->errstr
1184 unless defined($rv);
1185 die "Can't update seconds for svcnum". $self->svcnum
1188 my $action = $op2action{$op};
1190 if ( $conf->exists("svc_acct-usage_$action")
1191 && &{$op2condition{$op}}($self, $seconds) ) {
1192 #my $error = $self->$action();
1193 my $error = $self->cust_svc->cust_pkg->$action();
1195 $dbh->rollback if $oldAutoCommit;
1196 return "Error ${action}ing: $error";
1200 warn "$me update sucessful; committing\n"
1202 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1208 =item seconds_since TIMESTAMP
1210 Returns the number of seconds this account has been online since TIMESTAMP,
1211 according to the session monitor (see L<FS::Session>).
1213 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1214 L<Time::Local> and L<Date::Parse> for conversion functions.
1218 #note: POD here, implementation in FS::cust_svc
1221 $self->cust_svc->seconds_since(@_);
1224 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1226 Returns the numbers of seconds this account has been online between
1227 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1228 external SQL radacct table, specified via sqlradius export. Sessions which
1229 started in the specified range but are still open are counted from session
1230 start to the end of the range (unless they are over 1 day old, in which case
1231 they are presumed missing their stop record and not counted). Also, sessions
1232 which end in the range but started earlier are counted from the start of the
1233 range to session end. Finally, sessions which start before the range but end
1234 after are counted for the entire range.
1236 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1237 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1242 #note: POD here, implementation in FS::cust_svc
1243 sub seconds_since_sqlradacct {
1245 $self->cust_svc->seconds_since_sqlradacct(@_);
1248 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1250 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1251 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1252 TIMESTAMP_END (exclusive).
1254 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1255 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1260 #note: POD here, implementation in FS::cust_svc
1261 sub attribute_since_sqlradacct {
1263 $self->cust_svc->attribute_since_sqlradacct(@_);
1266 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1268 Returns an array of hash references of this customers login history for the
1269 given time range. (document this better)
1273 sub get_session_history {
1275 $self->cust_svc->get_session_history(@_);
1280 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1286 if ( $self->usergroup ) {
1287 #when provisioning records, export callback runs in svc_Common.pm before
1288 #radius_usergroup records can be inserted...
1289 @{$self->usergroup};
1291 map { $_->groupname }
1292 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1296 =item clone_suspended
1298 Constructor used by FS::part_export::_export_suspend fallback. Document
1303 sub clone_suspended {
1305 my %hash = $self->hash;
1306 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1307 new FS::svc_acct \%hash;
1310 =item clone_kludge_unsuspend
1312 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1317 sub clone_kludge_unsuspend {
1319 my %hash = $self->hash;
1320 $hash{_password} = '';
1321 new FS::svc_acct \%hash;
1324 =item check_password
1326 Checks the supplied password against the (possibly encrypted) password in the
1327 database. Returns true for a sucessful authentication, false for no match.
1329 Currently supported encryptions are: classic DES crypt() and MD5
1333 sub check_password {
1334 my($self, $check_password) = @_;
1336 #remove old-style SUSPENDED kludge, they should be allowed to login to
1337 #self-service and pay up
1338 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1340 #eventually should check a "password-encoding" field
1341 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1343 } elsif ( length($password) < 13 ) { #plaintext
1344 $check_password eq $password;
1345 } elsif ( length($password) == 13 ) { #traditional DES crypt
1346 crypt($check_password, $password) eq $password;
1347 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1348 unix_md5_crypt($check_password, $password) eq $password;
1349 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1350 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1351 $self->svcnum. "\n";
1354 warn "Can't check password: Unrecognized encryption for svcnum ".
1355 $self->svcnum. "\n";
1361 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1363 Returns an encrypted password, either by passing through an encrypted password
1364 in the database or by encrypting a plaintext password from the database.
1366 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1367 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1368 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1369 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
1370 encryption type is only used if the password is not already encrypted in the
1375 sub crypt_password {
1377 #eventually should check a "password-encoding" field
1378 if ( length($self->_password) == 13
1379 || $self->_password =~ /^\$(1|2a?)\$/
1380 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1385 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1386 if ( $encryption eq 'crypt' ) {
1389 $saltset[int(rand(64))].$saltset[int(rand(64))]
1391 } elsif ( $encryption eq 'md5' ) {
1392 unix_md5_crypt( $self->_password );
1393 } elsif ( $encryption eq 'blowfish' ) {
1394 die "unknown encryption method $encryption";
1396 die "unknown encryption method $encryption";
1401 =item virtual_maildir
1403 Returns $domain/maildirs/$username/
1407 sub virtual_maildir {
1409 $self->domain. '/maildirs/'. $self->username. '/';
1420 This is the FS::svc_acct job-queue-able version. It still uses
1421 FS::Misc::send_email under-the-hood.
1428 eval "use FS::Misc qw(send_email)";
1431 $opt{mimetype} ||= 'text/plain';
1432 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1434 my $error = send_email(
1435 'from' => $opt{from},
1437 'subject' => $opt{subject},
1438 'content-type' => $opt{mimetype},
1439 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1441 die $error if $error;
1444 =item check_and_rebuild_fuzzyfiles
1448 sub check_and_rebuild_fuzzyfiles {
1449 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1450 -e "$dir/svc_acct.username"
1451 or &rebuild_fuzzyfiles;
1454 =item rebuild_fuzzyfiles
1458 sub rebuild_fuzzyfiles {
1460 use Fcntl qw(:flock);
1462 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1466 open(USERNAMELOCK,">>$dir/svc_acct.username")
1467 or die "can't open $dir/svc_acct.username: $!";
1468 flock(USERNAMELOCK,LOCK_EX)
1469 or die "can't lock $dir/svc_acct.username: $!";
1471 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1473 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1474 or die "can't open $dir/svc_acct.username.tmp: $!";
1475 print USERNAMECACHE join("\n", @all_username), "\n";
1476 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1478 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1488 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1489 open(USERNAMECACHE,"<$dir/svc_acct.username")
1490 or die "can't open $dir/svc_acct.username: $!";
1491 my @array = map { chomp; $_; } <USERNAMECACHE>;
1492 close USERNAMECACHE;
1496 =item append_fuzzyfiles USERNAME
1500 sub append_fuzzyfiles {
1501 my $username = shift;
1503 &check_and_rebuild_fuzzyfiles;
1505 use Fcntl qw(:flock);
1507 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1509 open(USERNAME,">>$dir/svc_acct.username")
1510 or die "can't open $dir/svc_acct.username: $!";
1511 flock(USERNAME,LOCK_EX)
1512 or die "can't lock $dir/svc_acct.username: $!";
1514 print USERNAME "$username\n";
1516 flock(USERNAME,LOCK_UN)
1517 or die "can't unlock $dir/svc_acct.username: $!";
1525 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1529 sub radius_usergroup_selector {
1530 my $sel_groups = shift;
1531 my %sel_groups = map { $_=>1 } @$sel_groups;
1533 my $selectname = shift || 'radius_usergroup';
1536 my $sth = $dbh->prepare(
1537 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1538 ) or die $dbh->errstr;
1539 $sth->execute() or die $sth->errstr;
1540 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1544 function ${selectname}_doadd(object) {
1545 var myvalue = object.${selectname}_add.value;
1546 var optionName = new Option(myvalue,myvalue,false,true);
1547 var length = object.$selectname.length;
1548 object.$selectname.options[length] = optionName;
1549 object.${selectname}_add.value = "";
1552 <SELECT MULTIPLE NAME="$selectname">
1555 foreach my $group ( @all_groups ) {
1556 $html .= qq(<OPTION VALUE="$group");
1557 if ( $sel_groups{$group} ) {
1558 $html .= ' SELECTED';
1559 $sel_groups{$group} = 0;
1561 $html .= ">$group</OPTION>\n";
1563 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1564 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1566 $html .= '</SELECT>';
1568 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1569 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1578 The $recref stuff in sub check should be cleaned up.
1580 The suspend, unsuspend and cancel methods update the database, but not the
1581 current object. This is probably a bug as it's unexpected and
1584 radius_usergroup_selector? putting web ui components in here? they should
1585 probably live somewhere else...
1587 insertion of RADIUS group stuff in insert could be done with child_objects now
1588 (would probably clean up export of them too)
1592 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1593 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1594 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1595 L<freeside-queued>), L<FS::svc_acct_pop>,
1596 schema.html from the base documentation.