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