bitlair/revbank
6
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

RevBank 2.0, a rewrite. It's plugin based now.

Browse source
This commit is contained in:
Juerd Waalboer 2013-02-26 04:11:13 +01:00
parent b9a598fb69
commit c157ea0214
20 changed files with 1192 additions and 541 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

122
RevBank/Cart.pm Normal file
View file

@ -0,0 +1,122 @@
package RevBank::Cart;
use strict;
use Carp ();
use List::Util ();
use RevBank::Global;
# Some code is written with the assumption that the card will only grow or
# be emptied. Changing existing stuff or removing items is probably not a
# good idea, and may lead to inconsistency.
sub new {
my ($class) = @_;
return bless { }, $class;
}
sub add {
my ($self, $user, $amount, $description) = @_;
$user ||= '$you';
push @{ $self->{ $user } }, {
amount => $amount,
description => $description,
};
}
sub empty {
my ($self) = @_;
%$self = ();
}
sub _dump_item {
my ($prefix, $user, $amount, $description) = @_;
return sprintf(
"%s%-17s %4s EUR %5.2f %s",
$prefix,
$user,
($amount > 0 ? 'GAIN' : $amount < 0 ? 'LOSE' : ''),
abs($amount),
$description
);
}
sub as_strings {
my ($self, $prefix) = @_;
$prefix ||= ' ';
my @s;
for my $user (sort keys %$self) {
my @items = @{ $self->{$user} };
my $sum = List::Util::sum(map $_->{amount}, @items);
push @s, _dump_item($prefix, $user, $_->{amount}, "# $_->{description}")
for @items;
push @s, _dump_item($prefix, $user, $sum, "TOTAL")
if @items > 1;
}
return @s;
}
sub display {
my ($self, $prefix) = @_;
say $_ for $self->as_strings($prefix);
}
sub size {
my ($self) = @_;
return List::Util::sum(map scalar @{ $self->{$_} }, keys %$self) || 0;
}
sub _set_user {
my ($self, $user) = @_;
exists $self->{'$you'}
or Carp::croak("Error: no cart items for shell user");
$self->{$user} ||= [];
push @{ $self->{$user} }, @{ delete $self->{'$you'} };
for (values %$self) {
$_->{description} =~ s/\$you\b/$user/g for @$_;
}
}
sub checkout {
my ($self, $user) = @_;
$self->_set_user($user) if $user;
exists $self->{'$you'} and die "Incomplete transaction; user not set.";
my $transaction_id = time() - 1300000000;
RevBank::Plugins::call_hooks("checkout", $self, $user, $transaction_id);
for my $account (keys %$self) {
my $sum = List::Util::sum(map $_->{amount}, @{ $self->{$account} });
RevBank::Users::update($account, $sum, $transaction_id);
}
$self->empty;
sleep 1; # Ensure new timestamp/id for new transaction
}
sub select_items {
my ($self, $regex) = @_;
$regex ||= qr/(?:)/; # Match everything if no regex is given
my @matches;
for my $user (keys %$self) {
for my $item (@{ $self->{$user} }) {
push @matches, { user => $user, %$item }
if $item->{description} =~ /$regex/;
}
}
return @matches;
}
1;

13
RevBank/Eval.pm Normal file
View file

@ -0,0 +1,13 @@
package RevBank::Eval;
# This function is used so strings can be eval'ed in a clean lexical
# environment.
sub clean_eval { eval shift }
# No, it's not scary. We're using string eval to load plugins, just as it would
# be used to load modules. As we're not executing user input, this is really
# NOT a security bug.
1;

87
RevBank/Global.pm Normal file
View file

@ -0,0 +1,87 @@
package RevBank::Global;
use strict;
use POSIX qw(strftime);
sub import {
require RevBank::Plugins;
require RevBank::Users;
no strict 'refs';
my $caller = caller;
*{"$caller\::ACCEPT"} = sub () { \1 };
*{"$caller\::ABORT"} = sub () { \2 };
*{"$caller\::REJECT"} = sub () { \3 };
*{"$caller\::NEXT"} = sub () { \4 };
*{"$caller\::DONE"} = sub () { \5 };
*{"$caller\::parse_user"} = \&RevBank::Users::parse_user;
*{"$caller\::parse_amount"} = sub {
my ($amount) = @_;
defined $amount or return undef;
length $amount or return undef;
$amount =~ /^(-)?[0-9]*(?:[,.][0-9]{1,2})?$/ or return undef;
if ($1) {
die "For our sanity, no negative amounts, please :).\n";
}
$amount =~ s/,/./g;
if ($amount > 999) {
die "That's way too much money, or an unknown barcode.\n";
}
return 0 + $amount;
};
*{"$caller\::call_hooks"} = \&RevBank::Plugins::call_hooks;
*{"$caller\::say"} = sub {
print @_, "\n";
};
*{"$caller\::now"} = sub {
return strftime '%Y-%m-%d_%H:%M:%S', localtime;
};
}
1;
__END__
=head1 NAME
RevBank::Global - Constants and utility functions
=head1 SYNOPSIS
use RevBank::Global;
=head1 DESCRIPTION
This module unconditionally exports the following symbols into the calling
namespace:
=head2 ACCEPT, ABORT, REJECT, NEXT, DONE
Return codes for plugins. See L<RevBank::Plugins>.
=head2 say
Print with newline, in case your Perl version doesn't already have a C<say>.
=head2 call_hooks($hook, @arguments)
See C<call_hooks> in L<RevBank::Plugins>.
=head2 parse_amount($amount)
Returns the amount given if it is well formed, undef if it was not. Dies if
the given amount exceeds certain boundaries.
Commas are changed to periods so C<3,50> and C<3.50> both result in C<3.5>.
=head2 parse_user($username)
See C<parse_user> in L<RevBank::Users>.
Returns the canonical username, or undef if the account does not exist.
=head1 AUTHOR
Juerd Waalboer <#####@juerd.nl>
=head1 LICENSE
Pick your favourite OSI license.

58
RevBank/Messages.pm Normal file
View file

