package Authen::Bitcard;
  $Authen::Bitcard::VERSION = '0.90';
use strict;
use base qw( Class::ErrorHandler );

use Math::BigInt;
use MIME::Base64 qw( decode_base64 );
use Digest::SHA qw( sha1 sha1_hex );
use LWP::UserAgent;
use HTTP::Status qw( RC_NOT_MODIFIED );
use URI;
use URI::QueryParam;
use Carp qw(croak);
use JSON qw(decode_json);

sub new {
    my $class = shift;
    my $bc = bless { }, $class;
    my %args = @_;
    for my $k (keys %args) {
      next unless $bc->can($k);

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

sub key_cache         { shift->_var('key_cache',         @_) }
sub skip_expiry_check { shift->_var('skip_expiry_check', @_) }
sub expires           { shift->_var('expires',           @_) }
sub token             { shift->_var('token',             @_) }
sub api_secret        { shift->_var('api_secret',        @_) }
sub version           { shift->_var('version',           @_) }
sub ua                { shift->_var('ua',                @_) }
sub bitcard_url       { shift->_var('bitcard_url',       @_) }
sub info_optional     { shift->_var('io',                @_) }
sub info_required     { shift->_var('ir',                @_) }

sub _url {
  my ($bc, $url) = (shift, shift);
  my $args = ($_[0] && ref $_[0]) ? $_[0] : { @_ };
  $args->{"bc_$_"} = delete $args->{$_} for keys %$args;
  $args->{bc_t} = $bc->token;
  $args->{bc_v} = $bc->version;
  $args->{bc_io} = ref $bc->info_optional ? join ",", @{$bc->info_optional} : $bc->info_optional; 
  $args->{bc_ir} = ref $bc->info_required ? join ",", @{$bc->info_required} : $bc->info_required; 
  delete $args->{bc_io} unless $args->{bc_io};
  delete $args->{bc_ir} unless $args->{bc_ir};
  my $base = $bc->bitcard_url;
  $base = "$base/" unless $base =~ m!/$!;
  my $uri = URI->new($base . $url);
  unless ($url =~ m/regkey.txt/) {
      if ($url =~ m!^api/!) {
          croak "Bitcard API Secret required for API calls" unless $bc->api_secret;
          $args->{bc_ts} = time;
          my @fields = sort keys %$args;
          $args->{bc_fields} = join ",", @fields, 'bc_fields';
          my $string = join "::", (map { "$args->{$_}" } @fields, 'bc_fields'), $bc->api_secret;
          warn "ST: $string";
          $args->{bc_sig} = sha1_hex($string);

sub key_url{

sub login_url {
  shift->_url('login', @_)

sub logout_url {
  shift->_url('logout', @_)

sub account_url {
  shift->_url('account', @_)

sub register_url {
  shift->_url('register', @_)

sub _api_url {
  my ($self, $method) = (shift, shift);
  $self->_url("api/$method", @_);

sub verify {
    my $bc = shift;
    my %data;
    my $fields;
    if (@_ == 1) {
      my $q = $_[0];
      if (ref $q eq 'HASH') {
	$fields = $_[0]->{bc_fields} || '';
	%data = map { $_ => $_[0]->{$_} } grep { defined $_[0]->{$_} } split(/,/, $fields), 'bc_sig';
      else {
	$fields = $q->param('bc_fields') || '';
	%data = map { $_ => $q->param($_) } grep { defined $q->param($_) } split(/,/, $fields), 'bc_sig';
    else {
      ## Later we could process arguments passed in a hash.
      return $bc->error("usage: verify(\$query)");

    #warn Data::Dumper->Dump([\%data], [qw(data)]);

    for ($data{bc_email}, $data{bc_sig}) {
      defined $_ and tr/ /+/;
    return $bc->error("Bitcard data has expired")
        unless $bc->skip_expiry_check or ($data{bc_ts}||0) + $bc->expires >= time;

    my $key = $bc->_fetch_key($bc->key_url) or return;
    my($r, $s) = split /:/, $data{bc_sig};
    my $sig = {};
    $sig->{r} = Math::BigInt->new("0b" . unpack("B*", decode_base64($r)));
    $sig->{s} = Math::BigInt->new("0b" . unpack("B*", decode_base64($s)));
    my $msg = join '::', (map { $data{$_} || '' } split /,/, $data{bc_fields} ), $bc->token;
    unless ($bc->_verify($msg, $key, $sig)) {
        return $bc->error("Bitcard signature verification failed");

    for my $k (keys %data) {
      my $nk = $k;
      $nk =~ s/^bc_//;
      $data{$nk} = delete $data{$k};

    if ($bc->version >= 4) {
      unless ($data{version} == $bc->version) {
        $data{version} =~ s/\D//g; 
        return $bc->error(sprintf "Expected Bitcard protocol version [%i], got version [%i].", $bc->version, $data{version});

      unless ($data{confirmed}) {
        return $bc->error('Account not confirmed');


sub _verify {
    my $bc = shift;
    my($msg, $key, $sig) = @_;
    my $u1 = Math::BigInt->new("0b" . unpack("B*", sha1($msg)));
    $u1 = ($u1 * $sig->{s}) % $key->{q};
    $sig->{s} = ($sig->{r} * $sig->{s}) % $key->{q};
    $key->{g}->bmodpow($u1, $key->{p});
    $key->{pub_key}->bmodpow($sig->{s}, $key->{p});
    $u1 = ($key->{g} * $key->{pub_key}) % $key->{p};
    $u1 %= $key->{q};
    $u1 == $sig->{r};

sub _get_ua {
    shift->ua || LWP::UserAgent->new;

sub _fetch_key {
    my $bc = shift;
    my($uri) = @_;
    my $cache = $bc->key_cache;
    ## If it's a callback, call it and return the return value.
    return $cache->($bc, $uri) if $cache && ref($cache) eq 'CODE';
    ## Otherwise, load the key.
    my $data;
    my $ua = $bc->_get_ua;
    if ($cache) {
        my $res = $ua->mirror($uri, $cache);
        return $bc->error("Failed to fetch key: " . $res->status_line)
            unless $res->is_success || $res->code == RC_NOT_MODIFIED;
        open my $fh, $cache
            or return $bc->error("Can't open $cache: $!");
        $data = do { local $/; <$fh> };
        close $fh;
    } else {
        my $res = $ua->get($uri);
        return $bc->error("Failed to fetch key: " . $res->status_line)
            unless $res->is_success;
        $data = $res->content;
    chomp $data;
    my $key = {};
    for my $f (split /\s+/, $data) {
        my($k, $v) = split /=/, $f, 2;
        $key->{$k} = Math::BigInt->new($v);

sub add_invite {
    my $self  = shift;
    my $url = $self->_api_url('invite/add_invite', @_);
    warn "URL: $url\n";
    my $res = $self->_get_ua->get($url);
    return $self->error("Failed to retrive invitation code: " . $res->status_line)
      unless $res->is_success;
    my $data = decode_json($res->content);


=head1 NAME

Authen::Bitcard - Bitcard authentication verification


    use CGI;
    use Authen::Bitcard;
    my $q = CGI->new;
    my $bc = Authen::Bitcard->new;
    # send user to $bc->login_url(r => $return_url);
    # when the user comes back, get the user id with:
    my $user = $bc->verify($q) or die $bc->errstr;


I<Authen::Bitcard> is an implementation of verification for signatures
generated by Bitcard authentication. For information on the Bitcard
protocol and using Bitcard in other applications, see

The module and the protocol are heavily based on I<Authen::Typekey>.
(In fact, the Bitcard authentication server also supports the TypeKey

=head1 USAGE

=head2 Authen::Bitcard->new

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

=head2 $bc->token([ $bitcard_token ])

Your Bitcard token, which you passed to Bitcard when creating the original
link.

This must be set B<before> calling I<verify> or I<login_url> (etc).

=head2 $bc->bitcard_url( [ $url ])

Get/set the base URL for the Bitcard service.  The default URL is
I<>.  The other *_url methods are build based
on the C<bitcard_url> value.

=head2 $bc->login_url( r => $return_url )

Returns the URL for the user to login.  Takes a hash or hash ref with
extra parameters to put in the URL.  One of them must be the C<r>
parameter with the URL the user will get returned to after logging in
(or canceling the login).

=head2 $bc->logout_url( r => $return_url )

Returns the URL you can send the user if they wish to logout.  Also
needs the C<r> parameter for the URL the Bitcard server should send
the user back to after logging out.

=head2 $bc->account_url( r => $return_url )

Returns the URL the user can edit his Bitcard account information at.
Also needs the C<r> parameter like C<login_url> and C<logout_url>.

=head2 $bc->register_url( r => $return_url )

Returns the URL for a user to register a new Bitcard account.  Also
needs the C<r> parameter as above.

=head2 $bc->key_url()

Get the URL from which the Bitcard public key can be obtained.

=head2 $bc->info_required(  $string | [ array ref ] )

With info_required you specify what user data you require.  The
possible fields are "username", "name" and "email" (see C<verify> for
more information).

The method takes either a comma separated string or a reference to an

This must be called before C<login_url>.

NOTE: "name" is currently not implemented well in the Bitcard server,
so we recommend you require "username", but mark "name" as optional if
you want the "display name" of the user returned.

=head2 $bc->info_optional( $string | [ array ref ] )

As C<info_required> except the Bitcard server will ask the user to
allow the information to be forwarded, but not require it to proceed.

The Bitcard server will always have a confirmed email address on file
before letting a user login.

=head2 $bc->verify($query)

Verify a Bitcard signature based on the other parameters given. The signature
and other parameters are found in the I<$query> object, which should be
either a hash reference, or 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 * id

The unique user id of the Bitcard user on your site.  It's a 128bit
number as a 40 byte hex value.

The id is always returned when the verification was successful (all
other user data fields are optional, see C<info_required> and

=item * username

The unique username of the Bitcard user.

=item * name

The user's display name.

=item * email

The user's email address. 

=item * ts

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


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

=head2 $bc->key_cache([ $cache ])

Provide a caching mechanism for the public key.

If I<$cache> is a CODE reference, it is treated as a callback that should
return the public key. The callback will be passed two arguments: the
I<Authen::TypeKey> object, and the URI of the key. It should return a
hash reference with the I<p>, I<g>, I<q>, and I<pub_key> keys set to
I<Math::BigInt> objects representing the pieces of the DSA public key.

Otherwise, I<$cache> should be the path to a local file where the public
key will be cached/mirrored.

If I<$cache> is not set, the key is not cached. By default, no caching

=head2 $bc->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 $bc->expires([ $secs ])

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

=head2 $bc->ua([ $user_agent ])

Get/set the LWP::UserAgent-like object which will be used to retrieve the
regkeys from the network.  Needs to support I<mirror> and I<get> methods. 
By default, LWP::UserAgent is used, and this method as a getter returns
C<undef> unless the user agent has been previously set.

=head2 $bc->version([ $version ])

Get/set the version of the Bitcard protocol to use. The default version
is C<3>.

=head2 $bc->api_secret( $secret )

Get/set the api_secret (needed for some API calls, add_invite for

=head2 $bc->add_invite

Returns a hashref with C<invite_url> and C<invite_key>.  Can be used
for "invitation only" sites where you have to login before you can
access the site.

=head1 LICENSE

I<Authen::Bitcard> is distributed under the Apache License; see the
LICENSE file in the distribution for details.


Except where otherwise noted, I<Authen::Bitcard> is Copyright
2004-2010 Develooper LLC,

Parts are Copyright 2004 Six Apart Ltd,

All rights reserved.