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 Returns undef 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 freeside-wa-tax-table-update to fully populate the
163 city/county/districts for 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
175 If api returns no district for address, generates system log error
184 # freeside-queued will issue dbh->rollback on die() ... this will
185 # also roll back system log messages about errors :/ freeside-queued
186 # doesn't propgate die messages into the system log.
189 my $location_hash = shift;
191 # Return when called with pointless context
193 unless $location_hash
194 && ref $location_hash
195 && $location_hash->{state} eq 'WA'
196 && $location_hash->{address1}
197 && $location_hash->{zip}
198 && $location_hash->{city};
200 my $log = FS::Log->new('wa_sales');
202 warn "wa_sales() called with location_hash:\n".Dumper( $location_hash)."\n"
205 my $api_url = 'http://webgis.dor.wa.gov/webapi/AddressRates.aspx';
206 my @api_response_codes = (
207 'The address was found',
208 'The address was not found, but the ZIP+4 was located.',
209 'The address was updated and found, the user should validate the address record',
210 'The address was updated and Zip+4 located, the user should validate the address record',
211 'The address was corrected and found, the user should validate the address record',
212 'Neither the address or ZIP+4 was found, but the 5-digit ZIP was located.',
213 'The address, ZIP+4, and ZIP could not be found.',
214 'Invalid Latitude/Longitude',
220 addr => $location_hash->{address1},
221 city => $location_hash->{city},
222 zip => substr( $location_hash->{zip}, 0, 5 ),
224 my $get_string = join '&' => (
225 map{ sprintf "%s=%s", $_, uri_escape( $get_query{$_} ) }
229 my $prepared_url = "${api_url}?$get_string";
231 warn "API call to URL: $prepared_url\n"
236 eval { $dom = XML::LibXML->load_xml( location => $prepared_url ); };
239 sprintf "Problem parsing XML from API URL(%s): %s",
242 $log->error( $error );
247 my ($res_root) = $dom->findnodes('/response');
248 my ($res_addressline) = $dom->findnodes('/response/addressline');
249 my ($res_rate) = $dom->findnodes('/response/rate');
251 my $res_code = $res_root->getAttribute('code')
256 && ref $res_addressline
259 && $res_root->getAttribute('rate') > 0
263 "Problem querying WA DOR tax district - " .
268 $res_code ? $api_response_codes[$res_code] : 'n/a',
269 $location_hash->{address1},
272 $log->error( $error );
281 district => $res_root->getAttribute('loccode'),
282 tax => $res_root->getAttribute('rate') * 100,
283 county => uc $res_addressline->getAttribute('ptba'),
284 city => uc $res_rate->getAttribute('name')
287 $response{county} =~ s/ PTBA//i;
290 warn "XML document: $dom\n";
291 warn "API parsed response: ".Dumper( \%response )."\n";
296 "Tax district(%s) selected for address(%s %s %s %s)",
298 $location_hash->{address1},
299 $location_hash->{city},
300 $location_hash->{state},
301 $location_hash->{zip};
303 $log->info( $info_message );
304 warn "$info_message\n"
311 ###### USPS Standardization ######
313 sub standardize_usps {
316 eval "use Business::US::USPS::WebTools::AddressStandardization";
319 my $location = shift;
320 if ( $location->{country} ne 'US' ) {
322 warn "standardize_usps not for use in country ".$location->{country}."\n";
323 $location->{addr_clean} = '';
326 my $userid = $conf->config('usps_webtools-userid');
327 my $password = $conf->config('usps_webtools-password');
328 my $verifier = Business::US::USPS::WebTools::AddressStandardization->new( {
330 Password => $password,
332 } ) or die "error starting USPS WebTools\n";
334 my($zip5, $zip4) = split('-',$location->{'zip'});
337 FirmName => $location->{company},
338 Address2 => $location->{address1},
339 Address1 => $location->{address2},
340 City => $location->{city},
341 State => $location->{state},
345 warn join('', map "$_: $usps_args{$_}\n", keys %usps_args )
348 my $hash = $verifier->verify_address( %usps_args );
350 warn $verifier->response
353 die "USPS WebTools error: ".$verifier->{error}{description} ."\n"
354 if $verifier->is_error;
356 my $zip = $hash->{Zip5};
357 $zip .= '-' . $hash->{Zip4} if $hash->{Zip4} =~ /\d/;
359 { company => $hash->{FirmName},
360 address1 => $hash->{Address2},
361 address2 => $hash->{Address1},
362 city => $hash->{City},
363 state => $hash->{State},
369 ###### U.S. Census Bureau ######
371 sub standardize_uscensus {
373 my $location = shift;
374 my $log = FS::Log->new('FS::Misc::Geo::standardize_uscensus');
375 $log->debug(join("\n", @{$location}{'address1', 'city', 'state', 'zip'}));
377 eval "use Geo::USCensus::Geocoding";
380 if ( $location->{country} ne 'US' ) {
382 warn "standardize_uscensus not for use in country ".$location->{country}."\n";
383 $location->{addr_clean} = '';
388 street => $location->{address1},
389 city => $location->{city},
390 state => $location->{state},
391 zip => $location->{zip},
392 debug => ($DEBUG || 0),
395 my $result = Geo::USCensus::Geocoding->query($request);
396 if ( $result->is_match ) {
397 # unfortunately we get the address back as a single line
398 $log->debug($result->address);
399 if ($result->address =~ /^(.*), (.*), ([A-Z]{2}), (\d{5}.*)$/) {
405 address2 => uc($location->{address2}),
406 latitude => $result->latitude,
407 longitude => $result->longitude,
408 censustract => $result->censustract,
411 die "Geocoding returned '".$result->address."', which does not seem to be a valid address.\n";
413 } elsif ( $result->match_level eq 'Tie' ) {
414 die "Geocoding was not able to identify a unique matching address.\n";
415 } elsif ( $result->match_level ) {
416 die "Geocoding did not find a matching address.\n";
418 $log->error($result->error_message);
419 return; # for internal errors, don't return anything
423 ####### EZLOCATE (obsolete) #######
425 sub _tomtom_query { # helper method for the below
427 my $result = Geo::TomTom::Geocoding->query(%args);
428 die "TomTom geocoding error: ".$result->message."\n"
429 unless ( $result->is_success );
430 my ($match) = $result->locations;
431 my $type = $match->{type};
432 # match levels below "intersection" should not be considered clean
433 my $clean = ($type eq 'addresspoint' ||
436 $type eq 'intersection'
438 warn "tomtom returned $type match\n" if $DEBUG;
439 warn Dumper($match) if $DEBUG > 1;
443 sub standardize_tomtom {
444 # post-2013 TomTom API
445 # much better, but incompatible with ezlocate
447 my $location = shift;
448 eval "use Geo::TomTom::Geocoding; use Geo::StreetAddress::US";
451 my $key = $conf->config('tomtom-userid')
452 or die "no tomtom-userid configured\n";
454 my $country = code2country($location->{country});
455 my ($address1, $address2) = ($location->{address1}, $location->{address2});
459 $address1 =~ s/^\s+//;
460 $address1 =~ s/\s+$//;
461 $address2 =~ s/^\s+//;
462 $address2 =~ s/\s+$//;
464 # try to fix some cases of the address fields being switched
465 if ( $address2 =~ /^\d/ and $address1 !~ /^\d/ ) {
466 $address2 = $address1;
467 $address1 = $location->{address2};
469 # parse sublocation part (unit/suite/apartment...) and clean up
470 # non-sublocation address2
471 ($subloc, $address2) =
472 subloc_address2($address1, $address2, $location->{country});
473 # ask TomTom to standardize address1:
477 L => $location->{city},
478 AA => $location->{state},
479 PC => $location->{zip},
480 CC => country2code($country, LOCALE_CODE_ALPHA_3),
483 my ($match, $clean) = _tomtom_query(%args);
485 if (!$match or !$clean) {
486 # Then try cleaning up the input; TomTom is picky about junk in the
487 # address. Any of these can still be a clean match.
488 my $h = Geo::StreetAddress::US->parse_location($address1);
489 # First conservatively:
490 if ( $h->{sec_unit_type} ) {
491 my $strip = '\s+' . $h->{sec_unit_type};
492 $strip .= '\s*' . $h->{sec_unit_num} if $h->{sec_unit_num};
494 $args{T} =~ s/$strip//;
495 ($match, $clean) = _tomtom_query(%args);
497 if ( !$match or !$clean ) {
498 # Then more aggressively:
499 $args{T} = uc( join(' ', @$h{'number', 'street', 'type'}) );
500 ($match, $clean) = _tomtom_query(%args);
504 if ( !$match or !$clean ) { # partial matches are not useful
505 die "Address not found\n";
508 if ( defined $match->{censusTract} ) {
509 $tract = $match->{censusStateCode}. $match->{censusFipsCountyCode}.
510 join('.', $match->{censusTract} =~ /(....)(..)/);
513 $address1 = $match->{houseNumber} . ' ' if length($match->{houseNumber});
514 $address1 .= $match->{street} if $match->{street};
515 $address1 .= ' '.$subloc if $subloc;
516 $address1 = uc($address1); # USPS standards
519 address1 => $address1,
520 address2 => $address2,
521 city => uc($match->{city}),
522 state => uc($location->{state}),
523 country => uc($location->{country}),
524 zip => ($match->{standardPostalCode} || $match->{postcode}),
525 latitude => $match->{latitude},
526 longitude => $match->{longitude},
527 censustract => $tract,
528 addr_clean => $clean,
532 =iten subloc_address2 ADDRESS1, ADDRESS2, COUNTRY
534 Given 'address1' and 'address2' strings, extract the sublocation part
535 (from either one) and return it. If the sublocation was found in ADDRESS1,
536 also return ADDRESS2 (cleaned up for postal standards) as it's assumed to
537 contain something relevant.
542 # Postal Addressing Standards, Appendix C
543 # (plus correction of "hanger" to "hangar")
571 # Canada Post Addressing Guidelines 4.3
582 sub subloc_address2 {
583 # Some things seen in the address2 field:
585 # The complete address (with address1 containing part of the company name,
586 # or an ATTN or DBA line, or P.O. Box, or department name, or building/suite
589 # try to parse sublocation parts from address1; if they are present we'll
590 # append them back to address1 after standardizing
592 my ($addr1, $addr2, $country) = map uc, @_;
593 my $dict = $subloc_forms{$country} or return('', $addr2);
595 my $found_in = 0; # which address is the sublocation
598 # patterns to try to parse
600 "$addr1 Nullcity, CA"
602 $h = Geo::StreetAddress::US->parse_location($addr1);
603 last if exists($h->{sec_unit_type});
605 if (exists($h->{sec_unit_type})) {
612 "$addr1, $addr2 Nullcity, CA"
614 $h = Geo::StreetAddress::US->parse_location("$addr1, $addr2");
615 last if exists($h->{sec_unit_type});
617 if (exists($h->{sec_unit_type})) {
622 $subloc = $h->{sec_unit_type};
623 # special case: do not combine P.O. box sublocs with address1
624 if ( $h->{sec_unit_type} =~ /^P *O *BOX/i ) {
625 if ( $found_in == 2 ) {
626 $addr2 = "PO BOX ".$h->{sec_unit_num};
627 } # else it's in addr1, and leave it alone
629 } elsif ( exists($dict->{$subloc}) ) {
630 # substitute the official abbreviation
631 $subloc = $dict->{$subloc};
633 $subloc .= ' ' . $h->{sec_unit_num} if length($h->{sec_unit_num});
634 } # otherwise $subloc = ''
636 if ( $found_in == 2 ) {
637 # address2 should be fully combined into address1
638 return ($subloc, '');
640 # else address2 is not the canonical sublocation, but do our best to
644 $addr2 =~ s/#\s*(\d)/NUMBER$1/; # /g?
646 # remove all punctuation and spaces
647 foreach my $w (split(/\W+/, $addr2)) {
648 if ( exists($dict->{$w}) ) {
649 push @words, $dict->{$w};
653 my $result = join(' ', @words);
654 # correct spacing of pound sign + number
655 $result =~ s/NUMBER(\d)/# $1/;
656 warn "normalizing '$addr2' to '$result'\n" if $DEBUG > 1;
659 $addr2 = '' if $addr2 eq $subloc; # if it was entered redundantly
663 sub standardize_melissa {
665 my $location = shift;
668 eval "use Geo::Melissa::WebSmart";
671 my $id = $conf->config('melissa-userid')
672 or die "no melissa-userid configured\n";
673 my $geocode = $conf->exists('melissa-enable_geocoding') ? 1 : 0;
677 a1 => $location->{address1},
678 a2 => $location->{address2},
679 city => $location->{city},
680 state => $location->{state},
681 ctry => $location->{country},
682 zip => $location->{zip},
685 my $result = Geo::Melissa::WebSmart->query($request);
686 if ( $result->code =~ /AS01/ ) { # always present on success
687 my $addr = $result->address;
688 warn Dumper $addr if $DEBUG > 1;
690 address1 => $addr->{Address1},
691 address2 => $addr->{Address2},
692 city => $addr->{City}->{Name},
693 state => $addr->{State}->{Abbreviation},
694 country => $addr->{Country}->{Abbreviation},
696 latitude => $addr->{Latitude},
697 longitude => $addr->{Longitude},
700 if ( $addr->{Census}->{Tract} ) {
701 my $censustract = $addr->{County}->{Fips} . $addr->{Census}->{Tract};
702 # insert decimal point two digits from the end
703 $censustract =~ s/(\d\d)$/\.$1/;
704 $out->{censustract} = $censustract;
705 $out->{censusyear} = $conf->config('census_year');
707 # we could do a lot more nuanced reporting of the warning/status codes,
708 # but the UI doesn't support that yet.
711 die $result->status_message;
715 sub standardize_freeside {
717 my $location = shift;
719 my $url = 'https://ws.freeside.biz/normalize';
721 #free freeside.biz normalization only for US
722 if ( $location->{country} ne 'US' ) {
724 #why? something else could have cleaned it $location->{addr_clean} = '';
728 my $ua = LWP::UserAgent->new(
730 verify_hostname => 0,
731 SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
734 my $response = $ua->request( POST $url, [
735 'support-key' => scalar($conf->config('support-key')),
739 die "Address normalization error: ". $response->message
740 unless $response->is_success;
743 my $content = eval { decode_json($response->content) };
745 warn $response->content;
746 die "Address normalization JSON error : $@\n";
749 die $content->{error}."\n"
750 if $content->{error};
752 { 'addr_clean' => 'Y',
753 map { $_ => $content->{$_} }
754 qw( address1 address2 city state zip country )