# $Id: RSS.pm,v 1.4 2001/10/27 03:12:54 fil Exp $
package POE::Component::UPS::RSS;

use strict;
use vars qw($VERSION @ISA @EXPORT_OK);

use HTTP::Request;
use HTTP::Response;
use POE::Component::UPS::HTTP;
use POE::Session;
use URI::URL;
use XML::Grove;
use XML::Grove::AsCanonXML;
use XML::Grove::Builder;
use XML::Parser::PerlSAX;

$VERSION = '0.02';

sub DEBUG {0}


####################################################
sub spawn
{
    my($package, %args)=@_;
    my $agent=$package;
    $agent=~s/\W+/-/g;
    $args{Agent}    ||= "$agent/$VERSION";
    $args{Alias}    ||= 'UPS';
    $args{Protocol} ||= 'HTTP/1.0';
    $args{Testing}  ||= DEBUG;

    POE::Session->create(
        package_states=>[
            $package=>[qw(_start _stop _signal _parent
                        shutdown request answer respond
                         input_parse)],
        ],
        heap=>\%args,
    );
            
    return 1;
}

####################################################
sub _signal 
{
    my( $heap, $signal ) = @_[ HEAP, ARG0 ];

    ## Shut things down on TERM, QUIT, or INT
    if( $signal =~ /^TERM|QUIT|INT/ ) {
        ## toss our references
        delete $heap->{transaction};
    } 
    elsif($signal eq '__parent') { 
        DEBUG and warn "$$: is the parent";
    }
    elsif($signal eq '__child') {
        DEBUG and warn "$$: is the child";
    }
    elsif(DEBUG) {
        warn "RSS: signal: ", $signal;
    }

    return;
}

####################################################
sub _parent
{
    my( $heap, $old, $new ) = @_[ HEAP, ARG0, ARG1];

    DEBUG and warn "RSS: _parent old=$old new=$new";
    return;
}

####################################################
sub _start
{
    my($kernel, $heap)=@_[KERNEL, HEAP];

    POE::Component::UPS::HTTP->spawn(@{$heap}{qw(Agent Protocol)}, 
                                        Alias=>$heap->{Alias}."-http");
    $heap->{id}=0;
    DEBUG and warn "RSS: Setting alias ito $heap->{Alias}";

    $kernel->alias_set($heap->{Alias});
}



####################################################
sub _stop
{
}


####################################################
sub shutdown
{
    my($kernel, $heap)=@_[KERNEL, HEAP];
    $kernel->alias_remove($heap->{Alias});
    $kernel->post($heap->{Alias}.'-http', 'shutdown');
    delete $heap->{transaction};
    return;
}


####################################################
sub request
{
    my($kernel, $heap, $back, $back_id, $req)=
      @_[KERNEL, HEAP, ARG0,  ARG1,    ARG2];

    if('HASH' eq ref $req) {
        my $http=HTTP::Request->new (POST => 
                            "https://www.ups.com/ups.app/xml/Rate");
        $http->content($req);
        $req=$http;
    }
    
    eval {
        _mk_xml($req, $heap);
    };
    if($@) {
        $kernel->yield(respond=>{Error=>$@});
        return;
    }

    my $id=$heap->{id}++;
    $heap->{transaction}{$id}={
        sender=>$_[SENDER], event=>$back, back_id=>$back_id,
        req=>$req, id=>$id,
    };

    $kernel->post($heap->{Alias}."-http", 'request', 'answer', $id, $req);
    return;
}

####################################################
sub answer
{
    my($kernel, $heap, $id, $req, $resp)=@_[KERNEL, HEAP, ARG0, ARG1, ARG2];
    unless($resp->is_success) {
        $kernel->yield(respond=>$id, {Error=>$resp->as_string, 
                                        Severity => 'Hard'});
        return;
    }

    unless($resp->headers->header('Content-type') eq 'application/xml') {
        $kernel->yield(respond=>$id, $resp);
        return;
    }

    $kernel->yield(input_parse=>$id, $resp);
    return;
}

