our
$VERSION
=
'v0.999.999.5'
;
AuthMechanism
NonEmptyStr
)
;
Bool
HashRef
InstanceOf
Str
)
;
has
mechanism
=> (
is
=>
'ro'
,
isa
=> AuthMechanism,
required
=> 1,
);
has
username
=> (
is
=>
'ro'
,
isa
=> Str,
default
=>
''
,
);
has
source
=> (
is
=>
'lazy'
,
isa
=> NonEmptyStr,
builder
=>
'_build_source'
,
);
has
password
=> (
is
=>
'ro'
,
isa
=> Str,
default
=>
''
,
);
has
pw_is_digest
=> (
is
=>
'ro'
,
isa
=> Bool,
);
has
mechanism_properties
=> (
is
=>
'ro'
,
isa
=> HashRef,
default
=>
sub
{ {} },
);
has
_digested_password
=> (
is
=>
'lazy'
,
isa
=> Str,
builder
=>
'_build__digested_password'
,
);
has
_scram_client
=> (
is
=>
'lazy'
,
isa
=> InstanceOf[
'Authen::SCRAM::Client'
],
builder
=>
'_build__scram_client'
,
);
sub
_build__scram_client {
my
(
$self
) =
@_
;
Authen::SCRAM::Client->VERSION(0.003);
return
Authen::SCRAM::Client->new(
username
=>
$self
->username,
password
=>
$self
->_digested_password,
skip_saslprep
=> 1,
);
}
sub
_build__digested_password {
my
(
$self
) =
@_
;
return
$self
->password
if
$self
->pw_is_digest;
return
md5_hex( encode(
"UTF-8"
,
$self
->username .
":mongo:"
.
$self
->password ) );
}
sub
_build_source {
my
(
$self
) =
@_
;
my
$mech
=
$self
->mechanism;
return
$mech
eq
'DEFAULT'
||
$mech
eq
'MONGODB-CR'
||
$mech
eq
'SCRAM-SHA-1'
?
'admin'
:
'$external'
;
}
my
%CONSTRAINTS
= (
'MONGODB-CR'
=> {
username
=>
sub
{
length
},
password
=>
sub
{
length
},
source
=>
sub
{
length
},
mechanism_properties
=>
sub
{ !
keys
%$_
},
},
'MONGODB-X509'
=> {
username
=>
sub
{
length
},
password
=>
sub
{ !
length
},
source
=>
sub
{
$_
eq
'$external'
},
mechanism_properties
=>
sub
{ !
keys
%$_
},
},
'GSSAPI'
=> {
username
=>
sub
{
length
},
source
=>
sub
{
$_
eq
'$external'
},
},
'PLAIN'
=> {
username
=>
sub
{
length
},
password
=>
sub
{
length
},
source
=>
sub
{
$_
eq
'$external'
},
mechanism_properties
=>
sub
{ !
keys
%$_
},
},
'SCRAM-SHA-1'
=> {
username
=>
sub
{
length
},
password
=>
sub
{
length
},
source
=>
sub
{
length
},
mechanism_properties
=>
sub
{ !
keys
%$_
},
},
'DEFAULT'
=> {
username
=>
sub
{
length
},
password
=>
sub
{
length
},
source
=>
sub
{
length
},
mechanism_properties
=>
sub
{ !
keys
%$_
},
},
);
sub
BUILD {
my
(
$self
) =
@_
;
my
$mech
=
$self
->mechanism;
while
(
my
(
$key
,
$validator
) =
each
%{
$CONSTRAINTS
{
$mech
} } ) {
local
$_
=
$self
->
$key
;
unless
(
$validator
->() ) {
MongoDB::UsageError->throw(
"invalid field $key ('$_') in $mech credential"
);
}
}
if
(
$mech
eq
'GSSAPI'
) {
my
$mp
=
$self
->mechanism_properties;
$mp
->{SERVICE_NAME} ||=
'mongodb'
;
}
return
;
}
sub
authenticate {
my
(
$self
,
$link
,
$bson_codec
) =
@_
;
my
$mech
=
$self
->mechanism;
if
(
$mech
eq
'DEFAULT'
) {
$mech
=
$link
->accepts_wire_version(3) ?
'SCRAM-SHA-1'
:
'MONGODB-CR'
;
}
my
$method
=
"_authenticate_$mech"
;
$method
=~ s/-/_/g;
return
$self
->
$method
(
$link
,
$bson_codec
);
}
sub
_authenticate_NONE () { 1 }
sub
_authenticate_MONGODB_CR {
my
(
$self
,
$link
,
$bson_codec
) =
@_
;
my
$nonce
=
$self
->_send_command(
$link
,
$bson_codec
,
'admin'
, {
getnonce
=> 1 } )->output->{nonce};
my
$key
=
md5_hex( encode(
"UTF-8"
,
$nonce
.
$self
->username .
$self
->_digested_password ) );
my
$command
= Tie::IxHash->new(
authenticate
=> 1,
user
=>
$self
->username,
nonce
=>
$nonce
,
key
=>
$key
);
$self
->_send_command(
$link
,
$bson_codec
,
$self
->source,
$command
);
return
1;
}
sub
_authenticate_MONGODB_X509 {
my
(
$self
,
$link
,
$bson_codec
) =
@_
;
my
$command
= Tie::IxHash->new(
authenticate
=> 1,
user
=>
$self
->username,
mechanism
=>
"MONGODB-X509"
,
);
$self
->_send_command(
$link
,
$bson_codec
,
$self
->source,
$command
);
return
1;
}
sub
_authenticate_PLAIN {
my
(
$self
,
$link
,
$bson_codec
) =
@_
;
my
$auth_bytes
=
encode(
"UTF-8"
,
"\x00"
.
$self
->username .
"\x00"
.
$self
->password );
$self
->_sasl_start(
$link
,
$bson_codec
,
$auth_bytes
,
"PLAIN"
);
return
1;
}
sub
_authenticate_GSSAPI {
my
(
$self
,
$link
,
$bson_codec
) =
@_
;
or MongoDB::AuthError->throw(
"GSSAPI requires Authen::SASL and GSSAPI or Authen::SASL::XS from CPAN"
);
my
(
$sasl
,
$client
);
try
{
$sasl
= Authen::SASL->new(
mechanism
=>
'GSSAPI'
,
callback
=> {
user
=>
$self
->username,
authname
=>
$self
->username,
},
);
$client
=
$sasl
->client_new(
$self
->mechanism_properties->{SERVICE_NAME},
$link
->host );
}
catch
{
MongoDB::AuthError->throw(
"Failed to initialize a GSSAPI backend (did you install GSSAPI or Authen::SASL::XS?) Error was: $_"
);
};
try
{
my
$step
=
$client
->client_start;
$self
->_assert_gssapi(
$client
,
"Could not start GSSAPI. Did you run kinit? Error was: "
);
my
(
$sasl_resp
,
$conv_id
,
$done
) =
$self
->_sasl_start(
$link
,
$bson_codec
,
$step
,
'GSSAPI'
);
for
my
$i
( 1 .. 10 ) {
last
if
$done
;
$step
=
$client
->client_step(
$sasl_resp
);
$self
->_assert_gssapi(
$client
,
"GSSAPI step error: "
);
(
$sasl_resp
,
$conv_id
,
$done
) =
$self
->_sasl_continue(
$link
,
$bson_codec
,
$step
,
$conv_id
);
}
}
catch
{
MongoDB::AuthError->throw(
"GSSAPI error: $_"
);
};
return
1;
}
sub
_authenticate_SCRAM_SHA_1 {
my
(
$self
,
$link
,
$bson_codec
) =
@_
;
my
$client
=
$self
->_scram_client;
my
(
$msg
,
$sasl_resp
,
$conv_id
,
$done
);
try
{
$msg
=
$client
->first_msg;
(
$sasl_resp
,
$conv_id
,
$done
) =
$self
->_sasl_start(
$link
,
$bson_codec
,
$msg
,
'SCRAM-SHA-1'
);
$msg
=
$client
->final_msg(
$sasl_resp
);
(
$sasl_resp
,
$conv_id
,
$done
) =
$self
->_sasl_continue(
$link
,
$bson_codec
,
$msg
,
$conv_id
);
$client
->validate(
$sasl_resp
);
$self
->_sasl_continue(
$link
,
$bson_codec
,
""
,
$conv_id
)
if
!
$done
;
}
catch
{
MongoDB::AuthError->throw(
"SCRAM-SHA-1 error: $_"
);
};
return
1;
}
sub
_assert_gssapi {
my
(
$self
,
$client
,
$prefix
) =
@_
;
my
$type
=
ref
$client
;
if
(
$type
=~ m{^Authen::SASL::(?:XS|Cyrus)$} ) {
my
$code
=
$client
->code;
if
(
$code
!= 0 &&
$code
!= 1 ) {
my
$error
=
join
(
"; "
,
$client
->error );
MongoDB::AuthError->throw(
"$prefix$error"
);
}
}
else
{
if
(
my
$error
=
$client
->error ) {
MongoDB::AuthError->throw(
"$prefix$error"
);
}
}
return
1;
}
sub
_sasl_start {
my
(
$self
,
$link
,
$bson_codec
,
$payload
,
$mechanism
) =
@_
;
my
$command
= Tie::IxHash->new(
saslStart
=> 1,
mechanism
=>
$mechanism
,
payload
=>
$payload
? encode_base64(
$payload
,
""
) :
""
,
autoAuthorize
=> 1,
);
return
$self
->_sasl_send(
$link
,
$bson_codec
,
$command
);
}
sub
_sasl_continue {
my
(
$self
,
$link
,
$bson_codec
,
$payload
,
$conv_id
) =
@_
;
my
$command
= Tie::IxHash->new(
saslContinue
=> 1,
conversationId
=>
$conv_id
,
payload
=>
$payload
? encode_base64(
$payload
,
""
) :
""
,
);
return
$self
->_sasl_send(
$link
,
$bson_codec
,
$command
);
}
sub
_sasl_send {
my
(
$self
,
$link
,
$bson_codec
,
$command
) =
@_
;
my
$output
=
$self
->_send_command(
$link
,
$bson_codec
,
$self
->source,
$command
)->output;
my
$sasl_resp
=
$output
->{payload} ? decode_base64(
$output
->{payload} ) :
""
;
return
(
$sasl_resp
,
$output
->{conversationId},
$output
->{done} );
}
sub
_send_command {
my
(
$self
,
$link
,
$bson_codec
,
$db_name
,
$command
) =
@_
;
my
$op
= MongoDB::Op::_Command->_new(
db_name
=>
$db_name
,
query
=>
$command
,
query_flags
=> {},
bson_codec
=>
$bson_codec
,
);
my
$res
=
$op
->execute(
$link
);
return
$res
;
}
1;