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 END
  13 our $usage2 = <<'END';
  14 actions
  15   create [<genopts>] [<redirect>] [#<comment>]  (default redirect is username)
  16   choose [<genopts>] [<redirect>] [#<comment>]  (interactively allocate)
  17   update <addr> [<redirect>] [#<comment>]
  18   show <addr>
  19   list
  20   list-actions
  21 empty string for redirect means reject
  22 END
  23 our $usage3 = <<'END';
  24 privileged actions
  25   list-user <user>
  26   insert-exact <addr> <user> <redirect> <comment>
  27   donate <addr> <user>
  28   enable-user|disable-user <user>
  29 default generation method is alphanum
  30 END
  31 our %usage_genopts = (
  32 'alphanum' => <<END,
  33   -l<randlength>      (number of letters+digits)
  34 END
  35 );
  36 #/
  37
  38 use strict;
  39
  40 use DBI;
  41 use POSIX;
  42
  43 our $maxperuser = 10000;
  44 our $qualdom;
  45 our $dbh;
  46 our $dom;
  47 our $user;
  48 our $priv;
  49 our $showcomment;
  50 our $genmethod = 'alphanum';
  51
  52 # for alphanum
  53 #   options
  54 our $minrandlength = 6;
  55 our $maxrandlength = 100;
  56 #   genopts
  57 our $randlength;
  58
  59 sub nextarg () {
  60     die "too few arguments\n" unless @ARGV;
  61     my $v = shift @ARGV;
  62     die "option too late on command line\n" if $v =~ m/^-/;
  63     return $v;
  64 }
  65
  66 sub addr2localpart ($) {
  67     my ($addr) = @_;
  68     return $addr if $addr !~ m/\@/;
  69     die "address not in correct domain (\@$dom)\n" unless $' eq $dom; #';
  70     return $`; #`;
  71 }
  72
  73 sub nextarg_addr () {
  74     return addr2localpart nextarg;
  75 }
  76
  77 sub nomoreargs () {
  78     die "too many arguments\n" if @ARGV;
  79 }
  80
  81 sub isdisabled ($) {
  82     my ($u) = @_;
  83     our $dis_q;
  84     $dis_q ||= $dbh->prepare("SELECT * FROM disabled_users WHERE user=?");
  85     $dis_q->execute($u);
  86     my $row = $dis_q->fetchrow_arrayref();
  87     return !!$row;
  88 }
  89
  90 sub puser ($) {
  91     my ($u) = @_;
  92     our $last_u;
  93     if (!defined $last_u or $last_u ne $u) {
  94         print "# user $u ".(isdisabled($u) ? 'disabled' : 'enabled')."\n";
  95         $last_u = $u;
  96     }
  97 }
  98
  99 sub prow ($) {
 100     my ($row) = @_;
 101     my $u = $row->{'user'};
 102     puser($u);
 103     my $pa = $row->{'localpart'};
 104     $pa .= '@'.$dom if defined $dom;
 105     if (length $row->{'redirect'}) {
 106         print "$pa: $row->{'redirect'}" or die $!;
 107     } else {
 108         print "# reject $pa" or die $!;
 109     }
 110     if ($showcomment || !$priv) {
 111         print " #$row->{'comment'}" or die $!;
 112     }
 113     print "\n" or die $!;
 114 }
 115
 116 sub goodrand ($) {
 117     my ($lim) = @_;
 118     for (;;) {
 119         my $ch;
 120         read(R, $ch, 1) == 1 or die $!;
 121         my $o = ord $ch;
 122         my $v = $o % $lim;
 123         next unless $o-$v+$lim < 256;
 124 #       print STDERR "goodrand($lim)=$v\n";
 125         return $v;
 126     }
 127 }
 128
 129 sub qualify (\$) {
 130     my ($ref) = @_;
 131     if (defined $$ref && $$ref =~ m/[^\041-\177]/) {
 132         die "bad characters in redirection target\n";
 133     }
 134     if (defined $$ref && length $$ref && $$ref !~ m/\@/) {
 135         die "unqualified redirection target\n" unless defined $qualdom;
 136         $$ref .= '@'.$qualdom;
 137     }
 138 }
 139
 140 sub insertrow ($) {
 141     my ($row) = @_;
 142     my $stmt =
 143         "INSERT INTO addrs (".
 144         (join ",", sort keys %$row).
 145         ") VALUES (".
 146         (join ",", map { "?" } sort keys %$row).
 147         ") ";
 148     $dbh->do($stmt, {}, map { $row->{$_} } sort keys %$row);
 149 }
 150
 151 sub rhsargs ($) {
 152     my ($defrow) = @_;
 153     my $row = { };
 154     while (@ARGV) {
 155         $_ = shift @ARGV;
 156         my $f = (s/^\#// ? 'comment' : 'redirect');
 157         die "$f supplied twice\n" if exists $row->{$f};
 158         $row->{$f} = $_;
 159     }
 160     foreach my $f (keys %$defrow) {
 161         next if defined $row->{$f};
 162         $row->{$f} = $defrow->{$f};
 163     }
 164     qualify $row->{'redirect'};
 165     return $row;
 166 }
 167
 168 sub local_part_inuse ($) {
 169     my ($s) = @_;
 170     our $checkexist_q ||=
 171         $dbh->prepare("SELECT localpart FROM addrs WHERE localpart=?");
 172     $checkexist_q->execute($s);
 173     my $row = $checkexist_q->fetchrow_arrayref();
 174     return !!$row;
 175 }
 176
 177 sub gen_local_part_alphanum {
 178     my $s = chr(ord('a')+goodrand(26));
 179     while (length $s < $randlength) {
 180         my $v = goodrand(36);
 181         $s .= chr($v < 26
 182                   ? ord('a')+($v)
 183                   : ord('0')+($v-26));
 184     }
 185     return $s;
 186 }
 187
 188 sub generate_local_part () {
 189     my $s;
 190     for (;;) {
 191         { no strict qw(refs); $s = &{"gen_local_part_$genmethod"}; }
 192 #       print STDERR "$s\n";
 193         last if !local_part_inuse($s);
 194     }
 195     return $s;
 196 }
 197
 198 sub prepare_create () {
 199     my $countq = $dbh->prepare("SELECT count(*) FROM addrs WHERE user=?");
 200     $countq->execute($user);
 201     my ($count) = $countq->fetchrow_array();
 202     die unless defined $count;
 203     die "too many aliases for this user\n" if $count >= $maxperuser;
 204     open R, "/dev/urandom" or die $!;
 205     binmode R;
 206 }
 207
 208 sub genopt_alphanum {
 209     local ($_) = @_;
 210     if (m/^-l(\d+)$/) {
 211         $randlength = 0+$1;
 212         die "length out of range $minrandlength..$maxrandlength\n"
 213             unless ($minrandlength<=$randlength &&
 214                     $randlength<=$maxrandlength);
 215     } else {
 216         die "unknown alphanumeric generation option\n";
 217     }
 218 }
 219
 220 sub gendefaults_alphanum {
 221     $randlength ||= $minrandlength;
 222 }
 223
 224 sub genopts {
 225     while (@ARGV && $ARGV[0] =~ m/^-/) {
 226         my $arg = shift @ARGV;
 227         last if $arg =~ m/^--?$/;
 228         { no strict qw(refs); &{"genopt_$genmethod"}($arg); }
 229     }
 230     { no strict qw(refs); &{"gendefaults_$genmethod"}(); }
 231 }
 232
 233 sub action_create {
 234     genopts;
 235     my $newrow = rhsargs({'redirect'=>$user, 'comment'=>''});
 236     prepare_create();
 237     $newrow->{'user'} = $user;
 238     $newrow->{'localpart'} = generate_local_part();
 239     insertrow($newrow);
 240     $dbh->commit();
 241     prow($newrow);
 242 }
 243
 244 sub action_choose {
 245     genopts;
 246     my $template = rhsargs({'redirect'=>$user, 'comment'=>''});
 247     $template->{'user'} = $user;
 248     prepare_create();
 249     puser($user);
 250     my %s;
 251     while (keys %s < 10) {
 252         my $s = generate_local_part();
 253         next if $s{$s};
 254         print $s or die $!;
 255         print "\@$dom" or die $! if $dom;
 256         print "\n" or die $!;
 257         $s{$s} = 1;
 258     }
 259     print "# ready - enter addrs or local-parts to create,".
 260         " then \`.' on a line by itself\n"
 261         or die $!;
 262
 263     while (<STDIN>) {
 264         chomp;
 265         last if m/^\.$/;
 266         my $s;
 267         if (eval {
 268             $s = addr2localpart $_;
 269             $s{$s} or die "not an (as-yet-unused) suggestion\n";
 270             delete $s{$s};
 271             die "just taken in the meantime (bad luck!)\n"
 272                 if local_part_inuse $s;
 273             1;
 274         }) {
 275             my $newrow = { %$template, 'localpart' => $s };
 276             $dbh->commit();
 277             prow($newrow);
 278         } else {
 279             $dbh->rollback();
 280             print "! error: $@" or die $!;
 281         }
 282     }
 283 }
 284
 285 sub selectrow ($) {
 286     my ($localpart) = @_;
 287     our $row_q ||= $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
 288     $row_q->execute($localpart);
 289     return $row_q->fetchrow_hashref();
 290 }
 291
 292 sub begin_row ($) {
 293     my ($localpart) = @_;
 294     my $q = $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
 295     my $row = selectrow $localpart;
 296     die "unknown localpart\n" unless defined $row;
 297     die "not owned by you\n" unless $priv || $row->{user} eq $user;
 298     return $row;
 299 }
 300
 301 sub action_update {
 302     my $localpart = nextarg_addr;
 303     my $updrow = rhsargs({});
 304     nomoreargs;
 305     begin_row($localpart);
 306     foreach my $f (qw(redirect comment)) {
 307         my $v = $updrow->{$f};
 308         next unless defined $v;
 309         $dbh->do("UPDATE addrs SET $f=? WHERE localpart=?",
 310                  {}, $v, $localpart);
 311     }
 312     my $row = selectrow $localpart;
 313     $dbh->commit;
 314     prow($row);
 315 }
 316
 317 sub action_show {
 318     my $localpart = nextarg_addr;
 319     nomoreargs;
 320     my $row = begin_row($localpart);
 321     prow($row);
 322 }
 323
 324 sub listq ($) {
 325     my ($q) = @_;
 326     while (my $row = $q->fetchrow_hashref()) {
 327         prow($row);
 328     }
 329 }
 330
 331 sub action_list {
 332     nomoreargs;
 333     my $q = $dbh->prepare("SELECT * FROM addrs WHERE user=?".
 334                           " ORDER BY localpart");
 335     $q->execute($user);
 336     listq($q);
 337 }
 338
 339 sub action_list_user {
 340     die unless $priv;
 341     $user = nextarg;
 342     nomoreargs;
 343     action_list;
 344 }
 345
 346 sub action_list_all {
 347     die unless $priv;
 348     nomoreargs;
 349     my $q = $dbh->prepare("SELECT * FROM addrs".
 350                           " ORDER BY user, localpart");
 351     $q->execute();
 352     listq($q)
 353 }
 354
 355 sub action_insert_exact {
 356     die unless $priv;
 357     my $row = { };
 358     $row->{'localpart'} = nextarg_addr;
 359     $row->{'user'} = $user = nextarg;
 360     $row->{'redirect'} = nextarg;
 361     $row->{'comment'} = nextarg;
 362     nomoreargs;
 363     insertrow($row);
 364     $dbh->commit;
 365 }
 366
 367 sub action_donate {
 368     die unless $priv;
 369     my $localpart = nextarg_addr;
 370     my $newuser = nextarg;
 371     nomoreargs;
 372     begin_row($localpart);
 373     $dbh->do('UPDATE addrs SET user=? WHERE localpart=?',
 374              {}, $newuser, $localpart);
 375     $dbh->commit;
 376 }
 377
 378 sub action_enable_user {
 379     die unless $priv;
 380     $user = nextarg;
 381     nomoreargs;
 382     $dbh->do('DELETE FROM disabled_users WHERE user=?',{},$user);
 383     $dbh->commit;
 384 }
 385
 386 sub action_disable_user {
 387     die unless $priv;
 388     $user = nextarg;
 389     nomoreargs;
 390     $dbh->do('INSERT INTO disabled_users VALUES user (?)',{},$user);
 391     $dbh->commit;
 392 }
 393
 394 sub action_list_actions {
 395     print $usage2 or die $!;
 396     print "genopts\n" or die $!;
 397     print $usage_genopts{$genmethod} or die $!;
 398 }
 399
 400 while (@ARGV) {
 401     last unless $ARGV[0] =~ m/^-/;
 402     $_ = shift @ARGV;
 403     last if m/^--?$/;
 404     for (;;) {
 405         last unless m/^-./;
 406         if (s/^-l(\d+)$//) {
 407             $minrandlength = $1;
 408         } elsif (s/^-m(\d+)$//) {
 409             $maxperuser = $1;
 410         } elsif (s/^-d(\S+)$//) {
 411             $dom = $1;
 412         } elsif (s/^-q(\S+)$//) {
 413             $qualdom = $1;
 414         } elsif (s/^-C/-/) {
 415             $showcomment = 1;
 416         } elsif (s/^-h/-/) {
 417             print $usage1.$usage2.$usage3 or die $!;
 418             foreach my $meth (qw(alphanum)) {
 419                 print "genopts for $meth generation method\n" or die $!;
 420                 print $usage_genopts{$meth} or die $!;
 421             }
 422             exit 0;
 423         } else {
 424             die "unknown option \`$_'\n";
 425         }
 426     }
 427 }
 428
 429 my $dbfile = nextarg();
 430
 431 if (defined $ENV{'USERV_USER'}) {
 432     $priv=0;
 433     $user = $ENV{'USERV_USER'};
 434 } else {
 435     $priv=1;
 436     $user = ((getpwuid $<)[0]) or die;
 437 }
 438
 439 $usage2 .= defined $dom
 440     ? "addr may be a local part, implicitly qualified with \@$dom\n"
 441     : "addr must be a local part (only)\n";
 442 $usage2 .= "redirect is implicitly qualified with \@$qualdom".
 443     " if it has no \@\n"
 444     if defined $qualdom;
 445
 446 $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","",
 447                     { PrintError => 0, AutoCommit => 0, RaiseError => 1 })
 448     or die "$dbfile $!";
 449
 450 my $action = nextarg();
 451 $action =~ y/-/_/;
 452 { no strict qw(refs); &{"action_$action"}(); }