File Coverage

blib/lib/Authen/TOTP.pm

Criterion	Covered	Total	%
statement	126	176	71.5
branch	38	80	47.5
condition	22	47	46.8
subroutine	20	24	83.3
pod	2	18	11.1
total	208	345	60.2

# Authen::TOTP version 0.0.6
#
# Copyright (c) 2020 Thanos Chatziathanassiou . All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Authen::TOTP;
local $^W;
require 'Exporter.pm';
use vars qw(@ISA @EXPORT @EXPORT_OK);
@ISA = (Exporter);

@EXPORT_OK = qw();

$Authen::TOTP::VERSION='0.0.6';
$Authen::TOTP::ver=$Authen::TOTP::VERSION;

use strict;
use warnings;
use utf8;
use Carp;
use Data::Dumper;

sub debug_print {
	my $self = shift;

	#fancy stuff that can be done later
	warn @_;

	return 1;
}

sub process_sub_arguments {
	my $self = shift;

	my $args = shift;
	my $wants = shift;
	my @rets;

	if (@$args != 0) {
		if (ref $args->[0] eq 'HASH') {
			foreach my $want (@$wants) {
				push @rets,$args->[0]->{$want};
			}
		}
		elsif (!(scalar(@$args)%2)) {
			my %hash = @$args;
			foreach my $want (@$wants) {
				push @rets,$hash{$want};
			}
		}
	}
	return @rets;
}

sub valid_digits {
	my $self = shift;
	my $digits = shift;

	if ($digits && $digits =~ m|^[68]$|) {
		$self->{digits} = $digits;
	}
	elsif (!defined($self->{digits}) || $self->{digits} !~ m|^[68]$|) {
		$self->{digits} = 6;
	}
	1;
}
sub valid_period {
	my $self = shift;
	my $period = shift;

	if ($period && $period =~ m|^[36]0$|) {
		$self->{period} = $period;
	}
	elsif (!defined($self->{period}) || $self->{period} !~ m|^[36]0$|) {
		$self->{period} = 30;
	}
	1;
}
sub valid_algorithm {
	my $self = shift;
	my $algorithm = shift;

	if ($algorithm && $algorithm =~ m|^SHA\d+$|) {
		$self->{algorithm} = $algorithm;
	}
	elsif (!defined($self->{algorithm}) || $self->{algorithm} !~ m|^SHA\d+$|) {
		$self->{algorithm} = "SHA1";
	}
	1;
}
sub valid_when {
	my $self = shift;
	my $when = shift;

	if ($when && $when =~ m|^\-?\d+$|) { #negative epoch is valid, though not sure how useful :)
		$self->{when} = $when;
	}
	elsif (!defined($self->{when}) || $self->{when} !~ m|^\-?\d+$|) {
		$self->{when} = time;
	}
	1;
}
sub valid_tolerance {
	my $self = shift;
	my $tolerance = shift;

	if ($tolerance && $tolerance =~ m|^\d+$| && $tolerance > 0) {
		$self->{tolerance} = ($tolerance-1);
	}
	elsif (!defined($self->{tolerance}) || $self->{tolerance} !~ m|^\d+$|) {
		$self->{tolerance} = 0;
	}
	1;
}
sub valid_secret {
	my $self = shift;
	my ($secret, $base32secret) = @_;

	if ($secret) {
		$self->{secret} = $secret;
	}
	elsif ($base32secret) {
		$self->{secret} = $self->base32dec($base32secret);
	}
	else {
		if (defined($self->{base32secret})) {
			$self->{secret} = $self->base32dec($self->{base32secret});
		}
		else {
			$self->{secret} = $self->gen_secret(12);
		}
	}

	$self->{base32secret} = $self->base32enc($self->{secret});
	1;
}
sub secret {
	my $self = shift;
	return $self->{secret};
}
sub algorithm {
	my $self = shift;
	my $algorithm = shift;
	$self->valid_algorithm($algorithm);

	return $self->{algorithm};
}

sub hmac {
	my $self = shift;
	my $Td = shift;

	if  ((eval {require Digest::SHA;1;} || 0) ne 1) {
		# if module can't load
		require Digest::SHA::PurePerl;
		$self->{DEBUG} and $self->debug_print("Digest::SHA unavailable, using Digest::SHA::PurePerl()");
		if ($self->{algorithm} eq 'SHA512') {
			return Digest::SHA::PurePerl::hmac_sha512_hex($Td, $self->{secret});
		}
		elsif ($self->{algorithm} eq 'SHA256') {
			return Digest::SHA::PurePerl::hmac_sha256_hex($Td, $self->{secret} );
		}
		else {
			return Digest::SHA::PurePerl::hmac_sha1_hex($Td, $self->{secret} );
		}
	}
	else {
		#we have XS!
		$self->{DEBUG} and $self->debug_print("using Digest::SHA()");
		if ($self->{algorithm} eq 'SHA512') {
			return Digest::SHA::hmac_sha512_hex($Td, $self->{secret});
		}
		elsif ($self->{algorithm} eq 'SHA256') {
			return Digest::SHA::hmac_sha256_hex($Td, $self->{secret} );
		}
		else {
			return Digest::SHA::hmac_sha1_hex($Td, $self->{secret} );
		}
	}
}

