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()
476 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
481 #change homdir when we change username
482 $new->setfield('dir', '') if $old->username ne $new->username;
484 local $SIG{HUP} = 'IGNORE';
485 local $SIG{INT} = 'IGNORE';
486 local $SIG{QUIT} = 'IGNORE';
487 local $SIG{TERM} = 'IGNORE';
488 local $SIG{TSTP} = 'IGNORE';
489 local $SIG{PIPE} = 'IGNORE';
491 my $oldAutoCommit = $FS::UID::AutoCommit;
492 local $FS::UID::AutoCommit = 0;
495 # redundant, but so $new->usergroup gets set
496 $error = $new->check;
497 return $error if $error;
499 $old->usergroup( [ $old->radius_groups ] );
500 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
501 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
502 if ( $new->usergroup ) {
503 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
504 my @newgroups = @{$new->usergroup};
505 foreach my $oldgroup ( @{$old->usergroup} ) {
506 if ( grep { $oldgroup eq $_ } @newgroups ) {
507 @newgroups = grep { $oldgroup ne $_ } @newgroups;
510 my $radius_usergroup = qsearchs('radius_usergroup', {
511 svcnum => $old->svcnum,
512 groupname => $oldgroup,
514 my $error = $radius_usergroup->delete;
516 $dbh->rollback if $oldAutoCommit;
517 return "error deleting radius_usergroup $oldgroup: $error";
521 foreach my $newgroup ( @newgroups ) {
522 my $radius_usergroup = new FS::radius_usergroup ( {
523 svcnum => $new->svcnum,
524 groupname => $newgroup,
526 my $error = $radius_usergroup->insert;
528 $dbh->rollback if $oldAutoCommit;
529 return "error adding radius_usergroup $newgroup: $error";
535 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
536 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
537 $error = $new->_check_duplicate;
539 $dbh->rollback if $oldAutoCommit;
544 $error = $new->SUPER::replace($old);
546 $dbh->rollback if $oldAutoCommit;
547 return $error if $error;
550 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
551 $error = $new->queue_fuzzyfiles_update;
553 $dbh->rollback if $oldAutoCommit;
554 return "updating fuzzy search cache: $error";
558 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
562 =item queue_fuzzyfiles_update
564 Used by insert & replace to update the fuzzy search cache
568 sub queue_fuzzyfiles_update {
571 local $SIG{HUP} = 'IGNORE';
572 local $SIG{INT} = 'IGNORE';
573 local $SIG{QUIT} = 'IGNORE';
574 local $SIG{TERM} = 'IGNORE';
575 local $SIG{TSTP} = 'IGNORE';
576 local $SIG{PIPE} = 'IGNORE';
578 my $oldAutoCommit = $FS::UID::AutoCommit;
579 local $FS::UID::AutoCommit = 0;
582 my $queue = new FS::queue {
583 'svcnum' => $self->svcnum,
584 'job' => 'FS::svc_acct::append_fuzzyfiles'
586 my $error = $queue->insert($self->username);
588 $dbh->rollback if $oldAutoCommit;
589 return "queueing job (transaction rolled back): $error";
592 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
600 Suspends this account by calling export-specific suspend hooks. If there is
601 an error, returns the error, otherwise returns false.
603 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
609 return "can't suspend system account" if $self->_check_system;
610 $self->SUPER::suspend;
615 Unsuspends this account by by calling export-specific suspend hooks. If there
616 is an error, returns the error, otherwise returns false.
618 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
624 my %hash = $self->hash;
625 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
626 $hash{_password} = $1;
627 my $new = new FS::svc_acct ( \%hash );
628 my $error = $new->replace($self);
629 return $error if $error;
632 $self->SUPER::unsuspend;
637 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
639 If the B<auto_unset_catchall> configuration option is set, this method will
640 automatically remove any references to the canceled service in the catchall
641 field of svc_domain. This allows packages that contain both a svc_domain and
642 its catchall svc_acct to be canceled in one step.
647 # Only one thing to do at this level
649 foreach my $svc_domain (
650 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
651 if($conf->exists('auto_unset_catchall')) {
652 my %hash = $svc_domain->hash;
653 $hash{catchall} = '';
654 my $new = new FS::svc_domain ( \%hash );
655 my $error = $new->replace($svc_domain);
656 return $error if $error;
658 return "cannot unprovision svc_acct #".$self->svcnum.
659 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
663 $self->SUPER::cancel;
669 Checks all fields to make sure this is a valid service. If there is an error,
670 returns the error, otherwise returns false. Called by the insert and replace
673 Sets any fixed values; see L<FS::part_svc>.
680 my($recref) = $self->hashref;
682 my $x = $self->setfixed;
683 return $x unless ref($x);
686 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
688 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
691 my $error = $self->ut_numbern('svcnum')
692 #|| $self->ut_number('domsvc')
693 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
694 || $self->ut_textn('sec_phrase')
696 return $error if $error;
698 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
699 if ( $username_uppercase ) {
700 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
701 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
702 $recref->{username} = $1;
704 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
705 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
706 $recref->{username} = $1;
709 if ( $username_letterfirst ) {
710 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
711 } elsif ( $username_letter ) {
712 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
714 if ( $username_noperiod ) {
715 $recref->{username} =~ /\./ and return gettext('illegal_username');
717 if ( $username_nounderscore ) {
718 $recref->{username} =~ /_/ and return gettext('illegal_username');
720 if ( $username_nodash ) {
721 $recref->{username} =~ /\-/ and return gettext('illegal_username');
723 unless ( $username_ampersand ) {
724 $recref->{username} =~ /\&/ and return gettext('illegal_username');
726 if ( $password_noampersand ) {
727 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
729 if ( $password_noexclamation ) {
730 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
732 unless ( $username_percent ) {
733 $recref->{username} =~ /\%/ and return gettext('illegal_username');
736 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
737 $recref->{popnum} = $1;
738 return "Unknown popnum" unless
739 ! $recref->{popnum} ||
740 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
742 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
744 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
745 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
747 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
748 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
749 #not all systems use gid=uid
750 #you can set a fixed gid in part_svc
752 return "Only root can have uid 0"
753 if $recref->{uid} == 0
754 && $recref->{username} !~ /^(root|toor|smtp)$/;
756 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
757 or return "Illegal directory: ". $recref->{dir};
759 return "Illegal directory"
760 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
761 return "Illegal directory"
762 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
763 unless ( $recref->{dir} ) {
764 $recref->{dir} = $dir_prefix . '/';
765 if ( $dirhash > 0 ) {
766 for my $h ( 1 .. $dirhash ) {
767 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
769 } elsif ( $dirhash < 0 ) {
770 for my $h ( reverse $dirhash .. -1 ) {
771 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
774 $recref->{dir} .= $recref->{username};
778 unless ( $recref->{username} eq 'sync' ) {
779 if ( grep $_ eq $recref->{shell}, @shells ) {
780 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
782 return "Illegal shell \`". $self->shell. "\'; ".
783 $conf->dir. "/shells contains: @shells";
786 $recref->{shell} = '/bin/sync';
790 $recref->{gid} ne '' ?
791 return "Can't have gid without uid" : ( $recref->{gid}='' );
792 $recref->{dir} ne '' ?
793 return "Can't have directory without uid" : ( $recref->{dir}='' );
794 $recref->{shell} ne '' ?
795 return "Can't have shell without uid" : ( $recref->{shell}='' );
798 # $error = $self->ut_textn('finger');
799 # return $error if $error;
800 if ( $self->getfield('finger') eq '' ) {
801 my $cust_pkg = $self->svcnum
802 ? $self->cust_svc->cust_pkg
803 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
805 my $cust_main = $cust_pkg->cust_main;
806 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
809 $self->getfield('finger') =~
810 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
811 or return "Illegal finger: ". $self->getfield('finger');
812 $self->setfield('finger', $1);
814 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
815 $recref->{quota} = $1;
817 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
818 if ( $recref->{slipip} eq '' ) {
819 $recref->{slipip} = '';
820 } elsif ( $recref->{slipip} eq '0e0' ) {
821 $recref->{slipip} = '0e0';
823 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
824 or return "Illegal slipip: ". $self->slipip;
825 $recref->{slipip} = $1;
830 #arbitrary RADIUS stuff; allow ut_textn for now
831 foreach ( grep /^radius_/, fields('svc_acct') ) {
835 #generate a password if it is blank
836 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
837 unless ( $recref->{_password} );
839 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
840 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
841 $recref->{_password} = $1.$3;
842 #uncomment this to encrypt password immediately upon entry, or run
843 #bin/crypt_pw in cron to give new users a window during which their
844 #password is available to techs, for faxing, etc. (also be aware of
846 #$recref->{password} = $1.
847 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
849 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
850 $recref->{_password} = $1.$3;
851 } elsif ( $recref->{_password} eq '*' ) {
852 $recref->{_password} = '*';
853 } elsif ( $recref->{_password} eq '!' ) {
854 $recref->{_password} = '!';
855 } elsif ( $recref->{_password} eq '!!' ) {
856 $recref->{_password} = '!!';
858 #return "Illegal password";
859 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
860 FS::Msgcat::_gettext('illegal_password_characters').
861 ": ". $recref->{_password};
869 Internal function to check the username against the list of system usernames
870 from the I<system_usernames> configuration value. Returns true if the username
871 is listed on the system username list.
877 scalar( grep { $self->username eq $_ || $self->email eq $_ }
878 $conf->config('system_usernames')
882 =item _check_duplicate
884 Internal function to check for duplicates usernames, username@domain pairs and
887 If the I<global_unique-username> configuration value is set to B<username> or
888 B<username@domain>, enforces global username or username@domain uniqueness.
890 In all cases, check for duplicate uids and usernames or username@domain pairs
891 per export and with identical I<svcpart> values.
895 sub _check_duplicate {
898 #this is Pg-specific. what to do for mysql etc?
899 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
900 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
901 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
903 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
905 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
906 unless ( $part_svc ) {
907 return 'unknown svcpart '. $self->svcpart;
910 my $global_unique = $conf->config('global_unique-username') || 'none';
912 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
913 qsearch( 'svc_acct', { 'username' => $self->username } );
914 return gettext('username_in_use')
915 if $global_unique eq 'username' && @dup_user;
917 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
918 qsearch( 'svc_acct', { 'username' => $self->username,
919 'domsvc' => $self->domsvc } );
920 return gettext('username_in_use')
921 if $global_unique eq 'username@domain' && @dup_userdomain;
924 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
925 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
926 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
927 qsearch( 'svc_acct', { 'uid' => $self->uid } );
932 if ( @dup_user || @dup_userdomain || @dup_uid ) {
933 my $exports = FS::part_export::export_info('svc_acct');
934 my %conflict_user_svcpart;
935 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
937 foreach my $part_export ( $part_svc->part_export ) {
939 #this will catch to the same exact export
940 my @svcparts = map { $_->svcpart } $part_export->export_svc;
942 #this will catch to exports w/same exporthost+type ???
943 #my @other_part_export = qsearch('part_export', {
944 # 'machine' => $part_export->machine,
945 # 'exporttype' => $part_export->exporttype,
947 #foreach my $other_part_export ( @other_part_export ) {
948 # push @svcparts, map { $_->svcpart }
949 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
952 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
953 #silly kludge to avoid uninitialized value errors
954 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
955 ? $exports->{$part_export->exporttype}{'nodomain'}
957 if ( $nodomain =~ /^Y/i ) {
958 $conflict_user_svcpart{$_} = $part_export->exportnum
961 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
966 foreach my $dup_user ( @dup_user ) {
967 my $dup_svcpart = $dup_user->cust_svc->svcpart;
968 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
969 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
970 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
974 foreach my $dup_userdomain ( @dup_userdomain ) {
975 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
976 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
977 return "duplicate username\@domain: conflicts with svcnum ".
978 $dup_userdomain->svcnum. " via exportnum ".
979 $conflict_userdomain_svcpart{$dup_svcpart};
983 foreach my $dup_uid ( @dup_uid ) {
984 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
985 if ( exists($conflict_user_svcpart{$dup_svcpart})
986 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
987 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
988 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
989 || $conflict_userdomain_svcpart{$dup_svcpart};
1001 Depriciated, use radius_reply instead.
1006 carp "FS::svc_acct::radius depriciated, use radius_reply";
1007 $_[0]->radius_reply;
1012 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1013 reply attributes of this record.
1015 Note that this is now the preferred method for reading RADIUS attributes -
1016 accessing the columns directly is discouraged, as the column names are
1017 expected to change in the future.
1027 my($column, $attrib) = ($1, $2);
1028 #$attrib =~ s/_/\-/g;
1029 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1030 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1032 if ( $self->slipip && $self->slipip ne '0e0' ) {
1033 $reply{$radius_ip} = $self->slipip;
1036 if ( $self->seconds !~ /^$/ ) {
1037 $reply{'Session-Timeout'} = $self->seconds;
1045 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1046 check attributes of this record.
1048 Note that this is now the preferred method for reading RADIUS attributes -
1049 accessing the columns directly is discouraged, as the column names are
1050 expected to change in the future.
1060 my($column, $attrib) = ($1, $2);
1061 #$attrib =~ s/_/\-/g;
1062 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1063 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1065 my $password = $self->_password;
1066 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1068 my $cust_pkg = $self->cust_svc->cust_pkg;
1069 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1070 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1079 Returns the domain associated with this account.
1085 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1086 my $svc_domain = $self->svc_domain(@_)
1087 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1088 $svc_domain->domain;
1093 Returns the FS::svc_domain record for this account's domain (see
1101 ? $self->{'_domsvc'}
1102 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1107 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1111 #inherited from svc_Common
1115 Returns an email address associated with the account.
1121 $self->username. '@'. $self->domain(@_);
1126 Returns an array of FS::acct_snarf records associated with the account.
1127 If the acct_snarf table does not exist or there are no associated records,
1128 an empty list is returned
1134 return () unless dbdef->table('acct_snarf');
1135 eval "use FS::acct_snarf;";
1137 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1140 =item decrement_seconds SECONDS
1142 Decrements the I<seconds> field of this record by the given amount. If there
1143 is an error, returns the error, otherwise returns false.
1147 sub decrement_seconds {
1148 shift->_op_seconds('-', @_);
1151 =item increment_seconds SECONDS
1153 Increments the I<seconds> field of this record by the given amount. If there
1154 is an error, returns the error, otherwise returns false.
1158 sub increment_seconds {
1159 shift->_op_seconds('+', @_);
1167 my %op2condition = (
1168 '-' => sub { my($self, $seconds) = @_;
1169 $self->seconds - $seconds <= 0;
1171 '+' => sub { my($self, $seconds) = @_;
1172 $self->seconds + $seconds > 0;
1177 my( $self, $op, $seconds ) = @_;
1178 warn "$me _op_seconds called for svcnum ". $self->svcnum.
1179 ' ('. $self->email. "): $op $seconds\n"
1182 local $SIG{HUP} = 'IGNORE';
1183 local $SIG{INT} = 'IGNORE';
1184 local $SIG{QUIT} = 'IGNORE';
1185 local $SIG{TERM} = 'IGNORE';
1186 local $SIG{TSTP} = 'IGNORE';
1187 local $SIG{PIPE} = 'IGNORE';
1189 my $oldAutoCommit = $FS::UID::AutoCommit;
1190 local $FS::UID::AutoCommit = 0;
1193 my $sql = "UPDATE svc_acct SET seconds = ".
1194 " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0
1195 " $op ? WHERE svcnum = ?";
1199 my $sth = $dbh->prepare( $sql )
1200 or die "Error preparing $sql: ". $dbh->errstr;
1201 my $rv = $sth->execute($seconds, $self->svcnum);
1202 die "Error executing $sql: ". $sth->errstr
1203 unless defined($rv);
1204 die "Can't update seconds for svcnum". $self->svcnum
1207 my $action = $op2action{$op};
1209 if ( $conf->exists("svc_acct-usage_$action")
1210 && &{$op2condition{$op}}($self, $seconds) ) {
1211 #my $error = $self->$action();
1212 my $error = $self->cust_svc->cust_pkg->$action();
1214 $dbh->rollback if $oldAutoCommit;
1215 return "Error ${action}ing: $error";
1219 warn "$me update sucessful; committing\n"
1221 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1227 =item seconds_since TIMESTAMP
1229 Returns the number of seconds this account has been online since TIMESTAMP,
1230 according to the session monitor (see L<FS::Session>).
1232 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1233 L<Time::Local> and L<Date::Parse> for conversion functions.
1237 #note: POD here, implementation in FS::cust_svc
1240 $self->cust_svc->seconds_since(@_);
1243 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1245 Returns the numbers of seconds this account has been online between
1246 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1247 external SQL radacct table, specified via sqlradius export. Sessions which
1248 started in the specified range but are still open are counted from session
1249 start to the end of the range (unless they are over 1 day old, in which case
1250 they are presumed missing their stop record and not counted). Also, sessions
1251 which end in the range but started earlier are counted from the start of the
1252 range to session end. Finally, sessions which start before the range but end
1253 after are counted for the entire range.
1255 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1256 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1261 #note: POD here, implementation in FS::cust_svc
1262 sub seconds_since_sqlradacct {
1264 $self->cust_svc->seconds_since_sqlradacct(@_);
1267 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1269 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1270 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1271 TIMESTAMP_END (exclusive).
1273 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1274 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1279 #note: POD here, implementation in FS::cust_svc
1280 sub attribute_since_sqlradacct {
1282 $self->cust_svc->attribute_since_sqlradacct(@_);
1285 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1287 Returns an array of hash references of this customers login history for the
1288 given time range. (document this better)
1292 sub get_session_history {
1294 $self->cust_svc->get_session_history(@_);
1299 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1305 if ( $self->usergroup ) {
1306 #when provisioning records, export callback runs in svc_Common.pm before
1307 #radius_usergroup records can be inserted...
1308 @{$self->usergroup};
1310 map { $_->groupname }
1311 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1315 =item clone_suspended
1317 Constructor used by FS::part_export::_export_suspend fallback. Document
1322 sub clone_suspended {
1324 my %hash = $self->hash;
1325 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1326 new FS::svc_acct \%hash;
1329 =item clone_kludge_unsuspend
1331 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1336 sub clone_kludge_unsuspend {
1338 my %hash = $self->hash;
1339 $hash{_password} = '';
1340 new FS::svc_acct \%hash;
1343 =item check_password
1345 Checks the supplied password against the (possibly encrypted) password in the
1346 database. Returns true for a sucessful authentication, false for no match.
1348 Currently supported encryptions are: classic DES crypt() and MD5
1352 sub check_password {
1353 my($self, $check_password) = @_;
1355 #remove old-style SUSPENDED kludge, they should be allowed to login to
1356 #self-service and pay up
1357 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1359 #eventually should check a "password-encoding" field
1360 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1362 } elsif ( length($password) < 13 ) { #plaintext
1363 $check_password eq $password;
1364 } elsif ( length($password) == 13 ) { #traditional DES crypt
1365 crypt($check_password, $password) eq $password;
1366 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1367 unix_md5_crypt($check_password, $password) eq $password;
1368 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1369 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1370 $self->svcnum. "\n";
1373 warn "Can't check password: Unrecognized encryption for svcnum ".
1374 $self->svcnum. "\n";
1380 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1382 Returns an encrypted password, either by passing through an encrypted password
1383 in the database or by encrypting a plaintext password from the database.
1385 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1386 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1387 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1388 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
1389 encryption type is only used if the password is not already encrypted in the
1394 sub crypt_password {
1396 #eventually should check a "password-encoding" field
1397 if ( length($self->_password) == 13
1398 || $self->_password =~ /^\$(1|2a?)\$/
1399 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1404 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1405 if ( $encryption eq 'crypt' ) {
1408 $saltset[int(rand(64))].$saltset[int(rand(64))]
1410 } elsif ( $encryption eq 'md5' ) {
1411 unix_md5_crypt( $self->_password );
1412 } elsif ( $encryption eq 'blowfish' ) {
1413 die "unknown encryption method $encryption";
1415 die "unknown encryption method $encryption";
1420 =item virtual_maildir
1422 Returns $domain/maildirs/$username/
1426 sub virtual_maildir {
1428 $self->domain. '/maildirs/'. $self->username. '/';
1439 This is the FS::svc_acct job-queue-able version. It still uses
1440 FS::Misc::send_email under-the-hood.
1447 eval "use FS::Misc qw(send_email)";
1450 $opt{mimetype} ||= 'text/plain';
1451 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1453 my $error = send_email(
1454 'from' => $opt{from},
1456 'subject' => $opt{subject},
1457 'content-type' => $opt{mimetype},
1458 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1460 die $error if $error;
1463 =item check_and_rebuild_fuzzyfiles
1467 sub check_and_rebuild_fuzzyfiles {
1468 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1469 -e "$dir/svc_acct.username"
1470 or &rebuild_fuzzyfiles;
1473 =item rebuild_fuzzyfiles
1477 sub rebuild_fuzzyfiles {
1479 use Fcntl qw(:flock);
1481 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1485 open(USERNAMELOCK,">>$dir/svc_acct.username")
1486 or die "can't open $dir/svc_acct.username: $!";
1487 flock(USERNAMELOCK,LOCK_EX)
1488 or die "can't lock $dir/svc_acct.username: $!";
1490 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1492 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1493 or die "can't open $dir/svc_acct.username.tmp: $!";
1494 print USERNAMECACHE join("\n", @all_username), "\n";
1495 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1497 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1507 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1508 open(USERNAMECACHE,"<$dir/svc_acct.username")
1509 or die "can't open $dir/svc_acct.username: $!";
1510 my @array = map { chomp; $_; } <USERNAMECACHE>;
1511 close USERNAMECACHE;
1515 =item append_fuzzyfiles USERNAME
1519 sub append_fuzzyfiles {
1520 my $username = shift;
1522 &check_and_rebuild_fuzzyfiles;
1524 use Fcntl qw(:flock);
1526 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1528 open(USERNAME,">>$dir/svc_acct.username")
1529 or die "can't open $dir/svc_acct.username: $!";
1530 flock(USERNAME,LOCK_EX)
1531 or die "can't lock $dir/svc_acct.username: $!";
1533 print USERNAME "$username\n";
1535 flock(USERNAME,LOCK_UN)
1536 or die "can't unlock $dir/svc_acct.username: $!";
1544 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1548 sub radius_usergroup_selector {
1549 my $sel_groups = shift;
1550 my %sel_groups = map { $_=>1 } @$sel_groups;
1552 my $selectname = shift || 'radius_usergroup';
1555 my $sth = $dbh->prepare(
1556 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1557 ) or die $dbh->errstr;
1558 $sth->execute() or die $sth->errstr;
1559 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1563 function ${selectname}_doadd(object) {
1564 var myvalue = object.${selectname}_add.value;
1565 var optionName = new Option(myvalue,myvalue,false,true);
1566 var length = object.$selectname.length;
1567 object.$selectname.options[length] = optionName;
1568 object.${selectname}_add.value = "";
1571 <SELECT MULTIPLE NAME="$selectname">
1574 foreach my $group ( @all_groups ) {
1575 $html .= qq(<OPTION VALUE="$group");
1576 if ( $sel_groups{$group} ) {
1577 $html .= ' SELECTED';
1578 $sel_groups{$group} = 0;
1580 $html .= ">$group</OPTION>\n";
1582 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1583 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1585 $html .= '</SELECT>';
1587 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1588 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1597 The $recref stuff in sub check should be cleaned up.
1599 The suspend, unsuspend and cancel methods update the database, but not the
1600 current object. This is probably a bug as it's unexpected and
1603 radius_usergroup_selector? putting web ui components in here? they should
1604 probably live somewhere else...
1606 insertion of RADIUS group stuff in insert could be done with child_objects now
1607 (would probably clean up export of them too)
1611 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1612 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1613 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1614 L<freeside-queued>), L<FS::svc_acct_pop>,
1615 schema.html from the base documentation.