bean-query daemon: initial version.

This is a very basic daemon to run bean-query so that other Perl programs can call it. The speed savings is not really there yet, as to get that, it would need to leave bean-query running, perhaps timing out and reloading files as needed. That's the long term plan. Right now, all that this is useful for is to run another Perl process that wants to submit and receive answers to bean-query.
2020-06-15 12:42:13 -07:00 · 2020-06-15 12:42:13 -07:00 · 42800427f6
commit 42800427f6
parent 67c507367a
3 changed files with 177 additions and 0 deletions
--- a/README.md
+++ b/README.md
@ -0,0 +1,19 @@
+# Beancount Tools Written in Perl
+
+These are various tools written in Perl to interact with [Beancount project](http://furius.ca/beancount/).
+
+## bean-query-goofy-daemon.plx
+
+This daemon uses Perl's [`IPC::Shareable`](https://metacpan.org/pod/IPC::Shareable) library to take queries as a daemon for Beancount's `bean-query`.  Note that this daemon is not particularly secure, as it has the same security flaws inherent in `IPC::Shareable` and use of named pipes (as it uses `mkfifo` from [Perl's `POSIX` library](https://perldoc.perl.org/POSIX.html) underneath.
+
+## bean-query-daemon-lib.pl
+
+This file defines three functions to use in client scripts that want to talk to `bean-query-goofy-daemon.plx`.
+
+It's not an actual Perl library; just use `require` in Perl to load it.
+
+[comment]: Local variables:
+[comment]: mode: markdown
+[comment]: eval: (visual-line-mode t)
+[comment]: eval: (auto-fill-mode -1)
+[comment]: End:
--- a/bean-query-daemon-lib.pl
+++ b/bean-query-daemon-lib.pl
@ -0,0 +1,36 @@
+# 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;
+
+our %BEANCOUNT_QUERY;
+
+my $IPC_GLUE = 'BeAn';
+
+sub BeancountQueryInitialize {
+  my %options = (create    => 0, exclusive => 0, mode      => 0600, destroy   => 0);
+  tie %BEANCOUNT_QUERY, 'IPC::Shareable', $IPC_GLUE, { %options } or
+    die "BEANCOUNT_QUERY: tie failed: is the goffy beancount server running?\n";
+}
+
+sub BeancountQuerySubmit($) {
+  my($question) = @_;
+  (tied %BEANCOUNT_QUERY)->shlock;
+  $BEANCOUNT_QUERY{fifoName} = undef;
+  $BEANCOUNT_QUERY{question} = $question;
+  (tied %BEANCOUNT_QUERY)->shunlock;
+  while (not defined $BEANCOUNT_QUERY{fifoName}) { sleep 1; }
+  die "Ceci n'est pas une pipe: BEANCOUNT_QUERY{fifoName}, $BEANCOUNT_QUERY{fifoName}:$!"
+    unless (-p $BEANCOUNT_QUERY{fifoName});
+  (tied %BEANCOUNT_QUERY)->shlock;
+  return $BEANCOUNT_QUERY{fifoName};
+}
+
+sub BeancountQueryComplete {
+  $BEANCOUNT_QUERY{question} = undef;
+  (tied %BEANCOUNT_QUERY)->shunlock;
+}
+
+1;
--- a/bean-query-goofy-daemon.plx
+++ b/bean-query-goofy-daemon.plx
@ -0,0 +1,122 @@
+#!/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, sleeping 2\n" if $VERBOSE > 2;
+    if (defined $query{fifoName}) {
+      no autodie 'unlink'; unlink($query{fifoName});
+      $query{fifoName} = undef;
+    }
+    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:
+