lib/Business/OnlinePayment/WesternACH.pm

   1 package Business::OnlinePayment::WesternACH;
   2
   3 use strict;
   4 use Carp;
   5 use Business::OnlinePayment 3;
   6 use Business::OnlinePayment::HTTPS;
   7 use XML::Simple;
   8 use MIME::Base64;
   9 use Date::Format 'time2str';
  10 use Date::Parse  'str2time';
  11 use vars qw($VERSION @ISA $me $DEBUG);
  12
  13 @ISA = qw(Business::OnlinePayment::HTTPS);
  14 $VERSION = '0.08';
  15 $me = 'Business::OnlinePayment::WesternACH';
  16
  17 $DEBUG = 0;
  18
  19 my $defaults = {
  20   command      => 'payment',
  21   check_ver    => 'yes',
  22   sec_code     => 'PPD',
  23   tender_type  => 'check',
  24   check_number => 9999,
  25   schedule     => 'live',
  26 };
  27
  28 my $required = { map { $_ => 1 } ( qw(
  29   login
  30   password
  31   command
  32   amount
  33   tender_type
  34   _full_name
  35   routing_code
  36   check_number
  37   _check_type
  38 ))};
  39
  40
  41
  42 # Structure of the XML request document
  43 # Right sides of the hash entries are Business::OnlinePayment
  44 # field names.  Those that start with _ are local method names.
  45
  46 my $auth = {
  47 Authentication => {
  48   username => 'login',
  49   password => 'password',
  50 }
  51 };
  52
  53 my $request = {
  54 TransactionRequest => {
  55   %$auth,
  56   Request => {
  57     command => 'command',
  58     Payment => {
  59       type   => '_payment_type',
  60       amount => 'amount',
  61       # effective date: not supported
  62       Tender => {
  63         type   => 'tender_type',
  64         amount => 'amount',
  65         InvoiceNumber => { value => 'invoice_number' },
  66         AccountHolder => { value => '_full_name'      },
  67         Address       => { value => 'address'       },
  68         ClientID      => { value => 'customer_id'    },
  69         UserDefinedID => { value => 'email' },
  70         CheckDetails => {
  71           routing      => 'routing_code',
  72           account      => 'account_number',
  73           check        => 'check_number',
  74           type         => '_check_type',
  75           verification => 'check_ver',
  76         },
  77         Authorization => { schedule => 'schedule' },
  78         SECCode => { value => 'sec_code' },
  79       },
  80     },
  81   }
  82 }
  83 };
  84
  85 my $returns_request = {
  86 TransactionRequest => {
  87   %$auth,
  88   Request => {
  89     command => 'command',
  90     DateRange => {
  91       start => '_start',
  92       end   => '_end',
  93     },
  94   },
  95 }
  96 };
  97
  98 sub set_defaults {
  99   my $self = shift;
 100   $self->server('www.webcheckexpress.com');
 101   $self->port(443);
 102   $self->path('/requester.php');
 103   return;
 104 }
 105
 106 sub submit {
 107   my $self = shift;
 108   $Business::OnlinePayment::HTTPS::DEBUG = $DEBUG;
 109   $DB::single = $DEBUG; # If you're debugging this, you probably want to stop here.
 110   my $xml_request;
 111
 112   if ($self->{_content}->{command} eq 'get_returns') {
 113     # Setting get_returns overrides anything else.
 114     $xml_request = XMLout($self->build($returns_request), KeepRoot => 1);
 115   }
 116   else {
 117     # Error-check and prepare as a normal transaction.
 118
 119       eval {
 120       # Return-with-error situations
 121       croak "Unsupported transaction type: '" . $self->transaction_type . "'"
 122         if(not $self->transaction_type =~ /^e?check$/i);
 123
 124       croak "Unsupported action: '" . $self->{_content}->{action} . "'"
 125         if(!defined($self->_payment_type));
 126
 127       croak 'Test transactions not supported'
 128         if($self->test_transaction());
 129     };
 130
 131     if($@) {
 132       $self->is_success(0);
 133       $self->error_message($@);
 134       return;
 135     }
 136
 137     $xml_request = XMLout($self->build($request), KeepRoot => 1);
 138   }
 139   my ($xml_reply, $response, %reply_headers) = $self->https_post({ 'Content-Type' => 'text/xml' }, $xml_request);
 140
 141   if(not $response =~ /^200/) {
 142     croak "HTTPS error: '$response'";
 143   }
 144
 145   $self->server_response($xml_reply);
 146   my $reply = XMLin($xml_reply, KeepRoot => 1)->{TransactionResponse};
 147
 148   if(exists($reply->{Response})) {
 149     $self->is_success( ( $reply->{Response}->{status} eq 'successful') ? 1 : 0);
 150     $self->error_message($reply->{Response}->{ErrorMessage});
 151     if(exists($reply->{Response}->{TransactionID})) {
 152       # get_returns puts its results here
 153       my $tid = $reply->{Response}->{TransactionID};
 154       if($self->{_content}->{command} eq 'get_returns') {
 155         if(ref($tid) eq 'ARRAY') {
 156           $self->{_content}->{returns} =  [ map { $_->{value} } @$tid ];
 157         }
 158         else {
 159           $self->{_content}->{returns} = [ $tid->{value} ];
 160         }
 161       }
 162       else { # It's not get_returns
 163         $self->authorization($tid->{value});
 164       }
 165     }
 166   }
 167   elsif(exists($reply->{FatalException})) {
 168     $self->is_success(0);
 169     $self->error_message($reply->{FatalException});
 170   }
 171
 172
 173   return;
 174 }
 175
 176 sub get_returns {
 177   my $self = shift;
 178   my $content = $self->{_content};
 179   if(exists($content->{'command'})) {
 180     croak 'get_returns: command is already set on this transaction';
 181   }
 182   if ( exists($content->{'returns_method'}) &&
 183       $content->{'returns_method'} eq 'requester') {
 184     # Obsolete, deprecated method supported for now as a fallback option.
 185     $content->{'command'} = 'get_returns';
 186     $self->submit;
 187     if($self->is_success) {
 188       if(exists($content->{'returns'})) {
 189         return @{$content->{'returns'}};
 190       }
 191       else {
 192         return ();
 193       }
 194     }
 195     # you need to check error_message() for details.
 196     return ();
 197   }
 198   else {
 199     $Business::OnlinePayment::HTTPS::DEBUG = $DEBUG;
 200     $DB::single = $DEBUG;
 201     if (defined($content->{'login'}) and defined($content->{'password'})) {
 202       # transret.php doesn't respect date ranges.  It returns anything from the
 203       # same month as the date argument.  Therefore we generate one request for
 204       # each month in the date range, and then filter them by date later.
 205       my $path = ('transret.php?style=csv&sort=id&date=');
 206       my $starttime = str2time($self->_start);
 207       my $endtime = str2time($self->_end) - 1;
 208       my @months = map { s/^(....)(..)$/$1-$2-01/; $_ } (
 209           time2str('%Y%m', $starttime)..time2str('%Y%m', $endtime)
 210           );
 211       my $headers = {
 212          Authorization => 'Basic ' . MIME::Base64::encode($content->{'login'} . ':' . $content->{'password'})
 213           };
 214       my @tids;
 215       foreach my $m (@months) {
 216         $self->path($path . $m);
 217         # B:OP:HTTPS::https_get doesn't use $DEBUG.
 218         my ($page, $reply, %headers) =
 219             $self->https_get(
 220               { headers => $headers },
 221               {},
 222             );
 223         if ($reply =~ /^200/) {
 224           $self->is_success(1);
 225         }
 226         else {
 227           $self->error_message($reply);
 228           carp $reply if $DEBUG;
 229           carp $page if $DEBUG >= 3;
 230           $self->is_success(0);
 231           return;
 232         }
 233         my $index_date_ret = 2; # Usual position of 'Date Returned'
 234         foreach my $trans (split("\cJ", $page)) {
 235           my @fields = split(',', $trans);
 236           # fields:
 237           # id, Date Returned, Type, Amount, Name, Customer ID Number,
 238           # Email Address, Invoice Number, Status Code, SEC
 239
 240           # we only care about id and date.
 241           next if scalar(@fields) < 10;
 242           if($fields[0] eq 'id') {
 243             # Use this header row to find the 'Date Returned' field.
 244             ($index_date_ret) = grep { lc($fields[$_]) eq 'date returned' } ( 0..scalar(@fields)-1 );
 245             $index_date_ret ||= 2;
 246           }
 247           next if not($fields[0] =~ /^\d+$/);
 248           my $rettime = str2time($fields[$index_date_ret]);
 249           next if (!$rettime or $rettime < $starttime or $rettime > $endtime);
 250           carp $trans if $DEBUG > 1;
 251           push @tids, $fields[0];
 252         }
 253       }
 254       return @tids;
 255     }
 256     else {
 257       croak 'login and password required';
 258     }
 259   }
 260 }
 261
 262 sub build {
 263   my $self = shift;
 264     my $content = { $self->content };
 265     my $skel = shift;
 266     my $data;
 267     if (ref($skel) ne 'HASH') { croak 'Failed to build non-hash' };
 268     foreach my $k (keys(%$skel)) {
 269       my $val = $skel->{$k};
 270       # Rules for building from the skeleton:
 271       # 1. If the value is a hashref, build it recursively.
 272       if(ref($val) eq 'HASH') {
 273         $data->{$k} = $self->build($val);
 274       }
 275       # 2. If the value starts with an underscore, it's treated as a method name.
 276       elsif($val =~ /^_/ and $self->can($val)) {
 277         $data->{$k} = $self->can($val)->($self);
 278       }
 279       # 3. If the value is undefined, keep it undefined.
 280       elsif(!defined($val)) {
 281         $data->{$k} = undef;
 282       }
 283       # 4. If the value is the name of a key in $self->content, look up that value.
 284     elsif(exists($content->{$val})) {
 285       $data->{$k} = $content->{$val};
 286     }
 287     # 5. If the value is a key in $defaults, use that value.
 288     elsif(exists($defaults->{$val})) {
 289       $data->{$k} = $defaults->{$val};
 290     }
 291     # 6. If the value is not required, use an empty string.
 292     elsif(! $required->{$val}) {
 293       $data->{$k} = '';
 294     }
 295     # 7. Fail.
 296     else {
 297       croak "Missing request field: '$val'";
 298     }
 299   }
 300   return $data;
 301 }
 302
 303 sub XML {
 304   # For testing build().
 305   my $self = shift;
 306   return XMLout($self->build($request), KeepRoot => 1);
 307 }
 308
 309 sub _payment_type {
 310   my $self = shift;
 311   my $action = $self->{_content}->{action};
 312   if(!defined($action) or $action =~ /^normal authorization$/i) {
 313     return 'debit';
 314   }
 315   elsif($action =~ /^credit$/i) {
 316     return 'credit';
 317   }
 318   else {
 319     return;
 320   }
 321 }
 322
 323 sub _check_type {
 324   my $self = shift;
 325   my $type = $self->{_content}->{account_type};
 326   return 'checking' if($type =~ /checking/i);
 327   return 'savings'  if($type =~ /savings/i);
 328   croak "Invalid account_type: '$type'";
 329 }
 330
 331 sub _full_name {
 332   my $self = shift;
 333   return join(' ',$self->{_content}->{first_name},$self->{_content}->{last_name});
 334 }
 335
 336 sub _start {
 337   my $self = shift;
 338   if($self->{_content}->{start}) {
 339     my $start = time2str('%Y-%m-%d', str2time($self->{_content}->{start}));
 340     croak "Invalid start date: '".$self->{_content}->{start} if !$start;
 341     return $start;
 342   }
 343   else {
 344     return time2str('%Y-%m-%d', time - 86400);
 345   }
 346 }
 347
 348 sub _end {
 349   my $self = shift;
 350   my $end = $self->{_content}->{end};
 351   if($end) {
 352     $end = time2str('%Y-%m-%d', str2time($end));
 353     croak "Invalid end date: '".$self->{_content}->{end} if !$end;
 354     return $end;
 355   }
 356   else {
 357     return time2str('%Y-%m-%d', time);
 358   }
 359 }
 360
 361 1;
 362 __END__
 363
 364 =head1 NAME
 365
 366 Business::OnlinePayment::WesternACH - Western ACH backend for Business::OnlinePayment
 367
 368 =head1 SYNOPSIS
 369
 370   use Business::OnlinePayment;
 371
 372   ####
 373   # Electronic check authorization.  We only support
 374   # 'Normal Authorization' and 'Credit'.
 375   ####
 376
 377   my $tx = new Business::OnlinePayment("WesternACH");
 378   $tx->content(
 379       type           => 'ECHECK',
 380       login          => 'testdrive',
 381       password       => 'testpass',
 382       action         => 'Normal Authorization',
 383       description    => 'Business::OnlinePayment test',
 384       amount         => '49.95',
 385       invoice_number => '100100',
 386       first_name     => 'Jason',
 387       last_name      => 'Kohles',
 388       address        => '123 Anystreet',
 389       city           => 'Anywhere',
 390       state          => 'UT',
 391       zip            => '84058',
 392       account_type   => 'personal checking',
 393       account_number => '1000468551234',
 394       routing_code   => '707010024',
 395       check_number   => '1001', # optional
 396   );
 397   $tx->submit();
 398
 399   if($tx->is_success()) {
 400       print "Check processed successfully: ".$tx->authorization."\n";
 401   } else {
 402       print "Check was rejected: ".$tx->error_message."\n";
 403   }
 404
 405   my $tx = new Business::OnlinePayment("WesternACH");
 406   $tx->content(
 407       login     => 'testdrive',
 408       password  => 'testpass',
 409       start     => '2009-06-25', # optional; defaults to yesterday
 410       end       => '2009-06-26', # optional; defaults to today
 411       );
 412   $tx->get_returns;
 413
 414
 415 =head1 SUPPORTED TRANSACTION TYPES
 416
 417 =head2 ECHECK
 418
 419 Content required: type, login, password|transaction_key, action, amount, first_name, last_name, account_number, routing_code, account_type.
 420
 421 =head1 DESCRIPTION
 422
 423 For detailed information see L<Business::OnlinePayment>.
 424
 425 =head1 METHODS AND FUNCTIONS
 426
 427 See L<Business::OnlinePayment> for the complete list. The following methods either override the methods in L<Business::OnlinePayment> or provide additional functions.
 428
 429 =head2 result_code
 430
 431 Currently returns nothing; these transactions don't seem to have result codes.
 432
 433 =head2 error_message
 434
 435 Returns the response reason text.  This can come from several locations in the response document or from certain local errors.
 436
 437 =head2 server_response
 438
 439 Returns the complete response from the server.
 440
 441 =head1 Handling of content(%content) data:
 442
 443 =head2 action
 444
 445 The following actions are valid:
 446
 447   normal authorization
 448   credit
 449
 450 =head1 AUTHOR
 451
 452 Mark Wells <mark@freeside.biz> with advice from Ivan Kohler <ivan-westernach@freeside.biz>.
 453
 454 =head1 SEE ALSO
 455
 456 perl(1). L<Business::OnlinePayment>.
 457
 458 =cut
 459