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]    (default for REDIRECT is your username)
  15   update LOCAL-PART [REDIRECT] [#COMMENT]
  16   show LOCAL-PART
  17   list
  18   list-actions
  19 empty string 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 ($defrow) = @_;
 121     my $row = { };
 122     while (@ARGV) {
 123         $_ = shift @ARGV;
 124         my $f = (s/^\#// ? 'comment' : 'redirect');
 125         die "$f supplied twice\n" if exists $row->{$f};
 126         $row->{$f} = $_;
 127     }
 128     foreach my $f (keys %$defrow) {
 129         next if defined $row->{$f};
 130         $row->{$f} = $defrow->{$f};
 131     }
 132     qualify $row->{'redirect'};
 133     return $row;
 134 }
 135
 136 sub action_create {
 137     my $newrow = rhsargs({'redirect'=>$user, 'comment'=>''});
 138     open R, "/dev/urandom" or die $!;
 139     binmode R;
 140     my $countq = $dbh->prepare("SELECT count(*) FROM addrs WHERE user=?");
 141     $countq->execute($user);
 142     my ($count) = $countq->fetchrow_array();
 143     die unless defined $count;
 144     die "too many aliases for this user\n" if $count >= $maxperuser;
 145     my $q = $dbh->prepare("SELECT localpart FROM addrs WHERE localpart=?");
 146     my $s;
 147     for (;;) {
 148         $s = chr(ord('a')+goodrand(26));
 149         while (length $s < $randlength) {
 150             my $v = goodrand(36);
 151             $s .= chr($v < 26
 152                       ? ord('a')+($v)
 153                       : ord('0')+($v-26));
 154         }
 155 #       print STDERR "$s\n";
 156         $q->execute($s);
 157         my $row = $q->fetchrow_arrayref();
 158         last if !$row;
 159         $dbh->abort();
 160     }
 161     $newrow->{'user'} = $user;
 162     $newrow->{'localpart'} = $s;
 163     insertrow($newrow);
 164     $dbh->commit();
 165     prow($newrow);
 166 }
 167
 168 sub selectrow ($) {
 169     my ($localpart) = @_;
 170     our $row_q ||= $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
 171     $row_q->execute($localpart);
 172     return $row_q->fetchrow_hashref();
 173 }
 174
 175 sub begin_row ($) {
 176     my ($localpart) = @_;
 177     my $q = $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
 178     my $row = selectrow $localpart;
 179     die "unknown localpart\n" unless defined $row;
 180     die "not owned by you\n" unless $priv || $row->{user} eq $user;
 181     return $row;
 182 }
 183
 184 sub action_update {
 185     my $localpart = nextarg;
 186     my $updrow = rhsargs({});
 187     nomoreargs;
 188     begin_row($localpart);
 189     foreach my $f (qw(redirect comment)) {
 190         my $v = $updrow->{$f};
 191         next unless defined $v;
 192         $dbh->do("UPDATE addrs SET $f=? WHERE localpart=?",
 193                  {}, $v, $localpart);
 194     }
 195     my $row = selectrow $localpart;
 196     $dbh->commit;
 197     prow($row);
 198 }
 199
 200 sub action_show {
 201     my $localpart = nextarg;
 202     nomoreargs;
 203     my $row = begin_row($localpart);
 204     prow($row);
 205 }
 206
 207 sub listq ($) {
 208     my ($q) = @_;
 209     while (my $row = $q->fetchrow_hashref()) {
 210         prow($row);
 211     }
 212 }
 213
 214 sub action_list {
 215     nomoreargs;
 216     my $q = $dbh->prepare("SELECT * FROM addrs WHERE user=?".
 217                           " ORDER BY localpart");
 218     $q->execute($user);
 219     listq($q);
 220 }
 221
 222 sub action_list_user {
 223     die unless $priv;
 224     $user = nextarg;
 225     nomoreargs;
 226     action_list;
 227 }
 228
 229 sub action_list_all {
 230     die unless $priv;
 231     nomoreargs;
 232     my $q = $dbh->prepare("SELECT * FROM addrs".
 233                           " ORDER BY user, localpart");
 234     $q->execute();
 235     listq($q)
 236 }
 237
 238 sub action_insert_exact {
 239     die unless $priv;
 240     my $row = { };
 241     $row->{'localpart'} = nextarg;
 242     $row->{'user'} = $user = nextarg;
 243     $row->{'redirect'} = nextarg;
 244     $row->{'comment'} = nextarg;
 245     nomoreargs;
 246     insertrow($row);
 247     $dbh->commit;
 248 }
 249
 250 sub action_donate {
 251     die unless $priv;
 252     my $localpart = nextarg;
 253     my $newuser = nextarg;
 254     nomoreargs;
 255     begin_row($localpart);
 256     $dbh->do('UPDATE addrs SET user=? WHERE localpart=?',
 257              {}, $newuser, $localpart);
 258     $dbh->commit;
 259 }
 260
 261 sub action_enable_user {
 262     die unless $priv;
 263     $user = nextarg;
 264     nomoreargs;
 265     $dbh->do('DELETE FROM disabled_users WHERE user=?',{},$user);
 266     $dbh->commit;
 267 }
 268
 269 sub action_disable_user {
 270     die unless $priv;
 271     $user = nextarg;
 272     nomoreargs;
 273     $dbh->do('INSERT INTO disabled_users VALUES user (?)',{},$user);
 274     $dbh->commit;
 275 }
 276
 277 sub action_list_actions {
 278     print $usage2 or die $!;
 279 }
 280
 281 while (@ARGV) {
 282     last unless $ARGV[0] =~ m/^-/;
 283     $_ = shift @ARGV;
 284     last if m/^--?$/;
 285     for (;;) {
 286         last unless m/^-./;
 287         if (s/^-l(\d+)$//) {
 288             $randlength = $1;
 289         } elsif (s/^-m(\d+)$//) {
 290             $maxperuser = $1;
 291         } elsif (s/^-d(\S+)$//) {
 292             $dom = $1;
 293         } elsif (s/^-q(\S+)$//) {
 294             $qualdom = $1;
 295         } elsif (s/^-C/-/) {
 296             $showcomment = 1;
 297         } elsif (s/^-h/-/) {
 298             print $usage1.$usage2.$usage3 or die $!;
 299             exit 0;
 300         } else {
 301             die "unknown option \`$_'\n";
 302         }
 303     }
 304 }
 305
 306 my $dbfile = nextarg();
 307
 308 if (defined $ENV{'USERV_USER'}) {
 309     $priv=0;
 310     $user = $ENV{'USERV_USER'};
 311 } else {
 312     $priv=1;
 313     $user = ((getpwuid $<)[0]) or die;
 314 }
 315
 316 $usage2 .= "LOCAL-PART is implicitly qualified with \@$dom\n"
 317     if defined $qualdom;
 318 $usage2 .= "REDIRECT is implicitly qualified with \@$qualdom if it has no \@\n"
 319     if defined $qualdom;
 320
 321 $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","",
 322                     { PrintError => 0, AutoCommit => 0, RaiseError => 1 })
 323     or die "$dbfile $!";
 324
 325 my $action = nextarg();
 326 $action =~ y/-/_/;
 327 { no strict qw(refs); &{"action_$action"}(); }