File Coverage

blib/lib/Thrift/SASL/Transport.pm
Criterion Covered Total %
statement 18 125 14.4
branch 0 70 0.0
condition 0 28 0.0
subroutine 6 20 30.0
pod 0 9 0.0
total 24 252 9.5


line stmt bran cond sub pod time code
1             package Thrift::SASL::Transport;
2             $Thrift::SASL::Transport::VERSION = '0.007';
3 1     1   62570 use strict;
  1         9  
  1         25  
4 1     1   5 use warnings;
  1         1  
  1         52  
5 1     1   559 use Data::Dumper;
  1         5863  
  1         53  
6              
7             # Nasty hack to make the Thrift libs handle the extra 4-bytes
8             # header put by GSSAPI in front of unencoded (auth only) replies
9              
10 1     1   394 use Thrift::BinaryProtocol;
  1         17899  
  1         39  
11             my $real_readMessageBegin = \&Thrift::BinaryProtocol::readMessageBegin;
12             {
13 1     1   6 no warnings 'redefine';
  1         3  
  1         105  
14             *Thrift::BinaryProtocol::readMessageBegin = \&BinaryProtocolOverride_readMessageBegin;
15             }
16              
17             sub BinaryProtocolOverride_readMessageBegin {
18 0     0 0   my $self = shift;
19 0 0 0       if ( $self->{trans}{_sasl_client} && !$self->{trans}{_sasl_encode} ) {
20 0           $self->readI32( \my $foo ); # discard GSSAPI auth header (message length)
21             }
22 0           return $real_readMessageBegin->( $self, @_ );
23             }
24              
25             # end of nasty hack, phew.
26              
27             use constant {
28 1         1391 SASL_START => 1,
29             SASL_OK => 2,
30             SASL_BAD => 3,
31             SASL_ERROR => 4,
32             SASL_COMPLETE => 5,
33 1     1   7 };
  1         2  
