package Authen::NZRealMe::ICMSResolutionRequest;
$Authen::NZRealMe::ICMSResolutionRequest::VERSION = '1.23';
use warnings;
use strict;

require XML::Generator;
require XML::LibXML;
require XML::LibXML::XPathContext;
require Data::UUID;

use POSIX        qw(strftime);
use Digest::MD5  qw(md5_hex);
use MIME::Base64 qw(encode_base64);

use Authen::NZRealMe::CommonURIs qw(URI NS_PAIR);


my $ns_soap       = [ 'soap' => URI('soap12') ];
my $ns_wsse       = [ NS_PAIR('wsse') ];
my $ns_wsu        = [ NS_PAIR('wsu') ];
my $ns_wst        = [ NS_PAIR('wst') ];
my $ns_wsa        = [ NS_PAIR('wsa') ];
my $ns_icms       = [ NS_PAIR('icms') ];
my $ns_ds         = [ 'dsig' => URI('ds') ];
my @all_ns = (
    $ns_soap, $ns_wsse, $ns_wsu, $ns_wst, $ns_wsa, $ns_icms
);

my $wst_validate  = URI('wst_validate');
my $wss_saml2     = URI('wss_saml2');
my $wsa_anon      = URI('wsa_anon');


sub new {
    my $class      = shift;
    my $sp         = shift;
    my $icms_token = shift;

    my $self = bless {
        icms_token   => $icms_token,
        signer       => $sp->_signer(),
        method_data  => $sp->_icms_method_data( 'Validate' ),
    }, $class;

    die "The ICMS WSDL file has not been parsed or contains no data."
        unless $self->_method_data;

    return $self->_init($sp);
}


sub _init {
    my $self = shift;
    my $sp   = shift;

    $self->_generate_flt_resolve_doc($sp);

    return $self;
}

sub icms_token      { shift->{icms_token};      }
sub request_id      { shift->{request_id};      }
sub destination_url { shift->{destination_url}; }
sub request_data    { shift->{request_data};    }
sub _method_data    { shift->{method_data};     }
sub _signer         { shift->{signer};          }


sub _generate_flt_resolve_doc {
    my $self = shift;
    my $sp   = shift;

    # The following list of parts will be signed in the request, any with a
    # 'namespaces' array will have those namespaces treated as InclusiveNamespaces
    # as detailed in http://www.w3.org/TR/2002/REC-xml-exc-c14n-20020718/#sec-Specification
    my @signed_parts = (
        {
            name        => 'Action',
            id          => $sp->generate_saml_id('wsa:Action'),
            namespaces  => ['soap'],
        },
        {
            name        => 'MessageID',
            id          => $sp->generate_saml_id('wsa:MessageID'),
            namespaces  => ['soap'],
        },
        {
            name        => 'To',
            id          => $sp->generate_saml_id('wsa:To'),
            namespaces  => ['soap'],
        },
        {
            name        => 'ReplyTo',
            id          => $sp->generate_saml_id('wsa:ReplyTo'),
            namespaces  => ['soap'],
        },
        {
            name        => 'Timestamp',
            id          => $sp->generate_saml_id('wsa:Timestamp'),
        },
        {
            name        => 'Body',
            id          => $sp->generate_saml_id('soap:Body'),
        },
    );

    my %part_id = map { $_->{name} => $_->{id} } @signed_parts;

    my $uuid_gen = new Data::UUID;
    $self->{request_id}   = 'urn:uuid:'.$uuid_gen->create_str();

    my $method_data = $self->_method_data;
    $self->{destination_url} = $method_data->{url};

    my $x = XML::Generator->new(
        escape => 'unescaped',  # So we can insert other document bits usefully
    );

    my $soap_request = $x->Envelope($ns_soap,
        $x->Header($ns_soap,
            $x->Action( [@$ns_wsa, @$ns_wsu], {'wsu:Id' => $part_id{Action}}, $method_data->{operation}),
            $x->MessageID( [@$ns_wsa, @$ns_wsu], {'wsu:Id' => $part_id{MessageID}}, $self->request_id),
            $x->To( [@$ns_wsa, @$ns_wsu], {'wsu:Id' => $part_id{To}}, $method_data->{url}),
            $x->ReplyTo( [@$ns_wsa, @$ns_wsu], {'wsu:Id' => $part_id{ReplyTo}},
                $x->Address( $ns_wsa, $wsa_anon ),
            ),
            $x->Security( [@$ns_wsse, @$ns_wsu], {'soap:mustUnderstand' => 'true'},  # Populated by signing method
                $x->Timestamp( $ns_wsu, {'wsu:Id' => $part_id{Timestamp}},
                    $x->Created ( $ns_wsu, strftime "%FT%TZ", gmtime() ),
                    $x->Expires ( $ns_wsu, strftime "%FT%TZ", gmtime( time() + 300) ),
                ),
            )
        ),
        $x->Body($ns_soap, {'wsu:Id' => $part_id{Body}},
            $x->RequestSecurityToken($ns_wst,
                $x->RequestType( $ns_wst, $wst_validate ),
                $x->TokenType( $ns_wst, $wss_saml2 ),
                $x->ValidateTarget( $ns_wst, \$self->icms_token ),
                $x->AllowCreateFLT( $ns_icms),
            ),
        ),
    ) . "";

    my @refs = map {
        my $ref = { ref_id => $_->{id} };
        $ref->{namespaces} = $_->{namespaces} if $_->{namespaces};
        $ref;
    } @signed_parts;
    $soap_request = $self->_sign_xml( $soap_request, \@refs );

    $self->{request_data} = $soap_request;
    return $soap_request;
}

