File Coverage

blib/lib/Dancer/Plugin/EncodeID.pm

Criterion	Covered	Total	%
statement	55	59	93.2
branch	22	34	64.7
condition	1	2	50.0
subroutine	8	9	88.8
pod			n/a
total	86	104	82.6

package Dancer::Plugin::EncodeID;

use strict;
use warnings;
our $VERSION = '0.02';

use Dancer ':syntax';
use Dancer::Plugin;
use Crypt::Blowfish;

my $cipher = undef ;
my $padding_character = '!';

sub _create_cipher {
	## Crate a new cipher, based on the 'secret' in the configuration
	my $settings = plugin_setting or
		die "Configuration Error: can't find plugin settings for Dancer::Plugin::EncodeID. Please see documentation regarding proper configuration.";

	my $secret = $settings->{secret} or
		die "Configuration Error: can't find 'secret' key settings for Dancer::Plugin::EncodeID. Please see documentation regarding proper configuration.";

	$padding_character = $settings->{padding_character} || '!';
	die "Configuration error: padding_character must be 1 character long for Dancer::Plugin::EncodeID. Please see documentation regarding proper configuration." unless length($padding_character)==1;

	$cipher = new Crypt::Blowfish ( $secret ) ;
}

register encode_id => sub {
	my $cleartext_id = shift;
	die "Missing Clear text ID parameter" unless defined $cleartext_id;

	## Prefix is optional, can be undef
	my $prefix = shift ;
	$cleartext_id = $prefix . $cleartext_id if defined $prefix;

	_create_cipher() unless $cipher;

	my $hash_id = "" ;

	#Special case - user asked to encode an empty string
	$cleartext_id = $padding_character x '8' if length($cleartext_id)==0;

	while ( length($cleartext_id)>0 ) {
		my $sub_text = substr($cleartext_id,0,8,'');
		my $padded_str_id = $sub_text;
		if (length($sub_text)<8) {
			$padded_str_id = ( $padding_character x (8- length($sub_text) % 8 ) ). $sub_text ;
		};
		#print STDERR "Encoding '$padded_str_id'\n";
		my $ciphertext = $cipher->encrypt($padded_str_id);
		$hash_id .= unpack('H*', $ciphertext ) ;
	}
	return $hash_id;
};

register valid_encoded_id => sub {
	my $encoded_id = shift or die "Missing Encoded ID parameter";

	return 0 unless $encoded_id =~ /^[0-9A-F]+$/i;
	return 0 unless length($encoded_id)%16==0;
	return 1;
};

register decode_id => sub {
	my $encoded_id = shift or die "Missing Encoded ID parameter";
	my $orig_encoded_id = $encoded_id;

	## Prefix is optional, can be undef
	my $prefix = shift ;

	_create_cipher() unless $cipher;

	die "Invalid Hash-ID value ($encoded_id)" unless $encoded_id =~ /^[0-9A-F]+$/i;
	die "Invalid Hash-ID value ($encoded_id) - must be a multiple of 8 bytes (16 hex digits)"
		unless length($encoded_id)%16==0;

	my $cleartext = "";

	while ( length($encoded_id)>0 ) {
		my $sub_text = substr($encoded_id,0,16,'');
		my @list = $sub_text =~ /([0-9A-F]{2})/gi;
		#print STDERR "Decoding: '$sub_text'\n";
		my $ciphertext = pack('H2' x scalar(@list), @list) ;

		my $text = $cipher->decrypt($ciphertext);
		$text =~ s/^$padding_character+//;
		#print STDERR "Decoded: '$text'\n";
		$cleartext .= $text;
	};

	if (defined $prefix) {
		## Ensure the decoded ID contains the prefix
		my $i = index $cleartext,$prefix;
		if ($i != 0) {
			die "Invalid Hash-ID value ($orig_encoded_id) - bad prefix" ;
		}
		#skip the prefix;
		$cleartext = substr $cleartext, length($prefix);
	}

	return $cleartext;
};

register_plugin;

# ABSTRACT: A Dancer plugin for Encoding/Obfuscating IDs in URLs

1;
__END__