package WebService::CaptchasDotNet;

use 5.006;

use strict;
use warnings FATAL => qw(all);

use Digest::MD5 qw(md5 md5_hex);
use File::Spec ();
use File::Path qw(mkpath);
use File::Find qw(find);
use IO::File ();
use IO::Dir ();

our $DEBUG = 0;

#---------------------------------------------------------------------
# precompute some static variables to help persistent environments
# like mod_perl :)
#---------------------------------------------------------------------

my @characters;

foreach my $char (33 .. 126) {
  push @characters, chr $char;
}

#---------------------------------------------------------------------
# constructor
#---------------------------------------------------------------------
sub new {

  my $class = shift;

  my %args = @_;

  # Required Parameters: 'secret' and 'client'
  # Optional Parameters and Defaults
  my $self = { 
         _secret   => $args{secret},
         _client   => $args{client},
         _expire   => $args{cleanup_time} || 3600,
         _alphabet => $args{alphabet} || 'abcdefghkmnopqrstuvwxyz',
         _letters  => $args{letters} || 6,
         _height   => $args{height} || 80, 
         _width    => $args{width} || 240
         };

  bless $self, $class;

  $self->_init;

  return $self;
}

#---------------------------------------------------------------------
# expire accessor
#---------------------------------------------------------------------
sub expire {

  my $self = shift;

  $self->{_expire} = shift if @_;

  return $self->{_expire};
}

#---------------------------------------------------------------------
# validate routine
# make sure the random string has been generated by the 
# random () function and not been used yet
#---------------------------------------------------------------------
sub validate {

  my $self = shift;

  my $random = shift;

  # untaint
  ($random) = $random =~ m!^([0-9a-z-A-Z]{32})$!
    if $random;

  unless ($random) {

    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "unable to validate invalid random string\n"
      if $DEBUG;

    return;
  }

  $self->{_random} = $random;

  my $file = File::Spec->catfile($self->{_tempdir}, $random);

  unless (-e $file) {

    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "sanity file $file not found\n"
      if $DEBUG;

    return;
  }

  if ($self->_time_to_cleanup($file)) {

    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "sanity file $file too old\n"
      if $DEBUG;

    unlink $file;

    return;
  }

  $self->{_random_file} = $file;

  return 1;
}

#---------------------------------------------------------------------
# verify routine
# make sure user input matches the captcha
#---------------------------------------------------------------------
sub verify {

  my $self = shift;

  my ($input, $random) = @_;

  $random = $self->{_random} unless ($random);

  my $secret   = $self->{_secret};
  my $alphabet = $self->{_alphabet};
  my $letters  = $self->{_letters};

  # basic sanity checking

  unless ($secret && $random && $input ) {
    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "insufficient data for verify()\n"
      if $DEBUG;

    return;
  }

  # now for the computation - this is what
  # the captcha image should really be
  my $digest_base = $secret . $random;
  if (!($alphabet eq 'abcdefghijklmnopqrstuvwxyz') || ($letters != 6)) {
    $digest_base = $digest_base . ":" . $alphabet . ":" . $letters;
  }

  my $decode = substr(md5($digest_base), 0, $letters);

  my $captcha = '';

  foreach my $byte (split //, $decode) {
    $captcha .= substr($alphabet, ord($byte) % length($alphabet), 1);
  }

  if ($input eq $captcha) {
    unlink $self->{_random_file} if (-e $self->{_random_file});
    undef $self->{_random_file};
    return 1;
  }

  return;
}

#---------------------------------------------------------------------
# random string generator
#---------------------------------------------------------------------
sub random {

  my $self = shift;

  my $string = join '', @characters[rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                   ];

  # hmph, I can't seem to localize md5_hex() in my tests...
  my $random = Digest::MD5->new->add($string)->hexdigest;

  my $tempdir = $self->{_tempdir};

  my $file = File::Spec->catfile($tempdir, $random);

  if (-e $file) {
    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "collision found for '$random'\n"
      if $DEBUG;

    return;
  }

  my $fh = IO::File->new(">$file");

  unless ($fh) {
    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "could not create '$file': $!\n"
      if $DEBUG;

    return;
  }

  undef $fh;

  $self->{_random} = $random;

  return $random;
}

