# $Id: TypeKey.pm,v 1.5 2004/06/20 13:23:46 btrott Exp $

package Authen::TypeKey;
use strict;

use Crypt::DSA;
use Crypt::DSA::Key;
use Crypt::DSA::Signature;
use Crypt::DSA::Util qw( bin2mp );
use MIME::Base64 qw( decode_base64 );
use LWP::UserAgent;
use HTTP::Status qw( RC_NOT_MODIFIED );

use vars qw( $ERROR $VERSION );
$VERSION = '0.01';

sub new {
    my $class = shift;
    my $tk = bless { }, $class;
    $tk->skip_expiry_check(0);
    $tk->expires(600);
    $tk->key_url('http://www.typekey.com/extras/regkeys.txt');
    $tk;
}

sub _var {
    my $tk = shift;
    my $var = shift;
    $tk->{$var} = shift if @_;
    $tk->{$var};
}

sub key_cache         { shift->_var('key_cache',         @_) }
sub skip_expiry_check { shift->_var('skip_expiry_check', @_) }
sub expires           { shift->_var('expires',           @_) }
sub key_url           { shift->_var('key_url',           @_) }

sub verify {
    my $tk = shift;
    my($email, $username, $name, $ts, $sig);
    if (@_ == 1) {
        my $q = $_[0];
        ($email, $username, $name, $ts, $sig) = map $q->param($_),
            qw( email name nick ts sig );
        for ($email, $sig) {
            tr/ /+/;
        }
    } else {
        ## Later we could process arguments passed in a hash.
        return $tk->error("usage: verify(\$query)");
    }
    return $tk->error("TypeKey data has expired")
        unless $tk->skip_expiry_check || $ts + $tk->expires >= time;
    my $key = $tk->_fetch_key($tk->key_url) or return;
    my($r, $s) = split /:/, $sig;
    $sig = Crypt::DSA::Signature->new;
    $sig->r(bin2mp(decode_base64($r)));
    $sig->s(bin2mp(decode_base64($s)));
    my $msg = join '::', $email, $username, $name, $ts;
    my $dsa = Crypt::DSA->new;
    unless ($dsa->verify( Message => $msg, Key => $key, Signature => $sig )) {
        return $tk->error("TypeKey signature verification failed");
    }
    { name => $username,
      nick => $name,
      email => $email,
      ts => $ts };
}

sub _fetch_key {
    my $tk = shift;
    my($uri) = @_;
    my $data;
    my $ua = LWP::UserAgent->new;
    if (my $cache_file = $tk->key_cache) {
        my $res = $ua->mirror($uri, $cache_file);
        return $tk->error("Failed to fetch key: " . $res->status_line)
            unless $res->is_success || $res->code == RC_NOT_MODIFIED;
        open my $fh, $cache_file
            or return $tk->error("Can't open $cache_file: $!");
        $data = do { local $/; <$fh> };
        close $fh;
    } else {
        my $res = $ua->get($uri);
        return $tk->error("Failed to fetch key: " . $res->status_line)
            unless $res->is_success;
        $data = $res->content;
    }
    chomp $data;
    my $key = Crypt::DSA::Key->new;
    for my $f (split /\s+/, $data) {
        my($k, $v) = split /=/, $f, 2;
        $key->$k($v);
    }
    $key;
}

sub error  {
    my $msg = $_[1] || '';
    $msg .= "\n" unless $msg =~ /\n$/;
    if (ref($_[0])) {
        $_[0]->{_errstr} = $msg;
    } else {
        $ERROR = $msg;
    }
    return;
}

sub errstr { ref($_[0]) ? $_[0]->{_errstr} : $ERROR }

1;
__END__

=head1 NAME

Authen::TypeKey - TypeKey authentication verification

=head1 SYNOPSIS

    use CGI;
    use Authen::TypeKey;
    my $q = CGI->new;
    my $tk = Authen::TypeKey->new;
    my $res = $tk->verify($q) or die $tk->errstr;

=head1 DESCRIPTION

I<Authen::TypeKey> is an implementation of verification for signatures
generated by TypeKey authentication. For information on the TypeKey
protocol and using TypeKey in other applications, see
I<http://www.movabletype.org/docs/tk-apps.html>.

=head1 USAGE

=head2 Authen::TypeKey->new

Create a new I<Authen::TypeKey> object.

=head2 $tk->verify($query)

Verify a TypeKey signature based on the other parameters given. The signature
and other parameters are found in the I<$query> object, which should be
any object that supports a I<param> method--for example, a I<CGI> or
I<Apache::Request> object.

If the signature is successfully verified, I<verify> returns a reference to
a hash containing the following values.

=over 4

=item * name

The unique username of the TypeKey user.

=item * nick

The user's display name.

=item * email

The user's email address. If the user has chosen not to pass his/her
email address, this will contain the SHA-1 hash of the string
C<mailto:E<lt>emailE<gt>>.

=item * ts

The timestamp at which the signature was generated, expressed as seconds
since the epoch.

=back

If verification is unsuccessful, I<verify> will return C<undef>, and the
error message can be found in C<$tk-E<gt>errstr>.

=head2 $tk->key_cache([ $cache_file ])

Get/set the path to a local file where the TypeKey public key (at
C<$tk-E<gt>key_url>) should be cached/mirrored. If this is unset, the
key is not cached. By default, this is set to the empty string.

=head2 $tk->skip_expiry_check([ $boolean ])

Get/set a value indicating whether I<verify> should check the expiration
date and time in the TypeKey parameters. The default is to check the
expiration date and time.

=head2 $tk->expires([ $secs ])

Get/set the amount of time at which a TypeKey signature is intended to expire.
The default value is 600 seconds, i.e. 10 minutes.

=head2 $tk->key_url([ $url ])

Get/set the URL from which the TypeKey public key can be obtained. The
default URL is I<http://www.typekey.com/extras/regkeys.txt>.

=head1 LICENSE

I<Authen::TypeKey> is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.

=head1 AUTHOR & COPYRIGHT

Except where otherwise noted, I<Authen::TypeKey> is Copyright 2004 Six Apart
Ltd, cpan@sixapart.com. All rights reserved.

=cut