FS/FS/Misc/Geo.pm

   1 package FS::Misc::Geo;
   2
   3 use strict;
   4 use base qw( Exporter );
   5 use vars qw( $DEBUG @EXPORT_OK $conf );
   6 use LWP::UserAgent;
   7 use HTTP::Request;
   8 use HTTP::Request::Common qw( GET POST );
   9 use JSON;
  10 use URI::Escape 3.31;
  11 use Data::Dumper;
  12 use FS::Conf;
  13 use Locale::Country;
  14
  15 FS::UID->install_callback( sub {
  16   $conf = new FS::Conf;
  17 } );
  18
  19 $DEBUG = 0;
  20
  21 @EXPORT_OK = qw( get_district );
  22
  23 =head1 NAME
  24
  25 FS::Misc::Geo - routines to fetch geographic information
  26
  27 =head1 CLASS METHODS
  28
  29 =over 4
  30
  31 =item get_censustract_ffiec LOCATION YEAR
  32
  33 Given a location hash (see L<FS::location_Mixin>) and a census map year,
  34 returns a census tract code (consisting of state, county, and tract
  35 codes) or an error message.
  36
  37 =cut
  38
  39 sub get_censustract_ffiec {
  40   my $class = shift;
  41   my $location = shift;
  42   my $year  = shift;
  43   $year ||= 2012;
  44
  45   if ( length($location->{country}) and uc($location->{country}) ne 'US' ) {
  46     return '';
  47   }
  48
  49   warn Dumper($location, $year) if $DEBUG;
  50
  51   # the old FFIEC geocoding service was shut down December 1, 2014.
  52   # welcome to the future.
  53   my $url = 'https://geomap.ffiec.gov/FFIECGeocMap/GeocodeMap1.aspx/GetGeocodeData';
  54   # build the single-line query
  55   my $single_line = join(', ', $location->{address1},
  56                                $location->{city},
  57                                $location->{state}
  58                         );
  59   my $hashref = { sSingleLine => $single_line, iCensusYear => $year };
  60   my $request = POST( $url,
  61     'Content-Type' => 'application/json; charset=utf-8',
  62     'Accept' => 'application/json',
  63     'Content' => encode_json($hashref)
  64   );
  65
  66   my $ua = new LWP::UserAgent;
  67   my $res = $ua->request( $request );
  68
  69   warn $res->as_string
  70     if $DEBUG > 2;
  71
  72   if (!$res->is_success) {
  73
  74     die "Census tract lookup error: ".$res->message;
  75
  76   }
  77
  78   local $@;
  79   my $content = eval { decode_json($res->content) };
  80   die "Census tract JSON error: $@\n" if $@;
  81
  82   if ( !exists $content->{d}->{sStatus} ) {
  83     die "Census tract response is missing a status indicator.\nThis is an FFIEC problem.\n";
  84   }
  85   if ( $content->{d}->{sStatus} eq 'Y' ) {
  86     # success
  87     # this also contains the (partial) standardized address, correct zip
  88     # code, coordinates, etc., and we could get all of them, but right now
  89     # we only want the census tract
  90     my $tract = join('', $content->{d}->{sStateCode},
  91                          $content->{d}->{sCountyCode},
  92                          $content->{d}->{sTractCode});
  93     return $tract;
  94
  95   } else {
  96
  97     my $error = $content->{d}->{sMsg}
  98             ||  'FFIEC lookup failed, but with no status message.';
  99     die "$error\n";
 100
 101   }
 102 }
 103
 104 #sub get_district_methods {
 105 #  ''         => '',
 106 #  'wa_sales' => 'Washington sales tax',
 107 #};
 108
 109 =item get_district LOCATION METHOD
 110
 111 For the location hash in LOCATION, using lookup method METHOD, fetch
 112 tax district information.  Currently the only available method is
 113 'wa_sales' (the Washington Department of Revenue sales tax lookup).
 114
 115 Returns a hash reference containing the following fields:
 116
 117 - district
 118 - tax (percentage)
 119 - taxname
 120 - exempt_amount (currently zero)
 121 - city, county, state, country (from
 122
 123 The intent is that you can assign this to an L<FS::cust_main_county>
 124 object and insert it if there's not yet a tax rate defined for that
 125 district.
 126
 127 get_district will die on error.
 128
 129 =over 4
 130
 131 =cut
 132
 133 sub get_district {
 134   no strict 'refs';
 135   my $location = shift;
 136   my $method = shift or return '';
 137   warn Dumper($location, $method) if $DEBUG;
 138   &$method($location);
 139 }
 140
 141 sub wa_sales {
 142   my $location = shift;
 143   my $error = '';
 144   return '' if $location->{state} ne 'WA';
 145
 146   my $return = { %$location };
 147   $return->{'exempt_amount'} = 0.00;
 148
 149   my $url = 'http://webgis2.dor.wa.gov/TaxRateLookup_AGS/TaxReport.aspx';
 150   my $ua = new LWP::UserAgent;
 151
 152   my $delim = '<|>'; # yes, <|>
 153   my $year  = (localtime)[5] + 1900;
 154   my $month = (localtime)[4] + 1;
 155   my @zip = split('-', $location->{zip});
 156
 157   my @args = (
 158     'TaxType=S',  #sales; 'P' = property
 159     'Src=0',      #does something complicated
 160     'TAXABLE=',
 161     'Addr='.uri_escape($location->{address1}),
 162     'City='.uri_escape($location->{city}),
 163     'Zip='.$zip[0],
 164     'Zip1='.($zip[1] || ''), #optional
 165     'Year='.$year,
 166     'SYear='.$year,
 167     'Month='.$month,
 168     'EMon='.$month,
 169   );
 170
 171   my $query_string = join($delim, @args );
 172   $url .= "?$query_string";
 173   warn "\nrequest:  $url\n\n" if $DEBUG > 1;
 174
 175   my $res = $ua->request( GET( "$url?$query_string" ) );
 176
 177   warn $res->as_string
 178   if $DEBUG > 2;
 179
 180   if ($res->code ne '200') {
 181     $error = $res->message;
 182   }
 183
 184   my $content = $res->content;
 185   my $p = new HTML::TokeParser \$content;
 186   my $js = '';
 187   while ( my $t = $p->get_tag('script') ) {
 188     my $u = $p->get_token; #either enclosed text or the </script> tag
 189     if ( $u->[0] eq 'T' and $u->[1] =~ /tblSales/ ) {
 190       $js = $u->[1];
 191       last;
 192     }
 193   }
 194   if ( $js ) { #found it
 195     # strip down to the quoted string, which contains escaped single quotes.
 196     $js =~ s/.*\('tblSales'\);c.innerHTML='//s;
 197     $js =~ s/(?<!\\)'.*//s; # (?<!\\) means "not preceded by a backslash"
 198     warn "\n\n  innerHTML:\n$js\n\n" if $DEBUG > 2;
 199
 200     $p = new HTML::TokeParser \$js;
 201     TD: while ( my $td = $p->get_tag('td') ) {
 202       while ( my $u = $p->get_token ) {
 203         next TD if $u->[0] eq 'E' and $u->[1] eq 'td';
 204         next if $u->[0] ne 'T'; # skip non-text
 205         my $text = $u->[1];
 206
 207         if ( lc($text) eq 'location code' ) {
 208           $p->get_tag('td'); # skip to the next column
 209           undef $u;
 210           $u = $p->get_token until $u->[0] eq 'T'; # and then skip non-text
 211           $return->{'district'} = $u->[1];
 212         }
 213         elsif ( lc($text) eq 'total tax rate' ) {
 214           $p->get_tag('td');
 215           undef $u;
 216           $u = $p->get_token until $u->[0] eq 'T';
 217           $return->{'tax'} = $u->[1];
 218         }
 219       } # get_token
 220     } # TD
 221
 222     # just to make sure
 223     if ( $return->{'district'} =~ /^\d+$/ and $return->{'tax'} =~ /^.\d+$/ ) {
 224       $return->{'tax'} *= 100; #percentage
 225       warn Dumper($return) if $DEBUG > 1;
 226       return $return;
 227     }
 228     else {
 229       $error = 'district code/tax rate not found';
 230     }
 231   }
 232   else {
 233     $error = "failed to parse document";
 234   }
 235
 236   die "WA tax district lookup error: $error";
 237 }
 238
 239 sub standardize_usps {
 240   my $class = shift;
 241
 242   eval "use Business::US::USPS::WebTools::AddressStandardization";
 243   die $@ if $@;
 244
 245   my $location = shift;
 246   if ( $location->{country} ne 'US' ) {
 247     # soft failure
 248     warn "standardize_usps not for use in country ".$location->{country}."\n";
 249     $location->{addr_clean} = '';
 250     return $location;
 251   }
 252   my $userid   = $conf->config('usps_webtools-userid');
 253   my $password = $conf->config('usps_webtools-password');
 254   my $verifier = Business::US::USPS::WebTools::AddressStandardization->new( {
 255       UserID => $userid,
 256       Password => $password,
 257       Testing => 0,
 258   } ) or die "error starting USPS WebTools\n";
 259
 260   my($zip5, $zip4) = split('-',$location->{'zip'});
 261
 262   my %usps_args = (
 263     FirmName => $location->{company},
 264     Address2 => $location->{address1},
 265     Address1 => $location->{address2},
 266     City     => $location->{city},
 267     State    => $location->{state},
 268     Zip5     => $zip5,
 269     Zip4     => $zip4,
 270   );
 271   warn join('', map "$_: $usps_args{$_}\n", keys %usps_args )
 272     if $DEBUG > 1;
 273
 274   my $hash = $verifier->verify_address( %usps_args );
 275
 276   warn $verifier->response
 277     if $DEBUG > 1;
 278
 279   die "USPS WebTools error: ".$verifier->{error}{description} ."\n"
 280     if $verifier->is_error;
 281
 282   my $zip = $hash->{Zip5};
 283   $zip .= '-' . $hash->{Zip4} if $hash->{Zip4} =~ /\d/;
 284
 285   { company   => $hash->{FirmName},
 286     address1  => $hash->{Address2},
 287     address2  => $hash->{Address1},
 288     city      => $hash->{City},
 289     state     => $hash->{State},
 290     zip       => $zip,
 291     country   => 'US',
 292     addr_clean=> 'Y' }
 293 }
 294
 295 my %ezlocate_error = ( # USA_Geo_002 documentation
 296   10  => 'State not found',
 297   11  => 'City not found',
 298   12  => 'Invalid street address',
 299   14  => 'Street name not found',
 300   15  => 'Address range does not exist',
 301   16  => 'Ambiguous address',
 302   17  => 'Intersection not found', #unused?
 303 );
 304
 305 sub standardize_ezlocate {
 306   my $self = shift;
 307   my $location = shift;
 308   my $class;
 309   #if ( $location->{country} eq 'US' ) {
 310   #  $class = 'USA_Geo_004Tool';
 311   #}
 312   #elsif ( $location->{country} eq 'CA' ) {
 313   #  $class = 'CAN_Geo_001Tool';
 314   #}
 315   #else { # shouldn't be a fatal error, just pass through unverified address
 316   #  warn "standardize_teleatlas: address lookup in '".$location->{country}.
 317   #       "' not available\n";
 318   #  return $location;
 319   #}
 320   #my $path = $conf->config('teleatlas-path') || '';
 321   #local @INC = (@INC, $path);
 322   #eval "use $class;";
 323   #if ( $@ ) {
 324   #  die "Loading $class failed:\n$@".
 325   #      "\nMake sure the TeleAtlas Perl SDK is installed correctly.\n";
 326   #}
 327
 328   $class = 'Geo::EZLocate'; # use our own library
 329   eval "use $class 0.02"; #Geo::EZLocate 0.02 for error handling
 330   die $@ if $@;
 331
 332   my $userid = $conf->config('ezlocate-userid')
 333     or die "no ezlocate-userid configured\n";
 334   my $password = $conf->config('ezlocate-password')
 335     or die "no ezlocate-password configured\n";
 336
 337   my $tool = $class->new($userid, $password);
 338   my $match = $tool->findAddress(
 339     $location->{address1},
 340     $location->{city},
 341     $location->{state},
 342     $location->{zip}, #12345-6789 format is allowed
 343   );
 344   warn "ezlocate returned match:\n".Dumper($match) if $DEBUG > 1;
 345   # error handling - B codes indicate success
 346   die $ezlocate_error{$match->{MAT_STAT}}."\n"
 347     unless $match->{MAT_STAT} =~ /^B\d$/;
 348
 349   my %result = (
 350     address1    => $match->{MAT_ADDR},
 351     address2    => $location->{address2},
 352     city        => $match->{MAT_CITY},
 353     state       => $match->{MAT_ST},
 354     country     => $location->{country},
 355     zip         => $match->{MAT_ZIP},
 356     latitude    => $match->{MAT_LAT},
 357     longitude   => $match->{MAT_LON},
 358     censustract => $match->{FIPS_ST}.$match->{FIPS_CTY}.
 359                    sprintf('%07.2f',$match->{CEN_TRCT}),
 360     addr_clean  => 'Y',
 361   );
 362   if ( $match->{STD_ADDR} ) {
 363     # then they have a postal standardized address for us
 364     %result = ( %result,
 365       address1    => $match->{STD_ADDR},
 366       address2    => $location->{address2},
 367       city        => $match->{STD_CITY},
 368       state       => $match->{STD_ST},
 369       zip         => $match->{STD_ZIP}.'-'.$match->{STD_P4},
 370     );
 371   }
 372
 373   \%result;
 374 }
 375
 376 sub _tomtom_query { # helper method for the below
 377   my %args = @_;
 378   my $result = Geo::TomTom::Geocoding->query(%args);
 379   die "TomTom geocoding error: ".$result->message."\n"
 380     unless ( $result->is_success );
 381   my ($match) = $result->locations;
 382   my $type = $match->{type};
 383   # match levels below "intersection" should not be considered clean
 384   my $clean = ($type eq 'addresspoint'  ||
 385                $type eq 'poi'           ||
 386                $type eq 'house'         ||
 387                $type eq 'intersection'
 388               ) ? 'Y' : '';
 389   warn "tomtom returned $type match\n" if $DEBUG;
 390   warn Dumper($match) if $DEBUG > 1;
 391   ($match, $clean);
 392 }
 393
 394 sub standardize_tomtom {
 395   # post-2013 TomTom API
 396   # much better, but incompatible with ezlocate
 397   my $self = shift;
 398   my $location = shift;
 399   eval "use Geo::TomTom::Geocoding; use Geo::StreetAddress::US";
 400   die $@ if $@;
 401
 402   my $key = $conf->config('tomtom-userid')
 403     or die "no tomtom-userid configured\n";
 404
 405   my $country = code2country($location->{country});
 406   my ($address1, $address2) = ($location->{address1}, $location->{address2});
 407   my $subloc = '';
 408
 409   # trim whitespace
 410   $address1 =~ s/^\s+//;
 411   $address1 =~ s/\s+$//;
 412   $address2 =~ s/^\s+//;
 413   $address2 =~ s/\s+$//;
 414
 415   # try to fix some cases of the address fields being switched
 416   if ( $address2 =~ /^\d/ and $address1 !~ /^\d/ ) {
 417     $address2 = $address1;
 418     $address1 = $location->{address2};
 419   }
 420   # parse sublocation part (unit/suite/apartment...) and clean up
 421   # non-sublocation address2
 422   ($subloc, $address2) =
 423     subloc_address2($address1, $address2, $location->{country});
 424   # ask TomTom to standardize address1:
 425   my %args = (
 426     key => $key,
 427     T   => $address1,
 428     L   => $location->{city},
 429     AA  => $location->{state},
 430     PC  => $location->{zip},
 431     CC  => country2code($country, LOCALE_CODE_ALPHA_3),
 432   );
 433
 434   my ($match, $clean) = _tomtom_query(%args);
 435
 436   if (!$match or !$clean) {
 437     # Then try cleaning up the input; TomTom is picky about junk in the
 438     # address.  Any of these can still be a clean match.
 439     my $h = Geo::StreetAddress::US->parse_location($address1);
 440     # First conservatively:
 441     if ( $h->{sec_unit_type} ) {
 442       my $strip = '\s+' . $h->{sec_unit_type};
 443       $strip .= '\s*' . $h->{sec_unit_num} if $h->{sec_unit_num};
 444       $strip .= '$';
 445       $args{T} =~ s/$strip//;
 446       ($match, $clean) = _tomtom_query(%args);
 447     }
 448     if ( !$match or !$clean ) {
 449       # Then more aggressively:
 450       $args{T} = uc( join(' ', @$h{'number', 'street', 'type'}) );
 451       ($match, $clean) = _tomtom_query(%args);
 452     }
 453   }
 454
 455   if ( !$match or !$clean ) { # partial matches are not useful
 456     die "Address not found\n";
 457   }
 458   my $tract = '';
 459   if ( defined $match->{censusTract} ) {
 460     $tract = $match->{censusStateCode}. $match->{censusFipsCountyCode}.
 461              join('.', $match->{censusTract} =~ /(....)(..)/);
 462   }
 463   $address1 = '';
 464   $address1 = $match->{houseNumber} . ' ' if length($match->{houseNumber});
 465   $address1 .= $match->{street} if $match->{street};
 466   $address1 .= ' '.$subloc if $subloc;
 467   $address1 = uc($address1); # USPS standards
 468
 469   return +{
 470     address1    => $address1,
 471     address2    => $address2,
 472     city        => uc($match->{city}),
 473     state       => uc($location->{state}),
 474     country     => uc($location->{country}),
 475     zip         => ($match->{standardPostalCode} || $match->{postcode}),
 476     latitude    => $match->{latitude},
 477     longitude   => $match->{longitude},
 478     censustract => $tract,
 479     addr_clean  => $clean,
 480   };
 481 }
 482
 483 =iten subloc_address2 ADDRESS1, ADDRESS2, COUNTRY
 484
 485 Given 'address1' and 'address2' strings, extract the sublocation part
 486 (from either one) and return it.  If the sublocation was found in ADDRESS1,
 487 also return ADDRESS2 (cleaned up for postal standards) as it's assumed to
 488 contain something relevant.
 489
 490 =cut
 491
 492 my %subloc_forms = (
 493   # Postal Addressing Standards, Appendix C
 494   # (plus correction of "hanger" to "hangar")
 495   US => {qw(
 496     APARTMENT     APT
 497     BASEMENT      BSMT
 498     BUILDING      BLDG
 499     DEPARTMENT    DEPT
 500     FLOOR         FL
 501     FRONT         FRNT
 502     HANGAR        HNGR
 503     HANGER        HNGR
 504     KEY           KEY
 505     LOBBY         LBBY
 506     LOT           LOT
 507     LOWER         LOWR
 508     OFFICE        OFC
 509     PENTHOUSE     PH
 510     PIER          PIER
 511     REAR          REAR
 512     ROOM          RM
 513     SIDE          SIDE
 514     SLIP          SLIP
 515     SPACE         SPC
 516     STOP          STOP
 517     SUITE         STE
 518     TRAILER       TRLR
 519     UNIT          UNIT
 520     UPPER         UPPR
 521   )},
 522   # Canada Post Addressing Guidelines 4.3
 523   CA => {qw(
 524     APARTMENT     APT
 525     APPARTEMENT   APP
 526     BUREAU        BUREAU
 527     SUITE         SUITE
 528     UNIT          UNIT
 529     UNITÉ         UNITÉ
 530   )},
 531 );
 532
 533 sub subloc_address2 {
 534   # Some things seen in the address2 field:
 535   # Whitespace
 536   # The complete address (with address1 containing part of the company name,
 537   # or an ATTN or DBA line, or P.O. Box, or department name, or building/suite
 538   # number, etc.)
 539
 540   # try to parse sublocation parts from address1; if they are present we'll
 541   # append them back to address1 after standardizing
 542   my $subloc = '';
 543   my ($addr1, $addr2, $country) = map uc, @_;
 544   my $dict = $subloc_forms{$country} or return('', $addr2);
 545
 546   my $found_in = 0; # which address is the sublocation
 547   my $h;
 548   foreach my $string (
 549     # patterns to try to parse
 550     $addr1,
 551     "$addr1 Nullcity, CA"
 552   ) {
 553     $h = Geo::StreetAddress::US->parse_location($addr1);
 554     last if exists($h->{sec_unit_type});
 555   }
 556   if (exists($h->{sec_unit_type})) {
 557     $found_in = 1
 558   } else {
 559     foreach my $string (
 560       # more patterns
 561       $addr2,
 562       "$addr1, $addr2",
 563       "$addr1, $addr2 Nullcity, CA"
 564     ) {
 565       $h = Geo::StreetAddress::US->parse_location("$addr1, $addr2");
 566       last if exists($h->{sec_unit_type});
 567     }
 568     if (exists($h->{sec_unit_type})) {
 569       $found_in = 2;
 570     }
 571   }
 572   if ( $found_in ) {
 573     $subloc = $h->{sec_unit_type};
 574     # special case: do not combine P.O. box sublocs with address1
 575     if ( $h->{sec_unit_type} =~ /^P *O *BOX/i ) {
 576       if ( $found_in == 2 ) {
 577         $addr2 = "PO BOX ".$h->{sec_unit_num};
 578       } # else it's in addr1, and leave it alone
 579       return ('', $addr2);
 580     } elsif ( exists($dict->{$subloc}) ) {
 581       # substitute the official abbreviation
 582       $subloc = $dict->{$subloc};
 583     }
 584     $subloc .= ' ' . $h->{sec_unit_num} if length($h->{sec_unit_num});
 585   } # otherwise $subloc = ''
 586
 587   if ( $found_in == 2 ) {
 588     # address2 should be fully combined into address1
 589     return ($subloc, '');
 590   }
 591   # else address2 is not the canonical sublocation, but do our best to
 592   # clean it up
 593   #
 594   # protect this
 595   $addr2 =~ s/#\s*(\d)/NUMBER$1/; # /g?
 596   my @words;
 597   # remove all punctuation and spaces
 598   foreach my $w (split(/\W+/, $addr2)) {
 599     if ( exists($dict->{$w}) ) {
 600       push @words, $dict->{$w};
 601     } else {
 602       push @words, $w;
 603     }
 604     my $result = join(' ', @words);
 605     # correct spacing of pound sign + number
 606     $result =~ s/NUMBER(\d)/# $1/;
 607     warn "normalizing '$addr2' to '$result'\n" if $DEBUG > 1;
 608     $addr2 = $result;
 609   }
 610   $addr2 = '' if $addr2 eq $subloc; # if it was entered redundantly
 611   ($subloc, $addr2);
 612 }
 613
 614 sub standardize_melissa {
 615   my $class = shift;
 616   my $location = shift;
 617
 618   local $@;
 619   eval "use Geo::Melissa::WebSmart";
 620   die $@ if $@;
 621
 622   my $id = $conf->config('melissa-userid')
 623     or die "no melissa-userid configured\n";
 624   my $geocode = $conf->exists('melissa-enable_geocoding') ? 1 : 0;
 625
 626   my $request = {
 627     id      => $id,
 628     a1      => $location->{address1},
 629     a2      => $location->{address2},
 630     city    => $location->{city},
 631     state   => $location->{state},
 632     ctry    => $location->{country},
 633     zip     => $location->{zip},
 634     geocode => $geocode,
 635   };
 636   my $result = Geo::Melissa::WebSmart->query($request);
 637   if ( $result->code =~ /AS01/ ) { # always present on success
 638     my $addr = $result->address;
 639     warn Dumper $addr if $DEBUG > 1;
 640     my $out = {
 641       address1    => $addr->{Address1},
 642       address2    => $addr->{Address2},
 643       city        => $addr->{City}->{Name},
 644       state       => $addr->{State}->{Abbreviation},
 645       country     => $addr->{Country}->{Abbreviation},
 646       zip         => $addr->{Zip},
 647       latitude    => $addr->{Latitude},
 648       longitude   => $addr->{Longitude},
 649       addr_clean  => 'Y',
 650     };
 651     if ( $addr->{Census}->{Tract} ) {
 652       my $censustract = $addr->{County}->{Fips} . $addr->{Census}->{Tract};
 653       # insert decimal point two digits from the end
 654       $censustract =~ s/(\d\d)$/\.$1/;
 655       $out->{censustract} = $censustract;
 656       $out->{censusyear} = $conf->config('census_year');
 657     }
 658     # we could do a lot more nuanced reporting of the warning/status codes,
 659     # but the UI doesn't support that yet.
 660     return $out;
 661   } else {
 662     die $result->status_message;
 663   }
 664 }
 665
 666 =back
 667
 668 =cut
 669
 670 1;