# Copyrights 2012 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.00.
use warnings;
use strict;
package XML::Compile::WSS::Signature;
use vars '$VERSION';
$VERSION = '0.90';
use base 'XML::Compile::WSS';
my %canon; #to be removed
my %keywraps; #to be removed
use Log::Report 'xml-compile-wss-sig';
use XML::Compile::WSS::Util qw/:wss11 :wsm10 :dsig :xtp10/;
use XML::Compile::C14N ();
use XML::Compile::C14N::Util qw/:c14n/;
use XML::Compile::WSS::SecToken ();
use XML::Compile::WSS::Sign ();
use Digest ();
use XML::LibXML ();
use HTTP::Response ();
use MIME::Base64 qw/decode_base64 encode_base64/;
use File::Slurp qw/read_file/;
use Scalar::Util qw/blessed/;
use File::Basename qw/dirname/;
my $unique = $$.time;
my @default_canon_ns = qw/ds wsu xenc SOAP-ENV/;
my @prefixes = (dsig11 => DSIG11_NS, dsp => DSP_NS, dsigm => DSIG_MORE_NS);
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Quotekeys = 0;
my ($digest_algorithm, $sign_algorithm);
{ my ($signs, $sigmns) = (DSIG_NS, DSIG_MORE_NS);
# the digest algorithms can be distiguish by pure lowercase, no dash.
$digest_algorithm = qr/^(?:$signs|$sigmns)([a-z0-9]+)$/;
}
sub init($)
{ my ($self, $args) = @_;
$args->{wss_version} ||= '1.1';
$self->SUPER::init($args);
# Run digest to initialize modules (and detect what is not installed)
# Usually client and server use the same algorithms
my $digest = $self->{XCWS_digmeth} = $args->{digest_method} || DSIG_SHA1;
$self->digest($digest, \"test digest");
my $schema = $self->schema or panic;
my $c14n = XML::Compile::C14N->new(version => '1.1', schema => $schema);
$self->_make_canon
( $c14n
, $args->{canon_method} || C14N_EXC_NO_COMM
, $args->{prefix_list} || \@default_canon_ns
);
my $publ_token = $args->{publish_token} || 'INCLUDE_BY_REF';
my $token = $self->{XCWS_token} # usually an ::X509
= XML::Compile::WSS::SecToken->fromConfig($args->{token});
$self->_make_publish_token($token, $publ_token);
$self->_make_key_info($token, $publ_token);
my $sign_method = $args->{signer} || DSIG_RSA_SHA1;
my $priv_key = $args->{private_key}
or error __x"private_key required";
$self->_make_signer($sign_method, $priv_key);
$self->_make_checker($args->{checker}) if $args->{checker};
if(my $r = $args->{remote_token})
{ $self->{XCWS_rem_token} = XML::Compile::WSS::SecToken->fromConfig($r);
}
$self;
}
#-----------------------------
sub defaultDigestMethod() { shift->{XCWS_digmeth} }
sub digester($)
{ my ($self, $method) = @_;
$method =~ $digest_algorithm
or error __x"digest {name} is not a correct constant";
my $algo = uc $1;
sub {
my $data = shift;
my $digest = try { my $d = Digest->new($algo)->add($$data)->digest };
$@ or return $digest;
error __x"cannot use digest method {short}, constant {name}: {err}"
, short => $algo, name => $method, err => $@->wasFatal;
};
}
sub digest($$)
{ my ($self, $method, $text) = @_;
$self->digester($method)->($text);
}
sub _digest_elem_check($$)
{ my ($self, $elem, $ref) = @_;
my $transf = $ref->{ds_Transforms}{ds_Transform}[0]; # only 1 transform
my ($inclns, $preflist) = %{$transf->{cho_any}[0]}; # only 1 kv pair
my $elem_c14n = $self
->applyCanon($transf->{Algorithm}, $elem, $preflist->{PrefixList});
my $digmeth = $ref->{ds_DigestMethod}{Algorithm} || '(none)';
$self->digest($digmeth, \$elem_c14n) eq $ref->{ds_DigestValue};
}
#-----------------------------
# produces a sub which does correct canonicalization.
sub _make_canon($$$)
{ my ($self, $c14n, $method, $prefixes) = @_;
$self->{XCWS_c14n} = $c14n;
$self->{XCWS_canonmeth} = $method;
$self->{XCWS_prefixlist} = $prefixes;
$self->{XCWS_do_canon} = sub
{ my $node = shift or return '';
$c14n->normalize($method, $node, prefix_list => $prefixes);
};
}
sub canonicalizer() {shift->{XCWS_do_canon}}
sub defaultCanonMethod() {shift->{XCWS_canonmeth}}
sub defaultPrefixList() {shift->{XCWS_prefixlist}}
sub c14n() {shift->{XCWS_c14n}}
sub applyCanon($$$)
{ my ($self, $algo, $elem, $prefixlist) = @_;
$self->c14n->normalize($algo, $elem, prefixlist => $prefixlist);
}
# XML::Compile has to trick with prefixes, because XML::LibXML does not
# permit the creation of nodes with explicit prefix, only by namespace.
# The next can be slow and is ugly, Sorry. MO
sub _repair_xml($$)
{ my ($self, $xc_out_dom) = @_;
# only doc element does charsets correctly
my $doc = $xc_out_dom->ownerDocument;
# building bottom up: be sure we have all namespaces which may be
# declared later, on higher in the hierarchy.
my $env = $doc->createElement('Dummy');
my $prefixes = $self->schema->prefixes;
$env->setNamespace($_->{uri}, $_->{prefix}, 0)
for values %$prefixes;
# reparse tree
$env->addChild($xc_out_dom);
my $fixed_dom = XML::LibXML->load_xml(string => $env->toString(0));
my $new_out = ($fixed_dom->documentElement->childNodes)[0];
$doc->importNode($new_out);
$new_out;
}
#-----------------------------
sub token() {shift->{XCWS_token}}
sub remoteToken() {shift->{XCWS_rem_token}}
sub _make_publish_token($$)
{ my ($self, $token, $how) = @_;
my $publ
= ref $how eq 'CODE' ? $how
: $how eq 'INCLUDE_BY_REF' ? $token->makeBinSecTokenWriter($self)
: $how eq 'NO' ? sub {}
: error __x"do not understand how to publish token";
$self->{XCWS_publ_token} = $publ;
}
sub publishToken() {shift->{XCWS_publ_token}}
sub _make_key_info($$)
{ my ($self, $token, $how) = @_;
return $how if ref $how eq 'CODE';
$how eq 'INCLUDE_BY_REF'
or error __x"publish_token either CODE or 'INCLUDE_BY_REF'";
my %ref =
( URI => '#'.$token->id
, ValueType => $token->type
);
my $schema = $self->schema;
$schema->prefixFor(WSU_10); # force inclusion of namespace decl
my $krt = $schema->findName('wsse:Reference');
my $krw = $schema->writer($krt, include_namespaces => 0);
my $kit = $schema->findName('wsse:SecurityTokenReference');
my $kiw = $schema->writer($kit, include_namespaces => 0);
$self->{XCWS_key_info} = sub ($) {
my ($doc) = @_;
my $kr = $krw->($doc, \%ref);
my $ki = $kiw->($doc, {cho_any => {$krt => $kr}});
+{ cho_ds_KeyName => [{$kit => $ki}] };
};
}
sub includeKeyInfo() {shift->{XCWS_key_info}}
#-----------------------------
sub signer() {shift->{XCWS_signer}}
sub checker() {shift->{XCWS_checker}}
sub _make_signer($$)
{ my ($self, $config, $privkey) = @_;
$self->{XCWS_signer} = XML::Compile::WSS::Sign
->fromConfig($config, $privkey);
}
sub _make_checker($)
{ my ($self, $config) = @_;
$config or return;
$self->{XCWS_checker} = XML::Compile::WSS::Sign->fromConfig($config);
}
sub signElement(%)
{ my ($self, $node, %args) = @_;
my $wsuid = $node->getAttributeNS(WSU_10, 'Id');
unless($wsuid)
{ $wsuid = $args{id} || 'elem-'.$unique++;
$node->setNamespace(WSU_10, 'wsu', 0);
$node->setAttributeNS(WSU_10, 'Id', $wsuid);
}
push @{$self->{XCWS_to_sign}}, +{node => $node, id => $wsuid};
$node;
}
sub elementsToSign() { delete shift->{XCWS_to_sign} || [] }
sub checkElement($%)
{ my ($self, $node, %args) = @_;
my $id = $node->getAttributeNS(WSU_10, 'Id')
or error "element to check {name} has no wsu:Id"
, name => $node->nodeName;
$self->{XCWS_to_check}{$id} = $node;
}
sub elementsToCheck()
{ my $self = shift;
my $to_check = delete $self->{XCWS_to_check};
$self->{XCWS_to_check} = {};
$to_check;
}
#-----------------------------
#### HELPERS
sub _get_sec_token($$)
{ my ($self, $sec, $sig) = @_;
my $sec_tokens = $sig->{ds_KeyInfo}{cho_ds_KeyName}[0]
->{wsse_SecurityTokenReference}{cho_any}[0];
my ($key_type, $key_data) = %$sec_tokens;
$key_type eq 'wsse_Reference'
or error __x"key-type {type} not yet supported", type => $key_type;
my $key_uri = $key_data->{URI} or panic;
(my $key_id = $key_uri) =~ s/^#//;
my $token;
if(my $data = $sec->{wsse_BinarySecurityToken})
{ $token = XML::Compile::WSS::SecToken->fromBinSecToken($self, $data);
}
else
{ error __x"cannot collect token from response";
}
$token->id eq $key_id
or error __x"token does not match reference";
$token->type eq $key_data->{ValueType}
or error __x"token type {type1} does not match expected {type2}"
, type1 => $token->type, type2 => $key_data->{ValueType};
$token;
}
sub _get_signer($$)
{ my ($self, $sig_meth, $token) = @_;
XML::Compile::WSS::Sign->new(type => $sig_meth
, public_key => $token);
}
sub prepareReading($)
{ my ($self, $schema) = @_;
$self->SUPER::prepareReading($schema);
$schema->declare(READER => 'ds:Signature',
, hooks => {type => 'ds:SignedInfoType', after => 'XML_NODE'});
my $checker = $self->checker;
$self->{XCWS_reader} = sub {
my $sec = shift;
#warn Dumper $sec;
my $sig = $sec->{ds_Signature};
unless($sig)
{ # When the signature is missing, we only die if we expect one
$self->checker or return;
error __x"requires signature block missing from remote";
}
my $info = $sig->{ds_SignedInfo} || {};
# Check signature on SignedInfo
my $can_meth = $info->{ds_CanonicalizationMethod};
my $can_pref = $can_meth->{c14n_InclusiveNamespaces}{PrefixList};
my $si_canon = $self->applyCanon($can_meth->{Algorithm}
, $info->{_XML_NODE}, $can_pref);
unless($checker)
{ # We only create the checker once: at the first received
# message. We may need to invalidate it for reuse of this object.
my $sig_meth = $info->{ds_SignatureMethod}{Algorithm};
my $token = $self->_get_sec_token($sec, $sig);
$checker = $self->_get_signer($sig_meth, $token);
}
#warn "#3 $si_canon";
$checker->check(\$si_canon, $sig->{ds_SignatureValue}{_})
# or error __x"signature on SignedInfo incorrect";
or warning __x"signature on SignedInfo incorrect";
# Check digest of the elements
my %references;
foreach my $ref (@{$info->{ds_Reference}})
{ my $uri = $ref->{URI};
$references{$uri} = $ref;
}
my $check = $self->elementsToCheck;
#print "FOUND: ", Dumper \%references, $info, $check;
foreach my $id (sort keys %$check)
{ my $node = $check->{$id};
my $ref = delete $references{"#$id"}
or error __x"cannot find digest info for {elem}", elem => $id;
$self->_digest_elem_check($node, $ref)
or warning __x"digest info of {elem} is wrong", elem => $id;
}
};
$self;
}
sub check($)
{ my ($self, $data) = @_;
$self->{XCWS_reader}->($data);
}
### BE WARNED: created nodes can only be used once!!! in XML::LibXML
sub _create_inclns($)
{ my ($self, $prefixes) = @_;
$prefixes ||= [];
my $schema = $self->schema;
my $type = $schema->findName('c14n:InclusiveNamespaces');
my $incns = $schema->writer($type, include_namespaces => 0);
( $type, sub {$incns->($_[0], {PrefixList => $prefixes})} );
}
sub _fill_signed_info()
{ my $self = shift;
my $prefixes = $self->defaultPrefixList;
my ($incns, $incns_make) = $self->_create_inclns($prefixes);
my $canonical = $self->canonicalizer;
my $canon = $self->defaultCanonMethod;
my $signmeth = $self->signer->type;
my $digest = $self->defaultDigestMethod;
my $do_digest = $self->digester($digest);
my $digester = sub {
my $node = shift;
$do_digest->(\$canonical->($self->_repair_xml($node)));
};
sub {
my ($doc, $parts) = @_;
my $canon_method =
+{ Algorithm => $canon
, $incns => $incns_make->($doc)
};
my @refs;
foreach my $part (@$parts)
{ my $transform =
{ Algorithm => $canon
, cho_any => [ {$incns => $incns_make->($doc)} ]
};
push @refs,
+{ URI => '#'.$part->{id}
, ds_Transforms => { ds_Transform => [$transform] }
, ds_DigestValue => $digester->($part->{node})
, ds_DigestMethod => { Algorithm => $digest }
};
}
+{ ds_CanonicalizationMethod => $canon_method
, ds_Reference => \@refs
, ds_SignatureMethod => { Algorithm => $signmeth }
};
};
}
sub prepareWriting($)
{ my ($self, $schema) = @_;
$self->SUPER::prepareWriting($schema);
return $self if $self->{XCWS_sign};
my @elements_to_sign;
my $fill_signed_info = $self->_fill_signed_info;
my $signer = $self->signer;
# encode by hand, because we need the signature immediately
my $infow = $schema->writer('ds:SignedInfo');
my $sigt = $schema->findName('ds:Signature');
my $sigw = $schema->writer($sigt);
my $canonical = $self->canonicalizer;
my $publish_token = $self->publishToken;
my $key_info = $self->includeKeyInfo;
$self->{XCWS_sign} = sub {
my ($doc, $sec) = @_;
return $sec if $sec->{$sigt};
my $info = $fill_signed_info->($doc, $self->elementsToSign);
my $info_node = $self->_repair_xml($infow->($doc, $info));
my $signature = $signer->sign(\$canonical->($info_node));
#warn "Sign %3 ",$canonical->($info_node);
# The signature value is only known when the Info is ready,
# but gladly they are produced in the same order.
my %sig =
( ds_SignedInfo => $info_node
, ds_SignatureValue => {_ => $signature}
, ds_KeyInfo => $key_info->($doc)
);
$sec->{$sigt} = $sigw->($doc, \%sig);
$publish_token->($doc, $sec);
$sec;
};
$self;
}
sub create($$)
{ my ($self, $doc, $sec) = @_;
# cannot do much yet, first the Body must be ready.
$self->{XCWS_sec_hdr} = $sec;
$self;
}
sub createSignature($)
{ my ($self, $doc) = @_;
$self->{XCWS_sign}->($doc, $self->{XCWS_sec_hdr});
}
#---------------------------
sub loadSchemas($$)
{ my ($self, $schema, $version) = @_;
return if $schema->{XCWS_sig_loaded}++;
$self->SUPER::loadSchemas($schema, $version);
my $xsddir = (dirname __FILE__).'/dsig';
trace "loading wss-dsig schemas";
$schema->prefixes(@prefixes);
$schema->importDefinitions( [glob "$xsddir/*.xsd"] );
}
1;