4 use vars qw( @ISA $DEBUG $me $conf
5 $dir_prefix @shells $usernamemin
6 $usernamemax $passwordmin $passwordmax
7 $username_ampersand $username_letter $username_letterfirst
8 $username_noperiod $username_nounderscore $username_nodash
10 $password_noampersand $password_noexclamation
11 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
13 $radius_password $radius_ip
19 use FS::UID qw( datasrc );
21 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
26 use FS::cust_main_invoice;
30 use FS::radius_usergroup;
33 use FS::Msgcat qw(gettext);
37 @ISA = qw( FS::svc_Common );
41 $me = '[FS::svc_acct]';
43 #ask FS::UID to run this stuff for us later
44 $FS::UID::callback{'FS::svc_acct'} = sub {
46 $dir_prefix = $conf->config('home');
47 @shells = $conf->config('shells');
48 $usernamemin = $conf->config('usernamemin') || 2;
49 $usernamemax = $conf->config('usernamemax');
50 $passwordmin = $conf->config('passwordmin') || 6;
51 $passwordmax = $conf->config('passwordmax') || 8;
52 $username_letter = $conf->exists('username-letter');
53 $username_letterfirst = $conf->exists('username-letterfirst');
54 $username_noperiod = $conf->exists('username-noperiod');
55 $username_nounderscore = $conf->exists('username-nounderscore');
56 $username_nodash = $conf->exists('username-nodash');
57 $username_uppercase = $conf->exists('username-uppercase');
58 $username_ampersand = $conf->exists('username-ampersand');
59 $password_noampersand = $conf->exists('password-noexclamation');
60 $password_noexclamation = $conf->exists('password-noexclamation');
61 $dirhash = $conf->config('dirhash') || 0;
62 if ( $conf->exists('welcome_email') ) {
63 $welcome_template = new Text::Template (
65 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
66 ) or warn "can't create welcome email template: $Text::Template::ERROR";
67 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
68 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
69 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
71 $welcome_template = '';
73 $welcome_subject = '';
74 $welcome_mimetype = '';
76 $smtpmachine = $conf->config('smtpmachine');
77 $radius_password = $conf->config('radius-password') || 'Password';
78 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
81 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
82 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
86 my ( $hashref, $cache ) = @_;
87 if ( $hashref->{'svc_acct_svcnum'} ) {
88 $self->{'_domsvc'} = FS::svc_domain->new( {
89 'svcnum' => $hashref->{'domsvc'},
90 'domain' => $hashref->{'svc_acct_domain'},
91 'catchall' => $hashref->{'svc_acct_catchall'},
98 FS::svc_acct - Object methods for svc_acct records
104 $record = new FS::svc_acct \%hash;
105 $record = new FS::svc_acct { 'column' => 'value' };
107 $error = $record->insert;
109 $error = $new_record->replace($old_record);
111 $error = $record->delete;
113 $error = $record->check;
115 $error = $record->suspend;
117 $error = $record->unsuspend;
119 $error = $record->cancel;
121 %hash = $record->radius;
123 %hash = $record->radius_reply;
125 %hash = $record->radius_check;
127 $domain = $record->domain;
129 $svc_domain = $record->svc_domain;
131 $email = $record->email;
133 $seconds_since = $record->seconds_since($timestamp);
137 An FS::svc_acct object represents an account. FS::svc_acct inherits from
138 FS::svc_Common. The following fields are currently supported:
142 =item svcnum - primary key (assigned automatcially for new accounts)
146 =item _password - generated if blank
148 =item sec_phrase - security phrase
150 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
158 =item dir - set automatically if blank (and uid is not)
162 =item quota - (unimplementd)
164 =item slipip - IP address
168 =item domsvc - svcnum from svc_domain
170 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
180 Creates a new account. To add the account to the database, see L<"insert">.
184 sub table { 'svc_acct'; }
186 =item insert [ , OPTION => VALUE ... ]
188 Adds this account to the database. If there is an error, returns the error,
189 otherwise returns false.
191 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
192 defined. An FS::cust_svc record will be created and inserted.
194 The additional field I<usergroup> can optionally be defined; if so it should
195 contain an arrayref of group names. See L<FS::radius_usergroup>.
197 The additional field I<child_objects> can optionally be defined; if so it
198 should contain an arrayref of FS::tablename objects. They will have their
199 svcnum fields set and will be inserted after this record, but before any
202 Currently available options are: I<depend_jobnum>
204 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
205 jobnums), all provisioning jobs will have a dependancy on the supplied
206 jobnum(s) (they will not run until the specific job(s) complete(s)).
208 (TODOC: L<FS::queue> and L<freeside-queued>)
210 (TODOC: new exports!)
219 local $SIG{HUP} = 'IGNORE';
220 local $SIG{INT} = 'IGNORE';
221 local $SIG{QUIT} = 'IGNORE';
222 local $SIG{TERM} = 'IGNORE';
223 local $SIG{TSTP} = 'IGNORE';
224 local $SIG{PIPE} = 'IGNORE';
226 my $oldAutoCommit = $FS::UID::AutoCommit;
227 local $FS::UID::AutoCommit = 0;
230 $error = $self->check;
231 return $error if $error;
233 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
234 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
235 unless ( $cust_svc ) {
236 $dbh->rollback if $oldAutoCommit;
237 return "no cust_svc record found for svcnum ". $self->svcnum;
239 $self->pkgnum($cust_svc->pkgnum);
240 $self->svcpart($cust_svc->svcpart);
243 $error = $self->_check_duplicate;
245 $dbh->rollback if $oldAutoCommit;
250 $error = $self->SUPER::insert(
251 'jobnums' => \@jobnums,
252 'child_objects' => $self->child_objects,
256 $dbh->rollback if $oldAutoCommit;
260 if ( $self->usergroup ) {
261 foreach my $groupname ( @{$self->usergroup} ) {
262 my $radius_usergroup = new FS::radius_usergroup ( {
263 svcnum => $self->svcnum,
264 groupname => $groupname,
266 my $error = $radius_usergroup->insert;
268 $dbh->rollback if $oldAutoCommit;
274 #false laziness with sub replace (and cust_main)
275 my $queue = new FS::queue {
276 'svcnum' => $self->svcnum,
277 'job' => 'FS::svc_acct::append_fuzzyfiles'
279 $error = $queue->insert($self->username);
281 $dbh->rollback if $oldAutoCommit;
282 return "queueing job (transaction rolled back): $error";
285 my $cust_pkg = $self->cust_svc->cust_pkg;
288 my $cust_main = $cust_pkg->cust_main;
290 if ( $conf->exists('emailinvoiceauto') ) {
291 my @invoicing_list = $cust_main->invoicing_list;
292 push @invoicing_list, $self->email;
293 $cust_main->invoicing_list(\@invoicing_list);
298 if ( $welcome_template && $cust_pkg ) {
299 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
301 my $wqueue = new FS::queue {
302 'svcnum' => $self->svcnum,
303 'job' => 'FS::svc_acct::send_email'
305 my $error = $wqueue->insert(
307 'from' => $welcome_from,
308 'subject' => $welcome_subject,
309 'mimetype' => $welcome_mimetype,
310 'body' => $welcome_template->fill_in( HASH => {
311 'custnum' => $self->custnum,
312 'username' => $self->username,
313 'password' => $self->_password,
314 'first' => $cust_main->first,
315 'last' => $cust_main->getfield('last'),
316 'pkg' => $cust_pkg->part_pkg->pkg,
320 $dbh->rollback if $oldAutoCommit;
321 return "error queuing welcome email: $error";
324 if ( $options{'depend_jobnum'} ) {
325 warn "$me depend_jobnum found; adding to welcome email dependancies"
327 if ( ref($options{'depend_jobnum'}) ) {
328 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
329 "to welcome email dependancies"
331 push @jobnums, @{ $options{'depend_jobnum'} };
333 warn "$me adding job $options{'depend_jobnum'} ".
334 "to welcome email dependancies"
336 push @jobnums, $options{'depend_jobnum'};
340 foreach my $jobnum ( @jobnums ) {
341 my $error = $wqueue->depend_insert($jobnum);
343 $dbh->rollback if $oldAutoCommit;
344 return "error queuing welcome email job dependancy: $error";
354 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
360 Deletes this account from the database. If there is an error, returns the
361 error, otherwise returns false.
363 The corresponding FS::cust_svc record will be deleted as well.
365 (TODOC: new exports!)
372 return "can't delete system account" if $self->_check_system;
374 return "Can't delete an account which is a (svc_forward) source!"
375 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
377 return "Can't delete an account which is a (svc_forward) destination!"
378 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
380 return "Can't delete an account with (svc_www) web service!"
381 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
383 # what about records in session ? (they should refer to history table)
385 local $SIG{HUP} = 'IGNORE';
386 local $SIG{INT} = 'IGNORE';
387 local $SIG{QUIT} = 'IGNORE';
388 local $SIG{TERM} = 'IGNORE';
389 local $SIG{TSTP} = 'IGNORE';
390 local $SIG{PIPE} = 'IGNORE';
392 my $oldAutoCommit = $FS::UID::AutoCommit;
393 local $FS::UID::AutoCommit = 0;
396 foreach my $cust_main_invoice (
397 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
399 unless ( defined($cust_main_invoice) ) {
400 warn "WARNING: something's wrong with qsearch";
403 my %hash = $cust_main_invoice->hash;
404 $hash{'dest'} = $self->email;
405 my $new = new FS::cust_main_invoice \%hash;
406 my $error = $new->replace($cust_main_invoice);
408 $dbh->rollback if $oldAutoCommit;
413 foreach my $svc_domain (
414 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
416 my %hash = new FS::svc_domain->hash;
417 $hash{'catchall'} = '';
418 my $new = new FS::svc_domain \%hash;
419 my $error = $new->replace($svc_domain);
421 $dbh->rollback if $oldAutoCommit;
426 foreach my $radius_usergroup (
427 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
429 my $error = $radius_usergroup->delete;
431 $dbh->rollback if $oldAutoCommit;
436 my $error = $self->SUPER::delete;
438 $dbh->rollback if $oldAutoCommit;
442 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
446 =item replace OLD_RECORD
448 Replaces OLD_RECORD with this one in the database. If there is an error,
449 returns the error, otherwise returns false.
451 The additional field I<usergroup> can optionally be defined; if so it should
452 contain an arrayref of group names. See L<FS::radius_usergroup>.
458 my ( $new, $old ) = ( shift, shift );
460 warn "$me replacing $old with $new\n" if $DEBUG;
462 return "can't modify system account" if $old->_check_system;
464 return "Username in use"
465 if $old->username ne $new->username &&
466 qsearchs( 'svc_acct', { 'username' => $new->username,
467 'domsvc' => $new->domsvc,
470 #no warnings 'numeric'; #alas, a 5.006-ism
472 return "Can't change uid!" if $old->uid != $new->uid;
475 #change homdir when we change username
476 $new->setfield('dir', '') if $old->username ne $new->username;
478 local $SIG{HUP} = 'IGNORE';
479 local $SIG{INT} = 'IGNORE';
480 local $SIG{QUIT} = 'IGNORE';
481 local $SIG{TERM} = 'IGNORE';
482 local $SIG{TSTP} = 'IGNORE';
483 local $SIG{PIPE} = 'IGNORE';
485 my $oldAutoCommit = $FS::UID::AutoCommit;
486 local $FS::UID::AutoCommit = 0;
489 # redundant, but so $new->usergroup gets set
490 $error = $new->check;
491 return $error if $error;
493 $old->usergroup( [ $old->radius_groups ] );
494 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
495 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
496 if ( $new->usergroup ) {
497 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
498 my @newgroups = @{$new->usergroup};
499 foreach my $oldgroup ( @{$old->usergroup} ) {
500 if ( grep { $oldgroup eq $_ } @newgroups ) {
501 @newgroups = grep { $oldgroup ne $_ } @newgroups;
504 my $radius_usergroup = qsearchs('radius_usergroup', {
505 svcnum => $old->svcnum,
506 groupname => $oldgroup,
508 my $error = $radius_usergroup->delete;
510 $dbh->rollback if $oldAutoCommit;
511 return "error deleting radius_usergroup $oldgroup: $error";
515 foreach my $newgroup ( @newgroups ) {
516 my $radius_usergroup = new FS::radius_usergroup ( {
517 svcnum => $new->svcnum,
518 groupname => $newgroup,
520 my $error = $radius_usergroup->insert;
522 $dbh->rollback if $oldAutoCommit;
523 return "error adding radius_usergroup $newgroup: $error";
529 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
530 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
531 $error = $new->_check_duplicate;
533 $dbh->rollback if $oldAutoCommit;
538 $error = $new->SUPER::replace($old);
540 $dbh->rollback if $oldAutoCommit;
541 return $error if $error;
544 if ( $new->username ne $old->username ) {
545 #false laziness with sub insert (and cust_main)
546 my $queue = new FS::queue {
547 'svcnum' => $new->svcnum,
548 'job' => 'FS::svc_acct::append_fuzzyfiles'
550 $error = $queue->insert($new->username);
552 $dbh->rollback if $oldAutoCommit;
553 return "queueing job (transaction rolled back): $error";
557 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
563 Suspends this account by calling export-specific suspend hooks. If there is
564 an error, returns the error, otherwise returns false.
566 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
572 return "can't suspend system account" if $self->_check_system;
573 $self->SUPER::suspend;
578 Unsuspends this account by by calling export-specific suspend hooks. If there
579 is an error, returns the error, otherwise returns false.
581 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
587 my %hash = $self->hash;
588 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
589 $hash{_password} = $1;
590 my $new = new FS::svc_acct ( \%hash );
591 my $error = $new->replace($self);
592 return $error if $error;
595 $self->SUPER::unsuspend;
600 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
602 If the B<auto_unset_catchall> configuration option is set, this method will
603 automatically remove any references to the canceled service in the catchall
604 field of svc_domain. This allows packages that contain both a svc_domain and
605 its catchall svc_acct to be canceled in one step.
610 # Only one thing to do at this level
612 foreach my $svc_domain (
613 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
614 if($conf->exists('auto_unset_catchall')) {
615 my %hash = $svc_domain->hash;
616 $hash{catchall} = '';
617 my $new = new FS::svc_domain ( \%hash );
618 my $error = $new->replace($svc_domain);
619 return $error if $error;
621 return "cannot unprovision svc_acct #".$self->svcnum.
622 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
626 $self->SUPER::cancel;
632 Checks all fields to make sure this is a valid service. If there is an error,
633 returns the error, otherwise returns false. Called by the insert and replace
636 Sets any fixed values; see L<FS::part_svc>.
643 my($recref) = $self->hashref;
645 my $x = $self->setfixed;
646 return $x unless ref($x);
649 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
651 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
654 my $error = $self->ut_numbern('svcnum')
655 #|| $self->ut_number('domsvc')
656 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
657 || $self->ut_textn('sec_phrase')
659 return $error if $error;
661 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
662 if ( $username_uppercase ) {
663 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
664 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
665 $recref->{username} = $1;
667 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
668 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
669 $recref->{username} = $1;
672 if ( $username_letterfirst ) {
673 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
674 } elsif ( $username_letter ) {
675 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
677 if ( $username_noperiod ) {
678 $recref->{username} =~ /\./ and return gettext('illegal_username');
680 if ( $username_nounderscore ) {
681 $recref->{username} =~ /_/ and return gettext('illegal_username');
683 if ( $username_nodash ) {
684 $recref->{username} =~ /\-/ and return gettext('illegal_username');
686 unless ( $username_ampersand ) {
687 $recref->{username} =~ /\&/ and return gettext('illegal_username');
689 if ( $password_noampersand ) {
690 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
692 if ( $password_noexclamation ) {
693 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
696 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
697 $recref->{popnum} = $1;
698 return "Unknown popnum" unless
699 ! $recref->{popnum} ||
700 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
702 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
704 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
705 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
707 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
708 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
709 #not all systems use gid=uid
710 #you can set a fixed gid in part_svc
712 return "Only root can have uid 0"
713 if $recref->{uid} == 0
714 && $recref->{username} !~ /^(root|toor|smtp)$/;
716 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
717 or return "Illegal directory: ". $recref->{dir};
719 return "Illegal directory"
720 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
721 return "Illegal directory"
722 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
723 unless ( $recref->{dir} ) {
724 $recref->{dir} = $dir_prefix . '/';
725 if ( $dirhash > 0 ) {
726 for my $h ( 1 .. $dirhash ) {
727 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
729 } elsif ( $dirhash < 0 ) {
730 for my $h ( reverse $dirhash .. -1 ) {
731 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
734 $recref->{dir} .= $recref->{username};
738 unless ( $recref->{username} eq 'sync' ) {
739 if ( grep $_ eq $recref->{shell}, @shells ) {
740 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
742 return "Illegal shell \`". $self->shell. "\'; ".
743 $conf->dir. "/shells contains: @shells";
746 $recref->{shell} = '/bin/sync';
750 $recref->{gid} ne '' ?
751 return "Can't have gid without uid" : ( $recref->{gid}='' );
752 $recref->{dir} ne '' ?
753 return "Can't have directory without uid" : ( $recref->{dir}='' );
754 $recref->{shell} ne '' ?
755 return "Can't have shell without uid" : ( $recref->{shell}='' );
758 # $error = $self->ut_textn('finger');
759 # return $error if $error;
760 if ( $self->getfield('finger') eq '' ) {
761 my $cust_pkg = $self->svcnum
762 ? $self->cust_svc->cust_pkg
763 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
765 my $cust_main = $cust_pkg->cust_main;
766 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
769 $self->getfield('finger') =~
770 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
771 or return "Illegal finger: ". $self->getfield('finger');
772 $self->setfield('finger', $1);
774 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
775 $recref->{quota} = $1;
777 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
778 if ( $recref->{slipip} eq '' ) {
779 $recref->{slipip} = '';
780 } elsif ( $recref->{slipip} eq '0e0' ) {
781 $recref->{slipip} = '0e0';
783 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
784 or return "Illegal slipip: ". $self->slipip;
785 $recref->{slipip} = $1;
790 #arbitrary RADIUS stuff; allow ut_textn for now
791 foreach ( grep /^radius_/, fields('svc_acct') ) {
795 #generate a password if it is blank
796 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
797 unless ( $recref->{_password} );
799 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
800 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
801 $recref->{_password} = $1.$3;
802 #uncomment this to encrypt password immediately upon entry, or run
803 #bin/crypt_pw in cron to give new users a window during which their
804 #password is available to techs, for faxing, etc. (also be aware of
806 #$recref->{password} = $1.
807 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
809 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
810 $recref->{_password} = $1.$3;
811 } elsif ( $recref->{_password} eq '*' ) {
812 $recref->{_password} = '*';
813 } elsif ( $recref->{_password} eq '!' ) {
814 $recref->{_password} = '!';
815 } elsif ( $recref->{_password} eq '!!' ) {
816 $recref->{_password} = '!!';
818 #return "Illegal password";
819 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
820 FS::Msgcat::_gettext('illegal_password_characters').
821 ": ". $recref->{_password};
829 Internal function to check the username against the list of system usernames
830 from the I<system_usernames> configuration value. Returns true if the username
831 is listed on the system username list.
837 scalar( grep { $self->username eq $_ || $self->email eq $_ }
838 $conf->config('system_usernames')
842 =item _check_duplicate
844 Internal function to check for duplicates usernames, username@domain pairs and
847 If the I<global_unique-username> configuration value is set to B<username> or
848 B<username@domain>, enforces global username or username@domain uniqueness.
850 In all cases, check for duplicate uids and usernames or username@domain pairs
851 per export and with identical I<svcpart> values.
855 sub _check_duplicate {
858 #this is Pg-specific. what to do for mysql etc?
859 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
860 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
861 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
863 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
865 my $svcpart = $self->svcpart;
866 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
867 unless ( $part_svc ) {
868 return 'unknown svcpart '. $self->svcpart;
871 my $global_unique = $conf->config('global_unique-username');
873 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
874 qsearch( 'svc_acct', { 'username' => $self->username } );
875 return gettext('username_in_use')
876 if $global_unique eq 'username' && @dup_user;
878 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
879 qsearch( 'svc_acct', { 'username' => $self->username,
880 'domsvc' => $self->domsvc } );
881 return gettext('username_in_use')
882 if $global_unique eq 'username@domain' && @dup_userdomain;
885 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
886 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
887 @dup_uid = grep { $svcpart != $_->svcpart }
888 qsearch( 'svc_acct', { 'uid' => $self->uid } );
893 if ( @dup_user || @dup_userdomain || @dup_uid ) {
894 my $exports = FS::part_export::export_info('svc_acct');
895 my %conflict_user_svcpart;
896 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
898 foreach my $part_export ( $part_svc->part_export ) {
900 #this will catch to the same exact export
901 my @svcparts = map { $_->svcpart } $part_export->export_svc;
903 #this will catch to exports w/same exporthost+type ???
904 #my @other_part_export = qsearch('part_export', {
905 # 'machine' => $part_export->machine,
906 # 'exporttype' => $part_export->exporttype,
908 #foreach my $other_part_export ( @other_part_export ) {
909 # push @svcparts, map { $_->svcpart }
910 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
913 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
914 #silly kludge to avoid uninitialized value errors
915 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
916 ? $exports->{$part_export->exporttype}{'nodomain'}
918 if ( $nodomain =~ /^Y/i ) {
919 $conflict_user_svcpart{$_} = $part_export->exportnum
922 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
927 foreach my $dup_user ( @dup_user ) {
928 my $dup_svcpart = $dup_user->cust_svc->svcpart;
929 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
930 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
931 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
935 foreach my $dup_userdomain ( @dup_userdomain ) {
936 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
937 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
938 return "duplicate username\@domain: conflicts with svcnum ".
939 $dup_userdomain->svcnum. " via exportnum ".
940 $conflict_userdomain_svcpart{$dup_svcpart};
944 foreach my $dup_uid ( @dup_uid ) {
945 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
946 if ( exists($conflict_user_svcpart{$dup_svcpart})
947 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
948 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
949 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
950 || $conflict_userdomain_svcpart{$dup_svcpart};
962 Depriciated, use radius_reply instead.
967 carp "FS::svc_acct::radius depriciated, use radius_reply";
973 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
974 reply attributes of this record.
976 Note that this is now the preferred method for reading RADIUS attributes -
977 accessing the columns directly is discouraged, as the column names are
978 expected to change in the future.
987 my($column, $attrib) = ($1, $2);
988 #$attrib =~ s/_/\-/g;
989 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
990 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
991 if ( $self->slipip && $self->slipip ne '0e0' ) {
992 $reply{$radius_ip} = $self->slipip;
999 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1000 check 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.
1010 my $password = $self->_password;
1011 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1012 ( $pw_attrib => $password,
1015 my($column, $attrib) = ($1, $2);
1016 #$attrib =~ s/_/\-/g;
1017 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1018 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
1024 Returns the domain associated with this account.
1030 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1031 my $svc_domain = $self->svc_domain(@_)
1032 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1033 $svc_domain->domain;
1038 Returns the FS::svc_domain record for this account's domain (see
1046 ? $self->{'_domsvc'}
1047 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1052 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1058 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1063 Returns an email address associated with the account.
1069 $self->username. '@'. $self->domain(@_);
1074 Returns an array of FS::acct_snarf records associated with the account.
1075 If the acct_snarf table does not exist or there are no associated records,
1076 an empty list is returned
1082 return () unless dbdef->table('acct_snarf');
1083 eval "use FS::acct_snarf;";
1085 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1088 =item seconds_since TIMESTAMP
1090 Returns the number of seconds this account has been online since TIMESTAMP,
1091 according to the session monitor (see L<FS::Session>).
1093 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1094 L<Time::Local> and L<Date::Parse> for conversion functions.
1098 #note: POD here, implementation in FS::cust_svc
1101 $self->cust_svc->seconds_since(@_);
1104 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1106 Returns the numbers of seconds this account has been online between
1107 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1108 external SQL radacct table, specified via sqlradius export. Sessions which
1109 started in the specified range but are still open are counted from session
1110 start to the end of the range (unless they are over 1 day old, in which case
1111 they are presumed missing their stop record and not counted). Also, sessions
1112 which end in the range but started earlier are counted from the start of the
1113 range to session end. Finally, sessions which start before the range but end
1114 after are counted for the entire range.
1116 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1117 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1122 #note: POD here, implementation in FS::cust_svc
1123 sub seconds_since_sqlradacct {
1125 $self->cust_svc->seconds_since_sqlradacct(@_);
1128 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1130 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1131 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1132 TIMESTAMP_END (exclusive).
1134 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1135 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1140 #note: POD here, implementation in FS::cust_svc
1141 sub attribute_since_sqlradacct {
1143 $self->cust_svc->attribute_since_sqlradacct(@_);
1146 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1148 Returns an array of hash references of this customers login history for the
1149 given time range. (document this better)
1153 sub get_session_history_sqlradacct {
1155 $self->cust_svc->get_session_history_sqlradacct(@_);
1160 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1166 if ( $self->usergroup ) {
1167 #when provisioning records, export callback runs in svc_Common.pm before
1168 #radius_usergroup records can be inserted...
1169 @{$self->usergroup};
1171 map { $_->groupname }
1172 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1176 =item clone_suspended
1178 Constructor used by FS::part_export::_export_suspend fallback. Document
1183 sub clone_suspended {
1185 my %hash = $self->hash;
1186 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1187 new FS::svc_acct \%hash;
1190 =item clone_kludge_unsuspend
1192 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1197 sub clone_kludge_unsuspend {
1199 my %hash = $self->hash;
1200 $hash{_password} = '';
1201 new FS::svc_acct \%hash;
1204 =item check_password
1206 Checks the supplied password against the (possibly encrypted) password in the
1207 database. Returns true for a sucessful authentication, false for no match.
1209 Currently supported encryptions are: classic DES crypt() and MD5
1213 sub check_password {
1214 my($self, $check_password) = @_;
1216 #remove old-style SUSPENDED kludge, they should be allowed to login to
1217 #self-service and pay up
1218 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1220 #eventually should check a "password-encoding" field
1221 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1223 } elsif ( length($password) < 13 ) { #plaintext
1224 $check_password eq $password;
1225 } elsif ( length($password) == 13 ) { #traditional DES crypt
1226 crypt($check_password, $password) eq $password;
1227 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1228 unix_md5_crypt($check_password, $password) eq $password;
1229 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1230 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1231 $self->svcnum. "\n";
1234 warn "Can't check password: Unrecognized encryption for svcnum ".
1235 $self->svcnum. "\n";
1241 =item crypt_password
1243 Returns an encrypted password, either by passing through an encrypted password
1244 in the database or by encrypting a plaintext password from the database.
1248 sub crypt_password {
1250 #false laziness w/shellcommands.pm
1251 #eventually should check a "password-encoding" field
1252 if ( length($self->_password) == 13
1253 || $self->_password =~ /^\$(1|2a?)\$/ ) {
1258 $saltset[int(rand(64))].$saltset[int(rand(64))]
1263 =item virtual_maildir
1265 Returns $domain/maildirs/$username/
1269 sub virtual_maildir {
1271 $self->domain. '/maildirs/'. $self->username. '/';
1282 This is the FS::svc_acct job-queue-able version. It still uses
1283 FS::Misc::send_email under-the-hood.
1290 eval "use FS::Misc qw(send_email)";
1293 $opt{mimetype} ||= 'text/plain';
1294 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1296 my $error = send_email(
1297 'from' => $opt{from},
1299 'subject' => $opt{subject},
1300 'content-type' => $opt{mimetype},
1301 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1303 die $error if $error;
1306 =item check_and_rebuild_fuzzyfiles
1310 sub check_and_rebuild_fuzzyfiles {
1311 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1312 -e "$dir/svc_acct.username"
1313 or &rebuild_fuzzyfiles;
1316 =item rebuild_fuzzyfiles
1320 sub rebuild_fuzzyfiles {
1322 use Fcntl qw(:flock);
1324 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1328 open(USERNAMELOCK,">>$dir/svc_acct.username")
1329 or die "can't open $dir/svc_acct.username: $!";
1330 flock(USERNAMELOCK,LOCK_EX)
1331 or die "can't lock $dir/svc_acct.username: $!";
1333 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1335 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1336 or die "can't open $dir/svc_acct.username.tmp: $!";
1337 print USERNAMECACHE join("\n", @all_username), "\n";
1338 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1340 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1350 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1351 open(USERNAMECACHE,"<$dir/svc_acct.username")
1352 or die "can't open $dir/svc_acct.username: $!";
1353 my @array = map { chomp; $_; } <USERNAMECACHE>;
1354 close USERNAMECACHE;
1358 =item append_fuzzyfiles USERNAME
1362 sub append_fuzzyfiles {
1363 my $username = shift;
1365 &check_and_rebuild_fuzzyfiles;
1367 use Fcntl qw(:flock);
1369 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1371 open(USERNAME,">>$dir/svc_acct.username")
1372 or die "can't open $dir/svc_acct.username: $!";
1373 flock(USERNAME,LOCK_EX)
1374 or die "can't lock $dir/svc_acct.username: $!";
1376 print USERNAME "$username\n";
1378 flock(USERNAME,LOCK_UN)
1379 or die "can't unlock $dir/svc_acct.username: $!";
1387 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1391 sub radius_usergroup_selector {
1392 my $sel_groups = shift;
1393 my %sel_groups = map { $_=>1 } @$sel_groups;
1395 my $selectname = shift || 'radius_usergroup';
1398 my $sth = $dbh->prepare(
1399 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1400 ) or die $dbh->errstr;
1401 $sth->execute() or die $sth->errstr;
1402 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1406 function ${selectname}_doadd(object) {
1407 var myvalue = object.${selectname}_add.value;
1408 var optionName = new Option(myvalue,myvalue,false,true);
1409 var length = object.$selectname.length;
1410 object.$selectname.options[length] = optionName;
1411 object.${selectname}_add.value = "";
1414 <SELECT MULTIPLE NAME="$selectname">
1417 foreach my $group ( @all_groups ) {
1419 if ( $sel_groups{$group} ) {
1420 $html .= ' SELECTED';
1421 $sel_groups{$group} = 0;
1423 $html .= ">$group</OPTION>\n";
1425 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1426 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1428 $html .= '</SELECT>';
1430 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1431 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1440 The $recref stuff in sub check should be cleaned up.
1442 The suspend, unsuspend and cancel methods update the database, but not the
1443 current object. This is probably a bug as it's unexpected and
1446 radius_usergroup_selector? putting web ui components in here? they should
1447 probably live somewhere else...
1449 insertion of RADIUS group stuff in insert could be done with child_objects now
1450 (would probably clean up export of them too)
1454 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1455 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1456 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1457 L<freeside-queued>), L<FS::svc_acct_pop>,
1458 schema.html from the base documentation.