From 49d9ea969069430ef3fe23e5b1ac3599e929bb04 Mon Sep 17 00:00:00 2001 From: Mark Wells Date: Mon, 10 Oct 2016 11:59:41 -0700 Subject: new tower/sector UI, mapping features, and network monitoring, #37802 --- FS/FS/Conf.pm | 17 ++ FS/FS/Daemon.pm | 99 +++++++ FS/FS/Mason.pm | 1 + FS/FS/Schema.pm | 35 ++- FS/FS/addr_status.pm | 103 +++++++ FS/FS/sector_coverage.pm | 133 +++++++++ FS/FS/svc_IP_Mixin.pm | 37 +++ FS/FS/tower.pm | 23 +- FS/FS/tower_sector.pm | 81 +++++- FS/MANIFEST | 2 + FS/bin/freeside-pingd | 135 +++++++++ FS/t/addr_status.t | 5 + FS/t/sector_coverage.t | 5 + Makefile | 1 + httemplate/browse/tower-map.html | 85 ++++++ httemplate/browse/tower.html | 6 +- httemplate/docs/license.html | 4 + httemplate/edit/process/tower.html | 2 +- httemplate/edit/tower.html | 19 +- .../elements/images/ui-icons_444444_256x240.png | Bin 0 -> 6992 bytes .../elements/images/ui-icons_515151_256x240.png | Bin 0 -> 6987 bytes .../elements/images/ui-icons_555555_256x240.png | Bin 0 -> 6988 bytes .../elements/images/ui-icons_777620_256x240.png | Bin 0 -> 4549 bytes .../elements/images/ui-icons_777777_256x240.png | Bin 0 -> 6999 bytes .../elements/images/ui-icons_cc0000_256x240.png | Bin 0 -> 4549 bytes httemplate/elements/jquery-gmaps-latlon-picker.js | 254 +++++++++++++++++ httemplate/elements/jquery-ui.min.css | 10 +- httemplate/elements/jquery-ui.min.js | 22 +- httemplate/elements/jquery-ui.structure.min.css | 5 + httemplate/elements/jquery-ui.theme.min.css | 5 + httemplate/elements/mapselect.html | 82 ++++++ httemplate/elements/tower_sector.html | 68 ----- httemplate/elements/tr-tower_sectors.html | 250 +++++++++++++++++ httemplate/misc/sector_coverage-json.cgi | 40 +++ httemplate/search/elements/gmap.html | 63 +++-- httemplate/search/sector.html | 1 + httemplate/search/svc_broadband-json.cgi | 108 ++++++++ httemplate/search/svc_broadband-map.html | 35 +-- httemplate/search/tower-map.html | 303 +++++++++++++++++++++ httemplate/view/svc_broadband-popup.html | 35 +++ init.d/freeside-init | 10 + 41 files changed, 1937 insertions(+), 147 deletions(-) create mode 100644 FS/FS/addr_status.pm create mode 100644 FS/FS/sector_coverage.pm create mode 100644 FS/bin/freeside-pingd create mode 100644 FS/t/addr_status.t create mode 100644 FS/t/sector_coverage.t create mode 100644 httemplate/browse/tower-map.html create mode 100644 httemplate/elements/images/ui-icons_444444_256x240.png create mode 100644 httemplate/elements/images/ui-icons_515151_256x240.png create mode 100644 httemplate/elements/images/ui-icons_555555_256x240.png create mode 100644 httemplate/elements/images/ui-icons_777620_256x240.png create mode 100644 httemplate/elements/images/ui-icons_777777_256x240.png create mode 100644 httemplate/elements/images/ui-icons_cc0000_256x240.png create mode 100644 httemplate/elements/jquery-gmaps-latlon-picker.js create mode 100644 httemplate/elements/jquery-ui.structure.min.css create mode 100644 httemplate/elements/jquery-ui.theme.min.css create mode 100644 httemplate/elements/mapselect.html delete mode 100644 httemplate/elements/tower_sector.html create mode 100644 httemplate/elements/tr-tower_sectors.html create mode 100644 httemplate/misc/sector_coverage-json.cgi create mode 100755 httemplate/search/svc_broadband-json.cgi create mode 100755 httemplate/search/tower-map.html create mode 100644 httemplate/view/svc_broadband-popup.html diff --git a/FS/FS/Conf.pm b/FS/FS/Conf.pm index ef2a9388a..f4f7d2602 100644 --- a/FS/FS/Conf.pm +++ b/FS/FS/Conf.pm @@ -3072,6 +3072,23 @@ and customer address. Include units.', 'type' => 'text', }, + { + 'key' => 'pingd-interval', + 'section' => 'network_monitoring', + 'description' => 'Run ping scans of broadband services at this interval.', + 'type' => 'select', + 'select_hash' => [ '' => '', + 60 => '1 min', + 300 => '5 min', + 600 => '10 min', + 1800 => '30 min', + 3600 => '1 hour', + 14400 => '4 hours', + 28800 => '8 hours', + 86400 => '1 day', + ], + }, + { 'key' => 'ticket_system-default_queueid', 'section' => 'ticketing', diff --git a/FS/FS/Daemon.pm b/FS/FS/Daemon.pm index b58cde49f..4ecd80e98 100644 --- a/FS/FS/Daemon.pm +++ b/FS/FS/Daemon.pm @@ -9,6 +9,7 @@ use IO::File; use File::Basename; use File::Slurp qw(slurp); use Date::Format; +use FS::UID qw( forksuidsetup ); #this is a simple refactoring of the stuff from freeside-queued, just to #avoid duplicate code. eventually this should use something from CPAN. @@ -16,6 +17,7 @@ use Date::Format; @ISA = qw(Exporter); @EXPORT_OK = qw( daemonize1 drop_root daemonize2 myexit logfile sigint sigterm + daemon_fork daemon_wait daemon_reconnect ); %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] ); @@ -24,6 +26,10 @@ $pid_dir = '/var/run'; $NOSIG = 0; $PID_NEWSTYLE = 0; +our $MAX_KIDS = 10; # for daemon_fork +our $kids = 0; +our %kids; + sub daemonize1 { $me = shift; @@ -57,6 +63,13 @@ sub daemonize1 { $SIG{INT} = sub { warn "SIGINT received; shutting down\n"; $sigint++; }; $SIG{TERM} = sub { warn "SIGTERM received; shutting down\n"; $sigterm++; }; } + + # set the logfile sensibly + if (!$logfile) { + my $logname = $me; + $logname =~ s/^freeside-//; + logfile("%%%FREESIDE_LOG%%%/$logname-log.$FS::UID::datasrc"); + } } sub drop_root { @@ -117,4 +130,90 @@ sub _logmsg { close $log; } +=item daemon_fork CODEREF[, ARGS ] + +Executes CODEREF in a child process, with its own $FS::UID::dbh handle. If +the number of child processes is >= $FS::Daemon::MAX_KIDS then this will +block until some of the child processes are finished. ARGS will be passed +to the coderef. + +If the fork fails, this will throw an exception containing $!. Otherwise +it returns the PID of the child, like fork() does. + +=cut + +sub daemon_fork { + $FS::UID::dbh->{AutoInactiveDestroy} = 1; + # wait until there's a lane open + daemon_wait($MAX_KIDS - 1); + + my ($code, @args) = @_; + + my $user = $FS::CurrentUser::CurrentUser->username; + + my $pid = fork; + if (!defined($pid)) { + + warn "WARNING: can't fork: $!\n"; + die "$!\n"; + + } elsif ( $pid > 0 ) { + + $kids{ $pid } = 1; + $kids++; + return $pid; + + } else { # kid + forksuidsetup( $user ); + &{$code}(@args); + exit; + + } +} + +=item daemon_wait [ MAX ] + +Waits until there are at most MAX daemon_fork() child processes running, +reaps the ones that are finished, and continues. MAX defaults to zero, i.e. +wait for everything to finish. + +=cut + +sub daemon_wait { + my $max = shift || 0; + while ($kids > $max) { + foreach my $pid (keys %kids) { + my $kid = waitpid($pid, WNOHANG); + if ( $kid > 0 ) { + $kids--; + delete $kids{$kid}; + } + } + sleep(1); + } +} + +=item daemon_reconnect + +Checks whether the database connection is live, and reconnects if not. + +=cut + +sub daemon_reconnect { + my $dbh = $FS::UID::dbh; + unless ($dbh && $dbh->ping) { + warn "WARNING: connection to database lost, reconnecting...\n"; + + eval { $FS::UID::dbh = myconnect(); }; + + unless ( !$@ && $FS::UID::dbh && $FS::UID::dbh->ping ) { + warn "WARNING: still no connection to database, sleeping for retry...\n"; + sleep 10; + next; + } else { + warn "WARNING: reconnected to database\n"; + } + } +} + 1; diff --git a/FS/FS/Mason.pm b/FS/FS/Mason.pm index ee87b2de4..041b76c10 100644 --- a/FS/FS/Mason.pm +++ b/FS/FS/Mason.pm @@ -416,6 +416,7 @@ if ( -e $addl_handler_use_file ) { use FS::commission_schedule; use FS::commission_rate; use FS::saved_search; + use FS::sector_coverage; # Sammath Naur if ( $FS::Mason::addl_handler_use ) { diff --git a/FS/FS/Schema.pm b/FS/FS/Schema.pm index f66cb36d5..66b9a51c3 100644 --- a/FS/FS/Schema.pm +++ b/FS/FS/Schema.pm @@ -203,6 +203,7 @@ sub dbdef_dist { && ! /^log(_context)?$/ && ! /^(legacy_cust_history|cacti_page|template_image|access_user_log)$/ && ( ! /^queue(_arg|_depend|_stat)?$/ || ! $opt->{'queue-no_history'} ) + && ! /^addr_status$/ && ! $tables_hashref_torrus->{$_} } $dbdef->tables @@ -4885,7 +4886,8 @@ sub tables_hashref { 'sector_range', 'decimal', 'NULL', '', '', '', #? 'downtilt', 'decimal', 'NULL', '', '', '', 'v_width', 'int', 'NULL', '', '', '', - 'margin', 'decimal', 'NULL', '', '', '', + 'db_high', 'int', 'NULL', '', '', '', + 'db_low', 'int', 'NULL', '', '', '', 'image', 'blob', 'NULL', '', '', '', 'west', 'decimal', 'NULL', '10,7', '', '', 'east', 'decimal', 'NULL', '10,7', '', '', @@ -4902,6 +4904,23 @@ sub tables_hashref { ], }, + 'sector_coverage' => { + 'columns' => [ + 'coveragenum', 'serial', '', '', '', '', + 'sectornum', 'int', '', '', '', '', + 'db_loss', 'int', '', '', '', '', + 'geometry', 'text', 'NULL', '', '', '', + ], + 'primary_key' => 'coveragenum', + 'unique' => [], + 'index' => [], + 'foreign_keys' => [ + { columns => [ 'sectornum' ], + table => 'tower_sector' + }, + ], + }, + 'part_virtual_field' => { 'columns' => [ 'vfieldpart', 'serial', '', '', '', '', @@ -7509,6 +7528,20 @@ sub tables_hashref { ], }, + 'addr_status' => { + 'columns' => [ + 'addrnum', 'serial', '', '', '', '', + 'ip_addr', 'varchar', 'NULL', 40, '', '', + '_date', @date_type, '', '', + 'up', 'char', 'NULL', 1, '', '', + 'delay', 'int', 'NULL', '', '', '', + ], + 'primary_key' => 'addrnum', + 'unique' => [ [ 'ip_addr' ] ], + 'index' => [ [ '_date' ] ], + 'foreign_keys' => [], + }, + # name type nullability length default local #'new_table' => { diff --git a/FS/FS/addr_status.pm b/FS/FS/addr_status.pm new file mode 100644 index 000000000..7928d3ae5 --- /dev/null +++ b/FS/FS/addr_status.pm @@ -0,0 +1,103 @@ +package FS::addr_status; +use base qw( FS::Record ); + +use strict; + +=head1 NAME + +FS::addr_status; + +=head1 SYNOPSIS + + use FS::addr_status; + + $record = new FS::addr_status \%hash; + $record = new FS::addr_status { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::addr_status object represents the last known status (up or down, and +the latency) of an IP address monitored by freeside-pingd. FS::addr_status +inherits from FS::Record. The following fields are currently supported: + +=over 4 + +=item addrnum - primary key + +=item ip_addr - the IP address (unique) + +=item _date - the time the address was last scanned + +=item up - 'Y' if the address responded to a ping + +=item delay - the latency, in milliseconds + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new status record. To add the record to the database, see +L<"insert">. + +Note that this stores the hash reference, not a distinct copy of the hash it +points to. You can ask the object for a copy with the I method. + +=cut + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'addr_status'; } + +=item insert + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +=item delete + +=item replace OLD_RECORD + +=item check + +Checks all fields to make sure this is a valid status record. If there is +an error, returns the error, otherwise returns false. Called by the insert +and replace methods. + +=cut + +sub check { + my $self = shift; + + my $error = + $self->ut_numbern('addrnum') + || $self->ut_ip('ip_addr') + || $self->ut_number('_date') + || $self->ut_flag('up') + || $self->ut_numbern('delay') + ; + + $self->SUPER::check; +} + +=back + +=head1 SEE ALSO + +L + +=cut + +1; + diff --git a/FS/FS/sector_coverage.pm b/FS/FS/sector_coverage.pm new file mode 100644 index 000000000..fa6a9e154 --- /dev/null +++ b/FS/FS/sector_coverage.pm @@ -0,0 +1,133 @@ +package FS::sector_coverage; +use base qw( FS::Record ); + +use strict; +use FS::Record qw( qsearch qsearchs ); +use Cpanel::JSON::XS; + +=head1 NAME + +FS::sector_coverage - Object methods for sector_coverage records + +=head1 SYNOPSIS + + use FS::sector_coverage; + + $record = new FS::sector_coverage \%hash; + $record = new FS::sector_coverage { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::sector_coverage object represents a coverage map for a sector at +a specific signal strength level. FS::sector_coverage inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item coveragenum + +primary key + +=item sectornum + +L foreign key + +=item db_loss + +The maximum path loss shown on this map, in dB. + +=item geometry + +A GeoJSON Geometry object for the area covered at this level. + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new map. To add the example to the database, see L<"insert">. + +Note that this stores the hash reference, not a distinct copy of the hash it +points to. You can ask the object for a copy with the I method. + +=cut + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'sector_coverage'; } + +=item insert + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +=item delete + +Delete this record from the database. + +=item replace OLD_RECORD + +Replaces the OLD_RECORD with this one in the database. If there is an error, +returns the error, otherwise returns false. + +=cut + +# the replace method can be inherited from FS::Record + +=item check + +Checks all fields to make sure this is a valid example. If there is +an error, returns the error, otherwise returns false. Called by the insert +and replace methods. + +=cut + +# the check method should currently be supplied - FS::Record contains some +# data checking routines + +sub check { + my $self = shift; + + my $error = + $self->ut_numbern('coveragenum') + || $self->ut_number('sectornum') + || $self->ut_number('db_loss') + ; + return $error if $error; + + if ( length($self->geometry) ) { + # make sure it parses at least + local $@; + my $data = eval { decode_json($self->geometry) }; + if ( $@ ) { + # limit the length, in case it decides to return a large chunk of data + return "Error parsing coverage geometry: ".substr($@, 0, 100); + } + } + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L + +=cut + +1; + diff --git a/FS/FS/svc_IP_Mixin.pm b/FS/FS/svc_IP_Mixin.pm index 8b2b5f17e..c89245fe2 100644 --- a/FS/FS/svc_IP_Mixin.pm +++ b/FS/FS/svc_IP_Mixin.pm @@ -222,4 +222,41 @@ sub replace_check { ref($err_or_ref) ? '' : $err_or_ref; } +=item addr_status + +Returns the ping status record for this service's address, if there +is one. + +=cut + +sub addr_status { + my $self = shift; + my $addr = $self->ip_addr or return; + qsearchs('addr_status', { 'ip_addr' => $addr }); +} + +=item addr_status_color + +Returns the CSS color for the ping status of this service. + +=cut + +# subject to change; should also show high/low latency (yellow?) and +# staleness of data (probably means the daemon is not running) and packet +# loss (once we measure that) + +sub addr_status_color { + my $self = shift; + if ( my $addr_status = $self->addr_status ) { + if ( $addr_status->up ) { + return 'green'; + } else { + return 'red'; + } + } else { + return 'gray'; + } +} + + 1; diff --git a/FS/FS/tower.pm b/FS/FS/tower.pm index f371ec9c7..18b43fe7d 100644 --- a/FS/FS/tower.pm +++ b/FS/FS/tower.pm @@ -75,6 +75,27 @@ Delete this record from the database. Replaces the OLD_RECORD with this one in the database. If there is an error, returns the error, otherwise returns false. +=cut + +sub replace { + my $self = shift; + my $old = shift || $self->replace_old; + # editing the tower location needs to regenerate coverage on its sectors + my $regen_coverage = 0; + foreach (qw(latitude longitude height)) { + $regen_coverage = 1 if $self->get($_) != $old->get($_); + } + + my $error = $self->SUPER::replace($old); + return $error if $error; + + if ($regen_coverage) { + foreach my $sector ($self->tower_sector) { + $sector->queue_generate_coverage; + } + } +} + =item check Checks all fields to make sure this is a valid tower. If there is @@ -143,7 +164,7 @@ default sector. sub process_o2m { my $self = shift; my %opt = @_; - my $params = $opt{params}; + my $params = +{ %{$opt{params}} }; # Adjust to make sure our default sector is in the list. my $default_sector = $self->default_sector diff --git a/FS/FS/tower_sector.pm b/FS/FS/tower_sector.pm index 3fadc8685..08e8cc0df 100644 --- a/FS/FS/tower_sector.pm +++ b/FS/FS/tower_sector.pm @@ -4,6 +4,7 @@ use base qw( FS::Record ); use Class::Load qw(load_class); use File::Path qw(make_path); use Data::Dumper; +use Cpanel::JSON::XS; use strict; @@ -75,10 +76,13 @@ The antenna beam elevation in degrees below horizontal. The -3dB vertical beamwidth in degrees. -=item margin +=item db_high -The signal loss margin allowed on the sector, in dB. This is normally -transmitter EIRP minus receiver sensitivity. +The signal loss margin to treat as "high quality". + +=item db_low + +The signal loss margin to treat as "low quality". =item image @@ -110,6 +114,38 @@ sub table { 'tower_sector'; } Adds this record to the database. If there is an error, returns the error, otherwise returns false. +=cut + +sub insert { + my $self = shift; + my $error = $self->SUPER::insert; + return $error if $error; + + if (scalar($self->need_fields_for_coverage) == 0) { + $self->queue_generate_coverage; + } +} + +sub replace { + my $self = shift; + my $old = shift || $self->replace_old; + my $regen_coverage = 0; + if ( !$self->get('no_regen') ) { + foreach (qw(height freq_mhz direction width downtilt + v_width db_high db_low)) + { + $regen_coverage = 1 if ($self->get($_) ne $old->get($_)); + } + } + + my $error = $self->SUPER::replace($old); + return $error if $error; + + if ($regen_coverage) { + $self->queue_generate_coverage; + } +} + =item delete Delete this record from the database. @@ -149,7 +185,8 @@ sub check { || $self->ut_numbern('v_width') || $self->ut_numbern('downtilt') || $self->ut_floatn('sector_range') - || $self->ut_numbern('margin') + || $self->ut_numbern('db_high') + || $self->ut_numbern('db_low') || $self->ut_anything('image') || $self->ut_sfloatn('west') || $self->ut_sfloatn('east') @@ -201,7 +238,7 @@ sub need_fields_for_coverage { downtilt => 'Downtilt', width => 'Horiz. width', v_width => 'Vert. width', - margin => 'Signal margin', + db_high => 'High quality', latitude => 'Latitude', longitude => 'Longitude', ); @@ -222,6 +259,9 @@ Starts a job to recalculate the coverage map. sub queue_generate_coverage { my $self = shift; + my $need_fields = join(',', $self->need_fields_for_coverage); + return "Sector needs fields $need_fields" if $need_fields; + $self->set('no_regen', 1); # avoid recursion if ( length($self->image) > 0 ) { foreach (qw(image west south east north)) { $self->set($_, ''); @@ -258,9 +298,11 @@ sub process_generate_coverage { my $sectornum = $param->{sectornum}; my $sector = FS::tower_sector->by_key($sectornum) or die "sector $sectornum does not exist"; + $sector->set('no_regen', 1); # avoid recursion my $tower = $sector->tower; load_class('Map::Splat'); + # since this is still experimental, put it somewhere we can find later my $workdir = "$FS::UID::cache_dir/cache.$FS::UID::datasrc/" . "generate_coverage/sector$sectornum-". time; @@ -274,9 +316,9 @@ sub process_generate_coverage { h_width => $sector->width, tilt => $sector->downtilt, v_width => $sector->v_width, - max_loss => $sector->margin, - min_loss => $sector->margin - 80, + db_levels => [ $sector->db_low, $sector->db_high ], dir => $workdir, + #simplify => 0.0004, # remove stairstepping in SRTM3 data? ); $splat->calculate; @@ -284,11 +326,30 @@ sub process_generate_coverage { foreach (qw(west east south north)) { $sector->set($_, $box->{$_}); } - $sector->set('image', $splat->mask); - # mask returns a PNG where everything below max_loss is solid colored, - # and everything above it is transparent. More useful for our purposes. + $sector->set('image', $splat->png); my $error = $sector->replace; die $error if $error; + + foreach ($sector->sector_coverage) { + $error = $_->delete; + die $error if $error; + } + # XXX undecided whether Map::Splat should even do this operation + # or how to store it + # or anything else + $DB::single = 1; + my $data = decode_json( $splat->polygonize_json ); + for my $feature (@{ $data->{features} }) { + my $db = $feature->{properties}{level}; + my $coverage = FS::sector_coverage->new({ + sectornum => $sectornum, + db_loss => $db, + geometry => encode_json($feature->{geometry}) + }); + $error = $coverage->insert; + } + + die $error if $error; } =head1 BUGS diff --git a/FS/MANIFEST b/FS/MANIFEST index 73a740f63..10dda5948 100644 --- a/FS/MANIFEST +++ b/FS/MANIFEST @@ -876,3 +876,5 @@ FS/commission_rate.pm t/commission_rate.t FS/saved_search.pm t/saved_search.t +FS/sector_coverage.pm +t/sector_coverage.t diff --git a/FS/bin/freeside-pingd b/FS/bin/freeside-pingd new file mode 100644 index 000000000..fc9f8a378 --- /dev/null +++ b/FS/bin/freeside-pingd @@ -0,0 +1,135 @@ +#!/usr/bin/perl + +use strict; +use FS::Daemon ':all'; +use FS::UID qw(dbh adminsuidsetup); +use FS::Record qw( dbh qsearch qsearchs ); +use FS::addr_status; +use FS::Conf; +use Getopt::Std; +use Net::Ping; + +my @TARGETS = ( + 'tower_sector', + 'svc_broadband', + # could add others here +); + +my $timeout = 5.0; # seconds + +# useful opts: scan interval, timeout, verbose, max forks +# maybe useful opts: interface, protocol, packet size, no-fork + +my $interval; + +our %opt; +getopts('vxi:', \%opt); +my $user = shift or die usage(); + +if (!$opt{x}) { + daemonize1('freeside-pingd'); + drop_root(); + daemonize2(); +} + +if ($opt{i}) { + $interval = $opt{i}; +} + +sub debug { + warn(@_, "\n") if $opt{v}; +} + +adminsuidsetup($user); +$FS::UID::AutoCommit = 1; + +if ( !$interval ) { + my $conf = FS::Conf->new; + $interval = $conf->config('pingd-interval'); + if ( !$interval ) { + debug("no pingd-interval configured; exiting"); + exit(0); + } +} + +while(1) { + daemon_reconnect(); + my @addrs_to_scan; + foreach my $table (@TARGETS) { + # find addresses that need to be scanned (haven't been yet, or are + # expired) + my $expired = time - $interval; + debug("checking addresses from $table"); + + my $statement = "SELECT ip_addr FROM $table + LEFT JOIN addr_status USING (ip_addr) + WHERE $table.ip_addr IS NOT NULL + AND (addr_status.ip_addr IS NULL OR addr_status._date <= ?) + ORDER BY COALESCE(addr_status._date, 0)"; + my $addrs = dbh->selectcol_arrayref($statement, {}, $expired); + die dbh->errstr if !defined $addrs; + debug("found ".scalar(@$addrs)); + push @addrs_to_scan, @$addrs; + } + + # fork to handle this since we're going to spend most of our time + # waiting for remote machines to respond + foreach my $addr (@addrs_to_scan) { + daemon_fork( \&scan, $addr ); + } + + debug("waiting for scan to complete"); + # wait until finished + daemon_wait(); + + # sleep until there's more work to do: + # the oldest record that still has an expire time in the future + # (as opposed to records for dead addresses, which will not be rescanned) + my $next_expire = FS::Record->scalar_sql( + 'SELECT MIN(_date) FROM addr_status WHERE _date + ? > ?', + $interval, time + ) || time; + my $delay = $next_expire + $interval - time; + # but at least scan every $interval seconds, to pick up new addresses + $delay = $interval if $delay > $interval; + + if ( $delay > 0 ) { + debug("it is now ".time."; sleeping for $delay"); + sleep($delay); + } else { + debug("it is now ".time."; continuing"); + } + +} # main loop + +sub scan { + # currently just sends a single ping; it might be more useful to send + # several of them and estimate packet loss. + + my $addr = shift; + my $addr_status = qsearchs('addr_status', { 'ip_addr' => $addr }) + || FS::addr_status->new({ 'ip_addr' => $addr }); + + $addr_status->select_for_update if $addr_status->addrnum; + my $ping = Net::Ping->new; + $ping->hires; + debug "pinging $addr"; + my ($result, $latency) = $ping->ping($addr, $timeout); + debug "status $result, delay $latency"; + $addr_status->set('up', $result ? 'Y' : ''); + $addr_status->set('delay', int($latency * 1000)); + $addr_status->set('_date', time); + my $error = $addr_status->addrnum ? + $addr_status->replace : + $addr_status->insert; + if ( $error ) { + die "ERROR: could not update status for $addr\n$error\n"; + } +} + +sub usage { + "Usage: + freeside-pingd [ -i INTERVAL ] [ -v ] [ -x ] +"; +} + diff --git a/FS/t/addr_status.t b/FS/t/addr_status.t new file mode 100644 index 000000000..ece424b9e --- /dev/null +++ b/FS/t/addr_status.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::addr_status; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/sector_coverage.t b/FS/t/sector_coverage.t new file mode 100644 index 000000000..b30415888 --- /dev/null +++ b/FS/t/sector_coverage.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::sector_coverage; +$loaded=1; +print "ok 1\n"; diff --git a/Makefile b/Makefile index 8a244668e..c6eef91b0 100644 --- a/Makefile +++ b/Makefile @@ -217,6 +217,7 @@ perl-modules: perl -p -i -e "\ s|%%%FREESIDE_CONF%%%|${FREESIDE_CONF}|g;\ s|%%%FREESIDE_CACHE%%%|${FREESIDE_CACHE}|g;\ + s|%%%FREESIDE_LOG%%%|${FREESIDE_LOG}|g;\ s'%%%FREESIDE_DOCUMENT_ROOT%%%'${FREESIDE_DOCUMENT_ROOT}'g; \ s'%%%RT_ENABLED%%%'${RT_ENABLED}'g; \ s'%%%RT_PATH%%%'${RT_PATH}'g; \ diff --git a/httemplate/browse/tower-map.html b/httemplate/browse/tower-map.html new file mode 100644 index 000000000..62e08fcb5 --- /dev/null +++ b/httemplate/browse/tower-map.html @@ -0,0 +1,85 @@ +<& /elements/header.html, 'Towers and sectors' &> + + + + +
+ + + + + +
+
+
+ + diff --git a/httemplate/elements/tower_sector.html b/httemplate/elements/tower_sector.html deleted file mode 100644 index 987177582..000000000 --- a/httemplate/elements/tower_sector.html +++ /dev/null @@ -1,68 +0,0 @@ -% unless ( $opt{'js_only'} ) { - - - - - -% foreach my $field ( @fields ) { - - -% } - -
- get($field) |h %>" - <% $onchange %> - >
- <% $label{$field} %> -
- - -% } -<%init> - -my( %opt ) = @_; - -my $name = $opt{'element_name'} || $opt{'field'} || 'sectornum'; -my $id = $opt{'id'} || 'sectornum'; - -my $curr_value = $opt{'curr_value'} || $opt{'value'}; - -my $onchange = ''; -if ( $opt{'onchange'} ) { - $onchange = $opt{'onchange'}; - $onchange .= '(this)' unless $onchange =~ /\(\w*\);?$/; - $onchange =~ s/\(what\);/\(this\);/g; #ugh, terrible hack. all onchange - #callbacks should act the same - $onchange = 'onChange="'. $onchange. '"'; -} - -my $tower_sector; -if ( $curr_value ) { - $tower_sector = qsearchs('tower_sector', { 'sectornum' => $curr_value } ); -} else { - $tower_sector = new FS::tower_sector {}; -} - -my %size = ( 'title' => 12 ); - -tie my %label, 'Tie::IxHash', - 'sectorname' => 'Name', - 'ip_addr' => 'IP Address', - 'height' => 'Height', - 'freq_mhz' => 'Freq. (MHz)', - 'direction' => 'Direction', # or a button to set these to 0 for omni - 'downtilt' => 'Downtilt', - 'width' => 'Horiz. width', - 'v_width' => 'Vert. width', - 'sector_range' => 'Range', - 'margin' => 'Signal margin (dB)', -; - -my @fields = keys %label; - - diff --git a/httemplate/elements/tr-tower_sectors.html b/httemplate/elements/tr-tower_sectors.html new file mode 100644 index 000000000..4e8f3fb47 --- /dev/null +++ b/httemplate/elements/tr-tower_sectors.html @@ -0,0 +1,250 @@ +<%init> +my %opt = @_; +my $tower = $opt{'object'}; +my $towernum = $tower->towernum; +my $cgi = $opt{'cgi'}; + +my $tabcounter = 0; + +my @fields = qw( + sectorname ip_addr height freq_mhz direction width tilt v_width db_high + db_low sector_range +); + +my @sectors; +if ( $cgi->param('error') ) { + foreach my $k ($cgi->param) { + if ($k =~ /^sectornum\d+$/) { + my $sectornum = $cgi->param($k); + my $sector = FS::tower_sector->new({ + 'sectornum' => $sectornum, + 'towernum' => $towernum, + map { $_ => scalar($cgi->param($k.'_'.$_)) } @fields, + }); + push @sectors, $sector if length($sector->sectorname); + } + } +} elsif ( $towernum ) { + @sectors = $tower->tower_sector; +} # else new mode, no sectors yet + +my $id = $opt{id} || $opt{field} || 'sectornum'; + + +<& tablebreak-tr-title.html, value => 'Sectors' &> + + + + + + +%# prototypes +
+<& .tab, id => $id . '_P' &> +<& .panel, id => $id . '_P' &> +
+ +%# main container +
+
    +% foreach my $sector (@sectors) { +<& .tab, sector => $sector, id => $id . $tabcounter &> +% $tabcounter++; +% } +
+ +% $tabcounter = 0; +% foreach my $sector (@sectors) { +<& .panel, sector => $sector, id => $id . $tabcounter &> +% $tabcounter++; +% } +
+ + + +<%def .tab> +% my %opt = @_; +% my $sector = $opt{sector}; +% my $id = $opt{id}; +% my $title = $sector ? $sector->sectorname : mt('Add new'); +
  • + <% $title |h %> +
    • + +<%def .panel> +% my %opt = @_; +% my $sector = $opt{sector} || FS::tower_sector->new({}); +% my $id = $opt{id}; # sectornumX +
    +% # no id on this one, the panel gets the "sectornumX" id + +

    + + + + + +

    +

    + + + <% emt('feet above ground') %> +

    +

    + + ° + + ° +

    + +

    + + + <% emt('MHz') %> +

    + +

    + + ° + + ° +

    + + +
    + + <% emt('dB (high quality)') %> +
    + + + <% emt('dB (low quality)') %> +
    + +
    + diff --git a/httemplate/misc/sector_coverage-json.cgi b/httemplate/misc/sector_coverage-json.cgi new file mode 100644 index 000000000..37595f5e2 --- /dev/null +++ b/httemplate/misc/sector_coverage-json.cgi @@ -0,0 +1,40 @@ +<% encode_json($collection) %> +<%init> +my @sectors; +if ( my $towernum = $cgi->param('towernum') ) { + @sectors = qsearch('tower_sector', { towernum => $towernum }); +} elsif ( my $sectornum = $cgi->param('sectornum') ) { + @sectors = FS::tower_sector->by_key($sectornum); +} else { + die "towernum or sectornum required"; +} +my @features; +my $collection = { + type => 'FeatureCollection', + features => \@features, +}; +foreach my $sector (@sectors) { + my $sectornum = $sector->sectornum; + my $low = $sector->db_low; + my $high = $sector->db_high; + my $color = '#' . ($sector->tower->color || 'ffffff'); + foreach my $coverage ( $sector->sector_coverage ) { + #note $coverage->geometry is already JSON + my $level = $coverage->db_loss; + push @features, { + type => 'Feature', + id => "sector/$sectornum/$level", + properties => { + level => $level, + low => ($level == $low ? 1 : 0), + high => ($level == $high ? 1 : 0), + style => { + strokeColor => $color, + fillColor => $color, + }, + }, + geometry => decode_json($coverage->geometry), + }; + } +} + diff --git a/httemplate/search/elements/gmap.html b/httemplate/search/elements/gmap.html index b7d135dd6..69fdc5a09 100644 --- a/httemplate/search/elements/gmap.html +++ b/httemplate/search/elements/gmap.html @@ -37,6 +37,9 @@ Generic Google Maps front end. <%init> + +my $apikey = FS::Conf->new->config('google_maps_api_key'); + foreach (@features) { $_->{type} = 'Feature'; # any other per-feature massaging can go here @@ -57,7 +60,7 @@ body { height: 100%; margin: 0px; padding: 0px } #map_canvas { height: 100%; } - + + + +
    + + + + + +<& /elements/footer.html &> +<%init> + +die "access denied" unless + $FS::CurrentUser::CurrentUser->access_right('List services'); + +my $conf = new FS::Conf; + +my $apikey = $conf->config('google_maps_api_key'); + +my @features; # geoJSON structure + +my @towers = qsearch('tower', { + 'latitude' => { op=>'!=', value=>''}, + 'longitude' => { op=>'!=', value=>''}, +}); +my %sectors; # towernum => arrayref +my @towernums; + +foreach my $tower (@towers) { + my $towernum = $tower->towernum; + push @towernums, $towernum; + my @coord = ( + $tower->longitude + 0, + $tower->latitude + 0, + ); + push @features, + { + type => 'Feature', + id => 'tower/'.$towernum, + geometry => { + type => 'Point', + coordinates => \@coord, + }, + properties => { + style => { + icon => { + path => undef, + url => $fsurl.'images/antenna-square-21x51.png', + anchor => { x => 10, y => 4 }, + strokeColor => ($tower->color || 'black'), + }, + }, + content => include('.tower', $tower), + }, + }; + + $sectors{$towernum} = [ $tower->tower_sector ]; + +} # foreach $tower + +my $tower_data = { + type => 'FeatureCollection', + features => \@features +}; + + +<%def .tower> +% my $tower = shift; +% my $can_edit = $FS::CurrentUser::CurrentUser->access_right('Configuration'); +

    +% if ( $can_edit ) { + +% } +Tower #<% $tower->towernum %> | <% $tower->towername %> +% if ( $can_edit ) { + +% } +

    +% my $count_query = 'SELECT COUNT(*) FROM svc_broadband LEFT JOIN addr_status using (ip_addr) JOIN tower_sector USING (sectornum) WHERE tower_sector.towernum = '.$tower->towernum; +% my $num_down = FS::Record->scalar_sql("$count_query AND addr_status.up IS NULL AND addr_status._date IS NOT NULL"); +% my $num_up = FS::Record->scalar_sql("$count_query AND addr_status.up IS NOT NULL"); + +<% emt('Show services') %> +( <% $num_up %> <% emt('UP') %> +<% $num_down %> <% emt('DOWN') %> ) +
    + +<% emt('Show coverage') %> + diff --git a/httemplate/view/svc_broadband-popup.html b/httemplate/view/svc_broadband-popup.html new file mode 100644 index 000000000..1c2347454 --- /dev/null +++ b/httemplate/view/svc_broadband-popup.html @@ -0,0 +1,35 @@ +<%init> +die "access denied" + unless $FS::CurrentUser::CurrentUser->access_right('View customer services'); + +my ($svcnum) = $cgi->keywords; +# cleans svcnum, checks agent access, etc. +my $svc = qsearchs( FS::svc_broadband->search({ 'svcnum' => $svcnum }) ); +my $addr_status = $svc->addr_status; +my @label = $svc->cust_svc->label; + + +

    + + <% $label[0] |h %> #<% $svc->svcnum %> | <% $label[1] %> + +

    +% if ( $addr_status ) { +

    + + <% emt( $addr_status->up ? 'UP' : 'DOWN' ) %> + +% if ( $addr_status->up ) { + (<% $addr_status->delay |h %> ms) +% } + <% emt('as of') . ' ' . time2str('%b %o %H:%M', $addr_status->_date) %> +

    +% } +% my $cust_main = $svc->cust_main; + +<& /elements/small_custview.html, { + cust_main => $svc->cust_main, + #url => $fsurl.'view/cust_main.cgi', +} &> + + diff --git a/init.d/freeside-init b/init.d/freeside-init index 248c5b36e..a7bb3d12c 100644 --- a/init.d/freeside-init +++ b/init.d/freeside-init @@ -78,6 +78,10 @@ case "$1" in freeside-cdrrated $QUEUED_USER echo "done." + echo -n "Starting freeside-pingd: " + freeside-pingd $QUEUED_USER + echo "done." + if [ -e /usr/local/bin/torrus ]; then echo -n "Starting torrus collector: " /usr/local/bin/torrus collector --tree=main @@ -134,6 +138,12 @@ case "$1" in echo "done." fi + if [ -e /var/run/freeside-pingd.pid ]; then + echo -n "Stopping freeside-pingd: " + kill `cat /var/run/freeside-pingd.pid` + echo "done." + fi + if [ -e /var/run/freeside/torrus-srvderive.pid ]; then echo -n "Stopping freeside-torrus-srvderive: " kill `cat /var/run/freeside/torrus-srvderive.pid` -- cgit v1.2.1 From 04f53daab621710db56b075e1aaf56e7c52f9ba9 Mon Sep 17 00:00:00 2001 From: Mark Wells Date: Mon, 10 Oct 2016 23:54:05 -0700 Subject: export tower/sector data to TowerCoverage API, #39776 --- FS/FS/Schema.pm | 11 + FS/FS/hardware_type.pm | 3 + FS/FS/part_export/tower_towercoverage.pm | 420 ++++++++++++++++++++++++++++++ FS/FS/tower_sector.pm | 104 +++++++- httemplate/edit/process/tower.html | 3 +- httemplate/elements/tr-tower_sector.html | 24 -- httemplate/elements/tr-tower_sectors.html | 54 +++- httemplate/search/tower-map.html | 15 ++ 8 files changed, 598 insertions(+), 36 deletions(-) create mode 100644 FS/FS/part_export/tower_towercoverage.pm delete mode 100644 httemplate/elements/tr-tower_sector.html diff --git a/FS/FS/Schema.pm b/FS/FS/Schema.pm index 66b9a51c3..a1615b71a 100644 --- a/FS/FS/Schema.pm +++ b/FS/FS/Schema.pm @@ -4139,6 +4139,7 @@ sub tables_hashref { 'classnum', 'int', '', '', '', '', 'model', 'varchar', '', $char_d, '', '', 'revision','varchar', 'NULL', $char_d, '', '', + 'title', 'varchar', 'NULL', $char_d, '', '', # external id ], 'primary_key' => 'typenum', 'unique' => [ [ 'classnum', 'model', 'revision' ] ], @@ -4886,6 +4887,10 @@ sub tables_hashref { 'sector_range', 'decimal', 'NULL', '', '', '', #? 'downtilt', 'decimal', 'NULL', '', '', '', 'v_width', 'int', 'NULL', '', '', '', + 'power', 'decimal', 'NULL', '', '', '', + 'line_loss', 'decimal', 'NULL', '', '', '', + 'antenna_gain', 'decimal', 'NULL', '', '', '', + 'hardware_typenum', 'int', 'NULL', '', '', '', 'db_high', 'int', 'NULL', '', '', '', 'db_low', 'int', 'NULL', '', '', '', 'image', 'blob', 'NULL', '', '', '', @@ -4893,6 +4898,8 @@ sub tables_hashref { 'east', 'decimal', 'NULL', '10,7', '', '', 'south', 'decimal', 'NULL', '10,7', '', '', 'north', 'decimal', 'NULL', '10,7', '', '', + + 'title', 'varchar', 'NULL', $char_d,'', '', ], 'primary_key' => 'sectornum', 'unique' => [ [ 'towernum', 'sectorname' ], [ 'ip_addr' ], ], @@ -4901,6 +4908,10 @@ sub tables_hashref { { columns => [ 'towernum' ], table => 'tower', }, + { columns => [ 'hardware_typenum' ], + table => 'hardware_type', + references => [ 'typenum' ], + }, ], }, diff --git a/FS/FS/hardware_type.pm b/FS/FS/hardware_type.pm index 615c314b0..85473125c 100644 --- a/FS/FS/hardware_type.pm +++ b/FS/FS/hardware_type.pm @@ -40,6 +40,8 @@ to which this device type belongs. =item revision - revision name/number, subordinate to model +=item title - external ID + =back =head1 METHODS @@ -104,6 +106,7 @@ sub check { || $self->ut_foreign_key('classnum', 'hardware_class', 'classnum') || $self->ut_text('model') || $self->ut_textn('revision') + || $self->ut_textn('title') ; return $error if $error; diff --git a/FS/FS/part_export/tower_towercoverage.pm b/FS/FS/part_export/tower_towercoverage.pm new file mode 100644 index 000000000..5d3f8351a --- /dev/null +++ b/FS/FS/part_export/tower_towercoverage.pm @@ -0,0 +1,420 @@ +package FS::part_export::tower_towercoverage; + +use strict; +use base qw( FS::part_export ); +use FS::Record qw(qsearch qsearchs dbh); +use FS::hardware_class; +use FS::hardware_type; + +use vars qw( %options %info + %frequency_id %antenna_type_id ); + +use Color::Scheme; +use LWP::UserAgent; +use XML::LibXML::Simple qw(XMLin); +use Data::Dumper; + +# note this is not https +our $base_url = 'http://api.towercoverage.com/towercoverage.asmx/'; + +our $DEBUG = 0; +our $me = '[towercoverage.com]'; + +sub debug { + warn "$me ".join("\n",@_)."\n" + if $DEBUG; +} + +# hardware class to use for antenna defs +my $classname = 'TowerCoverage.com antenna'; + +tie %options, 'Tie::IxHash', ( + 'debug' => { label => 'Enable debugging', type => 'checkbox' }, + + 'Account' => { label => 'Account ID' }, + 'key' => { label => 'API key' }, + 'use_coverage' => { label => 'Enable coverage maps', type => 'checkbox' }, + 'FrequencyID' => { label => 'Frequency band', + type => 'select', + options => [ keys(%frequency_id) ], + option_labels => \%frequency_id, + }, + 'MaximumRange' => { label => 'Maximum range (miles)', default => '10' }, + '1' => { type => 'title', label => 'Client equipment' }, + 'ClientAverageAntennaHeight' => { label => 'Typical antenna height (feet)' }, + 'ClientAntennaGain' => { label => 'Antenna gain (dB)' }, + 'RxLineLoss' => { label => 'Line loss (dB)', + default => 0, + }, + '2' => { type => 'title', label => 'Performance requirements' }, + 'WeakRxThreshold' => { label => 'Low quality (dBm)', }, + 'StrongRxThreshold' => { label => 'High quality (dBm)', }, + 'RequiredReliability' => { label => 'Reliability %', + default => 70 + }, +); + +%info = ( + 'svc' => [qw( tower_sector )], + 'desc' => 'TowerCoverage.com coverage mapping and site qualification', + 'options' => \%options, + 'no_machine' => 1, + 'notes' => <<'END', +Export tower/sector configurations to TowerCoverage.com for coverage map +generation. +END +); + +sub insert { + my $self = shift; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + + my $error = $self->SUPER::insert(@_); + return $error if $error; + + my $hwclass = _hardware_class(); + if (!$hwclass) { + + $hwclass = FS::hardware_class->new({ classname => $classname }); + $error = $hwclass->insert; + if ($error) { + dbh->rollback if $oldAutoCommit; + return "error creating hardware class for antenna types: $error"; + } + + foreach my $id (keys %antenna_type_id) { + my $name = $antenna_type_id{$id}; + my $hardware_type = FS::hardware_type->new({ + classnum => $hwclass->classnum, + model => $name, + title => $id, + }); + $error = $hardware_type->insert; + if ($error) { + dbh->rollback if $oldAutoCommit; + return "error creating hardware class for antenna types: $error"; + } + } + } + dbh->commit if $oldAutoCommit; + ''; +} + +sub export_insert { + my ($self, $sector) = @_; + + return unless $self->option('use_coverage'); + local $DEBUG = $self->option('debug') ? 1 : 0; + + my $tower = $sector->tower; + my $height_m = sprintf('%.0f', ($sector->height || $tower->height) / 3.28); + my $clientheight_m = sprintf('%.0f', $self->option('ClientAverageAntennaHeight') / 3.28); + my $maximumrange_km = sprintf('%.0f', $self->option('MaximumRange') * 1.61); + my $strongmargin = $self->option('StrongRxThreshold') + - $self->option('WeakRxThreshold'); + + my $scheme = Color::Scheme->new->from_hex($tower->color || '00FF00'); + + my $antenna = qsearchs('hardware_type', { + typenum => $sector->hardware_typenum + }); + return "antenna type required" unless $antenna; + + # - ALL parameters must be present (or it throws a generic 500 error). + # - ONLY Coverageid and TowerSiteid are allowed to be empty. + # - ALL parameter names are case sensitive. + # - ALL numeric parameters are required to be integers, except for the + # coordinates, line loss factors, and center frequency. + # - Export options (like RxLineLoss) have a problem where if they're set + # to numeric zero, they get removed; make sure we actually send zero. + my $data = [ + 'Account' => $self->option('Account'), + 'key' => $self->option('key'), + 'Coverageid' => $sector->title, + 'Coveragename' => $sector->description, + 'TowerSiteid' => '', + 'Latitude' => $tower->latitude, + 'Longitude' => $tower->longitude, + 'AntennaHeight' => $height_m, + 'ClientAverageAntennaHeight' => $clientheight_m, + 'ClientAntennaGain' => $self->option('ClientAntennaGain'), + 'RxLineLoss' => sprintf('%.1f', $self->option('RxLineLoss')), + 'AntennaType' => $antenna->title, + 'AntennaAzimuth' => int($sector->direction), + # note that TowerCoverage bases their coverage map on the antenna + # radiation pattern, not on this number. + 'BeamwidthFilter' => $sector->width, + 'AntennaTilt' => int($sector->downtilt), + 'AntennaGain' => int($sector->antenna_gain), + 'Frequency' => $self->option('FrequencyID'), + 'ExactCenterFrequency' => $sector->freq_mhz, + 'TXPower' => int($sector->power), + 'TxLineLoss' => sprintf('%.1f', $sector->line_loss), + 'RxThreshold' => $self->option('WeakRxThreshold'), + 'RequiredReliability' => $self->option('RequiredReliability'), + 'StrongSignalMargin' => $strongmargin, + 'StrongSignalColor' => ($scheme->colors)[0], + 'WeakSignalColor' => ($scheme->colors)[2], + 'Opacity' => 50, + 'MaximumRange' => $maximumrange_km, + # this could be selectable but there's no reason to do that + 'RenderingQuality' => 3, + 'UseLandCover' => 1, + 'UseTwoRays' => 1, + 'CreateViewshed' => 0, + ]; + debug Dumper($data); + $self->http_queue( + 'action' => 'insert', + 'path' => 'CoverageAPI', + 'sectornum' => $sector->sectornum, + 'data' => $data + ); + +} + +sub export_replace { # do the same thing as insert + my $self = shift; + $self->export_insert(@_); +} + +sub export_delete { '' } + +=item http_queue + +Queue a job to send an API request. +Takes arguments: +'action' => what we're doing (for triggering after_* callback) +'path' => the path under TowerCoverage.asmx/ +'sectornum' => the sectornum +'data' => arrayref/hashref of params to send +to which it will add +'exportnum' => the exportnum + +=cut + +sub http_queue { + my $self = shift; + my $queue = new FS::queue { 'job' => "FS::part_export::tower_towercoverage::http" }; + return $queue->insert( + exportnum => $self->exportnum, + @_ + ); +} + +sub http { + my %params = @_; + my $self = FS::part_export->by_key($params{'exportnum'}); + local $DEBUG = $self->option('debug') ? 1 : 0; + + local $FS::tower_sector::noexport_hack = 1; # avoid recursion + + my $url = $base_url . $params{'path'}; + + my $ua = LWP::UserAgent->new; + + # URL is the same for insert and replace. + my $req = HTTP::Request::Common::POST( $url, $params{'data'} ); + debug("sending $url", $req->content); + my $response = $ua->request($req); + + die $response->error_as_HTML if $response->is_error; + debug "received ".$response->decoded_content; + + # throws exception on parse error + my $response_data = XMLin($response->decoded_content); + my $method = "after_" . $params{action}; + if ($self->can($method)) { + # should be some kind of event handler, that would be sweet + my $sector = FS::tower_sector->by_key($params{'sectornum'}); + $self->$method($sector, $response_data); + } +} + +sub after_insert { + my ($self, $sector, $data) = @_; + my ($png_path, $kml_path) = split("\n", $data->{content}); + die "$me no coverage map paths in response\n" unless $png_path; + if ( $png_path =~ /(\d+).png$/ ) { + $sector->set('title', $1); + my $error = $sector->replace; + die $error if $error; + } else { + die "$me can't parse map path '$png_path'\n"; + } +} + +sub _hardware_class { + qsearchs( 'hardware_class', { classname => $classname }); +} + +sub get_antenna_types { + my $hardware_class = _hardware_class() or return; + # return hardware typenums, not TowerCoverage IDs. + tie my %t, 'Tie::IxHash'; + + foreach my $type (qsearch({ + table => 'hardware_type', + hashref => { 'classnum' => $hardware_class->classnum }, + order_by => ' order by title::integer' + })) { + $t{$type->typenum} = $type->model; + } + + return \%t; +} + +sub export_links { + my $self = shift; + my ($sector, $arrayref) = @_; + if ( $sector->title =~ /^\d+$/ ) { + my $link = "http://www.towercoverage.com/En-US/Dashboard/editcoverages/". + $sector->title; + push @$arrayref, qq!TowerCoverage map!; + } +} + +# we can query this from them, but that requires the account id and key... +# XXX do some jquery magic in the UI to grab the account ID and key from +# those fields, and then look it up right there + +BEGIN { + tie our %frequency_id, 'Tie::IxHash', ( + 1 => "2400 MHz", + 2 => "5700 MHz", + 3 => "5300 MHz", + 4 => "900 MHz", + 5 => "3650 MHz", + 12 => "584 MHz", + 13 => "24000 MHz", + 14 => "11000 MHz Licensed", + 15 => "815 MHz", + 16 => "860 MHz", + 17 => "1800 MHz CDMA 3G", + 18 => "18000 MHz Licensed", + 19 => "1700 MHz", + 20 => "2100 MHz AWS", + 21 => "2500-2700 MHz EBS/BRS", + 22 => "6000 MHz Licensed", + 23 => "476 MHz", + 24 => "4900 MHz - Public Safety", + 25 => "2300 MHz", + 28 => "7000 MHz 4PSK", + 29 => "12000 MHz 4PSK", + 30 => "60 MHz", + 31 => "260 MHz", + 32 => "70 MHz", + 34 => "155 MHz", + 35 => "365 MHz", + 36 => "435 MHz", + 38 => "3500 MHz", + 39 => "750 MHz", + 40 => "27 MHz", + 41 => "10000 MHz", + 42 => "10250 Mhz", + 43 => "10250 Mhz", + 44 => "160 MHz", + 45 => "700 MHz", + 46 => "722 MHz", + 47 => "38000 Mhz", + 49 => "551 MHz", + 50 => "600 MHz", + 51 => "2300 MHz", + 52 => "5100 MHz", + 53 => "1900Mhz", + ); + + # there has to be a better way to handle this. load it during upgrade? + # provide a proxy method like get_dids? + + tie our %antenna_type_id, 'Tie::IxHash', ( + 1 => 'Generic - Omni', + 5 => 'Generic - 120 Degree', + 8 => 'Generic - 45 Degree Panel', + 9 => 'Generic - 60 Degree Panel', + 10 => 'Generic - 60 Degree x 8 Sectors', + 11 => 'Generic - 90 Degree', + 12 => 'Alvarion 3.65 WiMax Base Satation', + 24 => 'Tranzeo - 3.5 GHz 17db 60 Sector', + 31 => 'Alpha - 2.3 2033 Omni', + 32 => "PMP450 - 60° Sector", + 33 => "PMP450 - 90° Sector", + 34 => 'PMP450 - SM Panel', + 36 => 'KPPA - 2GHZDP90S-45 17 dBi', + 37 => 'KPPA - 2GHZDP120S-45 14.2 dBi', + 38 => 'KPPA - 3GHZDP60S-45 16.3 dBi', + 39 => 'KPPA - 3GHZDP90S-45 16.7 dBi', + 40 => 'KPPA - 3GHZDP120S-45 14.8 dBi', + 41 => 'KPPA - 5GHZDP40S-17 18.2 dBi', + 42 => 'KPPA - 5GHZDP60S 17.7 dBi', + 43 => 'KPPA - 5GHZDP60S-17 18.2 dBi', + 44 => 'KPPA - 5GHZDP90S 17 dBi', + 45 => 'KPPA - 5GHZDP120S 16.3 dBi', + 46 => 'KPPA - OMNI-DP-2 13 dBi', + 47 => 'KPPA - OMNI-DP-2.4-45 10.7 dBi', + 48 => 'KPPA - OMNI-DP-3 13 dBi', + 49 => 'KPPA - OMNI-DP-3-45 11 dBi', + 51 => 'KPPA - OMNI-DP-5 14 dBi', + 53 => 'Telrad - 65 Degree 3.65 Ghz', + 54 => 'KPPA - 2GHZDP60S-17-45 15.1 dBi', + 55 => 'KPPA - 2GHZDP60S-45 17.9 dBi', + 56 => 'UBNT - AG-2G20', + 57 => 'UBNT - AG-5G23', + 58 => 'UBNT - AG-5G27', + 59 => 'UBNT - AM-2G15-120', + 60 => 'UBNT - AM-2G16-90', + 61 => 'UBNT - AM-3G18-120', + 62 => 'UBNT - AM-5G16-120', + 63 => 'UBNT - AM-5G17-90', + 64 => 'UBNT - AM-5G19-120', + 65 => 'UBNT - AM-5G20-90', + 66 => 'UBNT - AM-9G15-90', + 67 => 'UBNT - AMO-2G10', + 68 => 'UBNT - AMO-2G13', + 69 => 'UBNT - AMO-5G10', + 70 => 'UBNT - AMO-5G13', + 71 => 'UBNT - AMY-9M16', + 72 => 'UBNT - LOCOM2', + 73 => 'UBNT - LOCOM5', + 74 => 'UBNT - LOCOM9', + 75 => 'UBNT - NB-2G18', + 76 => 'UBNT - NB-5G22', + 77 => 'UBNT - NB-5G25', + 78 => 'UBNT - NBM3', + 79 => 'UBNT - NBM9', + 80 => 'UBNT - NSM2', + 81 => 'UBNT - NSM3', + 82 => 'UBNT - NSM5', + 83 => 'UBNT - NSM9', + 84 => 'UBNT - PBM3', + 85 => 'UBNT - PBM5', + 86 => 'UBNT - PBM10', + 87 => 'UBNT - RD-2G23', + 88 => 'UBNT - RD-3G25', + 89 => 'UBNT - RD-5G30', + 90 => 'UBNT - RD-5G34', + 92 => 'TerraWave - 2.3-2.7 18db 65-Degree Panel', + 93 => 'UBNT - AM-M521-60-AC', + 94 => 'UBNT - AM-M522-45-AC', + 101 => 'RF Elements - SH-TP-5-30', + 104 => 'RF Elements - SH-TP-5-40', + 105 => 'RF Elements - SH-TP-5-50', + 106 => 'RF Elements - SH-TP-5-60', + 107 => 'RF Elements - SH-TP-5-70', + 108 => 'RF Elements - SH-TP-5-80', + 109 => 'RF Elements - SH-TP-5-90', + 110 => 'UBNT - Test', + 111 => '60 Titanium', + 112 => '3.65GHz - 6x6', + 113 => 'AW3015-t0-c4(EOS)', + 114 => 'AW3035 (EOS)', + 122 => 'RF Elements - SEC-CC-5-20', + 135 => 'RF Elements - SEC-CC-2-14', + 137 => 'RF Elements - SEC-CC-5-17', + 168 => 'KPPA - Mimosa - 5GHZZHV4P65S-17', + ); +} + +1; diff --git a/FS/FS/tower_sector.pm b/FS/FS/tower_sector.pm index 08e8cc0df..2e9232307 100644 --- a/FS/FS/tower_sector.pm +++ b/FS/FS/tower_sector.pm @@ -1,6 +1,7 @@ package FS::tower_sector; use base qw( FS::Record ); +use FS::Record qw(dbh qsearch); use Class::Load qw(load_class); use File::Path qw(make_path); use Data::Dumper; @@ -8,6 +9,8 @@ use Cpanel::JSON::XS; use strict; +our $noexport_hack = 0; + =head1 NAME FS::tower_sector - Object methods for tower_sector records @@ -118,9 +121,26 @@ otherwise returns false. sub insert { my $self = shift; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + my $error = $self->SUPER::insert; return $error if $error; + unless ($noexport_hack) { + foreach my $part_export ($self->part_export) { + my $error = $part_export->export_insert($self); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "exporting to ".$part_export->exporttype. + " (transaction rolled back): $error"; + } + } + } + + # XXX exportify if (scalar($self->need_fields_for_coverage) == 0) { $self->queue_generate_coverage; } @@ -128,7 +148,27 @@ sub insert { sub replace { my $self = shift; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + my $old = shift || $self->replace_old; + my $error = $self->SUPER::replace($old); + return $error if $error; + + unless ( $noexport_hack ) { + foreach my $part_export ($self->part_export) { + my $error = $part_export->export_replace($self, $old); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "exporting to ".$part_export->exporttype. + " (transaction rolled back): $error"; + } + } + } + + #XXX exportify my $regen_coverage = 0; if ( !$self->get('no_regen') ) { foreach (qw(height freq_mhz direction width downtilt @@ -138,8 +178,6 @@ sub replace { } } - my $error = $self->SUPER::replace($old); - return $error if $error; if ($regen_coverage) { $self->queue_generate_coverage; @@ -155,11 +193,31 @@ Delete this record from the database. sub delete { my $self = shift; + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + #not the most efficient, not not awful, and its not like deleting a sector # with customers is a common operation return "Can't delete a sector with customers" if $self->svc_broadband; - $self->SUPER::delete; + unless ($noexport_hack) { + foreach my $part_export ($self->part_export) { + my $error = $part_export->export_delete($self); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "exporting to ".$part_export->exporttype. + " (transaction rolled back): $error"; + } + } + } + + my $error = $self->SUPER::delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } =item check @@ -185,13 +243,19 @@ sub check { || $self->ut_numbern('v_width') || $self->ut_numbern('downtilt') || $self->ut_floatn('sector_range') - || $self->ut_numbern('db_high') - || $self->ut_numbern('db_low') + || $self->ut_decimaln('power') + || $self->ut_decimaln('line_loss') + || $self->ut_decimaln('antenna_gain') + || $self->ut_numbern('hardware_typenum') + || $self->ut_textn('title') + # all of these might get relocated as part of coverage refactoring || $self->ut_anything('image') || $self->ut_sfloatn('west') || $self->ut_sfloatn('east') || $self->ut_sfloatn('south') || $self->ut_sfloatn('north') + || $self->ut_numbern('db_high') + || $self->ut_numbern('db_low') ; return $error if $error; @@ -229,6 +293,7 @@ Returns a list of required fields for the coverage map that aren't yet filled. =cut sub need_fields_for_coverage { + # for now assume exports require all of this my $self = shift; my $tower = $self->tower; my %fields = ( @@ -238,7 +303,8 @@ sub need_fields_for_coverage { downtilt => 'Downtilt', width => 'Horiz. width', v_width => 'Vert. width', - db_high => 'High quality', + db_high => 'High quality signal margin', + db_low => 'Low quality signal margin', latitude => 'Latitude', longitude => 'Longitude', ); @@ -257,10 +323,12 @@ Starts a job to recalculate the coverage map. =cut +# XXX move to an export + sub queue_generate_coverage { my $self = shift; my $need_fields = join(',', $self->need_fields_for_coverage); - return "Sector needs fields $need_fields" if $need_fields; + return "$need_fields required" if $need_fields; $self->set('no_regen', 1); # avoid recursion if ( length($self->image) > 0 ) { foreach (qw(image west south east north)) { @@ -277,6 +345,28 @@ sub queue_generate_coverage { =back +=head1 CLASS METHODS + +=over 4 + +=item part_export + +Returns all sector exports. Eventually this may be refined to the level +of enabling exports on specific sectors. + +=cut + +sub part_export { + my $info = $FS::part_export::exports{'tower_sector'} or return; + my @exporttypes = map { dbh->quote($_) } keys %$info or return; + qsearch({ + 'table' => 'part_export', + 'extra_sql' => 'WHERE exporttype IN(' . join(',', @exporttypes) . ')' + }); +} + +=back + =head1 SUBROUTINES =over 4 diff --git a/httemplate/edit/process/tower.html b/httemplate/edit/process/tower.html index 588a68e8d..cfbb4ffa3 100644 --- a/httemplate/edit/process/tower.html +++ b/httemplate/edit/process/tower.html @@ -4,7 +4,8 @@ process_o2m => { 'table' => 'tower_sector', 'fields' => [qw( sectorname ip_addr height freq_mhz direction width - downtilt v_width db_high db_low + downtilt v_width db_high db_low power line_loss + antenna_gain hardware_typenum sector_range )], }, diff --git a/httemplate/elements/tr-tower_sector.html b/httemplate/elements/tr-tower_sector.html deleted file mode 100644 index 871c7fd9c..000000000 --- a/httemplate/elements/tr-tower_sector.html +++ /dev/null @@ -1,24 +0,0 @@ -% unless ( $opt{'js_only'} ) { - - <% include('tr-td-label.html', %opt) %> - > - -% } -% - <% include( '/elements/sector.html', %opt ) %> -% -% unless ( $opt{'js_only'} ) { - - - - -% } -<%init> - -my( %opt ) = @_; - -my $cell_style = $opt{'cell_style'} ? 'STYLE="'. $opt{'cell_style'}. '"' : ''; - -$opt{'label'} ||= 'Sector'; - - diff --git a/httemplate/elements/tr-tower_sectors.html b/httemplate/elements/tr-tower_sectors.html index 4e8f3fb47..106fc76f6 100644 --- a/httemplate/elements/tr-tower_sectors.html +++ b/httemplate/elements/tr-tower_sectors.html @@ -1,3 +1,11 @@ +<%shared> +# kind of a hack... +my ($export) = FS::tower_sector->part_export; +my $antenna_types; # will be an ordered hash +if ($export and $export->can('get_antenna_types')) { + $antenna_types = $export->get_antenna_types; +} + <%init> my %opt = @_; my $tower = $opt{'object'}; @@ -7,8 +15,9 @@ my $cgi = $opt{'cgi'}; my $tabcounter = 0; my @fields = qw( - sectorname ip_addr height freq_mhz direction width tilt v_width db_high - db_low sector_range + sectorname ip_addr height freq_mhz direction width downtilt v_width + db_high db_low sector_range + power line_loss antenna_gain hardware_typenum ); my @sectors; @@ -74,6 +83,11 @@ my $id = $opt{id} || $opt{field} || 'sectornum'; border: none; text-align: left; } + .ui-tabs p { + margin-top: 8px; + margin-bottom: 8px; + } + @@ -216,6 +230,38 @@ $(function() {

    + + + <% emt('dBm') %>
    + + + <% emt('dB antenna gain') %>
    + + + <% emt('dB line loss') %> + +% if ( $antenna_types ) { +

    + + <& /elements/select.html, + field => $id.'_hardware_typenum', + options => [ '', keys %$antenna_types ], + labels => $antenna_types, + curr_value => $sector->hardware_typenum, + &> +

    +% } +% # this next section might not be necessary if you enter an antenna type +

    -

    +
    <% emt('dB (low quality)') %> -
    +
    diff --git a/httemplate/search/tower-map.html b/httemplate/search/tower-map.html index 559d83d08..d87e19ea6 100755 --- a/httemplate/search/tower-map.html +++ b/httemplate/search/tower-map.html @@ -8,6 +8,9 @@ html { height: 100% } span.is_up { font-weight: bold; color: green } span.is_down { font-weight: bold; color: red } #search_location { width: 300px } + +.sector_list li { list-style: none } +.sector_list li a { width: 150px }
    @@ -300,4 +303,16 @@ Tower #<% $tower->towernum %> | <% $tower->towername %>
    <% emt('Show coverage') %> +
      +% foreach my $sector ($tower->tower_sector) { +% # could be more descriptive here +
    • <% emt($sector->sectorname) %> +% my @links_array; +% foreach my $export ($sector->part_export) { +% $export->export_links($sector, \@links_array); # already HTML, do not escape +% } +<% join(' ', @links_array) %> +
      • +% } +
    -- cgit v1.2.1 From c5a2d3613acdc3b9ab6f32eaf5316c2834071417 Mon Sep 17 00:00:00 2001 From: Jonathan Prykop Date: Tue, 11 Oct 2016 20:43:13 -0500 Subject: 71513: Card tokenization in v4+ --- FS/FS/cust_main.pm | 7 + FS/FS/cust_main/Billing_Realtime.pm | 342 +++++++++++++++++++++++++----------- FS/FS/cust_payby.pm | 65 ++++--- FS/FS/log_context.pm | 1 + FS/FS/payinfo_Mixin.pm | 3 +- httemplate/misc/process/payment.cgi | 9 +- 6 files changed, 282 insertions(+), 145 deletions(-) diff --git a/FS/FS/cust_main.pm b/FS/FS/cust_main.pm index 2f05af69a..11d776393 100644 --- a/FS/FS/cust_main.pm +++ b/FS/FS/cust_main.pm @@ -4443,6 +4443,10 @@ CHEK only CHEK only +=item saved_cust_payby + +scalar reference, for returning saved object + =back =cut @@ -4639,6 +4643,9 @@ PAYBYLOOP: return $error; } + ${$opt{'saved_cust_payby'}} = $new + if $opt{'saved_cust_payby'}; + $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; diff --git a/FS/FS/cust_main/Billing_Realtime.pm b/FS/FS/cust_main/Billing_Realtime.pm index 295136032..ced3b236f 100644 --- a/FS/FS/cust_main/Billing_Realtime.pm +++ b/FS/FS/cust_main/Billing_Realtime.pm @@ -111,6 +111,8 @@ I allows payment capture to unlock export jobs =cut +# Currently only used by ClientAPI +# NOT 4.x COMPATIBLE (see below) sub realtime_collect { my( $self, %options ) = @_; @@ -124,6 +126,7 @@ sub realtime_collect { $options{amount} = $self->balance unless exists( $options{amount} ); return '' unless $options{amount} > 0; + #### NOT 4.x COMPATIBLE $options{method} = FS::payby->payby2bop($self->payby) unless exists( $options{method} ); @@ -137,16 +140,14 @@ Runs a realtime credit card or ACH (electronic check) transaction via a Business::OnlinePayment realtime gateway. See L for supported gateways. -Required arguments in the hashref are I, and I +Required arguments in the hashref are I and either +I or I, I and (as applicable for method) +I, I, I, I, I, I and I. Available methods are: I, I, or I Available optional arguments are: I, I, I, I, I, I, I -The additional options I, I, I, I, I, -I, I and I are also available. Any of these options, -if set, will override the value from the customer record. - I is a free-text field passed to the gateway. It defaults to the value defined by the business-onlinepayment-description configuration option, or "Internet services" if that is unset. @@ -279,11 +280,6 @@ sub _bop_defaults { } } - unless ( exists( $options->{'payinfo'} ) ) { - $options->{'payinfo'} = $self->payinfo; - $options->{'paymask'} = $self->paymask; - } - # Default invoice number if the customer has exactly one open invoice. unless ( $options->{'invnum'} || $options->{'no_invnum'} ) { $options->{'invnum'} = ''; @@ -291,14 +287,50 @@ sub _bop_defaults { $options->{'invnum'} = $open[0]->invnum if scalar(@open) == 1; } - $options->{payname} = $self->payname unless exists( $options->{payname} ); +} + +sub _bop_cust_payby_options { + my ($self,$options) = @_; + my $cust_payby = $options->{'cust_payby'}; + if ($cust_payby) { + + $options->{'method'} = FS::payby->payby2bop( $cust_payby->payby ); + + if ($cust_payby->payby =~ /^(CARD|DCRD)$/) { + # false laziness with cust_payby->check + # which might not have been run yet + my( $m, $y ); + if ( $cust_payby->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ ) { + ( $m, $y ) = ( $1, length($2) == 4 ? $2 : "20$2" ); + } elsif ( $cust_payby->paydate =~ /^19(\d{2})[\/\-](\d{1,2})[\/\-]\d+$/ ) { + ( $m, $y ) = ( $2, "19$1" ); + } elsif ( $cust_payby->paydate =~ /^(20)?(\d{2})[\/\-](\d{1,2})[\/\-]\d+$/ ) { + ( $m, $y ) = ( $3, "20$2" ); + } else { + return "Illegal expiration date: ". $cust_payby->paydate; + } + $m = sprintf('%02d',$m); + $options->{paydate} = "$y-$m-01"; + } else { + $options->{paydate} = ''; + } + + $options->{$_} = $cust_payby->$_() + for qw( payinfo paycvv paymask paystart_month paystart_year + payissue payname paystate paytype payip ); + + if ( $cust_payby->locationnum ) { + my $cust_location = $cust_payby->cust_location; + $options->{$_} = $cust_location->$_() for qw( address1 address2 city state zip ); + } + } } sub _bop_content { my ($self, $options) = @_; my %content = (); - my $payip = exists($options->{'payip'}) ? $options->{'payip'} : $self->payip; + my $payip = $options->{'payip'}; $content{customer_ip} = $payip if length($payip); $content{invoice_number} = $options->{'invnum'} @@ -325,26 +357,14 @@ sub _bop_content { $content{name} = $payname; - $content{address} = exists($options->{'address1'}) - ? $options->{'address1'} - : $self->address1; - my $address2 = exists($options->{'address2'}) - ? $options->{'address2'} - : $self->address2; + $content{address} = $options->{'address1'}; + my $address2 = $options->{'address2'}; $content{address} .= ", ". $address2 if length($address2); - $content{city} = exists($options->{city}) - ? $options->{city} - : $self->city; - $content{state} = exists($options->{state}) - ? $options->{state} - : $self->state; - $content{zip} = exists($options->{zip}) - ? $options->{'zip'} - : $self->zip; - $content{country} = exists($options->{country}) - ? $options->{country} - : $self->country; + $content{city} = $options->{'city'}; + $content{state} = $options->{'state'}; + $content{zip} = $options->{'zip'}; + $content{country} = $options->{'country'}; $content{phone} = $self->daytime || $self->night; @@ -356,28 +376,24 @@ sub _bop_content { } sub _tokenize_card { - my ($self,$transaction,$payinfo,$log) = @_; + my ($self,$transaction,$cust_payby,$log,%opt) = @_; - if ( $transaction->can('card_token') + if ( $cust_payby + and $transaction->can('card_token') and $transaction->card_token - and $payinfo !~ /^99\d{14}$/ #not already tokenized + and $cust_payby->payinfo !~ /^99\d{14}$/ #not already tokenized ) { - my @cust_payby = $self->cust_payby('CARD','DCRD'); - @cust_payby = grep { $payinfo == $_->payinfo } @cust_payby; - if (@cust_payby > 1) { - $log->error('Multiple matching card numbers for cust '.$self->custnum.', could not tokenize card'); - } elsif (@cust_payby) { - my $cust_payby = $cust_payby[0]; - $cust_payby->payinfo($transaction->card_token); - my $error = $cust_payby->replace; - if ( $error ) { - $log->error('Error storing token for cust '.$self->custnum.', cust_payby '.$cust_payby->custpaybynum.': '.$error); - } else { - $log->debug('Tokenized card for cust '.$self->custnum.', cust_payby '.$cust_payby->custpaybynum); - } + $cust_payby->payinfo($transaction->card_token); + + my $error; + $error = $cust_payby->replace if $opt{'replace'}; + if ( $error ) { + $log->error('Error storing token for cust '.$self->custnum.', cust_payby '.$cust_payby->custpaybynum.': '.$error); + return $error; } else { - $log->debug('No matching card numbers for cust '.$self->custnum.', could not tokenize card'); + $log->debug('Tokenized card for cust '.$self->custnum.', cust_payby '.$cust_payby->custpaybynum); + return ''; } } @@ -411,6 +427,8 @@ sub realtime_bop { $options{amount} = $amount; } + # set fields from passed cust_payby + $self->_bop_cust_payby_options(\%options); ### # optional credit card surcharge @@ -450,6 +468,9 @@ sub realtime_bop { $self->_bop_defaults(\%options); + return "Missing payinfo" + unless $options{'payinfo'}; + ### # set trans_is_recur based on invnum if there is one ### @@ -535,29 +556,19 @@ sub realtime_bop { if ( $options{method} eq 'CC' ) { $content{card_number} = $options{payinfo}; - $paydate = exists($options{'paydate'}) - ? $options{'paydate'} - : $self->paydate; + $paydate = $options{'paydate'}; $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/; $content{expiration} = "$2/$1"; $content{cvv2} = $options{'paycvv'} if length($options{'paycvv'}); - my $paystart_month = exists($options{'paystart_month'}) - ? $options{'paystart_month'} - : $self->paystart_month; - - my $paystart_year = exists($options{'paystart_year'}) - ? $options{'paystart_year'} - : $self->paystart_year; - + my $paystart_month = $options{'paystart_month'}; + my $paystart_year = $options{'paystart_year'}; $content{card_start} = "$paystart_month/$paystart_year" if $paystart_month && $paystart_year; - my $payissue = exists($options{'payissue'}) - ? $options{'payissue'} - : $self->payissue; + my $payissue = $options{'payissue'}; $content{issue_number} = $payissue if $payissue; if ( $self->_bop_recurring_billing( @@ -576,13 +587,8 @@ sub realtime_bop { ( $content{account_number}, $content{routing_code} ) = split('@', $options{payinfo}); $content{bank_name} = $options{payname}; - $content{bank_state} = exists($options{'paystate'}) - ? $options{'paystate'} - : $self->getfield('paystate'); - $content{account_type}= - (exists($options{'paytype'}) && $options{'paytype'}) - ? uc($options{'paytype'}) - : uc($self->getfield('paytype')) || 'PERSONAL CHECKING'; + $content{bank_state} = $options{'paystate'}; + $content{account_type}= uc($options{'paytype'}) || 'PERSONAL CHECKING'; $content{company} = $self->company if $self->company; @@ -805,7 +811,8 @@ sub realtime_bop { # Tokenize ### - $self->_tokenize_card($transaction,$options{'payinfo'},$log); + my $error = $self->_tokenize_card($transaction,$options{'cust_payby'},$log,'replace' => 1); + return $error if $error; ### # result handling @@ -1721,21 +1728,14 @@ successful, immediatly reverses the authorization). Returns the empty string if the authorization was sucessful, or an error message otherwise. -I +Option I should be passed, even if it's not yet been inserted. +Object will be tokenized if possible, but that change will not be +updated in database (must be inserted/replaced afterwards.) -I - -I specifies the expiration date for a credit card overriding the -value from the customer record or the payment record. Specified as yyyy-mm-dd - -#The additional options I, I, I, I, -#I are also available. Any of these options, -#if set, will override the value from the customer record. +Currently only succeeds for Business::OnlinePayment CC transactions. =cut -#Available methods are: I or I - #some false laziness w/realtime_bop and realtime_refund_bop, not enough to make #it worth merging but some useful small subs should be pulled out sub realtime_verify_bop { @@ -1756,6 +1756,10 @@ sub realtime_verify_bop { warn " $_ => $options{$_}\n" foreach keys %options; } + # set fields from passed cust_payby + return "No cust_payby" unless $options{'cust_payby'}; + $self->_bop_cust_payby_options(\%options); + ### # select a gateway ### @@ -1802,43 +1806,33 @@ sub realtime_verify_bop { if ( $options{method} eq 'CC' ) { $content{card_number} = $options{payinfo}; - $paydate = exists($options{'paydate'}) - ? $options{'paydate'} - : $self->paydate; + $paydate = $options{'paydate'}; $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/; $content{expiration} = "$2/$1"; $content{cvv2} = $options{'paycvv'} if length($options{'paycvv'}); - my $paystart_month = exists($options{'paystart_month'}) - ? $options{'paystart_month'} - : $self->paystart_month; - - my $paystart_year = exists($options{'paystart_year'}) - ? $options{'paystart_year'} - : $self->paystart_year; + my $paystart_month = $options{'paystart_month'}; + my $paystart_year = $options{'paystart_year'}; $content{card_start} = "$paystart_month/$paystart_year" if $paystart_month && $paystart_year; - my $payissue = exists($options{'payissue'}) - ? $options{'payissue'} - : $self->payissue; + my $payissue = $options{'payissue'}; $content{issue_number} = $payissue if $payissue; } elsif ( $options{method} eq 'ECHECK' ){ - - #nop for checks (though it shouldn't be called...) - + #cannot verify, move along (though it shouldn't be called...) + return ''; } else { - die "unknown method ". $options{method}; + return "unknown method ". $options{method}; } - } elsif ( $namespace eq 'Business::OnlineThirdPartyPayment' ) { - #move along + #cannot verify, move along + return ''; } else { - die "unknown namespace $namespace"; + return "unknown namespace $namespace"; } ### @@ -1847,6 +1841,7 @@ sub realtime_verify_bop { my $error; my $transaction; #need this back so we can do _tokenize_card + # don't mutex the customer here, because they might be uncommitted. and # this is only verification. it doesn't matter if they have other # unfinished verifications. @@ -1859,12 +1854,10 @@ sub realtime_verify_bop { 'payinfo' => $options{payinfo}, 'paymask' => $options{paymask}, 'paydate' => $paydate, - #'recurring_billing' => $content{recurring_billing}, 'pkgnum' => $options{'pkgnum'}, 'status' => 'new', 'gatewaynum' => $payment_gateway->gatewaynum || '', 'session_id' => $options{session_id} || '', - #'jobnum' => $options{depend_jobnum} || '', }; $cust_pay_pending->payunique( $options{payunique} ) if defined($options{payunique}) && length($options{payunique}); @@ -1905,12 +1898,9 @@ sub realtime_verify_bop { 'action' => 'Authorization Only', 'description' => $options{'description'}, 'amount' => '1.00', - #'invoice_number' => $options{'invnum'}, 'customer_id' => $self->custnum, %$bop_content, 'reference' => $cust_pay_pending->paypendingnum, #for now - 'callback_url' => $payment_gateway->gateway_callback_url, - 'cancel_url' => $payment_gateway->gateway_cancel_url, 'email' => $email, %content, #after ); @@ -2123,7 +2113,9 @@ sub realtime_verify_bop { # Tokenize ### - $self->_tokenize_card($transaction,$options{'payinfo'},$log); + #important that we not pass replace option here, + #because cust_payby->replace uses realtime_verify_bop! + $self->_tokenize_card($transaction,$options{'cust_payby'},$log); ### # result handling @@ -2135,6 +2127,144 @@ sub realtime_verify_bop { } +=item realtime_tokenize [ OPTION => VALUE ... ] + +If possible, runs a tokenize transaction. +In order to be possible, a credit card cust_payby record +must be passed and a Business::OnlinePayment gateway capable +of Tokenize transactions must be configured for this user. + +Returns the empty string if the authorization was sucessful +or was not possible (thus allowing this to be safely called with +non-tokenizable records/gateways, without having to perform separate tests), +or an error message otherwise. + +Option I should be passed, even if it's not yet been inserted. +Object will be tokenized if possible, but that change will not be +updated in database (must be inserted/replaced afterwards.) + +=cut + +sub realtime_tokenize { + my $self = shift; + + local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG; + my $log = FS::Log->new('FS::cust_main::Billing_Realtime::realtime_tokenize'); + + my %options = (); + if (ref($_[0]) eq 'HASH') { + %options = %{$_[0]}; + } else { + %options = @_; + } + + # set fields from passed cust_payby + return "No cust_payby" unless $options{'cust_payby'}; + $self->_bop_cust_payby_options(\%options); + return '' unless $options{method} eq 'CC'; + return '' if $options{payinfo} =~ /^99\d{14}$/; #already tokenized + + ### + # select a gateway + ### + + $options{'nofatal'} = 1; + my $payment_gateway = $self->_payment_gateway( \%options ); + return '' unless $payment_gateway; + my $namespace = $payment_gateway->gateway_namespace; + return '' unless $namespace eq 'Business::OnlinePayment'; + + eval "use $namespace"; + return $@ if $@; + + ### + # check for tokenize ability + ### + + # just create transaction now, so it loads gateway_module + my $transaction = new $namespace( $payment_gateway->gateway_module, + $self->_bop_options(\%options), + ); + + my %supported_actions = $transaction->info('supported_actions'); + return '' unless $supported_actions{'CC'} and grep(/^Tokenize$/,@{$supported_actions{'CC'}}); + + ### + # check for banned credit card/ACH + ### + + my $ban = FS::banned_pay->ban_search( + 'payby' => $bop_method2payby{'CC'}, + 'payinfo' => $options{payinfo}, + ); + return "Banned credit card" if $ban && $ban->bantype ne 'warn'; + + ### + # massage data + ### + + my $bop_content = $self->_bop_content(\%options); + return $bop_content unless ref($bop_content); + + my $paydate = ''; + my %content = (); + + $content{card_number} = $options{payinfo}; + $paydate = $options{'paydate'}; + $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/; + $content{expiration} = "$2/$1"; + + $content{cvv2} = $options{'paycvv'} + if length($options{'paycvv'}); + + my $paystart_month = $options{'paystart_month'}; + my $paystart_year = $options{'paystart_year'}; + + $content{card_start} = "$paystart_month/$paystart_year" + if $paystart_month && $paystart_year; + + my $payissue = $options{'payissue'}; + $content{issue_number} = $payissue if $payissue; + + ### + # run transaction + ### + + my $error; + + # no cust_pay_pending---this is not a financial transaction + + $transaction->content( + 'type' => 'CC', + $self->_bop_auth(\%options), + 'action' => 'Tokenize', + 'description' => $options{'description'}, + 'customer_id' => $self->custnum, + %$bop_content, + %content, #after + ); + + # no $BOP_TESTING handling for this + $transaction->test_transaction(1) + if $conf->exists('business-onlinepayment-test_transaction'); + $transaction->submit(); + + if ( $transaction->card_token() ) { # no is_success flag + + #important that we not pass replace option here, + #because cust_payby->replace uses realtime_tokenize! + $self->_tokenize_card($transaction,$options{'cust_payby'},$log); + + } else { + + $error = $transaction->error_message || 'Unknown error'; + + } + + return $error; + +} + =back =head1 BUGS diff --git a/FS/FS/cust_payby.pm b/FS/FS/cust_payby.pm index e4a1d193c..626fc9fe9 100644 --- a/FS/FS/cust_payby.pm +++ b/FS/FS/cust_payby.pm @@ -250,8 +250,11 @@ sub replace { if ( $conf->exists('business-onlinepayment-verification') ) { $error = $self->verify; - return $error if $error; + } else { + $error = $self->tokenize; } + return $error if $error; + } local $SIG{HUP} = 'IGNORE'; @@ -521,9 +524,12 @@ sub check { } - if ( ! $self->custpaybynum - && $conf->exists('business-onlinepayment-verification') ) { - $error = $self->verify; + if ( ! $self->custpaybynum ) { + if ($conf->exists('business-onlinepayment-verification')) { + $error = $self->verify; + } else { + $error = $self->tokenize; + } return $error if $error; } @@ -638,59 +644,48 @@ sub label { =item realtime_bop +Runs a L transaction on this card + =cut sub realtime_bop { my( $self, %opt ) = @_; - $opt{$_} = $self->$_() for qw( payinfo payname paydate ); - - if ( $self->locationnum ) { - my $cust_location = $self->cust_location; - $opt{$_} = $cust_location->$_() for qw( address1 address2 city state zip ); - } - $self->cust_main->realtime_bop({ - 'method' => FS::payby->payby2bop( $self->payby ), %opt, + 'cust_payby' => $self, }); } -=item verify +=item tokenize + +Runs a L transaction on this card =cut -sub verify { +sub tokenize { my $self = shift; return '' unless $self->payby =~ /^(CARD|DCRD)$/; - my %opt = (); + $self->cust_main->realtime_tokenize({ + 'cust_payby' => $self, + }); - # false laziness with check - my( $m, $y ); - if ( $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ ) { - ( $m, $y ) = ( $1, length($2) == 4 ? $2 : "20$2" ); - } elsif ( $self->paydate =~ /^19(\d{2})[\/\-](\d{1,2})[\/\-]\d+$/ ) { - ( $m, $y ) = ( $2, "19$1" ); - } elsif ( $self->paydate =~ /^(20)?(\d{2})[\/\-](\d{1,2})[\/\-]\d+$/ ) { - ( $m, $y ) = ( $3, "20$2" ); - } else { - return "Illegal expiration date: ". $self->paydate; - } - $m = sprintf('%02d',$m); - $opt{paydate} = "$y-$m-01"; +} - $opt{$_} = $self->$_() for qw( payinfo payname paycvv ); +=item verify - if ( $self->locationnum ) { - my $cust_location = $self->cust_location; - $opt{$_} = $cust_location->$_() for qw( address1 address2 city state zip ); - } +Runs a L transaction on this card + +=cut + +sub verify { + my $self = shift; + return '' unless $self->payby =~ /^(CARD|DCRD)$/; $self->cust_main->realtime_verify_bop({ - 'method' => FS::payby->payby2bop( $self->payby ), - %opt, + 'cust_payby' => $self, }); } diff --git a/FS/FS/log_context.pm b/FS/FS/log_context.pm index ee3e413ee..809237d06 100644 --- a/FS/FS/log_context.pm +++ b/FS/FS/log_context.pm @@ -9,6 +9,7 @@ my @contexts = ( qw( FS::cust_main::Billing::bill_and_collect FS::cust_main::Billing::bill FS::cust_main::Billing_Realtime::realtime_bop + FS::cust_main::Billing_Realtime::realtime_tokenize FS::cust_main::Billing_Realtime::realtime_verify_bop FS::pay_batch::import_from_gateway FS::part_pkg diff --git a/FS/FS/payinfo_Mixin.pm b/FS/FS/payinfo_Mixin.pm index 5f7ce3550..3a32ad5b2 100644 --- a/FS/FS/payinfo_Mixin.pm +++ b/FS/FS/payinfo_Mixin.pm @@ -67,8 +67,9 @@ sub payinfo { my($self,$payinfo) = @_; if ( defined($payinfo) ) { + $self->paymask($self->mask_payinfo) unless $self->payinfo =~ /^99\d{14}$/; #make sure old mask is set $self->setfield('payinfo', $payinfo); - $self->paymask($self->mask_payinfo) unless $payinfo =~ /^99\d{14}$/; #token + $self->paymask($self->mask_payinfo) unless $payinfo =~ /^99\d{14}$/; #remask unless tokenizing } else { $self->getfield('payinfo'); } diff --git a/httemplate/misc/process/payment.cgi b/httemplate/misc/process/payment.cgi index 852becb9d..74ca7348f 100644 --- a/httemplate/misc/process/payment.cgi +++ b/httemplate/misc/process/payment.cgi @@ -72,7 +72,7 @@ $cgi->param('discount_term') =~ /^(\d*)$/ or errorpage("illegal discount_term"); my $discount_term = $1; -my( $payinfo, $paycvv, $month, $year, $payname ); +my( $cust_payby, $payinfo, $paycvv, $month, $year, $payname ); my $paymask = ''; if ( (my $custpaybynum = scalar($cgi->param('custpaybynum'))) > 0 ) { @@ -80,10 +80,11 @@ if ( (my $custpaybynum = scalar($cgi->param('custpaybynum'))) > 0 ) { # use stored cust_payby info ## - my $cust_payby = qsearchs('cust_payby', { custnum => $custnum, + $cust_payby = qsearchs('cust_payby', { custnum => $custnum, custpaybynum => $custpaybynum, } ) or die "unknown custpaybynum $custpaybynum"; + # not needed for realtime_bop, but still needed for batch_card $payinfo = $cust_payby->payinfo; $paymask = $cust_payby->paymask; $paycvv = $cust_payby->paycvv; # pass it if we got it, running a transaction will clear it @@ -164,7 +165,7 @@ if ( (my $custpaybynum = scalar($cgi->param('custpaybynum'))) > 0 ) { die "unknown payby $payby"; } - # save first, for proper tokenization later + # save first, for proper tokenization if ( $cgi->param('save') ) { my %saveopt; @@ -181,6 +182,7 @@ if ( (my $custpaybynum = scalar($cgi->param('custpaybynum'))) > 0 ) { } my $error = $cust_main->save_cust_payby( + 'saved_cust_payby' => \$cust_payby, 'payment_payby' => $payby, 'auto' => scalar($cgi->param('auto')), 'weight' => scalar($cgi->param('weight')), @@ -220,6 +222,7 @@ if ( $cgi->param('batch') ) { } else { $error = $cust_main->realtime_bop( $FS::payby::payby2bop{$payby}, $amount, + 'cust_payby' => $cust_payby, # if defined, will override passed payinfo, etc 'quiet' => 1, 'manual' => 1, 'balance' => $balance, -- cgit v1.2.1 From 6eec422e339e7a7209cac18da71ba598ee18d7d2 Mon Sep 17 00:00:00 2001 From: Mark Wells Date: Thu, 13 Oct 2016 15:35:26 -0700 Subject: per-customer option to force anniversary packages to prorate, #38191 --- FS/FS/Schema.pm | 1 + FS/FS/cust_main.pm | 1 + FS/FS/part_pkg/flat.pm | 6 ++++++ FS/FS/part_pkg/prorate_calendar.pm | 6 +++++- FS/FS/part_pkg/recur_Common.pm | 13 +++++++------ FS/FS/part_pkg/subscription.pm | 5 +++++ httemplate/edit/cust_main/billing.html | 6 ++++++ httemplate/elements/freeside.css | 3 ++- 8 files changed, 33 insertions(+), 8 deletions(-) diff --git a/FS/FS/Schema.pm b/FS/FS/Schema.pm index a1615b71a..f8b82f454 100644 --- a/FS/FS/Schema.pm +++ b/FS/FS/Schema.pm @@ -1641,6 +1641,7 @@ sub tables_hashref { 'accountcode_cdr', 'char', 'NULL', 1, '', '', 'billday', 'int', 'NULL', '', '', '', 'prorate_day', 'int', 'NULL', '', '', '', + 'force_prorate_day', 'char', 'NULL', 1, '', '', 'edit_subject', 'char', 'NULL', 1, '', '', 'locale', 'varchar', 'NULL', 16, '', '', 'calling_list_exempt', 'char', 'NULL', 1, '', '', diff --git a/FS/FS/cust_main.pm b/FS/FS/cust_main.pm index 11d776393..9c8e37499 100644 --- a/FS/FS/cust_main.pm +++ b/FS/FS/cust_main.pm @@ -1775,6 +1775,7 @@ sub check { || $self->ut_floatn('credit_limit') || $self->ut_numbern('billday') || $self->ut_numbern('prorate_day') + || $self->ut_flag('force_prorate_day') || $self->ut_flag('edit_subject') || $self->ut_flag('calling_list_exempt') || $self->ut_flag('invoice_noemail') diff --git a/FS/FS/part_pkg/flat.pm b/FS/FS/part_pkg/flat.pm index 97d4363da..504def0cf 100644 --- a/FS/FS/part_pkg/flat.pm +++ b/FS/FS/part_pkg/flat.pm @@ -173,6 +173,12 @@ sub calc_recur { sub cutoff_day { my $self = shift; my $cust_pkg = shift; + my $cust_main = $cust_pkg->cust_main; + # force it to act like a prorate package, is what this means + # because we made a distinction once between prorate and flat packages + if ( $cust_main->force_prorate_day and $cust_main->prorate_day ) { + return ( $cust_main->prorate_day ); + } if ( $self->option('sync_bill_date',1) ) { my $next_bill = $cust_pkg->cust_main->next_bill_date; if ( $next_bill ) { diff --git a/FS/FS/part_pkg/prorate_calendar.pm b/FS/FS/part_pkg/prorate_calendar.pm index c50cae0d7..a8ed8f942 100644 --- a/FS/FS/part_pkg/prorate_calendar.pm +++ b/FS/FS/part_pkg/prorate_calendar.pm @@ -72,7 +72,11 @@ sub check { sub cutoff_day { my( $self, $cust_pkg ) = @_; my @periods = @{ $freq_cutoff_days{$self->freq} }; - my @cutoffs = ($self->option('cutoff_day') || 1); # Jan 1 = 1 + my $prorate_day = $cust_pkg->cust_main->prorate_day + || $self->option('cutoff_day') + || 1; + + my @cutoffs = ($prorate_day); pop @periods; # we don't care about the last one foreach (@periods) { push @cutoffs, $cutoffs[-1] + $_; diff --git a/FS/FS/part_pkg/recur_Common.pm b/FS/FS/part_pkg/recur_Common.pm index b73c62c25..4ed83a46b 100644 --- a/FS/FS/part_pkg/recur_Common.pm +++ b/FS/FS/part_pkg/recur_Common.pm @@ -41,13 +41,14 @@ sub cutoff_day { # prorate/subscription only; we don't support sync_bill_date here my( $self, $cust_pkg ) = @_; my $recur_method = $self->option('recur_method',1) || 'anniversary'; - return () unless $recur_method eq 'prorate' - || $recur_method eq 'subscription'; + my $cust_main = $cust_pkg->cust_main; - #false laziness w/prorate.pm::cutoff_day - my $prorate_day = $cust_pkg->cust_main->prorate_day; - $prorate_day ? ( $prorate_day ) - : split(/\s*,\s*/, $self->option('cutoff_day', 1) || '1'); + if ( $cust_main->force_prorate_day and $cust_main->prorate_day ) { + return ( $cust_main->prorate_day ); + } elsif ($recur_method eq 'prorate' || $recur_method eq 'subscription') { + + return split(/\s*,\s*/, $self->option('cutoff_day', 1) || '1'); + } } sub calc_recur_Common { diff --git a/FS/FS/part_pkg/subscription.pm b/FS/FS/part_pkg/subscription.pm index 0dfe049fe..bf644d48c 100644 --- a/FS/FS/part_pkg/subscription.pm +++ b/FS/FS/part_pkg/subscription.pm @@ -88,6 +88,11 @@ use FS::part_pkg::flat; sub calc_recur { my($self, $cust_pkg, $sdate, $details, $param ) = @_; my $cutoff_day = $self->option('cutoff_day', 1) || 1; + my $cust_main = $cust_pkg->cust_main; + if ( $cust_main->force_prorate_day and $cust_main->prorate_day ) { + $cutoff_day = $cust_main->prorate_day; + } + my $mnow = $$sdate; my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($mnow) )[0,1,2,3,4,5]; diff --git a/httemplate/edit/cust_main/billing.html b/httemplate/edit/cust_main/billing.html index 50262e82c..649c4c945 100644 --- a/httemplate/edit/cust_main/billing.html +++ b/httemplate/edit/cust_main/billing.html @@ -124,6 +124,12 @@ + <& /elements/checkbox.html, + field => 'force_prorate_day', + value => 'Y', + curr_value => $cust_main->force_prorate_day + &> + diff --git a/httemplate/elements/freeside.css b/httemplate/elements/freeside.css index 8545ee596..c98fdcbc5 100644 --- a/httemplate/elements/freeside.css +++ b/httemplate/elements/freeside.css @@ -232,7 +232,8 @@ div.fstabcontainer { border-radius: .25em; } -.fsinnerbox th { +.fsinnerbox th, +.fsinnerbox label { font-weight:normal; font-size:80%; vertical-align: top; -- cgit v1.2.1 From c8d971625edc253e1fa011c08a96030c12dde3bb Mon Sep 17 00:00:00 2001 From: Mark Wells Date: Thu, 13 Oct 2016 20:31:59 -0700 Subject: script to manually initialize events, #72949 --- bin/initialize-event | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) create mode 100755 bin/initialize-event diff --git a/bin/initialize-event b/bin/initialize-event new file mode 100755 index 000000000..f186e195f --- /dev/null +++ b/bin/initialize-event @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +use FS::Misc::Getopt; +use FS::part_event; +use FS::cust_event; +use FS::Record 'dbdef'; +use FS::Cursor; + +getopts('e:x'); + +my $eventpart = $opt{e}; +my $part_event = FS::part_event->by_key($opt{e}) + or die "usage: initialize-event -e \n"; + + +my $eventtable = $part_event->eventtable; +my $pkey = dbdef->table($eventtable)->primary_key; +my $from = " LEFT JOIN (SELECT DISTINCT tablenum AS $pkey FROM cust_event + WHERE eventpart = $eventpart) AS done USING ($pkey)", +my $where = " WHERE done.$pkey IS NULL"; + +my $count = FS::Record->scalar_sql("SELECT COUNT(*) FROM $eventtable $from $where"); +print "Event ".$part_event->event."\n". + "Will initialize on $count $eventtable records.\n"; +if (!$opt{x}) { + print "Run with -x to make changes.\n"; + exit; +} + + +print "Disabling event.\n"; +$part_event->disabled('Y'); +my $error = $part_event->replace; +die $error if $error; +my $cursor = FS::Cursor->new({ + table => $eventtable, + addl_from => $from, + extra_sql => $where, +}); +my $user = $FS::CurrentUser::CurrentUser->username; +my $statustext = "Manually by $user"; +while (my $record = $cursor->fetch) { + my $cust_event = FS::cust_event->new({ + status => 'initial', + eventpart => $eventpart, + tablenum => $record->get($pkey), + _date => $^T, + statustext => $statustext, + }); + $error = $cust_event->insert; + if ($error) { + print "$eventtable #".$record->get($pkey).": $error\n" if $error; + } else { + $count--; + } +} +print "$count unprocessed records."; +if ($count == 0) { + print "Re-enabling event.\n"; + $part_event->disabled(''); + $error = $part_event->replace; + die $error if $error; +} else { + print "Event is still disabled.\n"; +} + +print "Finished.\n"; + -- cgit v1.2.1 From 8282a324857d658d17061e3f0867d8c7d71b098a Mon Sep 17 00:00:00 2001 From: Mark Wells Date: Fri, 14 Oct 2016 09:34:06 -0700 Subject: cursorize part_event::initialize so that it works on large data sets --- FS/FS/part_event.pm | 63 +++++++++++++++++++++++++++++++---------------------- 1 file changed, 37 insertions(+), 26 deletions(-) diff --git a/FS/FS/part_event.pm b/FS/FS/part_event.pm index 58e01271c..1c2389989 100644 --- a/FS/FS/part_event.pm +++ b/FS/FS/part_event.pm @@ -6,6 +6,7 @@ use vars qw( $DEBUG ); use Carp qw(confess); use FS::Record qw( dbh qsearch qsearchs ); use FS::Conf; +use FS::Cursor; use FS::part_event_option; use FS::part_event_condition; use FS::cust_event; @@ -251,10 +252,28 @@ but can be useful when configuring events. =cut -sub targets { +sub targets { # may want to cursor this also my $self = shift; my %opt = @_; - my $time = $opt{'time'} || time; + my $time = $opt{'time'} ||= time; + + my $query = $self->_target_query(%opt); + my @objects = qsearch($query); + my @tested_objects; + foreach my $object ( @objects ) { + my $cust_event = $self->new_cust_event($object, 'time' => $time); + next unless $cust_event->test_conditions; + + $object->set('cust_event', $cust_event); + push @tested_objects, $object; + } + @tested_objects; +} + +sub _target_query { + my $self = shift; + my %opt = @_; + my $time = $opt{'time'}; my $eventpart = $self->eventpart; $eventpart =~ /^\d+$/ or die "bad eventpart $eventpart"; @@ -285,23 +304,15 @@ sub targets { # and don't enforce disabled because we want to be able to see targets # for a disabled event - my @objects = qsearch({ + { table => $eventtable, hashref => {}, addl_from => $join, extra_sql => "WHERE $where", - }); - my @tested_objects; - foreach my $object ( @objects ) { - my $cust_event = $self->new_cust_event($object, 'time' => $time); - next unless $cust_event->test_conditions; - - $object->set('cust_event', $cust_event); - push @tested_objects, $object; - } - @tested_objects; + }; } + =item initialize PARAMS Identify all objects eligible for this event and create L @@ -323,26 +334,26 @@ sub initialize { my $self = shift; my $error; - my $oldAutoCommit = $FS::UID::AutoCommit; - local $FS::UID::AutoCommit = 0; - my $dbh = dbh; + my $time = time; + + local $FS::UID::AutoCommit = 1; + my $cursor = FS::Cursor->new( $self->_target_query('time' => $time) ); + while (my $object = $cursor->fetch) { + + my $cust_event = $self->new_cust_event($object, 'time' => $time); + next unless $cust_event->test_conditions; - my @objects = $self->targets; - foreach my $object ( @objects ) { - my $cust_event = $object->get('cust_event'); $cust_event->status('initial'); $error = $cust_event->insert; - last if $error; + die $error if $error; } - if ( !$error and $self->disabled ) { + + # on successful completion only, re-enable the event + if ( $self->disabled ) { $self->disabled(''); $error = $self->replace; + die $error if $error; } - if ( $error ) { - $dbh->rollback; - return $error; - } - $dbh->commit if $oldAutoCommit; return; } -- cgit v1.2.1 From fbfd9445bb00c2a1c7f4386878edead9b50c482f Mon Sep 17 00:00:00 2001 From: Mark Wells Date: Fri, 14 Oct 2016 12:04:45 -0700 Subject: and show the flag in view UI, #38191 --- httemplate/view/cust_main/billing.html | 1 + 1 file changed, 1 insertion(+) diff --git a/httemplate/view/cust_main/billing.html b/httemplate/view/cust_main/billing.html index 7ee05a357..8d3925a08 100644 --- a/httemplate/view/cust_main/billing.html +++ b/httemplate/view/cust_main/billing.html @@ -83,6 +83,7 @@ set_display_recurring(<% encode_json({'display_recurring' => [ $cust_main->displ <% mt('Prorate day of month') |h %> <% $cust_main->prorate_day %> + <% $cust_main->force_prorate_day && (''.emt('(applies to all packages)').'') %> % } -- cgit v1.2.1 From d4114381c5d95e8acd0d0fc2bbc2b3528bde2ecf Mon Sep 17 00:00:00 2001 From: Jonathan Prykop Date: Fri, 14 Oct 2016 20:49:38 -0500 Subject: 72901: OFM Freeside Note Classes --- FS/FS/Conf.pm | 6 +- FS/FS/Upgrade.pm | 8 ++ FS/FS/cust_main_note.pm | 8 ++ httemplate/edit/cust_main_note.cgi | 7 +- httemplate/elements/menu.html | 2 +- httemplate/view/cust_main/notes/notes.html | 196 +++++++++++++---------------- 6 files changed, 113 insertions(+), 114 deletions(-) diff --git a/FS/FS/Conf.pm b/FS/FS/Conf.pm index f4f7d2602..a48125d09 100644 --- a/FS/FS/Conf.pm +++ b/FS/FS/Conf.pm @@ -5419,11 +5419,7 @@ and customer address. Include units.', 'section' => 'customer_fields', 'description' => 'Use customer note classes', 'type' => 'select', - 'select_hash' => [ - 0 => 'Disabled', - 1 => 'Enabled', - 2 => 'Enabled, with tabs', - ], + 'select_enum' => [ '', 'Enabled', 'Required' ], }, { diff --git a/FS/FS/Upgrade.pm b/FS/FS/Upgrade.pm index c959ba947..1c1095e37 100644 --- a/FS/FS/Upgrade.pm +++ b/FS/FS/Upgrade.pm @@ -178,6 +178,14 @@ If you need to continue using the old Form 477 report, turn on the $conf->set('cust-fields',$cust_fields); } + #repurposed + $conf->set('note-classes','Enabled') + if $conf->exists('note-classes') + and grep {$_ eq $conf->config('note-classes')} ('1','2'); + $conf->set('note-classes','') + if $conf->exists('note-classes') + and '0' eq $conf->config('note-classes'); + enable_banned_pay_pad() unless length($conf->config('banned_pay-pad')); # if translate-auto-insert is enabled for a locale, ensure that invoice diff --git a/FS/FS/cust_main_note.pm b/FS/FS/cust_main_note.pm index ee63883d2..4c48eb609 100644 --- a/FS/FS/cust_main_note.pm +++ b/FS/FS/cust_main_note.pm @@ -4,6 +4,7 @@ use base qw( FS::otaker_Mixin FS::Record ); use strict; use Carp; use FS::Record qw( qsearchs ); #qw( qsearch qsearchs ); +use FS::Conf; =head1 NAME @@ -116,6 +117,13 @@ sub check { ; return $error if $error; + if (!$self->classnum) { + my $conf = new FS::Conf; + return 'Note class is required' + if $conf->exists('note-classes') + and $conf->config('note-classes') eq 'Required'; + } + $self->SUPER::check; } diff --git a/httemplate/edit/cust_main_note.cgi b/httemplate/edit/cust_main_note.cgi index c295e0d7a..cc93f2498 100755 --- a/httemplate/edit/cust_main_note.cgi +++ b/httemplate/edit/cust_main_note.cgi @@ -6,14 +6,17 @@ -% if ($conf->exists('note-classes') && $conf->config('note-classes') > 0) { +% if ($conf->exists('note-classes') && $conf->config('note-classes')) { +% my %includeopts = $conf->config('note-classes') eq 'Enabled' +% ? ('empty_label' => '(unclassified)') +% : ('disable_empty' => 1); # eq 'Required' Class   <% include( '/elements/select-table.html', 'table' => 'cust_note_class', 'name_col' => 'classname', 'curr_value' => $classnum, - 'empty_label' => '(none)', 'hashref' => { 'disabled' => '' }, + %includeopts, ) %>
    % } diff --git a/httemplate/elements/menu.html b/httemplate/elements/menu.html index d6ea06891..eb34e4946 100644 --- a/httemplate/elements/menu.html +++ b/httemplate/elements/menu.html @@ -685,7 +685,7 @@ tie my %config_cust, 'Tie::IxHash', ; $config_cust{'Note classes'} = [ $fsurl.'browse/cust_note_class.html', 'Note classes define groups of customer notes for reporting.' ] - if ($conf->exists('note-classes') && $conf->config('note-classes') > 0); + if ($conf->exists('note-classes') && $conf->config('note-classes')); tie my %config_agent, 'Tie::IxHash', 'Agent types' => [ $fsurl.'browse/agent_type.cgi', 'Agent types define groups of package definitions that you can then assign to particular agents' ], diff --git a/httemplate/view/cust_main/notes/notes.html b/httemplate/view/cust_main/notes/notes.html index eb421eb37..f36d7d878 100644 --- a/httemplate/view/cust_main/notes/notes.html +++ b/httemplate/view/cust_main/notes/notes.html @@ -1,55 +1,81 @@ % if ( scalar(@notes) ) { - <& /elements/init_overlib.html &> -% my $bgcolor1 = '#eeeeee'; -% my $bgcolor2 = '#ffffff'; -% my %sticky_color = ( '#eeeeee' => '#ffff66', -% '#ffffff' => '#ffffb8', -% ); -% -% my $bgcolor = ''; -% my $last_classnum = -1; -% my $skipheader = 0; -% my %classes = (); -% -% foreach my $note (@notes) { -% -% if ( $bgcolor eq $bgcolor1 ) { -% $bgcolor = $bgcolor2; -% } else { -% $bgcolor = $bgcolor1; +% if ( $note_classes_conf ) { +<% mt('Show notes of class:') |h %>   +% # list unclassified last +% foreach my $classnum ( (grep { $_ != 0} sort { $a <=> $b } (keys %classes)), '0' ) { + <% $classes{$classnum} %> +% } +
    +% } + +<& /elements/table-grid.html &> + + <% mt('Date') |h %> +% if ( $conf->exists('cust_main_note-display_times') ) { + <% mt('Time') |h %> +% } + <% mt('Employee') |h %> +% if ($note_classes_conf) { + <% mt('Class') |h %> % } + <% mt('Note') |h %> +% if ($curuser->access_right('Edit customer note') ) { +   +% } + + +% } # end if @notes + +% foreach my $note (@notes) { % % my $pop = popurl(3); % my $notenum = $note->notenum; @@ -74,79 +100,32 @@ % '('.emt('delete').')'; % } % -% if ( $last_classnum != $note->classnum && !$skipheader ) { -% my $tmp_classnum = $note->classnum ? $note->classnum : 0; -% $classes{$tmp_classnum} = $note->classname ne '' ? $note->classname -% : emt('Other'); -% if ( $last_classnum != -1 ) { - - -% } -% my $display = ($tmp_classnum == 0 || !$conf->exists('note-classes') -% || $conf->config('note-classes') < 2) -% ? 'block' : 'none'; -
    - <& /elements/table-grid.html &> - - - <% mt('Date') |h %> -% if ( $conf->exists('cust_main_note-display_times') ) { - <% mt('Time') |h %> -% } - <% mt('Employee') |h %> -% if ($conf->exists('note-classes') && $conf->config('note-classes') == 1) { - <% mt('Class') |h %> -% } - <% mt('Note') |h %> -% if ($curuser->access_right('Edit customer note') ) { -   -% } - - -% $skipheader = (!$conf->exists('note-classes') || $conf->config('note-classes') < 2); -% $last_classnum = $note->classnum; -% } - -% my $color = $note->sticky ? $sticky_color{$bgcolor} : $bgcolor; + > - - <% note_datestr($note,$conf,$color) %> - + <% note_datestr($note,$conf) %> +  <% $note->usernum ? $note->access_user->name : $note->otaker %> -% if ($conf->exists('note-classes') && $conf->config('note-classes') == 1) { - +% if ($note_classes_conf) { + <% $note->classname %> -% } - +% } + <% $note->comments | defang %> -% if($edit) { - <% $edit %> -% } +% if ($edit) { + <% $edit %> +% } - -% } #end display notes +% } #end foreach note -
    -% if ( $conf->exists('note-classes') && $conf->config('note-classes') == 2 ) { -% my($classnum,$classname); -<% mt('Show notes of class:') |h %>   -% foreach my $classnum ( sort { $b <=> $a } (keys %classes) ) { - <% $classes{$classnum} %> -% } -
    -% } + -% } <%init> use HTML::Defang; @@ -159,13 +138,18 @@ my(%opt) = @_; my $cust_main = $opt{'cust_main'}; my $custnum = $cust_main->custnum; -my (@notes) = $cust_main->notes($conf->exists('note-classes') && $conf->config('note-classes') == 2); +my $note_classes_conf = $conf->exists('note-classes') ? $conf->config('note-classes') : ''; + +my (@notes) = $cust_main->notes(); + +my %classes = map { ($_->classnum || 0) => ( $_->classname ne '' ? $_->classname : '('.emt('unclassified').')' ) } @notes; +$classes{'-1'} = 'All'; #subroutines sub note_datestr { - my($note, $conf, $bgcolor) = @_ or return ''; - my $td = qq{}; + my($note, $conf) = @_ or return ''; + my $td = qq{}; my $format = "$td%b %o, %Y"; $format .= "$td%l:%M%P" if $conf->exists('cust_main_note-display_times'); -- cgit v1.2.1 From 605a9aa2bef153ebe5376ba7500e5a6b567a8b63 Mon Sep 17 00:00:00 2001 From: Mark Wells Date: Sat, 15 Oct 2016 21:03:17 -0700 Subject: improve testing of prorate-sync behavior, #72928, #42108, and #34622 --- FS/t/suite/05-prorate_sync_same_day.t | 15 +++-- FS/t/suite/10-prorate_sync_same_hour.t | 102 ++++++++++++++++++++++++++++++++ FS/t/suite/11-prorate_sync_single_pkg.t | 89 ++++++++++++++++++++++++++++ 3 files changed, 201 insertions(+), 5 deletions(-) create mode 100755 FS/t/suite/10-prorate_sync_same_hour.t create mode 100755 FS/t/suite/11-prorate_sync_single_pkg.t diff --git a/FS/t/suite/05-prorate_sync_same_day.t b/FS/t/suite/05-prorate_sync_same_day.t index 91a8efa74..d08752ef1 100755 --- a/FS/t/suite/05-prorate_sync_same_day.t +++ b/FS/t/suite/05-prorate_sync_same_day.t @@ -5,10 +5,15 @@ Tests the effect of ordering and activating two sync_bill_date packages on the same day. Ref RT#42108. -Correct: If the packages have prorate_round_day = 1 (round nearest), or 3 -(round down) then the second package should be prorated one day short. If -they have prorate_round_day = 2 (round up), they should be billed -for the same amount. In both cases they should have the same next bill date. +Formerly correct: If the packages have prorate_round_day = 1 (round +nearest), or 3 (round down) then the second package should be prorated one +day short. If they have prorate_round_day = 2 (round up), they should be +billed for the same amount. In both cases they should have the same next +bill date. + +Revised RT#72928: The second package should be prorated one day short only +if the rounding mode is 1 (round nearest), as the nearest day is different +for the two packages. =cut @@ -81,7 +86,7 @@ foreach my $prorate_mode (1, 2, 3) { $error = $cust->bill_and_collect; # Check the amount billed. - if ( $prorate_mode == 1 or $prorate_mode == 3 ) { + if ( $prorate_mode == 1 ) { # it should be one day short, in March $recur = sprintf('%.2f', $recur * 30/31); } diff --git a/FS/t/suite/10-prorate_sync_same_hour.t b/FS/t/suite/10-prorate_sync_same_hour.t new file mode 100755 index 000000000..f1e31851a --- /dev/null +++ b/FS/t/suite/10-prorate_sync_same_hour.t @@ -0,0 +1,102 @@ +#!/usr/bin/perl + +=head2 DESCRIPTION + +Tests the effect of ordering and activating two sync_bill_date packages +either both before or both after noon, less than an hour apart. Ref RT#42108 +and #72928. + +Correct: The packages should always end up with the same next bill date, +and should be billed for a full period, except in the case where the first +package starts at midnight and the rounding mode is "always round down". + +=cut + +use strict; +use Test::More tests => 27; +use FS::Test; +use Date::Parse 'str2time'; +use Date::Format 'time2str'; +use Test::MockTime qw(set_fixed_time); +use FS::cust_main; +use FS::cust_pkg; +use FS::Conf; +my $FS= FS::Test->new; + +foreach my $prorate_mode (1, 2, 3) { + diag("prorate_round_day = $prorate_mode"); + # Create a package def with the sync_bill_date option. + my $error; + my $old_part_pkg = $FS->qsearchs('part_pkg', { pkgpart => 5 }); + my $part_pkg = $old_part_pkg->clone; + BAIL_OUT("existing pkgpart 5 is not a flat monthly package") + unless $part_pkg->freq eq '1' and $part_pkg->plan eq 'flat'; + $error = $part_pkg->insert( + options => { $old_part_pkg->options, + 'sync_bill_date' => 1, + 'prorate_round_day' => $prorate_mode, } + ); + + BAIL_OUT("can't configure package: $error") if $error; + + my $pkgpart = $part_pkg->pkgpart; + # Create a clean customer with no other packages. + foreach my $hour (0, 8, 16) { + diag("$hour:00"); + my $location = FS::cust_location->new({ + address1 => '123 Example Street', + city => 'Sacramento', + state => 'CA', + country => 'US', + zip => '94901', + }); + my $cust = FS::cust_main->new({ + agentnum => 1, + refnum => 1, + last => 'Customer', + first => 'Sync bill date', + invoice_email => 'newcustomer@fake.freeside.biz', + payby => 'BILL', + bill_location => $location, + ship_location => $location, + }); + $error = $cust->insert; + BAIL_OUT("can't create test customer: $error") if $error; + + my @pkgs; + # Create and bill the first package. + set_fixed_time(str2time("2016-03-10 $hour:00")); + $pkgs[0] = FS::cust_pkg->new({ pkgpart => $pkgpart }); + $error = $cust->order_pkg({ 'cust_pkg' => $pkgs[0] }); + BAIL_OUT("can't order package: $error") if $error; + $error = $cust->bill_and_collect; + # Check the amount billed. + my ($cust_bill_pkg) = $pkgs[0]->cust_bill_pkg; + my $recur = $part_pkg->base_recur; + ok( $cust_bill_pkg->recur == $recur, "first package recur is $recur" ) + or diag("first package recur is ".$cust_bill_pkg->recur); + + # Create and bill the second package. + set_fixed_time(str2time("2016-03-10 $hour:01")); + $pkgs[1] = FS::cust_pkg->new({ pkgpart => $pkgpart }); + $error = $cust->order_pkg({ 'cust_pkg' => $pkgs[1] }); + BAIL_OUT("can't order package: $error") if $error; + $error = $cust->bill_and_collect; + + # Check the amount billed. + if ( $prorate_mode == 3 and $hour == 0 ) { + # special case: a start date of midnight won't be rounded down but any + # later start date will, so the second package will be one day short. + $recur = sprintf('%.2f', $recur * 30/31); + } + ($cust_bill_pkg) = $pkgs[1]->cust_bill_pkg; + ok( $cust_bill_pkg->recur == $recur, "second package recur is $recur" ) + or diag("second package recur is ".$cust_bill_pkg->recur); + + my @next_bill = map { time2str('%Y-%m-%d', $_->replace_old->get('bill')) } @pkgs; + + ok( $next_bill[0] eq $next_bill[1], + "both packages will bill again on $next_bill[0]" ) + or diag("first package bill date is $next_bill[0], second package is $next_bill[1]"); + } +} diff --git a/FS/t/suite/11-prorate_sync_single_pkg.t b/FS/t/suite/11-prorate_sync_single_pkg.t new file mode 100755 index 000000000..83308f5f8 --- /dev/null +++ b/FS/t/suite/11-prorate_sync_single_pkg.t @@ -0,0 +1,89 @@ +#!/usr/bin/perl + +=head2 DESCRIPTION + +Tests the effect of ordering a sync_bill_date package either before or +after noon and billing it for two consecutive cycles, in all three prorate +rounding modes (round nearest, round up, and round down). Ref RT#34622. + +Correct: It should be charged full price in both cycles regardless of +the prorate rounding mode, as long as prorate rounding is enabled. + +=cut + +use strict; +use Test::More tests => 18; +use FS::Test; +use Date::Parse 'str2time'; +use Date::Format 'time2str'; +use Test::MockTime qw(set_fixed_time); +use FS::cust_main; +use FS::cust_pkg; +use FS::Conf; +my $FS= FS::Test->new; + +foreach my $prorate_mode (1, 2, 3) { + diag("prorate_round_day = $prorate_mode"); + # Create a package def with the sync_bill_date option. + my $error; + my $old_part_pkg = $FS->qsearchs('part_pkg', { pkgpart => 5 }); + my $part_pkg = $old_part_pkg->clone; + BAIL_OUT("existing pkgpart 5 is not a flat monthly package") + unless $part_pkg->freq eq '1' and $part_pkg->plan eq 'flat'; + $error = $part_pkg->insert( + options => { $old_part_pkg->options, + 'sync_bill_date' => 1, + 'prorate_round_day' => $prorate_mode, } + ); + + BAIL_OUT("can't configure package: $error") if $error; + + my $pkgpart = $part_pkg->pkgpart; + # Create a clean customer with no other packages. + foreach my $hour (0, 8, 16) { + diag("$hour:00"); + my $location = FS::cust_location->new({ + address1 => '123 Example Street', + city => 'Sacramento', + state => 'CA', + country => 'US', + zip => '94901', + }); + my $cust = FS::cust_main->new({ + agentnum => 1, + refnum => 1, + last => 'Customer', + first => 'Sync bill date', + invoice_email => 'newcustomer@fake.freeside.biz', + payby => 'BILL', + bill_location => $location, + ship_location => $location, + }); + $error = $cust->insert; + BAIL_OUT("can't create test customer: $error") if $error; + + my $pkg; + # Create and bill the package. + set_fixed_time(str2time("2016-03-10 $hour:00")); + $pkg = FS::cust_pkg->new({ pkgpart => $pkgpart }); + $error = $cust->order_pkg({ 'cust_pkg' => $pkg }); + BAIL_OUT("can't order package: $error") if $error; + $error = $cust->bill_and_collect; + BAIL_OUT("can't bill package: $error") if $error; + + # Bill it a second time. + $pkg = $pkg->replace_old; + set_fixed_time($pkg->bill); + $error = $cust->bill_and_collect; + BAIL_OUT("can't bill package: $error") if $error; + + # Check the amount billed. + my $recur = $part_pkg->base_recur; + my @cust_bill = $cust->cust_bill; + ok( $cust_bill[0]->charged == $recur, "first bill is $recur" ) + or diag("first bill is ".$cust_bill[0]->charged); + ok( $cust_bill[1]->charged == $recur, "second bill is $recur" ) + or diag("second bill is ".$cust_bill[1]->charged); + + } +} -- cgit v1.2.1 From f81c236b2f3b5fe8777b04ee78b793b301eef9fd Mon Sep 17 00:00:00 2001 From: Mark Wells Date: Sat, 15 Oct 2016 21:03:27 -0700 Subject: reconcile prorate-sync behavior with prorate rounding, #72928 --- FS/FS/part_pkg/flat.pm | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/FS/FS/part_pkg/flat.pm b/FS/FS/part_pkg/flat.pm index 504def0cf..6fd9c7d08 100644 --- a/FS/FS/part_pkg/flat.pm +++ b/FS/FS/part_pkg/flat.pm @@ -15,6 +15,7 @@ use Tie::IxHash; use List::Util qw( min ); use FS::UI::bytecount; use FS::Conf; +use Time::Local 'timelocal'; #ask FS::UID to run this stuff for us later FS::UID->install_callback( sub { @@ -182,13 +183,27 @@ sub cutoff_day { if ( $self->option('sync_bill_date',1) ) { my $next_bill = $cust_pkg->cust_main->next_bill_date; if ( $next_bill ) { - # careful here. if the prorate calculation is going to round to - # the nearest day, this needs to always return the same result - if ( $self->option('prorate_round_day', 1) ) { - my $hour = (localtime($next_bill))[2]; - $next_bill += 64800 if $hour >= 12; - } return (localtime($next_bill))[3]; + } else { + # This is the customer's only active package and hasn't been billed + # yet, so set the cutoff day to either today or tomorrow, whichever + # would result in a full period after rounding. + my $setup = $cust_pkg->setup; # because it's "now" + my $rounding_mode = $self->option('prorate_round_day',1); + return () if !$setup or !$rounding_mode; + my ($sec, $min, $hour, $mday, $mon, $year) = localtime($setup); + + if ( ( $rounding_mode == 1 and $hour >= 12 ) + or ( $rounding_mode == 3 and ( $sec > 0 or $min > 0 or $hour > 0 )) + ) { + # then the prorate period will be rounded down to start from + # midnight tomorrow, so the cutoff day should be the current day + + # 1. + $setup = timelocal(59,59,23,$mday,$mon,$year) + 1; + $mday = (localtime($setup))[3]; + } + # otherwise, it will be rounded up, so leave the cutoff day at today. + return $mday; } } return (); -- cgit v1.2.1