line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# https://dbus.freedesktop.org/doc/dbus-specification.html#auth-mechanisms-sha |
4
|
|
|
|
|
|
|
|
5
|
4
|
|
|
4
|
|
1940
|
use strict; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
116
|
|
6
|
4
|
|
|
4
|
|
24
|
use warnings; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
112
|
|
7
|
|
|
|
|
|
|
|
8
|
4
|
|
|
4
|
|
20
|
use parent qw( Protocol::DBus::Authn::Mechanism ); |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
24
|
|
9
|
|
|
|
|
|
|
|
10
|
4
|
|
|
4
|
|
168
|
use Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1::Pieces (); |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
52
|
|
11
|
|
|
|
|
|
|
|
12
|
4
|
|
|
4
|
|
20
|
use File::Spec (); |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
80
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
my $sha_module; |
15
|
|
|
|
|
|
|
|
16
|
4
|
|
|
4
|
|
20
|
use constant must_send_initial => 0; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
260
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
use constant { |
19
|
4
|
|
|
|
|
2740
|
DEBUG => 0, |
20
|
4
|
|
|
4
|
|
28
|
}; |
|
4
|
|
|
|
|
8
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub new { |
23
|
1
|
|
|
1
|
0
|
6
|
my ($class) = @_; |
24
|
|
|
|
|
|
|
|
25
|
1
|
|
|
|
|
9
|
local $@; |
26
|
|
|
|
|
|
|
|
27
|
1
|
50
|
|
|
|
3
|
if ( eval { require Digest::SHA1; 1 } ) { |
|
1
|
50
|
|
|
|
231
|
|
|
0
|
|
|
|
|
0
|
|
28
|
0
|
|
|
|
|
0
|
$sha_module = 'Digest::SHA1'; |
29
|
|
|
|
|
|
|
} |
30
|
1
|
|
|
|
|
1136
|
elsif ( eval { require Digest::SHA; 1 } ) { |
|
1
|
|
|
|
|
4124
|
|
31
|
1
|
|
|
|
|
12
|
$sha_module = 'Digest::SHA'; |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
else { |
34
|
0
|
|
|
|
|
0
|
die "No SHA module available!"; |
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
|
37
|
1
|
|
|
|
|
20
|
return $class->SUPER::new( @_[ 1 .. $#_ ] ); |
38
|
|
|
|
|
|
|
} |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
sub INITIAL_RESPONSE { |
41
|
1
|
|
|
1
|
0
|
4
|
my ($self) = @_; |
42
|
|
|
|
|
|
|
|
43
|
1
|
|
|
|
|
9
|
return unpack( 'H*', ($self->_getpw())[0] ); |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
sub AFTER_AUTH { |
47
|
1
|
|
|
1
|
0
|
32
|
my ($self) = @_; |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
return ( |
50
|
|
|
|
|
|
|
[ 1 => sub { |
51
|
1
|
|
|
1
|
|
8
|
_consume_data($self, @_); |
52
|
1
|
|
|
|
|
37
|
} ], |
53
|
|
|
|
|
|
|
[ 0 => \&_authn_respond_data ], |
54
|
|
|
|
|
|
|
); |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
sub _getpw { |
58
|
0
|
|
|
0
|
|
0
|
my ($self) = @_; |
59
|
|
|
|
|
|
|
|
60
|
0
|
|
0
|
|
|
0
|
$self->{'_pw'} ||= [ getpwuid $> ]; |
61
|
|
|
|
|
|
|
|
62
|
0
|
|
|
|
|
0
|
return @{ $self->{'_pw'} }; |
|
0
|
|
|
|
|
0
|
|
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
sub _consume_data { |
66
|
1
|
|
|
1
|
|
3
|
my ($self, $authn, $line) = @_; |
67
|
|
|
|
|
|
|
|
68
|
1
|
50
|
|
|
|
6
|
if (0 != index($line, 'DATA ')) { |
69
|
0
|
|
|
|
|
0
|
die "Invalid line: [$line]"; |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
1
|
|
|
|
|
4
|
substr( $line, 0, 5, q<> ); |
73
|
|
|
|
|
|
|
|
74
|
1
|
|
|
|
|
12
|
my ($ck_ctx, $ck_id, $sr_challenge) = split m< >, pack( 'H*', $line ); |
75
|
|
|
|
|
|
|
|
76
|
1
|
|
|
|
|
3
|
if (DEBUG()) { |
77
|
|
|
|
|
|
|
print STDERR ( |
78
|
|
|
|
|
|
|
"AUTHN/SHA1 context: $ck_ctx$/", |
79
|
|
|
|
|
|
|
"AUTHN/SHA1 cookie ID: $ck_id$/", |
80
|
|
|
|
|
|
|
"AUTHN/SHA1 server challenge: $sr_challenge$/", |
81
|
|
|
|
|
|
|
); |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
1
|
|
|
|
|
5
|
my $cookie = $self->_get_cookie($ck_ctx, $ck_id); |
85
|
|
|
|
|
|
|
|
86
|
1
|
|
|
|
|
7
|
my $cl_challenge = _create_challenge(); |
87
|
|
|
|
|
|
|
|
88
|
1
|
|
|
|
|
16
|
my $str = join( |
89
|
|
|
|
|
|
|
':', |
90
|
|
|
|
|
|
|
$sr_challenge, |
91
|
|
|
|
|
|
|
$cl_challenge, |
92
|
|
|
|
|
|
|
$cookie, |
93
|
|
|
|
|
|
|
); |
94
|
|
|
|
|
|
|
|
95
|
1
|
|
|
|
|
5
|
my $str_digest = _sha1_hex($str); |
96
|
|
|
|
|
|
|
|
97
|
1
|
|
|
|
|
3
|
if (DEBUG()) { |
98
|
|
|
|
|
|
|
print STDERR ( |
99
|
|
|
|
|
|
|
"AUTHN/SHA1 cookie: $cookie$/", |
100
|
|
|
|
|
|
|
"AUTHN/SHA1 client challenge: $ck_id$/", |
101
|
|
|
|
|
|
|
"AUTHN/SHA1 string: $str$/", |
102
|
|
|
|
|
|
|
); |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
1
|
|
|
|
|
19
|
$authn->{'_sha1_response'} = unpack 'H*', "$cl_challenge $str_digest"; |
106
|
|
|
|
|
|
|
|
107
|
1
|
|
|
|
|
5
|
return; |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
sub _authn_respond_data { |
111
|
|
|
|
|
|
|
return ( |
112
|
|
|
|
|
|
|
'DATA', |
113
|
1
|
|
33
|
1
|
|
7
|
$_[0]->{'_sha1_response'} || do { |
114
|
|
|
|
|
|
|
die "No SHA1 DATA response set!"; |
115
|
|
|
|
|
|
|
}, |
116
|
|
|
|
|
|
|
); |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
*_sha1_hex = \&Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1::Pieces::sha1_hex; |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
*_create_challenge = \&Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1::Pieces::create_challenge; |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
sub _get_cookie { |
124
|
1
|
|
|
1
|
|
3
|
my ($self, $ck_ctx, $ck_id) = @_; |
125
|
|
|
|
|
|
|
|
126
|
1
|
|
|
|
|
8
|
return Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1::Pieces::get_cookie( |
127
|
|
|
|
|
|
|
($self->_getpw())[7], |
128
|
|
|
|
|
|
|
$ck_ctx, |
129
|
|
|
|
|
|
|
$ck_id, |
130
|
|
|
|
|
|
|
); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
1; |