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
19 use Crypt::PasswdMD5 1.2;
20 use FS::UID qw( datasrc );
22 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
27 use FS::cust_main_invoice;
31 use FS::radius_usergroup;
34 use FS::Msgcat qw(gettext);
38 @ISA = qw( FS::svc_Common );
41 $me = '[FS::svc_acct]';
43 #ask FS::UID to run this stuff for us later
44 $FS::UID::callback{'FS::svc_acct'} = sub {
46 $dir_prefix = $conf->config('home');
47 @shells = $conf->config('shells');
48 $usernamemin = $conf->config('usernamemin') || 2;
49 $usernamemax = $conf->config('usernamemax');
50 $passwordmin = $conf->config('passwordmin') || 6;
51 $passwordmax = $conf->config('passwordmax') || 8;
52 $username_letter = $conf->exists('username-letter');
53 $username_letterfirst = $conf->exists('username-letterfirst');
54 $username_noperiod = $conf->exists('username-noperiod');
55 $username_nounderscore = $conf->exists('username-nounderscore');
56 $username_nodash = $conf->exists('username-nodash');
57 $username_uppercase = $conf->exists('username-uppercase');
58 $username_ampersand = $conf->exists('username-ampersand');
59 $username_percent = $conf->exists('username-percent');
60 $password_noampersand = $conf->exists('password-noexclamation');
61 $password_noexclamation = $conf->exists('password-noexclamation');
62 $dirhash = $conf->config('dirhash') || 0;
63 if ( $conf->exists('welcome_email') ) {
64 $welcome_template = new Text::Template (
66 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
67 ) or warn "can't create welcome email template: $Text::Template::ERROR";
68 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
69 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
70 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
72 $welcome_template = '';
74 $welcome_subject = '';
75 $welcome_mimetype = '';
77 $smtpmachine = $conf->config('smtpmachine');
78 $radius_password = $conf->config('radius-password') || 'Password';
79 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
82 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
83 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
87 my ( $hashref, $cache ) = @_;
88 if ( $hashref->{'svc_acct_svcnum'} ) {
89 $self->{'_domsvc'} = FS::svc_domain->new( {
90 'svcnum' => $hashref->{'domsvc'},
91 'domain' => $hashref->{'svc_acct_domain'},
92 'catchall' => $hashref->{'svc_acct_catchall'},
99 FS::svc_acct - Object methods for svc_acct records
105 $record = new FS::svc_acct \%hash;
106 $record = new FS::svc_acct { 'column' => 'value' };
108 $error = $record->insert;
110 $error = $new_record->replace($old_record);
112 $error = $record->delete;
114 $error = $record->check;
116 $error = $record->suspend;
118 $error = $record->unsuspend;
120 $error = $record->cancel;
122 %hash = $record->radius;
124 %hash = $record->radius_reply;
126 %hash = $record->radius_check;
128 $domain = $record->domain;
130 $svc_domain = $record->svc_domain;
132 $email = $record->email;
134 $seconds_since = $record->seconds_since($timestamp);
138 An FS::svc_acct object represents an account. FS::svc_acct inherits from
139 FS::svc_Common. The following fields are currently supported:
143 =item svcnum - primary key (assigned automatcially for new accounts)
147 =item _password - generated if blank
149 =item sec_phrase - security phrase
151 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
159 =item dir - set automatically if blank (and uid is not)
163 =item quota - (unimplementd)
165 =item slipip - IP address
169 =item domsvc - svcnum from svc_domain
171 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
173 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
183 Creates a new account. To add the account to the database, see L<"insert">.
187 sub table { 'svc_acct'; }
189 =item insert [ , OPTION => VALUE ... ]
191 Adds this account to the database. If there is an error, returns the error,
192 otherwise returns false.
194 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
195 defined. An FS::cust_svc record will be created and inserted.
197 The additional field I<usergroup> can optionally be defined; if so it should
198 contain an arrayref of group names. See L<FS::radius_usergroup>.
200 The additional field I<child_objects> can optionally be defined; if so it
201 should contain an arrayref of FS::tablename objects. They will have their
202 svcnum fields set and will be inserted after this record, but before any
203 exports are run. Each element of the array can also optionally be a
204 two-element array reference containing the child object and the name of an
205 alternate field to be filled in with the newly-inserted svcnum, for example
206 C<[ $svc_forward, 'srcsvc' ]>
208 Currently available options are: I<depend_jobnum>
210 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
211 jobnums), all provisioning jobs will have a dependancy on the supplied
212 jobnum(s) (they will not run until the specific job(s) complete(s)).
214 (TODOC: L<FS::queue> and L<freeside-queued>)
216 (TODOC: new exports!)
225 local $SIG{HUP} = 'IGNORE';
226 local $SIG{INT} = 'IGNORE';
227 local $SIG{QUIT} = 'IGNORE';
228 local $SIG{TERM} = 'IGNORE';
229 local $SIG{TSTP} = 'IGNORE';
230 local $SIG{PIPE} = 'IGNORE';
232 my $oldAutoCommit = $FS::UID::AutoCommit;
233 local $FS::UID::AutoCommit = 0;
236 $error = $self->check;
237 return $error if $error;
239 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
240 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
241 unless ( $cust_svc ) {
242 $dbh->rollback if $oldAutoCommit;
243 return "no cust_svc record found for svcnum ". $self->svcnum;
245 $self->pkgnum($cust_svc->pkgnum);
246 $self->svcpart($cust_svc->svcpart);
249 $error = $self->_check_duplicate;
251 $dbh->rollback if $oldAutoCommit;
256 $error = $self->SUPER::insert(
257 'jobnums' => \@jobnums,
258 'child_objects' => $self->child_objects,
262 $dbh->rollback if $oldAutoCommit;
266 if ( $self->usergroup ) {
267 foreach my $groupname ( @{$self->usergroup} ) {
268 my $radius_usergroup = new FS::radius_usergroup ( {
269 svcnum => $self->svcnum,
270 groupname => $groupname,
272 my $error = $radius_usergroup->insert;
274 $dbh->rollback if $oldAutoCommit;
280 unless ( $skip_fuzzyfiles ) {
281 $error = $self->queue_fuzzyfiles_update;
283 $dbh->rollback if $oldAutoCommit;
284 return "updating fuzzy search cache: $error";
288 my $cust_pkg = $self->cust_svc->cust_pkg;
291 my $cust_main = $cust_pkg->cust_main;
293 if ( $conf->exists('emailinvoiceauto') ) {
294 my @invoicing_list = $cust_main->invoicing_list;
295 push @invoicing_list, $self->email;
296 $cust_main->invoicing_list(\@invoicing_list);
301 if ( $welcome_template && $cust_pkg ) {
302 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
304 my $wqueue = new FS::queue {
305 'svcnum' => $self->svcnum,
306 'job' => 'FS::svc_acct::send_email'
308 my $error = $wqueue->insert(
310 'from' => $welcome_from,
311 'subject' => $welcome_subject,
312 'mimetype' => $welcome_mimetype,
313 'body' => $welcome_template->fill_in( HASH => {
314 'custnum' => $self->custnum,
315 'username' => $self->username,
316 'password' => $self->_password,
317 'first' => $cust_main->first,
318 'last' => $cust_main->getfield('last'),
319 'pkg' => $cust_pkg->part_pkg->pkg,
323 $dbh->rollback if $oldAutoCommit;
324 return "error queuing welcome email: $error";
327 if ( $options{'depend_jobnum'} ) {
328 warn "$me depend_jobnum found; adding to welcome email dependancies"
330 if ( ref($options{'depend_jobnum'}) ) {
331 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
332 "to welcome email dependancies"
334 push @jobnums, @{ $options{'depend_jobnum'} };
336 warn "$me adding job $options{'depend_jobnum'} ".
337 "to welcome email dependancies"
339 push @jobnums, $options{'depend_jobnum'};
343 foreach my $jobnum ( @jobnums ) {
344 my $error = $wqueue->depend_insert($jobnum);
346 $dbh->rollback if $oldAutoCommit;
347 return "error queuing welcome email job dependancy: $error";
357 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
363 Deletes this account from the database. If there is an error, returns the
364 error, otherwise returns false.
366 The corresponding FS::cust_svc record will be deleted as well.
368 (TODOC: new exports!)
375 return "can't delete system account" if $self->_check_system;
377 return "Can't delete an account which is a (svc_forward) source!"
378 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
380 return "Can't delete an account which is a (svc_forward) destination!"
381 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
383 return "Can't delete an account with (svc_www) web service!"
384 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
386 # what about records in session ? (they should refer to history table)
388 local $SIG{HUP} = 'IGNORE';
389 local $SIG{INT} = 'IGNORE';
390 local $SIG{QUIT} = 'IGNORE';
391 local $SIG{TERM} = 'IGNORE';
392 local $SIG{TSTP} = 'IGNORE';
393 local $SIG{PIPE} = 'IGNORE';
395 my $oldAutoCommit = $FS::UID::AutoCommit;
396 local $FS::UID::AutoCommit = 0;
399 foreach my $cust_main_invoice (
400 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
402 unless ( defined($cust_main_invoice) ) {
403 warn "WARNING: something's wrong with qsearch";
406 my %hash = $cust_main_invoice->hash;
407 $hash{'dest'} = $self->email;
408 my $new = new FS::cust_main_invoice \%hash;
409 my $error = $new->replace($cust_main_invoice);
411 $dbh->rollback if $oldAutoCommit;
416 foreach my $svc_domain (
417 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
419 my %hash = new FS::svc_domain->hash;
420 $hash{'catchall'} = '';
421 my $new = new FS::svc_domain \%hash;
422 my $error = $new->replace($svc_domain);
424 $dbh->rollback if $oldAutoCommit;
429 foreach my $radius_usergroup (
430 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
432 my $error = $radius_usergroup->delete;
434 $dbh->rollback if $oldAutoCommit;
439 my $error = $self->SUPER::delete;
441 $dbh->rollback if $oldAutoCommit;
445 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
449 =item replace OLD_RECORD
451 Replaces OLD_RECORD with this one in the database. If there is an error,
452 returns the error, otherwise returns false.
454 The additional field I<usergroup> can optionally be defined; if so it should
455 contain an arrayref of group names. See L<FS::radius_usergroup>.
461 my ( $new, $old ) = ( shift, shift );
463 warn "$me replacing $old with $new\n" if $DEBUG;
465 return "can't modify system account" if $old->_check_system;
468 #no warnings 'numeric'; #alas, a 5.006-ism
470 return "Can't change uid!" if $old->uid != $new->uid;
473 #change homdir when we change username
474 $new->setfield('dir', '') if $old->username ne $new->username;
476 local $SIG{HUP} = 'IGNORE';
477 local $SIG{INT} = 'IGNORE';
478 local $SIG{QUIT} = 'IGNORE';
479 local $SIG{TERM} = 'IGNORE';
480 local $SIG{TSTP} = 'IGNORE';
481 local $SIG{PIPE} = 'IGNORE';
483 my $oldAutoCommit = $FS::UID::AutoCommit;
484 local $FS::UID::AutoCommit = 0;
487 # redundant, but so $new->usergroup gets set
488 $error = $new->check;
489 return $error if $error;
491 $old->usergroup( [ $old->radius_groups ] );
492 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
493 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
494 if ( $new->usergroup ) {
495 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
496 my @newgroups = @{$new->usergroup};
497 foreach my $oldgroup ( @{$old->usergroup} ) {
498 if ( grep { $oldgroup eq $_ } @newgroups ) {
499 @newgroups = grep { $oldgroup ne $_ } @newgroups;
502 my $radius_usergroup = qsearchs('radius_usergroup', {
503 svcnum => $old->svcnum,
504 groupname => $oldgroup,
506 my $error = $radius_usergroup->delete;
508 $dbh->rollback if $oldAutoCommit;
509 return "error deleting radius_usergroup $oldgroup: $error";
513 foreach my $newgroup ( @newgroups ) {
514 my $radius_usergroup = new FS::radius_usergroup ( {
515 svcnum => $new->svcnum,
516 groupname => $newgroup,
518 my $error = $radius_usergroup->insert;
520 $dbh->rollback if $oldAutoCommit;
521 return "error adding radius_usergroup $newgroup: $error";
527 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
528 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
529 $error = $new->_check_duplicate;
531 $dbh->rollback if $oldAutoCommit;
536 $error = $new->SUPER::replace($old);
538 $dbh->rollback if $oldAutoCommit;
539 return $error if $error;
542 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
543 $error = $new->queue_fuzzyfiles_update;
545 $dbh->rollback if $oldAutoCommit;
546 return "updating fuzzy search cache: $error";
550 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
554 =item queue_fuzzyfiles_update
556 Used by insert & replace to update the fuzzy search cache
560 sub queue_fuzzyfiles_update {
563 local $SIG{HUP} = 'IGNORE';
564 local $SIG{INT} = 'IGNORE';
565 local $SIG{QUIT} = 'IGNORE';
566 local $SIG{TERM} = 'IGNORE';
567 local $SIG{TSTP} = 'IGNORE';
568 local $SIG{PIPE} = 'IGNORE';
570 my $oldAutoCommit = $FS::UID::AutoCommit;
571 local $FS::UID::AutoCommit = 0;
574 my $queue = new FS::queue {
575 'svcnum' => $self->svcnum,
576 'job' => 'FS::svc_acct::append_fuzzyfiles'
578 my $error = $queue->insert($self->username);
580 $dbh->rollback if $oldAutoCommit;
581 return "queueing job (transaction rolled back): $error";
584 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
592 Suspends this account by calling export-specific suspend hooks. If there is
593 an error, returns the error, otherwise returns false.
595 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
601 return "can't suspend system account" if $self->_check_system;
602 $self->SUPER::suspend;
607 Unsuspends this account by by calling export-specific suspend hooks. If there
608 is an error, returns the error, otherwise returns false.
610 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
616 my %hash = $self->hash;
617 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
618 $hash{_password} = $1;
619 my $new = new FS::svc_acct ( \%hash );
620 my $error = $new->replace($self);
621 return $error if $error;
624 $self->SUPER::unsuspend;
629 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
631 If the B<auto_unset_catchall> configuration option is set, this method will
632 automatically remove any references to the canceled service in the catchall
633 field of svc_domain. This allows packages that contain both a svc_domain and
634 its catchall svc_acct to be canceled in one step.
639 # Only one thing to do at this level
641 foreach my $svc_domain (
642 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
643 if($conf->exists('auto_unset_catchall')) {
644 my %hash = $svc_domain->hash;
645 $hash{catchall} = '';
646 my $new = new FS::svc_domain ( \%hash );
647 my $error = $new->replace($svc_domain);
648 return $error if $error;
650 return "cannot unprovision svc_acct #".$self->svcnum.
651 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
655 $self->SUPER::cancel;
661 Checks all fields to make sure this is a valid service. If there is an error,
662 returns the error, otherwise returns false. Called by the insert and replace
665 Sets any fixed values; see L<FS::part_svc>.
672 my($recref) = $self->hashref;
674 my $x = $self->setfixed;
675 return $x unless ref($x);
678 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
680 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
683 my $error = $self->ut_numbern('svcnum')
684 #|| $self->ut_number('domsvc')
685 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
686 || $self->ut_textn('sec_phrase')
688 return $error if $error;
690 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
691 if ( $username_uppercase ) {
692 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
693 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
694 $recref->{username} = $1;
696 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
697 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
698 $recref->{username} = $1;
701 if ( $username_letterfirst ) {
702 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
703 } elsif ( $username_letter ) {
704 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
706 if ( $username_noperiod ) {
707 $recref->{username} =~ /\./ and return gettext('illegal_username');
709 if ( $username_nounderscore ) {
710 $recref->{username} =~ /_/ and return gettext('illegal_username');
712 if ( $username_nodash ) {
713 $recref->{username} =~ /\-/ and return gettext('illegal_username');
715 unless ( $username_ampersand ) {
716 $recref->{username} =~ /\&/ and return gettext('illegal_username');
718 if ( $password_noampersand ) {
719 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
721 if ( $password_noexclamation ) {
722 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
724 unless ( $username_percent ) {
725 $recref->{username} =~ /\%/ and return gettext('illegal_username');
728 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
729 $recref->{popnum} = $1;
730 return "Unknown popnum" unless
731 ! $recref->{popnum} ||
732 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
734 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
736 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
737 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
739 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
740 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
741 #not all systems use gid=uid
742 #you can set a fixed gid in part_svc
744 return "Only root can have uid 0"
745 if $recref->{uid} == 0
746 && $recref->{username} !~ /^(root|toor|smtp)$/;
748 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
749 or return "Illegal directory: ". $recref->{dir};
751 return "Illegal directory"
752 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
753 return "Illegal directory"
754 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
755 unless ( $recref->{dir} ) {
756 $recref->{dir} = $dir_prefix . '/';
757 if ( $dirhash > 0 ) {
758 for my $h ( 1 .. $dirhash ) {
759 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
761 } elsif ( $dirhash < 0 ) {
762 for my $h ( reverse $dirhash .. -1 ) {
763 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
766 $recref->{dir} .= $recref->{username};
770 unless ( $recref->{username} eq 'sync' ) {
771 if ( grep $_ eq $recref->{shell}, @shells ) {
772 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
774 return "Illegal shell \`". $self->shell. "\'; ".
775 $conf->dir. "/shells contains: @shells";
778 $recref->{shell} = '/bin/sync';
782 $recref->{gid} ne '' ?
783 return "Can't have gid without uid" : ( $recref->{gid}='' );
784 $recref->{dir} ne '' ?
785 return "Can't have directory without uid" : ( $recref->{dir}='' );
786 $recref->{shell} ne '' ?
787 return "Can't have shell without uid" : ( $recref->{shell}='' );
790 # $error = $self->ut_textn('finger');
791 # return $error if $error;
792 if ( $self->getfield('finger') eq '' ) {
793 my $cust_pkg = $self->svcnum
794 ? $self->cust_svc->cust_pkg
795 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
797 my $cust_main = $cust_pkg->cust_main;
798 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
801 $self->getfield('finger') =~
802 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
803 or return "Illegal finger: ". $self->getfield('finger');
804 $self->setfield('finger', $1);
806 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
807 $recref->{quota} = $1;
809 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
810 if ( $recref->{slipip} eq '' ) {
811 $recref->{slipip} = '';
812 } elsif ( $recref->{slipip} eq '0e0' ) {
813 $recref->{slipip} = '0e0';
815 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
816 or return "Illegal slipip: ". $self->slipip;
817 $recref->{slipip} = $1;
822 #arbitrary RADIUS stuff; allow ut_textn for now
823 foreach ( grep /^radius_/, fields('svc_acct') ) {
827 #generate a password if it is blank
828 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
829 unless ( $recref->{_password} );
831 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
832 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
833 $recref->{_password} = $1.$3;
834 #uncomment this to encrypt password immediately upon entry, or run
835 #bin/crypt_pw in cron to give new users a window during which their
836 #password is available to techs, for faxing, etc. (also be aware of
838 #$recref->{password} = $1.
839 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
841 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
842 $recref->{_password} = $1.$3;
843 } elsif ( $recref->{_password} eq '*' ) {
844 $recref->{_password} = '*';
845 } elsif ( $recref->{_password} eq '!' ) {
846 $recref->{_password} = '!';
847 } elsif ( $recref->{_password} eq '!!' ) {
848 $recref->{_password} = '!!';
850 #return "Illegal password";
851 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
852 FS::Msgcat::_gettext('illegal_password_characters').
853 ": ". $recref->{_password};
861 Internal function to check the username against the list of system usernames
862 from the I<system_usernames> configuration value. Returns true if the username
863 is listed on the system username list.
869 scalar( grep { $self->username eq $_ || $self->email eq $_ }
870 $conf->config('system_usernames')
874 =item _check_duplicate
876 Internal function to check for duplicates usernames, username@domain pairs and
879 If the I<global_unique-username> configuration value is set to B<username> or
880 B<username@domain>, enforces global username or username@domain uniqueness.
882 In all cases, check for duplicate uids and usernames or username@domain pairs
883 per export and with identical I<svcpart> values.
887 sub _check_duplicate {
890 #this is Pg-specific. what to do for mysql etc?
891 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
892 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
893 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
895 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
897 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
898 unless ( $part_svc ) {
899 return 'unknown svcpart '. $self->svcpart;
902 my $global_unique = $conf->config('global_unique-username') || 'none';
904 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
905 qsearch( 'svc_acct', { 'username' => $self->username } );
906 return gettext('username_in_use')
907 if $global_unique eq 'username' && @dup_user;
909 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
910 qsearch( 'svc_acct', { 'username' => $self->username,
911 'domsvc' => $self->domsvc } );
912 return gettext('username_in_use')
913 if $global_unique eq 'username@domain' && @dup_userdomain;
916 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
917 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
918 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
919 qsearch( 'svc_acct', { 'uid' => $self->uid } );
924 if ( @dup_user || @dup_userdomain || @dup_uid ) {
925 my $exports = FS::part_export::export_info('svc_acct');
926 my %conflict_user_svcpart;
927 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
929 foreach my $part_export ( $part_svc->part_export ) {
931 #this will catch to the same exact export
932 my @svcparts = map { $_->svcpart } $part_export->export_svc;
934 #this will catch to exports w/same exporthost+type ???
935 #my @other_part_export = qsearch('part_export', {
936 # 'machine' => $part_export->machine,
937 # 'exporttype' => $part_export->exporttype,
939 #foreach my $other_part_export ( @other_part_export ) {
940 # push @svcparts, map { $_->svcpart }
941 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
944 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
945 #silly kludge to avoid uninitialized value errors
946 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
947 ? $exports->{$part_export->exporttype}{'nodomain'}
949 if ( $nodomain =~ /^Y/i ) {
950 $conflict_user_svcpart{$_} = $part_export->exportnum
953 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
958 foreach my $dup_user ( @dup_user ) {
959 my $dup_svcpart = $dup_user->cust_svc->svcpart;
960 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
961 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
962 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
966 foreach my $dup_userdomain ( @dup_userdomain ) {
967 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
968 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
969 return "duplicate username\@domain: conflicts with svcnum ".
970 $dup_userdomain->svcnum. " via exportnum ".
971 $conflict_userdomain_svcpart{$dup_svcpart};
975 foreach my $dup_uid ( @dup_uid ) {
976 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
977 if ( exists($conflict_user_svcpart{$dup_svcpart})
978 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
979 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
980 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
981 || $conflict_userdomain_svcpart{$dup_svcpart};
993 Depriciated, use radius_reply instead.
998 carp "FS::svc_acct::radius depriciated, use radius_reply";
1004 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1005 reply attributes of this record.
1007 Note that this is now the preferred method for reading RADIUS attributes -
1008 accessing the columns directly is discouraged, as the column names are
1009 expected to change in the future.
1019 my($column, $attrib) = ($1, $2);
1020 #$attrib =~ s/_/\-/g;
1021 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1022 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1024 if ( $self->slipip && $self->slipip ne '0e0' ) {
1025 $reply{$radius_ip} = $self->slipip;
1028 if ( $self->seconds !~ /^$/ ) {
1029 $reply{'Session-Timeout'} = $self->seconds;
1037 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1038 check attributes of this record.
1040 Note that this is now the preferred method for reading RADIUS attributes -
1041 accessing the columns directly is discouraged, as the column names are
1042 expected to change in the future.
1052 my($column, $attrib) = ($1, $2);
1053 #$attrib =~ s/_/\-/g;
1054 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1055 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1057 my $password = $self->_password;
1058 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1060 my $cust_pkg = $self->cust_svc->cust_pkg;
1061 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid ) {
1062 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1071 Returns the domain associated with this account.
1077 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1078 my $svc_domain = $self->svc_domain(@_)
1079 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1080 $svc_domain->domain;
1085 Returns the FS::svc_domain record for this account's domain (see
1093 ? $self->{'_domsvc'}
1094 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1099 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1103 #inherited from svc_Common
1107 Returns an email address associated with the account.
1113 $self->username. '@'. $self->domain(@_);
1118 Returns an array of FS::acct_snarf records associated with the account.
1119 If the acct_snarf table does not exist or there are no associated records,
1120 an empty list is returned
1126 return () unless dbdef->table('acct_snarf');
1127 eval "use FS::acct_snarf;";
1129 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1132 =item decrement_seconds SECONDS
1134 Decrements 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 decrement_seconds {
1140 shift->_op_seconds('-', @_);
1143 =item increment_seconds SECONDS
1145 Increments the I<seconds> field of this record by the given amount. If there
1146 is an error, returns the error, otherwise returns false.
1150 sub increment_seconds {
1151 shift->_op_seconds('+', @_);
1159 my %op2condition = (
1160 '-' => sub { my($self, $seconds) = @_;
1161 $self->seconds - $seconds <= 0;
1163 '+' => sub { my($self, $seconds) = @_;
1164 $self->seconds + $seconds > 0;
1169 my( $self, $op, $seconds ) = @_;
1170 warn "$me _op_seconds called for svcnum ". $self->svcnum.
1171 ' ('. $self->email. "): $op $seconds\n"
1174 local $SIG{HUP} = 'IGNORE';
1175 local $SIG{INT} = 'IGNORE';
1176 local $SIG{QUIT} = 'IGNORE';
1177 local $SIG{TERM} = 'IGNORE';
1178 local $SIG{TSTP} = 'IGNORE';
1179 local $SIG{PIPE} = 'IGNORE';
1181 my $oldAutoCommit = $FS::UID::AutoCommit;
1182 local $FS::UID::AutoCommit = 0;
1185 my $sql = "UPDATE svc_acct SET seconds = ".
1186 " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0
1187 " $op ? WHERE svcnum = ?";
1191 my $sth = $dbh->prepare( $sql )
1192 or die "Error preparing $sql: ". $dbh->errstr;
1193 my $rv = $sth->execute($seconds, $self->svcnum);
1194 die "Error executing $sql: ". $sth->errstr
1195 unless defined($rv);
1196 die "Can't update seconds for svcnum". $self->svcnum
1199 my $action = $op2action{$op};
1201 if ( $conf->exists("svc_acct-usage_$action")
1202 && &{$op2condition{$op}}($self, $seconds) ) {
1203 #my $error = $self->$action();
1204 my $error = $self->cust_svc->cust_pkg->$action();
1206 $dbh->rollback if $oldAutoCommit;
1207 return "Error ${action}ing: $error";
1211 warn "$me update sucessful; committing\n"
1213 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1219 =item seconds_since TIMESTAMP
1221 Returns the number of seconds this account has been online since TIMESTAMP,
1222 according to the session monitor (see L<FS::Session>).
1224 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1225 L<Time::Local> and L<Date::Parse> for conversion functions.
1229 #note: POD here, implementation in FS::cust_svc
1232 $self->cust_svc->seconds_since(@_);
1235 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1237 Returns the numbers of seconds this account has been online between
1238 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1239 external SQL radacct table, specified via sqlradius export. Sessions which
1240 started in the specified range but are still open are counted from session
1241 start to the end of the range (unless they are over 1 day old, in which case
1242 they are presumed missing their stop record and not counted). Also, sessions
1243 which end in the range but started earlier are counted from the start of the
1244 range to session end. Finally, sessions which start before the range but end
1245 after are counted for the entire range.
1247 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1248 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1253 #note: POD here, implementation in FS::cust_svc
1254 sub seconds_since_sqlradacct {
1256 $self->cust_svc->seconds_since_sqlradacct(@_);
1259 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1261 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1262 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1263 TIMESTAMP_END (exclusive).
1265 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1266 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1271 #note: POD here, implementation in FS::cust_svc
1272 sub attribute_since_sqlradacct {
1274 $self->cust_svc->attribute_since_sqlradacct(@_);
1277 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1279 Returns an array of hash references of this customers login history for the
1280 given time range. (document this better)
1284 sub get_session_history {
1286 $self->cust_svc->get_session_history(@_);
1291 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1297 if ( $self->usergroup ) {
1298 #when provisioning records, export callback runs in svc_Common.pm before
1299 #radius_usergroup records can be inserted...
1300 @{$self->usergroup};
1302 map { $_->groupname }
1303 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1307 =item clone_suspended
1309 Constructor used by FS::part_export::_export_suspend fallback. Document
1314 sub clone_suspended {
1316 my %hash = $self->hash;
1317 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1318 new FS::svc_acct \%hash;
1321 =item clone_kludge_unsuspend
1323 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1328 sub clone_kludge_unsuspend {
1330 my %hash = $self->hash;
1331 $hash{_password} = '';
1332 new FS::svc_acct \%hash;
1335 =item check_password
1337 Checks the supplied password against the (possibly encrypted) password in the
1338 database. Returns true for a sucessful authentication, false for no match.
1340 Currently supported encryptions are: classic DES crypt() and MD5
1344 sub check_password {
1345 my($self, $check_password) = @_;
1347 #remove old-style SUSPENDED kludge, they should be allowed to login to
1348 #self-service and pay up
1349 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1351 #eventually should check a "password-encoding" field
1352 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1354 } elsif ( length($password) < 13 ) { #plaintext
1355 $check_password eq $password;
1356 } elsif ( length($password) == 13 ) { #traditional DES crypt
1357 crypt($check_password, $password) eq $password;
1358 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1359 unix_md5_crypt($check_password, $password) eq $password;
1360 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1361 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1362 $self->svcnum. "\n";
1365 warn "Can't check password: Unrecognized encryption for svcnum ".
1366 $self->svcnum. "\n";
1372 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1374 Returns an encrypted password, either by passing through an encrypted password
1375 in the database or by encrypting a plaintext password from the database.
1377 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1378 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1379 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1380 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
1381 encryption type is only used if the password is not already encrypted in the
1386 sub crypt_password {
1388 #eventually should check a "password-encoding" field
1389 if ( length($self->_password) == 13
1390 || $self->_password =~ /^\$(1|2a?)\$/
1391 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1396 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1397 if ( $encryption eq 'crypt' ) {
1400 $saltset[int(rand(64))].$saltset[int(rand(64))]
1402 } elsif ( $encryption eq 'md5' ) {
1403 unix_md5_crypt( $self->_password );
1404 } elsif ( $encryption eq 'blowfish' ) {
1405 die "unknown encryption method $encryption";
1407 die "unknown encryption method $encryption";
1412 =item virtual_maildir
1414 Returns $domain/maildirs/$username/
1418 sub virtual_maildir {
1420 $self->domain. '/maildirs/'. $self->username. '/';
1431 This is the FS::svc_acct job-queue-able version. It still uses
1432 FS::Misc::send_email under-the-hood.
1439 eval "use FS::Misc qw(send_email)";
1442 $opt{mimetype} ||= 'text/plain';
1443 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1445 my $error = send_email(
1446 'from' => $opt{from},
1448 'subject' => $opt{subject},
1449 'content-type' => $opt{mimetype},
1450 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1452 die $error if $error;
1455 =item check_and_rebuild_fuzzyfiles
1459 sub check_and_rebuild_fuzzyfiles {
1460 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1461 -e "$dir/svc_acct.username"
1462 or &rebuild_fuzzyfiles;
1465 =item rebuild_fuzzyfiles
1469 sub rebuild_fuzzyfiles {
1471 use Fcntl qw(:flock);
1473 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1477 open(USERNAMELOCK,">>$dir/svc_acct.username")
1478 or die "can't open $dir/svc_acct.username: $!";
1479 flock(USERNAMELOCK,LOCK_EX)
1480 or die "can't lock $dir/svc_acct.username: $!";
1482 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1484 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1485 or die "can't open $dir/svc_acct.username.tmp: $!";
1486 print USERNAMECACHE join("\n", @all_username), "\n";
1487 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1489 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1499 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1500 open(USERNAMECACHE,"<$dir/svc_acct.username")
1501 or die "can't open $dir/svc_acct.username: $!";
1502 my @array = map { chomp; $_; } <USERNAMECACHE>;
1503 close USERNAMECACHE;
1507 =item append_fuzzyfiles USERNAME
1511 sub append_fuzzyfiles {
1512 my $username = shift;
1514 &check_and_rebuild_fuzzyfiles;
1516 use Fcntl qw(:flock);
1518 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1520 open(USERNAME,">>$dir/svc_acct.username")
1521 or die "can't open $dir/svc_acct.username: $!";
1522 flock(USERNAME,LOCK_EX)
1523 or die "can't lock $dir/svc_acct.username: $!";
1525 print USERNAME "$username\n";
1527 flock(USERNAME,LOCK_UN)
1528 or die "can't unlock $dir/svc_acct.username: $!";
1536 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1540 sub radius_usergroup_selector {
1541 my $sel_groups = shift;
1542 my %sel_groups = map { $_=>1 } @$sel_groups;
1544 my $selectname = shift || 'radius_usergroup';
1547 my $sth = $dbh->prepare(
1548 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1549 ) or die $dbh->errstr;
1550 $sth->execute() or die $sth->errstr;
1551 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1555 function ${selectname}_doadd(object) {
1556 var myvalue = object.${selectname}_add.value;
1557 var optionName = new Option(myvalue,myvalue,false,true);
1558 var length = object.$selectname.length;
1559 object.$selectname.options[length] = optionName;
1560 object.${selectname}_add.value = "";
1563 <SELECT MULTIPLE NAME="$selectname">
1566 foreach my $group ( @all_groups ) {
1567 $html .= qq(<OPTION VALUE="$group");
1568 if ( $sel_groups{$group} ) {
1569 $html .= ' SELECTED';
1570 $sel_groups{$group} = 0;
1572 $html .= ">$group</OPTION>\n";
1574 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1575 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1577 $html .= '</SELECT>';
1579 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1580 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1589 The $recref stuff in sub check should be cleaned up.
1591 The suspend, unsuspend and cancel methods update the database, but not the
1592 current object. This is probably a bug as it's unexpected and
1595 radius_usergroup_selector? putting web ui components in here? they should
1596 probably live somewhere else...
1598 insertion of RADIUS group stuff in insert could be done with child_objects now
1599 (would probably clean up export of them too)
1603 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1604 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1605 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1606 L<freeside-queued>), L<FS::svc_acct_pop>,
1607 schema.html from the base documentation.