4 use vars qw( @ISA $DEBUG $me $conf
5 $dir_prefix @shells $usernamemin
6 $usernamemax $passwordmin $passwordmax
7 $username_ampersand $username_letter $username_letterfirst
8 $username_noperiod $username_nounderscore $username_nodash
10 $password_noampersand $password_noexclamation
11 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
13 $radius_password $radius_ip
19 use FS::UID qw( datasrc );
21 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
26 use FS::cust_main_invoice;
30 use FS::radius_usergroup;
33 use FS::Msgcat qw(gettext);
37 @ISA = qw( FS::svc_Common );
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 $password_noampersand = $conf->exists('password-noexclamation');
60 $password_noexclamation = $conf->exists('password-noexclamation');
61 $dirhash = $conf->config('dirhash') || 0;
62 if ( $conf->exists('welcome_email') ) {
63 $welcome_template = new Text::Template (
65 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
66 ) or warn "can't create welcome email template: $Text::Template::ERROR";
67 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
68 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
69 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
71 $welcome_template = '';
73 $welcome_subject = '';
74 $welcome_mimetype = '';
76 $smtpmachine = $conf->config('smtpmachine');
77 $radius_password = $conf->config('radius-password') || 'Password';
78 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
81 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
82 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
86 my ( $hashref, $cache ) = @_;
87 if ( $hashref->{'svc_acct_svcnum'} ) {
88 $self->{'_domsvc'} = FS::svc_domain->new( {
89 'svcnum' => $hashref->{'domsvc'},
90 'domain' => $hashref->{'svc_acct_domain'},
91 'catchall' => $hashref->{'svc_acct_catchall'},
98 FS::svc_acct - Object methods for svc_acct records
104 $record = new FS::svc_acct \%hash;
105 $record = new FS::svc_acct { 'column' => 'value' };
107 $error = $record->insert;
109 $error = $new_record->replace($old_record);
111 $error = $record->delete;
113 $error = $record->check;
115 $error = $record->suspend;
117 $error = $record->unsuspend;
119 $error = $record->cancel;
121 %hash = $record->radius;
123 %hash = $record->radius_reply;
125 %hash = $record->radius_check;
127 $domain = $record->domain;
129 $svc_domain = $record->svc_domain;
131 $email = $record->email;
133 $seconds_since = $record->seconds_since($timestamp);
137 An FS::svc_acct object represents an account. FS::svc_acct inherits from
138 FS::svc_Common. The following fields are currently supported:
142 =item svcnum - primary key (assigned automatcially for new accounts)
146 =item _password - generated if blank
148 =item sec_phrase - security phrase
150 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
158 =item dir - set automatically if blank (and uid is not)
162 =item quota - (unimplementd)
164 =item slipip - IP address
168 =item domsvc - svcnum from svc_domain
170 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
180 Creates a new account. To add the account to the database, see L<"insert">.
184 sub table { 'svc_acct'; }
186 =item insert [ , OPTION => VALUE ... ]
188 Adds this account to the database. If there is an error, returns the error,
189 otherwise returns false.
191 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
192 defined. An FS::cust_svc record will be created and inserted.
194 The additional field I<usergroup> can optionally be defined; if so it should
195 contain an arrayref of group names. See L<FS::radius_usergroup>.
197 The additional field I<child_objects> can optionally be defined; if so it
198 should contain an arrayref of FS::tablename objects. They will have their
199 svcnum fields set and will be inserted after this record, but before any
200 exports are run. Each element of the array can also optionally be a
201 two-element array reference containing the child object and the name of an
202 alternate field to be filled in with the newly-inserted svcnum, for example
203 C<[ $svc_forward, 'srcsvc' ]>
205 Currently available options are: I<depend_jobnum>
207 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
208 jobnums), all provisioning jobs will have a dependancy on the supplied
209 jobnum(s) (they will not run until the specific job(s) complete(s)).
211 (TODOC: L<FS::queue> and L<freeside-queued>)
213 (TODOC: new exports!)
222 local $SIG{HUP} = 'IGNORE';
223 local $SIG{INT} = 'IGNORE';
224 local $SIG{QUIT} = 'IGNORE';
225 local $SIG{TERM} = 'IGNORE';
226 local $SIG{TSTP} = 'IGNORE';
227 local $SIG{PIPE} = 'IGNORE';
229 my $oldAutoCommit = $FS::UID::AutoCommit;
230 local $FS::UID::AutoCommit = 0;
233 $error = $self->check;
234 return $error if $error;
236 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
237 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
238 unless ( $cust_svc ) {
239 $dbh->rollback if $oldAutoCommit;
240 return "no cust_svc record found for svcnum ". $self->svcnum;
242 $self->pkgnum($cust_svc->pkgnum);
243 $self->svcpart($cust_svc->svcpart);
246 $error = $self->_check_duplicate;
248 $dbh->rollback if $oldAutoCommit;
253 $error = $self->SUPER::insert(
254 'jobnums' => \@jobnums,
255 'child_objects' => $self->child_objects,
259 $dbh->rollback if $oldAutoCommit;
263 if ( $self->usergroup ) {
264 foreach my $groupname ( @{$self->usergroup} ) {
265 my $radius_usergroup = new FS::radius_usergroup ( {
266 svcnum => $self->svcnum,
267 groupname => $groupname,
269 my $error = $radius_usergroup->insert;
271 $dbh->rollback if $oldAutoCommit;
277 #false laziness with sub replace (and cust_main)
278 my $queue = new FS::queue {
279 'svcnum' => $self->svcnum,
280 'job' => 'FS::svc_acct::append_fuzzyfiles'
282 $error = $queue->insert($self->username);
284 $dbh->rollback if $oldAutoCommit;
285 return "queueing job (transaction rolled back): $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;
467 return "Username in use"
468 if $old->username ne $new->username &&
469 qsearchs( 'svc_acct', { 'username' => $new->username,
470 'domsvc' => $new->domsvc,
473 #no warnings 'numeric'; #alas, a 5.006-ism
475 return "Can't change uid!" if $old->uid != $new->uid;
478 #change homdir when we change username
479 $new->setfield('dir', '') if $old->username ne $new->username;
481 local $SIG{HUP} = 'IGNORE';
482 local $SIG{INT} = 'IGNORE';
483 local $SIG{QUIT} = 'IGNORE';
484 local $SIG{TERM} = 'IGNORE';
485 local $SIG{TSTP} = 'IGNORE';
486 local $SIG{PIPE} = 'IGNORE';
488 my $oldAutoCommit = $FS::UID::AutoCommit;
489 local $FS::UID::AutoCommit = 0;
492 # redundant, but so $new->usergroup gets set
493 $error = $new->check;
494 return $error if $error;
496 $old->usergroup( [ $old->radius_groups ] );
497 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
498 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
499 if ( $new->usergroup ) {
500 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
501 my @newgroups = @{$new->usergroup};
502 foreach my $oldgroup ( @{$old->usergroup} ) {
503 if ( grep { $oldgroup eq $_ } @newgroups ) {
504 @newgroups = grep { $oldgroup ne $_ } @newgroups;
507 my $radius_usergroup = qsearchs('radius_usergroup', {
508 svcnum => $old->svcnum,
509 groupname => $oldgroup,
511 my $error = $radius_usergroup->delete;
513 $dbh->rollback if $oldAutoCommit;
514 return "error deleting radius_usergroup $oldgroup: $error";
518 foreach my $newgroup ( @newgroups ) {
519 my $radius_usergroup = new FS::radius_usergroup ( {
520 svcnum => $new->svcnum,
521 groupname => $newgroup,
523 my $error = $radius_usergroup->insert;
525 $dbh->rollback if $oldAutoCommit;
526 return "error adding radius_usergroup $newgroup: $error";
532 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
533 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
534 $error = $new->_check_duplicate;
536 $dbh->rollback if $oldAutoCommit;
541 $error = $new->SUPER::replace($old);
543 $dbh->rollback if $oldAutoCommit;
544 return $error if $error;
547 if ( $new->username ne $old->username ) {
548 #false laziness with sub insert (and cust_main)
549 my $queue = new FS::queue {
550 'svcnum' => $new->svcnum,
551 'job' => 'FS::svc_acct::append_fuzzyfiles'
553 $error = $queue->insert($new->username);
555 $dbh->rollback if $oldAutoCommit;
556 return "queueing job (transaction rolled back): $error";
560 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
566 Suspends this account by calling export-specific suspend hooks. If there is
567 an error, returns the error, otherwise returns false.
569 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
575 return "can't suspend system account" if $self->_check_system;
576 $self->SUPER::suspend;
581 Unsuspends this account by by calling export-specific suspend hooks. If there
582 is an error, returns the error, otherwise returns false.
584 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
590 my %hash = $self->hash;
591 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
592 $hash{_password} = $1;
593 my $new = new FS::svc_acct ( \%hash );
594 my $error = $new->replace($self);
595 return $error if $error;
598 $self->SUPER::unsuspend;
603 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
605 If the B<auto_unset_catchall> configuration option is set, this method will
606 automatically remove any references to the canceled service in the catchall
607 field of svc_domain. This allows packages that contain both a svc_domain and
608 its catchall svc_acct to be canceled in one step.
613 # Only one thing to do at this level
615 foreach my $svc_domain (
616 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
617 if($conf->exists('auto_unset_catchall')) {
618 my %hash = $svc_domain->hash;
619 $hash{catchall} = '';
620 my $new = new FS::svc_domain ( \%hash );
621 my $error = $new->replace($svc_domain);
622 return $error if $error;
624 return "cannot unprovision svc_acct #".$self->svcnum.
625 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
629 $self->SUPER::cancel;
635 Checks all fields to make sure this is a valid service. If there is an error,
636 returns the error, otherwise returns false. Called by the insert and replace
639 Sets any fixed values; see L<FS::part_svc>.
646 my($recref) = $self->hashref;
648 my $x = $self->setfixed;
649 return $x unless ref($x);
652 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
654 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
657 my $error = $self->ut_numbern('svcnum')
658 #|| $self->ut_number('domsvc')
659 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
660 || $self->ut_textn('sec_phrase')
662 return $error if $error;
664 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
665 if ( $username_uppercase ) {
666 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
667 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
668 $recref->{username} = $1;
670 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
671 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
672 $recref->{username} = $1;
675 if ( $username_letterfirst ) {
676 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
677 } elsif ( $username_letter ) {
678 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
680 if ( $username_noperiod ) {
681 $recref->{username} =~ /\./ and return gettext('illegal_username');
683 if ( $username_nounderscore ) {
684 $recref->{username} =~ /_/ and return gettext('illegal_username');
686 if ( $username_nodash ) {
687 $recref->{username} =~ /\-/ and return gettext('illegal_username');
689 unless ( $username_ampersand ) {
690 $recref->{username} =~ /\&/ and return gettext('illegal_username');
692 if ( $password_noampersand ) {
693 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
695 if ( $password_noexclamation ) {
696 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
699 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
700 $recref->{popnum} = $1;
701 return "Unknown popnum" unless
702 ! $recref->{popnum} ||
703 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
705 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
707 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
708 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
710 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
711 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
712 #not all systems use gid=uid
713 #you can set a fixed gid in part_svc
715 return "Only root can have uid 0"
716 if $recref->{uid} == 0
717 && $recref->{username} !~ /^(root|toor|smtp)$/;
719 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
720 or return "Illegal directory: ". $recref->{dir};
722 return "Illegal directory"
723 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
724 return "Illegal directory"
725 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
726 unless ( $recref->{dir} ) {
727 $recref->{dir} = $dir_prefix . '/';
728 if ( $dirhash > 0 ) {
729 for my $h ( 1 .. $dirhash ) {
730 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
732 } elsif ( $dirhash < 0 ) {
733 for my $h ( reverse $dirhash .. -1 ) {
734 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
737 $recref->{dir} .= $recref->{username};
741 unless ( $recref->{username} eq 'sync' ) {
742 if ( grep $_ eq $recref->{shell}, @shells ) {
743 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
745 return "Illegal shell \`". $self->shell. "\'; ".
746 $conf->dir. "/shells contains: @shells";
749 $recref->{shell} = '/bin/sync';
753 $recref->{gid} ne '' ?
754 return "Can't have gid without uid" : ( $recref->{gid}='' );
755 $recref->{dir} ne '' ?
756 return "Can't have directory without uid" : ( $recref->{dir}='' );
757 $recref->{shell} ne '' ?
758 return "Can't have shell without uid" : ( $recref->{shell}='' );
761 # $error = $self->ut_textn('finger');
762 # return $error if $error;
763 if ( $self->getfield('finger') eq '' ) {
764 my $cust_pkg = $self->svcnum
765 ? $self->cust_svc->cust_pkg
766 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
768 my $cust_main = $cust_pkg->cust_main;
769 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
772 $self->getfield('finger') =~
773 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
774 or return "Illegal finger: ". $self->getfield('finger');
775 $self->setfield('finger', $1);
777 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
778 $recref->{quota} = $1;
780 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
781 if ( $recref->{slipip} eq '' ) {
782 $recref->{slipip} = '';
783 } elsif ( $recref->{slipip} eq '0e0' ) {
784 $recref->{slipip} = '0e0';
786 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
787 or return "Illegal slipip: ". $self->slipip;
788 $recref->{slipip} = $1;
793 #arbitrary RADIUS stuff; allow ut_textn for now
794 foreach ( grep /^radius_/, fields('svc_acct') ) {
798 #generate a password if it is blank
799 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
800 unless ( $recref->{_password} );
802 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
803 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
804 $recref->{_password} = $1.$3;
805 #uncomment this to encrypt password immediately upon entry, or run
806 #bin/crypt_pw in cron to give new users a window during which their
807 #password is available to techs, for faxing, etc. (also be aware of
809 #$recref->{password} = $1.
810 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
812 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
813 $recref->{_password} = $1.$3;
814 } elsif ( $recref->{_password} eq '*' ) {
815 $recref->{_password} = '*';
816 } elsif ( $recref->{_password} eq '!' ) {
817 $recref->{_password} = '!';
818 } elsif ( $recref->{_password} eq '!!' ) {
819 $recref->{_password} = '!!';
821 #return "Illegal password";
822 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
823 FS::Msgcat::_gettext('illegal_password_characters').
824 ": ". $recref->{_password};
832 Internal function to check the username against the list of system usernames
833 from the I<system_usernames> configuration value. Returns true if the username
834 is listed on the system username list.
840 scalar( grep { $self->username eq $_ || $self->email eq $_ }
841 $conf->config('system_usernames')
845 =item _check_duplicate
847 Internal function to check for duplicates usernames, username@domain pairs and
850 If the I<global_unique-username> configuration value is set to B<username> or
851 B<username@domain>, enforces global username or username@domain uniqueness.
853 In all cases, check for duplicate uids and usernames or username@domain pairs
854 per export and with identical I<svcpart> values.
858 sub _check_duplicate {
861 #this is Pg-specific. what to do for mysql etc?
862 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
863 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
864 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
866 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
868 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
869 unless ( $part_svc ) {
870 return 'unknown svcpart '. $self->svcpart;
873 my $global_unique = $conf->config('global_unique-username');
875 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
876 qsearch( 'svc_acct', { 'username' => $self->username } );
877 return gettext('username_in_use')
878 if $global_unique eq 'username' && @dup_user;
880 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
881 qsearch( 'svc_acct', { 'username' => $self->username,
882 'domsvc' => $self->domsvc } );
883 return gettext('username_in_use')
884 if $global_unique eq 'username@domain' && @dup_userdomain;
887 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
888 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
889 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
890 qsearch( 'svc_acct', { 'uid' => $self->uid } );
895 if ( @dup_user || @dup_userdomain || @dup_uid ) {
896 my $exports = FS::part_export::export_info('svc_acct');
897 my %conflict_user_svcpart;
898 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
900 foreach my $part_export ( $part_svc->part_export ) {
902 #this will catch to the same exact export
903 my @svcparts = map { $_->svcpart } $part_export->export_svc;
905 #this will catch to exports w/same exporthost+type ???
906 #my @other_part_export = qsearch('part_export', {
907 # 'machine' => $part_export->machine,
908 # 'exporttype' => $part_export->exporttype,
910 #foreach my $other_part_export ( @other_part_export ) {
911 # push @svcparts, map { $_->svcpart }
912 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
915 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
916 #silly kludge to avoid uninitialized value errors
917 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
918 ? $exports->{$part_export->exporttype}{'nodomain'}
920 if ( $nodomain =~ /^Y/i ) {
921 $conflict_user_svcpart{$_} = $part_export->exportnum
924 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
929 foreach my $dup_user ( @dup_user ) {
930 my $dup_svcpart = $dup_user->cust_svc->svcpart;
931 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
932 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
933 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
937 foreach my $dup_userdomain ( @dup_userdomain ) {
938 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
939 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
940 return "duplicate username\@domain: conflicts with svcnum ".
941 $dup_userdomain->svcnum. " via exportnum ".
942 $conflict_userdomain_svcpart{$dup_svcpart};
946 foreach my $dup_uid ( @dup_uid ) {
947 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
948 if ( exists($conflict_user_svcpart{$dup_svcpart})
949 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
950 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
951 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
952 || $conflict_userdomain_svcpart{$dup_svcpart};
964 Depriciated, use radius_reply instead.
969 carp "FS::svc_acct::radius depriciated, use radius_reply";
975 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
976 reply attributes of this record.
978 Note that this is now the preferred method for reading RADIUS attributes -
979 accessing the columns directly is discouraged, as the column names are
980 expected to change in the future.
989 my($column, $attrib) = ($1, $2);
990 #$attrib =~ s/_/\-/g;
991 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
992 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
993 if ( $self->slipip && $self->slipip ne '0e0' ) {
994 $reply{$radius_ip} = $self->slipip;
1001 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1002 check attributes of this record.
1004 Note that this is now the preferred method for reading RADIUS attributes -
1005 accessing the columns directly is discouraged, as the column names are
1006 expected to change in the future.
1012 my $password = $self->_password;
1013 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1014 ( $pw_attrib => $password,
1017 my($column, $attrib) = ($1, $2);
1018 #$attrib =~ s/_/\-/g;
1019 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1020 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
1026 Returns the domain associated with this account.
1032 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1033 my $svc_domain = $self->svc_domain(@_)
1034 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1035 $svc_domain->domain;
1040 Returns the FS::svc_domain record for this account's domain (see
1048 ? $self->{'_domsvc'}
1049 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1054 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1060 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1065 Returns an email address associated with the account.
1071 $self->username. '@'. $self->domain(@_);
1076 Returns an array of FS::acct_snarf records associated with the account.
1077 If the acct_snarf table does not exist or there are no associated records,
1078 an empty list is returned
1084 return () unless dbdef->table('acct_snarf');
1085 eval "use FS::acct_snarf;";
1087 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1090 =item seconds_since TIMESTAMP
1092 Returns the number of seconds this account has been online since TIMESTAMP,
1093 according to the session monitor (see L<FS::Session>).
1095 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1096 L<Time::Local> and L<Date::Parse> for conversion functions.
1100 #note: POD here, implementation in FS::cust_svc
1103 $self->cust_svc->seconds_since(@_);
1106 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1108 Returns the numbers of seconds this account has been online between
1109 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1110 external SQL radacct table, specified via sqlradius export. Sessions which
1111 started in the specified range but are still open are counted from session
1112 start to the end of the range (unless they are over 1 day old, in which case
1113 they are presumed missing their stop record and not counted). Also, sessions
1114 which end in the range but started earlier are counted from the start of the
1115 range to session end. Finally, sessions which start before the range but end
1116 after are counted for the entire range.
1118 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1119 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1124 #note: POD here, implementation in FS::cust_svc
1125 sub seconds_since_sqlradacct {
1127 $self->cust_svc->seconds_since_sqlradacct(@_);
1130 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1132 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1133 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1134 TIMESTAMP_END (exclusive).
1136 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1137 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1142 #note: POD here, implementation in FS::cust_svc
1143 sub attribute_since_sqlradacct {
1145 $self->cust_svc->attribute_since_sqlradacct(@_);
1148 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1150 Returns an array of hash references of this customers login history for the
1151 given time range. (document this better)
1155 sub get_session_history {
1157 $self->cust_svc->get_session_history(@_);
1162 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1168 if ( $self->usergroup ) {
1169 #when provisioning records, export callback runs in svc_Common.pm before
1170 #radius_usergroup records can be inserted...
1171 @{$self->usergroup};
1173 map { $_->groupname }
1174 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1178 =item clone_suspended
1180 Constructor used by FS::part_export::_export_suspend fallback. Document
1185 sub clone_suspended {
1187 my %hash = $self->hash;
1188 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1189 new FS::svc_acct \%hash;
1192 =item clone_kludge_unsuspend
1194 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1199 sub clone_kludge_unsuspend {
1201 my %hash = $self->hash;
1202 $hash{_password} = '';
1203 new FS::svc_acct \%hash;
1206 =item check_password
1208 Checks the supplied password against the (possibly encrypted) password in the
1209 database. Returns true for a sucessful authentication, false for no match.
1211 Currently supported encryptions are: classic DES crypt() and MD5
1215 sub check_password {
1216 my($self, $check_password) = @_;
1218 #remove old-style SUSPENDED kludge, they should be allowed to login to
1219 #self-service and pay up
1220 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1222 #eventually should check a "password-encoding" field
1223 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1225 } elsif ( length($password) < 13 ) { #plaintext
1226 $check_password eq $password;
1227 } elsif ( length($password) == 13 ) { #traditional DES crypt
1228 crypt($check_password, $password) eq $password;
1229 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1230 unix_md5_crypt($check_password, $password) eq $password;
1231 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1232 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1233 $self->svcnum. "\n";
1236 warn "Can't check password: Unrecognized encryption for svcnum ".
1237 $self->svcnum. "\n";
1243 =item crypt_password
1245 Returns an encrypted password, either by passing through an encrypted password
1246 in the database or by encrypting a plaintext password from the database.
1250 sub crypt_password {
1252 #false laziness w/shellcommands.pm
1253 #eventually should check a "password-encoding" field
1254 if ( length($self->_password) == 13
1255 || $self->_password =~ /^\$(1|2a?)\$/ ) {
1260 $saltset[int(rand(64))].$saltset[int(rand(64))]
1265 =item virtual_maildir
1267 Returns $domain/maildirs/$username/
1271 sub virtual_maildir {
1273 $self->domain. '/maildirs/'. $self->username. '/';
1284 This is the FS::svc_acct job-queue-able version. It still uses
1285 FS::Misc::send_email under-the-hood.
1292 eval "use FS::Misc qw(send_email)";
1295 $opt{mimetype} ||= 'text/plain';
1296 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1298 my $error = send_email(
1299 'from' => $opt{from},
1301 'subject' => $opt{subject},
1302 'content-type' => $opt{mimetype},
1303 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1305 die $error if $error;
1308 =item check_and_rebuild_fuzzyfiles
1312 sub check_and_rebuild_fuzzyfiles {
1313 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1314 -e "$dir/svc_acct.username"
1315 or &rebuild_fuzzyfiles;
1318 =item rebuild_fuzzyfiles
1322 sub rebuild_fuzzyfiles {
1324 use Fcntl qw(:flock);
1326 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1330 open(USERNAMELOCK,">>$dir/svc_acct.username")
1331 or die "can't open $dir/svc_acct.username: $!";
1332 flock(USERNAMELOCK,LOCK_EX)
1333 or die "can't lock $dir/svc_acct.username: $!";
1335 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1337 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1338 or die "can't open $dir/svc_acct.username.tmp: $!";
1339 print USERNAMECACHE join("\n", @all_username), "\n";
1340 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1342 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1352 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1353 open(USERNAMECACHE,"<$dir/svc_acct.username")
1354 or die "can't open $dir/svc_acct.username: $!";
1355 my @array = map { chomp; $_; } <USERNAMECACHE>;
1356 close USERNAMECACHE;
1360 =item append_fuzzyfiles USERNAME
1364 sub append_fuzzyfiles {
1365 my $username = shift;
1367 &check_and_rebuild_fuzzyfiles;
1369 use Fcntl qw(:flock);
1371 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1373 open(USERNAME,">>$dir/svc_acct.username")
1374 or die "can't open $dir/svc_acct.username: $!";
1375 flock(USERNAME,LOCK_EX)
1376 or die "can't lock $dir/svc_acct.username: $!";
1378 print USERNAME "$username\n";
1380 flock(USERNAME,LOCK_UN)
1381 or die "can't unlock $dir/svc_acct.username: $!";
1389 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1393 sub radius_usergroup_selector {
1394 my $sel_groups = shift;
1395 my %sel_groups = map { $_=>1 } @$sel_groups;
1397 my $selectname = shift || 'radius_usergroup';
1400 my $sth = $dbh->prepare(
1401 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1402 ) or die $dbh->errstr;
1403 $sth->execute() or die $sth->errstr;
1404 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1408 function ${selectname}_doadd(object) {
1409 var myvalue = object.${selectname}_add.value;
1410 var optionName = new Option(myvalue,myvalue,false,true);
1411 var length = object.$selectname.length;
1412 object.$selectname.options[length] = optionName;
1413 object.${selectname}_add.value = "";
1416 <SELECT MULTIPLE NAME="$selectname">
1419 foreach my $group ( @all_groups ) {
1420 $html .= qq(<OPTION VALUE="$group");
1421 if ( $sel_groups{$group} ) {
1422 $html .= ' SELECTED';
1423 $sel_groups{$group} = 0;
1425 $html .= ">$group</OPTION>\n";
1427 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1428 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1430 $html .= '</SELECT>';
1432 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1433 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1442 The $recref stuff in sub check should be cleaned up.
1444 The suspend, unsuspend and cancel methods update the database, but not the
1445 current object. This is probably a bug as it's unexpected and
1448 radius_usergroup_selector? putting web ui components in here? they should
1449 probably live somewhere else...
1451 insertion of RADIUS group stuff in insert could be done with child_objects now
1452 (would probably clean up export of them too)
1456 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1457 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1458 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1459 L<freeside-queued>), L<FS::svc_acct_pop>,
1460 schema.html from the base documentation.