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