File Coverage

blib/lib/Authen/SCRAM/Server.pm

Criterion	Covered	Total	%
statement	80	85	94.1
branch	21	26	80.7
condition	2	3	66.6
subroutine	15	15	100.0
pod	3	3	100.0
total	121	132	91.6

use 5.008;
use strict;
use warnings;

package Authen::SCRAM::Server;
# ABSTRACT: RFC 5802 SCRAM Server

our $VERSION = '0.010';

use Moo 1.001000;

use Authen::SASL::SASLprep qw/saslprep/;
use Carp qw/croak/;
use Crypt::URandom qw/urandom/;
use Encode qw/encode_utf8/;
use MIME::Base64 qw/decode_base64/;
use PBKDF2::Tiny 0.003 qw/derive digest_fcn hmac/;
use Types::Standard qw/Str Num CodeRef Bool/;

use namespace::clean;

with 'Authen::SCRAM::Role::Common';

#--------------------------------------------------------------------------#
# public attributes
#--------------------------------------------------------------------------#

#pod =attr credential_cb (required)
#pod
#pod This attribute must contain a code reference that takes a username (as a
#pod character string normalized by SASLprep) and returns the four user-credential
#pod parameters required by SCRAM: C, C, C, and
#pod C.  The C, C and C must be
#pod provided as octets (i.e. B base64 encoded).
#pod
#pod If the username is unknown, it should return an empty list.
#pod
#pod     ($salt, $stored_key, $server_key, $iterations) =
#pod         $server->credential_cb->( $username );
#pod
#pod See L
#pod for details.
#pod
#pod =cut

has credential_cb => (
    is       => 'ro',
    isa      => CodeRef,
    required => 1,
);

#pod =attr auth_proxy_cb
#pod
#pod If provided, this attribute must contain a code reference that takes an
#pod B username and a B username (both as character
#pod strings), and return a true value if the authentication username is permitted
#pod to act as the authorization username:
#pod
#pod     $bool = $server->auth_proxy_cb->(
#pod         $authentication_user, $authorization_user
#pod     );
#pod
#pod It will only be all called if the authentication username has successfully
#pod authenticated.  Both usernames will have been normalized via C with
#pod any transport encoding removed before being passed to this function.
#pod
#pod =cut

has auth_proxy_cb => (
    is      => 'ro',
    isa     => CodeRef,
    default => sub {
        return sub { 1 }
    },
);

#--------------------------------------------------------------------------#
# provided by Authen::SCRAM::Role::Common
#--------------------------------------------------------------------------#

with 'Authen::SCRAM::Role::Common';

#pod =attr digest
#pod
#pod Name of a digest function available via L.  Valid values are
#pod SHA-1, SHA-224, SHA-256, SHA-384, or SHA-512.  Defaults to SHA-1.
#pod
#pod =attr nonce_size
#pod
#pod Size of the client-generated nonce, in bits.  Defaults to 192.
#pod The server-nonce will be appended, so the final nonce size will
#pod be substantially larger.
#pod
#pod =attr skip_saslprep
#pod
#pod A boolean that defaults to false.  If set to true, usernames and passwords will
#pod not be normalized through SASLprep.  This is a deviation from the RFC5802 spec
#pod and is not recommended.
#pod
#pod =cut

#--------------------------------------------------------------------------#
# private attributes
#--------------------------------------------------------------------------#

has _proof_ok => (
    is     => 'ro',
    isa    => Bool,
    writer => '_set_proof_ok',
);

#--------------------------------------------------------------------------#
# public methods
#--------------------------------------------------------------------------#

#pod =method first_msg
#pod
#pod     $server_first_msg = $server->first_msg( $client_first_msg );
#pod
#pod This takes the C received from the client and returns the
#pod C string to be sent to the client to continue a SCRAM
#pod session.  Calling this again will reset the internal state and initiate a new
#pod session.  This will throw an exception should an error occur.
#pod
#pod =cut

