view release on metacpan or  search on metacpan

lib/Captcha/Stateless/Text.pm  view on Meta::CPAN

###############################################################################
# Captcha::Stateless::Text module for Perl.
# Copyright (C) 2024, Lester Hightower <hightowe@cpan.org>
###############################################################################

package Captcha::Stateless::Text;

use strict;
use v5.20; # Version needed for feature signatures
use feature qw(signatures);
no warnings qw(experimental::signatures);
use Sub::Util qw(set_subname);   # core
use MIME::Base64 qw();           # core
use Digest::MD5 qw(md5_hex);     # core
use Data::Dumper;                # core
use Try::Tiny;                   # libtry-tiny-perl
use Crypt::Mode::CBC;            # libcryptx-perl
use JSON qw(to_json from_json);  # libjson-perl
use Lingua::EN::Nums2Words;      # From CPAN (cpanm Lingua::EN::Nums2Words)
$Data::Dumper::Sortkeys = 1;
Lingua::EN::Nums2Words::set_case('lower');

our $VERSION = "0.5";
sub Version { $VERSION; }

my %QAfuncs = {}; # Holds our private __ANON__ subroutines

sub new {
  my $class = shift;
  my $self = {
    cipher => 'AES',
    iv  => 'gkbx5g9hsvhqrosg',                 # Must be 16 bytes / 128 bits
    key => 'tyDjb39dQ20pdva0lTpyuiowWfxSSwa9', # 32 bytes / 256 bits (AES256)
    ep_pre => 'captcha'.lc(substr(md5_hex(__PACKAGE__), 0, 6)).'.',
  };
  bless $self, $class;
  return $self;
}

#############################################################################
# Object parameter get/set functions ########################################
#############################################################################
sub get_ep_pre($self)           { return $self->{ep_pre}; }
sub set_self_val($self, $k, $v) { $self->{$k} = $v; }
sub set_cipher($self, $v)       { set_self_val($self, 'cipher', $v); }
sub set_iv($self, $v)           { set_self_val($self, 'iv', $v); }
sub set_key($self, $v)          { set_self_val($self, 'key', $v); }

#############################################################################
# Crypto functions ##########################################################
#############################################################################
sub encrypt_b64($self, $data) {
  my $d = my_crypt_cbc($self, 'encrypt', $self->{cipher}, $self->{key}, $self->{iv}, $data);
  return MIME::Base64::encode_base64url($d, ''); # '' for no line breaks
}
sub decrypt_b64($self, $data) {
  my $d = MIME::Base64::decode_base64url($data);
  return my_crypt_cbc($self, 'decrypt', $self->{cipher}, $self->{key}, $self->{iv}, $d);
}
# Helper function to centralize and reduce code duplication
sub my_crypt_cbc($self, $mode, $cipher, $key, $iv, $data) {
  my $pkg = __PACKAGE__;

  my $cbc = Crypt::Mode::CBC->new($cipher, 1);
  if ($mode eq 'encrypt') {
    my $payload = undef;
    try {
      $payload = $cbc->encrypt($data, $key, $iv); # ENCRYPT
    } catch {
      warn("$pkg my_crypt_cbc() failed to $mode with error: $_");
      $payload = undef;
    };
    return $payload;
  } elsif ($mode eq 'decrypt') {
    my $payload = undef;
    try {
      $payload = $cbc->decrypt($data, $key, $iv); # DECRYPT
    } catch {
      warn("$pkg my_crypt_cbc() failed to $mode with error: $_");
      $payload = undef;
    };
    return $payload;
  }
  return undef;
}
#############################################################################
#############################################################################

#############################################################################
# Captcha creation functions ################################################
#############################################################################
sub getQA_chars {
  my $qa = $QAfuncs{chars}(@_);
  $_[0]->add_enc_payload($qa);
  return $qa;
}
sub getQA_math {
  my $qa = $QAfuncs{math}(@_);
  $_[0]->add_enc_payload($qa);
  return $qa;
}
sub add_enc_payload($self, $qa) {
  # Make and add the enc_payload
  my $payload_json = to_json($qa);
  my $enc_payload = $self->encrypt_b64($payload_json);
  $qa->{enc_payload} = $self->{ep_pre} . $enc_payload;
}
sub validate($self, $answer, $enc_payload) {
  my $ep_pre = $self->{ep_pre};
  return 0 if (!(defined($enc_payload) && length($enc_payload)));
  return 0 if ($enc_payload !~ m/^\Q$ep_pre\E/); # Invalid payload
  $enc_payload =~ s/^\Q$ep_pre\E//; # Trim the prefix
  my $payload = $self->decrypt_b64($enc_payload);
  return 0 if (!defined($payload));
  my $qa = from_json($payload);
  return 1 if ($qa->{a} =~ m/^\d+$/ && $answer == $qa->{a});
  return 1 if ($answer eq $qa->{a});
  return 0;
}

#############################################################################
# The subs in %QAfuncs are not callable by the outside world because they are
# __ANON__ and not in the Perl sumbol table.
#############################################################################