revbank/plugins/statiegeld_tokens

#!perl

# TODO:
# voiding of tokens
# querying of tokens
# expiry of tokens

use List::Util;

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.
# - 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 _read {
	spurt $filename if not -e $filename;

	my %users_tokens;
	for (slurp $filename) {
		my ($username, @tokens) = split " ", $_;
		if (exists $users_tokens{$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{$username} = \%by_type;
	}
	return \%users_tokens;
}

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";
	
	if ($create) {
		append $filename, $new_line if defined $new_line;
	} else {
		rewrite $filename, sub ($old_line) {
			# removes line from file if $new_line is undef
			return /(\S+)/ && $1 eq $username ? $new_line : $old_line;
		};
	}
}

sub _warn($message) {
	warn "\e[31;1mSorry,\e[0m $message\n";
}

sub _handle_undo($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;

			_warn "deposit refunds cannot be undone.";
			die "ROLLBACK_UNDO";
		}

		# 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) : 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->{$username};
	my $is_new = !defined $tokens_by_type;
	$tokens_by_type = {} if $is_new;

	my $tokens_changed = 0;

	# 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 commas in vanilla revbank, but custom
			# plugins may be less well behaved.
			/,/ 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() + $ttl,
					$entry->attribute('product_id'),
					$transaction_id,
					$seq++,
				);
				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}++;
		}

		splice @{ $tokens_by_type->{$type} }, 0, $entry->quantity;
		$tokens_changed++;
	}
	for my $type (keys %warnings_by_type) {
		my $products = RevBank::Plugin::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 "you have $only of type $type ($addon->{description}).";
	}

	# Store data
	_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->{$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";
}