File Coverage

blib/lib/Authen/SCRAM/Role/Common.pm

Criterion	Covered	Total	%
statement	115	116	99.1
branch	13	16	81.2
condition	13	15	86.6
subroutine	38	39	97.4
pod			n/a
total	179	186	96.2

use 5.008;
use strict;
use warnings;

package Authen::SCRAM::Role::Common;

our $VERSION = '0.010';

use Moo::Role 1.001000;

use Authen::SASL::SASLprep 1.100 qw/saslprep/;
use Carp qw/croak/;
use Crypt::URandom qw/urandom/;
use Encode qw/encode_utf8/;
use MIME::Base64 qw/encode_base64/;
use PBKDF2::Tiny 0.003 qw/digest_fcn hmac/;
use Try::Tiny;
use Types::Standard qw/Bool Enum Num HashRef CodeRef/;

use namespace::clean;

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

has digest => (
    is      => 'ro',
    isa     => Enum [qw/SHA-1 SHA-224 SHA-256 SHA-384 SHA-512/],
    default => 'SHA-1',
);

has nonce_size => (
    is      => 'ro',
    isa     => Num,
    default => 192,
);

has skip_saslprep => (
    is  => 'ro',
    isa => Bool,
);

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

has _const_eq_fcn => (
    is  => 'lazy',
    isa => CodeRef,
);

# constant time comparison to avoid timing attacks; uses
# String::Compare::ConstantTime if available or a pure-Perl fallback
sub _build__const_eq_fcn {
    my ($self) = @_;
    # XXX disable String::Compare::ConstantTime until a new version
    # is released that fixes warnings on older perls.
    if ( 0 && eval { require String::Compare::ConstantTime; 1 } ) {
        return \&String::Compare::ConstantTime::equals;
    }
    else {
        return sub {
            my ( $dk1, $dk2 ) = @_;
            my $dk1_length = length($dk1);
            return unless $dk1_length == length($dk2);
            my $match = 1;
            for my $offset ( 0 .. $dk1_length ) {
                $match &= ( substr( $dk1, $offset, 1 ) eq substr( $dk2, $offset, 1 ) ) ? 1 : 0;
            }
            return $match;
        };
    }
}

has _digest_fcn => (
    is  => 'lazy',
    isa => CodeRef,
);

sub _build__digest_fcn {
    my ($self) = @_;
    my ($fcn)  = digest_fcn( $self->digest );
    return $fcn;
}

# _hmac_fcn( $key, $data ) -- this matches RFC 5802 parameter order but
# is reversed from Digest::HMAC/PBKDF2::Tiny which uses (data, key)
has _hmac_fcn => (
    is  => 'lazy',
    isa => CodeRef,
);

sub _build__hmac_fcn {
    my ($self) = @_;
    my ( $fcn, $block_size, $digest_length ) = digest_fcn( $self->digest );
    return sub {
        my ( $key, $data ) = @_;
        $key = $fcn->($key) if length($key) > $block_size;
        return hmac( $data, $key, $fcn, $block_size );
    };
}

# helpful for testing
has _nonce_generator => (
    is  => 'lazy',
    isa => CodeRef,
);

sub _build__nonce_generator {
    my ($self) = @_;
    return sub { return $self->_base64( urandom( $self->nonce_size / 8 ) ) };
}

# _session builds up parameters used during a SCRAM session.  Keys
# starting with "_" are private state not used for exchange.  Single
# letter keys are defined as per RFC5802
#
# _nonce        private nonce part
# _c1b          client-first-message-bare
# _s1           server-first-message
# _c2wop        client-final-message-without-proof
# _stored_key   H(ClientKey)
# _server_key   HMAC(SaltedPassword, "Server Key")
# _auth         AuthMessage

has _session => (
    is      => 'lazy',
    isa     => HashRef,
    clearer => 1,
);

sub _build__session {
    my ($self) = @_;
    return { _nonce => $self->_nonce_generator->() };
}

#--------------------------------------------------------------------------#
# methods
#--------------------------------------------------------------------------#

sub _auth_msg {
    my ($self) = @_;
    return $self->_session->{_auth} ||=
      encode_utf8( join( ",", map { $self->_session->{$_} } qw/_c1b _s1 _c2wop/ ) );
}

sub _base64 {
    my ( $self, $data ) = @_;
    return encode_base64( $data, "" );
}

sub _client_sig {
    my ($self) = @_;
    return $self->_hmac_fcn->( $self->_session->{_stored_key}, $self->_auth_msg );
}

