path: root/Paymentech.pm

package Business::BatchPayment::Paymentech;

use 5.006;
use strict;
use warnings;
our $VERSION = '0.08';

use Unicode::Truncate 'truncate_egc';

=head1 NAME

Business::BatchPayment::Paymentech - Chase Paymentech XML batch format.

=head1 USAGE

See L<Business::BatchPayment> for general usage notes.

=head2 SYNOPSIS

use Business::BatchPayment;

my @items = Business::BatchPayment::Item->new( ... );

my $processor = Business::BatchPayment->processor('Paymentech',
  merchantID    => '123456',
  bin           => '00001',
  terminalID    => '001',
  industryType  => 'EC'
  login         => 'TESTUSER',
  password      => 'MYPASS',
  with_recurringInd  => 1,
);

my $result = $processor->submit(@items);

=head2 REQUIREMENTS

Requires L<Net::SFTP::Foreign> and ssh (for file transfer) and the zip and
unzip programs.  Unlikely to work on non-Unix systems.

=head2 PROCESSOR ATTRIBUTES

=over 4

=item login - the username to use for SFTP, and in the "userID" tag

=item password - the password for SFTP, and for creating zip files

=item merchantID - your 6- or 12-digit Paymentech merchant ID

=item bin - your BIN: 000001 or 000002

=item terminalID - your 3-digit terminal ID

=item industryType - your 2-letter industry type code

=item with_recurringInd - enable the recurring charge indicator field

=back

=cut

use File::Temp qw(tempdir);
use DateTime;
use XML::Writer;
use XML::Simple;
use Try::Tiny;

use Moose;
with 'Business::BatchPayment::Processor';
with 'Business::BatchPayment::TestMode';

use Encode;

# could have some validation on all of these
has [ qw(merchantID terminalID bin industryType login password) ] => (
  is       => 'ro',
  isa      => 'Str',
  required => 1,
);

has 'with_recurringInd' => (
  is      => 'ro',
  isa     => 'Bool',
  default => 0,
);

has 'fileDateTime' => (
  is      => 'ro',
  isa     => 'Str',
  default => sub {
    DateTime->now->strftime('%Y%m%d%H%M%S')
  },
);

my %BankAcctType = (
  'personal checking' => 'C',
  'personal savings'  => 'S',
  'business checking' => 'X',
  'business savings'  => 'X',
);

my %paymentech_countries = map { $_ => 1 } qw( US CA GB UK );

sub default_transport {
  my $self = shift;
  Business::BatchPayment::Paymentech::Transport->new(
    login     => $self->login,
    password  => $self->password,
    debug     => $self->debug,
    test_mode => $self->test_mode,
  );
}

sub format_request {
  my $self = shift;
  my $batch = shift;

  my $output;
  my $xml = XML::Writer->new(
    OUTPUT      => \$output,
    DATA_MODE   => 1,
    DATA_INDENT => 2,
    ENCODING    => 'utf-8',
  );
  $self->format_header($batch, $xml);
  my $count = 1;
  foreach my $item ( @{ $batch->items } ) {
    try {
      $self->format_item($item, $batch, $xml, $count);
      $count++;
    } catch {
      $self->format_error($item, $_);
    };
  }
  $self->format_trailer($batch, $xml, $count);
  return $output;
}

sub format_header {
  my ($self, $batch, $xml) = @_;
  my $num_items = $batch->count;

  $xml->xmlDecl();
  $xml->startTag('transRequest', RequestCount => $num_items + 1);
  $xml->startTag('batchFileID');
  $xml->dataElement(userID => $self->login);
  $xml->dataElement(fileDateTime => $self->fileDateTime);
  $xml->dataElement(fileID => sprintf('%06d-', $batch->batch_id) . 
                              $self->fileDateTime);
  $xml->endTag('batchFileID');
}

