#!/usr/bin/perl -w
our $usage1 = <<'END';
usage: ../fyvzl [OPTIONS DATABASE-FILE ACTION ARG
options
  -lLENGTH   (for create)
  -mMAXPERUSER
  -dDOM
  -qQUALDOM
  -C     (show comments in output)
  -h     (display help)
END
our $usage2 = <<'END';
actions
  create [REDIRECT] [#COMMENT]    (default for REDIRECT is your username)
  update ADDR [REDIRECT] [#COMMENT]
  show ADDR
  list
  list-actions
empty string for REDIRECT means reject
END
our $usage3 = <<'END';
privileged actions
  list-user USER
  insert-exact ADDR USER REDIRECT COMMENT
  donate ADDR USER
  enable-user|disable-user USER
END
#/

use strict;

use DBI;
use POSIX;

our $randlength = 6;
our $maxperuser = 10000;
our $qualdom;
our $dbh;
our $dom;
our $user;
our $priv;
our $showcomment;

sub nextarg () {
    die "too few arguments\n" unless @ARGV;
    my $v = shift @ARGV;
    die "option too late on command line\n" if $v =~ m/^-/;
    return $v;
}

sub nextarg_addr () {
    my $addr = nextarg;
    return $addr if $addr !~ m/\@/;
    die "address not in correct domain (\@$dom)\n" unless $' eq $dom; #';
    return $`; #`;
}

sub nomoreargs () {
    die "too many arguments\n" if @ARGV;
}

sub isdisabled ($) {
    my ($u) = @_;
    our $dis_q;
    $dis_q ||= $dbh->prepare("SELECT * FROM disabled_users WHERE user=?");
    $dis_q->execute($u);
    my $row = $dis_q->fetchrow_arrayref();
    return !!$row;
}

sub prow ($) {
    my ($row) = @_;
    my $u = $row->{'user'};
    our $last_u;
    if (!defined $last_u or $last_u ne $u) {
	print "# user $u ".(isdisabled($u) ? 'disabled' : 'enabled')."\n";
	$last_u = $u;
    }
    my $pa = $row->{'localpart'};
    $pa .= '@'.$dom if defined $dom;
    if (length $row->{'redirect'}) {
	print "$pa: $row->{'redirect'}" or die $!;
    } else {
	print "# reject $pa" or die $!;
    }
    if ($showcomment || !$priv) {
	print " #$row->{'comment'}" or die $!;
    }
    print "\n" or die $!;
}

sub goodrand ($) {
    my ($lim) = @_;
    for (;;) {
	my $ch;
	read(R, $ch, 1) == 1 or die $!;
	my $o = ord $ch;
	my $v = $o % $lim;
	next unless $o-$v+$lim < 256;
#	print STDERR "goodrand($lim)=$v\n";
	return $v;
    }
}

sub qualify (\$) {
    my ($ref) = @_;
    if (defined $$ref && $$ref =~ m/[^\041-\177]/) {
	die "bad characters in redirection target\n";
    }
    if (defined $$ref && length $$ref && $$ref !~ m/\@/) {
	die "unqualified redirection target\n" unless defined $qualdom;
	$$ref .= '@'.$qualdom;
    }
}

sub insertrow ($) {
    my ($row) = @_;
    my $stmt =
	"INSERT INTO addrs (".
	(join ",", sort keys %$row).
	") VALUES (".
	(join ",", map { "?" } sort keys %$row).
	") ";
    $dbh->do($stmt, {}, map { $row->{$_} } sort keys %$row);
}

sub rhsargs ($) {
    my ($defrow) = @_;
    my $row = { };
    while (@ARGV) {
	$_ = shift @ARGV;
	my $f = (s/^\#// ? 'comment' : 'redirect');
	die "$f supplied twice\n" if exists $row->{$f};
	$row->{$f} = $_;
    }
    foreach my $f (keys %$defrow) {
	next if defined $row->{$f};
	$row->{$f} = $defrow->{$f};
    }
    qualify $row->{'redirect'};
    return $row;
}

sub action_create {
    my $newrow = rhsargs({'redirect'=>$user, 'comment'=>''});
    open R, "/dev/urandom" or die $!;
    binmode R;
    my $countq = $dbh->prepare("SELECT count(*) FROM addrs WHERE user=?");
    $countq->execute($user);
    my ($count) = $countq->fetchrow_array();
    die unless defined $count;
    die "too many aliases for this user\n" if $count >= $maxperuser;
    my $q = $dbh->prepare("SELECT localpart FROM addrs WHERE localpart=?");
    my $s;
    for (;;) {
	$s = chr(ord('a')+goodrand(26));
	while (length $s < $randlength) {
	    my $v = goodrand(36);
	    $s .= chr($v < 26
		      ? ord('a')+($v)
		      : ord('0')+($v-26));
	}
#	print STDERR "$s\n";
	$q->execute($s);
	my $row = $q->fetchrow_arrayref();
	last if !$row;
	$dbh->abort();
    }
    $newrow->{'user'} = $user;
    $newrow->{'localpart'} = $s;
    insertrow($newrow);
    $dbh->commit();
    prow($newrow);
}

sub selectrow ($) {
    my ($localpart) = @_;
    our $row_q ||= $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
    $row_q->execute($localpart);
    return $row_q->fetchrow_hashref();
}

sub begin_row ($) {
    my ($localpart) = @_;
    my $q = $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
    my $row = selectrow $localpart;
    die "unknown localpart\n" unless defined $row;
    die "not owned by you\n" unless $priv || $row->{user} eq $user;
    return $row;
}

sub action_update {
    my $localpart = nextarg_addr;
    my $updrow = rhsargs({});
    nomoreargs;
    begin_row($localpart);
    foreach my $f (qw(redirect comment)) {
	my $v = $updrow->{$f};
	next unless defined $v;
	$dbh->do("UPDATE addrs SET $f=? WHERE localpart=?",
		 {}, $v, $localpart);
    }
    my $row = selectrow $localpart;
    $dbh->commit;
    prow($row);
}

sub action_show {
    my $localpart = nextarg_addr;
    nomoreargs;
    my $row = begin_row($localpart);
    prow($row);
}

sub listq ($) {
    my ($q) = @_;
    while (my $row = $q->fetchrow_hashref()) {
	prow($row);
    }
}

sub action_list {
    nomoreargs;
    my $q = $dbh->prepare("SELECT * FROM addrs WHERE user=?".
			  " ORDER BY localpart");
    $q->execute($user);
    listq($q);
}

sub action_list_user {
    die unless $priv;
    $user = nextarg;
    nomoreargs;
    action_list;
}

sub action_list_all {
    die unless $priv;
    nomoreargs;
    my $q = $dbh->prepare("SELECT * FROM addrs".
			  " ORDER BY user, localpart");
    $q->execute();
    listq($q)
}

sub action_insert_exact {
    die unless $priv;
    my $row = { };
    $row->{'localpart'} = nextarg_addr;
    $row->{'user'} = $user = nextarg;
    $row->{'redirect'} = nextarg;
    $row->{'comment'} = nextarg;
    nomoreargs;
    insertrow($row);
    $dbh->commit;
}

sub action_donate {
    die unless $priv;
    my $localpart = nextarg_addr;
    my $newuser = nextarg;
    nomoreargs;
    begin_row($localpart);
    $dbh->do('UPDATE addrs SET user=? WHERE localpart=?',
	     {}, $newuser, $localpart);
    $dbh->commit;
}

sub action_enable_user {
    die unless $priv;
    $user = nextarg;
    nomoreargs;
    $dbh->do('DELETE FROM disabled_users WHERE user=?',{},$user);
    $dbh->commit;
}

sub action_disable_user {
    die unless $priv;
    $user = nextarg;
    nomoreargs;
    $dbh->do('INSERT INTO disabled_users VALUES user (?)',{},$user);
    $dbh->commit;
}

sub action_list_actions {
    print $usage2 or die $!;
}

while (@ARGV) {
    last unless $ARGV[0] =~ m/^-/;
    $_ = shift @ARGV;
    last if m/^--?$/;
    for (;;) {
	last unless m/^-./;
	if (s/^-l(\d+)$//) {
	    $randlength = $1;
	} elsif (s/^-m(\d+)$//) {
	    $maxperuser = $1;
	} elsif (s/^-d(\S+)$//) {
	    $dom = $1;
	} elsif (s/^-q(\S+)$//) {
	    $qualdom = $1;
	} elsif (s/^-C/-/) {
	    $showcomment = 1;
	} elsif (s/^-h/-/) {
	    print $usage1.$usage2.$usage3 or die $!;
	    exit 0;
	} else {
	    die "unknown option \`$_'\n";
	}
    }
}

my $dbfile = nextarg();

if (defined $ENV{'USERV_USER'}) {
    $priv=0;
    $user = $ENV{'USERV_USER'};
} else {
    $priv=1;
    $user = ((getpwuid $<)[0]) or die;
}

$usage2 .= "ADDR may be a local part, implicitly qualified with \@$dom\n"
    if defined $qualdom;
$usage2 .= "REDIRECT is implicitly qualified with \@$qualdom if it has no \@\n"
    if defined $qualdom;

$dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","",
		    { PrintError => 0, AutoCommit => 0, RaiseError => 1 }) 
    or die "$dbfile $!";

my $action = nextarg();
$action =~ y/-/_/;
{ no strict qw(refs); &{"action_$action"}(); }