1package Net::OpenID::JanRain::Stores::FileStore;
2
3=head1 JanRain OpenID File Store
4
5This module maintains a directory structure that saves state for the
6JanRain OpenID Library.
7
8=head2 Synopsis:
9
10C<< Net::OpenID::JanRain::Stores::FileStore->new("directory") >>
11
12=cut
13
14# vi:ts=4:sw=4
15
16use warnings;
17use strict;
18
19use Carp;
20use MIME::Base64 qw(encode_base64);
21use File::Spec;
22use File::Temp qw( tempfile );
23use Net::OpenID::JanRain::CryptUtil qw( sha1 randomString );
24
25our @ISA = qw(
26	Net::OpenID::JanRain::Stores
27	);
28
29# Functions
30sub _safe64 {
31    my ($s) = @_;
32    my $h64 = encode_base64(sha1($s));
33    $h64 =~ s/\+/_/g;
34    $h64 =~ s!/!.!g;
35    $h64 =~ s/=//g;
36    $h64 =~ s/\n//g;
37    return $h64;
38}
39########################################################################
40sub _isFilenameSafe {
41    my ($c) = @_;
42    return
43}
44########################################################################
45sub _filenameEscape {
46    my ($s) = @_;
47}
48########################################################################
49# Attempt to remove a file, returning whether the file existed at
50# the time of the call.
51sub _removeIfPresent {
52	my ($filename) = @_;
53    if ((unlink $filename) == 0) {
54        die "Could not remove $filename. $!" if -e $filename;
55        return 0;
56    }
57    return 1;
58} # end removeIfPresent
59########################################################################
60# _ensureDir
61# Create dir_name as a directory if it does not exist. If it
62# exists, make sure that it is, in fact, a directory.
63sub _ensureDir {
64	my ($dir_name) = @_;
65    mkdir $dir_name, 0755
66        || -d $dir_name
67        || die "Unable to make directory $dir_name. $!";
68    return -d $dir_name;
69} # end ensureDir
70########################################################################
71
72# Methods
73########################################################################
74# new
75# Call with the directory where the files should go.
76# All files must reside on the same filesystem.
77sub new {
78    my $caller = shift;
79    my ($dir) = @_;
80    my $class = ref($caller) || $caller;
81    $dir = File::Spec->rel2abs($dir);
82    my $noncedir = File::Spec->catdir($dir, "nonces");
83    my $assocdir = File::Spec->catdir($dir, "associations");
84    my $tempdir = File::Spec->catdir($dir, "temp");
85    my $authkeyn = File::Spec->catfile($dir, "auth_key");
86    my $maxnonceage = 6 * 60 * 60;
87    my $AUTH_KEY_LEN = 20;
88	my $self = {nonce_dir => $noncedir,
89                assoc_dir => $assocdir,
90                temp_dir => $tempdir,
91                auth_key_name => $authkeyn,
92                max_nonce_age => $maxnonceage,
93                AUTH_KEY_LEN => $AUTH_KEY_LEN};
94
95    _ensureDir($dir);
96    _ensureDir($noncedir);
97    _ensureDir($assocdir);
98    _ensureDir($tempdir);
99
100    bless($self, $class);
101} # end new
102########################################################################
103# isDumb
104# true if we are a dumb store, which we aren't.
105sub isDumb {
106    my $self = shift;
107    return 0;
108}
109########################################################################
110# readAuthKey
111# Read the auth key from the auth key file. Will return None
112# if there is currently no key.
113sub readAuthKey {
114	my $self = shift;
115    my $key;
116    open AKF, "< $self->{auth_key_name}" or return undef;
117    # Read one more byte than necessary to detect corruption
118    my $keylen = (read AKF, $key, $self->{AUTH_KEY_LEN}+1);
119    return undef if $keylen == 0;
120    close AKF;
121    return $key;
122} # end readAuthKey
123########################################################################
124# createAuthKey
125# Generate a new random auth key and safely store it in the
126# location specified by self.auth_key_name.
127sub createAuthKey {
128	my $self = shift;
129    my $auth_key = randomString($self->{AUTH_KEY_LEN});
130
131    my ($fh, $tmpfn) = tempfile(DIR => $self->{temp_dir});
132    die "Could not open a temporary file" unless $fh;
133    print $fh $auth_key;
134    close $fh;
135
136    unless(link($tmpfn, $self->{auth_key_name})) {
137        unless(rename ($tmpfn, $self->{auth_key_name})) {
138            $auth_key = $self->readAuthKey();
139            unless ($auth_key) {
140                die 'Failed to create or read Auth Key'
141            }
142        }
143    }
144    $self->_removeIfPresent($tmpfn);
145    return $auth_key;
146
147} # end createAuthKey
148########################################################################
149# getAuthKey
150# Retrieve the auth key from the file specified by
151# self.auth_key_name, creating it if it does not exist.
152sub getAuthKey {
153	my $self = shift;
154    my $auth_key = $self->readAuthKey();
155    $auth_key = $self->createAuthKey() unless $auth_key;
156    if (length($auth_key) != $self->{AUTH_KEY_LEN}) {
157        die "Got invalid auth key from $self->{auth_key_name}. Expected ".
158            "$self->{AUTH_KEY_LEN} byte string. Got: $auth_key";
159    }
160    return $auth_key;
161} # end getAuthKey
162########################################################################
163# getAssociationFilename
164# Create a unique filename for a given server url and
165# handle. This implementation does not assume anything about the
166# format of the handle. The filename that is returned will
167# contain the domain name from the server URL for ease of human
168# inspection of the data directory.
169sub getAssociationFilename {
170	my $self = shift;
171	my ($server_url, $handle) = @_;
172    defined($server_url) || die "getAssociationFilename called without server url";
173    unless($server_url =~ m!(.+)://([.\w]+)/?!) {
174        die "Bad server URL: $server_url";
175    }
176    my $proto = $1;
177    my $domain = $2;
178
179    my $url_hash = _safe64($server_url);
180
181    my $handle_hash;
182
183    if ($handle) {
184        $handle_hash = _safe64($handle);
185    }
186    else {
187        $handle_hash = '';
188    }
189
190    my $filename = "${proto}-${domain}-${url_hash}-${handle_hash}";
191
192    return File::Spec->catfile($self->{assoc_dir}, $filename);
193} # end getAssociationFilename
194########################################################################
195# storeAssociation
196# Create a unique filename for a given server url and
197# handle. This implementation does not assume anything about the
198# format of the handle. The filename that is returned will
199# contain the domain name from the server URL for ease of human
200# inspection of the data directory.
201sub storeAssociation {
202	my $self = shift;
203	my ($server_url, $association) = @_;
204
205    my $association_s = $association->serialize();
206    my $filename=$self->getAssociationFilename($server_url, $association->{handle});
207    my ($fh, $tmpfn) = tempfile(DIR => $self->{temp_dir});
208
209    unless (print $fh $association_s) {
210        warn "Unable to write association to $tmpfn";
211        close $fh;
212        return;
213    }
214    # os.fsync(tmp_file.fileno())
215    close $fh;
216
217    unless (rename $tmpfn, $filename) {
218        unlink $filename;
219        unless (rename $tmpfn, $filename) {
220            warn "Unable to rename $tmpfn to $filename. $!";
221            unlink $tmpfn;
222        }
223    }
224} # end storeAssociation
225########################################################################
226# getAssociation
227# Retrieve an association. If no handle is specified, return
228# the association with the latest expiration.
229# If no matching association exists, returns undef
230sub getAssociation {
231    use Net::OpenID::JanRain::Association;
232    my $self = shift;
233    my ($server_url, $handle) = @_;
234
235    defined($handle) or $handle = '';
236
237    my $filename = $self->getAssociationFilename($server_url, $handle);
238
239    if ($handle) {
240        return $self->_getAssociation($filename);
241    }
242    else {
243        my @associations = ();
244        # The filename with an empty handle is a prefix of all association
245        # filenames for a given server URL.
246        my $file_match = "$filename*";
247        my $file;
248        for $file (glob($file_match)) {
249            my $assoc = $self->_getAssociation($file);
250            if ($assoc) {
251                push @associations, $assoc;
252            }
253        }
254        @associations = sort {$a->{issued} <=> $b->{issued}} @associations;
255        return pop @associations; # undef if array is empty
256    }
257} # end getAssociation
258########################################################################
259# _getAssociation
260# Read an association file and return an association object.
261# undef if we have no such association.
262sub _getAssociation {
263    my $self = shift;
264    my ($filename) = @_;
265
266    open FILE, "< $filename" or return undef;
267
268    my $assoc_s;
269    unless (read FILE, $assoc_s, 1024) { #more bytes than needed
270        warn "Unable to read $filename";
271        close FILE;
272        return undef;
273    }
274    close FILE;
275    my $association = Net::OpenID::JanRain::Association->deserialize($assoc_s);
276    #If we find a bunk association, remove it.
277    _removeIfPresent($filename) unless $association;
278    return $association;
279}
280########################################################################
281# removeAssociation
282# Remove an association if it exists. Do nothing if it does not.
283sub removeAssociation {
284	my $self = shift;
285	my ($server_url, $handle) = @_;
286    my $assoc = $self->getAssociation($server_url, $handle);
287    if ($assoc) {
288        return _removeIfPresent($self->getAssociationFilename($server_url, $handle));
289    }
290    return 0;
291} # end removeAssociation
292########################################################################
293sub storeNonce {
294	my $self = shift;
295	my ($nonce) = @_;
296    my $fn = File::Spec->catfile($self->{nonce_dir}, $nonce);
297    open FILE, "> $fn" or die "Could not open nonce file $fn - $!\n";
298    close FILE;
299} # end storeNonce
300########################################################################
301sub useNonce {
302	my $self = shift;
303	my ($nonce) = @_;
304    my $fn = File::Spec->catfile($self->{nonce_dir}, $nonce);
305    my @stats = stat $fn;
306    return undef unless @stats;
307    my $mtime = $stats[10];
308    unlink $fn || return undef;
309    return (($mtime - time) < $self->{max_nonce_age});
310} # end useNonce
311########################################################################
312sub clean {
313	my $self = shift;
314    my $now = time; # now is the time
315
316    # Check all nonces for expiration
317    my $fn;
318    for $fn (glob(File::Spec->catfile($self->{nonce_dir}, "*"))) {
319        my @stats = stat $fn;
320        if (@stats) {
321            # tenth stat is modification time
322            if (($now - $stats[10]) > $self->{max_nonce_age} ) {
323                _removeIfPresent($fn);
324            }
325        }
326    }
327
328    # Check all associations for corruption and expiration
329    for $fn (glob(File::Spec->catfile($self->assoc_dir,"*"))) {
330        my $assoc = _getAssociation($fn); #cleans up corrupted files.
331        if($assoc && $assoc->getExpiresIn() == 0) {
332            _removeIfPresent($fn);
333        }
334    }
335} # end clean
336########################################################################
3371;
338