4 use base qw( Exporter );
5 use vars qw( $DEBUG @EXPORT_OK $conf );
8 use HTTP::Request::Common qw( GET POST );
19 FS::UID->install_callback( sub {
25 @EXPORT_OK = qw( get_district );
29 FS::Misc::Geo - routines to fetch geographic information
35 =item get_censustract_ffiec LOCATION YEAR
37 Given a location hash (see L<FS::location_Mixin>) and a census map year,
38 returns a census tract code (consisting of state, county, and tract
39 codes) or an error message.
41 Data source: Federal Financial Institutions Examination Council
43 Note: This is the old method for pre-2022 (census year 2020) reporting.
47 sub get_censustract_ffiec {
53 if ( length($location->{country}) and uc($location->{country}) ne 'US' ) {
57 warn Dumper($location, $year) if $DEBUG;
59 # the old FFIEC geocoding service was shut down December 1, 2014.
60 # welcome to the future.
61 my $url = 'https://geomap.ffiec.gov/FFIECGeocMap/GeocodeMap1.aspx/GetGeocodeData';
62 # build the single-line query
63 my $single_line = join(', ', $location->{address1},
67 my $hashref = { sSingleLine => $single_line, iCensusYear => $year };
68 my $request = POST( $url,
69 'Content-Type' => 'application/json; charset=utf-8',
70 'Accept' => 'application/json',
71 'Content' => encode_json($hashref)
74 my $ua = new LWP::UserAgent;
75 my $res = $ua->request( $request );
80 if (!$res->is_success) {
82 die "Census tract lookup error: ".$res->message;
87 my $content = eval { decode_json($res->content) };
88 die "Census tract JSON error: $@\n" if $@;
90 if ( !exists $content->{d}->{sStatus} ) {
91 die "Census tract response is missing a status indicator.\nThis is an FFIEC problem.\n";
93 if ( $content->{d}->{sStatus} eq 'Y' ) {
95 # this also contains the (partial) standardized address, correct zip
96 # code, coordinates, etc., and we could get all of them, but right now
97 # we only want the census tract
98 my $tract = join('', $content->{d}->{sStateCode},
99 $content->{d}->{sCountyCode},
100 $content->{d}->{sTractCode});
105 my $error = $content->{d}->{sMsg}
106 || 'FFIEC lookup failed, but with no status message.';
112 =item get_censustract_uscensus LOCATION YEAR
114 Given a location hash (see L<FS::location_Mixin>) and a census map year,
115 returns a census tract code (consisting of state, county, tract, and block
116 codes) or an error message.
118 Data source: US Census Bureau
120 This is the new method for 2022+ (census year 2020) reporting.
124 sub get_censustract_uscensus {
126 my $location = shift;
127 my $year = shift || 2020;
129 if ( length($location->{country}) and uc($location->{country}) ne 'US' ) {
133 warn Dumper($location, $year) if $DEBUG;
135 my $url = 'https://geocoding.geo.census.gov/geocoder/geographies/address?';
137 my $address1 = $location->{address1};
138 $address1 =~ s/(apt|ste|suite|unit)[\s\d]\w*\s*$//i;
142 city => $location->{city},
143 state => $location->{state},
144 benchmark => 'Public_AR_Current',
145 vintage => 'Census'.$year.'_Current',
149 my $full_url = URI->new($url);
150 $full_url->query_form($query_hash);
152 warn "Full Request URL: \n".$full_url if $DEBUG;
154 my $ua = new LWP::UserAgent;
155 my $res = $ua->get( $full_url );
157 warn $res->as_string if $DEBUG > 2;
159 if (!$res->is_success) {
160 die 'Census tract lookup error: '.$res->message;
164 my $content = eval { decode_json($res->content) };
165 die "Census tract JSON error: $@\n" if $@;
167 warn Dumper($content) if $DEBUG;
169 my $addressMatches_ref = $content->{result}->{addressMatches};
171 if ( $addressMatches_ref && scalar @{$addressMatches_ref} ) {
173 my $tract = $addressMatches_ref->[0]->{geographies}->{'Census Blocks'}[0]->{GEOID};
178 my $error = 'Lookup failed, but with no status message.';
180 if ( $content->{errors} ) {
181 $error = join("\n", $content->{errors});
190 #sub get_district_methods {
192 # 'wa_sales' => 'Washington sales tax',
195 =item get_district LOCATION METHOD
197 For the location hash in LOCATION, using lookup method METHOD, fetch
198 tax district information. Currently the only available method is
199 'wa_sales' (the Washington Department of Revenue sales tax lookup).
201 Returns a hash reference containing the following fields:
206 - exempt_amount (currently zero)
207 - city, county, state, country (from
209 The intent is that you can assign this to an L<FS::cust_main_county>
210 object and insert it if there's not yet a tax rate defined for that
213 get_district will die on error.
221 my $location = shift;
222 my $method = shift or return '';
223 warn Dumper($location, $method) if $DEBUG;
228 =head2 wa_sales location_hash
230 Expects output of location_hash() as parameter
232 Returns undef on error, or if tax rate cannot be found using given address
234 Query the WA State Dept of Revenue API with an address, and return
235 tax district information for that address.
237 Documentation for the API can be found here:
239 L<https://dor.wa.gov/find-taxes-rates/retail-sales-tax/destination-based-sales-tax-and-streamlined-sales-tax/wa-sales-tax-rate-lookup-url-interface>
241 This API does not return consistent usable county names, as the county
242 name may include appreviations or labels referring to PTBA (public transport
243 benefit area) or CEZ (community empowerment zone). It's recommended to use
244 the tool freeside-wa-tax-table-update to fully populate the
245 city/county/districts for WA state every financial quarter.
247 Returns a hashref with the following keys:
249 - district the wa state tax district id
250 - tax the combined total tax rate, as a percentage
251 - city the API rate name
252 - county The API address PTBA
257 If api returns no district for address, generates system log error
266 # freeside-queued will issue dbh->rollback on die() ... this will
267 # also roll back system log messages about errors :/ freeside-queued
268 # doesn't propgate die messages into the system log.
271 my $location_hash = shift;
273 # Return when called with pointless context
275 unless $location_hash
276 && ref $location_hash
277 && $location_hash->{state} eq 'WA'
278 && $location_hash->{address1}
279 && $location_hash->{zip}
280 && $location_hash->{city};
282 my $log = FS::Log->new('wa_sales');
284 warn "wa_sales() called with location_hash:\n".Dumper( $location_hash)."\n"
287 my $api_url = 'http://webgis.dor.wa.gov/webapi/AddressRates.aspx';
288 my @api_response_codes = (
289 'The address was found',
290 'The address was not found, but the ZIP+4 was located.',
291 'The address was updated and found, the user should validate the address record',
292 'The address was updated and Zip+4 located, the user should validate the address record',
293 'The address was corrected and found, the user should validate the address record',
294 'Neither the address or ZIP+4 was found, but the 5-digit ZIP was located.',
295 'The address, ZIP+4, and ZIP could not be found.',
296 'Invalid Latitude/Longitude',
302 addr => $location_hash->{address1},
303 city => $location_hash->{city},
304 zip => substr( $location_hash->{zip}, 0, 5 ),
306 my $get_string = join '&' => (
307 map{ sprintf "%s=%s", $_, uri_escape( $get_query{$_} ) }
311 my $prepared_url = "${api_url}?$get_string";
313 warn "API call to URL: $prepared_url\n"
318 eval { $dom = XML::LibXML->load_xml( location => $prepared_url ); };
321 sprintf "Problem parsing XML from API URL(%s): %s",
324 $log->error( $error );
329 my ($res_root) = $dom->findnodes('/response');
330 my ($res_addressline) = $dom->findnodes('/response/addressline');
331 my ($res_rate) = $dom->findnodes('/response/rate');
333 my $res_code = $res_root->getAttribute('code')
338 && ref $res_addressline
341 && $res_root->getAttribute('rate') > 0
345 "Problem querying WA DOR tax district - " .
350 $res_code ? $api_response_codes[$res_code] : 'n/a',
351 $location_hash->{address1},
354 $log->error( $error );
363 district => $res_root->getAttribute('loccode'),
364 tax => $res_root->getAttribute('rate') * 100,
365 county => uc $res_addressline->getAttribute('ptba'),
366 city => uc $res_rate->getAttribute('name')
369 $response{county} =~ s/ PTBA//i;
372 warn "XML document: $dom\n";
373 warn "API parsed response: ".Dumper( \%response )."\n";
378 "Tax district(%s) selected for address(%s %s %s %s)",
380 $location_hash->{address1},
381 $location_hash->{city},
382 $location_hash->{state},
383 $location_hash->{zip};
385 $log->info( $info_message );
386 warn "$info_message\n"
393 ###### USPS Standardization ######
395 sub standardize_usps {
398 eval "use Business::US::USPS::WebTools::AddressStandardization";
401 my $location = shift;
402 if ( $location->{country} ne 'US' ) {
404 warn "standardize_usps not for use in country ".$location->{country}."\n";
405 $location->{addr_clean} = '';
408 my $userid = $conf->config('usps_webtools-userid');
409 my $password = $conf->config('usps_webtools-password');
410 my $verifier = Business::US::USPS::WebTools::AddressStandardization->new( {
412 Password => $password,
414 } ) or die "error starting USPS WebTools\n";
416 my($zip5, $zip4) = split('-',$location->{'zip'});
419 FirmName => $location->{company},
420 Address2 => $location->{address1},
421 Address1 => $location->{address2},
422 City => $location->{city},
423 State => $location->{state},
427 warn join('', map "$_: $usps_args{$_}\n", keys %usps_args )
430 my $hash = $verifier->verify_address( %usps_args );
432 warn $verifier->response
435 die "USPS WebTools error: ".$verifier->{error}{description} ."\n"
436 if $verifier->is_error;
438 my $zip = $hash->{Zip5};
439 $zip .= '-' . $hash->{Zip4} if $hash->{Zip4} =~ /\d/;
441 { company => $hash->{FirmName},
442 address1 => $hash->{Address2},
443 address2 => $hash->{Address1},
444 city => $hash->{City},
445 state => $hash->{State},
451 ###### U.S. Census Bureau ######
453 sub standardize_uscensus {
455 my $location = shift;
456 my $log = FS::Log->new('FS::Misc::Geo::standardize_uscensus');
457 $log->debug(join("\n", @{$location}{'address1', 'city', 'state', 'zip'}));
459 eval "use Geo::USCensus::Geocoding";
462 if ( $location->{country} ne 'US' ) {
464 warn "standardize_uscensus not for use in country ".$location->{country}."\n";
465 $location->{addr_clean} = '';
470 street => $location->{address1},
471 city => $location->{city},
472 state => $location->{state},
473 zip => $location->{zip},
474 debug => ($DEBUG || 0),
477 my $result = Geo::USCensus::Geocoding->query($request);
478 if ( $result->is_match ) {
479 # unfortunately we get the address back as a single line
480 $log->debug($result->address);
481 if ($result->address =~ /^(.*), (.*), ([A-Z]{2}), (\d{5}.*)$/) {
487 address2 => uc($location->{address2}),
488 latitude => $result->latitude,
489 longitude => $result->longitude,
490 censustract => $result->censustract,
493 die "Geocoding returned '".$result->address."', which does not seem to be a valid address.\n";
495 } elsif ( $result->match_level eq 'Tie' ) {
496 die "Geocoding was not able to identify a unique matching address.\n";
497 } elsif ( $result->match_level ) {
498 die "Geocoding did not find a matching address.\n";
500 $log->error($result->error_message);
501 return; # for internal errors, don't return anything
505 ####### EZLOCATE (obsolete) #######
507 sub _tomtom_query { # helper method for the below
509 my $result = Geo::TomTom::Geocoding->query(%args);
510 die "TomTom geocoding error: ".$result->message."\n"
511 unless ( $result->is_success );
512 my ($match) = $result->locations;
513 my $type = $match->{type};
514 # match levels below "intersection" should not be considered clean
515 my $clean = ($type eq 'addresspoint' ||
518 $type eq 'intersection'
520 warn "tomtom returned $type match\n" if $DEBUG;
521 warn Dumper($match) if $DEBUG > 1;
525 sub standardize_tomtom {
526 # post-2013 TomTom API
527 # much better, but incompatible with ezlocate
529 my $location = shift;
530 eval "use Geo::TomTom::Geocoding; use Geo::StreetAddress::US";
533 my $key = $conf->config('tomtom-userid')
534 or die "no tomtom-userid configured\n";
536 my $country = code2country($location->{country});
537 my ($address1, $address2) = ($location->{address1}, $location->{address2});
541 $address1 =~ s/^\s+//;
542 $address1 =~ s/\s+$//;
543 $address2 =~ s/^\s+//;
544 $address2 =~ s/\s+$//;
546 # try to fix some cases of the address fields being switched
547 if ( $address2 =~ /^\d/ and $address1 !~ /^\d/ ) {
548 $address2 = $address1;
549 $address1 = $location->{address2};
551 # parse sublocation part (unit/suite/apartment...) and clean up
552 # non-sublocation address2
553 ($subloc, $address2) =
554 subloc_address2($address1, $address2, $location->{country});
555 # ask TomTom to standardize address1:
559 L => $location->{city},
560 AA => $location->{state},
561 PC => $location->{zip},
562 CC => country2code($country, LOCALE_CODE_ALPHA_3),
565 my ($match, $clean) = _tomtom_query(%args);
567 if (!$match or !$clean) {
568 # Then try cleaning up the input; TomTom is picky about junk in the
569 # address. Any of these can still be a clean match.
570 my $h = Geo::StreetAddress::US->parse_location($address1);
571 # First conservatively:
572 if ( $h->{sec_unit_type} ) {
573 my $strip = '\s+' . $h->{sec_unit_type};
574 $strip .= '\s*' . $h->{sec_unit_num} if $h->{sec_unit_num};
576 $args{T} =~ s/$strip//;
577 ($match, $clean) = _tomtom_query(%args);
579 if ( !$match or !$clean ) {
580 # Then more aggressively:
581 $args{T} = uc( join(' ', @$h{'number', 'street', 'type'}) );
582 ($match, $clean) = _tomtom_query(%args);
586 if ( !$match or !$clean ) { # partial matches are not useful
587 die "Address not found\n";
590 if ( defined $match->{censusTract} ) {
591 $tract = $match->{censusStateCode}. $match->{censusFipsCountyCode}.
592 join('.', $match->{censusTract} =~ /(....)(..)/);
595 $address1 = $match->{houseNumber} . ' ' if length($match->{houseNumber});
596 $address1 .= $match->{street} if $match->{street};
597 $address1 .= ' '.$subloc if $subloc;
598 $address1 = uc($address1); # USPS standards
601 address1 => $address1,
602 address2 => $address2,
603 city => uc($match->{city}),
604 state => uc($location->{state}),
605 country => uc($location->{country}),
606 zip => ($match->{standardPostalCode} || $match->{postcode}),
607 latitude => $match->{latitude},
608 longitude => $match->{longitude},
609 censustract => $tract,
610 addr_clean => $clean,
614 =iten subloc_address2 ADDRESS1, ADDRESS2, COUNTRY
616 Given 'address1' and 'address2' strings, extract the sublocation part
617 (from either one) and return it. If the sublocation was found in ADDRESS1,
618 also return ADDRESS2 (cleaned up for postal standards) as it's assumed to
619 contain something relevant.
624 # Postal Addressing Standards, Appendix C
625 # (plus correction of "hanger" to "hangar")
653 # Canada Post Addressing Guidelines 4.3
664 sub subloc_address2 {
665 # Some things seen in the address2 field:
667 # The complete address (with address1 containing part of the company name,
668 # or an ATTN or DBA line, or P.O. Box, or department name, or building/suite
671 # try to parse sublocation parts from address1; if they are present we'll
672 # append them back to address1 after standardizing
674 my ($addr1, $addr2, $country) = map uc, @_;
675 my $dict = $subloc_forms{$country} or return('', $addr2);
677 my $found_in = 0; # which address is the sublocation
680 # patterns to try to parse
682 "$addr1 Nullcity, CA"
684 $h = Geo::StreetAddress::US->parse_location($addr1);
685 last if exists($h->{sec_unit_type});
687 if (exists($h->{sec_unit_type})) {
694 "$addr1, $addr2 Nullcity, CA"
696 $h = Geo::StreetAddress::US->parse_location("$addr1, $addr2");
697 last if exists($h->{sec_unit_type});
699 if (exists($h->{sec_unit_type})) {
704 $subloc = $h->{sec_unit_type};
705 # special case: do not combine P.O. box sublocs with address1
706 if ( $h->{sec_unit_type} =~ /^P *O *BOX/i ) {
707 if ( $found_in == 2 ) {
708 $addr2 = "PO BOX ".$h->{sec_unit_num};
709 } # else it's in addr1, and leave it alone
711 } elsif ( exists($dict->{$subloc}) ) {
712 # substitute the official abbreviation
713 $subloc = $dict->{$subloc};
715 $subloc .= ' ' . $h->{sec_unit_num} if length($h->{sec_unit_num});
716 } # otherwise $subloc = ''
718 if ( $found_in == 2 ) {
719 # address2 should be fully combined into address1
720 return ($subloc, '');
722 # else address2 is not the canonical sublocation, but do our best to
726 $addr2 =~ s/#\s*(\d)/NUMBER$1/; # /g?
728 # remove all punctuation and spaces
729 foreach my $w (split(/\W+/, $addr2)) {
730 if ( exists($dict->{$w}) ) {
731 push @words, $dict->{$w};
735 my $result = join(' ', @words);
736 # correct spacing of pound sign + number
737 $result =~ s/NUMBER(\d)/# $1/;
738 warn "normalizing '$addr2' to '$result'\n" if $DEBUG > 1;
741 $addr2 = '' if $addr2 eq $subloc; # if it was entered redundantly
745 #is anyone still using this?
746 sub standardize_melissa {
748 my $location = shift;
751 eval "use Geo::Melissa::WebSmart";
754 my $id = $conf->config('melissa-userid')
755 or die "no melissa-userid configured\n";
756 my $geocode = $conf->exists('melissa-enable_geocoding') ? 1 : 0;
760 a1 => $location->{address1},
761 a2 => $location->{address2},
762 city => $location->{city},
763 state => $location->{state},
764 ctry => $location->{country},
765 zip => $location->{zip},
768 my $result = Geo::Melissa::WebSmart->query($request);
769 if ( $result->code =~ /AS01/ ) { # always present on success
770 my $addr = $result->address;
771 warn Dumper $addr if $DEBUG > 1;
773 address1 => $addr->{Address1},
774 address2 => $addr->{Address2},
775 city => $addr->{City}->{Name},
776 state => $addr->{State}->{Abbreviation},
777 country => $addr->{Country}->{Abbreviation},
779 latitude => $addr->{Latitude},
780 longitude => $addr->{Longitude},
783 if ( $addr->{Census}->{Tract} ) {
784 my $censustract = $addr->{County}->{Fips} . $addr->{Census}->{Tract};
785 # insert decimal point two digits from the end
786 $censustract =~ s/(\d\d)$/\.$1/;
787 $out->{censustract} = $censustract;
788 $out->{censusyear} = $conf->config('census_year');
790 # we could do a lot more nuanced reporting of the warning/status codes,
791 # but the UI doesn't support that yet.
794 die $result->status_message;
798 sub standardize_freeside {
800 my $location = shift;
802 my $url = 'https://ws.freeside.biz/normalize';
804 #free freeside.biz normalization only for US
805 if ( $location->{country} ne 'US' ) {
807 #why? something else could have cleaned it $location->{addr_clean} = '';
811 my $ua = LWP::UserAgent->new(
813 verify_hostname => 0,
814 SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
817 my $response = $ua->request( POST $url, [
818 'support-key' => scalar($conf->config('support-key')),
822 die "Address normalization error: ". $response->message
823 unless $response->is_success;
826 my $content = eval { decode_json($response->content) };
828 warn $response->content;
829 die "Address normalization JSON error : $@\n";
832 die $content->{error}."\n"
833 if $content->{error};
835 { 'addr_clean' => 'Y',
836 map { $_ => $content->{$_} }
837 qw( address1 address2 city state zip country )