@ -0,0 +1,58 @@
package RevBank::Messages;
use RevBank::Global;
use base 'RevBank::Plugin';
# Don't edit this file just to change the messages. Instead, RTFM and define
# your own hooks.
BEGIN {
RevBank::Plugins::register("RevBank::Messages");
}
sub command { return NEXT; }
sub id { 'built in messages' }
sub hook_startup {
say "\e[0m\n\n\nWelcome to the RevBank Shell, version $::VERSION\n";
}
sub hook_plugin_fail {
my ($class, $plugin, $error) = @_;
warn "Plugin '$plugin' failed: $error\n";
}
sub hook_cart_changed {
my ($class, $cart) = @_;
$cart->display(" ");
say "Enter username to pay/finish or 'abort' to abort.\n";
}
sub hook_abort {
my ($class, $cart) = @_;
say "\e[1;4mABORTING TRANSACTION.\e[0m";
}
sub hook_invalid_input {
my ($class, $cart, $word) = @_;
say "$word: No such product, user, or command.";
}
sub hook_reject {
my ($class, $plugin, $reason, $abort) = @_;
say $abort ? $reason : "$reason Enter 'abort' to abort.";
}
sub hook_user_balance {
my ($class, $username, $old, $delta, $new) = @_;
my $sign = $delta >= 0 ? '+' : '-';
printf "New balance for %s: %+.2f %s %.2f = \e[1m%+.2f\e[0m %s\n",
$username, $old, $sign, abs($delta), $new,
($new < -13.37 ? "\e[5;1m(!!)\e[0m" : "");
}
sub hook_user_created {
my ($class, $username) = @_;
say "New account '$username' created.";
}
1;

20
RevBank/Plugin.pm Normal file
View file

@ -0,0 +1,20 @@
package RevBank::Plugin;
use strict;
sub new {
my ($class) = @_;
return bless { }, $class;
}
1;
__END__
=head1 NAME
RevBank::Plugin - Base class for RevBank plugins
=head1 DESCRIPTION
Documentation on writing plugins is at L<RevBank::Plugins>.

278
RevBank/Plugins.pm Normal file
View file

@ -0,0 +1,278 @@
package RevBank::Plugins;
use strict;
use RevBank::Eval;
use RevBank::Plugin;
use Exporter;
our @EXPORT = qw(call_hooks load_plugins);
my @plugins;
sub _read_file {
local (@ARGV) = @_;
readline *ARGV;
}
sub call_hooks {
my $hook = shift;
my $method = "hook_$hook";
for my $class (@plugins) {
$class->$method(@_) if $class->can($method);
}
};
sub register {
call_hooks("register", $_) for @_;
push @plugins, @_;
}
sub load {
my @config = _read_file('revbank.plugins');
chomp @config;
s/#.*//g for @config;
@config = map /(\S+)/, grep /\S/, @config;
for my $name (@config) {
my $fn = "plugins/$name";
my $package = "RevBank::Plugin::$name";
if (not -e $fn) {
warn "$fn does not exist; skipping plugin.\n";
next;
}
RevBank::Eval::clean_eval(qq[
use strict;
package $package;
BEGIN { RevBank::Global->import; }
our \@ISA = qw(RevBank::Plugin);
our \%ATTR;
sub MODIFY_CODE_ATTRIBUTES {
my (\$class, \$sub, \@attrs) = \@_;
\$ATTR{ \$sub } = "\@attrs";
return;
}
sub FETCH_CODE_ATTRIBUTES {
return \$ATTR{ +pop };
}
sub HELP {
\$::HELP{ +shift } = +pop;
}
sub id { '$name' }
] . "\n#line 1 $fn\n" . join "", _read_file($fn));
if ($@) {
call_hooks("plugin_fail", $name, "Compile error: $@");
next;
}
if (not $package->can("command")) {
warn "Plugin $name does not have a 'command' method; skipping.\n";
next;
}
register $package;
}
}
sub new {
return map $_->new, @plugins;
}
1;
__END__
=head1 NAME
RevBank::Plugins - Plugin mechanism for RevBank
=head1 DESCRIPTION
RevBank itself consists of a simple command line interface and a really brain
dead shopping cart. All transactions, even deposits and withdrawals, are
handled by plugins.
Plugins are defined in the C<revbank.plugins> file. Each plugin is a Perl
source file in the C<plugins> directory. Plugins are always iterated over in
the order they were defined in.
=head2 Methods
=head3 RevBank::Plugins::load
Reads the C<revbank.plugins> file and load the plugins.
=head3 RevBank::Plugins->new
Returns a B<list> of fresh plugin instances.
=head3 RevBank::Plugins::register($package)
Registers a plugin.
=head3 RevBank::Plugins::call_hooks($hook, @arguments)
Calls the given hook in each of the plugins. Non-standard hooks, called only
by plugins, SHOULD be prefixed with the name of the plugin, and an underscore.
For example, a plugin called C<cow> can call a hook called C<cow_moo> (which
calls the C<hook_cow_moo> methods).
There is no protection against infinite loops. Be careful!
=head1 WRITING PLUGINS
*** CAUTION ***
It is the responsibility of the PLUGINS to verify and normalize all
input. Behaviour for bad input is UNDEFINED. Weird things could
happen. Always use parse_user() and parse_amount() and test the
outcome for defined()ness. Use the result of the parse_*() functions
because that's canonicalised.
Don't do this:
$cart->add($u, $a, "Bad example");
But do this:
$u = parse_user($u) or return REJECT, "$u: No such user.";
$a = parse_amount($a) or return REJECT, "$a: Invalid amount.";
$cart->add($u, $a, 'Good, except that $a is special in Perl :)');
There are two kinds of plugin methods: input methods and hooks. A plugin MUST
define one C<command> input method (but it MAY be a no-op), and can have any
number of hooks.
=head2 Input methods
Whenever a command is given in the 'outer' loop of revbank, the C<command>
method of the plugins is called until one of the plugins returns either
C<ACCEPT> or C<DONE>. An input method receives three arguments: the plugin
object, the shopping cart, and the given input string. The plugin object
(please call it C<$self>) is temporary but persists as long as your plugin
keeps control. It can be used as a scratchpad for carrying over values from
one method call to the next.
A command method MUST return with one of the following statements:
=over 10
=item return NEXT;
The plugin declines handling of the given command, and revbank should proceed
with the next one.
Input methods other than C<command> MUST NOT return C<NEXT>.
=item return REJECT, "Reason";
The plugin decides that the input should be rejected for the given reason.
RevBank will either query the user again, or (if there is any remaining input
in the buffer) abort the transaction to avoid confusion.
=item return ABORT, "Reason";
=item return ABORT;
The plugin decides that the transaction should be aborted.
=item return ACCEPT;
The plugin has finished processing the command. No other plugins will be called.
=item return "Prompt", $method;
The plugin requires arguments for the command, which will be taken from the
input buffer if extra input was given, or else, requested interactively.
The given method, which can be a reference or the name of the method, will be
called with the given input.
The literal input string C<abort> is a hard coded special case, and will
never reach the plugin's input methods.
=back
=head2 Hooks
Hooks are called at specific points in the processing flow, and MAY introspect
the shopping cart. They SHOULD NOT manipulate the shopping cart, but this option
is provided anyway, to allow for interesting hacks. If you do manipulate the
cart, re-evaluate your assumptions when upgrading!
Hooks SHOULD NOT prompt for input or execute programs that do so.
A plugin that exists only for its hooks, MUST still provide a C<command> method.
The suggested implementation for a no-op C<command> method is:
sub command {
return NEXT;
}
Hooks are called as class methods. The return value is ignored. Hooks MUST NOT
interfere with the transaction flow (e.g. abort it).
The following hooks are available, with their respective arguments:
=over 10
=item hook_register $class, $plugin
Called when a new plugin is registered.
=item hook_abort $class, $cart
Called when a transaction is being aborted, right before the shopping cart is
emptied.
=item hook_prompt $class, $cart, $prompt
Called just before the user is prompted for input interactively. The prompt
MAY be altered by the plugin.
=item hook_input $class, $cart, $input, $split_input
Called when user input was given. C<$split_input> is a boolean that is true
if the input will be split on whitespace, rather than treated as a whole.
The input MAY be altered by the plugin.
=item hook_checkout $class, $cart, $user, $transaction_id
Called when the transaction is finalized.
=item hook_reject $class, $plugin, $reason, $abort
Called when input is rejected by a plugin. C<$abort> is true when the
transaction will be aborted because of the rejection.
=item hook_invalid_input $class, $cart, $word
Called when input was not recognised by any of the plugins.
=item hook_plugin_fail $class, $plugin, $error
Called when a plugin fails.
=item hook_user_created $class, $username
Called when a new user account was created.
=item hook_user_balance $class, $username, $old, $delta, $new, $transaction_id
Called when a user account is updated.
=back
Default messages can be silenced by overriding the hooks in
C<RevBank::Messages>. Such a hack might look like:
undef &RevBank::Messages::hook_abort;
sub hook_abort {
print "This message is much better!\n"
}
=head2 Utility functions
Several global utility functions are available. See L<RevBank::Global>
=head1 AUTHOR
Juerd Waalboer <#####@juerd.nl>
=head1 LICENSE
Pick your favorite OSI license.

70
RevBank/Users.pm Normal file
View file

@ -0,0 +1,70 @@
package RevBank::Users;
use strict;
use RevBank::Global;
use RevBank::Plugins;
my $filename = "revbank.accounts";
sub _read {
my @users;
open my $fh, $filename or die $!;
/\S/ and push @users, [split " "] while readline $fh;
close $fh;
return { map { lc($_->[0]) => $_ } @users };
}
sub names {
return map $_->[0], values %{ _read() };
}
sub balance {
my ($name) = @_;
return _read()->{ lc $name }->[1];
}
sub create {
my ($username) = @_;
open my $fh, '>>', $filename or die $!;
my $now = now();
print {$fh} "$username 0.00 $now\n" or die $!;
close $fh or die $!;
RevBank::Plugins::call_hooks("user_created", $username);
}
sub update {
my ($username, $delta, $transaction_id) = @_;
open my $in, 'revbank.accounts' or die $!;
open my $out, ">.revbank.$$" or die $!;
my $old;
my $new;
while (defined (my $line = readline $in)) {
my @a = split " ", $line;
if (lc $a[0] eq lc $username) {
$old = $a[1];
$new = $old + $delta;
printf {$out} "%-16s %+9.2f %s",
$username, $new, now() or die $!;
print {$out} "\n" or die $!;
} else {
print {$out} $line or die $!;
}
}
close $out or die $!;
close $in;
rename ".revbank.$$", "revbank.accounts" or die $!;
RevBank::Plugins::call_hooks(
"user_balance", $username, $old, $delta, $new, $transaction_id
);
}
sub parse_user {
my ($username) = @_;
my $users = _read();
return undef if not exists $users->{ lc $username };
return $users->{ lc $username }->[0];
}
1;

51
plugins/deposit Normal file
View file

@ -0,0 +1,51 @@
# This plugin must at the end in the plugins file.
HELP "deposit [<amount>]" => "[Create and] deposit into an account";
sub command :Tab(deposit) {
my ($self, $cart, $command) = @_;
if ($command eq 'deposit') {
return "Amount to deposit into your account", \&amount;
}
if ($cart->select_items(qr/^Deposit$/)) {
# No other plugin recognised the input, so it must be a new user.
$self->{new_user} = $command;
return "Add new account for user '$command'?", \&create;
}
return NEXT;
}
sub amount {
my ($self, $cart, $amount) = @_;
$amount = parse_amount($amount)
or return REJECT, "Invalid amount";
$cart->add(undef, +$amount, "Deposit");
return ACCEPT;
}
sub create {
my ($self, $cart, $yesno) = @_;
my $user = $self->{new_user};
if ($yesno eq "y" or $yesno eq "yes") {
RevBank::Users::create( $user );
$cart->checkout( $user );
return ACCEPT;
}
return ABORT;
}
sub hook_checkout {
my ($class, $cart, $user, $transaction_id) = @_;
my $sum;
$sum += $_->{amount} for $cart->select_items(qr/^Deposit$/);
say sprintf "Don't forget to add EUR %.2f to the cash box!", $sum if $sum;
}

32
plugins/give Normal file
View file

@ -0,0 +1,32 @@
HELP "give [<account> [<amount>]]" => "Transfer money to user's account";
sub command :Tab(give) {
my ($self, $cart, $command) = @_;
return NEXT if $command ne 'give';
return "Benificiary", \&benedinges;
}
sub benedinges :Tab(USERS) {
my ($self, $cart, $input) = @_;
$self->{user} = parse_user($input)
or return REJECT, "$input: No such user.";
return "Amount to give to $input", \&amount;
}
sub amount {
my ($self, $cart, $input) = @_;
my $amount = parse_amount($input)
or return REJECT, "$input: Invalid amount.";
my $user = $self->{user};
$cart->add(undef, -$amount, "Given to $user");
$cart->add($user, +$amount, "Received from \$you");
return ACCEPT;
}

25
plugins/help Normal file
View file

@ -0,0 +1,25 @@
HELP "help" => "The stuff you're looking at right now :)";
use List::Util qw(max);
sub command :Tab(help,wtf,omgwtfbbq) {
my ($self, $cart, $command) = @_;
return NEXT if $command !~ /^(?:help|wtf|omgwtfbbq)$/;
say <<END;
1. Enter products, amounts or commands
2. Enter your name
You can press <Enter> after each element to get a follow-up prompt, or separate
individual elements with whitespace.
Valid commands:
END
my $width = max(map length, keys %::HELP);
say sprintf " %-${width}s %s", $_, $::HELP{$_} for sort keys %::HELP;
return ACCEPT;
}

51
plugins/log Normal file
View file

@ -0,0 +1,51 @@
sub command { NEXT }
my $filename = ".revbank.log";
sub _log {
open my $fh, '>>', $filename or warn "$filename: $!";
print $fh now(), " ", @_, "\n";
close $fh or warn "$filename: $!";
}
my %buffer;
sub hook_abort {
_log("ABORT");
}
sub hook_prompt {
my ($class, $cart, $prompt) = @_;
$buffer{prompt} = $prompt;
}
sub hook_input {
my ($class, $cart, $input, $split_input) = @_;
$input //= "(UNDEF)";
_log("PROMPT $buffer{prompt} >> $input");
}
sub hook_reject {
my ($class, $plugin, $reason, $abort) = @_;
_log("REJECT [$plugin] $reason");
}
sub hook_user_created {
my ($class, $username);
_log("NEWUSER $username");
}
sub hook_user_balance {
my ($class, $user, $old, $delta, $new, $transaction_id) = @_;
$_ = sprintf "%+.02f", $_ for $old, $delta, $new;
my $lost = $delta < 0 ? "lost" : "got";
$delta = abs($delta);
_log("BALANCE $transaction_id $user had $old, $lost $delta, now has $new");
}
sub hook_checkout {
my ($class, $cart, $username, $transaction_id) = @_;
_log("CHECKOUT $transaction_id $_") for $cart->as_strings;
}
sub hook_register {
my ($class, $plugin) = @_;
_log("REGISTER $plugin");
}

28
plugins/products Normal file
View file

@ -0,0 +1,28 @@
HELP "<productID>" => "Look up products from database";
HELP "edit" => "Edit product list";
my $filename = 'revbank.products';
sub command :Tab(edit) {
my ($self, $cart, $command) = @_;
if ($command eq 'edit') {
system $ENV{EDITOR}, $filename;
return ACCEPT;
}
my @products;
open my $fh, '<', $filename or die $!;
/\S/ && !/^\s*#/ and push @products, [split " ", $_, 3] while readline $fh;
chomp @$_ for @products;
for my $fields (@products) {
next if $command ne $fields->[0];
$cart->add(undef, - $fields->[1], $fields->[2]);
return ACCEPT;
}
return NEXT;
}

25
plugins/restart Normal file
View file

@ -0,0 +1,25 @@
HELP "restart" => "Attempt to restart the RevBank shell";
sub command :Tab(restart) {
my ($self, $cart, $command) = @_;
return NEXT if $command ne 'restart';
no warnings;
call_hooks("restart_exec");
exec $0;
call_hooks("restart_survived");
return ABORT, "exec() failed. You'll have to restart revbank yourself :P";
}
sub hook_input {
my ($self, $cart, $input, $split_input) = @_;
return if defined $input;
no warnings;
call_hooks("restart_restart");
exec $0;
call_hooks("restart_survived");
}

3
plugins/sigint Normal file
View file

@ -0,0 +1,3 @@
sub command { NEXT }
$SIG{INT} = 'IGNORE';

68
plugins/take Normal file
View file

@ -0,0 +1,68 @@
HELP "take [<accounts> [<amount>]]" => "Take money from users (equal parts)";
sub command :Tab(take,steal) {
my ($self, $cart, $command) = @_;
$command eq 'take' or $command eq 'steal'
or return NEXT;
$self->{users} = [];
return "User to take from", \&arg;
}
sub arg :Tab(USERS) {
my ($self, $cart, $arg) = @_;
my @users = @{ $self->{users} };
my $amount = parse_amount($arg);
if (@users and $amount) {
my $each = sprintf "%.2f", $amount / @users;
my $total = sprintf "%.2f", @users * $each;
if ($total != $amount) {
print "Adjusted total amount to $total because of rounding.\n";
}
$self->{each} = $each;
$self->{total} = $total;
my $them = @users == 1 ? $users[0] : 'each';
return "Why are you taking $each from $them?", \&reason;
}
my $user = parse_user($arg);
if ($user) {
push @{ $self->{users} }, $user;
} else {
return REJECT, "$arg: No such user" .
($amount ? "." : ", and not a valid amount.");
}
return "User to take from, or total amount to finish", \&arg;
}
sub reason :Tab(bbq,NOABORT) { # finish
my ($self, $cart, $reason) = @_;
return REJECT, "'$reason' is a username, not a description :)."
if parse_user($reason);
return REJECT, "'$reason' is an amount, not a description :)."
if parse_amount($reason);
my @users = @{ $self->{users} };
my $each = $self->{each};
my $total = $self->{total};
for my $user (@users) {
$cart->add( $user, -$each, "Taken by \$you ($reason)" );
}
my $users = join '/', @users;
$cart->add( undef, $total, "Taken from $users ($reason)" );
return ACCEPT;
}

