mdw@git.distorted.org.uk Git - odin-cgi/blob - lib/Odin.pm

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