#!/usr/bin/perl -w
our $usage1 = <<'END';
usage: ../fyvzl [<options>] <database-file> <action> <arg>...
options
  -m<maxperuser>
  -d<dom>
  -q<qualdom>
  -C     (show comments in output)
  -h     (display help)
options for alphanum generation
  -l<minrandlength>   (for create/choose alphanum, minimum randlength)
options for wordlist generation
  -Wf<wordlist>       (switches generation method to wordlist)
  -WF<min-word-list-len>             } (for wordlist generation
  -Wl<min-num-words>                 }   method only)
  -WL<min-max-mean-word-len>         }
  -Wd<permitted-delimiter-chars>     } (first char is default; comma = none)
END
our $usage2 = <<'END';
actions
  create [<genopts>] [<redirect>] [#<comment>]  (default redirect is username)
  choose [<genopts>] [<redirect>] [#<comment>]  (interactively allocate)
  update <addr> [<redirect>] [#<comment>]
  show <addr>
  list
  list-actions
empty string for redirect means reject
remember to quote comments (to protect # from your shell)
END
our $usage3 = <<'END';
privileged actions
  list-user <user>
  insert-exact <addr> <user> <redirect> <comment>
  donate <addr> <user>
  enable-user|disable-user <user>
default generation method is alphanum
END
our %usage_genopts = (
'alphanum' => <<END,
  -l<randlength>      (number of letters+digits)
END
'wordlist' => <<END,
  -l<num-words>       (number of words in output)
  -d<delim-char>      (delimiter character, "," means none)
  -F<max-dict-size>   (pick from up to <dictsize> different words, 0 means all)
  -m<max-addr-len>    (restrict total length of generated addrs, 0 = unlimited)
END
);
#/

use strict;

use DBI;
use POSIX;

our $maxperuser = 10000;
our $qualdom;
our $dbh;
our $dom;
our $user;
our $priv;
our $showcomment;
our $genmethod = 'alphanum';

# for alphanum
#   options
our $minrandlength = 6;
our $maxrandlength = 100;
#   genopts
our $randlength;

# for wordlist
#   options
our $wordlist;
our $minwordlistlen = 1000;
our $minmaxmeanwordlen = 6.2;
our $minnumwords = 3;
our $maxnumwords = 10;
our $worddelims = '.-_,';
#   genopts
our $numwords;
our $worddelim;
our $wordlistlen = 3000;
our $maxdomainlen = 40;

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

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

sub nextarg_addr () {
    return addr2localpart nextarg;
}

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 puser ($) {
    my ($u) = @_;
    our $last_u;
    if (!defined $last_u or $last_u ne $u) {
	print "# user $u ".(isdisabled($u) ? 'disabled' : 'enabled')."\n";
	$last_u = $u;
    }
}

sub prow ($) {
    my ($row) = @_;
    my $u = $row->{'user'};
    puser($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 local_part_inuse ($) {
    my ($s) = @_;
    our $checkexist_q ||=
	$dbh->prepare("SELECT localpart FROM addrs WHERE localpart=?");
    $checkexist_q->execute($s);
    my $row = $checkexist_q->fetchrow_arrayref();
    return !!$row;
}

sub gen_local_part_alphanum {
    my $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));
    }
    return $s;
}

sub generate_local_part () {
    my $s;
    for (;;) {
	{ no strict qw(refs); $s = &{"gen_local_part_$genmethod"}; }
#	print STDERR "$s\n";
	last if !local_part_inuse($s);
    }
    return $s;
}

sub prepare_create () {
    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;
    open R, "/dev/urandom" or die $!;
    binmode R;
}

sub genopt_alphanum {
    local ($_) = @_;
    if (m/^-l(\d+)$/) {
	$randlength = 0+$1;
	die "length out of range $minrandlength..$maxrandlength\n"
	    unless ($minrandlength<=$randlength &&
		    $randlength<=$maxrandlength);
    } else {
	die "unknown alphanumeric generation option\n";
    }
}

sub gendefaults_alphanum {
    $randlength ||= $minrandlength;
}

sub gen_local_part_wordlist {
    my @cmd = (qw(random-word), "-f$wordlist","-n$numwords");
    push @cmd, "-F$wordlistlen" if $wordlistlen < 1e9;
    for (;;) {
	open P, "-|", @cmd or die $!;
	my $s = <P>;
	$!=0; $?=0; close P or die "$? $!";
	chomp $s or die;
	$s =~ s/ /$worddelim/g;
	my $efflen = length $s;
	$efflen += 1 + length($dom) if defined $dom;
	return $s if $efflen <= $maxdomainlen;
    }
}

sub genopt_wordlist {
    local ($_) = @_;
    if (m/^-l(\d+)$/) {
	$numwords = $1;
	die "length out of range $minnumwords..$maxnumwords\n"
	    unless ($minnumwords<=$numwords &&
		    $numwords<=$maxnumwords);
    } elsif (m/^-d(.)$/) {
	$worddelim = $1;
	die "word delimiter must be one of \`$worddelims'\n"
	    unless grep { $worddelim eq $_ } split //, $worddelims;
    } elsif (m/^-F(\d+)$/) {
	$wordlistlen = $1 ? 0+$1 : 1e9;
	die "requested dictionary size too small\n"
	    unless $wordlistlen >= $minwordlistlen;
    } elsif (m/^-m(\d+)$/) {
	$maxdomainlen = $1 ? 0+$1 : 1e9;
    } else {
	die "unknown wordlist generation option\n";
    }
}

sub gendefaults_wordlist {
    $numwords ||= $minnumwords;
    $worddelim = substr($worddelims,0,1) unless defined $worddelim;
    $worddelim = '' if $worddelim eq ',';
    my $expectedmindomlen =
	(defined $dom ? (1 + length $dom) : 0) # @domain.name
	+ $minmaxmeanwordlen * $numwords # some words
	+ (length $worddelim) * ($numwords-1); # delimiters
    die "assuming lowest reasonable mean word length $minmaxmeanwordlen".
	" addrs would be $expectedmindomlen long but".
	" maximum length is set to $maxdomainlen (use different -m?)\n"
	if $expectedmindomlen > $maxdomainlen;
}

sub genopts {
    while (@ARGV && $ARGV[0] =~ m/^-/) {
	my $arg = shift @ARGV;
	last if $arg =~ m/^--?$/;
	{ no strict qw(refs); &{"genopt_$genmethod"}($arg); }
    }
    { no strict qw(refs); &{"gendefaults_$genmethod"}(); }
}

sub action_create {
    genopts;
    my $newrow = rhsargs({'redirect'=>$user, 'comment'=>''});
    prepare_create();
    $newrow->{'user'} = $user;
    $newrow->{'localpart'} = generate_local_part();
    insertrow($newrow);
    $dbh->commit();
    prow($newrow);
}

sub action_choose {
    genopts;
    $|=1;
    my $template = rhsargs({'redirect'=>$user, 'comment'=>''});
    $template->{'user'} = $user;
    prepare_create();
    puser($user);
    my %s;
    while (keys %s < 10) {
	my $s = generate_local_part();
	next if $s{$s};
	print $s or die $!;
	print "\@$dom" or die $! if $dom;
	print "\n" or die $!;
	$s{$s} = 1;
    }
    print "# ready - enter addrs or local-parts to create,".
	" then \`.' on a line by itself\n"
	or die $!;

    while (<STDIN>) {
	chomp;
	last if m/^\.$/;
	my $s;
	if (eval {
	    $s = addr2localpart $_;
	    $s{$s} or die "not an (as-yet-unused) suggestion\n";
	    delete $s{$s};
	    die "just taken in the meantime (bad luck!)\n"
		if local_part_inuse $s;
	    1;
	}) {
	    my $newrow = { %$template, 'localpart' => $s };
	    insertrow($newrow);
	    $dbh->commit();
	    prow($newrow);
	} else {
	    $dbh->rollback();
	    print "! error: $@" or die $!;
	}
    }
}

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 $!;
    print "genopts\n" or die $!;
    print $usage_genopts{$genmethod} or die $!;
}

while (@ARGV) {
    last unless $ARGV[0] =~ m/^-/;
    $_ = shift @ARGV;
    last if m/^--?$/;
    for (;;) {
	last unless m/^-./;
	if (s/^-l(\d+)$//) {
	    $minrandlength = $1;
	} elsif (s/^-m(\d+)$//) {
	    $maxperuser = $1;
	} elsif (s/^-d(\S+)$//) {
	    $dom = $1;
	} elsif (s/^-q(\S+)$//) {
	    $qualdom = $1;
	} elsif (s/^-Wf(\S+)$//) {
	    $wordlist = $1;
	    $genmethod = 'wordlist';
	} elsif (s/^-WF(\d+)$//) {
	    $minwordlistlen = $1;
	} elsif (s/^-Wl(\d+)$//) {
	    $minnumwords = $1;
	} elsif (s/^-WL([0-9.]+)$//) {
	    $minmaxmeanwordlen = $1;
	} elsif (s/^-C/-/) {
	    $showcomment = 1;
	} elsif (s/^-h/-/) {
	    print $usage1.$usage2.$usage3 or die $!;
	    foreach my $meth (qw(alphanum wordlist)) {
		print "genopts for $meth generation method\n" or die $!;
		print $usage_genopts{$meth} 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 .= defined $dom
    ? "addr may be a local part, implicitly qualified with \@$dom\n"
    : "addr must be a local part (only)\n";
$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"}(); }