package WebGUI::Shop::ShipDriver::USPSInternational;

use strict;
use base qw/WebGUI::Shop::ShipDriver/;
use WebGUI::Exception;
use XML::Simple;
use LWP;
use Tie::IxHash;
use Data::Dumper;

=head1 NAME

Package WebGUI::Shop::ShipDriver::USPSInternational

=head1 DESCRIPTION

Shipping driver for the United States Postal Service, international shipping services.

=head1 SYNOPSIS

=head1 METHODS

See the master class, WebGUI::Shop::ShipDriver for information about
base methods.  These methods are customized in this class:

=cut

#-------------------------------------------------------------------

=head2 buildXML ( $cart, @packages )

Returns XML for submitting to the US Postal Service servers

=head3 $cart

A WebGUI::Shop::Cart object.  This allows us access to the user's
address book

=head3 @packages

An array of array references.  Each array element is 1 set of items.  The
quantity of items will vary in each set.  If the quantity of an item
is more than 1, then we will check for shipping 1 item, and multiple the
result by the quantity, rather than doing several identical checks.

=cut

sub buildXML {
    my ($self, $cart, @packages) = @_;
    tie my %xmlHash, 'Tie::IxHash';
    %xmlHash = ( IntlRateV2Request => {}, );
    my $xmlTop = $xmlHash{IntlRateV2Request};
    $xmlTop->{USERID}  = $self->get('userId');
    $xmlTop->{Revision}  = ['2'];
    $xmlTop->{Package} = [];
    ##Do a request for each package.
    my $packageIndex;
    PACKAGE: for(my $packageIndex = 0; $packageIndex < scalar @packages; $packageIndex++) {
        my $package = $packages[$packageIndex];
        next PACKAGE unless scalar @{ $package };
        tie my %packageData, 'Tie::IxHash';
        my $weight = 0;
        my $value  = 0;
        foreach my $item (@{ $package }) {
            my $sku = $item->getSku;
            my $itemWeight = $sku->getWeight();
            my $itemValue  = $sku->getPrice();
            ##Items that ship separately with a quantity > 1 are rate estimated as 1 item and then the
            ##shipping cost is multiplied by the quantity.
            if (! $sku->shipsSeparately ) {
                $itemWeight *= $item->get('quantity');
                $itemValue  *= $item->get('quantity');
            }
            $weight += $itemWeight;
            $value  += $itemValue;
        }
        my $pounds = int($weight);
        my $ounces = sprintf '%3.1f', (16 * ($weight - $pounds));
        if ($pounds == 0 && $ounces eq '0.0' ) {
            $ounces = 0.1;
        }
        $value = sprintf '%.2f', $value;
        my $destination = $package->[0]->getShippingAddress;
        my $country     = $self->correctCountry($destination->get('country'));
        $packageData{ID}         = $packageIndex;
        $packageData{Pounds}     = [ $pounds   ];
        $packageData{Ounces}     = [ $ounces   ];
        $packageData{Machinable} = [ 'true'    ];
        $packageData{MailType}   = [ 'Package' ];
        $packageData{ValueOfContents} = [ $value ];
        $packageData{Country}    = [ $country  ];
        $packageData{Container}  = [ 'RECTANGULAR' ];
        $packageData{Size}       = [ 'REGULAR' ];
        $packageData{Width}      = [ '1.0' ];
        $packageData{Length}     = [ '1.0' ];
        $packageData{Height}     = [ '1.0' ];
        $packageData{Girth}      = [ '4.0' ];
        if ($self->get('addInsurance')) {
            $packageData{ExtraServices} = [
                { ExtraService => [ '1' ], },
            ];
        }

        push @{ $xmlTop->{Package} }, \%packageData;
    }
    my $xml = XMLout(\%xmlHash,
        KeepRoot    => 1,
        NoSort      => 1,
        NoIndent    => 1,
        KeyAttr     => {
            Package       => 'ID',
        },
        SuppressEmpty => 0,
    );
    return $xml;
}


