File Coverage

lib/XML/Compile/WSS/Signature.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

# Copyrights 2012-2013 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.01.
use warnings;
use strict;

package XML::Compile::WSS::Signature;
use vars '$VERSION';
$VERSION = '2.01';

use base 'XML::Compile::WSS';

use Log::Report 'xml-compile-wss-sig';

use XML::Compile::WSS::Util     qw/:wss11 :wsm10 :dsig :xtp10/;
use XML::Compile::WSS::SecToken ();
use XML::Compile::WSS::Sign     ();
use XML::Compile::WSS::KeyInfo  ();
use XML::Compile::WSS::SignedInfo ();

use XML::Compile::C14N::Util    qw/:c14n/;
use XML::Compile::C14N          ();

use Digest          ();
use XML::LibXML     ();
use File::Basename  qw/dirname/;
use File::Glob      qw/bsd_glob/;
use Scalar::Util    qw/blessed/;

my %prefixes =
  ( # ds=DSIG_NS defined in ::WSS
    dsig11 => DSIG11_NS
  , dsp    => DSP_NS
  , dsigm  => DSIG_MORE_NS
  , xenc   => XENC_NS
  );

#use Data::Dumper;
#$Data::Dumper::Indent    = 1;
#$Data::Dumper::Quotekeys = 0;


sub init($)
{   my ($self, $args) = @_;
    my $wss_v = $args->{wss_version} ||= '1.1';

    $self->SUPER::init($args);

    my $signer  = delete $args->{signer} || {};
    blessed $signer || ref $signer
        or $signer  = { sign_method => $signer };            # pre 2.00
    $signer->{$_} ||= delete $args->{$_}                     # pre 2.00
        for qw/private_key/;
    $self->{XCWS_signer}  = XML::Compile::WSS::Sign
      ->fromConfig(%$signer, wss => $self);

    my $si      = delete $args->{signed_info} || {};
    $si->{$_} ||= delete $args->{$_}
        for qw/digest_method cannon_method prefix_list/;     # pre 2.00

    $self->{XCWS_siginfo} = XML::Compile::WSS::SignedInfo
      ->fromConfig(%$si, wss => $self);

    my $ki      = delete $args->{key_info} || {};
    $ki->{$_} ||= delete $args->{$_}
        for qw/publish_token/;                               # pre 2.00

    $self->{XCWS_keyinfo} = XML::Compile::WSS::KeyInfo
      ->fromConfig(%$ki, wss => $self);

    if(my $subsig = delete $args->{signature})
    {   $self->{XCWS_subsig} = (ref $self)->new(wss_version => $wss_v
          , schema => $self->schema, %$subsig);
    }

    $self->{XCWS_token}    = $args->{token};

    $self->{XCWS_config}   = $args;  # the left-overs are for me
    $self;
}

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


sub keyInfo()    {shift->{XCWS_keyinfo}}
sub signedInfo() {shift->{XCWS_siginfo}}
sub signer()     {shift->{XCWS_signer}}

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


sub token()       {shift->{XCWS_token}}
sub remoteToken() {shift->{XCWS_rem_token}}

#-----------------------------
#### HELPERS

sub prepareReading($)
{   my ($self, $schema) = @_;
    $self->SUPER::prepareReading($schema);

    my $config = $self->{XCWS_config};
    if(my $r   = $config->{remote_token})
    {   $self->{XCWS_rem_token} = XML::Compile::WSS::SecToken->fromConfig($r);
    }

    my (@elems_to_check, $container, @signature_elems);
    $schema->addHook
      ( action => 'READER'
      , type   =>  ($config->{sign_types} or panic)
      , before => sub {
          my ($node, $path) = @_;
          push @elems_to_check, $node;
          $node;
        }
      );

    # we need the unparsed node to canonicalize and check
    $schema->addHook
      ( action => 'READER'
      , type   => 'ds:SignedInfoType'
      , after  => 'XML_NODE'
      );

    # collect the elements to check, while decoding them
    $schema->addHook
      ( action => 'READER'
      , type   => ($config->{sign_put} || panic)
      , after  => sub {
          my ($xml, $data, $path) = @_;
#warn "Located signature at $path";
          push @signature_elems, $data->{ds_Signature}
              if $data->{ds_Signature};
          $container = $data;
          $data;
        }
      );

    my $check_signature = $self->checker;
    $schema->addHook
      ( action => 'READER'
      , type   => ($config->{sign_when} || panic)
      , after  => sub {
          my ($xml, $data, $path) = @_;
#warn "Checking signatures when at $path";
          @signature_elems
              or error __x"signature element not found in answer";

          # We can leave the checking via exceptions, so have to reset
          # the counters for the next message first.
          my @e = @elems_to_check;  @elems_to_check  = ();
          my @s = @signature_elems; @signature_elems = ();

          $check_signature->($container, $_, \@e) for @s;
          $data;
        }
      );

    $self;
}

