revbank/plugins/statiegeld_tokens
Juerd Waalboer a450aa7468 Use read_products in new namespace
(Would also work without this change, but indirectly through the
products plugin which imports this symbol)
2024-12-25 23:50:03 +01:00

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->{user} 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, $username, $transaction_id, @) {
if ($username eq '-undo') {
_handle_undo($cart);
return;
}
# Read data
my $tokens_by_type = _read->{lc $username};
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 $username: @created"
) if @created;
call_hooks(
"log_info",
"statiegeld_tokens: ${\scalar @used } used by $username: @used"
) if @used;
_write $username, $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;
}