BillBuddy.pm

   1 package Business::BatchPayment::BillBuddy;
   2
   3 use strict;
   4
   5 use Business::BatchPayment;
   6 use Moose;
   7 with 'Business::BatchPayment::Processor';
   8
   9 our $VERSION = '0.01';
  10
  11 has [ qw(user_id api_key host) ] => (
  12    is  => 'ro',
  13    isa => 'Str',
  14    required => 1,
  15 );
  16
  17 has 'path' => (
  18    is  => 'ro',
  19    isa => 'Str',
  20    default => '/',
  21 );
  22
  23 has 'port' => (
  24    is  => 'ro',
  25    isa => 'Str',
  26    default => '443',
  27 );
  28
  29 sub default_transport {
  30   my $self = shift;
  31   Business::BatchPayment->create('BillBuddy::Transport',
  32     user_id       => $self->user_id,
  33     api_key       => $self->api_key,
  34     host          => $self->host,
  35     port          => $self->port,
  36     path          => $self->path,
  37     debug         => $self->debug,
  38   );
  39 }
  40
  41 sub format_item {
  42   my ($self,$item,$batch) = @_;
  43   #Position Length Content
  44   #1-1 1 "D"
  45   my $line = 'D';
  46   #2-17 16 Reference Number
  47   $line .= sprintf("%-16s",$item->tid);
  48   #18-18 1 blank, filled with space
  49   $line .= ' ';
  50   #19-28 10 amount, numbers only, by cents, zero padded to the left
  51   $line .= sprintf("%10s",$item->amount * 100);
  52   #29-30 2 blank, filled with spaces
  53   $line .= '  ';
  54   #31-32 2 account type: "BC" for bank account, "CC" for credit card account
  55   my $pt = $item->payment_type;
  56   if ($pt eq 'CC') {
  57     #we currently don't support CC, but leaving the code in place for future development
  58     die 'Business::BatchPayment::BillBuddy currently does not handle credit card transactions';
  59     $line .= 'CC';
  60   } elsif ($pt eq 'ECHECK') {
  61     $line .= 'BC';
  62   } else {
  63     die "Unknown payment type";
  64   }
  65   #33-33 1 blank
  66   $line .= ' ';
  67   #34-40 7 BSB for bank account, formatted in 000-000. blank for credit card account
  68   my $bsb = ($pt eq 'CC') ? sprintf("%7s",'') : $item->routing_code;
  69   $bsb =~ s/^(\d{3})(\d{3})/$1\-$2/;
  70   die "Bad routing code $bsb" if ($pt ne 'CC') && ($bsb !~ /^\d{3}\-\d{3}$/);
  71   $line .= $bsb;
  72   #41-41 1 blank
  73   $line .= ' ';
  74   #42-50 9 Account number for bank accounts. blank for credit card account
  75   my $anum = ($pt eq 'CC') ? sprintf("%9s",'') : sprintf("%09s",$item->account_number);
  76   $line .= $anum;
  77   #51-66 16 credit card number, left padded with zero if less than 16 digits. Blank for bank accounts
  78   my $cnum = ($pt eq 'CC') ? sprintf("%016s",$item->card_number) : sprintf("%16s",'');
  79   $line .= $cnum;
  80   #67-98 32 bank account name or name on the credit card
  81   my $name = $item->first_name . ' ' . $item->last_name;
  82   $line .= sprintf("%-32.32s",$name);
  83   #99-99 1 blank
  84   $line .= ' ';
  85   #100-103 4 credit card expiry date, formatted as mmdd. "0000" for bank account.
  86   my $exp = ($pt eq 'CC') ? $item->expiration : '';
  87   $line .= sprintf("%04s",$exp);
  88   #104-104 1 blank
  89   #105-111 7 reserved, always "0000000"
  90   #112-114 3 reserved, blank
  91   $line .= ' 0000000   ';
  92   #115-120 6 line number, left padded with zero
  93   $line .= sprintf("%06s",$batch->num);
  94   $line .= "\n";
  95   return $line;
  96 }
  97
  98 #overriding this just to be able to pass batch to upload
  99 #but maybe this should go in standard module?
 100 sub submit {
 101   my $self = shift;
 102   my $batch = shift;
 103   my $request = $self->format_request($batch);
 104   warn $request if $self->debug >= 2;
 105   $self->transport->upload($request,$batch);
 106 }
 107
 108 #overriding this to pass process_ids to download,
 109 #but maybe this should go in standard module?
 110 sub receive {
 111   my $self = shift;
 112   return $self->transport->download(@_);
 113 }
 114
 115 package Business::BatchPayment::BillBuddy::Transport;
 116
 117 use XML::Simple qw(:strict);
 118 use XML::Writer;
 119
 120 use Moose;
 121 extends 'Business::BatchPayment::Transport::HTTPS';
 122
 123 has [ qw(user_id api_key) ] => (
 124    is  => 'ro',
 125    isa => 'Str',
 126    required => 1,
 127 );
 128
 129 has 'path' => (
 130    is  => 'ro',
 131    isa => 'Str',
 132    default => '',
 133 );
 134
 135 has 'debug' => (
 136   is => 'rw',
 137   isa => 'Int',
 138   default => 0,
 139 );
 140
 141 # this is really specific to BillBuddy, not a generic XML formatting routine
 142 sub xml_format {
 143   my ($self,$sid,@param) = @_;
 144   my $out;
 145   my $xml = XML::Writer->new(
 146     OUTPUT   => \$out,
 147     ENCODING => 'UTF-8',
 148   );
 149   $xml->startTag('postdata');
 150   $xml->dataElement('sessionid',$sid);
 151   $xml->dataElement('clientidentifier','');
 152   $xml->startTag('parameters');
 153   foreach my $param (@param) {
 154     if (ref($param) eq 'ARRAY') {
 155       my $type  = $$param[0];
 156       my $value = $$param[1];
 157       $xml->$type('parameter',$value);
 158     } else {
 159       $xml->dataElement('parameter',$param);
 160     }
 161   }
 162   $xml->endTag('parameters');
 163   $xml->endTag('postdata');
 164   $xml->end();
 165   return $out;
 166 }
 167
 168 # also specific to BillBuddy, doesn't actually follow XMLRPC standard for response
 169 sub xmlrpc_post {
 170   my ($self,$func,$sid,@param) = @_;
 171   my $path = $self->path;
 172   $path = '/' . $path unless $path =~ /^\//;
 173   $path .= '/' unless $path =~ /\/$/;
 174   $path .= $func;
 175   my $xmlcontent = $self->xml_format($sid,@param);
 176   warn $self->host . ' ' . $self->port . ' ' . $path . "\n" . $xmlcontent if $self->debug;
 177   my ($response, $rcode, %rheaders) = $self->https_post($path,$xmlcontent);
 178   die "Bad response from gateway: $rcode" unless $rcode eq '200 OK';
 179   warn $response . "\n" if $self->debug;
 180   my $rref = XMLin($response, KeyAttr => ['ResponseData'], ForceArray => []);
 181   die "Error from gateway: " . $rref->{'ResponseStatusDescription'} if $rref->{'ResponseStatus'};
 182   return $rref;
 183 }
 184
 185 #gets date from batch & sets processor_id in batch
 186 sub upload {
 187   my ($self,$request,$batch) = @_;
 188   my @tokens = ();
 189   # get date from batch
 190   my ($date) = $batch->process_date =~ /^(....-..-..)/;
 191   # login
 192   my $resp = $self->xmlrpc_post('xmlrpc_tp_Login.asp','',$self->user_id,$self->api_key);
 193   my $sid = $resp->{'ResponseData'}->{'sessionID'};
 194   die "Could not parse sessionid from gateway response" unless $sid;
 195   # start a payment batch
 196   $resp = $self->xmlrpc_post('xmlrpc_tp_DDRBatch_Open.asp',$sid,$self->user_id,$date);
 197   my $batchno = $resp->{'ResponseData'}->{'batchno'};
 198   die "Could not parse batchno from gateway response" unless $batchno;
 199   $batch->processor_id($batchno);
 200   # post a payment transaction
 201   foreach my $line (split(/\n/,$request)) {
 202     $self->xmlrpc_post('xmlrpc_tp_DDRTransaction_Add.asp',$sid,$self->user_id,$batchno,['cdataElement',$line]);
 203   }
 204   # close payment batch
 205   $self->xmlrpc_post('xmlrpc_tp_DDRBatch_Close.asp',$sid,$self->user_id,$batchno);
 206   # submit payment batch
 207   $self->xmlrpc_post('xmlrpc_tp_DDRBatch_Submit.asp',$sid,$self->user_id,$batchno);
 208   # logout
 209   $self->xmlrpc_post('xmlrpc_tp_Logout.asp',$sid,$self->user_id);
 210   return '';
 211 }
 212
 213 # caution--this method developed without access to completed test payments
 214 # built with best guesses, cross your fingers...
 215 sub download {
 216   my $self = shift;
 217   my @processor_ids = @_;
 218   return () unless @processor_ids;
 219   # login
 220   my $resp = $self->xmlrpc_post('xmlrpc_tp_Login.asp','',$self->user_id,$self->api_key);
 221   my $sid = $resp->{'ResponseData'}->{'sessionID'};
 222   die "Could not parse sessionid from gateway response" unless $sid;
 223   my @batches = ();
 224   foreach my $batchno (@processor_ids) {
 225     #get BillBuddy transaction ids for batch
 226     $resp = $self->xmlrpc_post('xmlrpc_tp_DDRBatch_getTranList.asp',$sid,$self->user_id,$batchno);
 227     my $tids = $resp->{'ResponseData'}->{'id'};
 228     next unless $tids; #error/die instead?
 229     my @batchitems = ();
 230     $tids = ref($tids) ? $tids : [ $tids ];
 231     #get status by individual transaction
 232     foreach my $tid (@$tids) {
 233       $resp = $self->xmlrpc_post('xmlrpc_tp_DDRBatch_getTranStatus.asp',$sid,$self->user_id,$tid);
 234       my $status = lc($resp->{'ResponseData'}->{'bankprocessstatus'});
 235       my $error = '';
 236       next if grep(/^$status$/,('submitted','processing','scheduled'));
 237       $error = "Unknown return status: $status"
 238         unless grep(/^$status$/,('deleted','declined'));
 239       my $item = Business::BatchPayment->create(Item =>
 240         order_number  => $tid,
 241         tid           => $resp->{'ResponseData'}->{'referencenumber'},
 242         approved      => ($status eq 'approved') ? 1 : 0,
 243         error_message => $error,
 244         authorization => '',
 245       );
 246       #not sure what format date gets returned in, item creation will fail on bad format,
 247       #so I'm taking a guess, and not recording the date if my guess is wrong
 248       if ($resp->{'ResponseData'}->{'actualprocessdate'} =~ /^(\d\d\d\d).(\d\d).(\d\d)/) {
 249         $item->payment_date($1.'-'.$2.'-'.$3);
 250       }
 251       push(@batchitems,$item);
 252     }
 253     if (@batchitems) {
 254       push(@batches, Business::BatchPayment->create('Batch', items => \@batchitems));
 255     }
 256   }
 257   # logout
 258   $self->xmlrpc_post('xmlrpc_tp_Logout.asp',$sid,$self->user_id);
 259   return @batches;
 260 }
 261
 262 1;
 263