Finance::Bank::Cahoot - Check your Cahoot bank accounts from Perl

  my $cahoot = Finance::Bank::Cahoot->new(credentials => 'Constant',
                                          credentials_options => {
                                             account => '12345678',
                                             password => 'verysecret',
					     place => 'London',
					     date => '01/01/1906',
					     username => 'dummy',
					     maiden => 'Smith' } );

  my $accounts = $cahoot->accounts;
  $cahoot->set_account($accounts->[0]->{account});
  my $snapshot = $cahoot->snapshot;
  foreach my $row (@$snapshot) {
    print join ',', @$row; print "\n";
  }

# Copyright (c) 2008 Jon Connell.
# All Rights Reserved.
#
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Finance::Bank::Cahoot;

use strict;
use warnings 'all';
use vars qw($VERSION @REQUIRED_SUBS);

$VERSION = '1.07';
@REQUIRED_SUBS = qw(account place date maiden username password);

use Carp qw(croak);
use Time::Local qw(timegm);
use Encode;
use English '-no_match_vars';
use HTML::TableExtract;
use WWW::Mechanize;

use Finance::Bank::Cahoot::Statement;
use Finance::Bank::Cahoot::DirectDebit;

sub new
{
  my ($class, %opts) = @_;

  croak 'Must provide a credentials handler' if not exists $opts{credentials};

  my $self = { _mech        => new WWW::Mechanize(autocheck => 1),
	       _credentials => $opts{credentials},
	       _connected   => 0,
	     };
  $self->{_mech}->agent_alias('Mac Safari');

  bless $self, $class;
  $self->_set_credentials(%opts);
  return $self;
}

sub _set_credentials
{
  my ($self, %opts) = @_;

  croak 'Must provide either a premade credentials object or a class name together with options'
      if not exists $opts{credentials};

  if (ref $opts{credentials}) {
    croak 'Not a valid credentials object'
      if not $self->_isa_credentials($opts{credentials});

    croak 'Can\'t accept credential options if supplying a premade credentials object'
	if exists $opts{credentials_options};

    $self->{_credentials} = $opts{credentials};
  } else {
    croak 'Must provide credential options unless suppying a premade credentials object'
	if not exists $opts{credentials_options};

    $self->{_credentials} =
      $self->_new_credentials($opts{credentials}, $opts{credentials_options});
  }
  return $self;
}

sub _new_credentials
{
  my ($self, $class, $options) = @_;

  croak 'Invalid class name'
    if $class !~ /^(?:\w|::)+$/;

  my $full_class = 'Finance::Bank::Cahoot::CredentialsProvider::'.$class;

  eval "local \$SIG{'__DIE__'}; local \$SIG{'__WARN__'}; require $full_class;";  ## no critic
  croak 'Not a valid credentials class - not found' if $EVAL_ERROR;

  my $credentials;
  {
    local $Carp::CarpLevel = $Carp::CarpLevel + 1;   ## no critic
    $credentials = $full_class->new(credentials => [@REQUIRED_SUBS],
				    options => $options);
  }
  croak 'Not a valid credentials class - incomplete' if not $self->_isa_credentials($credentials);
  return $credentials;
}

sub _isa_credentials
{
  my ($self, $credentials) = @_;

  foreach my $sub (@REQUIRED_SUBS) {
    return unless defined eval {
      local $SIG{'__DIE__'};       ## no critic
      local $SIG{'__WARN__'};      ## no critic
      $credentials->can($sub);
    };
  }

  return 1;
}

