service

   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 too late 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         " your maximum length specified $maxdomainlen\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     my $template = rhsargs({'redirect'=>$user, 'comment'=>''});
 324     $template->{'user'} = $user;
 325     prepare_create();
 326     puser($user);
 327     my %s;
 328     while (keys %s < 10) {
 329         my $s = generate_local_part();
 330         next if $s{$s};
 331         print $s or die $!;
 332         print "\@$dom" or die $! if $dom;
 333         print "\n" or die $!;
 334         $s{$s} = 1;
 335     }
 336     print "# ready - enter addrs or local-parts to create,".
 337         " then \`.' on a line by itself\n"
 338         or die $!;
 339
 340     while (<STDIN>) {
 341         chomp;
 342         last if m/^\.$/;
 343         my $s;
 344         if (eval {
 345             $s = addr2localpart $_;
 346             $s{$s} or die "not an (as-yet-unused) suggestion\n";
 347             delete $s{$s};
 348             die "just taken in the meantime (bad luck!)\n"
 349                 if local_part_inuse $s;
 350             1;
 351         }) {
 352             my $newrow = { %$template, 'localpart' => $s };
 353             $dbh->commit();
 354             prow($newrow);
 355         } else {
 356             $dbh->rollback();
 357             print "! error: $@" or die $!;
 358         }
 359     }
 360 }
 361
 362 sub selectrow ($) {
 363     my ($localpart) = @_;
 364     our $row_q ||= $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
 365     $row_q->execute($localpart);
 366     return $row_q->fetchrow_hashref();
 367 }
 368
 369 sub begin_row ($) {
 370     my ($localpart) = @_;
 371     my $q = $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
 372     my $row = selectrow $localpart;
 373     die "unknown localpart\n" unless defined $row;
 374     die "not owned by you\n" unless $priv || $row->{user} eq $user;
 375     return $row;
 376 }
 377
 378 sub action_update {
 379     my $localpart = nextarg_addr;
 380     my $updrow = rhsargs({});
 381     nomoreargs;
 382     begin_row($localpart);
 383     foreach my $f (qw(redirect comment)) {
 384         my $v = $updrow->{$f};
 385         next unless defined $v;
 386         $dbh->do("UPDATE addrs SET $f=? WHERE localpart=?",
 387                  {}, $v, $localpart);
 388     }
 389     my $row = selectrow $localpart;
 390     $dbh->commit;
 391     prow($row);
 392 }
 393
 394 sub action_show {
 395     my $localpart = nextarg_addr;
 396     nomoreargs;
 397     my $row = begin_row($localpart);
 398     prow($row);
 399 }
 400
 401 sub listq ($) {
 402     my ($q) = @_;
 403     while (my $row = $q->fetchrow_hashref()) {
 404         prow($row);
 405     }
 406 }
 407
 408 sub action_list {
 409     nomoreargs;
 410     my $q = $dbh->prepare("SELECT * FROM addrs WHERE user=?".
 411                           " ORDER BY localpart");
 412     $q->execute($user);
 413     listq($q);
 414 }
 415
 416 sub action_list_user {
 417     die unless $priv;
 418     $user = nextarg;
 419     nomoreargs;
 420     action_list;
 421 }
 422
 423 sub action_list_all {
 424     die unless $priv;
 425     nomoreargs;
 426     my $q = $dbh->prepare("SELECT * FROM addrs".
 427                           " ORDER BY user, localpart");
 428     $q->execute();
 429     listq($q)
 430 }
 431
 432 sub action_insert_exact {
 433     die unless $priv;
 434     my $row = { };
 435     $row->{'localpart'} = nextarg_addr;
 436     $row->{'user'} = $user = nextarg;
 437     $row->{'redirect'} = nextarg;
 438     $row->{'comment'} = nextarg;
 439     nomoreargs;
 440     insertrow($row);
 441     $dbh->commit;
 442 }
 443
 444 sub action_donate {
 445     die unless $priv;
 446     my $localpart = nextarg_addr;
 447     my $newuser = nextarg;
 448     nomoreargs;
 449     begin_row($localpart);
 450     $dbh->do('UPDATE addrs SET user=? WHERE localpart=?',
 451              {}, $newuser, $localpart);
 452     $dbh->commit;
 453 }
 454
 455 sub action_enable_user {
 456     die unless $priv;
 457     $user = nextarg;
 458     nomoreargs;
 459     $dbh->do('DELETE FROM disabled_users WHERE user=?',{},$user);
 460     $dbh->commit;
 461 }
 462
 463 sub action_disable_user {
 464     die unless $priv;
 465     $user = nextarg;
 466     nomoreargs;
 467     $dbh->do('INSERT INTO disabled_users VALUES user (?)',{},$user);
 468     $dbh->commit;
 469 }
 470
 471 sub action_list_actions {
 472     print $usage2 or die $!;
 473     print "genopts\n" or die $!;
 474     print $usage_genopts{$genmethod} or die $!;
 475 }
 476
 477 while (@ARGV) {
 478     last unless $ARGV[0] =~ m/^-/;
 479     $_ = shift @ARGV;
 480     last if m/^--?$/;
 481     for (;;) {
 482         last unless m/^-./;
 483         if (s/^-l(\d+)$//) {
 484             $minrandlength = $1;
 485         } elsif (s/^-m(\d+)$//) {
 486             $maxperuser = $1;
 487         } elsif (s/^-d(\S+)$//) {
 488             $dom = $1;
 489         } elsif (s/^-q(\S+)$//) {
 490             $qualdom = $1;
 491         } elsif (s/^-Wf(\S+)$//) {
 492             $wordlist = $1;
 493             $genmethod = 'wordlist';
 494         } elsif (s/^-WF(\d+)$//) {
 495             $minwordlistlen = $1;
 496         } elsif (s/^-Wl(\d+)$//) {
 497             $minnumwords = $1;
 498         } elsif (s/^-WL([0-9.]+)$//) {
 499             $minmaxmeanwordlen = $1;
 500         } elsif (s/^-C/-/) {
 501             $showcomment = 1;
 502         } elsif (s/^-h/-/) {
 503             print $usage1.$usage2.$usage3 or die $!;
 504             foreach my $meth (qw(alphanum wordlist)) {
 505                 print "genopts for $meth generation method\n" or die $!;
 506                 print $usage_genopts{$meth} or die $!;
 507             }
 508             exit 0;
 509         } else {
 510             die "unknown option \`$_'\n";
 511         }
 512     }
 513 }
 514
 515 my $dbfile = nextarg();
 516
 517 if (defined $ENV{'USERV_USER'}) {
 518     $priv=0;
 519     $user = $ENV{'USERV_USER'};
 520 } else {
 521     $priv=1;
 522     $user = ((getpwuid $<)[0]) or die;
 523 }
 524
 525 $usage2 .= defined $dom
 526     ? "addr may be a local part, implicitly qualified with \@$dom\n"
 527     : "addr must be a local part (only)\n";
 528 $usage2 .= "redirect is implicitly qualified with \@$qualdom".
 529     " if it has no \@\n"
 530     if defined $qualdom;
 531
 532 $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","",
 533                     { PrintError => 0, AutoCommit => 0, RaiseError => 1 })
 534     or die "$dbfile $!";
 535
 536 my $action = nextarg();
 537 $action =~ y/-/_/;
 538 { no strict qw(refs); &{"action_$action"}(); }