####################################################
sub _mk_xml
{
    my($req, $heap)=@_;

    return unless $req->method() eq 'POST';

    return unless(($req->headers->header('Content-type')||'text/xml') eq 'text/xml' 
                    or 'HASH' eq ref $req->content);

    my $q;
    my $in=$req->content;
    my $writer = XML::Grove::AsCanonXML->new();
    my @content;


    my $xml=_XML::Document->new();
    my $access=_XML::Element->new(Name=>'AccessRequest', 
                                Parent=>$xml, Attributes=>{qw(xml:lang en-US)});

    $q = delete($in->{AccessLicenseNumber}) || delete($in->{LicenseNumber}) 
      || delete($in->{License})             || 'TEST262223144CAT';
    _XML::Element->new(Name=>'AccessLicenseNumber', Parent=>$access,
                        Contents=>[$q]);

    $q = delete($in->{UserId})              || 'REG111111';
    _XML::Element->new(Name=>'UserId', Parent=>$access, Contents=>[$q]);

    $q = delete($in->{Password})            || 'REG111111';
    _XML::Element->new(Name=>'Password', Parent=>$access, Contents=>[$q]);
    push @content, qq(<?xml version="1.0"?>);
    push @content, $writer->as_canon_xml($xml);



    $xml=_XML::Document->new();
    my $rssr=_XML::Element->new(Name=>'RatingServiceSelectionRequest', 
                                Parent=>$xml, Attributes=>{qw(xml:lang en-US)});
    my $request=_XML::Element->new(Name=>'Request', Parent=>$rssr);

    # UPS provides an integration environment which allows you to test your
    # application prior to launch. To indicate you are testing, include the
    # tag, IntegrationIndicator, anywhere within the tool-specific XML request
    # node. p. 70
    _XML::Element->new(Name=>'IntegrationIndicator', Parent=>$request)
        if $heap->{Testing};

    my $trans=[];

    # RatingServiceSelectionRequest/Request/TransactionReference/CustomerContext No ANY 0..512 
    $q=delete $in->{CustomerContext};
    push @$trans, _XML::Element->new(Name=>'CustomerContext', 
                                     Contents=>[$q]) if $q;

    # RatingServiceSelectionRequest/Request/TransactionReference/XpciVersion No Alphanumeric 1..50 
    push @$trans, _XML::Element->new(Name=>'XpciVersion', 
                                     Contents=>['1.0001']);

    # RatingServiceSelectionRequest/Request/TransactionReference No Container 1 
    _XML::Element->new(Name=>'TransactionReference', Parent=>$request, 
                       Contents=>$trans);
    

    # RatingServiceSelectionRequest/Request/RequestAction Yes Char 15
    _XML::Element->new(Name=>'RequestAction', Parent=>$request, 
                             Contents=>['Rate']);

    # RatingServiceSelectionRequest/Request/RequestOption Yes Char 15 
    undef($q);
    $q   = delete $in->{Request}{RequestOption} if $in->{Request};
    $q ||= delete($in->{RequestOption}) || 'rate';
    _XML::Element->new(Name=>'RequestOption', Parent=>$request, 
                             Contents=>[substr($q, 0, 15)]);
    
    $q=ref($in->{PickupType}) ? $in->{PickupType}{Code} : $in->{PickupType};

    # 01 Daily Pickup 
    # 03 Customer Counter 
    # 06 One Time Pickup 
    # 07 On Call Air 
    # 11 Authorized Shipping Outlet 
    # 19 Letter Center 
    # 20 Air Service Center
    $q ||= '01';
    # RatingServiceSelectionRequest/PickupType No Container 1 
    my $pickup=_XML::Element->new(Name=>'PickupType', Parent=>$rssr);
                                    
    # RatingServiceSelectionRequest/PickupType/Code No Char 2 
    _XML::Element->new(Name=>'Code', Parent=>$pickup, 
                            Contents=>[substr($q, 0, 2)]);
    delete $in->{PickupType};

    my $shipment=_XML::Element->new(Name=>'Shipment', Parent=>$rssr);

    # RatingServiceSelectionRequest/Shipment/Shipper/Address/City No Char 30 
    # RatingServiceSelectionRequest/Shipment/Shipper/Address/StateProvinceCode No Char 2     
    # RatingServiceSelectionRequest/Shipment/Shipper/Address/PostalCode Yes Char 9 
    # RatingServiceSelectionRequest/Shipment/Shipper/Address/CountryCode No Char 2 
    $q = delete($in->{Shipper}) || delete($in->{From});
    die "No Shipper information supplied\n" unless $q;
    my $addr=_mk_xml_addr($q);
    _XML::Element->new(Name=>'Shipper', Parent=>$shipment, 
                             Contents=>[$addr]);

    # RatingServiceSelectionRequest/Shipment/ShipTo/Address/City No Char 30 
    # RatingServiceSelectionRequest/Shipment/ShipTo/Address/StateProvinceCode No Char 2 
    # RatingServiceSelectionRequest/Shipment/ShipTo/Address/PostalCode Yes Char 9 
    # RatingServiceSelectionRequest/Shipment/ShipTo/Address/CountryCode No Char 2 
    # RatingServiceSelectionRequest/Shipment/ShipTo/Address/ResidentialAddress No Empty N/A 
    $q = delete($in->{ShipTo}) || delete($in->{To});
    die "No Shipper information supplied\n" unless $q;
    $addr=_mk_xml_addr($q);
    _XML::Element->new(Name=>'ShipTo', Parent=>$shipment, 
                             Contents=>[$addr]);


    # RatingServiceSelectionRequest/Shipment/Service/Code Cond Char 2 
    # 01 Next Day Air 
    # 02 2nd Day Air 
    # 03 Ground 
    # 07 Worldwide Express 
    # 08 Worldwide Expedited 
    # 11 Standard 
    # 12 3-Day Select 
    # 13 Next Day Air Saver 
    # 14 Next Day Air Early AM 
    # 54 Worldwide Express Plus 
    # 59 2nd Day Air AM 
    # 65 Express Saver
    $q=delete($in->{Service}) || 11;
    my $service=_XML::Element->new(Name=>'Service', Parent=>$shipment);
    _XML::Element->new(Name=>'Code', Parent=>$service, Contents=>[$q]);




    # RatingServiceSelectionRequest/Shipment/Package/PackagingType/Code Yes Char 2 
    $q=delete($in->{PackagingType}) || '02';
    my $package=_XML::Element->new(Name=>'Package', Parent=>$shipment);
    _XML::Element->new(Name=>'Code', Parent=>
                _XML::Element->new(Name=>'PackagingType', Parent=>$package),
                Contents=>[$q]);

    # RatingServiceSelectionRequest/Shipment/Package/PackageWeight/Weight Yes Float 6.1 
    my $pack=delete($in->{Package}) || $in;
    $q = delete($pack->{Weight}) || 0;
    my $w=_XML::Element->new(Name=>'Weight', Contents=>[$q]);

    # RatingServiceSelectionRequest/Shipment/Package/PackageWeight/UnitOfMeasurement/Code No Char 3 
    my $units=delete($pack->{UnitOfMeasurement}) || delete($pack->{Unit}) || 'KGS';
    my $u=_XML::Element->new(Name=>'UnitOfMeasurement', Contents=>[
                    _XML::Element->new(Name=>'Code', Contents=>[$units])
            ]);
    
    _XML::Element->new(Name=>'PackageWeight', Parent=>$package, 
                       Contents=>[$w, $u]);

    # RatingServiceSelectionRequest/Shipment/ShipmentServiceOptions/SaturdayPickup No Empty N/A 
    my @options;
    $q=delete($in->{SaturdayPickup});
    push @options, _XML::Element->new(Name=>'SaturdayPickup') if $q;

    # RatingServiceSelectionRequest/Shipment/ShipmentServiceOptions/SaturdayDelivery No Empty N/A 
    $q=delete($in->{SaturdayDelivery});
    push @options, _XML::Element->new(Name=>'SaturdayDelivery') if $q;

    _XML::Element->new(Name=>'ShipmentServiceOptions', Parent=>$shipment, 
                       Contents=>[@options]);


    push @content, qq(<?xml version="1.0"?>);
    push @content, join "", $xml->accept($writer);

    $req->headers->header('Content-type'=> 'application/x-www-form-urlencoded');
    $req->content(join "\cM\cJ", @content);
}