sub _sign_xml {
    my($self, $xml, $refs) = @_;

    # Just ask the signer to return the signature block
    my $signer = $self->_signer;
    my $sig_xml = $signer->sign(
        $xml,
        undef,    # refs in options
        return_signature_xml    => 1,
        references              => $refs,
        reference_transforms    => [ 'ec14n' ],
        reference_digest_method => 'sha256',
        namespaces              => [ @$ns_soap ],
    );

    my $parser = XML::LibXML->new();
    my $doc    = $parser->parse_string($xml);
    my $xc     = XML::LibXML::XPathContext->new($doc->documentElement);
    $xc->registerNs( @$_ ) foreach @all_ns;

    my $sig_frag = $parser->parse_string($sig_xml)->documentElement();
    $sig_frag->{Id} = 'SIG-4';  # Add Id attr for backwards compatibility

    # Generate a cert fingerprint and append to the signature block
    my $x509 = Crypt::OpenSSL::X509->new_from_string($signer->pub_cert_text);
    my $fingerprint = $x509->fingerprint_sha1() =~ s/://gr;
    my $fingerprint_sha1 = encode_base64(pack("H*", $fingerprint), '');

    my $x = XML::Generator->new();
    my $keyinfo_block = $x->KeyInfo( $ns_ds, { Id => "KI-${fingerprint}1" },
        $x->SecurityTokenReference( $ns_wsse, { Id => "STR-${fingerprint}2" },
            $x->KeyIdentifier( $ns_wsse, { EncodingType => URI('wss_b64'), ValueType => URI('wss_sha1') },
                $fingerprint_sha1,
            ),
        ),
    ).'';
    my $x509_frag = $parser->parse_string($keyinfo_block)->documentElement();
    $sig_frag->appendChild($x509_frag);

    # Insert signature block as last element in soap:Header/wsse:Security section
    my($sec_node) = $xc->findnodes("/soap:Envelope/soap:Header/wsse:Security");
    $sec_node->appendChild($sig_frag);
    return $doc->toString(0);
}


1;

__END__

=head1 NAME

Authen::NZRealMe::ICMSResolutionRequest - Generate a WS-Trust request
for resolving an opaque token to a RealMe FLT.

=head1 DESCRIPTION

This package is used by the L<Authen::NZRealMe::ServiceProvider> to generate a
properly formatted WS-Trust Request containing an opaque token to
resolve to an FLT.

=head1 METHODS

=head2 new

Constructor.  Should not be called directly.  Instead, call the
C<resolve_artifact> method on the service provider with the 'resolve_flt'
option set to a true value.

=head2 icms_token

Accessor method to return the XML opaque token string as provided by the
assertion service

=head2 request_id

Accessor for the generated unique ID for this request.

=head2 request_data

Accessor for the entity ID of the Service Provider which generated the request.

=head2 request_time

Accessor for the request creation time formatted as an ISO date/time string.

=head2 destination_url

Accessor for the URL of the FLT resolution service, to which this request
will be sent.

=head2 request_data

Accessor for the XML document which will be sent as a SOAP request to the
context mapping service (ICMS).


=head1 SEE ALSO

See L<Authen::NZRealMe> for documentation index.


=head1 LICENSE AND COPYRIGHT

Copyright (c) 2010-2022 Enrolment Services, New Zealand Electoral Commission

Written by Haydn Newport E<lt>haydn@catalyst.net.nzE<gt>

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut