File Coverage

blib/lib/HTTP/CryptoCookie.pm

Criterion	Covered	Total	%
statement	51	90	56.6
branch	3	26	11.5
condition	3	20	15.0
subroutine	13	15	86.6
pod	4	4	100.0
total	74	155	47.7

package HTTP::CryptoCookie;

use 5.006001;
use strict;
# use warnings;

use CGI qw(:standard);  # for now, move to Apache (mod_perl) later
use CGI::Cookie;
use Crypt::CBC;
use Digest::SHA2;
use Convert::ASCII::Armour;
use Compress::Zlib qw(compress uncompress);
use FreezeThaw qw(freeze thaw);
use Data::Dumper;

# first, some notes about compression and cryptography.
#
# never, ever compress an encrypted string.  this can potentially
# give a cryptanalysist  clues about the encryption algorithm,
# the key, and the plaintext. so remember... compress, then encrypt.

require Exporter;

our @ISA = qw(Exporter);

our $VERSION = '1.14';

my $aa = new Convert::ASCII::Armour;

sub _roll_dough {
	my ($self,$struct) = @_;

	my $step_one = compress(freeze($struct));
	my $step_two = $self->{cipher}->encrypt($step_one);

	my $cooked = $aa->armour(
		Object	=> 'HCC',
		Headers	=> {},
		Content	=> {data=>$step_two},
		Compress => 1);

	return $cooked;
}

sub new {
	my($class,$key) = @_;
	die "argument of key required" unless $key;

	my $digest = new Digest::SHA2(256);
	$digest->add(($key));
	my $digest_key = $digest->digest();

	my $self = bless {
        cipher => Crypt::CBC->new(
			-key => $digest_key,
			-cipher => 'Rijndael',
			-regenerate_key => 0,
			-salt => 1,
			-header => 'salt'),
	}, $class;

	# redefine the value of $key in memory, then undef it
	$key = join '', map { chr(int(rand(255))) } (0..(100+length $key));
	undef $key;
	return $self;
}

sub get_cookie {
	my($self, %args) = @_;

	ref $args{cookie_name} && return undef;

	my %cookies = (! exists $self->{debug}) ?  CGI::Cookie->fetch() : $args{force_cookie};
	if(my $cookie = $cookies{$args{cookie_name}}) {
		# first step, unarmour
		my $dough = $aa->unarmour($cookie->value);
		my $xcval = $self->{cipher}->decrypt($dough->{Content}{data});
		# next step, uncompress
		if(length($xcval) > 0) {
			my $rv = (thaw(uncompress($xcval)))[0];
			return $rv;
		} else {
			return undef;
		}
	}
	return undef;
}

sub set_cookie {
	my($self, %args) = @_;
	# a basic cookie...


	if(exists $args{cookie} && exists $args{cookie_name}) {
		# bake the cookie

		my $cookie = CGI::Cookie->new(
			-name => $args{cookie_name},
			-value => $self->_roll_dough($args{cookie}),
			-path => $args{path} || '/',
			-expires => $args{exp},
			-secure => $args{secure} || 0,
			-domain => $args{domain},
		);


		# toss the cookie at the browser
		if(exists $args{r}) {
			$args{r}->headers_out->set('Set-Cookie' => $cookie);
		} else {
			print header(-cookie =>[$cookie]);
		}
		return 1;
	} elsif (scalar(@{$args{cookies}}) > 0) {
		my $jar = [];

		foreach my $cookie (@{$args{cookies}}) {
			my $oreo = CGI::Cookie->new(
				-name => $cookie->{name} || $cookie->{cookie_name},
				-value => $self->_roll_dough($cookie->{cookie}),
				-path => $cookie->{path} || $args{path} || '/',
				-expires => $cookie->{exp} || $args{exp},
				-secure => $cookie->{secure} || $args{secure} || 0,
				-domain => $cookie->{domain} || $args{domain},
			);

			push(@{$jar}, $oreo);
			if(exists $args{r}) {
				$args{r}->headers_out->set('Set-Cookie' => $oreo);
			}
		}

		print header(-cookie => $jar) unless (exists $args{r});
		return scalar(@{$jar});
	}
	return undef;
}

sub del_cookie {
	my($self,%args) = @_;

	my $jar = [];

	unless(ref($args{cookie_name}) eq 'ARRAY') {
		$args{cookie_name} = [ $args{cookie_name} ];
	}

	foreach my $cookie_name (@{$args{cookie_name}}) {
		my $donut_hole = CGI::Cookie->new(
			-name => $cookie_name,
			-expires => '-1M',
		);

		push(@{$jar}, $donut_hole);
		if(exists $args{r}) {
			$args{r}->headers_out->set('Set-Cookie' => $donut_hole);
		}
		print header(-cookie => $jar) unless (exists $args{r});
	}

	return scalar(@{$jar});
}

1;
__END__