sub first_msg {
    my ( $self, $msg ) = @_;
    $self->_clear_session;

    my ( $cbind, $authz, $c_1_bare, $mext, @params ) = $msg =~ $self->_client_first_re;

    if ( !defined $cbind ) {
        croak "SCRAM client-first-message could not be parsed";
    }
    if ( $cbind eq 'p' ) {
        croak
          "SCRAM client-first-message required channel binding, but we do not support it";
    }
    if ( defined $mext ) {
        croak
          "SCRAM client-first-message required mandatory extension '$mext', but we do not support it";
    }

    push @params, $authz if defined $authz;
    $self->_parse_to_session(@params);
    $self->_extend_nonce;

    my $name = $self->_get_session('n');
    my ( $salt, $stored_key, $server_key, $iters ) = $self->credential_cb->($name);

    if ( !defined $salt ) {
        croak "SCRAM client-first-message had unknown user '$name'";
    }

    $self->_set_session(
        s           => $self->_base64($salt),
        i           => $iters,
        _c1b        => $c_1_bare,
        _stored_key => $stored_key,
        _server_key => $server_key
    );

    my $reply = $self->_join_reply(qw/r s i/);
    $self->_set_session( _s1 => $reply );

    return $reply;
}

#pod =method final_msg
#pod
#pod     $server_final_msg = $server->final_msg( $client_final_msg );
#pod
#pod This takes the C received from the client and returns the
#pod C string containing the verification signature to be sent
#pod to the client.
#pod
#pod If an authorization identity was provided by the client, it will confirm that
#pod the authenticating username is authorized to act as the authorization id using
#pod the L attribute.
#pod
#pod If the client credentials do not match or the authentication name is not
#pod authorized to act as the authorization name, then an exception will be thrown.
#pod
#pod =cut

sub final_msg {
    my ( $self, $msg ) = @_;

    my ( $c2wop, @params ) = $msg =~ $self->_client_final_re;
    $self->_set_session( _c2wop => $c2wop );

    if ( !defined $c2wop ) {
        croak "SCRAM client-first-message could not be parsed";
    }

    # confirm nonce
    my $original_nonce = $self->_get_session("r");
    $self->_parse_to_session(@params);
    my $joint_nonce = $self->_get_session("r");
    unless ( $joint_nonce eq $original_nonce ) {
        croak "SCRAM client-final-message nonce invalid";
    }

    # confirm channel bindings
    my $cbind =
      $self->_base64( encode_utf8( $self->_construct_gs2( $self->_get_session("a") ) ) );
    if ( $cbind ne $self->_get_session("c") ) {
        croak "SCRAM client-final-message channel binding didn't match";
    }

    # confirm proof

    my $client_sig   = $self->_client_sig;
    my $proof        = decode_base64( $self->_get_session("p") );
    my $client_key   = $proof ^ $client_sig;
    my $computed_key = $self->_digest_fcn->($client_key);
    my $name         = $self->_get_session("n");

    if ( !$self->_const_eq_fcn->( $computed_key, $self->_get_session("_stored_key") ) ) {
        croak "SCRAM authentication for user '$name' failed";
    }

    if ( my $authz = $self->_get_session("a") ) {
        $self->auth_proxy_cb->( $name, $authz )
          or croak("SCRAM authentication failed; '$name' not authorized to act as '$authz'");
    }

    $self->_set_session( _proof_ok => 1 );

    my $server_sig =
      $self->_hmac_fcn->( $self->_get_session('_server_key'), $self->_auth_msg );

    $self->_set_session( v => $self->_base64($server_sig) );

    $self->_join_reply('v');
}

#pod =method authorization_id
#pod
#pod     $username = $client->authorization_id();
#pod
#pod This takes no arguments and returns the authorization identity resulting from
#pod the SCRAM exchange.  This is the client-supplied authorization identity (if one
#pod was provided and validated) or else the successfully authenticated identity.
#pod
#pod =cut

sub authorization_id {
    my ($self) = @_;
    return '' unless $self->_get_session("_proof_ok");
    my $authz = $self->_get_session("a");
    return ( defined($authz) && length($authz) ) ? $authz : $self->_get_session("n");
}

1;


# vim: ts=4 sts=4 sw=4 et:

__END__