view release on metacpan or  search on metacpan

lib/Authen/NZRealMe/XMLSig.pm  view on Meta::CPAN

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

=head1 NAME

Authen::NZRealMe::XMLSig - XML digital signature generation/verification

=head1 DESCRIPTION

This module implements the subset of http://www.w3.org/TR/xmldsig-core/
required to interface with the New Zealand RealMe Login service using SAML 2.0
messaging.

=cut


use Carp          qw(croak);
use Digest::SHA   qw(sha1 sha1_base64 sha256);
use MIME::Base64  qw(encode_base64 decode_base64);

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

require XML::LibXML;
require XML::LibXML::XPathContext;
require XML::Generator;
require Crypt::OpenSSL::RSA;
require Crypt::OpenSSL::X509;

my(%transforms_by_name, %transforms_by_uri);
__PACKAGE__->register_transform_method($_, URI($_)) foreach (qw(
    c14n
    c14n_wc
    c14n11
    c14n11_wc
    ec14n
    ec14n_wc
    sha1
    sha256
    env_sig
));

my(%sig_alg_by_name, %sig_alg_by_uri);
__PACKAGE__->register_signature_methods($_, URI($_)) foreach (qw(
    rsa_sha1
    rsa_sha256
));

use constant WITH_COMMENTS    => 1;
use constant WITHOUT_COMMENTS => 0;

sub new {
    my $class = shift;

    my $self = bless {
        reference_transforms    => [ 'env_sig', 'ec14n' ],
        reference_digest_method => 'sha1',
        c14n_method             => 'ec14n',
        signature_algorithm     => 'rsa_sha1',
        include_x509_cert       => 0,
        @_
    }, $class;
    return $self;
}


sub id_attr                 { shift->{id_attr};    }
sub reference_transforms    { shift->{reference_transforms}; }
sub reference_digest_method { shift->{reference_digest_method}; }
sub c14n_method             { shift->{c14n_method}; }
sub signature_algorithm     { shift->{signature_algorithm}; }

lib/Authen/NZRealMe/XMLSig.pm  view on Meta::CPAN

        }
        @elem = map { $_->ownerElement() } @attr;
    }
    return $elem[0];
}


sub _node_to_clarkian_path {
    my($self, $node) = @_;

    my $node_path = $node->nodePath();
    my %frag_ns;
    do {
        if(my $prefix = $node->prefix) {
            $frag_ns{$prefix} = $node->namespaceURI;
        }
        $node = $node->parentNode();
    } while($node);
    $node_path =~ s{([\w-]+):}{
        my $prefix = $1;
        my $uri = $frag_ns{$prefix};
        "{$uri}";
    }ge;
    return $node_path;
}


sub _make_sig_xml {
    my($self, $xc, %opt) = @_;

    my $sig = {};

    my $ref_specs = $opt{references} // [];
    die "Can't make a signature without references" unless @$ref_specs;
    my @references = map {
        $_->{digest_method} //= $opt{reference_digest_method} if $opt{reference_digest_method};
        $_->{transforms}    //= $opt{reference_transforms}    if $opt{reference_transforms};
        $self->_make_reference($xc, $_);
    } @$ref_specs;
    $sig->{references} = \@references;

    $sig->{c14n} = $self->_find_transform(
        $opt{c14n} // $self->c14n_method()
    );

    if(my $ns_list = $opt{c14n_namespaces}) {
        $sig->{c14n}->{namespaces} = $ns_list;
    }

    $sig->{signature_algorithm} = $self->_find_sig_alg(
        $opt{signature_algorithm} // $self->signature_algorithm()
    );

    return $self->_sig_as_xml($sig);
}


