4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
5 $dir_prefix @shells $usernamemin
6 $usernamemax $passwordmin $passwordmax
7 $username_ampersand $username_letter $username_letterfirst
8 $username_noperiod $username_nounderscore $username_nodash
10 $password_noampersand $password_noexclamation
11 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
13 $radius_password $radius_ip
18 use Crypt::PasswdMD5 1.2;
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 );
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 $password_noampersand = $conf->exists('password-noexclamation');
59 $password_noexclamation = $conf->exists('password-noexclamation');
60 $dirhash = $conf->config('dirhash') || 0;
61 if ( $conf->exists('welcome_email') ) {
62 $welcome_template = new Text::Template (
64 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
65 ) or warn "can't create welcome email template: $Text::Template::ERROR";
66 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
67 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
68 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
70 $welcome_template = '';
72 $welcome_subject = '';
73 $welcome_mimetype = '';
75 $smtpmachine = $conf->config('smtpmachine');
76 $radius_password = $conf->config('radius-password') || 'Password';
77 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
80 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
81 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
85 my ( $hashref, $cache ) = @_;
86 if ( $hashref->{'svc_acct_svcnum'} ) {
87 $self->{'_domsvc'} = FS::svc_domain->new( {
88 'svcnum' => $hashref->{'domsvc'},
89 'domain' => $hashref->{'svc_acct_domain'},
90 'catchall' => $hashref->{'svc_acct_catchall'},
97 FS::svc_acct - Object methods for svc_acct records
103 $record = new FS::svc_acct \%hash;
104 $record = new FS::svc_acct { 'column' => 'value' };
106 $error = $record->insert;
108 $error = $new_record->replace($old_record);
110 $error = $record->delete;
112 $error = $record->check;
114 $error = $record->suspend;
116 $error = $record->unsuspend;
118 $error = $record->cancel;
120 %hash = $record->radius;
122 %hash = $record->radius_reply;
124 %hash = $record->radius_check;
126 $domain = $record->domain;
128 $svc_domain = $record->svc_domain;
130 $email = $record->email;
132 $seconds_since = $record->seconds_since($timestamp);
136 An FS::svc_acct object represents an account. FS::svc_acct inherits from
137 FS::svc_Common. The following fields are currently supported:
141 =item svcnum - primary key (assigned automatcially for new accounts)
145 =item _password - generated if blank
147 =item sec_phrase - security phrase
149 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
157 =item dir - set automatically if blank (and uid is not)
161 =item quota - (unimplementd)
163 =item slipip - IP address
167 =item domsvc - svcnum from svc_domain
169 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
171 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
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
201 exports are run. Each element of the array can also optionally be a
202 two-element array reference containing the child object and the name of an
203 alternate field to be filled in with the newly-inserted svcnum, for example
204 C<[ $svc_forward, 'srcsvc' ]>
206 Currently available options are: I<depend_jobnum>
208 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
209 jobnums), all provisioning jobs will have a dependancy on the supplied
210 jobnum(s) (they will not run until the specific job(s) complete(s)).
212 (TODOC: L<FS::queue> and L<freeside-queued>)
214 (TODOC: new exports!)
223 local $SIG{HUP} = 'IGNORE';
224 local $SIG{INT} = 'IGNORE';
225 local $SIG{QUIT} = 'IGNORE';
226 local $SIG{TERM} = 'IGNORE';
227 local $SIG{TSTP} = 'IGNORE';
228 local $SIG{PIPE} = 'IGNORE';
230 my $oldAutoCommit = $FS::UID::AutoCommit;
231 local $FS::UID::AutoCommit = 0;
234 $error = $self->check;
235 return $error if $error;
237 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
238 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
239 unless ( $cust_svc ) {
240 $dbh->rollback if $oldAutoCommit;
241 return "no cust_svc record found for svcnum ". $self->svcnum;
243 $self->pkgnum($cust_svc->pkgnum);
244 $self->svcpart($cust_svc->svcpart);
247 $error = $self->_check_duplicate;
249 $dbh->rollback if $oldAutoCommit;
254 $error = $self->SUPER::insert(
255 'jobnums' => \@jobnums,
256 'child_objects' => $self->child_objects,
260 $dbh->rollback if $oldAutoCommit;
264 if ( $self->usergroup ) {
265 foreach my $groupname ( @{$self->usergroup} ) {
266 my $radius_usergroup = new FS::radius_usergroup ( {
267 svcnum => $self->svcnum,
268 groupname => $groupname,
270 my $error = $radius_usergroup->insert;
272 $dbh->rollback if $oldAutoCommit;
278 unless ( $skip_fuzzyfiles ) {
279 $error = $self->queue_fuzzyfiles_update;
281 $dbh->rollback if $oldAutoCommit;
282 return "updating fuzzy search cache: $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 { $_ !~ /^(POST|FAX)$/ } $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 return "can't delete system account" if $self->_check_system;
375 return "Can't delete an account which is a (svc_forward) source!"
376 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
378 return "Can't delete an account which is a (svc_forward) destination!"
379 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
381 return "Can't delete an account with (svc_www) web service!"
382 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
384 # what about records in session ? (they should refer to history table)
386 local $SIG{HUP} = 'IGNORE';
387 local $SIG{INT} = 'IGNORE';
388 local $SIG{QUIT} = 'IGNORE';
389 local $SIG{TERM} = 'IGNORE';
390 local $SIG{TSTP} = 'IGNORE';
391 local $SIG{PIPE} = 'IGNORE';
393 my $oldAutoCommit = $FS::UID::AutoCommit;
394 local $FS::UID::AutoCommit = 0;
397 foreach my $cust_main_invoice (
398 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
400 unless ( defined($cust_main_invoice) ) {
401 warn "WARNING: something's wrong with qsearch";
404 my %hash = $cust_main_invoice->hash;
405 $hash{'dest'} = $self->email;
406 my $new = new FS::cust_main_invoice \%hash;
407 my $error = $new->replace($cust_main_invoice);
409 $dbh->rollback if $oldAutoCommit;
414 foreach my $svc_domain (
415 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
417 my %hash = new FS::svc_domain->hash;
418 $hash{'catchall'} = '';
419 my $new = new FS::svc_domain \%hash;
420 my $error = $new->replace($svc_domain);
422 $dbh->rollback if $oldAutoCommit;
427 foreach my $radius_usergroup (
428 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
430 my $error = $radius_usergroup->delete;
432 $dbh->rollback if $oldAutoCommit;
437 my $error = $self->SUPER::delete;
439 $dbh->rollback if $oldAutoCommit;
443 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
447 =item replace OLD_RECORD
449 Replaces OLD_RECORD with this one in the database. If there is an error,
450 returns the error, otherwise returns false.
452 The additional field I<usergroup> can optionally be defined; if so it should
453 contain an arrayref of group names. See L<FS::radius_usergroup>.
459 my ( $new, $old ) = ( shift, shift );
461 warn "$me replacing $old with $new\n" if $DEBUG;
463 return "can't modify system account" if $old->_check_system;
466 #no warnings 'numeric'; #alas, a 5.006-ism
468 return "Can't change uid!" if $old->uid != $new->uid;
471 #change homdir when we change username
472 $new->setfield('dir', '') if $old->username ne $new->username;
474 local $SIG{HUP} = 'IGNORE';
475 local $SIG{INT} = 'IGNORE';
476 local $SIG{QUIT} = 'IGNORE';
477 local $SIG{TERM} = 'IGNORE';
478 local $SIG{TSTP} = 'IGNORE';
479 local $SIG{PIPE} = 'IGNORE';
481 my $oldAutoCommit = $FS::UID::AutoCommit;
482 local $FS::UID::AutoCommit = 0;
485 # redundant, but so $new->usergroup gets set
486 $error = $new->check;
487 return $error if $error;
489 $old->usergroup( [ $old->radius_groups ] );
490 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
491 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
492 if ( $new->usergroup ) {
493 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
494 my @newgroups = @{$new->usergroup};
495 foreach my $oldgroup ( @{$old->usergroup} ) {
496 if ( grep { $oldgroup eq $_ } @newgroups ) {
497 @newgroups = grep { $oldgroup ne $_ } @newgroups;
500 my $radius_usergroup = qsearchs('radius_usergroup', {
501 svcnum => $old->svcnum,
502 groupname => $oldgroup,
504 my $error = $radius_usergroup->delete;
506 $dbh->rollback if $oldAutoCommit;
507 return "error deleting radius_usergroup $oldgroup: $error";
511 foreach my $newgroup ( @newgroups ) {
512 my $radius_usergroup = new FS::radius_usergroup ( {
513 svcnum => $new->svcnum,
514 groupname => $newgroup,
516 my $error = $radius_usergroup->insert;
518 $dbh->rollback if $oldAutoCommit;
519 return "error adding radius_usergroup $newgroup: $error";
525 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
526 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
527 $error = $new->_check_duplicate;
529 $dbh->rollback if $oldAutoCommit;
534 $error = $new->SUPER::replace($old);
536 $dbh->rollback if $oldAutoCommit;
537 return $error if $error;
540 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
541 $error = $new->queue_fuzzyfiles_update;
543 $dbh->rollback if $oldAutoCommit;
544 return "updating fuzzy search cache: $error";
548 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
552 =item queue_fuzzyfiles_update
554 Used by insert & replace to update the fuzzy search cache
558 sub queue_fuzzyfiles_update {
561 local $SIG{HUP} = 'IGNORE';
562 local $SIG{INT} = 'IGNORE';
563 local $SIG{QUIT} = 'IGNORE';
564 local $SIG{TERM} = 'IGNORE';
565 local $SIG{TSTP} = 'IGNORE';
566 local $SIG{PIPE} = 'IGNORE';
568 my $oldAutoCommit = $FS::UID::AutoCommit;
569 local $FS::UID::AutoCommit = 0;
572 my $queue = new FS::queue {
573 'svcnum' => $self->svcnum,
574 'job' => 'FS::svc_acct::append_fuzzyfiles'
576 my $error = $queue->insert($self->username);
578 $dbh->rollback if $oldAutoCommit;
579 return "queueing job (transaction rolled back): $error";
582 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
590 Suspends this account by calling export-specific suspend hooks. If there is
591 an error, returns the error, otherwise returns false.
593 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
599 return "can't suspend system account" if $self->_check_system;
600 $self->SUPER::suspend;
605 Unsuspends this account by by calling export-specific suspend hooks. If there
606 is an error, returns the error, otherwise returns false.
608 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
614 my %hash = $self->hash;
615 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
616 $hash{_password} = $1;
617 my $new = new FS::svc_acct ( \%hash );
618 my $error = $new->replace($self);
619 return $error if $error;
622 $self->SUPER::unsuspend;
627 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
629 If the B<auto_unset_catchall> configuration option is set, this method will
630 automatically remove any references to the canceled service in the catchall
631 field of svc_domain. This allows packages that contain both a svc_domain and
632 its catchall svc_acct to be canceled in one step.
637 # Only one thing to do at this level
639 foreach my $svc_domain (
640 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
641 if($conf->exists('auto_unset_catchall')) {
642 my %hash = $svc_domain->hash;
643 $hash{catchall} = '';
644 my $new = new FS::svc_domain ( \%hash );
645 my $error = $new->replace($svc_domain);
646 return $error if $error;
648 return "cannot unprovision svc_acct #".$self->svcnum.
649 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
653 $self->SUPER::cancel;
659 Checks all fields to make sure this is a valid service. If there is an error,
660 returns the error, otherwise returns false. Called by the insert and replace
663 Sets any fixed values; see L<FS::part_svc>.
670 my($recref) = $self->hashref;
672 my $x = $self->setfixed;
673 return $x unless ref($x);
676 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
678 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
681 my $error = $self->ut_numbern('svcnum')
682 #|| $self->ut_number('domsvc')
683 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
684 || $self->ut_textn('sec_phrase')
686 return $error if $error;
688 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
689 if ( $username_uppercase ) {
690 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
691 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
692 $recref->{username} = $1;
694 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
695 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
696 $recref->{username} = $1;
699 if ( $username_letterfirst ) {
700 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
701 } elsif ( $username_letter ) {
702 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
704 if ( $username_noperiod ) {
705 $recref->{username} =~ /\./ and return gettext('illegal_username');
707 if ( $username_nounderscore ) {
708 $recref->{username} =~ /_/ and return gettext('illegal_username');
710 if ( $username_nodash ) {
711 $recref->{username} =~ /\-/ and return gettext('illegal_username');
713 unless ( $username_ampersand ) {
714 $recref->{username} =~ /\&/ and return gettext('illegal_username');
716 if ( $password_noampersand ) {
717 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
719 if ( $password_noexclamation ) {
720 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
723 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
724 $recref->{popnum} = $1;
725 return "Unknown popnum" unless
726 ! $recref->{popnum} ||
727 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
729 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
731 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
732 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
734 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
735 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
736 #not all systems use gid=uid
737 #you can set a fixed gid in part_svc
739 return "Only root can have uid 0"
740 if $recref->{uid} == 0
741 && $recref->{username} !~ /^(root|toor|smtp)$/;
743 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
744 or return "Illegal directory: ". $recref->{dir};
746 return "Illegal directory"
747 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
748 return "Illegal directory"
749 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
750 unless ( $recref->{dir} ) {
751 $recref->{dir} = $dir_prefix . '/';
752 if ( $dirhash > 0 ) {
753 for my $h ( 1 .. $dirhash ) {
754 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
756 } elsif ( $dirhash < 0 ) {
757 for my $h ( reverse $dirhash .. -1 ) {
758 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
761 $recref->{dir} .= $recref->{username};
765 unless ( $recref->{username} eq 'sync' ) {
766 if ( grep $_ eq $recref->{shell}, @shells ) {
767 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
769 return "Illegal shell \`". $self->shell. "\'; ".
770 $conf->dir. "/shells contains: @shells";
773 $recref->{shell} = '/bin/sync';
777 $recref->{gid} ne '' ?
778 return "Can't have gid without uid" : ( $recref->{gid}='' );
779 $recref->{dir} ne '' ?
780 return "Can't have directory without uid" : ( $recref->{dir}='' );
781 $recref->{shell} ne '' ?
782 return "Can't have shell without uid" : ( $recref->{shell}='' );
785 # $error = $self->ut_textn('finger');
786 # return $error if $error;
787 if ( $self->getfield('finger') eq '' ) {
788 my $cust_pkg = $self->svcnum
789 ? $self->cust_svc->cust_pkg
790 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
792 my $cust_main = $cust_pkg->cust_main;
793 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
796 $self->getfield('finger') =~
797 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
798 or return "Illegal finger: ". $self->getfield('finger');
799 $self->setfield('finger', $1);
801 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
802 $recref->{quota} = $1;
804 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
805 if ( $recref->{slipip} eq '' ) {
806 $recref->{slipip} = '';
807 } elsif ( $recref->{slipip} eq '0e0' ) {
808 $recref->{slipip} = '0e0';
810 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
811 or return "Illegal slipip: ". $self->slipip;
812 $recref->{slipip} = $1;
817 #arbitrary RADIUS stuff; allow ut_textn for now
818 foreach ( grep /^radius_/, fields('svc_acct') ) {
822 #generate a password if it is blank
823 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
824 unless ( $recref->{_password} );
826 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
827 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
828 $recref->{_password} = $1.$3;
829 #uncomment this to encrypt password immediately upon entry, or run
830 #bin/crypt_pw in cron to give new users a window during which their
831 #password is available to techs, for faxing, etc. (also be aware of
833 #$recref->{password} = $1.
834 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
836 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
837 $recref->{_password} = $1.$3;
838 } elsif ( $recref->{_password} eq '*' ) {
839 $recref->{_password} = '*';
840 } elsif ( $recref->{_password} eq '!' ) {
841 $recref->{_password} = '!';
842 } elsif ( $recref->{_password} eq '!!' ) {
843 $recref->{_password} = '!!';
845 #return "Illegal password";
846 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
847 FS::Msgcat::_gettext('illegal_password_characters').
848 ": ". $recref->{_password};
856 Internal function to check the username against the list of system usernames
857 from the I<system_usernames> configuration value. Returns true if the username
858 is listed on the system username list.
864 scalar( grep { $self->username eq $_ || $self->email eq $_ }
865 $conf->config('system_usernames')
869 =item _check_duplicate
871 Internal function to check for duplicates usernames, username@domain pairs and
874 If the I<global_unique-username> configuration value is set to B<username> or
875 B<username@domain>, enforces global username or username@domain uniqueness.
877 In all cases, check for duplicate uids and usernames or username@domain pairs
878 per export and with identical I<svcpart> values.
882 sub _check_duplicate {
885 #this is Pg-specific. what to do for mysql etc?
886 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
887 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
888 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
890 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
892 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
893 unless ( $part_svc ) {
894 return 'unknown svcpart '. $self->svcpart;
897 my $global_unique = $conf->config('global_unique-username') || 'none';
899 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
900 qsearch( 'svc_acct', { 'username' => $self->username } );
901 return gettext('username_in_use')
902 if $global_unique eq 'username' && @dup_user;
904 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
905 qsearch( 'svc_acct', { 'username' => $self->username,
906 'domsvc' => $self->domsvc } );
907 return gettext('username_in_use')
908 if $global_unique eq 'username@domain' && @dup_userdomain;
911 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
912 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
913 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
914 qsearch( 'svc_acct', { 'uid' => $self->uid } );
919 if ( @dup_user || @dup_userdomain || @dup_uid ) {
920 my $exports = FS::part_export::export_info('svc_acct');
921 my %conflict_user_svcpart;
922 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
924 foreach my $part_export ( $part_svc->part_export ) {
926 #this will catch to the same exact export
927 my @svcparts = map { $_->svcpart } $part_export->export_svc;
929 #this will catch to exports w/same exporthost+type ???
930 #my @other_part_export = qsearch('part_export', {
931 # 'machine' => $part_export->machine,
932 # 'exporttype' => $part_export->exporttype,
934 #foreach my $other_part_export ( @other_part_export ) {
935 # push @svcparts, map { $_->svcpart }
936 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
939 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
940 #silly kludge to avoid uninitialized value errors
941 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
942 ? $exports->{$part_export->exporttype}{'nodomain'}
944 if ( $nodomain =~ /^Y/i ) {
945 $conflict_user_svcpart{$_} = $part_export->exportnum
948 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
953 foreach my $dup_user ( @dup_user ) {
954 my $dup_svcpart = $dup_user->cust_svc->svcpart;
955 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
956 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
957 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
961 foreach my $dup_userdomain ( @dup_userdomain ) {
962 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
963 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
964 return "duplicate username\@domain: conflicts with svcnum ".
965 $dup_userdomain->svcnum. " via exportnum ".
966 $conflict_userdomain_svcpart{$dup_svcpart};
970 foreach my $dup_uid ( @dup_uid ) {
971 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
972 if ( exists($conflict_user_svcpart{$dup_svcpart})
973 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
974 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
975 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
976 || $conflict_userdomain_svcpart{$dup_svcpart};
988 Depriciated, use radius_reply instead.
993 carp "FS::svc_acct::radius depriciated, use radius_reply";
999 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1000 reply attributes of this record.
1002 Note that this is now the preferred method for reading RADIUS attributes -
1003 accessing the columns directly is discouraged, as the column names are
1004 expected to change in the future.
1013 my($column, $attrib) = ($1, $2);
1014 #$attrib =~ s/_/\-/g;
1015 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1016 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1017 if ( $self->slipip && $self->slipip ne '0e0' ) {
1018 $reply{$radius_ip} = $self->slipip;
1020 if ( $self->seconds !~ /^$/ ) {
1021 $reply{'Session-Timeout'} = $self->seconds;
1028 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1029 check attributes of this record.
1031 Note that this is now the preferred method for reading RADIUS attributes -
1032 accessing the columns directly is discouraged, as the column names are
1033 expected to change in the future.
1039 my $password = $self->_password;
1040 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1041 ( $pw_attrib => $password,
1044 my($column, $attrib) = ($1, $2);
1045 #$attrib =~ s/_/\-/g;
1046 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1047 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
1053 Returns the domain associated with this account.
1059 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1060 my $svc_domain = $self->svc_domain(@_)
1061 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1062 $svc_domain->domain;
1067 Returns the FS::svc_domain record for this account's domain (see
1075 ? $self->{'_domsvc'}
1076 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1081 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1087 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1092 Returns an email address associated with the account.
1098 $self->username. '@'. $self->domain(@_);
1103 Returns an array of FS::acct_snarf records associated with the account.
1104 If the acct_snarf table does not exist or there are no associated records,
1105 an empty list is returned
1111 return () unless dbdef->table('acct_snarf');
1112 eval "use FS::acct_snarf;";
1114 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1117 =item decrement_seconds SECONDS
1119 Decrements the I<seconds> field of this record by the given amount. If there
1120 is an error, returns the error, otherwise returns false.
1124 sub decrement_seconds {
1125 shift->_op_seconds('-', @_);
1128 =item increment_seconds SECONDS
1130 Increments the I<seconds> field of this record by the given amount. If there
1131 is an error, returns the error, otherwise returns false.
1135 sub increment_seconds {
1136 shift->_op_seconds('+', @_);
1144 my %op2condition = (
1145 '-' => sub { my($self, $seconds) = @_;
1146 $self->seconds - $seconds <= 0;
1148 '+' => sub { my($self, $seconds) = @_;
1149 $self->seconds + $seconds > 0;
1154 my( $self, $op, $seconds ) = @_;
1155 warn "$me _op_seconds called for svcnum ". $self->svcnum.
1156 ' ('. $self->email. "): $op $seconds\n"
1159 local $SIG{HUP} = 'IGNORE';
1160 local $SIG{INT} = 'IGNORE';
1161 local $SIG{QUIT} = 'IGNORE';
1162 local $SIG{TERM} = 'IGNORE';
1163 local $SIG{TSTP} = 'IGNORE';
1164 local $SIG{PIPE} = 'IGNORE';
1166 my $oldAutoCommit = $FS::UID::AutoCommit;
1167 local $FS::UID::AutoCommit = 0;
1170 my $sql = "UPDATE svc_acct SET seconds = ".
1171 " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0
1172 " $op ? WHERE svcnum = ?";
1176 my $sth = $dbh->prepare( $sql )
1177 or die "Error preparing $sql: ". $dbh->errstr;
1178 my $rv = $sth->execute($seconds, $self->svcnum);
1179 die "Error executing $sql: ". $sth->errstr
1180 unless defined($rv);
1181 die "Can't update seconds for svcnum". $self->svcnum
1184 my $action = $op2action{$op};
1186 if ( $conf->exists("svc_acct-usage_$action")
1187 && &{$op2condition{$op}}($self, $seconds) ) {
1188 #my $error = $self->$action();
1189 my $error = $self->cust_svc->cust_pkg->$action();
1191 $dbh->rollback if $oldAutoCommit;
1192 return "Error ${action}ing: $error";
1196 warn "$me update sucessful; committing\n"
1198 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1204 =item seconds_since TIMESTAMP
1206 Returns the number of seconds this account has been online since TIMESTAMP,
1207 according to the session monitor (see L<FS::Session>).
1209 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1210 L<Time::Local> and L<Date::Parse> for conversion functions.
1214 #note: POD here, implementation in FS::cust_svc
1217 $self->cust_svc->seconds_since(@_);
1220 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1222 Returns the numbers of seconds this account has been online between
1223 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1224 external SQL radacct table, specified via sqlradius export. Sessions which
1225 started in the specified range but are still open are counted from session
1226 start to the end of the range (unless they are over 1 day old, in which case
1227 they are presumed missing their stop record and not counted). Also, sessions
1228 which end in the range but started earlier are counted from the start of the
1229 range to session end. Finally, sessions which start before the range but end
1230 after are counted for the entire range.
1232 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1233 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1238 #note: POD here, implementation in FS::cust_svc
1239 sub seconds_since_sqlradacct {
1241 $self->cust_svc->seconds_since_sqlradacct(@_);
1244 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1246 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1247 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1248 TIMESTAMP_END (exclusive).
1250 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1251 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1256 #note: POD here, implementation in FS::cust_svc
1257 sub attribute_since_sqlradacct {
1259 $self->cust_svc->attribute_since_sqlradacct(@_);
1262 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1264 Returns an array of hash references of this customers login history for the
1265 given time range. (document this better)
1269 sub get_session_history {
1271 $self->cust_svc->get_session_history(@_);
1276 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1282 if ( $self->usergroup ) {
1283 #when provisioning records, export callback runs in svc_Common.pm before
1284 #radius_usergroup records can be inserted...
1285 @{$self->usergroup};
1287 map { $_->groupname }
1288 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1292 =item clone_suspended
1294 Constructor used by FS::part_export::_export_suspend fallback. Document
1299 sub clone_suspended {
1301 my %hash = $self->hash;
1302 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1303 new FS::svc_acct \%hash;
1306 =item clone_kludge_unsuspend
1308 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1313 sub clone_kludge_unsuspend {
1315 my %hash = $self->hash;
1316 $hash{_password} = '';
1317 new FS::svc_acct \%hash;
1320 =item check_password
1322 Checks the supplied password against the (possibly encrypted) password in the
1323 database. Returns true for a sucessful authentication, false for no match.
1325 Currently supported encryptions are: classic DES crypt() and MD5
1329 sub check_password {
1330 my($self, $check_password) = @_;
1332 #remove old-style SUSPENDED kludge, they should be allowed to login to
1333 #self-service and pay up
1334 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1336 #eventually should check a "password-encoding" field
1337 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1339 } elsif ( length($password) < 13 ) { #plaintext
1340 $check_password eq $password;
1341 } elsif ( length($password) == 13 ) { #traditional DES crypt
1342 crypt($check_password, $password) eq $password;
1343 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1344 unix_md5_crypt($check_password, $password) eq $password;
1345 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1346 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1347 $self->svcnum. "\n";
1350 warn "Can't check password: Unrecognized encryption for svcnum ".
1351 $self->svcnum. "\n";
1357 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1359 Returns an encrypted password, either by passing through an encrypted password
1360 in the database or by encrypting a plaintext password from the database.
1362 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1363 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1364 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1365 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
1366 encryption type is only used if the password is not already encrypted in the
1371 sub crypt_password {
1373 #eventually should check a "password-encoding" field
1374 if ( length($self->_password) == 13
1375 || $self->_password =~ /^\$(1|2a?)\$/
1376 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1381 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1382 if ( $encryption eq 'crypt' ) {
1385 $saltset[int(rand(64))].$saltset[int(rand(64))]
1387 } elsif ( $encryption eq 'md5' ) {
1388 unix_md5_crypt( $self->_password );
1389 } elsif ( $encryption eq 'blowfish' ) {
1390 die "unknown encryption method $encryption";
1392 die "unknown encryption method $encryption";
1397 =item virtual_maildir
1399 Returns $domain/maildirs/$username/
1403 sub virtual_maildir {
1405 $self->domain. '/maildirs/'. $self->username. '/';
1416 This is the FS::svc_acct job-queue-able version. It still uses
1417 FS::Misc::send_email under-the-hood.
1424 eval "use FS::Misc qw(send_email)";
1427 $opt{mimetype} ||= 'text/plain';
1428 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1430 my $error = send_email(
1431 'from' => $opt{from},
1433 'subject' => $opt{subject},
1434 'content-type' => $opt{mimetype},
1435 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1437 die $error if $error;
1440 =item check_and_rebuild_fuzzyfiles
1444 sub check_and_rebuild_fuzzyfiles {
1445 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1446 -e "$dir/svc_acct.username"
1447 or &rebuild_fuzzyfiles;
1450 =item rebuild_fuzzyfiles
1454 sub rebuild_fuzzyfiles {
1456 use Fcntl qw(:flock);
1458 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1462 open(USERNAMELOCK,">>$dir/svc_acct.username")
1463 or die "can't open $dir/svc_acct.username: $!";
1464 flock(USERNAMELOCK,LOCK_EX)
1465 or die "can't lock $dir/svc_acct.username: $!";
1467 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1469 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1470 or die "can't open $dir/svc_acct.username.tmp: $!";
1471 print USERNAMECACHE join("\n", @all_username), "\n";
1472 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1474 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1484 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1485 open(USERNAMECACHE,"<$dir/svc_acct.username")
1486 or die "can't open $dir/svc_acct.username: $!";
1487 my @array = map { chomp; $_; } <USERNAMECACHE>;
1488 close USERNAMECACHE;
1492 =item append_fuzzyfiles USERNAME
1496 sub append_fuzzyfiles {
1497 my $username = shift;
1499 &check_and_rebuild_fuzzyfiles;
1501 use Fcntl qw(:flock);
1503 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1505 open(USERNAME,">>$dir/svc_acct.username")
1506 or die "can't open $dir/svc_acct.username: $!";
1507 flock(USERNAME,LOCK_EX)
1508 or die "can't lock $dir/svc_acct.username: $!";
1510 print USERNAME "$username\n";
1512 flock(USERNAME,LOCK_UN)
1513 or die "can't unlock $dir/svc_acct.username: $!";
1521 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1525 sub radius_usergroup_selector {
1526 my $sel_groups = shift;
1527 my %sel_groups = map { $_=>1 } @$sel_groups;
1529 my $selectname = shift || 'radius_usergroup';
1532 my $sth = $dbh->prepare(
1533 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1534 ) or die $dbh->errstr;
1535 $sth->execute() or die $sth->errstr;
1536 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1540 function ${selectname}_doadd(object) {
1541 var myvalue = object.${selectname}_add.value;
1542 var optionName = new Option(myvalue,myvalue,false,true);
1543 var length = object.$selectname.length;
1544 object.$selectname.options[length] = optionName;
1545 object.${selectname}_add.value = "";
1548 <SELECT MULTIPLE NAME="$selectname">
1551 foreach my $group ( @all_groups ) {
1552 $html .= qq(<OPTION VALUE="$group");
1553 if ( $sel_groups{$group} ) {
1554 $html .= ' SELECTED';
1555 $sel_groups{$group} = 0;
1557 $html .= ">$group</OPTION>\n";
1559 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1560 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1562 $html .= '</SELECT>';
1564 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1565 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1574 The $recref stuff in sub check should be cleaned up.
1576 The suspend, unsuspend and cancel methods update the database, but not the
1577 current object. This is probably a bug as it's unexpected and
1580 radius_usergroup_selector? putting web ui components in here? they should
1581 probably live somewhere else...
1583 insertion of RADIUS group stuff in insert could be done with child_objects now
1584 (would probably clean up export of them too)
1588 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1589 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1590 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1591 L<freeside-queued>), L<FS::svc_acct_pop>,
1592 schema.html from the base documentation.