File Coverage

blib/lib/Authen/Bitcard.pm

Criterion	Covered	Total	%
statement	117	172	68.0
branch	23	56	41.0
condition	5	18	27.7
subroutine	28	36	77.7
pod	18	18	100.0
total	191	300	63.6

package Authen::Bitcard;
BEGIN {
  $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;
    $bc->skip_expiry_check(0);
    $bc->expires(600);
    $bc->bitcard_url('https://www.bitcard.org/');
    $bc->version(4);
    $bc->token('');
    my %args = @_;
    for my $k (keys %args) {
      next unless $bc->can($k);
      $bc->$k($args{$k});
    }
    $bc;
}

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

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);
      }
      $uri->query_form_hash($args);
  }
  $uri->as_string;
}

sub key_url{
  shift->_url("regkey.txt");
}

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');
      }
    }

    \%data;
}

sub _verify {
    my $bc = shift;
    my($msg, $key, $sig) = @_;
    my $u1 = Math::BigInt->new("0b" . unpack("B*", sha1($msg)));
    $sig->{s}->bmodinv($key->{q});
    $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);
    }
    $key;
}

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);
    $data;
}

1;
__END__