File Coverage

blib/lib/MongoDB/_Credential.pm
Criterion Covered Total %
statement 63 184 34.2
branch 8 54 14.8
condition 11 26 42.3
subroutine 17 36 47.2
pod 0 2 0.0
total 99 302 32.7


line stmt bran cond sub pod time code
1             # Copyright 2014 - present MongoDB, Inc.
2             #
3             # Licensed under the Apache License, Version 2.0 (the "License");
4             # you may not use this file except in compliance with the License.
5             # You may obtain a copy of the License at
6             #
7             # http://www.apache.org/licenses/LICENSE-2.0
8             #
9             # Unless required by applicable law or agreed to in writing, software
10             # distributed under the License is distributed on an "AS IS" BASIS,
11             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12             # See the License for the specific language governing permissions and
13             # limitations under the License.
14              
15 60     60   85679 use strict;
  60         144  
  60         1681  
16 60     60   287 use warnings;
  60         134  
  60         2021  
17              
18             package MongoDB::_Credential;
19              
20 60     60   688 use version;
  60         1778  
  60         351  
21             our $VERSION = 'v2.2.2';
22              
23 60     60   4651 use Moo;
  60         9814  
  60         320  
24 60     60   18956 use MongoDB::Error;
  60         156  
  60         5638  
25 60     60   769 use MongoDB::Op::_Command;
  60         165  
  60         1707  
26 60         417 use MongoDB::_Types qw(
27             AuthMechanism
28             NonEmptyStr
29 60     60   322 );
  60         117  
30              
31 60     60   104920 use Digest::MD5 qw/md5_hex/;
  60         130  
  60         2934  
32 60     60   28037 use Encode qw/encode/;
  60         480587  
  60         4048  
33 60     60   504 use MIME::Base64 qw/encode_base64 decode_base64/;
  60         139  
  60         3059  
34 60     60   342 use Safe::Isa;
  60         117  
  60         6649  
35 60     60   377 use Tie::IxHash;
  60         120  
  60         1404  
36 60         458 use MongoDB::_Types qw(
37             Boolish
38 60     60   298 );
  60         140  
39 60         411 use Types::Standard qw(
40             CodeRef
41             HashRef
42             InstanceOf
43             Maybe
44             Str
45 60     60   34957 );
  60         129  
46              
47 60     60   61904 use namespace::clean -except => 'meta';
  60         129  
  60         493  
