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
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 );
28 use FS::cust_main_invoice;
32 use FS::radius_usergroup;
35 use FS::Msgcat qw(gettext);
39 @ISA = qw( FS::svc_Common );
43 $me = '[FS::svc_acct]';
45 #ask FS::UID to run this stuff for us later
46 $FS::UID::callback{'FS::svc_acct'} = sub {
48 $dir_prefix = $conf->config('home');
49 @shells = $conf->config('shells');
50 $usernamemin = $conf->config('usernamemin') || 2;
51 $usernamemax = $conf->config('usernamemax');
52 $passwordmin = $conf->config('passwordmin') || 6;
53 $passwordmax = $conf->config('passwordmax') || 8;
54 $username_letter = $conf->exists('username-letter');
55 $username_letterfirst = $conf->exists('username-letterfirst');
56 $username_noperiod = $conf->exists('username-noperiod');
57 $username_nounderscore = $conf->exists('username-nounderscore');
58 $username_nodash = $conf->exists('username-nodash');
59 $username_uppercase = $conf->exists('username-uppercase');
60 $username_ampersand = $conf->exists('username-ampersand');
61 $mydomain = $conf->config('domain');
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>
181 Creates a new account. To add the account to the database, see L<"insert">.
185 sub table { 'svc_acct'; }
187 =item insert [ , OPTION => VALUE ... ]
189 Adds this account to the database. If there is an error, returns the error,
190 otherwise returns false.
192 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
193 defined. An FS::cust_svc record will be created and inserted.
195 The additional field I<usergroup> can optionally be defined; if so it should
196 contain an arrayref of group names. See L<FS::radius_usergroup>.
198 The additional field I<child_objects> can optionally be defined; if so it
199 should contain an arrayref of FS::tablename objects. They will have their
200 svcnum fields set and will be inserted after this record, but before any
203 Currently available options are: I<depend_jobnum>
205 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
206 jobnums), all provisioning jobs will have a dependancy on the supplied
207 jobnum(s) (they will not run until the specific job(s) complete(s)).
209 (TODOC: L<FS::queue> and L<freeside-queued>)
211 (TODOC: new exports!)
220 local $SIG{HUP} = 'IGNORE';
221 local $SIG{INT} = 'IGNORE';
222 local $SIG{QUIT} = 'IGNORE';
223 local $SIG{TERM} = 'IGNORE';
224 local $SIG{TSTP} = 'IGNORE';
225 local $SIG{PIPE} = 'IGNORE';
227 my $oldAutoCommit = $FS::UID::AutoCommit;
228 local $FS::UID::AutoCommit = 0;
231 $error = $self->check;
232 return $error if $error;
234 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
235 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
236 unless ( $cust_svc ) {
237 $dbh->rollback if $oldAutoCommit;
238 return "no cust_svc record found for svcnum ". $self->svcnum;
240 $self->pkgnum($cust_svc->pkgnum);
241 $self->svcpart($cust_svc->svcpart);
244 $error = $self->_check_duplicate;
246 $dbh->rollback if $oldAutoCommit;
251 $error = $self->SUPER::insert(
252 'jobnums' => \@jobnums,
253 'child_objects' => $self->child_objects,
257 $dbh->rollback if $oldAutoCommit;
261 if ( $self->usergroup ) {
262 foreach my $groupname ( @{$self->usergroup} ) {
263 my $radius_usergroup = new FS::radius_usergroup ( {
264 svcnum => $self->svcnum,
265 groupname => $groupname,
267 my $error = $radius_usergroup->insert;
269 $dbh->rollback if $oldAutoCommit;
275 #false laziness with sub replace (and cust_main)
276 my $queue = new FS::queue {
277 'svcnum' => $self->svcnum,
278 'job' => 'FS::svc_acct::append_fuzzyfiles'
280 $error = $queue->insert($self->username);
282 $dbh->rollback if $oldAutoCommit;
283 return "queueing job (transaction rolled back): $error";
286 my $cust_pkg = $self->cust_svc->cust_pkg;
289 my $cust_main = $cust_pkg->cust_main;
291 if ( $conf->exists('emailinvoiceauto') ) {
292 my @invoicing_list = $cust_main->invoicing_list;
293 push @invoicing_list, $self->email;
294 $cust_main->invoicing_list(\@invoicing_list);
299 if ( $welcome_template && $cust_pkg ) {
300 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
302 my $wqueue = new FS::queue {
303 'svcnum' => $self->svcnum,
304 'job' => 'FS::svc_acct::send_email'
306 my $error = $wqueue->insert(
308 'from' => $welcome_from,
309 'subject' => $welcome_subject,
310 'mimetype' => $welcome_mimetype,
311 'body' => $welcome_template->fill_in( HASH => {
312 'custnum' => $self->custnum,
313 'username' => $self->username,
314 'password' => $self->_password,
315 'first' => $cust_main->first,
316 'last' => $cust_main->getfield('last'),
317 'pkg' => $cust_pkg->part_pkg->pkg,
321 $dbh->rollback if $oldAutoCommit;
322 return "error queuing welcome email: $error";
325 if ( $options{'depend_jobnum'} ) {
326 warn "$me depend_jobnum found; adding to welcome email dependancies"
328 if ( ref($options{'depend_jobnum'}) ) {
329 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
330 "to welcome email dependancies"
332 push @jobnums, @{ $options{'depend_jobnum'} };
334 warn "$me adding job $options{'depend_jobnum'} ".
335 "to welcome email dependancies"
337 push @jobnums, $options{'depend_jobnum'};
341 foreach my $jobnum ( @jobnums ) {
342 my $error = $wqueue->depend_insert($jobnum);
344 $dbh->rollback if $oldAutoCommit;
345 return "error queuing welcome email job dependancy: $error";
355 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
361 Deletes this account from the database. If there is an error, returns the
362 error, otherwise returns false.
364 The corresponding FS::cust_svc record will be deleted as well.
366 (TODOC: new exports!)
373 if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
374 return "Can't delete an account which has (svc_acct_sm) mail aliases!"
375 if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
378 return "can't delete system account" if $self->_check_system;
380 return "Can't delete an account which is a (svc_forward) source!"
381 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
383 return "Can't delete an account which is a (svc_forward) destination!"
384 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
386 return "Can't delete an account with (svc_www) web service!"
387 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
389 # what about records in session ? (they should refer to history table)
391 local $SIG{HUP} = 'IGNORE';
392 local $SIG{INT} = 'IGNORE';
393 local $SIG{QUIT} = 'IGNORE';
394 local $SIG{TERM} = 'IGNORE';
395 local $SIG{TSTP} = 'IGNORE';
396 local $SIG{PIPE} = 'IGNORE';
398 my $oldAutoCommit = $FS::UID::AutoCommit;
399 local $FS::UID::AutoCommit = 0;
402 foreach my $cust_main_invoice (
403 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
405 unless ( defined($cust_main_invoice) ) {
406 warn "WARNING: something's wrong with qsearch";
409 my %hash = $cust_main_invoice->hash;
410 $hash{'dest'} = $self->email;
411 my $new = new FS::cust_main_invoice \%hash;
412 my $error = $new->replace($cust_main_invoice);
414 $dbh->rollback if $oldAutoCommit;
419 foreach my $svc_domain (
420 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
422 my %hash = new FS::svc_domain->hash;
423 $hash{'catchall'} = '';
424 my $new = new FS::svc_domain \%hash;
425 my $error = $new->replace($svc_domain);
427 $dbh->rollback if $oldAutoCommit;
432 foreach my $radius_usergroup (
433 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
435 my $error = $radius_usergroup->delete;
437 $dbh->rollback if $oldAutoCommit;
442 my $error = $self->SUPER::delete;
444 $dbh->rollback if $oldAutoCommit;
448 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
452 =item replace OLD_RECORD
454 Replaces OLD_RECORD with this one in the database. If there is an error,
455 returns the error, otherwise returns false.
457 The additional field I<usergroup> can optionally be defined; if so it should
458 contain an arrayref of group names. See L<FS::radius_usergroup>.
464 my ( $new, $old ) = ( shift, shift );
466 warn "$me replacing $old with $new\n" if $DEBUG;
468 return "can't modify system account" if $old->_check_system;
470 return "Username in use"
471 if $old->username ne $new->username &&
472 qsearchs( 'svc_acct', { 'username' => $new->username,
473 'domsvc' => $new->domsvc,
476 #no warnings 'numeric'; #alas, a 5.006-ism
478 return "Can't change uid!" if $old->uid != $new->uid;
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 ) {
551 #false laziness with sub insert (and cust_main)
552 my $queue = new FS::queue {
553 'svcnum' => $new->svcnum,
554 'job' => 'FS::svc_acct::append_fuzzyfiles'
556 $error = $queue->insert($new->username);
558 $dbh->rollback if $oldAutoCommit;
559 return "queueing job (transaction rolled back): $error";
563 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
569 Suspends this account by prefixing *SUSPENDED* to the password. If there is an
570 error, returns the error, otherwise returns false.
572 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
574 Calls any export-specific suspend hooks.
580 return "can't suspend system account" if $self->_check_system;
581 $self->SUPER::suspend;
586 Unsuspends this account by removing *SUSPENDED* from the password. If there is
587 an error, returns the error, otherwise returns false.
589 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
591 Calls any export-specific unsuspend hooks.
597 my %hash = $self->hash;
598 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
599 $hash{_password} = $1;
600 my $new = new FS::svc_acct ( \%hash );
601 my $error = $new->replace($self);
602 return $error if $error;
605 $self->SUPER::unsuspend;
610 Just returns false (no error) for now.
612 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
616 Checks all fields to make sure this is a valid service. If there is an error,
617 returns the error, otherwise returns false. Called by the insert and replace
620 Sets any fixed values; see L<FS::part_svc>.
627 my($recref) = $self->hashref;
629 my $x = $self->setfixed;
630 return $x unless ref($x);
633 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
635 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
638 my $error = $self->ut_numbern('svcnum')
639 #|| $self->ut_number('domsvc')
640 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
641 || $self->ut_textn('sec_phrase')
643 return $error if $error;
645 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
646 if ( $username_uppercase ) {
647 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
648 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
649 $recref->{username} = $1;
651 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
652 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
653 $recref->{username} = $1;
656 if ( $username_letterfirst ) {
657 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
658 } elsif ( $username_letter ) {
659 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
661 if ( $username_noperiod ) {
662 $recref->{username} =~ /\./ and return gettext('illegal_username');
664 if ( $username_nounderscore ) {
665 $recref->{username} =~ /_/ and return gettext('illegal_username');
667 if ( $username_nodash ) {
668 $recref->{username} =~ /\-/ and return gettext('illegal_username');
670 unless ( $username_ampersand ) {
671 $recref->{username} =~ /\&/ and return gettext('illegal_username');
674 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
675 $recref->{popnum} = $1;
676 return "Unknown popnum" unless
677 ! $recref->{popnum} ||
678 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
680 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
682 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
683 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
685 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
686 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
687 #not all systems use gid=uid
688 #you can set a fixed gid in part_svc
690 return "Only root can have uid 0"
691 if $recref->{uid} == 0
692 && $recref->{username} ne 'root'
693 && $recref->{username} ne 'toor';
696 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
697 or return "Illegal directory: ". $recref->{dir};
699 return "Illegal directory"
700 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
701 return "Illegal directory"
702 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
703 unless ( $recref->{dir} ) {
704 $recref->{dir} = $dir_prefix . '/';
705 if ( $dirhash > 0 ) {
706 for my $h ( 1 .. $dirhash ) {
707 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
709 } elsif ( $dirhash < 0 ) {
710 for my $h ( reverse $dirhash .. -1 ) {
711 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
714 $recref->{dir} .= $recref->{username};
718 unless ( $recref->{username} eq 'sync' ) {
719 if ( grep $_ eq $recref->{shell}, @shells ) {
720 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
722 return "Illegal shell \`". $self->shell. "\'; ".
723 $conf->dir. "/shells contains: @shells";
726 $recref->{shell} = '/bin/sync';
730 $recref->{gid} ne '' ?
731 return "Can't have gid without uid" : ( $recref->{gid}='' );
732 $recref->{dir} ne '' ?
733 return "Can't have directory without uid" : ( $recref->{dir}='' );
734 $recref->{shell} ne '' ?
735 return "Can't have shell without uid" : ( $recref->{shell}='' );
738 # $error = $self->ut_textn('finger');
739 # return $error if $error;
740 if ( $self->getfield('finger') eq '' ) {
741 my $cust_pkg = $self->svcnum
742 ? $self->cust_svc->cust_pkg
743 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
745 my $cust_main = $cust_pkg->cust_main;
746 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
749 $self->getfield('finger') =~
750 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
751 or return "Illegal finger: ". $self->getfield('finger');
752 $self->setfield('finger', $1);
754 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
755 $recref->{quota} = $1;
757 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
758 if ( $recref->{slipip} eq '' ) {
759 $recref->{slipip} = '';
760 } elsif ( $recref->{slipip} eq '0e0' ) {
761 $recref->{slipip} = '0e0';
763 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
764 or return "Illegal slipip". $self->slipip;
765 $recref->{slipip} = $1;
770 #arbitrary RADIUS stuff; allow ut_textn for now
771 foreach ( grep /^radius_/, fields('svc_acct') ) {
775 #generate a password if it is blank
776 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
777 unless ( $recref->{_password} );
779 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
780 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
781 $recref->{_password} = $1.$3;
782 #uncomment this to encrypt password immediately upon entry, or run
783 #bin/crypt_pw in cron to give new users a window during which their
784 #password is available to techs, for faxing, etc. (also be aware of
786 #$recref->{password} = $1.
787 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
789 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
790 $recref->{_password} = $1.$3;
791 } elsif ( $recref->{_password} eq '*' ) {
792 $recref->{_password} = '*';
793 } elsif ( $recref->{_password} eq '!' ) {
794 $recref->{_password} = '!';
795 } elsif ( $recref->{_password} eq '!!' ) {
796 $recref->{_password} = '!!';
798 #return "Illegal password";
799 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
800 FS::Msgcat::_gettext('illegal_password_characters').
801 ": ". $recref->{_password};
813 scalar( grep { $self->username eq $_ || $self->email eq $_ }
814 $conf->config('system_usernames')
818 =item _check_duplicate
820 Internal function to check for duplicates usernames, username@domain pairs and
823 If the I<global_unique-username> configuration value is set to B<username> or
824 B<username@domain>, enforces global username or username@domain uniqueness.
826 In all cases, check for duplicate uids and usernames or username@domain pairs
827 per export and with identical I<svcpart> values.
831 sub _check_duplicate {
834 #this is Pg-specific. what to do for mysql etc?
835 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
836 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
837 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
839 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
841 my $svcpart = $self->svcpart;
842 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
843 unless ( $part_svc ) {
844 return 'unknown svcpart '. $self->svcpart;
847 my $global_unique = $conf->config('global_unique-username');
849 my @dup_user = grep { $svcpart != $_->svcpart }
850 qsearch( 'svc_acct', { 'username' => $self->username } );
851 return gettext('username_in_use')
852 if $global_unique eq 'username' && @dup_user;
854 my @dup_userdomain = grep { $svcpart != $_->svcpart }
855 qsearch( 'svc_acct', { 'username' => $self->username,
856 'domsvc' => $self->domsvc } );
857 return gettext('username_in_use')
858 if $global_unique eq 'username@domain' && @dup_userdomain;
861 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
862 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
863 @dup_uid = grep { $svcpart != $_->svcpart }
864 qsearch( 'svc_acct', { 'uid' => $self->uid } );
869 if ( @dup_user || @dup_userdomain || @dup_uid ) {
870 my $exports = FS::part_export::export_info('svc_acct');
871 my %conflict_user_svcpart;
872 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
874 foreach my $part_export ( $part_svc->part_export ) {
876 #this will catch to the same exact export
877 my @svcparts = map { $_->svcpart } $part_export->export_svc;
879 #this will catch to exports w/same exporthost+type ???
880 #my @other_part_export = qsearch('part_export', {
881 # 'machine' => $part_export->machine,
882 # 'exporttype' => $part_export->exporttype,
884 #foreach my $other_part_export ( @other_part_export ) {
885 # push @svcparts, map { $_->svcpart }
886 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
889 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
890 #silly kludge to avoid uninitialized value errors
891 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
892 ? $exports->{$part_export->exporttype}{'nodomain'}
894 if ( $nodomain =~ /^Y/i ) {
895 $conflict_user_svcpart{$_} = $part_export->exportnum
898 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
903 foreach my $dup_user ( @dup_user ) {
904 my $dup_svcpart = $dup_user->cust_svc->svcpart;
905 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
906 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
907 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
911 foreach my $dup_userdomain ( @dup_userdomain ) {
912 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
913 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
914 return "duplicate username\@domain: conflicts with svcnum ".
915 $dup_userdomain->svcnum. " via exportnum ".
916 $conflict_userdomain_svcpart{$dup_svcpart};
920 foreach my $dup_uid ( @dup_uid ) {
921 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
922 if ( exists($conflict_user_svcpart{$dup_svcpart})
923 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
924 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
925 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
926 || $conflict_userdomain_svcpart{$dup_svcpart};
938 Depriciated, use radius_reply instead.
943 carp "FS::svc_acct::radius depriciated, use radius_reply";
949 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
950 reply attributes of this record.
952 Note that this is now the preferred method for reading RADIUS attributes -
953 accessing the columns directly is discouraged, as the column names are
954 expected to change in the future.
956 Internal function to check the username against the list of system usernames
957 from the I<system_usernames> configuration value. Returns true if the username
958 is listed on the system username list.
967 my($column, $attrib) = ($1, $2);
968 #$attrib =~ s/_/\-/g;
969 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
970 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
971 if ( $self->slipip && $self->slipip ne '0e0' ) {
972 $reply{$radius_ip} = $self->slipip;
979 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
980 check attributes of this record.
982 Note that this is now the preferred method for reading RADIUS attributes -
983 accessing the columns directly is discouraged, as the column names are
984 expected to change in the future.
990 my $password = $self->_password;
991 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
992 ( $pw_attrib => $self->_password,
995 my($column, $attrib) = ($1, $2);
996 #$attrib =~ s/_/\-/g;
997 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
998 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
1004 Returns the domain associated with this account.
1010 if ( $self->domsvc ) {
1011 #$self->svc_domain->domain;
1012 my $svc_domain = $self->svc_domain
1013 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1014 $svc_domain->domain;
1016 $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
1022 Returns the FS::svc_domain record for this account's domain (see
1030 ? $self->{'_domsvc'}
1031 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1036 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1042 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1047 Returns an email address associated with the account.
1053 $self->username. '@'. $self->domain;
1058 Returns an array of FS::acct_snarf records associated with the account.
1059 If the acct_snarf table does not exist or there are no associated records,
1060 an empty list is returned
1066 return () unless dbdef->table('acct_snarf');
1067 eval "use FS::acct_snarf;";
1069 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1072 =item seconds_since TIMESTAMP
1074 Returns the number of seconds this account has been online since TIMESTAMP,
1075 according to the session monitor (see L<FS::Session>).
1077 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1078 L<Time::Local> and L<Date::Parse> for conversion functions.
1082 #note: POD here, implementation in FS::cust_svc
1085 $self->cust_svc->seconds_since(@_);
1088 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1090 Returns the numbers of seconds this account has been online between
1091 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1092 external SQL radacct table, specified via sqlradius export. Sessions which
1093 started in the specified range but are still open are counted from session
1094 start to the end of the range (unless they are over 1 day old, in which case
1095 they are presumed missing their stop record and not counted). Also, sessions
1096 which end in the range but started earlier are counted from the start of the
1097 range to session end. Finally, sessions which start before the range but end
1098 after are counted for the entire range.
1100 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1101 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1106 #note: POD here, implementation in FS::cust_svc
1107 sub seconds_since_sqlradacct {
1109 $self->cust_svc->seconds_since_sqlradacct(@_);
1112 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1114 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1115 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1116 TIMESTAMP_END (exclusive).
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 attribute_since_sqlradacct {
1127 $self->cust_svc->attribute_since_sqlradacct(@_);
1130 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1132 Returns an array of hash references of this customers login history for the
1133 given time range. (document this better)
1137 sub get_session_history_sqlradacct {
1139 $self->cust_svc->get_session_history_sqlradacct(@_);
1144 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1150 if ( $self->usergroup ) {
1151 #when provisioning records, export callback runs in svc_Common.pm before
1152 #radius_usergroup records can be inserted...
1153 @{$self->usergroup};
1155 map { $_->groupname }
1156 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1160 =item clone_suspended
1162 Constructor used by FS::part_export::_export_suspend fallback. Document
1167 sub clone_suspended {
1169 my %hash = $self->hash;
1170 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1171 new FS::svc_acct \%hash;
1174 =item clone_kludge_unsuspend
1176 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1181 sub clone_kludge_unsuspend {
1183 my %hash = $self->hash;
1184 $hash{_password} = '';
1185 new FS::svc_acct \%hash;
1188 =item check_password
1190 Checks the supplied password against the (possibly encrypted) password in the
1191 database. Returns true for a sucessful authentication, false for no match.
1193 Currently supported encryptions are: classic DES crypt() and MD5
1197 sub check_password {
1198 my($self, $check_password) = @_;
1200 #remove old-style SUSPENDED kludge, they should be allowed to login to
1201 #self-service and pay up
1202 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1204 #eventually should check a "password-encoding" field
1205 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1207 } elsif ( length($password) < 13 ) { #plaintext
1208 $check_password eq $password;
1209 } elsif ( length($password) == 13 ) { #traditional DES crypt
1210 crypt($check_password, $password) eq $password;
1211 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1212 unix_md5_crypt($check_password, $password) eq $password;
1213 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1214 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1215 $self->svcnum. "\n";
1218 warn "Can't check password: Unrecognized encryption for svcnum ".
1219 $self->svcnum. "\n";
1239 use Mail::Internet 1.44;
1242 $opt{mimetype} ||= 'text/plain';
1243 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1245 $ENV{MAILADDRESS} = $opt{from};
1246 my $header = new Mail::Header ( [
1249 "Sender: $opt{from}",
1250 "Reply-To: $opt{from}",
1251 "Date: ". time2str("%a, %d %b %Y %X %z", time),
1252 "Subject: $opt{subject}",
1253 "Content-Type: $opt{mimetype}",
1255 my $message = new Mail::Internet (
1256 'Header' => $header,
1257 'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1260 $message->smtpsend( Host => $smtpmachine )
1261 or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1262 or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1265 =item check_and_rebuild_fuzzyfiles
1269 sub check_and_rebuild_fuzzyfiles {
1270 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1271 -e "$dir/svc_acct.username"
1272 or &rebuild_fuzzyfiles;
1275 =item rebuild_fuzzyfiles
1279 sub rebuild_fuzzyfiles {
1281 use Fcntl qw(:flock);
1283 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1287 open(USERNAMELOCK,">>$dir/svc_acct.username")
1288 or die "can't open $dir/svc_acct.username: $!";
1289 flock(USERNAMELOCK,LOCK_EX)
1290 or die "can't lock $dir/svc_acct.username: $!";
1292 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1294 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1295 or die "can't open $dir/svc_acct.username.tmp: $!";
1296 print USERNAMECACHE join("\n", @all_username), "\n";
1297 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1299 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1309 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1310 open(USERNAMECACHE,"<$dir/svc_acct.username")
1311 or die "can't open $dir/svc_acct.username: $!";
1312 my @array = map { chomp; $_; } <USERNAMECACHE>;
1313 close USERNAMECACHE;
1317 =item append_fuzzyfiles USERNAME
1321 sub append_fuzzyfiles {
1322 my $username = shift;
1324 &check_and_rebuild_fuzzyfiles;
1326 use Fcntl qw(:flock);
1328 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1330 open(USERNAME,">>$dir/svc_acct.username")
1331 or die "can't open $dir/svc_acct.username: $!";
1332 flock(USERNAME,LOCK_EX)
1333 or die "can't lock $dir/svc_acct.username: $!";
1335 print USERNAME "$username\n";
1337 flock(USERNAME,LOCK_UN)
1338 or die "can't unlock $dir/svc_acct.username: $!";
1346 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1350 sub radius_usergroup_selector {
1351 my $sel_groups = shift;
1352 my %sel_groups = map { $_=>1 } @$sel_groups;
1354 my $selectname = shift || 'radius_usergroup';
1357 my $sth = $dbh->prepare(
1358 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1359 ) or die $dbh->errstr;
1360 $sth->execute() or die $sth->errstr;
1361 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1365 function ${selectname}_doadd(object) {
1366 var myvalue = object.${selectname}_add.value;
1367 var optionName = new Option(myvalue,myvalue,false,true);
1368 var length = object.$selectname.length;
1369 object.$selectname.options[length] = optionName;
1370 object.${selectname}_add.value = "";
1373 <SELECT MULTIPLE NAME="$selectname">
1376 foreach my $group ( @all_groups ) {
1378 if ( $sel_groups{$group} ) {
1379 $html .= ' SELECTED';
1380 $sel_groups{$group} = 0;
1382 $html .= ">$group</OPTION>\n";
1384 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1385 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1387 $html .= '</SELECT>';
1389 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1390 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1399 The $recref stuff in sub check should be cleaned up.
1401 The suspend, unsuspend and cancel methods update the database, but not the
1402 current object. This is probably a bug as it's unexpected and
1405 radius_usergroup_selector? putting web ui components in here? they should
1406 probably live somewhere else...
1408 insertion of RADIUS group stuff in insert could be done with child_objects now
1409 (would probably clean up export of them too)
1413 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1414 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1415 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1416 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1417 schema.html from the base documentation.