package Net::OpenID::JanRain::Stores::FileStore;
=head1 JanRain OpenID File Store
This module maintains a directory structure that saves state for the
JanRain OpenID Library.
=head2 Synopsis:
C<< Net::OpenID::JanRain::Stores::FileStore->new("directory") >>
=cut
# vi:ts=4:sw=4
use warnings;
use strict;
use Carp;
use MIME::Base64 qw(encode_base64);
use File::Spec;
use File::Temp qw( tempfile );
use Net::OpenID::JanRain::CryptUtil qw( sha1 randomString );
our @ISA = qw(
Net::OpenID::JanRain::Stores
);
# Functions
sub _safe64 {
my ($s) = @_;
my $h64 = encode_base64(sha1($s));
$h64 =~ s/\+/_/g;
$h64 =~ s!/!.!g;
$h64 =~ s/=//g;
$h64 =~ s/\n//g;
return $h64;
}
########################################################################
sub _isFilenameSafe {
my ($c) = @_;
return
}
########################################################################
sub _filenameEscape {
my ($s) = @_;
}
########################################################################
# Attempt to remove a file, returning whether the file existed at
# the time of the call.
sub _removeIfPresent {
my ($filename) = @_;
if ((unlink $filename) == 0) {
die "Could not remove $filename. $!" if -e $filename;
return 0;
}
return 1;
} # end removeIfPresent
########################################################################
# _ensureDir
# Create dir_name as a directory if it does not exist. If it
# exists, make sure that it is, in fact, a directory.
sub _ensureDir {
my ($dir_name) = @_;
mkdir $dir_name, 0755
|| -d $dir_name
|| die "Unable to make directory $dir_name. $!";
return -d $dir_name;
} # end ensureDir
########################################################################
# Methods
########################################################################
# new
# Call with the directory where the files should go.
# All files must reside on the same filesystem.
sub new {
my $caller = shift;
my ($dir) = @_;
my $class = ref($caller) || $caller;
$dir = File::Spec->rel2abs($dir);
my $noncedir = File::Spec->catdir($dir, "nonces");
my $assocdir = File::Spec->catdir($dir, "associations");
my $tempdir = File::Spec->catdir($dir, "temp");
my $authkeyn = File::Spec->catfile($dir, "auth_key");
my $maxnonceage = 6 * 60 * 60;
my $AUTH_KEY_LEN = 20;
my $self = {nonce_dir => $noncedir,
assoc_dir => $assocdir,
temp_dir => $tempdir,
auth_key_name => $authkeyn,
max_nonce_age => $maxnonceage,
AUTH_KEY_LEN => $AUTH_KEY_LEN};
_ensureDir($dir);
_ensureDir($noncedir);
_ensureDir($assocdir);
_ensureDir($tempdir);
bless($self, $class);
} # end new
########################################################################
# isDumb
# true if we are a dumb store, which we aren't.
sub isDumb {
my $self = shift;
return 0;
}
########################################################################
# readAuthKey
# Read the auth key from the auth key file. Will return None
# if there is currently no key.
sub readAuthKey {
my $self = shift;
my $key;
open AKF, "< $self->{auth_key_name}" or return undef;
# Read one more byte than necessary to detect corruption
my $keylen = (read AKF, $key, $self->{AUTH_KEY_LEN}+1);
return undef if $keylen == 0;
close AKF;
return $key;
} # end readAuthKey
########################################################################
# createAuthKey
# Generate a new random auth key and safely store it in the
# location specified by self.auth_key_name.
sub createAuthKey {
my $self = shift;
my $auth_key = randomString($self->{AUTH_KEY_LEN});
my ($fh, $tmpfn) = tempfile(DIR => $self->{temp_dir});
die "Could not open a temporary file" unless $fh;
print $fh $auth_key;
close $fh;
unless(link($tmpfn, $self->{auth_key_name})) {
unless(rename ($tmpfn, $self->{auth_key_name})) {
$auth_key = $self->readAuthKey();
unless ($auth_key) {
die 'Failed to create or read Auth Key'
}
}
}
$self->_removeIfPresent($tmpfn);
return $auth_key;
} # end createAuthKey
########################################################################
# getAuthKey
# Retrieve the auth key from the file specified by
# self.auth_key_name, creating it if it does not exist.
sub getAuthKey {
my $self = shift;
my $auth_key = $self->readAuthKey();
$auth_key = $self->createAuthKey() unless $auth_key;
if (length($auth_key) != $self->{AUTH_KEY_LEN}) {
die "Got invalid auth key from $self->{auth_key_name}. Expected ".
"$self->{AUTH_KEY_LEN} byte string. Got: $auth_key";
}
return $auth_key;
} # end getAuthKey
########################################################################
# getAssociationFilename
# Create a unique filename for a given server url and
# handle. This implementation does not assume anything about the
# format of the handle. The filename that is returned will
# contain the domain name from the server URL for ease of human
# inspection of the data directory.
sub getAssociationFilename {
my $self = shift;
my ($server_url, $handle) = @_;
defined($server_url) || die "getAssociationFilename called without server url";
unless($server_url =~ m!(.+)://([.\w]+)/?!) {
die "Bad server URL: $server_url";
}
my $proto = $1;
my $domain = $2;
my $url_hash = _safe64($server_url);
my $handle_hash;
if ($handle) {
$handle_hash = _safe64($handle);
}
else {
$handle_hash = '';
}
my $filename = "${proto}-${domain}-${url_hash}-${handle_hash}";
return File::Spec->catfile($self->{assoc_dir}, $filename);
} # end getAssociationFilename
########################################################################
# storeAssociation
# Create a unique filename for a given server url and
# handle. This implementation does not assume anything about the
# format of the handle. The filename that is returned will
# contain the domain name from the server URL for ease of human
# inspection of the data directory.
sub storeAssociation {
my $self = shift;
my ($server_url, $association) = @_;
my $association_s = $association->serialize();
my $filename=$self->getAssociationFilename($server_url, $association->{handle});
my ($fh, $tmpfn) = tempfile(DIR => $self->{temp_dir});
unless (print $fh $association_s) {
warn "Unable to write association to $tmpfn";
close $fh;
return;
}
# os.fsync(tmp_file.fileno())
close $fh;
unless (rename $tmpfn, $filename) {
unlink $filename;
unless (rename $tmpfn, $filename) {
warn "Unable to rename $tmpfn to $filename. $!";
unlink $tmpfn;
}
}
} # end storeAssociation
########################################################################
# getAssociation
# Retrieve an association. If no handle is specified, return
# the association with the latest expiration.
# If no matching association exists, returns undef
sub getAssociation {
use Net::OpenID::JanRain::Association;
my $self = shift;
my ($server_url, $handle) = @_;
defined($handle) or $handle = '';
my $filename = $self->getAssociationFilename($server_url, $handle);
if ($handle) {
return $self->_getAssociation($filename);
}
else {
my @associations = ();
# The filename with an empty handle is a prefix of all association
# filenames for a given server URL.
my $file_match = "$filename*";
my $file;
for $file (glob($file_match)) {
my $assoc = $self->_getAssociation($file);
if ($assoc) {
push @associations, $assoc;
}
}
@associations = sort {$a->{issued} <=> $b->{issued}} @associations;
return pop @associations; # undef if array is empty
}
} # end getAssociation
########################################################################
# _getAssociation
# Read an association file and return an association object.
# undef if we have no such association.
sub _getAssociation {
my $self = shift;
my ($filename) = @_;
open FILE, "< $filename" or return undef;
my $assoc_s;
unless (read FILE, $assoc_s, 1024) { #more bytes than needed
warn "Unable to read $filename";
close FILE;
return undef;
}
close FILE;
my $association = Net::OpenID::JanRain::Association->deserialize($assoc_s);
#If we find a bunk association, remove it.
_removeIfPresent($filename) unless $association;
return $association;
}
########################################################################
# removeAssociation
# Remove an association if it exists. Do nothing if it does not.
sub removeAssociation {
my $self = shift;
my ($server_url, $handle) = @_;
my $assoc = $self->getAssociation($server_url, $handle);
if ($assoc) {
return _removeIfPresent($self->getAssociationFilename($server_url, $handle));
}
return 0;
} # end removeAssociation
########################################################################
sub storeNonce {
my $self = shift;
my ($nonce) = @_;
my $fn = File::Spec->catfile($self->{nonce_dir}, $nonce);
open FILE, "> $fn" or die "Could not open nonce file $fn - $!\n";
close FILE;
} # end storeNonce
########################################################################
sub useNonce {
my $self = shift;
my ($nonce) = @_;
my $fn = File::Spec->catfile($self->{nonce_dir}, $nonce);
my @stats = stat $fn;
return undef unless @stats;
my $mtime = $stats[10];
unlink $fn || return undef;
return (($mtime - time) < $self->{max_nonce_age});
} # end useNonce
########################################################################
sub clean {
my $self = shift;
my $now = time; # now is the time
# Check all nonces for expiration
my $fn;
for $fn (glob(File::Spec->catfile($self->{nonce_dir}, "*"))) {
my @stats = stat $fn;
if (@stats) {
# tenth stat is modification time
if (($now - $stats[10]) > $self->{max_nonce_age} ) {
_removeIfPresent($fn);
}
}
}
# Check all associations for corruption and expiration
for $fn (glob(File::Spec->catfile($self->assoc_dir,"*"))) {
my $assoc = _getAssociation($fn); #cleans up corrupted files.
if($assoc && $assoc->getExpiresIn() == 0) {
_removeIfPresent($fn);
}
}
} # end clean
########################################################################
1;