File Coverage

blib/lib/Protocol/DBus/Authn.pm
Criterion Covered Total %
statement 98 141 69.5
branch 18 50 36.0
condition 5 18 27.7
subroutine 16 21 76.1
pod 0 5 0.0
total 137 235 58.3


line stmt bran cond sub pod time code
1             package Protocol::DBus::Authn;
2              
3 9     9   1515 use strict;
  9         18  
  9         221  
4 9     9   69 use warnings;
  9         20  
  9         230  
5              
6 9     9   3369 use IO::Framed ();
  9         39377  
  9         178  
7 9     9   72 use Module::Load ();
  9         19  
  9         109  
8 9     9   37 use Socket ();
  9         10  
  9         106  
9              
10 9     9   3247 use Protocol::DBus::X ();
  9         22  
  9         283  
11              
12 9     9   50 use constant _CRLF => "\x0d\x0a";
  9         18  
  9         699  
13              
14 9     9   50 use constant DEBUG => 0;
  9         18  
  9         12752  
15              
16             sub new {
17 2     2 0 373608 my ($class, %opts) = @_;
18              
19 2         74 my @missing = grep { !$opts{$_} } qw( socket mechanism );
  4         87  
20 2 50       94 die "Need: @missing" if @missing;
21              
22 2         73 $opts{"_$_"} = delete $opts{$_} for keys %opts;
23              
24 2         218 $opts{'_can_pass_unix_fd'} = Socket::MsgHdr->can('new');
25 2   33     102 $opts{'_can_pass_unix_fd'} &&= Socket->can('SCM_RIGHTS');
26 2   33     34 $opts{'_can_pass_unix_fd'} &&= _is_unix_socket($opts{'_socket'});
27              
28 2         127 $opts{'_io'} = IO::Framed->new( $opts{'_socket'} )->enable_write_queue();
29              
30 2         439 my $self = bless \%opts, $class;
31              
32 2 50       33 $self->_set_mechanism( $opts{'_mechanism'} ) or do {
33 0         0 die "“$opts{'_mechanism'}” is not a valid authn mechanism.";
34             };
35              
36 2         8 return $self;
37             }
38              
39             sub _set_mechanism {
40 2     2   167 my ($self, $mechanism) = @_;
41              
42 2 50       38 if (!ref $mechanism) {
43 2         24 my $module = __PACKAGE__ . "::Mechanism::$mechanism";
44              
45 2         5 my $err = $@;
46 2 50       11 if (!eval { Module::Load::load($module); 1 } ) {
  2         30  
  2         598  
47 0         0 DEBUG && print STDERR "Failed to load $mechanism authn module: $@";
48 0         0 return 0;
49             }
50 2         4 $@ = $err;
51              
52 2         73 $self->{'_mechanism'} = $module->new();
53             }
54              
55 2         22 $self->{'_xaction'} = $self->_create_xaction();
56              
57 2         14 return 1;
58             }
59              
60             sub negotiated_unix_fd {
61 0 0   0 0 0 return $_[0]->{'_negotiated_unix_fd'} ? 1 : 0;
62             }
63              
64             # Whether a send is pending (1) or a receive (0).
65             sub pending_send {
66 0     0 0 0 my ($self) = @_;
67              
68 0         0 my $next_is_receive = $self->{'_xaction'}[0];
69 0   0     0 $next_is_receive &&= $next_is_receive->[0];
70              
71 0 0       0 if (!defined $next_is_receive) {
72 0         0 die "Authn transaction is done!";
73             }
74              
75 0         0 return !$next_is_receive;
76             }
77              
78             sub go {
79 2     2 0 14 my ($self) = @_;
80              
81 2         5 my $s = $self->{'_socket'};
82              
83             # Don’t send_initial() if !must_send_initial().
84 2   33     41 $self->{'_sent_initial'} ||= !$self->{'_mechanism'}->must_send_initial() || $self->{'_mechanism'}->send_initial($s);
      33        
85              
86 2 50       6 if ($self->{'_sent_initial'}) {
87             LINES:
88             {
89 2 50       8 if ( $self->{'_io'}->get_write_queue_count() ) {
  2         36  
90 0 0       0 $self->flush_write_queue() or last LINES;
91             }
92              
93 2         24 my $dollar_at = $@;
94 2         3 my $ok = eval {
95 2         8 while ( my $cur = $self->{'_xaction'}[0] ) {
96 8 100       31 if ($cur->[0]) {
97 3 50       12 my $line = $self->_read_line() or last LINES;
98 3         18 $cur->[1]->($self, $line);
99             }
100             else {
101 5         11 my @line_parts;
102              
103 5 100       14 if ('CODE' eq ref $cur->[1]) {
104 1         5 @line_parts = $cur->[1]->($self);
105             }
106             else {
107 4         12 @line_parts = @{$cur}[ 1 .. $#$cur ];
  4         13  
108             }
109              
110 5 50       55 $self->_send_line("@line_parts") or last LINES;
111              
112 5         28477 push @{ $self->{'_tried_mechanism'} }, $self->{'_mechanism'}->label();
  5         129  
113             }
114              
115 8         13 shift @{ $self->{'_xaction'} };
  8         42  
116             }
117              
118 2         8 1;
119             };
120              
121 2 50       16 if (!$ok) {
122 0         0 my $err = $@;
123 0 0       0 if (eval { $err->isa('Protocol::DBus::X::Rejected') }) {
  0         0  
124              
125 0         0 $self->{'_mechanism'}->on_rejected();
126              
127 0         0 my @to_try;
128              
129 0         0 for my $mech ( @{ $err->get('mechanisms') } ) {
  0         0  
130 0 0       0 if (!grep { $_ eq $mech } @{ $self->{'_tried_mechanism'} }) {
  0         0  
  0         0  
131 0         0 push @to_try, $mech;
132             }
133             }
134              
135 0         0 while (my $mech = shift @to_try) {
136 0 0       0 if ($self->_set_mechanism($mech)) {
137 0         0 redo LINES;
138             }
139             }
140              
141 0         0 die "Exhausted all authentication mechanisms! (@{ $self->{'_tried_mechanism'} })";
  0         0  
142             }
143             else {
144 0         0 local $@ = $err;
145 0         0 die;
146             }
147             }
148              
149 2         74 return 1;
150             }
151             }
152              
153 0         0 return undef;
154             }
155              
156             sub cancel {
157 0     0 0 0 my ($self) = @_;
158              
159 0         0 die 'unimplemented';
160             }
161              
162             sub _create_xaction {
163 2     2   18 my ($self) = @_;
164              
165 2         16 my $auth_label = 'AUTH';
166              
167             # Unless the mechanism sends its own initial NUL, might as well use the
168             # same system call to send the initial NUL as we use to send the AUTH.
169 2 50 33     49 if (!$self->{'_sent_initial'} && !$self->{'_mechanism'}->must_send_initial()) {
170 2         13 substr( $auth_label, 0, 0 ) = "\0";
171             }
172              
173             # 0 = send; 1 = receive
174             my @xaction = (
175             [ 0 => $auth_label, $self->{'_mechanism'}->label(), $self->{'_mechanism'}->INITIAL_RESPONSE() ],
176              
177             # e.g., for exchange of DATA
178 2         224 $self->{'_mechanism'}->AFTER_AUTH(),
179              
180             [ 1 => \&_consume_ok ],
181             );
182              
183 2 50       26 if ($self->{'_can_pass_unix_fd'}) {
184 0         0 push @xaction, (
185             [ 0 => 'NEGOTIATE_UNIX_FD' ],
186             [ 1 => \&_consume_agree_unix_fd ],
187             );
188             }
189              
190 2         23 push @xaction, [ 0 => 'BEGIN' ];
191              
192 2         24 return \@xaction;
193             }
194              
195             sub _consume_agree_unix_fd {
196 0     0   0 my ($self, $line) = @_;
197              
198 0 0       0 if ($line eq 'AGREE_UNIX_FD') {
    0          
199 0         0 $self->{'_negotiated_unix_fd'} = 1;
200             }
201             elsif (index($line, 'ERROR ') == 0) {
202 0         0 warn "Server rejected unix fd passing: " . substr($line, 6) . $/;
203             }
204              
205 0         0 return;
206             }
207              
208             sub _consume_ok {
209 2     2   19 my ($self, $line) = @_;
210              
211 2 50       13 if (index($line, 'OK ') == 0) {
212 2         17 $self->{'_server_guid'} = substr($line, 3);
213             }
214             else {
215 0         0 die "Unrecognized response: $line";
216             }
217              
218 2         6 return;
219             }
220              
221             sub _send_line {
222 5     5   14 my ($self) = @_;
223              
224 5         7 DEBUG() && print STDERR "AUTHN SENDING: [$_[1]]$/";
225              
226 5         71 $self->{'_io'}->write( $_[1] . _CRLF() );
227              
228 5         96 return $self->_flush_write_queue();
229             }
230              
231             sub _flush_write_queue {
232 5     5   9 my ($self) = @_;
233              
234 5         124 local $SIG{'PIPE'} = 'IGNORE';
235              
236 5         90 return $self->{'_io'}->flush_write_queue();
237             }
238              
239             sub _read_line {
240 3     3   73 my $line;
241              
242 3         22 DEBUG() && print STDERR "AUTHN RECEIVING …$/";
243              
244 3 50       61 if ($line = $_[0]->{'_io'}->read_until("\x0d\x0a")) {
245 3         19533 substr( $line, -2 ) = q<>;
246              
247 3         7 DEBUG() && print STDERR "AUTHN RECEIVED: [$line]$/";
248              
249 3 50       14 if (0 == index( $line, 'REJECTED ')) {
250 0         0 die Protocol::DBus::X->create(
251             'Rejected',
252             split( m< >, substr( $line, 9 ) ),
253             );
254             }
255             }
256              
257 3         13 return $line;
258             }
259              
260             sub _is_unix_socket {
261 0     0     my ($sk) = @_;
262              
263 0 0         my $sname = getsockname($sk) or die "getsockname(): $!";
264              
265 0           return Socket::sockaddr_family($sname) == Socket::AF_UNIX();
266             }
267              
268             1;