sub _construct_gs2 {
    my ( $self, $authz ) = @_;
    my $maybe =
        ( defined($authz) && length($authz) )
      ? ( "a=" . $self->_encode_name($authz) )
      : "";
    return "n,$maybe,";
}

sub _decode_name {
    my ( $self, $name ) = @_;
    $name =~ s/=2c/,/g;
    $name =~ s/=3d/=/g;
    return $name;
}

sub _encode_name {
    my ( $self, $name ) = @_;
    $name =~ s/=/=3d/g;
    $name =~ s/,/=2c/g;
    return $name;
}

sub _extend_nonce {
    my ($self) = @_;
    $self->_session->{r} .= $self->_session->{_nonce};
}

sub _get_session {
    my ( $self, $key ) = @_;
    return $self->_session->{$key};
}

sub _join_reply {
    my ( $self, @fields ) = @_;
    my @reply;
    for my $k (@fields) {
        my $v = $self->_session->{$k};
        if ( $k eq 'a' || $k eq 'n' ) {
            $v = $self->_encode_name($v);
        }
        push @reply, "$k=$v";
    }
    my $msg = '' . join( ",", @reply );
    utf8::upgrade($msg);
    return $msg;
}

sub _parse_to_session {
    my ( $self, @params ) = @_;
    for my $part (@params) {
        my ( $k, $v ) = split /=/, $part, 2;
        if ( $k eq 'a' || $k eq 'n' ) {
            $v = $self->_saslprep( $self->_decode_name($v) );
        }
        elsif ( $k eq 'i' && $v !~ /^[0-9]+$/ ) {
            croak "SCRAM iteration parameter '$part' invalid";
        }
        $self->_session->{$k} = $v;
    }
    return;
}

sub _saslprep {
    my ( $self, $name ) = @_;

    return $name if $self->skip_saslprep;

    my $prepped = try {
        saslprep( $name, 1 ); # '1' makes it use stored mode
    }
    catch {
        croak "SCRAM username '$name' invalid: $_";
    };
    return $prepped;
}

sub _set_session {
    my ( $self, %args ) = @_;
    while ( my ( $k, $v ) = each %args ) {
        $self->_session->{$k} = $v;
    }
    return;
}

#--------------------------------------------------------------------------#
# regular expressions for parsing
#--------------------------------------------------------------------------#

# tokens
my $VALUE    = qr/[^,]+/;
my $CBNAME   = qr/[a-zA-Z0-9.-]+/;
my $ATTR_VAL = qr/[a-zA-Z]=$VALUE/;

# atoms
my $GS2_CBIND_FLAG = qr/(?:n|y|p=$VALUE)/;
my $AUTHZID        = qr/a=$VALUE/;
my $CHN_BIND       = qr/c=$VALUE/;
my $S_ERROR        = qr/e=$VALUE/;
my $ITER_CNT       = qr/i=$VALUE/;
my $MEXT           = qr/m=$VALUE/;
my $USERNAME       = qr/n=$VALUE/;
my $PROOF          = qr/p=$VALUE/;
my $NONCE          = qr/r=$VALUE/;
my $SALT           = qr/s=$VALUE/;
my $VERIFIER       = qr/v=$VALUE/;
my $EXT            = qr/$ATTR_VAL (?: , $ATTR_VAL)*/;

# constructions
my $C_FRST_BARE   = qr/(?:($MEXT),)? ($USERNAME) , ($NONCE) (?:,$EXT)?/x;
my $GS2_HEADER    = qr/($GS2_CBIND_FLAG) , ($AUTHZID)? , /x;
my $C_FINL_WO_PRF = qr/($CHN_BIND) , ($NONCE) (?:,$EXT)?/x;

# messages
my $C_FRST_MSG = qr/$GS2_HEADER ($C_FRST_BARE)/x;
my $S_FRST_MSG = qr/(?:($MEXT),)? ($NONCE) , ($SALT) , ($ITER_CNT) (?:,$EXT)?/x;
my $C_FINL_MSG = qr/($C_FINL_WO_PRF) , ($PROOF)/x;
my $S_FINL_MSG = qr/($S_ERROR | $VERIFIER)/x;

sub _client_first_re { $C_FRST_MSG } # ($cbind, $authz?, $c_1_bare, $mext?, @params)
sub _server_first_re { $S_FRST_MSG } # ($mext?, @params)
sub _client_final_re { $C_FINL_MSG } # ($c_2_wo_proof, @params)
sub _server_final_re { $S_FINL_MSG } # ($error_or_verification)

1;

=pod

=for Pod::Coverage digest nonce_size skip_saslprep

=cut

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