8349b9610b
On the a classic “concurrency is hard” front, I am slightly proud of myself that I didn't hit this race condition but anticipated that it might occur later. Giving entire control to fifoName to the server makes more sense here, and the client should not submit its query any time either fifoName or question is set. As an extra safeguard, the client will die if it gets the lock and the state for submitting a query isn't right. Finally, added some fifoName removal debugging on the server.
128 lines
4.9 KiB
Perl
Executable file
128 lines
4.9 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
# License: AGPLv3-or-later
|
|
# see files COPYRIGHT, LICENSE, and AGPL-3.0.txt included in canonical repository for details.
|
|
# https://k.sfconservancy.org/NPO-Accounting/beancount-tools-in-Perl
|
|
|
|
use strict;
|
|
use warnings;
|
|
use autodie qw(:all);
|
|
|
|
use Getopt::Long;
|
|
use File::Spec::Functions;
|
|
use File::Temp qw/:mktemp/;
|
|
|
|
use POSIX qw(mkfifo);
|
|
use IPC::Shareable;
|
|
|
|
my $BEANCOUNT_QUERY_CMD = "/usr/bin/bean-query";
|
|
|
|
my($VERBOSE, $BEANCOUNT_DIR, $LOAD_FILE, $REPOSITORY_URL, $FIFO_DIR) = (0, undef, undef, undef, undef);
|
|
|
|
GetOptions("verbose=i" => \$VERBOSE, "beancountDir=s" => \$BEANCOUNT_DIR,
|
|
"loadFile=s" => \$LOAD_FILE, "repositoryURL=s" => \$REPOSITORY_URL, 'fifoDir=s' => \$FIFO_DIR);
|
|
|
|
sub UsageAndExit($) {
|
|
print STDERR "usage: $0 --loadFile=/path/to/file.beancount --beancountDir=/path/to/beancountdir --fifoDir=/path/to/directory/for/fifos [ --repositoryURL=URL_OF_REPOSITORY --verbose=N ]\n";
|
|
print STDERR "\n $_[0]\n";
|
|
exit 2;
|
|
}
|
|
UsageAndExit("/path/to/direcotry/for/fifos must be provided and be an existing directory")
|
|
unless (defined $FIFO_DIR and -d $FIFO_DIR);
|
|
|
|
UsageAndExit("/path/to/file.beancount/path/to/beancountdir must be provided and be an existing directory")
|
|
unless (defined $BEANCOUNT_DIR and -d $BEANCOUNT_DIR);
|
|
chdir $BEANCOUNT_DIR;
|
|
|
|
UsageAndExit("/path/to/file.beancount must a relative path to a file that exists in $BEANCOUNT_DIR")
|
|
unless (defined $LOAD_FILE and -r $LOAD_FILE);
|
|
|
|
if (defined $REPOSITORY_URL) {
|
|
UsageAndExit("if --repositoryURL is provided, $BEANCOUNT_DIR must be a checkout of a Git repository, but there is no $BEANCOUNT_DIR/.git/config.")
|
|
unless (-r '.git/config');
|
|
|
|
open(my $gitFH, "<", ".git/config");
|
|
my $repoString;
|
|
while (my $line = <$gitFH>) {
|
|
chomp $line;
|
|
$repoString = $1
|
|
if $line =~ /^\s*url\s*=\s*(\S+)\s*$/;
|
|
}
|
|
close $gitFH;
|
|
UsageAndExit("if --repositoryURL is provided, the checkout found in $BEANCOUNT_DIR must be of that repository, but .git/config does not list a URL.") unless defined $REPOSITORY_URL;
|
|
UsageAndExit("if --repositoryURL is provided, the checkout found in $BEANCOUNT_DIR must be of that repository, but it instead appears to be a checkout of $repoString.")
|
|
unless ($repoString eq $REPOSITORY_URL);
|
|
}
|
|
my $glue = 'BeAn';
|
|
my %options = (
|
|
create => 'yes',
|
|
exclusive => 0,
|
|
mode => 0600,
|
|
destroy => 'yes',
|
|
);
|
|
my %query;
|
|
tie %query, 'IPC::Shareable', $glue, { %options } or
|
|
die "server: tie failed for $glue\n";
|
|
|
|
%query = ();
|
|
|
|
my %beancountData;
|
|
tie %beancountData, 'IPC::Shareable', $glue, { %options } or
|
|
die "server: tie failed\n";
|
|
|
|
while (1) {
|
|
if (not defined $query{question}) {
|
|
print STDERR "No question posed..." if $VERBOSE > 2;
|
|
if (defined $query{fifoName}) {
|
|
print STDERR "fifo still active; locking to clear it..." if $VERBOSE > 2;
|
|
(tied %query)->shlock;
|
|
print STDERR "clearing fifo, $query{fifoName}..." if $VERBOSE > 2;
|
|
no autodie 'unlink'; unlink($query{fifoName});
|
|
$query{fifoName} = undef;
|
|
(tied %query)->shunlock;
|
|
print STDERR "fifo cleared & lock released." if $VERBOSE > 2;
|
|
}
|
|
print STDERR "sleep for 2 seconds\n" if $VERBOSE > 2;
|
|
sleep 2;
|
|
next;
|
|
} elsif ($query{question} !~ /^[\-\@\w.\s\"\'\_\(\)]+$/) {
|
|
print STDERR "Query string $query{question} looks suspicious, not running beancount query!\n";
|
|
(tied %query)->shlock;
|
|
$query{question} = undef;
|
|
$query{fifoName} = mktemp("REJECTED_beancount-query-fifo-this-file-does-not-exist_${$}_XXXXXXXXX");
|
|
(tied %query)->shunlock;
|
|
} elsif (not defined $query{fifoName}) {
|
|
my @cmd = ($BEANCOUNT_QUERY_CMD, '-f', 'text', $LOAD_FILE, $query{question});
|
|
print STDERR "Running query: $query{question}\n" if $VERBOSE > 0;
|
|
open(my $beancountFH, "-|", @cmd);
|
|
print STDERR "Running ", join(" ", @cmd), "\n" if $VERBOSE > 1;
|
|
(tied %query)->shlock;
|
|
print STDERR "Acquired shlock on tied variable.\n" if $VERBOSE > 1;
|
|
$query{fifoName} = undef;
|
|
my $cnt = 0;
|
|
my $fifoFileName = mktemp(catfile($FIFO_DIR, "beancount-query-fifo_${$}_XXXXXXXXX"));
|
|
mkfifo($fifoFileName, 0700);
|
|
die "unable to create fifo in $fifoFileName: $!" unless -p $fifoFileName;
|
|
print STDERR "Created $fifoFileName..." if $VERBOSE > 1;
|
|
$query{fifoName} = $fifoFileName;
|
|
(tied %query)->shunlock;
|
|
open(my $fifoFH, ">", $fifoFileName);
|
|
print STDERR "and beginning write to it." if $VERBOSE > 1;
|
|
while (my $line = <$beancountFH>) {
|
|
print STDERR "." if (++$cnt % 100) and ($VERBOSE > 1);
|
|
print $fifoFH $line;
|
|
}
|
|
close $beancountFH;
|
|
close $fifoFH;
|
|
(tied %query)->shlock; $query{question} = undef; (tied %query)->shunlock;
|
|
print STDERR "...done! Data now in $fifoFileName\n" if $VERBOSE > 0;
|
|
}
|
|
}
|
|
|
|
|
|
###############################################################################
|
|
#
|
|
# Local variables:
|
|
# compile-command: "perl -c bean-query-goofy-daemon.plx"
|
|
# perl-indent-level: 2
|
|
# End:
|
|
|