lei q: support mbox locking by default

While this diverges from from mairix(1) behavior, it's the safer
option.  We'll follow Debian policy by supporting fcntl and
dotlocks by default (in that order).  Users who do not want
locking can use "--lock=none"

This will be used in a read-only capacity for watching
mailboxes for keyword updates via inotify or EVFILT_VNODE.

1 files changed, 121 insertions, 0 deletions

diff --git a/lib/PublicInbox/MboxLock.pm b/lib/PublicInbox/MboxLock.pm
new file mode 100644
index 00000000..4e2a2d9a
--- /dev/null
+++ b/lib/PublicInbox/MboxLock.pm
@@ -0,0 +1,121 @@
+# Copyright (C) 2021 all contributors <meta@public-inbox.org>
+# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
+
+# Various mbox locking methods
+package PublicInbox::MboxLock;
+use strict;
+use v5.10.1;
+use PublicInbox::OnDestroy;
+use Fcntl qw(:flock F_SETLK F_SETLKW F_RDLCK F_WRLCK
+                        O_CREAT O_EXCL O_WRONLY SEEK_SET);
+use Carp qw(croak);
+use PublicInbox::DS qw(now); # ugh...
+
+our $TMPL = do {
+        if ($^O eq 'linux') { \'s @32' }
+        elsif ($^O =~ /bsd/) { \'@20 s @256' } # n.b. @32 may be enough...
+        else { eval { require File::FcntlLock; 1 } }
+};
+
+# This order matches Debian policy on Linux systems.
+# See policy/ch-customized-programs.rst in
+# https://salsa.debian.org/dbnpolicy/policy.git
+sub defaults { [ qw(fcntl dotlock) ] }
+
+sub acq_fcntl {
+        my ($self) = @_;
+        my $op = $self->{nb} ? F_SETLK : F_SETLKW;
+        my $t = $self->{rw} ? F_WRLCK : F_RDLCK;
+        my $end = now + $self->{timeout};
+        $TMPL or die <<EOF;
+"struct flock" layout not available on $^O, install File::FcntlLock?
+EOF
+        do {
+                if (ref $TMPL) {
+                        return if fcntl($self->{fh}, $op, pack($$TMPL, $t));
+                } else {
+                        my $fl = File::FcntlLock->new;
+                        $fl->l_type($t);
+                        $fl->l_whence(SEEK_SET);
+                        $fl->l_start(0);
+                        $fl->l_len(0);
+                        return if $fl->lock($self->{fh}, $op);
+                }
+                select(undef, undef, undef, $self->{delay});
+        } while (now < $end);
+        croak "fcntl lock $self->{f}: $!";
+}
+
+sub acq_dotlock {
+        my ($self) = @_;
+        my $dot_lock = "$self->{f}.lock";
+        my ($pfx, $base) = ($self->{f} =~ m!(\A.*?/)([^/]+)\z!);
+        $pfx //= '';
+        my $pid = $$;
+        my $end = now + $self->{timeout};
+        do {
+                my $tmp = "$pfx.$base-".sprintf('%x,%x,%x',
+                                        rand(0xffffffff), $pid, time);
+                if (sysopen(my $fh, $tmp, O_CREAT|O_EXCL|O_WRONLY)) {
+                        if (link($tmp, $dot_lock)) {
+                                unlink($tmp) or die "unlink($tmp): $!";
+                                $self->{".lock$pid"} = $dot_lock;
+                                return;
+                        }
+                        unlink($tmp) or die "unlink($tmp): $!";
+                        select(undef, undef, undef, $self->{delay});
+                } else {
+                        croak "open $tmp (for $dot_lock): $!" if !$!{EXIST};
+                }
+        } while (now < $end);
+        croak "dotlock $dot_lock";
+}
+
+sub acq_flock {
+        my ($self) = @_;
+        my $op = $self->{rw} ? LOCK_EX : LOCK_SH;
+        $op |= LOCK_NB if $self->{nb};
+        my $end = now + $self->{timeout};
+        do {
+                return if flock($self->{fh}, $op);
+                select(undef, undef, undef, $self->{delay});
+        } while (now < $end);
+        croak "flock $self->{f}: $!";
+}
+
+sub acq {
+        my ($cls, $f, $rw, $methods) = @_;
+        my $fh;
+        unless (open $fh, $rw ? '+>>' : '<', $f) {
+                croak "open($f): $!" if $rw || !$!{ENOENT};
+        }
+        my $self = bless { f => $f, fh => $fh, rw => $rw }, $cls;
+        my $m = "@$methods";
+        if ($m ne 'none') {
+                my @m = map {
+                        if (/\A(timeout|delay)=([0-9\.]+)s?\z/) {
+                                $self->{$1} = $2 + 0;
+                                ();
+                        } else {
+                                $cls->can("acq_$_") // $_
+                        }
+                } split(/[, ]/, $m);
+                my @bad = grep { !ref } @m;
+                croak "Unsupported lock methods: @bad\n" if @bad;
+                croak "No lock methods supplied with $m\n" if !@m;
+                $self->{nb} = $#m || defined($self->{timeout});
+                $self->{delay} //= 0.1;
+                $self->{timeout} //= 5;
+                $_->($self) for @m;
+        }
+        $self;
+}
+
+sub DESTROY {
+        my ($self) = @_;
+        if (my $f = $self->{".lock$$"}) {
+                unlink($f) or die "unlink($f): $! (lock stolen?)";
+        }
+}
+
+1;