sub base32enc {
	my $self = shift;

	if  ((eval {require MIME::Base32::XS;1;} || 0) ne 1) {
		# if module can't load
		require MIME::Base32;
		$self->{DEBUG} and $self->debug_print("MIME::Base32::XS unavailable, using MIME::Base32()");
		return MIME::Base32::encode_base32(shift);
	}
	else {
		#we have XS!
		$self->{DEBUG} and $self->debug_print("using MIME::Base32::XS()");
		return MIME::Base32::XS::encode_base32(shift);
	}
}

sub base32dec {
	my $self = shift;

	if  ((eval {require MIME::Base32::XS;1;} || 0) ne 1) {
		# if module can't load
		require MIME::Base32;
		$self->{DEBUG} and $self->debug_print("MIME::Base32::XS unavailable, using MIME::Base32()");
		return MIME::Base32::decode_base32(shift);
	}
	else {
		#we have XS!
		$self->{DEBUG} and $self->debug_print("using MIME::Base32::XS()");
		return MIME::Base32::XS::decode_base32(shift);
	}
}

sub gen_secret {
	my $self = shift;

	my $secret;
	for my $i(0..int(rand(12))+12) {
		$secret .= join '',('/', 1..9,'!','@','#','$','%','^','&','*','(',')','-','_','+','=', 'A'..'H','J'..'N','P'..'Z', 'a'..'h','m'..'z')[rand 58];
	}
	if (length($secret) > 13) {
		$self->{DEBUG} and $self->debug_print("have len ".length($secret)." ($secret) so cutting down");
		return substr($secret,0,12);
	}
	return $secret;
}

sub generate_otp {
	my $self = shift;
	my ($digits,$period,$algorithm,$secret,$base32secret, $issuer, $user) =
		$self->process_sub_arguments(\@_,[ 'digits', 'period', 'algorithm', 'secret', 'base32secret', 'issuer', 'user']);

	unless ($user) {
		Carp::confess("need user to use as prefix in generate_otp()");
	}

	$self->valid_digits($digits);
	$self->valid_period($period);
	$self->valid_algorithm($algorithm);
	$self->valid_secret($secret, $base32secret);

	if ($issuer) {
		$issuer = qq[&issuer=].$issuer;
	}
	else {
		$issuer = '';
	}

	return qq[otpauth://totp/$user?secret=]
								.$self->{base32secret}
								.qq[&algorithm=].$self->{algorithm}
								.qq[&digits=].$self->{digits}
								.qq[&period=].$self->{period}
								.$issuer;
}

sub validate_otp {
	my $self = shift;
	my ($digits,$period,$algorithm,$secret,$when,$tolerance,$base32secret, $otp) =
		$self->process_sub_arguments(\@_,[ 'digits', 'period', 'algorithm', 'secret', 'when', 'tolerance', 'base32secret', 'otp']);

	unless ($otp && $otp =~ m|^\d{6,8}$|) {
		$otp ||= "";
		Carp::confess("invalid otp $otp passed to validate_otp()");
	}

	$self->valid_digits($digits);
	$self->valid_period($period);
	$self->valid_algorithm($algorithm);
	$self->valid_when($when);
	$self->valid_tolerance($tolerance);
	$self->valid_secret($secret, $base32secret);

	my @tests = ( $self->{when} );
	for my $i (1..$self->{tolerance}) {
		push @tests, ($self->{when} - ($self->{period} * $i) );
		push @tests, ($self->{when} + ($self->{period} * $i) );
	}

	foreach $when (@tests) {
		$self->{DEBUG} and $self->debug_print("using when $when (". ($when - $self->{when}). ")");

		my $T = sprintf("%016x", int($when / $self->{period}) );
		my $Td = pack('H*', $T);

		my $hmac = $self->hmac($Td);

		# take the 4 least significant bits (1 hex char) from the encrypted string as an offset
		my $offset = hex(substr($hmac, -1));
		# take the 4 bytes (8 hex chars) at the offset (* 2 for hex), and drop the high bit
		my $encrypted = hex(substr($hmac, $offset * 2, 8)) & 0x7fffffff;

		my $code = sprintf("%0".$self->{digits}."d", ($encrypted % (10**$self->{digits}) ) );

		$self->{DEBUG} and $self->debug_print("comparing $code to $otp");

		if ($code eq sprintf("%0".$self->{digits}."d", $otp) ) {
			return 1;
		}

	}

	return undef;
}

sub initialize {
	my $self = shift;

	$self->{DEBUG} = 0;

	if (@_ != 0) {
		if (ref $_[0] eq 'HASH') {
			my $hash=$_[0];
			foreach (keys %$hash) {
				$self->{lc $_}=$hash->{$_};
			}
		}
		elsif (!(scalar(@_)%2)) {
			my %hash = @_;
			foreach (keys %hash) {
				$self->{lc $_}=$hash{$_};
			}
		}
	}

	$self->valid_digits();
	$self->valid_period();
	$self->valid_algorithm();
	$self->valid_when();
	$self->valid_tolerance();
	$self->valid_secret();

	return $self;
}

sub new {
	my $this = shift;
	my $class = ref($this) || $this;
	my $self = {};
	bless $self, $class;

	return $self->initialize(@_);
}

1;
__END__