Implement global advisory lock

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;
 

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;

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<get_lock> 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<with_lock> 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<with_lock> 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

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;

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

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);
 

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;

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;

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';
     };
 }
 

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;

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;
 }

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;
 }

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";
 }

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, @) {