evade-mail-admin

   1 #!/usr/bin/perl -w
   2 our $usage1 = <<'END';
   3 usage: ../fyvzl [<options>] <database-file> <action> <arg>...
   4 options
   5   -m<maxperuser>
   6   -d<dom>
   7   -q<qualdom>
   8   -C     (show comments in output)
   9   -h     (display help)
  10 options for alphanum generation
  11   -l<minrandlength>   (for create/choose alphanum, minimum randlength)
  12 options for wordlist generation
  13   -Wf<wordlist>       (switches generation method to wordlist)
  14   -WF<min-word-list-len>             } (for wordlist generation
  15   -Wl<min-num-words>                 }   method only)
  16   -WL<min-max-mean-word-len>         }
  17   -Wd<permitted-delimiter-chars>     } (first char is default; comma = none)
  18 END
  19 our $usage2 = <<'END';
  20 actions
  21   create [<genopts>] [<redirect>] [#<comment>]  (default redirect is username)
  22   choose [<genopts>] [<redirect>] [#<comment>]  (interactively allocate)
  23   update <addr> [<redirect>] [#<comment>]
  24   show <addr>
  25   list
  26   list-actions
  27 empty string for redirect means reject
  28 END
  29 our $usage3 = <<'END';
  30 privileged actions
  31   list-user <user>
  32   insert-exact <addr> <user> <redirect> <comment>
  33   donate <addr> <user>
  34   enable-user|disable-user <user>
  35 default generation method is alphanum
  36 END
  37 our %usage_genopts = (
  38 'alphanum' => <<END,
  39   -l<randlength>      (number of letters+digits)
  40 END
  41 'wordlist' => <<END,
  42   -l<num-words>       (number of words in output)
  43   -d<delim-char>      (delimiter character, "," means none)
  44   -F<max-dict-size>   (pick from up to <dictsize> different words, 0 means all)
  45   -m<max-addr-len>    (restrict total length of generated addrs, 0 = unlimited)
  46 END
  47 );
  48 #/
  49
  50 use strict;
  51
  52 use DBI;
  53 use POSIX;
  54
  55 our $maxperuser = 10000;
  56 our $qualdom;
  57 our $dbh;
  58 our $dom;
  59 our $user;
  60 our $priv;
  61 our $showcomment;
  62 our $genmethod = 'alphanum';
  63
  64 # for alphanum
  65 #   options
  66 our $minrandlength = 6;
  67 our $maxrandlength = 100;
  68 #   genopts
  69 our $randlength;
  70
  71 # for wordlist
  72 #   options
  73 our $wordlist;
  74 our $minwordlistlen = 1000;
  75 our $minmaxmeanwordlen = 6.2;
  76 our $minnumwords = 3;
  77 our $maxnumwords = 10;
  78 our $worddelims = '.-_,';
  79 #   genopts
  80 our $numwords;
  81 our $worddelim;
  82 our $wordlistlen = 3000;
  83 our $maxdomainlen = 40;
  84
  85 sub nextarg () {
  86     die "too few arguments\n" unless @ARGV;
  87     my $v = shift @ARGV;
  88     die "option in wrong place on command line\n" if $v =~ m/^-/;
  89     return $v;
  90 }
  91
  92 sub addr2localpart ($) {
  93     my ($addr) = @_;
  94     return $addr if $addr !~ m/\@/;
  95     die "address not in correct domain (\@$dom)\n" unless $' eq $dom; #';
  96     return $`; #`;
  97 }
  98
  99 sub nextarg_addr () {
 100     return addr2localpart nextarg;
 101 }
 102
 103 sub nomoreargs () {
 104     die "too many arguments\n" if @ARGV;
 105 }
 106
 107 sub isdisabled ($) {
 108     my ($u) = @_;
 109     our $dis_q;
 110     $dis_q ||= $dbh->prepare("SELECT * FROM disabled_users WHERE user=?");
 111     $dis_q->execute($u);
 112     my $row = $dis_q->fetchrow_arrayref();
 113     return !!$row;
 114 }
 115
 116 sub puser ($) {
 117     my ($u) = @_;
 118     our $last_u;
 119     if (!defined $last_u or $last_u ne $u) {
 120         print "# user $u ".(isdisabled($u) ? 'disabled' : 'enabled')."\n";
 121         $last_u = $u;
 122     }
 123 }
 124
 125 sub prow ($) {
 126     my ($row) = @_;
 127     my $u = $row->{'user'};
 128     puser($u);
 129     my $pa = $row->{'localpart'};
 130     $pa .= '@'.$dom if defined $dom;
 131     if (length $row->{'redirect'}) {
 132         print "$pa: $row->{'redirect'}" or die $!;
 133     } else {
 134         print "# reject $pa" or die $!;
 135     }
 136     if ($showcomment || !$priv) {
 137         print " #$row->{'comment'}" or die $!;
 138     }
 139     print "\n" or die $!;
 140 }
 141
 142 sub goodrand ($) {
 143     my ($lim) = @_;
 144     for (;;) {
 145         my $ch;
 146         read(R, $ch, 1) == 1 or die $!;
 147         my $o = ord $ch;
 148         my $v = $o % $lim;
 149         next unless $o-$v+$lim < 256;
 150 #       print STDERR "goodrand($lim)=$v\n";
 151         return $v;
 152     }
 153 }
 154
 155 sub qualify (\$) {
 156     my ($ref) = @_;
 157     if (defined $$ref && $$ref =~ m/[^\041-\177]/) {
 158         die "bad characters in redirection target\n";
 159     }
 160     if (defined $$ref && length $$ref && $$ref !~ m/\@/) {
 161         die "unqualified redirection target\n" unless defined $qualdom;
 162         $$ref .= '@'.$qualdom;
 163     }
 164 }
 165
 166 sub insertrow ($) {
 167     my ($row) = @_;
 168     my $stmt =
 169         "INSERT INTO addrs (".
 170         (join ",", sort keys %$row).
 171         ") VALUES (".
 172         (join ",", map { "?" } sort keys %$row).
 173         ") ";
 174     $dbh->do($stmt, {}, map { $row->{$_} } sort keys %$row);
 175 }
 176
 177 sub rhsargs ($) {
 178     my ($defrow) = @_;
 179     my $row = { };
 180     while (@ARGV) {
 181         $_ = shift @ARGV;
 182         my $f = (s/^\#// ? 'comment' : 'redirect');
 183         die "$f supplied twice\n" if exists $row->{$f};
 184         $row->{$f} = $_;
 185     }
 186     foreach my $f (keys %$defrow) {
 187         next if defined $row->{$f};
 188         $row->{$f} = $defrow->{$f};
 189     }
 190     qualify $row->{'redirect'};
 191     return $row;
 192 }
 193
 194 sub local_part_inuse ($) {
 195     my ($s) = @_;
 196     our $checkexist_q ||=
 197         $dbh->prepare("SELECT localpart FROM addrs WHERE localpart=?");
 198     $checkexist_q->execute($s);
 199     my $row = $checkexist_q->fetchrow_arrayref();
 200     return !!$row;
 201 }
 202
 203 sub gen_local_part_alphanum {
 204     my $s = chr(ord('a')+goodrand(26));
 205     while (length $s < $randlength) {
 206         my $v = goodrand(36);
 207         $s .= chr($v < 26
 208                   ? ord('a')+($v)
 209                   : ord('0')+($v-26));
 210     }
 211     return $s;
 212 }
 213
 214 sub generate_local_part () {
 215     my $s;
 216     for (;;) {
 217         { no strict qw(refs); $s = &{"gen_local_part_$genmethod"}; }
 218 #       print STDERR "$s\n";
 219         last if !local_part_inuse($s);
 220     }
 221     return $s;
 222 }
 223
 224 sub prepare_create () {
 225     my $countq = $dbh->prepare("SELECT count(*) FROM addrs WHERE user=?");
 226     $countq->execute($user);
 227     my ($count) = $countq->fetchrow_array();
 228     die unless defined $count;
 229     die "too many aliases for this user\n" if $count >= $maxperuser;
 230     open R, "/dev/urandom" or die $!;
 231     binmode R;
 232 }
 233
 234 sub genopt_alphanum {
 235     local ($_) = @_;
 236     if (m/^-l(\d+)$/) {
 237         $randlength = 0+$1;
 238         die "length out of range $minrandlength..$maxrandlength\n"
 239             unless ($minrandlength<=$randlength &&
 240                     $randlength<=$maxrandlength);
 241     } else {
 242         die "unknown alphanumeric generation option\n";
 243     }
 244 }
 245
 246 sub gendefaults_alphanum {
 247     $randlength ||= $minrandlength;
 248 }
 249
 250 sub gen_local_part_wordlist {
 251     my @cmd = (qw(random-word), "-f$wordlist","-n$numwords");
 252     push @cmd, "-F$wordlistlen" if $wordlistlen < 1e9;
 253     for (;;) {
 254         open P, "-|", @cmd or die $!;
 255         my $s = <P>;
 256         $!=0; $?=0; close P or die "$? $!";
 257         chomp $s or die;
 258         $s =~ s/ /$worddelim/g;
 259         my $efflen = length $s;
 260         $efflen += 1 + length($dom) if defined $dom;
 261         return $s if $efflen <= $maxdomainlen;
 262     }
 263 }
 264
 265 sub genopt_wordlist {
 266     local ($_) = @_;
 267     if (m/^-l(\d+)$/) {
 268         $numwords = $1;
 269         die "length out of range $minnumwords..$maxnumwords\n"
 270             unless ($minnumwords<=$numwords &&
 271                     $numwords<=$maxnumwords);
 272     } elsif (m/^-d(.)$/) {
 273         $worddelim = $1;
 274         die "word delimiter must be one of \`$worddelims'\n"
 275             unless grep { $worddelim eq $_ } split //, $worddelims;
 276     } elsif (m/^-F(\d+)$/) {
 277         $wordlistlen = $1 ? 0+$1 : 1e9;
 278         die "requested dictionary size too small\n"
 279             unless $wordlistlen >= $minwordlistlen;
 280     } elsif (m/^-m(\d+)$/) {
 281         $maxdomainlen = $1 ? 0+$1 : 1e9;
 282     } else {
 283         die "unknown wordlist generation option\n";
 284     }
 285 }
 286
 287 sub gendefaults_wordlist {
 288     $numwords ||= $minnumwords;
 289     $worddelim = substr($worddelims,0,1) unless defined $worddelim;
 290     $worddelim = '' if $worddelim eq ',';
 291     my $expectedmindomlen =
 292         (defined $dom ? (1 + length $dom) : 0) # @domain.name
 293         + $minmaxmeanwordlen * $numwords # some words
 294         + (length $worddelim) * ($numwords-1); # delimiters
 295     die "assuming lowest reasonable mean word length $minmaxmeanwordlen".
 296         " addrs would be $expectedmindomlen long but".
 297         " maximum length is set to $maxdomainlen (use different -m?)\n"
 298         if $expectedmindomlen > $maxdomainlen;
 299 }
 300
 301 sub genopts {
 302     while (@ARGV && $ARGV[0] =~ m/^-/) {
 303         my $arg = shift @ARGV;
 304         last if $arg =~ m/^--?$/;
 305         { no strict qw(refs); &{"genopt_$genmethod"}($arg); }
 306     }
 307     { no strict qw(refs); &{"gendefaults_$genmethod"}(); }
 308 }
 309
 310 sub action_create {
 311     genopts;
 312     my $newrow = rhsargs({'redirect'=>$user, 'comment'=>''});
 313     prepare_create();
 314     $newrow->{'user'} = $user;
 315     $newrow->{'localpart'} = generate_local_part();
 316     insertrow($newrow);
 317     $dbh->commit();
 318     prow($newrow);
 319 }
 320
 321 sub action_choose {
 322     genopts;
 323     $|=1;
 324     my $template = rhsargs({'redirect'=>$user, 'comment'=>''});
 325     $template->{'user'} = $user;
 326     prepare_create();
 327     puser($user);
 328     my %s;
 329     while (keys %s < 10) {
 330         my $s = generate_local_part();
 331         next if $s{$s};
 332         print $s or die $!;
 333         print "\@$dom" or die $! if $dom;
 334         print "\n" or die $!;
 335         $s{$s} = 1;
 336     }
 337     print "# ready - enter addrs or local-parts to create,".
 338         " then \`.' on a line by itself\n"
 339         or die $!;
 340
 341     while (<STDIN>) {
 342         chomp;
 343         last if m/^\.$/;
 344         my $s;
 345         if (eval {
 346             $s = addr2localpart $_;
 347             $s{$s} or die "not an (as-yet-unused) suggestion\n";
 348             delete $s{$s};
 349             die "just taken in the meantime (bad luck!)\n"
 350                 if local_part_inuse $s;
 351             1;
 352         }) {
 353             my $newrow = { %$template, 'localpart' => $s };
 354             insertrow($newrow);
 355             $dbh->commit();
 356             prow($newrow);
 357         } else {
 358             $dbh->rollback();
 359             print "! error: $@" or die $!;
 360         }
 361     }
 362 }
 363
 364 sub selectrow ($) {
 365     my ($localpart) = @_;
 366     our $row_q ||= $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
 367     $row_q->execute($localpart);
 368     return $row_q->fetchrow_hashref();
 369 }
 370
 371 sub begin_row ($) {
 372     my ($localpart) = @_;
 373     my $q = $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
 374     my $row = selectrow $localpart;
 375     die "unknown localpart\n" unless defined $row;
 376     die "not owned by you\n" unless $priv || $row->{user} eq $user;
 377     return $row;
 378 }
 379
 380 sub action_update {
 381     my $localpart = nextarg_addr;
 382     my $updrow = rhsargs({});
 383     nomoreargs;
 384     begin_row($localpart);
 385     foreach my $f (qw(redirect comment)) {
 386         my $v = $updrow->{$f};
 387         next unless defined $v;
 388         $dbh->do("UPDATE addrs SET $f=? WHERE localpart=?",
 389                  {}, $v, $localpart);
 390     }
 391     my $row = selectrow $localpart;
 392     $dbh->commit;
 393     prow($row);
 394 }
 395
 396 sub action_show {
 397     my $localpart = nextarg_addr;
 398     nomoreargs;
 399     my $row = begin_row($localpart);
 400     prow($row);
 401 }
 402
 403 sub listq ($) {
 404     my ($q) = @_;
 405     while (my $row = $q->fetchrow_hashref()) {
 406         prow($row);
 407     }
 408 }
 409
 410 sub action_list {
 411     nomoreargs;
 412     my $q = $dbh->prepare("SELECT * FROM addrs WHERE user=?".
 413                           " ORDER BY localpart");
 414     $q->execute($user);
 415     listq($q);
 416 }
 417
 418 sub action_list_user {
 419     die unless $priv;
 420     $user = nextarg;
 421     nomoreargs;
 422     action_list;
 423 }
 424
 425 sub action_list_all {
 426     die unless $priv;
 427     nomoreargs;
 428     my $q = $dbh->prepare("SELECT * FROM addrs".
 429                           " ORDER BY user, localpart");
 430     $q->execute();
 431     listq($q)
 432 }
 433
 434 sub action_insert_exact {
 435     die unless $priv;
 436     my $row = { };
 437     $row->{'localpart'} = nextarg_addr;
 438     $row->{'user'} = $user = nextarg;
 439     $row->{'redirect'} = nextarg;
 440     $row->{'comment'} = nextarg;
 441     nomoreargs;
 442     insertrow($row);
 443     $dbh->commit;
 444 }
 445
 446 sub action_donate {
 447     die unless $priv;
 448     my $localpart = nextarg_addr;
 449     my $newuser = nextarg;
 450     nomoreargs;
 451     begin_row($localpart);
 452     $dbh->do('UPDATE addrs SET user=? WHERE localpart=?',
 453              {}, $newuser, $localpart);
 454     $dbh->commit;
 455 }
 456
 457 sub action_enable_user {
 458     die unless $priv;
 459     $user = nextarg;
 460     nomoreargs;
 461     $dbh->do('DELETE FROM disabled_users WHERE user=?',{},$user);
 462     $dbh->commit;
 463 }
 464
 465 sub action_disable_user {
 466     die unless $priv;
 467     $user = nextarg;
 468     nomoreargs;
 469     $dbh->do('INSERT INTO disabled_users VALUES user (?)',{},$user);
 470     $dbh->commit;
 471 }
 472
 473 sub action_list_actions {
 474     print $usage2 or die $!;
 475     print "genopts\n" or die $!;
 476     print $usage_genopts{$genmethod} or die $!;
 477 }
 478
 479 while (@ARGV) {
 480     last unless $ARGV[0] =~ m/^-/;
 481     $_ = shift @ARGV;
 482     last if m/^--?$/;
 483     for (;;) {
 484         last unless m/^-./;
 485         if (s/^-l(\d+)$//) {
 486             $minrandlength = $1;
 487         } elsif (s/^-m(\d+)$//) {
 488             $maxperuser = $1;
 489         } elsif (s/^-d(\S+)$//) {
 490             $dom = $1;
 491         } elsif (s/^-q(\S+)$//) {
 492             $qualdom = $1;
 493         } elsif (s/^-Wf(\S+)$//) {
 494             $wordlist = $1;
 495             $genmethod = 'wordlist';
 496         } elsif (s/^-WF(\d+)$//) {
 497             $minwordlistlen = $1;
 498         } elsif (s/^-Wl(\d+)$//) {
 499             $minnumwords = $1;
 500         } elsif (s/^-WL([0-9.]+)$//) {
 501             $minmaxmeanwordlen = $1;
 502         } elsif (s/^-C/-/) {
 503             $showcomment = 1;
 504         } elsif (s/^-h/-/) {
 505             print $usage1.$usage2.$usage3 or die $!;
 506             foreach my $meth (qw(alphanum wordlist)) {
 507                 print "genopts for $meth generation method\n" or die $!;
 508                 print $usage_genopts{$meth} or die $!;
 509             }
 510             exit 0;
 511         } else {
 512             die "unknown option \`$_'\n";
 513         }
 514     }
 515 }
 516
 517 my $dbfile = nextarg();
 518
 519 if (defined $ENV{'USERV_USER'}) {
 520     $priv=0;
 521     $user = $ENV{'USERV_USER'};
 522 } else {
 523     $priv=1;
 524     $user = ((getpwuid $<)[0]) or die;
 525 }
 526
 527 $usage2 .= defined $dom
 528     ? "addr may be a local part, implicitly qualified with \@$dom\n"
 529     : "addr must be a local part (only)\n";
 530 $usage2 .= "redirect is implicitly qualified with \@$qualdom".
 531     " if it has no \@\n"
 532     if defined $qualdom;
 533
 534 $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","",
 535                     { PrintError => 0, AutoCommit => 0, RaiseError => 1 })
 536     or die "$dbfile $!";
 537
 538 my $action = nextarg();
 539 $action =~ y/-/_/;
 540 { no strict qw(refs); &{"action_$action"}(); }