34              
35             sub new {
36 0     0 0   my ( $class, $transport, $sasl, $debug, $principal ) = @_;
37 0 0 0       return bless {
38             _transport => $transport,
39             _sasl => $sasl,
40             _debug => $debug || 0,
41             ($principal ? (_principal => $principal): ()),
42             }, $class;
43             }
44              
45             sub _sasl_write {
46 0     0     my ( $self, $code, $payload ) = @_;
47 0   0       $payload //= '';
48 0           print STDERR "<< code $code + payload (@{[bytes::length($payload)]} bytes)\n"
49 0 0         if $self->{_debug};
50 0           $self->{_transport}->write( pack "CN", $code, bytes::length($payload) );
51 0           $self->{_transport}->write($payload);
52 0           $self->{_transport}->flush;
53             }
54              
55             sub _sasl_read {
56 0     0     my ($self) = @_;
57 0           my $data = $self->read(5);
58 0 0         die "No data from server" unless defined $data;
59 0           my ( $code, $length ) = unpack "CN", $data;
60 0 0         if ($length) {
61 0           $data = $self->read($length);
62             }
63             else {
64 0           $data = undef;
65             }
66             print STDERR ">> code $code + response ($length bytes)\n"
67 0 0         if $self->{_debug};
68 0           return ( $code, $data );
69             }
70              
71             sub open {
72 0     0 0   my ($self) = @_;
73 0 0 0       $self->{_transport}->open if !( $self->{_transport} && $self->isOpen );
74 0 0         die "Could not open transport" if !$self->isOpen;
75 0   0       return $self->{_sasl_client} || $self->_sasl_handshake;
76             }
77              
78             sub close {
79 0     0 0   my ($self) = @_;
80 0 0 0       $self->{_transport}->close if $self->{_transport} && $self->isOpen;
81 0           return 1;
82             }
83              
84             sub _sasl_handshake {
85 0     0     my ($self) = @_;
86              
87             print STDERR "SASL start: "
88 0 0         if $self->{_debug};
89 0           $self->_sasl_write( SASL_START, $self->{_sasl}->mechanism );
90              
91             # The socket passed to BufferedTransport was put in that object's
92             # "transport" property, this is a bit confusing imho
93 0           my $client;
94 0 0         if($self->{_sasl}->mechanism eq 'GSSAPI'){
    0          
95 0 0         if(!$self->{_principal}){
96 0           die "Principal needs to be specified for kerberos authentication."
97             }
98 0           my @kerberos_name_split = split('[/@]', $self->{_principal});
99 0 0         if(scalar @kerberos_name_split != 3){
100 0           die "Kerberos principal name should have 3 parts. Eg: hive/_HOST\@REALM.COM";
101             }
102 0           $client = $self->{_sasl}->client_new( $kerberos_name_split[0], $kerberos_name_split[1] );
103             }elsif($self->{_sasl}->mechanism eq 'DIGEST-MD5'){
104             # Server is configured with null and default for authentication with delegationtoken.
105 0           $client = $self->{_sasl}->client_new( 'null', 'default' );
106             }else{
107             #Keeping this line here for keep support for other mechanisms.
108 0           $client = $self->{_sasl}->client_new( 'hive', $self->{_transport}{transport}{host} );
109             }
110 0           my $resp = $client->client_start();
111              
112 0           my $step;
113 0           while ( ++$step ) {
114             print STDERR "SASL step $step: "
115 0 0         if $self->{_debug};
116              
117             #print STDERR Dumper{map {$_ => [$client->$_()]} qw(error code mechanism need_step)};
118 0           $self->_sasl_write( SASL_OK, $resp );
119 0           my ( $code, $data ) = $self->_sasl_read();
120              
121 0 0         if ( $code == SASL_COMPLETE ) {
122             print STDERR "Authentication OK\n"
123 0 0         if $self->{_debug};
124              
125             #$client->client_step($data // '') if $client->need_step;
126 0           last;
127             }
128              
129 0           my $extra_msg = $self->__probe_env_and_xs_sasl_bug( $client );
130              
131 0 0 0       if ( $code == SASL_BAD || $code == SASL_ERROR ) {
132 0 0         die sprintf "Authentication failed: %s > %s%s",
133             $code,
134             $data,
135             $extra_msg ? '. ' . $extra_msg : '',
136             ;
137             }
138              
139 0           $resp = $client->client_step($data);
140 0 0         if ( ! defined $data ) {
141 0 0         die sprintf 'Client rejected authentication%s',
142             $extra_msg ? '. ' . $extra_msg : '',
143             ;
144             }
145             }
146              
147 0           $self->{_sasl_encode_check} = 1;
148 0           $self->{_sasl_client} = $client;
149              
150 0           return $self->{_sasl_client};
151             }
152              
153             sub __probe_env_and_xs_sasl_bug {
154             # See: https://github.com/Perl-Hadoop/Thrift-SASL/issues/1
155             #
156 0     0     my($self, $client) = @_;
157 0 0 0       return if ! $client->isa('Authen::SASL::XS')
158             && ! $client->isa('Authen::SASL::Cyrus')
159             ;
160              
161 0 0 0       return if exists $ENV{USER} || exists $ENV{USERNAME};
162              
163 0           my $sasl_class = ref $client;
164              
165 0           return join ' ',
166             "cyrus-sasl and in turn $sasl_class needs either USER or USERNAME",
167             'environment variable to be present and they seem to be missing',
168             'in your environment.',
169             'The error you have received might be caused by that.',
170             ;
171             }
172              
173             sub write {
174 0     0 0   my $self = shift;
175 0           my $buffer = shift;
176             print STDERR "<< writing " . bytes::length($buffer) . " bytes\n"
177 0 0         if $self->{_debug} > 1;
178 0           $self->{_out_buffer} .= $buffer;
179 0           return 1;
180             }
181              
182             sub read {
183 0     0 0   my $self = shift;
184 0           my @passthru_args = @_;
185             print STDERR ">> reading\n"
186 0 0         if $self->{_debug};
187 0           my $buf = $self->{_transport}->read(@passthru_args);
188 0 0         return $buf if bytes::length($buf) > 0;
189              
190             # not sure about this, it is copied over from the python version
191 0           $self->_read_frame();
192 0           return $self->{_transport}->read(@passthru_args);
193             }
194              
195             # completely unsure about this, taken from the python version when trying to
196             # make the whole thing work, turned out my problem was with the BinaryProtocol
197             # needing a 4-byte offset on readMessageBegin as kerberos auth adds a 4 bytes
198             # header to replies, which was mistakenly used as the expected thrift header.
199             # leaving this in place in case it is actually needed (probably not working
200             # in the current state though)
201             sub _read_frame {
202 0     0     my $self = shift;
203 0           my $header = $self->{_transport}->readAll(4);
204 0           my $length = unpack( "N", $header );
205 0           my $decoded;
206 0 0         if ( $self->{_sasl_encode} ) {
207 0           my $encoded = $header . $self->{_transport}->readAll($length);
208 0 0         my $decoded = $self->{_sasl_client}->decode($encoded)
209             or die 'SASL decode returned nothing';
210              
211             # TODO throw a real per TTransportException like the python version
212             #die "SASL decode error: " .
213             # raise TTransportException(type=TTransportException.UNKNOWN,
214             # message=self.sasl.getError())
215             }
216             else {
217 0           $decoded = $self->{_transport}->readAll($length);
218             }
219 0           $self->{_transport}{rBuf} = $decoded;
220             }
221              
222             sub flush {
223 0     0 0   my $self = shift;
224              
225             print STDERR "<<< flush " . bytes::length( $self->{_out_buffer} ) . " bytes \n"
226 0 0         if $self->{_debug};
227              
228 0 0         if ( $self->{_sasl_encode_check} ) {
229 0           my $encoded = $self->{_sasl_client}->encode( $self->{_out_buffer} );
230 0 0 0       if ( bytes::length($encoded)
231             && bytes::length($encoded) != bytes::length( $self->{_out_buffer} ) )
232             {
233 0           $self->{_sasl_encode} = 1;
234 0 0         print STDERR "GSSAPI Will encode from now on\n" if $self->{_debug};
235             }
236             else {
237 0           $self->{_sasl_encode} = 0;
238 0 0         print STDERR "GSSAPI Will *not* encode from now on\n" if $self->{_debug};
239             }
240 0           $self->{_sasl_encode_check} = undef;
241             }
242 0 0         if ( $self->{_sasl_encode} ) {
243 0           $self->{_out_buffer} = $self->{_sasl_client}->encode( $self->{_out_buffer} );
244             }
245             else {
246             $self->{_out_buffer}
247 0           = pack( "N", bytes::length( $self->{_out_buffer} ) ) . $self->{_out_buffer};
248             }
249 0           $self->{_transport}->write( $self->{_out_buffer} );
250 0           $self->{_transport}->flush();
251 0           $self->{_out_buffer} = '';
252              
253             #print STDERR Dumper $self;
254             }
255              
256             sub isOpen {
257 0     0 0   shift->{_transport}->isOpen(@_);
258             }
259              
260             sub readAll {
261 0     0 0   my $self = shift;
262             print STDERR ">>> readAll $_[0] bytes\n"
263 0 0         if $self->{_debug} > 1;
264 0           my $ret = $self->{_transport}->readAll(@_);
265 0           return $ret;
266             }
267              
268             1;
269              
270             #ABSTRACT: Thrift Transport allowing Kerberos auth/encryption through GSSAPI
271              
272             __END__