Initial implementation of brmbar v3 - brmbar v1 emulator brmbar-cli.pl

Uses PostgreSQL to store accounts and transactions, and Perl + Moose for the implementation. The schema is somewhat complicated, but brmburo-compatible; accounting design by TMA.
2025-06-07 21:04:00 +02:00 · 2012-08-29 03:52:30 +02:00 · 2012-08-29 03:52:30 +02:00 · 945ee705c3
commit 945ee705c3
parent 540167bfb5
7 changed files with 521 additions and 0 deletions
--- a/brmbar3/BrmBar/Account.pm
+++ b/brmbar3/BrmBar/Account.pm
@ -0,0 +1,121 @@
+package BrmBar::Account;
+
+use strict;
+use warnings;
+use v5.10;
+
+use utf8;
+use encoding::warnings;
+use open qw(:encoding(UTF-8));
+
+use Moose;
+use Carp;
+
+has 'db' => (is => 'ro', isa => 'DBI::db', required => 1);
+has 'id' => (is => 'ro', isa => 'Int');
+has 'name' => (is => 'ro', isa => 'Str');
+has 'acctype' => (is => 'ro', isa => 'Str');
+has 'currency' => (is => 'ro', isa => 'BrmBar::Currency');
+
+
+sub load_by_barcode {
+	my ($class, %opts) = @_;
+
+	defined $opts{db} or croak "db parameter missing";
+
+	my $q = $opts{db}->prepare('SELECT account FROM barcodes WHERE barcode = ?');
+	$q->execute($opts{barcode});
+	($opts{id}) = $q->fetchrow_array();
+	defined $opts{id} or return undef;
+
+	delete $opts{barcode};
+	return $class->load(%opts);
+}
+
+# Constructor for existing account
+sub load {
+	my ($class, %opts) = @_;
+
+	defined $opts{db} or croak "db parameter missing";
+
+	if (defined $opts{id}) {
+		my $q = $opts{db}->prepare('SELECT name FROM accounts WHERE id = ?');
+		$q->execute($opts{id});
+		($opts{name}) = $q->fetchrow_array();
+
+	} elsif (defined $opts{name}) {
+		my $q = $opts{db}->prepare('SELECT id FROM accounts WHERE name = ?');
+		$q->execute($opts{name});
+		($opts{id}) = $q->fetchrow_array();
+	}
+
+	my $q = $opts{db}->prepare('SELECT currency, acctype FROM accounts WHERE id = ?');
+	$q->execute($opts{id});
+	@opts{'currency', 'acctype'} = $q->fetchrow_array();
+
+	$opts{currency} = BrmBar::Currency->load(db => $opts{db}, id => $opts{currency});
+
+	my $self = $class->new(%opts);
+	return $self;
+}
+
+# Constructor for new account
+sub create {
+	my ($class, %opts) = @_;
+
+	defined $opts{db} or croak "db parameter missing";
+	defined $opts{name} or croak "name parameter missing";
+	defined $opts{currency} or croak "currency parameter missing";
+	defined $opts{acctype} or croak "acctype parameter missing";
+
+	my $q = $opts{db}->prepare('INSERT INTO accounts (name, currency, acctype) VALUES (?, ?, ?) RETURNING id');
+	$q->execute($opts{name}, $opts{currency}->id(), $opts{acctype});
+	($opts{id}) = $q->fetchrow_array();
+
+	my $self = $class->new(%opts);
+	return $self;
+}
+
+sub balance {
+	my ($self) = @_;
+
+	my $q = $self->db()->prepare('SELECT SUM(amount) FROM transaction_splits WHERE account = ? AND side = ?');
+
+	$q->execute($self->id(), 'debit');
+	my ($debit) = $q->fetchrow_array;
+	$debit ||= 0;
+
+	$q->execute($self->id(), 'credit');
+	my ($credit) = $q->fetchrow_array;
+	$credit ||= 0;
+
+	return ($debit - $credit);
+}
+
+sub balance_str {
+	my ($self) = @_;
+	return $self->currency()->str($self->balance());
+}
+
+sub negbalance_str {
+	my ($self) = @_;
+	return $self->currency()->str(-$self->balance());
+}
+
+sub debit {
+	my ($self, $tr, $amount, $memo) = @_;
+	$self->_transaction_split($tr, 'debit', $amount, $memo);
+}
+
+sub credit {
+	my ($self, $tr, $amount, $memo) = @_;
+	$self->_transaction_split($tr, 'credit', $amount, $memo);
+}
+
+# Common part of credit(), debit()
+sub _transaction_split {
+	my ($self, $tr, $side, $amount, $memo) = @_;
+	$self->db()->prepare('INSERT INTO transaction_splits (transaction, side, account, amount, memo) VALUES (?, ?, ?, ?, ?)')->execute($tr, $side, $self->id(), $amount, $memo);
+}
+
+1;
--- a/brmbar3/BrmBar/Currency.pm
+++ b/brmbar3/BrmBar/Currency.pm
@ -0,0 +1,126 @@
+package BrmBar::Currency;
+
+use strict;
+use warnings;
+use v5.10;
+
+use utf8;
+use encoding::warnings;
+use open qw(:encoding(UTF-8));
+
+use Moose;
+use Carp;
+
+has 'db' => (is => 'ro', isa => 'DBI::db', required => 1);
+has 'id' => (is => 'ro', isa => 'Int');
+has 'name' => (is => 'ro', isa => 'Str');
+
+
+# Default wallet currency
+sub default {
+	my ($class, %opts) = @_;
+
+	return $class->load(db => $opts{db}, name => 'Kč');
+}
+
+# Constructor for existing currency
+sub load {
+	my ($class, %opts) = @_;
+
+	defined $opts{db} or croak "db parameter missing";
+
+	if (defined $opts{id}) {
+		my $q = $opts{db}->prepare('SELECT name FROM currencies WHERE id = ?');
+		$q->execute($opts{id});
+		($opts{name}) = $q->fetchrow_array();
+
+	} elsif (defined $opts{name}) {
+		my $q = $opts{db}->prepare('SELECT id FROM currencies WHERE name = ?');
+		$q->execute($opts{name});
+		($opts{id}) = $q->fetchrow_array();
+	}
+
+	my $self = $class->new(%opts);
+	return $self;
+}
+
+# Constructor for new currency
+sub create {
+	my ($class, %opts) = @_;
+
+	defined $opts{db} or croak "db parameter missing";
+	defined $opts{name} or croak "name parameter missing";
+
+	my $q = $opts{db}->prepare('INSERT INTO currencies (name) VALUES (?) RETURNING id');
+	$q->execute($opts{name});
+	($opts{id}) = $q->fetchrow_array();
+
+	my $self = $class->new(%opts);
+	return $self;
+}
+
+
+# Set exchange rate against $other (BrmBar::Currency):
+# $buy is the price of $self in means of $other when buying it (into brmbar)
+# $sell is the price of $self in means of $other when selling it (from brmbar)
+sub set_rate {
+	my ($self, $other, $buy, $sell) = @_;
+
+	my $qs = $self->db()->prepare("SELECT rate FROM exchange_rates WHERE target = ? AND source = ?");
+	my $qu = $self->db()->prepare("UPDATE exchange_rates SET rate = ?, rate_dir = ? WHERE target = ? AND source = ?");
+	my $qi = $self->db()->prepare("INSERT INTO exchange_rates (target, source, rate, rate_dir) VALUES (?, ?, ?, ?)");
+
+	$qs->execute($self->id(), $other->id());
+	if ($qs->fetchrow_array) {
+		$qu->execute($buy, 'target_to_source');
+	} else {
+		$qi->execute($self->id(), $other->id(), $buy, 'target_to_source');
+	}
+
+	$qs->execute($other->id(), $self->id());
+	if ($qs->fetchrow_array) {
+		$qu->execute($sell, 'source_to_target');
+	} else {
+		$qi->execute($other->id(), $self->id(), $sell, 'source_to_target');
+	}
+}
+
+# Return ($buy, $sell) rates of $self in relation to $other (BrmBar::Currency):
+# $buy is the price of $self in means of $other when buying it (into brmbar)
+# $sell is the price of $self in means of $other when selling it (from brmbar)
+sub rates {
+	my ($self, $other) = @_;
+
+	my $qs = $self->db()->prepare("SELECT rate, rate_dir FROM exchange_rates WHERE target = ? AND source = ?");
+
+	$qs->execute($self->id(), $other->id());
+	my ($buy_rate, $buy_rate_dir) = $qs->fetchrow_array;
+	defined $buy_rate or croak "unknown conversion ".$other->name()." to ".$self->name();
+	my $buy = $buy_rate_dir eq 'target_to_source' ? $buy_rate : 1/$buy_rate;
+
+	$qs->execute($other->id(), $self->id());
+	my ($sell_rate, $sell_rate_dir) = $qs->fetchrow_array;
+	defined $sell_rate or croak "unknown conversion ".$self->name()." to ".$other->name();
+	my $sell = $sell_rate_dir eq 'source_to_target' ? $sell_rate : 1/$sell_rate;
+
+	return ($buy, $sell);
+};
+
+sub convert {
+	my ($self, $amount, $target) = @_;
+
+	my $q = $self->db()->prepare("SELECT rate, rate_dir FROM exchange_rates WHERE target = ? AND source = ? AND valid_since <= NOW() ORDER BY valid_since ASC LIMIT 1");
+	$q->execute($target->id(), $self->id());
+	my ($rate, $rate_dir) = $q->fetchrow_array();
+
+	defined $rate or croak "unknown conversion ".$self->name()." to ".$target->name();
+
+	return $rate_dir eq 'source_to_target' ? $amount * $rate : $amount / $rate;
+}
+
+sub str {
+	my ($self, $amount) = @_;
+	return $amount . ' ' . $self->name();
+}
+
+1;
--- a/brmbar3/BrmBar/SQL.pm
+++ b/brmbar3/BrmBar/SQL.pm
@ -0,0 +1,20 @@
+package BrmBar::SQL;
+
+use warnings;
+use strict;
+use v5.10;
+
+use utf8;
+use encoding::warnings;
+use open qw(:encoding(UTF-8));
+
+use DBI;
+
+sub init {
+	my ($sqlconf) = @_;
+	my $db = DBI->connect("dbi:Pg:dbname=brmbar", '', '', {AutoCommit => 1, RaiseError => 1, pg_enable_utf8 => 1})
+		or die "Cannot open db: ".DBI->errstr;
+	$db;
+}
+
+1;
--- a/brmbar3/BrmBar/Shop.pm
+++ b/brmbar3/BrmBar/Shop.pm
@ -0,0 +1,73 @@
+package BrmBar::Shop;
+
+use strict;
+use warnings;
+use v5.10;
+
+use utf8;
+use encoding::warnings;
+use open qw(:encoding(UTF-8));
+
+use Moose;
+use Carp;
+
+use BrmBar::Currency;
+use BrmBar::Account;
+
+has 'db' => (is => 'ro', isa => 'DBI::db', required => 1);
+has 'currency' => (is => 'rw', isa => 'BrmBar::Currency');
+has 'profits' => (is => 'ro', isa => 'BrmBar::Account'); # income account for our margins
+has 'cash' => (is => 'ro', isa => 'BrmBar::Account'); # our operational ("wallet") cash account
+
+sub new_with_defaults {
+	my ($class, %opts) = @_;
+
+	return $class->new(
+		db => $opts{db},
+		currency => BrmBar::Currency->default(db => $opts{db}),
+		profits => BrmBar::Account->load(db => $opts{db}, name => 'BrmBar Profits'),
+		cash => BrmBar::Account->load(db => $opts{db}, name => 'BrmBar Cash')
+	);
+}
+
+
+sub sell {
+	my ($self, %opts) = @_;
+	my ($item, $user, $amount) = @opts{'item', 'user', 'amount'};
+	$amount ||= 1;
+
+	my ($buy, $sell) = $item->currency()->rates($self->currency());
+	my $cost = $amount * $sell;
+	my $profit = $amount * ($sell - $buy);
+
+	$self->db()->begin_work();
+	my $tr = $self->_transaction(responsible => $user, description => 'BrmBar sale of '.$amount.'x '.$item->name().' to '.$user->name());
+	$item->credit($tr, $amount, $user->name());
+	$user->debit($tr, $cost, $item->name()); # debit (increase) on a _debt_ account
+	$self->profits()->debit($tr, $profit, "Margin on ".$item->name());
+	$self->db()->commit();
+
+	return $cost;
+}
+
+sub add_credit {
+	my ($self, %opts) = @_;
+	my ($credit, $user) = @opts{'credit', 'user'};
+
+	$self->db()->begin_work();
+	my $tr = $self->_transaction(responsible => $user, description => 'BrmBar credit replenishment for '.$user->name());
+	$self->cash()->debit($tr, $credit, $user->name());
+	$user->credit($tr, $credit, 'Credit replenishment');
+	$self->db()->commit();
+}
+
+
+# This is for internal usage of the business logic
+sub _transaction {
+	my ($self, %opts) = @_;
+	my ($responsible, $description) = @opts{'responsible', 'description'};
+
+	$self->db()->prepare('INSERT INTO transactions (responsible, description) VALUES (?, ?)')->execute($responsible->id(), $description);
+}
+
+1;
--- a/brmbar3/SQL
+++ b/brmbar3/SQL
@ -0,0 +1,79 @@
+CREATE SEQUENCE currencies_id_seq START WITH 1 INCREMENT BY 1;
+CREATE TABLE currencies (
+	id INTEGER PRIMARY KEY NOT NULL DEFAULT NEXTVAL('currencies_id_seq'::regclass),
+	name VARCHAR(128) NOT NULL
+);
+INSERT INTO currencies (name) VALUES ('Kč');
+
+CREATE TYPE exchange_rate_direction AS ENUM ('source_to_target', 'target_to_source');
+CREATE TABLE exchange_rates (
+	valid_since TIMESTAMP WITHOUT TIME ZONE DEFAULT NOW() NOT NULL,
+
+	target INTEGER NOT NULL,
+        FOREIGN KEY (target) REFERENCES currencies (id),
+
+	source INTEGER NOT NULL,
+        FOREIGN KEY (source) REFERENCES currencies (id),
+
+	rate DECIMAL(12,2) NOT NULL,
+	rate_dir exchange_rate_direction NOT NULL
+);
+
+
+-- brmbar users have 'debt' accounts; a negative balance means that
+-- we have debt to the users, i.e. they are positive relative to the brmbar.
+-- Positive balance means that the users have debt in brmbar.
+-- Therefore, user's balance must always be shown negated.
+CREATE SEQUENCE accounts_id_seq START WITH 1 INCREMENT BY 1;
+CREATE TYPE account_type AS ENUM ('cash', 'debt', 'inventory', 'income', 'expense', 'starting_balance', 'ending_balance');
+CREATE TABLE accounts (
+	id INTEGER PRIMARY KEY NOT NULL DEFAULT NEXTVAL('accounts_id_seq'::regclass),
+
+	name VARCHAR(128) NOT NULL,
+
+	currency INTEGER NOT NULL,
+        FOREIGN KEY (currency) REFERENCES currencies (id),
+
+	acctype account_type NOT NULL
+);
+INSERT INTO accounts (name, currency, acctype) VALUES ('BrmBar Cash', (SELECT id FROM currencies WHERE name='Kč'), 'cash');
+INSERT INTO accounts (name, currency, acctype) VALUES ('BrmBar Profits', (SELECT id FROM currencies WHERE name='Kč'), 'income');
+
+
+CREATE SEQUENCE barcodes_id_seq START WITH 1 INCREMENT BY 1;
+CREATE TABLE barcodes (
+	barcode VARCHAR(128) PRIMARY KEY NOT NULL,
+
+	account INTEGER NOT NULL,
+        FOREIGN KEY (account) REFERENCES accounts (id)
+);
+
+
+CREATE SEQUENCE transactions_id_seq START WITH 1 INCREMENT BY 1;
+CREATE TABLE transactions (
+	id INTEGER PRIMARY KEY NOT NULL DEFAULT NEXTVAL('transactions_id_seq'::regclass),
+	time TIMESTAMP DEFAULT NOW() NOT NULL,
+
+	responsible INTEGER,
+	FOREIGN KEY (responsible) REFERENCES accounts (id),
+	-- FIXME: imperfect constraint to assure this is a user
+
+	description TEXT
+);
+
+CREATE SEQUENCE transaction_splits_id_seq START WITH 1 INCREMENT BY 1;
+CREATE TYPE transaction_split_side AS ENUM ('credit', 'debit');
+CREATE TABLE transaction_splits (
+	id INTEGER PRIMARY KEY NOT NULL DEFAULT NEXTVAL('transaction_splits_id_seq'::regclass),
+
+	transaction INTEGER NOT NULL,
+	FOREIGN KEY (transaction) REFERENCES transactions (id),
+
+	side transaction_split_side NOT NULL,
+
+	account INTEGER NOT NULL,
+        FOREIGN KEY (account) REFERENCES accounts (id),
+	amount DECIMAL(12,2) NOT NULL,
+
+	memo TEXT
+);
--- a/brmbar3/SQL.test
+++ b/brmbar3/SQL.test
@ -0,0 +1,22 @@
+-- Few test inserts just for debugging, to be used on clean database
+
+INSERT INTO accounts (name, currency, acctype) VALUES ('pasky', 1, 'debt');
+INSERT INTO barcodes (barcode, account) VALUES ('pasky', (SELECT id FROM accounts WHERE name = 'pasky'));
+INSERT INTO accounts (name, currency, acctype) VALUES ('TMA', 1, 'debt');
+INSERT INTO barcodes (barcode, account) VALUES ('TMA', (SELECT id FROM accounts WHERE name = 'TMA'));
+
+INSERT INTO currencies (name) VALUES ('Club Mate');
+INSERT INTO accounts (name, currency, acctype) VALUES ('Club Mate', (SELECT id FROM currencies WHERE name = 'Club Mate'), 'inventory');
+INSERT INTO exchange_rates (target, source, rate, rate_dir) VALUES ((SELECT id FROM currencies WHERE name = 'Club Mate'), (SELECT id FROM currencies WHERE name = 'Kč'), 28, 'target_to_source');
+INSERT INTO exchange_rates (target, source, rate, rate_dir) VALUES ((SELECT id FROM currencies WHERE name = 'Kč'), (SELECT id FROM currencies WHERE name = 'Club Mate'), 35, 'source_to_target');
+INSERT INTO barcodes (barcode, account) VALUES ('42', (SELECT id FROM accounts WHERE name = 'Club Mate'));
+
+INSERT INTO currencies (name) VALUES ('Deli');
+INSERT INTO accounts (name, currency, acctype) VALUES ('Deli', (SELECT id FROM currencies WHERE name = 'Deli'), 'inventory');
+INSERT INTO exchange_rates (target, source, rate, rate_dir) VALUES ((SELECT id FROM currencies WHERE name = 'Deli'), (SELECT id FROM currencies WHERE name = 'Kč'), 7.50, 'target_to_source');
+INSERT INTO exchange_rates (target, source, rate, rate_dir) VALUES ((SELECT id FROM currencies WHERE name = 'Kč'), (SELECT id FROM currencies WHERE name = 'Deli'), 10, 'source_to_target');
+INSERT INTO barcodes (barcode, account) VALUES ('43', (SELECT id FROM accounts WHERE name = 'Deli'));
+
+INSERT INTO transactions (responsible, description) VALUES ((SELECT id FROM accounts WHERE name = 'pasky'), 'Naskladnena krabice Deli');
+INSERT INTO transaction_splits (transaction, side, account, amount, memo) VALUES (1, 'credit', (SELECT id FROM accounts WHERE name = 'pasky'), 75, '10x Deli');
+INSERT INTO transaction_splits (transaction, side, account, amount, memo) VALUES (1, 'debit', (SELECT id FROM accounts WHERE name = 'Deli'), 10, 'pasky');
--- a/brmbar3/brmbar-cli.pl
+++ b/brmbar3/brmbar-cli.pl
@ -0,0 +1,80 @@
+#!/usr/bin/perl -CSA
+
+use warnings;
+use strict;
+use v5.10;
+
+use utf8;
+use encoding::warnings;
+use open qw(:encoding(UTF-8));
+
+use lib qw(.);
+use BrmBar::SQL;
+use BrmBar::Account;
+use BrmBar::Shop;
+
+my $db = BrmBar::SQL->init();
+my $shop = BrmBar::Shop->new_with_defaults(db => $db);
+my $currency = $shop->currency();
+
+my ($active_inv_item, $active_credit);
+
+while (<>) {
+	chomp;
+	my $barcode = $_;
+
+	if ($barcode =~ /^\$/) {
+		# Credit replenishment
+		my %credits = ('$02' => 20, '$05' => 50, '$10' => 100, '$20' => 200, '$50' => 500, '$1k' => 1000);
+		my $credit = $credits{$barcode};
+		if (not defined $credit) {
+			say("Unknown barcode: $barcode");
+			next;
+		}
+
+		undef $active_inv_item;
+		$active_credit = $credit;
+		next;
+	}
+
+	if ($barcode eq 'SCR') {
+		say("SHOW CREDIT");
+		undef $active_inv_item;
+		undef $active_credit;
+		# In next iteration, person's barcode will for sure not be charged anything
+		next;
+	}
+
+	my $acct = BrmBar::Account->load_by_barcode(db => $db, barcode => $barcode);
+	if (not $acct) {
+		say("Unknown barcode: $barcode");
+		next;
+	}
+
+	if ($acct->acctype() eq 'debt') {
+		if (defined $active_inv_item) {
+			my $cost = $shop->sell(item => $active_inv_item, user => $acct);
+			say($acct->name()." has bought ".$active_inv_item->name()." for ".$currency->str($cost)." and now has ".$acct->negbalance_str()." balance");
+		} elsif (defined $active_credit) {
+			$shop->add_credit(credit => $active_credit, user => $acct);
+			say($acct->name()." has added ".$currency->str($active_credit)." credit");
+		} else {
+			say($acct->name()." has ".$acct->negbalance_str()." balance");
+		}
+
+		undef $active_inv_item;
+		undef $active_credit;
+
+	} elsif ($acct->acctype() eq 'inventory') {
+		my ($buy, $sell) = $acct->currency()->rates($currency);
+		say($acct->name()." costs ".$currency->str($sell)." with ".$acct->balance()." in stock");
+
+		$active_inv_item = $acct;
+		undef $active_credit;
+
+	} else {
+		say("invalid account type ".$acct->acctype());
+		undef $active_inv_item;
+		undef $active_credit;
+	}
+}