diff --git a/lib/RevBank/Cart.pm b/lib/RevBank/Cart.pm index c38dc05..d05fe7a 100644 --- a/lib/RevBank/Cart.pm +++ b/lib/RevBank/Cart.pm @@ -9,6 +9,7 @@ use Carp (); use List::Util (); use RevBank::Global; use RevBank::Users; +use RevBank::FileIO; use RevBank::Cart::Entry; sub new($class) { @@ -82,16 +83,19 @@ sub checkout($self, $user) { } my $transaction_id = time() - 1300000000; - RevBank::Plugins::call_hooks("checkout", $self, $user, $transaction_id); - for my $account (reverse sort keys %deltas) { - # The reverse sort is a lazy way to make the "-" accounts come last, - # which looks nicer with the "cash" plugin. - RevBank::Users::update($account, $deltas{$account}, $transaction_id) - if $deltas{$account} != 0; - } + RevBank::FileIO::with_lock { + RevBank::Plugins::call_hooks("checkout", $self, $user, $transaction_id); - RevBank::Plugins::call_hooks("checkout_done", $self, $user, $transaction_id); + for my $account (reverse sort keys %deltas) { + # The reverse sort is a lazy way to make the "-" accounts come last, + # which looks nicer with the "cash" plugin. + RevBank::Users::update($account, $deltas{$account}, $transaction_id) + if $deltas{$account} != 0; + } + + RevBank::Plugins::call_hooks("checkout_done", $self, $user, $transaction_id); + }; $self->empty; diff --git a/lib/RevBank/FileIO.pm b/lib/RevBank/FileIO.pm new file mode 100644 index 0000000..e4947d5 --- /dev/null +++ b/lib/RevBank/FileIO.pm @@ -0,0 +1,116 @@ +package RevBank::FileIO; + +use v5.28; +use warnings; +use feature qw(signatures); +no warnings qw(experimental::signatures); + +use autodie; +use Fcntl qw(:flock); +use Carp qw(croak); +use Time::HiRes qw(sleep); + +my $tempfn = ".revbank.$$"; +my $lockfn = ".revbank.global-lock"; +my $lockfh; +my $lockcount = 0; + +sub get_lock() { + if (defined $lockfh) { + die "Fatal inconsistency" if $lockcount < 1; + return ++$lockcount; + } + die "Fatal inconsistency" if $lockcount; + + open $lockfh, ">", $lockfn; + my $attempt = 1; + FLOCK: { + if (flock $lockfh, LOCK_EX | LOCK_NB) { + syswrite $lockfh, $$; + return ++$lockcount; + } + + if (($attempt % 50) == 0) { + warn "Another revbank instance has the global lock. Waiting for it to finish...\n" + } + sleep .1; + + $attempt++; + redo FLOCK; + } + + + croak "Could not acquire lock on $lockfn; file access failed"; +} + +sub release_lock() { + if (not defined $lockfh) { + die "Fatal inconsistency" if $lockcount; + return; + } + die "Fatal inconsistency" if $lockcount < 1; + + if (--$lockcount == 0) { + flock $lockfh, LOCK_UN; + close $lockfh; + + undef $lockfh; + } +} + +sub with_lock :prototype(&) ($code) { + get_lock; + my @rv; + my $rv; + my $list_context = wantarray; + eval { + @rv = $code->() if $list_context; + $rv = $code->() if not $list_context; + }; + release_lock; + croak $@ =~ s/\n$/, called/r if $@; + return @rv if $list_context; + return $rv if not $list_context; +} + +sub slurp($fn) { + return with_lock { + local $/ = wantarray ? "\n" : undef; + open my $fh, "<", $fn; + return readline $fh; + } +} + +sub spurt($fn, @data) { + return with_lock { + open my $out, ">", $tempfn; + print $out @data; + close $out; + rename $tempfn, $fn; + }; +} + +sub append($fn, @data) { + return with_lock { + open my $out, ">>", $fn; + print $out @data; + close $out; + }; +} + +sub rewrite($fn, $sub) { + return with_lock { + open my $in, "<", $fn; + open my $out, ">", $tempfn; + while (defined(my $line = readline $in)) { + local $_ = $line; + my $new = $sub->($line); + print $out $new if defined $new; + } + close $out; + close $in; + rename $tempfn, $fn; + }; +} + +1; diff --git a/lib/RevBank/FileIO.pod b/lib/RevBank/FileIO.pod new file mode 100644 index 0000000..3840259 --- /dev/null +++ b/lib/RevBank/FileIO.pod @@ -0,0 +1,96 @@ +=head1 NAME + +RevBank::FileIO - Line-based text file manipulation with advisory locking + +=head1 SYNOPSIS + + with_lock { + ... + }; + + my $data = slurp $filename; + my @lines = slurp $filename; + spurt $filename, @data; + append $filename, @data; + + rewrite $filename, sub($line) { + return $line; # return changed or unchanged line + return undef; # exclude line from file + }; + +=head1 DESCRIPTION + +This package implements very simple locking to protect against filesystem +based race conditions when running multiple instances of revbank on the same +data files. + +These race conditions are probably exceptionally rare and very hard to trigger +in real-world conditions, because file system access is very fast due to +caching and buffering by the kernel. RevBank was used for over a decade without +any known problem due such a race condition, before locking was finally +added. + +No attempt was made to optimize for performance, and all locks are global and +exclusive. + +Will wait for the global lock for as long as it takes, printing a message every +few seconds to keep the user informed. + +=head2 Functions + +=head3 with_lock BLOCK + +Gets the lock, executes the block, releases the lock again. Returns whatever +the block returned. + +Use this instead of C to prevent forgetting to release the lock. + +=head3 get_lock + +Acquires the lock if it is not already held. Keeps extra virtual locks (by +virtue of a simple counter) if the global lock is already held by the current +process. + +Calling this function directly is discouraged. Use C instead. + +=head3 release_lock + +Decreases the number of virtual locks, releasing the real lock if none are +left. + +Calling this function directly is discouraged. Use C instead. + +=head1 slurp($filename) + +Returns the entire contents of the file. In list context, returns a list of +lines (including the line ending). + +=head1 spurt($filename, @data) + +=head1 append($filename, @data) + +Writes to a file. No separators or delimiters are added to the provided data, +so in general you will want to pass either the entire contents as a single +string, or a list of lines that already have line endings. + +=head1 rewrite($filename, sub($line) { ...; return $line; }) + +Rewrites the existing text file. The provided subroutine is called for each +line, and must return everything that should be written back. The sub can +return undef to essentially skip (remove) a line. + +=head2 CAVEATS + +=over 2 + +=item * A lock file is used, so external processes should not depend on the +individual files being flocked. + +=item * Using a text editor while revbank is running and changing files will +still mess things up. + +=item * The locking mechanism provides a lock per process; different parts +(e.g. plugins) of the same process can still simultaneously do things, so keep +to the pattern of always closing files before returning control or forking. + +=back diff --git a/lib/RevBank/Global.pm b/lib/RevBank/Global.pm index f2eb52e..0a5ad45 100644 --- a/lib/RevBank/Global.pm +++ b/lib/RevBank/Global.pm @@ -7,18 +7,24 @@ no warnings qw(experimental::signatures); use POSIX qw(strftime); use RevBank::Amount; +use RevBank::FileIO; 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\::ACCEPT"} = sub () { \1 }; + *{"$caller\::ABORT"} = sub () { \2 }; + *{"$caller\::REJECT"} = sub () { \3 }; + *{"$caller\::NEXT"} = sub () { \4 }; + *{"$caller\::DONE"} = sub () { \5 }; + *{"$caller\::slurp"} = \&RevBank::FileIO::slurp; + *{"$caller\::spurt"} = \&RevBank::FileIO::spurt; + *{"$caller\::rewrite"} = \&RevBank::FileIO::rewrite; + *{"$caller\::append"} = \&RevBank::FileIO::append; + *{"$caller\::with_lock"} = \&RevBank::FileIO::with_lock; + *{"$caller\::parse_user"} = \&RevBank::Users::parse_user; *{"$caller\::parse_amount"} = sub ($amount) { defined $amount or return undef; length $amount or return undef; diff --git a/lib/RevBank/Users.pm b/lib/RevBank/Users.pm index bd37777..5e6a6cf 100644 --- a/lib/RevBank/Users.pm +++ b/lib/RevBank/Users.pm @@ -13,9 +13,7 @@ my $filename = "revbank.accounts"; sub _read() { my @users; - open my $fh, $filename or die $!; - /\S/ and push @users, [split " "] while readline $fh; - close $fh; + /\S/ and push @users, [split " "] for slurp $filename; return { map { lc($_->[0]) => $_ } @users }; } @@ -32,20 +30,17 @@ sub since($username) { } sub create($username) { - open my $fh, '>>', $filename or die $!; my $now = now(); - print {$fh} "$username 0.00 $now\n" or die $!; - close $fh or die $!; + append $filename, "$username 0.00 $now\n"; RevBank::Plugins::call_hooks("user_created", $username); return $username; } sub update($username, $delta, $transaction_id) { - open my $in, 'revbank.accounts' or die $!; - open my $out, ">.revbank.$$" or die $!; my $old = RevBank::Amount->new(0); my $new = RevBank::Amount->new(0); - while (defined (my $line = readline $in)) { + + rewrite $filename, sub($line) { my @a = split " ", $line; if (lc $a[0] eq lc $username) { $old = RevBank::Amount->parse_string($a[1]); @@ -62,16 +57,13 @@ sub update($username, $delta, $transaction_id) { $since = "-\@" . now() if $newc < 0 and (!$since or $oldc >= 0); $since = "0\@" . now() if $newc == 0 and (!$since or $oldc != 0); - printf {$out} "%-16s %9s %s %s\n", ( + return sprintf "%-16s %9s %s %s\n", ( $username, $new->string("+"), now(), $since - ) or die $!; + ); } else { - print {$out} $line or die $!; + return $line; } - } - close $out or die $!; - close $in; - rename ".revbank.$$", "revbank.accounts" or die $!; + }; RevBank::Plugins::call_hooks( "user_balance", $username, $old, $delta, $new, $transaction_id diff --git a/plugins/grandtotal b/plugins/grandtotal index cbcfc4d..1e4092c 100644 --- a/plugins/grandtotal +++ b/plugins/grandtotal @@ -8,8 +8,7 @@ sub command :Tab(grandtotal) ($self, $cart, $command, @) { my $pos = 0; my $neg = 0; - open my $fh, "<", "revbank.accounts"; - while (defined(my $line = readline $fh)) { + for my $line (slurp 'revbank.accounts') { my ($username, $balance) = split " ", $line; next if RevBank::Users::is_hidden($username); diff --git a/plugins/log b/plugins/log index 070d2ad..bd9b752 100644 --- a/plugins/log +++ b/plugins/log @@ -5,9 +5,7 @@ my $filename = ".revbank.log"; sub _log($tag, @message) { @message = ("") if not @message; - open my $fh, '>>', $filename or warn "$filename: $!"; - print $fh map(s/^/now() . " $tag "/rgme, @message), "\n"; - close $fh or warn "$filename: $!"; + append $filename, map(s/^/now() . " $tag "/rgme, @message), "\n"; } my %buffer; diff --git a/plugins/market b/plugins/market index 6cb0a95..e942129 100644 --- a/plugins/market +++ b/plugins/market @@ -5,9 +5,8 @@ HELP "market" => "Edit market list"; my $filename = 'revbank.market'; sub _read_market() { - open my $fh, '<', $filename or die "$filename: $!"; my %market; - while (readline $fh) { + for (slurp $filename) { /^\s*#/ and next; /\S/ or next; chomp; diff --git a/plugins/pfand b/plugins/pfand index 57eafe1..a9547c0 100644 --- a/plugins/pfand +++ b/plugins/pfand @@ -5,14 +5,16 @@ HELP "pfand" => "Pfand zurueck"; # This is a demo plugin. It's called "pfand" because "deposit" would be # confusing and only the Germans are crazy enough to have deposits on small # bottles anyway ;) +# +# ^^ aged like milk - the netherlands has deposits on small bottles now. +# (but we're allowed to sell them without, for immediate consumption) # The file format for 'revbank.pfand' is simply two whitespace separated # columns: product id and pfand amount. sub _read_pfand() { - open my $fh, 'revbank.pfand' or die $!; return { - map { split " " } grep /\S/, grep !/^\s*#/, readline $fh + map { split " " } grep /\S/, grep !/^\s*#/, slurp 'revbank.pfand'; }; } diff --git a/plugins/products b/plugins/products index 32c86fa..1aebdf1 100644 --- a/plugins/products +++ b/plugins/products @@ -6,9 +6,8 @@ HELP "edit" => "Edit product list"; my $filename = 'revbank.products'; sub _read_products() { - open my $fh, '<', $filename or die "$filename: $!"; my %products; - while (readline $fh) { + for (slurp $filename) { /^\s*#/ and next; /\S/ or next; chomp; diff --git a/plugins/revspace_mqtt b/plugins/revspace_mqtt index 2c6004e..1f0d41c 100644 --- a/plugins/revspace_mqtt +++ b/plugins/revspace_mqtt @@ -7,12 +7,9 @@ sub hook_checkout($class, $cart, $user, $transaction_id, @) { my @entries = $cart->entries('product_id') or return; my %already_retained; - my %stats = do { - my $in; - open($in, '<', $filename) - ? map { split " ", $_, 2 } readline $in - : () - }; + # XXX: hook_checkout is called while the global lock is held, and the + # potentially slow network traffic could make that take quite long. + my %stats = eval { map { split " ", $_, 2 } slurp $filename }; $stats{ $_->attribute('product_id') } += $_->quantity for @entries; @@ -26,8 +23,7 @@ sub hook_checkout($class, $cart, $user, $transaction_id, @) { $already_retained{ $product } = 1; } - open my $out, '>', "$filename.$$" or warn "$filename.$$: $!"; - printf {$out} "%-16s %9d\n", $_, $stats{$_} for sort keys %stats; - close $out or die "$filename.$$: $!"; - rename "$filename.$$", $filename or die $!; + spurt $filename, map { + sprintf "%-16s %9d\n", $_, $stats{$_} + } sort keys %stats; } diff --git a/plugins/stock b/plugins/stock index 8de3a85..ae64e56 100644 --- a/plugins/stock +++ b/plugins/stock @@ -29,17 +29,11 @@ sub hook_checkout($class, $cart, $user, $transaction_id, @) { my @entries = $cart->entries('product_id') or return; - my %stock = do { - my $in; - open($in, '<', $filename) - ? map { split " ", $_, 2 } readline $in - : () - }; + my %stock = eval { map { split " ", $_, 2 } slurp $filename }; $stock{ $_->attribute('product_id') } -= $_->quantity for @entries; - open my $out, '>', "$filename.$$" or warn "$filename.$$: $!"; - printf {$out} "%-16s %+9d\n", $_, $stock{$_} for sort keys %stock; - close $out or die "$filename.$$: $!"; - rename "$filename.$$", $filename or die $!; + spurt $filename, map { + sprintf "%-16s %+9d\n", $_, $stock{$_} + } sort keys %stock; } diff --git a/plugins/undo b/plugins/undo index 6c44b71..f51d9e9 100644 --- a/plugins/undo +++ b/plugins/undo @@ -9,11 +9,10 @@ my @TAB; sub command :Tab(undo) ($self, $cart, $command, @) { $command eq 'undo' or return NEXT; - $cart->size and return ABORT, "Undo is not available mid-transaction."; + $cart->size and return REJECT, "Undo is not available mid-transaction."; my @log; - open my $in, '<', $filename or die "$filename: $!"; - while (defined(my $line = readline $in)) { + for my $line (slurp $filename) { my ($tid, $user, $delta, $dt) = split " ", $line; if (@log and $log[-1]{tid} eq $tid) { push @{ $log[-1]{deltas} }, [ $user, $delta ]; @@ -41,42 +40,39 @@ sub tab { @TAB } my $doing_undo = 0; # Ugly but works, just like the rest of this plugin sub undo :Tab(&tab) ($self, $cart, $tid, @) { - open my $in, '<', $filename or die "$filename: $!"; - open my $out, '>', "$filename.$$" or die "$filename.$$: $!"; my $description = "Undo $tid"; - my $entry; + my $found = 0; - while (defined(my $line = readline $in)) { - if ($line =~ /^\Q$tid\E\s/) { - my (undef, $user, $delta) = split " ", $line; + with_lock { + rewrite $filename, sub($line) { + if ($line =~ /^\Q$tid\E\s/) { + my (undef, $user, $delta) = split " ", $line; - $entry ||= $cart->add(0, $description); - $entry->{FORCE_UNBALANCED} = 1; + $entry ||= $cart->add(0, $description); + $entry->{FORCE_UNBALANCED} = 1; - $entry->add_contra($user, $delta, "Undo $tid"); - } else { - print {$out} $line; + $entry->add_contra($user, $delta, "Undo $tid"); + return undef; # remove line + } else { + return $line; + } + }; + + if ($cart->size) { + $found = 1; + $doing_undo = 1; # don't allow undoing undos + $cart->checkout('-undo'); + $doing_undo = 0; } - } - close $in; - close $out or die $!; - if ($cart->size) { - rename "$filename.$$", $filename or die $!; - $doing_undo = 1; # don't allow undoing undos - $cart->checkout('-undo'); - $doing_undo = 0; - } else { - return ABORT, "Transaction ID '$tid' not found in undo log."; - } + }; - return ACCEPT; + return ACCEPT if $found; + return ABORT, "Transaction ID '$tid' not found in undo log."; } sub hook_user_balance($class, $username, $old, $delta, $new, $transaction_id, @) { return if $doing_undo; # don't allow undoing undos - open my $fh, '>>', $filename or die "$filename: $!"; - print {$fh} join " ", $transaction_id, $username, -$delta, now(), "\n"; - close $fh or die "$filename: $!"; + append $filename, join(" ", $transaction_id, $username, -$delta, now()), "\n"; } diff --git a/plugins/warnings b/plugins/warnings index 7009af8..8825897 100644 --- a/plugins/warnings +++ b/plugins/warnings @@ -6,7 +6,6 @@ use Time::HiRes qw(sleep); sub _read_warnings() { - open my $fh, 'revbank.warnings' or die $!; return map { my ($regex, $products, $text) = m[^ (?: @@ -26,7 +25,7 @@ sub _read_warnings() { my ($id, $desc) = @_; (grep { $_ eq $id } split /,/, $products) ? $text : (); } - } grep /\S/, grep !/^\s*#/, readline $fh; + } grep /\S/, grep !/^\s*#/, slurp 'revbank.warnings'; } sub hook_add_entry($class, $cart, $entry, @) {