#---------------------------------------------------------------------
# url for captcha image
#---------------------------------------------------------------------
sub image_url {

  my $self = shift;

  my ($random, $base) = @_;

  $random = $self->{_random} unless ($random);
  $base = "http://image.captchas.net/" unless ($base);
  $base = "$base?client=$self->{_client}";
  $base = "$base&random=$random";
  if (!($self->{_alphabet} eq 'abcdefghijklmnopqrstuvwxyz')) {
     $base = "$base&alphabet=$self->{_alphabet}";
  }
  if ($self->{_letters} != 6) {
     $base = "$base&letters=$self->{_letters}";
  }
  if ($self->{_height} != 80) {
     $base = "$base&height=$self->{_height}";
  }
  if ($self->{_width} != 240) {
     $base = "$base&width=$self->{_width}";
  }
  return "$base";
}

#---------------------------------------------------------------------
# url for captcha audio
#---------------------------------------------------------------------
sub audio_url {

  my $self = shift;

  my ($random, $base) = @_;

  $random = $self->{_random} unless ($random);
  $base = "http://audio.captchas.net/" unless ($base);
  $base = "$base?client=$self->{_client}";
  $base = "$base&random=$random";
  if (!($self->{_alphabet} eq 'abcdefghijklmnopqrstuvwxyz')) {
     $base = "$base&alphabet=$self->{_alphabet}";
  }
  if ($self->{_letters} != 6) {
     $base = "$base&letters=$self->{_letters}";
  }
  return "$base";
}

#---------------------------------------------------------------------
# return a complete fault tolerant image code
# if image.captchas.net is not reachable for 10 seconds, a
# javascript switches to image.backup.captchas.net
#---------------------------------------------------------------------
sub image {

  my $self = shift;

  my ($random, $id, $width, $height) = @_;

  $random = $self->{_random} unless ($random);
  $id = "captchas.net" unless ($id);
  $width  = $self->{_width};
  $height = $self->{_height};

  return 
     '<a href="http://captchas.net"><img
            style="border: none; vertical-align: bottom"
            id="' . $id . '" src="' . $self->image_url ($random) . '" 
            width="' . $width . '" height="' . $height . '" 
            alt="The CAPTCHA image" /></a>
        <script type="text/javascript">
          <!--
          function captchas_image_reload (imgId) 
          {
	    var image_url = document.getElementById(imgId).src;
            image_url+= "&";
	    document.getElementById(imgId).src = image_url;
          }

          function captchas_image_error (image) 
          {
            if (!image.timeout) return true;
            image.src = image.src.replace (/^http:\/\/image\.captchas\.net/, 
                                        \'http://image.backup.captchas.net\');
            return captchas_image_loaded (image);
          }

          function captchas_image_loaded (image)
          {
            if (!image.timeout) return true;
            window.clearTimeout (image.timeout);
            image.timeout = false;
            return true;
          }

          var image = document.getElementById (\'' . $id . '\');
          image.onerror = function() {return captchas_image_error (image);};
          image.onload = function() {return captchas_image_loaded (image);};
          image.timeout 
            = window.setTimeout(
            "captchas_image_error (document.getElementById (\'' . $id . '\'))",
            10000);
          image.src = image.src;
          //-->      
        </script>';
}

#---------------------------------------------------------------------
# private initialization routine
#---------------------------------------------------------------------
sub _init {

  my $self = shift;

  # create a temporary filesystem to store used random strings

  my $tmp = File::Spec->catfile(File::Spec->tmpdir,
                                'CaptchasDotNet');

  mkpath $tmp unless -d $tmp;

  $self->{_tempdir} = $tmp;

  $self->_cleanup;
}

sub _cleanup {

  my $self = shift;

  my $dir = $self->{_tempdir};

  my $dh = IO::Dir->new($dir);

  if ($dh) {
    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "cleaning up stale entries in $dir\n"
      if $DEBUG;

    foreach my $entry ($dh->read) {

      # untaint
      ($entry) = $entry =~ m!^([0-9a-z-A-Z]{32})$!;

      next unless $entry;

      my $file = File::Spec->catfile($dir, $entry);

      unlink $file if $self->_time_to_cleanup($file); 
    } 

    return 1;
  }

  print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                         "cannot open cache directory $dir - $!\n"
    if $DEBUG;

  return;
}

sub _time_to_cleanup {

  my $self = shift;

  my $file = shift;

  my $mtime = (stat $file)[9];

  if ($mtime && $mtime + $self->{_expire} < time) {

    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "$file created at $mtime ready for cleanup\n"
      if $DEBUG;

    return 1;
  }

  return;
}

1;

#---------------------------------------------------------------------
# End
#---------------------------------------------------------------------