File Coverage

blib/lib/Session/Storage/Secure.pm

Criterion	Covered	Total	%
statement	122	122	100.0
branch	37	38	97.3
condition	13	18	72.2
subroutine	24	24	100.0
pod	2	3	66.6
total	198	205	96.5

use 5.008001;
use strict;
use warnings;

package Session::Storage::Secure;
# ABSTRACT: Encrypted, expiring, compressed, serialized session data with integrity

our $VERSION = '0.901'; # TRIAL

use Carp (qw/croak/);
use Crypt::CBC 2.33 ();
use Crypt::Rijndael ();
use Crypt::URandom          (qw/urandom/);
use Digest::SHA             (qw/hmac_sha256/);
use Math::Random::ISAAC::XS ();
use MIME::Base64 3.12     ();
use Sereal::Encoder 4.005 ();
use Sereal::Decoder 4.005 ();
use String::Compare::ConstantTime qw/equals/;
use namespace::clean;

use Moo;
use MooX::Types::MooseLike::Base 0.16 qw(:all);

#--------------------------------------------------------------------------#
# Attributes
#--------------------------------------------------------------------------#

#pod =attr secret_key (required)
#pod
#pod This is used to secure the session data.  The encryption and message
#pod authentication key is derived from this using a one-way function.  Changing it
#pod will invalidate all sessions.
#pod
#pod =cut

has secret_key => (
    is       => 'ro',
    isa      => Str,
    required => 1,
);

#pod =attr default_duration
#pod
#pod Number of seconds for which the session may be considered valid.  If an
#pod expiration is not provided to C, this is used instead to expire the
#pod session after a period of time.  It is unset by default, meaning that session
#pod expiration is not capped.
#pod
#pod =cut

has default_duration => (
    is        => 'ro',
    isa       => Int,
    predicate => 1,
);

#pod =attr old_secrets
#pod
#pod An optional array reference of strings containing old secret keys no longer
#pod used for encryption but still supported for decrypting session data.
#pod
#pod =cut

has old_secrets => (
    is  => 'ro',
    isa => ArrayRef [Str],
);

#pod =attr separator
#pod
#pod A character used to separate fields.  It defaults to C<~>.
#pod
#pod =cut

has separator => (
    is      => 'ro',
    isa     => Str,
    default => '~',
);

#pod =attr sereal_encoder_options
#pod
#pod A hash reference with constructor arguments for L. Defaults
#pod to C<< { snappy => 1, croak_on_bless => 1 } >>.
#pod
#pod =cut

has sereal_encoder_options => (
    is      => 'ro',
    isa     => HashRef,
    default => sub { { snappy => 1, croak_on_bless => 1 } },
);

#pod =attr sereal_decoder_options
#pod
#pod A hash reference with constructor arguments for L. Defaults
#pod to C<< { refuse_objects => 1, validate_utf8  => 1 } >>.
#pod
#pod =cut

has sereal_decoder_options => (
    is      => 'ro',
    isa     => HashRef,
    default => sub { { refuse_objects => 1, validate_utf8 => 1 } },
);

#pod =attr transport_encoder
#pod
#pod A code reference to convert binary data elements (the encrypted data and the
#pod MAC) into a transport-safe form.  Defaults to
#pod L.  The output must not include
#pod the C attribute used to delimit fields.
#pod
#pod =cut

has transport_encoder => (
    is      => 'ro',
    isa     => CodeRef,
    default => sub { \&MIME::Base64::encode_base64url },
);

#pod =attr transport_decoder
#pod
#pod A code reference to extract binary data (the encrypted data and the
#pod MAC) from a transport-safe form.  It must be the complement to C.
#pod Defaults to L.
#pod
#pod =cut

has transport_decoder => (
    is      => 'ro',
    isa     => CodeRef,
    default => sub { \&MIME::Base64::decode_base64url },
);

#pod =attr protocol_version
#pod
#pod An integer representing the protocol used by C.
#pod Protocol 1 was the initial version, which used a now-deprecated mode of
#pod L.  Protocol 2 is the current default.
#pod
#pod =cut

has protocol_version => (
    is      => 'ro',
    isa     => Num,
    default => 2,
);

has _encoder => (
    is      => 'lazy',
    isa     => InstanceOf ['Sereal::Encoder'],
    handles => { '_freeze' => 'encode' },
);

sub _build__encoder {
    my ($self) = @_;
    return Sereal::Encoder->new( $self->sereal_encoder_options );
}

has _decoder => (
    is      => 'lazy',
    isa     => InstanceOf ['Sereal::Decoder'],
    handles => { '_thaw' => 'decode' },
);

sub _build__decoder {
    my ($self) = @_;
    return Sereal::Decoder->new( $self->sereal_decoder_options );
}

has _rng => (
    is      => 'lazy',
    isa     => InstanceOf ['Math::Random::ISAAC::XS'],
    handles => { '_irand' => 'irand' },
);

sub _build__rng {
    my ($self) = @_;
    return Math::Random::ISAAC::XS->new( map { unpack( "N", urandom(4) ) } 1 .. 256 );
}

sub BUILD {
    my ($self) = @_;
    $self->_check_version_for( encoding => $self->protocol_version );
}

