package Business::OnlinePayment::InternetSecure;

use 5.008;
use strict;
use warnings;

use Carp;
use Encode;
use Net::SSLeay qw(make_form post_https);
use XML::Simple qw(xml_in xml_out);

use base qw(Business::OnlinePayment Exporter);


our $VERSION = '0.01';


use constant CARD_TYPES => {
				VI => 'Visa',
				MC => 'MasterCard',
				AX => 'American Express',
				NN => 'Discover',
			};


# Convenience functions to avoid undefs and escape products strings
sub _def($) { defined $_[0] ? $_[0] : '' }
sub _esc($) { local $_ = shift; tr/|:/ /s; tr/"`/'/s; return $_ }


sub set_defaults {
	my ($self) = @_;

	$self->server('secure.internetsecure.com');
	$self->port(443);
	$self->path('/process.cgi');

	$self->build_subs(qw(
				receipt_number	sales_order_number
				cardholder	card_type
				total_amount
				avs_response	cvv2_response
			));
}

# OnlinePayment's remap_fields is buggy, so we simply rewrite it
#
sub remap_fields {
	my ($self, %map) = @_;

	my %content = $self->content();
	foreach (keys %map) {
		$content{$map{$_}} = delete $content{$_};
	}
	$self->content(%content);
}

# Combine get_fields and remap_fields for convenience
#
sub get_remap_fields {
	my ($self, %map) = @_;

	$self->remap_fields(reverse %map);
	my %data = $self->get_fields(keys %map);

	foreach (values %data) {
		$_ = '' unless defined;
	}

	return %data;
}

# Since there's no standard format for expiration dates, we try to do our best
#
sub parse_expdate {
	my ($self, $str) = @_;

	local $_ = $str;

	my ($y, $m);

	if (/^(\d{4})\W(\d{1,2})$/ ||		# 2004.07  or  2004-7
			/^(\d\d)\W(\d)$/ ||	# 04/7
			/^(\d\d)[.-](\d\d)$/) {	# 04-07
		($y, $m) = ($1, $2);
	} elsif (/^(\d{1,2})\W(\d{4})$/ ||	# 07-2004  or  7/2004
			/^(\d)\W(\d\d)$/ ||	# 7/04
			/^(\d\d)\/(\d\d)$/) {	# 07/04
		($y, $m) = ($2, $1);
	} else {
		croak "Unable to parse expiration date: $str";
	}

	$y += 2000 if $y < 2000;  # Aren't we glad Y2K is behind us?

	return ($y, $m);
}

# Convert a single product into a product string
#
sub prod_string {
	my ($self, $currency, $taxes, %data) = @_;

	croak "Missing amount in product" unless defined $data{amount};

	my @flags = ($currency);

	$taxes = uc $data{taxes} if defined $data{taxes};
	foreach (split ' ' => $taxes) {
		croak "Unknown tax code $_" unless /^(GST|PST|HST)$/;
		push @flags, $_;
	}

	if ($self->test_transaction) {
		push @flags, $self->test_transaction < 0 ? 'TESTD' : 'TEST';
	}

	return join '::' =>
				sprintf('%.2f' => $data{amount}),
				$data{quantity} || 1,
				_esc _def $data{sku},
				_esc _def $data{description},
				join('' => map "{$_}" => @flags),
				;
}

# Generate the XML document for this transaction
#
sub to_xml {
	my ($self) = @_;

	my %content = $self->content;

	$self->required_fields(qw(action card_number exp_date));

	croak 'Unsupported transaction type'
		if $content{type} && $content{type} !~
			/^(Visa|MasterCard|American Express|Discover)$/i;
	
	croak 'Unsupported action'
		unless $content{action} =~ /^Normal Authori[zs]ation$/i;
	
	$content{currency} ||= 'CAD';
	$content{currency} = uc $content{currency};
	croak "Unknown currency code ", $content{currency}
		unless $content{currency} =~ /^(CAD|USD)$/;
	
	$content{taxes} ||= '';
	$content{taxes} = uc $content{taxes};

	my %data = $self->get_remap_fields(qw(
			xxxCardNumber		card_number

			xxxName			name
			xxxCompany		company
			xxxAddress		address
			xxxCity			city
			xxxProvince		state
			xxxPostal		zip
			xxxCountry		country
			xxxPhone		phone
			xxxEmail		email

			xxxShippingName		ship_name
			xxxShippingCompany	ship_company
			xxxShippingAddress	ship_address
			xxxShippingCity		ship_city
			xxxShippingProvince	ship_state
			xxxShippingPostal	ship_zip
			xxxShippingCountry	ship_country
			xxxShippingPhone	ship_phone
			xxxShippingEmail	ship_email
		));
	
	$data{MerchantNumber} = $self->merchant_id;

	$data{xxxCardNumber} =~ tr/ //d;

	my ($y, $m) = $self->parse_expdate($content{exp_date});
	$data{xxxCCYear} = sprintf '%.4u' => $y;
	$data{xxxCCMonth} = sprintf '%.2u' => $m;

	if (defined $content{cvv2} && $content{cvv2} ne '') {
		$data{CVV2} = 1;
		$data{CVV2Indicator} = $content{cvv2};
	} else {
		$data{CVV2} = 0;
		$data{CVV2Indicator} = '';
	}
	
	if (ref $content{description}) {
		$data{Products} = join '|' => map $self->prod_string(
							$content{currency},
							$content{taxes},
							%$_),
						@{ $content{description} };
	} else {
		$self->required_fields(qw(amount));
		$data{Products} = $self->prod_string(
					$content{currency},
					$content{taxes},
					amount => $content{amount},
					description => $content{description},
				);
	}

	xml_out(\%data,
		NoAttr => 1,
		RootName => 'TranxRequest',
		XMLDecl => '<?xml version="1.0" encoding="utf-8" standalone="yes"?>',
	);
}

# Map the various fields from the response, and put their values into our
# object for retrieval.
#
sub infuse {
	my ($self, $data, %map) = @_;

	while (my ($k, $v) = each %map) {
		no strict 'refs';
		$self->$v($data->{$k});
	}
}

# Parse the server's response and set various fields
#
sub parse_response {
	my ($self, $response) = @_;

	$self->server_response($response);
	
	# (It's not quite clear whether there should be some decoding, or if
	# the result is already utf8.)

	$response = xml_in($response,
 			ForceArray => [qw(product flag)],
 			GroupTags => { qw(Products product flags flag) },
 			KeyAttr => [],
 			SuppressEmpty => undef,
		);
	
	my $code = $self->result_code($response->{Page});
	$self->is_success($code eq '2000' || $code eq '90000' || $code eq '900P1');

	$self->infuse($response, qw(
			ReceiptNumber		receipt_number
			SalesOrderNumber	sales_order_number
			xxxName			cardholder
			CardType		card_type
			Page			result_code
			ApprovalCode		authorization
			Verbiage		error_message
			TotalAmount		total_amount
			AVSResponseCode		avs_response
			CVV2ResponseCode	cvv2_response
		));
	
	$self->card_type(CARD_TYPES->{$self->card_type});
	
	$self->{products_raw} = $response->{Products};

	return $self;
}

sub submit {
	my ($self) = @_;

	croak "Missing required argument 'merchant_id'"
		unless defined $self->{merchant_id};

	my ($page, $response, %headers) = 
		post_https(
				$self->server,
				$self->port,
				$self->path,
				undef,
				make_form(
					xxxRequestMode => 'X',
					xxxRequestData => Encode::encode_utf8(
								$self->to_xml
							  ),
				)
			);

	croak 'Error connecting to server' unless $page;
	croak 'Server responded, but not in XML' unless $page =~ /^<\?xml/;

	$self->parse_response($page);
}


1;

__END__


=head1 NAME

Business::OnlinePayment::InternetSecure - InternetSecure backend for Business::OnlinePayment

=head1 SYNOPSIS

  use Business::OnlinePayment;

  $txn = new Business::OnlinePayment 'InternetSecure',
  					merchant_id => '0000';

  $txn->content(
	action		=> 'Normal Authorization',

  	type		=> 'Visa',
	card_number	=> '0000000000000000',
	exp_date	=> '2004-07',
	cvv2		=> '000',		# Optional

	name		=> "Fr\x{e9}d\x{e9}ric Bri\x{e8}re",
	company		=> '',
	address		=> '123 Street',
	city		=> 'Metropolis',
	state		=> 'ZZ',
	zip		=> 'A1A 1A1',
	country		=> 'CA',
	phone		=> '(555) 555-1212',
	email		=> 'fbriere@fbriere.net',

	description	=> 'Online purchase',
	amount		=> 49.95,
	currency	=> 'CAD',
	taxes		=> 'GST PST',
	);

  $txn->submit;

  if ($txn->is_success) {
  	print "Card processed successfully: " . $tx->authorization . "\n";
  } else {
  	print "Card was rejected: " . $tx->error_message . "\n";
  }

=head1 DESCRIPTION

Business::OnlinePayment::InternetSecure is an implementation of
L<Business::OnlinePayment> that allows for processing online credit card
payments through Internet Secure.

See L<Business::OnlinePayment> for more information about the generic
Business::OnlinePayment interface.

=head1 CREATOR

Object creation is done via L<Business::OnlinePayment>; see its manpage for
details.  The I<merchant_id> processor option is required, and corresponds
to the merchant ID assigned to you by Internet Secure.

=head1 METHODS

(See L<Business::OnlinePayment> for more methods.)

=head2 Before order submission

=over 4

=item content( CONTENT )

Sets up the data prior to a transaction (overwriting any previous data by the
same occasion).  CONTENT is an associative array (hash), containing some of
the following fields:

=over 4

=item action (required)

What to do with the transaction.  Only C<Normal Authorization> is supported
for the moment.

=item type

Transaction type, being one of the following:

=over 4

=item - Visa

=item - MasterCard

=item - American Express

=item - Discover

=back

(This is actually ignored for the moment, and can be left blank or undefined.)

=item card_number (required)

Credit card number.  Any spaces will be removed.

=item exp_date (required)

Credit card expiration date.  Since L<Business::OnlinePayment> does not
specify any syntax, this module is rather lax in what it will accept.  It is
recommended to use either I<YYYY-MM> or I<MM/YYYY>, to avoid any nasty
surprises.

=item cvv2

Three- or four-digit verification code printed on the card.  This can be left
blank or undefined, in which case no check will be performed.  Whether or not a
transaction will be declined in case of a mismatch depends on the merchant.

This number may be called Card Verification Value (CVV2), Card Validation
Code (CVC2) or Card Identification number (CID).

=item description

A short description of the purchase.  See L<"Products list syntax"> for
an alternate syntax that allows a list of products to be specified.

=item amount

Total amount to be billed, excluding taxes if they are to be added separately.
This field is required if B<description> is a string, and should be left
undefined if B<description> contains a list of products, as outlined in
L<"Products list syntax">.

=item currency

Currency of all amounts for this order.  This can currently be either
C<CAN> (default) or C<USD>.

=item taxes

Taxes to be added automatically.  These should not be included in B<amount>;
they will be added by Internet Secure later on.

Available taxes are C<GST>, C<PST> and C<HST>; multiple taxes must be
separated by spaces.

=item name / company / address / city / state / zip / country / phone / email

Facultative customer information.  B<state> should be either a postal
abbreviation or a two-letter code taken from ISO 3166-2, and B<country> should
be a two-letter code taken from in ISO 3166-1.

=back

=back

=head2 After order submission

=over 4

=item receipt_number() / sales_order_number()

Receipt number and sales order number of submitted order.

=item total_amount()

Total amount billed for this order, including taxes.

=item cardholder()

Cardholder's name.  This is currently a mere copy of the B<name> field passed
to B<submit()>.

=item card_type()

Type of the credit card used for the submitted order, being one of the
following:

=over 4

=item - Visa

=item - MasterCard

=item - American Express

=item - Discover

=back

=item avs_response() / cvv2_response()

Results of the AVS and CVV2 checks.  See the Internet Secure documentation for
the list of possible values.

=back


=head1 NOTES

=head2 Products list syntax

Optionally, the B<description> field of B<content()> can contain a reference
to an array of products, instead of a simple string.  Each element of this
array represents a different product, and must be a reference to a hash with
the following fields:

=over 4

=item amount

Unit price of this product.

=item quantity

Ordered quantity of this product.  This can be a decimal value.

=item sku

Internal code for this product.

=item description

Description of this product

=item taxes

Taxes that should be automatically added to this product.  If specified, this
overrides the B<taxes> field passed to B<content()>.

=back

When using a products list, the B<amount> field passed to B<content()> should
be left undefined.


=head2 Character encodings

...


=head2 products_raw

...


=head1 EXPORT

None by default.


=head1 SEE ALSO

L<Business::OnlinePayment>

=head1 AUTHOR

Frederic Briere, E<lt>fbriere@fbriere.netE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2004 by Frederic Briere

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.4 or,
at your option, any later version of Perl 5 you may have available.


=cut