sub _sig_as_xml {
    my($self, $sig) = @_;

    my $ns_ds   = [ dsig => URI('ds') ];
    my $x = XML::Generator->new(':strict', pretty => 2);

    my @ref_blocks = map {
        my @transforms = map {
            $self->_transform_as_xml($x, 'Transform', $ns_ds, $_);
        } @{ $_->{transforms} };
        $x->Reference($ns_ds, { URI => '#' . $_->{ref_id} },
            $x->Transforms($ns_ds,
                @transforms,
            ),
            $x->DigestMethod($ns_ds, { Algorithm => $_->{digest_method}->{uri} }),
            $x->DigestValue($ns_ds, $_->{digest_value}),
        ),
    } @{ $sig->{references} };

    my $c14n    = $sig->{c14n};
    my $sig_alg = $sig->{signature_algorithm};

    my @key_info;
    if($self->include_x509_cert) {
        my $cert_text = $self->pub_cert_text()
            or die "Need pub_cert_file or pub_cert_text for include_x509_cert";
        $cert_text =~ s{\A\s*-+\s*BEGIN CERTIFICATE\s*-+\s*}{};
        $cert_text =~ s{\s*-+\s*END CERTIFICATE\s*-+\s*}{};
        $cert_text =~ s{^\s+}{}mg;
        @key_info = (
            $x->KeyInfo($ns_ds,
                $x->X509Data($ns_ds,
                    $x->X509Certificate($ns_ds,
                        $cert_text . "\n"
                    )
                )
            )
        );
    }

    my $sig_xml = $x->Signature($ns_ds,
        $x->SignedInfo($ns_ds,
            $self->_transform_as_xml($x, 'CanonicalizationMethod', $ns_ds, $c14n),
            $x->SignatureMethod($ns_ds, { Algorithm => $sig_alg->{uri} }),
            @ref_blocks,
        ),
        $x->SignatureValue($ns_ds),
        @key_info,
    ) . '';

    my $xc = $self->_xcdom_from_xml($sig_xml, @$ns_ds);
    my $doc = $xc->getContextNode();
    my($fragment) = [ $xc, $xc->findnodes('/ds:Signature/ds:SignedInfo') ];
    my $plaintext = $self->_apply_transform($sig->{c14n}, $fragment);
    my $sig_text = "\n" . $self->_create_signature(
        $sig->{signature_algorithm},
        $plaintext,
    );
    my($sig_node) = $xc->findnodes('//dsig:SignatureValue')
        or die "Failed to find SignatureValue in generated signature XML";
    $sig_node->addChild( $doc->ownerDocument->createTextNode($sig_text) );

    # Serialising, parsing and reserialising simplifies ns attr and empty tags
    return $self->_xml_to_dom( $doc->toStringEC14N() )->toString();
}


sub _transform_as_xml {
    my($self, $x, $tag_name, $ns_ds, $trans) = @_;

    my @content;
    if(my $ns_list = $trans->{namespaces}) {
        my $prefixes = join ' ', @$ns_list;
        my $ec_ns = [ 'ec' => URI('ec14n') ];
        push @content, $x->InclusiveNamespaces($ec_ns, { PrefixList => $prefixes });
    }
    my $xml = $x->$tag_name($ns_ds, { Algorithm => $trans->{uri} }, @content);
    return $xml;
}


sub _make_reference {
    my($self, $xc, $spec) = @_;

    if((ref($spec) || '') ne 'HASH') {
        die "references must be specified as hashrefs";
    }

    my $ref = {};
    my $ref_uri = $ref->{ref_id} = $spec->{ref_id}
        // die "need a 'ref_id' to create a reference";

    my $target_node = $self->_find_element_by_uri_reference($xc, $ref_uri);
    $ref->{xml_node} = $target_node;
    my $fragment = [$xc, $target_node];

    my @transforms = map {
        $self->_find_transform($_)
    } @{ $spec->{transforms} // $self->reference_transforms() };

    if(my $ns_list = $spec->{namespaces}) {
        if($transforms[-1]->{uri} ne URI('ec14n')) {
            $transforms[-1] = $self->_find_transform('ec14n');
        }
        $transforms[-1]->{namespaces} = $ns_list;
    }

    $ref->{transforms} = \@transforms;

    foreach my $transform ( @transforms ) {
        $fragment = $self->_apply_transform($transform, $fragment);
    }

    my $digest_method = $ref->{digest_method} = $self->_find_transform(
        $spec->{digest_method} // $self->reference_digest_method()
    );
    $ref->{digest_value} = $self->_apply_transform($digest_method, $fragment);

    return $ref;