fyvzl

   1 #!/usr/bin/perl -w
   2 our $usage1 = <<'END';
   3 usage: ../fyvzl [OPTIONS DATABASE-FILE ACTION ARG
   4 options
   5   -lLENGTH   (for create)
   6   -mMAXPERUSER
   7   -dDOM
   8   -qQUALDOM
   9   -C     (show comments in output)
  10   -h     (display help)
  11 END
  12 our $usage2 = <<'END';
  13 actions
  14   create [REDIRECT] [#COMMENT]
  15   update LOCAL-PART [REDIRECT] [#COMMENT]
  16   show LOCAL-PART
  17   list
  18   list-actions
  19 empty value for REDIRECT means reject
  20 END
  21 our $usage3 = <<'END';
  22 privileged actions
  23   list-user USER
  24   insert-exact LOCAL-PART USER REDIRECT COMMENT
  25   donate LOCAL-PART USER
  26   enable-user|disable-user USER
  27 END
  28
  29 use strict;
  30
  31 use DBI;
  32 use POSIX;
  33
  34 our $randlength = 6;
  35 our $maxperuser = 10000;
  36 our $qualdom;
  37 our $dbh;
  38 our $dom;
  39 our $user;
  40 our $priv;
  41 our $showcomment;
  42
  43 sub nextarg () {
  44     die "too few arguments\n" unless @ARGV;
  45     my $v = shift @ARGV;
  46     die "option too late on command line\n" if $v =~ m/^-/;
  47     return $v;
  48 }
  49
  50 sub nomoreargs () {
  51     die "too many arguments\n" if @ARGV;
  52 }
  53
  54 sub isdisabled ($) {
  55     my ($u) = @_;
  56     our $dis_q;
  57     $dis_q ||= $dbh->prepare("SELECT * FROM disabled_users WHERE user=?");
  58     $dis_q->execute($u);
  59     my $row = $dis_q->fetchrow_arrayref();
  60     return !!$row;
  61 }
  62
  63 sub prow ($) {
  64     my ($row) = @_;
  65     my $u = $row->{'user'};
  66     our $last_u;
  67     if (!defined $last_u or $last_u ne $u) {
  68         print "# user $u ".(isdisabled($u) ? 'disabled' : 'enabled')."\n";
  69         $last_u = $u;
  70     }
  71     my $pa = $row->{'localpart'};
  72     $pa .= '@'.$dom if defined $dom;
  73     if (length $row->{'redirect'}) {
  74         print "$pa: $row->{'redirect'}" or die $!;
  75     } else {
  76         print "# reject $pa" or die $!;
  77     }
  78     if ($showcomment || !$priv) {
  79         print " #$row->{'comment'}" or die $!;
  80     }
  81     print "\n" or die $!;
  82 }
  83
  84 sub goodrand ($) {
  85     my ($lim) = @_;
  86     for (;;) {
  87         my $ch;
  88         read(R, $ch, 1) == 1 or die $!;
  89         my $o = ord $ch;
  90         my $v = $o % $lim;
  91         next unless $o-$v+$lim < 256;
  92 #       print STDERR "goodrand($lim)=$v\n";
  93         return $v;
  94     }
  95 }
  96
  97 sub qualify (\$) {
  98     my ($ref) = @_;
  99     if (defined $$ref && $$ref =~ m/[^\041-\177]/) {
 100         die "bad characters in redirection target\n";
 101     }
 102     if (defined $$ref && length $$ref && $$ref !~ m/\@/) {
 103         die "unqualified redirection target\n" unless defined $qualdom;
 104         $$ref .= '@'.$qualdom;
 105     }
 106 }
 107
 108 sub insertrow ($) {
 109     my ($row) = @_;
 110     my $stmt =
 111         "INSERT INTO addrs (".
 112         (join ",", sort keys %$row).
 113         ") VALUES (".
 114         (join ",", map { "?" } sort keys %$row).
 115         ") ";
 116     $dbh->do($stmt, {}, map { $row->{$_} } sort keys %$row);
 117 }
 118
 119 sub rhsargs ($) {
 120     my ($row) = @_;
 121     while (@ARGV) {
 122         $_ = shift @ARGV;
 123         my $f = (s/^\#// ? 'comment' : 'redirect');
 124         die "$f supplied twice\n" if exists $row->{$f};
 125         $row->{$f} = $_;
 126     }
 127     qualify $row->{'redirect'};
 128     return $row;
 129 }
 130
 131 sub action_create {
 132     my $newrow = rhsargs({'redirect'=>$user, 'comment'=>''});
 133     open R, "/dev/urandom" or die $!;
 134     binmode R;
 135     my $countq = $dbh->prepare("SELECT count(*) FROM addrs WHERE user=?");
 136     $countq->execute($user);
 137     my ($count) = $countq->fetchrow_array();
 138     die unless defined $count;
 139     die "too many aliases for this user\n" if $count >= $maxperuser;
 140     my $q = $dbh->prepare("SELECT localpart FROM addrs WHERE localpart=?");
 141     my $s;
 142     for (;;) {
 143         $s = chr(ord('a')+goodrand(26));
 144         while (length $s < $randlength) {
 145             my $v = goodrand(36);
 146             $s .= chr($v < 26
 147                       ? ord('a')+($v)
 148                       : ord('0')+($v-26));
 149         }
 150 #       print STDERR "$s\n";
 151         $q->execute($s);
 152         my $row = $q->fetchrow_arrayref();
 153         last if !$row;
 154         $dbh->abort();
 155     }
 156     $newrow->{'user'} = $user;
 157     $newrow->{'localpart'} = $s;
 158     insertrow($newrow);
 159     $dbh->commit();
 160     prow($newrow);
 161 }
 162
 163 sub selectrow ($) {
 164     my ($localpart) = @_;
 165     our $row_q ||= $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
 166     $row_q->execute($localpart);
 167     return $row_q->fetchrow_hashref();
 168 }
 169
 170 sub begin_row ($) {
 171     my ($localpart) = @_;
 172     my $q = $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
 173     my $row = selectrow $localpart;
 174     die "unknown localpart\n" unless defined $row;
 175     die "not owned by you\n" unless $priv || $row->{user} eq $user;
 176     return $row;
 177 }
 178
 179 sub action_update {
 180     my $localpart = nextarg;
 181     my $updrow = rhsargs({});
 182     nomoreargs;
 183     begin_row($localpart);
 184     foreach my $f (qw(redirect comment)) {
 185         my $v = $updrow->{$f};
 186         next unless defined $v;
 187         $dbh->do("UPDATE addrs SET $f=? WHERE localpart=?",
 188                  {}, $v, $localpart);
 189     }
 190     my $row = selectrow $localpart;
 191     $dbh->commit;
 192     prow($row);
 193 }
 194
 195 sub action_show {
 196     my $localpart = nextarg;
 197     nomoreargs;
 198     my $row = begin_row($localpart);
 199     prow($row);
 200 }
 201
 202 sub action_list {
 203     nomoreargs;
 204     my $q = $dbh->prepare("SELECT * FROM addrs WHERE user=?".
 205                           " ORDER BY localpart");
 206     $q->execute($user);
 207     while (my $row = $q->fetchrow_hashref()) {
 208         prow($row);
 209     }
 210 }
 211
 212 sub action_list_user {
 213     die unless $priv;
 214     $user = nextarg;
 215     nomoreargs;
 216     action_list;
 217 }
 218
 219 sub action_insert_exact {
 220     die unless $priv;
 221     my $row = { };
 222     $row->{'localpart'} = nextarg;
 223     $row->{'user'} = $user = nextarg;
 224     $row->{'redirect'} = nextarg;
 225     $row->{'comment'} = nextarg;
 226     nomoreargs;
 227     insertrow($row);
 228     $dbh->commit;
 229 }
 230
 231 sub action_donate {
 232     die unless $priv;
 233     my $localpart = nextarg;
 234     my $newuser = nextarg;
 235     nomoreargs;
 236     begin_row($localpart);
 237     $dbh->do('UPDATE addrs SET user=? WHERE localpart=?',
 238              {}, $newuser, $localpart);
 239     $dbh->commit;
 240 }
 241
 242 sub action_enable_user {
 243     die unless $priv;
 244     $user = nextarg;
 245     nomoreargs;
 246     $dbh->do('DELETE FROM disabled_users WHERE user=?',{},$user);
 247     $dbh->commit;
 248 }
 249
 250 sub action_disable_user {
 251     die unless $priv;
 252     $user = nextarg;
 253     nomoreargs;
 254     $dbh->do('INSERT INTO disabled_users VALUES user (?)',{},$user);
 255     $dbh->commit;
 256 }
 257
 258 sub action_list_actions {
 259     print $usage2 or die $!;
 260 }
 261
 262 while (@ARGV) {
 263     last unless $ARGV[0] =~ m/^-/;
 264     $_ = shift @ARGV;
 265     last if m/^--?$/;
 266     for (;;) {
 267         last unless m/^-./;
 268         if (s/^-l(\d+)$//) {
 269             $randlength = $1;
 270         } elsif (s/^-m(\d+)$//) {
 271             $maxperuser = $1;
 272         } elsif (s/^-d(\S+)$//) {
 273             $dom = $1;
 274         } elsif (s/^-q(\S+)$//) {
 275             $qualdom = $1;
 276         } elsif (s/^-C/-/) {
 277             $showcomment = 1;
 278         } elsif (s/^-h/-/) {
 279             print $usage1.$usage2.$usage3 or die $!;
 280             exit 0;
 281         } else {
 282             die "unknown option \`$_'\n";
 283         }
 284     }
 285 }
 286
 287 my $dbfile = nextarg();
 288
 289 if (defined $ENV{'USERV_USER'}) {
 290     $priv=0;
 291     $user = $ENV{'USERV_USER'};
 292 } else {
 293     $priv=1;
 294     $user = ((getpwuid $<)[0]) or die;
 295 }
 296
 297 $usage2 .= "LOCAL-PART is implicitly qualified with \@$dom\n"
 298     if defined $qualdom;
 299 $usage2 .= "REDIRECT is implicitly qualified with \@$qualdom if it has no \@\n"
 300     if defined $qualdom;
 301
 302 $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","",
 303                     { PrintError => 0, AutoCommit => 0, RaiseError => 1 })
 304     or die "$dbfile $!";
 305
 306 my $action = nextarg();
 307 $action =~ y/-/_/;
 308 { no strict qw(refs); &{"action_$action"}(); }