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 if ( $content->{result}->{addressMatches} ) {
171 my $tract = $content->{result}->{addressMatches}[0]->{geographies}->{'Census Blocks'}[0]->{GEOID};
176 my $error = 'Lookup failed, but with no status message.';
178 if ( $content->{errors} ) {
179 $error = join("\n", $content->{errors});
188 #sub get_district_methods {
190 # 'wa_sales' => 'Washington sales tax',
193 =item get_district LOCATION METHOD
195 For the location hash in LOCATION, using lookup method METHOD, fetch
196 tax district information. Currently the only available method is
197 'wa_sales' (the Washington Department of Revenue sales tax lookup).
199 Returns a hash reference containing the following fields:
204 - exempt_amount (currently zero)
205 - city, county, state, country (from
207 The intent is that you can assign this to an L<FS::cust_main_county>
208 object and insert it if there's not yet a tax rate defined for that
211 get_district will die on error.
219 my $location = shift;
220 my $method = shift or return '';
221 warn Dumper($location, $method) if $DEBUG;
226 =head2 wa_sales location_hash
228 Expects output of location_hash() as parameter
230 Returns undef on error, or if tax rate cannot be found using given address
232 Query the WA State Dept of Revenue API with an address, and return
233 tax district information for that address.
235 Documentation for the API can be found here:
237 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>
239 This API does not return consistent usable county names, as the county
240 name may include appreviations or labels referring to PTBA (public transport
241 benefit area) or CEZ (community empowerment zone). It's recommended to use
242 the tool freeside-wa-tax-table-update to fully populate the
243 city/county/districts for WA state every financial quarter.
245 Returns a hashref with the following keys:
247 - district the wa state tax district id
248 - tax the combined total tax rate, as a percentage
249 - city the API rate name
250 - county The API address PTBA
255 If api returns no district for address, generates system log error
264 # freeside-queued will issue dbh->rollback on die() ... this will
265 # also roll back system log messages about errors :/ freeside-queued
266 # doesn't propgate die messages into the system log.
269 my $location_hash = shift;
271 # Return when called with pointless context
273 unless $location_hash
274 && ref $location_hash
275 && $location_hash->{state} eq 'WA'
276 && $location_hash->{address1}
277 && $location_hash->{zip}
278 && $location_hash->{city};
280 my $log = FS::Log->new('wa_sales');
282 warn "wa_sales() called with location_hash:\n".Dumper( $location_hash)."\n"
285 my $api_url = 'http://webgis.dor.wa.gov/webapi/AddressRates.aspx';
286 my @api_response_codes = (
287 'The address was found',
288 'The address was not found, but the ZIP+4 was located.',
289 'The address was updated and found, the user should validate the address record',
290 'The address was updated and Zip+4 located, the user should validate the address record',
291 'The address was corrected and found, the user should validate the address record',
292 'Neither the address or ZIP+4 was found, but the 5-digit ZIP was located.',
293 'The address, ZIP+4, and ZIP could not be found.',
294 'Invalid Latitude/Longitude',
300 addr => $location_hash->{address1},
301 city => $location_hash->{city},
302 zip => substr( $location_hash->{zip}, 0, 5 ),
304 my $get_string = join '&' => (
305 map{ sprintf "%s=%s", $_, uri_escape( $get_query{$_} ) }
309 my $prepared_url = "${api_url}?$get_string";
311 warn "API call to URL: $prepared_url\n"
316 eval { $dom = XML::LibXML->load_xml( location => $prepared_url ); };
319 sprintf "Problem parsing XML from API URL(%s): %s",
322 $log->error( $error );
327 my ($res_root) = $dom->findnodes('/response');
328 my ($res_addressline) = $dom->findnodes('/response/addressline');
329 my ($res_rate) = $dom->findnodes('/response/rate');
331 my $res_code = $res_root->getAttribute('code')
336 && ref $res_addressline
339 && $res_root->getAttribute('rate') > 0
343 "Problem querying WA DOR tax district - " .
348 $res_code ? $api_response_codes[$res_code] : 'n/a',
349 $location_hash->{address1},
352 $log->error( $error );
361 district => $res_root->getAttribute('loccode'),
362 tax => $res_root->getAttribute('rate') * 100,
363 county => uc $res_addressline->getAttribute('ptba'),
364 city => uc $res_rate->getAttribute('name')
367 $response{county} =~ s/ PTBA//i;
370 warn "XML document: $dom\n";
371 warn "API parsed response: ".Dumper( \%response )."\n";
376 "Tax district(%s) selected for address(%s %s %s %s)",
378 $location_hash->{address1},
379 $location_hash->{city},
380 $location_hash->{state},
381 $location_hash->{zip};
383 $log->info( $info_message );
384 warn "$info_message\n"
391 ###### USPS Standardization ######
393 sub standardize_usps {
396 eval "use Business::US::USPS::WebTools::AddressStandardization";
399 my $location = shift;
400 if ( $location->{country} ne 'US' ) {
402 warn "standardize_usps not for use in country ".$location->{country}."\n";
403 $location->{addr_clean} = '';
406 my $userid = $conf->config('usps_webtools-userid');
407 my $password = $conf->config('usps_webtools-password');
408 my $verifier = Business::US::USPS::WebTools::AddressStandardization->new( {
410 Password => $password,
412 } ) or die "error starting USPS WebTools\n";
414 my($zip5, $zip4) = split('-',$location->{'zip'});
417 FirmName => $location->{company},
418 Address2 => $location->{address1},
419 Address1 => $location->{address2},
420 City => $location->{city},
421 State => $location->{state},
425 warn join('', map "$_: $usps_args{$_}\n", keys %usps_args )
428 my $hash = $verifier->verify_address( %usps_args );
430 warn $verifier->response
433 die "USPS WebTools error: ".$verifier->{error}{description} ."\n"
434 if $verifier->is_error;
436 my $zip = $hash->{Zip5};
437 $zip .= '-' . $hash->{Zip4} if $hash->{Zip4} =~ /\d/;
439 { company => $hash->{FirmName},
440 address1 => $hash->{Address2},
441 address2 => $hash->{Address1},
442 city => $hash->{City},
443 state => $hash->{State},
449 ###### U.S. Census Bureau ######
451 sub standardize_uscensus {
453 my $location = shift;
454 my $log = FS::Log->new('FS::Misc::Geo::standardize_uscensus');
455 $log->debug(join("\n", @{$location}{'address1', 'city', 'state', 'zip'}));
457 eval "use Geo::USCensus::Geocoding";
460 if ( $location->{country} ne 'US' ) {
462 warn "standardize_uscensus not for use in country ".$location->{country}."\n";
463 $location->{addr_clean} = '';
468 street => $location->{address1},
469 city => $location->{city},
470 state => $location->{state},
471 zip => $location->{zip},
472 debug => ($DEBUG || 0),
475 my $result = Geo::USCensus::Geocoding->query($request);
476 if ( $result->is_match ) {
477 # unfortunately we get the address back as a single line
478 $log->debug($result->address);
479 if ($result->address =~ /^(.*), (.*), ([A-Z]{2}), (\d{5}.*)$/) {
485 address2 => uc($location->{address2}),
486 latitude => $result->latitude,
487 longitude => $result->longitude,
488 censustract => $result->censustract,
491 die "Geocoding returned '".$result->address."', which does not seem to be a valid address.\n";
493 } elsif ( $result->match_level eq 'Tie' ) {
494 die "Geocoding was not able to identify a unique matching address.\n";
495 } elsif ( $result->match_level ) {
496 die "Geocoding did not find a matching address.\n";
498 $log->error($result->error_message);
499 return; # for internal errors, don't return anything
503 ####### EZLOCATE (obsolete) #######
505 sub _tomtom_query { # helper method for the below
507 my $result = Geo::TomTom::Geocoding->query(%args);
508 die "TomTom geocoding error: ".$result->message."\n"
509 unless ( $result->is_success );
510 my ($match) = $result->locations;
511 my $type = $match->{type};
512 # match levels below "intersection" should not be considered clean
513 my $clean = ($type eq 'addresspoint' ||
516 $type eq 'intersection'
518 warn "tomtom returned $type match\n" if $DEBUG;
519 warn Dumper($match) if $DEBUG > 1;
523 sub standardize_tomtom {
524 # post-2013 TomTom API
525 # much better, but incompatible with ezlocate
527 my $location = shift;
528 eval "use Geo::TomTom::Geocoding; use Geo::StreetAddress::US";
531 my $key = $conf->config('tomtom-userid')
532 or die "no tomtom-userid configured\n";
534 my $country = code2country($location->{country});
535 my ($address1, $address2) = ($location->{address1}, $location->{address2});
539 $address1 =~ s/^\s+//;
540 $address1 =~ s/\s+$//;
541 $address2 =~ s/^\s+//;
542 $address2 =~ s/\s+$//;
544 # try to fix some cases of the address fields being switched
545 if ( $address2 =~ /^\d/ and $address1 !~ /^\d/ ) {
546 $address2 = $address1;
547 $address1 = $location->{address2};
549 # parse sublocation part (unit/suite/apartment...) and clean up
550 # non-sublocation address2
551 ($subloc, $address2) =
552 subloc_address2($address1, $address2, $location->{country});
553 # ask TomTom to standardize address1:
557 L => $location->{city},
558 AA => $location->{state},
559 PC => $location->{zip},
560 CC => country2code($country, LOCALE_CODE_ALPHA_3),
563 my ($match, $clean) = _tomtom_query(%args);
565 if (!$match or !$clean) {
566 # Then try cleaning up the input; TomTom is picky about junk in the
567 # address. Any of these can still be a clean match.
568 my $h = Geo::StreetAddress::US->parse_location($address1);
569 # First conservatively:
570 if ( $h->{sec_unit_type} ) {
571 my $strip = '\s+' . $h->{sec_unit_type};
572 $strip .= '\s*' . $h->{sec_unit_num} if $h->{sec_unit_num};
574 $args{T} =~ s/$strip//;
575 ($match, $clean) = _tomtom_query(%args);
577 if ( !$match or !$clean ) {
578 # Then more aggressively:
579 $args{T} = uc( join(' ', @$h{'number', 'street', 'type'}) );
580 ($match, $clean) = _tomtom_query(%args);
584 if ( !$match or !$clean ) { # partial matches are not useful
585 die "Address not found\n";
588 if ( defined $match->{censusTract} ) {
589 $tract = $match->{censusStateCode}. $match->{censusFipsCountyCode}.
590 join('.', $match->{censusTract} =~ /(....)(..)/);
593 $address1 = $match->{houseNumber} . ' ' if length($match->{houseNumber});
594 $address1 .= $match->{street} if $match->{street};
595 $address1 .= ' '.$subloc if $subloc;
596 $address1 = uc($address1); # USPS standards
599 address1 => $address1,
600 address2 => $address2,
601 city => uc($match->{city}),
602 state => uc($location->{state}),
603 country => uc($location->{country}),
604 zip => ($match->{standardPostalCode} || $match->{postcode}),
605 latitude => $match->{latitude},
606 longitude => $match->{longitude},
607 censustract => $tract,
608 addr_clean => $clean,
612 =iten subloc_address2 ADDRESS1, ADDRESS2, COUNTRY
614 Given 'address1' and 'address2' strings, extract the sublocation part
615 (from either one) and return it. If the sublocation was found in ADDRESS1,
616 also return ADDRESS2 (cleaned up for postal standards) as it's assumed to
617 contain something relevant.
622 # Postal Addressing Standards, Appendix C
623 # (plus correction of "hanger" to "hangar")
651 # Canada Post Addressing Guidelines 4.3
662 sub subloc_address2 {
663 # Some things seen in the address2 field:
665 # The complete address (with address1 containing part of the company name,
666 # or an ATTN or DBA line, or P.O. Box, or department name, or building/suite
669 # try to parse sublocation parts from address1; if they are present we'll
670 # append them back to address1 after standardizing
672 my ($addr1, $addr2, $country) = map uc, @_;
673 my $dict = $subloc_forms{$country} or return('', $addr2);
675 my $found_in = 0; # which address is the sublocation
678 # patterns to try to parse
680 "$addr1 Nullcity, CA"
682 $h = Geo::StreetAddress::US->parse_location($addr1);
683 last if exists($h->{sec_unit_type});
685 if (exists($h->{sec_unit_type})) {
692 "$addr1, $addr2 Nullcity, CA"
694 $h = Geo::StreetAddress::US->parse_location("$addr1, $addr2");
695 last if exists($h->{sec_unit_type});
697 if (exists($h->{sec_unit_type})) {
702 $subloc = $h->{sec_unit_type};
703 # special case: do not combine P.O. box sublocs with address1
704 if ( $h->{sec_unit_type} =~ /^P *O *BOX/i ) {
705 if ( $found_in == 2 ) {
706 $addr2 = "PO BOX ".$h->{sec_unit_num};
707 } # else it's in addr1, and leave it alone
709 } elsif ( exists($dict->{$subloc}) ) {
710 # substitute the official abbreviation
711 $subloc = $dict->{$subloc};
713 $subloc .= ' ' . $h->{sec_unit_num} if length($h->{sec_unit_num});
714 } # otherwise $subloc = ''
716 if ( $found_in == 2 ) {
717 # address2 should be fully combined into address1
718 return ($subloc, '');
720 # else address2 is not the canonical sublocation, but do our best to
724 $addr2 =~ s/#\s*(\d)/NUMBER$1/; # /g?
726 # remove all punctuation and spaces
727 foreach my $w (split(/\W+/, $addr2)) {
728 if ( exists($dict->{$w}) ) {
729 push @words, $dict->{$w};
733 my $result = join(' ', @words);
734 # correct spacing of pound sign + number
735 $result =~ s/NUMBER(\d)/# $1/;
736 warn "normalizing '$addr2' to '$result'\n" if $DEBUG > 1;
739 $addr2 = '' if $addr2 eq $subloc; # if it was entered redundantly
743 #is anyone still using this?
744 sub standardize_melissa {
746 my $location = shift;
749 eval "use Geo::Melissa::WebSmart";
752 my $id = $conf->config('melissa-userid')
753 or die "no melissa-userid configured\n";
754 my $geocode = $conf->exists('melissa-enable_geocoding') ? 1 : 0;
758 a1 => $location->{address1},
759 a2 => $location->{address2},
760 city => $location->{city},
761 state => $location->{state},
762 ctry => $location->{country},
763 zip => $location->{zip},
766 my $result = Geo::Melissa::WebSmart->query($request);
767 if ( $result->code =~ /AS01/ ) { # always present on success
768 my $addr = $result->address;
769 warn Dumper $addr if $DEBUG > 1;
771 address1 => $addr->{Address1},
772 address2 => $addr->{Address2},
773 city => $addr->{City}->{Name},
774 state => $addr->{State}->{Abbreviation},
775 country => $addr->{Country}->{Abbreviation},
777 latitude => $addr->{Latitude},
778 longitude => $addr->{Longitude},
781 if ( $addr->{Census}->{Tract} ) {
782 my $censustract = $addr->{County}->{Fips} . $addr->{Census}->{Tract};
783 # insert decimal point two digits from the end
784 $censustract =~ s/(\d\d)$/\.$1/;
785 $out->{censustract} = $censustract;
786 $out->{censusyear} = $conf->config('census_year');
788 # we could do a lot more nuanced reporting of the warning/status codes,
789 # but the UI doesn't support that yet.
792 die $result->status_message;
796 sub standardize_freeside {
798 my $location = shift;
800 my $url = 'https://ws.freeside.biz/normalize';
802 #free freeside.biz normalization only for US
803 if ( $location->{country} ne 'US' ) {
805 #why? something else could have cleaned it $location->{addr_clean} = '';
809 my $ua = LWP::UserAgent->new(
811 verify_hostname => 0,
812 SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
815 my $response = $ua->request( POST $url, [
816 'support-key' => scalar($conf->config('support-key')),
820 die "Address normalization error: ". $response->message
821 unless $response->is_success;
824 my $content = eval { decode_json($response->content) };
826 warn $response->content;
827 die "Address normalization JSON error : $@\n";
830 die $content->{error}."\n"
831 if $content->{error};
833 { 'addr_clean' => 'Y',
834 map { $_ => $content->{$_} }
835 qw( address1 address2 city state zip country )