####################################################
sub _mk_xml_addr
{
    my($in)=@_;
    
    my $addr=_XML::Element->new(Name=>'Address');
    # RatingServiceSelectionRequest/Shipment/Shipper/Address/City No Char 30 
    # RatingServiceSelectionRequest/Shipment/ShipTo/Address/City No Char 30 
    my $q=delete $in->{City};
    _XML::Element->new(Name=>'City', Contents=>[substr($q, 0, 30)]) if $q;

    # RatingServiceSelectionRequest/Shipment/Shipper/Address/StateProvinceCode No Char 2
    # RatingServiceSelectionRequest/Shipment/ShipTo/Address/StateProvinceCode No Char 2
    $q=delete($in->{StateProvinceCode}) || 
          delete($in->{Province})          || delete($in->{State});
    _XML::Element->new(Name=>'StateProvinceCode', Parent=>$addr, 
                       Contents=>[substr($q, 0, 2)]) if $q;

    # RatingServiceSelectionRequest/Shipment/Shipper/Address/PostalCode Yes Char 9 
    # RatingServiceSelectionRequest/Shipment/ShipTo/Address/PostalCode Yes Char 9 
    $q=delete($in->{PostalCode});
    $q=~s/\W//g;
    _XML::Element->new(Name=>'PostalCode', Parent=>$addr,
                                 Contents=>[substr($q, 0, 9)]);

    # RatingServiceSelectionRequest/Shipment/Shipper/Address/CountryCode No Char 2
    # RatingServiceSelectionRequest/Shipment/ShipTo/Address/CountryCode No Char 2
    $q=delete($in->{CountryCode}) || delete($in->{Country});
    if($q) {
        _XML::Element->new(Name=>'CountryCode', Parent=>$addr, 
                                 Contents=>[substr($q, 0, 2)]);
    }

    # RatingServiceSelectionRequest/Shipment/ShipTo/Address/ResidentialAddress No Empty N/A 
    $q=delete($in->{ResidentialAddress}) || delete($in->{Residential});
    if($q) {
        _XML::Element->new(Name=>'ResidentialAddress', Parent=>$addr);
    }
    return $addr;
}



