chiark - git - mdw - odin-cgi/blob - lib/Odin.pm

   1 ### -*-perl-*-
   2
   3 package Odin;
   4
   5 use DBI;
   6 use Date::Parse;
   7 use Digest::SHA qw(sha256_hex);
   8 use MIME::Base64;
   9 use POSIX;
  10
  11 ###--------------------------------------------------------------------------
  12 ### Early utilities.
  13
  14 sub merge_hash (\%%) {
  15   my ($hashref, %defaults) = @_;
  16   for my $k (keys %defaults)
  17     { $hashref->{$k} = $defaults{$k} unless exists $hashref->{$k}; }
  18 }
  19
  20 ###--------------------------------------------------------------------------
  21 ### Configuration.
  22
  23 our $DSN = "dbi:Pg(pg_enable_utf8=>1):host=db";
  24 our $RETRY = 10;
  25 our @BACKOFF = (0.1, 10, 1.5, 0.5, 2.0);
  26
  27 our $BASEURL = "https://odin.gg/";
  28 our $STATIC = "https://odin.gg/static/";
  29
  30 our $SHORTURL_PATH = "u";
  31 our $PASTEBIN_PATH = "p";
  32
  33 our $URLMAXLEN = 1024;
  34 our @URLPAT = (
  35   qr{^https?://}
  36 );
  37
  38 our $PASTEMAXLEN = 1024*1024;
  39
  40 our %COOKIE_DEFAULTS = (
  41   -httponly => undef,
  42   -max_age => 3600
  43 );
  44
  45 our $ALPHA = "abcdefghijklmnopqrstuvwxyz";
  46 our $NUM = "0123456789";
  47 our $SAFECH = qr/^[-\w_.+]*$/;
  48
  49 our %GENPARAM = ();
  50 our %GENMAP = ();
  51 our %MAILDOM_POLICY = ();
  52 our $MAIL_QUALDOM;
  53
  54 our @MAIL_DEFGEN = "chars";
  55 our $MAIL_MAXGENTRY = 32;
  56
  57 our $MAIL_DEFDOMAIN = "odin.gg";
  58 our $MAIL_ADDRMAX_LIVE = 16384;
  59 our $MAIL_ADDRMAX_RESV = 32;
  60 our $MAIL_AGEMAX_RESV = 3600;
  61
  62 our ($SCHEME, $DOMAIN, $BASEPATH);
  63 our ($SHORTURL, $PASTEBIN);
  64
  65 ###--------------------------------------------------------------------------
  66 ### Miscellaneous utilities.
  67
  68 our $NOW;
  69 sub update_now () { $NOW = time; }
  70 update_now;
  71
  72 (our $PROG = $0) =~ s:^.*/::;
  73
  74 sub fail_cmdline ($$%) {
  75   my ($msg, $label, %args) = @_;
  76   print STDERR "$PROG: $msg\n";
  77   exit 1;
  78 }
  79
  80 our $FAILPROC = \&fail_cmdline;
  81
  82 sub fail ($;$%) {
  83   my ($msg, $label, %args) = @_;
  84   $FAILPROC->($msg, $label, %args);
  85 }
  86
  87 sub set_mason_failproc ($) {
  88   my ($m) = @_;
  89   $FAILPROC = sub {
  90     my ($msg, $label, %args) = @_;
  91     $m->clear_buffer;
  92     $m->comp($label, %args);
  93     $m->abort;
  94   };
  95 }
  96
  97 sub nice_name ($) {
  98   my ($s) = @_;
  99   $s =~ s/\W+//g;
 100   return lc $s;
 101 }
 102
 103 my %TIMEUNIT = (
 104   "" => 1,
 105   "s" => 1, "m" => 60, "h" => 3600,
 106   "d" => 86400, "w" => 604800
 107 );
 108 sub parse_time ($) {
 109   my ($date) = @_;
 110   return undef unless defined $date;
 111   if ($date =~ /^\+\s*(\d+)\s*([smhdw]?)\s*$/)
 112     { return $NOW + $1 * $TIMEUNIT{$2}; }
 113   my $t = str2time($date);
 114   defined $t or Odin::fail "invalid time `$date'";
 115   return $t;
 116 }
 117
 118 sub print_columns (@) {
 119   my @col = reverse @_;
 120   my @fmt = ();
 121   my @val = ();
 122   while (@col && $col[1] eq "") { splice @col, 0, 2; }
 123   my ($wd, $v) = splice @col, 0, 2;
 124   push @fmt, "%s"; push @val, $v;
 125   while (@col) {
 126     my ($wd, $v) = splice @col, 0, 2;
 127     push @fmt, "%-${wd}s";
 128     push @val, $v;
 129   }
 130   printf join("  ", reverse @fmt) . "\n", reverse @val;
 131 }
 132
 133 sub fmt_time ($) {
 134   my ($t) = @_;
 135   return $t == -1 ? "--" : strftime "%Y-%m-%d %H:%M:%S %z", localtime $t;
 136 }
 137
 138 ###--------------------------------------------------------------------------
 139 ### Database utilities.
 140
 141 sub open_db (@) {
 142   my @attr = @_;
 143   my $db = DBI->connect_cached($DSN, undef, undef, {
 144     PrintError => 0,
 145     RaiseError => 1,
 146     @attr
 147   });
 148
 149   my $drv = $db->{Driver}{Name};
 150   if ($drv eq "Pg") {
 151     $db->{private_odin_retry_p} = sub { $db->state =~ /^40[0P]01$/ };
 152   } elsif ($drv eq "SQLite") {
 153     $db->{private_odin_retry_p} = sub { $db->err == 5 };
 154   } else {
 155     $db->{private_odin_retry_p} = sub { 0 };
 156   }
 157
 158   return $db;
 159 }
 160
 161 sub xact (&$) {
 162   my ($body, $db) = @_;
 163   my @rv;
 164   my $exc;
 165
 166   my ($sleep, $maxsleep, $mult, $minvar, $maxvar) = @BACKOFF;
 167   for (my $i = 0; $i < $RETRY; $i++) {
 168     $db->begin_work;
 169     eval { @rv = $body->(); $db->commit; };
 170     $exc = $@;
 171     return @rv unless $exc;
 172     my $retryp = $db->{private_odin_retry_p}();
 173     eval { $db->rollback; };
 174     die $exc unless $retryp;
 175     my $t = $sleep * ($minvar + rand($maxvar - $minvar));
 176     $sleep *= $mult; $sleep = $max if $sleep > $max;
 177     select undef, undef, undef, $t;
 178   }
 179   die $exc;
 180 }
 181
 182 sub insert_record ($$%) {
 183   my ($db, $table, %fields) = @_;
 184   my @var = ();
 185   my @val = ();
 186
 187   for my $v (keys %fields) {
 188     push @var, $v;
 189     push @val, $fields{$v};
 190   }
 191   $db->do("INSERT INTO $table (" . join(", ", @var) . ")
 192            VALUES (" . join(", ", map { "?" } @var) . ")", undef, @val);
 193 }
 194
 195 ###--------------------------------------------------------------------------
 196 ### Sequence numbers and tagging.
 197
 198 sub next_seq ($$) {
 199   my ($db, $table) = @_;
 200   my ($seq) = $db->selectrow_array("SELECT seq FROM $table");
 201   die "no sequence number in $table" unless defined $seq;
 202   $db->do("UPDATE $table SET seq = ?", undef, $seq + 1);
 203   return $seq;
 204 }
 205
 206 my $ALPHABET =
 207   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789";
 208 my $NALPHA = length $ALPHABET;
 209
 210 sub encode_tag ($) {
 211   my ($seq) = @_;
 212   my $tag = "";
 213   while ($seq) {
 214     $tag .= substr($ALPHABET, $seq % $NALPHA, 1);
 215     $seq = int $seq/$NALPHA;
 216   }
 217   return $tag;
 218 }
 219
 220 ###--------------------------------------------------------------------------
 221 ### HTTP utilities.
 222
 223 our %COOKIE;
 224 sub fetch_cookies ($) {
 225   my ($r) = @_;
 226
 227   %COOKIE = ();
 228   my $cookies = $r->header_in("Cookie");
 229   if (defined $cookies) {
 230     for my $kv (split /;/, $cookies) {
 231       my ($k, $v) = split /=/, $kv, 2;
 232       $k =~ s/^\s*(|\S|\S.*\S)\s*$/$1/;
 233       $v =~ s/^\s*(|\S|\S.*\S)\s*$/$1/;
 234       $v =~ s/\+/ /g;
 235       $v =~ s/\%([0-9a-f][0-9a-f])/chr hex $1/eg;
 236       $COOKIE{$k} = $v;
 237     }
 238   }
 239 }
 240
 241 sub bake_cookie ($$%) {
 242   my ($r, $cookie, %attr) = @_;
 243   merge_hash %attr, %COOKIE_DEFAULTS;
 244   my @attr = map {
 245     my $v = $attr{$_}; tr/_-/-/d;
 246     defined $v ? "$_=$v" : $_
 247   } keys %attr;
 248   $r->headers_out->add("Set-Cookie", join "; ", $cookie, @attr);
 249 }
 250
 251 sub path_info ($) {
 252   my ($r) = @_;
 253   return $ENV{PATH_INFO} // $r->path_info;
 254 }
 255
 256 ###--------------------------------------------------------------------------
 257 ### HTML utilities.
 258
 259 sub escapify ($$;$) {
 260   my ($m, $s, $mode) = @_;
 261   return $m->interp->apply_escapes($s, $mode // "h");
 262 }
 263
 264 ###--------------------------------------------------------------------------
 265 ### Access control.
 266
 267 our ($WHO, $WHOSURE);
 268 our ($WHOMATCH, $WHOCMP, $WHOPAT);
 269
 270 sub cgi_who ($) {
 271   my ($r) = @_;
 272   my $raddr = $ENV{REMOTE_ADDR} // $r->connection->remote_ip;
 273   $WHO = ":NET-$raddr"; $WHOSURE = 0;
 274   $WHOMATCH = "LIKE"; $WHOCMP = ":NET-\%"; $WHOPAT = qr/^:NET-/;
 275 }
 276
 277 sub cmdline_who () {
 278   $WHO = $ENV{USERV_USER}
 279     // ($< == $> && $ENV{USER})
 280     // @{[getpwuid $<]}[0]
 281     // die "nameless user";
 282   $WHOMATCH = "="; $WHOCMP = $WHO; $WHOPAT = qr/^\Q$WHO\E$/;
 283   $WHOSURE = 1;
 284 }
 285
 286 sub new_editkey () {
 287   open my $fh, "/dev/urandom" or die "open urandom: $!";
 288   sysread $fh, my $rand, 16;
 289   (my $edit = encode_base64 $rand) =~ tr:+/=\n:.-:d;
 290   return $edit, sha256_hex $edit;
 291 }
 292
 293 ###--------------------------------------------------------------------------
 294 ### URL shortening.
 295
 296 sub get_shorturl ($) {
 297   my ($tag) = @_;
 298
 299   my $db = open_db;
 300   my ($url) = $db->selectrow_array
 301     ("SELECT url FROM odin_shorturl WHERE tag = ?", undef, $tag);
 302   fail "tag `$tag' not found", ".notfound", tag => $tag unless defined $url;
 303   return $url;
 304 }
 305
 306 sub valid_url_p ($) {
 307   my ($url) = @_;
 308   return
 309     length $url < $URLMAXLEN &&
 310     scalar grep { $url =~ /$_/ } @URLPAT;
 311 }
 312
 313 sub new_shorturl ($) {
 314   my ($url) = @_;
 315
 316   valid_url_p $url or fail "invalid url", ".badurl", u => $url;
 317
 318   my $db = open_db;
 319   my $tag;
 320   xact {
 321     ($tag) = $db->selectrow_array
 322       ("SELECT tag FROM odin_shorturl WHERE owner $WHOMATCH ? AND url = ?",
 323        undef, $WHOCMP, $url);
 324     unless (defined $tag) {
 325       $tag = encode_tag(next_seq($db, "odin_shorturl_seq"));
 326       insert_record $db, "odin_shorturl",
 327         tag => $tag, stamp => $NOW, owner => $WHO, url => $url;
 328     }
 329   } $db;
 330   return $tag;
 331 }
 332
 333 sub check_shorturl_owner ($$) {
 334   my ($db, $tag) = @_;
 335
 336   my ($owner) = $db->selectrow_array
 337     ("SELECT owner FROM odin_shorturl WHERE tag = ?", undef, $tag);
 338   fail "tag `$tag' not found", ".notfound", tag => $tag
 339     unless defined $owner;
 340   fail "not owner of `$tag'", ".notowner", tag => $tag
 341     unless $owner =~ /$WHOPAT/;
 342 }
 343
 344 sub update_shorturl ($$) {
 345   my ($tag, $url) = @_;
 346
 347   my $db = open_db;
 348   xact {
 349     check_shorturl_owner $db, $tag;
 350     $db->do("UPDATE odin_shorturl SET url = ? WHERE tag = ?",
 351             undef, $url, $tag);
 352   } $db;
 353 }
 354
 355 sub delete_shorturl (@) {
 356   my (@tags) = @_;
 357
 358   my $db = open_db;
 359   xact {
 360     for my $tag (@tags) {
 361       check_shorturl_owner $db, $tag;
 362       $db->do("DELETE FROM odin_shorturl WHERE tag = ?", undef, $tag);
 363     }
 364   } $db;
 365 }
 366
 367 ###--------------------------------------------------------------------------
 368 ### Paste bin.
 369
 370 our %PASTEBIN_DEFAULTS = (
 371   title => "(untitled)",
 372   lang => "txt",
 373   content => ""
 374 );
 375 our @PASTEBIN_PROPS = keys %PASTEBIN_DEFAULTS;
 376 our $PASTEBIN_PROPCOLS = join ", ", @PASTEBIN_PROPS;
 377 our $PASTEBIN_PROPPLACES = join ", ", map "?", @PASTEBIN_PROPS;
 378
 379 sub check_lang ($) {
 380   my ($lang) = @_;
 381
 382   return unless defined $lang;
 383   my $db = open_db;
 384   @{$db->selectall_arrayref
 385     ("SELECT lang FROM odin_pastebin_lang WHERE lang = ?", undef, $lang)}
 386     or fail "unknown language `$lang'";
 387 }
 388
 389 sub new_pastebin (\%) {
 390   my ($new) = @_;
 391
 392   my $db = open_db;
 393   my ($editkey, $hash) = new_editkey;
 394   my $tag;
 395
 396   merge_hash %$new, %PASTEBIN_DEFAULTS;
 397   check_lang $new->{lang};
 398   xact {
 399     $tag = encode_tag next_seq $db, "odin_pastebin_seq";
 400     insert_record $db, "odin_pastebin",
 401       tag => $tag, stamp => $NOW, edithash => $hash, owner => $WHO,
 402       %$new;
 403   } $db;
 404   return $tag, $editkey;
 405 }
 406
 407 sub get_pastebin ($$\%) {
 408   my ($db, $tag, $props) = @_;
 409
 410   (my $owner, my $hash, @{$props}{@PASTEBIN_PROPS}) =
 411     $db->selectrow_array("SELECT owner, edithash, $PASTEBIN_PROPCOLS
 412                           FROM odin_pastebin WHERE tag = ?",
 413                          undef, $tag);
 414   fail "tag `$tag' not found", ".notfound", tag => $tag
 415     unless defined $owner;
 416   return $owner, $hash;
 417 }
 418
 419 sub get_pastebin_check_owner ($$\%) {
 420   my ($db, $tag, $props) = @_;
 421
 422   my ($owner, $hash) = get_pastebin $db, $tag, %$props;
 423   fail "not owner of `$tag'", ".notowner", tag => $tag
 424     unless $WHOSURE && $WHO eq $owner;
 425 }
 426
 427 sub get_pastebin_check_editkey_or_owner ($$$\%) {
 428   my ($db, $tag, $editkey, $props) = @_;
 429
 430   if (!defined $editkey) { get_pastebin_check_owner $db, $tag, %$props; }
 431   else {
 432     my ($owner, $hash) = get_pastebin $db, $tag, %$props;
 433     fail "incorrect edit key for `$tag'", ".badhash", tag => $tag
 434       unless $hash eq sha256_hex $editkey;
 435   }
 436 }
 437
 438 sub rekey_pastebin ($) {
 439   my ($tag) = @_;
 440
 441   my $db = open_db;
 442   my $editkey;
 443   xact {
 444     get_pastebin_check_owner $db, $tag, my %hunoz;
 445     ($editkey, my $hash) = new_editkey;
 446     $db->do("UPDATE odin_pastebin SET edithash = ? WHERE tag = ?",
 447             undef, $hash, $tag);
 448   } $db;
 449   return $editkey;
 450 }
 451
 452 sub claim_pastebin ($$) {
 453   my ($tag, $editkey) = @_;
 454
 455   my $db = open_db;
 456   $WHOSURE or fail "you can't claim pastes", ".notsure";
 457   xact {
 458     get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
 459     $db->do("UPDATE odin_pastebin SET owner = ? WHERE tag = ?",
 460             undef, $WHO, $tag);
 461   } $db;
 462 }
 463
 464 sub update_pastebin ($$\%) {
 465   my ($tag, $editkey, $new) = @_;
 466
 467   my $db = open_db;
 468   my $editp = 0;
 469   check_lang $new->{lang};
 470   xact {
 471     get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %old;
 472     for my $p (@PASTEBIN_PROPS) {
 473       if (!defined $new->{$p}) { $new->{$p} = $old{$p}; }
 474       else {
 475         $db->do("UPDATE odin_pastebin SET $p = ? WHERE tag = ?",
 476                 undef, $new->{$p}, $tag)
 477           unless $new->{$p} eq $old{$p};
 478         $editp = 1;
 479       }
 480     }
 481   } $db;
 482   return $editp;
 483 }
 484
 485 sub delete_pastebin (@) {
 486   my @a = @_;
 487   my $db = open_db;
 488   xact {
 489     while (@a) {
 490       (my $tag, my $editkey, @a) = @a;
 491       get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
 492       $db->do("DELETE FROM odin_pastebin WHERE tag = ?", undef, $tag);
 493     }
 494   } $db;
 495 }
 496
 497 sub tidy_pastebin_content ($) {
 498   my ($content) = @_;
 499   return undef unless defined $content;
 500   $content =~ tr/\r//d;
 501   $content =~ s/([^\n])\z/$1\n/;
 502   length $content <= $PASTEMAXLEN or
 503     fail "invalid paste content", ".badpaste";
 504   return $content;
 505 }
 506
 507 ###--------------------------------------------------------------------------
 508 ### Mail redirection utilities.
 509
 510 sub redir_query ($$$;$@) {
 511   my ($db, $dom, $owner, $cond, @args) = @_;
 512   return @{$db->selectall_arrayref
 513              ("SELECT lpart, expire, recip, comment
 514                FROM odin_mailredir WHERE dom = ? AND owner = ?" .
 515                (defined $cond ? " AND $cond" : "") . " " .
 516               "ORDER BY expire, lpart", undef, $dom, $owner, @args)};
 517 }
 518
 519 sub clear_redir_reservations ($) {
 520   my ($db) = @_;
 521   $db->do("DELETE FROM odin_mailredir WHERE
 522            st = 'reserved' AND expire < ?", undef,
 523           $NOW);
 524   $db->do("UPDATE odin_mailredir SET st = 'dormant', expire = -1
 525            WHERE st = 'live' AND expire <> -1 AND expire < ?", undef, $NOW);
 526 }
 527
 528 sub check_redir_limits ($) {
 529   my ($db) = @_;
 530   my %h = map { $_->[0] => $_->[1] }
 531     @{ $db->selectall_arrayref("SELECT st, COUNT(*) FROM odin_mailredir
 532                                 WHERE owner = ? GROUP BY st", undef,
 533                                $Odin::WHO) };
 534   for my $st (qw(live dormant reserved)) { $h{$st} //= 0; }
 535   $h{live} + $h{dormant} + $h{reserved} <= $MAIL_ADDRMAX_LIVE or
 536     Odin::fail "too many addresses claimed (see your sysadmin)";
 537   $h{reserved} <= $MAIL_ADDRMAX_RESV or
 538     Odin::fail "too many addresses reserved (time to release some)";
 539 }
 540
 541 sub gencls ($) {
 542   my ($g) = @_;
 543   return $GENMAP{$g} // die "configuration error: no generator class `$g'";
 544 }
 545
 546 sub default_generator_class ($) {
 547   my ($dom) = @_;
 548
 549   my $g = $MAILDOM_POLICY{$dom}{gen}[0] // $MAIL_DEFGEN[0];
 550   return gencls $g;
 551 }
 552
 553 sub get_generator_class ($$) {
 554   my ($dom, $g) = @_;
 555
 556   grep { $_ eq $g } @{$MAILDOM_POLICY{$dom}{gen} // \@MAIL_DEFGEN}
 557     or fail "domain `$dom' doesn't allow generator `$g'";
 558   return gencls $g;
 559 }
 560
 561 sub gen_redir_name ($$) {
 562   my ($db, $gen) = @_;
 563
 564   for (my $try = 0; $try < $MAIL_MAXGENTRY; $try++) {
 565     my $l = lc $gen->gen;
 566     return $l
 567       unless $db->selectrow_arrayref
 568         ("SELECT 1 FROM odin_mailredir WHERE lpart = ? AND dom = ?",
 569          undef, $l, $DOMAIN);
 570   }
 571   Odin::fail "failed to find unique local part";
 572 }
 573
 574 sub qualify_recip ($) {
 575   my ($r) = @_;
 576
 577   return $r =~ /\@/ || !defined $MAIL_QUALDOM ? $r : "$r\@\%d";
 578 }
 579
 580 sub check_fixup_redir ($) {
 581   my ($r) = @_;
 582
 583   if (exists $r->{recip}) {
 584     $r->{recip} =~ /^[!-~]+$/ or fail "invalid recipient name `$r->{recip}'";
 585     $r->{recip} = qualify_recip $r->{recip};
 586   }
 587 }
 588
 589 sub subst_recip ($$) {
 590   my ($l, $r) = @_;
 591   my %d = ('%' => '%', 'l' => $l, 'd' => $MAIL_QUALDOM);
 592   $r =~ s{%([%a-z])}{$d{$1} // fail "undefined substitution `\%$1'"}eg;
 593   return $r;
 594 }
 595
 596 sub new_redir ($$\%;$) {
 597   my ($dom, $gen, $r, $n) = @_;
 598   my $db = open_db;
 599   my @l;
 600
 601   $n //= 1;
 602   check_fixup_redir $r;
 603   Odin::xact {
 604     clear_redir_reservations $db;
 605     while (@l < $n) {
 606       my $l = Odin::gen_redir_name $db, $gen;
 607       insert_record $db, "odin_mailredir",
 608         lpart => $l, dom => $dom, st => 'live',
 609         owner => $WHO, creator => $WHO,
 610         recip => subst_recip($l, $r->{recip} // qualify_recip $Odin::WHO),
 611         expire => $r->{expire} // -1,
 612         comment => $r->{comment} // "";
 613       push @l, $l;
 614     }
 615     check_redir_limits $db;
 616   } $db;
 617   return @l;
 618 }
 619
 620 sub reserve_redir ($$$) {
 621   my ($dom, $gen, $n) = @_;
 622   my $db = open_db;
 623   my @l;
 624
 625   Odin::xact {
 626     clear_redir_reservations $db;
 627     @l = ();
 628     for (my $i = 0; $i < $n; $i++) { push @l, gen_redir_name $db, $gen; }
 629     for my $l (@l) {
 630       insert_record $db, "odin_mailredir",
 631         lpart => $l, dom => $dom, owner => $WHO, creator => $WHO,
 632         st => 'reserved', expire => $NOW + $MAIL_AGEMAX_RESV;
 633     }
 634     check_redir_limits $db;
 635   } $db;
 636   return @l;
 637 }
 638
 639 sub release_all_redir ($) {
 640   my ($dom) = @_;
 641   my $db = open_db;
 642
 643   my $st = $db->prepare("DELETE FROM odin_mailredir
 644                          WHERE dom = ? AND owner = ? AND st = 'reserved'");
 645   Odin::xact {
 646     $st->execute($dom, $WHO);
 647     $st->rows or Odin::fail "no reserved addresses";
 648   } $db;
 649 }
 650
 651 sub release_redir ($@) {
 652   my ($dom, @l) = @_;
 653   my $db = open_db;
 654
 655   my $st = $db->prepare("DELETE FROM odin_mailredir
 656                          WHERE lpart = ? AND dom = ? AND
 657                                owner = ? AND st = 'reserved'");
 658   Odin::xact {
 659     clear_redir_reservations $db;
 660     for my $l (@l) {
 661       $st->execute($l, $dom, $WHO);
 662       Odin::fail "local part `$l' not reserved" unless $st->rows;
 663     }
 664   } $db;
 665 }
 666
 667 sub disable_redir ($$) {
 668   my ($dom, @l) = @_;
 669   my $db = open_db;
 670
 671   my $st = $db->prepare("UPDATE odin_mailredir
 672                          SET st = 'dormant', expire = -1
 673                          WHERE lpart = ? AND dom = ? AND
 674                                owner = ? AND st = 'live'");
 675   Odin::xact {
 676     clear_redir_reservations $db;
 677     for my $l (@ARGV) {
 678       $st->execute($l, $dom, $WHO);
 679       Odin::fail "local part `$l' not live" unless $st->rows;
 680     }
 681   } $db;
 682 }
 683
 684 sub modify_redir ($\%@) {
 685   my ($dom, $r, @l) = @_;
 686   my $db = open_db;
 687
 688   check_fixup_redir $r;
 689   Odin::xact {
 690     clear_redir_reservations $db;
 691     for my $l (@l) {
 692       my %r = %$r;
 693       my ($recip, $st) = $db->selectrow_array
 694         ("SELECT recip, st FROM odin_mailredir
 695           WHERE lpart = ? AND dom = ? AND owner = ?", undef,
 696          $l, $dom, $WHO);
 697       if (!defined $recip) { Odin::fail "unknown local part `$l'"; }
 698       elsif ($recip eq "" || defined $r{recip})
 699         { $r{recip} = subst_recip $l, $r{recip} // qualify_recip $WHO; }
 700       if ($st ne "live") { $r{st} = "live"; $r{expire} //= -1; }
 701       my @var = ();
 702       my @val = ();
 703       for my $v (keys %r) {
 704         push @var, $v;
 705         push @val, $r{$v};
 706       }
 707       @var or fail "nothing to change";
 708       $db->do("UPDATE odin_mailredir SET " .
 709               join(", ", map { "$_ = ?" } @var) . " " .
 710               "WHERE lpart = ? AND dom = ?", undef,
 711               @val, $l, $dom);
 712     }
 713   } $db;
 714 }
 715
 716 ###--------------------------------------------------------------------------
 717 ### Simple option parser.
 718
 719 package Odin::OptParse;
 720
 721 sub new {
 722   my ($cls, @args) = @_;
 723   return bless {
 724     cur => "",
 725     args => \@args,
 726     opt => undef,
 727     ok => 1
 728   }, $cls;
 729 }
 730
 731 sub get {
 732   my ($me) = @_;
 733   if (!length $me->{cur}) {
 734     my $args = $me->{args};
 735     if (!@$args) { return undef; }
 736     elsif ($args->[0] =~ /^[^-]|^-$/) { return undef; }
 737     elsif ($args->[0] eq "--") { shift @$args; return undef; }
 738     $me->{cur} = substr shift @$args, 1;
 739   }
 740   my $o = $me->{opt} = substr $me->{cur}, 0, 1;
 741   $me->{cur} = substr $me->{cur}, 1;
 742   return $o;
 743 }
 744
 745 sub arg {
 746   my ($me) = @_;
 747   my $a;
 748   if (length $me->{cur}) { $a = $me->{cur}; $me->{cur} = ""; }
 749   elsif (@{$me->{args}}) { $a = shift @{$me->{args}}; }
 750   else { $a = undef; $me->err("option `-$me->{opt}' requires an argument"); }
 751   return $a;
 752 }
 753
 754 sub intarg {
 755   my ($me, $what, $min, $max) = @_;
 756   $what //= "option `-$me->{opt}'";
 757   defined (my $a = $me->arg) or return undef;
 758   if ($a !~ /^[-+]?\d+$/ ||
 759       (defined $min && $a < $min) ||
 760       (defined $max && $a > $max)) {
 761     $me->err("invalid value `$a' for $what");
 762     $a = undef;
 763   }
 764   return $a;
 765 }
 766
 767 sub rest { return @{$_[0]->{args}}; }
 768 sub ok { return $_[0]->{ok}; }
 769 sub bad { $_[0]->{ok} = 0; }
 770 sub err { $_[0]->bad; print STDERR "$PROG: $_[1]\n"; }
 771 sub unk { $_[0]->err("unknown option `-$_[0]->{opt}'"); }
 772
 773 ###--------------------------------------------------------------------------
 774 ### Parameter objects.
 775
 776 package Odin::Param;
 777 sub dflt { return $_[0]->{dflt}; }
 778
 779 package Odin::Param::Int;
 780 @ISA = qw(Odin::Param);
 781
 782 sub new {
 783   my ($cls, $dflt, $min, $max) = @_;
 784   return bless { dflt => $dflt, min => $min, max => $max }, $cls;
 785 }
 786
 787 sub check {
 788   my ($me, $v) = @_;
 789   return undef unless
 790     $v =~ /^[-+]?\d+$/ &&
 791     (!defined $me->{min} || $v >= $me->{min}) &&
 792     (!defined $me->{max} || $v <= $me->{max});
 793   return $v + 0;
 794 }
 795
 796 package Odin::Param::Str;
 797 @ISA = qw(Odin::Param);
 798
 799 sub new {
 800   my ($cls, $dflt, $rx, $minlen, $maxlen) = @_;
 801   return bless {
 802     dflt => $dflt,
 803     rx => defined $rx ? qr/$rx/ : qr//,
 804     minlen => $minlen,
 805     maxlen => $maxlen
 806   }, $cls;
 807 }
 808
 809 sub check {
 810   my ($me, $v) = @_;
 811   return undef unless
 812     $v =~ /$me->{rx}/ &&
 813     (!defined $me->{minlen} || length $v >= $me->{minlen}) &&
 814     (!defined $me->{maxlen} || length $v <= $me->{maxlen});
 815   return $v . "";
 816 }
 817
 818 ###--------------------------------------------------------------------------
 819 ### Name generators.
 820
 821 package Odin::Gen;
 822
 823 use Scalar::Util qw(blessed);
 824
 825 sub random {
 826   my ($me, $lim) = @_;
 827
 828   defined $me->{rand}
 829     or open $me->{rand}, "/dev/urandom"
 830     or die "open random: $!";
 831
 832   my $nb = 1; my $max = 255;
 833   while ($lim > $max) { $nb++; $max = ($max << 8) | 255; }
 834   my $thresh = $max - ($max%$lim);
 835
 836   for (;;) {
 837     sysread $me->{rand}, my $b, $nb
 838       or die "read random: $!";
 839     my $r = 0;
 840     for (my $i = 0; $i < $nb; $i++)
 841       { $r = ($r << 255) | ord substr $b, $i, 1; }
 842     return $r%$lim if $r < $thresh;
 843   }
 844 }
 845
 846 sub new {
 847   my ($cls, $dom, $param) = @_;
 848   my $pkg = \%::;
 849   for my $p (split /::/, $cls) { $pkg = \%{$pkg->{"${p}::"}}; }
 850
 851   my $label = ${$pkg->{LABEL}};
 852   my $plist = \@{$pkg->{PARAM}};
 853   my $gtmpl = $GENPARAM{$label};
 854   my $dtmpl = $MAILDOM_POLICY{$dom}{$label};
 855   my %pp = ();
 856
 857   for my $p (@$plist) {
 858     $pp->{$p} = 1;
 859     my $t = $dtmpl->{$p} // $gtmpl->{$p};
 860     if (blessed $t && $t->isa("Odin::Param")) {
 861       if (!exists $param->{$p}) { $param->{$p} = $t->dflt; }
 862       else {
 863         my $v = $t->check($param->{$p});
 864         Odin::fail "bad value `$param->{$p}' for $label parameter `$p'"
 865           unless defined $v;
 866         $param->{$p} = $v;
 867       }
 868     } else {
 869       if (exists $param->{$p})
 870         { Odin::fail "not allowed to set $label parameter `$p'"; }
 871       else
 872         { $param->{$p} = $t; }
 873     }
 874   }
 875   for my $p (keys %$param) {
 876     if (!$pp->{$p}) { Odin::fail "unknown $label parameter `$p'"; }
 877   }
 878
 879   my $me = bless { %$param }, $cls;
 880   $me->{rand} = undef;
 881   return $me;
 882 }
 883
 884 package Odin::Gen::Chars;
 885 @ISA = qw(Odin::Gen);
 886
 887 $LABEL = 'chars';
 888 @PARAM = qw(ichars mchars echars len);
 889
 890 $GENMAP{chars} = "Odin::Gen::Chars";
 891 $GENPARAM{chars} = {
 892   ichars => Odin::Param::Str->new($ALPHA, $SAFECH, 1, 255),
 893   mchars => Odin::Param::Str->new($ALPHA . $NUM, $SAFECH, 2, 255),
 894   echars => Odin::Param::Str->new($ALPHA . $NUM, $SAFECH, 2, 255),
 895   len => Odin::Param::Int->new(6, 2, 16)
 896 };
 897
 898 sub _pick {
 899   my ($me, $chars) = @_;
 900   return substr $chars, $me->random(length $chars), 1;
 901 }
 902
 903 sub gen {
 904   my ($me) = @_;
 905
 906   my $n = $me->{len};
 907
 908   my $s = "";
 909   if ($n) { $s .= $me->_pick($me->{ichars}); $n--; }
 910   while ($n > 1) { $s .= $me->_pick($me->{mchars}); $n--; }
 911   if ($n) { $s .= $me->_pick($me->{echars}); $n--; }
 912   if ($n) { die "INTERNAL can't count"; }
 913   return $s;
 914 }
 915
 916 package Odin::Gen::Words;
 917 @ISA = qw(Odin::Gen);
 918
 919 $LABEL = 'words';
 920 @PARAM = qw(wordlist delim nwords);
 921
 922 $GENMAP{words} = "Odin::Gen::Words";
 923 $GENPARAM{words} = {
 924   wordlist => "etc/words",
 925   delim => Odin::Param::Str->new(".", qr/^[-_.+]*$/, 1, 1),
 926   nwords => Odin::Param::Int->new(3, 2, 16)
 927 };
 928
 929 sub gen {
 930   my ($me) = @_;
 931   my @w = ();
 932
 933   if (!exists $me->{words}) {
 934     open my $f, $me->{wordlist} or die "open wordlist: $!";
 935     $me->{words} = [grep chomp, <$f>];
 936     close $f or die "close/read wordlist: $!";
 937   }
 938
 939   for (my $i = 0; $i < $me->{nwords}; $i++)
 940     { push @w, $me->{words}[$me->random(scalar @{$me->{words}})]; }
 941   return join $me->{delim}, @w;
 942 }
 943
 944 ###--------------------------------------------------------------------------
 945 ### Final configuration.
 946
 947 package Odin;
 948
 949 require "config.pl";
 950
 951 ($SCHEME, $DOMAIN, $BASEPATH) = $BASEURL =~ m!^([^:]+)://([^/]+)(/.*)$!;
 952 merge_hash %COOKIE_DEFAULTS, -domain => $DOMAIN, -path => $BASEPATH;
 953 merge_hash %COOKIE_DEFAULTS, -secure => undef if $SCHEME eq "https";
 954
 955 $MAIL_QUALDOM //= $MAIL_DEFDOMAIN;
 956
 957 $SHORTURL = "$BASEURL$SHORTURL_PATH";
 958 $PASTEBIN = "$BASEURL$PASTEBIN_PATH";
 959
 960 ###----- That's all, folks --------------------------------------------------
 961
 962 1;