sub format_item {
  my ($self, $item, $batch, $xml, $count) = @_;
  if ( $item->action eq 'payment' ) {
    $xml->startTag('newOrder', BatchRequestNo => $count);
    my @order = (
      industryType => $self->industryType,
      transType    => 'AC',
      bin          => $self->bin,
      merchantID   => $self->merchantID,
      terminalID   => $self->terminalID,
    );
    if ($item->payment_type eq 'CC') {
      my $expiration = $item->expiration;
      $expiration =~ s/\D//g;
      push @order, (
        ccAccountNum => $item->card_number,
        ccExp        => $expiration,
      );
    } elsif ( $item->payment_type eq 'ECHECK' ) {
      push @order, (
        cardBrand       => 'EC',
        ecpCheckRT      => $item->routing_code,
        ecpCheckDDA     => $item->account_number,
        ecpBankAcctType => $BankAcctType{ $item->account_type },
        ecpDelvMethod   => 'A',
      );
    } else {
      die "payment type ".$item->type." not supported";
    }
    if ( $self->with_recurringInd ) {
      if ( $item->recurring_billing eq 'F' ) {
        push @order, ( recurringInd => 'RF' );
      } elsif ( $item->recurring_billing eq 'S' ) {
        push @order, ( recurringInd => 'RS' );
      }
    } # else don't send recurringInd at all

    push @order, (                   # truncate_egc will die() on empty string
      avsZip      => $item->zip,
      avsAddress1 => $item->address  ? truncate_egc($item->address,  30, '') : undef,
      avsAddress2 => $item->address2 ? truncate_egc($item->address2, 30, '') : undef,
      avsCity     => $item->city     ? truncate_egc($item->city,     20, '') : undef,
      avsState    => $item->state    ? truncate_egc($item->state,     2, '') : undef,
      avsName     => ($item->first_name || $item->last_name)
                     ? truncate_egc($item->first_name.' '.$item->last_name, 30, '')
                     : undef,
      ( $paymentech_countries{ $item->country }
        ? ( avsCountryCode  => $item->country )
        : ()
      ),
      orderID        => $item->tid,
      amount         => int( $item->amount * 100 ),
    );
    while (@order) {
      my $key = shift @order;
      my $value = shift @order;
      $xml->dataElement($key, $value);
    }
    $xml->endTag('newOrder');
  } # if action eq 'payment'
  else {
    die "action ".$item->action." not supported";
  }
  '';
}

sub format_trailer {
  my ($self, $batch, $xml, $count) = @_;
  $xml->startTag('endOfDay', 'BatchRequestNo', $count);
  $xml->dataElement('bin' => $self->bin);
  $xml->dataElement('merchantID' => $self->merchantID);
  $xml->dataElement('terminalID' => $self->terminalID);
  $xml->endTag('endOfDay');
  $xml->endTag('transRequest');
}

sub parse_response {
  my $self = shift;
  my $input = shift;
  my $batch = Business::BatchPayment->create('Batch');
  
  my $tree = XML::Simple::XMLin($input, KeepRoot => 1);
  my $newOrderResp = $tree->{transResponse}->{newOrderResp};
  die "can't find <transResponse><newOrderResp> in input"
    unless defined $newOrderResp;

  $newOrderResp = [ $newOrderResp ] if ref($newOrderResp) ne 'ARRAY';
  foreach my $resp (@$newOrderResp) {
    try {
      $batch->push( $self->parse_item($resp) );
    } catch {
      # parse_error needs a string representation of the 
      # input data...and if it 's failing because it wasn't valid
      # XML, we wouldn't get this far.
      $self->parse_error(XML::Simple::XMLout($resp), $_);
    };
  }
  $batch;
}

sub parse_item {
  my ($self, $resp) = @_;

  my ($mon, $day, $year, $hour, $min, $sec) =
  $resp->{respDateTime} =~ /^(..)(..)(....)(..)(..)(..)$/;
  my $dt = DateTime->new(
    year    => $year,
    month   => $mon,
    day     => $day,
    hour    => $hour,
    minute  => $min,
    second  => $sec,
  );

  my %failure_status = (
    # API version 2.6, April 2013
    '00'  => undef,       # Approved
    '04'  => 'pickup',
    '33'  => 'expired',
    '41'  => 'stolen',
    '42'  => 'inactive',
    '43'  => 'stolen',
    '44'  => 'inactive',
    'B7'  => 'blacklisted', # Fraud
    'B9'  => 'blacklisted', # On Negative File
    'BB'  => 'stolen',      # Possible Compromise
    'BG'  => 'blacklisted', # Blocked Account
    'BQ'  => 'blacklisted', # Issuer has Flagged Account as Suspected Fraud
    'C4'  => 'nsf',         # Over Credit Limit
    'D5'  => 'blacklisted', # On Negative File
    'D7'  => 'nsf',         # Insufficient Funds
    'F3'  => 'inactive',    # Account Closed
    'K6'  => 'nsf',         # NSF
  ); # all others are "decline"

  my $failure_status = undef;
  my $error_message;

  if ( $resp->{procStatus} ) {
    $error_message = $resp->{procStatusMessage};
  } elsif ( $resp->{respCode} ) {
    $error_message = $resp->{respCodeMessage};
    $failure_status = $failure_status{ $resp->{respCode} } || 'decline';
  } else {
    $error_message = '';
  }

  my $item = Business::BatchPayment->create(Item =>
    tid           => $resp->{orderID},
    process_date  => $dt,
    authorization => $resp->{authorizationCode},
    order_number  => $resp->{txRefNum},
    approved      => ($resp->{approvalStatus} == 1),
    error_message => $error_message,
    failure_status  => $failure_status,
  );
  $item;
}