# The checker routines throw an exception on error
sub checker($@)
{   my $self   = shift;
    my $config = $self->{XCWS_config};
    my %args   = (%$config, @_);

    my $si         = $self->signedInfo;
    my $si_checker = $si->checker($self, %args);
    my $get_tokens = $self->keyInfo->getTokens($self, %args);

    sub {
        my ($container, $sig, $elems) = @_;
        my $ki        = $sig->{ds_KeyInfo};
        my @tokens    = $ki ? $get_tokens->($ki, $container, $sig->{Id}) : ();

        # Hey, you try to get tokens up in the hierachy in a recursive
        # nested program yourself!
        $ki->{__TOKENS} = \@tokens;

        ### check the signed-info content

        my $info      = $sig->{ds_SignedInfo};
        $si_checker->($info, $elems, \@tokens);

        ### Check the signature of the whole block

        my $canon    = $info->{ds_CanonicalizationMethod};
        my $preflist = $canon->{c14n_InclusiveNamespaces}{PrefixList}; # || [];
        my $canonic  = $si->_get_canonic($canon->{Algorithm}, $preflist);
        my $sigvalue = $sig->{ds_SignatureValue}{_};

        my $signer   = XML::Compile::WSS::Sign->new
          ( sign_method => $info->{ds_SignatureMethod}{Algorithm}
          , public_key  => $tokens[0]
          );

        $signer->checker->($canonic->($info->{_XML_NODE}), $sigvalue)
            or error __x"received signature value is incorrect";

    };
}

sub builder(%)
{   my $self   = shift;
    my $config = $self->{XCWS_config};
    my %args   = (%$config, @_);

    my $signer     = $self->signer;
    my $signmeth   = $signer->signMethod;
    my $sign       = $signer->builder($self, %args);
    my $signedinfo = $self->signedInfo->builder($self, %args);
    my $keylink    = $self->keyInfo->builder($self, %args);
    my $token      = $self->token;
    my $tokenw     = $token->isa('XML::Compile::WSS::SecToken::EncrKey')
      ? $token->builder($self, %args) : undef;

    my $sigw       = $self->schema->writer('ds:Signature');

    # sign the signature!
    my $subsign;
    if(my $subsig = $self->{XCWS_subsig})
    {   $subsign = $subsig->builder;
    }

    my $unique = time;

    sub {
        my ($doc, $elems, $sec_node) = @_;
        my ($sinfo, $si_canond) = $signedinfo->($doc, $elems, $signmeth);

        $sec_node->appendChild($tokenw->($doc, $sec_node))
           if $tokenw;

        my $signature = $sign->($si_canond);
        my %sig =
          ( ds_SignedInfo     => $sinfo
          , ds_SignatureValue => {_ => $signature}
          , ds_KeyInfo        => $keylink->($doc, $token, $sec_node)
          , Id                => 'SIG-'.$unique++
          );
        my $signode   = $sigw->($doc, \%sig);
        $sec_node->appendChild($signode);

        $subsign->($doc, [$signode], $sec_node)
            if $subsign;

        $sec_node;
    };
}

sub prepareWriting($)
{   my ($self, $schema) = @_;
    $self->SUPER::prepareWriting($schema);

    $self->token
        or error __x"creating signatures needs a token";

    my $config = $self->{XCWS_config};

    my @elems_to_sign;
    $schema->addHook
      ( action   => 'WRITER'
      , type     => ($config->{sign_types} or panic)
      , after    => sub {
          my ($doc, $xml) = @_;

          unless($xml->getAttributeNS(WSU_10, 'Id'))
          {   my $wsuid = 'node-'.($xml+0);      # configurable?
              $xml->setNamespace(WSU_10, wsu => 0);
              $xml->setAttributeNS(WSU_10, Id => $wsuid);

              # Above two lines do add a xml:wsu per Id.  Below does not,
              # which is not always enough: elements live in weird places
              #  my $wsu   = $schema->prefixFor(WSU_10);
              #  $xml->setAttribute("$wsu:Id", $wsuid);
          }

#use XML::Compile::Util qw/type_of_node/;
#warn "Registering to sign ".type_of_node($xml);
          push @elems_to_sign, $xml;
          $xml;
        }
      );

    my $container;
    $schema->addHook
      ( action => 'WRITER'
      , type   => ($config->{sign_put} || panic)
      , after  => sub {
          my ($doc, $xml) = @_;
#warn "Located signature container";
#         $schema->prefixFor(WSU_10);
          $container = $xml;
        }
      );

    my $add_signature = $self->builder;
    $schema->addHook
      ( action => 'WRITER'
      , type   => ($config->{sign_when} || panic)
      , after  => sub {
          my ($doc, $xml) = @_;
#warn "Creating signature";
          $add_signature->($doc, \@elems_to_sign, $container);
          @elems_to_sign = ();
          $xml;
        }
      );

    $self;
}

sub loadSchemas($$)
{   my ($self, $schema, $version) = @_;
    return if $schema->{XCWS_sig_loaded}++;

    $self->SUPER::loadSchemas($schema, $version);

    my $xsddir = dirname __FILE__;
    trace "loading wss-dsig schemas from $xsddir/(dsig|encr)/*.xsd";

    my @xsds   =
      ( bsd_glob("$xsddir/dsig/*.xsd")
      , bsd_glob("$xsddir/encr/*.xsd")
      );

    $schema->addPrefixes(\%prefixes);
    my $prefixes = join ',', sort keys %prefixes;
    $schema->addKeyRewrite("PREFIXED($prefixes)");

    $schema->importDefinitions(\@xsds);

    $schema;
}

1;