#-------------------------------------------------------------------

=head2 calculate ( $cart )

Returns a shipping price.

=head3 $cart

A WebGUI::Shop::Cart object.  The contents of the cart are analyzed to calculate
the shipping costs.  If no items in the cart require shipping, then no shipping
costs are assessed.

=cut

sub calculate {
    my ($self, $cart) = @_;
    if (! $self->get('userId')) {
        WebGUI::Error::InvalidParam->throw(error => q{Driver configured without a USPS userId.});
    }
    if ($cart->getShippingAddress->get('country') eq 'United States') {
        WebGUI::Error::InvalidParam->throw(error => q{Driver only handles international shipping});
    }
    my $cost = 0;
    ##Sort the items into shippable bundles.
    my @shippableUnits = $self->_getShippableUnits($cart);
    my $packageCount = scalar @shippableUnits;
    if ($packageCount > 25) {
        WebGUI::Error::InvalidParam->throw(error => q{Cannot do USPS lookups for more than 25 items.});
    }
    my $anyShippable = $packageCount > 0 ? 1 : 0;
    return $cost unless $anyShippable;
    #$cost = scalar @shippableUnits * $self->get('flatFee');
    ##Build XML ($cart, @shippableUnits)
    my $xml = $self->buildXML($cart, @shippableUnits);
    ##Do request ($xml)
    my $response = $self->_doXmlRequest($xml);
    ##Error handling
    if (! $response->is_success) {
        WebGUI::Error::Shop::RemoteShippingRate->throw(error => 'Problem connecting to USPS Web Tools: '. $response->status_line);
    }
    my $returnedXML = $response->content;
    #warn $returnedXML;
    my $xmlData     = XMLin($returnedXML, KeepRoot => 1, ForceArray => [qw/Package/]);
    if (exists $xmlData->{Error}) {
        WebGUI::Error::Shop::RemoteShippingRate->throw(error => 'Problem with USPS Web Tools XML: '. $xmlData->{Error}->{Description});
    }
    ##Summarize costs from returned data
    $cost = $self->_calculateFromXML($xmlData, @shippableUnits);
    return $cost;
}

#-------------------------------------------------------------------

=head2 _calculateFromXML ( $xmlData, @shippableUnits )

Takes data from the USPS and returns the calculated shipping price.

=head3 $xmlData

Processed XML data from an XML rate request, processed in perl data structure.  The data is expected to
have this structure:

    {
        IntlRateV2Response => {
            Package => [
                {
                    ID => 0,
                    Postage => {
                        Rate => some_number
                    }
                },
            ]
        }
    }

=head3 @shippableUnits

The set of shippable units, which are required to do quantity lookups.

=cut

sub _calculateFromXML {
    my ($self, $xmlData, @shippableUnits) = @_;
    my $cost = 0;
    foreach my $package (@{ $xmlData->{IntlRateV2Response}->{Package} }) {
        my $id   = $package->{ID};
        ##Error check for invalid index
        if ($id < 0 || $id > $#shippableUnits || $id !~ /^\d+$/) {
            WebGUI::Error::Shop::RemoteShippingRate->throw(error => "Illegal package index returned by USPS: $id");
        }
        if (exists $package->{Error}) {
            WebGUI::Error::Shop::RemoteShippingRate->throw(error => $package->{Error}->{Description});
        }
        my $unit = $shippableUnits[$id];
        my $rate;
        SERVICE: foreach my $service (@{ $package->{Service} }) {
            next SERVICE unless $service->{ID} eq $self->get('shipType');
            $rate = $service->{Postage};
            #print Dumper $service;
            if ($self->get('addInsurance')) {
                $rate += $service->{ExtraServices}->{ExtraService}->{Price};
            }
        }
        if (!$rate) {
            WebGUI::Error::Shop::RemoteShippingRate->throw(error => 'Selected shipping service not available');
        }
        if ($unit->[0]->getSku->shipsSeparately) {
            ##This is a single item due to ships separately.  Since in reality there will be
            ## N things being shipped, multiply the rate by the quantity.
            $cost += $rate * $unit->[0]->get('quantity');
        }
        else {
            ##This is a loose bundle of items, all shipped together
            $cost += $rate;
        }
    }
    return $cost;
}

