line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyrights 2011-2014 by [Mark Overmeer]. |
2
|
|
|
|
|
|
|
# For other contributors see ChangeLog. |
3
|
|
|
|
|
|
|
# See the manual pages for details on the licensing terms. |
4
|
|
|
|
|
|
|
# Pod stripped from pm file by OODoc 2.01. |
5
|
1
|
|
|
1
|
|
2245
|
use warnings; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
39
|
|
6
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
77
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
package XML::Compile::WSS::BasicAuth; |
9
|
|
|
|
|
|
|
our $VERSION = '1.12'; |
10
|
|
|
|
|
|
|
|
11
|
1
|
|
|
1
|
|
6
|
use base 'XML::Compile::WSS'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
194
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
use Log::Report 'xml-compile-wss'; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
use XML::Compile::WSS::Util qw/:wss11 :utp11 WSM10_BASE64/; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
use Digest::SHA qw/sha1_base64/; |
18
|
|
|
|
|
|
|
use Encode qw/encode/; |
19
|
|
|
|
|
|
|
use MIME::Base64 qw/encode_base64/; |
20
|
|
|
|
|
|
|
use POSIX qw/strftime/; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
my @nonce_chars = ('A'..'Z', 'a'..'z', '0'..'9'); |
24
|
|
|
|
|
|
|
sub _random_nonce() { join '', map $nonce_chars[rand @nonce_chars], 1..5 } |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
sub init($) |
27
|
|
|
|
|
|
|
{ my ($self, $args) = @_; |
28
|
|
|
|
|
|
|
$args->{wss_version} ||= '1.1'; |
29
|
|
|
|
|
|
|
$self->SUPER::init($args); |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
$self->{XCWB_username} = $args->{username} |
32
|
|
|
|
|
|
|
or error __"no username provided for basic authentication"; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
$self->{XCWB_password} = $args->{password} |
35
|
|
|
|
|
|
|
or error __x"no password provided for basic authentication"; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
my $n = defined $args->{nonce} ? $args->{nonce} : 'RANDOM'; |
38
|
|
|
|
|
|
|
my $nonce = ref $n eq 'CODE' ? $n |
39
|
|
|
|
|
|
|
: $n eq 'RANDOM' ? \&_random_nonce |
40
|
|
|
|
|
|
|
: sub { $n }; |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
$self->{XCWB_nonce} = $args->{nonce}; |
43
|
|
|
|
|
|
|
$self->{XCWB_wsu_id} = $args->{wsu_Id} || $args->{wsu_id}; |
44
|
|
|
|
|
|
|
$self->{XCWB_created} = $args->{created}; |
45
|
|
|
|
|
|
|
$self->{XCWB_pwformat} = $args->{pwformat} || UTP11_PTEXT; |
46
|
|
|
|
|
|
|
$self; |
47
|
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
#---------------------------------- |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
sub username() {shift->{XCWB_username}} |
52
|
|
|
|
|
|
|
sub password() {shift->{XCWB_password}} |
53
|
|
|
|
|
|
|
sub nonce() {shift->{XCWB_nonce} } |
54
|
|
|
|
|
|
|
sub wsuId() {shift->{XCWB_wsu_id} } |
55
|
|
|
|
|
|
|
sub created() {shift->{XCWB_created} } |
56
|
|
|
|
|
|
|
sub pwformat() {shift->{XCWB_pwformat}} |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
sub prepareWriting($) |
59
|
|
|
|
|
|
|
{ my ($self, $schema) = @_; |
60
|
|
|
|
|
|
|
$self->SUPER::prepareWriting($schema); |
61
|
|
|
|
|
|
|
return if $self->{XCWB_login}; |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
my $nonce_type = $schema->findName('wsse:Nonce') ; |
64
|
|
|
|
|
|
|
my $w_nonce = $schema->writer($nonce_type, include_namespaces => 0); |
65
|
|
|
|
|
|
|
my $make_nonce = sub { |
66
|
|
|
|
|
|
|
my ($doc, $nonce) = @_; |
67
|
|
|
|
|
|
|
my $enc = encode_base64 $nonce; |
68
|
|
|
|
|
|
|
$enc =~ s/\n$//; |
69
|
|
|
|
|
|
|
$w_nonce->($doc, {_ => $enc, EncodingType => WSM10_BASE64}); |
70
|
|
|
|
|
|
|
}; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
my $created_type = $schema->findName('wsu:Created'); |
73
|
|
|
|
|
|
|
my $w_created = $schema->writer($created_type, include_namespaces => 0); |
74
|
|
|
|
|
|
|
my $make_created = sub { |
75
|
|
|
|
|
|
|
my ($doc, $created) = @_; |
76
|
|
|
|
|
|
|
$w_created->($doc, $created); |
77
|
|
|
|
|
|
|
}; |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
my $pw_type = $schema->findName('wsse:Password'); |
80
|
|
|
|
|
|
|
my $w_pw = $schema->writer($pw_type, include_namespaces => 0); |
81
|
|
|
|
|
|
|
my $make_pw = sub { |
82
|
|
|
|
|
|
|
my ($doc, $password, $pwformat) = @_; |
83
|
|
|
|
|
|
|
$w_pw->($doc, {_ => $password, Type => $pwformat}); |
84
|
|
|
|
|
|
|
}; |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
# UsernameToken is allowed to have an "wsu:Id" attribute |
87
|
|
|
|
|
|
|
# We set up the writer with a hook to add that particular attribute. |
88
|
|
|
|
|
|
|
my $un_type = $schema->findName('wsse:UsernameToken'); |
89
|
|
|
|
|
|
|
my $make_un = $schema->writer($un_type, include_namespaces => 1, |
90
|
|
|
|
|
|
|
, hook => $self->writerHookWsuId('wsse:UsernameTokenType')); |
91
|
|
|
|
|
|
|
$schema->prefixFor(WSU_10); # to get ns-decl |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
$self->{XCWB_login} = sub { |
94
|
|
|
|
|
|
|
my ($doc, $data) = @_; |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
my %login = |
97
|
|
|
|
|
|
|
( wsu_Id => $self->wsuId |
98
|
|
|
|
|
|
|
, wsse_Username => $self->username |
99
|
|
|
|
|
|
|
); |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
my $now = delete $data->{wsu_Created} || $self->created; |
102
|
|
|
|
|
|
|
my $created = $self->dateTime($now) || ''; |
103
|
|
|
|
|
|
|
$login{$created_type} = $make_created->($doc, $created) if $created; |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
my $nonce = delete $data->{wsse_Nonce} || $self->nonce || ''; |
106
|
|
|
|
|
|
|
$login{$nonce_type} = $make_nonce->($doc, $nonce) |
107
|
|
|
|
|
|
|
if length $nonce; |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
my $pwformat = $self->pwformat; |
110
|
|
|
|
|
|
|
my $password = $self->password; |
111
|
|
|
|
|
|
|
$created = $created->{_} if ref $created eq 'HASH'; |
112
|
|
|
|
|
|
|
$password = sha1_base64(encode utf8 => "$nonce$created$password").'=' |
113
|
|
|
|
|
|
|
if $pwformat eq UTP11_PDIGEST; |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
$login{$pw_type} = $make_pw->($doc, $password, $pwformat); |
116
|
|
|
|
|
|
|
$data->{$un_type} = $make_un->($doc, \%login); |
117
|
|
|
|
|
|
|
$data; |
118
|
|
|
|
|
|
|
}; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub create($$) |
122
|
|
|
|
|
|
|
{ my ($self, $doc, $data) = @_; |
123
|
|
|
|
|
|
|
$self->SUPER::create($doc, $data); |
124
|
|
|
|
|
|
|
$self->{XCWB_login}->($doc, $data); |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
1; |