sub login
{
  my ($self) = @_;

  return if $self->{_connected};

  $self->_get('https://securebank.cahoot.com/AquariusSecurity/bks/web/en/core_banking/log_in/frameset_top_log_in.jsp');
  my %fields = (inputuserid => $self->{_credentials}->username());
  my $content = $self->{_mech}->content;
  foreach my $input ($self->{_mech}->find_all_inputs()) {
     my $name = $input->name();
     next if not defined $name;
     next if defined $fields{$name};
     $fields{$name} = $self->{_credentials}->place() if $content =~ /address or place:/i;
     $fields{$name} = $self->{_credentials}->date() if $content =~ /memorable year:/i;
     $fields{$name} = $self->{_credentials}->maiden() if $content =~ /maiden name:/i;
  }
  $self->_submit_form(fields => \%fields);

  my %chars;
  my $label;
  # Expect:
  #   <label for="passwordChar1">... select character #d ...</label>
  HTML::Parser->new(unbroken_text => 1,
		    report_tags   => [qw(label)],
		    start_h       => [ sub {
					 return if not defined $_[0]->{for};
					 return if $_[0]->{for} !~ /passwordChar(\d+)/;
					 $label = $1 if defined $1;
				       }, 'attr' ],
		    end_h         => [ sub {
					 $label = undef;
				       } ],
		    text_h        => [ sub {
					 return if not defined $label;
					 $_[0] =~ /select character.*?(\d+)/;
					 $chars{$label} = $1 if defined $1;
				       }, 'dtext' ])->parse($self->{_mech}->content());

  {
    # We submit a form, modifying hidden fields - WWW::Mechanize does not like
    # this (see FAQ).
    local $^W = 0; ## no critic
    $self->_submit_form(fields => { passwordChar1Hidden => $self->{_credentials}->password($chars{1}),
				    passwordChar2Hidden => $self->{_credentials}->password($chars{2}),
				    passwordChar1 => q{*},
				    passwordChar2 => q{*} });
  }
  $self->{_connected} = 1;
  return $self;
}

sub _test_content_for_error
{
  my ($self) = @_;
  
  croak 'Login failed'
    if $self->{_mech}->content =~ m{We cannot recognise those details};
  croak 'General system error returned from Cahoot server'
    if $self->{_mech}->content =~ m{/AquariusSecurity/web/en/GeneralSystemError.html};
    return;
}

sub _get
{
  my ($self, $url) = @_;
  
  $self->{_mech}->get($url);
  $self->_test_content_for_error;
  return;
}

sub _submit_form
{
  my ($self, @args) = @_;
  
  $self->{_mech}->submit_form(@args);
  $self->_test_content_for_error;
  return;
}

sub _get_frames
{
  my ($self) = @_;

  foreach my $link ($self->{_mech}->find_all_links(tag => 'frame')) {
    $self->_get($link->url());
  }
  return;
}

sub _trim
{
  my ($str) = @_;
  return if not defined $str;
  $str =~ s/[\x80-\xff]//gs;
  $str =~ s/\r//gs;
  $str =~ s/\s+/ /gs;
  $str =~ s/^\s+//gs;
  $str =~ s/\s+$//gs;
  return $str;
}

sub _trim_table
{
  my ($table) = @_;
  my @new;
  ROW: foreach my $row (@{$table}) {
    foreach my $col (@{$row}) {
      next ROW if not defined $col;
      $col = _trim $col;
    }
    push @new, $row;
  }
  return \@new;
}

sub set_account
{
  my ($self, $account) = @_;

  croak 'set_account called with no account number' if not defined $account;
  return if defined $self->{_current_account} and $self->{_current_account} eq $account;
  $self->login();
  $self->{_accounts} = $self->accounts if not defined $self->{_accounts};
  my $account_index;
  foreach my $account_details (@{$self->{_accounts}}) {
    $account_index = $account_details->{account_index} if $account_details->{account} eq $account or $account_details->{name} eq $account;
  }
  croak 'set_account called with invalid account details' if not defined $account_index;
  $self->_get('/servlet/com.aquariussecurity.accounts.servlet.PersonalHomepageSelectionServlet?productType=MTA&Index='.$account_index.'&origin=init');
  $self->_get_frames();
  $self->{_current_account} = $account;
  delete $self->{_statements} if defined $self->{_statements};
  return $self;
}

sub statement
{
  my ($self, $account) = @_;

  $self->login();
  $self->set_account($account) if defined $account;
  croak 'No account currently selected' if not defined $self->{_current_account};

  $self->_get('/servlet/com.aquariussecurity.accounts.servlet.CurrentAccountStatementEntryServlet?print=yes');
  my $te = HTML::TableExtract->new(headers => [qw(Date Transaction Withdrawn Paid Balance)]);
  $te->parse($self->{_mech}->content);
  my @table = $te->first_table_found->rows;
  return Finance::Bank::Cahoot::Statement->new(_trim_table \@table);
}

# convert a date of the form DD/MM/YY (assuming YY is in the 21st century) into a timestamp
sub _date2time
{
  my ($d, $m, $y) = split /\D+/, shift;
  return timegm 0, 0, 0, $d, $m-1, $y+100;   ## no critic (ProhibitMagicNumbers)
}

