X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ijackson/git?a=blobdiff_plain;f=service;h=a74bb79c60cb33cf1059589c6a0d189797aa0538;hb=3b8b28fc6a09bf548bd04555474644a42640c973;hp=5b997bd1bf15fcf280ffd39fbe31d2a132824fe3;hpb=4bbee9f44edf6898e67cc97c7aee904d45212815;p=d.git diff --git a/service b/service index 5b997bd..a74bb79 100755 --- a/service +++ b/service @@ -1,538 +1,7 @@ -#!/usr/bin/perl -w -our $usage1 = <<'END'; -usage: ../fyvzl [] ... -options - -m - -d - -q - -C (show comments in output) - -h (display help) -options for alphanum generation - -l (for create/choose alphanum, minimum randlength) -options for wordlist generation - -Wf (switches generation method to wordlist) - -WF } (for wordlist generation - -Wl } method only) - -WL } - -Wd } (first char is default; comma = none) -END -our $usage2 = <<'END'; -actions - create [] [] [#] (default redirect is username) - choose [] [] [#] (interactively allocate) - update [] [#] - show - list - list-actions -empty string for redirect means reject -END -our $usage3 = <<'END'; -privileged actions - list-user - insert-exact - donate - enable-user|disable-user -default generation method is alphanum -END -our %usage_genopts = ( -'alphanum' => < (number of letters+digits) -END -'wordlist' => < (number of words in output) - -d (delimiter character, "," means none) - -F (pick from up to different words, 0 means all) - -m (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 too late 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 =

; - $!=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". - " your maximum length specified $maxdomainlen\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; - 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 () { - 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 }; - $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"}(); } +#!/bin/sh +set -e +cd /usr/local/lib/evade-mail +dom="$USERV_U_domain" +exec "./service-$dom" -qchiark.greenend.org.uk \ + -d"$dom" /var/lib/evade-mail/"$dom".sqlite3 \ + "$@"