303 lines
8.4 KiB
Perl
303 lines
8.4 KiB
Perl
#!perl
|
|
use List::Util;
|
|
use RevBank::Products;
|
|
|
|
HELP void => "Destroy deposit tokens";
|
|
|
|
my $ttl = 100 * 86400; # expiry time in seconds
|
|
my $filename = "revbank.statiegeld";
|
|
|
|
# Token format: token_type,time,expiry_time,product_id,transaction_id,seq
|
|
# - token_type (also just "type") is the id of the product addon.
|
|
# - expiry_time < 0 means the token does not expire.
|
|
# - time and product_id is recorded but only used for debugging.
|
|
# - seq is a 0 based counter per transaction to make tokens unique,
|
|
# although the uniqueness of tokens is currently neither used nor enforced.
|
|
#
|
|
# Tokens are spent in FIFO order, by type rather than product_id. This
|
|
# effectively extends the TTL for active consumers. The product_ids of
|
|
# a user's remaining tokens may not correspond to those of the empty containers
|
|
# in their possession.
|
|
|
|
sub _addon_accounts {
|
|
my @accounts = @RevBank::Plugin::statiegeld::addon_accounts
|
|
or die "statiegeld_tokens plugin requires statiegeld plugin";
|
|
return @accounts;
|
|
}
|
|
|
|
sub _time_is_reliable() {
|
|
state $cache;
|
|
state $cached_at;
|
|
undef $cache if defined $cached_at and $cached_at <= (time() - 10);
|
|
|
|
return $cache if defined $cache;
|
|
|
|
$cache = sub {
|
|
return 1 if system('ntpstat >/dev/null 2>/dev/null') == 0;
|
|
return 1 if `timedatectl show -p NTPSynchronized 2>/dev/null` =~ /=yes/;
|
|
|
|
warn "Time/NTP status unknown or bad; deposit tokens will not expire.\n";
|
|
return 0;
|
|
}->();
|
|
$cached_at = time;
|
|
|
|
return $cache;
|
|
}
|
|
|
|
sub _read {
|
|
spurt $filename if not -e $filename;
|
|
|
|
my %users_tokens;
|
|
for (slurp $filename) {
|
|
/\S/ or next;
|
|
|
|
my ($username, @tokens) = split " ", $_;
|
|
if (exists $users_tokens{lc $username}) {
|
|
die "Corrupt data file $filename, $username listed twice";
|
|
}
|
|
|
|
my %by_type;
|
|
for my $token (@tokens) {
|
|
my ($token_type) = (split /,/, $token)[0];
|
|
push @{ $by_type{$token_type} }, $token;
|
|
}
|
|
|
|
$users_tokens{lc $username} = \%by_type;
|
|
}
|
|
return \%users_tokens;
|
|
}
|
|
|
|
sub _expire_tokens($line, $time) {
|
|
$time > 0 or return $line;
|
|
defined $line or return $line;
|
|
$line =~ / / or return $line;
|
|
|
|
my ($username, @tokens) = split " ", $line;
|
|
|
|
# Rewrite line with only non-tokens, invalid tokens, and non-expired tokens
|
|
my @keep;
|
|
my @expired;
|
|
for my $token (@tokens) {
|
|
my ($type, undef, $expiry) = split /,/, $token;
|
|
|
|
my $expired = defined($expiry) && $expiry > 0 && $expiry < $time;
|
|
push @{ $expired ? \@expired : \@keep }, $token;
|
|
}
|
|
|
|
call_hooks(
|
|
"log_info",
|
|
"statiegeld_tokens: ${\scalar @expired} expired for $username: @expired"
|
|
) if @expired;
|
|
|
|
return join(" ", $username, @keep) . "\n";
|
|
}
|
|
|
|
sub _write($username, $tokens_by_type, $create) {
|
|
my @tokens = map @{ $tokens_by_type->{$_} }, sort keys %$tokens_by_type;
|
|
my $new_line = @tokens == 0 ? undef : join(" ", $username, @tokens) . "\n";
|
|
|
|
my $time = _time_is_reliable ? time() : -1;
|
|
|
|
if ($create) {
|
|
append $filename, $new_line if defined $new_line;
|
|
} else {
|
|
rewrite $filename, sub ($old_line) {
|
|
$old_line =~ /\S/ or return $old_line; # keep whitespace-only lines
|
|
|
|
# removes line from file if $new_line is undef
|
|
my $line = /(\S+)/ && lc($1) eq lc($username) ? $new_line : $old_line;
|
|
return _expire_tokens($line, $time);
|
|
};
|
|
}
|
|
}
|
|
|
|
sub _warn($message) {
|
|
warn "\e[31;1mSorry,\e[0m $message\n";
|
|
}
|
|
|
|
sub hook_undo($class, $cart) {
|
|
# Undoing properly is hard. We can easily void tokens, but we can't restore
|
|
# them. That would requires duplicating all of the undo logic that exists
|
|
# for account balances, but for tokens. Too much work for something that I
|
|
# suspect would hardly be used anyway, so instead we'll just prohibit
|
|
# undoing refunds.
|
|
for my $entry ($cart->entries) {
|
|
# Undo deposit refund: prohibit
|
|
for my $contra ($entry->contras) {
|
|
next if $contra->{amount} < 0;
|
|
next if List::Util::none { $contra->{account} eq $_ } _addon_accounts;
|
|
|
|
return ABORT, "Sorry, deposit refunds cannot be undone.";
|
|
}
|
|
}
|
|
}
|
|
|
|
sub _handle_undo($cart) {
|
|
for my $entry ($cart->entries) {
|
|
# Undo buying: void specific tokens
|
|
my $undo_tid = $entry->attribute('undo_transaction_id')
|
|
or die "Plugin error: broken '-undo' transaction";
|
|
|
|
rewrite $filename, sub ($line) {
|
|
my ($username, @tokens) = split " ", $line;
|
|
@tokens = grep {
|
|
my ($token_type, undef, undef, undef, $tid) = split /,/, $_;
|
|
|
|
$tid ne $undo_tid
|
|
} @tokens;
|
|
|
|
return @tokens ? join(" ", $username, @tokens) . "\n" : undef;
|
|
};
|
|
}
|
|
}
|
|
|
|
sub hook_checkout_prepare($class, $cart, $account, $transaction_id, @) {
|
|
if ($account eq '-undo') {
|
|
_handle_undo($cart);
|
|
return;
|
|
}
|
|
|
|
# Read data
|
|
my $tokens_by_type = _read->{lc $account};
|
|
my $is_new = !defined $tokens_by_type;
|
|
$tokens_by_type = {} if $is_new;
|
|
my $time_is_reliable = _time_is_reliable;
|
|
|
|
my $tokens_changed = 0;
|
|
my @created;
|
|
my @used;
|
|
|
|
# Products bought: add tokens
|
|
my $seq = 0;
|
|
for my $entry ($cart->entries('product')) {
|
|
my $sg = RevBank::Plugin::statiegeld::statiegeld_product($entry->attribute('product'))
|
|
or next;
|
|
|
|
for my $addon (@{ $sg->{statiegeld_addons} }) {
|
|
# These should never contain spaces or commas in vanilla revbank,
|
|
# but custom plugins may be less well behaved.
|
|
/[\s,]/ and die "Internal error"
|
|
for $addon->{id}, $entry->attribute('product_id'), $transaction_id;
|
|
|
|
for (1 .. $entry->quantity) {
|
|
my $token = join(",",
|
|
$addon->{id}, # token_type
|
|
time(),
|
|
($time_is_reliable ? time() + $ttl : -1),
|
|
$entry->attribute('product_id'),
|
|
$transaction_id,
|
|
$seq++,
|
|
);
|
|
push @created, $token;
|
|
push @{ $tokens_by_type->{$addon->{id}} }, $token;
|
|
}
|
|
$tokens_changed++;
|
|
}
|
|
}
|
|
|
|
# Products (containers) returned: void tokens in FIFO order
|
|
my $cart_changed = 0;
|
|
my %warnings_by_type;
|
|
my %had_num_tokens_by_type = map { $_ => scalar @{ $tokens_by_type->{$_} } } keys %$tokens_by_type;
|
|
|
|
ENTRY: for my $entry ($cart->entries('plugin')) {
|
|
$entry->attribute('plugin') eq 'statiegeld' or next;
|
|
|
|
my $type = $entry->attribute('addon_id');
|
|
my $available = @{ $tokens_by_type->{$type} // [] };
|
|
|
|
if ($available < $entry->quantity) {
|
|
if ($available == 0) {
|
|
$cart->delete($entry);
|
|
$warnings_by_type{$type}++;
|
|
next ENTRY;
|
|
}
|
|
$entry->quantity($available);
|
|
$warnings_by_type{$type}++;
|
|
}
|
|
|
|
push @used, splice @{ $tokens_by_type->{$type} }, 0, $entry->quantity;
|
|
$tokens_changed++;
|
|
}
|
|
for my $type (keys %warnings_by_type) {
|
|
my $products = read_products;
|
|
my $addon = $products->{"+$type"} // $products->{$type};
|
|
my $avail = $had_num_tokens_by_type{$type} // 0;
|
|
my $only =
|
|
+ $avail == 0 ? "0 deposit tokens"
|
|
: $avail == 1 ? "only 1 deposit token"
|
|
: "only $avail deposit tokens";
|
|
|
|
_warn qq[you have $only of type $type.\n]
|
|
. qq[($type = "$addon->{description}")];
|
|
}
|
|
|
|
# Store data
|
|
call_hooks(
|
|
"log_info",
|
|
"statiegeld_tokens: ${\scalar @created } created for $account: @created"
|
|
) if @created;
|
|
|
|
call_hooks(
|
|
"log_info",
|
|
"statiegeld_tokens: ${\scalar @used } used by $account: @used"
|
|
) if @used;
|
|
|
|
_write $account, $tokens_by_type, $is_new if $tokens_changed;
|
|
|
|
return ABORT if %warnings_by_type and not $cart->size;
|
|
|
|
if (%warnings_by_type and $cart->changed(1)) {
|
|
print "\n"; # Between warnings and transaction overview
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub hook_user_info ($class, $username, @) {
|
|
my $tokens_by_type = _read->{lc $username};
|
|
my @info;
|
|
for my $type (sort keys %$tokens_by_type) {
|
|
my @tokens = @{ $tokens_by_type->{$type} // [] };
|
|
push @info, sprintf("%dx %s", scalar @tokens, $type);
|
|
}
|
|
@info = ("none") if not @info;
|
|
print "Deposit tokens: ", join(", ", @info), "\n";
|
|
}
|
|
|
|
sub command($self, $cart, $command, @) {
|
|
$command eq 'void' or return NEXT;
|
|
|
|
my $found =0;
|
|
for my $entry ($cart->entries('plugin')) {
|
|
next if $entry->attribute('plugin') ne 'statiegeld';
|
|
$found++;
|
|
}
|
|
$found or return REJECT, "Add deposit returns first.";
|
|
|
|
return "The tokens will be deleted irrevokably and you will NOT RECEIVE THE MONEY.\n"
|
|
. "Type 'yes' if you are sure", \&void;
|
|
}
|
|
|
|
sub void :Tab(yes,no) ($self, $cart, $input, @) {
|
|
if (lc $input eq 'y') {
|
|
return REJECT, "y is not yes...";
|
|
}
|
|
if (lc $input ne 'yes') {
|
|
print "Destruction cancelled.\n";
|
|
return ACCEPT;
|
|
}
|
|
|
|
for my $entry ($cart->entries('plugin')) {
|
|
next if $entry->attribute('plugin') ne 'statiegeld';
|
|
$entry->{description} = "Void: $entry->{description}";
|
|
$entry->amount(0);
|
|
$entry->delete_contras;
|
|
|
|
# Change key so subsequently added things aren't also void;
|
|
# deduplication of tokens to be voided doesn't actually work yet.
|
|
$entry->attribute(deduplicate => join("/", $self->id, $entry->attribute('addon_id')));
|
|
}
|
|
|
|
return ACCEPT;
|
|
}
|