297 lines
12 KiB
Perl
297 lines
12 KiB
Perl
# ==================================================================
|
|
# Gossamer Links - enhanced directory management system
|
|
#
|
|
# Website : http://gossamer-threads.com/
|
|
# Support : http://gossamer-threads.com/scripts/support/
|
|
# CVS Info : 087,071,086,086,085
|
|
# Revision : $Id: PayPal.pm,v 1.16 2006/12/01 00:31:56 brewt Exp $
|
|
#
|
|
# Copyright (c) 2003 Gossamer Threads Inc. All Rights Reserved.
|
|
# Redistribution in part or in whole strictly prohibited. Please
|
|
# see LICENSE file for full details.
|
|
# ==================================================================
|
|
#
|
|
# Glue between Gossamer Links and PayPal IPN payment interface
|
|
|
|
package Links::Payment::Remote::PayPal;
|
|
use strict;
|
|
|
|
# Make sure the payment module is available
|
|
use GT::Payment::Remote::PayPal;
|
|
use Links qw/:objects/;
|
|
use Links::Payment qw/:status :log/;
|
|
use Links::SiteHTML;
|
|
use vars qw/%INVALID %EMPTY/;
|
|
|
|
sub required {
|
|
# -----------------------------------------------------------------------------
|
|
# Returns a list of required field names. Each field name will be looked for
|
|
# in the language hash, prefixed with 'PAYMENT_REMOTE_PayPal_', for the title
|
|
# of the field, and 'PAYMENT_REMOTE_DESC_PayPal_' for a description of the
|
|
# field's contents.
|
|
# Note that these are just required SETUP fields, so things like credit card
|
|
# number, billing name, etc. are NOT included.
|
|
my @currencies;
|
|
for (qw/USD CAD AUD EUR GBP JPY NZD CHF HKD SGD SEK DKK PLN NOK HUF CZK/) {
|
|
push @currencies, $_ => Links::language('PAYMENT_CURRENCY_' . $_);
|
|
}
|
|
|
|
my @buttons;
|
|
for (qw/23 cc 02 03 01 9 5 6/) {
|
|
push @buttons, "x-click-but$_.gif" => qq|<img src="https://www.paypal.com/images/x-click-but$_.gif">|;
|
|
}
|
|
|
|
my $custom = qq|Custom image:<br><input type="text" name="button_custom" size="60"|;
|
|
if ($CFG->{payment}->{remote}->{used}->{PayPal} and $CFG->{payment}->{remote}->{used}->{PayPal}->{button_custom}) {
|
|
$custom .= qq| value="$CFG->{payment}->{remote}->{used}->{PayPal}->{button_custom}"|;
|
|
}
|
|
$custom .= '>';
|
|
|
|
push @buttons, "custom" => $custom;
|
|
|
|
return
|
|
business_email => { type => 'TEXT', valid => '.@[a-zA-Z0-9-]' },
|
|
currency => {
|
|
type => 'SELECT',
|
|
options => \@currencies
|
|
},
|
|
button => {
|
|
type => 'RADIO',
|
|
options => \@buttons,
|
|
custom => 1,
|
|
valid => '^https?://[a-zA-Z0-9-]' # Only applies to the custom value
|
|
}
|
|
}
|
|
|
|
sub optional {
|
|
# -----------------------------------------------------------------------------
|
|
return
|
|
image_url => { type => 'TEXT', size => 60, value => '^https?://[a-zA-Z0-9-]' },
|
|
notify_url => { type => 'TEXT', size => '60', value => '^https?://[a-zA-Z0-9-]' },
|
|
note => { type => 'TEXT', size => 30, value => '^.{1,30}$' },
|
|
color => {
|
|
type => 'SELECT',
|
|
options => [
|
|
white => Links::language('PAYMENT_REMOTE_PayPal_color_white'),
|
|
black => Links::language('PAYMENT_REMOTE_PayPal_color_black')
|
|
]
|
|
},
|
|
to_email => { type => 'TEXT', valid => '.@[a-zA-Z0-9-]' },
|
|
sandbox => { type => 'YESNO' };
|
|
}
|
|
|
|
sub payment_info {
|
|
# -----------------------------------------------------------------------------
|
|
# Returns a hash of payment hints
|
|
#
|
|
my @fields = qw/business_email to_email currency button button_custom image_url notify_url note color sandbox/;
|
|
my $ret = {
|
|
fields => \@fields
|
|
};
|
|
if (my $pp = $CFG->{payment}->{remote}->{used}->{PayPal}) {
|
|
for (@fields) {
|
|
$ret->{$_ eq 'image_url' ? 'pp_image_url' : $_} = $pp->{$_};
|
|
}
|
|
}
|
|
return $ret;
|
|
}
|
|
|
|
sub verify {
|
|
# -----------------------------------------------------------------------------
|
|
# Checks that $IN, combined with the saved admin settings, makes up all of the
|
|
# required information. Returns 1 on success, or an array ref of invalid keys
|
|
# on failure.
|
|
return 1;
|
|
}
|
|
|
|
sub postback {
|
|
# -----------------------------------------------------------------------------
|
|
# Handle PayPal postback
|
|
my $unique = $IN->param('invoice');
|
|
my $pay = $DB->table('Payments');
|
|
my $log = $DB->table('PaymentLogs');
|
|
my $payment = $pay->get($unique) or return;
|
|
|
|
GT::Payment::Remote::PayPal::process(
|
|
param => $IN,
|
|
sandbox => $CFG->{payment}->{remote}->{used}->{PayPal}->{sandbox},
|
|
on_valid => sub {
|
|
# If taxes or shipping was added, then mc_gross may be greater than payments_amount.
|
|
if ($IN->param('mc_gross') < $payment->{payments_amount}) {
|
|
$log->insert({
|
|
paylogs_payments_id => $payment->{payments_id},
|
|
paylogs_type => LOG_ERROR,
|
|
paylogs_time => time,
|
|
paylogs_text => "Invalid payment (payment amount is less than original charge): " .
|
|
$IN->param('mc_gross') . " < " . $payment->{payments_amount}
|
|
});
|
|
return;
|
|
}
|
|
elsif ($IN->param('mc_currency') ne $CFG->{payment}->{remote}->{used}->{PayPal}->{currency}) {
|
|
$log->insert({
|
|
paylogs_payments_id => $payment->{payments_id},
|
|
paylogs_type => LOG_ERROR,
|
|
paylogs_time => time,
|
|
paylogs_text => "Invalid payment (different currency): " .
|
|
$IN->param('mc_currency') . " != " . $CFG->{payment}->{remote}->{used}->{PayPal}->{currency}
|
|
});
|
|
return;
|
|
}
|
|
|
|
return if $payment->{payments_status} == COMPLETED;
|
|
|
|
$pay->update(
|
|
{ payments_status => COMPLETED, payments_last => time },
|
|
{ payments_id => $payment->{payments_id} }
|
|
);
|
|
|
|
$log->insert({
|
|
paylogs_payments_id => $payment->{payments_id},
|
|
paylogs_type => LOG_ACCEPTED,
|
|
paylogs_time => time,
|
|
paylogs_text => (
|
|
sprintf(Links::language('PAYMENT_REMOTE_APPROVED') => 'PayPal') . "\n" .
|
|
"Transaction ID: " . $IN->param('txn_id') . "\n" .
|
|
"Amount: " . $IN->param('mc_currency') . " " . $IN->param('mc_gross') . " (Fee: "
|
|
. $IN->param('mc_currency') . " " . $IN->param('mc_fee') . ")\n" .
|
|
"Payer Email: " . $IN->param('payer_email') . "\n"
|
|
)
|
|
});
|
|
|
|
Links::Payment::process_payment($payment->{payments_linkid}, $payment->{payments_term});
|
|
},
|
|
on_pending => sub {
|
|
$pay->update({ payments_last => time }, { payments_id => $unique });
|
|
|
|
my $match = Links::language('PAYLOG_PayPal_' . $IN->param('pending_reason'));
|
|
my $str = $match ? Links::language('PAYLOG_PayPal_' . $IN->param('pending_reason')) : '';
|
|
$log->insert({
|
|
paylogs_payments_id => $payment->{payments_id},
|
|
paylogs_type => LOG_INFO,
|
|
paylogs_time => time,
|
|
paylogs_text => (
|
|
"Transaction ID: " . $IN->param('txn_id') . "\n" .
|
|
"Pending: " . ($match ? $str : scalar $IN->param('pending_reason'))
|
|
)
|
|
});
|
|
},
|
|
on_refund => sub {
|
|
$pay->update({ payments_last => time }, { payments_id => $unique });
|
|
|
|
$log->insert({
|
|
paylogs_payments_id => $payment->{payments_id},
|
|
paylogs_type => LOG_INFO,
|
|
paylogs_time => time,
|
|
paylogs_text => (
|
|
sprintf(Links::language('PAYMENT_REMOTE_REFUND') => 'PayPal') . "\n" .
|
|
"Transaction ID: " . $IN->param('txn_id') . "\n"
|
|
)
|
|
});
|
|
},
|
|
on_failed => sub {
|
|
$pay->update(
|
|
{ payments_status => DECLINED, payments_last => time },
|
|
{ payments_id => $payment->{payments_id} }
|
|
);
|
|
|
|
$log->insert({
|
|
paylogs_payments_id => $payment->{payments_id},
|
|
paylogs_type => LOG_DECLINED,
|
|
paylogs_time => time,
|
|
paylogs_text => "Transaction ID: " . $IN->param('txn_id')
|
|
});
|
|
},
|
|
on_denied => sub {
|
|
$pay->update(
|
|
{ payments_status => DECLINED, payments_last => time },
|
|
{ payments_id => $payment->{payments_id} }
|
|
);
|
|
|
|
$log->insert({
|
|
paylogs_payments_id => $payment->{payments_id},
|
|
paylogs_type => LOG_DECLINED,
|
|
paylogs_time => time,
|
|
paylogs_text => "Transaction ID: " . $IN->param('txn_id')
|
|
});
|
|
},
|
|
duplicate => sub {
|
|
my $id = $IN->param('txn_id');
|
|
my $cond = GT::SQL::Condition->new();
|
|
$cond->add(paylogs_payments_id => '=' => $unique);
|
|
$cond->add(paylogs_type => '=' => LOG_ACCEPTED);
|
|
$cond->add(paylogs_text => LIKE => "%\nTransaction ID: $id\n%");
|
|
my $found = $log->count($cond);
|
|
return $found ? undef : 1; # True if everything checks out; undef if a duplicate was found
|
|
},
|
|
email => sub {
|
|
my $email = shift;
|
|
return lc $email eq lc $CFG->{payment}->{remote}->{used}->{PayPal}->{business_email}
|
|
},
|
|
on_error => sub {
|
|
my $errmsg = shift;
|
|
$pay->update(
|
|
{ payments_status => ERROR, payments_last => time },
|
|
{ payments_id => $payment->{payments_id} }
|
|
);
|
|
|
|
$log->insert({
|
|
paylogs_payments_id => $payment->{payments_id},
|
|
paylogs_type => LOG_ERROR,
|
|
paylogs_time => time,
|
|
paylogs_text => $errmsg
|
|
});
|
|
},
|
|
on_recurring => sub {
|
|
if ($IN->param('mc_gross') < $payment->{payments_amount}) {
|
|
$log->insert({
|
|
paylogs_payments_id => $payment->{payments_id},
|
|
paylogs_type => LOG_ERROR,
|
|
paylogs_time => time,
|
|
paylogs_text => "Invalid payment (payment amount is less than original charge): " .
|
|
$IN->param('mc_gross') . " < " . $payment->{payments_amount}
|
|
});
|
|
return;
|
|
}
|
|
elsif ($IN->param('mc_currency') ne $CFG->{payment}->{remote}->{used}->{PayPal}->{currency}) {
|
|
$log->insert({
|
|
paylogs_payments_id => $payment->{payments_id},
|
|
paylogs_type => LOG_ERROR,
|
|
paylogs_time => time,
|
|
paylogs_text => "Invalid payment (different currency): " .
|
|
$IN->param('mc_currency') . " != " . $CFG->{payment}->{remote}->{used}->{PayPal}->{currency}
|
|
});
|
|
return;
|
|
}
|
|
|
|
$pay->update(
|
|
{ payments_status => COMPLETED, payments_last => time },
|
|
{ payments_id => $payment->{payments_id} }
|
|
);
|
|
|
|
$log->insert({
|
|
paylogs_payments_id => $payment->{payments_id},
|
|
paylogs_type => LOG_ACCEPTED,
|
|
paylogs_time => time,
|
|
paylogs_text => (
|
|
sprintf(Links::language('PAYMENT_REMOTE_APPROVED') => 'PayPal') . "\n" .
|
|
"Transaction ID: " . $IN->param('txn_id') . "\n" .
|
|
"Amount: " . $IN->param('mc_currency') . " " . $IN->param('mc_gross') . " (Fee: "
|
|
. $IN->param('mc_currency') . " " . $IN->param('mc_fee') . ")\n" .
|
|
"Payer Email: " . $IN->param('payer_email') . "\n" .
|
|
"Subscription ID: " . $IN->param('subscr_id') . "\n"
|
|
)
|
|
});
|
|
|
|
Links::Payment::process_payment($payment->{payments_linkid}, $payment->{payments_term}, 1);
|
|
}
|
|
);
|
|
|
|
# There is no way to distinguish between PayPal sending the user back, and
|
|
# PayPal posting the IPN, so we print a payment confirmation page.
|
|
print $IN->header;
|
|
print Links::SiteHTML::display('payment_success');
|
|
1;
|
|
}
|
|
|
|
1;
|