#-------------------------------------------------------------------

=head2 correctCountry ( $country )

Correct country names to be compliant with USPS International's ICL.

=cut

sub correctCountry {
    my $self    = shift;
    my $country = shift;
    return $country eq q{United Kingdom}                         ? q{United Kingdom (Great Britain)} 
         : $country eq q{Bosnia and Herzegovina}                 ? q{Bosnia-Herzegovina} 
         : $country eq q{Christmas Island}                       ? q{Christmas Island (Australia)} 
         : $country eq q{Congo, the Democratic Republic of the}  ? q{Congo, Democratic Republic of the} 
         : $country eq q{Cocos (Keeling) Islands}                ? q{Cocos Island (Australia)} 
         : $country eq q{Congo}                                  ? q{Congo, Republic of the} 
         : $country eq q{Cote d'Ivoire}                          ? q{Ivory Coast (Cote d’Ivoire)} 
         : $country eq q{Georgia}                                ? q{Georgia, Republic of} 
         : $country eq q{Heard and Mc Donald Islands}            ? q{Australia} 
         : $country eq q{Korea (South)}                          ? q{South Korea} 
         : $country eq q{Korea, Republic of}                     ? q{Korea, Democratic People’s Republic of (North Korea)} 
         : $country eq q{Lao People's Democratic Republic}       ? q{Laos} 
         : $country eq q{Macedonia}                              ? q{Macedonia, Republic of} 
         : $country eq q{Moldova, Republic of}                   ? q{Moldova} 
         : $country eq q{Pitcairn}                               ? q{Pitcairn Island} 
         : $country eq q{Russian Federation}                     ? q{Russia} 
         : $country eq q{Saint Kitts and Nevis}                  ? q{Saint Christopher and Nevis} 
         : $country eq q{Slovakia}                               ? q{Slovak Republic} 
         : $country eq q{South Georgia and the South Sandwich Islands} ? q{South Georgia (Falkland Islands)} 
         : $country eq q{Tokelau}                                ? q{Tokelau (Union) Group (Western Samoa)} 
         : $country eq q{Trinidad}                               ? q{Trinidad and Tobago} 
         : $country eq q{Vatican City State (Holy See)}          ? q{Vatican City} 
         : $country eq q{Viet Nam}                               ? q{Vietnam} 
         : $country eq q{Virgin Islands (U.S.)}                  ? q{Virgin Islands U.S.} 
         : $country;
}

#-------------------------------------------------------------------

=head2 definition ( $session )

This subroutine returns an arrayref of hashrefs, used to validate data put into
the object by the user, and to automatically generate the edit form to show
the user.

=cut

sub definition {
    my $class      = shift;
    my $session    = shift;
    WebGUI::Error::InvalidParam->throw(error => q{Must provide a session variable})
        unless ref $session eq 'WebGUI::Session';
    my $definition = shift || [];
    my $i18n  = WebGUI::International->new($session, 'ShipDriver_USPS');
    my $i18n2 = WebGUI::International->new($session, 'ShipDriver_USPSInternational');
    tie my %shippingTypes, 'Tie::IxHash';
    ##Note, these keys are used by buildXML
    $shippingTypes{1}     = $i18n2->get('express mail international');
    $shippingTypes{2}     = $i18n2->get('priority mail international');
    $shippingTypes{6}     = $i18n2->get('global express guaranteed rectangular');
    $shippingTypes{7}     = $i18n2->get('global express guaranteed non-rectangular');
    $shippingTypes{9}     = $i18n2->get('priority mail flat rate box');
    $shippingTypes{11}    = $i18n2->get('priority mail large flat rate box');
    $shippingTypes{15}    = $i18n2->get('first class mail international parcels');
    $shippingTypes{16}    = $i18n2->get('priority mail small flat rate box');
    tie my %fields, 'Tie::IxHash';
    %fields = (
        instructions => {
            fieldType     => 'readOnly',
            label         => $i18n->get('instructions'),
            defaultValue  => $i18n->get('usps instructions'),
            noFormProcess => 1,
        },
        userId => {
            fieldType    => 'text',
            label        => $i18n->get('userid'),
            hoverHelp    => $i18n->get('userid help'),
            defaultValue => '',
        },
        shipType => {
            fieldType    => 'selectBox',
            label        => $i18n->get('ship type'),
            hoverHelp    => $i18n->get('ship type help'),
            options      => \%shippingTypes,
            defaultValue => 'PARCEL',
        },
        addInsurance => {
            fieldType    => 'yesNo',
            label        => $i18n->get('add insurance'),
            hoverHelp    => $i18n->get('add insurance help'),
            defaultValue => 0,
        },
##Note, if a flat fee is added to this driver, then according to the license
##terms the website must display a note to the user (shop customer) that additional
##fees have been added.
#        flatFee => {
#            fieldType    => 'float',
#            label        => $i18n->get('flatFee'),
#            hoverHelp    => $i18n->get('flatFee help'),
#            defaultValue => 0,
#        },
    );
    my %properties = (
        name        => $i18n2->get('U.S. Postal Service, International'),
        properties  => \%fields,
    );
    push @{ $definition }, \%properties;
    return $class->SUPER::definition($session, $definition);
}

#-------------------------------------------------------------------

=head2 _doXmlRequest ( $xml )

Contact the USPS website and submit the XML for a shipping rate lookup.
Returns a LWP::UserAgent response object.

=head3 $xml

XML to send.  It has some very high standards, including XML components in
the right order and sets of allowed tags.

=cut

sub _doXmlRequest {
    my ($self, $xml) = @_;
    my $userAgent = LWP::UserAgent->new;
    $userAgent->env_proxy;
    $userAgent->agent('WebGUI');
    $userAgent->timeout('45');
    my $url = 'http://production.shippingapis.com/ShippingAPI.dll?API=IntlRateV2&XML=';
    $url .= $xml;
    my $request = HTTP::Request->new(GET => $url);
    my $response = $userAgent->request($request);
    return $response;
}

#-------------------------------------------------------------------

=head2 _getShippableUnits ( $cart )

This is a private method.

Sorts items into the cart by how they must be shipped, together, separate,
etc.  Returns an array of array references of cart items grouped by
whether or not they ship separately, and then sorted by destination
zip code.

If an item in the cart must be shipped separately, but has a quantity greater
than 1, then for the purposes of looking up shipping costs it is returned
as 1 bundle, since the total cost can now be calculated by multiplying the
quantity together with the cost for a single unit.

For an empty cart (which shouldn't ever happen), it would return an empty array.

=head3 $cart

A WebGUI::Shop::Cart object.  It provides access to the items in the cart
that must be sorted.

=cut

sub _getShippableUnits {
    my ($self, $cart) = @_;
    my @shippableUnits = ();
    ##Loose units are sorted by zip code.
    my %looseUnits = ();
    ITEM: foreach my $item (@{$cart->getItems}) {
        my $sku = $item->getSku;
        next ITEM unless $sku->isShippingRequired;
        if ($sku->shipsSeparately) {
            push @shippableUnits, [ $item ];
        }
        else {
            my $zip = $item->getShippingAddress->get('code');
            if ($item->getShippingAddress->get('country') eq 'United States') {
                WebGUI::Error::InvalidParam->throw(error => q{Driver only handles international shipping});
            }
            push @{ $looseUnits{$zip} }, $item;
        }
    }
    push @shippableUnits, values %looseUnits;
    return @shippableUnits;
}

1;