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
471 foreach my $xid (qw( uid gid )) {
473 return "Can't change $xid!"
474 if ! $conf->exists("svc_acct-edit_$xid")
475 && $old->$xid() != $new->$xid();
480 #change homdir when we change username
481 $new->setfield('dir', '') if $old->username ne $new->username;
483 local $SIG{HUP} = 'IGNORE';
484 local $SIG{INT} = 'IGNORE';
485 local $SIG{QUIT} = 'IGNORE';
486 local $SIG{TERM} = 'IGNORE';
487 local $SIG{TSTP} = 'IGNORE';
488 local $SIG{PIPE} = 'IGNORE';
490 my $oldAutoCommit = $FS::UID::AutoCommit;
491 local $FS::UID::AutoCommit = 0;
494 # redundant, but so $new->usergroup gets set
495 $error = $new->check;
496 return $error if $error;
498 $old->usergroup( [ $old->radius_groups ] );
499 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
500 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
501 if ( $new->usergroup ) {
502 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
503 my @newgroups = @{$new->usergroup};
504 foreach my $oldgroup ( @{$old->usergroup} ) {
505 if ( grep { $oldgroup eq $_ } @newgroups ) {
506 @newgroups = grep { $oldgroup ne $_ } @newgroups;
509 my $radius_usergroup = qsearchs('radius_usergroup', {
510 svcnum => $old->svcnum,
511 groupname => $oldgroup,
513 my $error = $radius_usergroup->delete;
515 $dbh->rollback if $oldAutoCommit;
516 return "error deleting radius_usergroup $oldgroup: $error";
520 foreach my $newgroup ( @newgroups ) {
521 my $radius_usergroup = new FS::radius_usergroup ( {
522 svcnum => $new->svcnum,
523 groupname => $newgroup,
525 my $error = $radius_usergroup->insert;
527 $dbh->rollback if $oldAutoCommit;
528 return "error adding radius_usergroup $newgroup: $error";
534 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
535 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
536 $error = $new->_check_duplicate;
538 $dbh->rollback if $oldAutoCommit;
543 $error = $new->SUPER::replace($old);
545 $dbh->rollback if $oldAutoCommit;
546 return $error if $error;
549 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
550 $error = $new->queue_fuzzyfiles_update;
552 $dbh->rollback if $oldAutoCommit;
553 return "updating fuzzy search cache: $error";
557 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
561 =item queue_fuzzyfiles_update
563 Used by insert & replace to update the fuzzy search cache
567 sub queue_fuzzyfiles_update {
570 local $SIG{HUP} = 'IGNORE';
571 local $SIG{INT} = 'IGNORE';
572 local $SIG{QUIT} = 'IGNORE';
573 local $SIG{TERM} = 'IGNORE';
574 local $SIG{TSTP} = 'IGNORE';
575 local $SIG{PIPE} = 'IGNORE';
577 my $oldAutoCommit = $FS::UID::AutoCommit;
578 local $FS::UID::AutoCommit = 0;
581 my $queue = new FS::queue {
582 'svcnum' => $self->svcnum,
583 'job' => 'FS::svc_acct::append_fuzzyfiles'
585 my $error = $queue->insert($self->username);
587 $dbh->rollback if $oldAutoCommit;
588 return "queueing job (transaction rolled back): $error";
591 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
599 Suspends this account by calling export-specific suspend hooks. If there is
600 an error, returns the error, otherwise returns false.
602 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
608 return "can't suspend system account" if $self->_check_system;
609 $self->SUPER::suspend;
614 Unsuspends this account by by calling export-specific suspend hooks. If there
615 is an error, returns the error, otherwise returns false.
617 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
623 my %hash = $self->hash;
624 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
625 $hash{_password} = $1;
626 my $new = new FS::svc_acct ( \%hash );
627 my $error = $new->replace($self);
628 return $error if $error;
631 $self->SUPER::unsuspend;
636 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
638 If the B<auto_unset_catchall> configuration option is set, this method will
639 automatically remove any references to the canceled service in the catchall
640 field of svc_domain. This allows packages that contain both a svc_domain and
641 its catchall svc_acct to be canceled in one step.
646 # Only one thing to do at this level
648 foreach my $svc_domain (
649 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
650 if($conf->exists('auto_unset_catchall')) {
651 my %hash = $svc_domain->hash;
652 $hash{catchall} = '';
653 my $new = new FS::svc_domain ( \%hash );
654 my $error = $new->replace($svc_domain);
655 return $error if $error;
657 return "cannot unprovision svc_acct #".$self->svcnum.
658 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
662 $self->SUPER::cancel;
668 Checks all fields to make sure this is a valid service. If there is an error,
669 returns the error, otherwise returns false. Called by the insert and replace
672 Sets any fixed values; see L<FS::part_svc>.
679 my($recref) = $self->hashref;
681 my $x = $self->setfixed;
682 return $x unless ref($x);
685 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
687 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
690 my $error = $self->ut_numbern('svcnum')
691 #|| $self->ut_number('domsvc')
692 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
693 || $self->ut_textn('sec_phrase')
695 return $error if $error;
697 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
698 if ( $username_uppercase ) {
699 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
700 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
701 $recref->{username} = $1;
703 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
704 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
705 $recref->{username} = $1;
708 if ( $username_letterfirst ) {
709 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
710 } elsif ( $username_letter ) {
711 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
713 if ( $username_noperiod ) {
714 $recref->{username} =~ /\./ and return gettext('illegal_username');
716 if ( $username_nounderscore ) {
717 $recref->{username} =~ /_/ and return gettext('illegal_username');
719 if ( $username_nodash ) {
720 $recref->{username} =~ /\-/ and return gettext('illegal_username');
722 unless ( $username_ampersand ) {
723 $recref->{username} =~ /\&/ and return gettext('illegal_username');
725 if ( $password_noampersand ) {
726 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
728 if ( $password_noexclamation ) {
729 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
731 unless ( $username_percent ) {
732 $recref->{username} =~ /\%/ and return gettext('illegal_username');
735 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
736 $recref->{popnum} = $1;
737 return "Unknown popnum" unless
738 ! $recref->{popnum} ||
739 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
741 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
743 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
744 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
746 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
747 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
748 #not all systems use gid=uid
749 #you can set a fixed gid in part_svc
751 return "Only root can have uid 0"
752 if $recref->{uid} == 0
753 && $recref->{username} !~ /^(root|toor|smtp)$/;
755 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
756 or return "Illegal directory: ". $recref->{dir};
758 return "Illegal directory"
759 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
760 return "Illegal directory"
761 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
762 unless ( $recref->{dir} ) {
763 $recref->{dir} = $dir_prefix . '/';
764 if ( $dirhash > 0 ) {
765 for my $h ( 1 .. $dirhash ) {
766 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
768 } elsif ( $dirhash < 0 ) {
769 for my $h ( reverse $dirhash .. -1 ) {
770 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
773 $recref->{dir} .= $recref->{username};
777 unless ( $recref->{username} eq 'sync' ) {
778 if ( grep $_ eq $recref->{shell}, @shells ) {
779 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
781 return "Illegal shell \`". $self->shell. "\'; ".
782 $conf->dir. "/shells contains: @shells";
785 $recref->{shell} = '/bin/sync';
789 $recref->{gid} ne '' ?
790 return "Can't have gid without uid" : ( $recref->{gid}='' );
791 $recref->{dir} ne '' ?
792 return "Can't have directory without uid" : ( $recref->{dir}='' );
793 $recref->{shell} ne '' ?
794 return "Can't have shell without uid" : ( $recref->{shell}='' );
797 # $error = $self->ut_textn('finger');
798 # return $error if $error;
799 if ( $self->getfield('finger') eq '' ) {
800 my $cust_pkg = $self->svcnum
801 ? $self->cust_svc->cust_pkg
802 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
804 my $cust_main = $cust_pkg->cust_main;
805 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
808 $self->getfield('finger') =~
809 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
810 or return "Illegal finger: ". $self->getfield('finger');
811 $self->setfield('finger', $1);
813 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
814 $recref->{quota} = $1;
816 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
817 if ( $recref->{slipip} eq '' ) {
818 $recref->{slipip} = '';
819 } elsif ( $recref->{slipip} eq '0e0' ) {
820 $recref->{slipip} = '0e0';
822 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
823 or return "Illegal slipip: ". $self->slipip;
824 $recref->{slipip} = $1;
829 #arbitrary RADIUS stuff; allow ut_textn for now
830 foreach ( grep /^radius_/, fields('svc_acct') ) {
834 #generate a password if it is blank
835 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
836 unless ( $recref->{_password} );
838 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
839 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
840 $recref->{_password} = $1.$3;
841 #uncomment this to encrypt password immediately upon entry, or run
842 #bin/crypt_pw in cron to give new users a window during which their
843 #password is available to techs, for faxing, etc. (also be aware of
845 #$recref->{password} = $1.
846 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
848 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
849 $recref->{_password} = $1.$3;
850 } elsif ( $recref->{_password} eq '*' ) {
851 $recref->{_password} = '*';
852 } elsif ( $recref->{_password} eq '!' ) {
853 $recref->{_password} = '!';
854 } elsif ( $recref->{_password} eq '!!' ) {
855 $recref->{_password} = '!!';
857 #return "Illegal password";
858 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
859 FS::Msgcat::_gettext('illegal_password_characters').
860 ": ". $recref->{_password};
868 Internal function to check the username against the list of system usernames
869 from the I<system_usernames> configuration value. Returns true if the username
870 is listed on the system username list.
876 scalar( grep { $self->username eq $_ || $self->email eq $_ }
877 $conf->config('system_usernames')
881 =item _check_duplicate
883 Internal function to check for duplicates usernames, username@domain pairs and
886 If the I<global_unique-username> configuration value is set to B<username> or
887 B<username@domain>, enforces global username or username@domain uniqueness.
889 In all cases, check for duplicate uids and usernames or username@domain pairs
890 per export and with identical I<svcpart> values.
894 sub _check_duplicate {
897 #this is Pg-specific. what to do for mysql etc?
898 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
899 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
900 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
902 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
904 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
905 unless ( $part_svc ) {
906 return 'unknown svcpart '. $self->svcpart;
909 my $global_unique = $conf->config('global_unique-username') || 'none';
911 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
912 qsearch( 'svc_acct', { 'username' => $self->username } );
913 return gettext('username_in_use')
914 if $global_unique eq 'username' && @dup_user;
916 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
917 qsearch( 'svc_acct', { 'username' => $self->username,
918 'domsvc' => $self->domsvc } );
919 return gettext('username_in_use')
920 if $global_unique eq 'username@domain' && @dup_userdomain;
923 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
924 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
925 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
926 qsearch( 'svc_acct', { 'uid' => $self->uid } );
931 if ( @dup_user || @dup_userdomain || @dup_uid ) {
932 my $exports = FS::part_export::export_info('svc_acct');
933 my %conflict_user_svcpart;
934 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
936 foreach my $part_export ( $part_svc->part_export ) {
938 #this will catch to the same exact export
939 my @svcparts = map { $_->svcpart } $part_export->export_svc;
941 #this will catch to exports w/same exporthost+type ???
942 #my @other_part_export = qsearch('part_export', {
943 # 'machine' => $part_export->machine,
944 # 'exporttype' => $part_export->exporttype,
946 #foreach my $other_part_export ( @other_part_export ) {
947 # push @svcparts, map { $_->svcpart }
948 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
951 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
952 #silly kludge to avoid uninitialized value errors
953 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
954 ? $exports->{$part_export->exporttype}{'nodomain'}
956 if ( $nodomain =~ /^Y/i ) {
957 $conflict_user_svcpart{$_} = $part_export->exportnum
960 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
965 foreach my $dup_user ( @dup_user ) {
966 my $dup_svcpart = $dup_user->cust_svc->svcpart;
967 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
968 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
969 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
973 foreach my $dup_userdomain ( @dup_userdomain ) {
974 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
975 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
976 return "duplicate username\@domain: conflicts with svcnum ".
977 $dup_userdomain->svcnum. " via exportnum ".
978 $conflict_userdomain_svcpart{$dup_svcpart};
982 foreach my $dup_uid ( @dup_uid ) {
983 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
984 if ( exists($conflict_user_svcpart{$dup_svcpart})
985 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
986 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
987 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
988 || $conflict_userdomain_svcpart{$dup_svcpart};
1000 Depriciated, use radius_reply instead.
1005 carp "FS::svc_acct::radius depriciated, use radius_reply";
1006 $_[0]->radius_reply;
1011 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1012 reply attributes of this record.
1014 Note that this is now the preferred method for reading RADIUS attributes -
1015 accessing the columns directly is discouraged, as the column names are
1016 expected to change in the future.
1026 my($column, $attrib) = ($1, $2);
1027 #$attrib =~ s/_/\-/g;
1028 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1029 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1031 if ( $self->slipip && $self->slipip ne '0e0' ) {
1032 $reply{$radius_ip} = $self->slipip;
1035 if ( $self->seconds !~ /^$/ ) {
1036 $reply{'Session-Timeout'} = $self->seconds;
1044 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1045 check attributes of this record.
1047 Note that this is now the preferred method for reading RADIUS attributes -
1048 accessing the columns directly is discouraged, as the column names are
1049 expected to change in the future.
1059 my($column, $attrib) = ($1, $2);
1060 #$attrib =~ s/_/\-/g;
1061 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1062 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1064 my $password = $self->_password;
1065 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1067 my $cust_pkg = $self->cust_svc->cust_pkg;
1068 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1069 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1078 Returns the domain associated with this account.
1084 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1085 my $svc_domain = $self->svc_domain(@_)
1086 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1087 $svc_domain->domain;
1092 Returns the FS::svc_domain record for this account's domain (see
1100 ? $self->{'_domsvc'}
1101 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1106 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1110 #inherited from svc_Common
1114 Returns an email address associated with the account.
1120 $self->username. '@'. $self->domain(@_);
1125 Returns an array of FS::acct_snarf records associated with the account.
1126 If the acct_snarf table does not exist or there are no associated records,
1127 an empty list is returned
1133 return () unless dbdef->table('acct_snarf');
1134 eval "use FS::acct_snarf;";
1136 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1139 =item decrement_seconds SECONDS
1141 Decrements the I<seconds> field of this record by the given amount. If there
1142 is an error, returns the error, otherwise returns false.
1146 sub decrement_seconds {
1147 shift->_op_seconds('-', @_);
1150 =item increment_seconds SECONDS
1152 Increments the I<seconds> field of this record by the given amount. If there
1153 is an error, returns the error, otherwise returns false.
1157 sub increment_seconds {
1158 shift->_op_seconds('+', @_);
1166 my %op2condition = (
1167 '-' => sub { my($self, $seconds) = @_;
1168 $self->seconds - $seconds <= 0;
1170 '+' => sub { my($self, $seconds) = @_;
1171 $self->seconds + $seconds > 0;
1176 my( $self, $op, $seconds ) = @_;
1177 warn "$me _op_seconds called for svcnum ". $self->svcnum.
1178 ' ('. $self->email. "): $op $seconds\n"
1181 local $SIG{HUP} = 'IGNORE';
1182 local $SIG{INT} = 'IGNORE';
1183 local $SIG{QUIT} = 'IGNORE';
1184 local $SIG{TERM} = 'IGNORE';
1185 local $SIG{TSTP} = 'IGNORE';
1186 local $SIG{PIPE} = 'IGNORE';
1188 my $oldAutoCommit = $FS::UID::AutoCommit;
1189 local $FS::UID::AutoCommit = 0;
1192 my $sql = "UPDATE svc_acct SET seconds = ".
1193 " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0
1194 " $op ? WHERE svcnum = ?";
1198 my $sth = $dbh->prepare( $sql )
1199 or die "Error preparing $sql: ". $dbh->errstr;
1200 my $rv = $sth->execute($seconds, $self->svcnum);
1201 die "Error executing $sql: ". $sth->errstr
1202 unless defined($rv);
1203 die "Can't update seconds for svcnum". $self->svcnum
1206 my $action = $op2action{$op};
1208 if ( $conf->exists("svc_acct-usage_$action")
1209 && &{$op2condition{$op}}($self, $seconds) ) {
1210 #my $error = $self->$action();
1211 my $error = $self->cust_svc->cust_pkg->$action();
1213 $dbh->rollback if $oldAutoCommit;
1214 return "Error ${action}ing: $error";
1218 warn "$me update sucessful; committing\n"
1220 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1226 =item seconds_since TIMESTAMP
1228 Returns the number of seconds this account has been online since TIMESTAMP,
1229 according to the session monitor (see L<FS::Session>).
1231 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1232 L<Time::Local> and L<Date::Parse> for conversion functions.
1236 #note: POD here, implementation in FS::cust_svc
1239 $self->cust_svc->seconds_since(@_);
1242 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1244 Returns the numbers of seconds this account has been online between
1245 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1246 external SQL radacct table, specified via sqlradius export. Sessions which
1247 started in the specified range but are still open are counted from session
1248 start to the end of the range (unless they are over 1 day old, in which case
1249 they are presumed missing their stop record and not counted). Also, sessions
1250 which end in the range but started earlier are counted from the start of the
1251 range to session end. Finally, sessions which start before the range but end
1252 after are counted for the entire range.
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 seconds_since_sqlradacct {
1263 $self->cust_svc->seconds_since_sqlradacct(@_);
1266 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1268 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1269 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1270 TIMESTAMP_END (exclusive).
1272 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1273 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1278 #note: POD here, implementation in FS::cust_svc
1279 sub attribute_since_sqlradacct {
1281 $self->cust_svc->attribute_since_sqlradacct(@_);
1284 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1286 Returns an array of hash references of this customers login history for the
1287 given time range. (document this better)
1291 sub get_session_history {
1293 $self->cust_svc->get_session_history(@_);
1298 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1304 if ( $self->usergroup ) {
1305 #when provisioning records, export callback runs in svc_Common.pm before
1306 #radius_usergroup records can be inserted...
1307 @{$self->usergroup};
1309 map { $_->groupname }
1310 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1314 =item clone_suspended
1316 Constructor used by FS::part_export::_export_suspend fallback. Document
1321 sub clone_suspended {
1323 my %hash = $self->hash;
1324 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1325 new FS::svc_acct \%hash;
1328 =item clone_kludge_unsuspend
1330 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1335 sub clone_kludge_unsuspend {
1337 my %hash = $self->hash;
1338 $hash{_password} = '';
1339 new FS::svc_acct \%hash;
1342 =item check_password
1344 Checks the supplied password against the (possibly encrypted) password in the
1345 database. Returns true for a sucessful authentication, false for no match.
1347 Currently supported encryptions are: classic DES crypt() and MD5
1351 sub check_password {
1352 my($self, $check_password) = @_;
1354 #remove old-style SUSPENDED kludge, they should be allowed to login to
1355 #self-service and pay up
1356 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1358 #eventually should check a "password-encoding" field
1359 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1361 } elsif ( length($password) < 13 ) { #plaintext
1362 $check_password eq $password;
1363 } elsif ( length($password) == 13 ) { #traditional DES crypt
1364 crypt($check_password, $password) eq $password;
1365 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1366 unix_md5_crypt($check_password, $password) eq $password;
1367 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1368 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1369 $self->svcnum. "\n";
1372 warn "Can't check password: Unrecognized encryption for svcnum ".
1373 $self->svcnum. "\n";
1379 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1381 Returns an encrypted password, either by passing through an encrypted password
1382 in the database or by encrypting a plaintext password from the database.
1384 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1385 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1386 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1387 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
1388 encryption type is only used if the password is not already encrypted in the
1393 sub crypt_password {
1395 #eventually should check a "password-encoding" field
1396 if ( length($self->_password) == 13
1397 || $self->_password =~ /^\$(1|2a?)\$/
1398 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1403 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1404 if ( $encryption eq 'crypt' ) {
1407 $saltset[int(rand(64))].$saltset[int(rand(64))]
1409 } elsif ( $encryption eq 'md5' ) {
1410 unix_md5_crypt( $self->_password );
1411 } elsif ( $encryption eq 'blowfish' ) {
1412 die "unknown encryption method $encryption";
1414 die "unknown encryption method $encryption";
1419 =item virtual_maildir
1421 Returns $domain/maildirs/$username/
1425 sub virtual_maildir {
1427 $self->domain. '/maildirs/'. $self->username. '/';
1438 This is the FS::svc_acct job-queue-able version. It still uses
1439 FS::Misc::send_email under-the-hood.
1446 eval "use FS::Misc qw(send_email)";
1449 $opt{mimetype} ||= 'text/plain';
1450 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1452 my $error = send_email(
1453 'from' => $opt{from},
1455 'subject' => $opt{subject},
1456 'content-type' => $opt{mimetype},
1457 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1459 die $error if $error;
1462 =item check_and_rebuild_fuzzyfiles
1466 sub check_and_rebuild_fuzzyfiles {
1467 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1468 -e "$dir/svc_acct.username"
1469 or &rebuild_fuzzyfiles;
1472 =item rebuild_fuzzyfiles
1476 sub rebuild_fuzzyfiles {
1478 use Fcntl qw(:flock);
1480 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1484 open(USERNAMELOCK,">>$dir/svc_acct.username")
1485 or die "can't open $dir/svc_acct.username: $!";
1486 flock(USERNAMELOCK,LOCK_EX)
1487 or die "can't lock $dir/svc_acct.username: $!";
1489 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1491 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1492 or die "can't open $dir/svc_acct.username.tmp: $!";
1493 print USERNAMECACHE join("\n", @all_username), "\n";
1494 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1496 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1506 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1507 open(USERNAMECACHE,"<$dir/svc_acct.username")
1508 or die "can't open $dir/svc_acct.username: $!";
1509 my @array = map { chomp; $_; } <USERNAMECACHE>;
1510 close USERNAMECACHE;
1514 =item append_fuzzyfiles USERNAME
1518 sub append_fuzzyfiles {
1519 my $username = shift;
1521 &check_and_rebuild_fuzzyfiles;
1523 use Fcntl qw(:flock);
1525 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1527 open(USERNAME,">>$dir/svc_acct.username")
1528 or die "can't open $dir/svc_acct.username: $!";
1529 flock(USERNAME,LOCK_EX)
1530 or die "can't lock $dir/svc_acct.username: $!";
1532 print USERNAME "$username\n";
1534 flock(USERNAME,LOCK_UN)
1535 or die "can't unlock $dir/svc_acct.username: $!";
1543 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1547 sub radius_usergroup_selector {
1548 my $sel_groups = shift;
1549 my %sel_groups = map { $_=>1 } @$sel_groups;
1551 my $selectname = shift || 'radius_usergroup';
1554 my $sth = $dbh->prepare(
1555 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1556 ) or die $dbh->errstr;
1557 $sth->execute() or die $sth->errstr;
1558 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1562 function ${selectname}_doadd(object) {
1563 var myvalue = object.${selectname}_add.value;
1564 var optionName = new Option(myvalue,myvalue,false,true);
1565 var length = object.$selectname.length;
1566 object.$selectname.options[length] = optionName;
1567 object.${selectname}_add.value = "";
1570 <SELECT MULTIPLE NAME="$selectname">
1573 foreach my $group ( @all_groups ) {
1574 $html .= qq(<OPTION VALUE="$group");
1575 if ( $sel_groups{$group} ) {
1576 $html .= ' SELECTED';
1577 $sel_groups{$group} = 0;
1579 $html .= ">$group</OPTION>\n";
1581 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1582 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1584 $html .= '</SELECT>';
1586 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1587 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1596 The $recref stuff in sub check should be cleaned up.
1598 The suspend, unsuspend and cancel methods update the database, but not the
1599 current object. This is probably a bug as it's unexpected and
1602 radius_usergroup_selector? putting web ui components in here? they should
1603 probably live somewhere else...
1605 insertion of RADIUS group stuff in insert could be done with child_objects now
1606 (would probably clean up export of them too)
1610 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1611 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1612 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1613 L<freeside-queued>), L<FS::svc_acct_pop>,
1614 schema.html from the base documentation.