48              
49             # Required so we're sure it's passed explicitly, even if undef, so we don't
50             # miss wiring it up.
51             has monitoring_callback => (
52             is => 'ro',
53             required => 1,
54             isa => Maybe[CodeRef],
55             );
56              
57             has mechanism => (
58             is => 'ro',
59             isa => AuthMechanism,
60             required => 1,
61             );
62              
63             has username => (
64             is => 'ro',
65             isa => Str,
66             );
67              
68             has source => (
69             is => 'lazy',
70             isa => NonEmptyStr,
71             builder => '_build_source',
72             );
73              
74             has db_name => (
75             is => 'ro',
76             isa => Str,
77             );
78              
79             has password => (
80             is => 'ro',
81             isa => Str,
82             );
83              
84             has pw_is_digest => (
85             is => 'ro',
86             isa => Boolish,
87             );
88              
89             has mechanism_properties => (
90             is => 'ro',
91             isa => HashRef,
92             default => sub { {} },
93             );
94              
95             has _digested_password => (
96             is => 'lazy',
97             isa => Str,
98             builder => '_build__digested_password',
99             );
100              
101             has _scram_sha1_client => (
102             is => 'lazy',
103             isa => InstanceOf ['Authen::SCRAM::Client'],
104             builder => '_build__scram_sha1_client',
105             );
106              
107             has _scram_sha256_client => (
108             is => 'lazy',
109             isa => InstanceOf ['Authen::SCRAM::Client'],
110             builder => '_build__scram_sha256_client',
111             );
112              
113             sub _build__scram_sha1_client {
114 0     0   0 my ($self) = @_;
115             # loaded only demand as it has a long load time relative to other
116             # modules
117 0         0 require Authen::SCRAM::Client;
118 0         0 Authen::SCRAM::Client->VERSION(0.011);
119 0         0 return Authen::SCRAM::Client->new(
120             username => $self->username,
121             password => $self->_digested_password,
122             digest => 'SHA-1',
123             minimum_iteration_count => 4096,
124             skip_saslprep => 1,
125             );
126             }
127              
128             sub _build__scram_sha256_client {
129 0     0   0 my ($self) = @_;
130             # loaded only demand as it has a long load time relative to other
131             # modules
132 0         0 require Authen::SCRAM::Client;
133 0         0 Authen::SCRAM::Client->VERSION(0.007);
134 0         0 require Authen::SASL::SASLprep;
135 0         0 return Authen::SCRAM::Client->new(
136             username => $self->username,
137             password => Authen::SASL::SASLprep::saslprep($self->password),
138             digest => 'SHA-256',
139             minimum_iteration_count => 4096,
140             skip_saslprep => 1,
141             );
142             }
143              
144             sub _build__digested_password {
145 0     0   0 my ($self) = @_;
146 0 0       0 return $self->password if $self->pw_is_digest;
147 0         0 return md5_hex( encode( "UTF-8", $self->username . ":mongo:" . $self->password ) );
148             }
149              
150             sub _build_source {
151 21     21   373 my ($self) = @_;
152 21         84 my $mech = $self->mechanism;
153 21 100       80 if ( $mech eq 'PLAIN' ) {
154 2   100     48 return $self->db_name // '$external';
155             }
156 19 100 100     454 return $mech eq 'MONGODB-X509'
      100        
157             || $mech eq 'GSSAPI' ? '$external' : $self->db_name // 'admin';
158             }
159              
160             #<<< No perltidy
161             my %CONSTRAINTS = (
162             'MONGODB-CR' => {
163             username => sub { length },
164             password => sub { defined },
165             source => sub { length },
166             mechanism_properties => sub { !keys %$_ },
167             },
168             'MONGODB-X509' => {
169             password => sub { ! defined },
170             source => sub { $_ eq '$external' },
171             mechanism_properties => sub { !keys %$_ },
172             },
173             'GSSAPI' => {
174             username => sub { length },
175             source => sub { $_ eq '$external' },
176             },
177             'PLAIN' => {
178             username => sub { length },
179             password => sub { defined },
180             source => sub { length },
181             mechanism_properties => sub { !keys %$_ },
182             },
183             'SCRAM-SHA-1' => {
184             username => sub { length },
185             password => sub { defined },
186             source => sub { length },
187             mechanism_properties => sub { !keys %$_ },
188             },
189             'SCRAM-SHA-256' => {
190             username => sub { length },
191             password => sub { defined },
192             source => sub { length },
193             mechanism_properties => sub { !keys %$_ },
194             },
195             'DEFAULT' => {
196             username => sub { length },
197             password => sub { defined },
198             source => sub { length },
199             mechanism_properties => sub { !keys %$_ },
200             },
201             );
202             #>>>
203              
204             sub BUILD {
205 340     340 0 381495 my ($self) = @_;
206              
207 340         1105 my $mech = $self->mechanism;
208              
209             # validate attributes for given mechanism
210 340         646 for my $key ( sort keys %{ $CONSTRAINTS{$mech} } ) {
  340         1796  
211 112         247 my $validator = $CONSTRAINTS{$mech}{$key};
212 112         1139 local $_ = $self->$key;
213 112 100       1030 unless ( $validator->() ) {
214 9   100     57 $_ //= "";
215 9         94 MongoDB::UsageError->throw("invalid field $key with value '$_' in $mech credential");
216             }
217             }
218              
219             # fix up GSSAPI property defaults if not given
220 331 100       1187 if ( $mech eq 'GSSAPI' ) {
221 7         23 my $mp = $self->mechanism_properties;
222 7   100     35 $mp->{SERVICE_NAME} ||= 'mongodb';
223             }
224              
225 331         2485 return;
226             }
227              
228             sub authenticate {
229 0     0 0   my ( $self, $server, $link, $bson_codec ) = @_;
230              
231 0           my $mech = $self->mechanism;
232 0 0         if ( $mech eq 'DEFAULT' ) {
233 0           $mech = $self->_get_default_mechanism($server, $link);
234             }
235 0           my $method = "_authenticate_$mech";
236 0           $method =~ s/-/_/g;
237              
238 0           return $self->$method( $link, $bson_codec );
239             }
240              
241             #--------------------------------------------------------------------------#
242             # authentication mechanisms
243             #--------------------------------------------------------------------------#
244              
245             sub _authenticate_NONE () { 1 }
246              
247             sub _authenticate_MONGODB_CR {
248 0     0     my ( $self, $link, $bson_codec ) = @_;
249              
250             my $nonce = $self->_send_command( $link, $bson_codec, 'admin', { getnonce => 1 } )
251 0           ->output->{nonce};
252 0           my $key =
253             md5_hex( encode( "UTF-8", $nonce . $self->username . $self->_digested_password ) );
254              
255 0           my $command = Tie::IxHash->new(
256             authenticate => 1,
257             user => $self->username,
258             nonce => $nonce,
259             key => $key
260             );
261 0           $self->_send_command( $link, $bson_codec, $self->source, $command );
262              
263 0           return 1;
264             }
265              
266             sub _authenticate_MONGODB_X509 {
267 0     0     my ( $self, $link, $bson_codec ) = @_;
268              
269 0           my $username = $self->username;
270              
271 0 0 0       if ( !$username && !$link->supports_x509_user_from_cert ) {
272 0 0         $username = $link->client_certificate_subject
273             or MongoDB::UsageError->throw(
274             "Could not extract subject from client SSL certificate");
275             }
276              
277 0 0         my $command = Tie::IxHash->new(
278             authenticate => 1,
279             mechanism => "MONGODB-X509",
280             ( $username ? ( user => $username ) : () ),
281             );
282 0           $self->_send_command( $link, $bson_codec, $self->source, $command );
283              
284 0           return 1;
285             }
286              
287             sub _authenticate_PLAIN {
288 0     0     my ( $self, $link, $bson_codec ) = @_;
289              
290 0           my $auth_bytes =
291             encode( "UTF-8", "\x00" . $self->username . "\x00" . $self->password );
292 0           $self->_sasl_start( $link, $bson_codec, $auth_bytes, "PLAIN" );
293              
294 0           return 1;
295             }
296              
297             sub _authenticate_GSSAPI {
298 0     0     my ( $self, $link, $bson_codec ) = @_;
299              
300 0 0         eval { require Authen::SASL; 1 }
  0            
  0            
301             or MongoDB::AuthError->throw(
302             "GSSAPI requires Authen::SASL and GSSAPI or Authen::SASL::XS from CPAN");
303              
304 0           my ( $sasl, $client );
305             eval {
306 0           $sasl = Authen::SASL->new(
307             mechanism => 'GSSAPI',
308             callback => {
309             user => $self->username,
310             authname => $self->username,
311             },
312             );
313             $client =
314 0           $sasl->client_new( $self->mechanism_properties->{SERVICE_NAME}, $link->host );
315 0           1;
316 0 0         } or do {
317 0   0       my $error = $@ || "Unknown error";
318 0           MongoDB::AuthError->throw(
319             "Failed to initialize a GSSAPI backend (did you install GSSAPI or Authen::SASL::XS?) Error was: $error"
320             );
321             };
322              
323             eval {
324             # start conversation
325 0           my $step = $client->client_start;
326 0           $self->_assert_gssapi( $client,
327             "Could not start GSSAPI. Did you run kinit? Error was: " );
328 0           my ( $sasl_resp, $conv_id, $done ) =
329             $self->_sasl_start( $link, $bson_codec, $step, 'GSSAPI' );
330              
331             # iterate, but with maximum number of exchanges to prevent endless loop
332 0           for my $i ( 1 .. 10 ) {
333 0 0         last if $done;
334 0           $step = $client->client_step($sasl_resp);
335 0           $self->_assert_gssapi( $client, "GSSAPI step error: " );
336 0           ( $sasl_resp, $conv_id, $done ) =
337             $self->_sasl_continue( $link, $bson_codec, $step, $conv_id );
338             }
339 0           1;
340 0 0         } or do {
341 0   0       my $error = $@ || "Unknown error";
342 0 0         my $msg = $error->$_isa("MongoDB::Error") ? $error->message : "$error";
343 0           MongoDB::AuthError->throw("GSSAPI error: $msg");
344             };
345              
346 0           return 1;
347             }
348              
349             sub _authenticate_SCRAM_SHA_1 {
350 0     0     my $self = shift;
351              
352 0           $self->_scram_auth(@_, $self->_scram_sha1_client, 'SCRAM-SHA-1');
353              
354 0           return 1;
355             }
356              
357             sub _authenticate_SCRAM_SHA_256 {
358 0     0     my $self = shift;
359              
360 0           $self->_scram_auth(@_, $self->_scram_sha256_client, 'SCRAM-SHA-256');
361              
362 0           return 1;
363             }
364              
365             sub _get_default_mechanism {
366 0     0     my ( $self, $server, $link ) = @_;
367              
368 0 0         if ( my $supported = $server->is_master->{saslSupportedMechs} ) {
369 0 0         if ( grep { $_ eq 'SCRAM-SHA-256' } @$supported ) {
  0            
370 0           return 'SCRAM-SHA-256';
371             }
372 0           return 'SCRAM-SHA-1';
373             }
374              
375 0 0         if ( $link->supports_scram_sha1 ) {
376 0           return 'SCRAM-SHA-1';
377             }
378              
379 0           return 'MONGODB-CR';
380             }
381              
382             #--------------------------------------------------------------------------#
383             # GSSAPI/SASL methods
384             #--------------------------------------------------------------------------#
385              
386             # GSSAPI backends report status/errors differently
387             sub _assert_gssapi {
388 0     0     my ( $self, $client, $prefix ) = @_;
389 0           my $type = ref $client;
390              
391 0 0         if ( $type =~ m{^Authen::SASL::(?:XS|Cyrus)$} ) {
392 0           my $code = $client->code;
393 0 0 0       if ( $code != 0 && $code != 1 ) { # not OK or CONTINUE
394 0           my $error = join( "; ", $client->error );
395 0           MongoDB::AuthError->throw("$prefix$error");
396             }
397             }
398             else {
399             # Authen::SASL::Perl::GSSAPI or some unknown backend
400 0 0         if ( my $error = $client->error ) {
401 0           MongoDB::AuthError->throw("$prefix$error");
402             }
403             }
404              
405 0           return 1;
406             }
407              
408             # PERL-801: GSSAPI broke in some cases after switching to binary
409             # payloads, so fall back to base64 encoding for that mechanism.
410             sub _sasl_encode_payload {
411 0     0     my ( $self, $payload ) = @_;
412 0 0         $payload = "" unless defined $payload;
413 0 0         return encode_base64( $payload, "" ) if $self->mechanism eq 'GSSAPI';
414 0           $payload = encode( "UTF-8", $payload );
415 0           return \$payload;
416             }
417              
418             sub _sasl_decode_payload {
419 0     0     my ( $self, $payload ) = @_;
420 0 0 0       return "" unless defined $payload && length $payload;
421 0 0         return $payload->data if ref $payload;
422 0           return decode_base64($payload);
423             }
424              
425             sub _sasl_start {
426 0     0     my ( $self, $link, $bson_codec, $payload, $mechanism ) = @_;
427              
428 0           my $command = Tie::IxHash->new(
429             saslStart => 1,
430             mechanism => $mechanism,
431             payload => $self->_sasl_encode_payload($payload),
432             autoAuthorize => 1,
433             );
434              
435 0           return $self->_sasl_send( $link, $bson_codec, $command );
436             }
437              
438             sub _sasl_continue {
439 0     0     my ( $self, $link, $bson_codec, $payload, $conv_id ) = @_;
440              
441 0           my $command = Tie::IxHash->new(
442             saslContinue => 1,
443             conversationId => $conv_id,
444             payload => $self->_sasl_encode_payload($payload),
445             );
446              
447 0           return $self->_sasl_send( $link, $bson_codec, $command );
448             }
449              
450             sub _sasl_send {
451 0     0     my ( $self, $link, $bson_codec, $command ) = @_;
452 0           my $output =
453             $self->_send_command( $link, $bson_codec, $self->source, $command )->output;
454              
455             return (
456             $self->_sasl_decode_payload( $output->{payload} ),
457             $output->{conversationId},
458             $output->{done}
459 0           );
460             }
461              
462             sub _scram_auth {
463 0     0     my ( $self, $link, $bson_codec, $client, $mech ) = @_;
464              
465 0           my ( $msg, $sasl_resp, $conv_id, $done );
466             eval {
467 0           $msg = $client->first_msg;
468 0           ( $sasl_resp, $conv_id, $done ) =
469             $self->_sasl_start( $link, $bson_codec, $msg, $mech );
470 0           $msg = $client->final_msg($sasl_resp);
471 0           ( $sasl_resp, $conv_id, $done ) =
472             $self->_sasl_continue( $link, $bson_codec, $msg, $conv_id );
473 0           $client->validate($sasl_resp);
474             # might require an empty payload to complete SASL conversation
475 0 0         $self->_sasl_continue( $link, $bson_codec, "", $conv_id ) if !$done;
476 0           1;
477 0 0         } or do {
478 0   0       my $error = $@ || "Unknown error";
479 0 0         my $msg = $error->$_isa("MongoDB::Error") ? $error->message : "$error";
480 0           MongoDB::AuthError->throw("$mech error: $msg");
481             };
482             }
483              
484             sub _send_command {
485 0     0     my ( $self, $link, $bson_codec, $db_name, $command ) = @_;
486              
487 0           my $op = MongoDB::Op::_Command->_new(
488             db_name => $db_name,
489             query => $command,
490             query_flags => {},
491             bson_codec => $bson_codec,
492             monitoring_callback => $self->monitoring_callback,
493             );
494 0           my $res = $op->execute($link);
495 0           return $res;
496             }
497              
498             1;