46
plugins/undo Normal file
View file

@ -0,0 +1,46 @@
HELP "undo [<id>]" => "Undo a certain transaction";
my $filename = ".revbank.undo";
sub command :Tab(undo) {
my ($self, $cart, $command) = @_;
$command eq 'undo' or return NEXT;
$cart->size and return ABORT, "Undo is not available mid-transaction.";
return "Transaction ID", \&undo;
}
sub undo {
my ($self, $cart, $tid) = @_;
open my $in, '<', $filename or die "$filename: $!";
open my $out, '>', "$filename.$$" or die "$filename.$$: $!";
while (defined(my $line = readline $in)) {
if ($line =~ /^$tid\s/) {
my (undef, $user, $delta) = split " ", $line;
$cart->add($user, $delta, "Undo $tid");
} else {
print {$out} $line;
}
}
close $in;
close $out or die $!;
if ($cart->size) {
rename "$filename.$$", $filename or die $!;
$cart->checkout();
} else {
return ABORT, "Transaction ID '$tid' not found in undo log.";
}
return ACCEPT;
}
sub hook_user_balance {
my ($class, $username, $old, $delta, $new, $transaction_id) = @_;
open my $fh, '>>', $filename or die "$filename: $!";
print {$fh} join " ", $transaction_id, $username, -$delta, now(), "\n";
close $fh or die "$filename: $!";
}

48
plugins/users Normal file
View file

@ -0,0 +1,48 @@
HELP "<account>" => "[Pay with your account and] show balance";
HELP "list" => "List accounts and balances";
HELP "shame" => "Display Hall of Shame (negative balances)";
sub command :Tab(list,ls,shame,USERS) {
my ($self, $cart, $command) = @_;
return $self->list if $command eq 'list';
return $self->list if $command eq 'ls';
return $self->shame if $command eq 'shame';
my $user = parse_user($command)
or return NEXT;
return $self->balance($user) if not $cart->size;
$cart->checkout($user);
return ACCEPT;
}
sub hook_checkout {
my ($class, $cart, $user, $transaction_id) = @_;
my $line = "-" x 40;
say "/$line";
say "| Final (transaction ID = $transaction_id):";
$cart->display("| ");
say "\\$line";
}
sub list {
system "sort -f revbank.accounts | grep -v ^# | more";
return ACCEPT;
}
sub shame {
system "sort -f revbank.accounts | grep -v ^# | grep -- ' .-' | more";
return ACCEPT;
}
sub balance {
my ($self, $u) = @_;
printf "Balance for $u is \e[1m%+.2f\e[0m\n", RevBank::Users::balance($u);
say "NB: Products/amounts/commands FIRST, username LAST.";
return ABORT;
}

11
plugins/withdraw Normal file
View file

@ -0,0 +1,11 @@
HELP "<amount>" => "Withdraw or enter price manually";
sub command {
my ($self, $cart, $command) = @_;
my $amount = parse_amount($command) or return NEXT;
$cart->add(undef, -$amount, "Withdrawal or unlisted product");
return ACCEPT;
}

679
revbank
View file

