X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2Fsvc_acct.pm;h=626c13f927d85acc5604b7d52606120dfaf35681;hb=b3b2c984a3538c7e8c4c56f18a65c1a3cd8e1ff7;hp=6ea30437ad7e17fc1b9bbc6cf282ef3e29bb1a62;hpb=9e9e7407e7e8c5a94c27609145ee65205f984ac5;p=freeside.git diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm index 6ea30437a..626c13f92 100644 --- a/FS/FS/svc_acct.pm +++ b/FS/FS/svc_acct.pm @@ -7,6 +7,8 @@ use vars qw( @ISA $DEBUG $me $conf $username_ampersand $username_letter $username_letterfirst $username_noperiod $username_nounderscore $username_nodash $username_uppercase + $password_noampersand $password_noexclamation + $mydomain $welcome_template $welcome_from $welcome_subject $welcome_mimetype $smtpmachine $radius_password $radius_ip @@ -19,9 +21,11 @@ use FS::UID qw( datasrc ); use FS::Conf; use FS::Record qw( qsearch qsearchs fields dbh dbdef ); use FS::svc_Common; +use Net::SSH; use FS::cust_svc; use FS::part_svc; use FS::svc_acct_pop; +use FS::svc_acct_sm; use FS::cust_main_invoice; use FS::svc_domain; use FS::raddb; @@ -55,6 +59,9 @@ $FS::UID::callback{'FS::svc_acct'} = sub { $username_nodash = $conf->exists('username-nodash'); $username_uppercase = $conf->exists('username-uppercase'); $username_ampersand = $conf->exists('username-ampersand'); + $password_noampersand = $conf->exists('password-noexclamation'); + $password_noexclamation = $conf->exists('password-noexclamation'); + $mydomain = $conf->config('domain'); $dirhash = $conf->config('dirhash') || 0; if ( $conf->exists('welcome_email') ) { $welcome_template = new Text::Template ( @@ -227,14 +234,6 @@ sub insert { $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 && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) { my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum}); unless ( $cust_svc ) { @@ -245,94 +244,12 @@ sub insert { $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' => \@jobnums, @@ -456,6 +373,11 @@ The corresponding FS::cust_svc record will be deleted as well. sub delete { my $self = shift; + if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) { + return "Can't delete an account which has (svc_acct_sm) mail aliases!" + if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } ); + } + return "can't delete system account" if $self->_check_system; return "Can't delete an account which is a (svc_forward) source!" @@ -465,7 +387,7 @@ sub delete { 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) @@ -613,6 +535,15 @@ sub replace { } + 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; @@ -638,11 +569,13 @@ sub replace { =item suspend -Suspends this account by calling export-specific suspend hooks. If there is -an error, returns the error, otherwise returns false. +Suspends this account by prefixing *SUSPENDED* to the password. If there is an +error, returns the error, otherwise returns false. Called by the suspend method of FS::cust_pkg (see L). +Calls any export-specific suspend hooks. + =cut sub suspend { @@ -653,11 +586,13 @@ sub suspend { =item unsuspend -Unsuspends this account by by calling export-specific suspend hooks. If there -is an error, returns the error, otherwise returns false. +Unsuspends this account by removing *SUSPENDED* from the password. If there is +an error, returns the error, otherwise returns false. Called by the unsuspend method of FS::cust_pkg (see L). +Calls any export-specific unsuspend hooks. + =cut sub unsuspend { @@ -675,35 +610,9 @@ sub unsuspend { =item cancel -Called by the cancel method of FS::cust_pkg (see L). - -If the B 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; -} +Just returns false (no error) for now. +Called by the cancel method of FS::cust_pkg (see L). =item check @@ -764,6 +673,12 @@ sub check { unless ( $username_ampersand ) { $recref->{username} =~ /\&/ and return gettext('illegal_username'); } + if ( $password_noampersand ) { + $recref->{_password} =~ /\&/ and return gettext('illegal_password'); + } + if ( $password_noexclamation ) { + $recref->{_password} =~ /\!/ and return gettext('illegal_password'); + } $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum}; $recref->{popnum} = $1; @@ -783,9 +698,7 @@ sub check { return "Only root can have uid 0" if $recref->{uid} == 0 - && $recref->{username} ne 'root' - && $recref->{username} ne 'toor'; - + && $recref->{username} !~ /^(root|toor|smtp)$/; $recref->{dir} =~ /^([\/\w\-\.\&]*)$/ or return "Illegal directory: ". $recref->{dir}; @@ -855,7 +768,7 @@ sub check { $recref->{slipip} = '0e0'; } else { $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/ - or return "Illegal slipip: ". $self->slipip; + or return "Illegal slipip". $self->slipip; $recref->{slipip} = $1; } @@ -895,13 +808,13 @@ sub check { ": ". $recref->{_password}; } - $self->SUPER::check; + ''; #no error } =item _check_system - + =cut - + sub _check_system { my $self = shift; scalar( grep { $self->username eq $_ || $self->email eq $_ } @@ -909,6 +822,124 @@ sub _check_system { ); } +=item _check_duplicate + +Internal function to check for duplicates usernames, username@domain pairs and +uids. + +If the I configuration value is set to B or +B, 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 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 { $svcpart != $_->svcpart } + qsearch( 'svc_acct', { 'username' => $self->username } ); + return gettext('username_in_use') + if $global_unique eq 'username' && @dup_user; + + my @dup_userdomain = grep { $svcpart != $_->svcpart } + 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. @@ -929,6 +960,10 @@ Note that this is now the preferred method for reading RADIUS attributes - accessing the columns directly is discouraged, as the column names are expected to change in the future. +Internal function to check the username against the list of system usernames +from the I configuration value. Returns true if the username +is listed on the system username list. + =cut sub radius_reply { @@ -961,7 +996,7 @@ sub radius_check { my $self = shift; my $password = $self->_password; my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; - ( $pw_attrib => $password, + ( $pw_attrib => $self->_password, map { /^(rc_(.*))$/; my($column, $attrib) = ($1, $2); @@ -979,10 +1014,14 @@ Returns the domain associated with this account. sub domain { my $self = shift; - die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc; - my $svc_domain = $self->svc_domain - or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc; - $svc_domain->domain; + if ( $self->domsvc ) { + #$self->svc_domain->domain; + my $svc_domain = $self->svc_domain + or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc; + $svc_domain->domain; + } else { + $mydomain or die "svc_acct.domsvc is null and no legacy domain config file"; + } } =item svc_domain @@ -1190,39 +1229,6 @@ sub check_password { } -=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 @@ -1231,28 +1237,36 @@ sub virtual_maildir { =item send_email -This is the FS::svc_acct job-queue-able version. It still uses -FS::Misc::send_email under-the-hood. - =cut sub send_email { my %opt = @_; - eval "use FS::Misc qw(send_email)"; - die $@ if $@; + use Date::Format; + use Mail::Internet 1.44; + use Mail::Header; $opt{mimetype} ||= 'text/plain'; $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/; - my $error = send_email( - 'from' => $opt{from}, - 'to' => $opt{to}, - 'subject' => $opt{subject}, - 'content-type' => $opt{mimetype}, - 'body' => [ map "$_\n", split("\n", $opt{body}) ], + $ENV{MAILADDRESS} = $opt{from}; + my $header = new Mail::Header ( [ + "From: $opt{from}", + "To: $opt{to}", + "Sender: $opt{from}", + "Reply-To: $opt{from}", + "Date: ". time2str("%a, %d %b %Y %X %z", time), + "Subject: $opt{subject}", + "Content-Type: $opt{mimetype}", + ] ); + my $message = new Mail::Internet ( + 'Header' => $header, + 'Body' => [ map "$_\n", split("\n", $opt{body}) ], ); - die $error if $error; + $!=0; + $message->smtpsend( Host => $smtpmachine ) + or $message->smtpsend( Host => $smtpmachine, Debug => 1 ) + or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!"; } =item check_and_rebuild_fuzzyfiles @@ -1406,7 +1420,7 @@ insertion of RADIUS group stuff in insert could be done with child_objects now L, edit/part_svc.cgi from an installed web interface, export.html from the base documentation, L, L, L, L, L, L, -L), L, +L), L, L, L, schema.html from the base documentation. =cut