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 HTML::TokeParser;
  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 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
  44   warn Dumper($location, $year) if $DEBUG;
  45
  46   my $url = 'http://www.ffiec.gov/Geocode/default.aspx';
  47
  48   my $return = {};
  49   my $error = '';
  50
  51   my $ua = new LWP::UserAgent;
  52   my $res = $ua->request( GET( $url ) );
  53
  54   warn $res->as_string
  55     if $DEBUG > 2;
  56
  57   unless ($res->code  eq '200') {
  58
  59     $error = $res->message;
  60
  61   } else {
  62
  63     my $content = $res->content;
  64     my $p = new HTML::TokeParser \$content;
  65     my $viewstate;
  66     my $eventvalidation;
  67     while (my $token = $p->get_tag('input') ) {
  68       if ($token->[1]->{name} eq '__VIEWSTATE') {
  69         $viewstate = $token->[1]->{value};
  70       }
  71       if ($token->[1]->{name} eq '__EVENTVALIDATION') {
  72         $eventvalidation = $token->[1]->{value};
  73       }
  74       last if $viewstate && $eventvalidation;
  75     }
  76
  77     unless ($viewstate && $eventvalidation ) {
  78
  79       $error = "either no __VIEWSTATE or __EVENTVALIDATION found";
  80
  81     } else {
  82
  83       my($zip5, $zip4) = split('-',$location->{zip});
  84
  85       $year ||= '2012';
  86       my @ffiec_args = (
  87         __VIEWSTATE => $viewstate,
  88         __EVENTVALIDATION => $eventvalidation,
  89         ddlbYear    => $year,
  90         txtAddress  => $location->{address1},
  91         txtCity     => $location->{city},
  92         ddlbState   => $location->{state},
  93         txtZipCode  => $zip5,
  94         btnSearch   => 'Search',
  95       );
  96       warn join("\n", @ffiec_args )
  97         if $DEBUG > 1;
  98
  99       push @{ $ua->requests_redirectable }, 'POST';
 100       $res = $ua->request( POST( $url, \@ffiec_args ) );
 101       warn $res->as_string
 102         if $DEBUG > 2;
 103
 104       unless ($res->code  eq '200') {
 105
 106         $error = $res->message;
 107
 108       } else {
 109
 110         my @id = qw( MSACode StateCode CountyCode TractCode );
 111         $content = $res->content;
 112         warn $res->content if $DEBUG > 2;
 113         $p = new HTML::TokeParser \$content;
 114         my $prefix = 'UcGeoResult11_lb';
 115         my $compare =
 116           sub { my $t=shift; scalar( grep { lc($t) eq lc("$prefix$_")} @id ) };
 117
 118         while (my $token = $p->get_tag('span') ) {
 119           next unless ( $token->[1]->{id} && &$compare( $token->[1]->{id} ) );
 120           $token->[1]->{id} =~ /^$prefix(\w+)$/;
 121           $return->{lc($1)} = $p->get_trimmed_text("/span");
 122         }
 123
 124         unless ( $return->{tractcode} ) {
 125           warn "$error: $content ". Dumper($return) if $DEBUG;
 126           $error = "No census tract found";
 127         }
 128         $return->{tractcode} .= ' '
 129           unless $error || $JSON::VERSION >= 2; #broken JSON 1 workaround
 130
 131       } #unless ($res->code  eq '200')
 132
 133     } #unless ($viewstate)
 134
 135   } #unless ($res->code  eq '200')
 136
 137   die "FFIEC Geocoding error: $error\n" if $error;
 138
 139   $return->{'statecode'} .  $return->{'countycode'} .  $return->{'tractcode'};
 140 }
 141
 142 #sub get_district_methods {
 143 #  ''         => '',
 144 #  'wa_sales' => 'Washington sales tax',
 145 #};
 146
 147 =item get_district LOCATION METHOD
 148
 149 For the location hash in LOCATION, using lookup method METHOD, fetch
 150 tax district information.  Currently the only available method is
 151 'wa_sales' (the Washington Department of Revenue sales tax lookup).
 152
 153 Returns a hash reference containing the following fields:
 154
 155 - district
 156 - tax (percentage)
 157 - taxname
 158 - exempt_amount (currently zero)
 159 - city, county, state, country (from
 160
 161 The intent is that you can assign this to an L<FS::cust_main_county>
 162 object and insert it if there's not yet a tax rate defined for that
 163 district.
 164
 165 get_district will die on error.
 166
 167 =over 4
 168
 169 =cut
 170
 171 sub get_district {
 172   no strict 'refs';
 173   my $location = shift;
 174   my $method = shift or return '';
 175   warn Dumper($location, $method) if $DEBUG;
 176   &$method($location);
 177 }
 178
 179 sub wa_sales {
 180   my $location = shift;
 181   my $error = '';
 182   return '' if $location->{state} ne 'WA';
 183
 184   my $return = { %$location };
 185   $return->{'exempt_amount'} = 0.00;
 186
 187   my $url = 'http://webgis2.dor.wa.gov/TaxRateLookup_AGS/TaxReport.aspx';
 188   my $ua = new LWP::UserAgent;
 189
 190   my $delim = '<|>'; # yes, <|>
 191   my $year  = (localtime)[5] + 1900;
 192   my $month = (localtime)[4] + 1;
 193   my @zip = split('-', $location->{zip});
 194
 195   my @args = (
 196     'TaxType=S',  #sales; 'P' = property
 197     'Src=0',      #does something complicated
 198     'TAXABLE=',
 199     'Addr='.uri_escape($location->{address1}),
 200     'City='.uri_escape($location->{city}),
 201     'Zip='.$zip[0],
 202     'Zip1='.($zip[1] || ''), #optional
 203     'Year='.$year,
 204     'SYear='.$year,
 205     'Month='.$month,
 206     'EMon='.$month,
 207   );
 208
 209   my $query_string = join($delim, @args );
 210   $url .= "?$query_string";
 211   warn "\nrequest:  $url\n\n" if $DEBUG > 1;
 212
 213   my $res = $ua->request( GET( "$url?$query_string" ) );
 214
 215   warn $res->as_string
 216   if $DEBUG > 2;
 217
 218   if ($res->code ne '200') {
 219     $error = $res->message;
 220   }
 221
 222   my $content = $res->content;
 223   my $p = new HTML::TokeParser \$content;
 224   my $js = '';
 225   while ( my $t = $p->get_tag('script') ) {
 226     my $u = $p->get_token; #either enclosed text or the </script> tag
 227     if ( $u->[0] eq 'T' and $u->[1] =~ /tblSales/ ) {
 228       $js = $u->[1];
 229       last;
 230     }
 231   }
 232   if ( $js ) { #found it
 233     # strip down to the quoted string, which contains escaped single quotes.
 234     $js =~ s/.*\('tblSales'\);c.innerHTML='//s;
 235     $js =~ s/(?<!\\)'.*//s; # (?<!\\) means "not preceded by a backslash"
 236     warn "\n\n  innerHTML:\n$js\n\n" if $DEBUG > 2;
 237
 238     $p = new HTML::TokeParser \$js;
 239     TD: while ( my $td = $p->get_tag('td') ) {
 240       while ( my $u = $p->get_token ) {
 241         next TD if $u->[0] eq 'E' and $u->[1] eq 'td';
 242         next if $u->[0] ne 'T'; # skip non-text
 243         my $text = $u->[1];
 244
 245         if ( lc($text) eq 'location code' ) {
 246           $p->get_tag('td'); # skip to the next column
 247           undef $u;
 248           $u = $p->get_token until $u->[0] eq 'T'; # and then skip non-text
 249           $return->{'district'} = $u->[1];
 250         }
 251         elsif ( lc($text) eq 'total tax rate' ) {
 252           $p->get_tag('td');
 253           undef $u;
 254           $u = $p->get_token until $u->[0] eq 'T';
 255           $return->{'tax'} = $u->[1];
 256         }
 257       } # get_token
 258     } # TD
 259
 260     # just to make sure
 261     if ( $return->{'district'} =~ /^\d+$/ and $return->{'tax'} =~ /^.\d+$/ ) {
 262       $return->{'tax'} *= 100; #percentage
 263       warn Dumper($return) if $DEBUG > 1;
 264       return $return;
 265     }
 266     else {
 267       $error = 'district code/tax rate not found';
 268     }
 269   }
 270   else {
 271     $error = "failed to parse document";
 272   }
 273
 274   die "WA tax district lookup error: $error";
 275 }
 276
 277 sub standardize_usps {
 278   my $class = shift;
 279
 280   eval "use Business::US::USPS::WebTools::AddressStandardization";
 281   die $@ if $@;
 282
 283   my $location = shift;
 284   if ( $location->{country} ne 'US' ) {
 285     # soft failure
 286     warn "standardize_usps not for use in country ".$location->{country}."\n";
 287     $location->{addr_clean} = '';
 288     return $location;
 289   }
 290   my $userid   = $conf->config('usps_webtools-userid');
 291   my $password = $conf->config('usps_webtools-password');
 292   my $verifier = Business::US::USPS::WebTools::AddressStandardization->new( {
 293       UserID => $userid,
 294       Password => $password,
 295       Testing => 0,
 296   } ) or die "error starting USPS WebTools\n";
 297
 298   my($zip5, $zip4) = split('-',$location->{'zip'});
 299
 300   my %usps_args = (
 301     FirmName => $location->{company},
 302     Address2 => $location->{address1},
 303     Address1 => $location->{address2},
 304     City     => $location->{city},
 305     State    => $location->{state},
 306     Zip5     => $zip5,
 307     Zip4     => $zip4,
 308   );
 309   warn join('', map "$_: $usps_args{$_}\n", keys %usps_args )
 310     if $DEBUG > 1;
 311
 312   my $hash = $verifier->verify_address( %usps_args );
 313
 314   warn $verifier->response
 315     if $DEBUG > 1;
 316
 317   die "USPS WebTools error: ".$verifier->{error}{description} ."\n"
 318     if $verifier->is_error;
 319
 320   my $zip = $hash->{Zip5};
 321   $zip .= '-' . $hash->{Zip4} if $hash->{Zip4} =~ /\d/;
 322
 323   { company   => $hash->{FirmName},
 324     address1  => $hash->{Address2},
 325     address2  => $hash->{Address1},
 326     city      => $hash->{City},
 327     state     => $hash->{State},
 328     zip       => $zip,
 329     country   => 'US',
 330     addr_clean=> 'Y' }
 331 }
 332
 333 my %ezlocate_error = ( # USA_Geo_002 documentation
 334   10  => 'State not found',
 335   11  => 'City not found',
 336   12  => 'Invalid street address',
 337   14  => 'Street name not found',
 338   15  => 'Address range does not exist',
 339   16  => 'Ambiguous address',
 340   17  => 'Intersection not found', #unused?
 341 );
 342
 343 sub standardize_ezlocate {
 344   my $self = shift;
 345   my $location = shift;
 346   my $class;
 347   #if ( $location->{country} eq 'US' ) {
 348   #  $class = 'USA_Geo_004Tool';
 349   #}
 350   #elsif ( $location->{country} eq 'CA' ) {
 351   #  $class = 'CAN_Geo_001Tool';
 352   #}
 353   #else { # shouldn't be a fatal error, just pass through unverified address
 354   #  warn "standardize_teleatlas: address lookup in '".$location->{country}.
 355   #       "' not available\n";
 356   #  return $location;
 357   #}
 358   #my $path = $conf->config('teleatlas-path') || '';
 359   #local @INC = (@INC, $path);
 360   #eval "use $class;";
 361   #if ( $@ ) {
 362   #  die "Loading $class failed:\n$@".
 363   #      "\nMake sure the TeleAtlas Perl SDK is installed correctly.\n";
 364   #}
 365
 366   $class = 'Geo::EZLocate'; # use our own library
 367   eval "use $class 0.02"; #Geo::EZLocate 0.02 for error handling
 368   die $@ if $@;
 369
 370   my $userid = $conf->config('ezlocate-userid')
 371     or die "no ezlocate-userid configured\n";
 372   my $password = $conf->config('ezlocate-password')
 373     or die "no ezlocate-password configured\n";
 374
 375   my $tool = $class->new($userid, $password);
 376   my $match = $tool->findAddress(
 377     $location->{address1},
 378     $location->{city},
 379     $location->{state},
 380     $location->{zip}, #12345-6789 format is allowed
 381   );
 382   warn "ezlocate returned match:\n".Dumper($match) if $DEBUG > 1;
 383   # error handling - B codes indicate success
 384   die $ezlocate_error{$match->{MAT_STAT}}."\n"
 385     unless $match->{MAT_STAT} =~ /^B\d$/;
 386
 387   my %result = (
 388     address1    => $match->{MAT_ADDR},
 389     address2    => $location->{address2},
 390     city        => $match->{MAT_CITY},
 391     state       => $match->{MAT_ST},
 392     country     => $location->{country},
 393     zip         => $match->{MAT_ZIP},
 394     latitude    => $match->{MAT_LAT},
 395     longitude   => $match->{MAT_LON},
 396     censustract => $match->{FIPS_ST}.$match->{FIPS_CTY}.
 397                    sprintf('%07.2f',$match->{CEN_TRCT}),
 398     addr_clean  => 'Y',
 399   );
 400   if ( $match->{STD_ADDR} ) {
 401     # then they have a postal standardized address for us
 402     %result = ( %result,
 403       address1    => $match->{STD_ADDR},
 404       address2    => $location->{address2},
 405       city        => $match->{STD_CITY},
 406       state       => $match->{STD_ST},
 407       zip         => $match->{STD_ZIP}.'-'.$match->{STD_P4},
 408     );
 409   }
 410
 411   \%result;
 412 }
 413
 414 sub standardize_tomtom {
 415   # post-2013 TomTom API
 416   # much better, but incompatible with ezlocate
 417   my $self = shift;
 418   my $location = shift;
 419   my $class = 'Geo::TomTom::Geocoding';
 420   eval "use $class";
 421   die $@ if $@;
 422
 423   my $key = $conf->config('tomtom-userid')
 424     or die "no tomtom-userid configured\n";
 425
 426   my $country = code2country($location->{country});
 427   my $result = $class->query(
 428     key => $key,
 429     T   => $location->{address1},
 430     L   => $location->{city},
 431     AA  => $location->{state},
 432     PC  => $location->{zip},
 433     CC  => country2code($country, LOCALE_CODE_ALPHA_3),
 434   );
 435   unless ( $result->is_success ) {
 436     die "TomTom geocoding error: ".$result->message."\n";
 437   }
 438   my ($match) = $result->locations;
 439   if (!$match) {
 440     die "Location not found.\n";
 441   }
 442   warn "tomtom returned match:\n".Dumper($match) if $DEBUG > 1;
 443   my $tract = join('.', $match->{censusTract} =~ /(....)(..)/);
 444   return +{
 445     address1    => join(' ', $match->{houseNumber}, $match->{street}),
 446     address2    => $location->{address2}, # XXX still need a solution to this
 447     city        => $match->{city},
 448     state       => $match->{state},
 449     country     => country2code($match->{country}, LOCALE_CODE_ALPHA_2),
 450     zip         => ($match->{standardPostalCode} || $match->{postcode}),
 451     latitude    => $match->{latitude},
 452     longitude   => $match->{longitude},
 453     censustract => $match->{censusStateCode}.
 454                    $match->{censusFipsCountyCode}.
 455                    $tract,
 456     addr_clean  => 'Y',
 457   };
 458 }
 459
 460 =back
 461
 462 =cut
 463
 464
 465 1;