sub statements
{
  my ($self, $account) = @_;

  $self->login();
  $self->set_account($account) if defined $account;
  croak 'No account currently selected' if not defined $self->{_current_account};

  $self->_get('/servlet/com.aquariussecurity.accounts.servlet.CurrentAccountStatementEntryServlet');
  $self->{_mech}->content =~ m/name="statementPeriods"(.*?)<\/select>/gsi;
  croak 'Statement extraction parsing failed' if not defined $1;
  my $select = $1;
  my @dates = ($select =~ m/<option value="(.+?)"/gsi);
  my @statements;
  foreach my $date (@dates) {
    $date =~ m/(\S+)\s*-\s*(\S+)/gsi;
    push @statements, { description => $date,
			start => _date2time($1),
			end => _date2time($2)
		      };
  }
  $self->{_statements} = \@statements;
  return \@statements;
}

sub set_statement
{
  my ($self, $statement) = @_;

  croak 'No statement selected for set_statement()' if not defined $statement;
  $self->login;
  croak 'No account currently selected' if not defined $self->{_current_account};
  $self->statements if not defined $self->{_statements};

  TRY: while (1) {
    foreach my $s (@{$self->{_statements}}) {
      last TRY if $s->{description} eq $statement;
    }
    croak 'Invalid statement: '.$statement;
  }
  $self->_get('/servlet/com.aquariussecurity.accounts.servlet.CurrentAccountStatementEntryServlet');
  $self->{_mech}->select('statementPeriods', $statement);
  $self->_submit_form();
  return $self;
}

sub debits
{
  my ($self, $account) = @_;

  $self->login();
  $self->set_account($account) if defined $account;
  croak 'No account currently selected' if not defined $self->{_current_account};

  $self->_get('/AquariusSecurity/web/en/core_banking/current_account/direct_debits/frameset_view_direct_debits.html');
  $self->_get_frames();
  $self->_get('/servlet/com.aquariussecurity.orders.servlet.DirectDebitListEntryServlet');

  my $te = HTML::TableExtract->new(headers => ['Payable to', 'Reference is']);
  $te->parse(decode_utf8 $self->{_mech}->content);
  my $table = _trim_table([$te->first_table_found->rows]);
  my @debits;
  foreach my $row (@{$table}) {
    push @debits, Finance::Bank::Cahoot::DirectDebit->new($row);
  }
  while ($self->{_mech}->content =~ /origin=forward/) {
    $self->{_mech}->follow_link(url_regex => qr/origin=forward/);
    $self->_test_content_for_error;
    my $te = HTML::TableExtract->new(headers => ['Payable to', 'Reference is']);
    $te->parse(decode_utf8 $self->{_mech}->content);
    my $table = _trim_table([$te->first_table_found->rows]);
    foreach my $row (@{$table}) {
      push @debits, Finance::Bank::Cahoot::DirectDebit->new($row);
    }
  }
  return \@debits;
}

sub snapshot
{
  my ($self, $account) = @_;

  $self->login();
  $self->set_account($account) if defined $account;
  croak 'No account currently selected' if not defined $self->{_current_account};

  $self->_get('/servlet/com.aquariussecurity.accounts.servlet.CurrentAccountStatusServlet?origin=print');
  my $te = HTML::TableExtract->new(headers => ['Date', 'Transaction Details', 'Withdrawn', 'Paid In']);
  $te->parse($self->{_mech}->content);
  my @table = $te->first_table_found->rows;
  return Finance::Bank::Cahoot::Statement->new(_trim_table \@table);
}

sub accounts
{
  my ($self) = @_;
  $self->login();
  $self->_get('/AquariusSecurity/web/en/core_banking/personal_homepage/frameset_personal_homepage.html');
  $self->_get_frames;
  my $content = $self->{_mech}->content();
  my @account_details = ($content =~ m/(PersonalHomepageSelectionServlet.*?"go\s+to\s+.*?")/gsi);
  my @accounts;
  foreach my $account (@account_details) {
    $account =~ m/(available\s+balance|payment\s+this\s+month):.*?([\-0-9\.]+).*(current\s+balance|payment\s+this\s+month):.*?([\-0-9\.]+).*?productType=MTA&Index=(\d+).*?="go\s+to\s+(.*?)\s+(\d+)"/gsi;
    push @accounts, { name => _trim($6),
                      account => $7,
                      account_index => $5,
                      balance => $4,
                      available => $2 };
  }
  $self->{_accounts} = \@accounts;
  return \@accounts;
}

1;
__END__