File Coverage

blib/lib/Authen/NZRealMe/LogonStrength.pm

Criterion	Covered	Total	%
statement	50	50	100.0
branch	16	18	88.8
condition	8	9	88.8
subroutine	12	12	100.0
pod	4	4	100.0
total	90	93	96.7

package Authen::NZRealMe::LogonStrength;
{
  $Authen::NZRealMe::LogonStrength::VERSION = '1.16';
}

use strict;
use warnings;
use Carp;

use constant URN_PREFIX => 'urn:nzl:govt:ict:stds:authn:deployment:GLS:SAML:2.0:ac:classes:';

use constant STRENGTH_LOW          => URN_PREFIX . 'LowStrength';
use constant STRENGTH_MODERATE     => URN_PREFIX . 'ModStrength';
use constant STRENGTH_MODERATE_SID => URN_PREFIX . 'ModStrength::OTP:Token:SID';
use constant STRENGTH_MODERATE_SMS => URN_PREFIX . 'ModStrength::OTP:Token:SMS';


my %word_to_urn = (
    low      => STRENGTH_LOW,
    mod      => STRENGTH_MODERATE,
    moderate => STRENGTH_MODERATE,
);

my %strength_score = (
    &STRENGTH_LOW          => 10,
    &STRENGTH_MODERATE     => 20,
    &STRENGTH_MODERATE_SID => 20,
    &STRENGTH_MODERATE_SMS => 20,
);


sub new {
    my $class = shift;
    my $urn   = shift || 'low';

    $urn = $word_to_urn{$urn} if $word_to_urn{$urn};

    if(not exists $strength_score{$urn}) {
        my @match = grep /\Q$urn\E$/i, keys %strength_score;
        croak "Can't find a match for logon strength '$urn'" if @match == 0;
        croak "Ambiguous logon strength '$urn'"              if @match > 1;
        $urn = $match[0];
    }

    return bless { urn => $urn }, $class;
}


sub urn   { shift->{urn};                    }
sub score { $strength_score{ shift->{urn} }; }


sub assert_match {
    my $self     = shift;
    my $required = shift || 'low';
    my $match    = shift || 'minimum';

    my $class = ref($self);
    $required = $class->new($required);

    my $provided_urn = $self->urn;
    my $required_urn = $required->urn;
    return if $required_urn eq $provided_urn;

    my $provided_score = $self->score;
    my $required_score = $required->score;
    return if $required_urn eq STRENGTH_MODERATE and $provided_score == 20;

    if($match eq 'minimum') {
        return if $provided_score > $required_score;
    }
    elsif($match ne 'exact') {
        die "Unrecognised password strength match type: '$match'";
    }

    die "Invalid logon strength.\n"
        . "Required: $required_urn\n"
        . "Provided: $provided_urn\n"
        . "Comparison: $match\n";
}

1;

__END__