From 345ca8a07149af7c04112fa227d443f75261dfca Mon Sep 17 00:00:00 2001 From: Jonathan Prykop Date: Tue, 31 Mar 2015 13:45:58 -0500 Subject: [PATCH] As stable as I can make it without a real test environment, needs documentation --- BillBuddy.pm | 263 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Makefile.PL | 19 +++++ 2 files changed, 282 insertions(+) create mode 100644 BillBuddy.pm create mode 100755 Makefile.PL diff --git a/BillBuddy.pm b/BillBuddy.pm new file mode 100644 index 0000000..3704c84 --- /dev/null +++ b/BillBuddy.pm @@ -0,0 +1,263 @@ +package Business::BatchPayment::BillBuddy; + +use strict; + +use Business::BatchPayment; +use Moose; +with 'Business::BatchPayment::Processor'; + +our $VERSION = '0.01'; + +has [ qw(user_id api_key host) ] => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +has 'path' => ( + is => 'ro', + isa => 'Str', + default => '/', +); + +has 'port' => ( + is => 'ro', + isa => 'Str', + default => '443', +); + +sub default_transport { + my $self = shift; + Business::BatchPayment->create('BillBuddy::Transport', + user_id => $self->user_id, + api_key => $self->api_key, + host => $self->host, + port => $self->port, + path => $self->path, + debug => $self->debug, + ); +} + +sub format_item { + my ($self,$item,$batch) = @_; + #Position Length Content + #1-1 1 "D" + my $line = 'D'; + #2-17 16 Reference Number + $line .= sprintf("%-16s",$item->tid); + #18-18 1 blank, filled with space + $line .= ' '; + #19-28 10 amount, numbers only, by cents, zero padded to the left + $line .= sprintf("%10s",$item->amount * 100); + #29-30 2 blank, filled with spaces + $line .= ' '; + #31-32 2 account type: "BC" for bank account, "CC" for credit card account + my $pt = $item->payment_type; + if ($pt eq 'CC') { + #we currently don't support CC, but leaving the code in place for future development + die 'Business::BatchPayment::BillBuddy currently does not handle credit card transactions'; + $line .= 'CC'; + } elsif ($pt eq 'ECHECK') { + $line .= 'BC'; + } else { + die "Unknown payment type"; + } + #33-33 1 blank + $line .= ' '; + #34-40 7 BSB for bank account, formatted in 000-000. blank for credit card account + my $bsb = ($pt eq 'CC') ? sprintf("%7s",'') : $item->routing_code; + $bsb =~ s/^(\d{3})(\d{3})/$1\-$2/; + die "Bad routing code $bsb" if ($pt ne 'CC') && ($bsb !~ /^\d{3}\-\d{3}$/); + $line .= $bsb; + #41-41 1 blank + $line .= ' '; + #42-50 9 Account number for bank accounts. blank for credit card account + my $anum = ($pt eq 'CC') ? sprintf("%9s",'') : sprintf("%09s",$item->account_number); + $line .= $anum; + #51-66 16 credit card number, left padded with zero if less than 16 digits. Blank for bank accounts + my $cnum = ($pt eq 'CC') ? sprintf("%016s",$item->card_number) : sprintf("%16s",''); + $line .= $cnum; + #67-98 32 bank account name or name on the credit card + my $name = $item->first_name . ' ' . $item->last_name; + $line .= sprintf("%-32.32s",$name); + #99-99 1 blank + $line .= ' '; + #100-103 4 credit card expiry date, formatted as mmdd. "0000" for bank account. + my $exp = ($pt eq 'CC') ? $item->expiration : ''; + $line .= sprintf("%04s",$exp); + #104-104 1 blank + #105-111 7 reserved, always "0000000" + #112-114 3 reserved, blank + $line .= ' 0000000 '; + #115-120 6 line number, left padded with zero + $line .= sprintf("%06s",$batch->num); + $line .= "\n"; + return $line; +} + +#overriding this just to be able to pass batch to upload +#but maybe this should go in standard module? +sub submit { + my $self = shift; + my $batch = shift; + my $request = $self->format_request($batch); + warn $request if $self->debug >= 2; + $self->transport->upload($request,$batch); +} + +#overriding this to pass process_ids to download, +#but maybe this should go in standard module? +sub receive { + my $self = shift; + return $self->transport->download(@_); +} + +package Business::BatchPayment::BillBuddy::Transport; + +use XML::Simple qw(:strict); +use XML::Writer; + +use Moose; +extends 'Business::BatchPayment::Transport::HTTPS'; + +has [ qw(user_id api_key) ] => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +has 'path' => ( + is => 'ro', + isa => 'Str', + default => '', +); + +has 'debug' => ( + is => 'rw', + isa => 'Int', + default => 0, +); + +# this is really specific to BillBuddy, not a generic XML formatting routine +sub xml_format { + my ($self,$sid,@param) = @_; + my $out; + my $xml = XML::Writer->new( + OUTPUT => \$out, + ENCODING => 'UTF-8', + ); + $xml->startTag('postdata'); + $xml->dataElement('sessionid',$sid); + $xml->dataElement('clientidentifier',''); + $xml->startTag('parameters'); + foreach my $param (@param) { + if (ref($param) eq 'ARRAY') { + my $type = $$param[0]; + my $value = $$param[1]; + $xml->$type('parameter',$value); + } else { + $xml->dataElement('parameter',$param); + } + } + $xml->endTag('parameters'); + $xml->endTag('postdata'); + $xml->end(); + return $out; +} + +# also specific to BillBuddy, doesn't actually follow XMLRPC standard for response +sub xmlrpc_post { + my ($self,$func,$sid,@param) = @_; + my $path = $self->path; + $path = '/' . $path unless $path =~ /^\//; + $path .= '/' unless $path =~ /\/$/; + $path .= $func; + my $xmlcontent = $self->xml_format($sid,@param); + warn $self->host . ' ' . $self->port . ' ' . $path . "\n" . $xmlcontent if $self->debug; + my ($response, $rcode, %rheaders) = $self->https_post($path,$xmlcontent); + die "Bad response from gateway: $rcode" unless $rcode eq '200 OK'; + warn $response . "\n" if $self->debug; + my $rref = XMLin($response, KeyAttr => ['ResponseData'], ForceArray => []); + die "Error from gateway: " . $rref->{'ResponseStatusDescription'} if $rref->{'ResponseStatus'}; + return $rref; +} + +#gets date from batch & sets processor_id in batch +sub upload { + my ($self,$request,$batch) = @_; + my @tokens = (); + # get date from batch + my ($date) = $batch->process_date =~ /^(....-..-..)/; + # login + my $resp = $self->xmlrpc_post('xmlrpc_tp_Login.asp','',$self->user_id,$self->api_key); + my $sid = $resp->{'ResponseData'}->{'sessionID'}; + die "Could not parse sessionid from gateway response" unless $sid; + # start a payment batch + $resp = $self->xmlrpc_post('xmlrpc_tp_DDRBatch_Open.asp',$sid,$self->user_id,$date); + my $batchno = $resp->{'ResponseData'}->{'batchno'}; + die "Could not parse batchno from gateway response" unless $batchno; + $batch->processor_id($batchno); + # post a payment transaction + foreach my $line (split(/\n/,$request)) { + $self->xmlrpc_post('xmlrpc_tp_DDRTransaction_Add.asp',$sid,$self->user_id,$batchno,['cdataElement',$line]); + } + # close payment batch + $self->xmlrpc_post('xmlrpc_tp_DDRBatch_Close.asp',$sid,$self->user_id,$batchno); + # submit payment batch + $self->xmlrpc_post('xmlrpc_tp_DDRBatch_Submit.asp',$sid,$self->user_id,$batchno); + # logout + $self->xmlrpc_post('xmlrpc_tp_Logout.asp',$sid,$self->user_id); + return ''; +} + +# caution--this method developed without access to completed test payments +# built with best guesses, cross your fingers... +sub download { + my $self = shift; + my @processor_ids = @_; + return () unless @processor_ids; + # login + my $resp = $self->xmlrpc_post('xmlrpc_tp_Login.asp','',$self->user_id,$self->api_key); + my $sid = $resp->{'ResponseData'}->{'sessionID'}; + die "Could not parse sessionid from gateway response" unless $sid; + my @batches = (); + foreach my $batchno (@processor_ids) { + #get BillBuddy transaction ids for batch + $resp = $self->xmlrpc_post('xmlrpc_tp_DDRBatch_getTranList.asp',$sid,$self->user_id,$batchno); + my $tids = $resp->{'ResponseData'}->{'id'}; + next unless $tids; #error/die instead? + my @batchitems = (); + $tids = ref($tids) ? $tids : [ $tids ]; + #get status by individual transaction + foreach my $tid (@$tids) { + $resp = $self->xmlrpc_post('xmlrpc_tp_DDRBatch_getTranStatus.asp',$sid,$self->user_id,$tid); + my $status = lc($resp->{'ResponseData'}->{'bankprocessstatus'}); + my $error = ''; + next if grep(/^$status$/,('submitted','processing','scheduled')); + $error = "Unknown return status: $status" + unless grep(/^$status$/,('deleted','declined')); + my $item = Business::BatchPayment->create(Item => + order_number => $tid, + tid => $resp->{'ResponseData'}->{'referencenumber'}, + approved => ($status eq 'approved') ? 1 : 0, + error_message => $error, + authorization => '', + ); + #not sure what format date gets returned in, item creation will fail on bad format, + #so I'm taking a guess, and not recording the date if my guess is wrong + if ($resp->{'ResponseData'}->{'actualprocessdate'} =~ /^(\d\d\d\d).(\d\d).(\d\d)/) { + $item->payment_date($1.'-'.$2.'-'.$3); + } + push(@batchitems,$item); + } + if (@batchitems) { + push(@batches, Business::BatchPayment->create('Batch', items => \@batchitems)); + } + } + # logout + $self->xmlrpc_post('xmlrpc_tp_Logout.asp',$sid,$self->user_id); + return @batches; +} + +1; + diff --git a/Makefile.PL b/Makefile.PL new file mode 100755 index 0000000..5ea48da --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,19 @@ +#!/usr/bin/perl + +use 5.006; +use strict; +use warnings; +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Business::BatchPayment::BillBuddy', + AUTHOR => q{Jonathan Prykop }, + VERSION_FROM => 'BillBuddy.pm', + PREREQ_PM => { + 'Moose' => 1.09, + 'Business::BatchPayment' => 0.02, + 'XML::Simple' => 0, + 'XML::Writer' => 0, + }, +); + -- 2.11.0