####################################################
sub input_parse
{
    my($kernel, $heap, $id, $resp)=@_[KERNEL, HEAP, ARG0, ARG1];

    DEBUG and warn "RSS $id: input_parse\n";
    my $answer=_input_parse_content($resp);

    $kernel->yield(respond=>$id, $answer);
    return
}


####################################################
sub respond
{
    my($kernel, $heap, $id, $resp)=@_[KERNEL, HEAP, ARG0, ARG1];
    my $conn=delete $heap->{transaction}{$id};
    
    DEBUG and warn "RSS $id: respond to $conn->{sender}/$conn->{event}\n";
    $kernel->post($conn->{sender}=>$conn->{event}, $conn->{back_id}, $resp);
    return;
}


my $fake_response=<<XML;
<?xml version="1.0"?>
<RatingServiceSelectionResponse>

<Response>
<TransactionReference>
<CustomerContext>The world is my oyster</CustomerContext>
<XpciVersion>1.0001</XpciVersion>
</TransactionReference>

<ResponseStatusCode>1</ResponseStatusCode>
<ResponseStatusDescription>Success</ResponseStatusDescription>
</Response>

<RatedShipment>
    <Service><Code>03</Code></Service>
    <BillingWeight>
        <UnitOfMeasurement><Code>LBS</Code></UnitOfMeasurement>
        <Weight>33.0</Weight>
    </BillingWeight>
    <TransportationCharges>
        <CurrencyCode>CAD</CurrencyCode>
        <MonetaryValue>7.25</MonetaryValue>
    </TransportationCharges>
    <ServiceOptionsCharges>
        <CurrencyCode>CAD</CurrencyCode>
        <MonetaryValue>0.00</MonetaryValue>
    </ServiceOptionsCharges>
    <TotalCharges>
        <CurrencyCode>CAD</CurrencyCode> 
        <MonetaryValue>7.25</MonetaryValue> 
    </TotalCharges> 
    <GuaranteedDaysToDelivery>0</GuaranteedDaysToDelivery> 
    <RatedPackage> 
        <ServiceOptionsCharges> 
            <CurrencyCode>CAD</CurrencyCode> 
            <MonetaryValue>0.00</MonetaryValue>
        </ServiceOptionsCharges> 
        <Weight>33.0</Weight>
        <BillingWeight>
            <UnitOfMeasurement><Code>LBS</Code></UnitOfMeasurement> 
            <Weight>33.0</Weight> 
        </BillingWeight> 
    </RatedPackage> 
</RatedShipment>
</RatingServiceSelectionResponse>
XML



