@saltset @pw_set );
use Carp;
use Fcntl qw(:flock);
+use Crypt::PasswdMD5;
use FS::UID qw( datasrc );
use FS::Conf;
use FS::Record qw( qsearch qsearchs fields dbh dbdef );
use FS::export_svc;
use FS::part_export;
use FS::Msgcat qw(gettext);
+use FS::svc_forward;
+use FS::svc_www;
@ISA = qw( FS::svc_Common );
$DEBUG = 0;
+#$DEBUG = 1;
$me = '[FS::svc_acct]';
#ask FS::UID to run this stuff for us later
sub table { 'svc_acct'; }
-=item insert
+=item insert [ , OPTION => VALUE ... ]
Adds this account to the database. If there is an error, returns the error,
otherwise returns false.
defined. An FS::cust_svc record will be created and inserted.
The additional field I<usergroup> can optionally be defined; if so it should
-contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
-sqlradius export only)
+contain an arrayref of group names. See L<FS::radius_usergroup>.
The additional field I<child_objects> can optionally be defined; if so it
should contain an arrayref of FS::tablename objects. They will have their
svcnum fields set and will be inserted after this record, but before any
exports are run.
+Currently available options are: I<depend_jobnum>
+
+If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
+jobnums), all provisioning jobs will have a dependancy on the supplied
+jobnum(s) (they will not run until the specific job(s) complete(s)).
+
(TODOC: L<FS::queue> and L<freeside-queued>)
(TODOC: new exports!)
-
=cut
sub insert {
my $self = shift;
+ my %options = @_;
my $error;
local $SIG{HUP} = 'IGNORE';
$error = $self->check;
return $error if $error;
- #no, duplicate checking just got a whole lot more complicated
- #(perhaps keep this check with a config option to turn on?)
-
- #return gettext('username_in_use'). ": ". $self->username
- # if qsearchs( 'svc_acct', { 'username' => $self->username,
- # 'domsvc' => $self->domsvc,
- # } );
-
- if ( $self->svcnum ) {
+ if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
unless ( $cust_svc ) {
$dbh->rollback if $oldAutoCommit;
$self->svcpart($cust_svc->svcpart);
}
- #new duplicate username checking
-
- my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
- unless ( $part_svc ) {
+ $error = $self->_check_duplicate;
+ if ( $error ) {
$dbh->rollback if $oldAutoCommit;
- return 'unknown svcpart '. $self->svcpart;
- }
-
- my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
- my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
- 'domsvc' => $self->domsvc } );
- my @dup_uid;
- if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
- && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
- @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
- } else {
- @dup_uid = ();
- }
-
- if ( @dup_user || @dup_userdomain || @dup_uid ) {
- my $exports = FS::part_export::export_info('svc_acct');
- my %conflict_user_svcpart;
- my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
-
- foreach my $part_export ( $part_svc->part_export ) {
-
- #this will catch to the same exact export
- my @svcparts = map { $_->svcpart }
- qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
-
- #this will catch to exports w/same exporthost+type ???
- #my @other_part_export = qsearch('part_export', {
- # 'machine' => $part_export->machine,
- # 'exporttype' => $part_export->exporttype,
- #} );
- #foreach my $other_part_export ( @other_part_export ) {
- # push @svcparts, map { $_->svcpart }
- # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
- #}
-
- #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
- #silly kludge to avoid uninitialized value errors
- my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
- ? $exports->{$part_export->exporttype}{'nodomain'}
- : '';
- if ( $nodomain =~ /^Y/i ) {
- $conflict_user_svcpart{$_} = $part_export->exportnum
- foreach @svcparts;
- } else {
- $conflict_userdomain_svcpart{$_} = $part_export->exportnum
- foreach @svcparts;
- }
- }
-
- foreach my $dup_user ( @dup_user ) {
- my $dup_svcpart = $dup_user->cust_svc->svcpart;
- if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
- $dbh->rollback if $oldAutoCommit;
- return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
- " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
- }
- }
-
- foreach my $dup_userdomain ( @dup_userdomain ) {
- my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
- if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
- $dbh->rollback if $oldAutoCommit;
- return "duplicate username\@domain: conflicts with svcnum ".
- $dup_userdomain->svcnum. " via exportnum ".
- $conflict_userdomain_svcpart{$dup_svcpart};
- }
- }
-
- foreach my $dup_uid ( @dup_uid ) {
- my $dup_svcpart = $dup_uid->cust_svc->svcpart;
- if ( exists($conflict_user_svcpart{$dup_svcpart})
- || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
- $dbh->rollback if $oldAutoCommit;
- return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
- "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
- || $conflict_userdomain_svcpart{$dup_svcpart};
- }
- }
-
+ return $error;
}
- #see? i told you it was more complicated
-
my @jobnums;
- $error = $self->SUPER::insert(\@jobnums, $self->child_objects || [] );
+ $error = $self->SUPER::insert(
+ 'jobnums' => \@jobnums,
+ 'child_objects' => $self->child_objects,
+ %options,
+ );
if ( $error ) {
$dbh->rollback if $oldAutoCommit;
return $error;
return "error queuing welcome email: $error";
}
+ if ( $options{'depend_jobnum'} ) {
+ warn "$me depend_jobnum found; adding to welcome email dependancies"
+ if $DEBUG;
+ if ( ref($options{'depend_jobnum'}) ) {
+ warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
+ "to welcome email dependancies"
+ if $DEBUG;
+ push @jobnums, @{ $options{'depend_jobnum'} };
+ } else {
+ warn "$me adding job $options{'depend_jobnum'} ".
+ "to welcome email dependancies"
+ if $DEBUG;
+ push @jobnums, $options{'depend_jobnum'};
+ }
+ }
+
foreach my $jobnum ( @jobnums ) {
my $error = $wqueue->depend_insert($jobnum);
if ( $error ) {
sub delete {
my $self = shift;
+ return "can't delete system account" if $self->_check_system;
+
return "Can't delete an account which is a (svc_forward) source!"
if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
return "Can't delete an account with (svc_www) web service!"
- if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
+ if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
# what about records in session ? (they should refer to history table)
returns the error, otherwise returns false.
The additional field I<usergroup> can optionally be defined; if so it should
-contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
-sqlradius export only)
+contain an arrayref of group names. See L<FS::radius_usergroup>.
+
=cut
my $error;
warn "$me replacing $old with $new\n" if $DEBUG;
+ return "can't modify system account" if $old->_check_system;
+
return "Username in use"
if $old->username ne $new->username &&
qsearchs( 'svc_acct', { 'username' => $new->username,
}
+ if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
+ $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
+ $error = $new->_check_duplicate;
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return $error;
+ }
+ }
+
$error = $new->SUPER::replace($old);
if ( $error ) {
$dbh->rollback if $oldAutoCommit;
sub suspend {
my $self = shift;
- my %hash = $self->hash;
- unless ( $hash{_password} =~ /^\*SUSPENDED\* /
- || $hash{_password} eq '*'
- ) {
- $hash{_password} = '*SUSPENDED* '.$hash{_password};
- my $new = new FS::svc_acct ( \%hash );
- my $error = $new->replace($self);
- return $error if $error;
- }
-
+ return "can't suspend system account" if $self->_check_system;
$self->SUPER::suspend;
}
=item cancel
-Just returns false (no error) for now.
-
Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
+If the B<auto_unset_catchall> configuration option is set, this method will
+automatically remove any references to the canceled service in the catchall
+field of svc_domain. This allows packages that contain both a svc_domain and
+its catchall svc_acct to be canceled in one step.
+
+=cut
+
+sub cancel {
+ # Only one thing to do at this level
+ my $self = shift;
+ foreach my $svc_domain (
+ qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
+ if($conf->exists('auto_unset_catchall')) {
+ my %hash = $svc_domain->hash;
+ $hash{catchall} = '';
+ my $new = new FS::svc_domain ( \%hash );
+ my $error = $new->replace($svc_domain);
+ return $error if $error;
+ } else {
+ return "cannot unprovision svc_acct #".$self->svcnum.
+ " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
+ }
+ }
+
+ $self->SUPER::cancel;
+}
+
+
=item check
Checks all fields to make sure this is a valid service. If there is an error,
# $error = $self->ut_textn('finger');
# return $error if $error;
+ if ( $self->getfield('finger') eq '' ) {
+ my $cust_pkg = $self->svcnum
+ ? $self->cust_svc->cust_pkg
+ : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
+ if ( $cust_pkg ) {
+ my $cust_main = $cust_pkg->cust_main;
+ $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
+ }
+ }
$self->getfield('finger') =~
/^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
or return "Illegal finger: ". $self->getfield('finger');
$self->setfield('finger', $1);
- $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
+ $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
$recref->{quota} = $1;
unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
$self->SUPER::check;
}
+=item _check_system
+
+Internal function to check the username against the list of system usernames
+from the I<system_usernames> configuration value. Returns true if the username
+is listed on the system username list.
+
+=cut
+
+sub _check_system {
+ my $self = shift;
+ scalar( grep { $self->username eq $_ || $self->email eq $_ }
+ $conf->config('system_usernames')
+ );
+}
+
+=item _check_duplicate
+
+Internal function to check for duplicates usernames, username@domain pairs and
+uids.
+
+If the I<global_unique-username> configuration value is set to B<username> or
+B<username@domain>, enforces global username or username@domain uniqueness.
+
+In all cases, check for duplicate uids and usernames or username@domain pairs
+per export and with identical I<svcpart> values.
+
+=cut
+
+sub _check_duplicate {
+ my $self = shift;
+
+ #this is Pg-specific. what to do for mysql etc?
+ # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
+ warn "$me locking svc_acct table for duplicate search" if $DEBUG;
+ dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
+ or die dbh->errstr;
+ warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
+
+ my $svcpart = $self->svcpart;
+ my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
+ unless ( $part_svc ) {
+ return 'unknown svcpart '. $self->svcpart;
+ }
+
+ my $global_unique = $conf->config('global_unique-username');
+
+ my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+ qsearch( 'svc_acct', { 'username' => $self->username } );
+ return gettext('username_in_use')
+ if $global_unique eq 'username' && @dup_user;
+
+ my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+ qsearch( 'svc_acct', { 'username' => $self->username,
+ 'domsvc' => $self->domsvc } );
+ return gettext('username_in_use')
+ if $global_unique eq 'username@domain' && @dup_userdomain;
+
+ my @dup_uid;
+ if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
+ && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
+ @dup_uid = grep { $svcpart != $_->svcpart }
+ qsearch( 'svc_acct', { 'uid' => $self->uid } );
+ } else {
+ @dup_uid = ();
+ }
+
+ if ( @dup_user || @dup_userdomain || @dup_uid ) {
+ my $exports = FS::part_export::export_info('svc_acct');
+ my %conflict_user_svcpart;
+ my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
+
+ foreach my $part_export ( $part_svc->part_export ) {
+
+ #this will catch to the same exact export
+ my @svcparts = map { $_->svcpart } $part_export->export_svc;
+
+ #this will catch to exports w/same exporthost+type ???
+ #my @other_part_export = qsearch('part_export', {
+ # 'machine' => $part_export->machine,
+ # 'exporttype' => $part_export->exporttype,
+ #} );
+ #foreach my $other_part_export ( @other_part_export ) {
+ # push @svcparts, map { $_->svcpart }
+ # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
+ #}
+
+ #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
+ #silly kludge to avoid uninitialized value errors
+ my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
+ ? $exports->{$part_export->exporttype}{'nodomain'}
+ : '';
+ if ( $nodomain =~ /^Y/i ) {
+ $conflict_user_svcpart{$_} = $part_export->exportnum
+ foreach @svcparts;
+ } else {
+ $conflict_userdomain_svcpart{$_} = $part_export->exportnum
+ foreach @svcparts;
+ }
+ }
+
+ foreach my $dup_user ( @dup_user ) {
+ my $dup_svcpart = $dup_user->cust_svc->svcpart;
+ if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
+ return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
+ " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
+ }
+ }
+
+ foreach my $dup_userdomain ( @dup_userdomain ) {
+ my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
+ if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
+ return "duplicate username\@domain: conflicts with svcnum ".
+ $dup_userdomain->svcnum. " via exportnum ".
+ $conflict_userdomain_svcpart{$dup_svcpart};
+ }
+ }
+
+ foreach my $dup_uid ( @dup_uid ) {
+ my $dup_svcpart = $dup_uid->cust_svc->svcpart;
+ if ( exists($conflict_user_svcpart{$dup_svcpart})
+ || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
+ return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
+ "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
+ || $conflict_userdomain_svcpart{$dup_svcpart};
+ }
+ }
+
+ }
+
+ return '';
+
+}
+
=item radius
Depriciated, use radius_reply instead.
}
}
+=item clone_suspended
+
+Constructor used by FS::part_export::_export_suspend fallback. Document
+better.
+
+=cut
+
+sub clone_suspended {
+ my $self = shift;
+ my %hash = $self->hash;
+ $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
+ new FS::svc_acct \%hash;
+}
+
+=item clone_kludge_unsuspend
+
+Constructor used by FS::part_export::_export_unsuspend fallback. Document
+better.
+
+=cut
+
+sub clone_kludge_unsuspend {
+ my $self = shift;
+ my %hash = $self->hash;
+ $hash{_password} = '';
+ new FS::svc_acct \%hash;
+}
+
+=item check_password
+
+Checks the supplied password against the (possibly encrypted) password in the
+database. Returns true for a sucessful authentication, false for no match.
+
+Currently supported encryptions are: classic DES crypt() and MD5
+
+=cut
+
+sub check_password {
+ my($self, $check_password) = @_;
+
+ #remove old-style SUSPENDED kludge, they should be allowed to login to
+ #self-service and pay up
+ ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
+
+ #eventually should check a "password-encoding" field
+ if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
+ return 0;
+ } elsif ( length($password) < 13 ) { #plaintext
+ $check_password eq $password;
+ } elsif ( length($password) == 13 ) { #traditional DES crypt
+ crypt($check_password, $password) eq $password;
+ } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
+ unix_md5_crypt($check_password, $password) eq $password;
+ } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
+ warn "Can't check password: Blowfish encryption not yet supported, svcnum".
+ $self->svcnum. "\n";
+ 0;
+ } else {
+ warn "Can't check password: Unrecognized encryption for svcnum ".
+ $self->svcnum. "\n";
+ 0;
+ }
+
+}
+
+=item crypt_password
+
+Returns an encrypted password, either by passing through an encrypted password
+in the database or by encrypting a plaintext password from the database.
+
+=cut
+
+sub crypt_password {
+ my $self = shift;
+ #false laziness w/shellcommands.pm
+ #eventually should check a "password-encoding" field
+ if ( length($self->_password) == 13
+ || $self->_password =~ /^\$(1|2a?)\$/ ) {
+ $self->_password;
+ } else {
+ crypt(
+ $self->_password,
+ $saltset[int(rand(64))].$saltset[int(rand(64))]
+ );
+ }
+}
+
+=item virtual_maildir
+
+Returns $domain/maildirs/$username/
+
+=cut
+
+sub virtual_maildir {
+ my $self = shift;
+ $self->domain. '/maildirs/'. $self->username. '/';
+}
+
=back
=head1 SUBROUTINES
radius_usergroup_selector? putting web ui components in here? they should
probably live somewhere else...
+insertion of RADIUS group stuff in insert could be done with child_objects now
+(would probably clean up export of them too)
+
=head1 SEE ALSO
L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
projects / freeside.git / blobdiff