X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/odin-cgi/blobdiff_plain/cc346ee1adf852ba0f4322bc04a78ec64206d37a..c68a55498f50946e8fca9361386e11769c63aa4e:/lib/Odin.pm diff --git a/lib/Odin.pm b/lib/Odin.pm index e373dcc..154fae0 100644 --- a/lib/Odin.pm +++ b/lib/Odin.pm @@ -3,6 +3,7 @@ package Odin; use DBI; +use Date::Parse; use Digest::SHA qw(sha256_hex); use MIME::Base64; use POSIX; @@ -41,14 +42,25 @@ our %COOKIE_DEFAULTS = ( -max_age => 3600 ); -require "config.pl"; +our $ALPHA = "abcdefghijklmnopqrstuvwxyz"; +our $NUM = "0123456789"; +our $SAFECH = qr/^[-\w_.+]*$/; -our ($SCHEME, $DOMAIN, $BASEPATH) = $BASEURL =~ m!^([^:]+)://([^/]+)(/.*)$!; -merge_hash %COOKIE_DEFAULTS, -domain => $DOMAIN, -path => $BASEPATH; -merge_hash %COOKIE_DEFAULTS, -secure => undef if $SCHEME eq "https"; +our %GENPARAM = (); +our %GENMAP = (); +our %MAILDOM_POLICY = (); +our $MAIL_QUALDOM; + +our @MAIL_DEFGEN = "chars"; +our $MAIL_MAXGENTRY = 32; + +our $MAIL_DEFDOMAIN = "odin.gg"; +our $MAIL_ADDRMAX_LIVE = 16384; +our $MAIL_ADDRMAX_RESV = 32; +our $MAIL_AGEMAX_RESV = 3600; -our $SHORTURL = "$BASEURL$SHORTURL_PATH"; -our $PASTEBIN = "$BASEURL$PASTEBIN_PATH"; +our ($SCHEME, $DOMAIN, $BASEPATH); +our ($SHORTURL, $PASTEBIN); ###-------------------------------------------------------------------------- ### Miscellaneous utilities. @@ -88,6 +100,21 @@ sub nice_name ($) { return lc $s; } +my %TIMEUNIT = ( + "" => 1, + "s" => 1, "m" => 60, "h" => 3600, + "d" => 86400, "w" => 604800 +); +sub parse_time ($) { + my ($date) = @_; + return undef unless defined $date; + if ($date =~ /^\+\s*(\d+)\s*([smhdw]?)\s*$/) + { return $NOW + $1 * $TIMEUNIT{$2}; } + my $t = str2time($date); + defined $t or Odin::fail "invalid time `$date'"; + return $t; +} + sub print_columns (@) { my @col = reverse @_; my @fmt = (); @@ -152,6 +179,18 @@ sub xact (&$) { die $exc; } +sub insert_record ($$%) { + my ($db, $table, %fields) = @_; + my @var = (); + my @val = (); + + for my $v (keys %fields) { + push @var, $v; + push @val, $fields{$v}; + } + $db->do("INSERT INTO $table (" . join(", ", @var) . ") + VALUES (" . join(", ", map { "?" } @var) . ")", undef, @val); +} ###-------------------------------------------------------------------------- ### Sequence numbers and tagging. @@ -284,9 +323,8 @@ sub new_shorturl ($) { undef, $WHOCMP, $url); unless (defined $tag) { $tag = encode_tag(next_seq($db, "odin_shorturl_seq")); - $db->do("INSERT INTO odin_shorturl (tag, stamp, owner, url) - VALUES (?, ?, ?, ?)", undef, - $tag, $NOW, $WHO, $url); + insert_record $db, "odin_shorturl", + tag => $tag, stamp => $NOW, owner => $WHO, url => $url; } } $db; return $tag; @@ -348,10 +386,9 @@ sub new_pastebin (\%) { merge_hash %$new, %PASTEBIN_DEFAULTS; xact { $tag = encode_tag next_seq $db, "odin_pastebin_seq"; - $db->do("INSERT INTO odin_pastebin - (tag, stamp, edithash, owner, $PASTEBIN_PROPCOLS) - VALUES (?, ?, ?, ?, $PASTEBIN_PROPPLACES)", undef, - $tag, $NOW, $hash, $WHO, @{$new}{@PASTEBIN_PROPS}); + insert_record $db, "odin_pastebin", + tag => $tag, stamp => $NOW, edithash => $hash, owner => $WHO, + %$new; } $db; return $tag, $editkey; } @@ -455,6 +492,207 @@ sub tidy_pastebin_content ($) { return $content; } +###-------------------------------------------------------------------------- +### Mail redirection utilities. + +sub redir_query ($$$;$@) { + my ($db, $dom, $owner, $cond, @args) = @_; + return @{$db->selectall_arrayref + ("SELECT lpart, expire, recip, comment + FROM odin_mailredir WHERE dom = ? AND owner = ?" . + (defined $cond ? " AND $cond" : "") . " " . + "ORDER BY expire, lpart", undef, $dom, $owner, @args)}; +} + +sub clear_redir_reservations ($) { + my ($db) = @_; + $db->do("DELETE FROM odin_mailredir WHERE + st = 'reserved' AND expire < ?", undef, + $NOW); + $db->do("UPDATE odin_mailredir SET st = 'dormant', expire = -1 + WHERE st = 'live' AND expire <> -1 AND expire < ?", undef, $NOW); +} + +sub check_redir_limits ($) { + my ($db) = @_; + my %h = map { $_->[0] => $_->[1] } + @{ $db->selectall_arrayref("SELECT st, COUNT(*) FROM odin_mailredir + WHERE owner = ? GROUP BY st", undef, + $Odin::WHO) }; + for my $st (qw(live dormant reserved)) { $h{$st} //= 0; } + $h{live} + $h{dormant} + $h{reserved} <= $MAIL_ADDRMAX_LIVE or + Odin::fail "too many addresses claimed (see your sysadmin)"; + $h{reserved} <= $MAIL_ADDRMAX_RESV or + Odin::fail "too many addresses reserved (time to release some)"; +} + +sub gencls ($) { + my ($g) = @_; + return $GENMAP{$g} // die "configuration error: no generator class `$g'"; +} + +sub default_generator_class ($) { + my ($dom) = @_; + + my $g = $MAILDOM_POLICY{$dom}{gen}[0] // $MAIL_DEFGEN[0]; + return gencls $g; +} + +sub get_generator_class ($$) { + my ($dom, $g) = @_; + + grep { $_ eq $g } @{$MAILDOM_POLICY{$dom}{gen} // \@MAIL_DEFGEN} + or fail "domain `$dom' doesn't allow generator `$g'"; + return gencls $g; +} + +sub gen_redir_name ($$) { + my ($db, $gen) = @_; + + for (my $try = 0; $try < $MAIL_MAXGENTRY; $try++) { + my $l = lc $gen->gen; + return $l + unless $db->selectrow_arrayref + ("SELECT 1 FROM odin_mailredir WHERE lpart = ? AND dom = ?", + undef, $l, $DOMAIN); + } + Odin::fail "failed to find unique local part"; +} + +sub qualify_recip ($) { + my ($r) = @_; + + return $r =~ /\@/ || !defined $MAIL_QUALDOM ? $r : "$r\@$MAIL_QUALDOM"; +} + +sub check_fixup_redir ($) { + my ($r) = @_; + + if (exists $r->{recip}) { + $r->{recip} =~ /^[!-~]+$/ or fail "invalid recipient name `$r->{recip}'"; + $r->{recip} = qualify_recip $r->{recip}; + } +} + +sub new_redir ($$\%;$) { + my ($dom, $gen, $r, $n) = @_; + my $db = open_db; + my @l; + + $n //= 1; + check_fixup_redir $r; + Odin::xact { + clear_redir_reservations $db; + while (@l < $n) { + my $l = Odin::gen_redir_name $db, $gen; + insert_record $db, "odin_mailredir", + lpart => $l, dom => $dom, st => 'live', + owner => $WHO, creator => $WHO, + recip => $r->{recip} // qualify_recip $Odin::WHO, + expire => $r->{expire} // -1, + comment => $r->{comment} // ""; + push @l, $l; + } + check_redir_limits $db; + } $db; + return @l; +} + +sub reserve_redir ($$$) { + my ($dom, $gen, $n) = @_; + my $db = open_db; + my @l; + + Odin::xact { + clear_redir_reservations $db; + @l = (); + for (my $i = 0; $i < $n; $i++) { push @l, gen_redir_name $db, $gen; } + for my $l (@l) { + insert_record $db, "odin_mailredir", + lpart => $l, dom => $dom, owner => $WHO, + st => 'reserved', expire => $NOW + $MAIL_AGEMAX_RESV; + } + check_redir_limits $db; + } $db; + return @l; +} + +sub release_all_redir ($) { + my ($dom) = @_; + my $db = open_db; + + my $st = $db->prepare("DELETE FROM odin_mailredir + WHERE dom = ? AND owner = ? AND st = 'reserved'"); + Odin::xact { + $st->execute($dom, $WHO); + $st->rows or Odin::fail "no reserved addresses"; + } $db; +} + +sub release_redir ($@) { + my ($dom, @l) = @_; + my $db = open_db; + + my $st = $db->prepare("DELETE FROM odin_mailredir + WHERE lpart = ? AND dom = ? AND + owner = ? AND st = 'reserved'"); + Odin::xact { + clear_redir_reservations $db; + for my $l (@l) { + $st->execute($l, $dom, $WHO); + Odin::fail "local part `$l' not reserved" unless $st->rows; + } + } $db; +} + +sub disable_redir ($$) { + my ($dom, @l) = @_; + my $db = open_db; + + my $st = $db->prepare("UPDATE odin_mailredir + SET st = 'dormant', expire = -1 + WHERE lpart = ? AND dom = ? AND + owner = ? AND st = 'live'"); + Odin::xact { + clear_redir_reservations $db; + for my $l (@ARGV) { + $st->execute($l, $dom, $WHO); + Odin::fail "local part `$l' not live" unless $st->rows; + } + } $db; +} + +sub modify_redir ($\%@) { + my ($dom, $r, @l) = @_; + my $db = open_db; + + check_fixup_redir $r; + Odin::xact { + clear_redir_reservations $db; + for my $l (@l) { + my %r = %$r; + my ($recip, $st) = $db->selectrow_array + ("SELECT recip, st FROM odin_mailredir + WHERE lpart = ? AND dom = ? AND owner = ?", undef, + $l, $dom, $WHO); + if (!defined $recip) { Odin::fail "unknown local part `$l'"; } + elsif ($recip eq "") { $r{recip} //= qualify_recip $WHO; } + if ($st ne "live") { $r{st} = "live"; $r{expire} //= -1; } + my @var = (); + my @val = (); + for my $v (keys %r) { + push @var, $v; + push @val, $r{$v}; + } + @var or fail "nothing to change"; + $db->do("UPDATE odin_mailredir SET " . + join(", ", map { "$_ = ?" } @var) . " " . + "WHERE lpart = ? AND dom = ?", undef, + @val, $l, $dom); + } + } $db; +} + ###-------------------------------------------------------------------------- ### Simple option parser. @@ -493,12 +731,212 @@ sub arg { return $a; } +sub intarg { + my ($me, $what, $min, $max) = @_; + $what //= "option `-$me->{opt}'"; + defined (my $a = $me->arg) or return undef; + if ($a !~ /^[-+]?\d+$/ || + (defined $min && $a < $min) || + (defined $max && $a > $max)) { + $me->err("invalid value `$a' for $what"); + $a = undef; + } + return $a; +} + sub rest { return @{$_[0]->{args}}; } sub ok { return $_[0]->{ok}; } sub bad { $_[0]->{ok} = 0; } sub err { $_[0]->bad; print STDERR "$PROG: $_[1]\n"; } sub unk { $_[0]->err("unknown option `-$_[0]->{opt}'"); } +###-------------------------------------------------------------------------- +### Parameter objects. + +package Odin::Param; +sub dflt { return $_[0]->{dflt}; } + +package Odin::Param::Int; +@ISA = qw(Odin::Param); + +sub new { + my ($cls, $dflt, $min, $max) = @_; + return bless { dflt => $dflt, min => $min, max => $max }, $cls; +} + +sub check { + my ($me, $v) = @_; + return undef unless + $v =~ /^[-+]?\d+$/ && + (!defined $me->{min} || $v >= $me->{min}) && + (!defined $me->{max} || $v <= $me->{max}); + return $v + 0; +} + +package Odin::Param::Str; +@ISA = qw(Odin::Param); + +sub new { + my ($cls, $dflt, $rx, $minlen, $maxlen) = @_; + return bless { + dflt => $dflt, + rx => defined $rx ? qr/$rx/ : qr//, + minlen => $minlen, + maxlen => $maxlen + }, $cls; +} + +sub check { + my ($me, $v) = @_; + return undef unless + $v =~ /$me->{rx}/ && + (!defined $me->{minlen} || length $v >= $me->{minlen}) && + (!defined $me->{maxlen} || length $v <= $me->{maxlen}); + return $v . ""; +} + +###-------------------------------------------------------------------------- +### Name generators. + +package Odin::Gen; + +use Scalar::Util qw(blessed); + +sub random { + my ($me, $lim) = @_; + + defined $me->{rand} + or open $me->{rand}, "/dev/urandom" + or die "open random: $!"; + + my $nb = 1; my $max = 255; + while ($lim > $max) { $nb++; $max = ($max << 8) | 255; } + my $thresh = $max - ($max%$lim); + + for (;;) { + sysread $me->{rand}, my $b, $nb + or die "read random: $!"; + my $r = 0; + for (my $i = 0; $i < $nb; $i++) + { $r = ($r << 255) | ord substr $b, $i, 1; } + return $r%$lim if $r < $thresh; + } +} + +sub new { + my ($cls, $dom, $param) = @_; + my $pkg = \%::; + for my $p (split /::/, $cls) { $pkg = \%{$pkg->{"${p}::"}}; } + + my $label = ${$pkg->{LABEL}}; + my $plist = \@{$pkg->{PARAM}}; + my $gtmpl = $GENPARAM{$label}; + my $dtmpl = $MAILDOM_POLICY{$dom}{$label}; + my %pp = (); + + for my $p (@$plist) { + $pp->{$p} = 1; + my $t = $dtmpl->{$p} // $gtmpl->{$p}; + if (blessed $t && $t->isa("Odin::Param")) { + if (!exists $param->{$p}) { $param->{$p} = $t->dflt; } + else { + my $v = $t->check($param->{$p}); + Odin::fail "bad value `$param->{$p}' for $label parameter `$p'" + unless defined $v; + $param->{$p} = $v; + } + } else { + if (exists $param->{$p}) + { Odin::fail "not allowed to set $label parameter `$p'"; } + else + { $param->{$p} = $t; } + } + } + for my $p (keys %$param) { + if (!$pp->{$p}) { Odin::fail "unknown $label parameter `$p'"; } + } + + my $me = bless { %$param }, $cls; + $me->{rand} = undef; + return $me; +} + +package Odin::Gen::Chars; +@ISA = qw(Odin::Gen); + +$LABEL = 'chars'; +@PARAM = qw(ichars mchars echars len); + +$GENMAP{chars} = "Odin::Gen::Chars"; +$GENPARAM{chars} = { + ichars => Odin::Param::Str->new($ALPHA, $SAFECH, 1, 255), + mchars => Odin::Param::Str->new($ALPHA . $NUM, $SAFECH, 2, 255), + echars => Odin::Param::Str->new($ALPHA . $NUM, $SAFECH, 2, 255), + len => Odin::Param::Int->new(6, 2, 16) +}; + +sub _pick { + my ($me, $chars) = @_; + return substr $chars, $me->random(length $chars), 1; +} + +sub gen { + my ($me) = @_; + + my $n = $me->{len}; + + my $s = ""; + if ($n) { $s .= $me->_pick($me->{ichars}); $n--; } + while ($n > 1) { $s .= $me->_pick($me->{mchars}); $n--; } + if ($n) { $s .= $me->_pick($me->{echars}); $n--; } + if ($n) { die "INTERNAL can't count"; } + return $s; +} + +package Odin::Gen::Words; +@ISA = qw(Odin::Gen); + +$LABEL = 'words'; +@PARAM = qw(wordlist delim nwords); + +$GENMAP{words} = "Odin::Gen::Words"; +$GENPARAM{words} = { + wordlist => "etc/words", + delim => Odin::Param::Str->new(".", qr/^[-_.+]*$/, 1, 1), + nwords => Odin::Param::Int->new(3, 2, 16) +}; + +sub gen { + my ($me) = @_; + my @w = (); + + if (!exists $me->{words}) { + open my $f, $me->{wordlist} or die "open wordlist: $!"; + $me->{words} = [grep chomp, <$f>]; + close $f or die "close/read wordlist: $!"; + } + + for (my $i = 0; $i < $me->{nwords}; $i++) + { push @w, $me->{words}[$me->random(scalar @{$me->{words}})]; } + return join $me->{delim}, @w; +} + +###-------------------------------------------------------------------------- +### Final configuration. + +package Odin; + +require "config.pl"; + +($SCHEME, $DOMAIN, $BASEPATH) = $BASEURL =~ m!^([^:]+)://([^/]+)(/.*)$!; +merge_hash %COOKIE_DEFAULTS, -domain => $DOMAIN, -path => $BASEPATH; +merge_hash %COOKIE_DEFAULTS, -secure => undef if $SCHEME eq "https"; + +$MAIL_QUALDOM //= $MAIL_DEFDOMAIN; + +$SHORTURL = "$BASEURL$SHORTURL_PATH"; +$PASTEBIN = "$BASEURL$PASTEBIN_PATH"; + ###----- That's all, folks -------------------------------------------------- 1;