@ -1,580 +1,177 @@
#!/usr/bin/perl -w
use strict;
no warnings 'exiting'; # We'll exit subs with 'next'
use POSIX qw(strftime);
use List::Util qw(sum);
require Term::ReadLine::Gnu;
use attributes;
use Term::ReadLine;
use List::Util ();
use RevBank::Plugins;
use RevBank::Global;
use RevBank::Messages;
use RevBank::Cart;
require Term::ReadLine::Gnu; # The other one sucks.
$SIG{INT} = 'IGNORE';
our $VERSION = "2.0";
our %HELP = (
"abort" => "Abort the current transaction",
);
# If you don't like the code, just rewrite it, but do keep all functionality
# around, please.
$| = 1;
# The user interface is based on supermarkets: first all products are scanned,
# and then the user pays. In our case, "paying" is done simply by entering
# an account name. No authentication...
# Although the text files are reloaded all the time, it's probably not a good
# idea to edit them while someone else is using the bank script. They are,
# however, human readable and editable.
# Likewise, things might go wrong if you run multiple instances of revbank...
sub printlog {
open my $fh, ">>.revbank.log";
my $x = join "", @_;
$x =~ s/\n/POSIX::strftime("\n%Y%m%d%H%M%S ", localtime)/ge;
print {$fh} $x;
close $fh;
}
{
package Tee;
use base 'Tie::StdHandle';
sub PRINT {
shift;
local $| = 1;
print {*STDOUT} @_;
main::printlog(@_);
}
sub PRINTF {
shift->PRINT(sprintf(shift, @_));
}
}
tie *TEE, 'Tee';
select *TEE;
print "\e[0m\n\n\nWelcome to the RevBank Shell";
my $at = "\e[1;4mABORTING TRANSACTION.\e[0m";
my $readline = Term::ReadLine->new($0);
$readline->ornaments('me,md,,');
# For tab completion
my @commands = qw/
help wtf omgwtfbbq examples deposit take steal give undo
list ls edit restart
/;
sub prompt {
my ($prompt, $completions) = @_;
$completions ||= [];
push @$completions, 'abort';
my ($prompt, @completions) = @_;
$prompt =~ s/$/: /;
$prompt =~ s/\?: $/? /;
my @matches;
$readline->Attribs->{completion_entry_function} = sub {
my ($word, $state) = @_;
@matches = grep /^\Q$word\E/i, @$completions if $state == 0;
@matches = grep /^\Q$word\E/i, @completions if $state == 0;
return shift @matches;
};
my $input = $readline->readline($prompt);
printlog($prompt);
printlog(defined($input) ? $input : "\e[1;5mX\e[0m");
printlog("\n");
print "\e[0m";
defined $input or return;
$input =~ s/^\s+//; # trim leading whitespace
$input =~ s/\s+$//; # trim trailing whitespace
if ($input =~ /^abort$/i) {
print "$at\n";
next LINE; # Whoa, scary out-of-scope jump! But it works :)
return $input;
}
RevBank::Plugins->load;
call_hooks("startup");
my $cart = RevBank::Cart->new;
my $old_cart_size = 0;
my @words;
OUTER: for (;;) {
print "\n" if not @words;
if (not @words and $cart->size != $old_cart_size) {
call_hooks("cart_changed", $cart);
$old_cart_size = $cart->size;
}
return $input
}
sub help {
print <<END;
my $split_input = 1;
my $prompt = "Product ID, amount or command";
my @plugins = RevBank::Plugins->new;
my $method = "command";
1. Enter products, amounts or commands
2. Enter your name
You can press <Enter> after each element to get a follow-up prompt, or separate
individual elements with whitespace.
Valid commands:
<productID> Look up product from database
<amount> Withdraw or enter price manually
<account> [Pay with your account and] show balance
deposit [<amount>] [Create and] deposit into an account
give [<account>] [<amount>] Transfer money to user's account
take [<accounts>] [<amount>] Take money from users (equal parts)
list List accounts and balances
shame Display Hall of Shame (negative balances)
undo [<id>] Undo a certain transaction
help The stuff you're looking at right now :)
examples Show some usage examples
abort Abort the current transaction
edit Edit product list
restart Attempt to restart the revbank shell
END
return ['noop'];
}
sub examples {
print <<END;
Examples:
4029764001807 jdoe John pays for one Club Mate.
5 jdoe John withdraws EUR 5.00.
.1 4029764001807 jdoe John pays 10 cents and one Club Mate.
give 2.50 foo jdoe John gives Foo EUR 2.50.
take 1 foo jdoe Jonh takes EUR 1.00 from Foo.
take foo baz 15 jdoe John takes 7.50 from Foo and 7.50 from Baz.
take foo baz jdoe 15 jdoe Split the BBQ bill that John paid: 3 * 5.
deposit 5 jdoe John deposits EUR 5.00 into his account.
4029764001807 give foo 0.25 .5 take baz 2 deposit 10 help 4029764001807 jdoe
John pays for a Club Mate, transfers 0.25 to Foo's account, donates
50 cents, steals 2.00 from Baz, deposits 10 euro, displays the
instructions, and pays for another Club Mate. John is elite, or drunk.
If you're unsure of the syntax, just type the command, press enter, and
read the instructions.
END
return ['noop'];
}
sub now {
return strftime '%Y-%m-%d_%H:%M:%S', localtime;
}
sub git_commit {
my ($message) = @_;
system qw(git commit -q revbank.accounts .revbank.undo), -m => $message;
}
sub parse_product {
my ($id) = @_;
my @products;
open my $fh, 'revbank.products' or die $!;
/\S/ && !/^\s*#/ and push @products, [split " ", $_, 3] while readline $fh;
close $fh;
chomp @$_ for @products;
for (@products) {
return [ 'product', -$_->[1], $_->[2] ] if $_->[0] eq $id;
sub abort {
print @_, " " if @_;
@words = ();
call_hooks "abort", $cart;
$cart->empty;
{ no warnings; redo OUTER; }
}
return;
}
sub read_users {
my @users;
open my $fh, 'revbank.accounts' or die $!;
/\S/ and push @users, [split " "] while readline $fh;
close $fh;
return { map { lc($_->[0]) => $_ } @users };
}
PROMPT: {
if (not @words) {
call_hooks "prompt", $cart, $prompt;
sub users {
map $_->[0], values %{ read_users() }
}
sub create_account {
my ($username) = @_;
open my $fh, '>>revbank.accounts' or die $!;
my $now = now();
print {$fh} "$username 0.00 $now\n" or die $!;
close $fh or die $!;
}
sub update_account {
my ($username, $delta) = @_;
open my $in, 'revbank.accounts' or die $!;
open my $out, ">.revbank.$$" or die $!;
my $old;
my $new;
while (defined (my $line = readline $in)) {
my @a = split " ", $line;
if (lc $a[0] eq lc $username) {
$old = $a[1];
$new = $old + $delta;
printf {$out} "%-16s %+9.2f %s",
$username, $new, now() or die $!;
print {$out} "\n" or die $!;
} else {
print {$out} $line or die $!;
}
}
close $out or die $!;
close $in;
rename ".revbank.$$", "revbank.accounts" or die $!;
my $sign = $delta >= 0 ? '+' : '-';
printf "New balance for %s: %+.2f %s %.2f = \e[1m%+.2f\e[0m %s\n",
$username, $old, $sign, abs($delta), $new,
($new < -13.37 ? "\e[5;1m(!!)\e[0m" : "");
}
sub parse_user {
my ($id) = @_;
my $users = read_users;
return [ 'user', 0, $users->{lc $id}->[0] ] if exists $users->{lc $id};
}
sub parse_amount {
my ($amount) = @_;
length $amount or return;
if ($amount =~ /^(-)?[0-9]*(?:[,.][0-9]{1,2})?$/) {
if ($1) {
print "For our sanity, no negative amounts, please :). $at\n";
next LINE;
}
$amount =~ s/,/./g;
if ($amount > 999) {
printf "Hm, EUR %.2f? Probably not. Unknown barcode? Enter price"
. " instead.\n\e[1;5m'%s' IGNORED!!\e[0m\n", $amount, $amount;
next ELEMENT;
}
return ['amount', 0 + $amount];
}
return;
}
sub parse_manual {
my ($amount) = @_;
my $p = parse_amount($amount) or return;
return ['payment', -$p->[1], "Withdrawal or unlisted product"];
}
sub parse_command {
my ($command, $line) = @_;
if ($command =~ /^(?:h|help|\?!?|wtf|omgwtfbbq)$/i) {
return help();
} elsif ($command =~ /^(?:examples)$/i) {
return examples();
} elsif ($command =~ /^(?:deposit)$/i) {
return deposit($line);
} elsif ($command =~ /^(?:take|steal)$/i) {
return take($line);
} elsif ($command =~ /^(?:give)$/i) {
return give($line);
} elsif ($command =~ /^(?:undo)$/i) {
return undo($line);
} elsif ($command =~ /^(?:ls|list)$/i) {
return list();
} elsif ($command =~ /^(?:shame)$/i) {
return shame();
} elsif ($command =~ /^(?:edit)$/i) {
return edit();
} elsif ($command =~ /^(?:restart)$/i) {
exec $0;
die "exec() failed. You'll have to restart revbank yourself :P\n";
}
return;
}
sub deposit {
my ($line) = @_;
my $p;
if (@$line and $p = parse_amount($line->[0])) {
shift @$line;
return [ 'deposit', +$p->[1], "Deposit" ];
} elsif (@$line) {
print "$line->[0]: Invalid amount. $at\n";
next LINE;
}
for (;;) {
my $input = prompt "Amount to deposit into your account: ";
if ($p = parse_amount($input)) {
my $amount = $p->[1];
return [ 'deposit', +$p->[1], "Deposit" ];
}
print "$input: Invalid amount. Type 'abort' to abort.\n";
}
}
sub give {
my ($line) = @_;
my $p;
my $user;
if (@$line and $p = parse_user($line->[0])) {
shift @$line;
$user = $p->[2];
} elsif (@$line) {
print "$line->[0]: Invalid user. $at\n";
next LINE;
}
if (not $user) {
for (;;) {
my $input = prompt "Benificiary: ", [ users() ];
if ($p = parse_user($input)) {
$user = $p->[2];
last;
my %completions = qw(abort 1);
for (@plugins) {
my $attr = attributes::get(
ref $method ? $method : $_->can($method)
) or next;
my ($tab) = $attr =~ /Tab \( (.*?) \)/x;
$completions{$_}++ for split /\s*,\s*/, $tab;
}
print "$input: Invalid user. Type 'abort' to abort.\n";
}
}
my $amount;
if (@$line and $p = parse_amount($line->[0])) {
shift @$line;
$amount = $p->[1];
} elsif (@$line) {
print "$line->[0]: Invalid amount. $at\n";
next LINE;
}
if (not defined $amount) {
for (;;) {
my $input = prompt "Amount to give to $user: ";
if ($p = parse_amount($input)) {
$amount = $p->[1];
last;
if (delete $completions{USERS}) {
$completions{$_}++ for RevBank::Users::names;
}
print "$input: Invalid amount. Type 'abort' to abort.\n";
}
}
return [ 'transfer', -$amount, "Given to $user", [
[ $user, +$amount, "Received from %%%" ],
] ];
}
sub take {
my ($line) = @_;
my $p;
my @users;
my $amount;
ELEMENT: while (@$line) {
if ($p = parse_user($line->[0])) {
shift @$line;
push @users, $p->[2];
next ELEMENT;
}
if ($p = parse_amount($line->[0])) {
shift @$line;
$amount = $p->[1];
last ELEMENT;
}
print "$line->[0]: Invalid user or amount. $at\n";
next LINE;
}
while (not @users or not defined $amount) {
PROMPT: for (;;) {
my $input = prompt(
"User to take from"
. (@users ? ", or total amount to finish: " : ": "),
[ users() ]
);
if ($p = parse_user($input)) {
push @users, $p->[2];
next PROMPT;
}
if ($p = parse_amount($input)) {
$amount = $p->[1];
last PROMPT;
}
print "$input was not recognised as either an amount or a user.\n";
}
}
my $each = sprintf "%.2f", $amount / @users;
my $total = sprintf "%.2f", @users * $each;
if ($total != $amount) {
print "Adjusted total amount to $total because of rounding.\n";
}
my $x = @users > 1 ? 'each' : $users[0];
my $reason;
while (not $reason) {
$reason = prompt
"Why are you taking $each from $x? (e.g. 'bbq' or 'wok') ";
}
my $users = join "/", @users;
return [ 'transfer', +$total, "Taken from $users ($reason)", [
map [ $_, -$each, "Taken by %%% ($reason)" ], @users
] ];
}
sub undo {
my ($line) = @_;
my $tid;
if (@$line and $line->[0] =~ /^[0-9]+$/) {
$tid = shift @$line;
}
until ($tid) {
$tid = prompt "Transaction ID to undo: ";
}
open my $in, ".revbank.undo" or die $!;
open my $out, ">.revbank.undo.$$" or die $!;
my $matches = 0;
while (defined(my $line = readline $in)) {
if ($line =~ /^$tid\s/) {
$matches++;
my (undef, $user, $delta) = split " ", $line;
update_account($user, $delta);
} else {
print {$out} $line;
}
}
close $in;
close $out or die $!;
if ($matches) {
rename ".revbank.undo.$$", ".revbank.undo" or die $!;
print "$matches account(s) affected by rollback.\n";
} else {
print "Transaction ID '$tid' not found in undo log.\n";
}
git_commit("Transaction $tid undone.");
return ['noop'];
}
sub list {
system "sort -f revbank.accounts | grep -v ^# | more";
return ['noop'];
}
sub shame {
system "sort -f revbank.accounts | grep -v ^# | grep -- ' -' | more";
return ['noop'];
}
sub edit {
system "vim revbank.products";
return ['noop'];
}
sub number_of {
my ($type, @things) = @_;
my $counter = 0;
for (@things) {
$counter++ if $_->[0] eq $type;
}
return $counter;
}
sub transaction_sum {
return sum map $_->[1], @_;
}
sub todo2actions {
my ($user, @todo) = @_;
my %transactions;
for my $t (@todo) {
push @{ $transactions{$user} }, [ $t->[1], $t->[2] ];
for (@{ $t->[3] }) {
(my $desc = $_->[2]) =~ s/%%%/$user/g;
push @{ $transactions{$_->[0]} }, [ $_->[1], $desc ];
}
}
return %transactions;
}
sub summary {
my ($indent, $user, @todo) = @_;
$user ||= '-you-';
my %transactions = todo2actions($user, @todo);
my @users = sort keys %transactions;
for my $u (@users) {
my @tr = @{ $transactions{$u} };
for my $tr (@tr) {
printf(
"$indent %-16s %4s EUR %5.2f # %s\n",
$u,
($tr->[0] > 0 ? 'GAIN' : $tr->[0] < 0 ? 'LOSE' : ''),
abs($tr->[0]),
$tr->[1]
);
}
if (@tr > 1) {
my $sum = sum(map $_->[0], @tr);
printf(
"$indent %-16s %4s EUR %5.2f TOTAL\n",
$u,
($sum > 0 ? 'GAIN' : $sum < 0 ? 'LOSE' : ''),
abs($sum),
);
}
}
}
LINE: for (;;) {
my @todo = ();
print "\n";
my $user;
while (not $user) {
print "\n";
@todo = grep { $_->[0] ne 'noop' } @todo;
if (@todo) {
print "Preview:\n";
summary(" ", $user, @todo);
print "\nEnter username to pay/finish or 'abort' to abort.\n"
}
my $line = prompt(
"Product ID, amount or command: ",
[ @commands, users() ]
);
defined $line or exec $0;
my @line = split " ", $line;
ELEMENT: while (@line) {
my $element = shift @line;
my $p;
if ($p = parse_product($element) ) { push @todo, $p; next; }
if ($p = parse_manual($element) ) { push @todo, $p; next; }
if ($p = parse_command($element, \@line)) { push @todo, $p; next; }
if ($p = parse_user($element)) {
$user = $p->[2];
last;
if (delete $completions{NOABORT}) {
delete $completions{abort};
}
my $deposit = grep { $_->[0] eq 'deposit' } @todo;
if ($deposit) {
print "Input '$element' not recognised.\n";
for (;;) {
my $yesno = prompt(
"Add new account for user '$element'? ",
[ qw/yes no/ ] # tab completion ;)
);
if ($yesno =~ /^(?:y|yes)$/) {
create_account($element);
$user = $element;
next ELEMENT;
} elsif ($yesno =~ /^(?:n|no)$/) {
last;
}
print "Please enter y, yes, n, or no.\n";
my $input = prompt $prompt, keys %completions;
call_hooks "input", $cart, $input, $split_input;
length $input or redo PROMPT;
@words = ($split_input ? split(" ", $input) : $input);
$split_input = 0; # Only split 'outer' input.
}
WORD: for (;;) {
redo PROMPT if not @words;
abort if grep $_ eq 'abort', @words;
my $word = shift @words;
PLUGIN: for my $plugin (@plugins) {
my ($rv, @rvargs) = eval { $plugin->$method($cart, $word) };
if ($@) {
call_hooks "plugin_fail", $plugin->id, $@;
abort;
}
if (not defined $rv) {
call_hooks "plugin_fail", $plugin->id, "No return code";
abort;
}
if (not ref $rv) {
$prompt = $rv;
@plugins = $plugin;
($method) = @rvargs;
call_hooks "plugin_fail", $plugin->id, "No method supplied"
if not ref $method;
next WORD;
}
if ($rv == ABORT) {
abort(@rvargs);
}
if ($rv == REJECT) {
my ($reason) = @rvargs;
call_hooks "reject", $plugin->id, $reason, @words ? 1 : 0;
abort if @words;
redo PROMPT;
}
if ($rv == ACCEPT) {
next OUTER;
}
if ($rv == NEXT) {
next PLUGIN if $method eq 'command';
call_hooks "plugin_fail", $plugin->id, "Only 'command' "
. "should ever return NEXT.";
abort;
}
call_hooks "plugin_fail", $plugin->id, "Invalid return value";
abort;
}
print "$element: No such product, user, or command. $at\n";
next LINE;
}
if (@line) {
print "Superfluous input (@line) after benificiary/remunerator "
. "($user). $at\n";
next LINE;
call_hooks "invalid_input", $cart, $word;
abort if @words;
redo OUTER;
}
}
@todo = grep { $_->[0] ne 'noop' } @todo;
if (not @todo) {
printf "Balance for %s is \e[1m%+.2f\e[0m\n",
$user, read_users->{lc $user}->[1];
print "NB: Products/amounts/commands FIRST, username LAST. $at\n";
next LINE;
}
my $tid = time() - 1300000000;
print "/", "-" x 40, "\n";
print "| Final (transaction ID = $tid):\n";
summary("| ", $user, @todo);
print "\\", "-" x 40, "\n";
open my $ufh, '>>.revbank.undo' or die $!;
my %transactions = todo2actions($user, @todo);
for (sort keys %transactions) {
my $delta = sum map $_->[0], @{ $transactions{$_} };
print {$ufh} join " ", $tid, $_, -$delta, now(), "\n" or die $!;
my ($old, $new) = update_account($_, $delta);
}
close $ufh;
git_commit("Transaction $tid by $user.");
my $deposit = sum map $_->[1], grep { $_->[0] eq 'deposit' } @todo;
if ($deposit) {
printf "Don't forget to add EUR %.2f to the cash box!\n", $deposit;
}
sleep 1; # Ensure new timestamp/id for new transaction
}
=head1 NAME
revbank - Banking for hackerspace visitors
=head1 DESCRIPTION
Maybe I'll write some documentation, but not now.
=head1 PLUGINS
Refer to L<RevBank::Plugins> for documentation about writing plugins.
=head1 AUTHOR
Juerd Waalboer <#####@juerd.nl>
=head1 LICENSE
Pick your favorite OSI license.

18
revbank.plugins Normal file
View file

@ -0,0 +1,18 @@
# Order matters. Read RevBank::Plugins for documentation.
# First, plugins with no commands, or very specific commands
log # first, so that the registrations of other plugins are logged
sigint
restart
help
undo
give
take
# Then, plugins that apply heuristics
products # matches product IDs (barcodes)
withdraw # matches amounts
users # matches usernames
deposit # wants to be after 'users'