X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2Fsvc_acct.pm;h=022a6c731e7868daa43324ec38d466f3af61c206;hp=6ba2f97b67579b1c2192e714a4dffdcb675fb478;hb=a1b53bf2e2af68085228b73c9da980fc49b1d393;hpb=6194551336a925ae5455cede68a7f73660b06bb6 diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm index 6ba2f97b6..a04789bad 100644 --- a/FS/FS/svc_acct.pm +++ b/FS/FS/svc_acct.pm @@ -1,58 +1,78 @@ package FS::svc_acct; +use base qw( FS::svc_Domain_Mixin FS::svc_PBX_Mixin + FS::svc_CGP_Mixin FS::svc_CGPRule_Mixin + FS::svc_Radius_Mixin + FS::svc_Tower_Mixin + FS::svc_IP_Mixin + FS::Password_Mixin + FS::svc_Common + ); use strict; -use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles +use vars qw( $DEBUG $me $conf $skip_fuzzyfiles $dir_prefix @shells $usernamemin $usernamemax $passwordmin $passwordmax $username_ampersand $username_letter $username_letterfirst $username_noperiod $username_nounderscore $username_nodash - $username_uppercase $username_percent + $username_uppercase $username_percent $username_colon + $username_slash $username_equals $username_pound + $username_exclamation $password_noampersand $password_noexclamation - $welcome_template $welcome_from $welcome_subject $welcome_mimetype - $warning_template $warning_from $warning_subject $warning_mimetype - $warning_cc + $warning_msgnum $smtpmachine $radius_password $radius_ip $dirhash @saltset @pw_set ); +use Scalar::Util qw( blessed ); +use Math::BigInt; use Carp; use Fcntl qw(:flock); use Date::Format; use Crypt::PasswdMD5 1.2; +use Digest::SHA 'sha1_base64'; +use Digest::MD5 'md5_base64'; use Data::Dumper; -use FS::UID qw( datasrc ); +use Text::Template; +use Authen::Passphrase; +use FS::UID qw( datasrc driver_name ); use FS::Conf; use FS::Record qw( qsearch qsearchs fields dbh dbdef ); use FS::Msgcat qw(gettext); -use FS::svc_Common; -use FS::cust_svc; +use FS::UI::bytecount; +use FS::UI::Web; +use FS::PagedSearch qw( psearch ); # XXX in v4, replace with FS::Cursor +use FS::part_pkg; use FS::part_svc; use FS::svc_acct_pop; -use FS::cust_main_invoice; use FS::svc_domain; +use FS::svc_pbx; use FS::raddb; use FS::queue; use FS::radius_usergroup; +use FS::radius_group; use FS::export_svc; use FS::part_export; use FS::svc_forward; use FS::svc_www; use FS::cdr; - -@ISA = qw( FS::svc_Common ); +use FS::tower_sector; $DEBUG = 0; $me = '[FS::svc_acct]'; #ask FS::UID to run this stuff for us later -$FS::UID::callback{'FS::svc_acct'} = sub { +FS::UID->install_callback( sub { $conf = new FS::Conf; $dir_prefix = $conf->config('home'); @shells = $conf->config('shells'); $usernamemin = $conf->config('usernamemin') || 2; $usernamemax = $conf->config('usernamemax'); - $passwordmin = $conf->config('passwordmin') || 6; - $passwordmax = $conf->config('passwordmax') || 8; + $passwordmin = $conf->config('passwordmin'); + #blank->8, keep 0 + $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ ) + ? $passwordmin + : 8; + $passwordmax = $conf->config('passwordmax') || 12; $username_letter = $conf->exists('username-letter'); $username_letterfirst = $conf->exists('username-letterfirst'); $username_noperiod = $conf->exists('username-noperiod'); @@ -61,46 +81,23 @@ $FS::UID::callback{'FS::svc_acct'} = sub { $username_uppercase = $conf->exists('username-uppercase'); $username_ampersand = $conf->exists('username-ampersand'); $username_percent = $conf->exists('username-percent'); + $username_colon = $conf->exists('username-colon'); + $username_slash = $conf->exists('username-slash'); + $username_equals = $conf->exists('username-equals'); + $username_pound = $conf->exists('username-pound'); + $username_exclamation = $conf->exists('username-exclamation'); $password_noampersand = $conf->exists('password-noexclamation'); $password_noexclamation = $conf->exists('password-noexclamation'); $dirhash = $conf->config('dirhash') || 0; - if ( $conf->exists('welcome_email') ) { - $welcome_template = new Text::Template ( - TYPE => 'ARRAY', - SOURCE => [ map "$_\n", $conf->config('welcome_email') ] - ) or warn "can't create welcome email template: $Text::Template::ERROR"; - $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum' - $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome'; - $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain'; - } else { - $welcome_template = ''; - $welcome_from = ''; - $welcome_subject = ''; - $welcome_mimetype = ''; - } - if ( $conf->exists('warning_email') ) { - $warning_template = new Text::Template ( - TYPE => 'ARRAY', - SOURCE => [ map "$_\n", $conf->config('warning_email') ] - ) or warn "can't create warning email template: $Text::Template::ERROR"; - $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum' - $warning_subject = $conf->config('warning_email-subject') || 'Warning'; - $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain'; - $warning_cc = $conf->config('warning_email-cc'); - } else { - $warning_template = ''; - $warning_from = ''; - $warning_subject = ''; - $warning_mimetype = ''; - $warning_cc = ''; - } + $warning_msgnum = $conf->config('threshold_warning_msgnum'); $smtpmachine = $conf->config('smtpmachine'); $radius_password = $conf->config('radius-password') || 'Password'; $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address'; -}; + @pw_set = FS::svc_acct->pw_set; +} +); @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' ); -@pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' ); sub _cache { my $self = shift; @@ -160,43 +157,71 @@ FS::svc_Common. The following fields are currently supported: =over 4 -=item svcnum - primary key (assigned automatcially for new accounts) +=item svcnum + +Primary key (assigned automatcially for new accounts) =item username -=item _password - generated if blank +=item _password + +generated if blank -=item sec_phrase - security phrase +=item _password_encoding -=item popnum - Point of presence (see L) +plain, crypt, ldap (or empty for autodetection) + +=item sec_phrase + +security phrase + +=item popnum + +Point of presence (see L) =item uid =item gid -=item finger - GECOS +=item finger -=item dir - set automatically if blank (and uid is not) +GECOS + +=item dir + +set automatically if blank (and uid is not) =item shell -=item quota - (unimplementd) +=item quota + +=item slipip + +IP address -=item slipip - IP address +=item seconds -=item seconds - +=item upbytes -=item upbytes - +=item downbyte -=item downbytes - +=item totalbytes -=item totalbytes - +=item domsvc -=item domsvc - svcnum from svc_domain +svcnum from svc_domain -=item radius_I - I (reply) +=item pbxsvc -=item rc_I - I (check) +Optional svcnum from svc_pbx + +=item radius_I + +I (reply) + +=item rc_I + +I (check) =back @@ -210,24 +235,407 @@ Creates a new account. To add the account to the database, see L<"insert">. =cut -sub table { 'svc_acct'; } - -sub _fieldhandlers { +sub table_info { { - #false laziness with edit/svc_acct.cgi - 'usergroup' => sub { - my( $self, $groups ) = @_; - if ( ref($groups) eq 'ARRAY' ) { - $groups; - } elsif ( length($groups) ) { - [ split(/\s*,\s*/, $groups) ]; - } else { - []; - } + 'name' => 'Account', + 'longname_plural' => 'Access accounts and mailboxes', + 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ], + 'display_weight' => 10, + 'cancel_weight' => 50, + 'ip_field' => 'slipip', + 'manual_require' => 1, + 'fields' => { + 'dir' => 'Home directory', + 'uid' => { + label => 'UID', + def_info => 'set to fixed and blank for no UIDs', + type => 'text', + }, + 'slipip' => 'IP address', + # 'popnum' => qq!POP number!, + 'popnum' => { + label => 'Access number', + type => 'select', + select_table => 'svc_acct_pop', + select_key => 'popnum', + select_label => 'city', + disable_select => 1, + }, + 'username' => { + label => 'Username', + type => 'text', + disable_default => 1, + disable_fixed => 1, + disable_select => 1, + required => 1, + }, + 'password_selfchange' => { label => 'Password modification', + type => 'checkbox', + }, + 'password_recover' => { label => 'Password recovery', + type => 'checkbox', + }, + 'quota' => { + label => 'Quota', #Mail storage limit + type => 'text', + disable_inventory => 1, + }, + 'file_quota'=> { + label => 'File storage limit', + type => 'text', + disable_inventory => 1, + }, + 'file_maxnum'=> { + label => 'Number of files limit', + type => 'text', + disable_inventory => 1, + }, + 'file_maxsize'=> { + label => 'File size limit', + type => 'text', + disable_inventory => 1, + }, + '_password' => { label => 'Password', + #required => 1 + }, + 'gid' => { + label => 'GID', + def_info => 'when blank, defaults to UID', + type => 'text', + }, + 'shell' => { + label => 'Shell', + def_info => 'set to blank for no shell tracking', + type => 'select', + #select_list => [ $conf->config('shells') ], + select_list => [ $conf ? $conf->config('shells') : () ], + disable_inventory => 1, + disable_select => 1, + }, + 'finger' => 'Real name', # (GECOS)', + 'domsvc' => { + label => 'Domain', + type => 'select', + select_svc => 1, + select_table => 'svc_domain', + select_key => 'svcnum', + select_label => 'domain', + disable_inventory => 1, + required => 1, + }, + 'pbxsvc' => { label => 'PBX', + type => 'select-svc_pbx.html', + disable_inventory => 1, + disable_select => 1, #UI wonky, pry works otherwise + }, + 'sectornum' => 'Tower sector', + 'routernum' => 'Router/block', + 'blocknum' => { + 'label' => 'Address block', + 'type' => 'select', + 'select_table' => 'addr_block', + 'select_key' => 'blocknum', + 'select_label' => 'cidr', + 'disable_inventory' => 1, }, + 'usergroup' => { + label => 'RADIUS groups', + type => 'select-radius_group.html', + disable_inventory => 1, + disable_select => 1, + multiple => 1, + }, + 'seconds' => { label => 'Seconds', + label_sort => 'with Time Remaining', + type => 'text', + disable_inventory => 1, + disable_select => 1, + #disable_part_svc_column => 1, + }, + 'upbytes' => { label => 'Upload', + type => 'text', + disable_inventory => 1, + disable_select => 1, + 'format' => \&FS::UI::bytecount::display_bytecount, + 'parse' => \&FS::UI::bytecount::parse_bytecount, + disable_part_svc_column => 1, + }, + 'downbytes' => { label => 'Download', + type => 'text', + disable_inventory => 1, + disable_select => 1, + 'format' => \&FS::UI::bytecount::display_bytecount, + 'parse' => \&FS::UI::bytecount::parse_bytecount, + disable_part_svc_column => 1, + }, + 'totalbytes'=> { label => 'Total up and download', + type => 'text', + disable_inventory => 1, + disable_select => 1, + 'format' => \&FS::UI::bytecount::display_bytecount, + 'parse' => \&FS::UI::bytecount::parse_bytecount, + disable_part_svc_column => 1, + }, + 'seconds_threshold' => { label => 'Seconds threshold', + type => 'text', + disable_inventory => 1, + disable_select => 1, + disable_part_svc_column => 1, + }, + 'upbytes_threshold' => { label => 'Upload threshold', + type => 'text', + disable_inventory => 1, + disable_select => 1, + 'format' => \&FS::UI::bytecount::display_bytecount, + 'parse' => \&FS::UI::bytecount::parse_bytecount, + disable_part_svc_column => 1, + }, + 'downbytes_threshold' => { label => 'Download threshold', + type => 'text', + disable_inventory => 1, + disable_select => 1, + 'format' => \&FS::UI::bytecount::display_bytecount, + 'parse' => \&FS::UI::bytecount::parse_bytecount, + disable_part_svc_column => 1, + }, + 'totalbytes_threshold'=> { label => 'Total up and download threshold', + type => 'text', + disable_inventory => 1, + disable_select => 1, + 'format' => \&FS::UI::bytecount::display_bytecount, + 'parse' => \&FS::UI::bytecount::parse_bytecount, + disable_part_svc_column => 1, + }, + 'last_login'=> { + label => 'Last login', + type => 'disabled', + }, + 'last_logout'=> { + label => 'Last logout', + type => 'disabled', + }, + + 'cgp_aliases' => { + label => 'Communigate aliases', + type => 'text', + disable_inventory => 1, + disable_select => 1, + }, + #settings + 'cgp_type'=> { + label => 'Communigate account type', + type => 'select', + select_list => [qw( MultiMailbox TextMailbox MailDirMailbox AGrade BGrade CGrade )], + disable_inventory => 1, + disable_select => 1, + }, + 'cgp_accessmodes' => { + label => 'Communigate enabled services', + type => 'communigate_pro-accessmodes', + disable_inventory => 1, + disable_select => 1, + }, + 'cgp_rulesallowed' => { + label => 'Allowed mail rules', + type => 'select', + select_list => [ '', 'No', 'Filter Only', 'All But Exec', 'Any' ], + disable_inventory => 1, + disable_select => 1, + }, + 'cgp_rpopallowed' => { label => 'RPOP modifications', + type => 'checkbox', + }, + 'cgp_mailtoall' => { label => 'Accepts mail to "all"', + type => 'checkbox', + }, + 'cgp_addmailtrailer' => { label => 'Add trailer to sent mail', + type => 'checkbox', + }, + 'cgp_archiveafter' => { + label => 'Archive messages after', + type => 'select', + select_hash => [ + -2 => 'default(730 days)', + 0 => 'Never', + 86400 => '24 hours', + 172800 => '2 days', + 259200 => '3 days', + 432000 => '5 days', + 604800 => '7 days', + 1209600 => '2 weeks', + 2592000 => '30 days', + 7776000 => '90 days', + 15552000 => '180 days', + 31536000 => '365 days', + 63072000 => '730 days', + ], + disable_inventory => 1, + disable_select => 1, + }, + #XXX mailing lists + + #preferences + 'cgp_deletemode' => { + label => 'Communigate message delete method', + type => 'select', + select_list => [ 'Move To Trash', 'Immediately', 'Mark' ], + disable_inventory => 1, + disable_select => 1, + }, + 'cgp_emptytrash' => { + label => 'Communigate on logout remove trash', + type => 'select', + select_list => __PACKAGE__->cgp_emptytrash_values, + disable_inventory => 1, + disable_select => 1, + }, + 'cgp_language' => { + label => 'Communigate language', + type => 'select', + select_list => [ '', qw( English Arabic Chinese Dutch French German Hebrew Italian Japanese Portuguese Russian Slovak Spanish Thai ) ], + disable_inventory => 1, + disable_select => 1, + }, + 'cgp_timezone' => { + label => 'Communigate time zone', + type => 'select', + select_list => __PACKAGE__->cgp_timezone_values, + disable_inventory => 1, + disable_select => 1, + }, + 'cgp_skinname' => { + label => 'Communigate layout', + type => 'select', + select_list => [ '', '***', 'GoldFleece', 'Skin2' ], + disable_inventory => 1, + disable_select => 1, + }, + 'cgp_prontoskinname' => { + label => 'Communigate Pronto style', + type => 'select', + select_list => [ '', 'Pronto', 'Pronto-darkflame', 'Pronto-steel', 'Pronto-twilight', ], + disable_inventory => 1, + disable_select => 1, + }, + 'cgp_sendmdnmode' => { + label => 'Communigate send read receipts', + type => 'select', + select_list => [ '', 'Never', 'Manually', 'Automatically' ], + disable_inventory => 1, + disable_select => 1, + }, + + #mail + #XXX RPOP settings + + }, }; } +sub table { 'svc_acct'; } + +sub table_dupcheck_fields { ( 'username', 'domsvc' ); } + +sub last_login { + shift->_lastlog('in', @_); +} + +sub last_logout { + shift->_lastlog('out', @_); +} + +sub _lastlog { + my( $self, $op, $time ) = @_; + + if ( defined($time) ) { + warn "$me last_log$op called on svcnum ". $self->svcnum. + ' ('. $self->email. "): $time\n" + if $DEBUG; + + my $dbh = dbh; + + my $sql = "UPDATE svc_acct SET last_log$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($time, $self->svcnum); + die "Error executing $sql: ". $sth->errstr + unless defined($rv); + die "Can't update last_log$op for svcnum". $self->svcnum + if $rv == 0; + + $self->{'Hash'}->{"last_log$op"} = $time; + }else{ + $self->getfield("last_log$op"); + } +} + +=item search_sql STRING + +Class method which returns an SQL fragment to search for the given string. + +=cut + +sub search_sql { + my( $class, $string ) = @_; + if ( $string =~ /^([^@]+)@([^@]+)$/ ) { + my( $username, $domain ) = ( $1, $2 ); + my $q_username = dbh->quote($username); + my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } ); + if ( @svc_domain ) { + "svc_acct.username = $q_username AND ( ". + join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ). + " )"; + } else { + '1 = 0'; #false + } + } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) { + ' ( '. + $class->search_sql_field('slipip', $string ). + ' OR '. + $class->search_sql_field('username', $string ). + ' ) '; + } else { + $class->search_sql_field('username', $string); + } +} + +=item label [ END_TIMESTAMP [ START_TIMESTAMP ] ] + +Returns the "username@domain" string for this account. + +END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with +history records. + +=cut + +sub label { + my $self = shift; + $self->email(@_); +} + +=item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ] + +Returns a longer string label for this acccount ("Real Name " +if available, or "username@domain"). + +END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with +history records. + +=cut + +sub label_long { + my $self = shift; + my $label = $self->label(@_); + my $finger = $self->finger; + return $label unless $finger =~ /\S/; + my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc); + $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen; + "$finger <$label>"; +} + =item insert [ , OPTION => VALUE ... ] Adds this account to the database. If there is an error, returns the error, @@ -279,50 +687,20 @@ sub insert { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - my $error = $self->check; - return $error if $error; - - 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; - return "no cust_svc record found for svcnum ". $self->svcnum; - } - $self->pkgnum($cust_svc->pkgnum); - $self->svcpart($cust_svc->svcpart); - } - - $error = $self->_check_duplicate; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return $error; - } - my @jobnums; - $error = $self->SUPER::insert( + my $error = $self->SUPER::insert( # usergroup is here 'jobnums' => \@jobnums, 'child_objects' => $self->child_objects, %options, ); + + $error ||= $self->insert_password_history; + if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; } - if ( $self->usergroup ) { - foreach my $groupname ( @{$self->usergroup} ) { - my $radius_usergroup = new FS::radius_usergroup ( { - svcnum => $self->svcnum, - groupname => $groupname, - } ); - my $error = $radius_usergroup->insert; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return $error; - } - } - } - unless ( $skip_fuzzyfiles ) { $error = $self->queue_fuzzyfiles_update; if ( $error ) { @@ -335,72 +713,83 @@ sub insert { if ( $cust_pkg ) { my $cust_main = $cust_pkg->cust_main; + my $agentnum = $cust_main->agentnum; + + if ( $conf->exists('emailinvoiceautoalways') + || $conf->exists('emailinvoiceauto') + && ! $cust_main->invoicing_list_emailonly + ) { + + # slight false laziness w/ edit/process/cust_main.cgi... + # and also slightly arbitrary behavior. + # + # this will never happen but check it anyway + my ($contact) = map { $_->contact } + qsearch('contact_email', { emailaddress => $self->email }); + + if (!$contact) { + # if the "real name" of this account matches the first + last name + # of a contact, attach the email address to that person. + my @contacts = map { $_->contact } $cust_main->cust_contact; + my $myname = $self->get('finger'); + my ($contact) = + grep { $_->get('first') . ' ' . $_->get('last') eq $myname } @contacts; + # otherwise just pick the first one + $contact = $contacts[0]; + } + # if there is one + $contact ||= FS::contact->new({ + 'custnum' => $cust_main->get('custnum'), + 'locationnum' => $cust_main->get('bill_locationnum'), + 'last' => $cust_main->get('last'), + 'first' => $cust_main->get('first'), + }); + $contact->set('emailaddress', $self->email); + $contact->set('invoice_dest', 'Y'); + + if ( $contact->get('contactnum') ) { + $error = $contact->replace; + } else { + $error = $contact->insert; + } - if ( $conf->exists('emailinvoiceauto') ) { - my @invoicing_list = $cust_main->invoicing_list; - push @invoicing_list, $self->email; - $cust_main->invoicing_list(\@invoicing_list); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "creating invoice destination contact: $error"; + } } - #welcome email - my $to = ''; - if ( $welcome_template && $cust_pkg ) { - my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list ); - if ( $to ) { - my $wqueue = new FS::queue { - 'svcnum' => $self->svcnum, - 'job' => 'FS::svc_acct::send_email' - }; - my $error = $wqueue->insert( - 'to' => $to, - 'from' => $welcome_from, - 'subject' => $welcome_subject, - 'mimetype' => $welcome_mimetype, - 'body' => $welcome_template->fill_in( HASH => { - 'custnum' => $self->custnum, - 'username' => $self->username, - 'password' => $self->_password, - 'first' => $cust_main->first, - 'last' => $cust_main->getfield('last'), - 'pkg' => $cust_pkg->part_pkg->pkg, - } ), - ); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "error queuing welcome email: $error"; - } + } # if $cust_pkg - 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'}; - } - } + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; #no error +} - foreach my $jobnum ( @jobnums ) { - my $error = $wqueue->depend_insert($jobnum); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "error queuing welcome email job dependancy: $error"; - } - } +# set usage fields and thresholds if unset but set in a package def +# AND the package already has a last bill date (otherwise they get double added) +sub preinsert_hook_first { + my $self = shift; - } + return '' unless $self->pkgnum; - } + my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } ); + return '' unless $cust_pkg && $cust_pkg->last_bill; - } # if ( $cust_pkg ) + my $part_pkg = $cust_pkg->part_pkg; + return '' unless $part_pkg && $part_pkg->can('usage_valuehash'); + + my %values = $part_pkg->usage_valuehash; + my $multiplier = $conf->exists('svc_acct-usage_threshold') + ? 1 - $conf->config('svc_acct-usage_threshold')/100 + : 0.20; #doesn't matter + + foreach ( keys %values ) { + next if $self->getfield($_); + $self->setfield( $_, $values{$_} ); + $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) ) + if $conf->exists('svc_acct-usage_threshold'); + } - $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; #no error } @@ -442,23 +831,6 @@ sub delete { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - foreach my $cust_main_invoice ( - qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } ) - ) { - unless ( defined($cust_main_invoice) ) { - warn "WARNING: something's wrong with qsearch"; - next; - } - my %hash = $cust_main_invoice->hash; - $hash{'dest'} = $self->email; - my $new = new FS::cust_main_invoice \%hash; - my $error = $new->replace($cust_main_invoice); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return $error; - } - } - foreach my $svc_domain ( qsearch( 'svc_domain', { 'catchall' => $self->svcnum } ) ) { @@ -472,17 +844,19 @@ sub delete { } } - foreach my $radius_usergroup ( - qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } ) + foreach my $svc_phone ( + qsearch( 'svc_phone', { 'forward_svcnum' => $self->svcnum }) ) { - my $error = $radius_usergroup->delete; + $svc_phone->set('forward_svcnum', ''); + my $error = $svc_phone->replace; if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; } } - my $error = $self->SUPER::delete; + my $error = $self->delete_password_history + || $self->SUPER::delete; # usergroup here if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -504,14 +878,15 @@ contain an arrayref of group names. See L. =cut sub replace { - my ( $new, $old ) = ( shift, shift ); - my $error; + my $new = shift; + + my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') ) + ? shift + : $new->replace_old; + warn "$me replacing $old with $new\n" if $DEBUG; - # We absolutely have to have an old vs. new record to make this work. - if (!defined($old)) { - $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } ); - } + my $error; return "can't modify system account" if $old->_check_system; @@ -529,6 +904,10 @@ sub replace { } + return "can't change username" + if $old->username ne $new->username + && $conf->exists('svc_acct-no_edit_username'); + #change homdir when we change username $new->setfield('dir', '') if $old->username ne $new->username; @@ -543,58 +922,13 @@ sub replace { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - # redundant, but so $new->usergroup gets set - $error = $new->check; - return $error if $error; - - $old->usergroup( [ $old->radius_groups ] ); - if ( $DEBUG ) { - warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n"; - warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n"; - } - if ( $new->usergroup ) { - #(sorta) false laziness with FS::part_export::sqlradius::_export_replace - my @newgroups = @{$new->usergroup}; - foreach my $oldgroup ( @{$old->usergroup} ) { - if ( grep { $oldgroup eq $_ } @newgroups ) { - @newgroups = grep { $oldgroup ne $_ } @newgroups; - next; - } - my $radius_usergroup = qsearchs('radius_usergroup', { - svcnum => $old->svcnum, - groupname => $oldgroup, - } ); - my $error = $radius_usergroup->delete; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "error deleting radius_usergroup $oldgroup: $error"; - } - } - - foreach my $newgroup ( @newgroups ) { - my $radius_usergroup = new FS::radius_usergroup ( { - svcnum => $new->svcnum, - groupname => $newgroup, - } ); - my $error = $radius_usergroup->insert; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "error adding radius_usergroup $newgroup: $error"; - } - } - - } + $error = $new->SUPER::replace($old, @_); # usergroup here - 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; - } + # don't need to record this unless the password was changed + if ( $old->_password ne $new->_password ) { + $error ||= $new->insert_password_history; } - $error = $new->SUPER::replace($old); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error if $error; @@ -660,7 +994,7 @@ Called by the suspend method of FS::cust_pkg (see L). sub suspend { my $self = shift; return "can't suspend system account" if $self->_check_system; - $self->SUPER::suspend; + $self->SUPER::suspend(@_); } =item unsuspend @@ -682,7 +1016,7 @@ sub unsuspend { return $error if $error; } - $self->SUPER::unsuspend; + $self->SUPER::unsuspend(@_); } =item cancel @@ -713,7 +1047,7 @@ sub cancel { } } - $self->SUPER::cancel; + $self->SUPER::cancel(@_); } @@ -732,64 +1066,127 @@ sub check { my($recref) = $self->hashref; - my $x = $self->setfixed( $self->_fieldhandlers ); + my $x = $self->setfixed; return $x unless ref($x); my $part_svc = $x; - if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) { - $self->usergroup( - [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] ); - } - my $error = $self->ut_numbern('svcnum') #|| $self->ut_number('domsvc') - || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' ) + || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' ) + || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx', 'svcnum' ) + || $self->ut_foreign_keyn('sectornum','tower_sector','sectornum') + || $self->ut_foreign_keyn('routernum','router','routernum') + || $self->ut_foreign_keyn('blocknum','addr_block','blocknum') || $self->ut_textn('sec_phrase') || $self->ut_snumbern('seconds') || $self->ut_snumbern('upbytes') || $self->ut_snumbern('downbytes') || $self->ut_snumbern('totalbytes') + || $self->ut_snumbern('seconds_threshold') + || $self->ut_snumbern('upbytes_threshold') + || $self->ut_snumbern('downbytes_threshold') + || $self->ut_snumbern('totalbytes_threshold') + || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)]) + || $self->ut_enum('password_selfchange', [ '', 'Y' ]) + || $self->ut_enum('password_recover', [ '', 'Y' ]) + #cardfortress + || $self->ut_anything('cf_privatekey') + #communigate + || $self->ut_textn('cgp_accessmodes') + || $self->ut_alphan('cgp_type') + || $self->ut_textn('cgp_aliases' ) #well + # settings + || $self->ut_alphasn('cgp_rulesallowed') + || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ]) + || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ]) + || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ]) + || $self->ut_snumbern('cgp_archiveafter') + # preferences + || $self->ut_alphasn('cgp_deletemode') + || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values) + || $self->ut_alphan('cgp_language') + || $self->ut_textn('cgp_timezone') + || $self->ut_textn('cgp_skinname') + || $self->ut_textn('cgp_prontoskinname') + || $self->ut_alphan('cgp_sendmdnmode') ; return $error if $error; - my $ulen = $usernamemax || $self->dbdef_table->column('username')->length; - if ( $username_uppercase ) { - $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})$/ - or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username}; - $recref->{username} = $1; + # assign IP address, etc. + if ( $conf->exists('svc_acct-ip_addr') ) { + my $error = $self->svc_ip_check; + return $error if $error; + } else { # I think this is correct + $self->routernum(''); + $self->blocknum(''); + } + + my $cust_pkg; + local $username_letter = $username_letter; + local $username_uppercase = $username_uppercase; + if ($self->svcnum) { + my $cust_svc = $self->cust_svc + or return "no cust_svc record found for svcnum ". $self->svcnum; + my $cust_pkg = $cust_svc->cust_pkg; + } + if ($self->pkgnum) { + $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain? + } + if ($cust_pkg) { + $username_letter = + $conf->exists('username-letter', $cust_pkg->cust_main->agentnum); + $username_uppercase = + $conf->exists('username-uppercase', $cust_pkg->cust_main->agentnum); } + my $ulen = $usernamemax || $self->dbdef_table->column('username')->length; + + $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:\/\=\#\!]{$usernamemin,$ulen})$/i + or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username}; + $recref->{username} = $1; + + my $uerror = gettext('illegal_username'). ': '. $recref->{username}; + + unless ( $username_uppercase ) { + $recref->{username} =~ /[A-Z]/ and return $uerror; + } if ( $username_letterfirst ) { - $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username'); + $recref->{username} =~ /^[a-z]/ or return $uerror; } elsif ( $username_letter ) { - $recref->{username} =~ /[a-z]/ or return gettext('illegal_username'); + $recref->{username} =~ /[a-z]/ or return $uerror; } if ( $username_noperiod ) { - $recref->{username} =~ /\./ and return gettext('illegal_username'); + $recref->{username} =~ /\./ and return $uerror; } if ( $username_nounderscore ) { - $recref->{username} =~ /_/ and return gettext('illegal_username'); + $recref->{username} =~ /_/ and return $uerror; } if ( $username_nodash ) { - $recref->{username} =~ /\-/ and return gettext('illegal_username'); + $recref->{username} =~ /\-/ and return $uerror; } unless ( $username_ampersand ) { - $recref->{username} =~ /\&/ and return gettext('illegal_username'); + $recref->{username} =~ /\&/ and return $uerror; + } + unless ( $username_percent ) { + $recref->{username} =~ /\%/ and return $uerror; } - if ( $password_noampersand ) { - $recref->{_password} =~ /\&/ and return gettext('illegal_password'); + unless ( $username_colon ) { + $recref->{username} =~ /\:/ and return $uerror; } - if ( $password_noexclamation ) { - $recref->{_password} =~ /\!/ and return gettext('illegal_password'); + unless ( $username_slash ) { + $recref->{username} =~ /\// and return $uerror; } - unless ( $username_percent ) { - $recref->{username} =~ /\%/ and return gettext('illegal_username'); + unless ( $username_equals ) { + $recref->{username} =~ /\=/ and return $uerror; + } + unless ( $username_pound ) { + $recref->{username} =~ /\#/ and return $uerror; + } + unless ( $username_exclamation ) { + $recref->{username} =~ /\!/ and return $uerror; } + $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum}; $recref->{popnum} = $1; return "Unknown popnum" unless @@ -815,7 +1212,7 @@ sub check { $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0]; } else { return "Illegal shell \`". $self->shell. "\'; ". - $conf->dir. "/shells contains: @shells"; + "shells configuration value contains: @shells"; } } else { $recref->{shell} = '/bin/sync'; @@ -832,7 +1229,7 @@ sub check { unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) { - $recref->{dir} =~ /^([\/\w\-\.\&]*)$/ + $recref->{dir} =~ /^([\/\w\-\.\&\:\#]*)$/ or return "Illegal directory: ". $recref->{dir}; $recref->{dir} = $1; return "Illegal directory" @@ -856,8 +1253,6 @@ sub check { } - # $error = $self->ut_textn('finger'); - # return $error if $error; if ( $self->getfield('finger') eq '' ) { my $cust_pkg = $self->svcnum ? $self->cust_svc->cust_pkg @@ -867,17 +1262,22 @@ sub check { $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') ); } } - $self->getfield('finger') =~ - /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/ + # $error = $self->ut_textn('finger'); + # return $error if $error; + $self->getfield('finger') =~ /^([\w \,\.\-\'\&\t\!\@\#\$\%\(\)\+\;\"\?\/\*\<\>]*)$/ or return "Illegal finger: ". $self->getfield('finger'); $self->setfield('finger', $1); - $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota"; - $recref->{quota} = $1; + for (qw( quota file_quota file_maxsize )) { + $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_"; + $recref->{$_} = $1; + } + $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum"; + $recref->{file_maxnum} = $1; unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) { if ( $recref->{slipip} eq '' ) { - $recref->{slipip} = ''; + $recref->{slipip} = ''; # eh? } elsif ( $recref->{slipip} eq '0e0' ) { $recref->{slipip} = '0e0'; } else { @@ -885,7 +1285,6 @@ sub check { or return "Illegal slipip: ". $self->slipip; $recref->{slipip} = $1; } - } #arbitrary RADIUS stuff; allow ut_textn for now @@ -893,36 +1292,205 @@ sub check { $self->ut_textn($_); } - #generate a password if it is blank - $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) ) - unless ( $recref->{_password} ); - - #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) { - if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) { - $recref->{_password} = $1.$3; - #uncomment this to encrypt password immediately upon entry, or run - #bin/crypt_pw in cron to give new users a window during which their - #password is available to techs, for faxing, etc. (also be aware of - #radius issues!) - #$recref->{password} = $1. - # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))] - #; - } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) { - $recref->{_password} = $1.$3; - } elsif ( $recref->{_password} eq '*' ) { - $recref->{_password} = '*'; - } elsif ( $recref->{_password} eq '!' ) { - $recref->{_password} = '!'; - } elsif ( $recref->{_password} eq '!!' ) { - $recref->{_password} = '!!'; - } else { - #return "Illegal password"; - return gettext('illegal_password'). " $passwordmin-$passwordmax ". - FS::Msgcat::_gettext('illegal_password_characters'). - ": ". $recref->{_password}; + # First, if _password is blank, generate one and set default encoding. + if ( ! $recref->{_password} ) { + $error = $self->set_password(''); + } + # But if there's a _password but no encoding, assume it's plaintext and + # set it to default encoding. + elsif ( ! $recref->{_password_encoding} ) { + $error = $self->set_password($recref->{_password}); + } + return $error if $error; + + # Next, check _password to ensure compliance with the encoding. + if ( $recref->{_password_encoding} eq 'ldap' ) { + + if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) { + $recref->{_password} = uc($1).$2; + } else { + return 'Illegal (ldap-encoded) password: '. $recref->{_password}; + } + + } elsif ( $recref->{_password_encoding} eq 'crypt' ) { + + if ( $recref->{_password} =~ + #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/ + /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/ + ) { + + $recref->{_password} = ( defined($1) ? $1 : '' ). $2; + + } else { + return 'Illegal (crypt-encoded) password: '. $recref->{_password}; + } + + } elsif ( $recref->{_password_encoding} eq 'plain' ) { + # Password randomization is now in set_password. + # Strip whitespace characters, check length requirements, etc. + if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) { + $recref->{_password} = $1; + } else { + return gettext('illegal_password'). " $passwordmin-$passwordmax ". + FS::Msgcat::_gettext('illegal_password_characters'); + } + + if ( $password_noampersand ) { + $recref->{_password} =~ /\&/ and return gettext('illegal_password'); + } + if ( $password_noexclamation ) { + $recref->{_password} =~ /\!/ and return gettext('illegal_password'); + } + } + else { + return "invalid password encoding ('".$recref->{_password_encoding}."'"; } $self->SUPER::check; + +} + + +sub _password_encryption { + my $self = shift; + my $encoding = lc($self->_password_encoding); + return if !$encoding; + return 'plain' if $encoding eq 'plain'; + if($encoding eq 'crypt') { + my $pass = $self->_password; + $pass =~ s/^\*SUSPENDED\* //; + $pass =~ s/^!!?//; + return 'md5' if $pass =~ /^\$1\$/; + #return 'blowfish' if $self->_password =~ /^\$2\$/; + return 'des' if length($pass) == 13; + return; + } + if($encoding eq 'ldap') { + uc($self->_password) =~ /^\{([\w-]+)\}/; + return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES'; + return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT'; + return 'md5' if $1 eq 'MD5'; + return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1'; + + return; + } + return; +} + +sub get_cleartext_password { + my $self = shift; + if($self->_password_encryption eq 'plain') { + if($self->_password_encoding eq 'ldap') { + $self->_password =~ /\{\w+\}(.*)$/; + return $1; + } + else { + return $self->_password; + } + } + return; +} + + +=item set_password + +Set the cleartext password for the account. If _password_encoding is set, the +new password will be encoded according to the existing method (including +encryption mode, if it can be determined). Otherwise, +config('default-password-encoding') is used. + +If no password is supplied (or a zero-length password when minimum password length +is >0), one will be generated randomly. + +=cut + +sub set_password { + my( $self, $pass ) = ( shift, shift ); + + warn "[$me] set_password (to $pass) called on $self: ". Dumper($self) + if $DEBUG; + + my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ". + FS::Msgcat::_gettext('illegal_password_characters'). + ": ". $pass; + + my( $encoding, $encryption ) = ('', ''); + + if ( $self->_password_encoding ) { + $encoding = $self->_password_encoding; + # identify existing encryption method, try to use it. + $encryption = $self->_password_encryption; + if (!$encryption) { + # use the system default + undef $encoding; + } + } + + if ( !$encoding ) { + # set encoding to system default + ($encoding, $encryption) = + split(/-/, lc($conf->config('default-password-encoding') || '')); + $encoding ||= 'legacy'; + $self->_password_encoding($encoding); + } + + if ( $encoding eq 'legacy' ) { + + # The legacy behavior from check(): + # If the password is blank, randomize it and set encoding to 'plain'. + if(!defined($pass) or (length($pass) == 0 and $passwordmin)) { + $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) ); + $self->_password_encoding('plain'); + } else { + # Prefix + valid-length password + if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) { + $pass = $1.$3; + $self->_password_encoding('plain'); + # Prefix + crypt string + } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) { + $pass = $1.$3; + $self->_password_encoding('crypt'); + # Various disabled crypt passwords + } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) { + $self->_password_encoding('crypt'); + } else { + return $failure; + } + } + + $self->_password($pass); + return; + + } + + return $failure + if $passwordmin && length($pass) < $passwordmin + or $passwordmax && length($pass) > $passwordmax; + + if ( $encoding eq 'crypt' ) { + if ($encryption eq 'md5') { + $pass = unix_md5_crypt($pass); + } elsif ($encryption eq 'des') { + $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]); + } + + } elsif ( $encoding eq 'ldap' ) { + if ($encryption eq 'md5') { + $pass = md5_base64($pass); + } elsif ($encryption eq 'sha1') { + $pass = sha1_base64($pass); + } elsif ($encryption eq 'crypt') { + $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]); + } + # else $encryption eq 'plain', do nothing + $pass .= '=' x (4 - length($pass) % 4) #properly padded base64 + if $encryption eq 'md5' || $encryption eq 'sha1'; + $pass = '{'.uc($encryption).'}'.$pass; + } + # else encoding eq 'plain' + + $self->_password($pass); + return; } =item _check_system @@ -942,7 +1510,7 @@ sub _check_system { =item _check_duplicate -Internal function to check for duplicates usernames, username@domain pairs and +Internal method to check for duplicates usernames, username@domain pairs and uids. If the I configuration value is set to B or @@ -959,12 +1527,7 @@ sub _check_duplicate { my $global_unique = $conf->config('global_unique-username') || 'none'; return '' if $global_unique eq 'disabled'; - #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; + $self->lock_table; my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } ); unless ( $part_svc ) { @@ -1028,7 +1591,8 @@ sub _check_duplicate { 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. + return "duplicate username ". $self->username. + ": conflicts with svcnum ". $dup_user->svcnum. " via exportnum ". $conflict_user_svcpart{$dup_svcpart}; } } @@ -1036,9 +1600,9 @@ sub _check_duplicate { 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}; + return "duplicate username\@domain ". $self->email. + ": conflicts with svcnum ". $dup_userdomain->svcnum. + " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart}; } } @@ -1046,9 +1610,11 @@ sub _check_duplicate { 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 "duplicate uid ". $self->uid. + ": conflicts with svcnum ". $dup_uid->svcnum. + " via exportnum ". + ( $conflict_user_svcpart{$dup_svcpart} + || $conflict_userdomain_svcpart{$dup_svcpart} ); } } @@ -1102,6 +1668,29 @@ sub radius_reply { $reply{'Session-Timeout'} = $self->seconds; } + if ( $conf->exists('radius-chillispot-max') ) { + #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot + + #hmm. just because sqlradius.pm says so? + my %whatis = ( + 'input' => 'up', + 'output' => 'down', + 'total' => 'total', + ); + + foreach my $what (qw( input output total )) { + my $is = $whatis{$what}.'bytes'; + if ( $self->$is() =~ /\d/ ) { + my $big = new Math::BigInt $self->$is(); + $big = new Math::BigInt '0' if $big->is_neg(); + my $att = "Chillispot-Max-\u$what"; + $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr; + $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr; + } + } + + } + %reply; } @@ -1130,25 +1719,57 @@ sub radius_check { ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) ); } 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($pw_attrib, $password) = $self->radius_password; + $check{$pw_attrib} = $password; my $cust_svc = $self->cust_svc; - die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n" - unless $cust_svc; - my $cust_pkg = $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 + if ( $cust_svc ) { + my $cust_pkg = $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 + } + } else { + warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum. + "; can't set Expiration\n" + unless $cust_svc; } %check; } -=item snapshot +=item radius_password -This method instructs the object to "snapshot" or freeze RADIUS check and -reply attributes to the current values. +Returns a key/value pair containing the RADIUS attribute name and value +for the password. + +=cut + +sub radius_password { + my $self = shift; + + my $pw_attrib; + if ( $self->_password_encoding eq 'ldap' ) { + $pw_attrib = 'Password-With-Header'; + } elsif ( $self->_password_encoding eq 'crypt' ) { + $pw_attrib = 'Crypt-Password'; + } elsif ( $self->_password_encoding eq 'plain' ) { + $pw_attrib = $radius_password; + } else { + $pw_attrib = length($self->_password) <= 12 + ? $radius_password + : 'Crypt-Password'; + } + + ($pw_attrib, $self->_password); + +} + +=item snapshot + +This method instructs the object to "snapshot" or freeze RADIUS check and +reply attributes to the current values. =cut @@ -1180,10 +1801,13 @@ sub forget_snapshot { } -=item domain +=item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ] Returns the domain associated with this account. +END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with +history records. + =cut sub domain { @@ -1194,20 +1818,6 @@ sub domain { $svc_domain->domain; } -=item svc_domain - -Returns the FS::svc_domain record for this account's domain (see -L). - -=cut - -sub svc_domain { - my $self = shift; - $self->{'_domsvc'} - ? $self->{'_domsvc'} - : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } ); -} - =item cust_svc Returns the FS::cust_svc record for this account (see L). @@ -1216,10 +1826,13 @@ Returns the FS::cust_svc record for this account (see L). #inherited from svc_Common -=item email +=item email [ END_TIMESTAMP [ START_TIMESTAMP ] ] Returns an email address associated with the account. +END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with +history records. + =cut sub email { @@ -1227,20 +1840,24 @@ sub email { $self->username. '@'. $self->domain(@_); } + =item acct_snarf Returns an array of FS::acct_snarf records associated with the account. -If the acct_snarf table does not exist or there are no associated records, -an empty list is returned =cut -sub acct_snarf { +# unused as originally intended, but now by Communigate Pro "RPOP" + +=item cgp_rpop_hashref + +Returns an arrayref of RPOP data suitable for Communigate Pro API commands. + +=cut + +sub cgp_rpop_hashref { my $self = shift; - return () unless dbdef->table('acct_snarf'); - eval "use FS::acct_snarf;"; - die $@ if $@; - qsearch('acct_snarf', { 'svcnum' => $self->svcnum } ); + { map { $_->snarfname => $_->cgp_hashref } $self->acct_snarf }; } =item decrement_upbytes OCTETS @@ -1341,7 +1958,7 @@ my %op2condition = ( $self->$column - $amount <= 0; }, '+' => sub { my($self, $column, $amount) = @_; - $self->$column + $amount > 0; + ($self->$column || 0) + $amount > 0; }, ); my %op2warncondition = ( @@ -1350,7 +1967,7 @@ my %op2warncondition = ( $self->$column - $amount <= $self->$threshold + 0; }, '+' => sub { my($self, $column, $amount) = @_; - $self->$column + $amount > 0; + ($self->$column || 0) + $amount > 0; }, ); @@ -1363,6 +1980,9 @@ sub _op_usage { return '' unless $amount; + return '' + if $self->cust_svc->part_svc->part_svc_column($column)->columnflag eq 'F'; + local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; local $SIG{QUIT} = 'IGNORE'; @@ -1388,35 +2008,80 @@ sub _op_usage { die "Can't update $column for svcnum". $self->svcnum if $rv == 0; + if ( $conf->exists('radius-chillispot-max') + || scalar($conf->config('support_packages')) + ) + { + #$self->snapshot; #not necessary, we retain the old values + #create an object with the updated usage values + my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum }); + #call exports + my $error = $new->replace($self); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error replacing: $error"; + } + } + + #overlimit_action eq 'cancel' handling + my $cust_pkg = $self->cust_svc->cust_pkg; + if ( $cust_pkg + && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel' + && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount) + ) + { + + my $error = $cust_pkg->cancel; #XXX should have a reason + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error cancelling: $error"; + } + + #nothing else is relevant if we're cancelling, so commit & return success + warn "$me update successful; committing\n" + if $DEBUG; + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + return ''; + + } + my $action = $op2action{$op}; + if ( &{$op2condition{$op}}($self, $column, $amount) && + ( $action eq 'suspend' && !$self->overlimit + || $action eq 'unsuspend' && $self->overlimit ) + ) { + + my $error = $self->_op_overlimit($action); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + } + if ( $conf->exists("svc_acct-usage_$action") && &{$op2condition{$op}}($self, $column, $amount) ) { #my $error = $self->$action(); my $error = $self->cust_svc->cust_pkg->$action(); + # $error ||= $self->overlimit($action); if ( $error ) { $dbh->rollback if $oldAutoCommit; return "Error ${action}ing: $error"; } } - if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) { + if ($warning_msgnum && &{$op2warncondition{$op}}($self, $column, $amount)) { my $wqueue = new FS::queue { 'svcnum' => $self->svcnum, 'job' => 'FS::svc_acct::reached_threshold', }; - my $to = ''; - if ($op eq '-'){ - $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount); - } - # x_threshold race my $error = $wqueue->insert( 'svcnum' => $self->svcnum, 'op' => $op, - 'column' => $column, - 'to' => $to, + 'column' => $column ); if ( $error ) { $dbh->rollback if $oldAutoCommit; @@ -1431,8 +2096,62 @@ sub _op_usage { } +sub _op_overlimit { + my( $self, $action ) = @_; + + 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 $cust_pkg = $self->cust_svc->cust_pkg; + + my @conf_overlimit = + $cust_pkg + ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum ) + : $conf->config('overlimit_groups'); + + foreach my $part_export ( $self->cust_svc->part_svc->part_export ) { + + my @groups = scalar(@conf_overlimit) ? @conf_overlimit + : split(' ',$part_export->option('overlimit_groups')); + next unless scalar(@groups); + + my $other = new FS::svc_acct $self->hashref; + $other->usergroup(\@groups); + + my($new,$old); + if ($action eq 'suspend') { + $new = $other; + $old = $self; + } else { # $action eq 'unsuspend' + $new = $self; + $old = $other; + } + + my $error = $part_export->export_replace($new, $old) + || $self->overlimit($action); + + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error replacing radius groups: $error"; + } + + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + sub set_usage { - my( $self, $valueref ) = @_; + my( $self, $valueref, %options ) = @_; warn "$me set_usage called for svcnum ". $self->svcnum. ' ('. $self->email. "): ". @@ -1446,19 +2165,20 @@ sub set_usage { local $SIG{TSTP} = 'IGNORE'; local $SIG{PIPE} = 'IGNORE'; + local $FS::svc_Common::noexport_hack = 1; my $oldAutoCommit = $FS::UID::AutoCommit; local $FS::UID::AutoCommit = 0; my $dbh = dbh; - if ( $conf->exists("svc_acct-usage_unsuspend") ) { - my $error = $self->cust_svc->cust_pkg->unsuspend; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Error unsuspending: $error"; - } + my $reset = 0; + my %handyhash = (); + if ( $options{null} ) { + %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) } + qw( seconds upbytes downbytes totalbytes ) + ); } - foreach my $field (keys %$valueref){ + $reset = 1 if $valueref->{$field}; $self->setfield($field, $valueref->{$field}); $self->setfield( $field.'_threshold', int($self->getfield($field) @@ -1468,9 +2188,57 @@ sub set_usage { ) ) ); + $handyhash{$field} = $self->getfield($field); + $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold'); + } + #my $error = $self->replace; #NO! we avoid the call to ->check for + #die $error if $error; #services not explicity changed via the UI + + my $sql = "UPDATE svc_acct SET " . + join (',', map { "$_ = ?" } (keys %handyhash) ). + " WHERE svcnum = ". $self->svcnum; + + warn "$me $sql\n" + if $DEBUG; + + if (scalar(keys %handyhash)) { + my $sth = $dbh->prepare( $sql ) + or die "Error preparing $sql: ". $dbh->errstr; + my $rv = $sth->execute(values %handyhash); + die "Error executing $sql: ". $sth->errstr + unless defined($rv); + die "Can't update usage for svcnum ". $self->svcnum + if $rv == 0; + } + + if ( $conf->exists('radius-chillispot-max') ) { + #$self->snapshot; #not necessary, we retain the old values + #create an object with the updated usage values + my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum }); + local($FS::Record::nowarn_identical) = 1; + my $error = $new->replace($self); #call exports + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error replacing: $error"; + } + } + + if ( $reset ) { + + my $error = ''; + + $error = $self->_op_overlimit('unsuspend') + if $self->overlimit;; + + $error ||= $self->cust_svc->cust_pkg->unsuspend + if $conf->exists("svc_acct-usage_unsuspend"); + + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error unsuspending: $error"; + } + } - my $error = $self->replace; - die $error if $error; warn "$me update successful; committing\n" if $DEBUG; @@ -1529,7 +2297,7 @@ sub is_rechargable { =item seconds_since TIMESTAMP Returns the number of seconds this account has been online since TIMESTAMP, -according to the session monitor (see L). +according to the session monitor (see L). TIMESTAMP is specified as a UNIX timestamp; see L. Also see L and L for conversion functions. @@ -1542,141 +2310,114 @@ sub seconds_since { $self->cust_svc->seconds_since(@_); } -=item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END - -Returns the numbers of seconds this account has been online between -TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an -external SQL radacct table, specified via sqlradius export. Sessions which -started in the specified range but are still open are counted from session -start to the end of the range (unless they are over 1 day old, in which case -they are presumed missing their stop record and not counted). Also, sessions -which end in the range but started earlier are counted from the start of the -range to session end. Finally, sessions which start before the range but end -after are counted for the entire range. +=item last_login_text -TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see -L. Also see L and L for conversion -functions. +Returns text describing the time of last login. =cut -#note: POD here, implementation in FS::cust_svc -sub seconds_since_sqlradacct { +sub last_login_text { my $self = shift; - $self->cust_svc->seconds_since_sqlradacct(@_); + $self->last_login ? ctime($self->last_login) : 'unknown'; } -=item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE - -Returns the sum of the given attribute for all accounts (see L) -in this package for sessions ending between TIMESTAMP_START (inclusive) and -TIMESTAMP_END (exclusive). +=item psearch_cdrs OPTIONS -TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see -L. Also see L and L for conversion -functions. +Returns a paged search (L) for Call Detail Records +associated with this service. For svc_acct, "associated with" means that +either the "src" or the "charged_party" field of the CDR matches either +the "username" field of the service or the username@domain label. =cut -#note: POD here, implementation in FS::cust_svc -sub attribute_since_sqlradacct { - my $self = shift; - $self->cust_svc->attribute_since_sqlradacct(@_); -} +sub psearch_cdrs { + my($self, %options) = @_; + my @fields; + my %hash; + my @where; -=item get_session_history TIMESTAMP_START TIMESTAMP_END + my $did = dbh->quote($self->username); + my $diddomain = dbh->quote($self->label); -Returns an array of hash references of this customers login history for the -given time range. (document this better) + my $prefix = $options{'default_prefix'} || ''; #convergent.au '+61' + my $prefixdid = dbh->quote($prefix . $self->username); -=cut - -sub get_session_history { - my $self = shift; - $self->cust_svc->get_session_history(@_); -} + my $for_update = $options{'for_update'} ? 'FOR UPDATE' : ''; -=item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ] - -=cut - -sub get_cdrs { - my($self, $start, $end, %opt ) = @_; - - my $did = $self->username; #yup - - my $prefix = $opt{'default_prefix'}; #convergent.au '+61' - - my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : ''; - - #SELECT $for_update * FROM cdr - # WHERE calldate >= $start #need a conversion - # AND calldate < $end #ditto - # AND ( charged_party = "$did" - # OR charged_party = "$prefix$did" #if length($prefix); - # OR ( ( charged_party IS NULL OR charged_party = '' ) - # AND - # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix) - # ) - # ) - # AND ( freesidestatus IS NULL OR freesidestatus = '' ) - - my $charged_or_src; - if ( length($prefix) ) { - $charged_or_src = - " AND ( charged_party = '$did' - OR charged_party = '$prefix$did' - OR ( ( charged_party IS NULL OR charged_party = '' ) - AND - ( src = '$did' OR src = '$prefix$did' ) - ) - ) - "; - } else { - $charged_or_src = - " AND ( charged_party = '$did' - OR ( ( charged_party IS NULL OR charged_party = '' ) - AND - src = '$did' - ) - ) - "; + if ( $options{inbound} ) { + # these will be selected under their DIDs + push @where, "FALSE"; + } + my @orwhere; + if (!$options{'disable_charged_party'}) { + push @orwhere, + "charged_party = $did", + "charged_party = $prefixdid", + "charged_party = $diddomain" + ; } + if (!$options{'disable_src'}) { + push @orwhere, + "src = $did AND charged_party IS NULL", + "src = $prefixdid AND charged_party IS NULL", + "src = $diddomain AND charged_party IS NULL" + ; + } + push @where, '(' . join(' OR ', @orwhere) . ')'; - qsearch( - 'select' => "$for_update *", + # $options{'status'} = '' is meaningful; for the rest of them it's not + if ( exists $options{'status'} ) { + $hash{'freesidestatus'} = $options{'status'}; + } + if ( $options{'cdrtypenum'} ) { + $hash{'cdrtypenum'} = $options{'cdrtypenum'}; + } + if ( $options{'calltypenum'} ) { + $hash{'calltypenum'} = $options{'calltypenum'}; + } + if ( $options{'begin'} ) { + push @where, 'startdate >= '. $options{'begin'}; + } + if ( $options{'end'} ) { + push @where, 'startdate < '. $options{'end'}; + } + if ( $options{'nonzero'} ) { + push @where, 'duration > 0'; + } + + my $extra_sql = join(' AND ', @where); + if ($extra_sql) { + if (keys %hash) { + $extra_sql = " AND ".$extra_sql; + } else { + $extra_sql = " WHERE ".$extra_sql; + } + } + return psearch({ + 'select' => '*', 'table' => 'cdr', - 'hashref' => { - #( freesidestatus IS NULL OR freesidestatus = '' ) - 'freesidestatus' => '', - }, - 'extra_sql' => $charged_or_src, - - ); - + 'hashref' => \%hash, + 'extra_sql' => $extra_sql, + 'order_by' => "ORDER BY startdate $for_update", + }); } -=item radius_groups +=item get_cdrs (DEPRECATED) -Returns all RADIUS groups for this account (see L). +Like psearch_cdrs, but returns all the L objects at once, in a +single list. Arguments are the same as for psearch_cdrs. =cut -sub radius_groups { +sub get_cdrs { my $self = shift; - if ( $self->usergroup ) { - confess "explicitly specified usergroup not an arrayref: ". $self->usergroup - unless ref($self->usergroup) eq 'ARRAY'; - #when provisioning records, export callback runs in svc_Common.pm before - #radius_usergroup records can be inserted... - @{$self->usergroup}; - } else { - map { $_->groupname } - qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } ); - } + my $psearch = $self->psearch_cdrs(@_); + qsearch ( $psearch->{query} ) } +# sub radius_groups has moved to svc_Radius_Mixin + =item clone_suspended Constructor used by FS::part_export::_export_suspend fallback. Document @@ -1721,23 +2462,43 @@ sub check_password { #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; + if ( $self->_password_encoding eq 'ldap' ) { + + $password =~ s/^{PLAIN}/{CLEARTEXT}/; + my $auth = from_rfc2307 Authen::Passphrase $password; + return $auth->match($check_password); + + } elsif ( $self->_password_encoding eq 'crypt' ) { + + my $auth = from_crypt Authen::Passphrase $self->_password; + return $auth->match($check_password); + + } elsif ( $self->_password_encoding eq 'plain' ) { + + return $check_password eq $password; + } else { - warn "Can't check password: Unrecognized encryption for svcnum ". - $self->svcnum. "\n"; - 0; + + #XXX this could be replaced with Authen::Passphrase stuff + + 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; + } + } } @@ -1758,35 +2519,100 @@ database. sub crypt_password { my $self = shift; - #eventually should check a "password-encoding" field - if ( length($self->_password) == 13 - || $self->_password =~ /^\$(1|2a?)\$/ - || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/ - ) - { - $self->_password; - } else { + + if ( $self->_password_encoding eq 'ldap' ) { + + if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) { + my $plain = $2; + + #XXX this could be replaced with Authen::Passphrase stuff + + my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt'; + if ( $encryption eq 'crypt' ) { + return crypt( + $self->_password, + $saltset[int(rand(64))].$saltset[int(rand(64))] + ); + } elsif ( $encryption eq 'md5' ) { + return unix_md5_crypt( $self->_password ); + } elsif ( $encryption eq 'blowfish' ) { + croak "unknown encryption method $encryption"; + } else { + croak "unknown encryption method $encryption"; + } + + } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) { + return $1; + } + + } elsif ( $self->_password_encoding eq 'crypt' ) { + + return $self->_password; + + } elsif ( $self->_password_encoding eq 'plain' ) { + + #XXX this could be replaced with Authen::Passphrase stuff + my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt'; if ( $encryption eq 'crypt' ) { - crypt( + return crypt( $self->_password, $saltset[int(rand(64))].$saltset[int(rand(64))] ); } elsif ( $encryption eq 'md5' ) { - unix_md5_crypt( $self->_password ); + return unix_md5_crypt( $self->_password ); + } elsif ( $encryption eq 'sha512' ) { + return crypt( + $self->_password, + '$6$rounds=15420$'. join('', map $saltset[int(rand(64))], (1..16) ) + ); + } elsif ( $encryption eq 'sha1_base64' ) { #for acct_sql + my $pass = sha1_base64( $self->_password ); + $pass .= '=' x (4 - length($pass) % 4); #properly padded base64 + return $pass; } elsif ( $encryption eq 'blowfish' ) { croak "unknown encryption method $encryption"; } else { croak "unknown encryption method $encryption"; } + + } else { + + if ( length($self->_password) == 13 + || $self->_password =~ /^\$(1|2a?)\$/ + || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/ + ) + { + $self->_password; + } else { + + #XXX this could be replaced with Authen::Passphrase stuff + + my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt'; + if ( $encryption eq 'crypt' ) { + return crypt( + $self->_password, + $saltset[int(rand(64))].$saltset[int(rand(64))] + ); + } elsif ( $encryption eq 'md5' ) { + return unix_md5_crypt( $self->_password ); + } elsif ( $encryption eq 'blowfish' ) { + croak "unknown encryption method $encryption"; + } else { + croak "unknown encryption method $encryption"; + } + + } + } + } =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ] Returns an encrypted password in "LDAP" format, with a curly-bracked prefix -describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or -"{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f". +describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or +"{MD5}5426824942db4253f87a1009fd5d2d4". The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it to work the same as the B method. @@ -1796,33 +2622,71 @@ to work the same as the B method. sub ldap_password { my $self = shift; #eventually should check a "password-encoding" field - if ( length($self->_password) == 13 ) { #crypt - return '{CRYPT}'. $self->_password; - } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5 - return '{MD5}'. $1; - } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish - die "Blowfish encryption not supported in this context, svcnum ". - $self->svcnum. "\n"; - } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA - return '{SSHA}'. $1; - } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5 - return '{NS-MTA-MD5}'. $1; - } else { #plaintext + + if ( $self->_password_encoding eq 'ldap' ) { + + return $self->_password; + + } elsif ( $self->_password_encoding eq 'crypt' ) { + + if ( length($self->_password) == 13 ) { #crypt + return '{CRYPT}'. $self->_password; + } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5 + return '{MD5}'. $1; + #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish + # die "Blowfish encryption not supported in this context, svcnum ". + # $self->svcnum. "\n"; + } else { + warn "encryption method not (yet?) supported in LDAP context"; + return '{CRYPT}*'; #unsupported, should not auth + } + + } elsif ( $self->_password_encoding eq 'plain' ) { + return '{PLAIN}'. $self->_password; - #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt'; - #if ( $encryption eq 'crypt' ) { - # return '{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' ) { - # croak "unknown encryption method $encryption"; - #} else { - # croak "unknown encryption method $encryption"; - #} + + #return '{CLEARTEXT}'. $self->_password; #? + + } else { + + if ( length($self->_password) == 13 ) { #crypt + return '{CRYPT}'. $self->_password; + } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5 + return '{MD5}'. $1; + } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish + warn "Blowfish encryption not supported in this context, svcnum ". + $self->svcnum. "\n"; + return '{CRYPT}*'; + + #are these two necessary anymore? + } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA + return '{SSHA}'. $1; + } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5 + return '{NS-MTA-MD5}'. $1; + + } else { #plaintext + return '{PLAIN}'. $self->_password; + + #return '{CLEARTEXT}'. $self->_password; #? + + #XXX this could be replaced with Authen::Passphrase stuff if it gets used + #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt'; + #if ( $encryption eq 'crypt' ) { + # return '{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' ) { + # croak "unknown encryption method $encryption"; + #} else { + # croak "unknown encryption method $encryption"; + #} + } + } + } =item domain_slash_username @@ -1847,44 +2711,112 @@ sub virtual_maildir { $self->domain. '/maildirs/'. $self->username. '/'; } +=item password_svc_check + +Override, for L. Not really intended for other use. + +=cut + +sub password_svc_check { + my ($self, $password) = @_; + foreach my $field ( qw(username finger) ) { + foreach my $word (split(/\W+/,$self->get($field))) { + next unless length($word) > 2; + if ($password =~ /$word/i) { + return qq(Password contains account information '$word'); + } + } + } + return ''; +} + =back -=head1 SUBROUTINES +=head1 CLASS METHODS =over 4 -=item send_email +=item search HASHREF -This is the FS::svc_acct job-queue-able version. It still uses -FS::Misc::send_email under-the-hood. +Class method which returns a qsearch hash expression to search for parameters +specified in HASHREF. Valid parameters are + +=over 4 + +=item domain + +=item domsvc + +=item unlinked + +=item agentnum + +=item pkgpart + +Arrayref of pkgparts + +=item pkgpart + +=item where + +Arrayref of additional WHERE clauses, will be ANDed together. + +=item order_by + +=item cust_fields + +=back =cut -sub send_email { - my %opt = @_; +sub _search_svc { + my( $class, $params, $from, $where ) = @_; - eval "use FS::Misc qw(send_email)"; - die $@ if $@; + #these two should probably move to svc_Domain_Mixin ? - $opt{mimetype} ||= 'text/plain'; - $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/; + # domain + if ( $params->{'domain'} ) { + my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } ); + #preserve previous behavior & bubble up an error if $svc_domain not found? + push @$where, 'domsvc = '. $svc_domain->svcnum if $svc_domain; + } + + # domsvc + if ( $params->{'domsvc'} =~ /^(\d+)$/ ) { + push @$where, "domsvc = $1"; + } + + + # popnum + if ( $params->{'popnum'} =~ /^(\d+)$/ ) { + push @$where, "popnum = $1"; + } + + + #and these in svc_Tower_Mixin, or maybe we never should have done svc_acct + # towers (or, as mark thought, never should have done svc_broadband) + + # sector and tower + my @where_sector = $class->tower_sector_sql($params); + if ( @where_sector ) { + push @$where, @where_sector; + push @$from, ' LEFT JOIN tower_sector USING ( sectornum )'; + } - my $error = send_email( - 'from' => $opt{from}, - 'to' => $opt{to}, - 'subject' => $opt{subject}, - 'content-type' => $opt{mimetype}, - 'body' => [ map "$_\n", split("\n", $opt{body}) ], - ); - die $error if $error; } +=back + +=head1 SUBROUTINES + +=over 4 + =item check_and_rebuild_fuzzyfiles =cut sub check_and_rebuild_fuzzyfiles { - my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc; + my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc; -e "$dir/svc_acct.username" or &rebuild_fuzzyfiles; } @@ -1897,7 +2829,7 @@ sub rebuild_fuzzyfiles { use Fcntl qw(:flock); - my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc; + my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc; #username @@ -1923,7 +2855,7 @@ sub rebuild_fuzzyfiles { =cut sub all_username { - my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc; + my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc; open(USERNAMECACHE,"<$dir/svc_acct.username") or die "can't open $dir/svc_acct.username: $!"; my @array = map { chomp; $_; } ; @@ -1942,7 +2874,7 @@ sub append_fuzzyfiles { use Fcntl qw(:flock); - my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc; + my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc; open(USERNAME,">>$dir/svc_acct.username") or die "can't open $dir/svc_acct.username: $!"; @@ -1959,56 +2891,6 @@ sub append_fuzzyfiles { } - -=item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ] - -=cut - -sub radius_usergroup_selector { - my $sel_groups = shift; - my %sel_groups = map { $_=>1 } @$sel_groups; - - my $selectname = shift || 'radius_usergroup'; - - my $dbh = dbh; - my $sth = $dbh->prepare( - 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname' - ) or die $dbh->errstr; - $sth->execute() or die $sth->errstr; - my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref}; - - my $html = < - function ${selectname}_doadd(object) { - var myvalue = object.${selectname}_add.value; - var optionName = new Option(myvalue,myvalue,false,true); - var length = object.$selectname.length; - object.$selectname.options[length] = optionName; - object.${selectname}_add.value = ""; - } - - '; - - $html .= qq!
!. - qq!!; - - $html; -} - =item reached_threshold Performs some activities when svc_acct thresholds (such as number of seconds @@ -2042,43 +2924,33 @@ sub reached_threshold { my $error = $svc_acct->replace; die $error if $error; # email next time, i guess - if ( $warning_template ) { - eval "use FS::Misc qw(send_email)"; - die $@ if $@; + if ( $warning_msgnum ) { + + my $msg_template = qsearchs('msg_template',{ msgnum => $warning_msgnum }); + die "Could not load template for threshold_warning_msgnum ($warning_msgnum)" unless $msg_template; + + my $cust_main = $svc_acct->cust_svc->cust_pkg->cust_main; + + my $to = join(', ', $cust_main->invoicing_list_emailonly ); + + my $error = $msg_template->send( + cust_main => $cust_main, + object => $svc_acct, + to => $to, + substitutions => { + # have to override these, because we changed threshold above + 'column' => $opt{'column'}, + 'amount' => $opt{'column'} =~/bytes/ + ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'})) + : $svc_acct->getfield($opt{'column'}), + 'threshold' => $opt{'column'} =~/bytes/ + ? FS::UI::bytecount::display_bytecount($threshold) + : $threshold, + }, + ); - my $cust_pkg = $svc_acct->cust_svc->cust_pkg; - my $cust_main = $cust_pkg->cust_main; + die "Error sending threshold warning email: $error" if $error; - my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } - $cust_main->invoicing_list, - $svc_acct->email, - ($opt{'to'} ? $opt{'to'} : ()) - ); - - my $mimetype = $warning_mimetype; - $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/; - - my $body = $warning_template->fill_in( HASH => { - 'custnum' => $cust_main->custnum, - 'username' => $svc_acct->username, - 'password' => $svc_acct->_password, - 'first' => $cust_main->first, - 'last' => $cust_main->getfield('last'), - 'pkg' => $cust_pkg->part_pkg->pkg, - 'column' => $opt{'column'}, - 'amount' => $svc_acct->getfield($opt{'column'}), - 'threshold' => $threshold, - } ); - - - my $error = send_email( - 'from' => $warning_from, - 'to' => $to, - 'subject' => $warning_subject, - 'content-type' => $mimetype, - 'body' => [ map "$_\n", split("\n", $body) ], - ); - die $error if $error; } }else{ die "unknown op: " . $opt{'op'}; @@ -2095,12 +2967,11 @@ The suspend, unsuspend and cancel methods update the database, but not the current object. This is probably a bug as it's unexpected and counterintuitive. -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) +_op_usage and set_usage bypass the history... maybe they shouldn't + =head1 SEE ALSO L, edit/part_svc.cgi from an installed web interface, @@ -2112,4 +2983,3 @@ schema.html from the base documentation. =cut 1; -