X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;ds=sidebyside;f=FS%2FFS%2Fsvc_acct.pm;h=a9cdfb3df73759737542c3442d53027e9ab97b7b;hb=673b9a458d9138523026963df6fa3b4683e09bae;hp=2f68533c16250bf59197bb1a54018139caf600f4;hpb=2a0fa3b220f3231fe3fae04fe0c58641911385c6;p=freeside.git diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm index 2f68533c1..a9cdfb3df 100644 --- a/FS/FS/svc_acct.pm +++ b/FS/FS/svc_acct.pm @@ -6,7 +6,7 @@ use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles $usernamemax $passwordmin $passwordmax $username_ampersand $username_letter $username_letterfirst $username_noperiod $username_nounderscore $username_nodash - $username_uppercase + $username_uppercase $username_percent $password_noampersand $password_noexclamation $welcome_template $welcome_from $welcome_subject $welcome_mimetype $smtpmachine @@ -15,7 +15,8 @@ use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles @saltset @pw_set ); use Carp; use Fcntl qw(:flock); -use Crypt::PasswdMD5; +use Date::Format; +use Crypt::PasswdMD5 1.2; use FS::UID qw( datasrc ); use FS::Conf; use FS::Record qw( qsearch qsearchs fields dbh dbdef ); @@ -37,7 +38,6 @@ 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 @@ -56,6 +56,7 @@ $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'); + $username_percent = $conf->exists('username-percent'); $password_noampersand = $conf->exists('password-noexclamation'); $password_noexclamation = $conf->exists('password-noexclamation'); $dirhash = $conf->config('dirhash') || 0; @@ -167,7 +168,9 @@ FS::svc_Common. The following fields are currently supported: =item domsvc - svcnum from svc_domain -=item radius_I - I +=item radius_I - I (reply) + +=item rc_I - I (check) =back @@ -461,15 +464,18 @@ sub replace { 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, - 'domsvc' => $new->domsvc, - } ); { #no warnings 'numeric'; #alas, a 5.006-ism local($^W) = 0; - return "Can't change uid!" if $old->uid != $new->uid; + + foreach my $xid (qw( uid gid )) { + + return "Can't change $xid!" + if ! $conf->exists("svc_acct-edit_$xid") + && $old->$xid() != $new->$xid() + && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F' + } + } #change homdir when we change username @@ -691,11 +697,11 @@ sub check { my $ulen = $usernamemax || $self->dbdef_table->column('username')->length; if ( $username_uppercase ) { - $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i + $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username}; $recref->{username} = $1; } else { - $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/ + $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/ or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username}; $recref->{username} = $1; } @@ -723,6 +729,9 @@ sub check { if ( $password_noexclamation ) { $recref->{_password} =~ /\!/ and return gettext('illegal_password'); } + unless ( $username_percent ) { + $recref->{username} =~ /\%/ and return gettext('illegal_username'); + } $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum}; $recref->{popnum} = $1; @@ -898,7 +907,7 @@ sub _check_duplicate { return 'unknown svcpart '. $self->svcpart; } - my $global_unique = $conf->config('global_unique-username'); + my $global_unique = $conf->config('global_unique-username') || 'none'; my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum } qsearch( 'svc_acct', { 'username' => $self->username } ); @@ -1011,6 +1020,7 @@ expected to change in the future. sub radius_reply { my $self = shift; + my %reply = map { /^(radius_(.*))$/; @@ -1018,12 +1028,15 @@ sub radius_reply { #$attrib =~ s/_/\-/g; ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) ); } grep { /^radius_/ && $self->getfield($_) } fields( $self->table ); + if ( $self->slipip && $self->slipip ne '0e0' ) { $reply{$radius_ip} = $self->slipip; } + if ( $self->seconds !~ /^$/ ) { $reply{'Session-Timeout'} = $self->seconds; } + %reply; } @@ -1040,16 +1053,25 @@ expected to change in the future. sub radius_check { my $self = shift; - my $password = $self->_password; - my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; - ( $pw_attrib => $password, + + my %check = map { /^(rc_(.*))$/; my($column, $attrib) = ($1, $2); #$attrib =~ s/_/\-/g; ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) ); - } grep { /^rc_/ && $self->getfield($_) } fields( $self->table ) - ); + } grep { /^rc_/ && $self->getfield($_) } fields( $self->table ); + + my $password = $self->_password; + my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password; + + my $cust_pkg = $self->cust_svc->cust_pkg; + if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) { + $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html + } + + %check; + } =item domain @@ -1086,10 +1108,7 @@ Returns the FS::cust_svc record for this account (see L). =cut -sub cust_svc { - my $self = shift; - qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } ); -} +#inherited from svc_Common =item email @@ -1118,6 +1137,93 @@ sub acct_snarf { qsearch('acct_snarf', { 'svcnum' => $self->svcnum } ); } +=item decrement_seconds SECONDS + +Decrements the I field of this record by the given amount. If there +is an error, returns the error, otherwise returns false. + +=cut + +sub decrement_seconds { + shift->_op_seconds('-', @_); +} + +=item increment_seconds SECONDS + +Increments the I field of this record by the given amount. If there +is an error, returns the error, otherwise returns false. + +=cut + +sub increment_seconds { + shift->_op_seconds('+', @_); +} + + +my %op2action = ( + '-' => 'suspend', + '+' => 'unsuspend', +); +my %op2condition = ( + '-' => sub { my($self, $seconds) = @_; + $self->seconds - $seconds <= 0; + }, + '+' => sub { my($self, $seconds) = @_; + $self->seconds + $seconds > 0; + }, +); + +sub _op_seconds { + my( $self, $op, $seconds ) = @_; + warn "$me _op_seconds called for svcnum ". $self->svcnum. + ' ('. $self->email. "): $op $seconds\n" + if $DEBUG; + + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + local $SIG{PIPE} = 'IGNORE'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + my $sql = "UPDATE svc_acct SET seconds = ". + " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0 + " $op ? WHERE svcnum = ?"; + warn "$me $sql\n" + if $DEBUG; + + my $sth = $dbh->prepare( $sql ) + or die "Error preparing $sql: ". $dbh->errstr; + my $rv = $sth->execute($seconds, $self->svcnum); + die "Error executing $sql: ". $sth->errstr + unless defined($rv); + die "Can't update seconds for svcnum". $self->svcnum + if $rv == 0; + + my $action = $op2action{$op}; + + if ( $conf->exists("svc_acct-usage_$action") + && &{$op2condition{$op}}($self, $seconds) ) { + #my $error = $self->$action(); + my $error = $self->cust_svc->cust_pkg->$action(); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error ${action}ing: $error"; + } + } + + warn "$me update sucessful; committing\n" + if $DEBUG; + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + + =item seconds_since TIMESTAMP Returns the number of seconds this account has been online since TIMESTAMP, @@ -1271,25 +1377,43 @@ sub check_password { } -=item crypt_password +=item crypt_password [ DEFAULT_ENCRYPTION_TYPE ] Returns an encrypted password, either by passing through an encrypted password in the database or by encrypting a plaintext password from the database. +The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I (classic +UNIX DES crypt), I (md5 crypt supported by most modern Linux and BSD +distrubtions), or (eventually) I (blowfish hashing supported by +OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default +encryption type is only used if the password is not already encrypted in 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 =~ /^\$(1|2a?)\$/ + || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/ + ) + { $self->_password; } else { - crypt( - $self->_password, - $saltset[int(rand(64))].$saltset[int(rand(64))] - ); + my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt'; + if ( $encryption eq 'crypt' ) { + crypt( + $self->_password, + $saltset[int(rand(64))].$saltset[int(rand(64))] + ); + } elsif ( $encryption eq 'md5' ) { + unix_md5_crypt( $self->_password ); + } elsif ( $encryption eq 'blowfish' ) { + die "unknown encryption method $encryption"; + } else { + die "unknown encryption method $encryption"; + } } }