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 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
12 $radius_password $radius_ip
18 use FS::UID qw( datasrc );
20 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
25 use FS::cust_main_invoice;
29 use FS::radius_usergroup;
32 use FS::Msgcat qw(gettext);
36 @ISA = qw( FS::svc_Common );
40 $me = '[FS::svc_acct]';
42 #ask FS::UID to run this stuff for us later
43 $FS::UID::callback{'FS::svc_acct'} = sub {
45 $dir_prefix = $conf->config('home');
46 @shells = $conf->config('shells');
47 $usernamemin = $conf->config('usernamemin') || 2;
48 $usernamemax = $conf->config('usernamemax');
49 $passwordmin = $conf->config('passwordmin') || 6;
50 $passwordmax = $conf->config('passwordmax') || 8;
51 $username_letter = $conf->exists('username-letter');
52 $username_letterfirst = $conf->exists('username-letterfirst');
53 $username_noperiod = $conf->exists('username-noperiod');
54 $username_nounderscore = $conf->exists('username-nounderscore');
55 $username_nodash = $conf->exists('username-nodash');
56 $username_uppercase = $conf->exists('username-uppercase');
57 $username_ampersand = $conf->exists('username-ampersand');
58 $dirhash = $conf->config('dirhash') || 0;
59 if ( $conf->exists('welcome_email') ) {
60 $welcome_template = new Text::Template (
62 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
63 ) or warn "can't create welcome email template: $Text::Template::ERROR";
64 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
65 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
66 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
68 $welcome_template = '';
70 $welcome_subject = '';
71 $welcome_mimetype = '';
73 $smtpmachine = $conf->config('smtpmachine');
74 $radius_password = $conf->config('radius-password') || 'Password';
75 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
78 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
79 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
83 my ( $hashref, $cache ) = @_;
84 if ( $hashref->{'svc_acct_svcnum'} ) {
85 $self->{'_domsvc'} = FS::svc_domain->new( {
86 'svcnum' => $hashref->{'domsvc'},
87 'domain' => $hashref->{'svc_acct_domain'},
88 'catchall' => $hashref->{'svc_acct_catchall'},
95 FS::svc_acct - Object methods for svc_acct records
101 $record = new FS::svc_acct \%hash;
102 $record = new FS::svc_acct { 'column' => 'value' };
104 $error = $record->insert;
106 $error = $new_record->replace($old_record);
108 $error = $record->delete;
110 $error = $record->check;
112 $error = $record->suspend;
114 $error = $record->unsuspend;
116 $error = $record->cancel;
118 %hash = $record->radius;
120 %hash = $record->radius_reply;
122 %hash = $record->radius_check;
124 $domain = $record->domain;
126 $svc_domain = $record->svc_domain;
128 $email = $record->email;
130 $seconds_since = $record->seconds_since($timestamp);
134 An FS::svc_acct object represents an account. FS::svc_acct inherits from
135 FS::svc_Common. The following fields are currently supported:
139 =item svcnum - primary key (assigned automatcially for new accounts)
143 =item _password - generated if blank
145 =item sec_phrase - security phrase
147 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
155 =item dir - set automatically if blank (and uid is not)
159 =item quota - (unimplementd)
161 =item slipip - IP address
165 =item domsvc - svcnum from svc_domain
167 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
177 Creates a new account. To add the account to the database, see L<"insert">.
181 sub table { 'svc_acct'; }
183 =item insert [ , OPTION => VALUE ... ]
185 Adds this account to the database. If there is an error, returns the error,
186 otherwise returns false.
188 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
189 defined. An FS::cust_svc record will be created and inserted.
191 The additional field I<usergroup> can optionally be defined; if so it should
192 contain an arrayref of group names. See L<FS::radius_usergroup>.
194 The additional field I<child_objects> can optionally be defined; if so it
195 should contain an arrayref of FS::tablename objects. They will have their
196 svcnum fields set and will be inserted after this record, but before any
199 Currently available options are: I<depend_jobnum>
201 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
202 jobnums), all provisioning jobs will have a dependancy on the supplied
203 jobnum(s) (they will not run until the specific job(s) complete(s)).
205 (TODOC: L<FS::queue> and L<freeside-queued>)
207 (TODOC: new exports!)
216 local $SIG{HUP} = 'IGNORE';
217 local $SIG{INT} = 'IGNORE';
218 local $SIG{QUIT} = 'IGNORE';
219 local $SIG{TERM} = 'IGNORE';
220 local $SIG{TSTP} = 'IGNORE';
221 local $SIG{PIPE} = 'IGNORE';
223 my $oldAutoCommit = $FS::UID::AutoCommit;
224 local $FS::UID::AutoCommit = 0;
227 $error = $self->check;
228 return $error if $error;
230 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
231 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
232 unless ( $cust_svc ) {
233 $dbh->rollback if $oldAutoCommit;
234 return "no cust_svc record found for svcnum ". $self->svcnum;
236 $self->pkgnum($cust_svc->pkgnum);
237 $self->svcpart($cust_svc->svcpart);
240 $error = $self->_check_duplicate;
242 $dbh->rollback if $oldAutoCommit;
247 $error = $self->SUPER::insert(
248 'jobnums' => \@jobnums,
249 'child_objects' => $self->child_objects,
253 $dbh->rollback if $oldAutoCommit;
257 if ( $self->usergroup ) {
258 foreach my $groupname ( @{$self->usergroup} ) {
259 my $radius_usergroup = new FS::radius_usergroup ( {
260 svcnum => $self->svcnum,
261 groupname => $groupname,
263 my $error = $radius_usergroup->insert;
265 $dbh->rollback if $oldAutoCommit;
271 #false laziness with sub replace (and cust_main)
272 my $queue = new FS::queue {
273 'svcnum' => $self->svcnum,
274 'job' => 'FS::svc_acct::append_fuzzyfiles'
276 $error = $queue->insert($self->username);
278 $dbh->rollback if $oldAutoCommit;
279 return "queueing job (transaction rolled back): $error";
282 my $cust_pkg = $self->cust_svc->cust_pkg;
285 my $cust_main = $cust_pkg->cust_main;
287 if ( $conf->exists('emailinvoiceauto') ) {
288 my @invoicing_list = $cust_main->invoicing_list;
289 push @invoicing_list, $self->email;
290 $cust_main->invoicing_list(\@invoicing_list);
295 if ( $welcome_template && $cust_pkg ) {
296 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
298 my $wqueue = new FS::queue {
299 'svcnum' => $self->svcnum,
300 'job' => 'FS::svc_acct::send_email'
302 my $error = $wqueue->insert(
304 'from' => $welcome_from,
305 'subject' => $welcome_subject,
306 'mimetype' => $welcome_mimetype,
307 'body' => $welcome_template->fill_in( HASH => {
308 'custnum' => $self->custnum,
309 'username' => $self->username,
310 'password' => $self->_password,
311 'first' => $cust_main->first,
312 'last' => $cust_main->getfield('last'),
313 'pkg' => $cust_pkg->part_pkg->pkg,
317 $dbh->rollback if $oldAutoCommit;
318 return "error queuing welcome email: $error";
321 if ( $options{'depend_jobnum'} ) {
322 warn "$me depend_jobnum found; adding to welcome email dependancies"
324 if ( ref($options{'depend_jobnum'}) ) {
325 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
326 "to welcome email dependancies"
328 push @jobnums, @{ $options{'depend_jobnum'} };
330 warn "$me adding job $options{'depend_jobnum'} ".
331 "to welcome email dependancies"
333 push @jobnums, $options{'depend_jobnum'};
337 foreach my $jobnum ( @jobnums ) {
338 my $error = $wqueue->depend_insert($jobnum);
340 $dbh->rollback if $oldAutoCommit;
341 return "error queuing welcome email job dependancy: $error";
351 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
357 Deletes this account from the database. If there is an error, returns the
358 error, otherwise returns false.
360 The corresponding FS::cust_svc record will be deleted as well.
362 (TODOC: new exports!)
369 return "can't delete system account" if $self->_check_system;
371 return "Can't delete an account which is a (svc_forward) source!"
372 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
374 return "Can't delete an account which is a (svc_forward) destination!"
375 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
377 return "Can't delete an account with (svc_www) web service!"
378 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
380 # what about records in session ? (they should refer to history table)
382 local $SIG{HUP} = 'IGNORE';
383 local $SIG{INT} = 'IGNORE';
384 local $SIG{QUIT} = 'IGNORE';
385 local $SIG{TERM} = 'IGNORE';
386 local $SIG{TSTP} = 'IGNORE';
387 local $SIG{PIPE} = 'IGNORE';
389 my $oldAutoCommit = $FS::UID::AutoCommit;
390 local $FS::UID::AutoCommit = 0;
393 foreach my $cust_main_invoice (
394 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
396 unless ( defined($cust_main_invoice) ) {
397 warn "WARNING: something's wrong with qsearch";
400 my %hash = $cust_main_invoice->hash;
401 $hash{'dest'} = $self->email;
402 my $new = new FS::cust_main_invoice \%hash;
403 my $error = $new->replace($cust_main_invoice);
405 $dbh->rollback if $oldAutoCommit;
410 foreach my $svc_domain (
411 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
413 my %hash = new FS::svc_domain->hash;
414 $hash{'catchall'} = '';
415 my $new = new FS::svc_domain \%hash;
416 my $error = $new->replace($svc_domain);
418 $dbh->rollback if $oldAutoCommit;
423 foreach my $radius_usergroup (
424 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
426 my $error = $radius_usergroup->delete;
428 $dbh->rollback if $oldAutoCommit;
433 my $error = $self->SUPER::delete;
435 $dbh->rollback if $oldAutoCommit;
439 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
443 =item replace OLD_RECORD
445 Replaces OLD_RECORD with this one in the database. If there is an error,
446 returns the error, otherwise returns false.
448 The additional field I<usergroup> can optionally be defined; if so it should
449 contain an arrayref of group names. See L<FS::radius_usergroup>.
455 my ( $new, $old ) = ( shift, shift );
457 warn "$me replacing $old with $new\n" if $DEBUG;
459 return "can't modify system account" if $old->_check_system;
461 return "Username in use"
462 if $old->username ne $new->username &&
463 qsearchs( 'svc_acct', { 'username' => $new->username,
464 'domsvc' => $new->domsvc,
467 #no warnings 'numeric'; #alas, a 5.006-ism
469 return "Can't change uid!" if $old->uid != $new->uid;
472 #change homdir when we change username
473 $new->setfield('dir', '') if $old->username ne $new->username;
475 local $SIG{HUP} = 'IGNORE';
476 local $SIG{INT} = 'IGNORE';
477 local $SIG{QUIT} = 'IGNORE';
478 local $SIG{TERM} = 'IGNORE';
479 local $SIG{TSTP} = 'IGNORE';
480 local $SIG{PIPE} = 'IGNORE';
482 my $oldAutoCommit = $FS::UID::AutoCommit;
483 local $FS::UID::AutoCommit = 0;
486 # redundant, but so $new->usergroup gets set
487 $error = $new->check;
488 return $error if $error;
490 $old->usergroup( [ $old->radius_groups ] );
491 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
492 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
493 if ( $new->usergroup ) {
494 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
495 my @newgroups = @{$new->usergroup};
496 foreach my $oldgroup ( @{$old->usergroup} ) {
497 if ( grep { $oldgroup eq $_ } @newgroups ) {
498 @newgroups = grep { $oldgroup ne $_ } @newgroups;
501 my $radius_usergroup = qsearchs('radius_usergroup', {
502 svcnum => $old->svcnum,
503 groupname => $oldgroup,
505 my $error = $radius_usergroup->delete;
507 $dbh->rollback if $oldAutoCommit;
508 return "error deleting radius_usergroup $oldgroup: $error";
512 foreach my $newgroup ( @newgroups ) {
513 my $radius_usergroup = new FS::radius_usergroup ( {
514 svcnum => $new->svcnum,
515 groupname => $newgroup,
517 my $error = $radius_usergroup->insert;
519 $dbh->rollback if $oldAutoCommit;
520 return "error adding radius_usergroup $newgroup: $error";
526 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
527 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
528 $error = $new->_check_duplicate;
530 $dbh->rollback if $oldAutoCommit;
535 $error = $new->SUPER::replace($old);
537 $dbh->rollback if $oldAutoCommit;
538 return $error if $error;
541 if ( $new->username ne $old->username ) {
542 #false laziness with sub insert (and cust_main)
543 my $queue = new FS::queue {
544 'svcnum' => $new->svcnum,
545 'job' => 'FS::svc_acct::append_fuzzyfiles'
547 $error = $queue->insert($new->username);
549 $dbh->rollback if $oldAutoCommit;
550 return "queueing job (transaction rolled back): $error";
554 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
560 Suspends this account by calling export-specific suspend hooks. If there is
561 an error, returns the error, otherwise returns false.
563 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
569 return "can't suspend system account" if $self->_check_system;
570 $self->SUPER::suspend;
575 Unsuspends this account by by calling export-specific suspend hooks. If there
576 is an error, returns the error, otherwise returns false.
578 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
584 my %hash = $self->hash;
585 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
586 $hash{_password} = $1;
587 my $new = new FS::svc_acct ( \%hash );
588 my $error = $new->replace($self);
589 return $error if $error;
592 $self->SUPER::unsuspend;
597 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
599 If the B<auto_unset_catchall> configuration option is set, this method will
600 automatically remove any references to the canceled service in the catchall
601 field of svc_domain. This allows packages that contain both a svc_domain and
602 its catchall svc_acct to be canceled in one step.
607 # Only one thing to do at this level
609 foreach my $svc_domain (
610 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
611 if($conf->exists('auto_unset_catchall')) {
612 my %hash = $svc_domain->hash;
613 $hash{catchall} = '';
614 my $new = new FS::svc_domain ( \%hash );
615 my $error = $new->replace($svc_domain);
616 return $error if $error;
618 return "cannot unprovision svc_acct #".$self->svcnum.
619 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
623 $self->SUPER::cancel;
629 Checks all fields to make sure this is a valid service. If there is an error,
630 returns the error, otherwise returns false. Called by the insert and replace
633 Sets any fixed values; see L<FS::part_svc>.
640 my($recref) = $self->hashref;
642 my $x = $self->setfixed;
643 return $x unless ref($x);
646 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
648 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
651 my $error = $self->ut_numbern('svcnum')
652 #|| $self->ut_number('domsvc')
653 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
654 || $self->ut_textn('sec_phrase')
656 return $error if $error;
658 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
659 if ( $username_uppercase ) {
660 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
661 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
662 $recref->{username} = $1;
664 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
665 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
666 $recref->{username} = $1;
669 if ( $username_letterfirst ) {
670 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
671 } elsif ( $username_letter ) {
672 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
674 if ( $username_noperiod ) {
675 $recref->{username} =~ /\./ and return gettext('illegal_username');
677 if ( $username_nounderscore ) {
678 $recref->{username} =~ /_/ and return gettext('illegal_username');
680 if ( $username_nodash ) {
681 $recref->{username} =~ /\-/ and return gettext('illegal_username');
683 unless ( $username_ampersand ) {
684 $recref->{username} =~ /\&/ and return gettext('illegal_username');
687 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
688 $recref->{popnum} = $1;
689 return "Unknown popnum" unless
690 ! $recref->{popnum} ||
691 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
693 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
695 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
696 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
698 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
699 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
700 #not all systems use gid=uid
701 #you can set a fixed gid in part_svc
703 return "Only root can have uid 0"
704 if $recref->{uid} == 0
705 && $recref->{username} ne 'root'
706 && $recref->{username} ne 'toor';
709 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
710 or return "Illegal directory: ". $recref->{dir};
712 return "Illegal directory"
713 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
714 return "Illegal directory"
715 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
716 unless ( $recref->{dir} ) {
717 $recref->{dir} = $dir_prefix . '/';
718 if ( $dirhash > 0 ) {
719 for my $h ( 1 .. $dirhash ) {
720 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
722 } elsif ( $dirhash < 0 ) {
723 for my $h ( reverse $dirhash .. -1 ) {
724 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
727 $recref->{dir} .= $recref->{username};
731 unless ( $recref->{username} eq 'sync' ) {
732 if ( grep $_ eq $recref->{shell}, @shells ) {
733 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
735 return "Illegal shell \`". $self->shell. "\'; ".
736 $conf->dir. "/shells contains: @shells";
739 $recref->{shell} = '/bin/sync';
743 $recref->{gid} ne '' ?
744 return "Can't have gid without uid" : ( $recref->{gid}='' );
745 $recref->{dir} ne '' ?
746 return "Can't have directory without uid" : ( $recref->{dir}='' );
747 $recref->{shell} ne '' ?
748 return "Can't have shell without uid" : ( $recref->{shell}='' );
751 # $error = $self->ut_textn('finger');
752 # return $error if $error;
753 if ( $self->getfield('finger') eq '' ) {
754 my $cust_pkg = $self->svcnum
755 ? $self->cust_svc->cust_pkg
756 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
758 my $cust_main = $cust_pkg->cust_main;
759 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
762 $self->getfield('finger') =~
763 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
764 or return "Illegal finger: ". $self->getfield('finger');
765 $self->setfield('finger', $1);
767 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
768 $recref->{quota} = $1;
770 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
771 if ( $recref->{slipip} eq '' ) {
772 $recref->{slipip} = '';
773 } elsif ( $recref->{slipip} eq '0e0' ) {
774 $recref->{slipip} = '0e0';
776 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
777 or return "Illegal slipip: ". $self->slipip;
778 $recref->{slipip} = $1;
783 #arbitrary RADIUS stuff; allow ut_textn for now
784 foreach ( grep /^radius_/, fields('svc_acct') ) {
788 #generate a password if it is blank
789 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
790 unless ( $recref->{_password} );
792 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
793 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
794 $recref->{_password} = $1.$3;
795 #uncomment this to encrypt password immediately upon entry, or run
796 #bin/crypt_pw in cron to give new users a window during which their
797 #password is available to techs, for faxing, etc. (also be aware of
799 #$recref->{password} = $1.
800 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
802 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
803 $recref->{_password} = $1.$3;
804 } elsif ( $recref->{_password} eq '*' ) {
805 $recref->{_password} = '*';
806 } elsif ( $recref->{_password} eq '!' ) {
807 $recref->{_password} = '!';
808 } elsif ( $recref->{_password} eq '!!' ) {
809 $recref->{_password} = '!!';
811 #return "Illegal password";
812 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
813 FS::Msgcat::_gettext('illegal_password_characters').
814 ": ". $recref->{_password};
822 Internal function to check the username against the list of system usernames
823 from the I<system_usernames> configuration value. Returns true if the username
824 is listed on the system username list.
830 scalar( grep { $self->username eq $_ || $self->email eq $_ }
831 $conf->config('system_usernames')
835 =item _check_duplicate
837 Internal function to check for duplicates usernames, username@domain pairs and
840 If the I<global_unique-username> configuration value is set to B<username> or
841 B<username@domain>, enforces global username or username@domain uniqueness.
843 In all cases, check for duplicate uids and usernames or username@domain pairs
844 per export and with identical I<svcpart> values.
848 sub _check_duplicate {
851 #this is Pg-specific. what to do for mysql etc?
852 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
853 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
854 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
856 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
858 my $svcpart = $self->svcpart;
859 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
860 unless ( $part_svc ) {
861 return 'unknown svcpart '. $self->svcpart;
864 my $global_unique = $conf->config('global_unique-username');
866 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
867 qsearch( 'svc_acct', { 'username' => $self->username } );
868 return gettext('username_in_use')
869 if $global_unique eq 'username' && @dup_user;
871 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
872 qsearch( 'svc_acct', { 'username' => $self->username,
873 'domsvc' => $self->domsvc } );
874 return gettext('username_in_use')
875 if $global_unique eq 'username@domain' && @dup_userdomain;
878 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
879 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
880 @dup_uid = grep { $svcpart != $_->svcpart }
881 qsearch( 'svc_acct', { 'uid' => $self->uid } );
886 if ( @dup_user || @dup_userdomain || @dup_uid ) {
887 my $exports = FS::part_export::export_info('svc_acct');
888 my %conflict_user_svcpart;
889 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
891 foreach my $part_export ( $part_svc->part_export ) {
893 #this will catch to the same exact export
894 my @svcparts = map { $_->svcpart } $part_export->export_svc;
896 #this will catch to exports w/same exporthost+type ???
897 #my @other_part_export = qsearch('part_export', {
898 # 'machine' => $part_export->machine,
899 # 'exporttype' => $part_export->exporttype,
901 #foreach my $other_part_export ( @other_part_export ) {
902 # push @svcparts, map { $_->svcpart }
903 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
906 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
907 #silly kludge to avoid uninitialized value errors
908 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
909 ? $exports->{$part_export->exporttype}{'nodomain'}
911 if ( $nodomain =~ /^Y/i ) {
912 $conflict_user_svcpart{$_} = $part_export->exportnum
915 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
920 foreach my $dup_user ( @dup_user ) {
921 my $dup_svcpart = $dup_user->cust_svc->svcpart;
922 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
923 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
924 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
928 foreach my $dup_userdomain ( @dup_userdomain ) {
929 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
930 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
931 return "duplicate username\@domain: conflicts with svcnum ".
932 $dup_userdomain->svcnum. " via exportnum ".
933 $conflict_userdomain_svcpart{$dup_svcpart};
937 foreach my $dup_uid ( @dup_uid ) {
938 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
939 if ( exists($conflict_user_svcpart{$dup_svcpart})
940 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
941 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
942 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
943 || $conflict_userdomain_svcpart{$dup_svcpart};
955 Depriciated, use radius_reply instead.
960 carp "FS::svc_acct::radius depriciated, use radius_reply";
966 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
967 reply attributes of this record.
969 Note that this is now the preferred method for reading RADIUS attributes -
970 accessing the columns directly is discouraged, as the column names are
971 expected to change in the future.
980 my($column, $attrib) = ($1, $2);
981 #$attrib =~ s/_/\-/g;
982 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
983 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
984 if ( $self->slipip && $self->slipip ne '0e0' ) {
985 $reply{$radius_ip} = $self->slipip;
992 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
993 check attributes of this record.
995 Note that this is now the preferred method for reading RADIUS attributes -
996 accessing the columns directly is discouraged, as the column names are
997 expected to change in the future.
1003 my $password = $self->_password;
1004 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1005 ( $pw_attrib => $password,
1008 my($column, $attrib) = ($1, $2);
1009 #$attrib =~ s/_/\-/g;
1010 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1011 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
1017 Returns the domain associated with this account.
1023 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1024 my $svc_domain = $self->svc_domain
1025 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1026 $svc_domain->domain;
1031 Returns the FS::svc_domain record for this account's domain (see
1039 ? $self->{'_domsvc'}
1040 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1045 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1051 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1056 Returns an email address associated with the account.
1062 $self->username. '@'. $self->domain;
1067 Returns an array of FS::acct_snarf records associated with the account.
1068 If the acct_snarf table does not exist or there are no associated records,
1069 an empty list is returned
1075 return () unless dbdef->table('acct_snarf');
1076 eval "use FS::acct_snarf;";
1078 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1081 =item seconds_since TIMESTAMP
1083 Returns the number of seconds this account has been online since TIMESTAMP,
1084 according to the session monitor (see L<FS::Session>).
1086 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1087 L<Time::Local> and L<Date::Parse> for conversion functions.
1091 #note: POD here, implementation in FS::cust_svc
1094 $self->cust_svc->seconds_since(@_);
1097 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1099 Returns the numbers of seconds this account has been online between
1100 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1101 external SQL radacct table, specified via sqlradius export. Sessions which
1102 started in the specified range but are still open are counted from session
1103 start to the end of the range (unless they are over 1 day old, in which case
1104 they are presumed missing their stop record and not counted). Also, sessions
1105 which end in the range but started earlier are counted from the start of the
1106 range to session end. Finally, sessions which start before the range but end
1107 after are counted for the entire range.
1109 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1110 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1115 #note: POD here, implementation in FS::cust_svc
1116 sub seconds_since_sqlradacct {
1118 $self->cust_svc->seconds_since_sqlradacct(@_);
1121 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1123 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1124 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1125 TIMESTAMP_END (exclusive).
1127 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1128 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1133 #note: POD here, implementation in FS::cust_svc
1134 sub attribute_since_sqlradacct {
1136 $self->cust_svc->attribute_since_sqlradacct(@_);
1139 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1141 Returns an array of hash references of this customers login history for the
1142 given time range. (document this better)
1146 sub get_session_history_sqlradacct {
1148 $self->cust_svc->get_session_history_sqlradacct(@_);
1153 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1159 if ( $self->usergroup ) {
1160 #when provisioning records, export callback runs in svc_Common.pm before
1161 #radius_usergroup records can be inserted...
1162 @{$self->usergroup};
1164 map { $_->groupname }
1165 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1169 =item clone_suspended
1171 Constructor used by FS::part_export::_export_suspend fallback. Document
1176 sub clone_suspended {
1178 my %hash = $self->hash;
1179 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1180 new FS::svc_acct \%hash;
1183 =item clone_kludge_unsuspend
1185 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1190 sub clone_kludge_unsuspend {
1192 my %hash = $self->hash;
1193 $hash{_password} = '';
1194 new FS::svc_acct \%hash;
1197 =item check_password
1199 Checks the supplied password against the (possibly encrypted) password in the
1200 database. Returns true for a sucessful authentication, false for no match.
1202 Currently supported encryptions are: classic DES crypt() and MD5
1206 sub check_password {
1207 my($self, $check_password) = @_;
1209 #remove old-style SUSPENDED kludge, they should be allowed to login to
1210 #self-service and pay up
1211 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1213 #eventually should check a "password-encoding" field
1214 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1216 } elsif ( length($password) < 13 ) { #plaintext
1217 $check_password eq $password;
1218 } elsif ( length($password) == 13 ) { #traditional DES crypt
1219 crypt($check_password, $password) eq $password;
1220 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1221 unix_md5_crypt($check_password, $password) eq $password;
1222 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1223 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1224 $self->svcnum. "\n";
1227 warn "Can't check password: Unrecognized encryption for svcnum ".
1228 $self->svcnum. "\n";
1234 =item crypt_password
1236 Returns an encrypted password, either by passing through an encrypted password
1237 in the database or by encrypting a plaintext password from the database.
1241 sub crypt_password {
1243 #false laziness w/shellcommands.pm
1244 #eventually should check a "password-encoding" field
1245 if ( length($self->_password) == 13
1246 || $self->_password =~ /^\$(1|2a?)\$/ ) {
1251 $saltset[int(rand(64))].$saltset[int(rand(64))]
1256 =item virtual_maildir
1258 Returns $domain/maildirs/$username/
1262 sub virtual_maildir {
1264 $self->domain. '/maildirs/'. $self->username. '/';
1275 This is the FS::svc_acct job-queue-able version. It still uses
1276 FS::Misc::send_email under-the-hood.
1283 eval "use FS::Misc qw(send_email)";
1286 $opt{mimetype} ||= 'text/plain';
1287 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1289 my $error = send_email(
1290 'from' => $opt{from},
1292 'subject' => $opt{subject},
1293 'content-type' => $opt{mimetype},
1294 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1296 die $error if $error;
1299 =item check_and_rebuild_fuzzyfiles
1303 sub check_and_rebuild_fuzzyfiles {
1304 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1305 -e "$dir/svc_acct.username"
1306 or &rebuild_fuzzyfiles;
1309 =item rebuild_fuzzyfiles
1313 sub rebuild_fuzzyfiles {
1315 use Fcntl qw(:flock);
1317 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1321 open(USERNAMELOCK,">>$dir/svc_acct.username")
1322 or die "can't open $dir/svc_acct.username: $!";
1323 flock(USERNAMELOCK,LOCK_EX)
1324 or die "can't lock $dir/svc_acct.username: $!";
1326 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1328 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1329 or die "can't open $dir/svc_acct.username.tmp: $!";
1330 print USERNAMECACHE join("\n", @all_username), "\n";
1331 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1333 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1343 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1344 open(USERNAMECACHE,"<$dir/svc_acct.username")
1345 or die "can't open $dir/svc_acct.username: $!";
1346 my @array = map { chomp; $_; } <USERNAMECACHE>;
1347 close USERNAMECACHE;
1351 =item append_fuzzyfiles USERNAME
1355 sub append_fuzzyfiles {
1356 my $username = shift;
1358 &check_and_rebuild_fuzzyfiles;
1360 use Fcntl qw(:flock);
1362 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1364 open(USERNAME,">>$dir/svc_acct.username")
1365 or die "can't open $dir/svc_acct.username: $!";
1366 flock(USERNAME,LOCK_EX)
1367 or die "can't lock $dir/svc_acct.username: $!";
1369 print USERNAME "$username\n";
1371 flock(USERNAME,LOCK_UN)
1372 or die "can't unlock $dir/svc_acct.username: $!";
1380 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1384 sub radius_usergroup_selector {
1385 my $sel_groups = shift;
1386 my %sel_groups = map { $_=>1 } @$sel_groups;
1388 my $selectname = shift || 'radius_usergroup';
1391 my $sth = $dbh->prepare(
1392 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1393 ) or die $dbh->errstr;
1394 $sth->execute() or die $sth->errstr;
1395 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1399 function ${selectname}_doadd(object) {
1400 var myvalue = object.${selectname}_add.value;
1401 var optionName = new Option(myvalue,myvalue,false,true);
1402 var length = object.$selectname.length;
1403 object.$selectname.options[length] = optionName;
1404 object.${selectname}_add.value = "";
1407 <SELECT MULTIPLE NAME="$selectname">
1410 foreach my $group ( @all_groups ) {
1412 if ( $sel_groups{$group} ) {
1413 $html .= ' SELECTED';
1414 $sel_groups{$group} = 0;
1416 $html .= ">$group</OPTION>\n";
1418 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1419 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1421 $html .= '</SELECT>';
1423 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1424 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1433 The $recref stuff in sub check should be cleaned up.
1435 The suspend, unsuspend and cancel methods update the database, but not the
1436 current object. This is probably a bug as it's unexpected and
1439 radius_usergroup_selector? putting web ui components in here? they should
1440 probably live somewhere else...
1442 insertion of RADIUS group stuff in insert could be done with child_objects now
1443 (would probably clean up export of them too)
1447 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1448 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1449 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1450 L<freeside-queued>), L<FS::svc_acct_pop>,
1451 schema.html from the base documentation.