File Coverage

blib/lib/WWW/SolveMedia.pm

Criterion	Covered	Total	%
statement	15	54	27.7
branch	0	20	0.0
condition	0	5	0.0
subroutine	5	8	62.5
pod	3	3	100.0
total	23	90	25.5

# -*- perl -*-

# Copyright (c) 2009 by Jeff Weisberg
# Author: Jeff Weisberg
# Created: 2009-Jun-18 12:38 (EDT)
# Function: AC Puzzle Plugin
#
# $Id: SolveMedia.pm,v 1.1 2010/09/13 18:01:06 ilia Exp $

package WWW::SolveMedia;
use Carp;
use JSON;
use LWP::UserAgent;
use Digest::SHA1 'sha1_hex';
use strict;

our $VERSION 		= '1.1';

my $AC_API_HTTP		= 'http://api.solvemedia.com';
my $AC_API_HTTPS	= 'https://api-secure.solvemedia.com';
my $AC_VFY_HTTP		= 'http://verify.solvemedia.com';
my $AC_SIGNUP_URL	= 'http://api.solvemedia.com/public/signup';

# c-key, v-key, h-key, opts
sub new {
    my $class = shift;
    my $ckey  = shift;
    my $vkey  = shift;
    my $hkey  = shift;		# optional
    my $opts  = shift || {};	# for dev/testing

    croak "usage: new(ckey, vkey, hkey, [opts])\nyou may sign up for API keys at $AC_SIGNUP_URL"
      unless $ckey && $vkey;

    return bless {
        ckey	=> $ckey,
        vkey	=> $vkey,
        hkey	=> $hkey,
        http	=> $AC_API_HTTP,
        https	=> $AC_API_HTTPS,
        verify	=> $AC_VFY_HTTP,
        %$opts,
    }, $class;
}

# error_p, ssl_p, jsopts
sub get_html {
    my $me   = shift;
    my $errp = shift;
    my $sslp = shift;
    my $opts = shift;

    my $html = "\n";

    if( $opts ){
        $html .= "  \n    var ACPuzzleOptions = " </td>
</tr>

<tr>
<td  class="h" >
<a name="57">57</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">           . encode_json($opts) </td>
</tr>

<tr>
<td  class="h" >
<a name="58">58</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">           . ";\n  \n";
    }

    my $baseurl = $sslp ? $me->{https} : $me->{http};
    my $param   = $errp ? ';error=1' : '';

    $html .= <
  
</tr>

<tr>
<td  class="h" >
<a name="66">66</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">      src="$baseurl/papi/challenge.script?k=$me->{ckey}$param"> </td>
</tr>

<tr>
<td  class="h" >
<a name="67">67</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">


     
</tr>

<tr>
<td  class="h" >
<a name="71">71</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">          height="300" width="500" frameborder="0">
      </td>
</tr>

<tr>
<td  class="h" >
<a name="73">73</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">

         value="manual_challenge">


WIDGET
    ;

    return $html;
}

# ip, challenge, answer
sub check_answer {
    my $me     = shift;
    my $ipaddr = shift;
    my $ch     = shift;
    my $ans    = shift;

    # QQQ - validate more before sending?
    return { is_valid => 0, error => 'missing challenge' } unless $ch;
    return { is_valid => 0, error => 'missing client-ip' } unless $ipaddr;

    my $ua  = LWP::UserAgent->new( agent => "SolveMedia perl/$VERSION");
    my $res =  $ua->post( "$AC_VFY_HTTP/papi/verify", {
        privatekey	=> $me->{vkey},
        remoteip	=> $ipaddr,
        challenge	=> $ch,
        response	=> $ans,
    });

    unless( $res->is_success() ){
        # QQQ - return what error?
        carp "check_answer - server error: " . $res->status_line;
        return { is_valid => 0, error => 'server error' };
    }

    my($pass, $msg, $check) = split /\n/, $res->content();
    chomp($check);

    unless( $pass eq 'true' ){
        return { is_valid => 0, error => $msg };
    }

    # validate message authenticator
    if( $me->{hkey} ){
        my $hash = sha1_hex("$pass$ch$me->{hkey}");
        unless( $hash eq $check ){
            carp "check_answer - message authentication failed. either:
1) you are using an incorrect hash-key,
2) evil hackers trying to attack the system.";
            return { is_valid => 0, error => 'message authentication check failed' };
        }
    }

    # Yay!
    return { is_valid => 1 };

}

1;

__END__