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