sub _check_version_for {
    my ( $self, $action, $pv ) = @_;
    if ( $pv < 1 || $pv > 2 ) {
        croak "Invalid protocol version for $action: $pv";
    }
}

sub _get_cbc {
    my ( $self, $pv, $key, $salt ) = @_;

    my $cbc_opts = {
        -key    => $key,
        -cipher => 'Rijndael',
    };

    if ( $pv == 1 ) {
        $cbc_opts->{-pbkdf}       = 'opensslv1';
        $cbc_opts->{-nodeprecate} = 1;
    }
    else {
        $cbc_opts->{-pbkdf}       = 'none';
        $cbc_opts->{-keysize}     = 32;
        $cbc_opts->{-literal_key} = 1;
        $cbc_opts->{-header}      = 'none';
        my $cipher = Crypt::Rijndael->new($key);
        $cbc_opts->{-iv} = substr( $cipher->encrypt($salt), 0, 16 );
    }

    return Crypt::CBC->new(%$cbc_opts);
}

#pod =method encode
#pod
#pod   my $string = $store->encode( $data, $expires );
#pod
#pod The C<$data> argument should be a reference to a data structure.  By default,
#pod it must not contain objects.  (See L for
#pod rationale and alternatives.) If it is undefined, an empty hash reference will
#pod be encoded instead.
#pod
#pod The optional C<$expires> argument should be the session expiration time
#pod expressed as epoch seconds.  If the C<$expires> time is in the past, the
#pod C<$data> argument is cleared and an empty hash reference is encoded and returned.
#pod If no C<$expires> is given, then if the C attribute is set, it
#pod will be used to calculate an expiration time.
#pod
#pod The method returns a string that securely encodes the session data.  All binary
#pod components are protected via the L attribute.
#pod
#pod An exception is thrown on any errors.
#pod
#pod =cut

sub encode {
    my ( $self, $data, $expires ) = @_;
    $data = {} unless defined $data;
    my $sep = $self->separator;

    # If expiration is set, we want to check it and possibly clear data;
    # if not set, we might add an expiration based on default_duration
    if ( defined $expires ) {
        $data = {} if $expires < time;
    }
    else {
        $expires = $self->has_default_duration ? time + $self->default_duration : "";
    }

    # Random salt used to derive unique encryption/MAC key for each cookie
    my $salt;
    if ( $self->protocol_version == 1 ) {
        # numeric salt
        $salt = $self->_irand;
    }
    else {
        # binary salt
        $salt = pack( "N*", map { $self->_irand } 1 .. 8 );
    }

    my $key = hmac_sha256( $salt, $self->secret_key );

    my $cbc = $self->_get_cbc( $self->protocol_version, $key, $salt );

    my ( $ciphertext, $mac );
    eval {
        $ciphertext = $self->transport_encoder->( $cbc->encrypt( $self->_freeze($data) ) );
        $mac = $self->transport_encoder->( hmac_sha256( "$expires$sep$ciphertext", $key ) );
    };
    croak "Encoding error: $@" if $@;

    my $output;
    if ( $self->protocol_version == 1 ) {
        $output = join( $sep, $salt, $expires, $ciphertext, $mac );
    }
    else {
        $salt   = $self->transport_encoder->($salt);
        $output = join( $sep, $salt, $expires, $ciphertext, $mac, $self->protocol_version );
    }
    return $output;
}

#pod =method decode
#pod
#pod   my $data = $store->decode( $string );
#pod
#pod The C<$string> argument must be the output of C.
#pod
#pod If the message integrity check fails or if expiration exists and is in
#pod the past, the method returns undef or an empty list (depending on context).
#pod
#pod An exception is thrown on any errors.
#pod
#pod =cut

sub decode {
    my ( $self, $string ) = @_;
    return unless length $string;

    # Having a string implies at least salt; expires is optional; rest required
    my $sep = $self->separator;
    my ( $salt, $expires, $ciphertext, $mac, $version ) = split qr/\Q$sep\E/, $string;
    return unless defined($ciphertext) && length($ciphertext);
    return unless defined($mac)        && length($mac);
    $version = 1 unless defined $version;
    $self->_check_version_for( decoding => $version );

    if ( $version == 1 ) {
        # $salt is a decimal
    }
    else {
        # Decode salt to binary
        $salt = $self->transport_decoder->($salt);
    }

    # Try to decode against all known secret keys
    my @secrets = ( $self->secret_key, @{ $self->old_secrets || [] } );
    my $key;
    CHECK: foreach my $secret (@secrets) {
        $key = hmac_sha256( $salt, $secret );
        my $check_mac = eval {
            $self->transport_encoder->( hmac_sha256( "$expires$sep$ciphertext", $key ) );
        };
        last CHECK
          if (
               defined($check_mac)
            && length($check_mac)
            && equals( $check_mac, $mac ) # constant time comparison
          );
        undef $key;
    }

    # Check MAC integrity
    return unless defined($key);

    # Check expiration
    return if length($expires) && $expires < time;

    # Decrypt and deserialize the data
    my $cbc = $self->_get_cbc( $version, $key, $salt );

    my $data;
    eval {
        $self->_thaw( $cbc->decrypt( $self->transport_decoder->($ciphertext) ), $data );
    };
    croak "Decoding error: $@" if $@;

    return $data;
}

1;


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

__END__