The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/env perl
#
# Verify that, when "created" is passed as a number in wsseBasicAuth,
# it gets encrypted the right way.  Check using both integer and
# string timestamps, with Nonce and without.
#
# In version 0.90, this was not true.
#

use strict ;
use warnings ;

use Digest::SHA1            qw/sha1_base64/;
use Encode                  qw/encode/;
use MIME::Base64            qw/encode_base64 decode_base64/ ;

use Test::More tests => 24 ;

use XML::Compile::WSDL11;
use XML::Compile::SOAP::WSS;
use XML::Compile::WSS::Util qw/:utp11/;

my ($username, $password) = qw/username password/;

my $wsdl     = XML::Compile::WSDL11->new('t/example.wsdl');
my $wss      = XML::Compile::SOAP::WSS->new(version => 1.1, schema => $wsdl);

my $now      = time() ;
my $nonce    = 'insecure' ;

my $untype   = $wss->schema->findName('wsse:UsernameToken');
my $unreader = $wss->schema->reader($untype) ;

my @testCases = ( { nonce => $nonce, created => $now, _explain => 'integer, with Nonce' },
                  { created => $now, _explain => 'integer, no Nonce' },
                  { nonce => $nonce, created => '2012-08-17T12:02:26Z', _explain => 'string, with Nonce' },
                  { created => '2012-08-17T12:02:26Z', _explain => 'string, no Nonce' },
              ) ;

foreach my $t (@testCases) {
    my $explain = delete $t->{_explain} || 'huh??' ;

    my $usernameToken = $wss->wsseBasicAuth($username, $password, UTP11_PDIGEST
                                                , %$t
                                            );
    ok($usernameToken, "PasswordDigest returns something sensible, $explain");
    my $utString = $usernameToken->{$untype}->toString() ;

    ok( my $p = eval { $unreader->($utString) }
            , "UsernameToken is legible, $explain" )
        or do { diag($@) ; diag( "Bad string (skip encryption test):\n$utString" ) } ;
  SKIP: {
        # Only check encryption if there's a valid interpretation in
        # the first place, because it ain't going to work otherwise.
        # And the failure above means the whole test is going to be a
        # failure anyway.
        skip 'UsernameToken is illegible' => 4 unless $p ;

        checkEncryption( $p, $t->{nonce}, $password, $explain ) ;
    } ;
}


# Verify that, if one unpacks the Nonce and Created from the
# UsernameToken, the SHA1 goes back together the right way.
#
# This method always runs four tests.  Probably, this should just
# become a subtest; then we could remove the "free pass"
sub checkEncryption {
    my ($un, $nonce, $password, $explain) = @_ ;

    $nonce ||= '' ;
    if( $nonce ) {
        my $enc = $un->{wsse_Nonce}->{_} ;
        ok( $enc, 'Nonce is required and present' ) ;
        is( decode_base64( $enc ), $nonce, 'Nonce decodes correctly' )
    }
    else {
        ok( ! $un->{wsse_Nonce}, 'Nonce is appropriately absent' ) ;
        ok( 1, 'Free pass, to make the test-counts balance' ) ;
    }

    ok( $un->{wsu_Created}->{_}, "Created is present, $explain" ) ;
        # or diag( Data::Dumper->Dump( [$un], ['usernametoken'] ) ) ;
    my $plainPassword = join( '', $nonce, $un->{wsu_Created}->{_}, $password ) ;

    is( sha1_base64(encode( utf8 => $plainPassword )) . '=', $un->{wsse_Password}->{_},
        "Password is encrypted correctly, $explain" ) ;
}