# DEPRECATED

# sub bytes_substr {
#   my ($string, $offset, $length, $repl) = @_;
#   my $bytes = substr(
#     Encode::encode('utf8', $string || ''),
#     $offset,
#     $length,
#     Encode::encode('utf8', $repl || '')
#   );
#   return Encode::decode('utf8', $bytes, Encode::FB_QUIET);
# }


package Business::BatchPayment::Paymentech::Transport;

use File::Temp qw( tempdir );
use File::Slurp qw( read_file write_file );
use Moose;
use Moose::Util::TypeConstraints;
extends 'Business::BatchPayment::Transport::SFTP';
with 'Business::BatchPayment::TestMode';

has '+host' => (
  default => sub { 
    my $self = shift;
    $self->test_mode ? 'orbitalbatchvar.paymentech.net'
                     : 'orbitalbatch.paymentech.net'
  },
  lazy => 1,
);

subtype 'Writeable',
  as 'Maybe[Str]',
  where { !defined($_) or ( -d $_ and -w $_ ) },
  message { "can't write to '$_'" };

has 'archive_to' => ( 
  is => 'rw',
  isa => 'Writeable'
);

# batch content passed as an argument

sub upload {
  local $@;
  my $self = shift;
  my $content = shift;
  my $tmpdir = tempdir( CLEANUP => 1 );
  $content =~ /<fileID>(.*)<\/fileID>/;
  my $filename = $1;
  my $archive_dir = $self->archive_to;

  warn "Writing temp file to $tmpdir/$filename.xml.\n" if $self->debug;
  write_file("$tmpdir/$filename.xml", $content);

  warn "Creating zip file.\n" if $self->debug;
  my @args = (
    '-P',
    $self->password,
    '-j',
    "$tmpdir/$filename.zip",
    "$tmpdir/$filename.xml",
  );
  unshift @args, '-q' unless $self->debug;
  system('zip', @args);
  die "failed to create zip file" if (! -f "$tmpdir/$filename.zip");

  warn "Uploading.\n" if $self->debug;
  $self->put("$tmpdir/$filename.zip", "$filename.zip");
  return;
};

sub download {
  local $@;
  my $self = shift;
  my $tmpdir = tempdir( CLEANUP => 1 );
  my $ls_info = $self->ls('.', wanted => qr/_resp\.zip$/);
  my $archive_dir = $self->archive_to;
  my @batches;
  foreach (@$ls_info) {
    my $filename = $_->{filename}; # still ends in _resp
    $filename =~ s/\.zip$//;
    warn "Retrieving $filename.zip\n" if $self->debug;
    $self->get("$filename.zip", "$tmpdir/$filename.zip");

    my @args = (
      '-P',
      $self->password,
      "$tmpdir/$filename.zip",
      '-d',
      $tmpdir,
    );
    unshift @args, '-q' unless $self->debug;
    system('unzip', @args);
    if (! -f "$tmpdir/$filename.xml") {
      warn "failed to extract $filename.xml from $filename.zip\n";
      next;
    }
    my $content = read_file("$tmpdir/$filename.xml");
    if ( $archive_dir ) {
      warn "Copying $tmpdir/$filename.xml to archive dir $archive_dir\n";
      write_file("$archive_dir/$filename.xml", $content);
    }
    push @batches, $content;
  }
  @batches;
}

sub _info {
  {
    'info_compat'         => '0.01',
    'gateway_name'        => 'Paymentech',
    'gateway_url'         => 'http://www.chasepaymentech.com/',
    'module_version'      => $VERSION,
    'supported_types'     => [ qw( CC ECHECK ) ],
    'token_support'       => 0,
    'test_transaction'    => 1,
    'supported_actions'   => [ 'Payment' ],
  }
}

=head1 AUTHOR

Mark Wells, C<< <mark at freeside.biz> >>

=head1 BUGS

Relying on external zip/unzip is awkward.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Business::BatchPayment::Paymentech

Commercial support is available from Freeside Internet Services, Inc.

L<http://www.freeside.biz>

=head1 ACKNOWLEDGEMENTS

=head1 LICENSE AND COPYRIGHT

Copyright 2012 Mark Wells.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of Business::BatchPayment::Paymentech