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.
43 sub get_censustract_ffiec {
49 if ( length($location->{country}) and uc($location->{country}) ne 'US' ) {
53 warn Dumper($location, $year) if $DEBUG;
55 # the old FFIEC geocoding service was shut down December 1, 2014.
56 # welcome to the future.
57 my $url = 'https://geomap.ffiec.gov/FFIECGeocMap/GeocodeMap1.aspx/GetGeocodeData';
58 # build the single-line query
59 my $single_line = join(', ', $location->{address1},
63 my $hashref = { sSingleLine => $single_line, iCensusYear => $year };
64 my $request = POST( $url,
65 'Content-Type' => 'application/json; charset=utf-8',
66 'Accept' => 'application/json',
67 'Content' => encode_json($hashref)
70 my $ua = new LWP::UserAgent;
71 my $res = $ua->request( $request );
76 if (!$res->is_success) {
78 die "Census tract lookup error: ".$res->message;
83 my $content = eval { decode_json($res->content) };
84 die "Census tract JSON error: $@\n" if $@;
86 if ( !exists $content->{d}->{sStatus} ) {
87 die "Census tract response is missing a status indicator.\nThis is an FFIEC problem.\n";
89 if ( $content->{d}->{sStatus} eq 'Y' ) {
91 # this also contains the (partial) standardized address, correct zip
92 # code, coordinates, etc., and we could get all of them, but right now
93 # we only want the census tract
94 my $tract = join('', $content->{d}->{sStateCode},
95 $content->{d}->{sCountyCode},
96 $content->{d}->{sTractCode});
101 my $error = $content->{d}->{sMsg}
102 || 'FFIEC lookup failed, but with no status message.';
108 #sub get_district_methods {
110 # 'wa_sales' => 'Washington sales tax',
113 =item get_district LOCATION METHOD
115 For the location hash in LOCATION, using lookup method METHOD, fetch
116 tax district information. Currently the only available method is
117 'wa_sales' (the Washington Department of Revenue sales tax lookup).
119 Returns a hash reference containing the following fields:
124 - exempt_amount (currently zero)
125 - city, county, state, country (from
127 The intent is that you can assign this to an L<FS::cust_main_county>
128 object and insert it if there's not yet a tax rate defined for that
131 get_district will die on error.
139 my $location = shift;
140 my $method = shift or return '';
141 warn Dumper($location, $method) if $DEBUG;
146 =head2 wa_sales location_hash
148 Expects output of location_hash() as parameter
150 Dies on error, or if tax rate cannot be found using given address
152 Query the WA State Dept of Revenue API with an address, and return
153 tax district information for that address.
155 Documentation for the API can be found here:
157 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>
159 This API does not return consistent usable county names, as the county
160 name may include appreviations or labels referring to PTBA (public transport
161 benefit area) or CEZ (community empowerment zone). It's recommended to use
162 the tool wa_tax_rate_update to fully populate the city/county/districts for
163 WA state every financial quarter.
165 Returns a hashref with the following keys:
167 - district the wa state tax district id
168 - tax the combined total tax rate, as a percentage
169 - city the API rate name
170 - county The API address PTBA
178 my $location_hash = shift;
180 # Return without die() when called with pointless context
182 unless $location_hash
183 && ref $location_hash
184 && $location_hash->{state} eq 'WA'
185 && $location_hash->{address1}
186 && $location_hash->{zip}
187 && $location_hash->{city};
189 my $log = FS::Log->new('wa_sales');
191 warn "wa_sales() called with location_hash:\n".Dumper( $location_hash)."\n"
194 my $api_url = 'http://webgis.dor.wa.gov/webapi/AddressRates.aspx';
195 my @api_response_codes = (
196 'The address was found',
197 'The address was not found, but the ZIP+4 was located.',
198 'The address was updated and found, the user should validate the address record',
199 'The address was updated and Zip+4 located, the user should validate the address record',
200 'The address was corrected and found, the user should validate the address record',
201 'Neither the address or ZIP+4 was found, but the 5-digit ZIP was located.',
202 'The address, ZIP+4, and ZIP could not be found.',
203 'Invalid Latitude/Longitude',
209 addr => $location_hash->{address1},
210 city => $location_hash->{city},
211 zip => substr( $location_hash->{zip}, 0, 5 ),
213 my $get_string = join '&' => (
214 map{ sprintf "%s=%s", $_, uri_escape( $get_query{$_} ) }
218 my $prepared_url = "${api_url}?$get_string";
220 warn "API call to URL: $prepared_url\n"
225 eval { $dom = XML::LibXML->load_xml( location => $prepared_url ); };
228 sprintf "Problem parsing XML from API URL(%s): %s",
230 $log->error( $error );
234 my ($res_root) = $dom->findnodes('/response');
235 my ($res_addressline) = $dom->findnodes('/response/addressline');
236 my ($res_rate) = $dom->findnodes('/response/rate');
238 my $res_code = $res_root->getAttribute('code')
243 && ref $res_addressline
246 && $res_root->getAttribute('rate') > 0
250 "Problem querying WA DOR tax district - " .
255 $res_code ? $api_response_codes[$res_code] : 'n/a',
256 $location_hash->{address1},
258 $log->error( $error );
266 district => $res_root->getAttribute('loccode'),
267 tax => $res_root->getAttribute('rate') * 100,
268 county => uc $res_addressline->getAttribute('ptba'),
269 city => uc $res_rate->getAttribute('name')
272 $response{county} =~ s/ PTBA//i;
275 warn "XML document: $dom\n";
276 warn "API parsed response: ".Dumper( \%response )."\n";
281 "Tax district(%s) selected for address(%s %s %s %s)",
283 $location_hash->{address1},
284 $location_hash->{city},
285 $location_hash->{state},
286 $location_hash->{zip};
288 $log->info( $info_message );
289 warn "$info_message\n"
296 ###### USPS Standardization ######
298 sub standardize_usps {
301 eval "use Business::US::USPS::WebTools::AddressStandardization";
304 my $location = shift;
305 if ( $location->{country} ne 'US' ) {
307 warn "standardize_usps not for use in country ".$location->{country}."\n";
308 $location->{addr_clean} = '';
311 my $userid = $conf->config('usps_webtools-userid');
312 my $password = $conf->config('usps_webtools-password');
313 my $verifier = Business::US::USPS::WebTools::AddressStandardization->new( {
315 Password => $password,
317 } ) or die "error starting USPS WebTools\n";
319 my($zip5, $zip4) = split('-',$location->{'zip'});
322 FirmName => $location->{company},
323 Address2 => $location->{address1},
324 Address1 => $location->{address2},
325 City => $location->{city},
326 State => $location->{state},
330 warn join('', map "$_: $usps_args{$_}\n", keys %usps_args )
333 my $hash = $verifier->verify_address( %usps_args );
335 warn $verifier->response
338 die "USPS WebTools error: ".$verifier->{error}{description} ."\n"
339 if $verifier->is_error;
341 my $zip = $hash->{Zip5};
342 $zip .= '-' . $hash->{Zip4} if $hash->{Zip4} =~ /\d/;
344 { company => $hash->{FirmName},
345 address1 => $hash->{Address2},
346 address2 => $hash->{Address1},
347 city => $hash->{City},
348 state => $hash->{State},
354 ###### U.S. Census Bureau ######
356 sub standardize_uscensus {
358 my $location = shift;
359 my $log = FS::Log->new('FS::Misc::Geo::standardize_uscensus');
360 $log->debug(join("\n", @{$location}{'address1', 'city', 'state', 'zip'}));
362 eval "use Geo::USCensus::Geocoding";
365 if ( $location->{country} ne 'US' ) {
367 warn "standardize_uscensus not for use in country ".$location->{country}."\n";
368 $location->{addr_clean} = '';
373 street => $location->{address1},
374 city => $location->{city},
375 state => $location->{state},
376 zip => $location->{zip},
377 debug => ($DEBUG || 0),
380 my $result = Geo::USCensus::Geocoding->query($request);
381 if ( $result->is_match ) {
382 # unfortunately we get the address back as a single line
383 $log->debug($result->address);
384 if ($result->address =~ /^(.*), (.*), ([A-Z]{2}), (\d{5}.*)$/) {
390 address2 => uc($location->{address2}),
391 latitude => $result->latitude,
392 longitude => $result->longitude,
393 censustract => $result->censustract,
396 die "Geocoding returned '".$result->address."', which does not seem to be a valid address.\n";
398 } elsif ( $result->match_level eq 'Tie' ) {
399 die "Geocoding was not able to identify a unique matching address.\n";
400 } elsif ( $result->match_level ) {
401 die "Geocoding did not find a matching address.\n";
403 $log->error($result->error_message);
404 return; # for internal errors, don't return anything
408 ####### EZLOCATE (obsolete) #######
410 sub _tomtom_query { # helper method for the below
412 my $result = Geo::TomTom::Geocoding->query(%args);
413 die "TomTom geocoding error: ".$result->message."\n"
414 unless ( $result->is_success );
415 my ($match) = $result->locations;
416 my $type = $match->{type};
417 # match levels below "intersection" should not be considered clean
418 my $clean = ($type eq 'addresspoint' ||
421 $type eq 'intersection'
423 warn "tomtom returned $type match\n" if $DEBUG;
424 warn Dumper($match) if $DEBUG > 1;
428 sub standardize_tomtom {
429 # post-2013 TomTom API
430 # much better, but incompatible with ezlocate
432 my $location = shift;
433 eval "use Geo::TomTom::Geocoding; use Geo::StreetAddress::US";
436 my $key = $conf->config('tomtom-userid')
437 or die "no tomtom-userid configured\n";
439 my $country = code2country($location->{country});
440 my ($address1, $address2) = ($location->{address1}, $location->{address2});
444 $address1 =~ s/^\s+//;
445 $address1 =~ s/\s+$//;
446 $address2 =~ s/^\s+//;
447 $address2 =~ s/\s+$//;
449 # try to fix some cases of the address fields being switched
450 if ( $address2 =~ /^\d/ and $address1 !~ /^\d/ ) {
451 $address2 = $address1;
452 $address1 = $location->{address2};
454 # parse sublocation part (unit/suite/apartment...) and clean up
455 # non-sublocation address2
456 ($subloc, $address2) =
457 subloc_address2($address1, $address2, $location->{country});
458 # ask TomTom to standardize address1:
462 L => $location->{city},
463 AA => $location->{state},
464 PC => $location->{zip},
465 CC => country2code($country, LOCALE_CODE_ALPHA_3),
468 my ($match, $clean) = _tomtom_query(%args);
470 if (!$match or !$clean) {
471 # Then try cleaning up the input; TomTom is picky about junk in the
472 # address. Any of these can still be a clean match.
473 my $h = Geo::StreetAddress::US->parse_location($address1);
474 # First conservatively:
475 if ( $h->{sec_unit_type} ) {
476 my $strip = '\s+' . $h->{sec_unit_type};
477 $strip .= '\s*' . $h->{sec_unit_num} if $h->{sec_unit_num};
479 $args{T} =~ s/$strip//;
480 ($match, $clean) = _tomtom_query(%args);
482 if ( !$match or !$clean ) {
483 # Then more aggressively:
484 $args{T} = uc( join(' ', @$h{'number', 'street', 'type'}) );
485 ($match, $clean) = _tomtom_query(%args);
489 if ( !$match or !$clean ) { # partial matches are not useful
490 die "Address not found\n";
493 if ( defined $match->{censusTract} ) {
494 $tract = $match->{censusStateCode}. $match->{censusFipsCountyCode}.
495 join('.', $match->{censusTract} =~ /(....)(..)/);
498 $address1 = $match->{houseNumber} . ' ' if length($match->{houseNumber});
499 $address1 .= $match->{street} if $match->{street};
500 $address1 .= ' '.$subloc if $subloc;
501 $address1 = uc($address1); # USPS standards
504 address1 => $address1,
505 address2 => $address2,
506 city => uc($match->{city}),
507 state => uc($location->{state}),
508 country => uc($location->{country}),
509 zip => ($match->{standardPostalCode} || $match->{postcode}),
510 latitude => $match->{latitude},
511 longitude => $match->{longitude},
512 censustract => $tract,
513 addr_clean => $clean,
517 =iten subloc_address2 ADDRESS1, ADDRESS2, COUNTRY
519 Given 'address1' and 'address2' strings, extract the sublocation part
520 (from either one) and return it. If the sublocation was found in ADDRESS1,
521 also return ADDRESS2 (cleaned up for postal standards) as it's assumed to
522 contain something relevant.
527 # Postal Addressing Standards, Appendix C
528 # (plus correction of "hanger" to "hangar")
556 # Canada Post Addressing Guidelines 4.3
567 sub subloc_address2 {
568 # Some things seen in the address2 field:
570 # The complete address (with address1 containing part of the company name,
571 # or an ATTN or DBA line, or P.O. Box, or department name, or building/suite
574 # try to parse sublocation parts from address1; if they are present we'll
575 # append them back to address1 after standardizing
577 my ($addr1, $addr2, $country) = map uc, @_;
578 my $dict = $subloc_forms{$country} or return('', $addr2);
580 my $found_in = 0; # which address is the sublocation
583 # patterns to try to parse
585 "$addr1 Nullcity, CA"
587 $h = Geo::StreetAddress::US->parse_location($addr1);
588 last if exists($h->{sec_unit_type});
590 if (exists($h->{sec_unit_type})) {
597 "$addr1, $addr2 Nullcity, CA"
599 $h = Geo::StreetAddress::US->parse_location("$addr1, $addr2");
600 last if exists($h->{sec_unit_type});
602 if (exists($h->{sec_unit_type})) {
607 $subloc = $h->{sec_unit_type};
608 # special case: do not combine P.O. box sublocs with address1
609 if ( $h->{sec_unit_type} =~ /^P *O *BOX/i ) {
610 if ( $found_in == 2 ) {
611 $addr2 = "PO BOX ".$h->{sec_unit_num};
612 } # else it's in addr1, and leave it alone
614 } elsif ( exists($dict->{$subloc}) ) {
615 # substitute the official abbreviation
616 $subloc = $dict->{$subloc};
618 $subloc .= ' ' . $h->{sec_unit_num} if length($h->{sec_unit_num});
619 } # otherwise $subloc = ''
621 if ( $found_in == 2 ) {
622 # address2 should be fully combined into address1
623 return ($subloc, '');
625 # else address2 is not the canonical sublocation, but do our best to
629 $addr2 =~ s/#\s*(\d)/NUMBER$1/; # /g?
631 # remove all punctuation and spaces
632 foreach my $w (split(/\W+/, $addr2)) {
633 if ( exists($dict->{$w}) ) {
634 push @words, $dict->{$w};
638 my $result = join(' ', @words);
639 # correct spacing of pound sign + number
640 $result =~ s/NUMBER(\d)/# $1/;
641 warn "normalizing '$addr2' to '$result'\n" if $DEBUG > 1;
644 $addr2 = '' if $addr2 eq $subloc; # if it was entered redundantly
648 sub standardize_melissa {
650 my $location = shift;
653 eval "use Geo::Melissa::WebSmart";
656 my $id = $conf->config('melissa-userid')
657 or die "no melissa-userid configured\n";
658 my $geocode = $conf->exists('melissa-enable_geocoding') ? 1 : 0;
662 a1 => $location->{address1},
663 a2 => $location->{address2},
664 city => $location->{city},
665 state => $location->{state},
666 ctry => $location->{country},
667 zip => $location->{zip},
670 my $result = Geo::Melissa::WebSmart->query($request);
671 if ( $result->code =~ /AS01/ ) { # always present on success
672 my $addr = $result->address;
673 warn Dumper $addr if $DEBUG > 1;
675 address1 => $addr->{Address1},
676 address2 => $addr->{Address2},
677 city => $addr->{City}->{Name},
678 state => $addr->{State}->{Abbreviation},
679 country => $addr->{Country}->{Abbreviation},
681 latitude => $addr->{Latitude},
682 longitude => $addr->{Longitude},
685 if ( $addr->{Census}->{Tract} ) {
686 my $censustract = $addr->{County}->{Fips} . $addr->{Census}->{Tract};
687 # insert decimal point two digits from the end
688 $censustract =~ s/(\d\d)$/\.$1/;
689 $out->{censustract} = $censustract;
690 $out->{censusyear} = $conf->config('census_year');
692 # we could do a lot more nuanced reporting of the warning/status codes,
693 # but the UI doesn't support that yet.
696 die $result->status_message;
700 sub standardize_freeside {
702 my $location = shift;
704 my $url = 'https://ws.freeside.biz/normalize';
706 #free freeside.biz normalization only for US
707 if ( $location->{country} ne 'US' ) {
709 #why? something else could have cleaned it $location->{addr_clean} = '';
713 my $ua = LWP::UserAgent->new(
715 verify_hostname => 0,
716 SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
719 my $response = $ua->request( POST $url, [
720 'support-key' => scalar($conf->config('support-key')),
724 die "Address normalization error: ". $response->message
725 unless $response->is_success;
728 my $content = eval { decode_json($response->content) };
730 warn $response->content;
731 die "Address normalization JSON error : $@\n";
734 die $content->{error}."\n"
735 if $content->{error};
737 { 'addr_clean' => 'Y',
738 map { $_ => $content->{$_} }
739 qw( address1 address2 city state zip country )