####################################################
sub _input_parse_content
{
    my($resp)=@_;

    my $inside=$resp->content();
#    $inside=$fake_response if $inside=~ /Invalid UserId/;


    my $parser = XML::Parser->new( Style => 'Tree' );
    my $tree = $parser->parse($inside);
    $tree=$tree->[1]    if $tree->[0] eq 'RatingServiceSelectionResponse';
    shift @$tree;       # drop attributes
    my $xml=_xml_flaten($tree);
    
    unless($xml->{Response}) {
        return {Error=>"No Response element in reply", 
                Severity => 'Hard'};
    }

    my $response=$xml->{Response};

    my $answer={};

    # Response/TransactionReference/CustomerContext No Any 0..512 
    if($response->{TransactionReference}) {
        $answer->{CustomerContext}=
            $response->{TransactionReference}{CustomerContext};
    }

    unless($response->{ResponseStatusCode}==1) {
        $answer->{Error}    = ($response->{Error}{ErrorDescription}||'Request failed');
        $answer->{Code}     = $response->{Error}{ErrorCode};
        $answer->{Severity} = $response->{Error}{ErrorSeverity};
#        $answer->{Response} = $response;
        return $answer;
    }

    
    my $rs=$xml->{RatedShipment};
    unless($rs) {
        $answer->{Error}="There is no RatedShipment element in reply";
        return $answer;
    }

    my $total=$rs->{TotalCharges};
    unless($total) {
        $answer->{Error}="There is no TotalCharges element in reply";
        return $answer;
    }
    # RatingServiceSelectionResponse/RatedShipment/TotalCharges/CurrencyCode No Char 3 
    # RatingServiceSelectionResponse/RatedShipment/TotalCharges/MonetaryValue Yes Char 16.2 
    $answer->{Total}=$total->{MonetaryValue};
    $answer->{Currency}=$total->{CurrencyCode};


    # RatingServiceSelectionResponse/RatedShipment/GuaranteedDaysToDelivery Yes Char 8 
    if($rs->{GuaranteedDaysToDelivery}) {
        $answer->{GuaranteedDaysToDelivery}=$rs->{GuaranteedDaysToDelivery};

    }

    return $answer;   
}

####################################################
sub _xml_flaten
{
    my($xml)=@_;
    my $hash={};
    my($tag, $content)=@_;
    while(@$xml) {
        my $tag=shift @$xml;
        my $content=shift @$xml;
        unless($tag eq '0') {
            # drop attributes (which RSS doesn't have anyway)
            shift @$content;        
            $hash->{$tag}=_xml_flaten($content);
        }
        elsif($content=~/\S/) {
            $hash->{$tag}=$content;
        }
    }
    return $hash->{0} if 1==keys %$hash and exists $hash->{0};
    return $hash;
}












##############################################################################
package _XML::Document;
use strict;
@_XML::Document::ISA=qw(XML::Grove::Document);
$_XML::Document::type_name=$XML::Grove::Document::type_name;
sub new
{
    my($package, %args)=@_;
    $args{Contents} ||= [];
    my $self=$package->SUPER::new(%args);
    $self->_scan_content();
    return $self;
}

sub _new_child
{
    my($self, $child)=@_;
    # TODO: check for dups
    push @{$self->{Contents}}, $child;
}

sub _scan_content
{
    my($self)=@_;
    foreach (@{$self->{Contents}}) {
        if(ref $_) {
            $_->_new_parent($self);   
        }
        else {
            $_=XML::Grove::Characters->new(Parent=>$self, Data=>$_);
        }
    }
}

####################################################
package _XML::Element;
use strict;
@_XML::Element::ISA=qw(XML::Grove::Element);
$_XML::Element::type_name=$XML::Grove::Element::type_name;
sub new
{
    my($package, %args)=@_;
    $args{Contents} ||= [];
    my $self=$package->SUPER::new(%args);
    $self->{Parent}->_new_child($self) if $self->{Parent};
    # BWAHAHAHAHAHAHA! It's either this hack, or we inherit from 
    # _XML::Document which is worse
    _XML::Document::_scan_content($self);
    return $self;    
}

sub _new_parent
{
    my($self, $parent)=@_;
    # TODO: tell old parent we moved
    $self->{Parent}=$parent;
}

sub _new_child
{
    my($self, $child)=@_;
    # TODO: check for dups
    push @{$self->{Contents}}, $child;
}

####################################################


1;
__END__
# Below is the stub of documentation for your module. You better edit it!

=head1 NAME

POE::Component::UPS::RSS - UPS Rates & Service Selection

=head1 SYNOPSIS

  use POE::Component::UPS::RSS;
  blah blah blah

=head1 DESCRIPTION

Stub documentation for POE::Component::UPS::RSS was created by h2xs. It looks like the
author of the extension was negligent enough to leave the stub
unedited.

Blah blah blah.

=head1 AUTHOR

A. U. Thor, a.u.thor@a.galaxy.far.far.away

=head1 SEE ALSO

perl(1).

=cut